Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 13:37:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

fixing field setters and type constructors (issue #24)

Browse source
This commit is contained in:
foof 2010-01-12 12:54:24 -05:00
parent fdec55997a
commit ce5946578a
1 changed files with 40 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

44
tools/genstubs.scm
View file

@ -403,7 +403,16 @@
(cat "\n#include <" header ">\n"))
(define (parse-struct-like ls)
(map (lambda (x) (if (pair? x) (cons (parse-type (car x)) (cdr x)) x)) 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
@ -1057,7 +1066,7 @@
(define (type-setter-name type name field)
(string-append "sexp_" (x->string (type-name (parse-type name)))
"_set_" (x->string (type-base (parse-type (car field))))))
"_set_" (x->string (type-base (parse-type (cadr field))))))
(define (write-type-setter type name field)
(cat "static sexp " (type-setter-name type name field)
@ -1065,15 +1074,13 @@
(lambda () (write-validator "x" name))
(lambda () (write-validator "v" (car field)))
" "
(lambda () (c->scheme-converter
(car field)
(string-append "((" (x->string (or (type-struct-type name) ""))
" " (mangle name) "*)"
"sexp_cpointer_value(x))"
(if (type-struct? (car field)) "." "->")
(x->string (cadr field)))))
" = v;\n"
" return SEXP_VOID;"
(x->string (cadr field)))
" = " (lambda () (scheme->c-converter (car field) "v")) ";\n"
" return SEXP_VOID;\n"
"}\n\n"))
(define (write-type-funcs type)
@ -1097,7 +1104,11 @@
(args (cdadr x)))
(cat "static sexp " (generate-stub-name make)
" (sexp ctx"
(lambda () (for-each (lambda (x) (cat ", sexp " x)) args))
(lambda ()
(let lp ((ls args) (i 0))
(cond ((pair? ls)
(cat ", sexp arg" i)
(lp (cdr ls) (+ i 1))))))
") {\n"
" struct " (type-name name) " *r;\n"
" sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), "
@ -1105,6 +1116,23 @@
");\n"
" sexp_cpointer_value(res) = sexp_cpointer_body(res);\n"
" r = sexp_cpointer_value(res);\n"
(lambda ()
(let lp ((ls args) (i 0))
(cond
((pair? ls)
(let* ((a (car ls))
(field
(any (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)))))))
" return res;\n"
"}\n\n")
(set! *funcs*