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")) (cat "\n#include <" header ">\n"))
(define (parse-struct-like ls) (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 (define-syntax define-struct-like
(er-macro-transformer (er-macro-transformer
@ -1057,7 +1066,7 @@
(define (type-setter-name type name field) (define (type-setter-name type name field)
(string-append "sexp_" (x->string (type-name (parse-type name))) (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) (define (write-type-setter type name field)
(cat "static sexp " (type-setter-name type name field) (cat "static sexp " (type-setter-name type name field)
@ -1065,15 +1074,13 @@
(lambda () (write-validator "x" name)) (lambda () (write-validator "x" name))
(lambda () (write-validator "v" (car field))) (lambda () (write-validator "v" (car field)))
" " " "
(lambda () (c->scheme-converter
(car field)
(string-append "((" (x->string (or (type-struct-type name) "")) (string-append "((" (x->string (or (type-struct-type name) ""))
" " (mangle name) "*)" " " (mangle name) "*)"
"sexp_cpointer_value(x))" "sexp_cpointer_value(x))"
(if (type-struct? (car field)) "." "->") (if (type-struct? (car field)) "." "->")
(x->string (cadr field))))) (x->string (cadr field)))
" = v;\n" " = " (lambda () (scheme->c-converter (car field) "v")) ";\n"
" return SEXP_VOID;" " return SEXP_VOID;\n"
"}\n\n")) "}\n\n"))
(define (write-type-funcs type) (define (write-type-funcs type)
@ -1097,7 +1104,11 @@
(args (cdadr x))) (args (cdadr x)))
(cat "static sexp " (generate-stub-name make) (cat "static sexp " (generate-stub-name make)
" (sexp ctx" " (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" ") {\n"
" struct " (type-name name) " *r;\n" " struct " (type-name name) " *r;\n"
" sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " " sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), "
@ -1105,6 +1116,23 @@
");\n" ");\n"
" sexp_cpointer_value(res) = sexp_cpointer_body(res);\n" " sexp_cpointer_value(res) = sexp_cpointer_body(res);\n"
" r = sexp_cpointer_value(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" " return res;\n"
"}\n\n") "}\n\n")
(set! *funcs* (set! *funcs*