Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv22927/src/compiler

Modified Files:
      Tag: apd-0-7-cast
	fndb.lisp ir1opt.lisp locall.lisp 
Log Message:
0.7.13.30-cast.7:
        * ENDP requires the argument to be of type LIST (thanks to
          CSR);
        * correct type assertions for arguments of M-V-BIND;
        * fixed evaluation order in unknown values receiver on X86;


Index: fndb.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v
retrieving revision 1.57.2.2
retrieving revision 1.57.2.3
diff -u -d -r1.57.2.2 -r1.57.2.3
--- fndb.lisp	24 Mar 2003 06:22:29 -0000	1.57.2.2
+++ fndb.lisp	28 Mar 2003 07:07:55 -0000	1.57.2.3
@@ -676,7 +676,7 @@
 
 (defknown tree-equal (t t &key (:test callable) (:test-not callable)) boolean
   (foldable flushable call))
-(defknown endp (t) boolean (foldable flushable movable))
+(defknown endp (list) boolean (foldable flushable movable))
 (defknown list-length (list) (or index null) (foldable unsafely-flushable))
 (defknown nth (index list) t (foldable flushable))
 (defknown nthcdr (index list) t (foldable unsafely-flushable))

Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.55.2.3
retrieving revision 1.55.2.4
diff -u -d -r1.55.2.3 -r1.55.2.4
--- ir1opt.lisp	24 Mar 2003 06:22:29 -0000	1.55.2.3
+++ ir1opt.lisp	28 Mar 2003 07:07:55 -0000	1.55.2.4
@@ -1513,9 +1513,9 @@
 		    (propagate-from-sets var type)
 		    (propagate-to-refs var type)))
 	      vars
-		(append types
-			(make-list (max (- (length vars) nvals) 0)
-				   :initial-element (specifier-type 'null))))))
+              (adjust-list types
+                           (length vars)
+                           (specifier-type 'null)))))
     (setf (continuation-reoptimize arg) nil))
   (values))
 

Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.43.2.2
retrieving revision 1.43.2.3
diff -u -d -r1.43.2.2 -r1.43.2.3
--- locall.lisp	20 Mar 2003 10:18:07 -0000	1.43.2.2
+++ locall.lisp	28 Mar 2003 07:07:55 -0000	1.43.2.3
@@ -442,8 +442,7 @@
 
       (assert-continuation-type
        (first (basic-combination-args call))
-       (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
-			 :rest *universal-type*)
+       (make-short-values-type (mapcar #'leaf-type (lambda-vars ep)))
        (lexenv-policy (node-lexenv call)))))
   (values))

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1:/tmp/cvs-serv22927/tests

Modified Files:
      Tag: apd-0-7-cast
	compiler.pure.lisp 
Log Message:
0.7.13.30-cast.7:
        * ENDP requires the argument to be of type LIST (thanks to
          CSR);
        * correct type assertions for arguments of M-V-BIND;
        * fixed evaluation order in unknown values receiver on X86;


Index: compiler.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.pure.lisp,v
retrieving revision 1.27.2.2
retrieving revision 1.27.2.3
diff -u -d -r1.27.2.2 -r1.27.2.3
--- compiler.pure.lisp	20 Mar 2003 10:18:15 -0000	1.27.2.2
+++ compiler.pure.lisp	28 Mar 2003 07:07:55 -0000	1.27.2.3
@@ -232,7 +232,7 @@
     (ignore-errors (ecase 1 (t 0) (1 2)))
   (assert (eql result 2))
   (assert (null error)))
-	  
+
 ;;; FTYPE should accept any functional type specifier
 (compile nil '(lambda (x) (declare (ftype function f)) (f x)))
 
@@ -285,7 +285,6 @@
 	 '(lambda (x) (block nil (print x)))))
 
 ;;; bug 62: too cautious type inference in a loop
-#+nil
 (assert (nth-value
          2
          (compile nil
@@ -333,3 +332,13 @@
        ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil))
    for real-warns-p = (nth-value 1 (compile nil fun))
    do (assert (eq warns-p real-warns-p)))
+
+(raises-error? (multiple-value-bind (a b c)
+                   (eval '(truncate 3 4))
+                 (declare (integer c))
+                 (list a b c))
+               type-error)
+
+(assert (equal (multiple-value-list (the (values &rest integer)
+                                      (eval '(values 3))))
+               '(3)))

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1:/tmp/cvs-serv22927/src/code

Modified Files:
      Tag: apd-0-7-cast
	early-extensions.lisp late-type.lisp 
Log Message:
0.7.13.30-cast.7:
        * ENDP requires the argument to be of type LIST (thanks to
          CSR);
        * correct type assertions for arguments of M-V-BIND;
        * fixed evaluation order in unknown values receiver on X86;


Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.52.2.1
retrieving revision 1.52.2.2
diff -u -d -r1.52.2.1 -r1.52.2.2
--- early-extensions.lisp	20 Mar 2003 10:18:00 -0000	1.52.2.1
+++ early-extensions.lisp	28 Mar 2003 07:07:55 -0000	1.52.2.2
@@ -948,6 +948,15 @@
 
 ;;;; utilities for two-VALUES predicates
 
+(defmacro not/type (x)
+  (let ((val (gensym "VAL"))
+        (win (gensym "WIN")))
+    `(multiple-value-bind (,val ,win)
+         ,x
+       (if ,win
+           (values (not ,val) t)
+           (values nil nil)))))
+
 ;;; sort of like ANY and EVERY, except:
 ;;;   * We handle two-VALUES predicate functions, as SUBTYPEP does.
 ;;;     (And if the result is uncertain, then we return (VALUES NIL NIL),

Index: late-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v
retrieving revision 1.68.2.3
retrieving revision 1.68.2.4
diff -u -d -r1.68.2.3 -r1.68.2.4
--- late-type.lisp	21 Mar 2003 17:13:32 -0000	1.68.2.3
+++ late-type.lisp	28 Mar 2003 07:07:55 -0000	1.68.2.4
@@ -466,6 +466,21 @@
         (t
          (make-values-type :optional (list type) :rest *universal-type*))))
 
+;;; Return type, corresponding to ANSI short form of VALUES type
+;;; specifier.
+(defun make-short-values-type (types)
+  (declare (list types))
+  (let ((last-required (position-if
+                        (lambda (type)
+                          (not/type (csubtypep (specifier-type 'null) type)))
+                        types
+                        :from-end t)))
+    (if last-required
+        (make-values-type :required (subseq types 0 (1+ last-required))
+                          :optional (subseq types (1+ last-required))
+                          :rest *universal-type*)
+        (make-values-type :optional types :rest *universal-type*))))
+
 ;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any
 ;;; type, including VALUES types. With VALUES types such as:
 ;;;    (VALUES a0 a1)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1:/tmp/cvs-serv22927

Modified Files:
      Tag: apd-0-7-cast
	package-data-list.lisp-expr version.lisp-expr 
Log Message:
0.7.13.30-cast.7:
        * ENDP requires the argument to be of type LIST (thanks to
          CSR);
        * correct type assertions for arguments of M-V-BIND;
        * fixed evaluation order in unknown values receiver on X86;


Index: package-data-list.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/package-data-list.lisp-expr,v
retrieving revision 1.199.2.1
retrieving revision 1.199.2.2
diff -u -d -r1.199.2.1 -r1.199.2.2
--- package-data-list.lisp-expr	20 Mar 2003 10:17:58 -0000	1.199.2.1
+++ package-data-list.lisp-expr	28 Mar 2003 07:07:54 -0000	1.199.2.2
@@ -738,7 +738,7 @@
              "CYCLIC-LIST-P"
 	     "COMPOUND-OBJECT-P"
              "SWAPPED-ARGS-FUN"
-             "ANY/TYPE" "EVERY/TYPE"
+             "NOT/TYPE" "ANY/TYPE" "EVERY/TYPE"
 	     "EQUAL-BUT-NO-CAR-RECURSION"
              "TYPE-BOUND-NUMBER"
              "CONSTANTLY-T" "CONSTANTLY-NIL" "CONSTANTLY-0"
@@ -1128,6 +1128,7 @@
 	     "MAKE-NUMERIC-TYPE"
              "MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY"
              "%MAKE-INSTANCE"
+             "MAKE-SHORT-VALUES-TYPE"
 	     "MAKE-VALUE-CELL"
              "MAKE-VALUES-TYPE"
              "MAYBE-GC" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS"

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.762.2.5
retrieving revision 1.762.2.6
diff -u -d -r1.762.2.5 -r1.762.2.6
--- version.lisp-expr	24 Mar 2003 06:22:28 -0000	1.762.2.5
+++ version.lisp-expr	28 Mar 2003 07:07:54 -0000	1.762.2.6
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.13.30-cast.6"
+"0.7.13.30-cast.7"

Update of /cvsroot/sbcl/sbcl/src/compiler/x86
In directory sc8-pr-cvs1:/tmp/cvs-serv22927/src/compiler/x86

Modified Files:
      Tag: apd-0-7-cast
	call.lisp 
Log Message:
0.7.13.30-cast.7:
        * ENDP requires the argument to be of type LIST (thanks to
          CSR);
        * correct type assertions for arguments of M-V-BIND;
        * fixed evaluation order in unknown values receiver on X86;


Index: call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/call.lisp,v
retrieving revision 1.23
retrieving revision 1.23.8.1
diff -u -d -r1.23 -r1.23.8.1
--- call.lisp	17 Nov 2002 13:56:58 -0000	1.23
+++ call.lisp	28 Mar 2003 07:07:55 -0000	1.23.8.1
@@ -385,8 +385,11 @@
 	(done (gen-label)))
     (inst jmp-short variable-values)
 
-    (inst mov start esp-tn)
-    (inst push (first *register-arg-tns*))
+    (cond ((location= start (first *register-arg-tns*))
+           (inst push (first *register-arg-tns*))
+           (inst lea start (make-ea :dword :base esp-tn :disp 4)))
+          (t (inst mov start esp-tn)
+             (inst push (first *register-arg-tns*))))
     (inst mov count (fixnumize 1))
     (inst jmp done)

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1:/tmp/cvs-serv5883/tests

Modified Files:
	compiler.pure.lisp 
Log Message:
0.pre8.11:
	Fixed evaluation order in optional entries (reported by
	Gilbert Baumann in #lisp 2003-03-26).


Index: compiler.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.pure.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- compiler.pure.lisp	6 Mar 2003 05:47:36 -0000	1.29
+++ compiler.pure.lisp	27 Mar 2003 07:29:02 -0000	1.30
@@ -332,3 +332,8 @@
        ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil))
    for real-warns-p = (nth-value 1 (compile nil fun))
    do (assert (eq warns-p real-warns-p)))
+
+;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26
+(assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y)))
+                        '(1 2))
+               '((2) 1)))

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv5883/src/compiler

Modified Files:
	ir1-translators.lisp ir1tran.lisp 
Log Message:
0.pre8.11:
	Fixed evaluation order in optional entries (reported by
	Gilbert Baumann in #lisp 2003-03-26).


Index: ir1-translators.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -d -r1.42 -r1.43
--- ir1-translators.lisp	18 Feb 2003 17:22:05 -0000	1.42
+++ ir1-translators.lisp	27 Mar 2003 07:29:01 -0000	1.43
@@ -530,15 +530,17 @@
   During evaluation of the Forms, bind the Vars to the result of evaluating the
   Value forms. The variables are bound in parallel after all of the Values are
   evaluated."
-  (multiple-value-bind (forms decls) (parse-body body nil)
-    (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
-      (let ((fun-cont (make-continuation)))
-        (let* ((*lexenv* (process-decls decls vars nil cont))
-               (fun (ir1-convert-lambda-body
-                     forms vars
-                     :debug-name (debug-namify "LET ~S" bindings))))
-          (reference-leaf start fun-cont fun))
-        (ir1-convert-combination-args fun-cont cont values)))))
+  (if (null bindings)
+      (ir1-translate-locally  body start cont)
+      (multiple-value-bind (forms decls) (parse-body body nil)
+        (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
+          (let ((fun-cont (make-continuation)))
+            (let* ((*lexenv* (process-decls decls vars nil cont))
+                   (fun (ir1-convert-lambda-body
+                         forms vars
+                         :debug-name (debug-namify "LET ~S" bindings))))
+              (reference-leaf start fun-cont fun))
+            (ir1-convert-combination-args fun-cont cont values))))))
 
 (def-ir1-translator let* ((bindings &body body)
 			  start cont)

Index: ir1tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v
retrieving revision 1.101
retrieving revision 1.102
diff -u -d -r1.101 -r1.102
--- ir1tran.lisp	13 Mar 2003 10:38:08 -0000	1.101
+++ ir1tran.lisp	27 Mar 2003 07:29:01 -0000	1.102
@@ -1535,12 +1535,21 @@
 			      :where-from (leaf-where-from var)
 			      :specvar (lambda-var-specvar var)))
 			   fvars))
-	 (fun (ir1-convert-lambda-body `((%funcall ,fun
-						   ,@(reverse vals)
-						   ,@defaults))
-				       arg-vars
-				       :debug-name "&OPTIONAL processor"
-                                       :note-lexical-bindings nil)))
+	 (fun (collect ((default-bindings)
+                        (default-vals))
+                (dolist (default defaults)
+                  (if (constantp default)
+                      (default-vals default)
+                      (let ((var (gensym)))
+                        (default-bindings `(,var ,default))
+                        (default-vals var))))
+                (ir1-convert-lambda-body `((let (,@(default-bindings))
+                                             (%funcall ,fun
+                                                       ,@(reverse vals)
+                                                       ,@(default-vals))))
+                                         arg-vars
+                                         :debug-name "&OPTIONAL processor"
+                                         :note-lexical-bindings nil))))
     (mapc (lambda (var arg-var)
 	    (when (cdr (leaf-refs arg-var))
 	      (setf (leaf-ever-used var) t)))

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1:/tmp/cvs-serv5883

Modified Files:
	NEWS version.lisp-expr 
Log Message:
0.pre8.11:
	Fixed evaluation order in optional entries (reported by
	Gilbert Baumann in #lisp 2003-03-26).


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.267
retrieving revision 1.268
diff -u -d -r1.267 -r1.268
--- NEWS	25 Mar 2003 16:30:56 -0000	1.267
+++ NEWS	27 Mar 2003 07:28:59 -0000	1.268
@@ -1629,6 +1629,8 @@
   * fixed a bug in computing method discriminating functions: it is
     now possible to define methods specialized on classes which have
     forward-referenced superclasses.  (thanks to Gerd Moellmann)
+  * fixed evaluation order in optional entries. (reported by Gilbert
+    Baumann)
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** COPY-ALIST now signals an error if its argument is a dotted
        list;

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.836
retrieving revision 1.837
diff -u -d -r1.836 -r1.837
--- version.lisp-expr	26 Mar 2003 01:04:41 -0000	1.836
+++ version.lisp-expr	27 Mar 2003 07:29:00 -0000	1.837
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre8.10"
+"0.pre8.11"

Update of /cvsroot/sbcl/sbcl/src/compiler/x86
In directory sc8-pr-cvs1:/tmp/cvs-serv14318/src/compiler/x86

Modified Files:
	insts.lisp 
Log Message:
0.pre8.10
	Add some files needed by the soon-to-be-merged thread support

	Some non-invasive (supposed not to break unithread builds) 
	changes to existing files 
	... add SB-THREAD package
	... fs-segment-prefix "instruction" definition
	... some documentation

	(OK, so it will break McCLIM.  That's easily fixable, though)



Index: insts.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/insts.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- insts.lisp	14 Oct 2002 13:02:52 -0000	1.21
+++ insts.lisp	26 Mar 2003 01:04:42 -0000	1.22
@@ -1036,6 +1036,11 @@
      (emit-ea segment dst (reg-tn-encoding src)))))
 
 
+
+(define-instruction fs-segment-prefix (segment)
+  (:emitter
+   (emit-byte segment #x64)))
+
 ;;;; flag control instructions
 
 ;;; CLC -- Clear Carry Flag.

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1:/tmp/cvs-serv14318

Modified Files:
	base-target-features.lisp-expr package-data-list.lisp-expr 
	version.lisp-expr 
Log Message:
0.pre8.10
	Add some files needed by the soon-to-be-merged thread support

	Some non-invasive (supposed not to break unithread builds) 
	changes to existing files 
	... add SB-THREAD package
	... fs-segment-prefix "instruction" definition
	... some documentation

	(OK, so it will break McCLIM.  That's easily fixable, though)



Index: base-target-features.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/base-target-features.lisp-expr,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- base-target-features.lisp-expr	15 Sep 2002 14:20:23 -0000	1.23
+++ base-target-features.lisp-expr	26 Mar 2003 01:04:41 -0000	1.24
@@ -152,21 +152,14 @@
  ; :high-security
  ; :high-security-support
 
- ;; multiprocessing support
+ ;; low-level thread primitives support
  ;;
- ;; This is not maintained or tested in current SBCL. I haven't gone out
- ;; of my way to break it, but since it's derived from an old version of 
- ;; CMU CL where multiprocessing was pretty shaky, it's likely to be very
- ;; flaky now.
- ;;   :MP enables multiprocessing
- ;;   :MP-I486 is used, only within the multiprocessing code, to control
- ;;            what seems to control processor-version-specific code. It's
- ;;            probably for 486 or later, i.e. could be set as long as
- ;;            you know you're not running on a 386, but it doesn't seem
- ;;            to be documented anywhere, so that's just a guess.
- ; :mp
- ; :mp-i486
-
+ ;; As of SBCL 0.8,  this is only supposed to work in x86 Linux, on which
+ ;; system it's implemented using clone(2) and the %fs segment register.
+ ;; Note that no consistent effort to audit the SBCL library code for
+ ;; thread safety has been performed, so caveat executor
+ ; :sb-thread
+ 
  ;; This affects the definition of a lot of things in bignum.lisp. It
  ;; doesn't seem to be documented anywhere what systems it might apply
  ;; to. It doesn't seem to be needed for X86 systems anyway.

Index: package-data-list.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/package-data-list.lisp-expr,v
retrieving revision 1.206
retrieving revision 1.207
diff -u -d -r1.206 -r1.207
--- package-data-list.lisp-expr	24 Mar 2003 18:38:56 -0000	1.206
+++ package-data-list.lisp-expr	26 Mar 2003 01:04:41 -0000	1.207
@@ -1388,6 +1388,16 @@
              "%ARRAY-TYPEP" "%SET-SAP-REF-DESCRIPTOR"))
 
  #s(sb-cold:package-data
+    :name "SB!THREAD"
+    :use ("CL" "SB!ALIEN")
+    :doc "public (but low-level): native thread support"
+    :export ("MAKE-THREAD"
+	     "MAKE-LISTENER-THREAD" "DESTROY-THREAD" "WITH-RECURSIVE-LOCK"
+	     "MUTEX" "MAKE-MUTEX" "GET-MUTEX" "RELEASE-MUTEX" "WITH-MUTEX"
+	     "WAITQUEUE" "MAKE-WAITQUEUE" "CONDITION-WAIT" "CONDITION-NOTIFY"
+	     "WITH-RECURSIVE-LOCK" "RELEASE-FOREGROUND" "CURRENT-THREAD-ID"))
+ 
+ #s(sb-cold:package-data
     :name "SB!LOOP"
     :doc "private: implementation details of LOOP"
     :use ("CL")

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.835
retrieving revision 1.836
diff -u -d -r1.835 -r1.836
--- version.lisp-expr	25 Mar 2003 16:30:57 -0000	1.835
+++ version.lisp-expr	26 Mar 2003 01:04:41 -0000	1.836
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre8.9"
+"0.pre8.10"

Update of /cvsroot/sbcl/sbcl/doc
In directory sc8-pr-cvs1:/tmp/cvs-serv14318/doc

Modified Files:
	beyond-ansi.sgml 
Log Message:
0.pre8.10
	Add some files needed by the soon-to-be-merged thread support

	Some non-invasive (supposed not to break unithread builds) 
	changes to existing files 
	... add SB-THREAD package
	... fs-segment-prefix "instruction" definition
	... some documentation

	(OK, so it will break McCLIM.  That's easily fixable, though)



Index: beyond-ansi.sgml
===================================================================
RCS file: /cvsroot/sbcl/sbcl/doc/beyond-ansi.sgml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- beyond-ansi.sgml	7 Feb 2003 02:14:25 -0000	1.8
+++ beyond-ansi.sgml	26 Mar 2003 01:04:42 -0000	1.9
@@ -1,3 +1,4 @@
+<!-- -*- mode: SGML; sgml-parent-document: ("user-manual.sgml" "BOOK") -*- -->
 <chapter id="beyond-ansi"><title>Beyond The &ANSI; Standard</>
 
 <para>&SBCL; is mostly an implementation of the &ANSI; standard for
@@ -125,6 +126,115 @@
 behaviour) -->.</para>
 
 </sect2>
+
+<sect2><title>Threading (a.k.a Multiprocessing)</>
+
+<para>&SBCL; (as of version 0.x.y, on Linux x86 only) supports a
+fairly low-level threading interface that maps onto the host operating
+system's concept of threads or lightweight processes.  
+
+<sect3><title>Lisp-level view</title>
+
+<para>A rudimentary interface to creating and managing multiple threads
+can be found in the <literal>sb-thread</literal> package.  This is
+intended for public consumption, so look at the exported symbols and
+their documentation strings.  
+
+<para>Dynamic bindings to symbols are per-thread.   Signal handlers
+are per-thread.
+
+<para><function>sb-ext:quit</function> exits the current thread, not
+necessarily the whole environment.  The environment will be shut down
+when the last thread exits.  
+
+<para>Threads arbitrate between themselves for the user's attention.
+A thread may be in one of three notional states: foreground,
+background, or stopped.  When a background process attempts to print a
+repl prompt or to enter the debugger, it will stop and print a message
+saying that it has stopped.  The user at his leisure may switch to
+that thread to find out what it needs.  If a background thread enters
+the debugger, selecting any restart will put it back into the
+background before it resumes.
+
+<para>If the user has multiple views onto the same Lisp image (for
+example, using multiple terminals, or a windowing system, or network
+access) they are typically set up as multiple `sessions' such that each 
+view has its own collection of foreground/background/stopped threads.
+<function>sb-thread:make-listener-thread</function> can be used to
+start a new thread in its own `session'.
+
+<para>Mutexes and condition variables are available for 
+managing access to shared data: see 
+
+<itemizedlist>
+<listitem>
+<programlisting>(apropos "mutex" :sb-thread)</programlisting> 
+<listitem>
+<programlisting>(apropos "condition" :sb-thread)</programlisting> 
+<listitem> <para>and the <structname>waitqueue</structname> structure
+</para>
+</listitem>
+</itemizedlist>
+
+and poke around in their documentation strings.
+
+<sect3><title>Implementation (Linux x86)</title>
+
+<para>On Linux x86, this is implemented using
+<function>clone()</function> and does not involve pthreads.  This is
+not because there is anything wrong with pthreads <emphasis>per
+se</emphasis>, but there is plenty wrong (from our perspective) with
+LinuxThreads.  &SBCL; threads are mapped 1:1 onto Linux tasks which
+share a VM but nothing else - each has its own process id and can be
+seen in e.g. <command>ps</command> output.
+
+<para>Per-thread local bindings for special variables is achieved
+using the %fs segment register to point to a per-thread storage area.
+This may cause interesting results if you link to foreign code that
+expects threading or creates new threads, and the thread library in
+question uses %fs in an incompatible way.
+
+<para>Threads waiting on queues (e.g. for locks or condition
+variables) are put to sleep using <function>sigtimedwait()</function>
+and woken with SIGCONT.
+
+<para>&SBCL; at present will alway have at least two tasks running as
+seen from Linux: when the first process has done startup
+initialization (mapping files in place, installing signal handlers
+etc) it creates a new thread to run the Lisp startup and initial listener.
+The original thread is then used to run GC and to reap dead subthreads
+when they exit.
+
+<para>Garbage collection is done with the existing Conservative
+Generational GC.  Allocation is done in small (typically 8k) regions :
+each thread has its own region so this involves no stopping. However,
+when a region fills, a lock must be obtained while another is
+allocated, and when a collection is required, all processes are
+stopped.  This is achieved using <function>ptrace()</function>, so you
+should be very careful if you wish to examine an &SBCL; worker thread
+using <command>strace</command>, <command>truss</command>,
+<command>gdb</command> or similar.  It may be prudent to disable GC
+before doing so.
+
+<para>Large amounts of the &SBCL; library have not been inspected for
+thread-safety.  Some of the obviously unsafe areas have large locks
+around them, so compilation and fasl loading, for example, cannot be
+parallelized.  Work is ongoing in this area.
+
+<para>A new thread by default is created in the same POSIX process
+group and session as the thread it was created by.  This has an impact
+on keyboard interrupt handling: pressing your terminal's intr key
+(typically Control-C) will interrupt all processes in the foreground
+process group, including Lisp threads that &SBCL; considers to be
+notionally `background'.  This is undesirable, so background threads
+are set to ignore the SIGINT signal.  Arbitration for the input stream
+is managed by locking on sb-thread::*session-lock*
+
+<para>A thread can be created in a new Lisp 'session' (new terminal or
+window) using <function>sb-thread:make-listener-thread</function>.
+These sessions map directly onto POSIX sessions, so that pressing
+Control-C in the wrong window will not interrupt them - this has been
+found to be embarrassing.
 
 <sect2><title>Support For Unix</>

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory sc8-pr-cvs1:/tmp/cvs-serv14318/src/runtime

Added Files:
	thread.c thread.h 
Log Message:
0.pre8.10
	Add some files needed by the soon-to-be-merged thread support

	Some non-invasive (supposed not to break unithread builds) 
	changes to existing files 
	... add SB-THREAD package
	... fs-segment-prefix "instruction" definition
	... some documentation

	(OK, so it will break McCLIM.  That's easily fixable, though)

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1:/tmp/cvs-serv14318/src/code

Modified Files:
	serve-event.lisp 
Added Files:
	target-thread.lisp thread.lisp 
Log Message:
0.pre8.10
	Add some files needed by the soon-to-be-merged thread support

	Some non-invasive (supposed not to break unithread builds) 
	changes to existing files 
	... add SB-THREAD package
	... fs-segment-prefix "instruction" definition
	... some documentation

	(OK, so it will break McCLIM.  That's easily fixable, though)





Index: serve-event.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/serve-event.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- serve-event.lisp	26 Feb 2003 02:19:09 -0000	1.10
+++ serve-event.lisp	26 Mar 2003 01:04:42 -0000	1.11
@@ -279,8 +279,7 @@
 
 ;;; When a *periodic-polling-function* is defined the server will not
 ;;; block for more than the maximum event timeout and will call the
-;;; polling function if it does time out. One important use of this
-;;; is to periodically call process-yield.
+;;; polling function if it does time out.
 (declaim (type (or null function) *periodic-polling-function*))
 (defvar *periodic-polling-function* nil)
 (declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1:/tmp/cvs-serv20803

Modified Files:
	NEWS version.lisp-expr 
Log Message:
0.pre8.9:
	The other half of the forward-referenced-classes-in-methods 
		issue (again, thanks to Gerd Moellmann)
	... define and use CPL-OR-NIL rather than CLASS-PRECEDENCE-LIST, 
		to accommodate the fact that some specializers might not 
		be finalized


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.266
retrieving revision 1.267
diff -u -d -r1.266 -r1.267
--- NEWS	25 Mar 2003 12:34:32 -0000	1.266
+++ NEWS	25 Mar 2003 16:30:56 -0000	1.267
@@ -1624,8 +1624,11 @@
     private implementation detail, and no longer a semi-private MOP
     interface.
   * known functions, which cannot be open coded by backend, are
-    considered to be able to check types of their arguments. (reported
-    by Nathan J. Froyd)
+    considered to be able to check types of their arguments.
+    (reported by Nathan J. Froyd)
+  * fixed a bug in computing method discriminating functions: it is
+    now possible to define methods specialized on classes which have
+    forward-referenced superclasses.  (thanks to Gerd Moellmann)
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** COPY-ALIST now signals an error if its argument is a dotted
        list;

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.834
retrieving revision 1.835
diff -u -d -r1.834 -r1.835
--- version.lisp-expr	25 Mar 2003 15:39:41 -0000	1.834
+++ version.lisp-expr	25 Mar 2003 16:30:57 -0000	1.835
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre8.8"
+"0.pre8.9"

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1:/tmp/cvs-serv20803/tests

Modified Files:
	clos.impure-cload.lisp 
Log Message:
0.pre8.9:
	The other half of the forward-referenced-classes-in-methods 
		issue (again, thanks to Gerd Moellmann)
	... define and use CPL-OR-NIL rather than CLASS-PRECEDENCE-LIST, 
		to accommodate the fact that some specializers might not 
		be finalized


Index: clos.impure-cload.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/clos.impure-cload.lisp,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- clos.impure-cload.lisp	25 Mar 2003 15:39:45 -0000	1.3
+++ clos.impure-cload.lisp	25 Mar 2003 16:31:02 -0000	1.4
@@ -55,13 +55,13 @@
 (assert (= (class-allocation-reader) 4))
 
 ;;; from James Anderson via Gerd Moellmann: defining methods with
-;;; forward-referenced specializers used not to work (FIXME: and also
-;;; calling said method with an instance of something else
-;;; [SPECIALIZER1, here] should work -- patch forthcoming)
+;;; specializers with forward-referenced superclasses used not to
+;;; work.
 (defclass specializer1 () ())
 (defclass specializer2 (forward-ref1) ())
 (defmethod baz ((x specializer2)) x)
 (defmethod baz ((x specializer1)) x)
+(assert (typep (baz (make-instance 'specializer1)) 'specializer1))
 
 ;;; success
 (sb-ext:quit :unix-status 104)

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs1:/tmp/cvs-serv20803/src/pcl

Modified Files:
	dfun.lisp methods.lisp 
Log Message:
0.pre8.9:
	The other half of the forward-referenced-classes-in-methods 
		issue (again, thanks to Gerd Moellmann)
	... define and use CPL-OR-NIL rather than CLASS-PRECEDENCE-LIST, 
		to accommodate the fact that some specializers might not 
		be finalized


Index: dfun.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/dfun.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- dfun.lisp	25 Mar 2003 15:39:44 -0000	1.22
+++ dfun.lisp	25 Mar 2003 16:31:00 -0000	1.23
@@ -709,6 +709,10 @@
 	  ((and (eq *boot-state* 'complete)
 		(compute-applicable-methods-emf-std-p gf))
 	   (let* ((caching-p (use-caching-dfun-p gf))
+		  ;; KLUDGE: the only effect of this (when
+		  ;; *LAZY-DFUN-COMPUTE-P* is true, as it usually is)
+		  ;; is to signal an error when we try to add methods
+		  ;; with the wrong qualifiers to a generic function.
 		  (classes-list (precompute-effective-methods
 				 gf caching-p
 				 (not *lazy-dfun-compute-p*))))
@@ -1322,6 +1326,12 @@
       (mapcar (lambda (x) (position x lambda-list))
 	      argument-precedence-order)))
 
+(defun cpl-or-nil (class)
+  (if (eq *boot-state* 'complete)
+      (when (class-finalized-p class)
+        (class-precedence-list class))
+      (early-class-precedence-list class)))
+
 (defun saut-and (specl type)
   (let ((applicable nil)
 	(possibly-applicable t))
@@ -1345,8 +1355,8 @@
 
 (defun saut-not-class (specl ntype)
   (let* ((class (type-class specl))
-	 (cpl (class-precedence-list class)))
-     (not (memq (cadr ntype) cpl))))
+	 (cpl (cpl-or-nil class)))
+    (not (memq (cadr ntype) cpl))))
 
 (defun saut-not-prototype (specl ntype)
   (let* ((class (case (car specl)
@@ -1354,8 +1364,8 @@
 		  (class-eq  (cadr specl))
 		  (prototype (cadr specl))
 		  (class     (cadr specl))))
-	 (cpl (class-precedence-list class)))
-     (not (memq (cadr ntype) cpl))))
+	 (cpl (cpl-or-nil class)))
+    (not (memq (cadr ntype) cpl))))
 
 (defun saut-not-class-eq (specl ntype)
   (let ((class (case (car specl)
@@ -1369,9 +1379,7 @@
     (t   t)))
 
 (defun class-applicable-using-class-p (specl type)
-  (let ((pred (memq specl (if (eq *boot-state* 'complete)
-			      (class-precedence-list type)
-			      (early-class-precedence-list type)))))
+  (let ((pred (memq specl (cpl-or-nil type))))
     (values pred
 	    (or pred
 		(if (not *in-precompute-effective-methods-p*)
@@ -1393,7 +1401,7 @@
     (class (class-applicable-using-class-p (cadr specl) (cadr type)))
     (t     (values nil (let ((class (type-class specl)))
 			 (memq (cadr type)
-			       (class-precedence-list class)))))))
+			       (cpl-or-nil class)))))))
 
 (defun saut-class-eq (specl type)
   (if (eq (car specl) 'eql)

Index: methods.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- methods.lisp	25 Mar 2003 00:13:16 -0000	1.21
+++ methods.lisp	25 Mar 2003 16:31:01 -0000	1.22
@@ -561,8 +561,8 @@
 	(pushnew other-class (class-incompatible-superclass-list class))))))
 
 (defun superclasses-compatible-p (class1 class2)
-  (let ((cpl1 (class-precedence-list class1))
-	(cpl2 (class-precedence-list class2)))
+  (let ((cpl1 (cpl-or-nil class1))
+	(cpl2 (cpl-or-nil class2)))
     (dolist (sc1 cpl1 t)
       (dolist (ic (class-incompatible-superclass-list sc1))
 	(when (memq ic cpl2)

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1:/tmp/cvs-serv19786/tests

Modified Files:
	clos.impure-cload.lisp 
Log Message:
0.pre8.8:
	Partial bugfix for defining methods where some of the 
		specializers are forward-referenced-classes
	... noted by James Anderson, fixed by Gerd Moellmann


Index: clos.impure-cload.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/clos.impure-cload.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- clos.impure-cload.lisp	23 Dec 2002 13:53:00 -0000	1.2
+++ clos.impure-cload.lisp	25 Mar 2003 15:39:45 -0000	1.3
@@ -54,5 +54,14 @@
 (class-allocation-writer 4)
 (assert (= (class-allocation-reader) 4))
 
+;;; from James Anderson via Gerd Moellmann: defining methods with
+;;; forward-referenced specializers used not to work (FIXME: and also
+;;; calling said method with an instance of something else
+;;; [SPECIALIZER1, here] should work -- patch forthcoming)
+(defclass specializer1 () ())
+(defclass specializer2 (forward-ref1) ())
+(defmethod baz ((x specializer2)) x)
+(defmethod baz ((x specializer1)) x)
+
 ;;; success
 (sb-ext:quit :unix-status 104)

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs1:/tmp/cvs-serv19786/src/pcl

Modified Files:
	dfun.lisp 
Log Message:
0.pre8.8:
	Partial bugfix for defining methods where some of the 
		specializers are forward-referenced-classes
	... noted by James Anderson, fixed by Gerd Moellmann


Index: dfun.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/dfun.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- dfun.lisp	25 Mar 2003 00:13:15 -0000	1.21
+++ dfun.lisp	25 Mar 2003 15:39:44 -0000	1.22
@@ -686,38 +686,54 @@
 (defvar *lazy-dfun-compute-p* t)
 (defvar *early-p* nil)
 
+(defun finalize-specializers (gf)
+  (let ((all-finalized t))
+    (dolist (method (generic-function-methods gf))
+      (dolist (specializer (method-specializers method))
+	(when (and (classp specializer)
+		   (not (class-finalized-p specializer)))
+	  (if (class-has-a-forward-referenced-superclass-p specializer)
+	      (setq all-finalized nil)
+	      (finalize-inheritance specializer)))))
+    all-finalized))
+
 (defun make-initial-dfun (gf)
   (let ((initial-dfun
 	 #'(instance-lambda (&rest args)
 	     (initial-dfun gf args))))
     (multiple-value-bind (dfun cache info)
-	(if (and (eq *boot-state* 'complete)
-		 (compute-applicable-methods-emf-std-p gf))
-	    (let* ((caching-p (use-caching-dfun-p gf))
-		   (classes-list (precompute-effective-methods
-				  gf caching-p
-				  (not *lazy-dfun-compute-p*))))
-	      (if *lazy-dfun-compute-p*
-		  (cond ((use-dispatch-dfun-p gf caching-p)
-			 (values initial-dfun
-				 nil
-				 (initial-dispatch-dfun-info)))
-			(caching-p
-			 (insure-caching-dfun gf)
-			 (values initial-dfun nil (initial-dfun-info)))
-			(t
-			 (values initial-dfun nil (initial-dfun-info))))
-		  (make-final-dfun-internal gf classes-list)))
-	    (let ((arg-info (if (early-gf-p gf)
-				(early-gf-arg-info gf)
-				(gf-arg-info gf)))
-		  (type nil))
-	      (if (and (gf-precompute-dfun-and-emf-p arg-info)
-		       (setq type (final-accessor-dfun-type gf)))
-		  (if *early-p*
-		      (values (make-early-accessor gf type) nil nil)
-		      (make-final-accessor-dfun gf type))
-		  (values initial-dfun nil (initial-dfun-info)))))
+	(cond
+	  ((and (eq *boot-state* 'complete)
+		(not (finalize-specializers gf)))
+	   (values initial-dfun nil (initial-dfun-info)))
+	  ((and (eq *boot-state* 'complete)
+		(compute-applicable-methods-emf-std-p gf))
+	   (let* ((caching-p (use-caching-dfun-p gf))
+		  (classes-list (precompute-effective-methods
+				 gf caching-p
+				 (not *lazy-dfun-compute-p*))))
+	     (if *lazy-dfun-compute-p*
+		 (cond ((use-dispatch-dfun-p gf caching-p)
+			(values initial-dfun
+				nil
+				(initial-dispatch-dfun-info)))
+		       (caching-p
+			(insure-caching-dfun gf)
+			(values initial-dfun nil (initial-dfun-info)))
+		       (t
+			(values initial-dfun nil (initial-dfun-info))))
+		 (make-final-dfun-internal gf classes-list))))
+	  (t
+	   (let ((arg-info (if (early-gf-p gf)
+			       (early-gf-arg-info gf)
+			       (gf-arg-info gf)))
+		 (type nil))
+	     (if (and (gf-precompute-dfun-and-emf-p arg-info)
+		      (setq type (final-accessor-dfun-type gf)))
+		 (if *early-p*
+		     (values (make-early-accessor gf type) nil nil)
+		     (make-final-accessor-dfun gf type))
+		 (values initial-dfun nil (initial-dfun-info))))))
       (set-dfun gf dfun cache info))))
 
 (defun make-early-accessor (gf type)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1:/tmp/cvs-serv19786

Modified Files:
	version.lisp-expr 
Log Message:
0.pre8.8:
	Partial bugfix for defining methods where some of the 
		specializers are forward-referenced-classes
	... noted by James Anderson, fixed by Gerd Moellmann


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.833
retrieving revision 1.834
diff -u -d -r1.833 -r1.834
--- version.lisp-expr	25 Mar 2003 13:40:09 -0000	1.833
+++ version.lisp-expr	25 Mar 2003 15:39:41 -0000	1.834
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre8.7"
+"0.pre8.8"

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1:/tmp/cvs-serv16649/src/code

Modified Files:
	condition.lisp ntrace.lisp target-signal.lisp unix.lisp 
Log Message:
0.pre8.7
	Implement WITH-TIMEOUT macro, using the SIGALRM handler.

	Write each output from TRACE in a single write() call, to make
	it much much easier (as in, possible) to see what's happening
	when multiple threads are calling TRACEd code at once

	Delete some dead code in compiler/x86/macros.lisp



Index: condition.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/condition.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- condition.lisp	24 Mar 2003 18:39:00 -0000	1.22
+++ condition.lisp	25 Mar 2003 13:40:14 -0000	1.23
@@ -769,6 +769,11 @@
 	       (reader-error-format-control condition)
 	       (reader-error-format-arguments condition)
 	       (reader-impossible-number-error-error condition))))))
+
+;;; should this inherit from error?  good question
+(define-condition timeout (error) ())
+
+
 
 ;;;; special SBCL extension conditions
 

Index: ntrace.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/ntrace.lisp,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -d -r1.28 -r1.29
--- ntrace.lisp	14 Dec 2002 22:10:08 -0000	1.28
+++ ntrace.lisp	25 Mar 2003 13:40:17 -0000	1.29
@@ -250,7 +250,7 @@
 			(trace-wherein-p frame wherein)))))
        (when conditionp
 	 (let ((sb-kernel:*current-level-in-print* 0)
-	       (*standard-output* *trace-output*)
+	       (*standard-output* (make-string-output-stream))
 	       (*in-trace* t))
 	   (fresh-line)
 	   (print-trace-indentation)
@@ -263,7 +263,9 @@
 		 (prin1 `(,(trace-info-what info) ,@arg-list)))
 	       (print-frame-call frame))
 	   (terpri)
-	   (trace-print frame (trace-info-print info)))
+	   (trace-print frame (trace-info-print info))
+	   (write-sequence (get-output-stream-string *standard-output*)
+			   *trace-output*))
 	 (trace-maybe-break info (trace-info-break info) "before" frame)))
 
      (lambda (frame cookie)
@@ -290,7 +292,7 @@
 		     (let ((cond (trace-info-condition-after info)))
 		       (and cond (funcall (cdr cond) frame)))))
 	(let ((sb-kernel:*current-level-in-print* 0)
-	      (*standard-output* *trace-output*)
+	      (*standard-output* (make-string-output-stream))
 	      (*in-trace* t))
 	  (fresh-line)
 	  (pprint-logical-block (*standard-output* nil)
@@ -302,7 +304,9 @@
 	      (pprint-newline :linear)
 	      (prin1 v)))
 	  (terpri)
-	  (trace-print frame (trace-info-print-after info)))
+	  (trace-print frame (trace-info-print-after info))
+	  (write-sequence (get-output-stream-string *standard-output*)
+			  *trace-output*))
 	(trace-maybe-break info
 			   (trace-info-break-after info)
 			   "after"

Index: target-signal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-signal.lisp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- target-signal.lisp	6 Jun 2002 14:08:09 -0000	1.12
+++ target-signal.lisp	25 Mar 2003 13:40:19 -0000	1.13
@@ -114,7 +114,12 @@
 #!-linux
 (define-signal-handler sigsys-handler "bad argument to a system call")
 (define-signal-handler sigpipe-handler "SIGPIPE")
-(define-signal-handler sigalrm-handler "SIGALRM")
+
+(defun sigalrm-handler (signal info context)
+  (declare (ignore signal info context))
+  (declare (type system-area-pointer context))
+  (cerror "Continue" 'sb!kernel::timeout))
+
 
 (defun sigquit-handler (signal code context)
   (declare (ignore signal code context))

Index: unix.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix.lisp,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -d -r1.30 -r1.31
--- unix.lisp	7 Jun 2002 01:54:42 -0000	1.30
+++ unix.lisp	25 Mar 2003 13:40:20 -0000	1.31
@@ -685,6 +685,98 @@
 	      (addr tz))))
 
 
+;; Type of the second argument to `getitimer' and
+;; the second and third arguments `setitimer'. 
+(define-alien-type nil
+  (struct itimerval
+    (it-interval (struct timeval))	; timer interval
+    (it-value (struct timeval))))	; current value
+
+(defconstant ITIMER-REAL 0)
+(defconstant ITIMER-VIRTUAL 1)
+(defconstant ITIMER-PROF 2)
+
+(defun unix-getitimer(which)
+  "Unix-getitimer returns the INTERVAL and VALUE slots of one of
+   three system timers (:real :virtual or :profile). On success,
+   unix-getitimer returns 5 values,
+   T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec."
+  (declare (type (member :real :virtual :profile) which)
+	   (values t
+		   (unsigned-byte 29) (mod 1000000)
+		   (unsigned-byte 29) (mod 1000000)))
+  (let ((which (ecase which
+		 (:real ITIMER-REAL)
+		 (:virtual ITIMER-VIRTUAL)
+		 (:profile ITIMER-PROF))))
+    (with-alien ((itv (struct itimerval)))
+      (syscall* ("getitimer" int (* (struct itimerval)))
+		(values T
+			(slot (slot itv 'it-interval) 'tv-sec)
+			(slot (slot itv 'it-interval) 'tv-usec)
+			(slot (slot itv 'it-value) 'tv-sec)
+			(slot (slot itv 'it-value) 'tv-usec))
+		which (alien-sap (addr itv))))))
+
+(defun unix-setitimer (which int-secs int-usec val-secs val-usec)
+  " Unix-setitimer sets the INTERVAL and VALUE slots of one of
+   three system timers (:real :virtual or :profile). A SIGALRM signal
+   will be delivered VALUE <seconds+microseconds> from now. INTERVAL,
+   when non-zero, is <seconds+microseconds> to be loaded each time
+   the timer expires. Setting INTERVAL and VALUE to zero disables
+   the timer. See the Unix man page for more details. On success,
+   unix-setitimer returns the old contents of the INTERVAL and VALUE
+   slots as in unix-getitimer."
+  (declare (type (member :real :virtual :profile) which)
+	   (type (unsigned-byte 29) int-secs val-secs)
+	   (type (integer 0 (1000000)) int-usec val-usec)
+	   (values t
+		   (unsigned-byte 29) (mod 1000000)
+		   (unsigned-byte 29) (mod 1000000)))
+  (let ((which (ecase which
+		 (:real ITIMER-REAL)
+		 (:virtual ITIMER-VIRTUAL)
+		 (:profile ITIMER-PROF))))
+    (with-alien ((itvn (struct itimerval))
+		 (itvo (struct itimerval)))
+      (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs
+	    (slot (slot itvn 'it-interval) 'tv-usec) int-usec
+	    (slot (slot itvn 'it-value   ) 'tv-sec ) val-secs
+	    (slot (slot itvn 'it-value   ) 'tv-usec) val-usec)
+      (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval)))
+		(values T
+			(slot (slot itvo 'it-interval) 'tv-sec)
+			(slot (slot itvo 'it-interval) 'tv-usec)
+			(slot (slot itvo 'it-value) 'tv-sec)
+			(slot (slot itvo 'it-value) 'tv-usec))
+		which (alien-sap (addr itvn))(alien-sap (addr itvo))))))
+
+(defmacro with-timeout (expires &body body)
+  "Execute the body, interrupting it with a SIGALRM after at least
+EXPIRES seconds have passed.  Uses Unix setitimer(), restoring any
+previous timer after the body has finished executing"
+  (let ((saved-seconds (gensym "SAVED-SECONDS"))
+	(saved-useconds (gensym "SAVED-USECONDS"))
+	(s (gensym "S")) (u (gensym "U")))
+    `(let (- ,saved-seconds ,saved-useconds)
+      (multiple-value-setq (- - - ,saved-seconds ,saved-useconds)
+	(unix-getitimer :real))
+      (multiple-value-bind (,s ,u) (floor ,expires)
+	(setf ,u (floor (* ,u 1000000)))
+	(if (and (> ,expires 0)
+		 (or (and (zerop ,saved-seconds) (zerop ,saved-useconds))
+		     (> ,saved-seconds ,s)
+		     (and (= ,saved-seconds ,s)
+			  (> ,saved-useconds ,u))))
+	    (unwind-protect
+		 (progn
+		   (unix-setitimer :real 0 0 ,s ,u)
+		   ,@body)
+	      (unix-setitimer :real 0 0 ,saved-seconds ,saved-useconds))
+	    ,@body)))))
+
+
+
 (defconstant ENOENT 2) ; Unix error code, "No such file or directory"
 (defconstant EINTR 4) ; Unix error code, "Interrupted system call"
 (defconstant EIO 5) ; Unix error code, "I/O error"

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1:/tmp/cvs-serv16649

Modified Files:
	version.lisp-expr 
Log Message:
0.pre8.7
	Implement WITH-TIMEOUT macro, using the SIGALRM handler.

	Write each output from TRACE in a single write() call, to make
	it much much easier (as in, possible) to see what's happening
	when multiple threads are calling TRACEd code at once

	Delete some dead code in compiler/x86/macros.lisp



Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.832
retrieving revision 1.833
diff -u -d -r1.832 -r1.833
--- version.lisp-expr	25 Mar 2003 12:34:32 -0000	1.832
+++ version.lisp-expr	25 Mar 2003 13:40:09 -0000	1.833
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre8.6"
+"0.pre8.7"

Update of /cvsroot/sbcl/sbcl/src/compiler/x86
In directory sc8-pr-cvs1:/tmp/cvs-serv16649/src/compiler/x86

Modified Files:
	macros.lisp 
Log Message:
0.pre8.7
	Implement WITH-TIMEOUT macro, using the SIGALRM handler.

	Write each output from TRACE in a single write() call, to make
	it much much easier (as in, possible) to see what's happening
	when multiple threads are calling TRACEd code at once

	Delete some dead code in compiler/x86/macros.lisp



Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/macros.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- macros.lisp	27 Feb 2003 00:49:59 -0000	1.11
+++ macros.lisp	25 Mar 2003 13:40:21 -0000	1.12
@@ -257,17 +257,6 @@
   (cons 'progn
 	(emit-error-break vop error-trap error-code values)))
 
-;;; not used in SBCL
-#|
-(defmacro cerror-call (vop label error-code &rest values)
-  #!+sb-doc
-  "Cause a continuable error. If the error is continued, execution resumes
-  at LABEL."
-  `(progn
-     ,@(emit-error-break vop cerror-trap error-code values)
-     (inst jmp ,label)))
-|#
-
 (defmacro generate-error-code (vop error-code &rest values)
   #!+sb-doc
   "Generate-Error-Code Error-code Value*
@@ -278,24 +267,6 @@
        (error-call ,vop ,error-code ,@values)
        start-lab)))
 
-;;; not used in SBCL
-#|
-(defmacro generate-cerror-code (vop error-code &rest values)
-  #!+sb-doc
-  "Generate-CError-Code Error-code Value*
-  Emit code for a continuable error with the specified Error-Code and
-  context Values. If the error is continued, execution resumes after
-  the GENERATE-CERROR-CODE form."
-  (let ((continue (gensym "CONTINUE-LABEL-"))
-	(error (gensym "ERROR-LABEL-")))
-    `(let ((,continue (gen-label))
-	   (,error (gen-label)))
-       (emit-label ,continue)
-       (assemble (*elsewhere*)
-	 (emit-label ,error)
-	 (cerror-call ,vop ,continue ,error-code ,@values))
-       ,error)))
-|#
 
 ;;;; PSEUDO-ATOMIC

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1:/tmp/cvs-serv14126/tests

Modified Files:
	list.pure.lisp 
Log Message:
0.pre8.6:
	Fix COPY-ALIST bug
	... required to signal a type error on dotted lists.


Index: list.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/list.pure.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- list.pure.lisp	11 Mar 2003 18:24:33 -0000	1.6
+++ list.pure.lisp	25 Mar 2003 12:34:32 -0000	1.7
@@ -106,5 +106,7 @@
                 (append nil (1 2) nil (3 . 4) nil)
                 (reverse (1 2 . 3))
                 (nreverse (1 2 . 3))
-                (nreconc (1 2 . 3) (4 5))))
-  (assert (raises-error? (apply (first test) (copy-tree (rest test))) type-error)))
+                (nreconc (1 2 . 3) (4 5))
+		(copy-alist ((1 . 2) (3 . 4) . 5))))
+  (assert (raises-error? (apply (first test) (copy-tree (rest test)))
+			 type-error)))

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1:/tmp/cvs-serv14126/src/code

Modified Files:
	list.lisp 
Log Message:
0.pre8.6:
	Fix COPY-ALIST bug
	... required to signal a type error on dotted lists.


Index: list.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/list.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- list.lisp	11 Mar 2003 18:24:33 -0000	1.18
+++ list.lisp	25 Mar 2003 12:34:32 -0000	1.19
@@ -301,7 +301,7 @@
       (let ((result (list (car list))))
 	(do ((x (cdr list) (cdr x))
 	     (splice result
-		     (cdr (rplacd splice (cons (car x) '() ))) ))
+		     (cdr (rplacd splice (cons (car x) '())))))
 	    ((atom x)
 	     (unless (null x)
 	       (rplacd splice x))))
@@ -310,12 +310,12 @@
 (defun copy-alist (alist)
   #!+sb-doc
   "Return a new association list which is EQUAL to ALIST."
-  (if (atom alist)
+  (if (endp alist)
       alist
       (let ((result
 	     (cons (if (atom (car alist))
 		       (car alist)
-		       (cons (caar alist) (cdar alist)) )
+		       (cons (caar alist) (cdar alist)))
 		   nil)))
 	(do ((x (cdr alist) (cdr x))
 	     (splice result
@@ -325,10 +325,7 @@
 				       (car x)
 				       (cons (caar x) (cdar x)))
 				   nil)))))
-	    ;; Non-null terminated alist done here.
-	    ((atom x)
-	     (unless (null x)
-	       (rplacd splice x))))
+	    ((endp x)))
 	result)))
 
 (defun copy-tree (object)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1:/tmp/cvs-serv14126

Modified Files:
	version.lisp-expr NEWS 
Log Message:
0.pre8.6:
	Fix COPY-ALIST bug
	... required to signal a type error on dotted lists.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.831
retrieving revision 1.832
diff -u -d -r1.831 -r1.832
--- version.lisp-expr	25 Mar 2003 03:45:11 -0000	1.831
+++ version.lisp-expr	25 Mar 2003 12:34:32 -0000	1.832
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre8.5"
+"0.pre8.6"

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.265
retrieving revision 1.266
diff -u -d -r1.265 -r1.266
--- NEWS	25 Mar 2003 03:45:10 -0000	1.265
+++ NEWS	25 Mar 2003 12:34:32 -0000	1.266
@@ -1626,6 +1626,9 @@
   * known functions, which cannot be open coded by backend, are
     considered to be able to check types of their arguments. (reported
     by Nathan J. Froyd)
+  * fixed some bugs revealed by Paul Dietz' test suite:
+    ** COPY-ALIST now signals an error if its argument is a dotted
+       list;
 
 planned incompatible changes in 0.7.x:
   * (not done yet, but planned:) When the profiling interface settles