Changeset 6559

Timestamp:

May 16, 2007, 12:31:25 AM (18 years ago)

Author:

Gary Byers

Message:

Try to deal with the "SIMPLE-BASE-STRING, all of it" case in
%CSTR-POINTER; deal with all other cases in %CSTR-SEGMENT-POINTER.

File:

• trunk/ccl/level-0/l0-aprims.lisp (modified) (1 diff)

trunk/ccl/level-0/l0-aprims.lisp

@@ -57 +57 @@
 
 (defun %cstr-pointer (string pointer &optional (nul-terminated t))
-  (multiple-value-bind (s o n) (dereference-base-string string)
-    (declare (fixnum o n))
-    (do* ((i 0 (1+ i))
-          (o o (1+ o)))
-         ((= i n))
-      (declare (fixnum i o))
-      (setf (%get-unsigned-byte pointer i)
-            (let* ((code (char-code (schar s o))))
-              (declare (type (mod #x110000) code))
-              (if (< code 256)
-                code
-                (char-code #\Sub)))))
-    (when nul-terminated
-      (setf (%get-byte pointer n) 0)))
-  nil)
+  (if (typep string 'simple-base-string)
+    (locally (declare (simple-base-string string)
+                      (optimize (speed 3) (safety 0)))
+      (let* ((n (length string)))
+        (declare (fixnum n))
+        (dotimes (i n)
+          (setf (%get-unsigned-byte pointer i)
+                (let* ((code (%scharcode string i)))
+                  (declare (type (mod #x110000) code))
+                  (if (< code 256)
+                    code
+                    (char-code #\Sub)))))
+        (when nul-terminated
+          (setf (%get-byte pointer n) 0)))
+      nil))
+  (%cstr-segment-pointer string pointer 0 (length string) nul-terminated))
 
-(defun %cstr-segment-pointer (string pointer start end)
+(defun %cstr-segment-pointer (string pointer start end &optional (nul-terminated t))
   (declare (fixnum start end))
   (let* ((n (- end start)))
     (multiple-value-bind (s o) (dereference-base-string string)
       (declare (fixnum o))
-          (do* ((i 0 (1+ i))
-          (o (the fixnum (+ o start)) (1+ o)))
-         ((= i n))
-      (declare (fixnum i o))
-      (setf (%get-unsigned-byte pointer i)
-            (logand #xff (char-code (schar s o)))))
-    (setf (%get-byte pointer n) 0)
-    nil)))
+      (do* ((i 0 (1+ i))
+            (o (the fixnum (+ o start)) (1+ o)))
+           ((= i n))
+        (declare (fixnum i o))
+        (setf (%get-unsigned-byte pointer i)
+              (let* ((code (char-code (schar s o))))
+                (declare (type (mod #x110000) code))
+                (if (< code 256)
+                  code
+                  (char-code #\Sub))))))
+    (when nul-terminated
+      (setf (%get-byte pointer n) 0))
+    nil))
 
 (defun string (thing)