added GC_PROTECT to protect ret1 and mv_vec

This commit is contained in:
marting 1999-11-02 22:26:32 +00:00
parent 50d36014ba
commit c6860f767f
1 changed files with 28 additions and 31 deletions

View File

@ -646,7 +646,6 @@
(destructure (( (#f scheme-name (c-name . params) . return-reps) form ))
(let* ((c-name (stringify c-name))
(reps (map car params))
(no-declare? (and (pair? return-reps)
(eq? 'no-declare (car return-reps))))
(return-reps (if no-declare? (cdr return-reps)
@ -659,6 +658,9 @@
(ret-infos1 (parse-return-reps return-reps
(lambda (x) x)))
(ignore? (string? ret-infos1))
(gc-protected-vars (if ignore? ; maybe extended by mv_vec
'()
'("ret1")))
(ret-infos2 (if (not ignore?) ; Flatten them out.
(apply append ret-infos1)))
@ -681,7 +683,22 @@
;; Is major ret val non-immediate
(not (retrep:immediate
(caar ret-infos1))))))
(gc-protected-vars (if mv-return?
(cons "mv_vec" gc-protected-vars)
gc-protected-vars))
(gc_declare (if (> (length gc-protected-vars) 0)
(format #f "~% S48_DECLARE_GC_PROTECT(~d);"
(length gc-protected-vars))
""))
(gc_protect (if (> (length gc-protected-vars) 0)
(format #f "~% S48_GC_PROTECT_~d(~a);"
(length gc-protected-vars)
(if (null? (cdr gc-protected-vars))
(car gc-protected-vars)
(string-append (car gc-protected-vars)
","
(cadr gc-protected-vars))))
""))
(nargs (length reps))
(stub-nargs (if mv-return? (+ nargs 1) nargs))
(other-retvals (if ignore? '() (cdr ret-infos3)))
@ -743,17 +760,19 @@
(mv-assigns (if ignore? ""
(make-mv-assigns (cons "r1" ret-vars)
ret-infos1)))
(gc_unprotect (if (> (length gc-protected-vars) 0)
"\n S48_GC_UNPROTECT();"
""))
(return-stmt (format #f "~% return ~a;"
(if ignore? "S48_FALSE" "ret1")))
;; Do the call, release the free-vars, do the mv-return
;; assignments, then return.
(epilog (if ignore?
(string-append c-call ";" post-C-val-processing return-stmt)
(string-append "r1 = " c-call ";"
(string-append c-call ";" post-C-val-processing return-stmt)
(string-append gc_protect "\n r1 = " c-call ";"
post-C-val-processing
mv-assigns return-stmt))))
mv-assigns gc_unprotect return-stmt))))
; (breakpoint)
(format #f cfun-boilerplate
c-name
@ -765,6 +784,7 @@
; Frank: end
c-fun-decl
(if ignore? "" ret1-decl)
gc_declare
primary-retvar-decl ret-var-decls pc-var-decls
pc-var-assigns
epilog))))
@ -773,7 +793,7 @@
(define cfun-boilerplate
"s48_value df_~a(~a)
{
~a~a~a~a~a
~a~a~a~a~a~a
~a
~a
@ -904,29 +924,6 @@ step 4
(lp (append c-names (define-foreign-process-form form oport))))))))))))
; Frank: end
; JMG: stolen from various places
(define (file-name-nondirectory fname)
(cond ((rindex fname #\/) =>
(lambda (rslash)
(if (last-non-slash fname)
(substring fname (+ 1 rslash) (string-length fname))
fname))) ; Posix strangeness: solid slashes are root.
(else fname)))
(define (rindex str c ) ;removed optional argument
(let* ((len (string-length str))
(start len))
(do ((i (- start 1) (- i 1)))
((or (< i 0)
(char=? c (string-ref str i)))
(and (>= i 0) i)))))
(define (last-non-slash str)
(let lp ((i (- (string-length str) 1)))
(and (>= i 0)
(if (char=? #\/ (string-ref str i))
(lp (- i 1))
i))))
(define (cig-standalone-toplevel f-and-init-name) ; ignore your args no
(process-define-foreign-stream (current-input-port)