[Openmcl-cvs-notifications] r10220 - in /release/1.2/source/level-1: l1-aprims.lisp l1-io.lisp l1-lisp-threads.lisp l1-processes.lisp
gb at clozure.com
gb at clozure.com
Sun Jul 27 14:35:02 EDT 2008
Author: gb
Date: Sun Jul 27 14:35:02 2008
New Revision: 10220
Log:
Propagate recent changes from trunk:
l1-aprims.lisp: static value of *WHOSTATE* is "Reset".
l1-io.lisp: use stack-allocated temporary buffer in WRITE-PNAME.
l1-lisp-threads.lisp: in THREAD-ENABLE, default "wait" to 1 day.
l1-processes.lisp: PROCESS-WHOSTATE detects and handles static binding
of *WHOSTATE*. PROCESS-ENABLE waits for 1 day, which is effectively
infinite and avoids word-size issues.
Modified:
release/1.2/source/level-1/l1-aprims.lisp
release/1.2/source/level-1/l1-io.lisp
release/1.2/source/level-1/l1-lisp-threads.lisp
release/1.2/source/level-1/l1-processes.lisp
Modified: release/1.2/source/level-1/l1-aprims.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
--- release/1.2/source/level-1/l1-aprims.lisp (original)
+++ release/1.2/source/level-1/l1-aprims.lisp Sun Jul 27 14:35:02 2008
@@ -49,7 +49,7 @@
(def-standard-initial-binding *locks-pending* ())
(def-standard-initial-binding *lock-conses* (make-list 20)))
(def-standard-initial-binding *whostate* "Reset")
-(setq *whostate* "Active")
+(setq *whostate* "Reset")
(def-standard-initial-binding *error-print-length* 20)
(def-standard-initial-binding *error-print-level* 8)
=
Modified: release/1.2/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
--- release/1.2/source/level-1/l1-io.lisp (original)
+++ release/1.2/source/level-1/l1-io.lisp Sun Jul 27 14:35:02 2008
@@ -985,8 +985,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)
(optimize (speed 3)(safety 0)))
@@ -1022,7 +1020,7 @@
(if (neq sofar c-case)
(return nil))
(setq sofar c-case))))))))
- (declare (dynamic-extent slashify? single-case-p))
+ (declare (dynamic-extent #'slashify? #'single-case-p))
(block alice
(let ((len (length name))
(slash-count 0)
@@ -1064,12 +1062,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))
@@ -1084,8 +1080,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)
Modified: release/1.2/source/level-1/l1-lisp-threads.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
--- release/1.2/source/level-1/l1-lisp-threads.lisp (original)
+++ release/1.2/source/level-1/l1-lisp-threads.lisp Sun Jul 27 14:35:02 2008
@@ -394,7 +394,7 @@
(setf (lisp-thread.initial-function.args thread)
(cons function args)))
=
-(defun thread-enable (thread termination-semaphore allocation-quantum &opt=
ional (timeout most-positive-fixnum))
+(defun thread-enable (thread termination-semaphore allocation-quantum &opt=
ional (timeout (* 60 60 24)))
(let* ((tcr (or (lisp-thread.tcr thread) (new-tcr-for-thread thread))))
(with-macptrs (s)
(%setf-macptr-to-object s (%fixnum-ref tcr target::tcr.reset-complet=
ion))
Modified: release/1.2/source/level-1/l1-processes.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
--- release/1.2/source/level-1/l1-processes.lisp (original)
+++ release/1.2/source/level-1/l1-processes.lisp Sun Jul 27 14:35:02 2008
@@ -216,7 +216,21 @@
"Return a string which describes the status of a specified process."
(if (process-exhausted-p p)
"Exhausted"
- (symbol-value-in-process '*whostate* p)))
+ (let* ((loc nil))
+ (if (eq p *current-process*)
+ (setq loc (%tcr-binding-location (%current-tcr) '*whostate*))
+ (let* ((tcr (process-tcr p)))
+ (without-interrupts
+ (unwind-protect
+ (progn
+ (%suspend-tcr tcr)
+ (setq loc (%tcr-binding-location tcr '*whostate*)))
+ (%resume-tcr tcr)))))
+ (if loc
+ (%fixnum-ref loc)
+ (if (eq p *initial-process*)
+ "Active"
+ "Reset")))))
=
(defun (setf process-whostate) (new p)
(unless (process-exhausted-p p)
@@ -251,10 +265,12 @@
(setf (symbol-value-in-tcr sym (process-tcr process)) value)))
=
=
-(defun process-enable (p &optional (wait 1))
+(defun process-enable (p &optional (wait (* 60 60 24) wait-p))
"Begin executing the initial function of a specified process."
(setq p (require-type p 'process))
(not-in-current-process p 'process-enable)
+ (when wait-p
+ (check-type wait (unsigned-byte 32)))
(unless (car (process-initial-form p))
(error "Process ~s has not been preset. Use PROCESS-PRESET to preset =
the process." p))
(let* ((thread (process-thread p)))
More information about the Openmcl-cvs-notifications
mailing list