unmaintained: New home for misfit Factor vocabularies.

[factor-unmaintained.git] / alien / marshall / structs / structs.factor

diff --git a/alien/marshall/structs/structs.factor b/alien/marshall/structs/structs.factor
new file mode 100644 (file)
index 0000000..07ebb6a
--- /dev/null
+++ b/alien/marshall/structs/structs.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.marshall arrays assocs
+classes.tuple combinators destructors generalizations generic
+kernel libc locals parser quotations sequences slots words
+alien.structs lexer vocabs.parser fry effects alien.data ;
+IN: alien.marshall.structs
+
+<PRIVATE
+: define-struct-accessor ( class name quot -- )
+    [ "accessors" create create-method dup make-inline ] dip define ;
+
+: define-struct-getter ( class name word type -- )
+    [ ">>" append \ underlying>> ] 2dip
+    struct-field-unmarshaller \ call 4array >quotation
+    define-struct-accessor ;
+
+: define-struct-setter ( class name word type -- )
+    [ "<<" append ] 2dip
+    marshaller [ underlying>> ] \ bi* roll 4array >quotation
+    define-struct-accessor ;
+
+: define-struct-accessors ( class name type reader writer -- )
+    [ dup define-protocol-slot ] 3dip
+    [ drop swap define-struct-getter ]
+    [ nip swap define-struct-setter ] 5 nbi ;
+
+: define-struct-constructor ( class -- )
+    {
+        [ name>> "<" prepend ">" append create-word-in ]
+        [ '[ _ new ] ]
+        [ name>> '[ _ malloc-struct >>underlying ] append ]
+        [ name>> 1array ]
+    } cleave { } swap <effect> define-declared ;
+PRIVATE>
+
+:: define-struct-tuple ( name -- )
+    name create-word-in :> class
+    class struct-wrapper { } define-tuple-class
+    class define-struct-constructor
+    name c-type fields>> [
+        class swap
+        {
+            [ name>> H{ { CHAR: space CHAR: - } } substitute ]
+            [ type>> ] [ reader>> ] [ writer>> ]
+        } cleave define-struct-accessors
+    ] each ;
+
+: define-marshalled-struct ( name vocab fields -- )
+    [ define-struct ] [ 2drop define-struct-tuple ] 3bi ;