X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ffop.lisp;h=89bafa3185010c48c1b8a16b34310bede4fecc05;hb=cd0975b46e46cf6edcbec977616a475df9768bf9;hp=7f58e99e484c82e2b3e6da8ff6c01815a88f4d3d;hpb=d334bb7db90f9f88b22cd4786083ba96d976ba33;p=sbcl.git

diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index 7f58e99..89bafa3 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
 
@@ -180,9 +192,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
@@ -229,7 +248,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)
@@ -347,6 +369,19 @@
     (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)))
@@ -669,7 +704,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)