From 4cc2330a2a9239d019b45db76b6143040e7473cf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 19:56:42 -0500 Subject: [PATCH 1/5] add STRUCT: support to functors --- basis/functors/functors-tests.factor | 65 +++++++++++++++++++++++++++- basis/functors/functors.factor | 39 +++++++++++++++-- 2 files changed, 99 insertions(+), 5 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a21313312b..a8d97927f8 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,5 +1,5 @@ -USING: functors tools.test math words kernel multiline parser -io.streams.string generic ; +USING: classes.struct functors tools.test math words kernel +multiline parser io.streams.string generic ; IN: functors.tests << @@ -151,3 +151,64 @@ SYMBOL: W-symbol test-redefinition +<< + +FUNCTOR: define-a-struct ( T NAME TYPE N -- ) + +T-class DEFINES-CLASS ${T} + +WHERE + +STRUCT: T-class + { NAME int } + { "x" { TYPE 4 } } + { "y" { "short" N } } + { "z" TYPE initial: 5 } + { "w" { "int" 2 } } ; + +;FUNCTOR + +"a-struct" "nemo" "char" 2 define-a-struct + +>> + +[ + { + T{ struct-slot-spec + { name "nemo" } + { offset 0 } + { class integer } + { initial 0 } + { c-type "int" } + } + T{ struct-slot-spec + { name "x" } + { offset 4 } + { class object } + { initial f } + { c-type { "char" 4 } } + } + T{ struct-slot-spec + { name "y" } + { offset 8 } + { class object } + { initial f } + { c-type { "short" 2 } } + } + T{ struct-slot-spec + { name "z" } + { offset 12 } + { class fixnum } + { initial 5 } + { c-type "char" } + } + T{ struct-slot-spec + { name "w" } + { offset 16 } + { class object } + { initial f } + { c-type { "int" 2 } } + } + } +] [ a-struct struct-slots ] unit-test + diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 5f519aeece..befe3aa174 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,11 +1,11 @@ ! 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.tuple classes.tuple.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.parser locals.types macros make namespaces parser -quotations sequences vocabs.parser words words.symbol ; +locals locals.parser locals.types macros make namespaces parser +quotations sequences slots vectors vocabs.parser words words.symbol ; IN: functors ! This is a hack @@ -58,6 +58,32 @@ M: object (fake-quotations>) , ; [ parse-definition* ] dip parsed ; +: scan-c-type* ( -- c-type/param ) + scan { + { [ dup "{" = ] [ drop \ } parse-until >array ] } + { [ dup search ] [ search ] } + [ ] + } cond ; + +:: parse-struct-slot* ( accum -- accum ) + scan-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: scan-param parsed scan { @@ -71,6 +97,12 @@ 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: scan-param parsed \ define-singleton-class parsed ; @@ -147,6 +179,7 @@ DEFER: ;FUNCTOR delimiter : functor-words ( -- assoc ) H{ { "TUPLE:" POSTPONE: `TUPLE: } + { "STRUCT:" POSTPONE: `STRUCT: } { "SINGLETON:" POSTPONE: `SINGLETON: } { "MIXIN:" POSTPONE: `MIXIN: } { "M:" POSTPONE: `M: } From 309b11213c317248b2cd440cc7a191e89bb9ec51 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 19:58:07 -0500 Subject: [PATCH 2/5] correct some classes.struct docs --- basis/classes/struct/struct-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor index 2b27672018..bcc77f1b25 100644 --- a/basis/classes/struct/struct-docs.factor +++ b/basis/classes/struct/struct-docs.factor @@ -40,13 +40,13 @@ HELP: UNION-STRUCT: HELP: define-struct-class { $values - { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" } + { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" } } { $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ; HELP: define-union-struct-class { $values - { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" } + { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" } } { $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ; @@ -55,7 +55,7 @@ HELP: malloc-struct { "class" class } { "struct" struct } } -{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ; +{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are zeroed out. The struct should be " { $link free } "d when it is no longer needed." } ; HELP: memory>struct { $values From 2e3f75fd8783fdabb27b77b2cc00c70927245958 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 20:19:47 -0500 Subject: [PATCH 3/5] fix STRUCT: functor when a slot name is the same as a non-lexical word name --- basis/functors/functors-tests.factor | 12 ++++++------ basis/functors/functors.factor | 14 ++++++++------ 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a8d97927f8..bcdc1bae74 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -161,10 +161,10 @@ WHERE STRUCT: T-class { NAME int } - { "x" { TYPE 4 } } - { "y" { "short" N } } - { "z" TYPE initial: 5 } - { "w" { "int" 2 } } ; + { x { TYPE 4 } } + { y { "short" N } } + { z TYPE initial: 5 } + { float { "float" 2 } } ; ;FUNCTOR @@ -203,11 +203,11 @@ STRUCT: T-class { c-type "char" } } T{ struct-slot-spec - { name "w" } + { name "float" } { offset 16 } { class object } { initial f } - { c-type { "int" 2 } } + { c-type { "float" 2 } } } } ] [ a-struct struct-slots ] unit-test diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index befe3aa174..dcfd140e92 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -58,15 +58,17 @@ 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 ] } - { [ dup search ] [ search ] } - [ ] - } cond ; + scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ; + +: scan-string-param ( -- name/param ) + scan >string-param ; :: parse-struct-slot* ( accum -- accum ) - scan-param :> name + scan-string-param :> name scan-c-type* :> c-type \ } parse-until :> attributes accum { From db7eb4e27a5b340594caa8adccf41691249b2a32 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 20:20:25 -0500 Subject: [PATCH 4/5] change alien.complex to use struct classes --- basis/alien/complex/complex-tests.factor | 15 +++++++------- basis/alien/complex/functor/functor.factor | 23 +++++++++------------- 2 files changed, 16 insertions(+), 22 deletions(-) diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor index 2844e505b5..7bf826d87e 100644 --- a/basis/alien/complex/complex-tests.factor +++ b/basis/alien/complex/complex-tests.factor @@ -1,22 +1,21 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test alien.complex kernel alien.c-types alien.syntax -namespaces math ; +USING: accessors tools.test alien.complex classes.struct kernel +alien.c-types alien.syntax namespaces math ; IN: alien.complex.tests -C-STRUCT: complex-holder - { "complex-float" "z" } ; +STRUCT: complex-holder + { z complex-float } ; : ( z -- alien ) - "complex-holder" - [ set-complex-holder-z ] keep ; + complex-holder ; [ ] [ C{ 1.0 2.0 } "h" set ] unit-test -[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test +[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test [ number ] [ "complex-float" c-type-boxed-class ] unit-test -[ number ] [ "complex-double" c-type-boxed-class ] unit-test \ No newline at end of file +[ number ] [ "complex-double" c-type-boxed-class ] unit-test diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 7727546c00..cb66175a29 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -1,33 +1,28 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.structs alien.c-types math math.functions sequences -arrays kernel functors vocabs.parser namespaces accessors -quotations ; +USING: accessors alien.structs alien.c-types classes.struct math +math.functions sequences arrays kernel functors vocabs.parser +namespaces quotations ; IN: alien.complex.functor FUNCTOR: define-complex-type ( N T -- ) -T-real DEFINES ${T}-real -T-imaginary DEFINES ${T}-imaginary -set-T-real DEFINES set-${T}-real -set-T-imaginary DEFINES set-${T}-imaginary +T-class DEFINES-CLASS ${T} DEFINES <${T}> *T DEFINES *${T} WHERE +STRUCT: T-class { real N } { imaginary N } ; + : ( z -- alien ) - >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline + >rect T-class ; : *T ( alien -- z ) - [ T-real ] [ T-imaginary ] bi rect> ; inline + T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline -T current-vocab -{ { N "real" } { N "imaginary" } } -define-struct - -T c-type +T-class c-type 1quotation >>unboxer-quot *T 1quotation >>boxer-quot number >>boxed-class From 7276fe44d70d9636e2c355fc8e8a6d01bb30383e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 29 Aug 2009 21:04:19 -0500 Subject: [PATCH 5/5] 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