a cig for the new FFI
This commit is contained in:
marting
parent
09136048ae
commit
77f21395fd
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
@ -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);
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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);
|
||||
}
|
||||
}
|
||||
Loading…
Reference in New Issue