mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-10 14:37:34 +02:00
Supporting an arbitrary number of gc vars in FFI (e.g. as caused by more than 5 result params).
This commit is contained in:
parent
5ab2849d61
commit
5f705339ef
1 changed files with 50 additions and 17 deletions
|
@ -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)
|
||||||
|
|
Loading…
Add table
Reference in a new issue