mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
add support for user-defined error types and functions in ffi, address-of, frameworks
This commit is contained in:
Alex Shinn
parent
10759e8bdb
commit
d8e2e4aa54
2 changed files with 198 additions and 85 deletions
|
|
@ -398,6 +398,42 @@ int getpwnam_x(char* name, struct password* pwd, char* buf,
|
||||||
(test-not (getpwnam_x "hacker" (make-string 1024)))
|
(test-not (getpwnam_x "hacker" (make-string 1024)))
|
||||||
)
|
)
|
||||||
|
|
||||||
|
(test-ffi
|
||||||
|
"error-results"
|
||||||
|
(begin
|
||||||
|
(c-declare "
|
||||||
|
char* err2str(int err) {
|
||||||
|
switch (err) {
|
||||||
|
case 0: return NULL;
|
||||||
|
case 1: return \"domain error\";
|
||||||
|
case 2: return \"bad things\";
|
||||||
|
}
|
||||||
|
return \"unknown error\";
|
||||||
|
}
|
||||||
|
|
||||||
|
int fib(int n, int* status) {
|
||||||
|
if (n < 0)
|
||||||
|
*status = 1;
|
||||||
|
if (n > 5)
|
||||||
|
*status = 2;
|
||||||
|
if (*status)
|
||||||
|
return 0;
|
||||||
|
if (n <= 1)
|
||||||
|
return 1;
|
||||||
|
return fib(n-1, status) + fib(n-2, status);
|
||||||
|
}
|
||||||
|
")
|
||||||
|
(define-c int fib
|
||||||
|
(int (error err2str int))))
|
||||||
|
(test 1 (fib 0))
|
||||||
|
(test 1 (fib 1))
|
||||||
|
(test 2 (fib 2))
|
||||||
|
(test 8 (fib 5))
|
||||||
|
(test "domain error"
|
||||||
|
(protect (exn (else (exception-message exn))) (fib -1)))
|
||||||
|
(test "bad things"
|
||||||
|
(protect (exn (else (exception-message exn))) (fib 10))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Field introspection and matching.
|
;; Field introspection and matching.
|
||||||
|
|
||||||
|
|
|
||||||
247
tools/chibi-ffi
247
tools/chibi-ffi
|
|
@ -31,7 +31,7 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; globals
|
;; globals
|
||||||
|
|
||||||
(define *ffi-version* "0.3")
|
(define *ffi-version* "0.4")
|
||||||
(define *types* '())
|
(define *types* '())
|
||||||
(define *type-getters* '())
|
(define *type-getters* '())
|
||||||
(define *type-setters* '())
|
(define *type-setters* '())
|
||||||
|
|
@ -42,6 +42,7 @@
|
||||||
(define *inits* '())
|
(define *inits* '())
|
||||||
(define *clibs* '())
|
(define *clibs* '())
|
||||||
(define *cflags* '())
|
(define *cflags* '())
|
||||||
|
(define *frameworks* '())
|
||||||
(define *tags* '())
|
(define *tags* '())
|
||||||
(define *open-namespaces* '())
|
(define *open-namespaces* '())
|
||||||
(define *c++?* #f)
|
(define *c++?* #f)
|
||||||
|
|
@ -50,48 +51,7 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; type objects
|
;; type objects
|
||||||
|
|
||||||
(define (parse-type type . o)
|
(define (make-type) (make-vector 18 #f))
|
||||||
(cond
|
|
||||||
((vector? type)
|
|
||||||
(if (and (pair? o) (car o))
|
|
||||||
(let ((res (vector-copy type)))
|
|
||||||
(type-index-set! res (car o))
|
|
||||||
res)
|
|
||||||
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) (new? #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 new?))
|
|
||||||
((const)
|
|
||||||
(lp (next) free? #t null-ptr? ptr? ref? struct? link? result? array value default? template new?))
|
|
||||||
((maybe-null)
|
|
||||||
(lp (next) free? const? #t ptr? ref? struct? link? result? array value default? template new?))
|
|
||||||
((pointer)
|
|
||||||
(lp (next) free? const? null-ptr? #t ref? struct? link? result? array value default? template new?))
|
|
||||||
((reference)
|
|
||||||
(lp (next) free? const? null-ptr? ptr? #t struct? link? result? array value default? template new?))
|
|
||||||
((struct)
|
|
||||||
(lp (next) free? const? null-ptr? ptr? ref? #t link? result? array value default? template new?))
|
|
||||||
((link)
|
|
||||||
(lp (next) free? const? null-ptr? ptr? ref? struct? #t result? array value default? template new?))
|
|
||||||
((result)
|
|
||||||
(lp (next) free? const? null-ptr? ptr? ref? struct? link? #t array value default? template new?))
|
|
||||||
((array)
|
|
||||||
(lp (cadr type) free? const? null-ptr? ref? ptr? struct? link? result? (if (pair? (cddr type)) (car (cddr type)) #t) value default? template new?))
|
|
||||||
((value)
|
|
||||||
(lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) default? template new?))
|
|
||||||
((default)
|
|
||||||
(lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) #t template new?))
|
|
||||||
((template)
|
|
||||||
(lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array value default? (cadr type) new?))
|
|
||||||
((new)
|
|
||||||
(lp (next) free? const? null-ptr? ref? ptr? struct? link? result? array value default? template #t))
|
|
||||||
(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 new? (and (pair? o) (car o)))))))))
|
|
||||||
|
|
||||||
(define (type-base type) (vector-ref type 0))
|
(define (type-base type) (vector-ref type 0))
|
||||||
(define (type-free? type) (vector-ref type 1))
|
(define (type-free? type) (vector-ref type 1))
|
||||||
|
|
@ -107,8 +67,86 @@
|
||||||
(define (type-default? type) (vector-ref type 11))
|
(define (type-default? type) (vector-ref type 11))
|
||||||
(define (type-template type) (vector-ref type 12))
|
(define (type-template type) (vector-ref type 12))
|
||||||
(define (type-new? type) (vector-ref type 13))
|
(define (type-new? type) (vector-ref type 13))
|
||||||
(define (type-index type) (vector-ref type 14))
|
(define (type-error type) (vector-ref type 14))
|
||||||
(define (type-index-set! type i) (vector-set! type 14 i))
|
(define (type-address-of? type) (vector-ref type 15))
|
||||||
|
(define (type-no-free? type) (vector-ref type 16))
|
||||||
|
(define (type-index type) (vector-ref type 17))
|
||||||
|
(define (type-index-set! type i) (vector-set! type 17 i))
|
||||||
|
|
||||||
|
(define (spec->type type . o)
|
||||||
|
(let ((res (make-type)))
|
||||||
|
(if (pair? o)
|
||||||
|
(type-index-set! res (car o)))
|
||||||
|
(let lp ((type type))
|
||||||
|
(define (next) (if (null? (cddr type)) (cadr type) (cdr type)))
|
||||||
|
(case (and (pair? type) (car type))
|
||||||
|
((free)
|
||||||
|
(vector-set! res 1 #t)
|
||||||
|
(lp (next)))
|
||||||
|
((const)
|
||||||
|
(vector-set! res 2 #t)
|
||||||
|
(lp (next)))
|
||||||
|
((maybe-null)
|
||||||
|
(vector-set! res 3 #t)
|
||||||
|
(lp (next)))
|
||||||
|
((pointer)
|
||||||
|
(vector-set! res 4 #t)
|
||||||
|
(lp (next)))
|
||||||
|
((reference)
|
||||||
|
(vector-set! res 5 #t)
|
||||||
|
(lp (next)))
|
||||||
|
((struct)
|
||||||
|
(vector-set! res 6 #t)
|
||||||
|
(lp (next)))
|
||||||
|
((link)
|
||||||
|
(vector-set! res 7 #t)
|
||||||
|
(lp (next)))
|
||||||
|
((result)
|
||||||
|
(vector-set! res 8 #t)
|
||||||
|
(lp (next)))
|
||||||
|
((array)
|
||||||
|
(vector-set! res 9 (if (pair? (cddr type)) (car (cddr type)) #t))
|
||||||
|
(lp (cadr type)))
|
||||||
|
((value)
|
||||||
|
(vector-set! res 10 (cadr type))
|
||||||
|
(lp (cddr type)))
|
||||||
|
((default)
|
||||||
|
(vector-set! res 10 (cadr type))
|
||||||
|
(vector-set! res 11 #t)
|
||||||
|
(lp (cddr type)))
|
||||||
|
((template)
|
||||||
|
(vector-set! res 12 (cadr type))
|
||||||
|
(lp (cddr type)))
|
||||||
|
((new)
|
||||||
|
(vector-set! res 13 #t)
|
||||||
|
(lp (next)))
|
||||||
|
((error)
|
||||||
|
(vector-set! res 8 #t)
|
||||||
|
(vector-set! res 14 (cadr type))
|
||||||
|
(lp (cddr type)))
|
||||||
|
((address-of)
|
||||||
|
(vector-set! res 15 #t)
|
||||||
|
(lp (next)))
|
||||||
|
((no-free)
|
||||||
|
(vector-set! res 16 #t)
|
||||||
|
(lp (next)))
|
||||||
|
(else
|
||||||
|
(let ((base (if (and (pair? type) (null? (cdr type)))
|
||||||
|
(car type)
|
||||||
|
type)))
|
||||||
|
(vector-set! res 0 base)
|
||||||
|
res))))))
|
||||||
|
|
||||||
|
(define (parse-type type . o)
|
||||||
|
(cond
|
||||||
|
((vector? type)
|
||||||
|
(if (and (pair? o) (car o))
|
||||||
|
(let ((res (vector-copy type)))
|
||||||
|
(type-index-set! res (car o))
|
||||||
|
res)
|
||||||
|
type))
|
||||||
|
(else
|
||||||
|
(apply spec->type type o))))
|
||||||
|
|
||||||
(define (type-auto-expand? type)
|
(define (type-auto-expand? type)
|
||||||
(and (pair? (type-array type))
|
(and (pair? (type-array type))
|
||||||
|
|
@ -199,7 +237,9 @@
|
||||||
(memq type '(port input-port output-port input-output-port)))
|
(memq type '(port input-port output-port input-output-port)))
|
||||||
|
|
||||||
(define (error-type? type)
|
(define (error-type? type)
|
||||||
(memq type '(errno status-bool non-null-string non-null-pointer)))
|
(or (type-error type)
|
||||||
|
(memq (type-base type)
|
||||||
|
'(errno status-bool non-null-string non-null-pointer))))
|
||||||
|
|
||||||
(define (array-type? type)
|
(define (array-type? type)
|
||||||
(and (type-array type) (not (eq? 'char (type-base type)))))
|
(and (type-array type) (not (eq? 'char (type-base type)))))
|
||||||
|
|
@ -419,6 +459,9 @@
|
||||||
(define (c-link lib)
|
(define (c-link lib)
|
||||||
(set! *clibs* (cons lib *clibs*)))
|
(set! *clibs* (cons lib *clibs*)))
|
||||||
|
|
||||||
|
(define (c-framework lib)
|
||||||
|
(set! *frameworks* (cons lib *frameworks*)))
|
||||||
|
|
||||||
(define (c-flags-from-script cmd)
|
(define (c-flags-from-script cmd)
|
||||||
(eval '(import (chibi process)) (current-environment))
|
(eval '(import (chibi process)) (current-environment))
|
||||||
(let ((string-null? (lambda (str) (equal? str "")))
|
(let ((string-null? (lambda (str) (equal? str "")))
|
||||||
|
|
@ -678,7 +721,7 @@
|
||||||
(cond
|
(cond
|
||||||
((and (eq? base 'void) (not (type-pointer? type)))
|
((and (eq? base 'void) (not (type-pointer? type)))
|
||||||
(cat "((" val "), SEXP_VOID)"))
|
(cat "((" val "), SEXP_VOID)"))
|
||||||
((or (eq? base 'sexp) (error-type? base))
|
((or (eq? base 'sexp) (error-type? type))
|
||||||
(cat val))
|
(cat val))
|
||||||
((memq base '(bool boolean status-bool))
|
((memq base '(bool boolean status-bool))
|
||||||
(cat "sexp_make_boolean(" val ")"))
|
(cat "sexp_make_boolean(" val ")"))
|
||||||
|
|
@ -731,7 +774,9 @@
|
||||||
val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", "
|
val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", "
|
||||||
(if (or (type-free? type)
|
(if (or (type-free? type)
|
||||||
(type-new? type)
|
(type-new? type)
|
||||||
(and (type-result? type) (not (basic-type? type))))
|
(and (type-result? type)
|
||||||
|
(not (basic-type? type))
|
||||||
|
(not (type-no-free? type))))
|
||||||
1
|
1
|
||||||
0)
|
0)
|
||||||
")"))
|
")"))
|
||||||
|
|
@ -786,6 +831,7 @@
|
||||||
((or ctype void*?)
|
((or ctype void*?)
|
||||||
(cat (if (or (type-struct? type) (type-reference? type)) "*" "")
|
(cat (if (or (type-struct? type) (type-reference? type)) "*" "")
|
||||||
"(" (type-c-name type) ")"
|
"(" (type-c-name type) ")"
|
||||||
|
(if (type-address-of? type) "&" "")
|
||||||
(if (type-null? type)
|
(if (type-null? type)
|
||||||
"sexp_cpointer_maybe_null_value"
|
"sexp_cpointer_maybe_null_value"
|
||||||
"sexp_cpointer_value")
|
"sexp_cpointer_value")
|
||||||
|
|
@ -983,7 +1029,7 @@
|
||||||
(let* ((ret-type (func-ret-type func))
|
(let* ((ret-type (func-ret-type func))
|
||||||
(results (func-results func))
|
(results (func-results func))
|
||||||
(scheme-args (func-scheme-args func))
|
(scheme-args (func-scheme-args func))
|
||||||
(return-res? (not (error-type? (type-base ret-type))))
|
(return-res? (not (error-type? ret-type)))
|
||||||
(preserve-res? (> (+ (length results)) (if return-res? 0 1)))
|
(preserve-res? (> (+ (length results)) (if return-res? 0 1)))
|
||||||
(single-res? (and (= 1 (length results)) (not return-res?)))
|
(single-res? (and (= 1 (length results)) (not return-res?)))
|
||||||
(tmp-string? (any (lambda (a)
|
(tmp-string? (any (lambda (a)
|
||||||
|
|
@ -1013,9 +1059,10 @@
|
||||||
" struct " (type-base ret-type) "* ptr_res;\n"))
|
" struct " (type-base ret-type) "* ptr_res;\n"))
|
||||||
(cond
|
(cond
|
||||||
((pair? ints)
|
((pair? ints)
|
||||||
(cat " int " (car ints))
|
(cat " int " (car ints) " = 0"
|
||||||
(for-each (lambda (x) (display ", ") (display x)) (cdr ints))
|
(lambda ()
|
||||||
(cat ";\n")))
|
(for-each (lambda (x) (cat ", " x " = 0")) (cdr ints)))
|
||||||
|
";\n")))
|
||||||
(if (any (lambda (a) (eq? 'env-string (type-base a)))
|
(if (any (lambda (a) (eq? 'env-string (type-base a)))
|
||||||
(cons ret-type results))
|
(cons ret-type results))
|
||||||
(cat " char *p;\n"))
|
(cat " char *p;\n"))
|
||||||
|
|
@ -1029,8 +1076,11 @@
|
||||||
(cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x))
|
(cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x))
|
||||||
(if (number? len)
|
(if (number? len)
|
||||||
(cat "[" len "]"))
|
(cat "[" len "]"))
|
||||||
(if (type-reference? x)
|
(cond
|
||||||
(cat " = NULL"))
|
((type-reference? x)
|
||||||
|
(cat " = NULL"))
|
||||||
|
((type-error x)
|
||||||
|
(cat " = 0")))
|
||||||
(cat ";\n")
|
(cat ";\n")
|
||||||
(if (or (vector? len) (type-auto-expand? x))
|
(if (or (vector? len) (type-auto-expand? x))
|
||||||
(cat " int len" (type-index x) ";\n"))
|
(cat " int len" (type-index x) ";\n"))
|
||||||
|
|
@ -1046,7 +1096,8 @@
|
||||||
(lambda (arg)
|
(lambda (arg)
|
||||||
(cond
|
(cond
|
||||||
((and (type-pointer? arg) (basic-type? arg))
|
((and (type-pointer? arg) (basic-type? arg))
|
||||||
(cat " " (type-c-name (type-base arg))
|
(cat " " (if (type-const? arg) "const " "")
|
||||||
|
(type-c-name (type-base arg))
|
||||||
" tmp" (type-index arg) ";\n"))))
|
" tmp" (type-index arg) ";\n"))))
|
||||||
scheme-args)
|
scheme-args)
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -1116,7 +1167,8 @@
|
||||||
(define (write-actual-parameter func arg)
|
(define (write-actual-parameter func arg)
|
||||||
(cond
|
(cond
|
||||||
((or (type-result? arg) (type-array arg))
|
((or (type-result? arg) (type-array arg))
|
||||||
(cat (if (or (type-free? arg) (type-reference? arg) (basic-type? arg))
|
(cat (if (or (type-free? arg) (type-reference? arg)
|
||||||
|
(type-address-of? arg) (basic-type? arg))
|
||||||
"&"
|
"&"
|
||||||
"")
|
"")
|
||||||
"tmp" (type-index arg)))
|
"tmp" (type-index arg)))
|
||||||
|
|
@ -1168,15 +1220,17 @@
|
||||||
(cat " tmp" (type-index a)
|
(cat " tmp" (type-index a)
|
||||||
" = new " (type-c-name-derefed (type-base a)) "();\n")
|
" = new " (type-c-name-derefed (type-base a)) "();\n")
|
||||||
(cat " tmp" (type-index a) " = "
|
(cat " tmp" (type-index a) " = "
|
||||||
(if #t ;(type-struct-type a)
|
(lambda () (cat "(" (type-c-name (type-base a))
|
||||||
(lambda () (cat "(" (type-c-name (type-base a))
|
(if (or (type-pointer? a)
|
||||||
(if (type-pointer? a) "*" "")
|
(and (not (int-type? a))
|
||||||
")"))
|
(not (type-struct-type a))))
|
||||||
"")
|
"*"
|
||||||
|
"")
|
||||||
|
")"))
|
||||||
" calloc(1, 1 + "
|
" calloc(1, 1 + "
|
||||||
(if (and (symbol? len) (not (eq? len 'null)))
|
(if (and (symbol? len) (not (eq? len 'null)))
|
||||||
(lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len))
|
(lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len))
|
||||||
"*sizeof(tmp" (type-index a) "[0])"))
|
"*sizeof(tmp" (type-index a) "[0])"))
|
||||||
(lambda () (cat "sizeof(tmp" (type-index a) "[0])")))
|
(lambda () (cat "sizeof(tmp" (type-index a) "[0])")))
|
||||||
");\n"
|
");\n"
|
||||||
(lambda ()
|
(lambda ()
|
||||||
|
|
@ -1202,7 +1256,7 @@
|
||||||
(c-args (func-c-args func)))
|
(c-args (func-c-args func)))
|
||||||
(if (any type-auto-expand? (func-c-args func))
|
(if (any type-auto-expand? (func-c-args func))
|
||||||
(cat " loop:\n"))
|
(cat " loop:\n"))
|
||||||
(cat (cond ((error-type? (type-base ret-type)) " err = ")
|
(cat (cond ((error-type? ret-type) " err = ")
|
||||||
((type-array ret-type) " tmp = ")
|
((type-array ret-type) " tmp = ")
|
||||||
((type-struct? ret-type) " struct_res = ")
|
((type-struct? ret-type) " struct_res = ")
|
||||||
(else " res = ")))
|
(else " res = ")))
|
||||||
|
|
@ -1288,7 +1342,14 @@
|
||||||
" }\n"
|
" }\n"
|
||||||
" " res " = sexp_nreverse(ctx, " res ");\n"))
|
" " res " = sexp_nreverse(ctx, " res ");\n"))
|
||||||
(else
|
(else
|
||||||
(cat " for (i=" len "-1; i>=0; i--) {\n"
|
(cat " for (i=" (if (and (symbol? len)
|
||||||
|
(equal? "arg"
|
||||||
|
(substring (symbol->string len)
|
||||||
|
0 3)))
|
||||||
|
(string-append
|
||||||
|
"sexp_unbox_fixnum(" (symbol->string len) ")")
|
||||||
|
len)
|
||||||
|
"-1; i>=0; i--) {\n"
|
||||||
" sexp_push(ctx, " res ", SEXP_VOID);\n"
|
" sexp_push(ctx, " res ", SEXP_VOID);\n"
|
||||||
" sexp_car(" res ") = "
|
" sexp_car(" res ") = "
|
||||||
(lambda () (c->scheme-converter result (lambda () (cat tmp "[i]"))))
|
(lambda () (c->scheme-converter result (lambda () (cat tmp "[i]"))))
|
||||||
|
|
@ -1305,16 +1366,23 @@
|
||||||
(write-result-adjustment result)))
|
(write-result-adjustment result)))
|
||||||
|
|
||||||
(define (write-results func)
|
(define (write-results func)
|
||||||
(let ((error-res? (error-type? (type-base (func-ret-type func))))
|
(let* ((error-res (cond ((error-type? (func-ret-type func))
|
||||||
(void-res? (eq? 'void (type-base (func-ret-type func))))
|
(func-ret-type func))
|
||||||
(results (func-results func)))
|
((find type-error (func-c-args func)))
|
||||||
(if error-res?
|
(else #f)))
|
||||||
|
(error-return? (eq? error-res (func-ret-type func)))
|
||||||
|
(void-res? (eq? 'void (type-base (func-ret-type func))))
|
||||||
|
(results (remove type-error (func-results func))))
|
||||||
|
(if error-res
|
||||||
(cat " if ("
|
(cat " if ("
|
||||||
(if (memq (type-base (func-ret-type func))
|
(if (memq (type-base error-res)
|
||||||
'(status-bool non-null-string non-null-pointer))
|
'(status-bool non-null-string non-null-pointer))
|
||||||
"!"
|
"!"
|
||||||
"")
|
"")
|
||||||
"err) {\n"
|
(if error-return?
|
||||||
|
"err"
|
||||||
|
(string-append "tmp" (type-index-string error-res)))
|
||||||
|
") {\n"
|
||||||
(cond
|
(cond
|
||||||
((find type-auto-expand? (func-c-args func))
|
((find type-auto-expand? (func-c-args func))
|
||||||
=> (lambda (a)
|
=> (lambda (a)
|
||||||
|
|
@ -1327,20 +1395,26 @@
|
||||||
(cat " len" i " *= 2;\n"
|
(cat " len" i " *= 2;\n"
|
||||||
" tmp" i " = "
|
" tmp" i " = "
|
||||||
(lambda () (cat "(" (type-c-name (type-base a))
|
(lambda () (cat "(" (type-c-name (type-base a))
|
||||||
(if (or (type-pointer? a)
|
(if (or (type-pointer? a)
|
||||||
(and (not *c++?*)
|
(and (not *c++?*)
|
||||||
(string-type? a)))
|
(string-type? a)))
|
||||||
"*"
|
"*"
|
||||||
"")
|
"")
|
||||||
")"))
|
")"))
|
||||||
" calloc(len" i ", sizeof(tmp" i "[0]));\n"
|
" calloc(len" i ", sizeof(tmp" i "[0]));\n"
|
||||||
" goto loop;\n")))))
|
" goto loop;\n")))))
|
||||||
(else
|
(error-return?
|
||||||
;; TODO: free other results
|
;; TODO: free other results
|
||||||
" res = SEXP_FALSE;\n"))
|
" res = SEXP_FALSE;\n")
|
||||||
|
(else
|
||||||
|
(lambda ()
|
||||||
|
(cat " res = sexp_user_exception(ctx, self, "
|
||||||
|
(type-error error-res) "(tmp"
|
||||||
|
(type-index-string error-res)
|
||||||
|
"), SEXP_NULL);\n"))))
|
||||||
" } else {\n"))
|
" } else {\n"))
|
||||||
(if (null? results)
|
(if (null? results)
|
||||||
(if error-res?
|
(if (and error-res error-return?)
|
||||||
(cat " res = SEXP_TRUE;\n"))
|
(cat " res = SEXP_TRUE;\n"))
|
||||||
(let ((first-result-link
|
(let ((first-result-link
|
||||||
;; the `link' modifier applies to the first result when
|
;; the `link' modifier applies to the first result when
|
||||||
|
|
@ -1354,20 +1428,20 @@
|
||||||
(write-result (car results) first-result-link)
|
(write-result (car results) first-result-link)
|
||||||
(for-each write-result (cdr results))))
|
(for-each write-result (cdr results))))
|
||||||
(cond
|
(cond
|
||||||
((> (length results) (if (or error-res? void-res?) 1 0))
|
((> (length results) (if (or error-res void-res?) 1 0))
|
||||||
(if (or error-res? void-res?)
|
(if (or error-res void-res?)
|
||||||
(cat " res = SEXP_NULL;\n")
|
(cat " res = SEXP_NULL;\n")
|
||||||
(cat " res = sexp_cons(ctx, res, SEXP_NULL);\n"))
|
(cat " res = sexp_cons(ctx, res, SEXP_NULL);\n"))
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(if (or error-res? void-res?)
|
(if (or error-res void-res?)
|
||||||
(cat " sexp_push(ctx, res, res" (type-index x) ");\n")
|
(cat " sexp_push(ctx, res, res" (type-index x) ");\n")
|
||||||
(cat " sexp_push(ctx, res, sexp_car(res));\n"
|
(cat " sexp_push(ctx, res, sexp_car(res));\n"
|
||||||
" sexp_cadr(res) = res" (type-index x) ";\n")))
|
" sexp_cadr(res) = res" (type-index x) ";\n")))
|
||||||
(reverse results)))
|
(reverse results)))
|
||||||
((pair? results)
|
((pair? results)
|
||||||
(cat " res = res" (type-index (car results)) ";\n")))
|
(cat " res = res" (type-index (car results)) ";\n")))
|
||||||
(if error-res?
|
(if error-res
|
||||||
(cat " }\n"))))
|
(cat " }\n"))))
|
||||||
|
|
||||||
(define (write-free type)
|
(define (write-free type)
|
||||||
|
|
@ -1396,7 +1470,7 @@
|
||||||
(cat " free(tmp" (type-index a) ");\n"))))
|
(cat " free(tmp" (type-index a) ");\n"))))
|
||||||
(func-c-args func))
|
(func-c-args func))
|
||||||
(let* ((results (func-results func))
|
(let* ((results (func-results func))
|
||||||
(return-res? (not (error-type? (type-base (func-ret-type func)))))
|
(return-res? (not (error-type? (func-ret-type func))))
|
||||||
(preserve-res? (> (+ (length results)) (if return-res? 0 1)))
|
(preserve-res? (> (+ (length results)) (if return-res? 0 1)))
|
||||||
(single-res? (and (= 1 (length results)) (not return-res?)))
|
(single-res? (and (= 1 (length results)) (not return-res?)))
|
||||||
(tmp-string? (any (lambda (a)
|
(tmp-string? (any (lambda (a)
|
||||||
|
|
@ -2077,7 +2151,10 @@
|
||||||
(base-args (append cflags *cflags*
|
(base-args (append cflags *cflags*
|
||||||
`("-o" ,so ,dest "-lchibi-scheme")
|
`("-o" ,so ,dest "-lchibi-scheme")
|
||||||
(map (lambda (x) (string-append "-l" x))
|
(map (lambda (x) (string-append "-l" x))
|
||||||
(reverse *clibs*))))
|
(reverse *clibs*))
|
||||||
|
(apply append
|
||||||
|
(map (lambda (x) (list "-framework" x))
|
||||||
|
(reverse *frameworks*)))))
|
||||||
(args
|
(args
|
||||||
(eval
|
(eval
|
||||||
`(cond-expand
|
`(cond-expand
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue