From 59091c6cf286764b4d94b1e18bd90e98f19b83d6 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Tue, 21 Jul 2009 17:09:32 +1200
Subject: [PATCH] alien.marshall: refactored unmarshalling words

---
 extra/alien/marshall/marshall-docs.factor |  2 +-
 extra/alien/marshall/marshall.factor      | 65 +++++++++++++++--------
 2 files changed, 43 insertions(+), 24 deletions(-)

diff --git a/extra/alien/marshall/marshall-docs.factor b/extra/alien/marshall/marshall-docs.factor
index 6002b0c1c3..deac9fd186 100644
--- a/extra/alien/marshall/marshall-docs.factor
+++ b/extra/alien/marshall/marshall-docs.factor
@@ -327,7 +327,7 @@ HELP: out-arg-unmarshaller
     "for all types except pointers to non-const primitives."
 } ;
 
-HELP: pointer-unmarshaller
+HELP: class-unmarshaller
 { $values
     { "type" " a C type string" }
     { "quot" quotation }
diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor
index 85b157e4a0..deef94dc9b 100644
--- a/extra/alien/marshall/marshall.factor
+++ b/extra/alien/marshall/marshall.factor
@@ -11,7 +11,8 @@ specialized-arrays.long specialized-arrays.longlong
 specialized-arrays.short specialized-arrays.uchar
 specialized-arrays.uint specialized-arrays.ulong
 specialized-arrays.ulonglong specialized-arrays.ushort strings
-unix.utilities vocabs.parser words libc.private struct-arrays ;
+unix.utilities vocabs.parser words libc.private struct-arrays
+locals generalizations ;
 IN: alien.marshall
 
 << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
@@ -269,33 +270,51 @@ ALIAS: marshall-void* marshall-pointer
 : ?malloc-byte-array ( c-type -- alien )
     dup alien? [ malloc-byte-array ] unless ;
 
-: struct-unmarshaller ( type -- quot )
-    current-vocab lookup [
-        dup superclasses [ \ struct-wrapper = ] any? [
-            '[ ?malloc-byte-array _ new swap >>underlying ]
-        ] [ drop [ ] ] if
-    ] [ [ ] ] if* ;
+:: x-unmarshaller ( type type-quot wrapper-test def clean -- quot/f )
+    type type-quot call current-vocab lookup [
+        dup superclasses wrapper-test any?
+        [ def call ] [ drop clean call f ] if
+    ] [ clean call f ] if* ; inline
 
-: pointer-unmarshaller ( type -- quot )
-    type-sans-pointer current-vocab lookup [
-        dup superclasses [ \ alien-wrapper = ] any? [
-            '[ _ new swap >>underlying unmarshall-cast ]
-        ] [ drop [ ] ] if
-    ] [ [ ] ] if* ;
+: struct-unmarshaller ( type -- quot/f )
+    [ ] [ \ struct-wrapper = ]
+    [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
+    [ ]
+    x-unmarshaller ;
+
+: class-unmarshaller ( type -- quot/f )
+    [ type-sans-pointer ] [ \ alien-wrapper = ]
+    [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
+    [ ]
+    x-unmarshaller ;
+
+: template-class-unmarshaller ( type -- quot/f )
+    [ parse-c++-type [ name>> ] keep swap ] [ \ template-wrapper = ]
+    [ '[ _ _ new swap >>type swap >>underlying unmarshall-cast ] ]
+    [ drop ]
+    x-unmarshaller ;
+
+: non-primitive-unmarshaller ( type -- quot/f )
+    {
+        { [ dup template-class? ]
+          [ template-class-unmarshaller ] }
+        { [ dup pointer? ] [ class-unmarshaller ] }
+        [ struct-unmarshaller ]
+    } cond ;
 
 : unmarshaller ( type -- quot )
-    factorize-type dup primitive-unmarshaller [ nip ] [
-        dup pointer?
-        [ pointer-unmarshaller ]
-        [ struct-unmarshaller ] if
-    ] if* ;
+    factorize-type {
+        [ primitive-unmarshaller ]
+        [ non-primitive-unmarshaller ]
+        [ drop [ ] ]
+    } 1|| ;
 
 : struct-field-unmarshaller ( type -- quot )
-    factorize-type dup struct-primitive-unmarshaller [ nip ] [
-        dup pointer?
-        [ pointer-unmarshaller ]
-        [ struct-unmarshaller ] if
-    ] if* ;
+    factorize-type {
+        [ struct-primitive-unmarshaller ]
+        [ non-primitive-unmarshaller ]
+        [ drop [ ] ]
+    } 1|| ;
 
 : out-arg-unmarshaller ( type -- quot )
     dup pointer-to-non-const-primitive?