source: trunk/source/lib/nfcomp.lisp @ 15536

Last change on this file since 15536 was 15536, checked in by gb, 7 years ago

Support using the "coding" option in a file's file options line (a
line at the start of a text file that contains name:value pairs
separated by semicolons bracketed by -*- sequences) to determine a
file's character encoding. Specifically:

  • OPEN now allows an external-format of :INFERRED; previously, this was shorthand for an external-format whose line-termination was inferred and whose character encoding was based on *DEFAULT-FILE-CHARACTER-ENCODING*. When an input file whose external-format is specified as :INFERRED is opened, its file options are parsed and the value of the "coding" option is used if such an option is found (and if the value is something that CCL supports.) If a supported "coding" option isn't found, *DEFAULT-FILE-CHARACTER-ENCODING* is used as before.
  • In the Cocoa IDE, the Hemlock command "Ensure File Options Line" (bound to Control-Meta-M by default) ensures that the first line in the current buffer is a file options line and fills in some plausible values for the "Mode", "Package", and "Coding" options. The "Process File Options" command (Control-Meta-m) can be used to process the file options line after it's been edited. (The file options line is always processed when the file is first opened; changes to the "coding" option affect how the file will be saved.)

When a Lisp source file is opened in the IDE editor, the following
character encodings are tried in this order until one of them
succeeds:

  • if the "Open ..." panel was used to open the file and an encoding other than "Automatic" - which is now the default - is selected, that encoding is tried.
  • if a "coding" option is found, that encoding is tried.
  • the value of *DEFAULT-FILE-CHARACTER-ENCODING* is tried.
  • iso-8859-1 is tried. All files can be decoded in iso-8859-1.

This is all supposed to be what Emacs does and I think that it's
pretty close in practice.

A file that caused problems for Paul Krueger a few days ago
because its encoding (ISO-8859-1) wasn't guessed correctly
now has an explicit "coding" option and serves as a test case.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 93.9 KB
Line 
1;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20;; :lib:nfcomp.lisp - New fasl compiler.
21
22(eval-when (:compile-toplevel :load-toplevel :execute)
23   (require 'level-2))
24
25(require 'optimizers)
26(require 'hash)
27
28(eval-when (:compile-toplevel :execute)
29
30(require 'backquote)
31(require 'defstruct-macros)
32
33(defmacro short-fixnum-p (fixnum)
34  `(and (fixnump ,fixnum) (< (integer-length ,fixnum) 16)))
35
36(require "FASLENV" "ccl:xdump;faslenv")
37
38#+ppc32-target
39(require "PPC32-ARCH")
40#+ppc64-target
41(require "PPC64-ARCH")
42#+x8632-target
43(require "X8632-ARCH")
44#+x8664-target
45(require "X8664-ARCH")
46) ;eval-when (:compile-toplevel :execute)
47
48
49;File compiler options.  Not all of these need to be exported/documented, but
50;they should be in the product just in case we need them for patches....
51(defvar *fasl-save-local-symbols* t)
52(defvar *fasl-save-doc-strings*  t)
53(defvar *fasl-save-definitions* nil)
54
55(defvar *fasl-deferred-warnings* nil)
56(defvar *fasl-non-style-warnings-signalled-p* nil)
57(defvar *fasl-warnings-signalled-p* nil)
58
59(defvar *compile-verbose* nil ; Might wind up getting called *compile-FILE-verbose*
60  "The default for the :VERBOSE argument to COMPILE-FILE.")
61(defvar *compile-file-pathname* nil
62  "The defaulted pathname of the file currently being compiled, or NIL if not
63  compiling.") ; pathname of src arg to COMPILE-FILE
64(defvar *compile-file-truename* nil
65  "The TRUENAME of the file currently being compiled, or NIL if not
66  compiling.") ; truename ...
67(defvar *fasl-target* (backend-name *host-backend*))
68(defvar *fasl-backend* *host-backend*)
69(defvar *fasl-host-big-endian*
70  (arch::target-big-endian (backend-target-arch *host-backend*)))
71(defvar *fasl-target-big-endian* *fasl-host-big-endian*)
72(defvar *fcomp-external-format* :default)
73
74(defvar *fasl-break-on-program-errors* :defer
75  "Controls what happens when the compiler detects PROGRAM-ERROR's during file compilation.
76
77  If T, the compiler signals an error immediately when it detects the program-error.
78
79  If :DEFER, program errors are reported as compiler warnings, and in addition, an error
80    is signalled at the end of file compilation.  This allows all warnings for the file
81    to be reported, but prevents the creation of a fasl file.
82
83  If NIL, program errors are treated the same as any other error condition detected by
84   the compiler, i.e. they are reported as compiler warnings and do not cause any
85   error to be signalled at compile time.")
86 
87
88(defvar *compile-print* nil ; Might wind up getting called *compile-FILE-print*
89  "The default for the :PRINT argument to COMPILE-FILE.")
90
91;Note: errors need to rebind this to NIL if they do any reading without
92; unwinding the stack!
93(declaim (special *compiling-file*)) ; defined in l1-init.
94
95(defvar *fasl-source-file* nil "Name of file currently being read from.
96Will differ from *compiling-file* during an INCLUDE")
97
98(defparameter *fasl-package-qualified-symbols* '(*loading-file-source-file* set-package %define-package)
99  "These symbols are always fasdumped with full package qualification.")
100
101(defun setup-target-features (backend features)
102  (if (eq backend *host-backend*)
103    features
104    (let* ((new nil)
105           (nope (backend-target-specific-features *host-backend*)))
106      (dolist (f features)
107        (unless (memq f nope) (pushnew f new)))
108      (dolist (f (backend-target-specific-features backend)
109               (progn (pushnew :cross-compiling new) new))
110        (pushnew f new)))))
111
112(defun compile-file-pathname (pathname &rest ignore &key output-file &allow-other-keys)
113  "Return a pathname describing what file COMPILE-FILE would write to given
114   these arguments."
115  (declare (ignore ignore))
116  (setq pathname (merge-pathnames pathname))
117  (merge-pathnames (if output-file
118                     (merge-pathnames output-file *.fasl-pathname*)
119                     *.fasl-pathname*) 
120                   pathname))
121
122(defun compile-file (src &key output-file
123                         (verbose *compile-verbose*)
124                         (print *compile-print*)
125                         load
126                         (features nil features-p)
127                         (target *fasl-target* target-p)
128                         (save-local-symbols *fasl-save-local-symbols*)
129                         (save-doc-strings *fasl-save-doc-strings*)
130                         (save-definitions *fasl-save-definitions*)
131                         (save-source-locations *save-source-locations*)
132                         (external-format :default)
133                         force
134                         ;; src may be a temp file with a section of the real source,
135                         ;; then this is the real source file name.
136                         compile-file-original-truename
137                         (compile-file-original-buffer-offset 0)
138                         (break-on-program-errors (if compile-file-original-truename
139                                                    t  ;; really SLIME being interactive...
140                                                    *fasl-break-on-program-errors*))
141                         (load-preserves-optimization-settings *load-preserves-optimization-settings*))
142  "Compile SRC, producing a corresponding fasl file and returning its filename."
143  (let* ((backend *target-backend*)
144         (symbols ())
145         (values ())
146         (*load-preserves-optimization-settings* load-preserves-optimization-settings))
147    (when (and target-p (not (setq backend (find-backend target))))
148      (warn "Unknown :TARGET : ~S.  Reverting to ~s ..." target *fasl-target*)
149      (setq target *fasl-target*  backend *target-backend*))
150    (if (eq *target-backend* *host-backend*)
151      (when features-p
152        (setq symbols '(*features*)
153              values (list (append (if (listp features) features (list features)) *features*))))
154      (setq symbols '(*features*)
155            values (list (setup-target-features *target-backend* *features*))
156            save-source-locations nil))
157    (multiple-value-bind (output-file truename warnings-p serious-p)
158        (loop
159          (restart-case
160              (return (progv symbols values
161                        (%compile-file src output-file verbose print
162                                       save-local-symbols save-doc-strings save-definitions
163                                       save-source-locations break-on-program-errors
164                                       force backend external-format
165                                       compile-file-original-truename compile-file-original-buffer-offset)))
166            (retry-compile-file ()
167              :report (lambda (stream) (format stream "Retry compiling ~s" src))
168              nil)
169            (skip-compile-file ()
170              :report (lambda (stream)
171                        (if load
172                          (format stream "Skip compiling and loading ~s" src)
173                          (format stream "Skip compiling ~s" src)))
174              (return-from compile-file))))
175      (when load (load output-file :verbose (or verbose *load-verbose*)))
176      (values truename warnings-p serious-p))))
177
178
179(defvar *fasl-compile-time-env* nil)
180
181(defun %compile-file (src output-file verbose print
182                          save-local-symbols save-doc-strings save-definitions
183                          save-source-locations break-on-program-errors
184                          force target-backend external-format
185                          compile-file-original-truename compile-file-original-buffer-offset)
186  (let* ((orig-src (merge-pathnames src))
187         (output-default-type (backend-target-fasl-pathname target-backend))
188         (*fasl-non-style-warnings-signalled-p* nil)
189         (*fasl-warnings-signalled-p* nil))
190    (setq src (fcomp-find-file orig-src))
191    (let* ((newtype (pathname-type src)))
192      (when (and newtype (not (pathname-type orig-src)))
193        (setq orig-src (merge-pathnames orig-src (make-pathname :type newtype :defaults nil)))))
194    (setq output-file (merge-pathnames
195                       (if output-file  ; full-pathname in case output-file is relative
196                         (full-pathname (merge-pathnames output-file output-default-type) :no-error nil) 
197                         output-default-type)
198                       orig-src))
199    ;; This should not be necessary, but it is.
200    (setq output-file (namestring output-file))
201    (when (physical-pathname-p orig-src) ; only back-translate to things likely to exist at load time
202      (setq orig-src (back-translate-pathname orig-src '("home" "ccl"))))
203    (when (and (not force)
204               (probe-file output-file)
205               (not (fasl-file-p output-file)))
206      (cerror "overwrite it anyway"
207              "Compile destination ~S is not a ~A file!"
208              output-file (pathname-type
209                           (backend-target-fasl-pathname
210                            *target-backend*))))
211    (let* ((*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ...
212           (*fasl-save-local-symbols* save-local-symbols)
213           (*save-source-locations* save-source-locations)
214           (*fasl-save-doc-strings* save-doc-strings)
215           (*fasl-save-definitions* save-definitions)
216           (*fasl-break-on-program-errors* break-on-program-errors)
217           (*fcomp-warnings-header* nil)
218           (*compile-file-pathname* orig-src)
219           (*compile-file-truename* (truename src))
220           (*package* *package*)
221           (*readtable* *readtable*)
222           (*compile-print* print)
223           (*compile-verbose* verbose)
224           (*fasl-target* (backend-name target-backend))
225           (*fasl-backend* target-backend)
226           (*fasl-target-big-endian* (arch::target-big-endian
227                                      (backend-target-arch target-backend)))
228           (*target-ftd* (backend-target-foreign-type-data target-backend))
229           (defenv (new-definition-environment))
230           (lexenv (new-lexical-environment defenv))
231           (*fasl-compile-time-env* (new-lexical-environment (new-definition-environment)))
232           (*fcomp-external-format* (if (eq external-format :default)
233                                      :inferred
234                                      external-format))
235           (forms nil))
236      (let ((current *outstanding-deferred-warnings*) last)
237        (when (and current
238                   (setq last (deferred-warnings.last-file current))
239                   (equalp *compile-file-pathname* (cdr last)))
240          ;; Discard previous deferred warnings when recompiling exactly the same file again,
241          ;; since most likely this is due to an interactive "retry compilation" request and
242          ;; we want to avoid duplicate warnings.
243          (setf (deferred-warnings.last-file current) nil)))
244
245      (let* ((*outstanding-deferred-warnings* (%defer-warnings nil)))
246        (rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
247        (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))
248
249        (setq forms (fcomp-file src
250                                (or compile-file-original-truename (namestring orig-src))
251                                compile-file-original-buffer-offset
252                                lexenv))
253
254        (setf (deferred-warnings.warnings *outstanding-deferred-warnings*) 
255              (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*)))
256        (when *compile-verbose* (fresh-line))
257        (multiple-value-bind (any harsh) (report-deferred-warnings *compile-file-pathname*)
258          (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any)
259                *fasl-non-style-warnings-signalled-p* (if (eq harsh :very) :very
260                                                        (or *fasl-non-style-warnings-signalled-p* harsh)))))
261      (when (and *fasl-break-on-program-errors* (eq *fasl-non-style-warnings-signalled-p* :very))
262        (cerror "create the output file despite the errors"
263                "Serious errors encountered during compilation of ~s"
264                src))
265      (fasl-scan-forms-and-dump-file forms output-file lexenv)
266      (values output-file
267              (truename (pathname output-file)) 
268              *fasl-warnings-signalled-p* 
269              (and *fasl-non-style-warnings-signalled-p* t)))))
270
271(defvar *fcomp-locked-hash-tables*)
272(defvar *fcomp-load-forms-environment* nil)
273
274; This is separated out so that dump-forms-to-file can use it
275(defun fasl-scan-forms-and-dump-file (forms output-file &optional env)
276  (let ((*fcomp-locked-hash-tables* nil)
277        (*fcomp-load-forms-environment* env))
278    (unwind-protect
279      (multiple-value-bind (hash gnames goffsets) (fasl-scan forms)
280        (fasl-dump-file gnames goffsets forms hash output-file))
281      (fasl-unlock-hash-tables))))
282
283#-bccl
284(defun nfcomp (src &optional dest &rest keys)
285  (when (keywordp dest) (setq keys (cons dest keys) dest nil))
286  (apply #'compile-file src :output-file dest keys))
287
288#-bccl
289(%fhave 'fcomp #'nfcomp)
290
291(defparameter *default-file-compilation-policy* (new-compiler-policy))
292
293(defun current-file-compiler-policy ()
294  *default-file-compilation-policy*)
295
296(defun set-current-file-compiler-policy (&optional new-policy)
297  (setq *default-file-compilation-policy* 
298        (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy))))
299
300(defparameter *compile-time-evaluation-policy*
301  (new-compiler-policy :force-boundp-checks t))
302
303(defun %compile-time-eval (form env)
304  (declare (ignore env))
305  (let* ((*target-backend* *host-backend*)
306         (*loading-toplevel-location* (or (fcomp-source-note form)
307                                          *loading-toplevel-location*))
308         (lambda `(lambda () ,form)))
309    (fcomp-note-source-transformation form lambda)
310    ;; The HANDLER-BIND here is supposed to note WARNINGs that're
311    ;; signaled during (eval-when (:compile-toplevel) processing; this
312    ;; in turn is supposed to satisfy a pedantic interpretation of the
313    ;; spec's requirement that COMPILE-FILE's second and third return
314    ;; values reflect (all) conditions "detected by the compiler."
315    ;; (It's kind of sad that CL language design is influenced so
316    ;; strongly by the views of pedants these days.)
317    (handler-bind ((warning (lambda (c)
318                              (setq *fasl-warnings-signalled-p* t)
319                              (unless (typep c 'style-warning)
320                                (setq *fasl-non-style-warnings-signalled-p* t))
321                              (signal c))))
322      (funcall (compile-named-function
323                lambda
324                :compile-code-coverage nil
325                :source-notes *fcomp-source-note-map*
326                :env *fasl-compile-time-env*
327                :policy *compile-time-evaluation-policy*)))))
328
329
330;;; No methods by default, not even for structures.  This really sux.
331(defgeneric make-load-form (object &optional environment))
332
333;;; Well, no usable methods by default.  How this is better than
334;;; getting a NO-APPLICABLE-METHOD error frankly escapes me,
335;;; [Hint: this is called even when there is an applicable method]
336(defun no-make-load-form-for (object)
337  (error "No ~S method is defined for ~s" 'make-load-form object))
338
339(defmethod make-load-form ((s standard-object) &optional environment)
340  (declare (ignore environment))
341  (no-make-load-form-for s))
342
343(defmethod make-load-form ((s structure-object) &optional environment)
344  (declare (ignore environment))
345  (no-make-load-form-for s))
346
347(defmethod make-load-form ((c condition) &optional environment)
348  (declare (ignore environment))
349  (no-make-load-form-for c))
350
351(defmethod make-load-form ((c class) &optional environment)
352  (let* ((name (class-name c))
353         (found (if name (find-class name nil environment))))
354    (if (eq found c)
355      `(find-class ',name)
356      (error "Class ~s does not have a proper name." c))))
357
358
359;;;;          FCOMP-FILE - read & compile file
360;;;;          Produces a list of (opcode . args) to run on loading, intermixed
361;;;;          with read packages.
362
363(defparameter *fasl-eof-forms* nil)
364
365(defparameter cfasl-load-time-eval-sym (make-symbol "LOAD-TIME-EVAL"))
366(%macro-have cfasl-load-time-eval-sym
367    #'(lambda (call env) (declare (ignore env)) (list 'eval (list 'quote call))))
368;Make it a constant so compiler will barf if try to bind it, e.g. (LET #,foo ...)
369(define-constant cfasl-load-time-eval-sym cfasl-load-time-eval-sym)
370
371
372(defparameter *reading-for-cfasl* nil "Used by the reader for #,")
373
374
375
376(declaim (special *nx-compile-time-types*
377;The following are the global proclaimed values.  Since compile-file binds
378;them, this means you can't ever globally proclaim these things from within a
379;file compile (e.g. from within eval-when compile, or loading a file) - the
380;proclamations get lost when compile-file exits.  This is sort of intentional
381;(or at least the set of things which fall in this category as opposed to
382;having a separate compile-time variable is sort of intentional).
383                    *nx-proclaimed-inline*    ; inline and notinline
384                    *nx-proclaimed-ignore*    ; ignore and unignore
385                    *nx-known-declarations*   ; declaration
386                    *nx-speed*                ; optimize speed
387                    *nx-space*                ; optimize space
388                    *nx-safety*               ; optimize safety
389                    *nx-cspeed*))             ; optimize compiler-speed
390
391(defvar *fcomp-load-time*)
392(defvar *fcomp-inside-eval-always* nil)
393(defvar *fcomp-eval-always-functions* nil)   ; used by the LISP package
394(defvar *fcomp-output-list*)
395(defvar *fcomp-toplevel-forms*)
396(defvar *fcomp-source-note-map* nil)
397(defvar *fcomp-loading-toplevel-location*)
398(defvar *fcomp-warnings-header*)
399(defvar *fcomp-stream-position* nil)
400(defvar *fcomp-previous-position* nil)
401(defvar *fcomp-indentation*)
402(defvar *fcomp-print-handler-plist* nil)
403(defvar *fcomp-last-compile-print*
404  '(INCLUDE (NIL . T)
405    DEFSTRUCT ("Defstruct" . T) 
406    DEFCONSTANT "Defconstant" 
407    DEFSETF "Defsetf" 
408    DEFTYPE "Deftype" 
409    DEFCLASS "Defclass" 
410    DEFGENERIC "Defgeneric"
411    DEFMETHOD "Defmethod"
412    DEFMACRO "Defmacro" 
413    DEFPARAMETER "Defparameter" 
414    DEFVAR "Defvar" 
415    DEFUN ""))
416
417(setf (getf *fcomp-print-handler-plist* 'defun) ""
418      (getf *fcomp-print-handler-plist* 'defvar) "Defvar"
419      (getf *fcomp-print-handler-plist* 'defparameter) "Defparameter"
420      (getf *fcomp-print-handler-plist* 'defmacro) "Defmacro"
421      (getf *fcomp-print-handler-plist* 'defmethod) "Defmethod"  ; really want more than name (use the function option)
422      (getf *fcomp-print-handler-plist* 'defgeneric) "Defgeneric"
423      (getf *fcomp-print-handler-plist* 'defclass) "Defclass"
424      (getf *fcomp-print-handler-plist* 'deftype) "Deftype"
425      (getf *fcomp-print-handler-plist* 'defsetf) "Defsetf"
426      (getf *fcomp-print-handler-plist* 'defconstant) "Defconstant"
427      (getf *fcomp-print-handler-plist* 'defstruct) '("Defstruct" . t)
428      (getf *fcomp-print-handler-plist* 'include) '(nil . t))
429
430
431(defun fcomp-file (filename orig-file orig-offset env)  ; orig-file is back-translated
432  (let* ((*package* *package*)
433         (*compiling-file* filename)
434         (*nx-compile-time-types* *nx-compile-time-types*)
435         (*nx-proclaimed-inline* *nx-proclaimed-inline*)
436         (*nx-known-declarations* *nx-known-declarations*)
437         (*nx-proclaimed-ignore* *nx-proclaimed-ignore*)
438         (*nx-speed* *nx-speed*)
439         (*nx-space* *nx-space*)
440         (*nx-debug* *nx-debug*)
441         (*nx-safety* *nx-safety*)
442         (*nx-cspeed* *nx-cspeed*)
443         (*fcomp-load-time* t)
444         (*fcomp-output-list* nil)
445         (*fcomp-indentation* 0)
446         (*fcomp-last-compile-print* (cons nil (cons nil nil))))
447    (push (list $fasl-platform (backend-target-platform *fasl-backend*)) *fcomp-output-list*)
448    (fcomp-read-loop filename orig-file orig-offset env :not-compile-time)
449    (nreverse *fcomp-output-list*)))
450
451(defun fcomp-find-file (file &aux path)
452  (unless (or (and (setq path (probe-file file))
453                   (not (directoryp path)))
454              (setq path (probe-file (merge-pathnames file *.lisp-pathname*))))
455    (error 'file-error :pathname file :error-type "File ~S not found"))
456  (namestring path))
457
458;;; orig-file is back-translated when from fcomp-file
459;;; when from fcomp-include it's included filename merged with *compiling-file*
460;;; which is not back translated
461(defun fcomp-read-loop (filename orig-file orig-offset env processing-mode)
462  (when *compile-verbose*
463    (format t "~&;~A ~S..."
464            (if (eq filename *compiling-file*) "Compiling" " Including")
465            filename))
466  (with-open-file (stream filename
467                          :element-type 'base-char
468                          :external-format *fcomp-external-format*)
469    (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-file*))
470           (*fasl-source-file* (or orig-file filename))
471           (*fcomp-toplevel-forms* nil)
472           (*fasl-eof-forms* nil)
473           (*loading-file-source-file* orig-file)
474           (*fcomp-source-note-map* (and (or *save-source-locations* *compile-code-coverage*)
475                                         (make-hash-table :test #'eq :shared nil)))
476           (*loading-toplevel-location* nil)
477           (*fcomp-loading-toplevel-location* nil)
478           (eofval (cons nil nil))
479           (read-package nil)
480           form)
481
482      (fcomp-output-form $fasl-src env *loading-file-source-file*)
483      (let* ((*fcomp-previous-position* nil))
484        (loop
485          (let* ((*fcomp-stream-position* (file-position stream))
486                 (*nx-warnings* nil)) ;; catch any warnings from :compile-toplevel forms
487            (when (and *fcomp-stream-position* orig-offset)
488              (incf *fcomp-stream-position* orig-offset))
489            (unless (eq read-package *package*)
490              (fcomp-compile-toplevel-forms env)
491              (setq read-package *package*))
492            (let ((*reading-for-cfasl*
493                   (and *fcomp-load-time* cfasl-load-time-eval-sym)))
494              (declare (special *reading-for-cfasl*))
495              (let ((pos (file-position stream)))
496                (handler-bind
497                    ((error #'(lambda (c) ; we should distinguish read errors from others?
498                                (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename)
499                                (signal c))))
500                  (multiple-value-setq (form *loading-toplevel-location*)
501                    (read-recording-source stream
502                                           :eofval eofval
503                                           :file-name *loading-file-source-file*
504                                           :start-offset orig-offset
505                                           :map *fcomp-source-note-map*
506                                           :save-source-text (neq *save-source-locations* :no-text))))))
507            (when (eq eofval form)
508              (require-type *loading-toplevel-location* 'null)
509              (return))
510            (fcomp-form form env processing-mode)
511            (fcomp-signal-or-defer-warnings *nx-warnings* env)
512            (setq *fcomp-previous-position* *fcomp-stream-position*))))
513      (when *compile-code-coverage*
514        (fcomp-compile-toplevel-forms env)
515        (let* ((fns (fcomp-code-covered-functions))
516               (v (nreverse (coerce fns 'vector)))
517               (id (fcomp-file-checksum stream)))
518          (map nil #'fcomp-digest-code-notes v)
519          (fcomp-random-toplevel-form `(register-code-covered-functions ',v
520                                                                        ',*fcomp-external-format*
521                                                                        ,id)
522                                      env)))
523      (while (setq form *fasl-eof-forms*)
524        (setq *fasl-eof-forms* nil)
525        (fcomp-form-list form env processing-mode))
526      (when old-file
527        (fcomp-output-form $fasl-src env (namestring *compile-file-pathname*)))
528      (fcomp-compile-toplevel-forms env))))
529
530(defvar *crc32-table* (let ((crc-table (make-array 256 :element-type '(unsigned-byte 32))))
531                        (loop for i from 0 below 255 as crc = i
532                              do (loop for j from 0 below 8
533                                       do (setq crc (ash crc -1))
534                                       do (when (oddp crc)
535                                            (setq crc (logxor crc  #xEDB88320))))
536                              do (setf (aref crc-table i) crc))
537                        crc-table))
538(declaim (type (simple-array (unsigned-byte 32) (256)) *crc32-table*))
539
540(defun fcomp-stream-checksum (stream)
541  ;; Could consider crc16 for 32-bit targets, but this is only used with code
542  ;; coverage so don't worry about efficiency anyway.
543  (file-position stream 0)
544  (let ((crc 0))
545    (declare (type (unsigned-byte 32) crc))
546    (loop for char base-char = (read-char stream nil) while char
547          do (setq crc (logxor
548                         (%ilogand (ash crc -8) #x00FFFFFF)
549                         (aref *crc32-table* (logand (logxor crc (char-code char)) #xFF)))))
550    (logior (ash (file-position stream) 32) crc)))
551
552(defun fcomp-file-checksum (filename &key (external-format *fcomp-external-format*))
553  (when (setq filename (probe-file filename))
554    (with-open-file (stream filename
555                            :element-type 'base-char
556                            :external-format external-format)
557      (fcomp-stream-checksum stream))))
558
559(defun fcomp-code-covered-functions ()
560  (loop for op in *fcomp-output-list*
561        when (consp op)
562          nconc (if (eq (car op) $fasl-lfuncall)
563                  ;; Don't collect the toplevel lfun itself, it leads to spurious markings.
564                  ;; Instead, descend one level and collect any referenced fns.
565                  (destructuring-bind (fn) (cdr op)
566                    (lfunloop for imm in fn when (functionp imm) collect imm))
567                  (loop for arg in (cdr op) when (functionp arg) collect arg))))
568
569
570(defun fcomp-form (form env processing-mode
571                        &aux print-stuff 
572                        (load-time (and processing-mode (neq processing-mode :compile-time)))
573                        (compile-time-too (or (eq processing-mode :compile-time) 
574                                              (eq processing-mode :compile-time-too))))
575  (let* ((*fcomp-indentation* *fcomp-indentation*)
576         (*compile-print* *compile-print*))
577    (when *compile-print*
578      (cond ((and (consp form) (setq print-stuff (getf *fcomp-print-handler-plist* (car form))))
579             (rplaca (rplacd (cdr *fcomp-last-compile-print*) nil) nil)
580             (rplaca *fcomp-last-compile-print* nil)         
581             (let ((print-recurse nil))
582               (when (consp print-stuff)
583                 (setq print-recurse (cdr print-stuff) print-stuff (car print-stuff)))
584               (cond ((stringp print-stuff)
585                      (if (equal print-stuff "")
586                        (format t "~&~vT~S~%" *fcomp-indentation* (second form))
587                        (format t "~&~vT~S [~A]~%" *fcomp-indentation* (second form) print-stuff)))
588                     ((not (null print-stuff))
589                      (format t "~&~vT" *fcomp-indentation*)
590                      (funcall print-stuff form *standard-output*)
591                      (terpri *standard-output*)))
592               (if print-recurse
593                 (setq *fcomp-indentation* (+ *fcomp-indentation* 4))
594                 (setq *compile-print* nil))))
595            (t (unless (and (eq load-time (car *fcomp-last-compile-print*))
596                            (eq compile-time-too (cadr *fcomp-last-compile-print*))
597                            (eq *fcomp-indentation* (cddr *fcomp-last-compile-print*)))
598                 (rplaca *fcomp-last-compile-print* load-time)
599                 (rplaca (rplacd (cdr *fcomp-last-compile-print*) compile-time-too) *fcomp-indentation*)
600                 (format t "~&~vTToplevel Forms...~A~%"
601                         *fcomp-indentation*
602                         (if load-time
603                           (if compile-time-too
604                             "  (Compiletime, Loadtime)"
605                             "")
606                           (if compile-time-too
607                             "  (Compiletime)"
608                             "")))))))
609    (fcomp-form-1 form env processing-mode)))
610
611(defun fcomp-form-1 (form env processing-mode &aux sym body)
612  (if (consp form) (setq sym (%car form) body (%cdr form)))
613  (case sym
614    (progn (fcomp-form-list body env processing-mode))
615    (eval-when (fcomp-eval-when form env processing-mode))
616    (compiler-let (fcomp-compiler-let form env processing-mode))
617    (locally (fcomp-locally form env processing-mode))
618    (macrolet (fcomp-macrolet form env processing-mode))
619    (symbol-macrolet (fcomp-symbol-macrolet form env processing-mode))
620    ((%include include) (fcomp-include form env processing-mode))
621    (t
622     ;;Need to macroexpand to see if get more progn's/eval-when's and so should
623     ;;stay at toplevel.  But don't expand if either the evaluator or the
624     ;;compiler might not - better safe than sorry...
625     ;; Good advice, but the hard part is knowing which is which.
626     (cond 
627       ((and (non-nil-symbol-p sym)
628             (macro-function sym env)
629             (not (compiler-macro-function sym env))
630             (not (eq sym '%defvar-init)) ;  a macro that we want to special-case
631             (multiple-value-bind (new win) (fcomp-macroexpand-1 form env)
632               (if win (setq form new))
633               win))
634        (fcomp-form form env processing-mode))
635       ((and (not *fcomp-inside-eval-always*)
636             (memq sym *fcomp-eval-always-functions*))
637        (let* ((*fcomp-inside-eval-always* t)
638               (new `(eval-when (:execute :compile-toplevel :load-toplevel) ,form)))
639          (fcomp-form-1 new env processing-mode)))
640       (t
641        (when (or (eq processing-mode :compile-time) (eq processing-mode :compile-time-too))
642          (%compile-time-eval form env))
643        (when (and processing-mode (neq processing-mode :compile-time))
644          (case sym
645            ((%defconstant) (fcomp-load-%defconstant form env))
646            ((%defparameter) (fcomp-load-%defparameter form env))
647            ((%defvar %defvar-init) (fcomp-load-defvar form env))
648            ((%defun) (fcomp-load-%defun form env))
649            ((set-package %define-package)
650             (fcomp-random-toplevel-form form env)
651             (fcomp-compile-toplevel-forms env))
652            ((%macro) (fcomp-load-%macro form env))
653            ;; ((%deftype) (fcomp-load-%deftype form))
654            ;; ((define-setf-method) (fcomp-load-define-setf-method form))
655            (t (fcomp-random-toplevel-form form env)))))))))
656
657(defun fcomp-form-list (forms env processing-mode)
658  (let* ((outer *loading-toplevel-location*))
659    (dolist (form forms)
660      (setq *loading-toplevel-location* (or (fcomp-source-note form) outer))
661      (fcomp-form form env processing-mode))
662    (setq *loading-toplevel-location* outer)))
663
664(defun fcomp-compiler-let (form env processing-mode &aux vars varinits (body (%cdr form)))
665  (fcomp-compile-toplevel-forms env)
666  (dolist (pair (car body))
667    (push (nx-pair-name pair) vars)
668    (push (%compile-time-eval (nx-pair-initform pair) env) varinits))
669  (progv (nreverse vars) (nreverse varinits)
670    (fcomp-form-list (cdr body) env processing-mode)
671    (fcomp-compile-toplevel-forms env)))
672
673(defun fcomp-locally (form env processing-mode &aux (body (%cdr form)))
674  (fcomp-compile-toplevel-forms env)
675  (multiple-value-bind (body decls) (parse-body body env)
676    (let* ((decl-specs (decl-specs-from-declarations decls))
677           (env (augment-environment env :declare decl-specs))
678           (*fasl-compile-time-env* (augment-environment *fasl-compile-time-env*
679                                                         :declare decl-specs)))
680      (fcomp-form-list body env processing-mode)
681      (fcomp-compile-toplevel-forms env))))
682
683(defun fcomp-macrolet (form env processing-mode &aux (body (%cdr form)))
684  (fcomp-compile-toplevel-forms env)
685  (flet ((augment-with-macros (e defs)
686           (augment-environment e
687                                :macro
688                                (mapcar #'(lambda (m)
689                                            (destructuring-bind (name arglist &body body) m
690                                              (list name (enclose (parse-macro name arglist body env)
691                                                                  e))))
692                                        defs))))
693           
694    (let* ((macros (car body))
695           (outer-env (augment-with-macros env macros)))
696      (multiple-value-bind (body decls) (parse-body (cdr body) outer-env)
697        (let* ((decl-specs (decl-specs-from-declarations decls))
698               (env (augment-environment 
699                     outer-env
700                     :declare decl-specs))
701               (*fasl-compile-time-env* (augment-environment
702                                         (augment-with-macros
703                                          *fasl-compile-time-env*
704                                          macros)
705                                         :declare decl-specs)))
706          (fcomp-form-list body env processing-mode)
707          (fcomp-compile-toplevel-forms env))))))
708
709(defun fcomp-symbol-macrolet (form env processing-mode &aux (body (%cdr form)))
710  (fcomp-compile-toplevel-forms env)
711  (let* ((defs (car body))
712         (outer-env (augment-environment env :symbol-macro defs)))
713    (multiple-value-bind (body decls) (parse-body (cdr body) env)
714      (let* ((decl-specs (decl-specs-from-declarations decls))
715             (env (augment-environment outer-env 
716                                       :declare decl-specs))
717             (*fasl-compile-time-env* (augment-environment *fasl-compile-time-env*
718                                                           :symbol-macro defs
719                                                           :declare decl-specs)))
720        (fcomp-form-list body env processing-mode)
721        (fcomp-compile-toplevel-forms env)))))
722
723(defun fcomp-eval-when (form env processing-mode &aux (body (%cdr form)) (eval-times (pop body)))
724  (let* ((compile-time-too  (eq processing-mode :compile-time-too))
725         (compile-time-only (eq processing-mode :compile-time))
726         (at-compile-time nil)
727         (at-load-time nil)
728         (at-eval-time nil))
729    (dolist (when eval-times)
730      (if (or (eq when 'compile) (eq when :compile-toplevel))
731        (setq at-compile-time t)
732        (if (or (eq when 'eval) (eq when :execute))
733          (setq at-eval-time t)
734          (if (or (eq when 'load) (eq when :load-toplevel))
735            (setq at-load-time t)
736            (warn "Unknown EVAL-WHEN time ~s in ~S while compiling ~S."
737                  when eval-times *fasl-source-file*)))))
738    (fcomp-compile-toplevel-forms env)        ; always flush the suckers
739    (cond (compile-time-only
740           (if at-eval-time (fcomp-form-list body env :compile-time)))
741          (at-load-time
742           (fcomp-form-list body env (if (or at-compile-time (and at-eval-time compile-time-too))
743                                       :compile-time-too
744                                       :not-compile-time)))
745          ((or at-compile-time (and at-eval-time compile-time-too))
746           (fcomp-form-list body env :compile-time))))
747  (fcomp-compile-toplevel-forms env))
748
749(defun fcomp-include (form env processing-mode &aux file)
750  (fcomp-compile-toplevel-forms env)
751  (verify-arg-count form 1 1)
752  (setq file (nx-transform (%cadr form) env))
753  (unless (constantp file) (report-bad-arg file '(or string pathname)))
754  (let ((actual (merge-pathnames (eval-constant file)
755                                 (directory-namestring *compiling-file*))))
756    (when *compile-print* (format t "~&~vTIncluding file ~A~%" *fcomp-indentation* actual))
757    (let ((*fcomp-indentation* (+ 4 *fcomp-indentation*))
758          (*package* *package*))
759      (fcomp-read-loop (fcomp-find-file actual) actual 0 env processing-mode)
760      (fcomp-output-form $fasl-src env *loading-file-source-file*))
761    (when *compile-print* (format t "~&~vTFinished included file ~A~%" *fcomp-indentation* actual))))
762
763(defun define-compile-time-constant (symbol initform env)
764  (note-variable-info symbol t env)
765  (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*))
766        (definition-env (definition-environment env)))
767    (when (or compile-time-defenv definition-env)
768      (multiple-value-bind (value error) 
769                           (ignore-errors (values (%compile-time-eval initform env) nil))
770        (when error
771          (warn "Compile-time evaluation of DEFCONSTANT initial value form for ~S while ~
772                 compiling ~S signalled the error: ~&~A" symbol *fasl-source-file* error))
773        (let ((cell (cons symbol (if error (%unbound-marker-8) value))))
774          (when definition-env
775            (push cell (defenv.constants definition-env)))
776          (when compile-time-defenv
777            (push cell (defenv.constants compile-time-defenv))))))
778    symbol))
779
780(defun fcomp-load-%defconstant (form env)
781  (destructuring-bind (sym valform &optional doc) (cdr form)
782    (unless *fasl-save-doc-strings*
783      (setq doc nil))
784    (if (quoted-form-p sym)
785      (setq sym (%cadr sym)))
786    (if (and (typep sym 'symbol) (or (quoted-form-p valform) (self-evaluating-p valform)))
787      (fcomp-output-form $fasl-defconstant env sym (eval-constant valform) (eval-constant doc))
788      (fcomp-random-toplevel-form form env))))
789
790(defun fcomp-load-%defparameter (form env)
791  (destructuring-bind (sym valform &optional doc) (cdr form)
792    (unless *fasl-save-doc-strings*
793      (setq doc nil))
794    (if (quoted-form-p sym)
795      (setq sym (%cadr sym)))
796    (let* ((sym-p (typep sym 'symbol))
797           (fn (and sym-p (fcomp-function-arg valform env))))
798      (if (and sym-p (or fn (constantp valform)))
799        (fcomp-output-form $fasl-defparameter env sym (or fn (eval-constant valform)) (eval-constant doc))
800        (fcomp-random-toplevel-form form env)))))
801
802; Both the simple %DEFVAR and the initial-value case (%DEFVAR-INIT) come here.
803; Only try to dump this as a special fasl operator if the initform is missing
804;  or is "harmless" to evaluate whether needed or not (constant or function.)
805; Hairier initforms could be handled by another fasl operator that takes a thunk
806; and conditionally calls it.
807(defun fcomp-load-defvar (form env)
808  (destructuring-bind (sym &optional (valform nil val-p) doc) (cdr form)
809    (unless *fasl-save-doc-strings*
810      (setq doc nil))
811    (if (quoted-form-p sym)             ; %defvar quotes its arg, %defvar-init doesn't.
812      (setq sym (%cadr sym)))
813    (let* ((sym-p (typep sym 'symbol)))
814      (if (and sym-p (not val-p))
815        (fcomp-output-form $fasl-defvar env sym)
816        (let* ((fn (if sym-p (fcomp-function-arg valform env))))
817          (if (and sym-p (or fn (constantp valform)))
818            (fcomp-output-form $fasl-defvar-init env sym (or fn (eval-constant valform)) (eval-constant doc))
819            (fcomp-random-toplevel-form form env)))))))
820     
821(defun define-compile-time-macro (name lambda-expression env)
822  (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*))
823        (definition-env (definition-environment env)))
824    (when (or definition-env compile-time-defenv)
825      (let ((cell (list* name 
826                         'macro 
827                         (compile-named-function lambda-expression :name name :env env))))
828        (when compile-time-defenv
829          (push cell (defenv.functions compile-time-defenv)))
830        (when definition-env
831          (push cell (defenv.functions definition-env))))
832      (record-function-info name (%cons-def-info 'defmacro) env))
833    name))
834
835(defun define-compile-time-symbol-macro (name expansion env)
836  (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*))
837        (definition-env (definition-environment env)))
838    (let* ((info (variable-information name env)))
839      (when (or (eq info :special)
840                (eq info :constant))
841        (signal-program-error "Can't define ~s as a symbol-macro; already defined as a ~a." name (string-downcase info))))
842    (when (or definition-env compile-time-defenv)
843      (let ((cell (cons name expansion)))
844        (when compile-time-defenv
845          (push cell (defenv.symbol-macros compile-time-defenv)))
846        (when definition-env
847          (push cell (defenv.symbol-macros definition-env)))))
848    name))
849
850
851(defun fcomp-proclaim-type (type syms env)
852  (if (every #'symbolp syms)
853    (progn
854      (specifier-type-if-known type env :whine t)
855      (dolist (sym syms)
856        (push (cons sym type) *nx-compile-time-types*)))
857    (nx-bad-decls `(,type ,@syms))))
858
859(defun compile-time-proclamation (specs env &aux  sym (defenv (definition-environment env)))
860  (when defenv
861    (dolist (spec specs)
862      (setq sym (pop spec))
863      (case sym
864        (type
865         (fcomp-proclaim-type (car spec) (cdr spec) env))
866        (special
867         (if (every #'symbolp spec)
868           (dolist (sym spec)
869             (push (cons sym nil) (defenv.specials defenv)))
870           (nx-bad-decls `(,sym ,@spec))))
871        (notspecial
872         (if (every #'symbolp spec)
873           (let ((specials (defenv.specials defenv)))
874             (dolist (sym spec (setf (defenv.specials defenv) specials))
875               (let ((pair (assq sym specials)))
876                 (when pair (setq specials (nremove pair specials))))))
877           (nx-bad-decls `(,sym ,@spec))))
878        (optimize
879           (handler-case (%proclaim-optimize spec)
880             (program-error () (nx-bad-decls `(,sym ,@spec)))))
881        (inline
882         (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec)
883           (dolist (sym spec)
884             (push (cons (maybe-setf-function-name sym) (cons 'inline 'inline)) (lexenv.fdecls defenv)))
885           (nx-bad-decls `(,sym ,@spec))))
886        (notinline
887         (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec)
888           (dolist (sym spec)
889             (unless (compiler-special-form-p sym)
890               (push (cons (maybe-setf-function-name sym) (cons 'inline 'notinline)) (lexenv.fdecls defenv))))
891           (nx-bad-decls `(,sym ,@spec))))
892        (declaration
893         (if (every #'symbolp spec)
894           (dolist (sym spec)
895             (pushnew sym *nx-known-declarations*))
896           (nx-bad-decls `(,sym ,@spec))))
897        (ignore
898         (if (every #'symbolp spec)
899           (dolist (sym spec)
900             (push (cons sym t) *nx-proclaimed-ignore*))
901           (nx-bad-decls `(,sym ,@spec))))
902        (unignore
903         (if (every #'symbolp spec)
904           (dolist (sym spec)
905             (push (cons sym nil) *nx-proclaimed-ignore*))
906           (nx-bad-decls `(,sym ,@spec))))
907        (ftype 
908         (let ((ftype (car spec))
909               (fnames (cdr spec)))
910           (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) fnames)
911             (when (specifier-type-if-known ftype env :whine t)
912               ;; ----- this part may be redundant, now that the lexenv.fdecls part is being done
913               (if (and (consp ftype)
914                        (consp fnames)
915                        (eq (%car ftype) 'function))
916                 (dolist (fname fnames)
917                   (note-function-info fname nil env)))
918               (dolist (fname fnames)
919                 (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv))))
920             (nx-bad-decls `(ftype ,@spec)))))
921        (otherwise
922         (unless (memq sym *nx-known-declarations*)
923           ;; Any type name is now (ANSI CL) a valid declaration.
924           (if (specifier-type-if-known sym env)
925             (fcomp-proclaim-type sym spec env)
926             (nx-bad-decls `(,sym ,@spec)))))))))
927
928(defun fcomp-load-%defun (form env)
929  (destructuring-bind (fn &optional doc) (cdr form)
930    (unless *fasl-save-doc-strings*
931      (if (consp doc)
932        (if (and (eq (car doc) 'quote) (consp (cadr doc)))
933          (setf (car (cadr doc)) nil))
934        (setq doc nil)))
935    (when (and (consp fn) (eq (%car fn) 'nfunction))
936      (note-function-info (cadr fn) (caddr fn) env))
937    (if (and (constantp doc)
938             (setq fn (fcomp-function-arg fn env)))
939      (progn
940        (setq doc (eval-constant doc))
941        (fcomp-output-form $fasl-defun env fn doc))
942      (fcomp-random-toplevel-form form env))))
943
944(defun fcomp-load-%macro (form env &aux fn doc)
945  (verify-arg-count form 1 2)
946  (if (and (constantp (setq doc (caddr form)))
947           (setq fn (fcomp-function-arg (cadr form) env)))
948    (progn
949      (setq doc (eval-constant doc))
950      (fcomp-output-form $fasl-macro env fn doc))
951    (fcomp-random-toplevel-form form env)))
952
953(defun define-compile-time-structure (sd refnames predicate env)
954  (let ((defenv (definition-environment env))
955        (class-name (and (not (sd-type sd)) (symbolp (sd-name sd)) (sd-name sd))))
956    (when defenv
957      (when class-name
958        (note-type-info class-name 'class env)
959        (push (make-instance 'compile-time-class :name class-name)
960              (defenv.classes defenv)))
961      (setf (defenv.structures defenv) (alist-adjoin (sd-name sd) sd (defenv.structures defenv)))
962      (let* ((structrefs (defenv.structrefs defenv)))
963        (when (and predicate class-name)
964          (setq structrefs (alist-adjoin predicate class-name structrefs)))
965        (dolist (slot (sd-slots sd))
966          (cond
967            ((fixnump (ssd-name slot))) ;skip
968            ((ssd-inherited slot)
969             (when refnames (pop refnames)))
970            (t
971             (setq structrefs
972                   ;; structrefs isn't a proper alist
973                   (alist-adjoin (if refnames (pop refnames) (ssd-name slot))
974                                 (cons (ssd-type-and-refinfo slot) class-name)
975                                 structrefs)))))
976        (setf (defenv.structrefs defenv) structrefs)))))
977
978(defun fcomp-source-note (form &aux (notes *fcomp-source-note-map*))
979  (and notes (gethash form notes)))
980
981(defun (setf fcomp-source-note) (note form &aux (notes *fcomp-source-note-map*))
982  (and notes (setf (gethash form notes) note)))
983
984(defun fcomp-note-source-transformation (original new)
985  (let* ((*nx-source-note-map* *fcomp-source-note-map*))
986    (nx-note-source-transformation original new)))
987
988(defun fcomp-macroexpand-1 (form env)
989  (handler-bind ((warning (lambda (c)
990                            (nx1-whine :program-error c)
991                            (muffle-warning c)))
992                 (program-error (lambda (c)
993                                  (if *fasl-break-on-program-errors*
994                                    (cerror "continue compilation ignoring this form" c)
995                                    (progn
996                                      (when (typep c 'compile-time-program-error)
997                                        (setq c (make-condition 'simple-program-error
998                                                  :format-control (simple-condition-format-control c)
999                                                  :format-arguments (simple-condition-format-arguments c))))
1000                                      (nx1-whine :program-error c)))
1001                                  (return-from fcomp-macroexpand-1 (values nil t)))))
1002    (let* ((*nx-source-note-map* *fcomp-source-note-map*))
1003      (multiple-value-bind (new win)
1004          (macroexpand-1 form env)
1005        (when win
1006          (nx-note-source-transformation form new))
1007        (values new win)))))
1008
1009(defun fcomp-transform (form env)
1010  (let* ((*nx-source-note-map* *fcomp-source-note-map*))
1011    (nx-transform form env)))
1012
1013
1014(defun fcomp-random-toplevel-form (form env)
1015  (unless (constantp form)
1016    (unless (or (atom form)
1017                (compiler-special-form-p (%car form)))
1018      ;;Pre-compile any lfun args.  This is an efficiency hack, since compiler
1019      ;;reentering itself for inner lambdas tends to be more expensive than
1020      ;;top-level compiles.
1021      ;;This assumes the form has been macroexpanded, or at least none of the
1022      ;;non-evaluated macro arguments could look like functions.
1023      (let ((new-form (make-list (length form))))
1024        (declare (dynamic-extent new-form))
1025        (loop for arg in (%cdr form) for newptr on (%cdr new-form)
1026              do (setf (%car newptr)
1027                       (multiple-value-bind (new win) (fcomp-transform arg env)
1028                         (let ((lfun (fcomp-function-arg new env)))
1029                           (when lfun
1030                             (setq new `',lfun win t)
1031                             (fcomp-note-source-transformation arg new)))
1032                         (if win new arg))))
1033        (unless (every #'eq (%cdr form) (%cdr new-form))
1034          (setf (%car new-form) (%car form))
1035          (fcomp-note-source-transformation form (setq form (copy-list new-form))))))
1036    ;; At some point we will dump the toplevel forms, make sure that when that happens,
1037    ;;; the loading location for this form is stored in *fcomp-loading-toplevel-location*,
1038    ;; because *loading-toplevel-location* will be long gone by then.
1039    (fcomp-ensure-source env)
1040    (push form *fcomp-toplevel-forms*)))
1041
1042(defun fcomp-function-arg (expr env)
1043  (when (consp expr)
1044    (multiple-value-bind (lambda-expr name win)
1045        (cond ((and (eq (%car expr) 'nfunction)
1046                    (lambda-expression-p (cadr (%cdr expr))))
1047               (values (%caddr expr) (%cadr expr) t))
1048              ((and (eq (%car expr) 'function)
1049                    (lambda-expression-p (car (%cdr expr))))
1050               (values (%cadr expr) nil t)))
1051      (when win
1052        (fcomp-named-function lambda-expr name env
1053                              (or (fcomp-source-note expr)
1054                                  (fcomp-source-note lambda-expr)
1055                                  *loading-toplevel-location*))))))
1056
1057(defun fcomp-compile-toplevel-forms (env)
1058  (when *fcomp-toplevel-forms*
1059    (let* ((forms (nreverse *fcomp-toplevel-forms*))
1060           (*fcomp-stream-position* *fcomp-previous-position*)
1061           (*loading-toplevel-location* *fcomp-loading-toplevel-location*)
1062           (body (if T ;; (null (cdr forms))
1063                   `(progn ,@forms)
1064                   `(macrolet ((load-time-value (value)
1065                                 (declare (ignore value))
1066                                 (compiler-function-overflow)))
1067                      ,@forms)))
1068           (lambda `(lambda () ,body)))
1069      ;; Don't assign a location to the lambda so it doesn't confuse acode printing, but
1070      ;; arrange to assign it to any inner lambdas.
1071      (setf (fcomp-source-note body) *loading-toplevel-location*)
1072      (setq *fcomp-toplevel-forms* nil)
1073      ;(format t "~& Random toplevel form: ~s" lambda)
1074      (handler-case (fcomp-output-form
1075                     $fasl-lfuncall
1076                     env
1077                     (fcomp-named-function lambda nil env #|*loading-toplevel-location*|#))
1078        (compiler-function-overflow ()
1079          (if (null (cdr forms))
1080            (error "Form ~s cannot be compiled - size exceeds compiler limitation"
1081                   (%car forms))
1082            ; else compile each half :
1083            (progn
1084              (dotimes (i (floor (length forms) 2))
1085                (declare (fixnum i))
1086                (push (pop forms) *fcomp-toplevel-forms*))
1087              (fcomp-compile-toplevel-forms env)
1088              (setq *fcomp-toplevel-forms* (nreverse forms))
1089              (fcomp-compile-toplevel-forms env))))))))
1090
1091(defun fcomp-ensure-source (env)
1092  ;; if source location saving is off, both values are NIL, so this will do nothing,
1093  ;; don't need to check explicitly.
1094  (unless (eq *fcomp-loading-toplevel-location* *loading-toplevel-location*)
1095    (fcomp-compile-toplevel-forms env)
1096    (setq *fcomp-loading-toplevel-location* *loading-toplevel-location*)
1097    (fcomp-output-form $fasl-toplevel-location env *loading-toplevel-location*)))
1098
1099(defun fcomp-output-form (opcode env &rest args)
1100  (fcomp-ensure-source env)
1101  (when *fcomp-toplevel-forms* (fcomp-compile-toplevel-forms env))
1102  (push (cons opcode args) *fcomp-output-list*))
1103
1104
1105;;; Compile a lambda expression for the sole purpose of putting it in a fasl
1106;;; file.  The result will not be funcalled.  This really shouldn't bother
1107;;; making an lfun, but it's simpler this way...
1108(defun fcomp-named-function (def name env &optional source-note)
1109  (let* ((env (new-lexical-environment env))
1110         (*nx-break-on-program-errors* (not (memq *fasl-break-on-program-errors* '(nil :defer)))))
1111    (multiple-value-bind (lfun warnings)
1112        (compile-named-function def
1113                                :name name
1114                                :env env
1115                                :function-note source-note
1116                                :keep-lambda *fasl-save-definitions*
1117                                :keep-symbols *fasl-save-local-symbols*
1118                                :policy *default-file-compilation-policy*
1119                                :source-notes *fcomp-source-note-map*
1120                                :load-time-eval-token cfasl-load-time-eval-sym
1121                                :target *fasl-target*)
1122      (fcomp-signal-or-defer-warnings warnings env)
1123      lfun)))
1124
1125
1126;; Convert parent-notes to immediate indices.  The reason this is necessary is to avoid hitting
1127;; the fasdumper's 64K limit on multiply-referenced objects.  This removes the reference
1128;; from parent slots, making notes less likely to be multiply-referenced.
1129(defun fcomp-digest-code-notes (lfun &optional refs)
1130  (unless (memq lfun refs)
1131    (let ((source (function-source-note lfun)))
1132      (when (and (source-note-p source)
1133                 (not (equalp (source-note-filename source) *loading-file-source-file*)))
1134        ;; Function is from a different file than being compiled, so don't digest it.
1135        ;; This can happen when #. is used to create arbitrary literal constants.
1136        #+no (warn "Reference to non-externalizable literal ~s" lfun)
1137        (return-from fcomp-digest-code-notes)))
1138    (let* ((lfv (function-to-function-vector lfun))
1139           (start #-x86-target 0 #+x86-target (%function-code-words lfun))
1140           (refs (cons lfun refs)))
1141      (declare (dynamic-extent refs))
1142      (loop for i from start below (uvsize lfv) as imm = (uvref lfv i)
1143            do (typecase imm
1144                 (code-note
1145                  (let* ((parent (code-note-parent-note imm))
1146                         (pos (when (code-note-p parent)
1147                                (loop for j from start below i
1148                                      do (when (eq parent (uvref lfv j)) (return j))))))
1149                    (when pos
1150                      (setf (code-note-parent-note imm) pos))))
1151                 (function
1152                  (fcomp-digest-code-notes imm refs)))))))
1153
1154; For now, defer only UNDEFINED-REFERENCEs, signal all others via WARN.
1155; Well, maybe not WARN, exactly.
1156(defun fcomp-signal-or-defer-warnings (warnings env)
1157  (let ((init (null *fcomp-warnings-header*))
1158        (some *fasl-warnings-signalled-p*)
1159        (harsh *fasl-non-style-warnings-signalled-p*))
1160    (dolist (w warnings)
1161      (when (and (not (compiler-warning-source-note w)) *fcomp-stream-position*)
1162        (setf (compiler-warning-source-note w)
1163              (make-source-note :source nil
1164                                :filename *fasl-source-file*
1165                                :start-pos *fcomp-stream-position*
1166                                :end-pos *fcomp-stream-position*)))
1167      (if (and (typep w 'undefined-reference) 
1168               (eq w (setq w (macro-too-late-p w env))))
1169        (push w *fasl-deferred-warnings*)
1170        (progn
1171          (multiple-value-setq (harsh some *fcomp-warnings-header*)
1172                               (signal-compiler-warning w init *fcomp-warnings-header* harsh some))
1173          (setq init nil))))
1174    (setq *fasl-warnings-signalled-p* some
1175          *fasl-non-style-warnings-signalled-p* harsh)))
1176
1177; If W is an UNDEFINED-FUNCTION-REFERENCE which refers to a macro (either at compile-time in ENV
1178; or globally), cons up a MACRO-USED-BEFORE-DEFINITION warning and return it; else return W.
1179
1180(defun macro-too-late-p (w env)
1181  (let* ((args (compiler-warning-args w))
1182         (name (car args)))
1183    (if (typep w 'undefined-function-reference)
1184      (if (or (macro-function name)
1185              (let* ((defenv (definition-environment env))
1186                     (info (if defenv (assq name (defenv.functions defenv)))))
1187                (and (consp (cdr info))
1188                     (eq 'macro (cadr info)))))
1189          (make-instance 'macro-used-before-definition
1190            :source-note (compiler-warning-source-note w)
1191            :function-name (compiler-warning-function-name w)
1192            :warning-type ':macro-used-before-definition
1193            :args args)
1194          w)
1195      w)))
1196
1197
1198             
1199;;;;          fasl-scan - dumping reference counting
1200;;;;
1201;;;;
1202;These should be constants, but it's too much trouble when need to change 'em.
1203(defparameter FASL-FILE-ID #xFF00)  ;Overall file format, shouldn't change much
1204
1205(defvar *fasdump-hash*)
1206(defvar *fasdump-read-package*)
1207(defvar *fasdump-global-offsets*)
1208(defvar *make-load-form-hash*)
1209
1210;;;Return a hash table containing subexp's which are referenced more than once.
1211(defun fasl-scan (forms)
1212  (let* ((*fasdump-hash* (make-hash-table :size (length forms)          ; Crude estimate
1213                                          :rehash-threshold 0.9
1214                                          :test 'eq
1215                                          :shared nil))
1216         (*make-load-form-hash* (make-hash-table :test 'eq :shared nil))
1217         (*fasdump-read-package* nil)
1218         (*fasdump-global-offsets* nil)
1219         (gsymbols nil))
1220    (dolist (op forms)
1221      (if (packagep op) ; old magic treatment of *package*
1222        (setq *fasdump-read-package* op)
1223        (dolist (arg (cdr op)) (fasl-scan-form arg))))
1224
1225    #-bccl (when (eq *compile-verbose* :debug)
1226             (format t "~&~S forms, ~S entries -> "
1227                     (length forms)
1228                     (hash-table-count *fasdump-hash*)))
1229    (maphash #'(lambda (key val)
1230                 (when (%izerop val) (remhash key *fasdump-hash*)))
1231             *fasdump-hash*)
1232    #-bccl (when (eq *compile-verbose* :debug)
1233             (format t "~S." (hash-table-count *fasdump-hash*)))
1234    (values *fasdump-hash*
1235            gsymbols
1236            *fasdump-global-offsets*)))
1237
1238;;; During scanning, *fasdump-hash* values are one of the following:
1239;;;  nil - form hasn't been referenced yet.
1240;;;   0 - form has been referenced exactly once
1241;;;   T - form has been referenced more than once
1242;;;  (load-form scanning-p referenced-p initform)
1243;;;     form should be replaced by load-form
1244;;;     scanning-p is true while we're scanning load-form
1245;;;     referenced-p is nil if unreferenced,
1246;;;                     T if referenced but not dumped yet,
1247;;;                     0 if dumped already (fasl-dump-form uses this)
1248;;;     initform is a compiled version of the user's initform
1249(defun fasl-scan-form (form)
1250  (when form
1251    (let ((info (gethash form *fasdump-hash*)))
1252      (cond ((null info)
1253             (fasl-scan-dispatch form))
1254            ((eql info 0)
1255             (puthash form *fasdump-hash* t))
1256            ((listp info)               ; a make-load-form form
1257             (when (cadr info)
1258               (error "Circularity in ~S for ~S" 'make-load-form form))
1259             (let ((referenced-cell (cddr info)))
1260               (setf (car referenced-cell) t)   ; referenced-p
1261               (setf (gethash (car info) *fasdump-hash*) t)))))))
1262
1263
1264
1265
1266(defun fasl-scan-dispatch (exp)
1267  (when exp
1268    (let ((type-code (typecode exp)))
1269      (declare (fixnum type-code))
1270      (case type-code
1271        (#.target::tag-fixnum
1272         (fasl-scan-fixnum exp))
1273        (#+ppc64-target #.target::fulltag-cons
1274         #-ppc64-target #.target::tag-list (fasl-scan-list exp))
1275        #+ppc32-target
1276        (#.ppc32::tag-imm)
1277        #+ppc64-target
1278        ((#.ppc64::fulltag-imm-0
1279          #.ppc64::fulltag-imm-1
1280          #.ppc64::fulltag-imm-2
1281          #.ppc64::fulltag-imm-3))
1282        #+x8632-target
1283        (#.x8632::tag-imm)
1284        #+x8664-target
1285        ((#.x8664::fulltag-imm-0
1286          #.x8664::fulltag-imm-1))
1287        #+arm-target
1288        (#.arm::tag-imm)
1289        (t
1290         (if
1291           #+ppc32-target
1292           (= (the fixnum (logand type-code ppc32::full-tag-mask)) ppc32::fulltag-immheader)
1293           #+ppc64-target
1294           (= (the fixnum (logand type-code ppc64::lowtagmask)) ppc64::lowtag-immheader)
1295           #+x8632-target
1296           (= (the fixnum (logand type-code x8632::fulltagmask)) x8632::fulltag-immheader)
1297           #+x8664-target
1298           (and (= (the fixnum (lisptag exp)) x8664::tag-misc)
1299                (logbitp (the (unsigned-byte 16) (logand type-code x8664::fulltagmask))
1300                         (logior (ash 1 x8664::fulltag-immheader-0)
1301                                 (ash 1 x8664::fulltag-immheader-1)
1302                                 (ash 1 x8664::fulltag-immheader-2))))
1303           #+arm-target
1304           (= (the fixnum (logand type-code arm::fulltagmask)) arm::fulltag-immheader)
1305           (case type-code
1306             (#.target::subtag-dead-macptr (fasl-unknown exp))
1307             (#.target::subtag-macptr
1308              ;; Treat untyped pointers to the high/low 64K of the address
1309              ;; space as constants.  Refuse to dump other pointers.
1310              (unless (and (zerop (%macptr-type exp))
1311                           (<= (%macptr-domain exp) 1))
1312                (error "Can't dump typed pointer ~s" exp))
1313              (let* ((addr (%ptr-to-int exp)))
1314                (unless (or (< addr #x10000)
1315                            (>= addr (- (ash 1 target::nbits-in-word)
1316                                        #x10000)))
1317                  (error "Can't dump pointer ~s : address is not in the low or high 64K of the address space." exp))))
1318             (t (fasl-scan-ref exp)))
1319           (case type-code
1320             ((#.target::subtag-pool #.target::subtag-weak #.target::subtag-lock) (fasl-unknown exp))
1321             (#+ppc-target #.target::subtag-symbol
1322              #+x8632-target #.target::subtag-symbol
1323              #+x8664-target #.target::tag-symbol
1324              #+arm-target #.target::subtag-symbol (fasl-scan-symbol exp))
1325             ((#.target::subtag-instance #.target::subtag-struct)
1326              (fasl-scan-user-form exp))
1327             (#.target::subtag-package (fasl-scan-ref exp))
1328             (#.target::subtag-istruct
1329              (if (memq (istruct-type-name exp) *istruct-make-load-form-types*)
1330                (progn
1331                  (if (hash-table-p exp)
1332                    (fasl-lock-hash-table exp))
1333                  (fasl-scan-user-form exp))
1334                (fasl-scan-gvector exp)))
1335             #+x8632-target
1336             (#.target::subtag-function (fasl-scan-clfun exp))
1337             #+x8664-target
1338             (#.target::tag-function (fasl-scan-clfun exp))
1339             (t (fasl-scan-gvector exp)))))))))
1340             
1341
1342(defun fasl-scan-ref (form)
1343  (puthash form *fasdump-hash* 0))
1344
1345(defun fasl-scan-fixnum (fixnum)
1346  (unless (short-fixnum-p fixnum) (fasl-scan-ref fixnum)))
1347
1348(defparameter *istruct-make-load-form-types*
1349  '(lexical-environment shared-library-descriptor shared-library-entry-point
1350    external-entry-point foreign-variable
1351    ctype unknown-ctype class-ctype foreign-ctype union-ctype member-ctype 
1352    array-ctype numeric-ctype hairy-ctype named-ctype constant-ctype args-ctype
1353    hash-table package-ref type-cell class-cell slot-id))
1354
1355
1356
1357
1358(defun fasl-scan-gvector (vec)
1359  (fasl-scan-ref vec)
1360  (dotimes (i (uvsize vec)) 
1361    (declare (fixnum i))
1362    (fasl-scan-form (%svref vec i))))
1363
1364#+x86-target
1365(defun fasl-scan-clfun (f)
1366  (let* ((fv (function-to-function-vector f))
1367         (size (uvsize fv))
1368         (ncode-words (%function-code-words f)))
1369    (fasl-scan-ref f)
1370    (do* ((k ncode-words (1+ k)))
1371         ((= k size))
1372      (fasl-scan-form (uvref fv k)))))
1373
1374(defun funcall-lfun-p (form)
1375  (and (listp form)
1376       (eq (%car form) 'funcall)
1377       (listp (%cdr form))
1378       (or (functionp (%cadr form))
1379           (eql (typecode (%cadr form)) target::subtag-xfunction))
1380       (null (%cddr form))))
1381
1382;;; We currently represent istruct-cells as conses.  That's not
1383;;; incredibly efficient (among other things, we have to do this
1384;;; check when scanning/dumping any list), but it's probably not
1385;;; worth burning a tag on them.  There are currently about 50
1386;;; entries on the *istruct-cells* list.
1387(defun istruct-cell-p (x)
1388  (and (consp x)
1389       (typep (%car x) 'symbol)
1390       (atom (%cdr x))
1391       (not (null (memq x *istruct-cells*)))))
1392
1393(defun fasl-scan-list (list)
1394  (cond ((eq (%car list) cfasl-load-time-eval-sym)
1395         (let ((form (car (%cdr list))))
1396           (fasl-scan-form (if (funcall-lfun-p form)
1397                             (%cadr form)
1398                             form))))
1399        ((istruct-cell-p list)
1400         (fasl-scan-form (%car list)))
1401        (t (when list
1402             (fasl-scan-ref list)
1403             (fasl-scan-form (%car list))
1404             (fasl-scan-form (%cdr list))))))
1405
1406(defun fasl-scan-user-form (form)
1407  (when (or (source-note-p form)
1408            (code-note-p form))
1409    (return-from fasl-scan-user-form (fasl-scan-gvector form)))
1410  (multiple-value-bind (load-form init-form) (make-load-form form *fcomp-load-forms-environment*)
1411    (labels ((simple-load-form (form)
1412               (or (atom form)
1413                   (let ((function (car form)))
1414                     (or (eq function 'quote)
1415                         (and (symbolp function)
1416                              ;; using fboundp instead of symbol-function
1417                              ;; see comments in symbol-function
1418                              (or (functionp (fboundp function))
1419                                  (eq function 'progn))
1420                              ;; (every #'simple-load-form (cdr form))
1421                              (dolist (arg (cdr form) t)
1422                                (unless (simple-load-form arg)
1423                                  (return nil))))))))
1424             (load-time-eval-form (load-form form type)
1425               (cond ((quoted-form-p load-form)
1426                      (%cadr load-form))
1427                     ((self-evaluating-p load-form)
1428                      load-form)
1429                     ((simple-load-form load-form)
1430                      `(,cfasl-load-time-eval-sym ,load-form))
1431                     (t (multiple-value-bind (lfun warnings)
1432                                             (or
1433                                              (gethash load-form *make-load-form-hash*)
1434                                              (fcomp-named-function `(lambda () ,load-form) nil nil))
1435                          (when warnings
1436                            (cerror "Ignore the warnings"
1437                                    "Compiling the ~s ~a form for~%~s~%produced warnings."
1438                                    'make-load-form type form))
1439                          (setf (gethash load-form *make-load-form-hash*) lfun)
1440                          `(,cfasl-load-time-eval-sym (funcall ,lfun)))))))
1441      (declare (dynamic-extent #'simple-load-form #'load-time-eval-form))
1442      (let* ((compiled-initform
1443              (and init-form (load-time-eval-form init-form form "initialization")))
1444             (info (list (load-time-eval-form load-form form "creation")
1445                         T              ; scanning-p
1446                         nil            ; referenced-p
1447                         compiled-initform  ;initform-info
1448                         )))
1449        (puthash form *fasdump-hash* info)
1450        (fasl-scan-form (%car info))
1451        (setf (cadr info) nil)        ; no longer scanning load-form
1452        (when init-form
1453          (fasl-scan-form compiled-initform))))))
1454
1455(defun fasl-scan-symbol (form)
1456  (fasl-scan-ref form)
1457  (fasl-scan-form (symbol-package form)))
1458 
1459
1460
1461;;;;          Pass 3 - dumping
1462;;;;
1463;;;;
1464(defvar *fasdump-epush*)
1465(defvar *fasdump-stream*)
1466(defvar *fasdump-eref*)
1467
1468(defun fasl-dump-file (gnames goffsets forms hash filename)
1469  (let ((opened? nil)
1470        (finished? nil))
1471    (unwind-protect
1472      (with-open-file (*fasdump-stream* filename :direction :output
1473                                        :element-type '(unsigned-byte 8)
1474                                        :if-exists :supersede
1475                                        :if-does-not-exist :create)
1476        (setq opened? t)
1477        (fasl-set-filepos 0)
1478        (fasl-out-word 0)             ;Will become the ID word
1479        (fasl-out-word 1)             ;One block in the file
1480        (fasl-out-long 12)            ;Block starts at file pos 12
1481        (fasl-out-long 0)             ;Length will go here
1482        (fasl-dump-block gnames goffsets forms hash)  ;Write the block
1483        (let ((pos (fasl-filepos)))
1484          (fasl-set-filepos 8)        ;Back to length longword
1485          (fasl-out-long (- pos 12))) ;Write length
1486        (fasl-set-filepos 0)          ;Seem to have won, make us legal
1487        (fasl-out-word FASL-FILE-ID)
1488        (setq finished? t)
1489        filename)
1490      (when (and opened? (not finished?))
1491        (delete-file filename)))))
1492
1493(defun target-symbol-value (name) 
1494  (let* ((package (arch::target-package-name (backend-target-arch *target-backend*)))
1495         (sym (find-symbol name package)))
1496    (unless (and sym (boundp sym))
1497      (error "~a not defined in target package ~s." name package))
1498    (logior #xff00 (logand #xff (symbol-value sym)))))
1499
1500;;; This is an exported, public interface.
1501(defun target-fasl-version ()
1502  (target-symbol-value "FASL-VERSION"))
1503
1504;; Redefine the versions of these functions used by the fasloader.
1505
1506(defun target-fasl-min-version ()
1507  (target-symbol-value "FASL-MIN-VERSION"))
1508
1509(defun target-fasl-max-version ()
1510  (target-symbol-value "FASL-MAX-VERSION"))
1511
1512(defun fasl-dump-block (gnames goffsets forms hash)
1513  (let ((etab-size (hash-table-count hash)))
1514    (fasl-out-word (target-fasl-version))          ; Word 0
1515    (fasl-out-long  0)
1516    (fasl-out-byte $fasl-vetab-alloc)
1517    (fasl-out-count etab-size)
1518    (fasl-dump gnames goffsets forms hash)
1519    (fasl-out-byte $fasl-end)))
1520
1521(defun fasl-dump (gnames goffsets forms hash)
1522  (let* ((*fasdump-hash* hash)
1523         (*fasdump-read-package* nil)
1524         (*fasdump-epush* nil)
1525         (*fasdump-eref* -1)
1526         (*fasdump-global-offsets* goffsets))
1527    (when gnames
1528      (fasl-out-byte $fasl-globals)
1529      (fasl-dump-form gnames))
1530    (dolist (op forms)
1531      (if (packagep op)
1532        (setq *fasdump-read-package* op)
1533        (progn
1534          (fasl-out-byte (car op))
1535          (dolist (arg (cdr op)) (fasl-dump-form arg)))))))
1536
1537;;;During dumping, *fasdump-hash* values are one of the following:
1538;;;   nil - form has no load form, is referenced at most once.
1539;;;   fixnum - form has already been dumped, fixnum is the etab index.
1540;;;   T - form hasn't been dumped yet, is referenced more than once.
1541;;;  (load-form . nil) - form should be replaced by load-form.
1542(defun fasl-dump-form (form)
1543  (let ((info (gethash form *fasdump-hash*)))
1544    (cond ((fixnump info)
1545           (fasl-out-byte $fasl-veref)
1546           (fasl-out-count info))
1547          ((consp info)
1548           (fasl-dump-user-form form info))
1549          (t
1550           (setq *fasdump-epush* info)
1551           (fasl-dump-dispatch form)))))
1552
1553(defun fasl-dump-user-form (form info)
1554  (let* ((load-form (car info))
1555         (referenced-p (caddr info))
1556         (initform (cadddr info)))
1557    (when referenced-p
1558      (unless (gethash load-form *fasdump-hash*)
1559        (error "~s was not in ~s.  This shouldn't happen." 'load-form '*fasdump-hash*)))
1560    (when initform
1561      (fasl-out-byte $fasl-prog1))      ; ignore the initform
1562    (fasl-dump-form load-form)
1563    (when referenced-p
1564      (setf (gethash form *fasdump-hash*) (gethash load-form *fasdump-hash*)))
1565    (when initform
1566      (fasl-dump-form initform))))
1567
1568(defun fasl-out-opcode (opcode form)
1569  (if *fasdump-epush*
1570    (progn
1571      (setq *fasdump-epush* nil)
1572      (fasl-out-byte (fasl-epush-op opcode))
1573      (fasl-dump-epush form))
1574    (fasl-out-byte opcode)))
1575
1576(defun fasl-dump-epush (form)
1577  #-bccl (when (fixnump (gethash form *fasdump-hash*))
1578           (error "Bug! Duplicate epush for ~S" form))
1579  (puthash form *fasdump-hash* (setq *fasdump-eref* (1+ *fasdump-eref*))))
1580
1581
1582(defun fasl-dump-dispatch (exp)
1583  (etypecase exp
1584    ((signed-byte 16) (fasl-dump-s16 exp))
1585    ((signed-byte 32) (fasl-dump-s32 exp))
1586    ((signed-byte 64) (fasl-dump-s64 exp))
1587    (bignum (fasl-dump-32-bit-ivector exp $fasl-bignum32))
1588    (character (fasl-dump-char exp))
1589    (list (fasl-dump-list exp))
1590    (immediate (fasl-dump-t_imm exp))
1591    (double-float (fasl-dump-dfloat exp))
1592    (single-float (fasl-dump-sfloat exp))
1593    (simple-string
1594     (let* ((nextra (utf-8-extra-bytes exp)))
1595       (cond ((= 0 nextra)
1596              (fasl-out-opcode $fasl-nvstr exp)
1597              (fasl-out-nvstring exp))
1598             (t (fasl-out-opcode $fasl-vstr exp)
1599                (fasl-out-vstring exp nextra)))))
1600    (simple-bit-vector (fasl-dump-bit-vector exp))
1601    ((simple-array (unsigned-byte 8) (*))
1602     (fasl-dump-8-bit-ivector exp $fasl-u8-vector))
1603    ((simple-array (signed-byte 8) (*))
1604     (fasl-dump-8-bit-ivector exp $fasl-s8-vector))
1605    ((simple-array (unsigned-byte 16) (*))
1606     (fasl-dump-16-bit-ivector exp $fasl-u16-vector))
1607    ((simple-array (signed-byte 16) (*))
1608     (fasl-dump-16-bit-ivector exp $fasl-s16-vector))
1609    ((simple-array (unsigned-byte 32) (*))
1610     (fasl-dump-32-bit-ivector exp $fasl-u32-vector))
1611    ((simple-array (signed-byte 32) (*))
1612     (fasl-dump-32-bit-ivector exp $fasl-s32-vector))
1613    ((simple-array single-float (*))
1614     (fasl-dump-32-bit-ivector exp $fasl-single-float-vector))
1615    ((simple-array double-float (*))
1616     (fasl-dump-double-float-vector exp))
1617    (symbol (fasl-dump-symbol exp))
1618    (package (fasl-dump-package exp))
1619    (function (fasl-dump-function exp))
1620    (xfunction (fasl-dump-function exp))
1621    (code-vector (fasl-dump-codevector exp))
1622    (xcode-vector (fasl-dump-codevector exp))
1623    (simple-vector (fasl-dump-gvector exp $fasl-t-vector))
1624    (ratio (fasl-dump-ratio exp))
1625    (complex (fasl-dump-complex exp))
1626    #+(and 64-bit-target (not cross-compiling))
1627    ((simple-array (unsigned-byte 64) (*))
1628     (fasl-dump-64-bit-ivector exp $fasl-u64-vector))
1629    #+(and 64-bit-target (not cross-compiling))
1630    ((simple-array (signed-byte 64) (*))
1631     (fasl-dump-64-bit-ivector exp $fasl-s64-vector))
1632    (ivector
1633     (unless (eq (backend-target-arch-name *target-backend*)
1634                 (backend-target-arch-name *host-backend*))
1635       (error "can't cross-compile constant reference to ~s" exp))
1636     (let* ((typecode (typecode exp))
1637            (n (uvsize exp))
1638            (nb (subtag-bytes typecode n)))
1639       (declare (fixnum n nb typecode))
1640       (fasl-out-opcode $fasl-vivec exp)
1641       (fasl-out-byte typecode)
1642       (fasl-out-count n)
1643       (fasl-out-ivect exp 0 nb)))
1644    (vector (fasl-dump-gvector exp $fasl-vector-header))
1645    (array (fasl-dump-gvector exp $fasl-array-header))
1646
1647    (gvector
1648     (if (= (typecode exp) target::subtag-istruct)
1649       (fasl-dump-gvector exp $fasl-istruct)
1650       (progn
1651         (unless (eq (backend-target-arch-name *target-backend*)
1652                     (backend-target-arch-name *host-backend*))
1653           (error "can't cross-compile constant reference to ~s" exp))
1654         (let* ((typecode (typecode exp))
1655                (n (uvsize exp)))
1656           (declare (fixnum n typecode))
1657           (fasl-out-opcode $fasl-vgvec exp)
1658           (fasl-out-byte typecode)
1659           (fasl-out-count n)
1660           (dotimes (i n)
1661             (fasl-dump-form (%svref exp i)))))))))
1662
1663(defun fasl-dump-gvector (v op)
1664  (let* ((n (uvsize v)))
1665    (fasl-out-opcode op v)
1666    (fasl-out-count n)
1667    (dotimes (i n)
1668      (fasl-dump-form (%svref v i)))))
1669
1670(defun fasl-dump-ratio (v)
1671  (fasl-out-opcode $fasl-ratio v)
1672  (fasl-dump-form (%svref v target::ratio.numer-cell))
1673  (fasl-dump-form (%svref v target::ratio.denom-cell)))
1674
1675(defun fasl-dump-complex (v)
1676  (fasl-out-opcode $fasl-complex v)
1677  (fasl-dump-form (%svref v target::complex.realpart-cell))
1678  (fasl-dump-form (%svref v target::complex.imagpart-cell)))
1679
1680(defun fasl-dump-bit-vector (v)
1681  (let* ((n (uvsize v)))
1682    (fasl-out-opcode $fasl-bit-vector v)
1683    (fasl-out-count n)
1684    (if (eq *fasl-host-big-endian* *fasl-target-big-endian*)
1685      (let* ((nb (ash (+ n 7) -3)))
1686        (fasl-out-ivect v 0 nb))
1687      (compiler-bug "need to byte-swap ~a" v))))
1688
1689(defun fasl-dump-8-bit-ivector (v op)
1690  (let* ((n (uvsize v)))
1691    (fasl-out-opcode op v)
1692    (fasl-out-count n)
1693    (let* ((nb n))
1694      (fasl-out-ivect v 0 nb))))
1695
1696(defun fasl-dump-16-bit-ivector (v op)
1697  (let* ((n (uvsize v)))
1698    (fasl-out-opcode op v)
1699    (fasl-out-count n)
1700    (if (eq *fasl-host-big-endian* *fasl-target-big-endian*)
1701      (let* ((nb (ash n 1)))
1702        (fasl-out-ivect v 0 nb))
1703      (dotimes (i n)
1704        (let* ((k (uvref v i)))
1705          (fasl-out-byte (ldb (byte 8 0) k))
1706          (fasl-out-byte (ldb (byte 8 8) k)))))))
1707
1708(defun fasl-dump-32-bit-ivector (v op)
1709  (let* ((n (uvsize v)))
1710    (fasl-out-opcode op v)
1711    (fasl-out-count n)
1712    (if (eq *fasl-host-big-endian* *fasl-target-big-endian*)
1713      (let* ((nb (ash n 2)))
1714        (fasl-out-ivect v 0 nb))
1715      (dotimes (i n)
1716        (let* ((k (uvref v i)))
1717          (fasl-out-byte (ldb (byte 8 0) k))
1718          (fasl-out-byte (ldb (byte 8 8) k))
1719          (fasl-out-byte (ldb (byte 8 16) k))
1720          (fasl-out-byte (ldb (byte 8 24) k)))))))
1721
1722
1723(defun fasl-dump-64-bit-ivector (v op)
1724  (let* ((n (uvsize v)))
1725    (fasl-out-opcode op v)
1726    (fasl-out-count n)
1727    (if (eq *fasl-host-big-endian* *fasl-target-big-endian*)
1728      (let* ((nb (ash n 3)))
1729        (fasl-out-ivect v 0 nb))
1730      (compiler-bug "need to byte-swap ~a" v))))
1731
1732(defun fasl-dump-double-float-vector (v)
1733  (let* ((n (uvsize v)))
1734    (fasl-out-opcode $fasl-double-float-vector v)
1735    (fasl-out-count n)
1736    (if (eq *fasl-host-big-endian* *fasl-target-big-endian*)
1737      (let* ((nb (ash n 3)))
1738        (fasl-out-ivect v (- target::misc-dfloat-offset
1739                             target::misc-data-offset) nb))
1740      (compiler-bug "need to byte-swap ~a" v))))
1741
1742;;; This is used to dump functions and "xfunctions".
1743;;; If we're cross-compiling, we shouldn't reference any
1744;;; (host) functions as constants; try to detect that
1745;;; case.
1746#-x86-target
1747(defun fasl-dump-function (f)
1748  (if (and (not (eq *fasl-backend* *host-backend*))
1749           (typep f 'function))
1750    (compiler-bug "Dumping a native function constant ~s during cross-compilation." f))
1751  (if (and (= (typecode f) target::subtag-xfunction)
1752           (= (typecode (uvref f 0)) target::subtag-u8-vector))
1753    (fasl-xdump-clfun f)
1754    (let* ((n (uvsize f)))
1755      (fasl-out-opcode $fasl-function f)
1756      (fasl-out-count n)
1757      (dotimes (i n)
1758        (if (= i 0)
1759          (target-arch-case
1760           (:arm (fasl-dump-form 0))
1761           (t (fasl-dump-form (%svref f i))))
1762          (fasl-dump-form (%svref f i)))))))
1763
1764#+x86-target
1765(defun fasl-dump-function (f)
1766  (if (and (not (eq *fasl-backend* *host-backend*))
1767           (typep f 'function))
1768    (compiler-bug "Dumping a native function constant ~s during cross-compilation." f))
1769  (if (and (= (typecode f) target::subtag-xfunction)
1770           (= (typecode (uvref f 0)) target::subtag-u8-vector))
1771    (fasl-xdump-clfun f)
1772    (if (= (typecode f) target::subtag-xfunction)
1773      (let* ((n (uvsize f)))
1774        (fasl-out-opcode $fasl-function f)
1775        (fasl-out-count n)
1776        (dotimes (i n)
1777          (fasl-dump-form (%svref f i))))       
1778
1779      (let* ((code-size (%function-code-words f))
1780             (function-vector (function-to-function-vector f))
1781             (function-size (uvsize function-vector)))
1782        (fasl-out-opcode $fasl-clfun f)
1783        (fasl-out-count function-size)
1784        (fasl-out-count code-size)
1785        (fasl-out-ivect function-vector 0 (ash code-size target::word-shift))
1786        (do* ((k code-size (1+ k)))
1787             ((= k function-size))
1788          (declare (fixnum k))
1789          (fasl-dump-form (uvref function-vector k)))))))
1790       
1791
1792 
1793
1794;;; Write a "concatenated function".
1795(defun fasl-xdump-clfun (f)
1796  (target-arch-case
1797   (:x8632
1798    (let* ((code (uvref f 0))
1799           (function-size (ash (uvsize code) -2))
1800           (encoded-imm-words (dpb (uvref code 1) (byte 8 8) (uvref code 0)))
1801           (imm-words (if (logbitp 15 encoded-imm-words)
1802                        (- function-size (ldb (byte 15 0) encoded-imm-words))
1803                        encoded-imm-words))
1804           (imm-bytes (ash imm-words 2))
1805           (other-words (- function-size imm-words)))
1806      (assert (= other-words (1- (uvsize f))))
1807      (fasl-out-opcode $fasl-clfun f)
1808      (fasl-out-count function-size)
1809      (fasl-out-count imm-words)
1810      (fasl-out-ivect code 0 imm-bytes)
1811      (do ((i 1 (1+ i))
1812           (n (uvsize f)))
1813          ((= i n))
1814        (declare (fixnum i n))
1815        (fasl-dump-form (%svref f i)))))
1816   (:x8664
1817    (let* ((code (uvref f 0))
1818           (code-size (dpb (uvref code 3)
1819                           (byte 8 24)
1820                           (dpb (uvref code 2)
1821                                (byte 8 16)
1822                                (dpb (uvref code 1)
1823                                     (byte 8 8)
1824                                     (uvref code 0)))))
1825           (function-size (ash (uvsize code) -3)))
1826      (assert (= (- function-size code-size) (1- (uvsize f))))
1827      (fasl-out-opcode $fasl-clfun f)
1828      (fasl-out-count function-size)
1829      (fasl-out-count code-size)
1830      (fasl-out-ivect code 0 (ash code-size 3))
1831      (do* ((i 1 (1+ i))
1832            (n (uvsize f)))
1833           ((= i n))
1834        (declare (fixnum i n))
1835        (fasl-dump-form (%svref f i)))))))
1836
1837(defun fasl-dump-codevector (c)
1838  (if (and (not (eq *fasl-backend* *host-backend*))
1839           (typep c 'code-vector))
1840    (compiler-bug "Dumping a native code-vector constant ~s during cross-compilation." c))
1841  (let* ((n (uvsize c)))
1842    (fasl-out-opcode $fasl-code-vector c)
1843    (fasl-out-count n)
1844    (fasl-out-ivect c)))
1845
1846(defun fasl-dump-t_imm (imm)
1847  (fasl-out-opcode $fasl-timm imm)
1848  (fasl-out-long (%address-of imm)))
1849
1850(defun fasl-dump-char (char)     ; << maybe not
1851  (let ((code (%char-code char)))
1852    (fasl-out-opcode $fasl-char char)
1853    (fasl-out-count code)))
1854
1855;;; Always write big-endian.
1856(defun fasl-dump-s16 (s16)
1857  (fasl-out-opcode $fasl-word-fixnum s16)
1858  (fasl-out-word s16))
1859
1860;;; Always write big-endian
1861(defun fasl-dump-s32 (s32)
1862  (fasl-out-opcode $fasl-s32 s32)
1863  (fasl-out-word (ldb (byte 16 16) s32))
1864  (fasl-out-word (ldb (byte 16 0) s32)))
1865
1866;;; Always write big-endian
1867(defun fasl-dump-s64 (s64)
1868  (fasl-out-opcode $fasl-s64 s64)
1869  (fasl-out-word (ldb (byte 16 48) s64))
1870  (fasl-out-word (ldb (byte 16 32) s64))
1871  (fasl-out-word (ldb (byte 16 16) s64))
1872  (fasl-out-word (ldb (byte 16 0) s64)))
1873
1874
1875
1876(defun fasl-dump-dfloat (float)
1877  (fasl-out-opcode $fasl-dfloat float)
1878  (multiple-value-bind (high low) (double-float-bits float)
1879    (fasl-out-long high)
1880    (fasl-out-long low)))
1881
1882(defun fasl-dump-sfloat (float)
1883  (fasl-out-opcode $fasl-sfloat float)
1884  (fasl-out-long (single-float-bits float)))
1885
1886
1887(defun fasl-dump-package (pkg)
1888  (let* ((name (package-name pkg))
1889         (nextra (utf-8-extra-bytes name)))
1890    (cond ((eql nextra 0)
1891           (fasl-out-opcode $fasl-nvpkg pkg)
1892           (fasl-out-nvstring name))
1893          (t
1894           (fasl-out-opcode $fasl-vpkg pkg)
1895           (fasl-out-vstring name nextra)))))
1896
1897
1898
1899(defun fasl-dump-list (list)
1900  (cond ((null list) (fasl-out-opcode $fasl-nil list))
1901        ((eq (%car list) cfasl-load-time-eval-sym)
1902         (let* ((form (car (%cdr list)))
1903                (opcode $fasl-eval))
1904           (when (funcall-lfun-p form)
1905             (setq opcode $fasl-lfuncall
1906                   form (%cadr form)))
1907           (if *fasdump-epush*
1908             (progn
1909               (fasl-out-byte (fasl-epush-op opcode))
1910               (fasl-dump-form form)
1911               (fasl-dump-epush list))
1912             (progn
1913               (fasl-out-byte opcode)
1914               (fasl-dump-form form)))))
1915        ((istruct-cell-p list)
1916         (fasl-out-opcode $fasl-istruct-cell (car list))
1917         (fasl-dump-symbol (car list)))
1918        (t (fasl-dump-cons list))))
1919
1920(defun fasl-dump-cons (cons &aux (end cons) (cdr-len 0))
1921  (declare (fixnum cdr-len))
1922  (while (and (consp (setq end (%cdr end)))
1923              (null (gethash end *fasdump-hash*)))
1924    (incf cdr-len))
1925  (if (eql 0 cdr-len)
1926    (fasl-out-opcode $fasl-cons cons)
1927    (progn
1928      (fasl-out-opcode (if end $fasl-vlist* $fasl-vlist) cons)
1929      (fasl-out-count cdr-len)))
1930  (dotimes (i (the fixnum (1+ cdr-len)))
1931    (fasl-dump-form (%car cons))
1932    (setq cons (%cdr cons)))
1933  (when (or (eql 0 cdr-len) end)      ;cons or list*
1934    (fasl-dump-form end)))
1935
1936
1937
1938(defun fasl-dump-symbol (sym)
1939  (let* ((pkg (symbol-package sym))
1940         (name (symbol-name sym))
1941         (nextra (utf-8-extra-bytes name))
1942         (ascii (eql nextra 0))
1943         (idx (let* ((i (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell)))
1944                (declare (fixnum i))
1945                (unless (zerop i) i))))
1946    (cond ((null pkg) 
1947           (progn 
1948             (fasl-out-opcode (if idx
1949                                (if ascii $fasl-nvmksym-special $fasl-vmksym-special)
1950                                (if ascii $fasl-nvmksym $fasl-vmksym))
1951                              sym)
1952             (if ascii
1953               (fasl-out-nvstring name)
1954               (fasl-out-vstring name nextra))))
1955          (*fasdump-epush*
1956           (progn
1957             (fasl-out-byte (fasl-epush-op (if idx
1958                                             (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special)
1959                                             (if ascii $fasl-nvpkg-intern $fasl-vpkg-intern))))
1960             (fasl-dump-form pkg)
1961             (fasl-dump-epush sym)
1962             (if ascii
1963               (fasl-out-nvstring name)
1964               (fasl-out-vstring name nextra))))
1965          (t
1966           (progn
1967             (fasl-out-byte (if idx
1968                              (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special)
1969                              (if ascii $fasl-nvpkg-intern $fasl-vpkg-intern)))
1970             (fasl-dump-form pkg)
1971             (if ascii
1972               (fasl-out-nvstring name)
1973               (fasl-out-vstring name nextra)))))))
1974
1975
1976(defun fasl-unknown (exp)
1977  (error "Can't dump ~S - unknown type" exp))
1978
1979(defun fasl-out-simple-string (str start end)
1980  (declare (simple-string str) (fixnum start end))
1981  (do* ((k start (1+ k)))
1982       ((= k end))
1983    (declare (fixnum k))
1984    (fasl-out-byte (char-code (schar str k)))))
1985
1986(defun fasl-out-nvstring (str)
1987  (fasl-out-count (length str))
1988  (fasl-out-simple-string str 0 (length str)))
1989
1990(defun utf-8-extra-bytes (string)
1991  (declare (simple-string string))
1992  (let* ((extra 0))
1993    (declare (fixnum extra))
1994    (dotimes (i (length string) extra)
1995      (let* ((code (%scharcode string i)))
1996        (declare ((mod #x110000) code))
1997        (cond ((>= code #x10000) (incf extra 3))
1998              ((>= code #x800) (incf extra 2))
1999              ((>= code #x80) (incf extra 1)))))))
2000
2001(defun fasl-out-vstring (str nextra)
2002  (declare (fixnum nextra))
2003  (let* ((len (length str)))
2004    (declare (fixnum len))
2005    (fasl-out-count len)
2006    (fasl-out-count nextra)
2007    (dotimes (i len)
2008      (let* ((code (%scharcode str i)))
2009        (declare ((mod #x110000) code))
2010        (cond ((< code #x80) (fasl-out-byte code))
2011              ((< code #x800)
2012               (let* ((y (ldb (byte 5 6) code))
2013                      (z (ldb (byte 6 0) code)))
2014                 (declare (fixnum y z))
2015                 (fasl-out-byte (logior #xc0 y))
2016                 (fasl-out-byte (logior #x80 z))))
2017              ((< code #x10000)
2018               (let* ((x (ldb (byte 4 12) code))
2019                      (y (ldb (byte 6 6) code))
2020                      (z (ldb (byte 6 0) code)))
2021                 (declare (fixnum x y z))
2022                 (fasl-out-byte (logior #xe0 x))
2023                 (fasl-out-byte (logior #x80 y))
2024                 (fasl-out-byte (logior #x80 z))))
2025              (t
2026                (let* ((w (ldb (byte 3 18) code))
2027                       (x (ldb (byte 6 12) code))
2028                       (y (ldb (byte 6 6) code))
2029                       (z (ldb (byte 6 0) code)))
2030                  (declare (fixnum w x y z))
2031                  (fasl-out-byte (logior #xf0 w))
2032                  (fasl-out-byte (logior #x80 x))
2033                  (fasl-out-byte (logior #x80 y))
2034                  (fasl-out-byte (logior #x80 z)))))))))
2035
2036
2037(defun fasl-out-ivect (iv &optional 
2038                          (start 0) 
2039                          (nb 
2040                           (subtag-bytes (typecode iv) (uvsize iv))))
2041  (stream-write-ivector *fasdump-stream* iv start nb))
2042
2043
2044(defun fasl-out-long (long)
2045  (fasl-out-word (ash long -16))
2046  (fasl-out-word (logand long #xFFFF)))
2047
2048(defun fasl-out-word (word)
2049  (fasl-out-byte (ash word -8))
2050  (fasl-out-byte word))
2051
2052(defun fasl-out-byte (byte)
2053  (write-byte (%ilogand2 byte #xFF) *fasdump-stream*))
2054
2055;;; Write an unsigned integer in 7-bit chunks.
2056(defun fasl-out-count (val)
2057  (do* ((b (ldb (byte 7 0) val) (ldb (byte 7 0) val))
2058        (done nil))
2059       (done)
2060    (when (zerop (setq val (ash val -7)))
2061      (setq b (logior #x80 b) done t))
2062    (fasl-out-byte b)))
2063
2064(defun fasl-filepos ()
2065  (file-position *fasdump-stream*))
2066
2067(defun fasl-set-filepos (pos)
2068  (file-position *fasdump-stream* pos)
2069  #-bccl (unless (eq (file-position *fasdump-stream*) pos)
2070           (error "Unable to set file position to ~S" pos)))
2071
2072;;; Concatenate fasl files.
2073
2074;;; Format of a fasl file as expected by the fasloader.
2075;;;
2076;;; #xFF00         2 bytes - File version
2077;;; Block Count    2 bytes - Number of blocks in the file
2078;;; addr[0]        4 bytes - address of 0th block
2079;;; length[0]      4 bytes - length of 0th block
2080;;; addr[1]        4 bytes - address of 1st block
2081;;; length[1]      4 bytes - length of 1st block
2082;;; ...
2083;;; addr[n-1]      4 bytes
2084;;; length[n-1]    4 bytes
2085;;; length[0] + length[1] + ... + length [n-1] bytes of data
2086
2087;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2088;;
2089;; (fasl-concatenate out-file fasl-files &key :if-exists)
2090;;
2091;; out-file     name of file in which to store the concatenation
2092;; fasl-files   list of names of fasl files to concatenate
2093;; if-exists    as for OPEN, defaults to :error
2094;;
2095;; function result: pathname to the output file.
2096;; It works to use the output of one invocation of fasl-concatenate
2097;; as an input of another invocation.
2098;;
2099(defun fasl-concatenate (out-file fasl-files &key (if-exists :error))
2100  (%fasl-concatenate out-file fasl-files if-exists (pathname-type *.fasl-pathname*)))
2101
2102(defun %fasl-concatenate (out-file fasl-files if-exists file-ext)
2103  (let ((count 0)
2104        (created? nil)
2105        (finished? nil)
2106        (ext-pathname (make-pathname :type file-ext)))
2107    (declare (fixnum count))
2108    (flet ((fasl-read-halfword (f)
2109             (dpb (read-byte f) (byte 8 8) (read-byte f)))
2110           (fasl-write-halfword (h f)
2111             (write-byte (ldb (byte 8 8) h) f)
2112             (write-byte (ldb (byte 8 0) h) f)
2113             h))
2114      (flet ((fasl-read-fullword (f)
2115               (dpb (fasl-read-halfword f) (byte 16 16) (fasl-read-halfword f)))
2116             (fasl-write-fullword (w f)
2117               (fasl-write-halfword (ldb (byte 16 16) w) f)
2118               (fasl-write-halfword (ldb (byte 16 0) w) f)
2119               w))
2120        (dolist (file fasl-files)
2121          (setq file (merge-pathnames file ext-pathname))
2122          (unless (equal (pathname-type file) file-ext)
2123            (error "Not a ~A file: ~s" file-ext file))
2124          (with-open-file (instream file :element-type '(unsigned-byte 8))
2125            (unless (eql fasl-file-id (fasl-read-halfword instream))
2126              (error "Bad ~A file ID in ~s" file-ext file))
2127            (incf count (fasl-read-halfword instream))))
2128        (unwind-protect
2129             (with-open-file (outstream
2130                              (setq out-file (merge-pathnames out-file ext-pathname))
2131                              :element-type '(unsigned-byte 8)
2132                              :direction :output
2133                              :if-does-not-exist :create
2134                              :if-exists if-exists)
2135               (setq created? t)
2136               (let ((addr-address 4)
2137                     (data-address (+ 4 (* count 8))))
2138                 (fasl-write-halfword 0 outstream) ;  will be $fasl-id
2139                 (fasl-write-halfword count outstream)
2140                 (dotimes (i (* 2 count))
2141                   (fasl-write-fullword 0 outstream)) ; for addresses/lengths
2142                 (dolist (file fasl-files)
2143                   (with-open-file (instream (merge-pathnames file ext-pathname)
2144                                             :element-type '(unsigned-byte 8))
2145                     (fasl-read-halfword instream) ; skip ID
2146                     (let* ((fasl-count (fasl-read-halfword instream))
2147                            (addrs (make-array fasl-count))
2148                            (sizes (make-array fasl-count))
2149                            addr0)
2150                       (declare (fixnum fasl-count)
2151                                (dynamic-extent addrs sizes))
2152                       (dotimes (i fasl-count)
2153                         (setf (svref addrs i) (fasl-read-fullword instream)
2154                               (svref sizes i) (fasl-read-fullword instream)))
2155                       (setq addr0 (svref addrs 0))
2156                       (file-position outstream addr-address)
2157                       (dotimes (i fasl-count)
2158                         (fasl-write-fullword
2159                          (+ data-address (- (svref addrs i) addr0))
2160                          outstream)
2161                         (fasl-write-fullword (svref sizes i) outstream)
2162                         (incf addr-address 8))
2163                       (file-position outstream data-address)
2164                       (dotimes (i fasl-count)
2165                         (file-position instream (svref addrs i))
2166                         (let ((fasl-length (svref sizes i)))
2167                           (dotimes (j fasl-length)
2168                             (write-byte (read-byte instream) outstream))
2169                           (incf data-address fasl-length))))))
2170                 (stream-length outstream data-address)
2171                 (file-position outstream 0)
2172                 (fasl-write-halfword fasl-file-id outstream)
2173                 (setq finished? t)))
2174          (when (and created? (not finished?))
2175            (delete-file out-file))))
2176      out-file)))
2177
2178;;; Cross-compilation environment stuff.  Some of this involves
2179;;; setting up the TARGET and OS packages.
2180(defun ensure-package-nickname (name package)
2181  (let* ((old (find-package name)))
2182    (unless (eq old package)
2183      (rename-package old (package-name old) (delete name (package-nicknames old) :test #'string=))
2184      (rename-package package (package-name package) (cons name (package-nicknames package)))
2185      old)))
2186
2187(defmacro with-cross-compilation-package ((name target) &body body)
2188  (let* ((old-package (gensym))
2189         (name-var (gensym))
2190         (target-var (gensym)))
2191    `(let* ((,name-var ,name)
2192            (,target-var ,target)
2193            (,old-package (ensure-package-nickname ,name-var ,target-var)))
2194      (unwind-protect
2195           (progn ,@body)
2196        (when ,old-package (ensure-package-nickname ,name-var
2197                                                          ,old-package))))))
2198
2199(defun %with-cross-compilation-target (target thunk)
2200  (let* ((backend (find-backend target)))
2201    (if (null backend)
2202      (error "No known compilation target named ~s." target)
2203      (let* ((arch (backend-target-arch backend))
2204             (arch-package-name (arch::target-package-name arch))
2205             (ftd (backend-target-foreign-type-data backend))
2206             (ftd-package-name (ftd-interface-package-name ftd)))
2207        (or (find-package arch-package-name)
2208            (make-package arch-package-name))
2209        (or (find-package ftd-package-name)
2210            (make-package ftd-package-name :use "COMMON-LISP"))
2211        (with-cross-compilation-package ("OS" ftd-package-name)
2212          (with-cross-compilation-package ("TARGET" arch-package-name)
2213            (let* ((*target-ftd* ftd))
2214               (funcall thunk))))))))
2215
2216(defmacro with-cross-compilation-target ((target) &body body)
2217  `(%with-cross-compilation-target ,target #'(lambda () ,@body)))
2218             
2219
2220 
2221
2222(provide 'nfcomp)
2223
Note: See TracBrowser for help on using the repository browser.