mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-11 03:33:11 -08:00
Code Issues Projects Releases Packages Wiki Activity

Sending arguments via the lisp stack to a local function with lexical

Browse source 
and closure environments did not work. Example of failed code
(funcall
    (compile nil
            '(lambda (a b c)
               (labels ((%f6 (f6-1 f6-2) c))
                 (multiple-value-call #'%f6 (values a c)))))
    0 10 20)
This commit is contained in:
jjgarcia 2003-11-05 17:32:45 +00:00
parent c229b350cf
commit d45438dce9
2 changed files with 31 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

45
src/cmp/cmpflet.lsp
View file

@ -306,26 +306,39 @@
(closure-p (fun-closure fun))
(fname (fun-name fun)))
(unwind-exit
(if (eq 'ARGS-PUSHED args)
(list 'CALL-LOCAL "APPLY" lex-level closure-p
(list fun `(STACK-POINTER ,narg)) narg fname)
(list 'CALL-LOCAL fun lex-level closure-p
(coerce-locs (inline-args args)) narg fname)))
(list 'CALL-LOCAL fun lex-level closure-p
(if (eq args 'ARGS-PUSHED) 'ARGS-PUSHED (coerce-locs (inline-args args)))
narg fname))
(close-inline-blocks)))))
(defun wt-call-local (fun lex-lvl closure-p args narg fname)
(declare (fixnum lex-lvl))
;; if NARG is non-NIL it is location containing narg
(wt fun "(" (or narg (length args)))
(when (plusp lex-lvl)
(dotimes (n lex-lvl)
(wt ",lex" n)))
(when closure-p
;; env of local fun is ALWAYS contained in current env (?)
(wt ", env" *env-lvl*))
(dolist (arg args)
(wt "," arg))
(wt ")")
(cond ((not (eq args 'ARGS-PUSHED))
;; if NARG is non-NIL it is location containing narg
(wt fun "(" (or narg (length args)))
(when (plusp lex-lvl)
(dotimes (n lex-lvl)
(wt ",lex" n)))
(when closure-p
;; env of local fun is ALWAYS contained in current env (?)
(wt ", env" *env-lvl*))
(dolist (arg args)
(wt "," arg))
(wt ")"))
((not narg)
;; When getting arguments from lisp stack, a location with the number
;; of arguments must have been supplied
(baboon))
((not (or (plusp lex-lvl) closure-p))
(wt "APPLY(" narg "," fun "," `(STACK-POINTER ,narg) ")"))
(t
(wt "(")
(when (plusp lex-lvl)
(dotimes (n lex-lvl)
(wt "cl_stack_push(lex" n ")," narg "++,")))
(when closure-p
(wt "cl_stack_push(env" *env-lvl* ")," narg "++,"))
(wt-nl " APPLY(" narg "," fun "," `(STACK-POINTER ,narg) "))")))
(when fname (wt-comment fname)))

2
src/cmp/cmpmulti.lsp
View file

@ -15,6 +15,8 @@
(defun c1multiple-value-call (args &aux info funob)
(check-args-number 'MULTIPLE-VALUE-CALL args 1)
(cond ((endp (rest args)) (c1funcall args))
;; FIXME! We should optimize
;; (multiple-value-call ... (values a b c ...))
(t (setq funob (c1funob (first args)))
(make-c1form 'MULTIPLE-VALUE-CALL funob funob (c1args* (rest args))))))