Unpack 960213.tar.gz

BUGS.FFI

@@ -0,0 +1,3 @@
+Known bugs
+
+- the use of delete-file in chez.w is not portable.

CHGLOG.FFI

@@ -0,0 +1,11 @@
+Changes to FFIGEN over time.
+
+960213 / lth
+- Fixed error in chez.w:basic-type-name where the entry for unsigned-short 
+  was a list and not a pair, causing a crash.
+- Fixed error in chez.w:dump-struct/union-def to avoid generating code
+  for structures and unions with no fields (declarations, effectively).
+- Fixed portability problems in process.sch: reverse! changed to reverse.
+- Implemented function pointer casts in chez.w:c-cast-expression.
+- Changed 'ffigen' driver program to use /usr/include by default, and 
+  also to define -D_NO_LONGLONG by default.

chez-stdlib.c

@@ -0,0 +1,16 @@
+#include "chez-stdlib.h"
+
+int _ref_int( unsigned _p, int _k ) { return ((int*)_p)[_k]; }
+void _set_int( unsigned _p, int _k, int _v ) { ((int*)_p)[_k] = _v; }
+
+unsigned _ref_uint( unsigned _p, int _k ) { return ((unsigned*)_p)[_k]; }
+void _set_uint( unsigned _p, int _k, unsigned _v ) { ((unsigned*)_p)[_k] = _v; }
+
+char _ref_char( unsigned _p, int _k ) { return ((char*)_p)p[_k]; }
+void _set_char( unsigned _p, int _k, char _v ) { ((char*)_p)[_k] = _v; }
+
+double _ref_double( unsigned _p, int _k ) { return ((double*)_p)[_k]; }
+void _set_double( unsigned _p, int _k, double _v ) { ((double*)_p)[_k] = _v; }
+
+float _ref_float( unsigned _p, int _k ) { return ((float*)_p)[_k]; }
+void _set_float( unsigned _p, int _k, float _v ) { ((float*)_p)[_k] = _v; }

chez-stdlib.h

@@ -0,0 +1,10 @@
+int _ref_int( unsigned _p, int _k );
+void _set_int( unsigned _p, int _k, int _v );
+unsigned _ref_uint( unsigned _p, int _k );
+void _set_uint( unsigned _p, int _k, unsigned _v );
+char _ref_char( unsigned _p, int _k );
+void _set_char( unsigned _p, int _k, char _v );
+double _ref_double( unsigned _p, int _k );
+void _set_double( unsigned _p, int _k, double _v );
+float _ref_float( unsigned _p, int _k );
+void _set_float( unsigned _p, int _k, float _v );

chez-stdlib.sch

@@ -0,0 +1,49 @@
+(define _ref_int
+  (foreign-function "_ref_int" (unsigned-32 integer-32) integer-32))
+
+(define _set_int
+  (foreign-function "_set_int" (unsigned-32 integer-32 integer-32) void))
+
+(define _ref_uint
+  (foreign-function "_ref_uint" (unsigned-32 integer-32) integer-32))
+
+(define _set_uint
+  (foreign-function "_set_uint" (unsigned-32 integer-32 unsigned-32) void))
+
+(define _ref_char
+  (foreign-function "_ref_char" (unsigned-32 integer-32) char))
+
+(define _set_char
+  (foreign-function "_set_char" (unsigned-32 integer-32 char) void))
+
+(define _ref_double
+  (foreign-function "_ref_double" (unsigned-32 integer-32) double-float))
+
+(define _set_double
+  (foreign-function "_set_double" (unsigned-32 integer-32 double-float) void))
+
+(define _ref_float
+  (foreign-function "_ref_float" (unsigned-32 integer-32) single-float))
+
+(define _set_float
+  (foreign-function "_set_float" (unsigned-32 integer-32 single-float) void))
+
+(define _memcpy
+  (let ((memcpy-*-*
+         (foreign-function "memcpy" (unsigned-32 unsigned-32 unsigned-32) void))
+        (memcpy-string-string
+         (foreign-function "memcpy" (string string unsigned-32) void))
+        (memcpy-string-*
+         (foreign-function "memcpy" (string unsigned-32 unsigned-32) void))
+        (memcpy-*-string
+         (foreign-function "memcpy" (unsigned-32 string unsigned-32) void)))
+    (lambda (a b count)
+      (cond ((string? a)
+             (cond ((string? b) (memcpy-string-string a b count))
+                   ((integer? b) (memcpy-string-* a b count))
+                   (else ???)))
+            ((integer? a)
+             (cond ((string? b) (memcpy-*-string a b count))
+                   ((integer? b) (memcpy-*-* a b count))
+                   (else ???)))
+            (else ???)))))

chez.sch

@@ -82,14 +82,15 @@
             ((string-prefix=? oldname free) (string-append "_free_" typedef-name))
             (else (error "compute-newname: can't handle: " oldname))))))
 (define (dump-struct/union-def structure qualifier name)
-  (let* ((funcname (if (string=? qualifier "")
-                       name
-                       (string-append qualifier "_" name)))
-         (cast     (if (string=? qualifier "")
-                       name
-                       (string-append qualifier " " name))))
-    (generate-constructor-and-destructor structure funcname cast)
-    (generate-accessors-and-mutators structure funcname cast "")))
+  (if (not (null? (fields structure)))
+      (let* ((funcname (if (string=? qualifier "")
+                           name
+                           (string-append qualifier "_" name)))
+             (cast     (if (string=? qualifier "")
+                           name
+                           (string-append qualifier " " name))))
+        (generate-constructor-and-destructor structure funcname cast)
+        (generate-accessors-and-mutators structure funcname cast ""))))
 (define (generate-constructor-and-destructor structure funcname cast)
   (function-pair constructor-template 
                  (vector funcname cast)
@@ -263,7 +264,7 @@
                        (signed-char . "signed char")
                        (unsigned-char . "unsigned char")
                        (short . "short")
-                       (unsigned-short "unsigned short")
+                       (unsigned-short . "unsigned short")
                        (int . "int")
                        (enum . "int")
                        (unsigned . "unsigned")
@@ -279,10 +280,25 @@
         (begin (warn "Unknown type " type)
                "***invalid***"))))
 (define (c-cast-expression type)
+  (define (function-cast stars ftype)
+    (string-append (c-cast-expression (rett ftype))
+                   "(" stars ")("
+                   (apply string-append 
+                          (insert 
+                           ","
+                           (map c-cast-expression (arglist ftype))))
+                   ")"))
+
   (cond ((primitive-type? type) 
          (basic-type-name type))
         ((pointer-type? type)
-         (string-append (c-cast-expression (cadr type)) "*"))
+         (let loop ((t (cadr type)) (stars "*"))
+           (cond ((eq? 'function (record-tag t))
+                  (function-cast stars t))
+                 ((eq? 'pointer (record-tag t))
+                  (loop (cadr t) (string-append "*" stars)))
+                 (else
+                  (string-append (c-cast-expression (cadr type)) "*")))))
         ((eq? (record-tag type) 'enum-ref)
          (basic-type-name '(int ())))
         ((memq (record-tag type) '(struct-ref union-ref))
@@ -301,6 +317,16 @@
         (else
          (warn "c-cast-expression: Too complicated: " type)
          "unknown")))
+
+(define (insert x l)
+  (define (loop l)
+    (if (null? (cdr l))
+        l
+        (cons (car l) (cons x (loop (cdr l))))))
+  (if (or (null? l)
+          (null? (cdr l)))
+      l
+      (loop l)))
 (define (string-prefix=? s prefix)
   (let ((limit (string-length prefix)))
     (and (<= limit (string-length s))

chez.w

@@ -3,7 +3,7 @@
 % This is a nuweb document.
 % nuweb is available by anon. ftp from cs.rice.edu in /public/preston.
 %
-% Author: Lars Thomas Hansen (lth@cs.uoregon.edu)
+% Author: Lars Thomas Hansen (lth@@cs.uoregon.edu)
 %
 % Copyright (C) 1996 The University of Oregon.  All rights reserved.
 % 
@@ -435,16 +435,21 @@ for the structure.
 
 @d dump structs and unions 
 @{(define (dump-struct/union-def structure qualifier name)
-  (let* ((funcname (if (string=? qualifier "")
-		       name
-		       (string-append qualifier "_" name)))
-	 (cast     (if (string=? qualifier "")
-		       name
-		       (string-append qualifier " " name))))
-    (generate-constructor-and-destructor structure funcname cast)
-    (generate-accessors-and-mutators structure funcname cast "")))
+  (if (not (null? (fields structure)))
+      (let* ((funcname (if (string=? qualifier "")
+			   name
+			   (string-append qualifier "_" name)))
+	     (cast     (if (string=? qualifier "")
+			   name
+			   (string-append qualifier " " name))))
+	(generate-constructor-and-destructor structure funcname cast)
+	(generate-accessors-and-mutators structure funcname cast ""))))
 @| dump-struct/union-def @}
 
+Constructors, destructors, accessors and mutators are generated only if
+the field list for the structure is non-empty, as an empty field lists
+implies that the structure has merely been declared.
+
 \subsubsection{Constructors and destructors}
 
 The procedure \verb|generate-constructor-and-destructor| generates
@@ -925,7 +930,7 @@ issue; here are our encodings:
 		       (signed-char . "signed char")
 		       (unsigned-char . "unsigned char")
 		       (short . "short")
-		       (unsigned-short "unsigned short")
+		       (unsigned-short . "unsigned short")
 		       (int . "int")
 		       (enum . "int")
 		       (unsigned . "unsigned")
@@ -954,10 +959,25 @@ refers to the structure, and that name should be used instead.
 
 @d utility functions
 @{(define (c-cast-expression type)
+  (define (function-cast stars ftype)
+    (string-append (c-cast-expression (rett ftype))
+		   "(" stars ")("
+		   (apply string-append 
+			  (insert 
+			   ","
+			   (map c-cast-expression (arglist ftype))))
+		   ")"))
+
   (cond ((primitive-type? type) 
 	 (basic-type-name type))
 	((pointer-type? type)
-	 (string-append (c-cast-expression (cadr type)) "*"))
+	 (let loop ((t (cadr type)) (stars "*"))
+	   (cond ((eq? 'function (record-tag t))
+		  (function-cast stars t))
+		 ((eq? 'pointer (record-tag t))
+		  (loop (cadr t) (string-append "*" stars)))
+		 (else
+		  (string-append (c-cast-expression (cadr type)) "*")))))
 	((eq? (record-tag type) 'enum-ref)
 	 (basic-type-name '(int ())))
 	((memq (record-tag type) '(struct-ref union-ref))
@@ -976,7 +996,17 @@ refers to the structure, and that name should be used instead.
 	(else
 	 (warn "c-cast-expression: Too complicated: " type)
 	 "unknown")))
-@| c-cast-expression @}
+
+(define (insert x l)
+  (define (loop l)
+    (if (null? (cdr l))
+	l
+	(cons (car l) (cons x (loop (cdr l))))))
+  (if (or (null? l)
+	  (null? (cdr l)))
+      l
+      (loop l)))
+@| c-cast-expression insert @}
 
 \verb|String-prefix=?| takes a string and a prefix and tests whether the
 prefix matches the string.

ffigen

@@ -11,9 +11,10 @@ LCCHOME=/home/users/lth/net/lcc
 ARCH=sparc/solaris
 
 TMP=/tmp/ffitmp.$$
-DEFINES="-D__STDC__"
-INCLUDES="-I$LCCHOME/include/$ARCH -I/usr/include -I."
+DEFINES="-D__STDC__ -D_NO_LONGLONG"
 output=""
+INCLUDES="-I/usr/include -I."
+#INCLUDES="-I$LCCHOME/include/$ARCH -I/usr/include -I."
 VERBOSE=1
 
 if [ $# -lt 1 ]; then

process.sch

@@ -290,12 +290,12 @@
 (define (instantiate template args)
 
   (define (get-arg n)
-    (reverse! (string->list (vector-ref args n))))
+    (reverse (string->list (vector-ref args n))))
 
   (let ((limit (string-length template)))
     (let loop ((i 0) (r '()))
       (cond ((= i limit)
-	     (list->string (reverse! r)))
+	     (list->string (reverse r)))
 	    ((char=? (string-ref template i) #\@)
 	     (let ((k (- (char->integer (string-ref template (+ i 1)))
 			 (char->integer #\0))))