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

Supporting an arbitrary number of gc vars in FFI (e.g. as caused by more than 5 result params).

Browse source
This commit is contained in:
Alex Shinn 2013-01-23 23:35:51 +09:00
parent 5ab2849d61
commit 5f705339ef
1 changed files with 50 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

67
tools/chibi-ffi
View file

@ -784,6 +784,52 @@
(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)))
(define (take ls n)
(let lp ((ls ls) (n n) (res '()))
(if (zero? n) (reverse res) (lp (cdr ls) (- n 1) (cons (car ls) res)))))
(define max-gc-vars 7)
(define (write-gc-vars ls . o)
(let ((num-gc-vars (length ls)))
(cond
((zero? num-gc-vars))
((<= num-gc-vars max-gc-vars)
(cat " sexp_gc_var" num-gc-vars "(")
(display (car ls))
(for-each (lambda (x) (display ", ") (display x)) (cdr ls))
(cat ");\n"))
(else
(write-gc-vars (take ls max-gc-vars))
(let lp ((ls (list-tail ls max-gc-vars))
(i (+ max-gc-vars 1)))
(cond
((pair? ls)
(cat " sexp_gc_var(" (car ls) ", __sexp_gc_preserver" i ");\n")
(lp (cdr ls) (+ i 1)))))))))
(define (write-gc-preserves ls)
(let ((num-gc-vars (length ls)))
(cond
((zero? num-gc-vars))
((<= num-gc-vars max-gc-vars)
(cat " sexp_gc_preserve" num-gc-vars "(ctx")
(for-each (lambda (x) (display ", ") (display x)) ls)
(cat ");\n"))
(else
(write-gc-preserves (take ls max-gc-vars))
(let lp ((ls (list-tail ls max-gc-vars))
(i (+ max-gc-vars 1)))
(cond
((pair? ls)
(cat " sexp_gc_preserve(ctx, " (car ls)
", __sexp_gc_preserver" i ");\n")
(lp (cdr ls) (+ i 1)))))))))
(define (write-gc-release ls)
(if (pair? ls)
(cat " sexp_gc_release" (min max-gc-vars (length ls)) "(ctx);\n")))
(define (get-array-length func x) (define (get-array-length func x)
(let ((len (if (pair? (type-array x)) (let ((len (if (pair? (type-array x))
(car (reverse (type-array x))) (car (reverse (type-array x)))
@ -820,7 +866,6 @@
(gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars))
(gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars))
(sexps (if preserve-res? '() '("res"))) (sexps (if preserve-res? '() '("res")))
(num-gc-vars (length gc-vars))
(ints (if (or return-res? (ints (if (or return-res?
(memq (type-base ret-type) (memq (type-base ret-type)
'(non-null-string non-null-pointer))) '(non-null-string non-null-pointer)))
@ -878,21 +923,12 @@
(for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) (for-each (lambda (x) (display ", ") (display x)) (cdr sexps))
(cat ";\n"))) (cat ";\n")))
;; Declare the gc vars. ;; Declare the gc vars.
(cond (write-gc-vars gc-vars)
((pair? gc-vars)
(cat " sexp_gc_var" num-gc-vars "(")
(display (car gc-vars))
(for-each (lambda (x) (display ", ") (display x)) (cdr gc-vars))
(cat ");\n")))
;; Shortcut returns should come before preserving. ;; Shortcut returns should come before preserving.
(write-validators (func-scheme-args func)) (write-validators (func-scheme-args func))
(write-additional-checks (func-c-args func)) (write-additional-checks (func-c-args func))
;; Preserve the gc vars. ;; Preserve the gc vars.
(cond (write-gc-preserves gc-vars)))
((pair? gc-vars)
(cat " sexp_gc_preserve" num-gc-vars "(ctx")
(for-each (lambda (x) (display ", ") (display x)) gc-vars)
(cat ");\n")))))
(define (write-validators args) (define (write-validators args)
(for-each (for-each
@ -1202,11 +1238,8 @@
(func-results func)))) (func-results func))))
(gc-vars results) (gc-vars results)
(gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars))
(gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)))
(num-gc-vars (length gc-vars))) (write-gc-release gc-vars)))
(cond
((pair? gc-vars)
(cat " sexp_gc_release" num-gc-vars "(ctx);\n")))))
(define (write-func-declaration func) (define (write-func-declaration func)
(cat "static sexp " (func-stub-name func) (cat "static sexp " (func-stub-name func)