From da01ae5cda66ec100438f5972ff1eb94387d1638 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Mon, 6 Jul 2009 20:57:51 +1200
Subject: [PATCH] Added alien.inline.types (forgot to add several commits ago)

---
 basis/alien/inline/inline.factor      | 32 ++++--------------
 basis/alien/inline/types/authors.txt  |  1 +
 basis/alien/inline/types/types.factor | 47 +++++++++++++++++++++++++++
 3 files changed, 54 insertions(+), 26 deletions(-)
 create mode 100644 basis/alien/inline/types/authors.txt
 create mode 100644 basis/alien/inline/types/types.factor

diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor
index 9a9f2eb683..ae4a95497a 100644
--- a/basis/alien/inline/inline.factor
+++ b/basis/alien/inline/inline.factor
@@ -1,10 +1,11 @@
 ! Copyright (C) 2009 Jeremy Hughes.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.inline.compiler alien.libraries
-alien.parser arrays assocs effects fry generalizations grouping
-io.files io.files.info io.files.temp kernel lexer math
-math.order math.ranges multiline namespaces sequences splitting
-strings system vocabs.loader vocabs.parser words ;
+USING: accessors alien.inline.compiler alien.inline.types
+alien.libraries alien.parser arrays assocs effects fry
+generalizations grouping io.files io.files.info io.files.temp
+kernel lexer math math.order math.ranges multiline namespaces
+sequences splitting strings system vocabs.loader
+vocabs.parser words ;
 IN: alien.inline
 
 <PRIVATE
@@ -13,35 +14,14 @@ SYMBOL: library-is-c++
 SYMBOL: compiler-args
 SYMBOL: c-strings
 
-: annotate-effect ( types effect -- types effect' )
-    [ in>> ] [ out>> ] bi [
-        zip
-        [ over pointer-to-primitive? [ ">" prepend ] when ]
-        assoc-map unzip
-    ] dip <effect> ;
-
-
 : function-types-effect ( -- function types effect )
     scan scan swap ")" parse-tokens
     [ "(" subseq? not ] filter swap parse-arglist ;
 
-: types-effect>params-return ( types effect -- params return )
-    [ in>> zip ]
-    [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
-    2bi ;
-
 : arg-list ( types -- params )
     CHAR: a swap length CHAR: a + [a,b]
     [ 1string ] map ;
 
-: factorize-type ( str -- str' )
-    "const-" ?head drop
-    "unsigned-" ?head [ "u" prepend ] when
-    "long-" ?head [ "long" prepend ] when ;
-
-: cify-type ( str -- str' )
-    { { CHAR: - CHAR: space } } substitute ;
-
 : factor-function ( function types effect -- word quot effect )
     annotate-effect [ c-library get ] 3dip
     [ [ factorize-type ] map ] dip
diff --git a/basis/alien/inline/types/authors.txt b/basis/alien/inline/types/authors.txt
new file mode 100644
index 0000000000..c45c6f3279
--- /dev/null
+++ b/basis/alien/inline/types/authors.txt
@@ -0,0 +1 @@
+Jeremy Hughes
\ No newline at end of file
diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor
new file mode 100644
index 0000000000..acc62a81a2
--- /dev/null
+++ b/basis/alien/inline/types/types.factor
@@ -0,0 +1,47 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators.short-circuit
+continuations effects fry kernel math memoize sequences
+splitting ;
+IN: alien.inline.types
+
+: factorize-type ( str -- str' )
+    "const-" ?head drop
+    "unsigned-" ?head [ "u" prepend ] when
+    "long-" ?head [ "long" prepend ] when ;
+
+: cify-type ( str -- str' )
+    { { CHAR: - CHAR: space } } substitute ;
+
+: const-type? ( str -- ? )
+    "const-" head? ;
+
+MEMO: resolved-primitives ( -- seq )
+    primitive-types [ resolve-typedef ] map ;
+
+: primitive-type? ( type -- ? )
+    [
+        factorize-type resolve-typedef [ resolved-primitives ] dip
+        '[ _ = ] any?
+    ] [ 2drop f ] recover ;
+
+: pointer? ( type -- ? )
+    [ "*" tail? ] [ "&" tail? ] bi or ;
+
+: type-sans-pointer ( type -- type' )
+    [ '[ _ = ] "*&" swap any? ] trim-tail ;
+
+: pointer-to-primitive? ( type -- ? )
+    { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
+
+: types-effect>params-return ( types effect -- params return )
+    [ in>> zip ]
+    [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
+    2bi ;
+
+: annotate-effect ( types effect -- types effect' )
+    [ in>> ] [ out>> ] bi [
+        zip
+        [ over pointer-to-primitive? [ ">" prepend ] when ]
+        assoc-map unzip
+    ] dip <effect> ;