diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index af9b67441..d741234cb 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -44,7 +44,7 @@ :args blk body) body)))) -(defun c2block (blk body) +(defun c2block (c1form blk body) (if (plusp (var-ref (blk-var blk))) (let* ((blk-var (blk-var blk)) (*env-lvl* *env-lvl*)) @@ -103,7 +103,7 @@ (when var (add-to-read-nodes var output)) output))))) -(defun c2return-from (blk type val var) +(defun c2return-from (c1form blk type val var) (declare (ignore var)) (case type (CCB diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 65a7a8cde..b660f624c 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -68,7 +68,7 @@ (t (cmperr "Malformed function name: ~A" fun))))) -(defun c2funcall (form args) +(defun c2funcall (c1form form args) (let* ((*inline-blocks* 0) (*temp* *temp*) (form-type (c1form-primary-type form)) @@ -83,13 +83,13 @@ ;;; ARGS is the list of arguments ;;; LOC is either NIL or the location of the function object ;;; -(defun c2call-global (fname args &optional (return-type T)) +(defun c2call-global (c1form fname args) (let ((fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p))) (when (and fun (c2try-tail-recursive-call fun args)) (return-from c2call-global)) (let* ((*inline-blocks* 0) (*temp* *temp*)) - (unwind-exit (call-global-loc fname fun args return-type + (unwind-exit (call-global-loc fname fun args (c1form-type c1form) (loc-type *destination*))) (close-inline-blocks)))) diff --git a/src/cmp/cmpcatch.lsp b/src/cmp/cmpcatch.lsp index 202de5562..326fe3fbb 100644 --- a/src/cmp/cmpcatch.lsp +++ b/src/cmp/cmpcatch.lsp @@ -20,7 +20,7 @@ (make-c1form* 'CATCH :sp-change t :type t :args (c1expr (first args)) (c1progn (rest args)))) -(defun c2catch (tag body) +(defun c2catch (c1form tag body) (let* ((new-destination (tmp-destination *destination*))) (let* ((*destination* 'VALUE0)) (c2expr* tag)) @@ -54,7 +54,7 @@ (make-c1form* 'UNWIND-PROTECT :type (c1form-type form) :sp-change t :args form (c1progn (rest args))))) -(defun c2unwind-protect (form body) +(defun c2unwind-protect (c1form form body) (let* ((sp (make-lcl-var :rep-type :cl-index)) (nargs (make-lcl-var :rep-type :cl-index)) (*unwind-exit* `((STACK ,sp) ,@*unwind-exit*))) @@ -90,7 +90,7 @@ (check-args-number 'THROW args 2 2) (make-c1form* 'THROW :args (c1expr (first args)) (c1expr (second args)))) -(defun c2throw (tag val &aux loc) +(defun c2throw (c1form tag val &aux loc) (case (c1form-name tag) ((VAR LOCATION) (setq loc (c1form-arg 0 tag))) (t (setq loc (make-temp-var)) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 150d9dc75..009a33bcd 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -159,11 +159,7 @@ (let* ((name (c1form-name form)) (args (c1form-args form)) (dispatch (gethash name *c2-dispatch-table*))) - (if (or (eq name 'LET) (eq name 'LET*)) - (let ((*volatile* (c1form-volatile* form))) - (declare (special *volatile*)) - (apply dispatch args)) - (apply dispatch args))))) + (apply dispatch form args)))) (defun c2expr* (form) (let* ((*exit* (next-label)) @@ -190,7 +186,7 @@ (output-type (and output-form (c1form-type output-form)))) (make-c1form* 'PROGN :type output-type :args fl))))) -(defun c2progn (forms) +(defun c2progn (c1form forms) ;; c1progn ensures that the length of forms is not less than 1. (do ((l forms (cdr l)) (lex *lex*)) diff --git a/src/cmp/cmpexit.lsp b/src/cmp/cmpexit.lsp index 4797be2e1..4823d4e40 100644 --- a/src/cmp/cmpexit.lsp +++ b/src/cmp/cmpexit.lsp @@ -204,7 +204,8 @@ (let* ((*destination* 'TRASH) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) - (c2psetq (cdr *tail-recursion-info*) args) + (c2psetq nil ;; We do not provide any C2FORM + (cdr *tail-recursion-info*) args) (wt-label *exit*)) (unwind-no-exit 'TAIL-RECURSION-MARK) (wt-nl "goto TTL;") diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 69e9b4655..1a87861e2 100755 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -583,7 +583,7 @@ (wt "cl_env_copy->nvalues=" (length output-vars) ";") 'VALUES)))))) -(defun c2c-inline (arguments &rest rest) +(defun c2c-inline (c1form arguments &rest rest) (let ((*inline-blocks* 0) (*temp* *temp*)) (unwind-exit (apply #'produce-inline-loc (inline-args arguments) rest)) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index f9672733b..32ff731a7 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -160,10 +160,10 @@ (setf recompute t finish nil)))) t))) -(defun c2locals (funs body labels ;; labels is T when deriving from labels - &aux block-p - (*env* *env*) - (*env-lvl* *env-lvl*) env-grows) +(defun c2locals (c1form funs body labels ;; labels is T when deriving from labels + &aux block-p + (*env* *env*) + (*env-lvl* *env-lvl*) env-grows) ;; create location for each function which is returned, ;; either in lexical: (dolist (fun funs) @@ -256,7 +256,7 @@ (var-kind var) 'LEXICAL)))))) fun)) -(defun c2call-local (fun args &optional narg) +(defun c2call-local (c1form fun args) (declare (type fun fun)) (unless (c2try-tail-recursive-call fun args) (let ((*inline-blocks* 0) diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index 075005ac7..a067c49c1 100644 --- a/src/cmp/cmpform.lsp +++ b/src/cmp/cmpform.lsp @@ -190,7 +190,6 @@ (*compile-file-position* (c1form-file-position ,form)) (*current-toplevel-form* (c1form-toplevel-form ,form)) (*current-form* (c1form-form ,form)) - (*current-c2form* ,form) (*cmp-env* (c1form-env ,form))) ,@body)) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 97fa3b253..10e769e0b 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -38,7 +38,6 @@ ;;; (defvar *current-form* '|compiler preprocess|) (defvar *current-toplevel-form* '|compiler preprocess|) -(defvar *current-c2form* nil) (defvar *compile-file-position* -1) (defvar *first-error* t) (defvar *active-protection* nil) diff --git a/src/cmp/cmpif.lsp b/src/cmp/cmpif.lsp index 10c3ac495..fdf98e8c8 100644 --- a/src/cmp/cmpif.lsp +++ b/src/cmp/cmpif.lsp @@ -81,7 +81,7 @@ ,@body (wt-label ,label)))) -(defun c2if (fmla form1 form2) +(defun c2if (c1form fmla form1 form2) ;; FIXME! Optimize when FORM1 or FORM2 are constants (with-exit-label (normal-exit) (with-exit-label (false-label) @@ -105,7 +105,7 @@ (:object '((:object) (:object) "Null(#0)?Ct:Cnil" nil t)) (otherwise (return-from negate-argument nil))))))) -(defun c2fmla-not (arg) +(defun c2fmla-not (c1form arg) (let ((dest *destination*)) (cond ((and (consp dest) (eq (car dest) 'JUMP-TRUE)) (let ((*destination* `(JUMP-FALSE ,@(cdr dest)))) @@ -129,7 +129,7 @@ (let ((dest *destination*)) (and (consp dest) (eq (car dest) 'JUMP-FALSE)))) -(defun c2fmla-and (butlast last) +(defun c2fmla-and (c1form butlast last) (if (jump-false-destination?) (progn (mapc #'c2expr* butlast) @@ -141,7 +141,7 @@ (c2expr last)) (unwind-exit nil)))) -(defun c2fmla-or (butlast last) +(defun c2fmla-or (c1form butlast last) (cond ((jump-true-destination?) (mapc #'c2expr* butlast) (c2expr last)) diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index 0a920cb89..d09016cb6 100644 --- a/src/cmp/cmplet.lsp +++ b/src/cmp/cmplet.lsp @@ -241,8 +241,9 @@ (baboon :format-control "In REPLACEABLE, variable ~A not found. Form:~%~A" :format-arguments (list (var-name var) *current-form*)))) -(defun c2let* (vars forms body +(defun c2let* (c1form vars forms body &aux + (*volatile* (c1form-volatile* c1form)) (*unwind-exit* *unwind-exit*) (*env* *env*) (*env-lvl* *env-lvl*) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 4d5b4104b..b1fda3a96 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -58,7 +58,7 @@ (defun c1values (args) (make-c1form* 'VALUES :args (c1args* args))) -(defun c2values (forms) +(defun c2values (c1form forms) (when (and (eq *destination* 'RETURN-OBJECT) (rest forms) (consp *current-form*) @@ -224,7 +224,7 @@ (when labels (wt-label label)))) output)) -(defun c2multiple-value-setq (vars form) +(defun c2multiple-value-setq (c1form vars form) (multiple-value-bind (min-values max-values) (c1form-values-number form) (unwind-exit @@ -257,7 +257,7 @@ :local-vars vars :args vars init-form body))))) -(defun c2multiple-value-bind (vars init-form body) +(defun c2multiple-value-bind (c1form vars init-form body) ;; 0) Compile the form which is going to give us the values (let ((*destination* 'VALUES)) (c2expr* init-form)) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 89517fe0c..490df680f 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -105,7 +105,7 @@ of the occurrences in those lists." values-type)) (values values-type assumptions))) -(defun p1call-global (c1form assumptions fname args &optional (return-type t)) +(defun p1call-global (c1form assumptions fname args) (loop for v in args do (multiple-value-bind (arg-type local-ass) (p1propagate v assumptions) @@ -116,7 +116,7 @@ of the occurrences in those lists." type (c1form-type c1form)) (return (values type assumptions))))) -(defun p1call-local (c1form assumptions fun args &optional (return-type t)) +(defun p1call-local (c1form assumptions fun args) (loop for v in args do (multiple-value-bind (arg-type local-ass) (p1propagate v assumptions) diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index 0ff6d6ec4..e5b54fd56 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -52,7 +52,7 @@ (setq args (progv symbols values (c1progn (cdr args)))) (make-c1form 'COMPILER-LET args symbols values args)) -(defun c2compiler-let (symbols values body) +(defun c2compiler-let (c1form symbols values body) (progv symbols values (c2expr body))) (defun c1function (args &aux fd) @@ -82,7 +82,7 @@ (make-c1form 'FUNCTION lambda-form 'CLOSURE lambda-form funob)))) (t (cmperr "The function ~s is illegal." fun))))) -(defun c2function (kind funob fun) +(defun c2function (c1form kind funob fun) (case kind (GLOBAL (unwind-exit (list 'FDEFINITION fun))) diff --git a/src/cmp/cmpstack.lsp b/src/cmp/cmpstack.lsp index 2c972f5c0..a556d4983 100644 --- a/src/cmp/cmpstack.lsp +++ b/src/cmp/cmpstack.lsp @@ -35,7 +35,7 @@ :type (c1form-type body) :args body))) -(defun c2with-stack (body) +(defun c2with-stack (c1form body) (let* ((new-destination (tmp-destination *destination*)) (*temp* *temp*)) (wt-nl "{ struct ecl_stack_frame _ecl_inner_frame_aux;") @@ -65,7 +65,7 @@ (c1expr `(c-inline (,frame-var) (t) :void "ecl_stack_frame_push_values(#0)" :one-liner t :side-effects t))))) -(defun c2stack-push-values (form push-statement) +(defun c2stack-push-values (c1form form push-statement) (let ((*destination* 'VALUES)) (c2expr* form)) (c2expr push-statement)) diff --git a/src/cmp/cmpstructures.lsp b/src/cmp/cmpstructures.lsp index f326b4e6a..69b0bbaf0 100644 --- a/src/cmp/cmpstructures.lsp +++ b/src/cmp/cmpstructures.lsp @@ -79,7 +79,7 @@ nil))) (c1call-global 'sys:structure-ref args)))) -(defun c2structure-ref (form name-vv index unsafe) +(defun c2structure-ref (c1form form name-vv index unsafe) (let* ((*inline-blocks* 0) (*temp* *temp*) (loc (first (coerce-locs (inline-args (list form)))))) @@ -125,8 +125,7 @@ :args x (add-symbol name) (third args) y)) (c1call-global 'SYS:STRUCTURE-SET args))) -(defun c2structure-set (x name-vv index y - &aux locs (*inline-blocks* 0)) +(defun c2structure-set (c1form x name-vv index y) ;; the third argument here *c1t* is just a hack to ensure that ;; a variable is introduced for y if it is an expression with side effects (let* ((*inline-blocks* 0) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 2253db412..7f949416a 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -168,6 +168,8 @@ (value0 . set-value0-loc) (return . set-return-loc) (trash . set-trash-loc) + + (the . set-the-loc) )) (defconstant +wt-loc-dispatch-alist+ @@ -187,6 +189,7 @@ (character-value . wt-character) (value . wt-value) (keyvars . wt-keyvars) + (the . wt-the) (fdefinition . wt-fdefinition) (make-cclosure . wt-make-closure) @@ -222,8 +225,6 @@ (let* . c2let*) - (multiple-value-call . c2multiple-value-call) ; c2 - (multiple-value-prog1 . c2multiple-value-prog1) ; c2 (values . c2values) ; c2 (multiple-value-setq . c2multiple-value-setq) ; c2 (multiple-value-bind . c2multiple-value-bind) ; c2 diff --git a/src/cmp/cmptag.lsp b/src/cmp/cmptag.lsp index 0b83c54a8..41e220b03 100644 --- a/src/cmp/cmptag.lsp +++ b/src/cmp/cmptag.lsp @@ -123,7 +123,7 @@ (make-c1form* 'TAGBODY :local-vars (list tag-var) :args tag-var body)) -(defun c2tagbody (tag-loc body) +(defun c2tagbody (c1form tag-loc body) (declare (type var tag-loc)) (if (null (var-kind tag-loc)) ;; only local goto's @@ -209,7 +209,7 @@ (incf (tag-ref tag)) (add-to-read-nodes var (make-c1form* 'GO :args tag (or ccb clb unw))))))) -(defun c2go (tag nonlocal) +(defun c2go (c1form tag nonlocal) (if nonlocal (let ((var (tag-var tag))) (wt-nl "cl_go(" var ",MAKE_FIXNUM(" (tag-index tag) "));")) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 7b93f176c..87c196f07 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -73,9 +73,8 @@ (*compile-file-position* (c1form-file-position form)) (*current-toplevel-form* (c1form-form form)) (*current-form* (c1form-form form)) - (*current-c2form* form) (*cmp-env* (c1form-env form))) - (apply def (c1form-args form))) + (apply def form (c1form-args form))) (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form))))) @@ -299,10 +298,10 @@ return f2; (t (c1progn 'NIL))))) -(defun t2compiler-let (symbols values body) +(defun t2compiler-let (c1form symbols values body) (progv symbols values (c2expr body))) -(defun t2progn (args) +(defun t2progn (c1form args) (mapc #'t2expr args)) (defun exported-fname (name) @@ -510,7 +509,7 @@ return f2; (defun p1ordinary (c1form assumptions form) (p1propagate form assumptions)) -(defun t2ordinary (form) +(defun t2ordinary (c1form form) (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) (*destination* 'TRASH)) @@ -554,19 +553,19 @@ return f2; (setf loc (add-object (cmp-eval form))))) (make-c1form* 'LOCATION :type t :args loc))) -(defun t2load-time-value (vv-loc form) +(defun t2load-time-value (c1form vv-loc form) (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) (*destination* vv-loc)) (c2expr form) (wt-label *exit*))) -(defun t2make-form (vv-loc form) +(defun t2make-form (c1form vv-loc form) (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) (*destination* vv-loc)) (c2expr form) (wt-label *exit*))) -(defun t2init-form (vv-loc form) +(defun t2init-form (c1form vv-loc form) (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) (*destination* 'TRASH)) (c2expr form) @@ -811,7 +810,7 @@ return f2; (defun p1fset (c1form assumptions fun fname macro pprint c1forms) (p1propagate (fun-lambda fun) assumptions)) -(defun c2fset (fun fname macro pprint c1forms) +(defun c2fset (c1form fun fname macro pprint c1forms) (when (fun-no-entry fun) (wt-nl "(void)0; /* No entry created for " (format nil "~A" (fun-name fun)) @@ -822,7 +821,7 @@ return f2; (unless (and (not (fun-closure fun)) (eq *destination* 'TRASH)) (return-from c2fset - (c2call-global 'SI:FSET c1forms (c1form-primary-type (second c1forms))))) + (c2call-global c1form 'SI:FSET c1forms))) (let ((*inline-blocks* 0) (loc (data-empty-loc))) (push (list loc fname fun) *global-cfuns-array*) diff --git a/src/cmp/cmptype-assert.lsp b/src/cmp/cmptype-assert.lsp index 16de3a286..89ca31834 100644 --- a/src/cmp/cmptype-assert.lsp +++ b/src/cmp/cmptype-assert.lsp @@ -32,7 +32,7 @@ :type (reduce #'type-or types) :args var expressions))))) -(defun c2compiler-typecase (var expressions) +(defun c2compiler-typecase (c1form var expressions) (loop with var-type = (var-type var) for (type form) in expressions when (or (member type '(t otherwise)) @@ -122,7 +122,7 @@ :type type :args type form (c1expr full-check))))))) -(defun c2checked-value (type value let-form) +(defun c2checked-value (c1form type value let-form) (c2expr (if (subtypep (c1form-primary-type value) type) value let-form))) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index ba9fcae6b..a7406b2e3 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -262,9 +262,10 @@ (or (eq kind 'global) (eq kind 'special)))) -(defun c2var (vref) (unwind-exit vref)) +(defun c2var (c1form vref) + (unwind-exit vref)) -(defun c2location (loc) (unwind-exit loc)) +(defun c2location (c1form loc) (unwind-exit loc)) (defun wt-var (var &aux (var-loc (var-loc var))) ; ccb (declare (type var var)) @@ -284,28 +285,28 @@ (t (var-kind var)))) (defun set-var (loc var &aux (var-loc (var-loc var))) ; ccb - (if (var-p var) - (case (var-kind var) - (CLOSURE - (wt-nl)(wt-env var-loc)(wt "= ") - (wt-coerce-loc (var-rep-type var) loc) - (wt #\;)) - (LEXICAL - (wt-nl)(wt-lex var-loc)(wt "= ") - (wt-coerce-loc (var-rep-type var) loc) - (wt #\;)) - ((SPECIAL GLOBAL) - (if (safe-compile) - (wt-nl "cl_set(" var-loc ",") - (wt-nl "ECL_SETQ(cl_env_copy," var-loc ",")) - (wt-coerce-loc (var-rep-type var) loc) - (wt ");")) - (t - (wt-nl var-loc "= ") - (wt-coerce-loc (var-rep-type var) loc) - (wt #\;)) - ) - (baboon))) + (unless (var-p var) + (baboon)) + (case (var-kind var) + (CLOSURE + (wt-nl)(wt-env var-loc)(wt "= ") + (wt-coerce-loc (var-rep-type var) loc) + (wt #\;)) + (LEXICAL + (wt-nl)(wt-lex var-loc)(wt "= ") + (wt-coerce-loc (var-rep-type var) loc) + (wt #\;)) + ((SPECIAL GLOBAL) + (if (safe-compile) + (wt-nl "cl_set(" var-loc ",") + (wt-nl "ECL_SETQ(cl_env_copy," var-loc ",")) + (wt-coerce-loc (var-rep-type var) loc) + (wt ");")) + (t + (wt-nl var-loc "= ") + (wt-coerce-loc (var-rep-type var) loc) + (wt #\;)) + )) (defun wt-lex (lex) (if (consp lex) @@ -369,10 +370,10 @@ :args name form))) `(setf name ,form))) -(defun c2setq (vref form) +(defun c2setq (c1form vref form) (let ((*destination* vref)) (c2expr* form)) (if (eq (c1form-name form) 'LOCATION) - (c2location (c1form-arg 0 form)) + (c2location form (c1form-arg 0 form)) (unwind-exit vref)) ) @@ -384,7 +385,7 @@ (make-c1form* 'PROGV :type (c1form-type forms) :args symbols values forms))) -(defun c2progv (symbols values body) +(defun c2progv (c1form symbols values body) (let* ((*lcl* *lcl*) (lcl (next-lcl)) (sym-loc (make-lcl-var)) @@ -434,7 +435,7 @@ `(checked-value ,form ,type))) forms)))) -(defun c2psetq (vrefs forms &aux (*lcl* *lcl*) (saves nil) (blocks 0)) +(defun c2psetq (c1form vrefs forms &aux (*lcl* *lcl*) (saves nil) (blocks 0)) ;; similar to inline-args (do ((vrefs vrefs (cdr vrefs)) (forms forms (cdr forms))