! 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 } ;
: <complex-holder> ( z -- alien )
- "complex-holder" <c-object>
- [ set-complex-holder-z ] keep ;
+ complex-holder <struct-boa> ;
[ ] [
C{ 1.0 2.0 } <complex-holder> "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
! 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}
<T> DEFINES <${T}>
*T DEFINES *${T}
WHERE
+STRUCT: T-class { real N } { imaginary N } ;
+
: <T> ( z -- alien )
- >rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
+ >rect T-class <struct-boa> ;
: *T ( alien -- z )
- [ T-real ] [ T-imaginary ] bi rect> ; inline
-
-T current-vocab
-{ { N "real" } { N "imaginary" } }
-define-struct
+ T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
-T c-type
+T-class c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
number >>boxed-class
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." } ;
{ "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
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
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
--- /dev/null
+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 ;
+
-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
<<
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 }
+ { float { "float" 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 "float" }
+ { offset 16 }
+ { class object }
+ { initial f }
+ { c-type { "float" 2 } }
+ }
+ }
+] [ a-struct struct-slots ] unit-test
+
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.mixin classes.parser
classes.singleton classes.tuple classes.tuple.parser
-combinators effects.parser fry generic generic.parser
-generic.standard interpolate io.streams.string kernel lexer
+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
<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 ;
[ parse-definition* ] dip
parsed ;
-SYNTAX: `TUPLE:
+FUNCTOR-SYNTAX: TUPLE:
scan-param parsed
scan {
{ ";" [ tuple parsed f parsed ] }
} case
\ define-tuple-class parsed ;
-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
<PRIVATE
-: functor-words ( -- assoc )
- H{
- { "TUPLE:" POSTPONE: `TUPLE: }
- { "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 ;
projects / factor.git / commitdiff