diff --git a/cig/cig.scm b/cig/cig.scm index b12aff6..7b387a8 100644 --- a/cig/cig.scm +++ b/cig/cig.scm @@ -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,7 +658,10 @@ (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))) (ret-infos3 (if (not ignore?) ; A canonical representative @@ -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)