refactor functors so that new functor syntax words can be added outside of functors...

diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index 88c207f41891ebf59becec966d8464868ced0c5d..45ad3c62bb54133a66ffab601316e692dc532fb6 100644 (file)
--- a/basis/classes/struct/struct.factor
+++ b/basis/classes/struct/struct.factor
@@ -2,11 +2,11 @@
 USING: accessors alien alien.c-types alien.structs
 alien.structs.fields arrays byte-arrays classes classes.parser
 classes.tuple classes.tuple.parser classes.tuple.private
-combinators combinators.short-circuit combinators.smart fry
-generalizations generic.parser kernel kernel.private lexer
-libc macros make math math.order parser quotations sequences
-slots slots.private struct-arrays vectors words
-compiler.tree.propagation.transforms ;
+combinators combinators.short-circuit combinators.smart
+functors.backend fry generalizations generic.parser kernel
+kernel.private lexer libc locals macros make math math.order parser
+quotations sequences slots slots.private struct-arrays vectors
+words compiler.tree.propagation.transforms ;
 FROM: slots => reader-word writer-word ;
 IN: classes.struct
 
@@ -259,6 +259,34 @@ SYNTAX: UNION-STRUCT:
 SYNTAX: S{
     scan-word dup struct-slots parse-tuple-literal-slots parsed ;
 
+: scan-c-type` ( -- c-type/param )
+    scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
+
+:: parse-struct-slot` ( accum -- accum )
+    scan-string-param :> name
+    scan-c-type` :> c-type
+    \ } parse-until :> attributes
+    accum {
+        \ struct-slot-spec new 
+            name >>name
+            c-type [ >>c-type ] [ struct-slot-class >>class ] bi
+            attributes [ dup empty? ] [ peel-off-attributes ] until drop
+        over push
+    } over push-all ;
+
+: parse-struct-slots` ( accum -- accum more? )
+    scan {
+        { ";" [ f ] }
+        { "{" [ parse-struct-slot` t ] }
+        [ invalid-struct-slot ]
+    } case ;
+
+FUNCTOR-SYNTAX: STRUCT:
+    scan-param parsed
+    [ 8 <vector> ] over push-all
+    [ parse-struct-slots` ] [ ] while
+    [ >array define-struct-class ] over push-all ;
+
 USING: vocabs vocabs.loader ;
 
 "prettyprint" vocab [ "classes.struct.prettyprint" require ] when

diff --git a/basis/functors/backend/backend.factor b/basis/functors/backend/backend.factor
new file mode 100644 (file)
index 0000000..dd3d891
--- /dev/null
+++ b/basis/functors/backend/backend.factor
@@ -0,0 +1,33 @@
+USING: accessors arrays assocs generic.standard kernel
+lexer locals.types namespaces parser quotations vocabs.parser
+words ;
+IN: functors.backend
+
+DEFER: functor-words
+\ functor-words [ H{ } clone ] initialize
+
+SYNTAX: FUNCTOR-SYNTAX:
+    scan-word
+    gensym [ parse-definition define-syntax ] keep
+    swap name>> \ functor-words get-global set-at ;
+
+: functor-words ( -- assoc )
+    \ functor-words get-global ;
+
+: scan-param ( -- obj ) scan-object literalize ;
+
+: >string-param ( string -- string/param )
+    dup search dup lexical? [ nip ] [ drop ] if ;
+
+: scan-string-param ( -- name/param )
+    scan >string-param ;
+
+: scan-c-type-param ( -- c-type/param )
+    scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
+
+: define* ( word def -- ) over set-word define ;
+
+: define-declared* ( word def effect -- ) pick set-word define-declared ;
+
+: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
+

diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index dcfd140e92da6d908dd6132d2616324eac477d32..62654ece7953dda2700b6a5c6c5c747f03837666 100644 (file)
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -1,25 +1,17 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes.mixin classes.parser
-classes.singleton classes.struct classes.tuple classes.tuple.parser
-combinators effects.parser fry generic generic.parser
-generic.standard interpolate io.streams.string kernel lexer
-locals locals.parser locals.types macros make namespaces parser
-quotations sequences slots vectors vocabs.parser words words.symbol ;
+classes.singleton classes.tuple classes.tuple.parser
+combinators effects.parser fry functors.backend generic
+generic.parser interpolate io.streams.string kernel lexer
+locals.parser locals.types macros make namespaces parser
+quotations sequences vocabs.parser words words.symbol ;
 IN: functors
 
 ! This is a hack
 
 <PRIVATE
 
-: scan-param ( -- obj ) scan-object literalize ;
-
-: define* ( word def -- ) over set-word define ;
-
-: define-declared* ( word def effect -- ) pick set-word define-declared ;
-
-: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
-
 TUPLE: fake-call-next-method ;
 
 TUPLE: fake-quotation seq ;
@@ -58,35 +50,7 @@ M: object (fake-quotations>) , ;
     [ parse-definition* ] dip
     parsed ;
 
-: >string-param ( string -- string/param )
-    dup search dup lexical? [ nip ] [ drop ] if ;
-
-: scan-c-type* ( -- c-type/param )
-    scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
-
-: scan-string-param ( -- name/param )
-    scan >string-param ;
-
-:: parse-struct-slot* ( accum -- accum )
-    scan-string-param :> name
-    scan-c-type* :> c-type
-    \ } parse-until :> attributes
-    accum {
-        \ struct-slot-spec new 
-            name >>name
-            c-type [ >>c-type ] [ struct-slot-class >>class ] bi
-            attributes [ dup empty? ] [ peel-off-attributes ] until drop
-        over push
-    } over push-all ;
-
-: parse-struct-slots* ( accum -- accum more? )
-    scan {
-        { ";" [ f ] }
-        { "{" [ parse-struct-slot* t ] }
-        [ invalid-struct-slot ]
-    } case ;
-
-SYNTAX: `TUPLE:
+FUNCTOR-SYNTAX: TUPLE:
     scan-param parsed
     scan {
         { ";" [ tuple parsed f parsed ] }
@@ -99,66 +63,60 @@ SYNTAX: `TUPLE:
     } case
     \ define-tuple-class parsed ;
 
-SYNTAX: `STRUCT:
-    scan-param parsed
-    [ 8 <vector> ] over push-all
-    [ parse-struct-slots* ] [ ] while
-    [ >array define-struct-class ] over push-all ;
-
-SYNTAX: `SINGLETON:
+FUNCTOR-SYNTAX: SINGLETON:
     scan-param parsed
     \ define-singleton-class parsed ;
 
-SYNTAX: `MIXIN:
+FUNCTOR-SYNTAX: MIXIN:
     scan-param parsed
     \ define-mixin-class parsed ;
 
-SYNTAX: `M:
+FUNCTOR-SYNTAX: M:
     scan-param parsed
     scan-param parsed
     [ create-method-in dup method-body set ] over push-all
     parse-definition*
     \ define* parsed ;
 
-SYNTAX: `C:
+FUNCTOR-SYNTAX: C:
     scan-param parsed
     scan-param parsed
     complete-effect
     [ [ [ boa ] curry ] over push-all ] dip parsed
     \ define-declared* parsed ;
 
-SYNTAX: `:
+FUNCTOR-SYNTAX: :
     scan-param parsed
     parse-declared*
     \ define-declared* parsed ;
 
-SYNTAX: `SYMBOL:
+FUNCTOR-SYNTAX: SYMBOL:
     scan-param parsed
     \ define-symbol parsed ;
 
-SYNTAX: `SYNTAX:
+FUNCTOR-SYNTAX: SYNTAX:
     scan-param parsed
     parse-definition*
     \ define-syntax parsed ;
 
-SYNTAX: `INSTANCE:
+FUNCTOR-SYNTAX: INSTANCE:
     scan-param parsed
     scan-param parsed
     \ add-mixin-instance parsed ;
 
-SYNTAX: `GENERIC:
+FUNCTOR-SYNTAX: GENERIC:
     scan-param parsed
     complete-effect parsed
     \ define-simple-generic* parsed ;
 
-SYNTAX: `MACRO:
+FUNCTOR-SYNTAX: MACRO:
     scan-param parsed
     parse-declared*
     \ define-macro parsed ;
 
-SYNTAX: `inline [ word make-inline ] over push-all ;
+FUNCTOR-SYNTAX: inline [ word make-inline ] over push-all ;
 
-SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
+FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } parsed ;
 
 : (INTERPOLATE) ( accum quot -- accum )
     [ scan interpolate-locals ] dip
@@ -178,24 +136,6 @@ DEFER: ;FUNCTOR delimiter
 
 <PRIVATE
 
-: functor-words ( -- assoc )
-    H{
-        { "TUPLE:" POSTPONE: `TUPLE: }
-        { "STRUCT:" POSTPONE: `STRUCT: }
-        { "SINGLETON:" POSTPONE: `SINGLETON: }
-        { "MIXIN:" POSTPONE: `MIXIN: }
-        { "M:" POSTPONE: `M: }
-        { "C:" POSTPONE: `C: }
-        { ":" POSTPONE: `: }
-        { "GENERIC:" POSTPONE: `GENERIC: }
-        { "INSTANCE:" POSTPONE: `INSTANCE: }
-        { "SYNTAX:" POSTPONE: `SYNTAX: }
-        { "SYMBOL:" POSTPONE: `SYMBOL: }
-        { "inline" POSTPONE: `inline }
-        { "MACRO:" POSTPONE: `MACRO: }
-        { "call-next-method" POSTPONE: `call-next-method }
-    } ;
-
 : push-functor-words ( -- )
     functor-words use-words ;