0.pre7.65:

[sbcl.git] / src / code / defboot.lisp

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index ccc2c4b..fb80dc3 100644 (file)
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -141,72 +141,109 @@
 (defmacro-mundanely prog2 (form1 result &body body)
   `(prog1 (progn ,form1 ,result) ,@body))
 \f
 (defmacro-mundanely prog2 (form1 result &body body)
   `(prog1 (progn ,form1 ,result) ,@body))
 \f

-;;; Now that we have the definition of MULTIPLE-VALUE-BIND, we can make a
-;;; reasonably readable definition of DEFUN.
-;;;
-;;; DEFUN expands into %DEFUN which is a function that is treated
-;;; magically by the compiler (through an IR1 transform) in order to
-;;; handle stuff like inlining. After the compiler has gotten the
-;;; information it wants out of macro definition, it compiles a call
-;;; to %%DEFUN which happens at load time.
-(defmacro-mundanely defun (&whole whole name args &body body)
+;;;; DEFUN
+
+;;; Should we save the inline expansion of the function named NAME?
+(defun inline-fun-name-p (name)
+  (or
+   ;; the normal reason for saving the inline expansion
+   (info :function :inlinep name)
+   ;; another reason for saving the inline expansion: If the
+   ;; ANSI-recommended idiom
+   ;;   (DECLAIM (INLINE FOO))
+   ;;   (DEFUN FOO ..)
+   ;;   (DECLAIM (NOTINLINE FOO))
+   ;; has been used, and then we later do another
+   ;;   (DEFUN FOO ..)
+   ;; without a preceding
+   ;;   (DECLAIM (INLINE FOO))
+   ;; what should we do with the old inline expansion when we see the
+   ;; new DEFUN? Overwriting it with the new definition seems like
+   ;; the only unsurprising choice.
+   (info :function :inline-expansion-designator name)))
+
+;;; Now that we have the definition of MULTIPLE-VALUE-BIND, we can
+;;; make a reasonably readable definition of DEFUN.
+(defmacro-mundanely defun (&environment env name args &body body)
+  "Define a function at top level."
+  #+sb-xc-host
+  (unless (symbol-package (fun-name-block-name name))
+    (warn "DEFUN of uninterned symbol ~S (tricky for GENESIS)" name))

   (multiple-value-bind (forms decls doc) (parse-body body)
   (multiple-value-bind (forms decls doc) (parse-body body)

-    (let ((def `(lambda ,args
-                 ,@decls
-                 (block ,(function-name-block-name name)
-                   ,@forms))))
-      `(sb!c::%defun ',name #',def ,doc ',whole))))
-#+sb-xc-host (/show "before PROCLAIM" (sb!c::info :function :kind 'sb!c::%%defun))
-#+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defun)) ; to avoid
-                                       ; undefined function warnings
-#+sb-xc-host (/show "after PROCLAIM" (sb!c::info :function :kind 'sb!c::%%defun))
-(defun sb!c::%%defun (name def doc &optional inline-expansion)
+    (let* ((lambda `(lambda ,args
+                     ,@decls
+                     (block ,(fun-name-block-name name)
+                       ,@forms)))
+          (want-to-inline )
+          (inline-lambda
+           (cond (;; Does the user not even want to inline?
+                  (not (inline-fun-name-p name))
+                  nil)
+                 (;; Does inlining look too hairy to handle?
+                  (not (sb!c:lambda-independent-of-lexenv-p lambda env))
+                  (sb!c:maybe-compiler-note
+                   "lexical environment too hairy, can't inline DEFUN ~S"
+                   name)
+                  nil)
+                 (t
+                  ;; FIXME: The only reason that we return
+                  ;; LAMBDA-WITH-LEXENV instead of returning bare
+                  ;; LAMBDA is to avoid modifying downstream code
+                  ;; which expects LAMBDA-WITH-LEXENV. But the code
+                  ;; here is the only code which feeds into the
+                  ;; downstream code, and the generality of the
+                  ;; interface is no longer used, so it'd make sense
+                  ;; to simplify the interface instead of using the
+                  ;; old general LAMBDA-WITH-LEXENV interface in this
+                  ;; simplified way.
+                  `(sb!c:lambda-with-lexenv
+                    nil nil nil ; i.e. no DECLS, no MACROS, no SYMMACS
+                    ,@(rest lambda))))))
+      `(progn
+
+        ;; In cross-compilation of toplevel DEFUNs, we arrange
+        ;; for the LAMBDA to be statically linked by GENESIS.
+        #+sb-xc-host
+        (cold-fset ,name ,lambda)
+
+        (eval-when (:compile-toplevel :load-toplevel :execute)
+          (sb!c:%compiler-defun ',name ',inline-lambda))
+
+        (%defun ',name
+                ;; In normal compilation (not for cold load) this is
+                ;; where the compiled LAMBDA first appears. In
+                ;; cross-compilation, we manipulate the
+                ;; previously-statically-linked LAMBDA here.
+                #-sb-xc-host ,lambda
+                #+sb-xc-host (fdefinition ',name)
+                ,doc)))))
+#-sb-xc-host
+(defun %defun (name def doc)
+  (declare (type function def))
+  (declare (type (or null simple-string doc)))
+  (/show0 "entering %DEFUN, name (or block name) = ..")
+  (/primitive-print (symbol-name (fun-name-block-name name)))
+  (aver (legal-fun-name-p name))

   (when (fboundp name)
   (when (fboundp name)

+    (/show0 "redefining NAME")

     (style-warn "redefining ~S in DEFUN" name))
     (style-warn "redefining ~S in DEFUN" name))

+  (/show0 "setting FDEFINITION")

   (setf (sb!xc:fdefinition name) def)
   (when doc
   (setf (sb!xc:fdefinition name) def)
   (when doc

-    ;; FIXME: This should use shared SETF-name parsing logic.
+    ;; FIXME: This should use shared SETF-name-parsing logic.
+    (/show0 "setting FDOCUMENTATION")

     (if (and (consp name) (eq (first name) 'setf))
        (setf (fdocumentation (second name) 'setf) doc)
     (if (and (consp name) (eq (first name) 'setf))
        (setf (fdocumentation (second name) 'setf) doc)

-       (setf (fdocumentation name 'function) doc)))
-  (become-defined-function-name name)
-  (when (or inline-expansion
-           (info :function :inline-expansion name))
-    (setf (info :function :inline-expansion name)
-         inline-expansion))
+       (setf (fdocumentation (the symbol name) 'function) doc)))
+  (/show0 "leaving %DEFUN")

   name)
   name)

-;;; Ordinarily this definition of SB!C:%DEFUN as an ordinary function is not
-;;; used: the parallel (but different) definition as an IR1 transform takes
-;;; precedence. However, it's still good to define this in order to keep the
-;;; interpreter happy. We define it here (instead of alongside the parallel
-;;; IR1 transform) because while the IR1 transform is needed and appropriate
-;;; in the cross-compiler running in the host Common Lisp, this parallel
-;;; ordinary function definition is only appropriate in the target Lisp.
-(defun sb!c::%defun (name def doc source)
-  (declare (ignore source))
-  (setf (sb!eval:interpreted-function-name def) name)
-  (ecase (info :function :where-from name)
-    (:assumed
-      (setf (info :function :where-from name) :defined)
-      (setf (info :function :type name)
-              (extract-function-type def))
-      (when (info :function :assumed-type name)
-        (setf (info :function :assumed-type name) nil)))
-    (:declared)
-    (:defined
-     (setf (info :function :type name)
-          (extract-function-type def))
-     ;; We shouldn't need to clear this here because it should be clear
-     ;; already (cleared when the last definition was processed).
-     (aver (null (info :function :assumed-type name)))))
-  (sb!c::%%defun name def doc))

 \f
 ;;;; DEFVAR and DEFPARAMETER
 
 (defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp))
   #!+sb-doc
 \f
 ;;;; DEFVAR and DEFPARAMETER
 
 (defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp))
   #!+sb-doc

-  "For defining global variables at top level. Declares the variable
-  SPECIAL and, optionally, initializes it. If the variable already has a
+  "Define a global variable at top level. Declare the variable
+  SPECIAL and, optionally, initialize it. If the variable already has a

   value, the old value is not clobbered. The third argument is an optional
   documentation string for the variable."
   `(progn
   value, the old value is not clobbered. The third argument is an optional
   documentation string for the variable."
   `(progn

@@ -220,10 +257,11 @@
 
 (defmacro-mundanely defparameter (var val &optional (doc nil docp))
   #!+sb-doc
 
 (defmacro-mundanely defparameter (var val &optional (doc nil docp))
   #!+sb-doc

-  "Defines a parameter that is not normally changed by the program,
-  but that may be changed without causing an error. Declares the
-  variable special and sets its value to VAL. The third argument is
-  an optional documentation string for the parameter."
+  "Define a parameter that is not normally changed by the program,
+  but that may be changed without causing an error. Declare the
+  variable special and sets its value to VAL, overwriting any
+  previous value. The third argument is an optional documentation
+  string for the parameter."

   `(progn
      (declaim (special ,var))
      (setq ,var ,val)
   `(progn
      (declaim (special ,var))
      (setq ,var ,val)

@@ -236,11 +274,11 @@
 \f
 ;;;; iteration constructs
 
 \f
 ;;;; iteration constructs
 

-;;; (These macros are defined in terms of a function DO-DO-BODY which is also
-;;; used by SB!INT:DO-ANONYMOUS. Since these macros should not be loaded
-;;; on the cross-compilation host, but SB!INT:DO-ANONYMOUS and DO-DO-BODY
-;;; should be, these macros can't conveniently be in the same file as
-;;; DO-DO-BODY.)
+;;; (These macros are defined in terms of a function DO-DO-BODY which
+;;; is also used by SB!INT:DO-ANONYMOUS. Since these macros should not
+;;; be loaded on the cross-compilation host, but SB!INT:DO-ANONYMOUS
+;;; and DO-DO-BODY should be, these macros can't conveniently be in
+;;; the same file as DO-DO-BODY.)

 (defmacro-mundanely do (varlist endlist &body body)
   #!+sb-doc
   "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
 (defmacro-mundanely do (varlist endlist &body body)
   #!+sb-doc
   "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*

@@ -299,8 +337,8 @@
     ;; form, we introduce a gratuitous binding of the variable to NIL
     ;; without the declarations, then evaluate the result form in that
     ;; environment. We spuriously reference the gratuitous variable,
     ;; form, we introduce a gratuitous binding of the variable to NIL
     ;; without the declarations, then evaluate the result form in that
     ;; environment. We spuriously reference the gratuitous variable,

-    ;; since we don't want to use IGNORABLE on what might be a special
-    ;; var.
+    ;; since since we don't want to use IGNORABLE on what might be a
+    ;; special var.

     (let ((n-list (gensym)))
       `(do ((,n-list ,list (cdr ,n-list)))
           ((endp ,n-list)
     (let ((n-list (gensym)))
       `(do ((,n-list ,list (cdr ,n-list)))
           ((endp ,n-list)