diff --git a/cig/cig.scm b/cig/cig.scm new file mode 100644 index 0000000..a0a00d2 --- /dev/null +++ b/cig/cig.scm @@ -0,0 +1,1077 @@ +;;; This file defines the cig foreign function interface for Scheme 48. +;;; The current version is Cig 3.0. +;;; This file contains the following Scheme 48 modules: +;;; - cig-processor +;;; The code for translating DEFINE-FOREIGN forms into C stubs. +;;; - cig-standalone +;;; The S48 top-level for translating stdin->stdout. +;;; - define-foreign-syntax-support +;;; This package must be opened in the FOR-SYNTAX package, +;;; so that the DEFINE-FOREIGN macro-expander code can use it's procedures. +;;; - define-foreign-syntax +;;; This package must be opened by cig's clients, to access the +;;; DEFINE-FOREIGN and FOREIGN-INCLUDE macros. +;;; +;;; Copyright (c) 1994 by Olin Shivers. + +(define-structures ((cig-processor (export process-define-foreign-file + process-define-foreign-stream)) + (cig-standalone (export cig-standalone-toplevel)) + + ;; This must be opened in the FOR-SYNTAX package. + (define-foreign-syntax-support + (export define-foreign-expander))) + + (open scheme formats structure-refs + destructuring receiving + code-vectors) ; for making alien containers. + (access signals) ; for ERROR + (begin + (define error (structure-ref signals error)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The general syntax of define-foreign is: +;;; (define-foreign scheme-name (c-name arg1 ... argn) [no-declare] +;;; ret1 +;;; . +;;; retn) +;;; +;;; This defines a Scheme procedure, . It takes the arguments +;;; arg1 ... argn, type-checks them, and then passes them to a C stub, +;;; df_. If the Scheme procedure is to return multiple values, the C +;;; stub also gets a return vector passed to return the extra values. The C +;;; stub rep-converts the Scheme data as specified by the i declarations, +;;; and then calls the C procedure . The C procedure is expected to +;;; return its first value () as its real value. The other return values +;;; are returned by assigning targets passed by-reference to by the +;;; stub. These return parameters are passed after the argument parameters. +;;; When returns, the C stub df_ rep-converts the C data, +;;; stuffs extra return values into the Scheme answer vector if there are any, +;;; and returns to the Scheme routine. The Scheme routine completes the +;;; rep-conversion specified by the i declarations, and return the +;;; values. +;;; +;;; An ARGi spec has the form: +;;; (rep [var]) +;;; where REP gives the representation of the value being passed (see +;;; below), and VAR is the name of the Scheme procedure's parameter (for +;;; documentation purposes, mostly). +;;; +;;; The optional symbol NO-DECLARE means "Do not place an extern declaration +;;; of the C routine in the body of the stub." This is necessary for the +;;; occasional strange ANSI C declaration that cig is incapable of generating +;;; (the only case I know of where the C procedure uses varargs, so the C +;;; declaration needs a ..., e.g., +;;; extern int open(const char *, int flags, ...); +;;; In this case, just use NO-DECLARE, and insert your own a declaration of open() +;;; outside the stub with a +;;; (foreign-source "extern int open(const char *, int flags, ...);") +;;; Ugly, yes.) +;;; +;;; The rep-conversion specs are pretty hairy and baroque. I kept throwing +;;; in machinery until I was able to handle all the Unix syscalls, so that +;;; is what drove the complexity level. See syscalls.scm for examples. + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; The fields of a rep record for argument reps: +;;; Scheme-pred: +;;; A Scheme predicate for type-testing args. #f means no check. +;;; C-decl: +;;; A C declaration for the argument in its C representation -- +;;; the type of the value actually passed to or returned from the foreign +;;; function. This is a format string; the ~a is where the C variable goes. +;;; (format #f c-decl "") is used to compute a pure type -- e.g., for +;;; casts. +;;; C-cvtr: +;;; The Scheme->C rep-converter; a string. Applied as a C +;;; function/macro in the stub. The empty string means the null +;;; rep-conversion. +;;; Post-C: +;;; Optional post-call processing in the C stub; a string like C-cvtr. +;;; If not #f, this form will be applied in the C stub to the C argument +;;; value *after* the C call returns. It is mostly used to free a +;;; block of storage that was malloc'd by the rep converter on the +;;; way in. + +(define (argrep:c-decl i) (vector-ref i 0)) +(define (argrep:scheme-pred i) (vector-ref i 1)) +(define (argrep:c-cvtr i) (vector-ref i 2)) +(define (argrep:post-C i) (vector-ref i 3)) + + +;;; The fields of a rep record for return reps: +;;; C-decl: +;;; As above. +;;; immediate?: +;;; If the return value is to be boxed into a carrier passed in from +;;; Scheme, then this is #f. If this value is a true value, then the +;;; C value is to be rep-converted into an immediate Scheme value. +;;; In this case, the immediate? field is a string, naming the C +;;; function/macro used to do the rep-conversion. +;;; C-boxcvtr: +;;; If immediate? is false, then this value specifies the C code +;;; for rep-converting the return value into the Scheme carrier. +;;; It is a procedure, which is called on two string arguments: +;;; a C variable bound to the carrier, and a C variable bound to +;;; the C return value. The procedure returns a string which is a +;;; C statement for doing the rep-conversion. To pass a raw C value +;;; back, for instance, you would use the following box converter: +;;; (lambda (carrier c-val) (string-append carrier "=" c-val ";")) +;;; make-carrier: +;;; A procedure that when called returns a carrier. This field is only +;;; used if immediate? is #f. This field is a Scheme expression. +;;; S-cvtr +;;; This is a Scheme form that is applied to the rep-converted value passed +;;; back from the C stub. Its value is the actual return value returned to +;;; Scheme. #f means just pass a single value back as-is. This is mostly +;;; used for string hacking. This field is a Scheme expression. + +(define (retrep:c-decl i) (vector-ref i 0)) +(define (retrep:immediate i) (vector-ref i 1)) +(define (retrep:C-boxcvtr i) (vector-ref i 2)) +(define (retrep:make-carrier i) (vector-ref i 3)) +(define (retrep:s-cvtr i) (vector-ref i 4)) + +;;; Works for both argrep-info and retrep-info nodes. +(define (rep:c-decl i) (vector-ref i 0)) + +;;; The Scheme-pred field in this table is a symbol that is syntactically +;;; closed in the macro expander's environment, so the user won't lose +;;; if he should accidentally bind INTEGER? to something unusual, and +;;; then try a DEFINE-FOREIGN. +(define *simple-argrep-alist* '( + + (char #("char ~a" char? "EXTRACT_CHAR" #f)) + (bool #("int ~a" #f "EXTRACT_BOOLEAN" #f)) + + (integer #("int ~a" integer? "s48_extract_fixnum" #f)) + (short_u #("unsigned short ~a" integer? "s48_extract_fixnum" #f)) + (size_t #("size_t ~a" integer? "s48_extract_fixnum" #f)) + (mode_t #("mode_t ~a" integer? "s48_extract_fixnum" #f)) + (gid_t #("gid_t ~a" integer? "s48_extract_fixnum" #f)) + (uid_t #("uid_t ~a" integer? "s48_extract_fixnum" #f)) + (off_t #("off_t ~a" integer? "s48_extract_fixnum" #f)) + (pid_t #("pid_t ~a" integer? "s48_extract_fixnum" #f)) + (uint_t #("unsigned int ~a" integer? "s48_extract_fixnum" #f)) + (long #("long ~a" integer? "s48_extract_fixnum" #f)) + (fixnum #("int ~a" fixnum? "s48_extract_fixnum" #f)) + + (desc #("s48_value ~a" #f "" #f)) + (string-desc #("s48_value ~a" string? "" #f)) + (char-desc #("s48_value ~a" char? "" #f)) + (integer-desc #("s48_value ~a" integer? "" #f)) + (vector-desc #("s48_value ~a" vector? "" #f)) + (pair-desc #("s48_value ~a" pair? "" #f)) + + (string #("const char *~a" string? "s48_extract_string" #f)) + + (var-string #("char *~a" string? "s48_extract_string" #f)) + + (string-copy #("char *~a" string? "scheme2c_strcpy" #f)))) + +;;; Emit C code to copy a C string into its carrier. +(define (str-and-len->carrier carrier str) + (format #f + "{SetAlienVal(CAR(~a),(long) ~a); SET_CDR(~a,strlen_or_false(~a));}" + carrier str carrier str)) + +;;; Carrier and assignment-generator for alien values: +(define (simple-assign carrier val) + (format #f "SetAlienVal(~a,(long) ~a);" carrier val)) + +;;; Note: When MAKE-CARRIER and S-CVTR fields are taken from this table, +;;; they are symbols that are syntactically closed in the macro expander's +;;; environment by using the expander's rename procedure. This ensures that +;;; even if the user accidentally binds his own MAKE-ALIEN identifier, +;;; he won't clobber the Scheme stub's use of this MAKE-ALIEN procedure. + +(define *simple-retrep-alist* `( + + ;; All the immediate ones (we are sleazing on ints for now). + (char #("char ~a" "s48_enter_char" #f #f #f)) + (bool #("int ~a" "ENTER_BOOLEAN" #f #f #f)) ;; JMG c and bool: + ; s48 knows nothing about this I think + + (integer #("int ~a" "s48_enter_fixnum" #f #f #f)) + (fixnum #("int ~a" "s48_enter_fixnum" #f #f #f)) + (short_u #("unsigned short ~a" "s48_enter_fixnum" #f #f #f)) + (size_t #("size_t ~a" "s48_enter_fixnum" #f #f #f)) + (mode_t #("mode_t ~a" "s48_enter_fixnum" #f #f #f)) + (gid_t #("gid_t ~a" "s48_enter_fixnum" #f #f #f)) + (uid_t #("uid_t ~a" "s48_enter_fixnum" #f #f #f)) + (off_t #("off_t ~a" "s48_enter_fixnum" #f #f #f)) + (pid_t #("pid_t ~a" "s48_enter_fixnum" #f #f #f)) + (uint_t #("unsigned int ~a" "s48_enter_fixnum" #f #f #f)) + (long #("long ~a" "s48_enter_fixnum" #f #f #f)) + + (desc #("s48_value ~a" "" #f #f #f)) + (string-desc #("s48_value ~a" "" #f #f #f)) + (char-desc #("s48_value ~a" "" #f #f #f)) + (integer-desc #("s48_value ~a" "" #f #f #f)) + (vector-desc #("s48_value ~a" "" #f #f #f)) + (pair-desc #("s48_value ~a" "" #f #f #f)) + + (string #("const char *~a" #f ,str-and-len->carrier make-string-carrier + string-carrier->string)) + + (var-string #("char *~a" #f ,str-and-len->carrier make-string-carrier + string-carrier->string)) + + (string-length #("char *~a" "strlen_or_false" #f #f #f)) + + (static-string #("char *~a" #f ,str-and-len->carrier make-string-carrier + string-carrier->string-no-free)))) + +;;; String reps: +;;; ----------- +;;; - STRING-COPY +;;; Parameter only. The C routine is given a private, malloc'd C string. +;;; The string is not freed when the routine returns. +;;; +;;; - STRING +;;; Parameter: The C routine is given a C string that it should not alter +;;; or retain beyond the end of the routine. Right now, the Scheme string +;;; is copied to a malloc'd C temporary, which is freed after the routine +;;; returns. Later, we'll just pass a pointer into the actual Scheme +;;; string, as soon as Richard fixes the S48 string reps. +;;; Ret value: The C string is from malloc'd storage. Convert it to a +;;; Scheme string and free the C string. +;;; +;;; - STRING-LENGTH +;;; Return-value only. Return the length of the C string, as a fixnum. +;;; +;;; - STATIC-STRING +;;; Return-value only. The C string is not freed after converting it to +;;; to a Scheme string. +;;; +;;; - VAR-STRING +;;; Same as STRING, but C type is declared char* instead of const char*. +;;; Used to keep some broken system call include files happy. + +;;; Parameter reps: +;;; - A simple rep is simply the name of a record in the rep table. +;;; e.g., integer, string +;;; - (REP scheme-pred c-decl to-c [free?]) +;;; A detailed spec, as outlined above. SCHEME-PRED is a procedure or #f. +;;; C-DECL is a format string (or a symbol). TO-C is a format string +;;; (or a symbol). +;;; - (C type) +;;; The argument is a C value, passed with no type-checking +;;; or rep-conversion. TYPE is a format string (or a symbol). + +;;; A return-value rep is: +;;; - A simple rep, as above. +;;; - (MULTI-REP rep1 ... repn) +;;; The single value returned from the C function is rep-converted +;;; n ways, each resulting in a distinct return value from Scheme. +;;; - (TO-SCHEME rep c->scheme) +;;; Identical to REP, but use the single C->SCHEME form for the return +;;; rep-conversion in the C stub. There is no POST-SCHEME processing. This +;;; allows you to use a special rep-converter on the C side, but otherwise +;;; use all the properties of some standard rep. C->SCHEME is a string (or +;;; symbol). +;;; - (C type) +;;; Returns a raw C type. No rep-conversion. TYPE is a C type, represented +;;; as a string (or a symbol). + +;;; C Short-hand: +;;; Things that go in the C code are usually specified as strings, +;;; since C is case-sensitive, and Scheme symbols are not. However, +;;; as a convenient short-hand, symbols may also be used -- they +;;; are mapped to strings by lower-casing their print names. This +;;; applies to the TO-C part of (REP ...) and the C->SCHEME part of +;;; TO-SCHEME. +;;; +;;; Furthermore, C declarations (the TYPE part of (C ...) and the C-DECL part +;;; of (REP ...)) can be either a format string (e.g., "char ~a[]"), or a +;;; symbol (double). A symbol is converted to a string by lower-casing it, and +;;; appending " ~a", so the symbol double is just convenient short-hand for +;;; the C declaration "double ~a". +;;; +;;; Examples: (rep integer? int "EXTRACT_FIXNUM") +;;; (C char*) +;;; (C "int ~a[10]") +;;; (to-scheme integer "HackInt") +;;; +;;; These shorthand forms are not permitted in the actual rep tables; +;;; only in DEFINE-FOREIGN forms. + +;;; Note: the RENAME procedure is for use by the Scheme-stub macro expander +;;; when taking SCHEME-PRED fields from the simple-rep internal table. This +;;; way, the user's bindings of variables won't interfere with the functioning +;;; of the simple reps. When Cig's C-stub generator calls this procedure, it +;;; should just pass the identity procedure for the RENAME argument. + +(define (parameter-rep->info rep rename) + (let* ((hack (lambda (x) + (if (symbol? x) (string-append (symbol->string x) " ~a") + x))) + (do-rep (lambda (scheme-pred C-decl C-cvtr . maybe-post-C) + (vector (hack C-decl) scheme-pred (stringify C-cvtr) + (and (pair? maybe-post-C) (car maybe-post-C))))) + (you-lose (lambda () (error "Unknown parameter rep" rep)))) + + (cond ((symbol? rep) + (cond ((assq rep *simple-argrep-alist*) => + (lambda (entry) + (let* ((info (copy-vector (cadr entry))) + (scheme-pred (argrep:scheme-pred info))) + (vector-set! info 1 (and scheme-pred (rename scheme-pred))) + info))) + + (else (you-lose)))) + + ((pair? rep) + (case (car rep) + ((rep) (apply do-rep (cdr rep))) + ((C) (let* ((c-decl (hack (cadr rep))) + (c-type (format #f c-decl ""))) + (do-rep (rename 'alien?) c-decl + (format #f "(~a)AlienVal" c-type) + #f))) + (else (you-lose)))) + (else (you-lose))))) + +(define (copy-vector v) + (let* ((vlen (vector-length v)) + (v-new (make-vector vlen))) + (do ((i (- vlen 1) (- i 1))) + ((< i 0) v-new) + (vector-set! v-new i (vector-ref v i))))) + +(define (stringify x) + (if (symbol? x) + (list->string (map char-downcase (string->list (symbol->string x)))) + x)) + +;;; Fields are as follows: +;;; c-decl: 0, immediate: 1, C-boxcvtr: 2, make-carrier: 3, s-cvtr: 4 + +;;; Return a list of reps (because of MULTI-REP). +;;; The RENAME arg is for the Scheme-side macro expander, so that +;;; the make-carrier and s-cvtr fields can be syntactically closed +;;; in the expander's environment. The C-stub generator should just +;;; pass an identity procedure for RENAME. + +(define (return-rep->info rep rename) + (let* ((hack (lambda (x) + (if (symbol? x) + (string-append (symbol->string x) " ~a") + x))) + (do-rep (lambda (c-decl . to-scheme) + (list (vector (hack c-decl) (list to-scheme) '() #f)))) + (you-lose (lambda () (error "Unknown return rep" rep))) + + (infos (cond ((symbol? rep) + (cond ((assq rep *simple-retrep-alist*) => + (lambda (entry) + ;; Apply RENAME to make-carrier and s-cvtr. + (let* ((info (copy-vector (cadr entry))) + (make-carrier (retrep:make-carrier info)) + (s-cvtr (retrep:s-cvtr info))) + (vector-set! info 3 + (and make-carrier + (rename make-carrier))) + (vector-set! info 4 + (and s-cvtr (rename s-cvtr))) + (list info)))) + (else (you-lose)))) + + ((pair? rep) + (case (car rep) + ((rep) + (let ((v (apply vector rep))) + (vector-set! v 0 (hack (vector-ref v 0))) + (list v))) + ((to-scheme) ; (to-scheme rep converter) + (let* ((v (car (return-rep->info (cadr rep) rename))) + (v (copy-vector v))) + (vector-set! v 1 (stringify (caddr rep))) + (vector-set! v 2 '#f) + (vector-set! v 3 '#f) + (vector-set! v 4 '#f) + (list v))) + ((C) (list (vector (hack (cadr rep)) #f + simple-assign (rename 'make-alien) + #f))) + ((multi-rep) + (apply append (map (lambda (rep) + (return-rep->info rep rename)) + (cdr rep)))) + (else (you-lose)))) + (else (you-lose))))) + + infos)) + +;;; Return a type string for IGNORE, or a list of lists of info vectors for +;;; the standard case. + +(define (parse-return-reps reps rename) + (cond ((or (not (pair? reps)) + (not (list? reps))) + (error "Bad return rep list" reps)) + + ;; (IGNORE c-type) or IGNORE + ((and (null? (cdr reps)) + (let ((rep (car reps))) + (or (eq? rep 'ignore) + (and (pair? rep) + (eq? (car rep) 'ignore))))) + (let ((rep (car reps))) + (if (pair? rep) (cadr rep) "void ~a"))) + + (else (map (lambda (rep) (return-rep->info rep rename)) reps)))) + +(define (insert-commas lis) + (if (pair? lis) + (cdr (let rec ((lis lis)) + (if (pair? lis) + (cons ", " (cons (car lis) (rec (cdr lis)))) + '()))) + '(""))) + +(define (elts->comma-string lis) + (apply string-append (insert-commas lis))) + +(define (info->type i . maybe-outer-type) + (let ((outer-type (if (null? maybe-outer-type) "" (car maybe-outer-type)))) + (format #f (rep:c-decl i) outer-type))) + +(define (info->var-decl i var) + (format #f "~% ~a;" ; statement-ize decl. + (format #f (rep:c-decl i) var))) ; decl-ize var. + +(define (make-gensym prefix i) + (lambda (x) + (set! i (+ i 1)) + (string-append prefix (number->string i)))) + +;;; This returns a list mapping each of the Scheme stub's args to +;;; it's corresponding name in the C stub (e.g., ("arg[2]" "arg[1]" "arg[0]")). +;;; If MV-RETURN? is true, we reserve arg[0] for the mv-return Scheme vec. +(define (make-stub-args nargs mv-return?) + (do ((i (if mv-return? 1 0) (+ i 1)) + (nargs nargs (- nargs 1)) + (ans '() (cons (format #f "args[~d]" i) ans))) + ((zero? nargs) ans))) + +(define (filter lis) + (if (pair? lis) + (let* ((head (car lis)) + (tail (cdr lis)) + (new-tail (filter tail))) + (if head (if (eq? tail new-tail) lis (cons head new-tail)) + new-tail)) + '())) + +(define nl (string #\newline)) +(define (separate-line stmt) (string-append " " stmt ";" nl)) + +;;; Apply a Scheme->C rep-converter to the C expression EXP. +(define (C-ize info exp) + (cond ((argrep:c-cvtr info) + => (lambda (s) + (if (string=? s "") exp + (string-append s "(" exp ")")))) + (else exp))) + +;;; Return a C statement rep-converting the C value VAL into the +;;; carrier CARRIER. Rep-conversion is determined by INFO. +(define (Scheme-ize->carrier info carrier val) + (cond ((retrep:C-boxcvtr info) + => (lambda (f) (f carrier val))) + (else (error "Rep is not carrier rep:" info)))) + +;;; Apply a C->Scheme rep-converter in the C stub to C expression EXP. +(define (Scheme-ize-exp converter exp) + (if (string=? converter "") exp + (string-append converter "(" exp ")"))) + +;;; If an arg needs post-C processing in the C stub, +;;; then we need to assign the arg's C rep to a variable. +;;; Return #f or " char *f3 = scm2c_string(arg[2]);" +(define (free-var-decl info fvar stub-arg) + (and (argrep:post-C info) + (format #f "~% ~a = ~a;" + (format #f (argrep:c-decl info) fvar) + (C-ize info stub-arg)))) + + +;;; Multiple return values happen across three boundaries: C routine -> C stub, +;;; C stub -> Scheme stub, and Scheme stub -> user. M.v. return happens +;;; across these boundaries sometimes for different reasons. If the +;;; C routine returns m.v., then everyone does. But even if the C routine +;;; returns just a single value, the C stub may rep-convert that multiple +;;; ways, and so need to pass multiple values back to the Scheme stub. + +;;; Nomenclature: if someone is returning 4 return values, let's call +;;; the first value returned the *major return value*, and the other three +;;; values the *minor return values*. + +;;; M.V. return linkages work like this: +;;; The C routine returns m.v.'s to the C stub by (1) returning the major value +;;; as the value of the C routine, and (2) assigning the minor return values +;;; to pointers passed to the C routine from the stub -- these pointer values +;;; are appended to the routine's parameter list after the actual arguments. +;;; That is, if the C routine needs to return an int, it will be passed +;;; an int*, which it assigns to return the int value. + +;;; If the Scheme stub is expecting N multiple values, it passes in +;;; a Scheme vector of size N-1 to the C stub. The C stub stashes the +;;; minor return values into this vector; the major value is passed back +;;; as the C stub's actual return value. This vector is always the last +;;; value passed to the C stub from the Scheme stub, so we can get it +;;; in the C stub by accessing arg[0] or just *arg (remember, the args +;;; get their order reversed during the Scheme/C transition when they +;;; are pushed on the Scheme48 stack, so the m.v. vector, being last, comes +;;; out first). +;;; +;;; If the major return value for the call requires a carrier structure, +;;; it is passed in the m.v. Scheme vector, in the first element of the +;;; vector. The carrier itself is returned as the C stub's major return value. + +;;; MAKE-MV-ASSIGNS produces the C code that puts the C stub's minor +;;; return values into the vector. For each value and each rep for that value: +;;; - If the value is the major return value: +;;; + if the value is immediate, it is rep-converted, and assigned to +;;; the variable ret1. +;;; + if the value is passed back in a carrier, the carrier is fetched +;;; from the m.v. vector's elt 0, and the value is rep-converted into +;;; this carrier. The carrier itself is assigned to ret1. +;;; - If the value is a minor return value: +;;; + if the value is immediate, it is rep-converts, and assigned to +;;; the appropriate slot in the m.v. vector. +;;; + if the value is passed back in a carrier, the carrier is fetched +;;; from the m.v. vector, and the value is rep-converted into the carrier. + +;;; Ugh. Nested looping in Scheme is like nested looping in assembler. +(define (make-mv-assigns c-vars info-lists) + (apply string-append + (let lp1 ((j 0) ; J is location in Scheme vec into which we store. + (c-vars c-vars) + (info-lists info-lists) + (assigns '())) + (if (pair? c-vars) + + (let ((v (car c-vars)) + (info-list (car info-lists)) + (c-vars (cdr c-vars)) + (info-lists (cdr info-lists))) + + ;; Loop over V's info elts in INFO-LIST + (let lp2 ((j j) + (info-list info-list) + (assigns assigns)) + (if (pair? info-list) + + ;; Do rep-conversion INFO. + (let ((info (car info-list)) + (info-list (cdr info-list))) + (receive (c-stmt j) + (if (null? assigns) + (make-major-retval-stmt v info) + (make-minor-retval-stmt v info j)) + (lp2 j info-list (cons c-stmt assigns)))) + + (lp1 j c-vars info-lists assigns)))) + + (reverse assigns))))) +;;; c-decl: 0, immediate: 1, C-boxcvtr: 2, make-carrier: 3, s-cvtr: 4 + +;;; Major ret value rep conversion. If immediate, just rep-convert & assign +;;; to ret1. If carrier, store into an alien struct and assign that to ret1. +;;; C-VAR should always be "r1". +(define (make-major-retval-stmt c-var info) + (cond ((retrep:immediate info) => + (lambda (cvtr) + (values (format #f "~% ret1 = ~a;" (Scheme-ize-exp cvtr c-var)) + 0))) + (else + (values (format #f "~% ret1 = S48_VECTOR_REF(mv_vec,0);~% ~a" + (Scheme-ize->carrier info "ret1" c-var)) + 1)))) + +;;; Minor ret value rep-conversion. +;;; Convert and store into minor-value vector at entry j. +(define (make-minor-retval-stmt c-var info j) + (values (cond ((retrep:immediate info) => + (lambda (cvtr) + (format #f "~% S48_VECTOR_SET(mv_vec,~d,~a);" + j (Scheme-ize-exp cvtr c-var)))) + (else + (let ((target (format #f "S48_VECTOR_REF(mv_vec,~d)" j))) + (format #f "~% ~a" + (Scheme-ize->carrier info target c-var))))) + (+ j 1))) + +(define (stmts strings) (apply string-append strings)) + +(define (make-post-C-var-list infos) + (do ((j 1 (+ j 1)) + (infos infos (cdr infos)) + (ans '() + (cons (let ((i (car infos))) + (and (argrep:post-C i) (format #f "f~d" j))) + ans))) + ((not (pair? infos)) (reverse ans)))) + + +;;; Compute the args part of function prototype. +(define (proto-args arg-decls) + (if (null? arg-decls) "void" ; echh + (elts->comma-string arg-decls))) + + +(define (define-foreign->C-stub form) + (destructure (( (#f scheme-name (c-name . params) . return-reps) form )) + (let* ((c-name (stringify c-name)) + (reps (map car params)) + + (no-declare? (and (pair? return-reps) + (eq? 'no-declare (car return-reps)))) + (return-reps (if no-declare? (cdr return-reps) + return-reps)) + + (params-info (map (lambda (rep) + (parameter-rep->info rep (lambda (x) x))) + reps)) + ;; A list of lists, due to MULTI-REP. + (ret-infos1 (parse-return-reps return-reps + (lambda (x) x))) + (ignore? (string? ret-infos1)) + + (ret-infos2 (if (not ignore?) ; Flatten them out. + (apply append ret-infos1))) + (ret-infos3 (if (not ignore?) ; A canonical representative + (map car ret-infos1))) ; per item. + + (primary-retval-info (if (not ignore?) (car ret-infos3))) + (primary-retval-decl-template + (if ignore? + ret-infos1 + (retrep:c-decl primary-retval-info))) + ;; The type of the value returned by the C routine, + ;; stored into the C stub's r1 variable. + (primary-retvar-decl (if ignore? "" + (format #f "~% ~a;" + (format #f primary-retval-decl-template + "r1")))) + (mv-return? (and (not ignore?) + (or (pair? (cdr ret-infos2)) + ;; Is major ret val non-immediate + (not (retrep:immediate + (caar ret-infos1)))))) + + (nargs (length reps)) + (stub-nargs (if mv-return? (+ nargs 1) nargs)) + (other-retvals (if ignore? '() (cdr ret-infos3))) + (ret-vars (map (make-gensym "r" 1) other-retvals)) + (ret-var-decls (stmts (map info->var-decl + other-retvals ret-vars))) + + ; Frank: begin + (gensym (let ((gs (make-gensym "g" 0))) + (lambda () (gs #f)))) + ; the c-stubs formal parameters are named "g1" ... "gn" + (stub-args (map (lambda (p) (gensym)) params)) + ; Frank: end + (post-C-vars (make-post-C-var-list params-info)) + (pc-var-decls (stmts (map (lambda (i v) + (if v (info->var-decl i v) "")) + params-info + post-C-vars))) + + (c-proto (proto-args (append (map info->type params-info) + (map (lambda (i) + (info->type i "*")) + other-retvals)))) + + (c-fun-decl (format #f primary-retval-decl-template + (string-append c-name "(" c-proto ")"))) + (c-fun-decl (format #f "extern ~a;" c-fun-decl)) + (c-fun-decl (if no-declare? "" c-fun-decl)) + + (pc-var-assigns (stmts (map (lambda (i fv sv) + (if fv + (format #f "~% ~a = ~a;" + fv (C-ize i sv)) + "")) + params-info + post-C-vars + stub-args))) + + (c-args (elts->comma-string (append (map (lambda (i fv sv) + (or fv (C-ize i sv))) + params-info + post-C-vars + stub-args) + (map (lambda (rv) + (string-append "&" rv)) + ret-vars)))) + (c-call (string-append c-name "(" c-args ")")) + + ;; Do the post-C-call processing in the C stub. + (post-C-val-processing + (stmts (map (lambda (v i) + (if v + (format #f "~% %a(~a);" + (argrep:post-C i) v) + "")) + post-C-vars reps))) + + + (mv-assigns (if ignore? "" + (make-mv-assigns (cons "r1" ret-vars) + ret-infos1))) + + (return-stmt (format #f "~% return ~a;" + (if ignore? "S48_FALSE" "ret1"))) + + ;; Do the call, release the free-vars, do the mv-return + ;; assignments, then return. + (epilog (if ignore? + (string-append c-call ";" post-C-val-processing return-stmt) + (string-append "r1 = " c-call ";" + post-C-val-processing + mv-assigns return-stmt)))) +; (breakpoint) + (format #f cfun-boilerplate + c-name + ; Frank: begin + ; multiple values will be returned in the c-stubs last formal parameter: + ; the vector mv_vec + (let ((args (if mv-return? (append stub-args '("mv_vec")) stub-args))) + (proto-args (map (lambda (var) (string-append "s48_value " var)) args))) + ; Frank: end + c-fun-decl + (if ignore? "" ret1-decl) + primary-retvar-decl ret-var-decls pc-var-decls + pc-var-assigns + epilog)))) + +; Frank: begin +(define cfun-boilerplate + "s48_value df_~a(~a) +{ + ~a~a~a~a~a + + ~a + ~a +} + +") +; Frank: end + +(define ret1-decl + " + s48_value ret1;") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define cfile-header-boilerplate + "/* This is an Scheme48/C interface file, +** automatically generated by cig. +*/ + +#include +#include /* For malloc. */ +#include \"libcig.h\" + +") + +; Frank: begin + +(define s48-init-boilerplate + "s48_value s48_init_~a(void) +{~a + + return S48_UNSPECIFIC; +} +") + +(define (define-foreign-process-form form oport) + ; c-names will be the list of c-names of all define-foreign-forms + (define c-names '()) + (define (define-foreign-process-form2 form) + (if (pair? form) + (case (car form) + + ((begin) + (if (list? (cdr form)) + (for-each (lambda (f) (define-foreign-process-form2 f)) + (cdr form)))) + + ((define-structure define-structures) + (if (and (pair? (cdr form)) + (list? (cddr form))) + (let ((clauses (cddr form))) + (for-each (lambda (clause) + (if (and (pair? clause) + (eq? 'begin (car clause))) + (define-foreign-process-form2 clause))) + clauses)))) + + ((define-foreign) + (let ((c-name (string-append "df_" (stringify (caaddr form))))) + (begin + (set! c-names (cons c-name c-names)) + (display (define-foreign->C-stub form) oport)))) + + ((foreign-source) + (let ((forms (cdr form))) + (if (pair? forms) + (begin (display (car forms) oport) + (map (lambda (x) + (newline oport) + (display x oport)) + (cdr forms))))))))) + (define-foreign-process-form2 form) + (reverse c-names)) + +; Frank: end + +(define (process-define-foreign-stream iport oport) + (display cfile-header-boilerplate oport) + (let lp () + (let ((form (read iport))) + (cond ((not (eof-object? form)) + (define-foreign-process-form form oport) + (lp)))))) + +; Frank: begin +; (process-define-foreign-file fname) scans file fname.scm and produces a c-stub for every +; scanned define-foreign form and places git in file fname.c. +(define (process-define-foreign-file fname) + (call-with-input-file (string-append fname ".scm") + (lambda (iport) + (call-with-output-file (string-append fname ".c") + (lambda (oport) + (begin + (display cfile-header-boilerplate oport) + (let lp ((c-names '())) + (let ((form (read iport))) + (if (eof-object? form) + (let ((register-txt + (apply + string-append + (map (lambda (c-name) + (format #f "~% S48_EXPORT_FUNCTION(~a);" c-name)) + c-names)))) + (format oport s48-init-boilerplate fname register-txt)) + (lp (append c-names (define-foreign-process-form form oport)))))))))))) +; Frank: end + +(define (cig-standalone-toplevel fname) ; ignore your args. + (process-define-foreign-file fname) + 0) + +;;; This section defines the Scheme-side macro processor. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; (define-syntax define-foreign define-foreign-expander) + +(define (define-foreign-expander form rename compare) + (destructure (( (#f scheme-name (c-name . params) . return-reps) form )) + (let* ((c-name (string-append "df_" (stringify c-name))) + + (reps (map car params)) + (params-info (map (lambda (rep) (parameter-rep->info rep rename)) + reps)) + + (return-reps (if (and (pair? return-reps) + (eq? 'no-declare (car return-reps))) + (cdr return-reps) + return-reps)) + (ret-infos1 (parse-return-reps return-reps rename)) + (ignore? (string? ret-infos1)) + + (ret-infos2 (if (not ignore?) + (apply append ret-infos1))) + (major-rep (and (not ignore?) (car ret-infos2))) + + ;; Does the Scheme stub return m.v.'s to the user? + (scheme-mv-return? (and (not ignore?) + (pair? (cdr ret-infos2)))) + + (carrier-vec? (or scheme-mv-return? + (and major-rep + (not (retrep:immediate major-rep))))) + + (carrier-veclen (if carrier-vec? + (- (length ret-infos2) + (if (retrep:immediate major-rep) 1 0)))) + + (%define (rename 'define)) + (%let (rename 'let)) + (%lambda (rename 'lambda)) + ; JMG: begin replaced external-lambda by import-lambda-definition + (%import-lambda-definition (rename 'import-lambda-definition)) + ; JMG: end + (gensym (let ((gs (make-gensym "g" -1))) + (lambda () (string->symbol (gs #f))))) + + (args (map (lambda (p) + (let ((tail (cdr p))) + (if (pair? tail) (car tail) + (gensym)))) + params)) + + (%string? (rename 'string?)) + (%char? (rename 'char?)) + (%integer? (rename 'integer?)) + (%vector? (rename 'vector?)) + (%pair? (rename 'pair?)) + (%check-arg (rename 'check-arg)) + + (rep-checker (lambda (i arg) + (cond ((argrep:scheme-pred i) => + (lambda (pred) `(,%check-arg ,pred ,arg + ,scheme-name))) + (else arg)))) + + (c-args (map rep-checker params-info args)) + (%f (rename 'f))) + + (if (not carrier-vec?) + (let* ((xcall `(,%f ,@c-args)) + (xcall (cond ((and (not ignore?) + (retrep:s-cvtr (car ret-infos2))) + => (lambda (proc) `(,proc ,xcall))) ; not hygenic + (else xcall)))) + + ; Frank: begin + ; get-external and external-call replaced: now external-lambda + ;JMG now import-lambda-definition + `(,%import-lambda-definition ,scheme-name ,args ,c-name)) +;; `(,%define ,scheme-name +;; (,%let ((,%f (,%external-lambda ,args ,c-name))) +;; (,%lambda ,args ,xcall)))) + + (let ((retarg1 (rename 'r1)) + (retarg2 (rename 'r2)) + (%make-vector (rename 'make-vector))) + `(,%define ,scheme-name + (,%import-lambda-definition ,%f ,args ,c-name) + ;; (,%let ((,%f (,%external-lambda ,args ,c-name))) + (,%lambda ,args + (,%let ((,retarg2 (,%make-vector ,carrier-veclen))) + ,@(install-carriers retarg2 ret-infos2 + (rename 'vector-set!)) + (,%let ((,retarg1 (,%f ,@c-args ,retarg2))) + (values ,@(make-values-args retarg1 retarg2 + ret-infos2 + rename))))))))))) +; Frank: end +(define (install-carriers carrier-vec ret-infos2 %vector-set!) + ;; Skip the major ret value if it doesn't require a carrier. + (let* ((major-rep (and (pair? ret-infos2) (car ret-infos2))) + (infos (if (and major-rep (retrep:immediate major-rep)) + (cdr ret-infos2) + ret-infos2))) + + (let lp ((ans '()) (infos infos) (i 0)) + (if (null? infos) ans + (let ((info (car infos)) + (infos (cdr infos))) + (if (retrep:immediate info) + (lp ans infos (+ i 1)) + (lp (cons `(,%vector-set! ,carrier-vec ,i + (,(retrep:make-carrier info))) + ans) + infos + (+ i 1)))))))) + +(define (c-arg i retarg1 retarg2 %vector-ref) + (if (zero? i) + retarg1 + `(,%vector-ref ,retarg2 ,(- i 1)))) + +(define (make-values-args arg1 carrier-vec infos rename) + (let ((%vector-ref (rename 'vector-ref)) + (do-arg (lambda (arg info) + (cond ((retrep:s-cvtr info) => + (lambda (cvtr) `(,cvtr ,arg))) + (else arg))))) + (if (null? infos) '() + (let lp ((ans (list (do-arg arg1 (car infos)))) + (i (if (retrep:immediate (car infos)) 0 1)) + (infos (cdr infos))) + (if (pair? infos) + (let* ((info (car infos)) + (arg `(,%vector-ref ,carrier-vec ,i))) + (lp (cons (do-arg arg info) ans) + (+ i 1) + (cdr infos))) + (reverse ans)))))) + +)) ; egakcap + + + +(define-structure define-foreign-syntax (export (define-foreign :syntax) + (foreign-source :syntax)) + (open scheme external-calls structure-refs cig-aux) + (access signals) ; for ERROR + (for-syntax (open scheme define-foreign-syntax-support)) + (begin + (define error (structure-ref signals error)) + + (define-syntax define-foreign define-foreign-expander) + + ;; Ignore FOREIGN-SOURCE forms. + (define-syntax foreign-source + (syntax-rules () + ((foreign-source stuff ...) #f))) + + (define (check-arg pred obj proc) + (if (not (pred obj)) + (error "check-arg" pred obj proc) + obj)) +)) ; egakcap + + +;;; Todo: "info" terminology is gone. Clean up. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/cig/image2script b/cig/image2script new file mode 100755 index 0000000..aa71f67 --- /dev/null +++ b/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 +#include /* 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; + } + diff --git a/cig/libcig.h b/cig/libcig.h new file mode 100644 index 0000000..57899f6 --- /dev/null +++ b/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); diff --git a/cig/libcig.scm b/cig/libcig.scm new file mode 100644 index 0000000..81b3bc1 --- /dev/null +++ b/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 + + + + + diff --git a/cig/libcig1.c b/cig/libcig1.c new file mode 100644 index 0000000..e58989f --- /dev/null +++ b/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 +#include +#include +#include + +#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 ) ). */ + 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); + } + }