From 7276fe44d70d9636e2c355fc8e8a6d01bb30383e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 21:04:19 -0500 Subject: [PATCH] refactor functors so that new functor syntax words can be added outside of functors vocab, and move STRUCT: functor syntax to classes.struct to break a circular dependency --- basis/classes/struct/struct.factor | 38 +++++++++-- basis/functors/backend/backend.factor | 33 +++++++++ basis/functors/functors.factor | 96 +++++---------------------- 3 files changed, 84 insertions(+), 83 deletions(-) create mode 100644 basis/functors/backend/backend.factor diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 88c207f418..45ad3c62bb 100644 --- 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 ] 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 index 0000000000..dd3d891f7b --- /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 dcfd140e92..62654ece79 100644 --- 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 ) , ; [ 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 ] 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