From dc9bcc8b7304020ffe6d0790742bcbabd795b9fb Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Tue, 7 Jul 2009 15:49:39 +1200
Subject: [PATCH] alien.structs: alien.syntax: struct wrapper and marshalling
 of fields

---
 basis/alien/structs/structs.factor | 43 +++++++++++++++++++++++++++---
 basis/alien/syntax/syntax.factor   |  3 ++-
 2 files changed, 41 insertions(+), 5 deletions(-)

diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index b618e7974b..6820c7afeb 100755
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -1,9 +1,11 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs generic hashtables kernel kernel.private
-math namespaces parser sequences strings words libc fry
-alien.c-types alien.structs.fields cpu.architecture math.order
-quotations byte-arrays ;
+USING: accessors alien.c-types alien.marshall
+alien.structs.fields arrays assocs byte-arrays classes.tuple
+combinators cpu.architecture destructors fry generalizations
+generic hashtables kernel kernel.private libc locals math
+math.order namespaces parser quotations sequences slots strings
+words ;
 IN: alien.structs
 
 TUPLE: struct-type
@@ -82,3 +84,36 @@ M: struct-type stack-size
 : offset-of ( field struct -- offset )
     c-types get at fields>> 
     [ name>> = ] with find nip offset>> ;
+
+TUPLE: struct-wrapper < alien-wrapper disposed ;
+
+M: struct-wrapper dispose* underlying>> free ;
+
+: 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 
+    unmarshaller \ call 4array >quotation
+    define-struct-accessor ;
+
+: define-struct-setter ( class name word type -- )
+    [ "(>>" prepend ")" 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-tuple ( name -- )
+    name create-in :> class
+    class struct-wrapper { } define-tuple-class
+    name c-type fields>> [
+        class swap
+        {
+            [ name>> { { CHAR: space CHAR: - } } substitute ]
+            [ type>> ] [ reader>> ] [ writer>> ]
+        } cleave define-struct-accessors
+    ] each ;
diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor
index d479e6d498..113581c949 100644
--- a/basis/alien/syntax/syntax.factor
+++ b/basis/alien/syntax/syntax.factor
@@ -22,7 +22,8 @@ SYNTAX: TYPEDEF:
     scan scan typedef ;
 
 SYNTAX: C-STRUCT:
-    scan current-vocab parse-definition define-struct ;
+    scan current-vocab parse-definition [ define-struct ] 3keep
+    2drop define-struct-tuple ;
 
 SYNTAX: C-UNION:
     scan parse-definition define-union ;