core/generic/parser/parser.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators effects.parser generic
   4 kernel namespaces parser quotations sequences words ;
   5 IN: generic.parser
   6
   7 ERROR: not-in-a-method-error ;
   8
   9 : scan-new-generic ( -- word ) scan-new dup reset-word ;
  10
  11 : (GENERIC:) ( quot -- )
  12     [ scan-new-generic ] dip call scan-effect define-generic ; inline
  13
  14 : create-method-in ( class generic -- method )
  15     create-method dup set-last-word dup save-location ;
  16
  17 : define-inline-method ( class generic quot -- )
  18     [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
  19
  20 : scan-new-method ( -- method )
  21     scan-class bootstrap-word scan-word create-method-in ;
  22
  23 SYMBOL: current-method
  24
  25 : with-method-definition ( method quot -- )
  26     over current-method set call current-method off ; inline
  27
  28 : generic-effect ( word -- effect )
  29     "method-generic" word-prop "declared-effect" word-prop ;
  30
  31 : method-effect= ( method-effect generic-effect -- ? )
  32     [ [ in>> length ] same? ]
  33     [
  34         over terminated?>>
  35         [ 2drop t ] [ [ out>> length ] same? ] if
  36     ] 2bi and ;
  37
  38 ERROR: bad-method-effect ;
  39
  40 : check-method-effect ( effect -- )
  41     last-word generic-effect method-effect= [ bad-method-effect ] unless ;
  42
  43 : ?execute-parsing ( word/number -- seq )
  44     dup parsing-word?
  45     [ V{ } clone swap execute-parsing ] [ 1array ] if ;
  46
  47 : parse-method-definition ( -- quot )
  48     scan-datum {
  49         { \ ( [ ")" parse-effect check-method-effect parse-definition ] }
  50         { \ ; [ [ ] ] }
  51         [ ?execute-parsing \ ; parse-until append >quotation ]
  52     } case ;
  53
  54 : (M:) ( -- method def )
  55     [
  56         scan-new-method [ parse-method-definition ] with-method-definition
  57     ] with-definition ;