1172 lines
40 KiB
Scheme
1172 lines
40 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.
|
||
|
|
|
||
|
|
;;; WARNING: the xxx_t are not yet adapted to the new FFI, only time_t,
|
||
|
|
;;; long and int are entered via enter/extract_integer, which converts to a
|
||
|
|
;;; bignum if appropriate.
|
||
|
|
;;; Since this requires runtime-checks it is slower than the _integer's
|
||
|
|
;;; You have to check, where more than 29 bits is required
|
||
|
|
|
||
|
|
(define *simple-argrep-alist* '(
|
||
|
|
|
||
|
|
(char #("char ~a" char? "s48_extract_char" #f))
|
||
|
|
(bool #("int ~a" #f "EXTRACT_BOOLEAN" #f))
|
||
|
|
|
||
|
|
(integer #("int ~a" integer? "s48_extract_integer" #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_integer" #f))
|
||
|
|
(long #("long ~a" integer? "s48_extract_integer" #f))
|
||
|
|
(fixnum #("int ~a" fixnum? "s48_extract_fixnum" #f))
|
||
|
|
|
||
|
|
;; extensions by JMG for the new FFI
|
||
|
|
(time_t #("time_t ~a" integer? "s48_extract_integer" #f))
|
||
|
|
(clock_t #("clock_t ~a" integer? "s48_extract_fixnum" #f))
|
||
|
|
(ssize_t #("ssize_t ~a" integer? "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(S48_CAR(~a),(long) ~a); S48_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)) ;;JMG: untested
|
||
|
|
|
||
|
|
;;; 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_integer" #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_integer" #f #f #f))
|
||
|
|
|
||
|
|
; Extension by JMG with the new FFI
|
||
|
|
(time_t #("time_t ~a" "s48_enter_integer" #f #f #f))
|
||
|
|
(clock_t #("clock_t ~a" "s48_enter_fixnum" #f #f #f))
|
||
|
|
(ssize_t #("ssize_t ~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 = 0;" ; 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))
|
||
|
|
(gc-protected-vars (if ignore? ; maybe extended by mv_vec
|
||
|
|
'()
|
||
|
|
'("ret1")))
|
||
|
|
|
||
|
|
(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))))))
|
||
|
|
(gc-protected-vars (if mv-return?
|
||
|
|
(cons "mv_vec" gc-protected-vars)
|
||
|
|
gc-protected-vars))
|
||
|
|
(gc_declare (if (> (length gc-protected-vars) 0)
|
||
|
|
(format #f "~% S48_DECLARE_GC_PROTECT(~d);"
|
||
|
|
(length gc-protected-vars))
|
||
|
|
""))
|
||
|
|
(gc_protect (if (> (length gc-protected-vars) 0)
|
||
|
|
(format #f "~% S48_GC_PROTECT_~d(~a);"
|
||
|
|
(length gc-protected-vars)
|
||
|
|
(if (null? (cdr gc-protected-vars))
|
||
|
|
(car gc-protected-vars)
|
||
|
|
(string-append (car gc-protected-vars)
|
||
|
|
","
|
||
|
|
(cadr gc-protected-vars))))
|
||
|
|
""))
|
||
|
|
(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)))
|
||
|
|
(gc_unprotect (if (> (length gc-protected-vars) 0)
|
||
|
|
"\n S48_GC_UNPROTECT();"
|
||
|
|
""))
|
||
|
|
(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 gc_protect "\n r1 = " c-call ";"
|
||
|
|
post-C-val-processing
|
||
|
|
mv-assigns gc_unprotect 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)
|
||
|
|
gc_declare
|
||
|
|
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
|
||
|
|
~a
|
||
|
|
}
|
||
|
|
|
||
|
|
")
|
||
|
|
; Frank: end
|
||
|
|
|
||
|
|
(define ret1-decl
|
||
|
|
"
|
||
|
|
s48_value ret1 = S48_FALSE;")
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
|
||
|
|
(define cfile-header-boilerplate
|
||
|
|
"/* This is an Scheme48/C interface file,
|
||
|
|
** automatically generated by a hacked version of cig 3.0.
|
||
|
|
step 4
|
||
|
|
*/
|
||
|
|
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <stdlib.h> /* For malloc. */
|
||
|
|
#include \"libcig.h\"
|
||
|
|
|
||
|
|
")
|
||
|
|
|
||
|
|
; Frank: begin
|
||
|
|
|
||
|
|
(define s48-init-boilerplate
|
||
|
|
"void s48_init_~a(void)
|
||
|
|
{~a
|
||
|
|
}
|
||
|
|
")
|
||
|
|
|
||
|
|
(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 init-name #f)
|
||
|
|
(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-init-name)
|
||
|
|
(let ((name (cdr form)))
|
||
|
|
(set! init-name (car name))))
|
||
|
|
|
||
|
|
((define-stubless-foreign)
|
||
|
|
(let ((c-name (cadddr form)))
|
||
|
|
(set! c-names (cons c-name c-names))))
|
||
|
|
|
||
|
|
((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)
|
||
|
|
(values (reverse c-names) init-name))
|
||
|
|
|
||
|
|
; Frank: end
|
||
|
|
(define (display-register c-names init-name oport)
|
||
|
|
(if (not init-name)
|
||
|
|
(error "no foreign-init-name statement found")
|
||
|
|
(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 init-name register-txt))))
|
||
|
|
|
||
|
|
(define (process-define-foreign-stream iport oport)
|
||
|
|
(display cfile-header-boilerplate oport)
|
||
|
|
(let lp ((c-names '()) (init-name #f))
|
||
|
|
(let ((form (read iport)))
|
||
|
|
(if (eof-object? form)
|
||
|
|
(display-register c-names init-name oport)
|
||
|
|
(receive (new-c-names maybe-init-name)
|
||
|
|
(define-foreign-process-form form oport)
|
||
|
|
(let ((init-name (if maybe-init-name
|
||
|
|
(if init-name
|
||
|
|
(error "multiple foreign-init-name definitions")
|
||
|
|
maybe-init-name)
|
||
|
|
init-name)))
|
||
|
|
(lp (append c-names new-c-names) init-name)))))))
|
||
|
|
|
||
|
|
; Frank: begin
|
||
|
|
; (process-define-foreign-file fname) scans file fname.scm and produces a c-stub for every
|
||
|
|
; scanned define-foreign form and places it in file fname.c.
|
||
|
|
(define (process-define-foreign-file fname init-name)
|
||
|
|
(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 init-name register-txt))
|
||
|
|
(lp (append c-names (define-foreign-process-form form oport))))))))))))
|
||
|
|
; Frank: end
|
||
|
|
|
||
|
|
|
||
|
|
(define (cig-standalone-toplevel f-and-init-name) ; ignore your args no
|
||
|
|
(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))
|
||
|
|
; JMG: begin replaced external-lambda by import-lambda-definition
|
||
|
|
(%import-lambda-definition (rename 'import-lambda-definition))
|
||
|
|
(%lookup-imported-binding (rename 'lookup-imported-binding))
|
||
|
|
(%call-imported-binding (rename 'call-imported-binding))
|
||
|
|
(%let* (rename 'let*))
|
||
|
|
; 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))
|
||
|
|
(let ((retarg1 (rename 'r1))
|
||
|
|
(retarg2 (rename 'r2))
|
||
|
|
(%make-vector (rename 'make-vector)))
|
||
|
|
`(,%define ,scheme-name
|
||
|
|
(,%let ((,%f (,%lookup-imported-binding ,c-name)))
|
||
|
|
(,%lambda ,args
|
||
|
|
(,%let ((,retarg2 (,%make-vector ,carrier-veclen)))
|
||
|
|
,@(install-carriers retarg2 ret-infos2
|
||
|
|
(rename 'vector-set!))
|
||
|
|
(,%let ((,retarg1 (,%call-imported-binding ,%f ,@c-args ,retarg2)))
|
||
|
|
(values ,@(make-values-args retarg1 retarg2
|
||
|
|
ret-infos2
|
||
|
|
rename))))))))))))
|
||
|
|
;; `(,%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
|
||
|
|
; (,%let* ((temp (,%lookup-imported-binding ,c-name))
|
||
|
|
; (,%f (,%lambda ,args (,%call-imported-binding temp ,args))))
|
||
|
|
; (,%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)
|
||
|
|
(foreign-init-name :syntax)
|
||
|
|
(define-stubless-foreign :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-syntax foreign-init-name
|
||
|
|
(syntax-rules ()
|
||
|
|
((foreign-init-name name) (lambda () name))))
|
||
|
|
|
||
|
|
(define-syntax define-stubless-foreign
|
||
|
|
(syntax-rules ()
|
||
|
|
((define-stubless-foreign bla ...)
|
||
|
|
(import-lambda-definition bla ...))))
|
||
|
|
|
||
|
|
(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.
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|