diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index a6a0f8d3d..b35037146 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -124,21 +124,11 @@ (unoptimized-long-call `#',fname args))) (let* ((forms (c1args* args))) ;; If all arguments are constants, try to precompute the function - ;; value - (when (and (get-sysprop fname 'pure) - (policy-evaluate-forms) - (inline-possible fname)) - (loop with all-values = '() - with constant-p - with v - for form in forms - do (if (multiple-value-setq (constant-p v) - (c1form-constant-p form)) - (push v all-values) - (return nil)) - finally (return-from c1call-global - (c1constant-value (apply fname (nreverse all-values)) - :always t)))) + ;; value. We abort when the function signals an error or the value + ;; is not printable. + (let ((value (c1call-constant-fold fname forms))) + (when value + (return-from c1call-global value))) ;; Otherwise emit a global function call (make-c1form* 'CALL-GLOBAL :sp-change (function-may-change-sp fname) @@ -148,6 +138,26 @@ ;; loc and type are filled by c2expr ))) +(defun c1call-constant-fold (fname forms) + (when (and (get-sysprop fname 'pure) + (policy-evaluate-forms) + (inline-possible fname)) + (handler-case + (loop with all-values = '() + with constant-p + with v + for form in forms + do (if (multiple-value-setq (constant-p v) + (c1form-constant-p form)) + (push v all-values) + (return nil)) + finally + (let ((value (c1constant-value + (apply fname (nreverse all-values)) + :only-small-values nil))) + (return values))) + (error (c))))) + (defun c2expr (form) (with-c1form-env (form form) (let* ((name (c1form-name form))