From b46999584b3ee645af124e2c91eb7762e781c7c6 Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Tue, 30 Jun 2009 22:55:20 +0900
Subject: [PATCH] invoker infers function param c-types more generally

---
 extra/llvm/invoker/invoker.factor |  6 +++---
 extra/llvm/types/types.factor     | 14 ++++++++++++++
 2 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/extra/llvm/invoker/invoker.factor b/extra/llvm/invoker/invoker.factor
index 55ebe6db84..2f679ea885 100644
--- a/extra/llvm/invoker/invoker.factor
+++ b/extra/llvm/invoker/invoker.factor
@@ -30,15 +30,15 @@ TUPLE: function name alien return params ;
     LLVMGetFirstFunction [ (functions) ] { } make [ <function> ] map ;
 
 : function-effect ( function -- effect )
-    [ params>> [ first ] map ] [ void? 0 1 ? ] bi <effect> ;
+    [ params>> [ first ] map ] [ return>> void? 0 1 ? ] bi <effect> ;
 
 : install-function ( function -- )
     dup name>> "alien.llvm" create-vocab drop
     "alien.llvm" create swap
     [
         dup name>> function-pointer ,
-        dup return>> drop "int" ,
-        dup params>> [ drop "int" ] map ,
+        dup return>> c-type ,
+        dup params>> [ second c-type ] map ,
         "cdecl" , \ alien-indirect ,
     ] [ ] make swap function-effect [ define-declared ] with-compilation-unit ;
 
diff --git a/extra/llvm/types/types.factor b/extra/llvm/types/types.factor
index 1d528fb699..6313037e6f 100644
--- a/extra/llvm/types/types.factor
+++ b/extra/llvm/types/types.factor
@@ -18,20 +18,32 @@ IN: llvm.types
 !
 GENERIC: (>tref) ( type -- LLVMTypeRef )
 GENERIC: ((tref>)) ( LLVMTypeRef type -- type )
+GENERIC: c-type ( type -- str )
 
 ! default implementation for simple types
 M: object ((tref>)) nip ;
+: unsupported-type ( -- )
+    "cannot generate c-type: unsupported llvm type" throw ;
+M: object c-type unsupported-type ;
 
 TUPLE: integer size ;
 C: <integer> integer
 
 M: integer (>tref) size>> LLVMIntType ;
 M: integer ((tref>)) swap LLVMGetIntTypeWidth >>size ;
+M: integer c-type size>> {
+    { 64 [ "longlong" ] }
+    { 32 [ "int" ] }
+    { 16 [ "short" ] }
+    { 8  [ "char" ] }
+    [ unsupported-type ]
+} case ;
 
 SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ;
 
 M: float (>tref) drop LLVMFloatType ;
 M: double (>tref) drop LLVMDoubleType ;
+M: double c-type drop "double" ;
 M: x86_fp80 (>tref) drop LLVMX86FP80Type ;
 M: fp128 (>tref) drop LLVMFP128Type ;
 M: ppc_fp128 (>tref) drop LLVMPPCFP128Type ;
@@ -41,6 +53,7 @@ SINGLETONS: opaque label void metadata ;
 M: opaque (>tref) drop LLVMOpaqueType ;
 M: label (>tref) drop LLVMLabelType ;
 M: void (>tref) drop LLVMVoidType ;
+M: void c-type drop "void" ;
 M: metadata (>tref) drop
     "metadata types unsupported by llvm c bindings" throw ;
 
@@ -85,6 +98,7 @@ TUPLE: pointer < enclosing type ;
 M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ;
 M: pointer clean* type>> clean ;
 M: pointer (tref>)* swap LLVMGetElementType (tref>) >>type ;
+M: pointer c-type type>> 8 <integer> = "char*" "void*" ? ;
 
 TUPLE: vector < enclosing size type ;
 : <vector> ( s t -- o )