990 lines
35 KiB
Scheme
990 lines
35 KiB
Scheme
;;; 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, <scheme-name>. It takes the arguments
|
||
;;; arg1 ... argn, type-checks them, and then passes them to a C stub,
|
||
;;; df_<c-name>. 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 <arg>i declarations,
|
||
;;; and then calls the C procedure <c-name>. The C procedure is expected to
|
||
;;; return its first value (<ret1>) as its real value. The other return values
|
||
;;; are returned by assigning targets passed by-reference to <c-name> by the
|
||
;;; stub. These return parameters are passed after the argument parameters.
|
||
;;; When <c-name> returns, the C stub df_<c-name> 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 <ret>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? "EXTRACT_FIXNUM" #f))
|
||
(short_u #("unsigned short ~a" integer? "EXTRACT_FIXNUM" #f))
|
||
(size_t #("size_t ~a" integer? "EXTRACT_FIXNUM" #f))
|
||
(mode_t #("mode_t ~a" integer? "EXTRACT_FIXNUM" #f))
|
||
(gid_t #("gid_t ~a" integer? "EXTRACT_FIXNUM" #f))
|
||
(uid_t #("uid_t ~a" integer? "EXTRACT_FIXNUM" #f))
|
||
(off_t #("off_t ~a" integer? "EXTRACT_FIXNUM" #f))
|
||
(pid_t #("pid_t ~a" integer? "EXTRACT_FIXNUM" #f))
|
||
(uint_t #("unsigned int ~a" integer? "EXTRACT_FIXNUM" #f))
|
||
(long #("long ~a" integer? "EXTRACT_FIXNUM" #f))
|
||
(fixnum #("int ~a" fixnum? "EXTRACT_FIXNUM" #f))
|
||
|
||
(desc #("scheme_value ~a" #f "" #f))
|
||
(string-desc #("scheme_value ~a" string? "" #f))
|
||
(char-desc #("scheme_value ~a" char? "" #f))
|
||
(integer-desc #("scheme_value ~a" integer? "" #f))
|
||
(vector-desc #("scheme_value ~a" vector? "" #f))
|
||
(pair-desc #("scheme_value ~a" pair? "" #f))
|
||
|
||
(string #("const char *~a" string? "cig_string_body" #f))
|
||
|
||
(var-string #("char *~a" string? "cig_string_body" #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
|
||
"{AlienVal(CAR(~a)) = (long) ~a; CDR(~a) = strlen_or_false(~a);}"
|
||
carrier str carrier str))
|
||
|
||
;;; Carrier and assignment-generator for alien values:
|
||
(define (simple-assign carrier val)
|
||
(format #f "AlienVal(~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" "ENTER_CHAR" #f #f #f))
|
||
(bool #("int ~a" "ENTER_BOOLEAN" #f #f #f))
|
||
|
||
(integer #("int ~a" "ENTER_FIXNUM" #f #f #f))
|
||
(fixnum #("int ~a" "ENTER_FIXNUM" #f #f #f))
|
||
(short_u #("unsigned short ~a" "ENTER_FIXNUM" #f #f #f))
|
||
(size_t #("size_t ~a" "ENTER_FIXNUM" #f #f #f))
|
||
(mode_t #("mode_t ~a" "ENTER_FIXNUM" #f #f #f))
|
||
(gid_t #("gid_t ~a" "ENTER_FIXNUM" #f #f #f))
|
||
(uid_t #("uid_t ~a" "ENTER_FIXNUM" #f #f #f))
|
||
(off_t #("off_t ~a" "ENTER_FIXNUM" #f #f #f))
|
||
(pid_t #("pid_t ~a" "ENTER_FIXNUM" #f #f #f))
|
||
(uint_t #("unsigned int ~a" "ENTER_FIXNUM" #f #f #f))
|
||
(long #("long ~a" "ENTER_FIXNUM" #f #f #f))
|
||
|
||
(desc #("scheme_value ~a" "" #f #f #f))
|
||
(string-desc #("scheme_value ~a" "" #f #f #f))
|
||
(char-desc #("scheme_value ~a" "" #f #f #f))
|
||
(integer-desc #("scheme_value ~a" "" #f #f #f))
|
||
(vector-desc #("scheme_value ~a" "" #f #f #f))
|
||
(pair-desc #("scheme_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 = VECTOR_REF(*args,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)
|
||
(let ((target (format #f "VECTOR_REF(*args,~d)" j)))
|
||
(values (cond ((retrep:immediate info) =>
|
||
(lambda (cvtr)
|
||
(format #f "~% ~a = ~a;"
|
||
target (Scheme-ize-exp cvtr c-var))))
|
||
(else
|
||
(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)))
|
||
|
||
;; List of the form ("arg[2]" "arg[1]" "arg[0]").
|
||
(stub-args (make-stub-args nargs mv-return?))
|
||
|
||
(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? "SCHFALSE" "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
|
||
c-fun-decl
|
||
(if ignore? "" ret1-decl)
|
||
primary-retvar-decl ret-var-decls pc-var-decls
|
||
stub-nargs c-name
|
||
pc-var-assigns
|
||
epilog))))
|
||
|
||
(define cfun-boilerplate
|
||
"scheme_value df_~a(long nargs, scheme_value *args)
|
||
{
|
||
~a~a~a~a~a
|
||
|
||
cig_check_nargs(~d, nargs, \"~a\");~a
|
||
~a
|
||
}
|
||
|
||
")
|
||
|
||
(define ret1-decl
|
||
"
|
||
scheme_value ret1;")
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
(define cfile-header-boilerplate
|
||
"/* This is an Scheme48/C interface file,
|
||
** automatically generated by cig.
|
||
*/
|
||
|
||
#include <stdio.h>
|
||
#include <stdlib.h> /* For malloc. */
|
||
#include \"libcig.h\"
|
||
|
||
")
|
||
|
||
(define (define-foreign-process-form form oport)
|
||
(if (pair? form)
|
||
(case (car form)
|
||
|
||
((begin)
|
||
(if (list? (cdr form))
|
||
(for-each (lambda (f) (define-foreign-process-form f oport))
|
||
(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-form clause oport)))
|
||
clauses))))
|
||
|
||
((define-foreign)
|
||
(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 (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))))))
|
||
|
||
(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)
|
||
(process-define-foreign-stream iport oport))))))
|
||
|
||
|
||
(define (cig-standalone-toplevel . args) ; ignore your args.
|
||
(process-define-foreign-stream (current-input-port)
|
||
(current-output-port))
|
||
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))
|
||
(%external-call (rename 'external-call))
|
||
(%get-external (rename 'get-external))
|
||
|
||
(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 `(,%external-call ,%f ,@c-args))
|
||
(xcall (cond ((and (not ignore?)
|
||
(retrep:s-cvtr (car ret-infos2)))
|
||
=> (lambda (proc) `(,proc ,xcall))) ; not hygenic
|
||
(else xcall))))
|
||
|
||
`(,%define ,scheme-name
|
||
(,%let ((,%f (,%get-external ,c-name)))
|
||
(,%lambda ,args ,xcall))))
|
||
|
||
(let ((retarg1 (rename 'r1))
|
||
(retarg2 (rename 'r2))
|
||
(%make-vector (rename 'make-vector)))
|
||
`(,%define ,scheme-name
|
||
(,%let ((,%f (,%get-external ,c-name)))
|
||
(,%lambda ,args
|
||
(,%let ((,retarg2 (,%make-vector ,carrier-veclen)))
|
||
,@(install-carriers retarg2 ret-infos2
|
||
(rename 'vector-set!))
|
||
(,%let ((,retarg1 (,%external-call ,%f ,@c-args ,retarg2)))
|
||
(values ,@(make-values-args retarg1 retarg2
|
||
ret-infos2
|
||
rename))))))))))))
|
||
|
||
(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 externals 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.
|