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

adding support for unions

Browse source
This commit is contained in:
Alex Shinn 2010-07-12 23:04:53 +09:00
parent dbb4db1728
commit b5f29def78
1 changed files with 17 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
tools/genstubs.scm
View file

@ -213,7 +213,7 @@
(memq type '(signed-char short int long boolean))) (memq type '(signed-char short int long boolean)))
(define (unsigned-int-type? type) (define (unsigned-int-type? type)
(memq type '(unsigned-char unsigned-short unsigned-int unsigned-long (memq type '(unsigned-char unsigned-short unsigned unsigned-int unsigned-long
size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t
uid_t gid_t pid_t blksize_t blkcnt_t sigval_t))) uid_t gid_t pid_t blksize_t blkcnt_t sigval_t)))
@ -425,6 +425,11 @@
(lambda (expr rename compare) (lambda (expr rename compare)
`(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) `(define-struct-like ,(cadr expr) type: class ,@(cddr expr)))))
(define-syntax define-c-union
(er-macro-transformer
(lambda (expr rename compare)
`(define-struct-like ,(cadr expr) type: union ,@(cddr expr)))))
(define-syntax define-c-type (define-syntax define-c-type
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
@ -439,8 +444,9 @@
(define-syntax define-c-const (define-syntax define-c-const
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(set! *consts* (let ((type (parse-type (cadr expr))))
(cons (cons (parse-type (cadr expr)) (cddr expr)) *consts*))))) (for-each (lambda (x) (set! *consts* (cons (list type x) *consts*)))
(cddr expr))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; C code generation ;; C code generation
@ -568,7 +574,7 @@
(if (type-const? type) "const " "") (if (type-const? type) "const " "")
(if struct-type (string-append (symbol->string struct-type) " ") "") (if struct-type (string-append (symbol->string struct-type) " ") "")
(string-replace (base-type-c-name base) #\- " ") (string-replace (base-type-c-name base) #\- " ")
(if type-spec "*" "") (if struct-type "*" "")
(if (type-pointer? type) "*" "")))) (if (type-pointer? type) "*" ""))))
(define (check-type arg type) (define (check-type arg type)
@ -605,6 +611,7 @@
((eq? base 'port) "SEXP_IPORT") ((eq? base 'port) "SEXP_IPORT")
((eq? base 'input-port) "SEXP_IPORT") ((eq? base 'input-port) "SEXP_IPORT")
((eq? base 'output-port) "SEXP_OPORT") ((eq? base 'output-port) "SEXP_OPORT")
((void-pointer-type? type) "SEXP_CPOINTER")
(else (type-id-name base))))) (else (type-id-name base)))))
(define (write-validator arg type) (define (write-validator arg type)
@ -1112,9 +1119,9 @@
" return SEXP_VOID;\n" " return SEXP_VOID;\n"
"}\n\n")) "}\n\n"))
(define (write-type-funcs type) (define (write-type-funcs orig-type)
(let ((name (car type)) (let ((name (car orig-type))
(type (cdr type))) (type (cdr orig-type)))
;; maybe write finalizer ;; maybe write finalizer
(cond (cond
((memq 'finalizer: type) ((memq 'finalizer: type)
@ -1139,7 +1146,7 @@
(cat ", sexp arg" i) (cat ", sexp arg" i)
(lp (cdr ls) (+ i 1)))))) (lp (cdr ls) (+ i 1))))))
") {\n" ") {\n"
" struct " (type-name name) " *r;\n" " " (or (type-struct-type name) "") " " (type-name name) " *r;\n"
" sexp_gc_var1(res);\n" " sexp_gc_var1(res);\n"
" sexp_gc_preserve1(ctx, res);\n" " sexp_gc_preserve1(ctx, res);\n"
;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), " ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), "
@ -1149,8 +1156,8 @@
" res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), "
(type-id-name name) (type-id-name name)
");\n" ");\n"
" r = sexp_cpointer_value(res) = malloc(sizeof(struct " " r = sexp_cpointer_value(res) = malloc(sizeof("
(type-name name) "));\n" (or (type-struct-type name) "") " " (type-name name) "));\n"
" sexp_freep(res) = 1;\n" " sexp_freep(res) = 1;\n"
(lambda () (lambda ()
(let lp ((ls args) (i 0)) (let lp ((ls args) (i 0))