a cig for the new FFI

cig/image2script

@@ -0,0 +1,48 @@
+#!/bin/sh -
+
+binary=$1
+shift
+
+if [ `echo $binary | wc -c` -gt 28 ] ; then
+    echo "#!/bin/sh -"
+    echo exec $binary $* -i '"$0"' '"$@"'
+
+elif [ $# -gt 0 ] ; then
+    echo '#!'$binary \\
+    echo $* -i
+
+else echo '#!'$binary -i
+fi
+
+exec cat
+
+
+# This program reads an S48 image from stdin and turns it into
+# an executable by prepending a #! prefix. The vm and its
+# args are passed to this program on the command line.
+#
+# If the vm binary is 27 chars or less, then we can directly
+# execute the vm with one of these scripts:
+#     No args:
+#         image2script /usr/local/bin/svm <image
+#     outputs this script:
+#	  #!/usr/local/bin/svm -i
+#	  ...image bits follow...
+#    
+#     Args:
+#         image2script /usr/bin/svm -h 4000000 -o /usr/bin/svm <image
+#     outputs this script:
+#	  #!/usr/bin/svm \
+#	  -h 4000000 -o /usr/bin/svm -i
+#	  ...image bits follow...
+#
+# The exec system call won't handle the #! line if it contains more than
+# 32 chars, so if the vm binary is over 28 chars, we have to use a /bin/sh
+# trampoline.
+#     image2script /user1/lecturer/shivers/vc/scsh/s48/lib/svm -h 4000000 < ...
+# outputs this script:
+#     #!/bin/sh -
+#     exec /user1/lecturer/shivers/vc/scsh/s48/lib/svm -h 4000000 -i $0 $*
+#     ...image bits follow...
+#
+# 	-Olin

cig/libcig.c

@@ -0,0 +1,86 @@
+/* This is an Scheme48/C interface file, 
+** automatically generated by cig.
+*/
+
+#include <stdio.h>
+#include <stdlib.h> /* For malloc. */
+#include "libcig.h"
+
+scheme_value df_strlen_or_false(long nargs, scheme_value *args)
+{
+    extern scheme_value strlen_or_false(const char * );
+    scheme_value ret1;
+    scheme_value r1;
+
+    cig_check_nargs(1, nargs, "strlen_or_false");
+    r1 = strlen_or_false((const char * )AlienVal(args[0]));
+    ret1 = r1;
+    return ret1;
+    }
+
+scheme_value df_cstring_nullp(long nargs, scheme_value *args)
+{
+    extern int cstring_nullp(const char * );
+    scheme_value ret1;
+    int r1;
+
+    cig_check_nargs(1, nargs, "cstring_nullp");
+    r1 = cstring_nullp((const char * )AlienVal(args[0]));
+    ret1 = ENTER_BOOLEAN(r1);
+    return ret1;
+    }
+
+scheme_value df_c2scheme_strcpy_free(long nargs, scheme_value *args)
+{
+    extern int c2scheme_strcpy_free(scheme_value , char* );
+    scheme_value ret1;
+    int r1;
+
+    cig_check_nargs(2, nargs, "c2scheme_strcpy_free");
+    r1 = c2scheme_strcpy_free(args[1], (char* )AlienVal(args[0]));
+    ret1 = ENTER_BOOLEAN(r1);
+    return ret1;
+    }
+
+scheme_value df_c2scheme_strcpy(long nargs, scheme_value *args)
+{
+    extern int c2scheme_strcpy(scheme_value , char* );
+    scheme_value ret1;
+    int r1;
+
+    cig_check_nargs(2, nargs, "c2scheme_strcpy");
+    r1 = c2scheme_strcpy(args[1], (char* )AlienVal(args[0]));
+    ret1 = ENTER_BOOLEAN(r1);
+    return ret1;
+    }
+
+scheme_value df_c_veclen(long nargs, scheme_value *args)
+{
+    extern scheme_value c_veclen(long* );
+    scheme_value ret1;
+    scheme_value r1;
+
+    cig_check_nargs(1, nargs, "c_veclen");
+    r1 = c_veclen((long* )AlienVal(args[0]));
+    ret1 = r1;
+    return ret1;
+    }
+
+scheme_value df_free(long nargs, scheme_value *args)
+{
+    
+
+    cig_check_nargs(1, nargs, "free");
+    free((void* )AlienVal(args[0]));
+    return SCHFALSE;
+    }
+
+scheme_value df_set_strvec_carriers(long nargs, scheme_value *args)
+{
+    extern void set_strvec_carriers(scheme_value , char** );
+
+    cig_check_nargs(2, nargs, "set_strvec_carriers");
+    set_strvec_carriers(args[1], (char** )AlienVal(args[0]));
+    return SCHFALSE;
+    }
+

cig/libcig.h

@@ -0,0 +1,24 @@
+#include "scheme48.h"
+
+/* StobData is used by fdports.c. It should be changed over to STOB_REF
+** by removing the extra indirection. */
+#define StobData(x) (S48_ADDRESS_AFTER_HEADER(x, s48_value))
+
+#define IsChar(x) ((((long) x) & 0xff) == S48_CHAR) 
+//JMG: untested !!
+
+#define StrByte(x, i)  ((i) + S48_ADDRESS_AFTER_HEADER((x), char))
+// JMG: #define cig_string_body(x) (S48_ADDRESS_AFTER_HEADER((x), char))
+
+#define AlienVal(x) (STOB_REF((x),0))
+
+extern char *scheme2c_strcpy(s48_value sstr);
+
+extern s48_value strlen_or_false(const char *s);
+
+extern char *copystring_or_die(const char *);
+extern char *copystring(char *, const char *);
+
+extern s48_value strlen_or_false(const char *);
+
+extern void cig_check_nargs(int arity, int nargs, const char *fn);

cig/libcig.scm

@@ -0,0 +1,138 @@
+;;; (DEFINE-FOREIGN ...) forms are expanded by Cig into Scheme stubs.
+;;; These stubs reference some support procedures to rep-convert the
+;;; standard reps (e.g., string). This structure provides these support 
+;;; procedures.
+;;;
+;;; We export three kinds of things:
+;;; - Type predicates that aren't in the R4RS env (e.g., FIXNUM?).
+;;; - Carrier makers for making boxes to return things in.
+;;; - Scheme-side rep-converters for return values.
+
+(define-structure cig-aux
+  (export cstring-null?
+	  C->scheme-string
+	  C->scheme-string-w/len
+	  C->scheme-string-w/len-no-free
+	  C-string-vec->Scheme&free
+	  C-string-vec->Scheme ; Bogus, because clients not reentrant.
+	  string-carrier->string
+	  string-carrier->string-no-free
+	  fixnum?
+	  make-string-carrier
+	  make-alien
+	  alien?
+	  )
+  (open scheme code-vectors define-foreign-syntax)
+
+  (begin
+    (define min-fixnum (- (expt 2 29)))
+    (define max-fixnum (- (expt 2 29) 1))
+    (define (fixnum? x) (and (integer? x) (<= min-fixnum x max-fixnum)))
+
+    ;; Internal utility.
+    (define (mapv! f v)
+      (let ((len (vector-length v)))
+	(do ((i 0 (+ i 1)))
+	    ((= i len) v)
+	  (vector-set! v i (f (vector-ref v i))))))
+
+    ;; Make a carrier for returning strings. 
+    ;; It holds a raw C string and a fixnum giving the length of the string.
+    (define (make-string-carrier) (cons (make-alien) 0))
+
+    (define (make-alien) (make-code-vector 4 0))
+    (define (alien? x) (and (code-vector? x) (= 4 (code-vector-length x)))) ; BOGUS
+
+
+;;; C/Scheme string and vector conversion
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Generally speaking, in the following routines, 
+;;; a NULL C string param causes a function to return #f.
+
+(define-foreign %cstring-length-or-false
+  (strlen_or_false ((C "const char * ~a") cstr))
+  desc)
+
+(define-foreign cstring-null?
+  (cstring_nullp ((C "const char * ~a") cstr))
+  bool)
+
+(define-foreign %copy-c-string&free
+  (c2scheme_strcpy_free (string-desc sstr) ((C char*) cstr))
+  bool)
+
+(define-foreign %copy-c-string
+  (c2scheme_strcpy (string-desc sstr) ((C char*) cstr))
+  bool)
+
+(define (C->scheme-string cstr)
+  (cond ((%cstring-length-or-false cstr)
+	 => (lambda (strlen)
+	      (let ((str (make-string strlen)))
+		(%copy-c-string&free str cstr)
+		str)))
+	(else #f)))
+
+(define (C->scheme-string-w/len cstr len)
+  (and (integer? len)
+       (let ((str (make-string len)))
+	 (%copy-c-string&free str cstr)
+	 str)))
+
+(define (C->scheme-string-w/len-no-free cstr len)
+  (and (integer? len)
+       (let ((str (make-string len)))
+	 (%copy-c-string str cstr)
+	 str)))
+
+(define (string-carrier->string carrier)
+  (C->scheme-string-w/len (car carrier) (cdr carrier)))
+
+(define (string-carrier->string-no-free carrier)
+  (C->scheme-string-w/len-no-free (car carrier) (cdr carrier)))
+
+;;; Return the length of a null-terminated C word vector. 
+;;; Does not count the null word as part of the length.
+;;; If vector is NULL, returns #f.
+
+(define-foreign %c-veclen-or-false
+  (c_veclen ((C long*) c-vec))
+  desc) ; integer or #f if arg is NULL.
+
+;;; CVEC is a C vector of char* strings, length VECLEN.
+;;; This procedure converts a C vector of strings into a Scheme vector of 
+;;; strings. The C vector and its strings are all assumed to come from
+;;; the malloc heap; they are returned to the heap when the rep-conversion
+;;; is done.
+;;;
+;;; Hack: if VECLEN is #f, CVEC is assumed to be NULL terminated, and
+;;; its length is calculated thusly.
+
+(define (C-string-vec->Scheme&free cvec veclen)
+  (let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0))))
+    (mapv! (lambda (ignore) (make-string-carrier)) vec)
+    (%set-string-vector-carriers! vec cvec)
+    (C-free cvec)
+    (mapv! string-carrier->string vec)))
+
+(define (C-string-vec->Scheme cvec veclen) ; No free.
+  (let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0))))
+    (mapv! (lambda (ignore) (make-string-carrier)) vec)
+    (%set-string-vector-carriers! vec cvec)
+    (mapv! string-carrier->string-no-free vec)))
+
+
+(define-foreign C-free (free ((C void*) ptr)) no-declare ; for SunOS 4.x 
+  ignore)
+
+(define-foreign %set-string-vector-carriers!
+  (set_strvec_carriers (vector-desc svec) ((C char**) cvec))
+  ignore)
+
+)) ; egakcap
+
+
+
+
+

cig/libcig1.c

@@ -0,0 +1,149 @@
+/* Generic routines for Scheme48/C interfacing -- mostly for converting
+** strings and null-terminated vectors back and forth.
+** Copyright (c) 1993 by Olin Shivers.
+*/
+
+#include "libcig.h"
+#include <string.h>
+#include <stddef.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#define Malloc(type,n)	((type *) malloc(sizeof(type)*(n)))
+#define Free(p)		(free((char *)(p)))
+
+/* (c2scheme_strcpy dest_scheme_string source_C_string)
+** Copies C string's chars into Scheme string. Return #t.
+** If C string is NULL, do nothing and return #f.
+*/
+
+int c2scheme_strcpy(scheme_value sstr, const char *cstr)
+{
+    if( cstr ) {
+	strncpy( (char*) StobData(sstr), cstr, STRING_LENGTH(sstr) );
+	return 1;
+	}
+    else return 0;
+    }
+
+
+/* Same as above, but free the C string when we are done. */
+int c2scheme_strcpy_free(scheme_value sstr, const char *cstr)
+{
+    if( cstr ) {
+	strncpy( (char*) StobData(sstr), cstr, STRING_LENGTH(sstr) );
+	Free(cstr);
+	return 1;
+	}
+    else return 0;
+    }
+
+char *scheme2c_strcpy(scheme_value sstr)
+{
+    char *result;
+    int slen;
+    extern int errno;
+
+    slen = STRING_LENGTH(sstr);
+    result = Malloc(char, slen+1);
+
+    if( result == NULL ) {
+        fprintf(stderr,
+		"Fatal error: C stub tried to copy Scheme string,\n"
+		"but malloc failed on arg 0x%x, errno %d.\n",
+		sstr, errno);
+	exit(-1);
+	}
+
+    memcpy(result, cig_string_body(sstr), slen);
+    result[slen] = '\000';
+    return result;
+    }
+
+
+/*  One arg, a zero-terminated C word vec. Returns length.
+**  The terminating null is not counted. Returns #f on NULL.
+*/
+
+scheme_value c_veclen(const long *vec)
+{
+    const long *vptr = vec;
+    if( !vptr ) return SCHFALSE;
+    while( *vptr ) vptr++;
+    return ENTER_FIXNUM(vptr - vec);
+    }
+    
+
+/* Copy string from into string to. If to is NULL, malloc a fresh string
+** (if the malloc loses, return NULL).
+** If from is NULL, then
+** - if to is NULL, do nothing and return NULL.
+** - Otherwise, deposit a single nul byte.
+** Under normal conditions, this routine returns the destination string.
+**
+** The little boundary cases of this procedure are a study in obfuscation
+** because C doesn't have a reasonable string data type. Give me a break.
+*/
+char *copystring(char *to, const char *from)
+{
+    if( from ) {
+	int slen = strlen(from)+1;
+	if( !to && !(to = Malloc(char, slen)) ) return NULL;
+	else return memcpy(to, from, slen);
+	}
+
+    else
+	return to ? *to = '\000', to : NULL;
+    }
+
+/* As in copystring, but if malloc loses, print out an error msg and croak. */
+char *copystring_or_die(const char *str ) /* Note: NULL -> NULL. */
+{
+    if( str ) {
+	int len = strlen(str)+1;
+	char *new_str = Malloc(char, len);
+	if( ! new_str ) {
+	    fprintf(stderr, "copystring: Malloc failed.\n");
+	    exit(-1);
+	    }
+	return memcpy(new_str, str, len);
+	}
+    else return NULL;
+    }
+
+int cstring_nullp( const char *s ) { return ! s; }
+
+scheme_value strlen_or_false(const char *s)
+{ return s ?  ENTER_FIXNUM(strlen(s)) : SCHFALSE; }
+
+
+
+/* svec is a Scheme vector of C string carriers. Scan over the C strings
+** in cvec, and initialise the corresponding string carriers in svec.
+*/
+void set_strvec_carriers(scheme_value svec, char const * const * cvec)
+{
+    int svec_len = VECTOR_LENGTH(svec);
+    char const * const * cv = cvec;
+    scheme_value *sv = &VECTOR_REF(svec,0);
+
+    for(; svec_len > 0; cv++, sv++, svec_len-- ) {
+	/* *sv is a (cons (make-alien <c-string>) <string-length>). */
+	scheme_value carrier = *sv;
+	scheme_value alien = CAR(carrier);
+	CDR(carrier) = ENTER_FIXNUM(strlen(*cv));
+	AlienVal(alien) = (long) *cv;
+	}
+    }
+
+/* Helper function for arg checking. Why bother, actually? */
+void cig_check_nargs(int arity, int nargs, const char *fn)
+{
+   if( arity != nargs ) {
+       fprintf(stderr,
+	       "Cig fatal error (%s) -- C stub expected %d arg%s, "
+	       "but got %d.\n",
+	       fn, arity, (arity == 1) ? "" : "s", nargs);
+       exit(-1);
+       }
+   }