[Openmcl-cvs-notifications] r10217 - /trunk/source/level-1/l1-io.lisp

[gb at clozure.com]

Author: gb
Date: Sun Jul 27 12:29:39 2008
New Revision: 10217

Log:
Don't use *pname-buffer* (not thread-safe/thread-private) in WRITE-PNAME;
use a stack-allocated string instead.

Modified:
    trunk/source/level-1/l1-io.lisp

Modified: trunk/source/level-1/l1-io.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-io.lisp (original)
+++ trunk/source/level-1/l1-io.lisp Sun Jul 27 12:29:39 2008
@@ -995,7 +995,6 @@
     (write-pname name case stream)))
 =

 =

-(defvar *pname-buffer* (%cons-pool "12345678901234567890"))
 =

 (defun write-pname (name case stream)
   (declare (type simple-string name) (stream stream)
@@ -1074,12 +1073,10 @@
                          (t (write-perverted-string name stream len case))=
)))))
             (let* ((outbuf-len (+ len len))
                    (outbuf-ptr -1)
-                   (pool *pname-buffer*)
-                   (outbuf (pool.data pool)))
-              (declare (fixnum outbuf-ptr) (simple-string outbuf))
-              (setf (pool.data pool) nil)   ; grab it.
-              (unless (and outbuf (>=3D (length outbuf) outbuf-len))
-                (setq outbuf (make-array outbuf-len :element-type 'charact=
er)))
+                   (outbuf (make-string outbuf-len)))
+              (declare (fixnum outbuf-ptr outbuf-len)
+                       (dynamic-extent outbuf)
+                       (simple-string outbuf))
               (dotimes (pos (the fixnum len))
                 (declare (type fixnum pos))
                 (let* ((char (schar name pos))
@@ -1094,8 +1091,7 @@
                     (setq slash-count (%i- slash-count 1))
                     (setf (schar outbuf (incf outbuf-ptr)) #\\))
                   (setf (schar outbuf (incf outbuf-ptr)) char)))
-              (write-string outbuf stream :start  0 :end (1+ outbuf-ptr))
-              (setf (pool.data pool) outbuf)))))))
+              (write-string outbuf stream :start  0 :end (1+ outbuf-ptr)))=
)))))
 =

 #|
 (defun write-studly-string (string stream)