Linked values will be applied to the first result in a multi-result function.

Also adding support for value function conversions (e.g. string-length
-> sexp_string_length).
This commit is contained in:
Alex Shinn 2012-10-09 21:50:56 +09:00
parent 7b31ba7685
commit 5b31263136

View file

@ -678,7 +678,7 @@
(else (string-replace (symbol->string base) #\- " ")))) (else (string-replace (symbol->string base) #\- " "))))
(define (type-struct-type type) (define (type-struct-type type)
(let ((type-spec (lookup-type(if (vector? type) (type-base type) type)))) (let ((type-spec (lookup-type (if (vector? type) (type-base type) type))))
(cond ((and type-spec (memq 'type: type-spec)) => cadr) (cond ((and type-spec (memq 'type: type-spec)) => cadr)
(else #f)))) (else #f))))
@ -906,6 +906,11 @@
(cat " sexp_check_block_port(ctx, arg" (type-index a) ", 0);\n"))) (cat " sexp_check_block_port(ctx, arg" (type-index a) ", 0);\n")))
args)) args))
(define (scheme-procedure->c name)
(cond
((eq? name 'string-length) 'sexp_string_length)
(else name)))
(define (write-value func val) (define (write-value func val)
(cond (cond
((find (lambda (x) ((find (lambda (x)
@ -916,8 +921,8 @@
=> (lambda (x) (cat "len" (type-index x)))) => (lambda (x) (cat "len" (type-index x))))
((lookup-type val) ((lookup-type val)
(cat (or (type-struct-type val) "") " " val)) (cat (or (type-struct-type val) "") " " val))
((list? val) ((and (pair? val) (list? val))
(write (car val)) (write (scheme-procedure->c (car val)))
(cat (cat
"(" "("
(lambda () (lambda ()
@ -1042,7 +1047,7 @@
" fcntl(fileno(sexp_port_stream(" res ")), F_SETFL, O_NONBLOCK);\n" " fcntl(fileno(sexp_port_stream(" res ")), F_SETFL, O_NONBLOCK);\n"
"#endif\n"))))) "#endif\n")))))
(define (write-result result) (define (write-result result . o)
(let ((res (string-append "res" (type-index-string result))) (let ((res (string-append "res" (type-index-string result)))
(tmp (string-append "tmp" (type-index-string result)))) (tmp (string-append "tmp" (type-index-string result))))
(cond (cond
@ -1076,9 +1081,11 @@
" }\n"))))) " }\n")))))
(else (else
(cat " " res " = ") (cat " " res " = ")
(c->scheme-converter (apply
c->scheme-converter
result result
(string-append "tmp" (type-index-string result))) (string-append "tmp" (type-index-string result))
o)
(cat ";\n"))) (cat ";\n")))
(write-result-adjustment result))) (write-result-adjustment result)))
@ -1111,7 +1118,17 @@
(if (null? results) (if (null? results)
(if error-res? (if error-res?
(cat " res = SEXP_TRUE;\n")) (cat " res = SEXP_TRUE;\n"))
(for-each write-result results)) (let ((first-result-link
;; the `link' modifier applies to the first result when
;; there are multiple results
(and
(not (lookup-type (func-ret-type func)))
(cond
((find type-link? (func-c-args func))
=> (lambda (a) (string-append "arg" (type-index-string a))))
(else #f)))))
(write-result (car results) first-result-link)
(for-each write-result (cdr results))))
(cond (cond
((> (length results) (if error-res? 1 0)) ((> (length results) (if error-res? 1 0))
(if error-res? (if error-res?