Merge branch 'master' of git://factorcode.org/git/factor

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
+USING: accessors tools.test alien.complex classes.struct kernel
-namespaces math ;
+alien.c-types alien.syntax namespaces math ;
 IN: alien.complex.tests
 
-C-STRUCT: complex-holder
+STRUCT: complex-holder
-    { "complex-float" "z" } ;
+    { z complex-float } ;
 
 : <complex-holder> ( z -- alien )
-    "complex-holder" <c-object>
+    complex-holder <struct-boa> ;
-    [ set-complex-holder-z ] keep ;
 
 [ ] [
     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
+[ number ] [ "complex-double" c-type-boxed-class ] unit-test

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
+USING: accessors alien.structs alien.c-types classes.struct math
-arrays kernel functors vocabs.parser namespaces accessors
+math.functions sequences arrays kernel functors vocabs.parser
-quotations ;
+namespaces quotations ;
 IN: alien.complex.functor
 
 FUNCTOR: define-complex-type ( N T -- )
 
-T-real DEFINES ${T}-real
+T-class DEFINES-CLASS ${T}
-T-imaginary DEFINES ${T}-imaginary
-set-T-real DEFINES set-${T}-real
-set-T-imaginary DEFINES set-${T}-imaginary
 
 <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-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
 
-T current-vocab
+T-class c-type
-{ { N "real" } { N "imaginary" } }
-define-struct
-
-T c-type
 <T> 1quotation >>unboxer-quot
 *T 1quotation >>boxer-quot
 number >>boxed-class

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

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
+combinators combinators.short-circuit combinators.smart
-generalizations generic.parser kernel kernel.private lexer
+functors.backend fry generalizations generic.parser kernel
-libc macros make math math.order parser quotations sequences
+kernel.private lexer libc locals macros make math math.order parser
-slots slots.private struct-arrays vectors words
+quotations sequences slots slots.private struct-arrays vectors
-compiler.tree.propagation.transforms ;
+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

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 ;
+

basis/functors/functors-tests.factor

@@ -1,5 +1,5 @@
-USING: functors tools.test math words kernel multiline parser
+USING: classes.struct functors tools.test math words kernel
-io.streams.string generic ;
+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 }
+    { 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
+

basis/functors/functors.factor

@@ -2,8 +2,8 @@
 ! 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
+combinators effects.parser fry functors.backend generic
-generic.standard interpolate io.streams.string kernel lexer
+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
@@ -12,14 +12,6 @@ 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 ;
@@ -58,7 +50,7 @@ M: object (fake-quotations>) , ;
     [ parse-definition* ] dip
     parsed ;
 
-SYNTAX: `TUPLE:
+FUNCTOR-SYNTAX: TUPLE:
     scan-param parsed
     scan {
         { ";" [ tuple parsed f parsed ] }
@@ -71,60 +63,60 @@ SYNTAX: `TUPLE:
     } 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
@@ -144,23 +136,6 @@ DEFER: ;FUNCTOR delimiter
 
 <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 ;