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

Forms are now stored as structures.

Browse source
This commit is contained in:
jjgarcia 2003-10-16 07:38:17 +00:00
parent 8b13dff308
commit 540e4140f4
14 changed files with 116 additions and 139 deletions
Download patch file Download diff file Expand all files Collapse all files

10
src/cmp/cmpcall.lsp
View file

@ -54,7 +54,7 @@
;; Don't create closure boundary like in c1function
;; since funob is used in this same environment
(let ((lambda-expr (c1lambda-expr (rest function))))
(make-c1form 'LAMBDA (second lambda-expr) lambda-expr (next-cfun))))
(make-c1form 'LAMBDA lambda-expr lambda-expr (next-cfun))))
((and (consp function)
(eq (first function) 'LAMBDA-BLOCK)
(consp (rest function)))
@ -62,7 +62,7 @@
;; since funob is used in this same environment
(let* ((block-name (second function)))
(let ((lambda-expr (c1lambda-expr (cddr function) block-name)))
(make-c1form 'LAMBDA (second lambda-expr) lambda-expr (next-cfun)))))
(make-c1form 'LAMBDA lambda-expr lambda-expr (next-cfun)))))
(t (cmperr "Malformed function: ~A" fun))))
(defun c1funcall (args)
@ -85,13 +85,13 @@
(make-c1form* 'FUNCALL :args (c1funob fun) (c1args* arguments))))))
(defun c2funcall (funob args &optional loc narg
&aux (form (third funob)))
&aux (form (c1form-arg 0 funob)))
;; Usually, ARGS holds a list of forms, which are arguments to the
;; function. If, however, the arguments are on VALUES,
;; ARGS should be set to the symbol ARGS-PUSHED, and NARG to a location
;; containing the number of arguments.
;; LOC is the location of the function object (created by save-funob).
(case (first funob)
(case (c1form-name funob)
(GLOBAL (c2call-global form args loc t narg))
(LOCAL (c2call-local form args narg))
(ORDINARY ;;; An ordinary expression. In this case, if
@ -283,7 +283,7 @@
temp))))
(ORDINARY (let* ((temp (make-temp-var))
(*destination* temp))
(c2expr* (third funob))
(c2expr* (c1form-arg 0 funob))
temp))
(otherwise (baboon))
))

2
src/cmp/cmpenv.lsp
View file

@ -445,7 +445,7 @@
(*compiler-push-events* *compiler-push-events*)
(dl (c1add-declarations decls)))
(setq body (c1progn body))
(make-c1form 'DECL-BODY (second body) dl body))))
(make-c1form 'DECL-BODY body dl body))))
(put-sysprop 'decl-body 'c2 'c2decl-body)

6
src/cmp/cmpeval.lsp
View file

@ -52,7 +52,7 @@
(let* ((forms (c1args* args))
(fun (c1form-arg 0 fd))
(return-type (or (get-local-return-type fun) 'T)))
(let ((arg-types (get-local-arg-types (third fd))))
(let ((arg-types (get-local-arg-types fun)))
;; Add type information to the arguments.
(when arg-types
(let ((fl nil))
@ -248,9 +248,9 @@
(cmpwarn "The type of the form ~s is not ~s."
(fourth args) slot-type)
(progn
(when (eq 'VAR (car y))
(when (eq 'VAR (c1form-name y))
;; it's a variable, propagate type
(setf (var-type (third y)) new-type))
(setf (var-type (c1form-arg 0 y)) new-type))
(setf (c1form-type y) new-type))))
(make-c1form* 'SYS:STRUCTURE-SET :type (c1form-type y)
:args x (add-symbol name) (third args) y))

4
src/cmp/cmpfun.lsp
View file

@ -61,9 +61,9 @@
(c1expr (first args))))
(if (or (endp args)
(and (eq (c1form-name stream) 'VAR)
(member (var-kind (third stream)) '(GLOBAL SPECIAL))))
(member (var-kind (c1form-arg 0 stream)) '(GLOBAL SPECIAL))))
(make-c1form* 'C2PRINC :args #\Newline
(if (endp args) nil (third stream))
(if (endp args) nil (c1form-arg 0 stream))
stream)
(c1call-global 'TERPRI args)))

51
src/cmp/cmpinline.lsp
View file

@ -56,8 +56,8 @@
(var-changed-in-forms loc forms)))
(let ((check-specials (or (eq kind 'SPECIAL) (eq kind 'GLOBAL))))
(dolist (form forms)
(when (or (member var (info-changed-vars (second form)))
(and check-specials (info-sp-change (second form))))
(when (or (member var (c1form-changed-vars form))
(and check-specials (c1form-sp-change form)))
(return t)))))))
;;; Valid property names for open coded functions are:
@ -88,8 +88,9 @@
(defun inline-args (forms &optional types)
(flet ((all-locations (args &aux (res t))
(dolist (arg args res)
(unless (member (car arg) '(LOCATION VAR SYS:STRUCTURE-REF
#+clos SYS:INSTANCE-REF)
(unless (member (c1form-name arg)
'(LOCATION VAR SYS:STRUCTURE-REF
#+clos SYS:INSTANCE-REF)
:test #'eq)
(setq res nil)))))
@ -97,11 +98,11 @@
(form) (locs))
((endp forms) (nreverse locs))
(setq form (car forms))
(case (car form)
(case (c1form-name form)
(LOCATION
(push (list (c1form-type form) (third form)) locs))
(push (list (c1form-type form) (c1form-arg 0 form)) locs))
(VAR
(let ((var (third form)))
(let ((var (c1form-arg 0 form)))
(if (var-changed-in-forms var (cdr forms))
(let* ((var-rep-type (var-rep-type var))
(lcl (make-lcl-var :rep-type var-rep-type :type (var-type var))))
@ -111,8 +112,8 @@
(push (list (c1form-type form) var) locs))))
(CALL-GLOBAL
(let* ((fname (third form))
(args (fourth form))
(let* ((fname (c1form-arg 0 form))
(args (c1form-arg 1 form))
(return-type (c1form-type form))
(arg-locs (inline-args args))
(loc (inline-function fname arg-locs return-type)))
@ -167,9 +168,9 @@
(push (list type
(list 'SYS:STRUCTURE-REF
(first (coerce-locs
(inline-args (list (third form)))))
(fourth form)
(fifth form)))
(inline-args (list (c1form-arg 0 form)))))
(c1form-arg 1 form)
(c1form-arg 2 form)))
locs))))
#+clos
(SYS:INSTANCE-REF
@ -182,18 +183,18 @@
(push (list type
(list 'SYS:INSTANCE-REF
(first (coerce-locs
(inline-args (list (third form)))))
(fourth form)
#+nil (fifth form))) ; JJGR
(inline-args (list (c1form-arg 0 form)))))
(c1form-arg 1 form)
#+nil (c1form-arg 2 form))) ; JJGR
locs))))
(SETQ
(let ((vref (third form))
(form1 (fourth form)))
(let ((vref (c1form-arg 0 form))
(form1 (c1form-arg 1 form)))
(let ((*destination* vref)) (c2expr* form1))
(if (eq (car form1) 'LOCATION)
(push (list (c1form-type form1) (third form1)) locs)
(if (eq (c1form-name form1) 'LOCATION)
(push (list (c1form-type form1) (c1form-arg 0 form1)) locs)
(setq forms (list* nil ; discarded at iteration
(make-c1form 'VAR (second form) vref)
(make-c1form 'VAR form vref)
(cdr forms))
))))
@ -307,14 +308,14 @@
((or res (endp forms)) res)
(let ((form (car forms)))
(declare (object form))
(case (car form)
(case (c1form-name form)
(LOCATION)
(VAR
(when (var-changed-in-forms (third form) (cdr forms))
(when (var-changed-in-forms (c1form-arg 0 form) (cdr forms))
(setq res t)))
(CALL-GLOBAL
(let ((fname (third form))
(args (fourth form)))
(let ((fname (c1form-arg 0 form))
(args (c1form-arg 1 form)))
(when (or (not (inline-possible fname))
(null (setq ii (get-inline-info
fname
@ -325,7 +326,7 @@
(need-to-protect args))
(setq res t))))
(SYS:STRUCTURE-REF
(when (need-to-protect (list (third form)))
(when (need-to-protect (list (c1form-arg 0 form)))
(setq res t)))
(t (setq res t)))))
)

7
src/cmp/cmplam.lsp
View file

@ -306,8 +306,8 @@
(var (second kwd))
(init (third kwd))
(flag (fourth kwd)))
(cond ((and (eq (car init) 'LOCATION)
(null (third init)))
(cond ((and (eq (c1form-name init) 'LOCATION)
(null (c1form-arg 0 init)))
;; no initform
;; Cnil has been set in keyvars if keyword parameter is not supplied.
(setf (second KEYVARS[i]) i)
@ -379,7 +379,7 @@
(defun c1dm (macro-name vl body
&aux (whole nil) (env nil)
(vnames nil) (dm-info (make-info)) (dm-vars nil)
(vnames nil) (dm-vars nil)
(setjmps *setjmps*) ; Beppe
doc ss is ts other-decls ppn)
@ -507,7 +507,6 @@
(check-vdecl vnames ts is)
(setq body (c1decl-body other-decls body))
(unless (eql setjmps *setjmps*)
(setf (info-volatile dm-info) t)
(put-sysprop macro-name 'CONTAINS-SETJMP t))
(dolist (v dm-vars) (check-vref v))

29
src/cmp/cmplet.lsp
View file

@ -113,14 +113,15 @@
continue))
(defun update-var-type (var type x)
(when (listp x)
(if (and (eq (car x) 'VAR)
(eq var (third x)))
(setf (c1form-type x)
;; some occurrences might be typed with 'the'
(type-and (c1form-type x) type))
(dolist (e x)
(update-var-type var type e)))))
(cond ((consp x)
(dolist (e x)
(update-var-type var type e)))
((not (c1form-p x)))
((eq (c1form-name x) 'VAR)
(when (eq var (c1form-arg 0 x))
(setf (c1form-type x) (type-and (c1form-type x) type))))
(t
(update-var-type var type (c1form-args x)))))
;(defun read-only-variable-p (v l) (eq 'READ-ONLY (cdr (assoc v l))))
@ -179,10 +180,10 @@
(LOCATION
(if (can-be-replaced var body)
(setf (var-kind var) 'REPLACED
(var-loc var) (third form))
(push (cons var (third form)) bindings)))
(var-loc var) (c1form-arg 0 form))
(push (cons var (c1form-arg 0 form)) bindings)))
(VAR
(let* ((var1 (third form)))
(let* ((var1 (c1form-arg 0 form)))
(cond ((or (var-changed-in-forms var1 (cdr fl))
(and (member (var-kind var1) '(SPECIAL GLOBAL))
(member (var-name var1) prev-ss)))
@ -369,9 +370,9 @@
(LOCATION
(when (can-be-replaced* var body (cdr fl))
(setf (var-kind var) 'REPLACED
(var-loc var) (third form))))
(var-loc var) (c1form-arg 0 form))))
(VAR
(let* ((var1 (third form)))
(let* ((var1 (c1form-arg 0 form)))
(declare (type var var1))
(when (and (can-be-replaced* var body (cdr fl))
(member (var-kind var1) '(LEXICAL REPLACED :OBJECT))
@ -426,7 +427,7 @@
(last-form (car (last (first args)))))
((LET LET* FLET LABELS BLOCK CATCH)
(last-form (car (last args))))
(VAR (first x))
(VAR (c1form-arg 0 x))
(t x))))
(and (not (form-causes-side-effect form))
(or (< (var-ref var) 1)

77
src/cmp/cmpmac.lsp
View file

@ -61,8 +61,24 @@
;; C1-FORMS
;;
(defun make-c1form (name info &rest args)
(let ((form (list* name info args)))
(defstruct (c1form (:include info)
(:constructor do-make-c1form))
(name nil)
(args '()))
(defun make-c1form (name subform &rest args)
(let ((form (do-make-c1form :name name :args args
:changed-vars (info-changed-vars subform)
:referred-vars (info-referred-vars subform)
:type (info-type subform)
:sp-change (info-sp-change subform)
:volatile (info-volatile subform)
:local-referred (info-local-referred subform))))
(c1form-add-info form args)
form)
#+nil
(let ((form (do-make-c1form :name name :args args)))
(add-info form info)
(c1form-add-info form args)
form))
@ -80,68 +96,23 @@
(t
(setf info-args (list* key (second l) info-args)
l (cdr l))))))
(let ((form (list* name (apply #'make-info info-args) form-args)))
(let ((form (apply #'do-make-c1form :name name :args form-args
info-args)))
(c1form-add-info form form-args)
form)))
(defun c1form-add-info (form dependents)
(dolist (subform dependents form)
(cond ((c1form-p subform)
(add-info (second form) (second subform)
(eql (c1form-name subform) 'FUNCTION)))
(add-info form subform (eql (c1form-name subform) 'FUNCTION)))
((consp subform)
(c1form-add-info form subform)))))
(defun c1form-add-info1 (form subform)
(add-info (second form) (second subform)
(eql (c1form-name subform) 'FUNCTION)))
(defun c1form-args (form)
(cddr form))
(defun (setf c1form-args) (value form)
(setf (cddr form) value))
(defun c1form-p (form)
(and (consp form)
(consp (cdr form))
(info-p (second form))))
(defun c1form-name (form)
(first form))
(defun (setf c1form-name) (value form)
(setf (first form) value))
(defmacro c1form-referred-vars (form)
`(info-referred-vars (second ,form)))
(defmacro c1form-local-referred (form)
`(info-local-referred (second ,form)))
(defmacro c1form-changed-vars (form)
`(info-changed-vars (second ,form)))
(defun c1form-type (form)
(info-type (second form)))
(defun (setf c1form-type) (value form)
(setf (info-type (second form)) value))
(defmacro c1form-sp-change (form)
`(info-sp-change (second ,form)))
(defmacro c1form-volatile (form)
`(info-volatile (second ,form)))
(defun c1form-volatile* (form)
(if (c1form-volatile form) "volatile " ""))
(add-info form subform (eql (c1form-name subform) 'FUNCTION)))
(defun copy-c1form (form)
(let* ((info (copy-info (second form)))
(output (copy-list form)))
(setf (second output) info)
output))
(copy-structure form))
(defmacro c1form-arg (nth form)
(case nth
@ -149,3 +120,5 @@
(1 `(second (c1form-args ,form)))
(otherwise `(nth ,nth (c1form-args ,form)))))
(defun c1form-volatile* (form)
(if (c1form-volatile form) "volatile " ""))

6
src/cmp/cmpmain.lsp
View file

@ -224,12 +224,12 @@ int init_~A(cl_object cblock)
(delete-file o-name)
output-name))
(defun build-fasl (&rest args)
(apply #'builder :fasl args))
(defun build-program (&rest args)
(apply #'builder :program args))
(defun build-module (&rest args)
(apply #'builder :fasl args))
(defun build-static-library (&rest args)
(apply #'builder :static-library args))

7
src/cmp/cmpmulti.lsp
View file

@ -16,8 +16,7 @@
(check-args-number 'MULTIPLE-VALUE-CALL args 1)
(cond ((endp (rest args)) (c1funcall args))
(t (setq funob (c1funob (first args)))
(setq info (copy-info (second funob)))
(make-c1form 'MULTIPLE-VALUE-CALL info funob (c1args* (rest args))))))
(make-c1form 'MULTIPLE-VALUE-CALL funob funob (c1args* (rest args))))))
(defun c2multiple-value-call (funob forms)
(let ((tot (make-lcl-var :rep-type :cl-index))
@ -223,7 +222,9 @@
(dolist (v vars)
(wt-label (first labels))
(pop labels)
(bind (third (default-init v)) v)))
;; DEFAULT-INIT returns a LOCATION form, whose only argument
;; is the location that we pass to BIND.
(bind (c1form-arg 0 (default-init v)) v)))
(wt-label label))
;; 6) Compile the body. If there are bindings of special variables,

12
src/cmp/cmpspecial.lsp
View file

@ -57,7 +57,7 @@
(setq symbols (nreverse symbols))
(setq values (nreverse values))
(setq args (progv symbols values (c1progn (cdr args))))
(make-c1form 'COMPILER-LET (second args) symbols values args))
(make-c1form 'COMPILER-LET args symbols values args))
(defun c2compiler-let (symbols values body)
(progv symbols values (c2expr body)))
@ -85,35 +85,33 @@
(cmpck (endp (cdr fun))
"The lambda expression ~s is illegal." fun)
(let* ((funob (c1lambda-expr (cdr fun)))
(info (second funob))
(closure (closure-p funob))
(body (cddr fun))
(fun (make-fun :name NIL
:cfun (next-cfun)
:closure closure)))
(if closure
(make-c1form 'FUNCTION info 'CLOSURE funob fun)
(make-c1form 'FUNCTION funob 'CLOSURE funob fun)
(progn
(push (make-c1form* 'FUNCTION-CONSTANT :args funob fun)
*top-level-forms*)
(make-c1form 'FUNCTION info 'CONSTANT funob fun)))))
(make-c1form 'FUNCTION funob 'CONSTANT funob fun)))))
((and (consp fun) (eq (car fun) 'LAMBDA-BLOCK))
(cmpck (endp (cdr fun))
"The lambda expression ~s is illegal." fun)
(let* ((name (second fun))
(funob (c1lambda-expr (cddr fun) name))
(info (second funob))
(closure (closure-p funob))
(fun (make-fun :name NIL
:description name
:cfun (next-cfun)
:closure closure)))
(if closure
(make-c1form 'FUNCTION info 'CLOSURE funob fun)
(make-c1form 'FUNCTION funob 'CLOSURE funob fun)
(progn
(push (make-c1form* 'FUNCTION-CONSTANT :args funob fun)
*top-level-forms*)
(make-c1form 'FUNCTION info 'CONSTANT funob fun)))))
(make-c1form 'FUNCTION funob 'CONSTANT funob fun)))))
(t (cmperr "The function ~s is illegal." fun)))))
(defun c2function (kind funob fun)

13
src/cmp/cmptag.lsp
View file

@ -56,11 +56,14 @@
;; then increment the var-ref slot.
(labels ((add-reg1 (form)
;; increase the var-ref in FORM for all vars
(if (consp form)
(dolist (v form)
(add-reg1 v))
(when (var-p form)
(incf (var-ref form) (the fixnum *reg-amount*)))))
(cond ((c1form-p form)
(dolist (v (c1form-args form))
(add-reg1 v)))
((consp form)
(dolist (v form)
(add-reg1 v)))
((var-p form)
(incf (var-ref form) (the fixnum *reg-amount*)))))
(jumps-to-p (clause tag-name)
;; Does CLAUSE have a go TAG-NAME in it?
(cond ((c1form-p clause)

23
src/cmp/cmptop.lsp
View file

@ -74,7 +74,7 @@
(when form
(emit-local-funs)
(setq *funarg-vars* nil)
(let ((def (get-sysprop (car form) 'T3)))
(let ((def (get-sysprop (c1form-name form) 'T3)))
(when def
;; new local functions get pushed into *local-funs*
(apply def (c1form-args form))))
@ -229,7 +229,7 @@
(setq lambda-expr (c1lambda-expr (cdr args) (si::function-block-name fname)))
(unless (eql setjmps *setjmps*)
(setf (info-volatile (second lambda-expr)) t))
(setf (c1form-volatile lambda-expr) t))
(multiple-value-bind (decl body doc)
(si::process-declarations (cddr args) nil)
(cond ((and (assoc 'si::c-local decl) *allow-c-local-declaration*)
@ -242,7 +242,7 @@
(and
(symbolp fname)
(get-sysprop fname 'PROCLAIMED-FUNCTION)
(let ((lambda-list (third lambda-expr)))
(let ((lambda-list (c1form-arg 0 lambda-expr)))
(declare (list lambda-list))
(and (null (second lambda-list)) ; no optional
(null (third lambda-list)) ; no rest
@ -342,9 +342,9 @@
(setq *funarg-vars* funarg-vars)
(when *compile-print* (print-emitting fname))
(when lambda-expr ; Not sharing code.
(setq lambda-list (third lambda-expr)
(setq lambda-list (c1form-arg 0 lambda-expr)
requireds (car lambda-list))
(analyze-regs (info-referred-vars (second lambda-expr)))
(analyze-regs (c1form-referred-vars lambda-expr))
(if (setq inline-info (assoc fname *inline-functions* :test #'same-fname-p))
@ -391,7 +391,7 @@
(*unwind-exit* *unwind-exit*))
(wt-nl1 "{")
(wt-function-prolog nil 'LOCAL-ENTRY)
(c2lambda-expr lambda-list (third (cddr lambda-expr)) cfun fname
(c2lambda-expr lambda-list (c1form-arg 2 lambda-expr) cfun fname
nil 'LOCAL-ENTRY)
(wt-nl1 "}")
(wt-function-epilogue)))
@ -425,7 +425,7 @@
(wt-nl1 "{")
(wt-function-prolog sp)
(c2lambda-expr lambda-list (third (cddr lambda-expr)) cfun fname)
(c2lambda-expr lambda-list (c1form-arg 2 lambda-expr) cfun fname)
(wt-nl1 "}")
(wt-function-epilogue)))))
@ -733,7 +733,7 @@
&aux (level (fun-level fun))
(nenvs level)
(*volatile* (c1form-volatile* lambda-expr))
(lambda-list (third lambda-expr))
(lambda-list (c1form-arg 0 lambda-expr))
(requireds (car lambda-list))
(va_args (or (second lambda-list)
(third lambda-list)
@ -762,7 +762,7 @@
(wt-h1 ");")
(wt ")")
(analyze-regs (info-referred-vars (second lambda-expr)))
(analyze-regs (c1form-referred-vars lambda-expr))
(let* ((*lcl* 0) (*temp* 0) (*max-temp* 0)
(*lex* 0) (*max-lex* 0)
(*env* (fun-env fun)) ; continue growing env
@ -786,7 +786,7 @@
;; parameter of this closure
;; (not yet bound, therefore var-loc is OBJECT)
(eq (var-loc x) 'OBJECT)))
(info-local-referred (second lambda-expr)))))
(c1form-local-referred lambda-expr))))
(setq clv-used (sort clv-used #'> :key #'var-loc))
(when clv-used
(wt-nl "{cl_object scan=env0;")
@ -800,7 +800,8 @@
(unless bs (return))
(when (plusp n) (wt " scan=CDR(scan);")))
(wt "}"))))
(c2lambda-expr (third lambda-expr) (third (cddr lambda-expr))
(c2lambda-expr (c1form-arg 0 lambda-expr)
(c1form-arg 2 lambda-expr)
(fun-cfun fun) (fun-name fun)
(fun-closure fun))
(wt-nl1 "}")

8
src/cmp/cmpvar.lsp
View file

@ -320,8 +320,8 @@
(defun c2setq (vref form)
(let ((*destination* vref)) (c2expr* form))
(if (eq (car form) 'LOCATION)
(c2location (third form))
(if (eq (c1form-name form) 'LOCATION)
(c2location (c1form-arg 0 form))
(unwind-exit vref))
)
@ -413,8 +413,8 @@
form (car forms))
(if (or (var-changed-in-forms var (cdr forms))
(var-referred-in-forms var (cdr forms)))
(case (car form)
(LOCATION (push (cons var (third form)) saves))
(case (c1form-name form)
(LOCATION (push (cons var (c1form-arg 0 form)) saves))
(otherwise
(if (local var)
(let* ((rep-type (var-rep-type var))