Managed to a simple Ikarus -> Objective-C interface to work. Ikarus

can now open a Cocoa window under Mac OS X.   Happy Happy Joy Joy!!

lab/lalr-example-calc.scm

@@ -0,0 +1,203 @@
+;;;
+;;;; Simple calculator in Scheme
+;;;
+;;
+;; @created   "Tue Jan  6 12:47:23 2004"
+;; @modified  "Mon Oct 25 11:07:24 2004"
+;; @author    "Dominique Boucher"
+;; @copyright "Dominique Boucher"
+;;
+;; Simple arithmetic calculator. 
+;; 
+;;   This program illustrates the use of the lalr-scm parser generator
+;; for Scheme. It is NOT robust, since calling a function with 
+;; the wrong number of arguments may generate an error that will
+;; cause the calculator to crash.
+
+
+;;;
+;;;;   The LALR(1) parser
+;;;
+
+
+(import (rnrs) (rnrs mutable-pairs) (lalr))
+
+(define calc-parser
+  (lalr-parser
+   
+   ;; --- Options 
+   ;; output a parser, called calc-parser, in a separate file - calc.yy.scm, 
+   ;(output:    calc-parser "calc.yy.scm")
+   ;; output the LALR table to calc.out
+   ;(out-table: "calc.out")
+   ;; there should be no conflict
+   (expect:    0)
+   
+   ;; --- token definitions
+   (ID NUM = LPAREN RPAREN NEWLINE COMMA
+    (left: + -)
+    (left: * /)
+    (nonassoc: uminus))
+   
+   (lines    (lines line) : (display-result $2)
+	     (line)       : (display-result $1))
+	   
+
+   ;; --- rules
+   (line     (assign NEWLINE)        : $1
+	     (expr   NEWLINE)        : $1
+	     (error  NEWLINE)        : #f)
+   
+   (assign   (ID = expr)             : (add-binding $1 $3))
+   
+   (expr     (expr + expr)           : (+ $1 $3)
+	     (expr - expr)           : (- $1 $3)
+	     (expr * expr)           : (* $1 $3)
+	     (expr / expr)           : (/ $1 $3)
+	     (- expr (prec: uminus)) : (- $2)
+	     (ID)                    : (get-binding $1)
+	     (ID LPAREN args RPAREN) : (invoke-proc $1 $3)
+	     (NUM)                   : $1
+	     (LPAREN expr RPAREN)    : $2)
+    
+   (args     ()                      : '()
+	     (expr arg-rest)         : (cons $1 $2))
+   
+   (arg-rest (COMMA expr arg-rest)   : (cons $2 $3)
+	     ()                      : '())))
+
+
+(define (display-result v)
+  (if v
+      (begin
+	(display "==> ")
+	(display v)
+	(newline))))
+
+
+;;;
+;;;;   The lexer
+;;;
+
+
+(define (make-lexer errorp)
+  (lambda ()
+    (letrec ((skip-spaces
+	      (lambda ()
+		(let loop ((c (peek-char)))
+		  (if (and (not (eof-object? c))
+			   (or (char=? c #\space) (char=? c #\tab)))
+		      (begin
+			(read-char)
+			(loop (peek-char)))))))   
+	     (read-number 
+	      (lambda (l)
+		(let ((c (peek-char)))
+		  (if (char-numeric? c)
+		      (read-number (cons (read-char) l))
+		      (string->number (apply string (reverse l)))))))
+	     (read-id
+	      (lambda (l)
+		(let ((c (peek-char)))
+		  (if (char-alphabetic? c)
+		      (read-id (cons (read-char) l))
+		      (string->symbol (apply string (reverse l))))))))
+
+      ;; -- skip spaces
+      (skip-spaces)
+      ;; -- read the next token
+      (let loop ((c (read-char)))
+	(cond
+	 ((eof-object? c)      '*eoi*)
+	 ((char=? c #\newline) 'NEWLINE)
+	 ((char=? c #\+)       '+)
+	 ((char=? c #\-)       '-)
+	 ((char=? c #\*)       '*)
+	 ((char=? c #\/)       '/)
+	 ((char=? c #\=)       '=)
+	 ((char=? c #\,)       'COMMA)
+	 ((char=? c #\()       'LPAREN)
+	 ((char=? c #\))       'RPAREN)
+	 ((char-numeric? c)    (cons 'NUM (read-number (list c))))
+	 ((char-alphabetic? c) (cons 'ID  (read-id (list c))))
+	 (else                 
+	  (errorp "PARSE ERROR : illegal character: " c)
+	  (skip-spaces)
+	  (loop (read-char))))))))
+
+
+(define (read-line)
+  (let loop ((c (read-char)))
+    (if (and (not (eof-object? c))
+	     (not (char=? c #\newline)))
+	(loop (read-char)))))
+
+
+;;;
+;;;;   Environment management
+;;;
+
+
+(define *env* (list (cons '$$ 0)))
+
+
+(define (init-bindings)
+  (set-cdr! *env* '())
+  (add-binding 'cos cos)
+  (add-binding 'sin sin)
+  (add-binding 'tan tan)
+  (add-binding 'expt expt)
+  (add-binding 'sqrt sqrt))
+
+
+(define (add-binding var val)
+  (set! *env* (cons (cons var val) *env*))
+  val)
+
+
+(define (get-binding var)
+  (let ((p (assq var *env*)))
+    (if p 
+	(cdr p)
+	0)))
+
+
+(define (invoke-proc proc-name args)
+  (let ((proc (get-binding proc-name)))
+    (if (procedure? proc)
+	(apply proc args)
+	(begin
+	  (display "ERROR: invalid procedure:")
+	  (display proc-name)
+	  (newline)
+	  0))))
+
+
+;;;
+;;;;   The main program
+;;;
+
+
+(define calc
+  (lambda ()
+    (call-with-current-continuation
+     (lambda (k)
+       (display "********************************") (newline)
+       (display "*  Mini calculator in Scheme   *") (newline)
+       (display "*                              *") (newline)
+       (display "* Enter expressions followed   *") (newline)
+       (display "* by [RETURN] or 'quit()' to   *") (newline)
+       (display "* exit.                        *") (newline)
+       (display "********************************") (newline)
+       (init-bindings)
+       (add-binding 'quit k)
+       (letrec ((errorp
+		 (lambda args
+		   (for-each display args) (newline)))
+		(start
+		 (lambda ()
+		   (calc-parser (make-lexer errorp) errorp))))
+	 (start))))))
+
+(calc)
+

lab/objc/hello-cocoa.ss

@@ -0,0 +1,47 @@
+#!/usr/bin/env ikarus --r6rs-script
+;;; vim:syntax=scheme
+(import (ikarus) (objc))
+
+(define-framework Cocoa)
+(define-class NSAutoreleasePool)
+(define-class NSWindow)
+(define-class NSApplication)
+(define-object NSApp Cocoa)
+
+
+(define pool [$ [$ NSAutoreleasePool alloc] init])
+[$ NSApplication sharedApplication]
+
+(define NSBorderlessWindowMask         #b000000000)
+(define NSTitledWindowMask             #b000000001)
+(define NSClosableWindowMask           #b000000010)
+(define NSMiniaturizableWindowMask     #b000000100)
+(define NSResizableWindowMask          #b000001000)
+(define NSTexturedBackgroundWindowMask #b100000000)
+
+(define NSBackingStoreRetained     0)
+(define NSBackingStoreNonretained  1)
+(define NSBackingStoreBuffered     2)
+
+(define style 
+  (bitwise-ior 
+    NSClosableWindowMask 
+    NSResizableWindowMask
+    NSTexturedBackgroundWindowMask
+    NSTitledWindowMask
+    NSMiniaturizableWindowMask))
+
+(define backing NSBackingStoreBuffered)
+
+(define win [$ [$ NSWindow alloc]
+               initWithContentRect: '#(#(50 50) #(600 400))
+               styleMask: style
+               backing: backing
+               defer: #f])
+
+[$ win makeKeyAndOrderFront: win]
+
+[$ NSApp run]
+[$ pool release]
+
+

lab/objc/objc.ss

@@ -0,0 +1,454 @@
+
+(library (objc)
+  (export 
+    define-framework
+    define-class
+    define-object
+    $)
+  (import 
+    (ikarus)
+    (ikarus system $foreign)
+    (except (ypsilon-compat) format)
+    )
+
+(define ptrsize 4)
+
+
+
+ 
+(define objc 
+  (load-shared-object "libobjc.A.dylib"))
+(define Cocoa 
+  (load-shared-object "/System/Library/Frameworks/Cocoa.framework/Cocoa"))
+
+
+(define-syntax define-function
+  (syntax-rules ()
+    ((_ ret name args)
+     (define name 
+       (c-function objc "Objective C Binding" ret __stdcall name args)))))
+
+
+(define-function int objc_getClassList (void* int))
+(define-function void* objc_getClass (char*))
+(define-function void* sel_registerName (char*))
+(define-function void* sel_getUid (char*))
+(define-function void* class_getInstanceMethod (void* void*))
+(define-function void* class_getClassMethod (void* void*))
+(define-function void* class_nextMethodList (void* void*))
+
+
+
+(define-record-type class (fields ptr))
+(define-record-type object (fields ptr))
+(define-record-type lazy-object (fields ptr))
+(define-record-type selector (fields ptr))
+(define-record-type method (fields ptr))
+
+(define (pointer-ref addr offset)
+  (assert (pointer? addr))
+  (integer->pointer (pointer-ref-long addr offset)))
+
+(define (char*len x)
+  (let f ([i 0])
+    (cond
+      [(zero? (pointer-ref-uchar x i)) i]
+      [else (f (+ i 1))])))
+
+(define (char*->bv x)
+  (let ([n (char*len x)])
+    (let ([bv (make-bytevector n)])
+      (let f ([i 0])
+        (cond
+          [(= i n) bv]
+          [else
+           (bytevector-u8-set! bv i (pointer-ref-uchar x i))
+           (f (+ i 1))])))))
+
+(define (char*->string x)
+  (utf8->string (char*->bv x)))
+
+(define-syntax check
+  (syntax-rules ()
+    [(_ who pred expr)
+     (let ([t expr])
+       (unless (pred t)
+         (die who (format "not a ~a" 'pred) t)))]))
+
+(define (class-name x)
+  (check 'class-name class? x)
+  (char*->string (pointer-ref (class-ptr x) (* ptrsize 2))))
+
+(define (method-types x)
+  (check 'method-types method? x)
+  (char*->string (pointer-ref (method-ptr x) (* ptrsize 1))))
+
+(define (method-pointer x)
+  (check 'method-pointer method? x)
+  (pointer-ref (method-ptr x) (* ptrsize 2)))
+
+
+(define (method-selector x)
+  (check 'method-selector method? x)
+  (make-selector (pointer-ref (method-ptr x) (* ptrsize 0))))
+
+(define (method-name x)
+  (check 'method-name method? x)
+  (string-append 
+    (selector-name (method-selector x))
+    "  "
+    (method-types x)))
+
+
+
+(define CLS_METHOD_ARRAY #x100)
+
+
+(define (class-is? x what)
+  (define alist
+    '([method-array      #x100]
+      [no-method-array  #x4000]))
+  (check 'class-info class? x)
+  (let ([mask
+          (cond
+            [(assq what alist) => cadr]
+            [else (error 'class-is? "invalid what" what)])])
+    (= mask (bitwise-and mask (pointer-ref-long (class-ptr x) (* ptrsize 4))))))
+
+(define (class-methods x)
+  (define (methods x)
+    (let ([n (pointer-ref-int x ptrsize)]
+          [array (integer->pointer (+ (pointer->integer x) (* 2 ptrsize)))])
+      (let f ([i 0])
+        (if (= i n)
+            '()
+            (let ([m (make-method 
+                       (integer->pointer 
+                         (+ (pointer->integer array)
+                            (* 3 ptrsize i))))])
+              (cons m (f (+ i 1))))))))
+  (check 'class-methods class? x)
+  (when (class-is? x 'method-array)
+    (error 'class-methods "BUG: not yet for method arrays"))
+  (let ([iterator (malloc ptrsize)])
+    (pointer-set-long iterator 0 0)
+    (let f ()
+      (let ([methodlist (class_nextMethodList (class-ptr x) iterator)])
+        (cond
+          [(nil? methodlist)
+           (free iterator) 
+           '()]
+          [else
+           (let ([ls (methods methodlist)])
+             (append ls (f)))])))))
+
+
+(define (get-class-list)
+  (let ([n (objc_getClassList (integer->pointer 0) 0)])
+    (if (= n 0)
+        '()
+        (let ([buffer (malloc (* ptrsize n))])
+          (let ([n (objc_getClassList buffer n)])
+            (let f ([i 0] [ac '()])
+              (if (= i n) 
+                  (begin (free buffer) ac)
+                  (f (+ i 1) 
+                     (cons 
+                       (make-class 
+                         (integer->pointer
+                           (pointer-ref-long buffer (* ptrsize i))))
+                       ac)))))))))
+
+(define (nil? x)
+  (zero? (pointer->integer x)))
+
+(define (get-class name)
+  (check 'lookup-class string? name)
+  (let ([v (objc_getClass name)])
+    (cond
+      [(nil? v) #f]
+      [else (make-class v)])))
+
+(define (get-selector name)
+  (check 'lookup-selector string? name)
+  (let ([v (sel_registerName name)])
+    (cond
+      [(nil? v) #f]
+      [else (make-selector v)])))
+
+(define (selector-name x)
+  (check 'selector-name selector? x)
+  (char*->string (selector-ptr x)))
+
+(define (get-class-method class selector)
+  (check 'get-class-method class? class)
+  (check 'get-class-method selector? selector)
+  (let ([v (class_getClassMethod 
+             (class-ptr class)
+             (selector-ptr selector))])
+    (cond
+      [(nil? v) #f]
+      [else (make-method v)])))
+
+(define (get-instance-method x selector)
+  (check 'get-instance-method object? x)
+  (check 'get-instance-method selector? selector)
+  (let ([class (pointer-ref (object-ptr x) 0)])
+    (let ([v (class_getInstanceMethod 
+               class
+               (selector-ptr selector))])
+    (cond
+      [(nil? v) #f]
+      [else (make-method v)]))))
+
+
+(define-syntax define-class 
+  (syntax-rules ()
+    [(_ name) 
+     (define name 
+       (or (get-class (symbol->string 'name))
+           (error 'define-class "undefined class" 'name)))]))
+
+(define-syntax define-selector 
+  (syntax-rules ()
+    [(_ name) 
+     (define name 
+       (or (get-selector (symbol->string 'name))
+           (error 'define-selector "undefined selector" 'name)))]))
+
+(define-syntax define-class-method
+  (syntax-rules ()
+    [(_ name class selector)
+     (define name 
+       (or (get-class-method class selector)
+           (error 'define-class-method 
+                  "class method not implemented"
+                  'name)))]))
+
+
+(define-class NSObject)
+(define-class NSString)
+(define-class NSAutoreleasePool)
+(define-class NSWindow)
+(define-selector alloc)
+(define-selector allocWithZone:)
+(define-selector init)
+
+(define-class-method NSObject:alloc NSObject alloc)
+(define-class-method NSObject:allocWithZone: NSObject allocWithZone:)
+(define-class-method NSAutoreleasePool:alloc NSAutoreleasePool alloc)
+
+
+(define (class-info x)
+  `([name: ,(class-name x)]
+    [methods: 
+      ,(list-sort string<?
+         (map method-name (class-methods x)))]))
+
+
+(define-syntax define-framework
+  (lambda (x)
+    (syntax-case x ()
+      [(_ name) (identifier? #'name)
+       (let ([str (symbol->string (syntax->datum #'name))])
+         (with-syntax ([framework-name
+                        (string-append str ".framework/" str)])
+           #'(define name 
+               (load-shared-object framework-name))))])))
+
+(define (load-object lib name)
+  (let ([ptr 
+         (or (dlsym (library-pointer lib) (symbol->string name))
+             (error 'load-object "cannot find symbol" name))])
+    (make-lazy-object ptr)))
+
+(define-syntax define-object
+  (lambda (x)
+    (syntax-case x ()
+      [(_ name lib)
+       #'(define name (load-object lib 'name))])))
+
+(define (symbol->selector x)
+  (or (get-selector (symbol->string x))
+      (error 'symbol->selector "undefined selector" x)))
+
+
+(define (make-signature str)
+  (define who 'make-signature)
+  (let ([n (string-length str)])
+    (define (scan i c)
+      (cond
+        [(= i n) (error who "cannot find " c)]
+        [(char=? c (string-ref str i)) (+ i 1)]
+        [else (scan (+ i 1) c)]))
+    (define (parse i)
+      (cond
+        [(= i n) (error who "unterminated string")]
+        [else
+         (let ([c (string-ref str i)])
+           (case c
+             [(#\@) (values 'object (+ i 1))]
+             [(#\:) (values 'selector (+ i 1))]
+             [(#\v) (values 'void (+ i 1))]
+             [(#\f) (values 'float (+ i 1))]
+             [(#\i) (values 'int (+ i 1))]
+             [(#\I) (values 'uint (+ i 1))]
+             [(#\c) (values 'char (+ i 1))]
+             [(#\{) ;;; struct
+              (let ([i (scan (+ i 1) #\=)])
+                (let-values ([(i ls)
+                              (let f ([i i])
+                                (let-values ([(x i) (parse i)])
+                                  (cond
+                                    [(>= i n) (error who "runaway")]
+                                    [(char=? (string-ref str i) #\})
+                                     (values (+ i 1) (list x))]
+                                    [else
+                                     (let-values ([(i ls) (f i)])
+                                       (values i (cons x ls)))])))])
+                  (values (list->vector ls) i)))]
+             [(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+              (values 'skip (+ i 1))]
+             [else (error who "invalid char" c str)]))]))
+    (define (cons/skip x y)
+      (if (eq? x 'skip) y (cons x y)))
+    (let f ([i 0])
+      (cond
+        [(= i n) '()]
+        [else 
+         (let-values ([(x i) (parse i)])
+           (cons/skip x (f i)))]))))
+
+
+(define (objc-type->ikarus-type x)
+  (cond
+    [(vector? x) 
+     (vector-map objc-type->ikarus-type x)]
+    [else
+     (case x 
+       [(selector) 'pointer]
+       [(object)   'pointer]
+       [(void)     'void]
+       [(float)    'float]
+       [(uint)     'uint32]
+       [(int)      'sint32]
+       [(char)     'sint8]
+       [else (error 'objc-type->ikarus-type "invalid type" x)])]))
+
+
+
+(define (convert-incoming t x)
+  (case t
+    [(object) (make-object x)]
+    [(void)   (void)]
+    [else (error 'convert-incoming "invalid type" t)]))
+
+(define (convert-outgoing t x)
+  (cond
+    [(vector? t)
+     (cond
+       [(vector? x)
+        (unless (= (vector-length x) (vector-length t))
+          (error 'convert-outgoing "length mismatch" x t))
+        (vector-map convert-outgoing t x)]
+       [else (error 'convert-output "not a vector" x)])]
+    [else
+     (case t
+       [(selector)
+        (cond
+          [(selector? x) (selector-ptr x)]
+          [else (error 'convert-output "not a selector" x)])]
+       [(object) 
+        (cond
+          [(object? x) (object-ptr x)]
+          [(lazy-object? x) 
+           (pointer-ref (lazy-object-ptr x) 0)]
+          [(class? x) (class-ptr x)]
+          [else (error 'convert-output "cannot convert to object" x)])]
+       [(float) 
+        (cond
+          [(number? x) (inexact x)]
+          [else (error 'convert-output "cannot convert to float" x)])]
+       [(uint int char)
+        (cond
+          [(or (fixnum? x) (bignum? x)) x]
+          [(boolean? x) (if x 1 0)]
+          [else (error 'convert-output "cannot convert to int" x)])]
+       [else (error 'convert-outgoing "invalid type" t)])]))
+
+
+(define (call-with-sig sig mptr args)
+  (let ([rtype (car sig)] [argtypes (cdr sig)])
+    (unless (= (length args) (length argtypes))
+      (error 'call-with-sig "incorrect number of args" args argtypes))
+    (let ([ffi (make-ffi 
+                 (objc-type->ikarus-type rtype)
+                 (map objc-type->ikarus-type argtypes))])
+      (let ([proc (ffi mptr)])
+        (convert-incoming rtype 
+          (apply proc (map convert-outgoing argtypes args)))))))
+
+(define (send-message x method-name . args)
+  (let ([selector (symbol->selector method-name)])
+    (let ([method 
+           (cond
+             [(class? x) (get-class-method x selector)]
+             [(object? x) (get-instance-method x selector)]
+             [(lazy-object? x)
+              (get-instance-method 
+                (make-object (pointer-ref (lazy-object-ptr x) 0))
+                selector)]
+             [else (error 'send-message "not an object" x)])])
+      (unless method
+        (error 'send-message "undefined method" method-name))
+      (let ([sig (make-signature (method-types method))]
+            [mptr (method-pointer method)])
+        (call-with-sig sig mptr (cons* x selector args))))))
+
+(define-syntax $
+  (lambda (x)
+    (define (process-rest ls)
+      (syntax-case ls ()
+        [() (values "" '())]
+        [(kwd val . rest) (identifier? #'kwd)
+         (let-values ([(sel args) (process-rest #'rest)])
+           (values 
+             (string-append 
+               (symbol->string (syntax->datum #'kwd))
+               sel)
+             (cons #'val args)))]))
+    (define (process-args ls)
+      (let-values ([(sel args) (process-rest ls)])
+        (cons (datum->syntax #'here (string->symbol sel)) args)))
+    (syntax-case x ()
+      [(_ receiver kwd)
+       (identifier? #'kwd)
+       #'(send-message receiver 'kwd)]
+      [(_ receiver kwd/arg* ...)
+       (identifier? #'kwd)
+       (with-syntax ([(sel-name arg* ...)
+                      (process-args #'(kwd/arg* ...))])
+         #'(send-message receiver 'sel-name arg* ...))])))
+
+
+         
+
+;(printf "Classes: ~s\n" 
+;  (list-sort string<? (map class-name (get-class-list))))
+;
+;(printf "NSObject=~s\n" NSObject)
+;(printf "alloc=~s\n" alloc)
+;(printf "init=~s\n" init)
+;(printf "NSObject:alloc=~s\n" NSObject:alloc)
+;(printf "NSObject:allocWithZone=~s\n" NSObject:allocWithZone:)
+;(printf "types alloc=~s\n" (method-types NSObject:alloc))
+;(printf "types alloc=~s\n" (method-types NSAutoreleasePool:alloc))
+;(printf "types allocWithZone=~s\n" (method-types NSObject:allocWithZone:))
+;(for-each
+;  (lambda (x)
+;    (pretty-print (class-info x)))
+;  (list NSObject NSString NSAutoreleasePool NSWindow))
+
+
+
+) ; library

lab/test-ffi.ss

@@ -93,8 +93,11 @@
 (check = (test_D_DDD S_add_D_DDD 12.0 13.0 14.0) (+ 12.0 13.0 14.0))
 
 
+(define RectArea 
+  ((make-ffi 'float '(#(#(float float) #(float float))))
+   (dlsym self "test_area_F_R")))
 
-
+(check = (RectArea '#(#(0.0 0.0) #(10.0 10.0))) 100.0)
 
 
 

lib/ypsilon-compat.ikarus.ss

@@ -2,7 +2,7 @@
 (library (ypsilon-compat)
   (export on-windows on-darwin on-linux on-freebsd on-posix
           load-shared-object c-argument c-function 
-          microsecond usleep
+          microsecond usleep library-pointer
           (rename (ypsilon:format format)))
   (import 
     (ikarus system $foreign)
@@ -19,8 +19,9 @@
     (cond
       [(eq? what #t) 
        (apply printf str args)]
-      [else 
+      [(eq? what #f) 
-       (apply format str args)]))
+       (apply format str args)]
+      [else (error 'ypsion:format "invalid what" what)]))
 
 
   (define (architecture-feature what)
@@ -148,7 +149,10 @@
          (define (name* . args) (error 'name* "not implemented"))
          ...)]))
 
-  (todo check-void* )
+  (define (check-void* who x)
+    (cond
+      [(pointer? x) x]
+      [else (die who "not a void*" x)]))
 
   (define-syntax convert-arg
     (lambda (x)
@@ -235,7 +239,7 @@
     (unless (library? lib) (die who "not a library" lib))
     (or (dlsym (library-pointer lib) (symbol->string name))
       (error who 
-        (format #f "cannot find object ~a in library ~a" 
+        (format "cannot find object ~a in library ~a" 
                 name (library-name lib)))))
 
 

scheme/ikarus.pointers.ss

@@ -124,6 +124,9 @@
   (define (ffi-prep-cif rtype argtypes)
     (define who 'ffi-prep-cif)
     (define (convert x)
+      (cond
+        [(vector? x) (vector-map convert x)]
+        [else
          (case x 
            [(void)       1]
            [(uint8)      2]
@@ -137,7 +140,7 @@
            [(float)     10]
            [(double)    11]
            [(pointer)   12]
-        [else (die who "invalid type" x)]))
+           [else (die who "invalid type" x)])]))
     (unless (list? argtypes)
       (die who "arg types is not a list" argtypes))
     (let ([argtypes-n (vector-map convert (list->vector argtypes))]

scheme/last-revision

@@ -1 +1 @@
-1612
+1613

src/ikarus-ffi.c

@@ -19,9 +19,36 @@ alloc(size_t n, int m) {
   return x;
 }
 
+static ffi_type* scheme_to_ffi_type_cast(ikptr nptr);
 
 static ffi_type* 
-scheme_to_ffi_type_cast(int n){
+scheme_to_ffi_record_type_cast(ikptr vec){
+  ikptr lenptr = ref(vec, -vector_tag);
+  if (! is_fixnum(lenptr)) {
+    fprintf(stderr, "NOT A VECTOR 0x%016lx\n", vec);
+    exit(-1);
+  }
+  long n = unfix(lenptr);
+  ffi_type* t = alloc(sizeof(ffi_type), 1);
+  ffi_type** ts = alloc(sizeof(ffi_type*), n+1);
+  t->size = 0;
+  t->alignment = 0;
+  t->type = FFI_TYPE_STRUCT;
+  t->elements = ts;
+  long i;
+  for(i=0; i<n; i++){
+    ts[i] = scheme_to_ffi_type_cast(ref(vec, off_vector_data + i*wordsize)); 
+  }
+  ts[n] = 0;
+  return t;
+}
+
+static ffi_type* 
+scheme_to_ffi_type_cast(ikptr nptr){
+  if (tagof(nptr) == vector_tag) {
+    return scheme_to_ffi_record_type_cast(nptr);
+  } else if (is_fixnum(nptr)) {
+    long n = unfix(nptr);
     switch (n & 0xF) {
       case  1: return &ffi_type_void;
       case  2: return &ffi_type_uint8;
@@ -36,21 +63,50 @@ scheme_to_ffi_type_cast(int n){
       case 11: return &ffi_type_double;
       case 12: return &ffi_type_pointer;
       default: 
-      fprintf(stderr, "INVALID ARG %d", n);
+        fprintf(stderr, "INVALID ARG %ld", n);
+        exit(-1);
+    }
+  } else {
+    fprintf(stderr, "INVALID ARG %ld", nptr);
     exit(-1);
   }
 }
 
 static void* 
-alloc_room_for_type(int n){
+alloc_room_for_type(ffi_type* t){
-  ffi_type* t = scheme_to_ffi_type_cast(n);
   return alloc(t->size, 1);
 }
 
 extern long extract_num(ikptr x);
 
+static void scheme_to_ffi_value_cast(ffi_type*, ikptr, ikptr, void*);
+
 static void
-scheme_to_ffi_value_cast(int n, ikptr p, void* r) {
+scheme_to_ffi_record_value_cast(ffi_type* t, ikptr nptr, ikptr p, void* r) {
+  if (t->type != FFI_TYPE_STRUCT) {
+    fprintf(stderr, "not a struct type\n");
+    exit(-1);
+  }
+  ffi_type** ts = t->elements;
+  char* buf = r;
+  ikptr lenptr = ref(nptr, off_vector_length);
+  int n = unfix(lenptr);
+  int i;
+  for(i=0; i<n; i++) {
+    ffi_type* at = ts[i];
+    ikptr argt = ref(nptr, off_vector_data + i*wordsize);
+    ikptr arg = ref(p, off_vector_data + i*wordsize);
+    scheme_to_ffi_value_cast(at, argt, arg, buf);
+    buf += at->size;
+  }
+}
+
+static void
+scheme_to_ffi_value_cast(ffi_type* t, ikptr nptr, ikptr p, void* r) {
+  if (tagof(nptr) == vector_tag) {
+    scheme_to_ffi_record_value_cast(t, nptr, p, r);
+  } else if (is_fixnum(nptr)) {
+    long n = unfix(nptr);
     switch (n & 0xF) {
       case  1: {  return; }
       case  2: // ffi_type_uint8;
@@ -72,7 +128,11 @@ scheme_to_ffi_value_cast(int n, ikptr p, void* r) {
       case 12: //return &ffi_type_pointer;
        { *((void**)r) = (void*)ref(p, off_pointer_data); return; }
       default: 
-      fprintf(stderr, "INVALID ARG %d", n);
+        fprintf(stderr, "INVALID ARG %ld", n);
+        exit(-1);
+    }
+  } else {
+    fprintf(stderr, "INVALID TYPE  0x%016lx\n", nptr);
     exit(-1);
   }
 }
@@ -112,10 +172,10 @@ ikrt_ffi_prep_cif(ikptr rtptr, ikptr argstptr, ikpcb* pcb) {
   int i;
   for(i=0; i<nargs; i++){
     ikptr argt = ref(argstptr, off_vector_data + i*wordsize);
-    argtypes[i] = scheme_to_ffi_type_cast(unfix(argt));
+    argtypes[i] = scheme_to_ffi_type_cast(argt);
   }
   argtypes[nargs] = NULL;
-  ffi_type* rtype = scheme_to_ffi_type_cast(unfix(rtptr));
+  ffi_type* rtype = scheme_to_ffi_type_cast(rtptr);
   ffi_status s = ffi_prep_cif(cif, abi, nargs, rtype, argtypes);
   if (s == FFI_OK) {
     ikptr r = ik_safe_alloc(pcb, pointer_size);
@@ -266,14 +326,15 @@ ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb)  {
   void** avalues = alloc(sizeof(void*), n+1);
   int i;
   for(i=0; i<n; i++){
-    ikptr t = ref(typevec, off_vector_data + i * wordsize);
+    ffi_type* t = cif->arg_types[i];
+    ikptr at = ref(typevec, off_vector_data + i * wordsize);
     ikptr v = ref(argsvec, off_vector_data + i * wordsize);
-    void* p = alloc_room_for_type(unfix(t));
+    void* p = alloc_room_for_type(t);
     avalues[i] = p;
-    scheme_to_ffi_value_cast(unfix(t), v, p);
+    scheme_to_ffi_value_cast(t, at, v, p);
   }
   avalues[n] = NULL;
-  void* rvalue = alloc_room_for_type(unfix(rtype));
+  void* rvalue = alloc_room_for_type(cif->rtype);
   ffi_call(cif, fn, rvalue, avalues);
   ikptr val = ffi_to_scheme_value_cast(unfix(rtype), rvalue, pcb);
   for(i=0; i<n; i++){
@@ -351,7 +412,7 @@ generic_callback(ffi_cif *cif, void *ret, void **args, void *user_data){
 #ifdef DEBUG_FFI
   fprintf(stderr, "and back with rv=0x%016lx!\n", rv);
 #endif
-  scheme_to_ffi_value_cast(unfix(rtype_conv), rv, ret);
+  scheme_to_ffi_value_cast(cif->rtype, rtype_conv, rv, ret);
   return;
 }
 
@@ -432,6 +493,21 @@ int add_I_III(int n0, int n1, int n2) {
 
 
 
+struct Point{
+  float x;
+  float y;
+};
+
+struct Rect{
+  struct Point tl;
+  struct Point br;
+};
+
+float test_area_F_R(struct Rect r) {
+  float dx = r.br.x - r.tl.x;
+  float dy = r.br.y - r.tl.y;
+  return dx * dy;
+}
 
 double test_D_D (double(*f)(double), double n0) {
   return f(n0);