X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=6a443622bd19a7d18f46045ecea3a19c69004455;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=fab38c4e8d80941f72d62be896c4f333527268d5;hpb=988afd9d54ba6c8a915544822658824ab6ae0d6c;p=sbcl.git

diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index fab38c4..6a44362 100644
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -71,7 +71,8 @@
 ;;; of like READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8),
 ;;; with an automatic conversion from (UNSIGNED-BYTE 8) into CHARACTER
 ;;; for each element read
-(declaim (ftype (function (stream simple-string &optional index) (values)) read-string-as-bytes))
+(declaim (ftype (function (stream simple-string &optional index) (values))
+                read-string-as-bytes #!+sb-unicode read-string-as-words))
 (defun read-string-as-bytes (stream string &optional (length (length string)))
   (dotimes (i length)
     (setf (aref string i)
@@ -83,6 +84,17 @@
   ;; significantly better than the portable version here. If it is, then use
   ;; it as an alternate definition, protected with #-SB-XC-HOST.
   (values))
+#!+sb-unicode
+(defun read-string-as-words (stream string &optional (length (length string)))
+  #+sb-xc-host (bug "READ-STRING-AS-WORDS called")
+  (dotimes (i length)
+    (setf (aref string i)
+	  (let ((code 0))
+	    ;; FIXME: is this the same as READ-WORD-ARG?
+	    (dotimes (k sb!vm:n-word-bytes (sb!xc:code-char code))
+	      (setf code (logior code (ash (read-byte stream) 
+					   (* k sb!vm:n-byte-bits))))))))
+  (values))
 
 ;;;; miscellaneous fops
 
@@ -123,28 +135,32 @@
   #-sb-xc-host
   (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-widetag))
 
-;;; CMU CL had FOP-CHARACTER as fop 68, but it's not needed in current
-;;; SBCL as we have no extended characters, only 1-byte characters.
-;;; (Ditto for CMU CL, actually: FOP-CHARACTER was speculative generality.)
-(define-fop (fop-short-character 69)
-  (code-char (read-byte-arg)))
+(define-cloned-fops (fop-character 68) (fop-short-character 69)
+  (code-char (clone-arg)))
 
 (define-cloned-fops (fop-struct 48) (fop-small-struct 49)
   (let* ((size (clone-arg))
 	 (res (%make-instance size)))
     (declare (type index size))
-    (do ((n (1- size) (1- n)))
-	((minusp n))
-      (declare (type index-or-minus-1 n))
-      (setf (%instance-ref res n) (pop-stack)))
+    (let* ((layout (pop-stack))
+	   (nuntagged (layout-n-untagged-slots layout))
+	   (ntagged (- size nuntagged)))
+      (setf (%instance-ref res 0) layout)
+      (dotimes (n (1- ntagged))
+	(declare (type index n))
+	(setf (%instance-ref res (1+ n)) (pop-stack)))
+      (dotimes (n nuntagged)
+	(declare (type index n))
+	(setf (%raw-instance-ref/word res (- nuntagged n 1)) (pop-stack))))
     res))
 
 (define-fop (fop-layout 45)
-  (let ((length (pop-stack))
+  (let ((nuntagged (pop-stack))
+	(length (pop-stack))
 	(depthoid (pop-stack))
 	(inherits (pop-stack))
 	(name (pop-stack)))
-    (find-and-init-or-check-layout name length inherits depthoid)))
+    (find-and-init-or-check-layout name length inherits depthoid nuntagged)))
 
 (define-fop (fop-end-group 64 :stackp nil)
   (/show0 "THROWing FASL-GROUP-END")
@@ -183,9 +199,16 @@
 			      (make-string (* ,n-size 2))))
 		      (done-with-fast-read-byte)
 		      (let ((,n-buffer *fasl-symbol-buffer*))
+                        #+sb-xc-host
 			(read-string-as-bytes *fasl-input-stream*
 					      ,n-buffer
 					      ,n-size)
+                        #-sb-xc-host
+			(#!+sb-unicode read-string-as-words
+                         #!-sb-unicode read-string-as-bytes
+                         *fasl-input-stream*
+                         ,n-buffer
+                         ,n-size)
 			(push-fop-table (without-package-locks
 					 (intern* ,n-buffer
 						  ,n-size
@@ -232,7 +255,10 @@
 		    (fop-uninterned-small-symbol-save 13)
   (let* ((arg (clone-arg))
 	 (res (make-string arg)))
+    #!-sb-unicode
     (read-string-as-bytes *fasl-input-stream* res)
+    #!+sb-unicode
+    (read-string-as-words *fasl-input-stream* res)
     (push-fop-table (make-symbol res))))
 
 (define-fop (fop-package 14)
@@ -344,12 +370,25 @@
 
 ;;;; fops for loading arrays
 
-(define-cloned-fops (fop-string 37) (fop-small-string 38)
+(define-cloned-fops (fop-base-string 37) (fop-small-base-string 38)
   (let* ((arg (clone-arg))
-	 (res (make-string arg)))
+	 (res (make-string arg :element-type 'base-char)))
     (read-string-as-bytes *fasl-input-stream* res)
     res))
 
+#!+sb-unicode
+(progn
+  #+sb-xc-host
+  (define-cloned-fops (fop-character-string 161) (fop-small-character-string 162)
+    (bug "CHARACTER-STRING FOP encountered"))
+
+  #-sb-xc-host
+  (define-cloned-fops (fop-character-string 161) (fop-small-character-string 162)
+    (let* ((arg (clone-arg))
+           (res (make-string arg)))
+      (read-string-as-words *fasl-input-stream* res)
+      res)))
+
 (define-cloned-fops (fop-vector 39) (fop-small-vector 40)
   (let* ((size (clone-arg))
 	 (res (make-array size)))
@@ -639,7 +678,7 @@ bug.~:@>")
   (let* ((kind (pop-stack))
 	 (code-object (pop-stack))
 	 (len (read-byte-arg))
-	 (sym (make-string len)))
+	 (sym (make-string len :element-type 'base-char)))
     (read-n-bytes *fasl-input-stream* sym 0 len)
     (sb!vm:fixup-code-object code-object
 			     (read-word-arg)
@@ -672,7 +711,7 @@ bug.~:@>")
   (let* ((kind (pop-stack))
 	 (code-object (pop-stack))
 	 (len (read-byte-arg))
-	 (sym (make-string len)))
+	 (sym (make-string len :element-type 'base-char)))
     (read-n-bytes *fasl-input-stream* sym 0 len)
     (sb!vm:fixup-code-object code-object
 			     (read-word-arg)