main.lisp 74.3 KB
Newer Older
wlott's avatar
wlott committed
1
2
3
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
ram's avatar
ram committed
4
5
6
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
7
(ext:file-comment "$Header: src/compiler/main.lisp $")
ram's avatar
ram committed
8
;;;
wlott's avatar
wlott committed
9
10
11
12
13
14
;;; **********************************************************************
;;;
;;;    This file contains the top-level interfaces to the compiler.
;;; 
;;; Written by Rob MacLachlan
;;;
ram's avatar
ram committed
15
(in-package "C")
16
(in-package "EXTENSIONS")
17
18
(intl:textdomain "cmucl")

19
(export '(*compile-progress* compile-from-stream *block-compile-default*
20
21
22
			     start-block end-block
			     *byte-compile-default*
			     *byte-compile-top-level*))
23
24
(in-package "LISP")
(export '(*compile-verbose* *compile-print* *compile-file-pathname*
ram's avatar
ram committed
25
26
			    *compile-file-truename*
			    compile-file-pathname))
27
(in-package "C")
wlott's avatar
wlott committed
28

pw's avatar
pw committed
29
30
31
32
33
34
35
36
37
38
39
40
41
42
(declaim (special *constants* *free-variables* *compile-component*
		  *code-vector* *next-location* *result-fixups*
		  *free-functions* *source-paths*
		  *continuation-number* *continuation-numbers*
		  *number-continuations* *tn-id* *tn-ids* *id-tns*
		  *label-ids* *label-id* *id-labels*
		  *undefined-warnings* *compiler-error-count*
		  *compiler-warning-count* *compiler-note-count*
		  *compiler-error-output* *compiler-error-bailout*
		  *compiler-trace-output*
		  *last-source-context* *last-original-source*
		  *last-source-form* *last-format-string* *last-format-args*
		  *last-message-count* *lexical-environment*
		  *coalesce-constants*))
wlott's avatar
wlott committed
43

44
;;; Exported:
45
(defvar *block-compile-default* :specified
46
  "The default value for the :Block-Compile argument to COMPILE-FILE.")
47
48
49
50
(declaim (type (member t nil :specified) *block-compile-default*))

;;; Exported:
(defvar *byte-compile-default* :maybe
51
  "The default value for the :Byte-Compile argument to COMPILE-FILE.")
52
53
54

;;; Exported:
(defvar *byte-compile-top-level* t
55
  "Similar to *BYTE-COMPILE-DEFAULT*, but controls the compilation of top-level
56
57
  forms (evaluated at load-time) when the :BYTE-COMPILE argument is :MAYBE
  (the default.)  When true, we decide to byte-compile.")
58

59
60
;;; Exported:
(defvar *loop-analyze* nil
61
  "Whether loop analysis should be done or not.")
62

63
64
65
66
;;; Value of the :byte-compile argument to the compiler.
(defvar *byte-compile* :maybe)

;;; Bound by COMPILE-COMPONENT to T when byte-compiling, and NIL when
ram's avatar
ram committed
67
68
;;; native compiling.  During IR1 conversion this can also be :MAYBE, in which
;;; case we must look at the policy, see (byte-compiling).
69
;;;
ram's avatar
ram committed
70
71
72
(defvar *byte-compiling* :maybe)
(declaim (type (member t nil :maybe) *byte-compile* *byte-compiling*
	       *byte-compile-default*))
73

74
(defvar compiler-version "1.1")
ram's avatar
ram committed
75
76
77
78
79
(pushnew :python *features*)
(setf (getf ext:*herald-items* :python)
      `("    Python " ,compiler-version ", target "
	,#'(lambda (stream)
	     (write-string (backend-version *backend*) stream))))
wlott's avatar
wlott committed
80

81
(defvar *check-consistency* nil)
82
83

(defvar *record-xref-info* nil
84
  "Whether the compiler should record cross-reference information.")
85

wlott's avatar
wlott committed
86
87
(defvar *all-components*)

88
89
90
;;; The current block compilation state.  These are initialized to the 
;;; :Block-Compile and :Entry-Points arguments that COMPILE-FILE was called
;;; with.  Subsequent START-BLOCK or END-BLOCK declarations alter the values.
wlott's avatar
wlott committed
91
;;;
92
93
94
;;; *Block-Compile-Argument* holds the original value of the :block-compile
;;; argument, which overrides any internal declarations.
;;;
wlott's avatar
wlott committed
95
(defvar *block-compile*)
96
97
98
(defvar *block-compile-argument*)
(declaim (type (member nil t :specified)
	       *block-compile* *block-compile-argument*))
99
100
(defvar *entry-points*)
(declaim (list *entry-points*))
wlott's avatar
wlott committed
101

102
103
;;;

wlott's avatar
wlott committed
104
105
106
107
;;; When block compiling, used by PROCESS-FORM to accumulate top-level lambdas
;;; resulting from compiling subforms.  (In reverse order.)
;;;
(defvar *top-level-lambdas*)
108
(declaim (list *top-level-lambdas*))
wlott's avatar
wlott committed
109

110
(defvar *compile-verbose* t
111
  "The default for the :VERBOSE argument to COMPILE-FILE.")
112
(defvar *compile-print* t
113
  "The default for the :PRINT argument to COMPILE-FILE.")
114
(defvar *compile-progress* nil
115
  "The default for the :PROGRESS argument to COMPILE-FILE.")
116
117

(defvar *compile-file-pathname* nil
118
  "The defaulted pathname of the file currently being compiled, or NIL if not
119
120
  compiling.")
(defvar *compile-file-truename* nil
121
  "The TRUENAME of the file currently being compiled, or NIL if not
122
123
124
125
  compiling.")

(declaim (type (or pathname null) *compile-file-pathname*
	       *compile-file-truename*))
wlott's avatar
wlott committed
126

127
;;; The values of *Package* and policy when compilation started.
wlott's avatar
wlott committed
128
129
130
;;;
(defvar *initial-package*)
(defvar *initial-cookie*)
131
(defvar *initial-interface-cookie*)
wlott's avatar
wlott committed
132
133
134
135
136
137
138

;;; The source-info structure for the current compilation.  This is null
;;; globally to indicate that we aren't currently in any identifiable
;;; compilation.
;;;
(defvar *source-info* nil)

139
(defvar *user-source-info* nil
140
  "The user supplied source-info for the current compilation.  
141
142
143
  This is the :source-info argument to COMPILE-FROM-STREAM and will be
  stored in the INFO slot of the DEBUG-SOURCE in code components and 
  in the user USER-INFO slot of STREAM-SOURCE-LOCATIONs.")
wlott's avatar
wlott committed
144
145
146

;;; Maybe-Mumble  --  Internal
;;;
147
;;;    Mumble conditional on *compile-progress*.
wlott's avatar
wlott committed
148
149
;;;
(defun maybe-mumble (&rest foo)
150
  (when *compile-progress*
wlott's avatar
wlott committed
151
152
    (apply #'compiler-mumble foo)))

153

wlott's avatar
wlott committed
154
155
(deftype object () '(or fasl-file core-object null))

156
157
158
159
(defvar *compile-object* nil)
(declaim (type object *compile-object*))


wlott's avatar
wlott committed
160
161
162

;;;; Component compilation:

163
(defparameter max-optimize-iterations 6
164
  "The upper limit on the number of times that we will consecutively do IR1
wlott's avatar
wlott committed
165
166
167
168
169
170
171
172
173
174
  optimization that doesn't introduce any new code.  A finite limit is
  necessary, since type inference may take arbitrarily long to converge.")

(defevent ir1-optimize-until-done "IR1-OPTIMIZE-UNTIL-DONE called.")
(defevent ir1-optimize-maxed-out "Hit MAX-OPTIMIZE-ITERATIONS limit.")

;;; IR1-Optimize-Until-Done  --  Internal
;;;
;;;    Repeatedly optimize Component until no further optimizations can be
;;; found or we hit our iteration limit.  When we hit the limit, we clear the
175
;;; component and block REOPTIMIZE flags to discourage the following
wlott's avatar
wlott committed
176
177
178
179
180
181
182
183
184
185
;;; optimization attempt from pounding on the same code.
;;;
(defun ir1-optimize-until-done (component)
  (declare (type component component))
  (maybe-mumble "Opt")
  (event ir1-optimize-until-done)
  (let ((count 0)
	(cleared-reanalyze nil))
    (loop
      (when (component-reanalyze component)
186
187
	(setf count 0)
	(setf cleared-reanalyze t)
wlott's avatar
wlott committed
188
189
190
	(setf (component-reanalyze component) nil))
      (setf (component-reoptimize component) nil)
      (ir1-optimize component)
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
      (cond ((component-reoptimize component)
	     (incf count)
	     (when (= count max-optimize-iterations)
	       (maybe-mumble "*")
	       (cond ((retry-delayed-transforms :optimize)
		      (maybe-mumble "+")
		      (setf count 0))
		     (t
		      (event ir1-optimize-maxed-out)
		      (setf (component-reoptimize component) nil)
		      (do-blocks (block component)
			(setf (block-reoptimize block) nil))
		      (return)))))
	    ((retry-delayed-transforms :optimize)
	     (setf count 0)
	     (maybe-mumble "+"))
	    (t
	     (return)))
wlott's avatar
wlott committed
209
210
      (maybe-mumble "."))
    (when cleared-reanalyze
211
212
      (setf (component-reanalyze component) t))
    (maybe-mumble " "))
wlott's avatar
wlott committed
213
214
  (undefined-value))

215
(defparameter *constraint-propagate* t)
216
(defparameter *reoptimize-after-type-check-max* 10)
217
218

(defevent reoptimize-maxed-out
219
  "*REOPTIMIZE-AFTER-TYPE-CHECK-MAX* exceeded.")
wlott's avatar
wlott committed
220

221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238

;;; DFO-AS-NEEDED  --  Internal
;;;
;;;    Iterate doing FIND-DFO until no new dead code is discovered.
;;;
(defun dfo-as-needed (component)
  (declare (type component component))
  (when (component-reanalyze component)
    (maybe-mumble "DFO")
    (loop
      (find-dfo component)
      (unless (component-reanalyze component)
	(maybe-mumble " ")
	(return))
      (maybe-mumble ".")))
  (undefined-value))


wlott's avatar
wlott committed
239
240
241
242
243
244
;;; IR1-Phases  --  Internal
;;;
;;;    Do all the IR1 phases for a non-top-level component.
;;;
(defun ir1-phases (component)
  (declare (type component component))
245
  (let ((*constraint-number* 0)
246
247
	(loop-count 1)
	(*delayed-transforms* nil))
248
    (declare (special *constraint-number* *delayed-transforms*))
249
    (loop
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
     (ir1-optimize-until-done component)
     (when (or (component-new-functions component)
	       (component-reanalyze-functions component))
       (maybe-mumble "Locall ")
       (local-call-analyze component))
     (dfo-as-needed component)
     (when *constraint-propagate*
       (maybe-mumble "Constraint ")
       (constraint-propagate component))
     (when (retry-delayed-transforms :constraint)
       (maybe-mumble "Rtran "))
     ;; Delay the generation of type checks until the type constraints have
     ;; had time to propagate, else the compiler can confuse itself.
     (unless (and (or (component-reoptimize component)
		      (component-reanalyze component)
		      (component-new-functions component)
		      (component-reanalyze-functions component))
		  (< loop-count (- *reoptimize-after-type-check-max* 4)))
       (maybe-mumble "Type ")
       (generate-type-checks component)
       (unless (or (component-reoptimize component)
		   (component-reanalyze component)
		   (component-new-functions component)
		   (component-reanalyze-functions component))
	 (return)))
     (when (>= loop-count *reoptimize-after-type-check-max*)
       (maybe-mumble "[Reoptimize Limit]")
       (event reoptimize-maxed-out)
       (return))
     (incf loop-count)))
280
281

  (ir1-finalize component)
282
  (undefined-value))
wlott's avatar
wlott committed
283
284


285
;;; Native-Compile-Component  --  Internal
wlott's avatar
wlott committed
286
;;;
287
288
(defun native-compile-component (component)
  (let ((*code-segment* nil)
289
290
	(*elsewhere* nil)
	(*elsewhere-label* nil))
wlott's avatar
wlott committed
291
292
293
294
    (maybe-mumble "GTN ")
    (gtn-analyze component)
    (maybe-mumble "LTN ")
    (ltn-analyze component)
295
    (dfo-as-needed component)
ram's avatar
ram committed
296
    (maybe-mumble "Control ")
297
    (control-analyze component #'make-ir2-block)
wlott's avatar
wlott committed
298
299
300

    (when (ir2-component-values-receivers (component-info component))
      (maybe-mumble "Stack ")
301
302
303
304
305
306
      (stack-analyze component)
      ;;
      ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by stack
      ;; analysis.  There shouldn't be any unreachable code after control, so
      ;; this won't delete anything.
      (dfo-as-needed component))
wlott's avatar
wlott committed
307

308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
    (unwind-protect
	(progn
	  (maybe-mumble "IR2Tran ")
	  (init-assembler)
	  (entry-analyze component)
	  (ir2-convert component)
	  
	  (when (policy nil (>= speed cspeed))
	    (maybe-mumble "Copy ")
	    (copy-propagate component))
	  
	  (select-representations component)
	  
	  (when *check-consistency*
	    (maybe-mumble "Check2 ")
	    (check-ir2-consistency component))
	  
	  (delete-unreferenced-tns component)
	  
	  (maybe-mumble "Life ")
	  (lifetime-analyze component)
	  
	  (when *compile-progress*
	    (compiler-mumble "") ; Sync before doing random output.
	    (pre-pack-tn-stats component *compiler-error-output*))
	  
	  (when *check-consistency*
	    (maybe-mumble "CheckL ")
	    (check-life-consistency component))
337

338
339
340
341
342
343
344
345
	  (maybe-mumble "Pack ")
	  (pack component)
	  
	  (when *check-consistency*
	    (maybe-mumble "CheckP ")
	    (check-pack-consistency component))
	  
	  (when *compiler-trace-output*
346
347
	    (describe-component component *compiler-trace-output*)
	    (describe-ir2-component component *compiler-trace-output*))
348
349
350
351
352
	  
	  (maybe-mumble "Code ")
	  (multiple-value-bind
	      (length trace-table fixups)
	      (generate-code component)
353

354
355
	    (when (and *compiler-trace-output*
		       (backend-disassem-params *backend*))
356
	      (format *compiler-trace-output*
357
		      (intl:gettext "~|~%Disassembly of code for ~S~2%") component)
358
359
360
	      (disassem:disassemble-assem-segment *code-segment*
						  *compiler-trace-output*
						  *backend*))
361

362
363
364
365
366
367
368
369
370
	    (etypecase *compile-object*
	      (fasl-file
	       (maybe-mumble "FASL")
	       (fasl-dump-component component *code-segment*
				    length trace-table fixups
				    *compile-object*))
	      (core-object
	       (maybe-mumble "Core")
	       (make-core-component component *code-segment*
371
372
				    length trace-table fixups
				    *compile-object*))
373
	      (null))))
374

wlott's avatar
wlott committed
375
376
377
378
      (when *code-segment*
	(new-assem:release-segment *code-segment*))
      (when *elsewhere*
	(new-assem:release-segment *elsewhere*))))
wlott's avatar
wlott committed
379

380
  ;; We are done, so don't bother keeping anything around.
381
382
  (nuke-ir2-component component)
  (setf (component-info component) nil)
383
384
385
386
  
  (undefined-value))


ram's avatar
ram committed
387
388
389
390
;;; BYTE-COMPILING  --  Interface
;;;
;;;    Return our best guess for whether we will byte compile code currently
;;; being IR1 converted.  Only a guess because the decision is made on a
391
;;; per-component basis.
ram's avatar
ram committed
392
;;;
393
(defun byte-compiling ()
ram's avatar
ram committed
394
  (if (eq *byte-compiling* :maybe)
395
      (or (eq *byte-compile* t)
396
	  (policy nil (zerop speed) (<= debug 1)))
397
      (and *byte-compile* *byte-compiling*)))
ram's avatar
ram committed
398

399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418

;;; DELETE-IF-NO-ENTRIES  --  Internal
;;;
;;;    Delete components with no external entry points before we try to
;;; generate code.  Unreachable closures can cause IR2 conversion to puke on
;;; itself, since it is the reference to the closure which normally causes the
;;; components to be combined.  This doesn't really cover all cases...
;;;
(defun delete-if-no-entries (component)
  (dolist (fun (component-lambdas component)
	       (delete-component component))
    (case (functional-kind fun)
      (:top-level (return))
      (:external
       (unless (every #'(lambda (ref)
			  (eq (block-component (node-block ref))
			      component))
		      (leaf-refs fun))
	 (return))))))

ram's avatar
ram committed
419
  
420
421
422
;;; COMPILE-COMPONENT -- internal.
;;;
(defun compile-component (component)
423
  (let* ((*compile-component* component)
ram's avatar
ram committed
424
	 (*byte-compiling*
425
426
427
428
	  (ecase *byte-compile*
	    ((t) t)
	    ((nil) nil)
	    (:maybe
429
430
	     (dolist (fun (component-lambdas component) t)
	       (unless (policy (lambda-bind fun)
431
			       (zerop speed) (<= debug 1))
432
433
		 (return nil)))))))

434
    (when *compile-print*
435
436
      (compiler-mumble "~&")
      (pprint-logical-block (*compiler-error-output* nil :per-line-prefix "; ")
437
	(compiler-mumble (intl:gettext "~:[~;Byte ~]Compiling ~A: ")
438
		       *byte-compiling*
439
		       (component-name component))))
440
441
442

    (ir1-phases component)

443
444
445
446
447
448
449
    (when *loop-analyze*
      (dfo-as-needed component)
      (maybe-mumble "Dom ")
      (find-dominators component)
      (maybe-mumble "Loop ")
      (loop-analyze component))

450
451
452
453
454

    (maybe-mumble "Env ")
    (environment-analyze component)
    (dfo-as-needed component)

455
456
    (delete-if-no-entries component)

457
458
459
460
    (when *record-xref-info*
      (maybe-mumble "[record-xref-info]~%")
      (record-component-xrefs component))

ram's avatar
ram committed
461
462
463
464
465
    (unless (eq (block-next (component-head component))
		(component-tail component))
      (if *byte-compiling*
	  (byte-compile-component component)
	  (native-compile-component component))))
466

467
468
  (clear-constant-info)

469
470
471
  (when *compile-print*
    (compiler-mumble "~&"))

wlott's avatar
wlott committed
472
473
474
475
476
  (undefined-value))


;;;; Clearing global data structures:

477
;;; CLEAR-CONSTANT-INFO  --  Internal
wlott's avatar
wlott committed
478
;;;
479
480
481
482
483
;;;    Clear the INFO in constants in the *FREE-VARIABLES*, etc.  In addition
;;; to allowing stuff to be reclaimed, this is required for correct assignment
;;; of constant offsets, since we need to assign a new offset for each
;;; component.  We don't clear the FUNCTIONAL-INFO slots, since they are used
;;; to keep track of functions across component boundaries.
wlott's avatar
wlott committed
484
;;;
485
(defun clear-constant-info ()
wlott's avatar
wlott committed
486
487
488
489
490
491
492
493
494
495
496
497
498
499
  (maphash #'(lambda (k v)
	       (declare (ignore k))
	       (setf (leaf-info v) nil))
	   *constants*)

  (maphash #'(lambda (k v)
	       (declare (ignore k))
	       (when (constant-p v)
		 (setf (leaf-info v) nil)))
	   *free-variables*)

  (undefined-value))


500
501
502
503
504
505
506
;;; CLEAR-IR1-INFO  --  Internal
;;;
;;;    Blow away the REFS for all global variables, and recycle the IR1 for
;;; Component.
;;;
(defun clear-ir1-info (component)
  (declare (type component component))
507
508
509
  (labels ((blast (x)
	     (maphash #'(lambda (k v)
			  (declare (ignore k))
wlott's avatar
wlott committed
510
511
512
513
514
515
			  (when (leaf-p v)
			    (setf (leaf-refs v)
				  (delete-if #'here-p (leaf-refs v)))
			    (when (basic-var-p v)
			      (setf (basic-var-sets v)
				    (delete-if #'here-p (basic-var-sets v))))))
516
517
518
		      x))
	   (here-p (x)
	     (eq (block-component (node-block x)) component)))
519
520
521
522
523
524
525
    (blast *free-variables*)
    (blast *free-functions*)
    (blast *constants*))
  (macerate-ir1-component component)
  (undefined-value))


526
;;; CLEAR-STUFF  --  Interface
527
528
;;;
;;;    Clear all the global variables used by the compiler.
wlott's avatar
wlott committed
529
;;;
530
(defun clear-stuff (&optional (debug-too t))
wlott's avatar
wlott committed
531
532
  ;;
  ;; Clear global tables.
533
534
535
536
  (when (boundp '*free-functions*)
    (clrhash *free-functions*)
    (clrhash *free-variables*)
    (clrhash *constants*))
537
538
539
540
541
542
543
544
545
546

  (when debug-too
    (clrhash *continuation-numbers*)
    (clrhash *number-continuations*)
    (setq *continuation-number* 0)
    (clrhash *tn-ids*)
    (clrhash *id-tns*)
    (setq *tn-id* 0)
    (clrhash *label-ids*)
    (clrhash *id-labels*)
547
548
549
550
551
552
553
    (setq *label-id* 0)
    ;;
    ;; Clear some Pack data structures (for GC purposes only.)
    (assert (not *in-pack*))
    (dolist (sb (backend-sb-list *backend*))
      (when (finite-sb-p sb)
	(fill (finite-sb-live-tns sb) nil))))
wlott's avatar
wlott committed
554
555
  ;;
  ;; Reset Gensym.
556
557
558
  (setq lisp:*gensym-counter* 0)

  (values))
wlott's avatar
wlott committed
559

560

wlott's avatar
wlott committed
561
562
563
564
;;; PRINT-SUMMARY  --  Interface
;;;
;;;    This function is called by WITH-COMPILATION-UNIT at the end of a
;;; compilation unit.  It prints out any residual unknown function warnings and
565
566
;;; the total error counts.  ABORT-P should be true when the compilation unit
;;; was aborted by throwing out.  ABORT-COUNT is the number of dynamically
wlott's avatar
wlott committed
567
568
569
570
;;; enclosed nested compilation units that were aborted.
;;;
(defun print-summary (abort-p abort-count)
  (unless abort-p
571
572
573
574
575
576
577
578
579
580
581
    (handler-bind ((warning #'compiler-warning-handler))
      (let ((undefs (sort *undefined-warnings* #'string<
			  :key #'(lambda (x)
				   (let ((x (undefined-warning-name x)))
				     (if (symbolp x)
					 (symbol-name x)
					 (prin1-to-string x)))))))
	(unless *converting-for-interpreter*
	  (dolist (undef undefs)
	    (let ((name (undefined-warning-name undef))
		  (kind (undefined-warning-kind undef))
582
                  (context (undefined-warning-context undef))
583
584
585
		  (warnings (undefined-warning-warnings undef))
		  (count (undefined-warning-count undef)))
	      (dolist (*compiler-error-context* warnings)
586
		(compiler-warning _N"Undefined ~(~A~) ~S~@[ ~A~]" kind name context))
587
588
589
590
	      
	      (let ((warn-count (length warnings)))
		(when (and warnings (> count warn-count))
		  (let ((more (- count warn-count)))
591
		    (compiler-warning _N"~D more use~:P of undefined ~(~A~) ~S."
592
593
594
595
596
597
598
599
				      more kind name)))))))
	
	(dolist (kind '(:variable :function :type))
	  (let ((summary (mapcar #'undefined-warning-name
				 (remove kind undefs :test-not #'eq
					 :key #'undefined-warning-kind))))
	    (when summary
	      (compiler-warning
600
	       _N"~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
601
602
		~%  ~{~<~%  ~1:;~S~>~^ ~}"
	       (cdr summary) kind summary)))))))
603
  
604
605
606
607
608
  (unless (or *converting-for-interpreter*
	      (and (not abort-p) (zerop abort-count)
		   (zerop *compiler-error-count*)
		   (zerop *compiler-warning-count*)
		   (zerop *compiler-note-count*)))
609
    (compiler-mumble
610
     (intl:gettext "~2&; Compilation unit ~:[finished~;aborted~].~
611
612
613
      ~[~:;~:*~&;   ~D fatal error~:P~]~
      ~[~:;~:*~&;   ~D error~:P~]~
      ~[~:;~:*~&;   ~D warning~:P~]~
614
      ~[~:;~:*~&;   ~D note~:P~]~2%")
615
616
617
618
619
     abort-p
     abort-count
     *compiler-error-count*
     *compiler-warning-count*
     *compiler-note-count*)))
620

621
   
622
623
;;;; Trace output:

wlott's avatar
wlott committed
624
625
626
627
;;; Describe-Component  --  Internal
;;;
;;;    Print out some useful info about Component to Stream.
;;;
628
(defun describe-component (component *standard-output*)
629
  (declare (type component component))
630
  (format t (intl:gettext "~|~%;;;; Component: ~S~2%") (component-name component))
631
632
633
634
635
  (print-blocks component)  
  (undefined-value))


(defun describe-ir2-component (component *standard-output*)
636
  (format t (intl:gettext "~%~|~%;;;; IR2 component: ~S~2%") (component-name component))
wlott's avatar
wlott committed
637
  
638
  (format t (intl:gettext "Entries:~%"))
639
  (dolist (entry (ir2-component-entries (component-info component)))
640
    (format t (intl:gettext "~4TL~D: ~S~:[~; [Closure]~]~%")
641
642
643
	    (label-id (entry-info-offset entry))
	    (entry-info-name entry)
	    (entry-info-closure-p entry)))
wlott's avatar
wlott committed
644
  
645
646
647
648
649
  (terpri)
  (pre-pack-tn-stats component *standard-output*)
  (terpri)
  (print-ir2-blocks component)
  (terpri)
wlott's avatar
wlott committed
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
  (undefined-value))


;;;; File reading:
;;;
;;;    When reading from a file, we have to keep track of some source
;;; information.  We also exploit our ability to back up for printing the error
;;; context and for recovering from errors.
;;;
;;; The interface we provide to this stuff is the stream-oid Source-Info
;;; structure.  The bookkeeping is done as a side-effect of getting the next
;;; source form.


;;; The File-Info structure holds all the source information for a given file.
;;;
(defstruct file-info
  ;;
  ;; If a file, the truename of the corresponding source file.  If from a Lisp
  ;; form, :LISP, if from a stream, :STREAM.
670
  (name (required-argument) :type (or pathname (member :lisp :stream)))
wlott's avatar
wlott committed
671
  ;;
672
  ;; The defaulted, but not necessarily absolute file name (i.e. prior to
673
674
675
  ;; TRUENAME call.)  Null if not a file.  This is used to set
  ;; *COMPILE-FILE-PATHNAME*, and if absolute, is dumped in the debug-info.
  (untruename nil :type (or pathname null))
676
  ;;
wlott's avatar
wlott committed
677
678
679
  ;; The file's write date (if relevant.)
  (write-date nil :type (or unsigned-byte null))
  ;;
ram's avatar
ram committed
680
681
682
  ;; This file's FILE-COMMENT, or NIL if none.
  (comment nil :type (or simple-string null))
  ;;
wlott's avatar
wlott committed
683
684
685
686
687
688
689
  ;; The source path root number of the first form in this file (i.e. the
  ;; total number of forms converted previously in this compilation.)
  (source-root 0 :type unsigned-byte)
  ;;
  ;; Parallel vectors containing the forms read out of the file and the file
  ;; positions that reading of each form started at (i.e. the end of the
  ;; previous form.)
690
  (forms (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))
691
692
693
  (positions (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))
  ;;
  ;; Language to use.  Normally Lisp, but sometimes Dylan.
694
  (language :lisp :type (member :lisp #+nil :dylan)))
wlott's avatar
wlott committed
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715

;;; The Source-Info structure provides a handle on all the source information
;;; for an entire compilation.
;;;
(defstruct (source-info
	    (:print-function
	     (lambda (s stream d)
	       (declare (ignore s d))
	       (format stream "#<Source-Info>"))))
  ;;
  ;; The UT that compilation started at.
  (start-time (get-universal-time) :type unsigned-byte)
  ;;
  ;; A list of the file-info structures for this compilation.
  (files nil :type list)
  ;;
  ;; The tail of the Files for the file we are currently reading.
  (current-file nil :type list)
  ;;
  ;; The stream that we are using to read the Current-File.  Null if no stream
  ;; has been opened yet.
rtoy's avatar
rtoy committed
716
717
718
719
  (stream nil :type (or stream null))
  ;;
  ;; External format to use for the stream if the stream hasn't been opened
  #+unicode
720
721
722
723
724
725
  (external-format :default)
  ;;
  ;; How to handle decoding errors when reading the source file.
  ;; Default is T to signal an error.
  #+unicode
  (decoding-error t))
wlott's avatar
wlott committed
726
727
728
729
730
731


;;; Make-File-Source-Info  --  Internal
;;;
;;;    Given a list of pathnames, return a Source-Info structure.
;;;
732
(defun make-file-source-info (files external-format decoding-error)
wlott's avatar
wlott committed
733
734
735
  (declare (list files))
  (let ((file-info
	 (mapcar #'(lambda (x)
ram's avatar
ram committed
736
		     (make-file-info :name (truename x)
737
				     :untruename x
738
				     :write-date (file-write-date x)
739
				     :language :lisp))
wlott's avatar
wlott committed
740
741
742
		 files)))

    (make-source-info :files file-info
rtoy's avatar
rtoy committed
743
744
		      :current-file file-info
		      #+unicode :external-format
745
		      #+unicode (stream::ef-name
746
747
748
				 (stream::find-external-format external-format))
		      #+unicode :decoding-error
		      #+unicode decoding-error)))
wlott's avatar
wlott committed
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767


;;; MAKE-LISP-SOURCE-INFO  --  Interface
;;;
;;;    Return a SOURCE-INFO to describe the incremental compilation of Form.
;;; Also used by EVAL:INTERNAL-EVAL.
;;;
(defun make-lisp-source-info (form)
  (make-source-info
   :start-time (get-universal-time)
   :files (list (make-file-info :name :lisp
				:forms (vector form)
				:positions '#(0)))))


;;; MAKE-STREAM-SOURCE-INFO  --  Internal
;;;
;;;    Return a SOURCE-INFO which will read from Stream.
;;;
768
(defun make-stream-source-info (stream language)
769
  (declare (type (member :lisp) language))
770
  (let ((files (list (make-file-info :name :stream :language language))))
wlott's avatar
wlott committed
771
772
773
774
775
776
777
778
779
780
781
782
783
784
    (make-source-info
     :files files
     :current-file files
     :stream stream)))


;;; Normal-Read-Error  --  Internal
;;;
;;;    Print an error message for a non-EOF error on Stream.  Old-Pos is a
;;; preceding file position that hopefully comes before the beginning of the
;;; line.  Of course, this only works on streams that support the file-position
;;; operation.
;;;
(defun normal-read-error (stream old-pos condition)
785
  (declare (type stream stream) (type unsigned-byte old-pos))
wlott's avatar
wlott committed
786
787
788
789
790
791
792
  (let ((pos (file-position stream)))
    (file-position stream old-pos)
    (let ((start old-pos))
      (loop
	(let ((line (read-line stream nil))
	      (end (file-position stream)))
	  (when (>= end pos)
793
	    (compiler-read-error 
794
	     pos (intl:gettext "Read error at ~D:~% \"~A/\\~A\"~%~A")
795
796
	     pos (string-left-trim '(#\space #\tab)
				   (subseq line 0 (- pos start)))
wlott's avatar
wlott committed
797
798
799
800
801
802
803
804
805
806
807
808
809
	     (subseq line (- pos start))
	     condition)
	    (return))
	  (setq start end)))))
  (undefined-value))


;;; Ignore-Error-Form  --  Internal
;;;
;;;    Back Stream up to the position Pos, then read a form with
;;; *Read-Suppress* on, discarding the result.  If an error happens during this
;;; read, then bail out using Compiler-Error (fatal in this context).
;;;
810
(defun ignore-error-form (stream pos)
wlott's avatar
wlott committed
811
812
  (declare (type stream stream) (type unsigned-byte pos))
  (file-position stream pos)
813
814
  (handler-case (let ((*read-suppress* t)
		      (*features* (backend-features *target-backend*)))
815
		  (read stream))
wlott's avatar
wlott committed
816
817
    (error (condition)
      (declare (ignore condition))
818
      (compiler-error _N"Unable to recover from read error."))))
wlott's avatar
wlott committed
819
820
821
822
823


;;; Unexpected-EOF-Error  --  Internal
;;;
;;;    Print an error message giving some context for an EOF error.  We print
824
;;; the first line after POS that contains #\" or #\(, or lacking that, the
wlott's avatar
wlott committed
825
826
827
828
;;; first non-empty line.
;;;
(defun unexpected-eof-error (stream pos condition)
  (declare (type stream stream) (type unsigned-byte pos))
829
830
  (let ((eof-pos (file-position stream))
        (res nil))
wlott's avatar
wlott committed
831
832
    (file-position stream pos)
    (loop
rtoy's avatar
rtoy committed
833
834
835
836
837
838
839
       (let ((line (read-line stream nil nil))) 
	 (unless line (return))
	 (when (or (find #\" line) (find #\( line))
	   (setq res line)
	   (return))
	 (unless (or res (zerop (length line)))
	   (setq res line))))
wlott's avatar
wlott committed
840

841
    (compiler-read-error 
842
     pos _"Read error in form starting at ~D:~%~@[ \"~A\"~%~]~A"
rtoy's avatar
rtoy committed
843
     pos res condition)
wlott's avatar
wlott committed
844

rtoy's avatar
rtoy committed
845
846
    (file-position stream eof-pos)
    (undefined-value)))
wlott's avatar
wlott committed
847
848
849
850


;;; Careful-Read  --  Internal
;;;
851
;;;    Read a form from STREAM, returning EOF at EOF.  If a read error happens,
wlott's avatar
wlott committed
852
853
;;; then attempt to recover if possible, returing a proxy error form.
;;;
854
(defun careful-read (stream eof pos)
855
  (handler-case (let ((*features* (backend-features *target-backend*)))
856
		  (read stream nil eof))
wlott's avatar
wlott committed
857
    (error (condition)
858
859
860
861
862
      (if (null (peek-char nil stream nil))
          (unexpected-eof-error stream pos condition)
          (progn
            (normal-read-error stream pos condition)
            (ignore-error-form stream pos)))
863
864
      '(cerror (intl:gettext "Skip this form.")
	       (intl:gettext "Attempt to load a file having a compile-time read error.")))))
wlott's avatar
wlott committed
865
866
867
868
869
870


;;; Get-Source-Stream  --  Internal
;;;
;;;    If Stream is present, return it, otherwise open a stream to the current
;;; file.  There must be a current file.  When we open a new file, we also
871
;;; reset *Package* and policy.  This gives the effect of rebinding
wlott's avatar
wlott committed
872
873
874
875
876
877
878
879
;;; around each file.
;;;
(defun get-source-stream (info)
  (declare (type source-info info))
  (cond ((source-info-stream info))
	(t
	 (setq *package* *initial-package*)
	 (setq *default-cookie* (copy-cookie *initial-cookie*))
880
881
	 (setq *default-interface-cookie*
	       (copy-cookie *initial-interface-cookie*))
882
883
	 (let* ((finfo (first (source-info-current-file info)))
		(name (file-info-name finfo)))
884
885
	   (setq *compile-file-truename* name)
	   (setq *compile-file-pathname* (file-info-untruename finfo))
886
	   (setf (source-info-stream info)
rtoy's avatar
rtoy committed
887
888
		 (open name :direction :input
		       #+unicode :external-format
889
890
891
		       #+unicode (source-info-external-format info)
		       #+unicode :decoding-error
		       #+unicode (source-info-decoding-error info)))))))
wlott's avatar
wlott committed
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920

;;; CLOSE-SOURCE-INFO  --  Internal
;;;
;;;    Close the stream in Info if it is open.
;;;
(defun close-source-info (info)
  (declare (type source-info info))
  (let ((stream (source-info-stream info)))
    (when stream (close stream)))
  (setf (source-info-stream info) nil)
  (undefined-value))


;;; Advance-Source-File  --  Internal
;;;
;;;    Advance Info to the next source file.  If none, return NIL, otherwise T.
;;;
(defun advance-source-file (info)
  (declare (type source-info info))
  (close-source-info info)
  (let ((prev (pop (source-info-current-file info))))
    (if (source-info-current-file info)
	(let ((current (first (source-info-current-file info))))
	  (setf (file-info-source-root current)
		(+ (file-info-source-root prev)
		   (length (file-info-forms prev))))
	  t)
	nil)))

921
;;; PROCESS-SOURCES -- internal.
wlott's avatar
wlott committed
922
;;;
923
924
925
926
927
928
929
930
;;; Read the sources from the source files and process them.
;;; 
(defun process-sources (info)
  (let* ((file (first (source-info-current-file info)))
	 (language (file-info-language file))
	 (stream (get-source-stream info)))
    (ecase language
      (:lisp
rtoy's avatar
rtoy committed
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
       (flet
	   ((process-one (stream)
	      (loop
		 (let* ((pos (file-position stream))
			(eof '(*eof*))
			(form (careful-read stream eof pos)))
		   (if (eq form eof)
		       (return)
		       (let* ((forms (file-info-forms file))
			      (current-idx (+ (fill-pointer forms)
					      (file-info-source-root file))))
			 (vector-push-extend form forms)
			 (vector-push-extend pos (file-info-positions file))
			 (clrhash *source-paths*)
			 (find-source-paths form current-idx)
			 (process-form form
				       `(original-source-start 0 ,current-idx)))))))
	    (process-xref-info (pathname)
	      ;; When we have xref enabled, we save the xref data to the
	      ;; file by faking it.  What we do is append a bunch of forms
	      ;; to the file as if the file actually contained them.  These
	      ;; forms clear out the entries from the xref databases
	      ;; pertaining to this file, and then registers new entries
	      ;; based on what we've found out so far from compiling this
	      ;; file.
	      ;;
	      ;; Is this what we really want to do?  A new FOP might be good.
	      ;;
	      ;; Also, when compiling a file should we have a file-local
	      ;; version of the databases?  This makes it easy to figure
	      ;; out what we need to save to the fasl.  Then we can update
	      ;; the global tables with the new info when we're done.  Or
	      ;; we can just wait until the user loads the fasl.  This
	      ;; latter option, however, changes how xref currently behaves.

	      ;; Set *compile-print* to nil so we don't see any
	      ;; spurious output from our fake source forms.  (Do we
	      ;; need more?)
	      (let ((*compile-print* nil))
		;; Clear the xref database of all references to this file
		(when (or (pathnamep pathname)
			  (stringp pathname))
		  (process-form `(xref::invalidate-xrefs-for-namestring
				  ,(namestring pathname))
				;; What should we use here?
				`(original-source-start 0 0))
		  ;; Now dump all the xref info pertaining to this file
		  (dolist (db-type '(:calls :called :references :binds :sets
				     :macroexpands))
		    (dolist (xrefs (xref::find-xrefs-for-pathname db-type pathname))
		      (destructuring-bind (target contexts)
			  xrefs
			(dolist (c contexts)
			  (process-form
			   `(xref:register-xref
			     ,db-type ',target
			     (xref:make-xref-context :name ',(xref:xref-context-name c)
						     :file ,(xref:xref-context-file c)
						     :source-path ',(xref:xref-context-source-path c)))

			   `(original-source-start 0 0))))))))))
	 ;; Compile the real file.
	 (process-one stream)

	 (when *record-xref-info*
	   (process-xref-info (file-info-name file))))
      
       (when (advance-source-file info)
	 (process-sources info))))))
wlott's avatar
wlott committed
1000

1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
;;; FIND-FILE-INFO  --  Interface
;;;
;;;    Return the File-Info describing the Index'th form.
;;;
(defun find-file-info (index info)
  (declare (type index index) (type source-info info))
  (dolist (file (source-info-files info))
    (when (> (+ (length (file-info-forms file))
		(file-info-source-root file))
	     index)
      (return file))))


;;; FIND-SOURCE-ROOT  --  Interface
wlott's avatar
wlott committed
1015
1016
1017
1018
1019
;;;
;;;    Return the Index'th source form read from Info and the position that it
;;; was read at.
;;;
(defun find-source-root (index info)
1020
1021
1022
1023
1024
  (declare (type source-info info) (type index index))
  (let* ((file (find-file-info index info))
	 (idx (- index (file-info-source-root file))))
    (values (aref (file-info-forms file) idx)
	    (aref (file-info-positions file) idx))))
wlott's avatar
wlott committed
1025
1026
1027
1028
1029
1030

;;;; Top-level form processing:

;;; CONVERT-AND-MAYBE-COMPILE  --  Internal
;;;
;;;    Called by top-level form processing when we are ready to actually
1031
;;; compile something.  If *BLOCK-COMPILE* is T, then we still convert the
wlott's avatar
wlott committed
1032
1033
;;; form, but delay compilation, pushing the result on *TOP-LEVEL-LAMBDAS*
;;; instead.
1034
;;;
1035
1036
1037
;;;   The cookies at this time becomes the default policy for compiling the
;;; form.  Any enclosed PROCLAIMs will affect only subsequent forms.
;;;
1038
1039
(defun convert-and-maybe-compile (form path)
  (declare (list path))
1040
1041
1042
1043
1044
1045
1046
  (let* ((*lexical-environment*
	  (make-lexenv :cookie *default-cookie*
		       :interface-cookie *default-interface-cookie*))
	 (tll (ir1-top-level form path nil)))
    (if (eq *block-compile* t)
	(push tll *top-level-lambdas*)
	(compile-top-level (list tll) nil))))
wlott's avatar
wlott committed
1047
1048
1049
1050

;;; PROCESS-PROGN  --  Internal
;;;
;;;    Process a PROGN-like portion of a top-level form.  Forms is a list of
1051
;;; the forms, and Path is source path of the form they came out of.
wlott's avatar
wlott committed
1052
;;;
1053
1054
(defun process-progn (forms path)
  (declare (list forms) (list path))
1055
  (dolist (form forms)
1056
    (process-form form path)))
wlott's avatar
wlott committed
1057
1058


1059
1060
;;; PREPROCESSOR-MACROEXPAND  --  Internal
;;;
1061
1062
1063
;;;    Macroexpand form in the current environment with an error handler.  We
;;; only expand one level, so that we retain all the intervening forms in the
;;; source path.
1064
1065
;;;
(defun preprocessor-macroexpand (form)
1066
  (handler-case (macroexpand-1 form *lexical-environment*)
1067
    (error (condition)
1068
       (compiler-error _N"(during macroexpansion)~%~A" condition))))
1069
1070


1071
1072
1073
1074
1075
;;; PROCESS-LOCALLY  --  Internal
;;;
;;;    Process a top-level use of LOCALLY.  We parse declarations and then
;;; recursively process the body.
;;;
1076
;;;    Binding *DEFAULT-xxx-COOKIE* is pretty much of a hack, since it causes
1077
1078
1079
1080
1081
;;; LOCALLY to "capture" enclosed proclamations.  It is necessary because
;;; CONVERT-AND-MAYBE-COMPILE uses the value of *DEFAULT-COOKIE* as the policy.
;;; The need for this hack is due to the quirk that there is no way to
;;; represent in a cookie that an optimize quality came from the default.
;;;
1082
1083
(defun process-locally (form path)
  (declare (list path))
1084
1085
1086
1087
1088
  (multiple-value-bind
      (body decls)
      (system:parse-body (cdr form) *lexical-environment* nil)
    (let* ((*lexical-environment*
	    (process-declarations decls nil nil (make-continuation)))
1089
1090
1091
	   (*default-cookie* (lexenv-cookie *lexical-environment*))
	   (*default-interface-cookie*
	    (lexenv-interface-cookie *lexical-environment*)))
1092
      (process-progn body path))))
1093
1094
1095
1096
1097
1098
1099
1100


;;; PROCESS-FILE-COMMENT  --  Internal
;;;
;;;    Stash file comment in the file-info structure.
;;;
(defun process-file-comment (form)
  (unless (and (= (length form) 2) (stringp (second form)))
1101
    (compiler-error _N"Bad FILE-COMMENT form: ~S." form))
1102
  (let ((file (first (source-info-current-file *source-info*))))
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
    (labels
	((run-git (path)
	   (let ((cwd (default-directory))
		 (new (make-pathname :directory (pathname-directory path))))
	     (unwind-protect
		  (progn
		    ;; Cd to the directory containing the file so that
		    ;; git can find the git repo, if available.
		    (setf (default-directory) new)
		    ;; Run git to get the info.  Don't signal any
		    ;; errors if we can't find git and discard any
		    ;; error messages from git.  We only use the
		    ;; result if git returns a zero exit code, anyway.
		    (handler-case
			(run-program "git"
				     (list "log"
					   "-1"
					   "--pretty=format:%h %ai %an"
					   (namestring path))
				     :output :stream
				     :error nil)
		      (error ()
			nil)))
	       (setf (default-directory) cwd))))
	 (generate-comment (file-info)
	   (let* ((name (pathname (source-info-stream file-info)))
1129
1130
1131
1132
		  (proc (run-git name))
		  comment)
	     (if (and proc (zerop (process-exit-code proc))
		      (setf comment (read-line (process-output proc) nil nil)))
1133
1134
		 (format nil "$Header: ~A ~A $"
			 (enough-namestring name)
1135
			 comment)
1136
1137
1138
1139
1140
1141
1142
1143
1144
		 (second form)))))
      (cond ((file-info-comment file)
	     (compiler-warning _N"Ignoring extra file comment:~%  ~S." form))
	    (t
	     (let ((comment (coerce (generate-comment *source-info*)
				    'simple-string)))
	       (setf (file-info-comment file) comment)
	       (when *compile-verbose*
		 (compiler-mumble (intl:gettext "~&; Comment: ~A~2&") comment))))))))
1145
1146


1147
;;; PROCESS-COLD-LOAD-FORM  --  Internal
1148
1149
;;;
;;;    Force any pending top-level forms to be compiled and dumped so that they
1150
1151
;;; will be evaluated in the correct package environment.  Eval the form if
;;; Eval is true, then dump the form to evaled at (cold) load time.
1152
;;;
1153
1154
1155
1156
(defun process-cold-load-form (form path eval)
  (let ((object *compile-object*))
    (etypecase object
      (fasl-file
1157
       (compile-top-level-lambdas () t)
1158
1159
       (fasl-dump-cold-load-form form object))
      ((or null core-object)
1160
1161
       (convert-and-maybe-compile form path)))
    (when eval (eval form))))
1162
1163
1164
1165
1166


;;; PROCESS-PROCLAIM  --  Internal
;;;
;;;    If a special block compilation delimiter, then start or end the block as
1167
;;; appropriate.  Otherwise, just convert-and-maybe-compile the form.  If
1168
1169
;;; :block-compile was T or NIL, then we ignore any start/end block
;;; declarations.
1170
;;;
1171
(defun process-proclaim (form path)
1172
1173
  (if (and (eql (length form) 2) (constantp (cadr form)))
      (let ((spec (eval (cadr form))))
1174
	(if (and (consp spec) (eq *block-compile-argument* :specified))
1175
1176
	    (case (first spec)
	      (start-block
1177
1178
1179
	       (finish-block-compilation)
	       (setq *block-compile* t)
	       (setq *entry-points* (rest spec)))
1180
	      (end-block
1181
	       (finish-block-compilation))
1182
	      (t
1183
1184
1185
	       (convert-and-maybe-compile form path)))
	    (convert-and-maybe-compile form path)))
      (convert-and-maybe-compile form path)))
1186
1187


pw's avatar
pw committed
1188
(declaim (special *compiler-error-bailout*))
wlott's avatar
wlott committed
1189
1190
1191
1192

;;; PROCESS-FORM  --  Internal
;;;
;;;    Process a top-level Form with the specified source Path and output to
ram's avatar
ram committed
1193
1194
1195
1196
;;; Object.
;;; -- If this is a magic top-level form, then do stuff.
;;; -- If it is a macro expand it.
;;; -- Otherwise, just compile it.
wlott's avatar
wlott committed
1197
;;;
1198
1199
(defun process-form (form path)
  (declare (list path))
wlott's avatar
wlott committed
1200
  (catch 'process-form-error-abort
1201
1202
    (let* ((path (or (gethash form *source-paths*) (cons form path)))
	   (*compiler-error-bailout*
1203
1204
	    #'(lambda ()
		(convert-and-maybe-compile
1205
		 `(error 'simple-program-error
1206
		    :format-control (intl:gettext "Execution of a form compiled with errors:~% ~S")
1207
		    :format-arguments (list ',form))
1208
		 path)
1209
		(throw 'process-form-error-abort nil))))
wlott's avatar
wlott committed
1210
      (if (atom form)
1211
	  (convert-and-maybe-compile form path)
wlott's avatar
wlott committed
1212
	  (case (car form)
1213
1214
	    ((make-package shadow shadowing-import export
	      unexport use-package unuse-package import
1215
	      old-in-package %in-package %defpackage)
1216
	     (process-cold-load-form form path t))
1217
	    ((error cerror break signal)
1218
	     (process-cold-load-form form path nil))
1219
1220
1221
	    (kernel:%compiler-defstruct
	     (convert-and-maybe-compile form path)
	     (compile-top-level-lambdas () t))
wlott's avatar
wlott committed
1222
1223
	    ((eval-when)
	     (unless (>= (length form) 2)
1224
	       (compiler-error _N"EVAL-WHEN form is too short: ~S." form))
wlott's avatar
wlott committed
1225
1226
1227
	     (do-eval-when-stuff
	      (cadr form) (cddr form)
	      #'(lambda (forms)
1228
1229
		  (process-progn forms path))
	      t))
wlott's avatar
wlott committed
1230
1231
	    ((macrolet)
	     (unless (>= (length form) 2)