Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 14:49:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding (pointer void) support

Browse source
This commit is contained in:
Alex Shinn 2010-03-15 13:29:43 +09:00
parent a1566b79d0
commit ca1f6202ae
1 changed files with 36 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

68
tools/genstubs.scm
View file

@ -235,8 +235,13 @@
(define (basic-type? type) (define (basic-type? type)
(let ((type (parse-type type))) (let ((type (parse-type type)))
(and (not (type-array type)) (and (not (type-array type))
(not (void-pointer-type? type))
(not (assq (type-base type) *types*))))) (not (assq (type-base type) *types*)))))
(define (void-pointer-type? type)
(or (and (eq? 'void (type-base type)) (type-pointer? type))
(eq? 'void* (type-base type))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; function objects ;; function objects
@ -456,7 +461,7 @@
(define (c->scheme-converter type val . o) (define (c->scheme-converter type val . o)
(let ((base (type-base type))) (let ((base (type-base type)))
(cond (cond
((eq? base 'void) ((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? base))
(cat val)) (cat val))
@ -483,10 +488,12 @@
((eq? 'output-port base) ((eq? 'output-port base)
(cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)")) (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)"))
(else (else
(let ((ctype (assq base *types*))) (let ((ctype (assq base *types*))
(void*? (void-pointer-type? type)))
(cond (cond
(ctype ((or ctype void*?)
(cat "sexp_make_cpointer(ctx, " (type-id-name base) ", " (cat "sexp_make_cpointer(ctx, "
(if void*? "SEXP_CPOINTER" (type-id-name base)) ", "
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)
(and (type-result? type) (not (basic-type? type)))) (and (type-result? type) (not (basic-type? type))))
@ -522,9 +529,10 @@
((port-type? base) ((port-type? base)
(cat "sexp_port_stream(" val ")")) (cat "sexp_port_stream(" val ")"))
(else (else
(let ((ctype (assq base *types*))) (let ((ctype (assq base *types*))
(void*? (void-pointer-type? type)))
(cond (cond
(ctype ((or ctype void*?)
(cat "(" (type-c-name type) ")" (cat "(" (type-c-name type) ")"
(if (type-null? type) (if (type-null? type)
"sexp_cpointer_maybe_null_value" "sexp_cpointer_maybe_null_value"
@ -586,19 +594,18 @@
((or (int-type? base) (float-type? base) ((or (int-type? base) (float-type? base)
(string-type? base) (port-type? base)) (string-type? base) (port-type? base))
(cat (type-predicate type) "(" arg ")")) (cat (type-predicate type) "(" arg ")"))
((or (assq base *types*) (void-pointer-type? type))
(cat
(if (type-null? type) "(" "")
"(sexp_pointerp(" arg ")"
" && (sexp_pointer_tag(" arg ") == "
(if (void-pointer-type? type) "SEXP_CPOINTER" (type-id-name base)) "))"
(lambda () (if (type-null? type) (cat " || sexp_not(" arg "))")))))
(else (else
(cond (display "WARNING: don't know how to check: " (current-error-port))
((assq base *types*) (write type (current-error-port))
(cat (newline (current-error-port))
(if (type-null? type) "(" "") (cat "1")))))
"(sexp_pointerp(" arg ")"
" && (sexp_pointer_tag(" arg ") == " (type-id-name base) "))"
(lambda () (if (type-null? type) (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 (write-validator arg type) (define (write-validator arg type)
(let* ((type (parse-type type)) (let* ((type (parse-type type))
@ -631,21 +638,18 @@
" return sexp_type_exception(ctx, \"not " " return sexp_type_exception(ctx, \"not "
(definite-article (type-name type)) "\", " (definite-article (type-name type)) "\", "
arg ");\n")) arg ");\n"))
((or (assq base-type *types*) (void-pointer-type? type))
(cat
" if (! " (lambda () (check-type arg type)) ")\n"
" return sexp_type_exception(ctx, \"not "
(definite-article (type-name type)) "\", " arg ");\n"))
((eq? 'sexp base-type))
((string-type? type)
(write-validator arg 'string))
(else (else
(cond (display "WARNING: don't know how to validate: " (current-error-port))
((assq base-type *types*) (write type (current-error-port))
(cat (newline (current-error-port))))))
" if (! " (lambda () (check-type arg type)) ")\n"
" return sexp_type_exception(ctx, \"not "
(definite-article (type-name type)) "\", " arg ");\n"))
((eq? 'sexp base-type))
((string-type? type)
(write-validator arg 'string))
(else
(display "WARNING: don't know how to validate: " (current-error-port))
(write type (current-error-port))
(newline (current-error-port))
(write type)))))))
(define (write-parameters args) (define (write-parameters args)
(lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args)))