X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdump.lisp;h=7c4619f02391bdaf272129bbf3658e5d664886fa;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=82469dd5dfc7e4294e1b0c89a7c8531b4e83e532;hpb=86210c4e406c1b2ff10cc3bac0e71435867db48b;p=sbcl.git

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index 82469dd..7c4619f 100644
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -155,7 +155,7 @@
 	 (dump-byte ',val ,file))
       (error "compiler bug: ~S is not a legal fasload operator." fs))))
 
-;;; Dump a FOP-Code along with an integer argument, choosing the FOP
+;;; Dump a FOP-CODE along with an integer argument, choosing the FOP
 ;;; based on whether the argument will fit in a single byte.
 ;;;
 ;;; FIXME: This, like DUMP-FOP, should be a function with a
@@ -246,6 +246,17 @@
 
 ;;;; opening and closing fasl files
 
+;;; A utility function to write strings to (unsigned-byte 8) streams.
+;;; We restrict this to ASCII (with the averrance) because of
+;;; ambiguity of higher bytes: Unicode, some ISO-8859-x, or what? This
+;;; could be revisited in the event of doing funky things with stream
+;;; encodings -- CSR, 2002-04-25
+(defun fasl-write-string (string stream)
+  (loop for char across string
+	do (let ((code (char-code char)))
+	     (aver (<= 0 code 127))
+	     (write-byte code stream))))
+
 ;;; Open a fasl file, write its header, and return a FASL-OUTPUT
 ;;; object for dumping to it. Some human-readable information about
 ;;; the source code is given by the string WHERE. If BYTE-P is true,
@@ -255,38 +266,42 @@
   (declare (type pathname name))
   (let* ((stream (open name
 		       :direction :output
-		       :if-exists :new-version
+		       :if-exists :supersede
 		       :element-type 'sb!assem:assembly-unit))
 	 (res (make-fasl-output :stream stream)))
 
     ;; Begin the header with the constant machine-readable (and
     ;; semi-human-readable) string which is used to identify fasl files.
-    (write-string *fasl-header-string-start-string* stream)
+    (fasl-write-string *fasl-header-string-start-string* stream)
 
     ;; The constant string which begins the header is followed by
     ;; arbitrary human-readable text, terminated by a special
     ;; character code.
-    (with-standard-io-syntax
-     (format stream
-	     "~%  ~
-	     compiled from ~S~%  ~
-	     at ~A~%  ~
-	     on ~A~%  ~
-	     using ~A version ~A~%"
-	     where
-	     (format-universal-time nil (get-universal-time))
-	     (machine-instance)
-	     (sb!xc:lisp-implementation-type)
-	     (sb!xc:lisp-implementation-version)))
+    (fasl-write-string
+     (with-standard-io-syntax
+       (format nil
+	       "~%  ~
+	        compiled from ~S~%  ~
+	        at ~A~%  ~
+	        on ~A~%  ~
+	        using ~A version ~A~%"
+	        where
+	        (format-universal-time nil (get-universal-time))
+	        (machine-instance)
+	        (sb!xc:lisp-implementation-type)
+	        (sb!xc:lisp-implementation-version)))
+     stream)
     (dump-byte +fasl-header-string-stop-char-code+ res)
 
-    ;; Finish the header by outputting fasl file implementation and
-    ;; version in machine-readable form.
-    (let ((implementation +backend-fasl-file-implementation+))
-      (dump-unsigned-32 (length (symbol-name implementation)) res)
-      (dotimes (i (length (symbol-name implementation)))
-	(dump-byte (char-code (aref (symbol-name implementation) i)) res)))
-    (dump-unsigned-32 +fasl-file-version+ res)
+    ;; Finish the header by outputting fasl file implementation,
+    ;; version, and key *FEATURES*.
+    (flet ((dump-counted-string (string)
+	     (dump-unsigned-32 (length string) res)
+	     (dotimes (i (length string))
+	       (dump-byte (char-code (aref string i)) res))))
+      (dump-counted-string (symbol-name +backend-fasl-file-implementation+))
+      (dump-unsigned-32 +fasl-file-version+ res)      
+      (dump-counted-string *features-affecting-fasl-format*))
 
     res))
 
@@ -563,9 +578,8 @@
 ;;; this function is not parallel to other functions DUMP-FOO, e.g.
 ;;; DUMP-SYMBOL and DUMP-LIST. The mapping between names and behavior
 ;;; should be made more consistent.
+(declaim (ftype (function (package fasl-output) index) dump-package))
 (defun dump-package (pkg file)
-  (declare (type package pkg) (type fasl-output file))
-  #+nil (declare (values index))
   (declare (inline assoc))
   (cond ((cdr (assoc pkg (fasl-output-packages file) :test #'eq)))
 	(t
@@ -697,7 +711,9 @@
 ;;; tables.
 (defun dump-vector (x file)
   (let ((simple-version (if (array-header-p x)
-			    (coerce x 'simple-array)
+			    (coerce x `(simple-array
+					,(array-element-type x)
+					(*)))
 			    x)))
     (typecase simple-version
       (simple-base-string
@@ -808,8 +824,17 @@
 	;; KLUDGE: What exactly does the (ASH .. -3) stuff do? -- WHN 19990902
 	(simple-bit-vector
 	 (dump-unsigned-vector 1 (ash (+ (the index len) 7) -3)))
+	;; KLUDGE: This isn't the best way of expressing that the host
+	;; may not have specializations for (unsigned-byte 2) and
+	;; (unsigned-byte 4), which means that these types are
+	;; type-equivalent to (simple-array (unsigned-byte 8) (*));
+	;; the workaround is to remove them from the etypecase, since
+	;; they can't be dumped from the cross-compiler anyway. --
+	;; CSR, 2002-05-07
+	#-sb-xc-host
 	((simple-array (unsigned-byte 2) (*))
 	 (dump-unsigned-vector 2 (ash (+ (the index (ash len 1)) 7) -3)))
+	#-sb-xc-host
 	((simple-array (unsigned-byte 4) (*))
 	 (dump-unsigned-vector 4 (ash (+ (the index (ash len 2)) 7) -3)))
 	((simple-array (unsigned-byte 8) (*))
@@ -1235,7 +1260,7 @@
   (when (layout-invalid obj)
     (compiler-error "attempt to dump reference to obsolete class: ~S"
 		    (layout-class obj)))
-  (let ((name (sb!xc:class-name (layout-class obj))))
+  (let ((name (classoid-name (layout-classoid obj))))
     (unless name
       (compiler-error "dumping anonymous layout: ~S" obj))
     (dump-fop 'fop-normal-load file)