mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-22 07:09:18 +02:00
786 lines
28 KiB
Scheme
Executable file
786 lines
28 KiB
Scheme
Executable file
#! chibi-scheme -s
|
|
|
|
;; Simple C FFI. "genstubs.scm 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).
|
|
|
|
;; 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.
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Struct Interface
|
|
;;
|
|
;; (define-c-struct struct-name
|
|
;; [predicate: predicate-name]
|
|
;; [constructor: constructor-name]
|
|
;; [finalizer: c_finalizer_name]
|
|
;; (type c_field_name getter-name setter-name) ...)
|
|
;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Function Interface
|
|
;;
|
|
;; (define-c return-type name-spec (arg-type ...))
|
|
;;
|
|
;; where name-space is either a symbol name, or a list of
|
|
;; (scheme-name c_name). If just a symbol, the C name is taken
|
|
;; to be the same with -'s replaced by _'s.
|
|
;;
|
|
;; arg-type is a type suitable for input validation and conversion.
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Types
|
|
;;
|
|
;; Types
|
|
;;
|
|
;; Basic Types
|
|
;; void
|
|
;; boolean
|
|
;; char
|
|
;;
|
|
;; Integer Types:
|
|
;; short int long
|
|
;; unsigned-short unsigned-int unsigned-long size_t pid_t
|
|
;; time_t (in seconds, but using the chibi epoch of 2010/01/01)
|
|
;; errno (as a return type returns #f on error)
|
|
;;
|
|
;; Float Types:
|
|
;; float double long-double
|
|
;;
|
|
;; String Types:
|
|
;; string (a null-terminated char*)
|
|
;;
|
|
;; Port Types:
|
|
;; input-port output-port
|
|
;;
|
|
;; Struct Types:
|
|
;;
|
|
;; Struct types are by default just referred to by the bare
|
|
;; struct-name from define-c-struct, and it is assumed you want a
|
|
;; pointer to that type. To refer to the full struct, use the struct
|
|
;; modifier, as in (struct struct-name).
|
|
|
|
;; Type modifiers
|
|
;;
|
|
;; Any type may also be written as a list of modifiers followed by the
|
|
;; type itself. The supported modifiers are:
|
|
;;
|
|
;; const: prepends the "const" C type modifier
|
|
;; * as a return or result parameter, makes non-immediates immutable
|
|
;;
|
|
;; free: it's Scheme's responsibility to "free" this resource
|
|
;; * as a return or result parameter, registers the freep flag
|
|
;; this causes the type finalizer to be run when GCed
|
|
;;
|
|
;; maybe-null: this pointer type may be NULL
|
|
;; * as a result parameter, NULL is translated to #f
|
|
;; normally this would just return a wrapped NULL pointer
|
|
;; * as an input parameter, #f is translated to NULL
|
|
;; normally this would be a type error
|
|
;;
|
|
;; pointer: create a pointer to this type
|
|
;; * as a return parameter, wraps the result in a vanilla cpointer
|
|
;; * as a result parameter, boxes then unboxes the value
|
|
;;
|
|
;; struct: treat this struct type as a struct, not a pointer
|
|
;; * as an input parameter, dereferences the pointer
|
|
;; * as a type field, indicates a nested struct
|
|
;;
|
|
;; link: add a gc link
|
|
;; * as a field getter, link to the parent object, so the
|
|
;; parent won't be GCed so long as we have a reference
|
|
;; to the child. this behavior is automatic for nested
|
|
;; structs.
|
|
;;
|
|
;; result: return a result in this parameter
|
|
;; * if there are multiple results (including the return type),
|
|
;; they are all returned in a list
|
|
;; * if there are any result parameters, a return type
|
|
;; of errno returns #f on failure, and as eliminated
|
|
;; from the list of results otherwise
|
|
;;
|
|
;; (value <expr>): specify a fixed value
|
|
;; * as an input parameter, this parameter is not provided
|
|
;; in the Scheme API but always passed as <expr>
|
|
;;
|
|
;; (default <expr>): specify a default value
|
|
;; * as the final input parameter, makes the Scheme parameter
|
|
;; optional, defaulting to <expr>
|
|
;;
|
|
;; (array <type> [<length>]) an array type
|
|
;; * length must be specified for return and result parameters
|
|
;; * if specified, length can be any of
|
|
;; ** an integer, for a fixed size
|
|
;; ** the symbol null, indicating a NULL-terminated array
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define types '())
|
|
(define funcs '())
|
|
|
|
(define (make-type type free? const? null? ptr? struct? link? result? array value default? i)
|
|
(vector type free? const? null? ptr? struct? link? result? array value default? i))
|
|
|
|
(define (with-parsed-type type proc . o)
|
|
(cond
|
|
((vector? type)
|
|
(apply proc (vector->list type)))
|
|
(else
|
|
(let lp ((type type) (free? #f) (const? #f) (null-ptr? #f)
|
|
(ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f)
|
|
(value #f) (default? #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? struct? link? result? array value default?))
|
|
((const) (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?))
|
|
((maybe-null) (lp (next) free? const? #t ptr? struct? link? result? array value default?))
|
|
((pointer) (lp (next) free? const? null-ptr? #t struct? link? result? array value default?))
|
|
((struct) (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?))
|
|
((link) (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?))
|
|
((result) (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?))
|
|
((array) (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?))
|
|
((value) (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?))
|
|
((default) (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t))
|
|
(else (proc type free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o)))))))))
|
|
|
|
(define (parse-type type . o)
|
|
(with-parsed-type type make-type (and (pair? o) (car o))))
|
|
(define (maybe-parse-type type)
|
|
(if (vector? type) type (parse-type type)))
|
|
|
|
(define (type-base type) (vector-ref (maybe-parse-type type) 0))
|
|
(define (type-free type) (vector-ref (maybe-parse-type type) 1))
|
|
(define (type-const type) (vector-ref (maybe-parse-type type) 2))
|
|
(define (type-null? type) (vector-ref (maybe-parse-type type) 3))
|
|
(define (type-pointer? type) (vector-ref (maybe-parse-type type) 4))
|
|
(define (type-struct? type) (vector-ref (maybe-parse-type type) 5))
|
|
(define (type-link? type) (vector-ref (maybe-parse-type type) 6))
|
|
(define (type-result? type) (vector-ref (maybe-parse-type type) 7))
|
|
(define (type-array type) (vector-ref (maybe-parse-type type) 8))
|
|
(define (type-value type) (vector-ref (maybe-parse-type type) 9))
|
|
(define (type-default? type) (vector-ref (maybe-parse-type type) 10))
|
|
(define (type-index type) (vector-ref (maybe-parse-type type) 11))
|
|
|
|
(define (cat . args)
|
|
(for-each (lambda (x) (if (procedure? x) (x) (display x))) args))
|
|
|
|
(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 (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 (mangle x)
|
|
(string-replace
|
|
(string-replace (string-replace (x->string x) #\- "_") #\? "_p")
|
|
#\! "_x"))
|
|
|
|
(define (string-scan c str . o)
|
|
(let ((limit (string-length str)))
|
|
(let lp ((i (if (pair? o) (car o) 0)))
|
|
(cond ((>= i limit) #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 (definite-article x)
|
|
(define (vowel? c)
|
|
(memv c '(#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U)))
|
|
(define (vowel-exception? str)
|
|
(member (string-downcase str)
|
|
'("european" "ewe" "unicorn" "unicycle" "university" "user")))
|
|
(define (consonant-exception? str)
|
|
;; not "historic" according to elements of style
|
|
(member (string-downcase str)
|
|
'("heir" "herb" "herbal" "herbivore" "honest" "honor" "hour")))
|
|
(let* ((full-str (with-output-to-string (lambda () (cat x))))
|
|
(i (string-scan #\space full-str))
|
|
(str (if i (substring full-str 0 i) full-str)))
|
|
(string-append
|
|
(cond
|
|
((equal? str "") "a ")
|
|
((vowel? (string-ref str 0)) (if (vowel-exception? str) "a " "an "))
|
|
(else (if (consonant-exception? str) "an " "a ")))
|
|
full-str)))
|
|
|
|
(define (func-name func)
|
|
(caddr func))
|
|
|
|
(define (func-scheme-name x)
|
|
(if (pair? x) (car x) x))
|
|
|
|
(define (func-c-name x)
|
|
(if (pair? x) (cadr x) x))
|
|
|
|
(define (stub-name sym)
|
|
(string-append "sexp_" (mangle sym) "_stub"))
|
|
|
|
(define (type-id-name sym)
|
|
(string-append "sexp_" (mangle sym) "_type_id"))
|
|
|
|
(define (signed-int-type? type)
|
|
(memq type '(short int long)))
|
|
|
|
(define (unsigned-int-type? type)
|
|
(memq type '(unsigned-short unsigned-int unsigned-long size_t pid_t)))
|
|
|
|
(define (int-type? type)
|
|
(or (signed-int-type? type) (unsigned-int-type? type)))
|
|
|
|
(define (float-type? type)
|
|
(memq type '(float double long-double)))
|
|
|
|
(define (c-declare . args)
|
|
(apply cat args)
|
|
(newline))
|
|
|
|
(define (c-system-include header)
|
|
(cat "\n#include <" header ">\n"))
|
|
|
|
(define-syntax define-c-struct
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(set! types (cons (cdr expr) types))
|
|
`(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n"))))
|
|
|
|
(define-syntax define-c
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(set! funcs (cons (cons (stub-name (func-scheme-name (caddr expr)))
|
|
(cdr expr))
|
|
funcs))
|
|
#f)))
|
|
|
|
(define (c->scheme-converter type val . o)
|
|
(with-parsed-type
|
|
type
|
|
(lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i)
|
|
(cond
|
|
((eq? type 'void)
|
|
(cat "((" val "), SEXP_VOID)"))
|
|
((memq type '(sexp errno))
|
|
(cat val))
|
|
((eq? type 'time_t)
|
|
(cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))"))
|
|
((int-type? type)
|
|
(cat "sexp_make_integer(ctx, " val ")"))
|
|
((eq? 'string type)
|
|
(cat "sexp_c_string(ctx, " val ", -1)"))
|
|
((eq? 'input-port type)
|
|
(cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)"))
|
|
((eq? 'output-port type)
|
|
(cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)"))
|
|
(else
|
|
(let ((ctype (assq type types)))
|
|
(cond
|
|
(ctype
|
|
(cat "sexp_make_cpointer(ctx, " (type-id-name type) ", "
|
|
val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", "
|
|
(if free? 1 0) ")"))
|
|
(else
|
|
(error "unknown type" type)))))))))
|
|
|
|
(define (scheme->c-converter type val)
|
|
(with-parsed-type
|
|
type
|
|
(lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i)
|
|
(cond
|
|
((eq? type 'sexp)
|
|
(cat val))
|
|
((eq? type 'time_t)
|
|
(cat "sexp_uint_value(sexp_unshift_epoch(" val "))"))
|
|
((signed-int-type? type)
|
|
(cat "sexp_sint_value(" val ")"))
|
|
((unsigned-int-type? type)
|
|
(cat "sexp_uint_value(" val ")"))
|
|
((eq? 'string type)
|
|
(cat "sexp_string_data(" val ")"))
|
|
(else
|
|
(let ((ctype (assq type types)))
|
|
(cond
|
|
(ctype
|
|
(cat (if null-ptr?
|
|
"sexp_cpointer_maybe_null_value"
|
|
"sexp_cpointer_value")
|
|
"(" val ")"))
|
|
(else
|
|
(error "unknown type" type)))))))))
|
|
|
|
(define (type-predicate type)
|
|
(with-parsed-type
|
|
type
|
|
(lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i)
|
|
(cond
|
|
((int-type? type) "sexp_exact_integerp")
|
|
((float-type? type) "sexp_flonump")
|
|
((eq? 'string type) "sexp_stringp")
|
|
(else #f)))))
|
|
|
|
(define (type-name type)
|
|
(with-parsed-type
|
|
type
|
|
(lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i)
|
|
(cond
|
|
((int-type? type) "integer")
|
|
((float-type? type) "flonum")
|
|
(else type)))))
|
|
|
|
(define (type-c-name type)
|
|
(with-parsed-type
|
|
type
|
|
(lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
|
|
(let ((struct? (assq base-type types)))
|
|
(string-append
|
|
(if const? "const " "")
|
|
(if struct? "struct " "")
|
|
(string-replace (symbol->string base-type) #\- #\space)
|
|
(if struct? "*" "")
|
|
(if ptr? "*" ""))))))
|
|
|
|
(define (check-type arg type)
|
|
(with-parsed-type
|
|
type
|
|
(lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
|
|
(cond
|
|
((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type))
|
|
(cat (type-predicate type) "(" arg ")"))
|
|
(else
|
|
(cond
|
|
((assq base-type types)
|
|
(cat
|
|
(if null-ptr? "(" "")
|
|
"(sexp_pointerp(" arg ")"
|
|
" && (sexp_pointer_tag(" arg ") == " (type-id-name base-type) "))"
|
|
(lambda () (if null-ptr? (cat " || sexp_not(" arg "))")))))
|
|
(else
|
|
(display "WARNING: don't know how to check: " (current-error-port))
|
|
(write type (current-error-port))
|
|
(newline (current-error-port))
|
|
(cat "1"))))))))
|
|
|
|
(define (validate-type arg type)
|
|
(with-parsed-type
|
|
type
|
|
(lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
|
|
(cond
|
|
((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type))
|
|
(cat
|
|
" if (! " (lambda () (check-type arg type)) ")\n"
|
|
" return sexp_type_exception(ctx, \"not "
|
|
(definite-article (type-name type)) "\", "
|
|
arg ");\n"))
|
|
(else
|
|
(cond
|
|
((assq base-type types)
|
|
(cat
|
|
" if (! " (lambda () (check-type arg type)) ")\n"
|
|
" return sexp_type_exception(ctx, \"not "
|
|
(definite-article type) "\", " arg ");\n"))
|
|
(else
|
|
(display "WARNING: don't know how to validate: " (current-error-port))
|
|
(write type (current-error-port))
|
|
(newline (current-error-port))
|
|
(write type))))))))
|
|
|
|
(define (get-func-result func)
|
|
(let lp ((ls (cadddr func)))
|
|
(and (pair? ls)
|
|
(if (memq 'result (car ls))
|
|
(car ls)
|
|
(lp (cdr ls))))))
|
|
|
|
(define (get-func-args func)
|
|
(let lp ((ls (cadddr func)) (res '()))
|
|
(if (pair? ls)
|
|
(if (and (pair? (car ls))
|
|
(or (memq 'result (car ls)) (memq 'value (car ls))))
|
|
(lp (cdr ls) res)
|
|
(lp (cdr ls) (cons (car ls) res)))
|
|
(reverse res))))
|
|
|
|
(define (with-parsed-func func proc)
|
|
(let* ((ret-type (parse-type (cadr func)))
|
|
(scheme-name (if (pair? (caddr func)) (caaddr func) (caddr func)))
|
|
(c-name (if (pair? (caddr func))
|
|
(cadr (caddr func))
|
|
(mangle scheme-name))))
|
|
(let lp ((ls (cadddr func))
|
|
(i 0)
|
|
(results '())
|
|
(c-args '())
|
|
(s-args '()))
|
|
(cond
|
|
((null? ls)
|
|
(proc scheme-name c-name ret-type
|
|
(reverse results) (reverse c-args) (reverse s-args)))
|
|
(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))
|
|
((type-value 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 (write-parameters args)
|
|
(lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args)))
|
|
|
|
(define (write-locals func)
|
|
(with-parsed-func func
|
|
(lambda (scheme-name c-name ret-type results c-args scheme-args)
|
|
(cat " sexp res;\n"))))
|
|
|
|
(define (write-validators args)
|
|
(for-each
|
|
(lambda (a)
|
|
(validate-type (string-append "arg" (number->string (type-index arg))) a))
|
|
args))
|
|
|
|
(define (write-temporaries func)
|
|
#f)
|
|
|
|
(define (write-call ret-type c-name c-args)
|
|
(cat (if (eq? 'errno (type-base ret-type)) " err = " " res = "))
|
|
(c->scheme-converter
|
|
ret-type
|
|
(lambda ()
|
|
(cat c-name "(")
|
|
(for-each
|
|
(lambda (arg)
|
|
(if (> (type-index arg) 0) (cat ", "))
|
|
(cond
|
|
((type-result? arg)
|
|
(cat (if (or (type-pointer? result) (type-array result)) "" "&")
|
|
"tmp"))
|
|
((type-value arg)
|
|
=> (lambda (x) (write x)))
|
|
(else
|
|
(scheme->c-converter arg (string-append "arg" (type-index arg))))))
|
|
c-args)
|
|
(cat ");\n"))))
|
|
|
|
(define (write-result result)
|
|
(if (type-array (car result))
|
|
(cat " sexp_gc_preserve1(ctx, res);\n"
|
|
" res = SEXP_NULL;\n"
|
|
" for (i=" (type-array (car result)) "-1; i>=0; i--) {\n"
|
|
" sexp_push(ctx, res, SEXP_VOID);\n"
|
|
" sexp_car(res) = "
|
|
(lambda () (c->scheme-converter (car result) "tmp[i]")) ";\n"
|
|
" }\n"
|
|
" sexp_gc_release1(ctx);\n")
|
|
(c->scheme-converter (car result) "tmp")))
|
|
|
|
(define (write-results ret-type results)
|
|
(if (eq? 'errno (type-base ret-type))
|
|
(cat " if (err) {\n"
|
|
" res = SEXP_FALSE;\n"
|
|
" } else {\n"))
|
|
(if (null? results)
|
|
(cat " res = SEXP_TRUE;\n")
|
|
(for-each write-result results))
|
|
(if (eq? 'errno (type-base ret-type))
|
|
(cat " }\n")))
|
|
|
|
(define (write-cleanup func)
|
|
#f)
|
|
|
|
(define (write-func func)
|
|
(with-parsed-func func
|
|
(lambda (scheme-name c-name ret-type results c-args scheme-args)
|
|
(cat "static sexp " scheme-name
|
|
"(sexp ctx" (write-parameters scheme-args) ") {\n"
|
|
(write-locals func)
|
|
(write-validators scheme-args)
|
|
(write-temporaries func)
|
|
(write-call ret-type c-name c-args)
|
|
(write-result ret-type results)
|
|
(write-cleanup func)
|
|
" return res;\n"
|
|
"}\n\n"))))
|
|
|
|
(define (write-func func)
|
|
(let ((ret-type (cadr func))
|
|
(result (get-func-result func))
|
|
(args (get-func-args func)))
|
|
(cat "static sexp " (car func) "(sexp ctx")
|
|
(let lp ((ls args) (i 0))
|
|
(cond ((pair? ls)
|
|
(cat ", sexp arg" i)
|
|
(lp (cdr ls) (+ i 1)))))
|
|
(cat ") {\n "
|
|
(if (and result (type-array result)) "sexp_gc_var1(res)" "sexp res")
|
|
";\n")
|
|
(if (eq? 'errno ret-type) (cat " int err;\n"))
|
|
(if (type-array result) (cat " int i;\n"))
|
|
(if result
|
|
(cat " " (type-c-name result) (if (type-pointer? result) "*" "")
|
|
" tmp"
|
|
(if (type-array result)
|
|
(with-output-to-string
|
|
(lambda () (cat "[" (type-array result) "]")))
|
|
"")
|
|
";\n"))
|
|
(let lp ((ls args) (i 0))
|
|
(cond ((pair? ls)
|
|
(validate-type (string-append "arg" (number->string i)) (car ls))
|
|
(lp (cdr ls) (+ i 1)))))
|
|
(cat (if (eq? 'errno ret-type) " err = " " res = "))
|
|
(c->scheme-converter
|
|
ret-type
|
|
(lambda ()
|
|
(cat (func-c-name (func-name func)) "(")
|
|
(let lp ((ls (cadddr func)) (i 0))
|
|
(cond ((pair? ls)
|
|
(cat (cond
|
|
((eq? (car ls) result)
|
|
(lambda () (cat (if (or (type-pointer? result)
|
|
(type-array result))
|
|
""
|
|
"&")
|
|
"tmp")))
|
|
((and (pair? (car ls)) (memq 'value (car ls)))
|
|
=> (lambda (x) (write (cadr x)) ""))
|
|
(else
|
|
(lambda ()
|
|
(scheme->c-converter
|
|
(car ls)
|
|
(string-append "arg" (number->string i))))))
|
|
(if (pair? (cdr ls)) ", " ""))
|
|
(lp (cdr ls) (+ i 1)))))
|
|
(cat ")")))
|
|
(cat ";\n")
|
|
(if (eq? 'errno ret-type)
|
|
(if result
|
|
(if (type-array result)
|
|
(cat " if (err) {\n"
|
|
" res = SEXP_FALSE;\n"
|
|
" } else {\n"
|
|
" sexp_gc_preserve1(ctx, res);\n"
|
|
" res = SEXP_NULL;\n"
|
|
" for (i=" (type-array result) "-1; i>=0; i--) {\n"
|
|
" sexp_push(ctx, res, SEXP_VOID);\n"
|
|
" sexp_car(res) = "
|
|
(lambda () (c->scheme-converter result "tmp[i]")) ";\n"
|
|
" }\n"
|
|
" sexp_gc_release1(ctx);\n"
|
|
" }\n")
|
|
(cat " res = (err ? SEXP_FALSE : "
|
|
(lambda () (c->scheme-converter result "tmp"))
|
|
");\n"))
|
|
(cat " res = sexp_make_boolean(! err);\n")))
|
|
(cat " return res;\n"
|
|
"}\n\n")))
|
|
|
|
(define (write-func-binding func)
|
|
(cat " sexp_define_foreign(ctx, env, "
|
|
(lambda () (write (symbol->string (func-scheme-name (func-name func)))))
|
|
", " (length (get-func-args func)) ", " (car func) ");\n"))
|
|
|
|
(define (write-type type)
|
|
(let ((name (car type))
|
|
(type (cdr type)))
|
|
(with-parsed-type
|
|
type
|
|
(lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
|
|
(cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n"
|
|
" " (type-id-name name)
|
|
" = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, "
|
|
(cond ((memq 'finalizer: base-type)
|
|
=> (lambda (x) (stub-name (cadr x))))
|
|
(else "sexp_finalize_c_type"))
|
|
"));\n")
|
|
(cond
|
|
((memq 'predicate: base-type)
|
|
=> (lambda (x)
|
|
(let ((pred (cadr x)))
|
|
(cat " tmp = sexp_make_type_predicate(ctx, name, "
|
|
"sexp_make_fixnum(" (type-id-name name) "));\n"
|
|
" name = sexp_intern(ctx, \"" pred "\");\n"
|
|
" sexp_env_define(ctx, env, name, tmp);\n")))))))))
|
|
|
|
(define (type-getter-name type name field)
|
|
(string-append "sexp_" (x->string (type-name name))
|
|
"_get_" (x->string (type-base (cadr field)))))
|
|
|
|
(define (write-type-getter type name field)
|
|
(with-parsed-type
|
|
(car field)
|
|
(lambda (field-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
|
|
(cat "static sexp " (type-getter-name type name field)
|
|
" (sexp ctx, sexp x) {\n"
|
|
(lambda () (validate-type "x" name))
|
|
" return "
|
|
(lambda ()
|
|
(c->scheme-converter
|
|
field-type
|
|
(string-append "((struct " (mangle name) "*)"
|
|
"sexp_cpointer_value(x))"
|
|
(if struct? "." "->")
|
|
(x->string (cadr field)))
|
|
(and (or struct? link?) "x")))
|
|
";\n"
|
|
"}\n\n"))))
|
|
|
|
(define (type-setter-name type name field)
|
|
(string-append "sexp_" (x->string (type-name name))
|
|
"_set_" (x->string (type-base (car field)))))
|
|
|
|
(define (write-type-setter type name field)
|
|
(with-parsed-type
|
|
(car field)
|
|
(lambda (field-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
|
|
(cat "static sexp " (type-setter-name type name field)
|
|
" (sexp ctx, sexp x, sexp v) {\n"
|
|
(lambda () (validate-type "x" name))
|
|
(lambda () (validate-type "v" (car field)))
|
|
" "
|
|
(lambda () (c->scheme-converter
|
|
field-type
|
|
(string-append "((struct " (mangle name) "*)"
|
|
"sexp_cpointer_value(x))"
|
|
(if struct? "." "->")
|
|
(x->string (cadr field)))))
|
|
" = v;\n"
|
|
" return SEXP_VOID;"
|
|
"}\n\n"))))
|
|
|
|
(define (write-type-funcs type)
|
|
(let ((name (car type))
|
|
(type (cdr type)))
|
|
(with-parsed-type
|
|
type
|
|
(lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
|
|
(cond
|
|
((memq 'finalizer: base-type)
|
|
=> (lambda (x)
|
|
(cat "static sexp " (stub-name (cadr x))
|
|
" (sexp ctx, sexp x) {\n"
|
|
" if (sexp_cpointer_freep(x))\n"
|
|
" " (cadr x) "(sexp_cpointer_value(x));\n"
|
|
" return SEXP_VOID;\n"
|
|
"}\n\n"))))
|
|
(cond
|
|
((memq 'constructor: base-type)
|
|
=> (lambda (x)
|
|
(let ((make (caadr x))
|
|
(args (cdadr x)))
|
|
(cat "static sexp " (stub-name make)
|
|
" (sexp ctx"
|
|
(lambda () (for-each (lambda (x) (cat ", sexp " x)) args))
|
|
") {\n"
|
|
" struct " (type-name name) " *r;\n"
|
|
" sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), "
|
|
(type-id-name name)
|
|
");\n"
|
|
" sexp_cpointer_value(res) = sexp_cpointer_body(res);\n"
|
|
" r = sexp_cpointer_value(res);\n"
|
|
" return res;\n"
|
|
"}\n\n")
|
|
(set! funcs
|
|
(cons (list (stub-name make) 'void make args) funcs))))))
|
|
(for-each
|
|
(lambda (field)
|
|
(cond
|
|
((and (pair? field) (pair? (cdr field)))
|
|
(cond
|
|
((and (pair? (cddr field)) (caddr field))
|
|
(write-type-getter type name field)
|
|
(set! funcs
|
|
(cons (list (type-getter-name type name field)
|
|
(car field) (caddr field) (list name))
|
|
funcs))))
|
|
(cond
|
|
((and (pair? (cddr field))
|
|
(pair? (cdddr field))
|
|
(car (cdddr field)))
|
|
(write-type-setter type name field)
|
|
(set! funcs
|
|
(cons (list (type-setter-name type name field)
|
|
(car field) (cadddr field)
|
|
(list name (car field)))
|
|
funcs)))))))
|
|
base-type)))))
|
|
|
|
(define (write-init)
|
|
(newline)
|
|
(for-each write-func funcs)
|
|
(for-each write-type-funcs types)
|
|
(cat "sexp sexp_init_library (sexp ctx, sexp env) {\n"
|
|
" sexp_gc_var2(name, tmp);\n"
|
|
" sexp_gc_preserve2(ctx, name, tmp);\n")
|
|
(for-each write-type types)
|
|
(for-each write-func-binding funcs)
|
|
(cat " sexp_gc_release2(ctx);\n"
|
|
" return SEXP_VOID;\n"
|
|
"}\n\n"))
|
|
|
|
(define (generate file)
|
|
(display "/* automatically generated by chibi genstubs */\n")
|
|
(c-system-include "chibi/eval.h")
|
|
(load file)
|
|
(write-init))
|
|
|
|
(define (main args)
|
|
(case (length args)
|
|
((1)
|
|
(with-output-to-file (string-append (strip-extension (car args)) ".c")
|
|
(lambda () (generate (car args)))))
|
|
((2)
|
|
(if (equal? "-" (cadr args))
|
|
(generate (car args))
|
|
(with-output-to-file (cadr args) (lambda () (generate (car args))))))
|
|
(else
|
|
(error "usage: genstubs <file.stub> [<output.c>]"))))
|
|
|
|
(main (command-line-arguments))
|
|
|