diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 6fe158e1d..65a7a8cde 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -17,9 +17,9 @@ (defun unoptimized-long-call (fun arguments) (let ((frame (gensym))) - (c1expr `(with-stack ,frame - ,@(loop for i in arguments collect `(stack-push ,frame ,i)) - (si::apply-from-stack-frame ,frame ,fun))))) + `(with-stack ,frame + ,@(loop for i in arguments collect `(stack-push ,frame ,i)) + (si::apply-from-stack-frame ,frame ,fun)))) (defun unoptimized-funcall (fun arguments) (let ((l (length arguments))) @@ -36,12 +36,12 @@ (cond ;; (FUNCALL (LAMBDA ...) ...) ((and (consp fun) (eq (first fun) 'LAMBDA)) - (c1expr (optimize-funcall/apply-lambda (cdr fun) arguments nil))) + (optimize-funcall/apply-lambda (cdr fun) arguments nil)) ;; (FUNCALL (EXT::LAMBDA-BLOCK ...) ...) ((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK)) (setf fun (macroexpand-1 fun)) - (c1expr (optimize-funcall/apply-lambda (cdr fun) arguments nil))) + (optimize-funcall/apply-lambda (cdr fun) arguments nil)) ;; (FUNCALL atomic-expression ...) ((atom fun) (unoptimized-funcall fun arguments)) @@ -60,11 +60,11 @@ (c1call fun arguments nil)) ;; (FUNCALL #'(LAMBDA ...) ...) ((and (consp fun) (eq (first fun) 'LAMBDA)) - (c1expr (optimize-funcall/apply-lambda (rest fun) arguments nil))) + (optimize-funcall/apply-lambda (rest fun) arguments nil)) ;; (FUNCALL #'(EXT::LAMBDA-BLOCK ...) ...) ((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK)) (setf fun (macroexpand-1 fun)) - (c1expr (optimize-funcall/apply-lambda (rest fun) arguments nil))) + (optimize-funcall/apply-lambda (rest fun) arguments nil)) (t (cmperr "Malformed function name: ~A" fun))))) diff --git a/src/cmp/cmpclos.lsp b/src/cmp/cmpclos.lsp index cbee70f70..dd3285765 100644 --- a/src/cmp/cmpclos.lsp +++ b/src/cmp/cmpclos.lsp @@ -100,7 +100,7 @@ (let* ((slotd (clos:accessor-method-slot-definition reader)) (index (clos::safe-slot-definition-location slotd))) (when (si::fixnump index) - (c1expr `(clos::safe-instance-ref ,object ,index))))))))) + `(clos::safe-instance-ref ,object ,index)))))))) (defun try-optimize-slot-writer (orig-writers args) (let* ((c-args (mapcar #'c1expr args)) @@ -112,7 +112,7 @@ (let* ((slotd (clos:accessor-method-slot-definition writer)) (index (clos::safe-slot-definition-location slotd))) (when (si::fixnump index) - (c1expr `(si::instance-set ,(second args) ,index ,(first args)))))))))) + `(si::instance-set ,(second args) ,index ,(first args))))))))) (progn . #.(loop for var in '(clos::+standard-generic-function-slots+ diff --git a/src/cmp/cmpct.lsp b/src/cmp/cmpct.lsp index d5c65d5af..2c7922c1c 100644 --- a/src/cmp/cmpct.lsp +++ b/src/cmp/cmpct.lsp @@ -64,10 +64,10 @@ (single-float (values "_mm_castsi128_ps" :float-sse-pack)) (double-float (values "_mm_castsi128_pd" :double-sse-pack)) (otherwise (values "" :int-sse-pack))) - (c1expr `(c-inline () () ,rtype - ,(format nil "~A(_mm_setr_epi8(~{~A~^,~}))" - wrapper (coerce bytes 'list)) - :one-liner t :side-effects nil))))) + `(c-inline () () ,rtype + ,(format nil "~A(_mm_setr_epi8(~{~A~^,~}))" + wrapper (coerce bytes 'list)) + :one-liner t :side-effects nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 7e50e8665..ebd30a77c 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -14,35 +14,41 @@ (in-package "COMPILER") +(defun c1expr-inner (form) + (declare (si::c-local)) + (cond ((symbolp form) + (setq form (chk-symbol-macrolet form)) + (cond ((not (symbolp form)) + form) + ((eq form nil) (c1nil)) + ((eq form t) (c1t)) + ((keywordp form) + (make-c1form* 'LOCATION :type (object-type form) + :args (add-symbol form))) + ((constantp form) + (or (c1constant-value (symbol-value form) :only-small-values t) + (c1var form))) + (t (c1var form)))) + ((consp form) + (cmpck (not (si::proper-list-p form)) + "Improper list found in lisp form~%~A" form) + (let ((fun (car form))) + (cond ((let ((fd (gethash fun *c1-dispatch-table*))) + (and fd (setf fun fd))) + (funcall fun (rest form))) + ((symbolp fun) + (c1call fun (cdr form) t)) + ((and (consp fun) (eq (car fun) 'LAMBDA)) + (c1funcall form)) + (t (cmperr "~s is not a legal function name." fun))))) + (t (c1constant-value form :always t)))) + (defun c1expr (form) (let ((*current-form* form)) - (setq form (catch *cmperr-tag* - (cond ((symbolp form) - (setq form (chk-symbol-macrolet form)) - (cond ((not (symbolp form)) - (c1expr form)) - ((eq form nil) (c1nil)) - ((eq form t) (c1t)) - ((keywordp form) - (make-c1form* 'LOCATION :type (object-type form) - :args (add-symbol form))) - ((constantp form) - (or (c1constant-value (symbol-value form) :only-small-values t) - (c1var form))) - (t (c1var form)))) - ((consp form) - (let ((fun (car form))) - (cond ((let ((fd (gethash fun *c1-dispatch-table*))) - (and fd (funcall fd (rest form))))) - ((symbolp fun) - (c1call fun (cdr form) t)) - ((and (consp fun) (eq (car fun) 'LAMBDA)) - (c1funcall form)) - (t (cmperr "~s is not a legal function name." fun))))) - (t (c1constant-value form :always t)))))) - (if (eq form '*cmperr-tag*) - (c1nil) - form)) + (loop + (setf form (c1expr-inner form)) + (when (c1form-p form) + (return form))))) (defvar *c1nil* (make-c1form* 'LOCATION :type (object-type nil) :args nil)) (defun c1nil () *c1nil*) @@ -57,16 +63,16 @@ (multiple-value-setq (fd success) (cmp-expand-compiler-macro fd fname args)) success)) - (c1expr fd)) + fd) ((and can-inline (progn (multiple-value-setq (fd success) (clos-compiler-macro-expand fname args)) success)) - (c1expr fd)) + fd) ((and macros-allowed (setq fd (cmp-macro-function fname))) - (c1expr (cmp-expand-macro fd (list* fname args)))) + (cmp-expand-macro fd (list* fname args))) ((and (setq can-inline (declared-inline-p fname)) (consp can-inline) (eq (first can-inline) 'function) @@ -74,7 +80,7 @@ (<= (cmp-env-optimization 'space) 1)) (let ((*inline-max-depth* (1- *inline-max-depth*))) (cmpnote "Inlining ~a" fname) - (c1expr `(funcall ,can-inline ,@args)))) + `(funcall ,can-inline ,@args))) (t (c1call-global fname args)))) (defun c1call-local (fname args) @@ -88,7 +94,7 @@ (plusp *inline-max-depth*)) (return-from c1call-local (let ((*inline-max-depth* (1- *inline-max-depth*))) - (c1expr `(funcall #',lambda ,@args)))))) + `(funcall #',lambda ,@args))))) (let* ((forms (c1args* args)) (return-type (or (get-local-return-type fun) 'T)) (arg-types (get-local-arg-types fun))) @@ -151,10 +157,9 @@ (push v all-values) (return nil)) finally - (let ((value (c1constant-value - (apply fname (nreverse all-values)) - :only-small-values nil))) - (return value))) + (return (c1constant-value + (apply fname (nreverse all-values)) + :only-small-values nil))) (error (c))))) (defun c2expr (form) diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 4746ae8e3..69e9b4655 100755 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -423,7 +423,7 @@ (unless (every #'stringp args) (cmperr "The argument to CLINES, ~s, is not a list of strings." args)) (setf *clines-string-list* (nconc *clines-string-list* (copy-list args))) - (c1expr '(progn))) + '(progn)) (defun output-clines (output-stream) (flet ((parse-one-string (s output-stream) diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index 750a0b7f4..c26a58173 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -21,11 +21,11 @@ (arguments (rest args))) (cond ((and (consp fun) (eq (first fun) 'LAMBDA)) - (c1expr (optimize-funcall/apply-lambda (cdr fun) arguments t))) + (optimize-funcall/apply-lambda (cdr fun) arguments t)) ((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK)) (setf fun (macroexpand-1 fun)) - (c1expr (optimize-funcall/apply-lambda (cdr fun) arguments t))) + (optimize-funcall/apply-lambda (cdr fun) arguments t)) ((and (consp fun) (eq (first fun) 'FUNCTION) (consp (second fun)) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 757e9e233..97fa3b253 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -41,9 +41,6 @@ (defvar *current-c2form* nil) (defvar *compile-file-position* -1) (defvar *first-error* t) -(defconstant *cmperr-tag* (cons nil nil)) - -(defvar *active-handlers* nil) (defvar *active-protection* nil) (defvar *pending-actions* nil) diff --git a/src/cmp/cmpif.lsp b/src/cmp/cmpif.lsp index 1f5bb5259..10c3ac495 100644 --- a/src/cmp/cmpif.lsp +++ b/src/cmp/cmpif.lsp @@ -22,7 +22,7 @@ (c1form-constant-p test) (when constant-p (return-from c1if - (c1expr (if value (second args) (third args)))))) + (if value (second args) (third args))))) ;; Otherwise, normal IF form (let* ((true-branch (c1expr (second args))) (false-branch (c1expr (third args)))) @@ -39,7 +39,7 @@ (multiple-value-bind (constant-p value) (c1form-constant-p value) (when constant-p - (return-from c1not (c1expr (not value))))) + (return-from c1not (not value)))) (make-c1form* 'FMLA-NOT :type '(member t nil) :args value))) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index f45f93b2a..2cec69c07 100755 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -891,9 +891,7 @@ from the C language code. NIL means \"do not create the file\"." (with-open-file (*compiler-output2* h-pathname :direction :output :if-does-not-exist :create :if-exists :supersede) (wt-nl1 "#include " *cmpinclude*) - (catch *cmperr-tag* (ctop-write init-name - h-pathname - data-pathname)) + (ctop-write init-name h-pathname data-pathname) (terpri *compiler-output1*) (terpri *compiler-output2*)))) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 29992ab38..7189b5e62 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -21,7 +21,8 @@ (check-args-number 'MULTIPLE-VALUE-CALL args 1) (cond ;; (M-V-C #'FUNCTION) => (FUNCALL #'FUNCTION) - ((endp (rest args)) (c1funcall args)) + ((endp (rest args)) + (c1funcall args)) ;; (M-V-C #'FUNCTION (VALUES A ... Z)) => (FUNCALL #'FUNCTION A ... Z) ((and (= (length args) 2) (consp (setq forms (second args))) @@ -29,22 +30,21 @@ (c1funcall (list* (first args) (rest forms)))) ;; More complicated case. (t - (c1expr - (let ((function (gensym)) - (frame (gensym))) - `(with-stack ,frame - (let* ((,function ,(first args))) - ,@(loop for i in (rest args) - collect `(stack-push-values ,frame ,i)) - (si::apply-from-stack-frame ,frame ,function)))))))) + (let ((function (gensym)) + (frame (gensym))) + `(with-stack ,frame + (let* ((,function ,(first args))) + ,@(loop for i in (rest args) + collect `(stack-push-values ,frame ,i)) + (si::apply-from-stack-frame ,frame ,function))))))) (defun c1multiple-value-prog1 (args) (check-args-number 'MULTIPLE-VALUE-PROG1 args 1) - (c1expr (let ((frame (gensym))) - `(with-stack ,frame - (stack-push-values ,frame ,(first args)) - ,@(rest args) - (stack-pop ,frame))))) + (let ((frame (gensym))) + `(with-stack ,frame + (stack-push-values ,frame ,(first args)) + ,@(rest args) + (stack-pop ,frame)))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -132,13 +132,13 @@ (push `(setf ,var ,new-var) late-bindings))))) (let ((value (second args))) (cond (temp-vars - (c1expr `(let* (,@temp-vars) - (multiple-value-setq ,vars ,value) - ,@late-bindings))) + `(let* (,@temp-vars) + (multiple-value-setq ,vars ,value) + ,@late-bindings)) ((endp vars) - (c1expr `(values ,value))) + `(values ,value)) ((= (length vars) 1) - (c1expr `(setq ,(first vars) ,value))) + `(setq ,(first vars) ,value)) (t (setq value (c1expr value) vars (mapcar #'c1vref vars)) @@ -236,8 +236,8 @@ (init-form (pop args))) (when (= (length variables) 1) (return-from c1multiple-value-bind - (c1expr `(let* ((,(first variables) ,init-form)) - ,@args)))) + `(let* ((,(first variables) ,init-form)) + ,@args))) (multiple-value-bind (body ss ts is other-decls) (c1body args nil) (c1declare-specials ss) diff --git a/src/cmp/cmpstack.lsp b/src/cmp/cmpstack.lsp index 15bf1a072..2c972f5c0 100644 --- a/src/cmp/cmpstack.lsp +++ b/src/cmp/cmpstack.lsp @@ -47,14 +47,14 @@ (unwind-exit new-destination))) (defun c1innermost-stack-frame (args) - (c1expr `(c-inline () () :object ,+ecl-stack-frame-variable+ - :one-liner t :side-effects nil))) + `(c-inline () () :object ,+ecl-stack-frame-variable+ + :one-liner t :side-effects nil)) (defun c1stack-push (args) - (c1expr `(progn - (c-inline ,args (t t) :void "ecl_stack_frame_push(#0,#1)" - :one-liner t :side-effects t) - 1))) + `(progn + (c-inline ,args (t t) :void "ecl_stack_frame_push(#0,#1)" + :one-liner t :side-effects t) + 1)) (defun c1stack-push-values (args) (let ((frame-var (pop args)) @@ -71,11 +71,11 @@ (c2expr push-statement)) (defun c1stack-pop (args) - (c1expr `(c-inline ,args (t) (values &rest t) - "cl_env_copy->values[0]=ecl_stack_frame_pop_values(#0);" - :one-liner nil :side-effects t))) + `(c-inline ,args (t) (values &rest t) + "cl_env_copy->values[0]=ecl_stack_frame_pop_values(#0);" + :one-liner nil :side-effects t)) (defun c1apply-from-stack-frame (args) - (c1expr `(c-inline ,args (t t) (values &rest t) - "cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);" - :one-liner nil :side-effects t))) + `(c-inline ,args (t t) (values &rest t) + "cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);" + :one-liner nil :side-effects t)) diff --git a/src/cmp/cmpstructures.lsp b/src/cmp/cmpstructures.lsp index 3dab84260..f326b4e6a 100644 --- a/src/cmp/cmpstructures.lsp +++ b/src/cmp/cmpstructures.lsp @@ -51,13 +51,13 @@ (setf args (first args)) (cond ((eq structure-type 'list) - (c1expr `(elt ,args ,slot-index))) + `(elt ,args ,slot-index)) ((eq structure-type 'vector) - (c1expr `(svref ,args ,slot-index))) + `(svref ,args ,slot-index)) ((consp structure-type) - (c1expr `(aref (the ,structure-type ,args) ,slot-index))) + `(aref (the ,structure-type ,args) ,slot-index)) (t - (c1structure-ref `(,args ',structure-type ,slot-index)))))))) + `(,args ',structure-type ,slot-index))))))) (defun c1structure-ref (args) (check-args-number 'sys:structure-ref args 3) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 1e12fa8ad..7b93f176c 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -29,34 +29,33 @@ (*current-form* form) (*first-error* t) (*setjmps* 0)) - (catch *cmperr-tag* - (when (consp form) - (let ((fun (car form)) (args (cdr form)) fd) - (when (member fun *toplevel-forms-to-print*) - (print-current-form)) - (cond - ((consp fun) (t1ordinary form)) - ((not (symbolp fun)) - (cmperr "~s is illegal function." fun)) - ((eq fun 'QUOTE) - (t1ordinary 'NIL)) - ((setq fd (gethash fun *t1-dispatch-table*)) - (funcall fd args)) - ((gethash fun *c1-dispatch-table*) - (t1ordinary form)) - ((and (setq fd (compiler-macro-function fun)) - (inline-possible fun) - (let ((success nil)) - (multiple-value-setq (fd success) - (cmp-expand-macro fd form)) - success)) - (push 'macroexpand *current-toplevel-form*) - (t1expr* fd)) - ((setq fd (cmp-macro-function fun)) - (push 'macroexpand *current-toplevel-form*) - (t1expr* (cmp-expand-macro fd form))) - (t (t1ordinary form)) - ))))) + (when (consp form) + (let ((fun (car form)) (args (cdr form)) fd) + (when (member fun *toplevel-forms-to-print*) + (print-current-form)) + (cond + ((consp fun) (t1ordinary form)) + ((not (symbolp fun)) + (cmperr "~s is illegal function." fun)) + ((eq fun 'QUOTE) + (t1ordinary 'NIL)) + ((setq fd (gethash fun *t1-dispatch-table*)) + (funcall fd args)) + ((gethash fun *c1-dispatch-table*) + (t1ordinary form)) + ((and (setq fd (compiler-macro-function fun)) + (inline-possible fun) + (let ((success nil)) + (multiple-value-setq (fd success) + (cmp-expand-macro fd form)) + success)) + (push 'macroexpand *current-toplevel-form*) + (t1expr* fd)) + ((setq fd (cmp-macro-function fun)) + (push 'macroexpand *current-toplevel-form*) + (t1expr* (cmp-expand-macro fd form))) + (t (t1ordinary form)) + )))) (defun t1/c1expr (form) (cond ((not *compile-toplevel*) diff --git a/src/cmp/cmptype-assert.lsp b/src/cmp/cmptype-assert.lsp index 5a90740c6..16de3a286 100644 --- a/src/cmp/cmptype-assert.lsp +++ b/src/cmp/cmptype-assert.lsp @@ -91,12 +91,12 @@ (type (pop args)) form form-type and-type) (cond ((or (trivial-type-p args) (not (policy-type-assertions))) - (c1expr value)) + value) ((and (policy-evaluate-forms) (constantp value)) (unless (typep (cmp-eval value) type) (cmpwarning "Failed type assertion for value ~A and type ~A" value type)) - (c1expr value)) + value) ;; Is the form type contained in the test? ((progn (setf form (c1expr value) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 77fb1cffa..5341b6d61 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -351,7 +351,7 @@ (cmpck (constantp name) "The constant ~s is being assigned a value." name) (setq name (chk-symbol-macrolet name)) (unless (symbolp name) - (return-from c1setq1 (c1expr `(setf ,name ,form)))) + (return-from c1setq1 `(setf ,name ,form))) (let* ((name1 (c1vref name)) (form1 (c1expr form)) (v-type (var-type name1)) @@ -409,7 +409,7 @@ "The constant ~s is being assigned a value." var) (setq use-psetf t))) (when use-psetf - (return-from c1psetq (c1expr `(psetf ,@args)))) + (return-from c1psetq `(psetf ,@args))) (do ((l args (cddr l)) (vrefs '()) (forms '()))