home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / main.lisp < prev    next >
Encoding:
Text File  |  1992-12-18  |  57.2 KB  |  1,760 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: main.lisp,v 1.56.1.2 92/12/17 20:36:44 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains the top-level interfaces to the compiler.
  15. ;;; 
  16. ;;; Written by Rob MacLachlan
  17. ;;;
  18. (in-package "C")
  19. (in-package "EXTENSIONS")
  20. (export '(*compile-progress* compile-from-stream *block-compile-default*
  21.                  start-block end-block))
  22. (in-package "LISP")
  23. (export '(*compile-verbose* *compile-print* *compile-file-pathname*
  24.                 *compile-file-truename*))
  25. (in-package "C")
  26.  
  27. (proclaim '(special *constants* *free-variables* *compile-component*
  28.             *code-vector* *next-location* *result-fixups*
  29.             *free-functions* *source-paths* *failed-optimizations*
  30.             *seen-blocks* *seen-functions* *list-conflicts-table*
  31.             *continuation-number* *continuation-numbers*
  32.             *number-continuations* *tn-id* *tn-ids* *id-tns*
  33.             *label-ids* *label-id* *id-labels*
  34.             *undefined-warnings* *compiler-error-count*
  35.             *compiler-warning-count* *compiler-note-count*
  36.             *compiler-error-output* *compiler-error-bailout*
  37.             *compiler-trace-output*
  38.             *last-source-context* *last-original-source*
  39.             *last-source-form* *last-format-string* *last-format-args*
  40.             *last-message-count* *lexical-environment*))
  41.  
  42. (defvar *block-compile-default* :specified
  43.   "The default value for the :Block-Compile argument to COMPILE-FILE.")
  44.  
  45. (defvar compiler-version "1.0")
  46. (pushnew :python *features*)
  47. (setf (getf ext:*herald-items* :python)
  48.       `("    Python " ,compiler-version ", target "
  49.     ,#'(lambda (stream)
  50.          (write-string (backend-version *backend*) stream))))
  51.  
  52. (defvar *check-consistency* nil)
  53. (defvar *all-components*)
  54.  
  55. ;;; The current block compilation state.  These are initialized to the 
  56. ;;; :Block-Compile and :Entry-Points arguments that COMPILE-FILE was called
  57. ;;; with.  Subsequent START-BLOCK or END-BLOCK declarations alter the values.
  58. ;;;
  59. (defvar *block-compile*)
  60. (declaim (type (member nil t :specified) *block-compile*))
  61. (defvar *entry-points*)
  62. (declaim (list *entry-points*))
  63.  
  64. ;;; When block compiling, used by PROCESS-FORM to accumulate top-level lambdas
  65. ;;; resulting from compiling subforms.  (In reverse order.)
  66. ;;;
  67. (defvar *top-level-lambdas*)
  68. (declaim (list *top-level-lambdas*))
  69.  
  70. (defvar *compile-verbose* t
  71.   "The default for the :VERBOSE argument to COMPILE-FILE.")
  72. (defvar *compile-print* t
  73.   "The default for the :PRINT argument to COMPILE-FILE.")
  74. (defvar *compile-progress* nil
  75.   "The default for the :PROGRESS argument to COMPILE-FILE.")
  76.  
  77. (defvar *compile-file-pathname* nil
  78.   "The defaulted pathname of the file currently being compiler, or NIL if not
  79.   compiling.")
  80. (defvar *compile-file-truename* nil
  81.   "The TRUENAME of the file currently being compiler, or NIL if not
  82.   compiling.")
  83.  
  84. (declaim (type (or pathname null) *compile-file-pathname*
  85.            *compile-file-truename*))
  86.  
  87. ;;; The values of *Package* and policy when compilation started.
  88. ;;;
  89. (defvar *initial-package*)
  90. (defvar *initial-cookie*)
  91. (defvar *initial-interface-cookie*)
  92.  
  93. ;;; The source-info structure for the current compilation.  This is null
  94. ;;; globally to indicate that we aren't currently in any identifiable
  95. ;;; compilation.
  96. ;;;
  97. (defvar *source-info* nil)
  98.  
  99.  
  100. ;;; Maybe-Mumble  --  Internal
  101. ;;;
  102. ;;;    Mumble conditional on *compile-progress*.
  103. ;;;
  104. (defun maybe-mumble (&rest foo)
  105.   (when *compile-progress*
  106.     (apply #'compiler-mumble foo)))
  107.  
  108.  
  109. (deftype object () '(or fasl-file core-object null))
  110.  
  111. (defvar *compile-object* nil)
  112. (declaim (type object *compile-object*))
  113.  
  114.  
  115.  
  116. ;;;; Component compilation:
  117.  
  118. (defparameter max-optimize-iterations 3
  119.   "The upper limit on the number of times that we will consecutively do IR1
  120.   optimization that doesn't introduce any new code.  A finite limit is
  121.   necessary, since type inference may take arbitrarily long to converge.")
  122.  
  123. (defevent ir1-optimize-until-done "IR1-OPTIMIZE-UNTIL-DONE called.")
  124. (defevent ir1-optimize-maxed-out "Hit MAX-OPTIMIZE-ITERATIONS limit.")
  125.  
  126. ;;; IR1-Optimize-Until-Done  --  Internal
  127. ;;;
  128. ;;;    Repeatedly optimize Component until no further optimizations can be
  129. ;;; found or we hit our iteration limit.  When we hit the limit, we clear the
  130. ;;; component and block REOPTIMIZE flags to discourage following the next
  131. ;;; optimization attempt from pounding on the same code.
  132. ;;;
  133. (defun ir1-optimize-until-done (component)
  134.   (declare (type component component))
  135.   (maybe-mumble "Opt")
  136.   (event ir1-optimize-until-done)
  137.   (let ((count 0)
  138.     (cleared-reanalyze nil))
  139.     (loop
  140.       (when (component-reanalyze component)
  141.     (setq count 0)
  142.     (setq cleared-reanalyze t)
  143.     (setf (component-reanalyze component) nil))
  144.       (setf (component-reoptimize component) nil)
  145.       (ir1-optimize component)
  146.       (unless (component-reoptimize component)
  147.     (maybe-mumble " ")
  148.     (return))
  149.       (incf count)
  150.       (when (= count max-optimize-iterations)
  151.     (event ir1-optimize-maxed-out)
  152.     (maybe-mumble "* ")
  153.     (setf (component-reoptimize component) nil)
  154.     (do-blocks (block component)
  155.       (setf (block-reoptimize block) nil))
  156.     (return))
  157.       (maybe-mumble "."))
  158.     (when cleared-reanalyze
  159.       (setf (component-reanalyze component) t)))
  160.   (undefined-value))
  161.  
  162. (defparameter *constraint-propagate* t)
  163. (defparameter *reoptimize-after-type-check-max* 5)
  164.  
  165. (defevent reoptimize-maxed-out
  166.   "*REOPTIMIZE-AFTER-TYPE-CHECK-MAX* exceeded.")
  167.  
  168.  
  169. ;;; DFO-AS-NEEDED  --  Internal
  170. ;;;
  171. ;;;    Iterate doing FIND-DFO until no new dead code is discovered.
  172. ;;;
  173. (defun dfo-as-needed (component)
  174.   (declare (type component component))
  175.   (when (component-reanalyze component)
  176.     (maybe-mumble "DFO")
  177.     (loop
  178.       (find-dfo component)
  179.       (unless (component-reanalyze component)
  180.     (maybe-mumble " ")
  181.     (return))
  182.       (maybe-mumble ".")))
  183.   (undefined-value))
  184.  
  185.  
  186. ;;; IR1-Phases  --  Internal
  187. ;;;
  188. ;;;    Do all the IR1 phases for a non-top-level component.
  189. ;;;
  190. (defun ir1-phases (component)
  191.   (declare (type component component))
  192.   (let ((*constraint-number* 0)
  193.     (loop-count 1))
  194.     (declare (special *constraint-number*))
  195.     (loop
  196.       (ir1-optimize-until-done component)
  197.       (dfo-as-needed component)
  198.       (when *constraint-propagate*
  199.     (maybe-mumble "Constraint ")
  200.     (constraint-propagate component))
  201.       (maybe-mumble "Type ")
  202.       (generate-type-checks component)
  203.       (unless (or (component-reoptimize component)
  204.           (component-reanalyze component))
  205.     (return))
  206.       (when (>= loop-count *reoptimize-after-type-check-max*)
  207.     (maybe-mumble "[Reoptimize Limit]")
  208.     (event reoptimize-maxed-out)
  209.     (return))
  210.       (incf loop-count)))
  211.  
  212.   (ir1-finalize component)
  213.   (undefined-value))
  214.  
  215.  
  216. ;;; Compile-Component  --  Internal
  217. ;;;
  218. (defun compile-component (component)
  219.   (when *compile-print*
  220.     (compiler-mumble "~&Compiling ~A: " (component-name component)))
  221.   
  222.   (ir1-phases component)
  223.   
  224.   #|
  225.   (maybe-mumble "Dom ")
  226.   (find-dominators component)
  227.   (maybe-mumble "Loop ")
  228.   (loop-analyze component)
  229.   |#
  230.  
  231.   (let ((*compile-component* component)
  232.     (*code-segment* nil)
  233.     (*elsewhere* nil))
  234.     (maybe-mumble "Env ")
  235.     (environment-analyze component)
  236.     (dfo-as-needed component)
  237.     (maybe-mumble "GTN ")
  238.     (gtn-analyze component)
  239.     (maybe-mumble "LTN ")
  240.     (ltn-analyze component)
  241.     (dfo-as-needed component)
  242.     (maybe-mumble "Control ")
  243.     (control-analyze component)
  244.  
  245.     (when (ir2-component-values-receivers (component-info component))
  246.       (maybe-mumble "Stack ")
  247.       (stack-analyze component)
  248.       ;;
  249.       ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by stack
  250.       ;; analysis.  There shouldn't be any unreachable code after control, so
  251.       ;; this won't delete anything.
  252.       (dfo-as-needed component))
  253.  
  254.     (maybe-mumble "IR2Tran ")
  255.     (init-assembler)
  256.     (entry-analyze component)
  257.     (ir2-convert component)
  258.  
  259.     (when (policy nil (>= speed cspeed))
  260.       (maybe-mumble "Copy ")
  261.       (copy-propagate component))
  262.  
  263.     (select-representations component)
  264.  
  265.     (when *check-consistency*
  266.       (maybe-mumble "Check2 ")
  267.       (check-ir2-consistency component))
  268.  
  269.     (delete-unreferenced-tns component)
  270.     
  271.     (maybe-mumble "Life ")
  272.     (lifetime-analyze component)
  273.  
  274.     (when *compile-progress*
  275.       (compiler-mumble "") ; Sync before doing random output.
  276.       (pre-pack-tn-stats component *compiler-error-output*))
  277.  
  278.     (when *check-consistency*
  279.       (maybe-mumble "CheckL ")
  280.       (check-life-consistency component))
  281.  
  282.     (maybe-mumble "Pack ")
  283.     (pack component)
  284.  
  285.     (when *check-consistency*
  286.       (maybe-mumble "CheckP ")
  287.       (check-pack-consistency component))
  288.  
  289.     (when *compiler-trace-output*
  290.       (describe-component component *compiler-trace-output*))
  291.     
  292.     (maybe-mumble "Code ")
  293.     (multiple-value-bind
  294.     (length trace-table)
  295.     (generate-code component)
  296.       
  297.       (when *compiler-trace-output*
  298.     (format *compiler-trace-output*
  299.         "~|~%Assembly code for ~S~2%"
  300.         component)
  301.     (dump-segment *code-segment* :stream *compiler-trace-output*))
  302.  
  303.       (when *count-vop-usages*
  304.     (count-vops component))
  305.  
  306.       (when *collect-dynamic-statistics*
  307.     (setup-dynamic-count-info component))
  308.  
  309.       (etypecase *compile-object*
  310.     (fasl-file
  311.      (maybe-mumble "FASL")
  312.      (fasl-dump-component component *code-segment*
  313.                   length trace-table *compile-object*))
  314.     (core-object
  315.      (maybe-mumble "Core")
  316.      (make-core-component component *code-segment*
  317.                   length trace-table *compile-object*))
  318.     (null))
  319.  
  320.       (nuke-segment *code-segment*)))
  321.  
  322.   (when *compile-print*
  323.     (compiler-mumble "~&"))
  324.   (undefined-value))
  325.  
  326.  
  327. ;;;; Clearing global data structures:
  328.  
  329. ;;; CLEAR-IR2-INFO  --  Internal
  330. ;;;
  331. ;;;    Clear all the INFO slots in sight in Component to allow the IR2 data
  332. ;;; structures to be reclaimed.  We also clear the INFO in constants in the
  333. ;;; *FREE-VARIABLES*, etc.  The latter is required for correct assignment of
  334. ;;; costant TNs, in addition to allowing stuff to be reclaimed.
  335. ;;;
  336. ;;;    We don't clear the FUNCTIONAL-INFO slots, since they are used to keep
  337. ;;; track of functions across component boundaries.
  338. ;;;
  339. (defun clear-ir2-info (component)
  340.   (declare (type component component))
  341.   (nuke-ir2-component component)
  342.   (setf (component-info component) nil)
  343.  
  344.   (maphash #'(lambda (k v)
  345.            (declare (ignore k))
  346.            (setf (leaf-info v) nil))
  347.        *constants*)
  348.  
  349.   (maphash #'(lambda (k v)
  350.            (declare (ignore k))
  351.            (when (constant-p v)
  352.          (setf (leaf-info v) nil)))
  353.        *free-variables*)
  354.  
  355.   (undefined-value))
  356.  
  357.  
  358. ;;; CLEAR-IR1-INFO  --  Internal
  359. ;;;
  360. ;;;    Blow away the REFS for all global variables, and recycle the IR1 for
  361. ;;; Component.
  362. ;;;
  363. (defun clear-ir1-info (component)
  364.   (declare (type component component))
  365.   (labels ((blast (x)
  366.          (maphash #'(lambda (k v)
  367.               (declare (ignore k))
  368.               (when (leaf-p v)
  369.                 (setf (leaf-refs v)
  370.                   (delete-if #'here-p (leaf-refs v)))
  371.                 (when (basic-var-p v)
  372.                   (setf (basic-var-sets v)
  373.                     (delete-if #'here-p (basic-var-sets v))))))
  374.               x))
  375.        (here-p (x)
  376.          (eq (block-component (node-block x)) component)))
  377.     (blast *free-variables*)
  378.     (blast *free-functions*)
  379.     (blast *constants*))
  380.   (macerate-ir1-component component)
  381.   (undefined-value))
  382.  
  383.  
  384. ;;; CLEAR-STUFF  --  Interface
  385. ;;;
  386. ;;;    Clear all the global variables used by the compiler.
  387. ;;;
  388. (defun clear-stuff (&optional (debug-too t))
  389.   ;;
  390.   ;; Clear global tables.
  391.   (when (boundp '*free-functions*)
  392.     (clrhash *free-functions*)
  393.     (clrhash *free-variables*)
  394.     (clrhash *constants*))
  395.   (clrhash *failed-optimizations*)
  396.   ;;
  397.   ;; Clear debug counters and tables.
  398.   (clrhash *seen-blocks*)
  399.   (clrhash *seen-functions*)
  400.   (clrhash *list-conflicts-table*)
  401.  
  402.   (when debug-too
  403.     (clrhash *continuation-numbers*)
  404.     (clrhash *number-continuations*)
  405.     (setq *continuation-number* 0)
  406.     (clrhash *tn-ids*)
  407.     (clrhash *id-tns*)
  408.     (setq *tn-id* 0)
  409.     (clrhash *label-ids*)
  410.     (clrhash *id-labels*)
  411.     (setq *label-id* 0)
  412.     ;;
  413.     ;; Clear some Pack data structures (for GC purposes only.)
  414.     (assert (not *in-pack*))
  415.     (dolist (sb (backend-sb-list *backend*))
  416.       (when (finite-sb-p sb)
  417.     (fill (finite-sb-live-tns sb) nil))))
  418.   ;;
  419.   ;; Reset Gensym.
  420.   (setq lisp:*gensym-counter* 0)
  421.  
  422.   (values))
  423.  
  424.  
  425. ;;; PRINT-SUMMARY  --  Interface
  426. ;;;
  427. ;;;    This function is called by WITH-COMPILATION-UNIT at the end of a
  428. ;;; compilation unit.  It prints out any residual unknown function warnings and
  429. ;;; the total error counts.  Abort-P should be true when the compilation unit
  430. ;;; was aborted by throwing out.  Abort-Count is the number of dynamically
  431. ;;; enclosed nested compilation units that were aborted.
  432. ;;;
  433. (defun print-summary (abort-p abort-count)
  434.   (unless abort-p
  435.     (let ((undefs (sort *undefined-warnings* #'string<
  436.             :key #'(lambda (x)
  437.                  (let ((x (undefined-warning-name x)))
  438.                    (if (symbolp x)
  439.                        (symbol-name x)
  440.                        (prin1-to-string x)))))))
  441.       (unless *converting-for-interpreter*
  442.     (dolist (undef undefs)
  443.       (let ((name (undefined-warning-name undef))
  444.         (kind (undefined-warning-kind undef))
  445.         (warnings (undefined-warning-warnings undef))
  446.         (count (undefined-warning-count undef)))
  447.         (dolist (*compiler-error-context* warnings)
  448.           (compiler-warning "Undefined ~(~A~): ~S" kind name))
  449.         
  450.         (let ((warn-count (length warnings)))
  451.           (when (and warnings (> count warn-count))
  452.         (let ((more (- count warn-count)))
  453.           (compiler-warning "~D more use~:P of undefined ~(~A~) ~S."
  454.                     more kind name)))))))
  455.   
  456.       (dolist (kind '(:variable :function :type))
  457.     (let ((summary (mapcar #'undefined-warning-name
  458.                    (remove kind undefs :test-not #'eq
  459.                        :key #'undefined-warning-kind))))
  460.       (when summary
  461.         (compiler-warning
  462.          "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
  463.           ~%  ~{~<~%  ~1:;~S~>~^ ~}"
  464.          (cdr summary) kind summary))))))
  465.   
  466.   (unless (or *converting-for-interpreter*
  467.           (and (not abort-p) (zerop abort-count)
  468.            (zerop *compiler-error-count*)
  469.            (zerop *compiler-warning-count*)
  470.            (zerop *compiler-note-count*)))
  471.     (compiler-mumble
  472.      "~2&Compilation unit ~:[finished~;aborted~].~
  473.       ~[~:;~:*~&  ~D fatal error~:P~]~
  474.       ~[~:;~:*~&  ~D error~:P~]~
  475.       ~[~:;~:*~&  ~D warning~:P~]~
  476.       ~[~:;~:*~&  ~D note~:P~]~2%"
  477.      abort-p
  478.      abort-count
  479.      *compiler-error-count*
  480.      *compiler-warning-count*
  481.      *compiler-note-count*)))
  482.  
  483.    
  484. ;;; Describe-Component  --  Internal
  485. ;;;
  486. ;;;    Print out some useful info about Component to Stream.
  487. ;;;
  488. (defun describe-component (component &optional
  489.                      (*standard-output* *standard-output*))
  490.   (declare (type component component))
  491.   (format t "~|~%;;;; Component: ~S~2%" (component-name component))
  492.   (print-blocks component)
  493.   
  494.   (format t "~%~|~%;;;; IR2 component: ~S~2%" (component-name component))
  495.   
  496.   (format t "Entries:~%")
  497.   (dolist (entry (ir2-component-entries (component-info component)))
  498.     (format t "~4TL~D: ~S~:[~; [Closure]~]~%"
  499.         (label-id (entry-info-offset entry))
  500.         (entry-info-name entry)
  501.         (entry-info-closure-p entry)))
  502.   
  503.   (terpri)
  504.   (pre-pack-tn-stats component *standard-output*)
  505.   (terpri)
  506.   (print-ir2-blocks component)
  507.   (terpri)
  508.   
  509.   (undefined-value))
  510.  
  511.  
  512. ;;;; File reading:
  513. ;;;
  514. ;;;    When reading from a file, we have to keep track of some source
  515. ;;; information.  We also exploit our ability to back up for printing the error
  516. ;;; context and for recovering from errors.
  517. ;;;
  518. ;;; The interface we provide to this stuff is the stream-oid Source-Info
  519. ;;; structure.  The bookkeeping is done as a side-effect of getting the next
  520. ;;; source form.
  521.  
  522.  
  523. ;;; The File-Info structure holds all the source information for a given file.
  524. ;;;
  525. (defstruct file-info
  526.   ;;
  527.   ;; If a file, the truename of the corresponding source file.  If from a Lisp
  528.   ;; form, :LISP, if from a stream, :STREAM.
  529.   (name (required-argument) :type (or simple-string (member :lisp :stream)))
  530.   ;;
  531.   ;; The defaulted, but not necessarily absolute file name (i.e. prior to
  532.   ;; TRUENAME call.)  Null if not a file.  This is only used to set
  533.   ;; *COMPILE-FILE-PATHNAME* 
  534.   (untruename nil :type (or simple-string null))
  535.   ;;
  536.   ;; The file's write date (if relevant.)
  537.   (write-date nil :type (or unsigned-byte null))
  538.   ;;
  539.   ;; This file's FILE-COMMENT, or NIL if none.
  540.   (comment nil :type (or simple-string null))
  541.   ;;
  542.   ;; The source path root number of the first form in this file (i.e. the
  543.   ;; total number of forms converted previously in this compilation.)
  544.   (source-root 0 :type unsigned-byte)
  545.   ;;
  546.   ;; Parallel vectors containing the forms read out of the file and the file
  547.   ;; positions that reading of each form started at (i.e. the end of the
  548.   ;; previous form.)
  549.   (forms (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))
  550.   (positions (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t)))
  551.  
  552.  
  553. ;;; The Source-Info structure provides a handle on all the source information
  554. ;;; for an entire compilation.
  555. ;;;
  556. (defstruct (source-info
  557.         (:print-function
  558.          (lambda (s stream d)
  559.            (declare (ignore s d))
  560.            (format stream "#<Source-Info>"))))
  561.   ;;
  562.   ;; The UT that compilation started at.
  563.   (start-time (get-universal-time) :type unsigned-byte)
  564.   ;;
  565.   ;; A list of the file-info structures for this compilation.
  566.   (files nil :type list)
  567.   ;;
  568.   ;; The tail of the Files for the file we are currently reading.
  569.   (current-file nil :type list)
  570.   ;;
  571.   ;; The stream that we are using to read the Current-File.  Null if no stream
  572.   ;; has been opened yet.
  573.   (stream nil :type (or stream null)))
  574.  
  575.  
  576. ;;; Make-File-Source-Info  --  Internal
  577. ;;;
  578. ;;;    Given a list of pathnames, return a Source-Info structure.
  579. ;;;
  580. (defun make-file-source-info (files)
  581.   (declare (list files))
  582.   (let ((file-info
  583.      (mapcar #'(lambda (x)
  584.              (make-file-info :name (namestring (truename x))
  585.                      :untruename (namestring x)
  586.                      :write-date (file-write-date x)))
  587.          files)))
  588.  
  589.     (make-source-info :files file-info
  590.               :current-file file-info)))
  591.  
  592.  
  593. ;;; MAKE-LISP-SOURCE-INFO  --  Interface
  594. ;;;
  595. ;;;    Return a SOURCE-INFO to describe the incremental compilation of Form.
  596. ;;; Also used by EVAL:INTERNAL-EVAL.
  597. ;;;
  598. (defun make-lisp-source-info (form)
  599.   (make-source-info
  600.    :start-time (get-universal-time)
  601.    :files (list (make-file-info :name :lisp
  602.                 :forms (vector form)
  603.                 :positions '#(0)))))
  604.  
  605.  
  606. ;;; MAKE-STREAM-SOURCE-INFO  --  Internal
  607. ;;;
  608. ;;;    Return a SOURCE-INFO which will read from Stream.
  609. ;;;
  610. (defun make-stream-source-info (stream)
  611.   (let ((files (list (make-file-info :name :stream))))
  612.     (make-source-info
  613.      :files files
  614.      :current-file files
  615.      :stream stream)))
  616.  
  617.  
  618. ;;; Normal-Read-Error  --  Internal
  619. ;;;
  620. ;;;    Print an error message for a non-EOF error on Stream.  Old-Pos is a
  621. ;;; preceding file position that hopefully comes before the beginning of the
  622. ;;; line.  Of course, this only works on streams that support the file-position
  623. ;;; operation.
  624. ;;;
  625. (defun normal-read-error (stream old-pos condition)
  626.   (declare (type stream stream) (type unsigned-byte old-pos))
  627.   (let ((pos (file-position stream)))
  628.     (file-position stream old-pos)
  629.     (let ((start old-pos))
  630.       (loop
  631.     (let ((line (read-line stream nil))
  632.           (end (file-position stream)))
  633.       (when (>= end pos)
  634.         (compiler-error-message
  635.          "Read error at ~D:~% \"~A/\\~A\"~%~A"
  636.          pos
  637.          (string-left-trim "     "
  638.                    (subseq line 0 (- pos start)))
  639.          (subseq line (- pos start))
  640.          condition)
  641.         (return))
  642.       (setq start end)))))
  643.   (undefined-value))
  644.  
  645.  
  646. ;;; Ignore-Error-Form  --  Internal
  647. ;;;
  648. ;;;    Back Stream up to the position Pos, then read a form with
  649. ;;; *Read-Suppress* on, discarding the result.  If an error happens during this
  650. ;;; read, then bail out using Compiler-Error (fatal in this context).
  651. ;;;
  652. (defun ignore-error-form (stream pos)
  653.   (declare (type stream stream) (type unsigned-byte pos))
  654.   (file-position stream pos)
  655.   (handler-case (let ((*read-suppress* t))
  656.           (read stream))
  657.     (error (condition)
  658.       (declare (ignore condition))
  659.       (compiler-error "Unable to recover from read error."))))
  660.  
  661.  
  662. ;;; Unexpected-EOF-Error  --  Internal
  663. ;;;
  664. ;;;    Print an error message giving some context for an EOF error.  We print
  665. ;;; the first line after Pos that contains #\" or #\(, or lacking that, the
  666. ;;; first non-empty line.
  667. ;;;
  668. (defun unexpected-eof-error (stream pos condition)
  669.   (declare (type stream stream) (type unsigned-byte pos))
  670.   (let ((res nil))
  671.     (file-position stream pos)
  672.     (loop
  673.       (let ((line (read-line stream nil nil))) 
  674.     (unless line (return))
  675.     (when (or (find #\" line) (find #\( line))
  676.       (setq res line)
  677.       (return))
  678.     (unless (or res (zerop (length line)))
  679.       (setq res line))))
  680.  
  681.     (compiler-error-message
  682.      "Read error in form starting at ~D:~%~@[ \"~A\"~%~]~A"
  683.      pos res condition))
  684.  
  685.   (file-position stream (file-length stream))
  686.   (undefined-value))
  687.  
  688.  
  689. ;;; Careful-Read  --  Internal
  690. ;;;
  691. ;;;    Read a form from Stream, returning EOF at EOF.  If a read error happens,
  692. ;;; then attempt to recover if possible, returing a proxy error form.
  693. ;;;
  694. (defun careful-read (stream eof pos)
  695.   (handler-case (read stream nil eof)
  696.     (error (condition)
  697.       (let ((new-pos (file-position stream)))
  698.     (cond ((= new-pos (file-length stream))
  699.            (unexpected-eof-error stream pos condition))
  700.           (t
  701.            (normal-read-error stream pos condition)
  702.            (ignore-error-form stream pos))))
  703.       '(cerror "Skip this form."
  704.            "Attempt to load a file having a compile-time read error."))))
  705.  
  706.  
  707. ;;; Get-Source-Stream  --  Internal
  708. ;;;
  709. ;;;    If Stream is present, return it, otherwise open a stream to the current
  710. ;;; file.  There must be a current file.  When we open a new file, we also
  711. ;;; reset *Package* and policy.  This gives the effect of rebinding
  712. ;;; around each file.
  713. ;;;
  714. (defun get-source-stream (info)
  715.   (declare (type source-info info))
  716.   (cond ((source-info-stream info))
  717.     (t
  718.      (setq *package* *initial-package*)
  719.      (setq *default-cookie* (copy-cookie *initial-cookie*))
  720.      (setq *default-interface-cookie*
  721.            (copy-cookie *initial-interface-cookie*))
  722.      (let* ((finfo (first (source-info-current-file info)))
  723.         (name (file-info-name finfo)))
  724.        (setq *compile-file-truename* (pathname name))
  725.        (setq *compile-file-pathname*
  726.          (pathname (file-info-untruename finfo)))
  727.        (setf (source-info-stream info) (open name :direction :input))))))
  728.  
  729. ;;; CLOSE-SOURCE-INFO  --  Internal
  730. ;;;
  731. ;;;    Close the stream in Info if it is open.
  732. ;;;
  733. (defun close-source-info (info)
  734.   (declare (type source-info info))
  735.   (let ((stream (source-info-stream info)))
  736.     (when stream (close stream)))
  737.   (setf (source-info-stream info) nil)
  738.   (undefined-value))
  739.  
  740.  
  741. ;;; Advance-Source-File  --  Internal
  742. ;;;
  743. ;;;    Advance Info to the next source file.  If none, return NIL, otherwise T.
  744. ;;;
  745. (defun advance-source-file (info)
  746.   (declare (type source-info info))
  747.   (close-source-info info)
  748.   (let ((prev (pop (source-info-current-file info))))
  749.     (if (source-info-current-file info)
  750.     (let ((current (first (source-info-current-file info))))
  751.       (setf (file-info-source-root current)
  752.         (+ (file-info-source-root prev)
  753.            (length (file-info-forms prev))))
  754.       t)
  755.     nil)))
  756.  
  757.  
  758. ;;; Read-Source-Form  --  Internal
  759. ;;;
  760. ;;;    Read the next form from the source designated by Info.  The second value
  761. ;;; is the top-level form number of the read form.  The third value is true
  762. ;;; when at EOF.
  763. ;;;
  764. ;;;   We carefully read from the current source file.  If it is at EOF, we
  765. ;;; advance to the next file and try again.  When we get a form, we enter it
  766. ;;; into the per-file Forms and Positions vectors.
  767. ;;;
  768. (defun read-source-form (info) 
  769.   (declare (type source-info info))
  770.   (let ((eof '(*eof*)))
  771.     (loop
  772.       (let* ((file (first (source-info-current-file info)))
  773.          (stream (get-source-stream info))
  774.          (pos (file-position stream))
  775.          (res (careful-read stream eof pos)))
  776.     (unless (eq res eof)
  777.       (let* ((forms (file-info-forms file))
  778.          (current-idx (+ (fill-pointer forms)
  779.                  (file-info-source-root file))))
  780.         (vector-push-extend res forms)
  781.         (vector-push-extend pos (file-info-positions file))
  782.         (return (values res current-idx nil))))
  783.  
  784.     (unless (advance-source-file info)
  785.       (return (values nil nil t)))))))
  786.  
  787.  
  788. ;;; FIND-FILE-INFO  --  Interface
  789. ;;;
  790. ;;;    Return the File-Info describing the Index'th form.
  791. ;;;
  792. (defun find-file-info (index info)
  793.   (declare (type index index) (type source-info info))
  794.   (dolist (file (source-info-files info))
  795.     (when (> (+ (length (file-info-forms file))
  796.         (file-info-source-root file))
  797.          index)
  798.       (return file))))
  799.  
  800.  
  801. ;;; FIND-SOURCE-ROOT  --  Interface
  802. ;;;
  803. ;;;    Return the Index'th source form read from Info and the position that it
  804. ;;; was read at.
  805. ;;;
  806. (defun find-source-root (index info)
  807.   (declare (type source-info info) (type index index))
  808.   (let* ((file (find-file-info index info))
  809.      (idx (- index (file-info-source-root file))))
  810.     (values (aref (file-info-forms file) idx)
  811.         (aref (file-info-positions file) idx))))
  812.  
  813. ;;;; Top-level form processing:
  814.  
  815. ;;; CONVERT-AND-MAYBE-COMPILE  --  Internal
  816. ;;;
  817. ;;;    Called by top-level form processing when we are ready to actually
  818. ;;; compile something.  If *BLOCK-COMPILE* is T, then we still convert the
  819. ;;; form, but delay compilation, pushing the result on *TOP-LEVEL-LAMBDAS*
  820. ;;; instead.
  821. ;;;
  822. ;;;   The cookies at this time becomes the default policy for compiling the
  823. ;;; form.  Any enclosed PROCLAIMs will affect only subsequent forms.
  824. ;;;
  825. (defun convert-and-maybe-compile (form path)
  826.   (declare (list path))
  827.   (let ((orig (bytes-consed-between-gcs)))
  828.     (unwind-protect
  829.     (progn
  830.       (setf (bytes-consed-between-gcs) (* orig 4))
  831.       (let* ((*lexical-environment*
  832.           (make-lexenv :cookie *default-cookie*
  833.                    :interface-cookie *default-interface-cookie*))
  834.          (tll (ir1-top-level form path nil)))
  835.         (cond ((eq *block-compile* t) (push tll *top-level-lambdas*))
  836.           (t
  837.            (compile-top-level (list tll) nil)))))
  838.       (system:scrub-control-stack)
  839.       (setf (bytes-consed-between-gcs) orig))))
  840.  
  841. ;;; PROCESS-PROGN  --  Internal
  842. ;;;
  843. ;;;    Process a PROGN-like portion of a top-level form.  Forms is a list of
  844. ;;; the forms, and Path is source path of the form they came out of.
  845. ;;;
  846. (defun process-progn (forms path)
  847.   (declare (list forms) (list path))
  848.   (dolist (form forms)
  849.     (process-form form path)))
  850.  
  851.  
  852. ;;; PREPROCESSOR-MACROEXPAND  --  Internal
  853. ;;;
  854. ;;;    Macroexpand form in the current environment with an error handler.  We
  855. ;;; only expand one level, so that we retain all the intervening forms in the
  856. ;;; source path.
  857. ;;;
  858. (defun preprocessor-macroexpand (form)
  859.   (handler-case (macroexpand-1 form *lexical-environment*)
  860.     (error (condition)
  861.        (compiler-error "(during macroexpansion)~%~A" condition))))
  862.  
  863.  
  864. ;;; PROCESS-LOCALLY  --  Internal
  865. ;;;
  866. ;;;    Process a top-level use of LOCALLY.  We parse declarations and then
  867. ;;; recursively process the body.
  868. ;;;
  869. ;;;    Binding *DEFAULT-xxx-COOKIE* is pretty much of a hack, since it causes
  870. ;;; LOCALLY to "capture" enclosed proclamations.  It is necessary because
  871. ;;; CONVERT-AND-MAYBE-COMPILE uses the value of *DEFAULT-COOKIE* as the policy.
  872. ;;; The need for this hack is due to the quirk that there is no way to
  873. ;;; represent in a cookie that an optimize quality came from the default.
  874. ;;;
  875. (defun process-locally (form path)
  876.   (declare (list path))
  877.   (multiple-value-bind
  878.       (body decls)
  879.       (system:parse-body (cdr form) *lexical-environment* nil)
  880.     (let* ((*lexical-environment*
  881.         (process-declarations decls nil nil (make-continuation)))
  882.        (*default-cookie* (lexenv-cookie *lexical-environment*))
  883.        (*default-interface-cookie*
  884.         (lexenv-interface-cookie *lexical-environment*)))
  885.       (process-progn body path))))
  886.  
  887.  
  888. ;;; PROCESS-FILE-COMMENT  --  Internal
  889. ;;;
  890. ;;;    Stash file comment in the file-info structure.
  891. ;;;
  892. (defun process-file-comment (form)
  893.   (unless (and (= (length form) 2) (stringp (second form)))
  894.     (compiler-error "Bad FILE-COMMENT form: ~S." form))
  895.   (let ((file (first (source-info-current-file *source-info*))))
  896.     (cond ((file-info-comment file)
  897.        (compiler-warning "Ignoring extra file comment:~%  ~S." form))
  898.       (t
  899.        (let ((comment (coerce (second form) 'simple-string)))
  900.          (setf (file-info-comment file) comment)
  901.          (when *compile-verbose*
  902.            (compiler-mumble "~&Comment: ~A~2&" comment)))))))
  903.  
  904.  
  905. ;;; PROCESS-COLD-LOAD-FORM  --  Internal
  906. ;;;
  907. ;;;    Force any pending top-level forms to be compiled and dumped so that they
  908. ;;; will be evaluated in the correct package environment.  Eval the form if
  909. ;;; Eval is true, then dump the form to evaled at (cold) load time.
  910. ;;;
  911. (defun process-cold-load-form (form path eval)
  912.   (let ((object *compile-object*))
  913.     (typecase object
  914.       (fasl-file
  915.        (compile-top-level-lambdas () t)))
  916.     (when eval (eval form))
  917.     (etypecase object
  918.       (fasl-file
  919.        (fasl-dump-cold-load-form form object))
  920.       ((or null core-object)
  921.        (convert-and-maybe-compile form path)))))
  922.  
  923.  
  924. ;;; PROCESS-PROCLAIM  --  Internal
  925. ;;;
  926. ;;;    If a special block compilation delimiter, then start or end the block as
  927. ;;; appropriate.  Otherwise, just convert-and-maybe-compile the form.  If
  928. ;;; *BLOCK-COMPILE* is NIL, then we ignore block declarations.
  929. ;;;
  930. (defun process-proclaim (form path)
  931.   (if (and (eql (length form) 2) (constantp (cadr form)))
  932.       (let ((spec (eval (cadr form))))
  933.     (if (consp spec)
  934.         (case (first spec)
  935.           (start-block
  936.            (when *block-compile*
  937.          (finish-block-compilation)
  938.          (setq *block-compile* t)
  939.          (setq *entry-points* (rest spec))))
  940.           (end-block
  941.            (finish-block-compilation))
  942.           (t
  943.            (convert-and-maybe-compile form path)))
  944.         (convert-and-maybe-compile form path)))
  945.       (convert-and-maybe-compile form path)))
  946.  
  947.  
  948. (proclaim '(special *compiler-error-bailout*))
  949.  
  950. ;;; PROCESS-FORM  --  Internal
  951. ;;;
  952. ;;;    Process a top-level Form with the specified source Path and output to
  953. ;;; Object.
  954. ;;; -- If this is a magic top-level form, then do stuff.
  955. ;;; -- If it is a macro expand it.
  956. ;;; -- Otherwise, just compile it.
  957. ;;;
  958. (defun process-form (form path)
  959.   (declare (list path))
  960.   (catch 'process-form-error-abort
  961.     (let* ((path (or (gethash form *source-paths*) (cons form path)))
  962.        (*compiler-error-bailout*
  963.         #'(lambda ()
  964.         (convert-and-maybe-compile
  965.          `(error "Execution of a form compiled with errors:~% ~S"
  966.              ',form)
  967.          path)
  968.         (throw 'process-form-error-abort nil))))
  969.       (if (atom form)
  970.       (convert-and-maybe-compile form path)
  971.       (case (car form)
  972.         ((make-package in-package shadow shadowing-import export
  973.                unexport use-package unuse-package import)
  974.          (process-cold-load-form form path t))
  975.         ((error cerror break signal)
  976.          (process-cold-load-form form path nil))
  977.         ((eval-when)
  978.          (unless (>= (length form) 2)
  979.            (compiler-error "EVAL-WHEN form is too short: ~S." form))
  980.          (do-eval-when-stuff
  981.           (cadr form) (cddr form)
  982.           #'(lambda (forms)
  983.           (process-progn forms path))))
  984.         ((macrolet)
  985.          (unless (>= (length form) 2)
  986.            (compiler-error "MACROLET form is too short: ~S." form))
  987.          (do-macrolet-stuff
  988.           (cadr form)
  989.           #'(lambda ()
  990.           (process-progn (cddr form) path))))
  991.         (locally (process-locally form path))
  992.         (progn (process-progn (cdr form) path))
  993.         (file-comment (process-file-comment form))
  994.         (proclaim (process-proclaim form path))
  995.         (t
  996.          (let ((exp (preprocessor-macroexpand form)))
  997.            (if (eq exp form)
  998.            (convert-and-maybe-compile form path)
  999.            (process-form exp path))))))))
  1000.       
  1001.   (undefined-value))
  1002.  
  1003.  
  1004. ;;;; Load time value support.
  1005.  
  1006. ;;; PRODUCING-FASL-FILE  --  interface.
  1007. ;;;
  1008. ;;; Returns T iff we are currently producing a fasl-file and hence constants
  1009. ;;; need to be dumped carfully.
  1010. ;;; 
  1011. (defun producing-fasl-file ()
  1012.   (unless *converting-for-interpreter*
  1013.     (fasl-file-p *compile-object*)))
  1014.  
  1015. ;;; COMPILE-LOAD-TIME-VALUE  --  interface.
  1016. ;;;
  1017. ;;; Compile FORM and arrange for it to be called at load-time.  Returns the
  1018. ;;; dumper handle and our best guess at the type of the object.
  1019. ;;; 
  1020. (defun compile-load-time-value
  1021.        (form &optional
  1022.          (name (let ((*print-level* 2) (*print-length* 3))
  1023.              (format nil "Load Time Value of ~S" form))))
  1024.   (let ((lambda (compile-load-time-stuff form name t)))
  1025.     (values
  1026.      (fasl-dump-load-time-value-lambda lambda *compile-object*)
  1027.      (let ((type (leaf-type lambda)))
  1028.        (if (function-type-p type)
  1029.        (single-value-type (function-type-returns type))
  1030.        *wild-type*)))))
  1031.  
  1032. ;;; COMPILE-MAKE-LOAD-FORM-INIT-FORMS  --  internal.
  1033. ;;;
  1034. ;;; Compile the FORMS and arrange for them to be called (for effect, not value)
  1035. ;;; at load-time.
  1036. ;;; 
  1037. (defun compile-make-load-form-init-forms (forms name)
  1038.   (let ((lambda (compile-load-time-stuff `(progn ,@forms) name nil)))
  1039.     (fasl-dump-top-level-lambda-call lambda *compile-object*)))
  1040.  
  1041. ;;; COMPILE-LOAD-TIME-STUFF  --  internal.
  1042. ;;;
  1043. ;;; Does the actual work of COMPILE-LOAD-TIME-VALUE or COMPILE-MAKE-LOAD-FORM-
  1044. ;;; INIT-FORMS.
  1045. ;;; 
  1046. (defun compile-load-time-stuff (form name for-value)
  1047.   (compile-top-level-lambdas () t)
  1048.   (with-ir1-namespace
  1049.    (let* ((*lexical-environment* (make-null-environment))
  1050.       (lambda (ir1-top-level form *current-path* for-value)))
  1051.      (setf (leaf-name lambda) name)
  1052.      (compile-top-level (list lambda) t)
  1053.      lambda)))
  1054.  
  1055. ;;; COMPILE-LOAD-TIME-VALUE-LAMBDA  --  internal.
  1056. ;;;
  1057. ;;; Called by COMPILE-TOP-LEVEL when it was pased T for LOAD-TIME-VALUE-P
  1058. ;;; (which happens in COMPILE-LOAD-TIME-STUFF).  We don't try to combine
  1059. ;;; this component with anything else and frob the name.
  1060. ;;; 
  1061. (defun compile-load-time-value-lambda (lambdas)
  1062.   (assert (null (cdr lambdas)))
  1063.   (let* ((lambda (car lambdas))
  1064.      (component (block-component (node-block (lambda-bind lambda)))))
  1065.     (setf (component-name component) (leaf-name lambda))
  1066.     (compile-component component)
  1067.     (clear-ir2-info component)
  1068.     (clear-ir1-info component)))
  1069.  
  1070.  
  1071. ;;; EMIT-MAKE-LOAD-FORM  --  interface.
  1072. ;;;
  1073. ;;; The entry point for MAKE-LOAD-FORM support.  When IR1 conversion finds a
  1074. ;;; constant structure, it invokes this to arrange for proper dumping.  If it
  1075. ;;; turns out that the constant has already been dumped, then we don't need
  1076. ;;; to do anything.
  1077. ;;;
  1078. ;;; If the constant hasn't been dumped, then we check to see if we are in the
  1079. ;;; process of creating it.  We detect this by maintaining the special
  1080. ;;; *constants-being-created* as a list of all the constants we are in the
  1081. ;;; process of creating.  Actually, each entry is a list of the constant and
  1082. ;;; any init forms that need to be processed on behalf of that constant.
  1083. ;;;
  1084. ;;; It's not necessarily an error for this to happen.  If we are processing the
  1085. ;;; init form for some object that showed up *after* the original reference
  1086. ;;; to this constant, then we just need to defer the processing of that init
  1087. ;;; form.  To detect this, we maintain *constants-created-sense-last-init* as
  1088. ;;; a list of the constants created sense the last time we started processing
  1089. ;;; an init form.  If the constant passed to emit-make-load-form shows up in
  1090. ;;; this list, then there is a circular chain through creation forms, which is
  1091. ;;; an error.
  1092. ;;;
  1093. ;;; If there is some intervening init form, then we blow out of processing it
  1094. ;;; by throwing to the tag PENDING-INIT.  The value we throw is the entry from
  1095. ;;; *constants-being-created*.  This is so the offending init form can be
  1096. ;;; tacked onto the init forms for the circular object.
  1097. ;;;
  1098. ;;; If the constant doesn't show up in *constants-being-created*, then we have
  1099. ;;; to create it.  We call MAKE-LOAD-FORM and check to see if the creation
  1100. ;;; form is the magic value :just-dump-it-normally.  If it is, then we don't
  1101. ;;; do anything.  The dumper will eventually get it's hands on the object
  1102. ;;; and use the normal structure dumping noise on it.
  1103. ;;;
  1104. ;;; Otherwise, we bind *constants-being-created* and *constants-created-sense-
  1105. ;;; last-init* and compile the creation form a la load-time-value.  When this
  1106. ;;; finishes, we tell the dumper to use that result instead whenever it sees
  1107. ;;; this constant.
  1108. ;;;
  1109. ;;; Now we try to compile the init form.  We bind *constants-created-sense-
  1110. ;;; last-init* to NIL and compile the init form (and any init forms that were
  1111. ;;; added because of circularity detection).  If this works, great.  If not,
  1112. ;;; we add the init forms to the init forms for the object that caused the
  1113. ;;; problems and let it deal with it.
  1114. ;;; 
  1115. (defvar *constants-being-created* nil)
  1116. (defvar *constants-created-sense-last-init* nil)
  1117. ;;;
  1118. (defun emit-make-load-form (constant)
  1119.   (assert (fasl-file-p *compile-object*))
  1120.   (unless (fasl-constant-already-dumped constant *compile-object*)
  1121.     (let ((circular-ref (assoc constant *constants-being-created* :test #'eq)))
  1122.       (when circular-ref
  1123.     (when (find constant *constants-created-sense-last-init* :test #'eq)
  1124.       (throw constant t))
  1125.     (throw 'pending-init circular-ref)))
  1126.     (multiple-value-bind
  1127.     (creation-form init-form)
  1128.     (handler-case
  1129.         (if (fboundp 'lisp::make-load-form)
  1130.         (locally
  1131.          (declare (optimize (inhibit-warnings 3)))
  1132.          (lisp::make-load-form constant (make-null-environment)))
  1133.         (make-structure-load-form constant))
  1134.       (error (condition)
  1135.          (compiler-error "(while making load form for ~S)~%~A"
  1136.                  constant condition)))
  1137.       (case creation-form
  1138.     (:just-dump-it-normally
  1139.      (fasl-validate-structure constant *compile-object*)
  1140.      t)
  1141.     (:ignore-it
  1142.      nil)
  1143.     (t
  1144.      (let* ((name (let ((*print-level* 1) (*print-length* 2))
  1145.             (with-output-to-string (stream)
  1146.               (write constant :stream stream))))
  1147.         (info (if init-form
  1148.               (list constant name init-form)
  1149.               (list constant))))
  1150.        (let ((*constants-being-created*
  1151.           (cons info *constants-being-created*))
  1152.          (*constants-created-sense-last-init*
  1153.           (cons constant *constants-created-sense-last-init*)))
  1154.          (when
  1155.          (catch constant
  1156.            (fasl-note-handle-for-constant
  1157.             constant
  1158.             (compile-load-time-value
  1159.              creation-form
  1160.              (format nil "Creation Form for ~A" name))
  1161.             *compile-object*)
  1162.            nil)
  1163.            (compiler-error "Circular references in creation form for ~S"
  1164.                    constant)))
  1165.        (when (cdr info)
  1166.          (let* ((*constants-created-sense-last-init* nil)
  1167.             (circular-ref
  1168.              (catch 'pending-init
  1169.                (loop for (name form) on (cdr info) by #'cddr
  1170.              collect name into names
  1171.              collect form into forms
  1172.              finally do
  1173.              (compile-make-load-form-init-forms
  1174.               forms
  1175.               (format nil "Init Form~:[~;s~] for ~{~A~^, ~}"
  1176.                   (cdr forms) names)))
  1177.                nil)))
  1178.            (when circular-ref
  1179.          (setf (cdr circular-ref)
  1180.                (append (cdr circular-ref) (cdr info))))))))))))
  1181.  
  1182.  
  1183.  
  1184. ;;;; COMPILE-FILE and COMPILE-FROM-STREAM: 
  1185.  
  1186. ;;; We build a list of top-level lambdas, and then periodically smash them
  1187. ;;; together into a single component and compile it.
  1188. ;;;
  1189. (defvar *pending-top-level-lambdas*)
  1190.  
  1191. ;;; The maximum number of top-level lambdas we put in a single top-level
  1192. ;;; component.
  1193. ;;;
  1194. (defparameter top-level-lambda-max 10)
  1195.  
  1196.  
  1197. ;;; OBJECT-CALL-TOP-LEVEL-LAMBDA  --  Internal
  1198. ;;;
  1199. (defun object-call-top-level-lambda (tll)
  1200.   (declare (type functional tll))
  1201.   (let ((object *compile-object*))
  1202.     (etypecase object
  1203.       (fasl-file
  1204.        (fasl-dump-top-level-lambda-call tll object))
  1205.       (core-object
  1206.        (core-call-top-level-lambda tll object))
  1207.       (null))))
  1208.  
  1209.  
  1210. ;;; SUB-COMPILE-TOP-LEVEL-LAMBDAS  --  Internal
  1211. ;;;
  1212. ;;;    Add Lambdas to the pending lambdas.  If this leaves more than
  1213. ;;; TOP-LEVEL-LAMBDA-MAX lambdas in the list, or if Force-P is true, then smash
  1214. ;;; the lambdas into a single component, compile it, and call the resulting
  1215. ;;; function.
  1216. ;;;
  1217. (defun sub-compile-top-level-lambdas (lambdas force-p)
  1218.   (declare (list lambdas))
  1219.   (setq *pending-top-level-lambdas*
  1220.     (append *pending-top-level-lambdas* lambdas))
  1221.   (let ((pending *pending-top-level-lambdas*))
  1222.     (when (and pending
  1223.            (or (> (length pending) top-level-lambda-max)
  1224.            force-p))
  1225.       (multiple-value-bind (component tll)
  1226.                (merge-top-level-lambdas pending)
  1227.     (setq *pending-top-level-lambdas* ())
  1228.     (compile-component component)
  1229.     (clear-ir2-info component)
  1230.     (clear-ir1-info component)
  1231.     (object-call-top-level-lambda tll))))
  1232.   (undefined-value))
  1233.  
  1234.  
  1235. ;;; COMPILE-TOP-LEVEL-LAMBDAS  --  Internal
  1236. ;;;
  1237. ;;;    Compile top-level code and call the Top-Level lambdas.  We pick off
  1238. ;;; top-level lambdas in non-top-level components here, calling SUB-c-t-l-l on
  1239. ;;; each subsequence of normal top-level lambdas.
  1240. ;;;
  1241. (defun compile-top-level-lambdas (lambdas force-p)
  1242.   (declare (list lambdas))
  1243.   (let ((len (length lambdas)))
  1244.     (flet ((loser (start)
  1245.          (or (position-if #'(lambda (x)
  1246.                   (not (eq (component-kind
  1247.                         (block-component
  1248.                          (node-block
  1249.                           (lambda-bind x))))
  1250.                        :top-level)))
  1251.                   lambdas
  1252.                   :start start)
  1253.          len)))
  1254.       (do* ((start 0 (1+ loser))
  1255.         (loser (loser start) (loser start)))
  1256.        ((>= start len)
  1257.         (when force-p
  1258.           (sub-compile-top-level-lambdas nil t)))
  1259.     (sub-compile-top-level-lambdas (subseq lambdas start loser)
  1260.                        (or force-p (/= loser len)))
  1261.     (unless (= loser len)
  1262.       (object-call-top-level-lambda (elt lambdas loser))))))
  1263.   (undefined-value))
  1264.  
  1265.  
  1266. ;;; Compile-Top-Level  --  Internal
  1267. ;;;
  1268. ;;;    Compile Lambdas (a list of the lambdas for top-level forms) into the
  1269. ;;; Object file.  We loop doing local call analysis until it converges, since a
  1270. ;;; single pass might miss something due to components being joined by let
  1271. ;;; conversion.
  1272. ;;;
  1273. (defun compile-top-level (lambdas load-time-value-p)
  1274.   (declare (list lambdas))
  1275.   (maybe-mumble "Locall ")
  1276.   (loop
  1277.     (let ((did-something nil))
  1278.       (dolist (lambda lambdas)
  1279.     (let* ((component (block-component (node-block (lambda-bind lambda))))
  1280.            (*all-components* (list component)))
  1281.       (when (component-new-functions component)
  1282.         (setq did-something t)
  1283.         (local-call-analyze component))))
  1284.       (unless did-something (return))))
  1285.   
  1286.   (maybe-mumble "IDFO ")
  1287.   (multiple-value-bind (components top-components hairy-top)
  1288.                (find-initial-dfo lambdas)
  1289.     (let ((*all-components* (append components top-components))
  1290.       (top-level-closure nil))
  1291.       (when *check-consistency*
  1292.     (maybe-mumble "[Check]~%")
  1293.     (check-ir1-consistency *all-components*))
  1294.       
  1295.       (dolist (component (append hairy-top top-components))
  1296.     (pre-environment-analyze-top-level component))
  1297.       
  1298.       (dolist (component components)
  1299.     (compile-component component)
  1300.     (clear-ir2-info component)
  1301.     (when (replace-top-level-xeps component)
  1302.         (setq top-level-closure t)))
  1303.       
  1304.       (when *check-consistency*
  1305.     (maybe-mumble "[Check]~%")
  1306.     (check-ir1-consistency *all-components*))
  1307.       
  1308.       (if load-time-value-p
  1309.       (compile-load-time-value-lambda lambdas)
  1310.       (compile-top-level-lambdas lambdas top-level-closure))
  1311.  
  1312.       (dolist (component components)
  1313.     (clear-ir1-info component))
  1314.       (clear-stuff)))
  1315.   (undefined-value))
  1316.  
  1317.  
  1318. ;;; FINISH-BLOCK-COMPILATION  --  Internal
  1319. ;;;
  1320. ;;;    Actually compile any stuff that has been queued up for block
  1321. ;;; compilation.
  1322. ;;;
  1323. (defun finish-block-compilation ()
  1324.   (when *block-compile*
  1325.     (when *top-level-lambdas*
  1326.       (compile-top-level (nreverse *top-level-lambdas*) nil)
  1327.       (setq *top-level-lambdas* ()))
  1328.     (setq *block-compile* :specified)
  1329.     (setq *entry-points* nil)))
  1330.  
  1331.  
  1332. ;;; Sub-Compile-File  --  Internal
  1333. ;;;
  1334. ;;;    Read all forms from Info and compile them, with output to Object.  We
  1335. ;;; return :ERROR, :WARNING, :NOTE or NIL to indicate the most severe kind of
  1336. ;;; compiler diagnostic emitted.
  1337. ;;;
  1338. (defun sub-compile-file (info &optional d-s-info)
  1339.   (declare (type source-info info))
  1340.   (with-ir1-namespace
  1341.     (let* ((start-errors *compiler-error-count*)
  1342.        (start-warnings *compiler-warning-count*)
  1343.        (start-notes *compiler-note-count*)
  1344.        (*package* *package*)
  1345.        (*initial-package* *package*)
  1346.        (*initial-cookie* *default-cookie*)
  1347.        (*initial-interface-cookie* *default-interface-cookie*)
  1348.        (*default-cookie* (copy-cookie *initial-cookie*))
  1349.        (*default-interface-cookie*
  1350.         (copy-cookie *initial-interface-cookie*))
  1351.        (*lexical-environment* (make-null-environment))
  1352.        (*converting-for-interpreter* nil)
  1353.        (*source-info* info)
  1354.        (*compile-file-pathname* nil)
  1355.        (*compile-file-truename* nil)
  1356.        (*top-level-lambdas* ())
  1357.        (*pending-top-level-lambdas* ())
  1358.        (*compiler-error-bailout*
  1359.         #'(lambda ()
  1360.         (compiler-mumble
  1361.          "~2&Fatal error, aborting compilation...~%")
  1362.         (return-from sub-compile-file :error)))
  1363.        (*current-path* nil)
  1364.        (*last-source-context* nil)
  1365.        (*last-original-source* nil)
  1366.        (*last-source-form* nil)
  1367.        (*last-format-string* nil)
  1368.        (*last-format-args* nil)
  1369.        (*last-message-count* 0)
  1370.        (*info-environment*
  1371.         (or (backend-info-environment *backend*)
  1372.         *info-environment*))
  1373.        (*features*
  1374.         (or (backend-features *backend*)
  1375.         *features*))
  1376.        (*gensym-counter* 0))
  1377.       (clear-stuff)
  1378.       (with-compilation-unit ()
  1379.     (loop
  1380.       (multiple-value-bind (form tlf eof-p)
  1381.                    (read-source-form info)
  1382.         (when eof-p (return))
  1383.         (clrhash *source-paths*)
  1384.         (find-source-paths form tlf)
  1385.         (process-form form `(original-source-start 0 ,tlf))))
  1386.  
  1387.     (finish-block-compilation)
  1388.     (compile-top-level-lambdas () t)
  1389.     (let ((object *compile-object*))
  1390.       (etypecase object
  1391.         (fasl-file (fasl-dump-source-info info object))
  1392.         (core-object (fix-core-source-info info object d-s-info))
  1393.         (null)))
  1394.     
  1395.     (cond ((> *compiler-error-count* start-errors) :error)
  1396.           ((> *compiler-warning-count* start-warnings) :warning)
  1397.           ((> *compiler-note-count* start-notes) :note)
  1398.           (t nil))))))
  1399.  
  1400.  
  1401. ;;; Verify-Source-Files  --  Internal
  1402. ;;;
  1403. ;;;    Return a list of pathnames for the named files.  All the files must
  1404. ;;; exist.
  1405. ;;;
  1406. (defun verify-source-files (stuff)
  1407.   (unless stuff
  1408.     (error "Can't compile with no source files."))
  1409.   (mapcar #'(lambda (x)
  1410.           (let ((x (pathname x)))
  1411.         (if (probe-file x)
  1412.             x
  1413.             (let ((x (merge-pathnames x (make-pathname :type "lisp"))))
  1414.               (if (probe-file x)
  1415.               x
  1416.               (truename x))))))
  1417.       (if (listp stuff) stuff (list stuff))))
  1418.  
  1419.  
  1420. ;;; COMPILE-FROM-STREAM  --  Public
  1421. ;;;
  1422. ;;;    Just call SUB-COMPILE-FILE on the on a stream source info for the
  1423. ;;; stream, sending output to core.
  1424. ;;;
  1425. (defun compile-from-stream
  1426.        (stream &key
  1427.            ((:error-stream *compiler-error-output*) *error-output*)
  1428.            ((:trace-stream *compiler-trace-output*) nil)
  1429.            ((:verbose *compile-verbose*) *compile-verbose*)
  1430.            ((:print *compile-print*) *compile-print*)
  1431.            ((:progress *compile-progress*) *compile-progress*)
  1432.            ((:block-compile *block-compile*) *block-compile-default*)
  1433.            ((:entry-points *entry-points*) nil)
  1434.            source-info)
  1435.   "Similar to COMPILE-FILE, but compiles text from Stream into the current lisp
  1436.   environment.  Stream is closed when compilation is complete.  These keywords
  1437.   are supported:
  1438.  
  1439.   :Error-Stream
  1440.       The stream to write compiler error output to (default *ERROR-OUTPUT*.)
  1441.   :Trace-Stream
  1442.       The stream that we write compiler trace output to, or NIL (the default)
  1443.       to inhibit trace output.
  1444.   :Block-Compile
  1445.         If true, then function names will be resolved at compile time.
  1446.   :Source-Info
  1447.         Some object to be placed in the DEBUG-SOURCE-INFO."
  1448.   (let ((info (make-stream-source-info stream))
  1449.     (*backend* *native-backend*))
  1450.     (unwind-protect
  1451.     (let* ((*compile-object* (make-core-object))
  1452.            (won (sub-compile-file info source-info)))
  1453.       (values (not (null won))
  1454.           (if (member won '(:error :warning)) t nil)))
  1455.       (close-source-info info))))
  1456.  
  1457.  
  1458. (defun elapsed-time-to-string (tsec)
  1459.   (multiple-value-bind (tmin sec)
  1460.                (truncate tsec 60)
  1461.     (multiple-value-bind (thr min)
  1462.              (truncate tmin 60)
  1463.       (format nil "~D:~2,'0D:~2,'0D" thr min sec))))
  1464.  
  1465.  
  1466. ;;; START-ERROR-OUTPUT, FINISH-ERROR-OUTPUT  --  Internal
  1467. ;;;
  1468. ;;;    Print some junk at the beginning and end of compilation.
  1469. ;;;
  1470. (defun start-error-output (source-info)
  1471.   (declare (type source-info source-info))
  1472.   (compiler-mumble "~2&Python version ~A, VM version ~A on ~A.~%"
  1473.            compiler-version (backend-version *backend*)
  1474.            (ext:format-universal-time nil (get-universal-time)
  1475.                           :style :government
  1476.                           :print-weekday nil
  1477.                           :print-timezone nil))
  1478.   (dolist (x (source-info-files source-info))
  1479.     (compiler-mumble "Compiling: ~A ~A~%"
  1480.              (file-info-name x)
  1481.              (ext:format-universal-time nil (file-info-write-date x)
  1482.                         :style :government
  1483.                         :print-weekday nil
  1484.                         :print-timezone nil)))
  1485.   (compiler-mumble "~%")
  1486.   (undefined-value))
  1487. ;;;
  1488. (defun finish-error-output (source-info won)
  1489.   (declare (type source-info source-info))
  1490.   (compiler-mumble "~&Compilation ~:[aborted after~;finished in~] ~A.~&"
  1491.            won
  1492.            (elapsed-time-to-string
  1493.             (- (get-universal-time)
  1494.                (source-info-start-time source-info))))
  1495.   (undefined-value))
  1496.  
  1497.  
  1498. ;;; COMPILE-FILE  --  Public.
  1499. ;;;
  1500. ;;; Open some files and call SUB-COMPILE-FILE.  If something unwinds out of the
  1501. ;;; compile, then abort the writing of the output file, so we don't overwrite
  1502. ;;; it with known garbage.
  1503. ;;;
  1504. (defun compile-file (source &key
  1505.                 (output-file t)
  1506.                 (error-file nil)
  1507.                 (trace-file nil) 
  1508.                 (error-output t)
  1509.                 (load nil)
  1510.                 ((:verbose *compile-verbose*) *compile-verbose*)
  1511.                 ((:print *compile-print*) *compile-print*)
  1512.                 ((:progress *compile-progress*) *compile-progress*)
  1513.                 ((:block-compile *block-compile*)
  1514.                  *block-compile-default*)
  1515.                 ((:entry-points *entry-points*) nil))
  1516.   "Compiles Source, producing a corresponding .FASL file.  Source may be a list
  1517.    of files, in which case the files are compiled as a unit, producing a single
  1518.    .FASL file.  The output file names are defaulted from the first (or only)
  1519.    input file name.  Other options available via keywords:
  1520.    :Output-File
  1521.       The name of the fasl to output, NIL for none, T for the default.
  1522.    :Error-File
  1523.       The name of the error listing file, NIL for none (the default), T for
  1524.       .err.
  1525.    :Trace-File
  1526.       If specified, internal data structures are dumped to this file.  T for
  1527.       the .trace default.
  1528.    :Error-Output
  1529.       If a stream, then error output is sent there as well as to the listing
  1530.       file.  NIL suppresses this additional error output.  The default is T,
  1531.       which means use *ERROR-OUTPUT*.
  1532.    :Block-Compile {NIL | :SPECIFIED | T}
  1533.       Determines whether multiple functions are compiled together as a unit,
  1534.       resolving function references at compile time.  NIL means that global
  1535.       function names are never resolved at compilation time.  :SPECIFIED means
  1536.       that names are resolved at compile-time when convenient (as in a
  1537.       self-recursive call), but the compiler doesn't combine top-level DEFUNs.
  1538.       With :SPECIFIED, an explicit START-BLOCK declaration will enable block
  1539.       compilation.  A value of T indicates that all forms in the file(s) should
  1540.       be compiled as a unit.  The default is the value of
  1541.       *BLOCK-COMPILE-DEFAULT*, which is initially :SPECIFIED.
  1542.    :Entry-Points
  1543.       This specifies a list of function names for functions in the file(s) that
  1544.       must be given global definitions.  This only applies to block
  1545.       compilation, and is useful mainly when :BLOCK-COMPILE T is specified on a
  1546.       file that lacks START-BLOCK declarations.  If the value is NIL (the
  1547.       default) then all functions will be globally defined."
  1548.   (let* ((fasl-file nil)
  1549.      (error-file-stream nil)
  1550.      (output-file-name nil)
  1551.      (*compiler-error-output* *compiler-error-output*)
  1552.      (*compiler-trace-output* nil)
  1553.      (compile-won nil)
  1554.      (error-severity nil)
  1555.      (source (verify-source-files source))
  1556.      (source-info (make-file-source-info source))
  1557.      (default (pathname (first source))))
  1558.     (unwind-protect
  1559.     (progn
  1560.       (flet ((frob (file type)
  1561.            (if (eq file t)
  1562.                (make-pathname :type type  :defaults default)
  1563.                (pathname file))))
  1564.         
  1565.         (when output-file
  1566.           (setq output-file-name
  1567.             (frob output-file
  1568.               (backend-fasl-file-type *backend*)))
  1569.           (setq fasl-file (open-fasl-file output-file-name
  1570.                           (namestring (first source)))))
  1571.         
  1572.         (when trace-file
  1573.           (setq *compiler-trace-output*
  1574.             (open (frob trace-file "trace")
  1575.               :if-exists :supersede
  1576.               :direction :output)))
  1577.         
  1578.         (when error-file
  1579.           (setq error-file-stream
  1580.             (open (frob error-file "err")
  1581.               :if-exists :supersede
  1582.               :direction :output))))
  1583.       
  1584.       (setq *compiler-error-output*
  1585.         (apply #'make-broadcast-stream
  1586.                (remove nil
  1587.                    (list (if (eq error-output t)
  1588.                      *error-output*
  1589.                      error-output)
  1590.                      error-file-stream))))
  1591.  
  1592.       (when *compile-verbose*
  1593.         (start-error-output source-info))
  1594.       (setq error-severity
  1595.         (let ((*compile-object* fasl-file))
  1596.           (sub-compile-file source-info)))
  1597.       (setq compile-won t))
  1598.  
  1599.       (close-source-info source-info)
  1600.  
  1601.       (when fasl-file
  1602.     (close-fasl-file fasl-file (not compile-won))
  1603.     (setq output-file-name (pathname (fasl-file-stream fasl-file)))
  1604.     (when (and compile-won *compile-verbose*)
  1605.       (compiler-mumble "~2&~A written.~%" (namestring output-file-name))))
  1606.  
  1607.       (when *compile-verbose*
  1608.     (finish-error-output source-info compile-won))
  1609.  
  1610.       (when error-file-stream
  1611.     (let ((name (pathname error-file-stream)))
  1612.       ;;
  1613.       ;; Leave this var pointing to something reasonable in case someone
  1614.       ;; tries to use it before the LET ends, e.g. during the LOAD.
  1615.       (setq *compiler-error-output* *error-output*)
  1616.       (close error-file-stream)
  1617.       (when (and compile-won (not error-severity))
  1618.         (delete-file name))))
  1619.  
  1620.       (when *compiler-trace-output*
  1621.     (close *compiler-trace-output*)))
  1622.  
  1623.     (when load
  1624.       (unless output-file
  1625.     (error "Can't :LOAD with no output file."))
  1626.       (load output-file-name :verbose *compile-verbose*))
  1627.  
  1628.     (values (if output-file
  1629.         ;; Hack around filesystem race condition...
  1630.         (or (probe-file output-file-name) output-file-name)
  1631.         nil)
  1632.         (not (null error-severity))
  1633.         (if (member error-severity '(:warning :error)) t nil))))
  1634.  
  1635.  
  1636. ;;;; COMPILE and UNCOMPILE:
  1637.  
  1638. ;;; GET-LAMBDA-TO-COMPILE  --  Internal
  1639. ;;;
  1640. (defun get-lambda-to-compile (definition)
  1641.   (if (consp definition)
  1642.       definition
  1643.       (multiple-value-bind (def env-p)
  1644.                (function-lambda-expression definition)
  1645.     (when env-p
  1646.       (error "~S was defined in a non-null environment." definition))
  1647.     (unless def
  1648.       (error "Can't find a definition for ~S." definition))
  1649.     def)))
  1650.  
  1651.  
  1652. ;;; COMPILE-FIX-FUNCTION-NAME  --  Internal
  1653. ;;;
  1654. ;;;    Find the function that is being compiled by COMPILE and bash its name to
  1655. ;;; NAME.  We also substitute for any references to name so that recursive
  1656. ;;; calls will be compiled direct.  Lambda is the top-level lambda for the
  1657. ;;; compilation.  A REF for the real function is the only thing in the
  1658. ;;; top-level lambda other than the bind and return, so it isn't too hard to
  1659. ;;; find.
  1660. ;;;
  1661. (defun compile-fix-function-name (lambda name)
  1662.   (declare (type clambda lambda) (type (or symbol cons) name))
  1663.   (when name
  1664.     (let ((fun (ref-leaf
  1665.         (continuation-next
  1666.          (node-cont (lambda-bind lambda))))))
  1667.       (setf (leaf-name fun) name)
  1668.       (let ((old (gethash name *free-functions*)))
  1669.     (when old
  1670.       (substitute-leaf-if #'(lambda (x)
  1671.                   (not (eq (ref-inlinep x) :notinline)))
  1672.                   fun old)))
  1673.       name)))
  1674.  
  1675.  
  1676. ;;; COMPILE  --  Public
  1677. ;;;
  1678. (defun compile (name &optional (definition (fdefinition name)))
  1679.   "Compiles the function whose name is Name.  If Definition is supplied,
  1680.   it should be a lambda expression that is compiled and then placed in the
  1681.   function cell of Name.  If Name is Nil, the compiled code object is
  1682.   returned."
  1683.   (with-compilation-unit ()
  1684.     (with-ir1-namespace
  1685.       (let* ((*backend* *native-backend*)
  1686.          (*info-environment*
  1687.           (or (backend-info-environment *backend*)
  1688.           *info-environment*))
  1689.          (*features*
  1690.           (or (backend-features *backend*)
  1691.           *features*))
  1692.          (start-errors *compiler-error-count*)
  1693.          (start-warnings *compiler-warning-count*)
  1694.          (start-notes *compiler-note-count*)
  1695.          (*lexical-environment* (make-null-environment))
  1696.          (form `#',(get-lambda-to-compile definition))
  1697.          (*source-info* (make-lisp-source-info form))
  1698.          (*top-level-lambdas* ())
  1699.          (*converting-for-interpreter* nil)
  1700.          (*block-compile* nil)
  1701.          (*compiler-error-bailout*
  1702.           #'(lambda ()
  1703.           (compiler-mumble
  1704.            "~2&Fatal error, aborting compilation...~%")
  1705.           (return-from compile (values nil t nil))))
  1706.          (*compiler-error-output* *error-output*)
  1707.          (*compiler-trace-output* nil)
  1708.          (*current-path* nil)
  1709.          (*last-source-context* nil)
  1710.          (*last-original-source* nil)
  1711.          (*last-source-form* nil)
  1712.          (*last-format-string* nil)
  1713.          (*last-format-args* nil)
  1714.          (*last-message-count* 0)
  1715.          (*compile-object* (make-core-object))
  1716.          (*gensym-counter* 0))
  1717.     (clear-stuff)
  1718.     (find-source-paths form 0)
  1719.     (let ((lambda (ir1-top-level form '(original-source-start 0 0) t)))
  1720.       
  1721.       (compile-fix-function-name lambda name)
  1722.       (let* ((component
  1723.           (block-component (node-block (lambda-bind lambda))))
  1724.          (*all-components* (list component)))
  1725.         (local-call-analyze component))
  1726.       
  1727.       (multiple-value-bind (components top-components)
  1728.                    (find-initial-dfo (list lambda))
  1729.         (let ((*all-components* (append components top-components)))
  1730.           (dolist (component *all-components*)
  1731.         (compile-component component)
  1732.         (clear-ir2-info component))))
  1733.       
  1734.       (let* ((res (core-call-top-level-lambda lambda *compile-object*))
  1735.          (return (or name res)))
  1736.         (fix-core-source-info *source-info* *compile-object* res)
  1737.         (when name
  1738.           (setf (fdefinition name) res))
  1739.         
  1740.         (cond ((or (> *compiler-error-count* start-errors)
  1741.                (> *compiler-warning-count* start-warnings))
  1742.            (values return t t))
  1743.           ((> *compiler-note-count* start-notes)
  1744.            (values return t nil))
  1745.           (t
  1746.            (values return nil nil)))))))))
  1747.  
  1748. ;;; UNCOMPILE  --  Public
  1749. ;;;
  1750. (defun uncompile (name)
  1751.   "Attempt to replace Name's definition with an interpreted version of that
  1752.   definition.  If no interpreted definition is to be found, then signal an
  1753.   error."
  1754.   (let ((def (fdefinition name)))
  1755.     (if (eval:interpreted-function-p def)
  1756.     (warn "~S is already interpreted." name)
  1757.     (setf (fdefinition name)
  1758.           (coerce (get-lambda-to-compile def) 'function))))
  1759.   name)
  1760.