mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 21:59:17 +02:00
1648 lines
61 KiB
Text
Executable file
1648 lines
61 KiB
Text
Executable file
#! /usr/bin/env chibi-scheme
|
|
|
|
;; Note: this evolved as a throw-away script to provide certain core
|
|
;; modules, and so is a mess. Tread carefully.
|
|
|
|
;; Simple C FFI. "chibi-ffi file.stub" will read in the C function
|
|
;; FFI definitions from file.stub and output the appropriate C
|
|
;; wrappers into file.c. You can then compile that file with:
|
|
;;
|
|
;; cc -fPIC -shared file.c -lchibi-scheme
|
|
;;
|
|
;; (or using whatever flags are appropriate to generate shared libs on
|
|
;; your platform) and then the generated .so file can be loaded
|
|
;; directly with load, or portably using (include-shared "file") in a
|
|
;; module definition (note that include-shared uses no suffix).
|
|
;;
|
|
;; Passing the -c/--compile option will attempt to compile the .so
|
|
;; file in a single step.
|
|
|
|
;; The goal of this interface is to make access to C types and
|
|
;; functions easy, without requiring the user to write any C code.
|
|
;; That means the stubber needs to be intelligent about various C
|
|
;; calling conventions and idioms, such as return values passed in
|
|
;; actual parameters. Writing C by hand is still possible, and
|
|
;; several of the core modules provide C interfaces directly without
|
|
;; using the stubber.
|
|
|
|
;; For bootstrapping purposes we depend only on the core language.
|
|
(import (scheme))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; globals
|
|
|
|
(define *ffi-version* "0.2")
|
|
(define *types* '())
|
|
(define *typedefs* '())
|
|
(define *funcs* '())
|
|
(define *methods* '())
|
|
(define *consts* '())
|
|
(define *inits* '())
|
|
(define *tags* '())
|
|
(define *open-namespaces* '())
|
|
(define *c++?* #f)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; type objects
|
|
|
|
(define (parse-type type . o)
|
|
(cond
|
|
((vector? type)
|
|
type)
|
|
(else
|
|
(let lp ((type type) (free? #f) (const? #f) (null-ptr? #f)
|
|
(ptr? #f) (ref? #f) (struct? #f) (link? #f) (result? #f) (array #f)
|
|
(value #f) (default? #f) (template #f))
|
|
(define (next) (if (null? (cddr type)) (cadr type) (cdr type)))
|
|
(case (and (pair? type) (car type))
|
|
((free)
|
|
(lp (next) #t const? null-ptr? ptr? ref? struct? link? result? array value default? template))
|
|
((const)
|
|
(lp (next) free? #t null-ptr? ptr? ref? struct? link? result? array value default? template))
|
|
((maybe-null)
|
|
(lp (next) free? const? #t ptr? ref? struct? link? result? array value default? template))
|
|
((pointer)
|
|
(lp (next) free? const? null-ptr? #t ref? struct? link? result? array value default? template))
|
|
((reference)
|
|
(lp (next) free? const? null-ptr? ptr? #t struct? link? result? array value default? template))
|
|
((struct)
|
|
(lp (next) free? const? null-ptr? ptr? ref? #t link? result? array value default? template))
|
|
((link)
|
|
(lp (next) free? const? null-ptr? ptr? ref? struct? #t result? array value default? template))
|
|
((result)
|
|
(lp (next) free? const? null-ptr? ptr? ref? struct? link? #t array value default? template))
|
|
((array)
|
|
(lp (cadr type) free? const? null-ptr? ref? ptr? struct? link? result? (if (pair? (cddr type)) (car (cddr type)) #t) value default? template))
|
|
((value)
|
|
(lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) default? template))
|
|
((default)
|
|
(lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) #t template))
|
|
((template)
|
|
(lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) default? (cadr type)))
|
|
(else
|
|
(vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? ref? struct? link? result? array value default? template (and (pair? o) (car o)))))))))
|
|
|
|
(define (type-base type) (vector-ref type 0))
|
|
(define (type-free? type) (vector-ref type 1))
|
|
(define (type-const? type) (vector-ref type 2))
|
|
(define (type-null? type) (vector-ref type 3))
|
|
(define (type-pointer? type) (vector-ref type 4))
|
|
(define (type-reference? type) (vector-ref type 5))
|
|
(define (type-struct? type) (vector-ref type 6))
|
|
(define (type-link? type) (vector-ref type 7))
|
|
(define (type-result? type) (vector-ref type 8))
|
|
(define (type-array type) (vector-ref type 9))
|
|
(define (type-value type) (vector-ref type 10))
|
|
(define (type-default? type) (vector-ref type 11))
|
|
(define (type-template type) (vector-ref type 12))
|
|
(define (type-index type) (vector-ref type 13))
|
|
|
|
(define (type-auto-expand? type)
|
|
(and (pair? (type-array type))
|
|
(memq 'auto-expand (type-array type))))
|
|
|
|
(define (type-index-string type)
|
|
(if (integer? (type-index type))
|
|
(number->string (type-index type))
|
|
""))
|
|
|
|
(define (struct-fields ls)
|
|
(let lp ((ls ls) (res '()))
|
|
(cond ((null? ls) (reverse res))
|
|
((symbol? (car ls)) (lp (cddr ls) res))
|
|
(else (lp (cdr ls) (cons (car ls) res))))))
|
|
|
|
(define (lookup-type type)
|
|
(or (assq type *types*)
|
|
(assq type *typedefs*)))
|
|
|
|
(define (type-field-type type field)
|
|
(cond
|
|
((lookup-type (type-base (parse-type type)))
|
|
=> (lambda (x)
|
|
(let lp ((ls (struct-fields (cdr x))))
|
|
(cond
|
|
((null? ls) #f)
|
|
((eq? field (caar ls)) (car (cdar ls)))
|
|
(else (lp (cdr ls)))))))
|
|
(else
|
|
#f)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; type predicates
|
|
|
|
(define *c-int-types* '())
|
|
|
|
(define-syntax define-c-int-type
|
|
(syntax-rules ()
|
|
((define-c-int-type type)
|
|
(if (not (memq 'type *c-int-types*))
|
|
(set! *c-int-types* (cons 'type *c-int-types*))))))
|
|
|
|
(define (signed-int-type? type)
|
|
(or (memq type '(signed-char short int long boolean))
|
|
(memq type *c-int-types*)))
|
|
|
|
(define (unsigned-int-type? type)
|
|
(memq type '(unsigned-char unsigned-short unsigned unsigned-int unsigned-long
|
|
size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t
|
|
uid_t gid_t pid_t blksize_t blkcnt_t sigval_t)))
|
|
|
|
(define (int-type? type)
|
|
(or (signed-int-type? type) (unsigned-int-type? type)))
|
|
|
|
(define (float-type? type)
|
|
(memq type '(float double long-double long-long-double)))
|
|
|
|
(define (string-type? type)
|
|
(or (memq type '(char* string env-string non-null-string))
|
|
(and (vector? type)
|
|
(type-array type)
|
|
(not (type-pointer? type))
|
|
(eq? 'char (type-base type)))))
|
|
|
|
(define (port-type? type)
|
|
(memq type '(port input-port output-port input-output-port)))
|
|
|
|
(define (error-type? type)
|
|
(memq type '(errno non-null-string non-null-pointer)))
|
|
|
|
(define (array-type? type)
|
|
(and (type-array type) (not (eq? 'char (type-base type)))))
|
|
|
|
(define (basic-type? type)
|
|
(let ((type (parse-type type)))
|
|
(and (not (type-array type))
|
|
(not (void-pointer-type? type))
|
|
(not (lookup-type (type-base type))))))
|
|
|
|
(define (void-pointer-type? type)
|
|
(or (and (eq? 'void (type-base type)) (type-pointer? type))
|
|
(eq? 'void* (type-base type))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; function objects
|
|
|
|
(define (parse-func func . o)
|
|
(if (not (and (= 3 (length func))
|
|
(or (identifier? (cadr func))
|
|
(and (list (cadr func))
|
|
(<= 1 (length (cadr func)) 3)
|
|
(every (lambda (x) (or (identifier? x) (not x) (string? x)))
|
|
(cadr func))))
|
|
(list? (car (cddr func)))))
|
|
(error "bad function definition" func))
|
|
(let* ((method? (and (pair? o) (car o)))
|
|
(ret-type (parse-type (car func)))
|
|
(scheme-name (if (pair? (cadr func)) (car (cadr func)) (cadr func)))
|
|
(c-name (if (pair? (cadr func))
|
|
(cadr (cadr func))
|
|
(mangle scheme-name)))
|
|
(stub-name (if (and (pair? (cadr func)) (pair? (cddr (cadr func))))
|
|
(car (cddr (cadr func)))
|
|
(generate-stub-name scheme-name))))
|
|
(let lp ((ls (if (equal? (car (cddr func)) '(void)) '() (car (cddr func))))
|
|
(i 0)
|
|
(results '())
|
|
(c-args '())
|
|
(s-args '()))
|
|
(cond
|
|
((null? ls)
|
|
(vector scheme-name c-name stub-name ret-type
|
|
(reverse results) (reverse c-args) (reverse s-args)
|
|
method?))
|
|
(else
|
|
(let ((type (parse-type (car ls) i)))
|
|
(cond
|
|
((type-result? type)
|
|
(lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args))
|
|
((and (type-value type) (not (type-default? type)))
|
|
(lp (cdr ls) (+ i 1) results (cons type c-args) s-args))
|
|
(else
|
|
(lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args)))
|
|
)))))))
|
|
|
|
(define (func-scheme-name func) (vector-ref func 0))
|
|
(define (func-c-name func) (vector-ref func 1))
|
|
(define (func-stub-name func) (vector-ref func 2))
|
|
(define (func-ret-type func) (vector-ref func 3))
|
|
(define (func-results func) (vector-ref func 4))
|
|
(define (func-c-args func) (vector-ref func 5))
|
|
(define (func-scheme-args func) (vector-ref func 6))
|
|
(define (func-method? func) (vector-ref func 7))
|
|
|
|
(define (func-stub-name-set! func x) (vector-set! func 2 x))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; utilities
|
|
|
|
(define (cat . args)
|
|
(for-each (lambda (x) (if (procedure? x) (x) (display x))) args))
|
|
|
|
(define (join ls . o)
|
|
(if (pair? ls)
|
|
(let ((sep (if (pair? o) (car o) " ")))
|
|
(let lp ((ls ls))
|
|
(if (pair? (cdr ls))
|
|
(cat (car ls) sep (lambda () (lp (cdr ls))))
|
|
(cat (car ls)))))))
|
|
|
|
(define (x->string x)
|
|
(cond ((string? x) x)
|
|
((symbol? x) (symbol->string x))
|
|
((number? x) (number->string x))
|
|
(else (error "non-stringable object" x))))
|
|
|
|
(define (filter pred ls)
|
|
(cond ((null? ls) '())
|
|
((pred (car ls)) (cons (car ls) (filter pred (cdr ls))))
|
|
(else (filter pred (cdr ls)))))
|
|
|
|
(define (remove pred ls)
|
|
(cond ((null? ls) '())
|
|
((pred (car ls)) (filter pred (cdr ls)))
|
|
(else (cons (car ls) (filter pred (cdr ls))))))
|
|
|
|
(define (strip-extension path)
|
|
(let lp ((i (- (string-length path) 1)))
|
|
(cond ((<= i 0) path)
|
|
((eq? #\. (string-ref path i)) (substring path 0 i))
|
|
(else (lp (- i 1))))))
|
|
|
|
(define (string-concatenate-reverse ls)
|
|
(cond ((null? ls) "")
|
|
((null? (cdr ls)) (car ls))
|
|
(else (string-concatenate (reverse ls)))))
|
|
|
|
(define (string-replace str c r)
|
|
(let ((len (string-length str)))
|
|
(let lp ((from 0) (i 0) (res '()))
|
|
(define (collect) (if (= i from) res (cons (substring str from i) res)))
|
|
(cond
|
|
((>= i len) (string-concatenate-reverse (collect)))
|
|
((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect))))
|
|
(else (lp from (+ i 1) res))))))
|
|
|
|
(define (string-split str c . o)
|
|
(let ((start (if (pair? o) (car o) 0))
|
|
(end (string-length str)))
|
|
(let lp ((from start) (i start) (res '()))
|
|
(define (collect) (if (= i from) res (cons (substring str from i) res)))
|
|
(cond
|
|
((>= i end) (reverse (collect)))
|
|
((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (collect)))
|
|
(else (lp from (+ i 1) res))))))
|
|
|
|
(define (string-scan c str . o)
|
|
(let ((end (string-length str)))
|
|
(let lp ((i (if (pair? o) (car o) 0)))
|
|
(cond ((>= i end) #f)
|
|
((eqv? c (string-ref str i)) i)
|
|
(else (lp (+ i 1)))))))
|
|
|
|
(define (string-downcase str)
|
|
(list->string (map char-downcase (string->list str))))
|
|
|
|
(define (with-output-to-string thunk)
|
|
(call-with-output-string
|
|
(lambda (out)
|
|
(let ((old-out (current-output-port)))
|
|
(current-output-port out)
|
|
(thunk)
|
|
(current-output-port old-out)))))
|
|
|
|
(define (warn msg . args)
|
|
(let ((err (current-error-port)))
|
|
(display "WARNING: " err)
|
|
(display msg err)
|
|
(if (pair? args) (display ":" err))
|
|
(for-each (lambda (x) (display " " err) (write x err)) args)
|
|
(newline err)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; naming
|
|
|
|
(define (c-char? c)
|
|
(or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?))))
|
|
|
|
(define (c-escape str)
|
|
(let ((len (string-length str)))
|
|
(let lp ((from 0) (i 0) (res '()))
|
|
(define (collect) (if (= i from) res (cons (substring str from i) res)))
|
|
(cond
|
|
((>= i len) (string-concatenate-reverse (collect)))
|
|
((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect)))))
|
|
(else (lp from (+ i 1) res))))))
|
|
|
|
(define (mangle x)
|
|
(string-replace
|
|
(string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p")
|
|
#\! "_x"))
|
|
|
|
(define (generate-stub-name sym)
|
|
(string-append "sexp_" (mangle sym) "_stub"))
|
|
|
|
(define (type-id-name sym)
|
|
(string-append "sexp_" (mangle sym) "_type_tag"))
|
|
|
|
(define (make-integer x)
|
|
(case x
|
|
((-1) "SEXP_NEG_ONE") ((0) "SEXP_ZERO") ((1) "SEXP_ONE")
|
|
((2) "SEXP_TWO") ((3) "SEXP_THREE") ((4) "SEXP_FOUR")
|
|
((5) "SEXP_FIVE") ((6) "SEXP_SIX") ((7) "SEXP_SEVEN")
|
|
((8) "SEXP_EIGHT") ((9) "SEXP_NINE") ((10) "SEXP_TEN")
|
|
(else (string-append "sexp_make_fixnum(" (x->string x) ")"))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; .stub file interface
|
|
|
|
(define (c-declare . args)
|
|
(apply cat args)
|
|
(newline))
|
|
|
|
(define (c-include header)
|
|
(cat "\n#include \"" header "\"\n"))
|
|
|
|
(define (c-system-include header)
|
|
(cat "\n#include <" header ">\n"))
|
|
|
|
(define (c-init x)
|
|
(set! *inits* (cons x *inits*)))
|
|
|
|
(define (parse-struct-like ls)
|
|
(let lp ((ls ls) (res '()))
|
|
(cond
|
|
((null? ls)
|
|
(reverse res))
|
|
((symbol? (car ls))
|
|
(lp (cddr ls) (cons (cadr ls) (cons (car ls) res))))
|
|
((pair? (car ls))
|
|
(lp (cdr ls) (cons (cons (parse-type (caar ls)) (cdar ls)) res)))
|
|
(else
|
|
(lp (cdr ls) (cons (car ls) res))))))
|
|
|
|
(define-syntax define-struct-like
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(set! *types*
|
|
`((,(cadr expr)
|
|
,@(parse-struct-like (cddr expr)))
|
|
,@*types*))
|
|
(set! *tags* `(,(type-id-name (cadr expr)) ,@*tags*))
|
|
#f)))
|
|
|
|
(define-syntax define-c-struct
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
`(define-struct-like ,(cadr expr) type: struct ,@(cddr expr)))))
|
|
|
|
(define-syntax define-c-class
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
`(define-struct-like ,(cadr expr) type: class ,@(cddr expr)))))
|
|
|
|
(define-syntax define-c-union
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
`(define-struct-like ,(cadr expr) type: union ,@(cddr expr)))))
|
|
|
|
(define-syntax define-c-type
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
`(define-struct-like ,(cadr expr) ,@(cddr expr)))))
|
|
|
|
(define-syntax define-c
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(set! *funcs* (cons (parse-func (cdr expr)) *funcs*))
|
|
#f)))
|
|
|
|
(define-syntax define-c-const
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(let ((type (parse-type (cadr expr))))
|
|
(for-each (lambda (x) (set! *consts* (cons (list type x) *consts*)))
|
|
(cddr expr))))))
|
|
|
|
(define-syntax c-typedef
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(let ((type (parse-type (cadr expr)))
|
|
(name (car (cddr expr))))
|
|
(set! *typedefs* `((,name ,@type) ,@*typedefs*))
|
|
`(,(rename 'cat) "typedef " ,(type-c-name type) " " ',name ";\n")))))
|
|
|
|
(define (c++)
|
|
(set! *c++?* #t))
|
|
|
|
(define (ensure-c++ name)
|
|
(cond
|
|
((not *c++?*)
|
|
(display "WARNING: assuming c++ mode from " (current-error-port))
|
|
(display name (current-error-port))
|
|
(display " - use (c++) to make this explicit\n" (current-error-port))
|
|
(c++))))
|
|
|
|
(define-syntax c++-namespace
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(ensure-c++ 'c++-namespace)
|
|
(let ((namespace (cadr expr)))
|
|
(cond
|
|
((null? (cddr expr))
|
|
(set! *open-namespaces* (cons namespace *open-namespaces*))
|
|
`(,(rename 'cat) "namespace " ',namespace " {\n"))
|
|
(else
|
|
`(,(rename 'begin)
|
|
(,(rename 'cat) "namespace " ',namespace " {\n")
|
|
,@(cddr expr)
|
|
(,(rename 'cat) "} // namespace " ',namespace "\n\n"))))))))
|
|
|
|
(define-syntax c++-using
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(ensure-c++ 'c++-using)
|
|
`(,(rename 'cat) "using " ',(cadr expr) ";\n"))))
|
|
|
|
(define-syntax define-c++-method
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(ensure-c++ 'define-c++-method)
|
|
(let* ((class (cadr expr))
|
|
(ret-type (car (cddr expr)))
|
|
(name (cadr (cddr expr)))
|
|
(meths (map (lambda (x)
|
|
(parse-func `(,ret-type ,name (,class ,@x)) #t))
|
|
(cddr (cddr expr)))))
|
|
(set! *methods* (cons (cons name meths) *methods*))))))
|
|
|
|
;; (define-syntax define-c++-constructor
|
|
;; (er-macro-transformer
|
|
;; (lambda (expr rename compare)
|
|
;; (ensure-c++ 'define-c++-constructor)
|
|
;; (set! *funcs* (cons (parse-func (cdr expr)) *funcs*))
|
|
;; (let* ((meth (parse-func (cdr expr) #t))
|
|
;; (name (func-scheme-name meth)))
|
|
;; (cond
|
|
;; ((assq name *methods*)
|
|
;; => (lambda (x) (set-cdr! x (cons meth (cdr x)))))
|
|
;; (else
|
|
;; (set! *methods* (cons (list name meth) *methods*))))
|
|
;; #f))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; C code generation
|
|
|
|
(define (type-predicate type)
|
|
(let ((base (type-base (parse-type type))))
|
|
(cond
|
|
((int-type? base) "sexp_exact_integerp")
|
|
((float-type? base) "sexp_flonump")
|
|
((string-type? base) "sexp_stringp")
|
|
((eq? base 'char) "sexp_charp")
|
|
((eq? base 'boolean) "sexp_booleanp")
|
|
((eq? base 'port) "sexp_portp")
|
|
((eq? base 'input-port) "sexp_iportp")
|
|
((eq? base 'output-port) "sexp_oportp")
|
|
((eq? base 'input-output-port) "sexp_ioportp")
|
|
((eq? base 'fileno) "sexp_filenop")
|
|
(else #f))))
|
|
|
|
(define (type-name type)
|
|
(let ((base (type-base (parse-type type))))
|
|
(cond
|
|
((int-type? base) "integer")
|
|
((float-type? base) "flonum")
|
|
((eq? 'boolean base) "int")
|
|
(else base))))
|
|
|
|
(define (type-id-number type . o)
|
|
(let ((base (type-base type)))
|
|
(cond
|
|
((int-type? base) "SEXP_FIXNUM")
|
|
((float-type? base) "SEXP_FLONUM")
|
|
((string-type? base) "SEXP_STRING")
|
|
((eq? base 'char) "SEXP_CHAR")
|
|
((eq? base 'boolean) "SEXP_BOOLEAN")
|
|
((eq? base 'string) "SEXP_STRING")
|
|
((eq? base 'symbol) "SEXP_SYMBOL")
|
|
((eq? base 'pair) "SEXP_PAIR")
|
|
((eq? base 'port) "SEXP_IPORT")
|
|
((eq? base 'input-port) "SEXP_IPORT")
|
|
((eq? base 'output-port) "SEXP_OPORT")
|
|
((eq? base 'input-output-port) "SEXP_IPORT")
|
|
((eq? base 'fileno) "SEXP_FILENO")
|
|
((void-pointer-type? type) "SEXP_CPOINTER")
|
|
((lookup-type base)
|
|
;; (string-append "sexp_type_tag(" (type-id-name base) ")")
|
|
(let ((i (type-index type)))
|
|
(cond
|
|
((not i)
|
|
;;(warn "type-id-number on unknown arg" type)
|
|
(if (and (pair? o) (car o))
|
|
"sexp_unbox_fixnum(sexp_opcode_return_type(self))"
|
|
(string-append "sexp_type_tag(" (type-id-name base) ")")))
|
|
((< i 3)
|
|
(string-append
|
|
"sexp_unbox_fixnum(sexp_opcode_arg"
|
|
(number->string (+ i 1)) "_type(self))"))
|
|
(else
|
|
(string-append
|
|
"sexp_unbox_fixnum(sexp_vector_ref(sexp_opcode_argn_type(self), "
|
|
(make-integer (- i 3)) "))")))))
|
|
(else "SEXP_OBJECT"))))
|
|
|
|
(define (type-id-value type . o)
|
|
(cond
|
|
((eq? 'void (type-base type))
|
|
"SEXP_VOID")
|
|
(else
|
|
(make-integer (apply type-id-number type o)))))
|
|
|
|
(define (type-id-init-value type)
|
|
(cond
|
|
((lookup-type (type-base type))
|
|
(make-integer
|
|
(string-append "sexp_type_tag(" (type-id-name (type-base type)) ")")))
|
|
(else
|
|
(type-id-value type))))
|
|
|
|
(define (c-array-length type)
|
|
(if (memq 'result (type-array type))
|
|
"sexp_unbox_fixnum(res)"
|
|
"-1"))
|
|
|
|
(define (c->scheme-converter type val . o)
|
|
(let ((base (type-base type)))
|
|
(cond
|
|
((and (eq? base 'void) (not (type-pointer? type)))
|
|
(cat "((" val "), SEXP_VOID)"))
|
|
((or (eq? base 'sexp) (error-type? base))
|
|
(cat val))
|
|
((eq? base 'boolean)
|
|
(cat "sexp_make_boolean(" val ")"))
|
|
((eq? base 'time_t)
|
|
(cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))"))
|
|
((unsigned-int-type? base)
|
|
(cat "sexp_make_unsigned_integer(ctx, " val ")"))
|
|
((signed-int-type? base)
|
|
(cat "sexp_make_integer(ctx, " val ")"))
|
|
((float-type? base)
|
|
(cat "sexp_make_flonum(ctx, " val ")"))
|
|
((eq? base 'char)
|
|
(if (type-array type)
|
|
(cat "sexp_c_string(ctx, " val ", " (c-array-length type) ")")
|
|
(cat "sexp_make_character(ctx, " val ")")))
|
|
((eq? 'env-string base)
|
|
(cat "(p=strchr(" val ", '=') ? "
|
|
"sexp_cons(ctx, str=sexp_c_string(ctx, " val
|
|
", p - " val "), str=sexp_c_string(ctx, p, -1))"
|
|
" : sexp_cons(ctx, str=" val ", SEXP_FALSE)"))
|
|
((string-type? base)
|
|
(cat "sexp_c_string(ctx, " val ", " (c-array-length type) ")"))
|
|
((eq? 'input-port base)
|
|
(cat "sexp_make_non_null_input_port(ctx, " val ", SEXP_FALSE)"))
|
|
((eq? 'output-port base)
|
|
(cat "sexp_make_non_null_output_port(ctx, " val ", SEXP_FALSE)"))
|
|
((eq? 'input-output-port base)
|
|
(cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)"))
|
|
((eq? 'fileno base)
|
|
(cat "sexp_make_fileno(ctx, sexp_make_fixnum(" val "), SEXP_FALSE)"))
|
|
(else
|
|
(let ((ctype (lookup-type base))
|
|
(void*? (void-pointer-type? type)))
|
|
(cond
|
|
((or ctype void*?)
|
|
(cat "sexp_make_cpointer(ctx, "
|
|
(if void*?
|
|
"SEXP_CPOINTER"
|
|
;;(string-append "sexp_type_tag(" (type-id-name base) ")")
|
|
(type-id-number type #t))
|
|
", "
|
|
val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", "
|
|
(if (or (type-free? type)
|
|
(and (type-result? type) (not (basic-type? type))))
|
|
1
|
|
0)
|
|
")"))
|
|
(else
|
|
(error "unknown type" base))))))))
|
|
|
|
(define (scheme->c-converter type val)
|
|
(let* ((type (parse-type type))
|
|
(base (type-base type)))
|
|
(cond
|
|
((eq? base 'sexp)
|
|
(cat val))
|
|
((eq? base 'boolean)
|
|
(cat "sexp_truep(" val ")"))
|
|
((eq? base 'time_t)
|
|
(cat "sexp_unshift_epoch(sexp_uint_value(" val "))"))
|
|
((signed-int-type? base)
|
|
(cat "sexp_sint_value(" val ")"))
|
|
((unsigned-int-type? base)
|
|
(cat "sexp_uint_value(" val ")"))
|
|
((float-type? base)
|
|
(cat "sexp_flonum_value(" val ")"))
|
|
((eq? base 'char)
|
|
(cat "sexp_unbox_character(" val ")"))
|
|
((eq? base 'env-string)
|
|
(cat "sexp_concat_env_string(" val ")"))
|
|
((string-type? base)
|
|
(cat "sexp_string_data(" val ")"))
|
|
((eq? base 'port-or-fileno)
|
|
(cat "(sexp_portp(" val ") ? sexp_port_fileno(" val ")"
|
|
" : sexp_fileno_fd(" val "))"))
|
|
((port-type? base)
|
|
(cat "sexp_port_stream(" val ")"))
|
|
((eq? base 'fileno)
|
|
(cat "(sexp_filenop(" val ") ? sexp_fileno_fd(" val ")"
|
|
" : sexp_unbox_fixnum(" val "))"))
|
|
(else
|
|
(let ((ctype (lookup-type base))
|
|
(void*? (void-pointer-type? type)))
|
|
(cond
|
|
((or ctype void*?)
|
|
(cat "(" (type-c-name type) ")"
|
|
(if (type-null? type)
|
|
"sexp_cpointer_maybe_null_value"
|
|
"sexp_cpointer_value")
|
|
"(" val ")"))
|
|
(else
|
|
(error "unknown type" base))))))))
|
|
|
|
(define (base-type-c-name base)
|
|
(case base
|
|
((string env-string non-null-string) (if *c++?* "string" "char*"))
|
|
((fileno) "int")
|
|
(else (symbol->string base))))
|
|
|
|
(define (type-struct-type type)
|
|
(let ((type-spec (lookup-type(if (vector? type) (type-base type) type))))
|
|
(cond ((and type-spec (memq 'type: type-spec)) => cadr)
|
|
(else #f))))
|
|
|
|
(define (type-c-name-derefed type)
|
|
(let* ((type (parse-type type))
|
|
(base (type-base type))
|
|
(type-spec (lookup-type base))
|
|
(struct-type (type-struct-type type)))
|
|
(string-append
|
|
(if (type-const? type) "const " "")
|
|
(if struct-type (string-append (symbol->string struct-type) " ") "")
|
|
(base-type-c-name base)
|
|
(if (type-template type)
|
|
(string-append
|
|
"<"
|
|
(string-concatenate (map type-c-name (type-template type)) ", ")
|
|
">")
|
|
""))))
|
|
|
|
(define (type-c-name type)
|
|
(let ((type (parse-type type)))
|
|
(string-append
|
|
(type-c-name-derefed type)
|
|
(if (type-struct-type type) "*" "")
|
|
(if (type-pointer? type) "*" ""))))
|
|
|
|
(define (check-type arg type)
|
|
(let* ((type (parse-type type))
|
|
(base (type-base type)))
|
|
(cond
|
|
((eq? base 'env-string)
|
|
(cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg
|
|
")) && sexp_stringp(sexp_cdr(" arg ")))"))
|
|
((eq? base 'fileno)
|
|
(cat "(sexp_filenop(" arg ") || sexp_fixnump(" arg "))"))
|
|
((or (int-type? base) (float-type? base)
|
|
(string-type? base) (port-type? base))
|
|
(cat (type-predicate type) "(" arg ")"))
|
|
((or (lookup-type base) (void-pointer-type? type))
|
|
(cat
|
|
(if (type-null? type) "(" "")
|
|
"(sexp_pointerp(" arg ")"
|
|
" && (sexp_pointer_tag(" arg ") == "
|
|
(if (void-pointer-type? type)
|
|
"SEXP_CPOINTER"
|
|
(type-id-number type))
|
|
"))"
|
|
(lambda () (if (type-null? type) (cat " || sexp_not(" arg "))")))))
|
|
(else
|
|
(warn "don't know how to check" type)
|
|
(cat "1")))))
|
|
|
|
(define (write-validator arg type)
|
|
(let* ((type (parse-type type))
|
|
(array (type-array type))
|
|
(base-type (type-base type)))
|
|
(cond
|
|
((and array (not (string-type? type)))
|
|
(cond
|
|
((number? array)
|
|
(cat " if (!sexp_listp(ctx, " arg ")"
|
|
" || sexp_unbox_fixnum(sexp_length(ctx, " arg ")) != " array ")\n"
|
|
" return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n")))
|
|
(cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n"
|
|
" if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n"
|
|
" return sexp_xtype_exception(ctx, self, \"not a list of "
|
|
(type-name type) "s\", " arg ");\n")
|
|
(if (not (number? array))
|
|
(cat " if (! sexp_nullp(res))\n"
|
|
" return sexp_xtype_exception(ctx, self, \"not a list of "
|
|
(type-name type) "s\", " arg ");\n")))
|
|
((eq? base-type 'port-or-fileno)
|
|
(cat " if (! (sexp_portp(" arg ") || sexp_filenop(" arg ")))\n"
|
|
" return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n"))
|
|
((or (int-type? base-type)
|
|
(float-type? base-type)
|
|
(string-type? base-type)
|
|
(port-type? base-type)
|
|
(eq? base-type 'fileno))
|
|
(cat
|
|
" if (! " (lambda () (check-type arg type)) ")\n"
|
|
" return sexp_type_exception(ctx, self, "
|
|
(type-id-number type) ", " arg ");\n"))
|
|
((or (lookup-type base-type) (void-pointer-type? type))
|
|
(cat
|
|
" if (! " (lambda () (check-type arg type)) ")\n"
|
|
" return sexp_type_exception(ctx, self, "
|
|
(type-id-number type) ", " arg ");\n"))
|
|
((eq? 'sexp base-type))
|
|
((string-type? type)
|
|
(write-validator arg 'string))
|
|
(else
|
|
(warn "don't know how to validate" type)))))
|
|
|
|
(define (write-parameters args)
|
|
(lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args)))
|
|
|
|
(define (get-array-length func x)
|
|
(let ((len (if (pair? (type-array x))
|
|
(car (reverse (type-array x)))
|
|
(type-array x))))
|
|
(cond
|
|
((number? len)
|
|
len)
|
|
(else
|
|
(and func
|
|
(symbol? len)
|
|
(let* ((str (symbol->string len))
|
|
(len2 (string-length str)))
|
|
(and (> len2 3)
|
|
(string=? "arg" (substring str 0 3))
|
|
(let ((i (string->number (substring str 3 len2))))
|
|
(if i
|
|
(let ((y (list-ref (func-c-args func) i)))
|
|
(or (type-value y) len)))))))))))
|
|
|
|
(define (write-locals func)
|
|
(define (arg-res x)
|
|
(string-append "res" (type-index-string x)))
|
|
(let* ((ret-type (func-ret-type func))
|
|
(results (func-results func))
|
|
(scheme-args (func-scheme-args func))
|
|
(return-res? (not (error-type? (type-base ret-type))))
|
|
(preserve-res? (> (+ (length results)) (if return-res? 0 1)))
|
|
(single-res? (and (= 1 (length results)) (not return-res?)))
|
|
(tmp-string? (any (lambda (a)
|
|
(and (type-array a)
|
|
(string-type? (type-base a))))
|
|
(cons ret-type results)))
|
|
(gc-vars (map arg-res results))
|
|
(gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars))
|
|
(gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars))
|
|
(sexps (if preserve-res? '() '("res")))
|
|
(num-gc-vars (length gc-vars))
|
|
(ints (if (or return-res?
|
|
(memq (type-base ret-type)
|
|
'(non-null-string non-null-pointer)))
|
|
'()
|
|
'("err")))
|
|
(ints (if (or (array-type? ret-type)
|
|
(any array-type? results)
|
|
(any array-type? scheme-args))
|
|
(cons "i" ints)
|
|
ints)))
|
|
(case (type-base ret-type)
|
|
((non-null-string) (cat " char *err;\n"))
|
|
((non-null-pointer) (cat " void *err;\n")))
|
|
(cond
|
|
((pair? ints)
|
|
(cat " int " (car ints))
|
|
(for-each (lambda (x) (display ", ") (display x)) (cdr ints))
|
|
(cat ";\n")))
|
|
(if (any (lambda (a) (eq? 'env-string (type-base a)))
|
|
(cons ret-type results))
|
|
(cat " char *p;\n"))
|
|
(for-each
|
|
(lambda (x)
|
|
(let ((len (get-array-length func x)))
|
|
(cat " " (if (type-const? x) "const " "")
|
|
(type-c-name (type-base x)) " ")
|
|
(if (or (and (type-array x) (not (number? len))) (type-pointer? x))
|
|
(cat "*"))
|
|
(cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x))
|
|
(if (number? len)
|
|
(cat "[" len "]"))
|
|
(if (type-reference? x)
|
|
(cat " = NULL"))
|
|
(cat ";\n")
|
|
(if (or (vector? len) (type-auto-expand? x))
|
|
(cat " int len" (type-index x) ";\n"))
|
|
(if (type-auto-expand? x)
|
|
(cat " " (type-c-name (type-base x))
|
|
" *tmp" (type-index-string x) ";\n"))))
|
|
(append (if (or (type-array ret-type) (type-pointer? ret-type))
|
|
(list ret-type)
|
|
'())
|
|
results
|
|
(remove type-result? (filter type-array scheme-args))))
|
|
(for-each
|
|
(lambda (arg)
|
|
(cond
|
|
((and (type-pointer? arg) (basic-type? arg))
|
|
(cat " " (type-c-name (type-base arg))
|
|
" tmp" (type-index arg) ";\n"))))
|
|
scheme-args)
|
|
(cond
|
|
((pair? sexps)
|
|
(cat " sexp " (car sexps))
|
|
(for-each (lambda (x) (display ", ") (display x)) (cdr sexps))
|
|
(cat ";\n")))
|
|
;; Declare the gc vars.
|
|
(cond
|
|
((pair? gc-vars)
|
|
(cat " sexp_gc_var" num-gc-vars "(")
|
|
(display (car gc-vars))
|
|
(for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars))
|
|
(cat ");\n")))
|
|
;; Shortcut returns should come before preserving.
|
|
(write-validators (func-scheme-args func))
|
|
(write-additional-checks (func-c-args func))
|
|
;; Preserve the gc vars.
|
|
(cond
|
|
((pair? gc-vars)
|
|
(cat " sexp_gc_preserve" num-gc-vars "(ctx")
|
|
(for-each (lambda (x) (display ", ") (display x)) gc-vars)
|
|
(cat ");\n")))))
|
|
|
|
(define (write-validators args)
|
|
(for-each
|
|
(lambda (a)
|
|
(write-validator (string-append "arg" (type-index-string a)) a))
|
|
args))
|
|
|
|
(define (write-additional-checks args)
|
|
(for-each
|
|
(lambda (a)
|
|
(if (port-type? (type-base a))
|
|
(cat " if (!sexp_stream_portp(arg" (type-index a) "))\n"
|
|
" return sexp_xtype_exception(ctx, self,"
|
|
" \"not a FILE* backed port\", arg" (type-index a) ");\n")))
|
|
args)
|
|
(for-each
|
|
(lambda (a)
|
|
(if (eq? 'input-port (type-base a))
|
|
(cat " sexp_check_block_port(ctx, arg" (type-index a) ", 0);\n")))
|
|
args))
|
|
|
|
(define (write-value func val)
|
|
(cond
|
|
((find (lambda (x)
|
|
(and (type-array x)
|
|
(type-auto-expand? x)
|
|
(eq? val (get-array-length func x))))
|
|
(func-c-args func))
|
|
=> (lambda (x) (cat "len" (type-index x))))
|
|
((lookup-type val)
|
|
(cat (or (type-struct-type val) "") " " val))
|
|
((list? val)
|
|
(write (car val))
|
|
(cat
|
|
"("
|
|
(lambda ()
|
|
(cond
|
|
((pair? (cdr val))
|
|
(write-value func (cadr val))
|
|
(for-each (lambda (x) (display ", ") (write-value func x)) (cddr val)))))
|
|
")"))
|
|
(else
|
|
(write val))))
|
|
|
|
(define (write-actual-parameter func arg)
|
|
(cond
|
|
((or (type-result? arg) (type-array arg))
|
|
(cat (if (or (type-free? arg) (type-reference? arg) (basic-type? arg))
|
|
"&"
|
|
"")
|
|
"tmp" (type-index arg)))
|
|
((and (not (type-default? arg)) (type-value arg))
|
|
=> (lambda (x) (write-value func x)))
|
|
((and (type-pointer? arg) (basic-type? arg))
|
|
(cat "&tmp" (type-index arg)))
|
|
(else
|
|
(scheme->c-converter
|
|
arg
|
|
(string-append "arg" (type-index-string arg))))))
|
|
|
|
(define (write-temporaries func)
|
|
(for-each
|
|
(lambda (a)
|
|
(let ((len (and (type-array a) (get-array-length func a))))
|
|
(cond
|
|
((and (type-array a) (or (vector? len) (type-auto-expand? a)))
|
|
(cat " len" (type-index a) " = "
|
|
(lambda ()
|
|
(if (number? len) (cat len) (scheme->c-converter 'int len)))
|
|
";\n"
|
|
" tmp" (type-index a) " = buf" (type-index a) ";\n")))
|
|
(cond
|
|
((and (not (type-result? a)) (type-array a) (not (string-type? a)))
|
|
(if (not (number? (type-array a)))
|
|
(cat " tmp" (type-index a)
|
|
" = (" (type-c-name (type-base a)) "*) calloc("
|
|
"(sexp_unbox_fixnum(sexp_length(ctx, arg" (type-index a)
|
|
"))+1), sizeof(tmp" (type-index a) "[0]));\n"))
|
|
(cat " for (i=0, res=arg" (type-index a)
|
|
"; sexp_pairp(res); res=sexp_cdr(res), i++) {\n"
|
|
" tmp" (type-index a) "[i] = "
|
|
(lambda () (scheme->c-converter (type-base a) "sexp_car(res)"))
|
|
";\n"
|
|
" }\n")
|
|
(if (not (number? (type-array a)))
|
|
(cat " tmp" (type-index a) "[i] = NULL;\n")))
|
|
((and (type-result? a) (not (basic-type? a))
|
|
(not (type-free? a)) ;;(not (type-pointer? a))
|
|
(not (type-reference? a))
|
|
(not (type-auto-expand? a))
|
|
(or (not (type-array a))
|
|
(not (integer? len))))
|
|
(cat " tmp" (type-index a) " = calloc(1, 1 + "
|
|
(if (and (symbol? len) (not (eq? len 'null)))
|
|
(lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len))
|
|
"*sizeof(tmp" (type-index a) "[0])"))
|
|
(lambda () (cat "sizeof(tmp" (type-index a) "[0])")))
|
|
");\n"
|
|
(lambda ()
|
|
(if (and (symbol? len) (not (eq? len 'null)))
|
|
(cat " tmp" (type-index a) "[" (lambda () (scheme->c-converter 'unsigned-int len))
|
|
"*sizeof(tmp" (type-index a) "[0])] = 0;\n")))))
|
|
((and (type-result? a) (type-value a))
|
|
(cat " tmp" (type-index a) " = "
|
|
(lambda () (write-value func (type-value a))) ";\n"))
|
|
((and (type-pointer? a) (basic-type? a))
|
|
(cat " tmp" (type-index a) " = "
|
|
(lambda ()
|
|
(scheme->c-converter
|
|
a
|
|
(string-append "arg" (type-index-string a))))
|
|
";\n")))))
|
|
(func-c-args func)))
|
|
|
|
(define (write-call func)
|
|
(let ((ret-type (func-ret-type func))
|
|
(c-name (func-c-name func))
|
|
(c-args (func-c-args func)))
|
|
(if (any type-auto-expand? (func-c-args func))
|
|
(cat " loop:\n"))
|
|
(cat (cond ((error-type? (type-base ret-type)) " err = ")
|
|
((type-array ret-type) " tmp = ")
|
|
(else " res = ")))
|
|
((if (type-array ret-type)
|
|
(lambda (t f x) (f))
|
|
c->scheme-converter)
|
|
ret-type
|
|
(lambda ()
|
|
(if (func-method? func)
|
|
(cat "(" (lambda () (write-actual-parameter func (car c-args)))
|
|
")->" c-name)
|
|
(cat c-name))
|
|
(cat "(")
|
|
(for-each
|
|
(lambda (arg)
|
|
(if (> (type-index arg) (if (func-method? func) 1 0)) (cat ", "))
|
|
(write-actual-parameter func arg))
|
|
(if (func-method? func) (cdr c-args) c-args))
|
|
(cat ")"))
|
|
(cond
|
|
((find type-link? (func-c-args func))
|
|
=> (lambda (a) (string-append "arg" (type-index-string a))))
|
|
(else #f)))
|
|
(cat ";\n")
|
|
(if (type-array ret-type)
|
|
(write-result ret-type)
|
|
(write-result-adjustment ret-type))))
|
|
|
|
(define (write-result-adjustment result)
|
|
(cond
|
|
((memq (type-base result) '(input-port output-port input-output-port))
|
|
(let ((res (string-append "res" (type-index-string result))))
|
|
(cat "#ifdef SEXP_USE_GREEN_THREADS\n"
|
|
" if (sexp_portp(" res "))\n"
|
|
" fcntl(fileno(sexp_port_stream(" res ")), F_SETFL, O_NONBLOCK);\n"
|
|
"#endif\n")))))
|
|
|
|
(define (write-result result)
|
|
(let ((res (string-append "res" (type-index-string result)))
|
|
(tmp (string-append "tmp" (type-index-string result))))
|
|
(cond
|
|
((and (type-array result) (eq? 'char (type-base result)))
|
|
(cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n"))
|
|
((type-array result)
|
|
(cat " " res " = SEXP_NULL;\n")
|
|
(let ((auto-expand?
|
|
(and (pair? (type-array result))
|
|
(memq 'auto-expand (type-array result))))
|
|
(len (if (pair? (type-array result))
|
|
(car (reverse (type-array result)))
|
|
(type-array result))))
|
|
(cond
|
|
((eq? 'null len)
|
|
(cat " for (i=0; " tmp "[i]; i++) {\n"
|
|
" sexp_push(ctx, " res ", "
|
|
(if (eq? 'string (type-base result))
|
|
"str="
|
|
(lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = ")))
|
|
(lambda () (c->scheme-converter result (lambda () (cat tmp "[i]"))))
|
|
");\n"
|
|
" }\n"
|
|
" " res " = sexp_nreverse(ctx, " res ");\n"))
|
|
(else
|
|
(cat " for (i=" len "-1; i>=0; i--) {\n"
|
|
" sexp_push(ctx, " res ", SEXP_VOID);\n"
|
|
" sexp_car(" res ") = "
|
|
(lambda () (c->scheme-converter result (lambda () (cat tmp "[i]"))))
|
|
";\n"
|
|
" }\n")))))
|
|
(else
|
|
(cat " " res " = ")
|
|
(c->scheme-converter
|
|
result
|
|
(string-append "tmp" (type-index-string result)))
|
|
(cat ";\n")))
|
|
(write-result-adjustment result)))
|
|
|
|
(define (write-results func)
|
|
(let ((error-res? (error-type? (type-base (func-ret-type func))))
|
|
(results (func-results func)))
|
|
(if error-res?
|
|
(cat " if ("
|
|
(if (memq (type-base (func-ret-type func))
|
|
'(non-null-string non-null-pointer))
|
|
"!"
|
|
"")
|
|
"err) {\n"
|
|
(cond
|
|
((find type-auto-expand? (func-c-args func))
|
|
=> (lambda (a)
|
|
(lambda ()
|
|
(let ((len (get-array-length func a))
|
|
(i (type-index a)))
|
|
(if (number? len)
|
|
(cat " if (len" i " != " len ")\n"
|
|
" free(tmp" i ");\n"))
|
|
(cat " len" i " *= 2;\n"
|
|
" tmp" i
|
|
" = calloc(len" i ", sizeof(tmp" i "[0]));\n"
|
|
" goto loop;\n")))))
|
|
(else
|
|
" res = SEXP_FALSE;\n"))
|
|
" } else {\n"))
|
|
(if (null? results)
|
|
(if error-res?
|
|
(cat " res = SEXP_TRUE;\n"))
|
|
(for-each write-result results))
|
|
(cond
|
|
((> (length results) (if error-res? 1 0))
|
|
(if error-res?
|
|
(cat " res = SEXP_NULL;\n")
|
|
(cat " res = sexp_cons(ctx, res, SEXP_NULL);\n"))
|
|
(for-each
|
|
(lambda (x)
|
|
(if error-res?
|
|
(cat " sexp_push(ctx, res, res" (type-index x) ");\n")
|
|
(cat " sexp_push(ctx, res, sexp_car(res));\n"
|
|
" sexp_cadr(res) = res" (type-index x) ";\n")))
|
|
(reverse results)))
|
|
((pair? results)
|
|
(cat " res = res" (type-index (car results)) ";\n")))
|
|
(if error-res?
|
|
(cat " }\n"))))
|
|
|
|
(define (write-free type)
|
|
(if (type-array type)
|
|
(cat " free(tmp" (type-index-string type) ");\n")))
|
|
|
|
(define (write-cleanup func)
|
|
(for-each write-free (func-scheme-args func))
|
|
(for-each
|
|
(lambda (a)
|
|
(cond
|
|
((type-auto-expand? a)
|
|
(let ((len (get-array-length func a))
|
|
(i (type-index a)))
|
|
(if (number? len)
|
|
(cat " if (len" i " != " len ")\n"
|
|
" free(tmp" i ");\n"))))
|
|
((memq (type-base a) '(input-port input-output-port))
|
|
(cat " sexp_maybe_unblock_port(ctx, arg" (type-index a) ");\n"))
|
|
((and (type-result? a) (not (basic-type? a))
|
|
(not (lookup-type (type-base a)))
|
|
(not (type-free? a)) (not (type-pointer? a))
|
|
(or (not (type-array a))
|
|
(not (integer? (get-array-length func a)))))
|
|
;; the above is hairy - basically this frees temporary strings
|
|
(cat " free(tmp" (type-index a) ");\n"))))
|
|
(func-c-args func))
|
|
(let* ((results (func-results func))
|
|
(return-res? (not (error-type? (type-base (func-ret-type func)))))
|
|
(preserve-res? (> (+ (length results)) (if return-res? 0 1)))
|
|
(single-res? (and (= 1 (length results)) (not return-res?)))
|
|
(tmp-string? (any (lambda (a)
|
|
(and (type-array a)
|
|
(string-type? (type-base a))))
|
|
(cons (func-ret-type func)
|
|
(func-results func))))
|
|
(gc-vars results)
|
|
(gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars))
|
|
(gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars))
|
|
(num-gc-vars (length gc-vars)))
|
|
(cond
|
|
((pair? gc-vars)
|
|
(cat " sexp_gc_release" num-gc-vars "(ctx);\n")))))
|
|
|
|
(define (write-func-declaration func)
|
|
(cat "static sexp " (func-stub-name func)
|
|
" (sexp ctx, sexp self, sexp_sint_t n"
|
|
(write-parameters (func-scheme-args func)) ")"))
|
|
|
|
(define (write-func func)
|
|
(write-func-declaration func)
|
|
(cat " {\n")
|
|
(write-locals func)
|
|
(write-temporaries func)
|
|
(write-call func)
|
|
(write-results func)
|
|
(write-cleanup func)
|
|
(cat " return res;\n"
|
|
"}\n\n"))
|
|
|
|
(define (adjust-method-name! func i)
|
|
(func-stub-name-set!
|
|
func
|
|
(string-append (func-stub-name func) "__" (number->string i))))
|
|
|
|
(define (write-primitive-call func args)
|
|
(cat (func-stub-name func)
|
|
"(" (lambda () (join (append '(ctx self n) args) ", ")) ")"))
|
|
|
|
(define (write-fixed-arity-method meth)
|
|
(define (write-dispatch func)
|
|
(write-primitive-call
|
|
func
|
|
(map (lambda (a) (string-append "arg" (type-index-string a)))
|
|
(func-scheme-args func))))
|
|
(define (write-method-validators func)
|
|
(cond
|
|
((not (pair? (cdr (func-scheme-args func))))
|
|
(warn "no arguments to distinguish" func)
|
|
(cat "1"))
|
|
(else
|
|
(let lp ((ls (cdr (func-scheme-args func))))
|
|
(check-type (string-append "arg" (type-index-string (car ls))) (car ls))
|
|
(cond
|
|
((pair? (cdr ls))
|
|
(cat " && ")
|
|
(lp (cdr ls))))))))
|
|
(case (length meth)
|
|
((0 1)
|
|
(error "invalid method" meth))
|
|
((2)
|
|
(write-func (cadr meth)))
|
|
(else
|
|
(let ((orig-stub-name (func-stub-name (cadr meth))))
|
|
(do ((ls (cdr meth) (cdr ls)) (i 0 (+ i 1)))
|
|
((null? ls))
|
|
(adjust-method-name! (car ls) i)
|
|
(write-func (car ls)))
|
|
(let ((new-stub-name (func-stub-name (cadr meth))))
|
|
(func-stub-name-set! (cadr meth) orig-stub-name)
|
|
(write-func-declaration (cadr meth))
|
|
(func-stub-name-set! (cadr meth) new-stub-name)
|
|
(cat " {\n"
|
|
" sexp orig_self = self;\n")
|
|
(write-validator "arg0" (car (func-scheme-args (cadr meth))))
|
|
(let lp ((ls (cdr meth)) (i 0))
|
|
(cat " self = sexp_vector_ref(sexp_opcode_methods(orig_self), "
|
|
(make-integer i) ");\n")
|
|
(cond
|
|
((null? (cdr ls))
|
|
(cat " return " (lambda () (write-dispatch (car ls))) ";\n"))
|
|
(else
|
|
(cat " if ("
|
|
(lambda () (write-method-validators (car ls))) ") {\n"
|
|
" return " (lambda () (write-dispatch (car ls))) ";\n"
|
|
" }\n" (lambda () (lp (cdr ls) (+ i 1)))))))
|
|
(cat "}\n\n")
|
|
(func-stub-name-set! (cadr meth) orig-stub-name))))))
|
|
|
|
(define (write-method meth)
|
|
(if (not (apply = (map length (map func-scheme-args (cdr meth)))))
|
|
(error "methods must have the same arity"))
|
|
(write-fixed-arity-method meth))
|
|
|
|
(define (parameter-default? x)
|
|
(and (pair? x)
|
|
(member x '((current-input-port)
|
|
(current-output-port)
|
|
(current-error-port)))))
|
|
|
|
(define (write-default x) ;; this is a hack but very convenient
|
|
(lambda ()
|
|
(let ((value (type-value x)))
|
|
(cond
|
|
((equal? value '(current-input-port))
|
|
(cat "\"current-input-port\""))
|
|
((equal? value '(current-output-port))
|
|
(cat "\"current-output-port\""))
|
|
((equal? value '(current-error-port))
|
|
(cat "\"current-error-port\""))
|
|
((equal? value 'NULL)
|
|
(cat "SEXP_FALSE"))
|
|
(else
|
|
(c->scheme-converter x value))))))
|
|
|
|
(define (write-func-creation var func . o)
|
|
(let ((default (and (pair? (func-scheme-args func))
|
|
(type-default? (car (reverse (func-scheme-args func))))
|
|
(car (reverse (func-scheme-args func)))))
|
|
(no-bind? (and (pair? o) (car o))))
|
|
(cat " " var " = "
|
|
(cond
|
|
(no-bind?
|
|
"sexp_make_foreign(ctx, ")
|
|
((not default)
|
|
"sexp_define_foreign(ctx, env, ")
|
|
((parameter-default? (type-value default))
|
|
"sexp_define_foreign_param(ctx, env, ")
|
|
(else
|
|
"sexp_define_foreign_opt(ctx, env, "))
|
|
(lambda () (write (symbol->string (func-scheme-name func))))
|
|
", " (length (func-scheme-args func)) ", "
|
|
(if no-bind?
|
|
(lambda ()
|
|
(cat (cond ((not default) 0)
|
|
((parameter-default? (type-value default)) 3)
|
|
(else 1))
|
|
", "))
|
|
"")
|
|
"(sexp_proc1)" (func-stub-name func)
|
|
(cond
|
|
(default (lambda () (cat ", " (write-default default))))
|
|
(no-bind? ", SEXP_VOID")
|
|
(else ""))
|
|
");\n")))
|
|
|
|
(define (write-func-types var func)
|
|
(cond
|
|
((or (not (eq? 'sexp (type-base (func-ret-type func))))
|
|
(and (pair? (func-c-args func))
|
|
(any (lambda (a) (not (eq? 'sexp (type-base a))))
|
|
(func-c-args func))))
|
|
(cat
|
|
" if (sexp_opcodep(" var ")) {\n"
|
|
" sexp_opcode_return_type(" var ") = "
|
|
(type-id-init-value (func-ret-type func)) ";\n"
|
|
(lambda ()
|
|
(do ((ls (func-c-args func) (cdr ls))
|
|
(i 1 (+ i 1)))
|
|
((null? ls))
|
|
(cond
|
|
((eq? 'sexp (type-base (car ls))))
|
|
((<= i 3)
|
|
(cat " sexp_opcode_arg" i "_type(" var ") = "
|
|
(type-id-init-value (car ls)) ";\n"))
|
|
(else
|
|
(if (= i 4)
|
|
(cat " sexp_opcode_argn_type(" var ") = "
|
|
"sexp_make_vector(ctx, "
|
|
(make-integer (- (length (func-c-args func)) 3)) ", "
|
|
(make-integer "SEXP_OBJECT") ");\n"))
|
|
(cat " sexp_vector_set(sexp_opcode_argn_type(" var "), "
|
|
(make-integer (- i 4)) ", "
|
|
(type-id-init-value (car ls)) ");\n")))))
|
|
" }\n"))))
|
|
|
|
(define (write-func-binding func . o)
|
|
(let ((var (if (pair? o) (car o) "op")))
|
|
(write-func-creation var func)
|
|
(write-func-types var func)))
|
|
|
|
(define (write-method-binding meth)
|
|
(write-func-binding (cadr meth))
|
|
(adjust-method-name! (cadr meth) 0)
|
|
(cat " if (sexp_opcodep(op)) {\n"
|
|
(lambda ()
|
|
(cat " sexp_opcode_methods(op) = "
|
|
"sexp_make_vector(ctx, " (make-integer (length (cdr meth)))
|
|
", SEXP_VOID);\n")
|
|
(do ((ls (cdr meth) (cdr ls)) (i 0 (+ i 1)))
|
|
((null? ls))
|
|
(let ((var (string-append
|
|
"sexp_vector_ref(sexp_opcode_methods(op), "
|
|
(make-integer i) ")")))
|
|
(write-func-creation var (car ls) #t)
|
|
(write-func-types var (car ls)))))
|
|
" }\n"))
|
|
|
|
(define (write-type type)
|
|
(let ((name (car type))
|
|
(type (cdr type)))
|
|
(cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n"
|
|
" " (type-id-name name)
|
|
" = sexp_register_c_type(ctx, name, "
|
|
(cond ((memq 'finalizer: type)
|
|
=> (lambda (x) (generate-stub-name (cadr x))))
|
|
(else "sexp_finalize_c_type"))
|
|
");\n")
|
|
(cond
|
|
((memq 'predicate: type)
|
|
=> (lambda (x)
|
|
(let ((pred (cadr x)))
|
|
(cat " tmp = sexp_make_type_predicate(ctx, name, "
|
|
(type-id-name name) ");\n"
|
|
" name = sexp_intern(ctx, \"" pred "\", "
|
|
(string-length (x->string pred)) ");\n"
|
|
" sexp_env_define(ctx, env, name, tmp);\n")))))))
|
|
|
|
(define (type-getter-name type name field)
|
|
(string-append "sexp_" (x->string (type-name (parse-type name)))
|
|
"_get_" (x->string (type-base (parse-type (cadr field))))))
|
|
|
|
(define (write-type-getter type name field)
|
|
(cat "static sexp " (type-getter-name type name field)
|
|
" (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
|
|
(lambda () (write-validator "x" (parse-type name 0)))
|
|
" return "
|
|
(lambda ()
|
|
(c->scheme-converter
|
|
(car field)
|
|
(string-append (if (type-struct? (car field)) "&" "")
|
|
"((" (x->string (or (type-struct-type name) ""))
|
|
" " (mangle name) "*)"
|
|
"sexp_cpointer_value(x))" "->"
|
|
(x->string (cadr field)))
|
|
(and (or (type-struct? (car field)) (type-link? (car field))) "x")))
|
|
";\n"
|
|
"}\n\n"))
|
|
|
|
(define (type-setter-name type name field)
|
|
(string-append "sexp_" (x->string (type-name (parse-type name)))
|
|
"_set_" (x->string (type-base (parse-type (cadr field))))))
|
|
|
|
(define (write-type-setter-assignment type name field dst val)
|
|
(cond
|
|
((type-struct? (car field))
|
|
;; assign to a nested struct - copy field-by-field
|
|
(let ((field-type
|
|
(cond ((lookup-type (type-name (car field)))
|
|
=> (lambda (x) (cddr (cdr x))))
|
|
(else (cdr field)))))
|
|
(lambda ()
|
|
(for-each
|
|
(lambda (subfield)
|
|
(let ((subname (x->string (cadr subfield))))
|
|
(cat
|
|
" "
|
|
(string-append dst "." (x->string (cadr subfield)))
|
|
" = "
|
|
(string-append
|
|
"((" (x->string (or (type-struct-type (type-name (car field))) ""))
|
|
" " (mangle (type-name (car field))) "*)" "sexp_cpointer_value(" val "))"
|
|
"->" (x->string (cadr subfield)))
|
|
";\n")))
|
|
(struct-fields field-type)))))
|
|
(else
|
|
(lambda ()
|
|
(cat " " dst " = " (lambda () (scheme->c-converter (car field) val)) ";\n")))))
|
|
|
|
(define (write-type-setter type name field)
|
|
(cat "static sexp " (type-setter-name type name field)
|
|
" (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp v) {\n"
|
|
(lambda () (write-validator "x" (parse-type name 0)))
|
|
(lambda () (write-validator "v" (parse-type (car field) 1)))
|
|
(write-type-setter-assignment
|
|
type name field
|
|
(string-append "((" (x->string (or (type-struct-type name) ""))
|
|
" " (mangle name) "*)" "sexp_cpointer_value(x))"
|
|
"->" (x->string (cadr field)))
|
|
"v")
|
|
" return SEXP_VOID;\n"
|
|
"}\n\n"))
|
|
|
|
(define (write-type-funcs orig-type)
|
|
(let ((name (car orig-type))
|
|
(type (cdr orig-type)))
|
|
;; maybe write finalizer
|
|
(cond
|
|
((memq 'finalizer: type)
|
|
=> (lambda (x)
|
|
(cat "static sexp " (generate-stub-name (cadr x))
|
|
" (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
|
|
" if (sexp_cpointer_freep(x))\n"
|
|
" " (cadr x) "(sexp_cpointer_value(x));\n"
|
|
" return SEXP_VOID;\n"
|
|
"}\n\n"))))
|
|
;; maybe write constructor
|
|
(cond
|
|
((memq 'constructor: type)
|
|
=> (lambda (x)
|
|
(let ((make (car (cadr x)))
|
|
(args (cdr (cadr x))))
|
|
(cat "static sexp " (generate-stub-name make)
|
|
" (sexp ctx, sexp self, sexp_sint_t n"
|
|
(lambda ()
|
|
(let lp ((ls args) (i 0))
|
|
(cond ((pair? ls)
|
|
(cat ", sexp arg" i)
|
|
(lp (cdr ls) (+ i 1))))))
|
|
") {\n"
|
|
" " (type-c-name name) " r;\n"
|
|
" sexp_gc_var1(res);\n"
|
|
" sexp_gc_preserve1(ctx, res);\n"
|
|
;; TODO: support heap-managed allocations
|
|
;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer)"
|
|
;; " + sizeof(struct " (type-name name) "), "
|
|
;; (type-id-name name)
|
|
;; ");\n"
|
|
;; " r = sexp_cpointer_value(res) = "
|
|
;; "sexp_cpointer_body(res);\n"
|
|
;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), sexp_type_tag("
|
|
;; (type-id-name name)
|
|
;; "));\n"
|
|
" res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), "
|
|
"sexp_unbox_fixnum(sexp_opcode_return_type(self)));\n"
|
|
" sexp_cpointer_value(res) = calloc(1, sizeof("
|
|
(type-c-name-derefed name) "));\n"
|
|
" r = (" (type-c-name name) ") sexp_cpointer_value(res);\n"
|
|
" memset(r, 0, sizeof("
|
|
(type-c-name-derefed name) "));\n"
|
|
" sexp_freep(res) = 1;\n"
|
|
(lambda ()
|
|
(let lp ((ls args) (i 0))
|
|
(cond
|
|
((pair? ls)
|
|
(let* ((a (car ls))
|
|
(field
|
|
(find (lambda (f) (and (pair? f) (eq? a (cadr f))))
|
|
(cddr x))))
|
|
(if field
|
|
(cat " r->" (cadr field) " = "
|
|
(lambda ()
|
|
(scheme->c-converter
|
|
(car field)
|
|
(string-append "arg"
|
|
(number->string i))))
|
|
";\n"))
|
|
(lp (cdr ls) (+ i 1)))))))
|
|
" sexp_gc_release1(ctx);\n"
|
|
" return res;\n"
|
|
"}\n\n")
|
|
(set! *funcs*
|
|
(cons (parse-func
|
|
`(,name ,make
|
|
,(map (lambda (a)
|
|
(cond
|
|
((find (lambda (x) (eq? a (cadr x)))
|
|
(struct-fields type))
|
|
=> car)
|
|
(else 'sexp)))
|
|
args)))
|
|
*funcs*))))))
|
|
;; write field accessors
|
|
(for-each
|
|
(lambda (field)
|
|
(cond
|
|
((and (pair? field) (pair? (cdr field)))
|
|
(cond
|
|
((and (pair? (cddr field)) (car (cddr field)))
|
|
(write-type-getter type name field)
|
|
(set! *funcs*
|
|
(cons (parse-func
|
|
`(,(car field)
|
|
(,(car (cddr field))
|
|
#f
|
|
,(type-getter-name type name field))
|
|
(,name)))
|
|
*funcs*))))
|
|
(cond
|
|
((and (pair? (cddr field))
|
|
(pair? (cdr (cddr field)))
|
|
(cadr (cddr field)))
|
|
(write-type-setter type name field)
|
|
(set! *funcs*
|
|
(cons (parse-func
|
|
`(,(car field)
|
|
(,(cadr (cddr field))
|
|
#f
|
|
,(type-setter-name type name field))
|
|
(,name ,(car field))))
|
|
*funcs*)))))))
|
|
(struct-fields type))))
|
|
|
|
(define (write-const const)
|
|
(let ((scheme-name (if (pair? (cadr const)) (car (cadr const)) (cadr const)))
|
|
(c-name (if (pair? (cadr const)) (cadr (cadr const)) (mangle (cadr const)))))
|
|
(cat " name = sexp_intern(ctx, \"" scheme-name "\", "
|
|
(string-length (x->string scheme-name)) ");\n"
|
|
" sexp_env_define(ctx, env, name, tmp="
|
|
(lambda () (c->scheme-converter (car const) c-name)) ");\n")))
|
|
|
|
(define (write-utilities)
|
|
(define (input-env-string? x)
|
|
(and (eq? 'env-string (type-base x)) (not (type-result? x))))
|
|
(cond
|
|
((any (lambda (f)
|
|
(or (any input-env-string? (func-results f))
|
|
(any input-env-string? (func-scheme-args f))))
|
|
*funcs*)
|
|
(cat "static char* sexp_concat_env_string (sexp x) {\n"
|
|
" int klen=sexp_string_length(sexp_car(x)), vlen=sexp_string_length(sexp_cdr(x));\n"
|
|
" char *res = (char*) calloc(1, klen+vlen+2);\n"
|
|
" strncpy(res, sexp_string_data(sexp_car(x)), klen);\n"
|
|
" res[sexp_string_length(sexp_car(x))] = '=';\n"
|
|
" strncpy(res+sexp_string_length(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n"
|
|
" res[len-1] = '\\0';\n"
|
|
" return res;\n"
|
|
"}\n\n"))))
|
|
|
|
(define (write-init)
|
|
(newline)
|
|
(write-utilities)
|
|
(for-each write-func *funcs*)
|
|
(for-each write-method *methods*)
|
|
(for-each write-type-funcs *types*)
|
|
(for-each (lambda (n) (cat "} // " n "\n")) *open-namespaces*)
|
|
(newline)
|
|
(if *c++?*
|
|
(cat "extern \"C\" "))
|
|
(cat "sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) {\n"
|
|
(lambda ()
|
|
(for-each
|
|
(lambda (t) (cat " sexp " t ";\n"))
|
|
*tags*))
|
|
" sexp_gc_var3(name, tmp, op);\n"
|
|
" if (!(sexp_version_compatible(ctx, version, sexp_version)\n"
|
|
" && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))\n"
|
|
" return sexp_global(ctx, SEXP_G_ABI_ERROR);\n"
|
|
" sexp_gc_preserve3(ctx, name, tmp, op);\n")
|
|
(for-each write-const *consts*)
|
|
(for-each write-type *types*)
|
|
(for-each write-func-binding *funcs*)
|
|
(for-each write-method-binding *methods*)
|
|
(for-each (lambda (x) (cat " " x "\n")) (reverse *inits*))
|
|
(cat " sexp_gc_release3(ctx);\n"
|
|
" return SEXP_VOID;\n"
|
|
"}\n\n"))
|
|
|
|
(define (generate file)
|
|
(cat "/* Automatically generated by chibi-ffi; version: "
|
|
*ffi-version* " */\n")
|
|
(c-system-include "chibi/eval.h")
|
|
(load file)
|
|
(write-init))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; main
|
|
|
|
(define (main args)
|
|
(if (not (null? args)) (set! args (cdr args)))
|
|
(let* ((compile? (and (pair? args) (member (car args) '("-c" "--compile"))))
|
|
(args (if compile? (cdr args) args))
|
|
(cflags (if (and (pair? args) (member (car args) '("-f" "--flags")))
|
|
(string-split (cadr args) #\space)
|
|
#f))
|
|
(args (if cflags (cddr args) args))
|
|
(src (if (pair? args) (car args) "/dev/stdin"))
|
|
(dest
|
|
(case (length args)
|
|
((0) "-")
|
|
((1) (string-append (strip-extension src) ".c"))
|
|
((2) (cadr args))
|
|
(else (error "usage: chibi-ffi [-c] <file.stub> [<output.c>]")))))
|
|
(if (equal? "-" dest)
|
|
(generate src)
|
|
(with-output-to-file dest (lambda () (generate src))))
|
|
(cond
|
|
((and compile? (not (equal? "-" dest)))
|
|
;; This has to use `eval' for bootstrapping, since we need
|
|
;; chibi-ffi to compile to (chibi process) module.
|
|
(let* ((so (string-append (strip-extension src) *shared-object-extension*))
|
|
(system (begin (eval '(import (chibi process)))
|
|
(eval 'system)))
|
|
(base-args (append (or cflags '())
|
|
`("-o" ,so ,dest "-lchibi-scheme")))
|
|
(args (cond-expand
|
|
(macosx (append '("-dynamiclib" "-Oz") base-args))
|
|
(else (append '("-fPIC" "-shared" "-Os") base-args)))))
|
|
(apply system (if *c++?* "c++" "cc") args))))))
|