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 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 effect expected-effect ;
  39
  40 : check-method-effect ( effect -- )
  41     last-word generic-effect 2dup method-effect=
  42     [ 2drop ] [ bad-method-effect ] if ;
  43
  44 : parse-method-definition ( -- quot )
  45     scan-datum {
  46         { \ ( [ ")" parse-effect check-method-effect parse-definition ] }
  47         { \ ; [ [ ] ] }
  48         [ ?execute-parsing \ ; parse-until append >quotation ]
  49     } case ;
  50
  51 : (M:) ( -- method def )
  52     [
  53         scan-new-method [ parse-method-definition ] with-method-definition
  54     ] with-definition ;