mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-10 11:12:58 -08:00
38134ccfdc
must be stored in a vector. The number of these vectors (i.e. the "lexical
level") was not properly computed: sample bogus code
(funcall
(compile nil
'(lambda (b)
(labels ((%f8 nil -39011))
(flet ((%f4 (f4-1 f4-2 &optional (f4-3 (%f8)) (f4-4 b))
(%f8)))
(%f4 -260093 -75538 -501684 (let ((v9 (%f8))) -3))))))
361 lines
12 KiB
Common Lisp
361 lines
12 KiB
Common Lisp
;;;; CMPFLET Flet, Labels, and Macrolet.
|
|
|
|
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
|
|
;;;; Copyright (c) 1990, Giuseppe Attardi.
|
|
;;;;
|
|
;;;; This program is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Library General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 2 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; See file '../Copyright' for full details.
|
|
|
|
(in-package "COMPILER")
|
|
|
|
(defun c1flet (args &aux body ss ts is other-decl
|
|
(defs '()) (local-funs '()))
|
|
(check-args-number 'FLET args 1)
|
|
;; On a first round, we extract the definitions of the functions,
|
|
;; and build empty function objects that record the references to
|
|
;; this functions in the processed body. In the end
|
|
;; DEFS = ( { ( fun-object function-body ) }* ).
|
|
(let ((*funs* *funs*))
|
|
(dolist (def (car args))
|
|
(cmpck (or (endp def)
|
|
(not (si::valid-function-name-p (car def)))
|
|
(endp (cdr def)))
|
|
"The function definition ~s is illegal." def)
|
|
(let ((fun (make-fun :name (car def))))
|
|
(push fun *funs*)
|
|
(push (list fun (cdr def)) defs)))
|
|
|
|
(multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
|
|
|
|
(let ((*vars* *vars*))
|
|
(c1add-globals ss)
|
|
(check-vdecl nil ts is)
|
|
(setq body (c1decl-body other-decl body))))
|
|
|
|
;; Now we can compile the function themselves. Notice that we have
|
|
;; emptied *fun* so that the functions do not see each other (that is
|
|
;; the difference with LABELS). In the end
|
|
;; LOCAL-FUNS = ( { ( fun-object lambda-c1form ) }* ).
|
|
(dolist (def (nreverse defs))
|
|
(let ((fun (car def)) lam CB/LB)
|
|
(when (plusp (fun-ref fun))
|
|
(setq CB/LB (if (fun-ref-ccb fun) 'CB 'LB))
|
|
(setq lam
|
|
(let ((*funs* (cons CB/LB *funs*))
|
|
(*vars* (cons CB/LB *vars*))
|
|
(*blocks* (cons CB/LB *blocks*))
|
|
(*tags* (cons CB/LB *tags*)))
|
|
(c1lambda-expr (second def)
|
|
(si::function-block-name (fun-name fun)))))
|
|
(push (list fun lam) local-funs)
|
|
(setf (fun-cfun fun) (next-cfun)))))
|
|
|
|
;; cant do in previous loop since closed var may be in later function
|
|
(dolist (fun-lam local-funs)
|
|
(setf (fun-closure (first fun-lam)) (closure-p (second fun-lam))))
|
|
|
|
(if local-funs
|
|
(make-c1form* 'LOCALS :type (c1form-type body)
|
|
:args (nreverse local-funs) body nil)
|
|
body))
|
|
|
|
(defun closure-p (funob)
|
|
;; It's a closure if inside its body there is a reference (var)
|
|
(dolist (var (c1form-referred-vars funob))
|
|
;; referred across CB
|
|
(when (ref-ref-ccb var)
|
|
;; established outside the body
|
|
(when (or
|
|
(member var *vars* :test #'eq)
|
|
(member var *funs* :test #'eq :key
|
|
#'(lambda (x) (unless (or (consp x) (symbolp x)) (fun-var x))))
|
|
(member var *blocks* :test #'eq :key
|
|
#'(lambda (x) (unless (symbolp x) (blk-var x))))
|
|
(member var *tags* :test #'eql :key
|
|
#'(lambda (x) (unless (symbolp x) (tag-var x)))))
|
|
(return t)))))
|
|
|
|
(defun c2locals (funs body labels ;; labels is T when deriving from labels
|
|
&aux block-p
|
|
(level *level*)
|
|
(*env* *env*)
|
|
(*env-lvl* *env-lvl*) env-grows)
|
|
;; create location for each function which is returned,
|
|
;; either in lexical:
|
|
(dolist (def funs)
|
|
(let* ((fun (car def)) (var (fun-var fun)))
|
|
(when (plusp (var-ref var)) ; the function is returned
|
|
(unless (member (var-kind var) '(LEXICAL CLOSURE))
|
|
(setf (var-loc var) (next-lcl))
|
|
(unless block-p
|
|
(setq block-p t) (wt-nl "{ "))
|
|
(wt "cl_object " var ";"))
|
|
(unless env-grows
|
|
(setq env-grows (var-ref-ccb var))))))
|
|
;; or in closure environment:
|
|
(when (env-grows env-grows)
|
|
(unless block-p
|
|
(wt-nl "{ ") (setq block-p t))
|
|
(let ((env-lvl *env-lvl*))
|
|
(wt "volatile cl_object env" (incf *env-lvl*) " = env" env-lvl ";")))
|
|
;; bind such locations:
|
|
;; - first create binding (because of possible circularities)
|
|
(dolist (def funs)
|
|
(let* ((fun (car def)) (var (fun-var fun)))
|
|
(when (and var (plusp (var-ref var)))
|
|
(when labels
|
|
(incf (fun-env fun))) ; var is included in the closure env
|
|
(bind nil var))))
|
|
;; - then assign to it
|
|
(dolist (def funs)
|
|
(let* ((fun (car def)) (var (fun-var fun)))
|
|
(when (and var (plusp (var-ref var)))
|
|
(set-var (list 'MAKE-CCLOSURE fun) var))))
|
|
;; We need to introduce a new lex vector when lexical variables
|
|
;; are present in body and it is the outermost FLET or LABELS
|
|
;; (nested FLETS/LABELS can use a single lex).
|
|
(when (plusp *lex*)
|
|
(incf level))
|
|
;; create the functions:
|
|
(dolist (def funs)
|
|
(let* ((fun (car def)) (var (fun-var fun)) previous)
|
|
(when (setq previous (new-local level fun (second def)))
|
|
(format t "~%> ~A" previous)
|
|
(setf (fun-level fun) (fun-level previous)
|
|
(fun-env fun) (fun-env previous)))))
|
|
|
|
(c2expr body)
|
|
(when block-p (wt-nl "}")))
|
|
|
|
(defun c1labels (args &aux body ss ts is other-decl defs fun local-funs
|
|
fnames (*funs* *funs*))
|
|
(check-args-number 'LABELS args 1)
|
|
|
|
;;; bind local-functions
|
|
(dolist (def (car args))
|
|
(cmpck (or (endp def)
|
|
(not (si::valid-function-name-p (car def)))
|
|
(endp (cdr def)))
|
|
"The local function definition ~s is illegal." def)
|
|
(cmpck (member (car def) fnames)
|
|
"The function ~s was already defined." (car def))
|
|
(push (car def) fnames)
|
|
(let ((fun (make-fun :name (car def))))
|
|
(push fun *funs*)
|
|
(push (list fun NIL (cdr def)) defs)))
|
|
|
|
(setq defs (nreverse defs))
|
|
|
|
;;; Now DEFS holds ( { ( fun-object processed body ) }* ).
|
|
|
|
(multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
|
|
(let ((*vars* *vars*))
|
|
(c1add-globals ss)
|
|
(check-vdecl nil ts is)
|
|
(setq body (c1decl-body other-decl body)))
|
|
|
|
(do ((finished))
|
|
(finished)
|
|
(setq finished t)
|
|
(dolist (def defs)
|
|
(setq fun (car def))
|
|
(when (and (plusp (fun-ref fun)) ; referred
|
|
(not (fun-ref-ccb fun)) ; not within closure
|
|
(not (second def))) ; but not processed yet
|
|
(setq finished nil)
|
|
(let ((*vars* (cons 'LB *vars*))
|
|
(*funs* (cons 'LB *funs*))
|
|
(*blocks* (cons 'LB *blocks*))
|
|
(*tags* (cons 'LB *tags*)))
|
|
(let ((lam (c1lambda-expr (third def)
|
|
(si::function-block-name (fun-name fun)))))
|
|
(push (list fun lam) local-funs)))
|
|
(setf (second def) T)))
|
|
)
|
|
|
|
(do ((finished))
|
|
(finished)
|
|
(setq finished t)
|
|
(dolist (def defs)
|
|
(setq fun (car def))
|
|
(when (and fun ; not processed yet
|
|
(fun-ref-ccb fun)) ; referred across closure
|
|
(setq finished nil)
|
|
(when (second def)
|
|
;; also processed as local, e.g.:
|
|
;; (defun foo (z) (labels ((g () z) (h (y) #'g)) (list (h z) (g))))
|
|
(setq local-funs (delete fun local-funs :key #'car)))
|
|
(let ((*vars* (cons 'CB *vars*))
|
|
(*funs* (cons 'CB *funs*))
|
|
(*blocks* (cons 'CB *blocks*))
|
|
(*tags* (cons 'CB *tags*)))
|
|
(let ((lam (c1lambda-expr (third def)
|
|
(si::function-block-name (fun-name fun)))))
|
|
(push (list fun lam) local-funs)))
|
|
(setf (car def) NIL))) ; def processed
|
|
)
|
|
|
|
(dolist (fun-lam local-funs)
|
|
(setq fun (first fun-lam))
|
|
(setf (fun-closure fun) (closure-p (second fun-lam)))
|
|
(setf (fun-cfun fun) (next-cfun)))
|
|
|
|
(if local-funs
|
|
(make-c1form* 'LOCALS :type (c1form-type body)
|
|
:args local-funs body T) ; T means labels
|
|
body))
|
|
|
|
(defun c1locally (args)
|
|
(multiple-value-bind (body ss ts is other-decl)
|
|
(c1body args t)
|
|
(c1add-globals ss)
|
|
(check-vdecl nil ts is)
|
|
(c1decl-body other-decl body)))
|
|
|
|
(defun c1macrolet (args &aux (*funs* *funs*))
|
|
(check-args-number 'MACROLET args 1)
|
|
(dolist (def (car args))
|
|
(cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
|
|
"The macro definition ~s is illegal." def)
|
|
(push (list (car def)
|
|
'MACRO
|
|
(si::make-lambda (car def)
|
|
(cdr (sys::expand-defmacro (car def) (second def) (cddr def)))))
|
|
*funs*))
|
|
(c1locally (cdr args)))
|
|
|
|
(defun c1symbol-macrolet (args &aux (*vars* *vars*))
|
|
(check-args-number 'SYMBOL-MACROLET args 1)
|
|
(dolist (def (car args))
|
|
(cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
|
|
"The symbol-macro definition ~s is illegal." def)
|
|
(push def *vars*))
|
|
(c1locally (cdr args)))
|
|
|
|
(defun local-closure (fname &aux (ccb nil) (clb nil))
|
|
(dolist (fun *funs*)
|
|
(cond ((eq fun 'CB) (setq ccb t))
|
|
((eq fun 'LB) (setq clb t))
|
|
((and (symbolp fname) (consp fun)) ; macro
|
|
(when (eq fname (car fun))
|
|
(return nil)))
|
|
((same-fname-p (fun-name fun) fname)
|
|
(incf (fun-ref fun))
|
|
;; we introduce a variable to hold the funob
|
|
(let ((var (or (fun-var fun)
|
|
(setf (fun-var fun)
|
|
(make-var :name fname :kind :OBJECT)))))
|
|
(cond (ccb (setf (var-ref-ccb var) t
|
|
(var-kind var) 'CLOSURE)
|
|
(setf (fun-ref-ccb fun) t))
|
|
(clb (setf (var-ref-clb var) t
|
|
(var-kind var) 'LEXICAL))))
|
|
(return fun)))))
|
|
|
|
(defun c1call-local (fname)
|
|
;; used by c1funob and c1call-symbol
|
|
(let ((fun (local-closure fname)))
|
|
(when fun
|
|
(make-c1form* 'LOCAL :local-referred (list (fun-var fun))
|
|
:referred-vars (list (fun-var fun))
|
|
:args fun))))
|
|
|
|
(defun sch-local-fun (fname)
|
|
;; Returns fun-ob for the local function (not locat macro) named FNAME,
|
|
;; if any. Otherwise, returns FNAME itself.
|
|
(dolist (fun *funs* fname)
|
|
(when (and (not (eq fun 'CB))
|
|
(not (consp fun))
|
|
(same-fname-p (fun-name fun) fname))
|
|
(return fun))))
|
|
|
|
(defun sch-local-macro (fname)
|
|
(dolist (fun *funs*)
|
|
(when (and (consp fun)
|
|
(eq (first fun) fname))
|
|
(return (third fun)))))
|
|
|
|
(defun c2call-local (fun args &optional narg)
|
|
(declare (type fun fun))
|
|
(multiple-value-bind (*unwind-exit* args narg)
|
|
(maybe-push-args args)
|
|
(when narg
|
|
(c2call-local fun args narg)
|
|
(wt-nl "}")
|
|
(return-from c2call-local)))
|
|
(cond
|
|
((and (listp args)
|
|
*tail-recursion-info*
|
|
(same-fname-p (car *tail-recursion-info*) (fun-name fun))
|
|
(eq *exit* 'RETURN)
|
|
(tail-recursion-possible)
|
|
(= (length args) (length (cdr *tail-recursion-info*))))
|
|
(let* ((*destination* 'TRASH)
|
|
(*exit* (next-label))
|
|
(*unwind-exit* (cons *exit* *unwind-exit*)))
|
|
(c2psetq (cdr *tail-recursion-info*) args)
|
|
(wt-label *exit*))
|
|
(unwind-no-exit 'TAIL-RECURSION-MARK)
|
|
(wt-nl "goto TTL;")
|
|
(cmpnote "Tail-recursive call of ~s was replaced by iteration."
|
|
(fun-name fun)))
|
|
(t (let ((*inline-blocks* 0)
|
|
(fun (format nil "LC~d" (fun-cfun fun)))
|
|
(lex-level (fun-level fun))
|
|
(closure-p (fun-closure fun))
|
|
(fname (fun-name fun)))
|
|
(unwind-exit
|
|
(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))
|
|
(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)))
|
|
|
|
|
|
;;; ----------------------------------------------------------------------
|
|
|
|
(put-sysprop 'FLET 'C1SPECIAL 'c1flet)
|
|
(put-sysprop 'LABELS 'C1SPECIAL 'c1labels)
|
|
(put-sysprop 'LOCALLY 'C1SPECIAL 'c1locally)
|
|
(put-sysprop 'MACROLET 'C1SPECIAL 'c1macrolet)
|
|
(put-sysprop 'SYMBOL-MACROLET 'C1SPECIAL 'c1symbol-macrolet)
|
|
|
|
(put-sysprop 'LOCALS 'c2 'c2locals) ; replaces both c2flet and c2lables
|
|
;;; c2macrolet is not defined, because MACROLET is replaced by PROGN
|
|
;;; during Pass 1.
|
|
(put-sysprop 'CALL-LOCAL 'C2 'c2call-local)
|
|
|
|
(put-sysprop 'CALL-LOCAL 'WT-LOC #'wt-call-local)
|