X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=aa925880239d59b18e472ad73c01a9fec4512ed9;hb=8886298f2c0e50e595cf481c426b6331ab898a23;hp=5976435ea2d0d84503758fbe77273783db03d2b7;hpb=4e0ff6bb79908436adea8375d4eea46d10079cec;p=sbcl.git

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 5976435..aa92588 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -284,8 +284,8 @@
         (unless (symbolp name)
           (fail "The local macro name ~S is not a symbol." name))
         (when (fboundp name)
-          (compiler-assert-symbol-home-package-unlocked
-           name "binding ~A as a local macro"))
+          (program-assert-symbol-home-package-unlocked
+           context name "binding ~A as a local macro"))
         (unless (listp arglist)
           (fail "The local macro argument list ~S is not a list."
                 arglist))
@@ -335,8 +335,8 @@
         (unless (symbolp name)
           (fail "The local symbol macro name ~S is not a symbol." name))
         (when (or (boundp name) (eq (info :variable :kind name) :macro))
-          (compiler-assert-symbol-home-package-unlocked
-           name "binding ~A as a local symbol-macro"))
+          (program-assert-symbol-home-package-unlocked
+           context name "binding ~A as a local symbol-macro"))
         (let ((kind (info :variable :kind name)))
           (when (member kind '(:special :constant))
             (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
@@ -499,14 +499,11 @@
   (with-fun-name-leaf (leaf thing start :global t)
     (reference-leaf start next result leaf)))
 
-(defun constant-global-fun-name-p (thing)
-  ;; FIXME: Once we have a marginally better CONSTANTP and
-  ;; CONSTANT-VALUE we can use those instead.
-  (and (consp thing)
-       (eq 'quote (car thing))
-       (null (cddr thing))
-       (legal-fun-name-p (cadr thing))
-       t))
+(defun constant-global-fun-name (thing)
+  (let ((constantp (sb!xc:constantp thing)))
+    (and constantp
+         (let ((name (constant-form-value thing)))
+           (and (legal-fun-name-p name) name)))))
 
 ;;;; FUNCALL
 
@@ -540,12 +537,12 @@
 ;;; directly to %FUNCALL, instead of waiting around for type
 ;;; inference.
 (define-source-transform funcall (function &rest args)
-  (cond ((and (consp function) (eq (car function) 'function))
-         `(%funcall ,function ,@args))
-        ((constant-global-fun-name-p function)
-         `(%funcall (global-function ,(second function)) ,@args))
-        (t
-         (values nil t))))
+  (if (and (consp function) (eq (car function) 'function))
+      `(%funcall ,function ,@args)
+      (let ((name (constant-global-fun-name function)))
+        (if name
+            `(%funcall (global-function ,name) ,@args)
+            (values nil t)))))
 
 (deftransform %coerce-callable-to-fun ((thing) (function) *)
   "optimize away possible call to FDEFINITION at runtime"
@@ -593,8 +590,8 @@
                  (vals (second spec)))))))
     (dolist (name (names))
       (when (eq (info :variable :kind name) :macro)
-        (compiler-assert-symbol-home-package-unlocked
-         name "lexically binding symbol-macro ~A")))
+        (program-assert-symbol-home-package-unlocked
+         :compile name "lexically binding symbol-macro ~A")))
     (values (vars) (vals))))
 
 (def-ir1-translator let ((bindings &body body) start next result)
@@ -686,8 +683,8 @@
       (let ((name (first def)))
         (check-fun-name name)
         (when (fboundp name)
-          (compiler-assert-symbol-home-package-unlocked
-           name "binding ~A as a local function"))
+          (program-assert-symbol-home-package-unlocked
+           :compile name "binding ~A as a local function"))
         (names name)
         (multiple-value-bind (forms decls) (parse-body (cddr def))
           (defs `(lambda ,(second def)
@@ -1026,12 +1023,12 @@
                    ;; MV-COMBINATIONS.
                    (make-combination fun-lvar))))
     (ir1-convert start ctran fun-lvar
-                 (cond ((and (consp fun) (eq (car fun) 'function))
-                        fun)
-                       ((constant-global-fun-name-p fun)
-                        `(global-function ,(second fun)))
-                       (t
-                        `(%coerce-callable-to-fun ,fun))))
+                 (if (and (consp fun) (eq (car fun) 'function))
+                     fun
+                     (let ((name (constant-global-fun-name fun)))
+                       (if name
+                           `(global-function ,name)
+                           `(%coerce-callable-to-fun ,fun)))))
     (setf (lvar-dest fun-lvar) node)
     (collect ((arg-lvars))
       (let ((this-start ctran))