Changeset 5053

Timestamp:

Aug 28, 2006, 4:28:21 AM (18 years ago)

Author:

Gary Byers

Message:

New string stuff.

File:

• trunk/ccl/level-0/nfasload.lisp (modified) (7 diffs)

trunk/ccl/level-0/nfasload.lisp

@@ -147 +147 @@
     (values str n copy)))
 
+
+(defun %fasl-read-n-string (s string start n)
+  (declare (fixnum start n))
+  (do* ((i start (1+ i))
+        (n n (1- n)))
+       ((<= n 0))
+    (declare (fixnum i n))
+    (setf (schar string i) (code-char (%fasl-read-count s)))))
+
+(defun %fasl-nvreadstr (s)
+  (let* ((nchars (%fasl-read-count s))
+         (copy t)
+         (n nchars)
+         (str (faslstate.faslstr s)))
+    (declare (fixnum n nbytes))
+    (if (> n (length str))
+        (setq str (make-string n :element-type 'base-char))
+        (setq copy nil))
+    (%fasl-read-n-string  s str 0 nchars)
+    (values str n copy)))
+
 (defun %fasl-copystr (str len)
   (declare (fixnum len))
@@ -185 +206 @@
       (%epushval s sym))))
 
+(defun %fasl-nvmake-symbol (s &optional idx)
+  (declare (fixnum subtype))
+  (let* ((n (%fasl-read-count s))
+         (str (make-string n :element-type 'base-char)))
+    (declare (fixnum n))
+    (%fasl-read-n-string s str 0 n)
+    (let* ((sym (make-symbol str)))
+      (when idx (ensure-binding-index sym))
+      (%epushval s sym))))
+
 (defun %fasl-vintern (s package &optional binding-index)
   (multiple-value-bind (str len new-p) (%fasl-vreadstr s)
+    (with-package-lock (package)
+      (multiple-value-bind (symbol access internal-offset external-offset)
+          (%find-symbol str len package)
+        (unless access
+          (unless new-p (setq str (%fasl-copystr str len)))
+          (setq symbol (%add-symbol str package internal-offset external-offset)))
+        (when binding-index
+          (ensure-binding-index symbol))
+        (%epushval s symbol)))))
+
+(defun %fasl-nvintern (s package &optional binding-index)
+  (multiple-value-bind (str len new-p) (%fasl-nvreadstr s)
     (with-package-lock (package)
       (multiple-value-bind (symbol access internal-offset external-offset)
@@ -242 +285 @@
 (defun %fasl-vpackage (s)
   (multiple-value-bind (str len new-p) (%fasl-vreadstr s)
+    (let* ((p (%find-pkg str len)))
+      (%epushval s (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len))))))))
+
+
+(defun %fasl-nvpackage (s)
+  (multiple-value-bind (str len new-p) (%fasl-nvreadstr s)
     (let* ((p (%find-pkg str len)))
       (%epushval s (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len))))))))
@@ -344 +393 @@
     (%fasl-read-n-bytes s str 0 n)))
 
+(deffaslop $fasl-nvstr (s)
+  (let* ((n (%fasl-read-count s))
+         (str (make-string (the fixnum n) :element-type 'base-char)))
+    (%epushval s str)
+    (%fasl-read-n-string s str 0 n)))
+
 (deffaslop $fasl-word-fixnum (s)
   (%epushval s (%word-to-int (%fasl-read-word s))))
@@ -350 +405 @@
   (%fasl-vmake-symbol s))
 
+(deffaslop $fasl-nvmksym (s)
+  (%fasl-nvmake-symbol s))
+
 (deffaslop $fasl-vmksym-special (s)
   (%fasl-vmake-symbol s t))
 
+(deffaslop $fasl-nvmksym-special (s)
+  (%fasl-nvmake-symbol s t))
+
 (deffaslop $fasl-vintern (s)
   (%fasl-vintern s *package*))
 
+(deffaslop $fasl-nvintern (s)
+  (%fasl-nvintern s *package*))
+
 (deffaslop $fasl-vintern-special (s)
   (%fasl-vintern s *package* t))
+
+(deffaslop $fasl-nvintern-special (s)
+  (%fasl-nvintern s *package* t))
+
+
 
 
@@ -366 +435 @@
     (%fasl-vintern s pkg)))
 
+(deffaslop $fasl-nvpkg-intern (s)
+  (let* ((pkg (%fasl-expr-preserve-epush s)))
+    #+paranoia
+    (setq pkg (pkg-arg pkg))
+    (%fasl-nvintern s pkg)))
+
 (deffaslop $fasl-vpkg-intern-special (s)
   (let* ((pkg (%fasl-expr-preserve-epush s)))
@@ -372 +447 @@
     (%fasl-vintern s pkg t)))
 
+(deffaslop $fasl-nvpkg-intern-special (s)
+  (let* ((pkg (%fasl-expr-preserve-epush s)))
+    #+paranoia
+    (setq pkg (pkg-arg pkg))
+    (%fasl-nvintern s pkg t)))
+
 (deffaslop $fasl-vpkg (s)
   (%fasl-vpackage s))
+
+(deffaslop $fasl-nvpkg (s)
+  (%fasl-nvpackage s))
 
 (deffaslop $fasl-cons (s)