Steel Bank Common Lisp

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

Modified Files:
	version.lisp-expr 
Log Message:
sb-aclrepl updates

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.865
retrieving revision 1.866
diff -u -d -r1.865 -r1.866
--- version.lisp-expr	5 Apr 2003 20:51:20 -0000	1.865
+++ version.lisp-expr	5 Apr 2003 23:15:38 -0000	1.866
@@ -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.40"
+"0.pre8.41"

Update of /cvsroot/sbcl/sbcl/contrib/sb-aclrepl
In directory sc8-pr-cvs1:/tmp/cvs-serv29602

Modified Files:
	Makefile sb-aclrepl.asd 
Log Message:
fix Makefile, improve test-op

Index: Makefile
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-aclrepl/Makefile,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- Makefile	5 Apr 2003 20:51:43 -0000	1.2
+++ Makefile	5 Apr 2003 23:15:12 -0000	1.3
@@ -1,2 +1,2 @@
-MODULE=sb-aclrepl
+SYSTEM=sb-aclrepl
 include ../asdf-module.mk

Index: sb-aclrepl.asd
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-aclrepl/sb-aclrepl.asd,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- sb-aclrepl.asd	5 Apr 2003 22:10:03 -0000	1.2
+++ sb-aclrepl.asd	5 Apr 2003 23:15:14 -0000	1.3
@@ -10,6 +10,8 @@
 
 
 ;; FIXME - test for successful compilation of sb-aclrepl
-
 (defmethod perform ((o test-op) (c (eql (find-system :sb-aclrepl))))
-  t)
+  (and (boundp 'sb-impl::*inspect-fun*)
+       (boundp 'sb-int:*repl-prompt-fun*)
+       (boundp 'sb-int:*repl-read-form-fun*)))
+

Update of /cvsroot/sbcl/sbcl/contrib/sb-aclrepl
In directory sc8-pr-cvs1:/tmp/cvs-serv6988

Modified Files:
	sb-aclrepl.asd 
Log Message:
add basic test-op

Index: sb-aclrepl.asd
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-aclrepl/sb-aclrepl.asd,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- sb-aclrepl.asd	5 Apr 2003 20:51:43 -0000	1.1
+++ sb-aclrepl.asd	5 Apr 2003 22:10:03 -0000	1.2
@@ -8,3 +8,8 @@
     :components ((:file "repl")
 		 (:file "inspect" :depends-on ("repl"))))
 
+
+;; FIXME - test for successful compilation of sb-aclrepl
+
+(defmethod perform ((o test-op) (c (eql (find-system :sb-aclrepl))))
+  t)

Update of /cvsroot/sbcl/sbcl/contrib/sb-aclrepl
In directory sc8-pr-cvs1:/tmp/cvs-serv13500

Modified Files:
	Makefile 
Added Files:
	README inspect.lisp repl.lisp sb-aclrepl.asd 
Removed Files:
	sb-aclrepl.lisp 
Log Message:
Add inspector

--- NEW FILE: README ---
The sb-aclrepl module offers an AllegroCL style Read-Eval-Print Loop for
SBCL. An AllegroCL style inspector is integrated. Adding an AllegroCL style
debugger is planned.

Questions, comments, or bug reports should be sent to Kevin Rosenberg
<kevin@...>.

--- NEW FILE: inspect.lisp ---
;;;; Inspector for sb-aclrepl
;;;;
;;;; The documentation, which may or may not apply in its entirety at
;;;; any given time, for this functionality is on the ACL website:
;;;;   <http://www.franz.com/support/documentation/6.2/doc/inspector.htm>.
;;;;
;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP*
;;;; variable.

(cl:in-package :sb-aclrepl)

(defparameter *inspect-stack* nil
  "Stack of the hierarchy of an inspected object.")

(defparameter *parent-select-stack* nil
  "a stack of the indices of parent object components that brought us to the current object.")

(defparameter *inspect-length* 10
  "Number of components to display.")

;; FIXME - raw mode isn't currently used in object display
(defparameter *inspect-raw* nil
  "Raw mode for object display.")

(defvar *inspected*)
(setf (documentation '*inspected* 'variable)
      "the value currently being inspected by CL:INSPECT")

(defvar *inspect-help*
":istep takes between 0 to 3 arguments.
The commands are:
:i             redisplay current object
:i =           redisplay current object
:i nil         redisplay current object
:i ?           display this help
:i *           inspect the current * value
:i + <form>    inspect the (eval form)
:i <index>     inspect the numbered component of object
:i <name>      inspect the named component of object
:i <form>      evaluation and inspect form
:i -           inspect parent
:i ^           inspect parent
:i <           inspect previous parent component
:i >           inspect next parent component
:i set <index> <form> set indexed component to evalated form
:i set <name> <form>  set named component to evalated form
:i print <max> set the maximum number of components to print
:i skip <n>    skip a number of components when printing
:i tree        print inspect stack
")

;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it
;;; indicates that that a slot is unbound.
(defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))


;; Setup binding for multithreading
(let ((*inspect-stack* nil)
      (*parent-select-stack* nil)
      (*inspect-length* 10)
      (*inspect-raw* nil)
      (*inspected* nil))
  
(defun inspector (object input-stream output-stream)
  (declare (ignore input-stream))
  (setq object (eval object))
  (reset-stack)
  (setq *inspect-stack* (list object))
  (setq *parent-select-stack* (list "(inspect ...)"))
  (%inspect output-stream))

 

(defun istep (arg-string output-stream)
  (%istep arg-string (string-to-list-skip-spaces arg-string) output-stream))

(setq sb-impl::*inspect-fun* #'inspector)

(defun reset-stack ()
  (setq *inspect-stack* nil)
  (setq *parent-select-stack* nil)
  (makunbound '*inspected*))

(defun %istep (arg-string args output-stream)
  (let* ((option (car args))
	 (option-read (when arg-string
			(read-from-string arg-string))))
    (cond
      ;; Redisplay
      ((or (string= "=" option)
	   (zerop (length args)))
       (%inspect output-stream))
      ;; Select parent
      ((or (string= "-" option)
	   (string= "^" option))
       (cond
	 ((> (length *inspect-stack*) 1)
	  (pop *inspect-stack*)
	  (%inspect output-stream))
	 (*inspect-stack*
	   (format output-stream "Object has no parent.~%"))
	 (t
	  (%inspect output-stream))))
      ;; Select * to inspect
      ((string= "*" option)
       (reset-stack) 
       (setq *inspect-stack* (list *))
       (setq *parent-select-stack* (list "(inspect ...)"))
       (%inspect output-stream))
      ;; Start new inspect level for eval'd form
      ((string= "+" option)
       (inspector (eval (second args)) nil output-stream))
      ;; Next or previous parent component
      ((or (string= "<" option)
	   (string= ">" option))
       (if *inspect-stack*
	   (if (eq (length *inspect-stack*) 1)
	       (format output-stream "Object does not have a parent")
	       (let ((parent (second *inspect-stack*))
		     (id (car *parent-select-stack*)))
		 (multiple-value-bind (position list-type elements)
		     (find-object-component parent id)
		   (declare (list elements)
			    (ignore list-type))
		   (let ((new-position (if (string= ">" option)
					   (1+ position)
					   (1- position))))
		     (if (< -1 new-position (length elements))
			 (let ((new-object (elt elements new-position)))
			   (setf (car *inspect-stack*) new-object)
			   (setf (car *parent-select-stack*)
				 (if (integerp id)
				     new-position
				     (read-from-string
				      (car (nth new-position elements)))))
			   (%inspect output-stream))
			 (format output-stream "Parent has no selectable component indexed by ~d"
				 new-position))))))
	   (%inspect output-stream)))
      ;; Set component to eval'd form
      ((string-equal "set" option)
       (if *inspect-stack*
	   (let ((id (when (second args)
			 (read-from-string (second args)))))
	     (multiple-value-bind (position list-type elements)
		 (find-object-component (car *inspect-stack*) id)
	       (declare (ignore list-type))
	       (if elements
		   (if position
		       (let ((value-stirng (third args)))
			 (when value-stirng
			   (let ((new-value (eval (read-from-string (third args)))))
			     ;; FIXME -- this will require new new generic
			     ;; function to set component of the object
			     (format output-stream "Set component - not yet implemented")))
			 (%inspect output-stream))
		       (format output-stream
			       "Object has no selectable component named by ~A" id))
		   (format output-stream
			   "Object has no selectable components"))))
	     (%inspect output-stream)))
      ;; Set/reset raw display mode for components
      ((string-equal "raw" option)
       (when *inspect-stack*
	 (when (and (second args)
		    (or (null (second args))
			(eq (read-from-string (second args)) t)))
	   (setq *inspect-raw* t))
	 (%inspect output-stream)))
      ;; Reset stack
      ((string-equal "q" option)
       (reset-stack))
      ;; Display help
      ((string-equal "?" option)
       (format output-stream *inspect-help*))
      ;; Set number of components to skip
      ((string-equal "skip" option)
       (let ((len (read-from-string (second args))))
	 (if (and (integerp len) (>= len 0))
	     (%inspect output-stream len)
	     (format output-stream "Skip missing or invalid~%"))))
      ;; Print stack tree
      ((string-equal "tree" option)
       (if *inspect-stack*
	   (progn
	     (format output-stream "The current object is:~%")
	     (dotimes (i (length *inspect-stack*))
	       (format output-stream "~A, ~A~%"
		       (inspected-parts (nth i *inspect-stack*) :description t)
		       (let ((select (nth i *parent-select-stack*)))
			 (typecase select
			   (integer
			    (format nil "which is componenent number ~d of" select))
			   (symbol
			    (format nil "which is the ~a component of" select))
			   (string
			    (format nil "which was selected by ~S" select))
			   (t
			    (write-to-string select)))))))
	   (%inspect output-stream)))
      ;; Set maximum number of components to print 
      ((string-equal "print" option)
       (let ((len (read-from-string (second args))))
	 (if (and (integerp len) (plusp len))
	     (setq *inspect-length* len)
	     (format output-stream "Cannot set print limit to ~A~%" len))))
      ;; Select numbered or named component
      ((or (symbolp option-read)
	   (integerp option-read))
       (if *inspect-stack*
	   (multiple-value-bind (position list-type elements)
	       (find-object-component (car *inspect-stack*) option-read)
	     (cond
	       ((integerp position)
		(let* ((element (elt elements position))
		       (value (if (eq list-type :named) (cdr element) element)))
		  (cond ((eq value *inspect-unbound-object-marker*)
			 (format output-stream "That slot is unbound~%"))
			(t
			 (push value *inspect-stack*)
			 (push option-read *parent-select-stack*)
			 (%inspect output-stream)))))
	       ((null elements)
		(format output-stream "Object does not contain any subobjects~%"))
	       (t
		(typecase option-read
		  (symbol
		   (format output-stream
			   "Object has no selectable component named ~A"
			   option))
		  (integer
		   (format output-stream
			   "Object has no selectable component indexed by ~d~&Enter a valid index (~:[0-~W~;0~])~%"
			   option-read
			   (= (length elements) 1)
			   (1- (length elements))))))))
	   (%inspect output-stream)))
      ;; Default is to select eval'd form
      (t
       (reset-stack)
       (setq *inspect-stack* (list (eval option-read)))
       (setq *parent-select-stack* (list ":i <form>"))
       (%inspect output-stream))
      )))

(defun find-object-component (object id)
  "COMPONENT-ID can be an integer or a name of a id.
Returns POSITION LIST-TYPE ELEMENTS
POSITION is NIL if the id is invalid or not found."
  (if object
      (multiple-value-bind (description list-type elements)
	  (inspected-parts object)
	(declare (ignore description)
		 (list elements))
	(when (symbolp id)
	  (setq id (symbol-name id)))
	(let ((position
	       (cond ((and (eq list-type :named)
			   (stringp id))
		      (position id elements :key #'car :test #'string-equal))
		     ((numberp id)
		      (when (< -1 id (length elements))
			id)))))
	  (values position list-type elements)))
      (values nil nil nil)))


(defun %inspect (s &optional (skip 0))
  (if *inspect-stack*
      (progn
	(setq *inspected* (car *inspect-stack*))
	(setq cl:* *inspected*)
	(multiple-value-bind (description list-type elements) (inspected-parts *inspected*)
	  (display-inspected-parts *inspected* description list-type elements s skip)))
      (format s "No object is being inspected")))


(defun display-inspected-parts (object description list-type elements stream &optional (skip 0))
  (format stream "~&~A" description)
  (unless (or (characterp object) (typep object 'fixnum))
    (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object)))
  (princ #\newline stream)
  (when elements
    (do* ((index skip (1+ index))
	  (nelem (length elements))
	  (max (min (1- nelem) (+ skip *inspect-length*)))
	  (suspension (when (plusp (- nelem max))
			(- nelem max)))
	  (count (if (typep elements 'sequence)
		     (length elements)
		     0))
	  (element))
	 ((> index max))
      (declare (ignore suspension)) ;; FIXME - not yet implemented
      (setq element (elt elements index))
      (cond
	((eq list-type :index-with-tail)
	 (if (eql index (- count 1))
	   (format stream "~4,' D ~A~%" "tail" (inspected-parts element :description t))
	   (format stream "~4,' D ~A~%" index (inspected-parts element :description t))))
	((eq list-type :named)
	 (destructuring-bind (name . value) element
	   (format stream "~4,' D ~16,1,1,'-A> ~A~%" index (format nil "~A "  name)
		 (if (eq value *inspect-unbound-object-marker*)
		     "..unbound.."
		     (inspected-parts value :description t)))))
	(t
	 (format stream "~4,' D ~A~%" index (inspected-parts element :description t)))))))

) ;; end binding for multithreading



;;;; INSPECTED-PARTS

;;; Destructure an object for inspection, returning
;;;   (VALUES DESCRIPTION LIST-TYPE ELEMENTS),
;;; where..
;;;
;;;   DESCRIPTION is a summary description of the destructured object,
;;;   e.g. "the object is a CONS.~%".
;;;
;;;   LIST-TYPE determines what representation is used for elements
;;;   of ELEMENTS.
;;;      If LIST-TYPE is :named, then each element is (CONS NAME VALUE)
;;;      If LIST-TYPE is :index-with-tail, then each element is just value,
;;;        but the last element is marked as "tail"
;;;      If LIST-TYPE is :long, then each element is just value,
;;;        and suspension points ('...) are shown before the last element.
;;;      otherwise, each element is just VALUE.
;;;
;;;   ELEMENTS is a list of the component parts of OBJECT (whose
;;;   representation is determined by LIST-TYPE).
;;;
;;; (LIST-TYPE is useful because symbols and instances
;;; need to display both a slot name and a value, while lists and
;;; vectors need only display a value.)

(defgeneric inspected-parts (object &key description))

(defmethod inspected-parts ((object symbol) &key description)
  (let ((desc (format nil "the symbol ~A" object (sb-kernel:get-lisp-obj-address object))))
    (if description
	desc
	(values desc :named
		(list (cons "name" (symbol-name object))
		      (cons "package" (symbol-package object))
		      (cons "value" (if (boundp object)
					(symbol-value object)
					*inspect-unbound-object-marker*))
		      (cons "function" (if (fboundp object)
					   (symbol-function object)
					   *inspect-unbound-object-marker*))
		      (cons "plist" (symbol-plist object)))))))
    
(defun inspected-structure-elements (object)
  (let ((parts-list '())
        (info (sb-kernel:layout-info (sb-kernel:layout-of object))))
    (when (sb-kernel::defstruct-description-p info)
      (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse parts-list))
        (push (cons (sb-kernel:dsd-%name dd-slot)
                    (funcall (sb-kernel:dsd-accessor-name dd-slot) object))
              parts-list)))))

(defmethod inspected-parts ((object structure-object) &key description)
  (let ((desc (format nil "~W" (find-class (type-of object)))))
    (if description
	desc
	(values desc :named (inspected-structure-elements object)))))

(defmethod inspected-parts ((object package) &key description)
  (let ((desc (format nil "the ~A package" (package-name object))))
    (if description
	desc
	(values desc :named (inspected-structure-elements object)))))

(defun inspected-standard-object-elements (object)
  (let ((reversed-elements nil)
	(class-slots (sb-pcl::class-slots (class-of object))))
    (dolist (class-slot class-slots (nreverse reversed-elements))
      (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
	     (slot-value (if (slot-boundp object slot-name)
			     (slot-value object slot-name)
			     *inspect-unbound-object-marker*)))
	(push (cons slot-name slot-value) reversed-elements)))))

(defmethod inspected-parts ((object standard-object) &key description)
  (let ((desc (format nil "~W" (class-of object))))
    (if description
	desc
	(values desc :named
		(inspected-standard-object-elements object)))))

(defmethod inspected-parts ((object sb-kernel:funcallable-instance) &key description)
  (let ((desc (format nil "a funcallable-instance of type ~S"
		      (type-of object))))
    (if description
	desc
	(values desc :named
		(inspected-structure-elements object)))))

(defmethod inspected-parts ((object function) &key description)
  (let* ((type (sb-kernel:widetag-of object))
	 (object (if (= type sb-vm:closure-header-widetag)
		     (sb-kernel:%closure-fun object)
		     object))
	 (desc (format nil "~S" object)))
    (if description
	desc
	(values desc :named
		(list (cons "arglist" (sb-kernel:%simple-fun-arglist object)))))))

(defmethod inspected-parts ((object vector) &key description)
  (let ((desc  (format nil
		  "a ~:[~;displaced ~]vector (~W)"
		  (and (sb-kernel:array-header-p object)
		       (sb-kernel:%array-displaced-p object))
		  (length object)
		  (sb-kernel:get-lisp-obj-address object))))
    (if description
	desc
	(values desc nil object))))

(defun inspected-index-string (index rev-dimensions)
  (if (null rev-dimensions)
      "[]"
      (let ((list nil))
	(dolist (dim rev-dimensions)
	  (multiple-value-bind (q r) (floor index dim)
	    (setq index q)
 	    (push r list)))
	(format nil "[~W~{,~W~}]" (car list) (cdr list)))))

(defmethod inspected-parts ((object simple-vector) &key description)
  (let ((desc (format nil "a simple ~A vector (~D)"
		      (array-element-type object)
		      (length object))))
    (if description
	desc
	(values desc nil object))))

(defmethod inspected-parts ((object array) &key description)
  (declare (array object))
  (let* ((length (array-total-size object))
	 (reference-array (make-array length :displaced-to object))
	 (dimensions (array-dimensions object))
	 (reversed-elements nil)
	 (desc (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W"
		       (and (sb-kernel:array-header-p object)
			    (sb-kernel:%array-displaced-p object))
		       (array-element-type object)
		       dimensions)))
    (if description
	desc
	(progn
	  (dotimes (i length)
	    (push (cons (format nil "~A "
				(inspected-index-string i (reverse dimensions)))
			(aref reference-array i))
		  reversed-elements))
	  (values desc :named (nreverse reversed-elements))))))

(defmethod inspected-parts ((object cons) &key description)
  (if (or (consp (cdr object)) (null (cdr object)))
      (inspected-parts-of-nontrivial-list object description)
      (inspected-parts-of-simple-cons object description)))

(defun inspected-parts-of-simple-cons (object description)
  (let ((desc (format nil "a cons pair")))
    (if description
	desc
	(values desc :named
		(list (cons "car" (car object))
		      (cons "cdr" (cdr object)))))))

(defun inspected-parts-of-nontrivial-list (object description)
  (let ((length 0)
	(in-list object)
	(reversed-elements nil))
    (flet ((done (description-format list-type)
	     (let ((desc (format nil description-format length length)))
	       (return-from inspected-parts-of-nontrivial-list
		 (if description
		     desc
		     (values desc list-type (nreverse reversed-elements)))))))
      (loop
       (cond ((null in-list)
	      (done "a proper list with ~D element~P" nil))
	     ((consp in-list)
	      (push (pop in-list) reversed-elements)
	      (incf length))
	     (t
	      (push in-list reversed-elements)
	      (done "a improper list with ~D element~P" :index-with-tail)))))))

(defmethod inspected-parts ((object simple-string) &key description)
  (let ((desc (format nil "a simple-string (~W) ~W" (length object) object)))
    (if description
	desc
	(values desc nil object))))

(defmethod inspected-parts ((object double-float) &key description)
  (let ((desc (format nil "double-float ~W" object)))
    (if description
	desc
	(values desc nil nil))))

(defmethod inspected-parts ((object single-float) &key description)
  (let ((desc (format nil "single-float ~W" object)))
    (if description
	desc
	(values desc nil nil))))

(defmethod inspected-parts ((object fixnum) &key description)
  (let ((desc (format nil "fixnum ~W" object)))
    (if description
	desc
	(values desc nil nil))))

(defmethod inspected-parts ((object complex) &key description)
  (let ((desc (format nil "complex number ~W" object)))
    (if description
	desc
	(values desc :named
		(list (cons "real" (realpart object))
		      (cons "imag" (imagpart object)))))))

(defmethod inspected-parts ((object bignum) &key description)
  (let ((desc (format nil "bignum ~W" object)))
    (if description
	desc
	(values desc nil nil))))

(defmethod inspected-parts ((object ratio) &key description)
  (let ((desc (format nil "ratio ~W" object)))
    (if description
	desc
	(values desc :named
		(list (cons "numerator" (numerator object))
		      (cons "denominator" (denominator object)))))))

(defmethod inspected-parts ((object character) &key description)
  (let ((desc (format nil "character ~W char-code #x~X" object (char-code object))))
    (if description
	desc
	(values desc nil nil))))

(defmethod inspected-parts ((object t) &key description)
  (let ((desc (format nil "a generic object ~W" object)))
    (if description
	desc
	(values desc nil nil))))

--- NEW FILE: repl.lisp ---
;;;; Replicate much of the ACL toplevel functionality in SBCL. Mostly
;;;; this is portable code, but fundamentally it all hangs from a few
;;;; SBCL-specific hooks like SB-INT:*REPL-READ-FUN* and
;;;; SB-INT:*REPL-PROMPT-FUN*.
;;;;
;;;; The documentation, which may or may not apply in its entirety at
;;;; any given time, for this functionality is on the ACL website:
;;;;   <http://www.franz.com/support/documentation/6.2/doc/top-level.htm>.

(cl:defpackage :sb-aclrepl
  (:use :cl :sb-ext)
  (:export #:*prompt* #:*exit-on-eof* #:*max-history*
	   #:*use-short-package-name* #:*command-char*
	   #:alias))

(cl:in-package :sb-aclrepl)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *default-prompt* "~&~A(~d): "
    "The default prompt."))
(defparameter *prompt* #.*default-prompt*
  "The current prompt string or formatter function.")
(defparameter *use-short-package-name* t
  "when T, use the shortnest package nickname in a prompt")
(defparameter *dir-stack* nil
  "The top-level directory stack")
(defparameter *command-char* #\:
  "Prefix character for a top-level command")
(defvar *max-history* 24
  "Maximum number of history commands to remember")
(defvar *exit-on-eof* t
  "If T, then exit when the EOF character is entered.")
(defparameter *history* nil
  "History list")
(defparameter *cmd-number* 1
  "Number of the next command")

(declaim (type list *history*))

(defstruct user-cmd
  (input nil) ; input, maybe a string or form
  (func nil)  ; cmd func entered, overloaded
              ; (:eof :null-cmd :cmd-error :history-error)
  (args nil)  ; args for cmd func
  (hnum nil)) ; history number

(defvar *eof-marker* (cons :eof nil))
(defvar *eof-cmd* (make-user-cmd :func :eof))
(defvar *null-cmd* (make-user-cmd :func :null-cmd))

(defparameter *cmd-table-hash*
  (make-hash-table :size 30 :test #'equal))

;; Set up binding for multithreading

(let ((*prompt* #.*default-prompt*)
      (*use-short-package-name* t)
      (*dir-stack* nil)
      (*command-char* #\:)
      (*max-history* 24)
      (*exit-on-eof* t)
      (*history* nil)
      (*cmd-number* 1))
      
(defun prompt-package-name ()
  (if *use-short-package-name*
      (car (sort (append
		  (package-nicknames cl:*package*)
		  (list (package-name cl:*package*)))
		 (lambda (a b) (< (length a) (length b)))))
      (package-name cl:*package*)))

(defun read-cmd (input-stream)
  ;; Reads a command from the user and returns a user-cmd object
  (flet ((parse-args (parsing args-string)
	   (case parsing
	     (:string
	      (if (zerop (length args-string))
		  nil
		  (list args-string)))
 	     (t
	      (let ((string-stream (make-string-input-stream args-string)))
		(loop as arg = (read string-stream nil *eof-marker*)
		      until (eq arg *eof-marker*)
		      collect arg))))))
    (let ((next-char (peek-char-non-whitespace input-stream)))
      (cond
	((eql next-char *command-char*)
	 (let* ((line (string-trim-whitespace (read-line input-stream)))
		(first-space-pos (position #\space line))
		(cmd-string (subseq line 1 first-space-pos))
		(cmd-args-string
		 (if first-space-pos
		     (string-trim-whitespace (subseq line first-space-pos))
		     "")))
	   (declare (string line))
	   (if (numberp (read-from-string cmd-string))
	       (let ((cmd (get-history (read-from-string cmd-string))))
		 (if (eq cmd *null-cmd*)
		     (make-user-cmd :func :history-error
				    :input (read-from-string cmd-string))
		     (make-user-cmd :func (user-cmd-func cmd)
				    :input (user-cmd-input cmd)
				    :args (user-cmd-args cmd)
				    :hnum *cmd-number*)))
	       (let ((cmd-entry (find-cmd cmd-string)))
		 (if cmd-entry
		     (make-user-cmd :func (cmd-table-entry-func cmd-entry)
				    :input line
				    :args (parse-args
					   (cmd-table-entry-parsing cmd-entry)
					   cmd-args-string)
				    :hnum *cmd-number*)
		     (make-user-cmd :func :cmd-error
				    :input cmd-string)
		     )))))
	((eql next-char #\newline)
	 (read-char input-stream)
	 *null-cmd*)
      (t
       (let ((form (read input-stream nil *eof-marker*)))
	 (if (eq form *eof-marker*)
	     *eof-cmd*
	     (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))

;;; cmd table entry
(defstruct cmd-table-entry
  (name nil) ; name of command
  (func nil) ; function handler
  (desc nil) ; short description
  (parsing nil) ; (:string :case-sensitive nil)
  (group nil)) ; command group (:cmd or :alias)
  
(defun make-cte (name-param func desc parsing group)
  (let ((name (etypecase name-param
		(string
		 name-param)
		(symbol
		 (string-downcase (write-to-string name-param))))))
    (make-cmd-table-entry :name name :func func :desc desc
			  :parsing parsing :group group)))

(defun %add-entry (cmd &optional abbr-len)
  (let* ((name (cmd-table-entry-name cmd))
	 (alen (if abbr-len
		   abbr-len
		   (length name))))
    (dotimes (i (length name))
      (when (>= i (1- alen))
	(setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*)
	      cmd)))))

(defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing)
  (%add-entry
   (make-cte cmd-string (symbol-function func-name) desc parsing :cmd)
   abbr-len))
   
(defun find-cmd (cmdstr)
  (gethash (string-downcase cmdstr) *cmd-table-hash*))

(defun user-cmd= (c1 c2)
  "Returns T if two user commands are equal"
  (and (eq (user-cmd-func c1) (user-cmd-func c2))
       (equal (user-cmd-args c1) (user-cmd-args c2))
       (equal (user-cmd-input c1) (user-cmd-input c2))))

(defun add-to-history (cmd)
  (unless (and *history* (user-cmd= cmd (car *history*)))
    (when (>= (length *history*) *max-history*)
      (setq *history* (nbutlast *history* (+ (length *history*) *max-history* 1))))
    (push cmd *history*)
    (incf *cmd-number*)))

(defun get-history (n)
  (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql)))
    (if cmd
	cmd
	*null-cmd*)))

(defun get-cmd-doc-list (&optional (group :cmd))
  "Return list of all commands"
  (let ((cmds '()))
    (maphash (lambda (k v)
	       (when (and
		      (eql (length k) (length (cmd-table-entry-name v)))
		      (eq (cmd-table-entry-group v) group))
		 (push (list k (cmd-table-entry-desc v)) cmds)))
	     *cmd-table-hash*)
    (sort cmds #'string-lessp :key #'car)))

(defun cd-cmd (output-stream &optional string-dir)
  (cond
    ((or (zerop (length string-dir))
	 (string= string-dir "~"))
     (setf cl:*default-pathname-defaults* (user-homedir-pathname)))
    (t
     (let ((new (truename string-dir)))
       (when (pathnamep new)
	 (setf cl:*default-pathname-defaults* new)))))
  (format output-stream "~A~%" (namestring cl:*default-pathname-defaults*))
  (values))

(defun pwd-cmd (output-stream)
  (format output-stream "Lisp's current working directory is ~s.~%"
	  (namestring cl:*default-pathname-defaults*))
  (values))

(defun trace-cmd (output-stream &rest args)
  (if args
      (format output-stream "~A~%" (eval (sb-debug::expand-trace args)))
      (format output-stream "~A~%" (sb-debug::%list-traced-funs)))
  (values))

(defun untrace-cmd (output-stream &rest args)
  (if args
      (format output-stream "~A~%"
	      (eval
	       (sb-int:collect ((res))
		(let ((current args))
		  (loop
		   (unless current (return))
		   (let ((name (pop current)))
		     (res (if (eq name :function)
			      `(sb-debug::untrace-1 ,(pop current))
			      `(sb-debug::untrace-1 ',name))))))
		`(progn ,@(res) t))))
      (format output-stream "~A~%" (eval (sb-debug::untrace-all))))
  (values))

(defun exit-cmd (output-stream &optional (status 0))
  (declare (ignore output-stream))
  (quit :unix-status status)
  (values))

(defun package-cmd (output-stream &optional pkg)
  (cond
    ((null pkg)
     (format output-stream "The ~A package is current.~%"
	     (package-name cl:*package*)))
    ((null (find-package (write-to-string pkg)))
     (format output-stream "Unknown package: ~A.~%" pkg))
    (t
     (setf cl:*package* (find-package (write-to-string pkg)))))
  (values))

(defun string-to-list-skip-spaces (str)
  "Return a list of strings, delimited by spaces, skipping spaces."
  (when str
    (loop for i = 0 then (1+ j)
	  as j = (position #\space str :start i)
	  when (not (char= (char str i) #\space))
	  collect (subseq str i j) while j)))

(let ((last-files-loaded nil))
  (defun ld-cmd (output-stream &optional string-files)
    (if string-files
	(setq last-files-loaded string-files)
	(setq string-files last-files-loaded))
    (dolist (arg (string-to-list-skip-spaces string-files))
      (format output-stream "loading ~a~%" arg)
      (load arg)))
  (values))

(defun cf-cmd (output-stream string-files)
  (declare (ignore output-stream))
  (when string-files
    (dolist (arg (string-to-list-skip-spaces string-files))
      (compile-file arg)))
  (values))

(defun >-num (x y)
  "Return if x and y are numbers, and x > y"
  (and (numberp x) (numberp y) (> x y)))

(defun newer-file-p (file1 file2)
  "Is file1 newer (written later than) file2?"
  (>-num (if (probe-file file1) (file-write-date file1))
	 (if (probe-file file2) (file-write-date file2))))

(defun compile-file-as-needed (src-path)
  "Compiles a file if needed, returns path."
  (let ((dest-path (compile-file-pathname src-path)))
    (when (or (not (probe-file dest-path))
	      (newer-file-p src-path dest-path))
      (ensure-directories-exist dest-path)
      (compile-file src-path :output-file dest-path))
    dest-path))

;;;; implementation of commands

(defun apropos-cmd (output-stream string)
  (declare (ignore output-stream))
  (apropos (string-upcase string))
  (values))

(let ((last-files-loaded nil))
  (defun cload-cmd (output-stream &optional string-files)
    (if string-files
	(setq last-files-loaded string-files)
	(setq string-files last-files-loaded))
    (dolist (arg (string-to-list-skip-spaces string-files))
      (format output-stream "loading ~a~%" arg)
      (load (compile-file-as-needed arg)))
    (values)))

(defun inspect-cmd (output-stream arg)
  (inspector arg nil output-stream)
  (values))

(defun istep-cmd (output-stream &optional arg-string)
  (istep arg-string output-stream)
  (values))

(defun describe-cmd (output-stream &rest args)
  (declare (ignore output-stream))
  (dolist (arg args)
    (eval `(describe ,arg)))
  (values))

(defun macroexpand-cmd (output-stream arg)
  (pprint (macroexpand arg) output-stream)
  (values))

(defun history-cmd (output-stream)
  (let ((n (length *history*)))
    (declare (fixnum n))
    (dotimes (i n)
      (declare (fixnum i))
      (let ((hist (nth (- n i 1) *history*)))
	(format output-stream "~3A ~A~%" (user-cmd-hnum hist)
		(user-cmd-input hist)))))
  (values))

(defun help-cmd (output-stream &optional cmd)
  (cond
    (cmd
     (let ((cmd-entry (find-cmd cmd)))
       (if cmd-entry
	   (format output-stream "Documentation for ~A: ~A~%"
		   (cmd-table-entry-name cmd-entry)
		   (cmd-table-entry-desc cmd-entry)))))
    (t
     (format output-stream "~13A ~a~%" "Command" "Description")
     (format output-stream "------------- -------------~%")
     (format output-stream "~13A ~A~%" "n"
	     "(for any number n) recall nth command from history list")
     (dolist (doc-entry (get-cmd-doc-list :cmd))
       (format output-stream "~13A ~A~%" (car doc-entry) (cadr doc-entry)))))
  (values))

(defun alias-cmd (output-stream)
  (let ((doc-entries (get-cmd-doc-list :alias)))
    (typecase doc-entries
      (cons
       (format output-stream "~13A ~a~%" "Alias" "Description")
       (format output-stream "------------- -------------~%")
       (dolist (doc-entry doc-entries)
	 (format output-stream "~13A ~A~%" (car doc-entry) (cadr doc-entry))))
      (t
       (format output-stream "No aliases are defined~%"))))
  (values))

(defun shell-cmd (output-stream string-arg)
  (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
		      :input nil :output output-stream)
  (values))

(defun pushd-cmd (output-stream string-arg)
  (push string-arg *dir-stack*)
  (cd-cmd output-stream string-arg)
  (values))

(defun popd-cmd (output-stream)
  (if *dir-stack*
      (let ((dir (pop *dir-stack*)))
	(cd-cmd dir))
      (format output-stream "No directory on stack to pop.~%"))
  (values))

(defun dirs-cmd (output-stream)
  (dolist (dir *dir-stack*)
    (format output-stream "~a~%" dir))
  (values))

;;;; dispatch table for commands

(let ((cmd-table
       '(("aliases" 3 alias-cmd "show aliases")
	 ("apropos" 2 apropos-cmd "show apropos" :parsing :string)
	 ("cd" 2 cd-cmd "change default diretory" :parsing :string)
	 ("ld" 2 ld-cmd "load a file" :parsing :string)
	 ("cf" 2 cf-cmd "compile file" :parsing :string)
	 ("cload" 2 cload-cmd "compile if needed and load file"
	  :parsing :string)
	 ("describe" 2 describe-cmd "describe an object")
	 ("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
	 ("package" 2 package-cmd "change current package")
	 ("exit" 2 exit-cmd "exit sbcl")
	 ("help" 2 help-cmd "print this help")
	 ("history" 3 history-cmd "print the recent history")
	 ("inspect" 2 inspect-cmd "inspect an object")
	 ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string)
	 ("pwd" 3 pwd-cmd "print current directory")
	 ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
	 ("popd" 2 popd-cmd "pop directory from stack")
	 ("trace" 2 trace-cmd "trace a function")
	 ("untrace" 4 untrace-cmd "untrace a function")
	 ("dirs" 2 dirs-cmd "show directory stack")
	 ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string))))
  (dolist (cmd cmd-table)
    (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
      (add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))

;;;; machinery for aliases

(defsetf alias (name) (user-func)
  `(progn
    (%add-entry
     (make-cte (quote ,name) ,user-func "" nil :alias))
    (quote ,name)))

(defmacro alias (name-param args &rest body)
  (let ((parsing nil)
	(desc "")
	(abbr-index nil)
	(name (if (atom name-param)
		  name-param
		  (car name-param))))
    (when (consp name-param)
     (dolist (param (cdr name-param))
	(cond
	  ((or
	    (eq param :case-sensitive)
	    (eq param :string))
	   (setq parsing param))
	  ((stringp param)
	   (setq desc param))
	  ((numberp param)
	   (setq abbr-index param)))))
    `(progn
      (%add-entry
       (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias)
       ,abbr-index)
      ,name)))
       
    
(defun remove-alias (&rest aliases)
  (declare (list aliases))
  (let ((keys '())
	(remove-all (not (null (find :all aliases)))))
    (unless remove-all  ;; ensure all alias are strings
      (setq aliases
	    (loop for alias in aliases
		  collect
		  (etypecase alias
		    (string
		     alias)
		    (symbol
		     (symbol-name alias))))))
    (maphash
     (lambda (key cmd)
       (when (eq (cmd-table-entry-group cmd) :alias)
	 (if remove-all
	     (push key keys)
	     (when (some
		    (lambda (alias)
		      (let ((klen (length key)))
			(and (>= (length alias) klen)
			     (string-equal (subseq alias 0 klen)
					   (subseq key 0 klen)))))
		    aliases)
	       (push key keys)))))
     *cmd-table-hash*)
    (dolist (key keys)
      (remhash key *cmd-table-hash*))
    keys))

;;;; low-level reading/parsing functions

;;; Skip white space (but not #\NEWLINE), and peek at the next
;;; character.
(defun peek-char-non-whitespace (&optional stream)
  (do ((char (peek-char nil stream nil *eof-marker*)
	     (peek-char nil stream nil *eof-marker*)))
      ((not (whitespace-char-not-newline-p char)) char)
    (read-char stream)))

(defun string-trim-whitespace (str)
  (string-trim '(#\space #\tab #\return)
	       str))

(defun whitespace-char-not-newline-p (x)
  (and (characterp x)
       (or (char= x #\space)
	   (char= x #\tab)
	   (char= x #\return))))


;;;; linking into SBCL hooks

(defun repl-prompt-fun (stream)
  (if (functionp *prompt*)
      (write-string (funcall *prompt* (prompt-package-name) *cmd-number*)
		    stream)
      (format stream *prompt* (prompt-package-name) *cmd-number*)))
  
(defun process-cmd (user-cmd output-stream)
  ;; Processes a user command. Returns t if the user-cmd was a top-level
  ;; command
  (cond ((eq user-cmd *eof-cmd*)
	 (when *exit-on-eof*
	   (quit))
	 (format output-stream "EOF~%")
	 t)
	((eq user-cmd *null-cmd*)
	 t)
	((eq (user-cmd-func user-cmd) :cmd-error)
	 (format output-stream "Unknown top-level command: ~s.~%"
		 (user-cmd-input user-cmd))
	 (format output-stream "Type `:help' for the list of commands.~%")
	 t)
	((eq (user-cmd-func user-cmd) :history-error)
	 (format output-stream "Input numbered ~d is not on the history list~%"
		 (user-cmd-input user-cmd))
	 t)
	((functionp (user-cmd-func user-cmd))
	 (add-to-history user-cmd)
	 (apply (user-cmd-func user-cmd) output-stream (user-cmd-args user-cmd))
	 (fresh-line)
	 t)
	(t
	 (add-to-history user-cmd)
	 nil))) ; nope, not in my job description

(defun repl-read-form-fun (input-stream output-stream)
  ;; Pick off all the leading ACL magic commands, then return a normal
  ;; Lisp form.
  (loop for user-cmd = (read-cmd input-stream) do
	(if (process-cmd user-cmd output-stream)
	    (progn
	      (repl-prompt-fun output-stream)
	      (force-output output-stream))
	    (return (user-cmd-input user-cmd)))))


(setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
      sb-int:*repl-read-form-fun* #'repl-read-form-fun)

) ;; close special variables bindings


--- NEW FILE: sb-aclrepl.asd ---
;;; -*-  Lisp -*-

(defpackage #:sb-aclrepl-system (:use #:asdf #:cl))
(in-package #:sb-aclrepl-system)

(defsystem sb-aclrepl
    :version "0.5"
    :components ((:file "repl")
		 (:file "inspect" :depends-on ("repl"))))


Index: Makefile
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-aclrepl/Makefile,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- Makefile	8 Feb 2003 15:41:20 -0000	1.1
+++ Makefile	5 Apr 2003 20:51:43 -0000	1.2
@@ -1,5 +1,2 @@
 MODULE=sb-aclrepl
-include ../vanilla-module.mk
-
-test::
-	true
+include ../asdf-module.mk

--- sb-aclrepl.lisp DELETED ---

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

Modified Files:
	version.lisp-expr 
Log Message:
update for sb-aclrepl

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.864
retrieving revision 1.865
diff -u -d -r1.864 -r1.865
--- version.lisp-expr	5 Apr 2003 13:04:14 -0000	1.864
+++ version.lisp-expr	5 Apr 2003 20:51:20 -0000	1.865
@@ -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.39"
+"0.pre8.40"

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

Modified Files:
	NEWS 
Log Message:
Add sb-aclrepl news

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.273
retrieving revision 1.274
diff -u -d -r1.273 -r1.274
--- NEWS	4 Apr 2003 14:24:57 -0000	1.273
+++ NEWS	5 Apr 2003 20:50:09 -0000	1.274
@@ -1644,6 +1644,8 @@
     compiled in by default: you need to add :SB-THREAD to the target
     features.  See the "Beyond ANSI" chapter of the manual for 
     details.
+  * sb-aclrepl module improvements: an integrated inspector, added
+    repl features, and a bug fix to :trace command.
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** COPY-ALIST now signals an error if its argument is a dotted
        list;

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

Modified Files:
	inspect.lisp 
Log Message:
Add hook for external inspector

Index: inspect.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/inspect.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- inspect.lisp	7 Feb 2002 23:33:53 -0000	1.16
+++ inspect.lisp	5 Apr 2003 20:49:44 -0000	1.17
@@ -17,14 +17,21 @@
 ;;; indicates that that a slot is unbound.
 (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))
 
-(defun inspect (object)
+(defun inspector (object input-stream output-stream)
+  (declare (ignore input-stream))
   (catch 'quit-inspect
-    (%inspect object *standard-output*))
+    (%inspect object output-stream))
   (values))
 
+(defvar *inspect-fun* #'inspector
+  "a function of three arguments OBJECT, INPUT, and OUTPUT which starts an interactive inspector.")
+
 (defvar *inspected*)
 (setf (documentation '*inspected* 'variable)
       "the value currently being inspected in CL:INSPECT")
+
+(defun inspect (object)
+  (funcall *inspect-fun* object *standard-input* *standard-output*))
 
 (defvar *help-for-inspect*
   "

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

Modified Files:
	Config.sparc-sunos ppc-linux-os.c purify.c sparc-arch.c 
	sparc-sunos-os.c sunos-os.c thread.c thread.h x86-linux-os.h 
Log Message:
0.pre8.39:
	          === Threads merge, 0.78125 metres ===

Merge patch (CSR sbcl-devel 2003-04-04) supporting SPARC/SunOS.  This version
builds on SPARC/SunOS and x86/Linux in #!-sb-thread mode; it has not been
tested on x86/Linux with threads enabled (and will obviously not run on 
SPARC/SunOS with threads, because of the minor matter of various implementation
details such as a garbage collector and multiprocessing primitives).


Index: Config.sparc-sunos
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/Config.sparc-sunos,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- Config.sparc-sunos	1 Sep 2002 15:14:05 -0000	1.3
+++ Config.sparc-sunos	5 Apr 2003 13:04:15 -0000	1.4
@@ -22,6 +22,6 @@
 OS_SRC = sunos-os.c sparc-sunos-os.c os-common.c 
 #LINKFLAGS+=-static 
 LINKFLAGS+= 
-OS_LIBS= -ldl -lsocket -lnsl 
+OS_LIBS= -ldl -lsocket -lnsl -lrt
 
 GC_SRC= cheneygc.c

Index: ppc-linux-os.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/ppc-linux-os.c,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- ppc-linux-os.c	3 Apr 2003 18:27:26 -0000	1.5
+++ ppc-linux-os.c	5 Apr 2003 13:04:15 -0000	1.6
@@ -41,10 +41,10 @@
 struct thread *arch_os_get_current_thread() {
     return all_threads;
 }
-struct thread *arch_os_thread_init() {
+int arch_os_thread_init(struct thread *thread) {
     return 1;			/* success */
 }
-struct thread *arch_os_thread_cleanup() {
+int arch_os_thread_cleanup(struct thread *thread) {
     return 1;			/* success */
 }
 

Index: purify.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/purify.c,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- purify.c	3 Apr 2003 18:27:28 -0000	1.25
+++ purify.c	5 Apr 2003 13:04:15 -0000	1.26
@@ -17,8 +17,10 @@
 #include <sys/types.h>
 #include <stdlib.h>
 #include <strings.h>
+#if (defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_LINUX))
 #include <sys/ptrace.h>
 #include <linux/user.h>
+#endif
 #include <errno.h>
 
 #include "runtime.h"

Index: sparc-arch.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/sparc-arch.c,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- sparc-arch.c	19 Aug 2002 12:14:04 -0000	1.7
+++ sparc-arch.c	5 Apr 2003 13:04:15 -0000	1.8
@@ -351,6 +351,11 @@
     undoably_install_low_level_interrupt_handler(SIGEMT, sigemt_handler);
 }
 
+void get_spinlock(lispobj *word, int value) {
+    /* FIXME: dummy definition */
+    *word = value;
+}
+
 
 extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
 

Index: sparc-sunos-os.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/sparc-sunos-os.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- sparc-sunos-os.c	6 Aug 2002 11:46:33 -0000	1.4
+++ sparc-sunos-os.c	5 Apr 2003 13:04:15 -0000	1.5
@@ -36,6 +36,19 @@
 
 #include "validate.h"
 
+#ifdef LISP_FEATURE_SB_THREAD
+#error "Define threading support functions"
+#else
+struct thread *arch_os_get_current_thread() {
+    return all_threads;
+}
+int arch_os_thread_init(struct thread *thread) {
+    return 1;			/* success */
+}
+int arch_os_thread_cleanup(struct thread *thread) {
+    return 1;			/* success */
+}
+#endif
 
 os_context_register_t   *
 os_context_register_addr(os_context_t *context, int offset)

Index: sunos-os.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/sunos-os.c,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- sunos-os.c	6 Aug 2002 11:46:33 -0000	1.7
+++ sunos-os.c	5 Apr 2003 13:04:15 -0000	1.8
@@ -150,14 +150,26 @@
        
        Just assume address is valid if it lies within one of the known
        spaces.  (Unlike sunos-os which keeps track of every valid page.) */
-    return (   in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE)
-	       || in_range_p(addr, STATIC_SPACE_START   , STATIC_SPACE_SIZE   )
-	       || in_range_p(addr, DYNAMIC_0_SPACE_START, DYNAMIC_SPACE_SIZE  )
-	       || in_range_p(addr, DYNAMIC_1_SPACE_START, DYNAMIC_SPACE_SIZE  )
-	       || in_range_p(addr, CONTROL_STACK_START  , CONTROL_STACK_SIZE  )
-	       || in_range_p(addr, BINDING_STACK_START  , BINDING_STACK_SIZE  ));
+    
+    /* FIXME: this looks like a valid definition for all targets with
+       cheney-gc; it may not be impressively smart (witness the
+       comment above) but maybe associating these functions with the
+       GC rather than the OS would be a maintainability win.  -- CSR,
+       2003-04-04 */
+    struct thread *th;
+    if(in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) ||
+       in_range_p(addr, STATIC_SPACE_START   , STATIC_SPACE_SIZE) ||
+       in_range_p(addr, DYNAMIC_0_SPACE_START, DYNAMIC_SPACE_SIZE) ||
+       in_range_p(addr, DYNAMIC_1_SPACE_START, DYNAMIC_SPACE_SIZE))
+	return 1;
+    for_each_thread(th) {
+	if((th->control_stack_start <= addr) && (addr < th->control_stack_end))
+	    return 1;
+	if(in_range_p(addr, th->binding_stack_start, BINDING_STACK_SIZE))
+	    return 1;
+    }
+    return 0;
 }
-
 
 
 

Index: thread.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/thread.c,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- thread.c	4 Apr 2003 13:08:11 -0000	1.6
+++ thread.c	5 Apr 2003 13:04:15 -0000	1.7
@@ -1,6 +1,7 @@
 #include <stdlib.h>
 #include <stdio.h>
 #include <sched.h>
+#include <signal.h>
 #include <stddef.h>
 #ifndef CLONE_PARENT		/* lameass glibc 2.2  doesn't define this */
 #define CLONE_PARENT 0x00008000	/* even though the manpage documents it */
@@ -50,8 +51,13 @@
 	fprintf(stderr, "/continue\n");
     }
     th->unbound_marker = UNBOUND_MARKER_WIDETAG;
+#ifdef LISP_FEATURE_SB_THREAD
     /* wait here until our thread is linked into all_threads: see below */
     while(th->pid<1) sched_yield();
+#else
+    if(th->pid < 1)
+	lose("th->pid not set up right");
+#endif
 
     if(arch_os_thread_init(th)==0) 
 	return 1;		/* failure.  no, really */
@@ -249,8 +255,6 @@
     return 0;
 }
 
-
-
 void block_sigcont(void)
 {
     /* don't allow ourselves to receive SIGCONT while we're in the
@@ -270,4 +274,3 @@
     sigwaitinfo(&set,0);
     sigprocmask(SIG_UNBLOCK,&set,0);
 }
-

Index: thread.h
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/thread.h,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- thread.h	3 Apr 2003 18:27:31 -0000	1.4
+++ thread.h	5 Apr 2003 13:04:15 -0000	1.5
@@ -88,6 +88,7 @@
 #endif
 }
 
-    
+int arch_os_thread_init(struct thread *thread);
+extern struct thread *arch_os_get_current_thread();
 
 #endif /* _INCLUDE_THREAD_H_ */

Index: x86-linux-os.h
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/x86-linux-os.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- x86-linux-os.h	2 Apr 2003 11:15:23 -0000	1.5
+++ x86-linux-os.h	5 Apr 2003 13:04:15 -0000	1.6
@@ -8,9 +8,7 @@
     return (os_context_t *) *void_context;
 }
 
-extern struct thread *arch_os_get_current_thread();
 unsigned long os_context_fp_control(os_context_t *context);
 void os_restore_fp_control(os_context_t *context);
-int arch_os_thread_init(struct thread *thread);
 
 #endif /* _X86_LINUX_OS_H */

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

Modified Files:
	parms.lisp system.lisp 
Log Message:
0.pre8.39:
	          === Threads merge, 0.78125 metres ===

Merge patch (CSR sbcl-devel 2003-04-04) supporting SPARC/SunOS.  This version
builds on SPARC/SunOS and x86/Linux in #!-sb-thread mode; it has not been
tested on x86/Linux with threads enabled (and will obviously not run on 
SPARC/SunOS with threads, because of the minor matter of various implementation
details such as a garbage collector and multiprocessing primitives).


Index: parms.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/sparc/parms.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- parms.lisp	23 Jul 2002 17:22:37 -0000	1.6
+++ parms.lisp	5 Apr 2003 13:04:15 -0000	1.7
@@ -159,13 +159,7 @@
   (def!constant dynamic-0-space-end     #x38000000)
   
   (def!constant dynamic-1-space-start   #x40000000)
-  (def!constant dynamic-1-space-end     #x48000000)
-
-  (def!constant control-stack-start   #x50000000)
-  (def!constant control-stack-end     #x51000000)
-
-  (def!constant binding-stack-start    #x60000000)
-  (def!constant binding-stack-end      #x61000000))  
+  (def!constant dynamic-1-space-end     #x48000000))  
 
 
 ;;;; other random constants.
@@ -222,6 +216,10 @@
     *current-catch-block*
     *current-unwind-protect-block*
 
+    *binding-stack-start*
+    *control-stack-start*
+    *control-stack-end*
+    
     ;; interrupt handling
     *free-interrupt-context-index*
     sb!unix::*interrupts-enabled*

Index: system.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/sparc/system.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- system.lisp	4 Dec 2002 15:23:03 -0000	1.2
+++ system.lisp	5 Apr 2003 13:04:15 -0000	1.3
@@ -222,6 +222,8 @@
   (:generator 1
     (inst unimp pending-interrupt-trap)))
 
+#!+sb-thread
+(error "write a VOP for CURRENT-THREAD-OFFSET-SAP")
 
 (define-vop (halt)
   (:generator 1

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

Modified Files:
	target-unithread.lisp 
Log Message:
0.pre8.39:
	          === Threads merge, 0.78125 metres ===

Merge patch (CSR sbcl-devel 2003-04-04) supporting SPARC/SunOS.  This version
builds on SPARC/SunOS and x86/Linux in #!-sb-thread mode; it has not been
tested on x86/Linux with threads enabled (and will obviously not run on 
SPARC/SunOS with threads, because of the minor matter of various implementation
details such as a garbage collector and multiprocessing primitives).


Index: target-unithread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-unithread.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- target-unithread.lisp	4 Apr 2003 14:46:22 -0000	1.2
+++ target-unithread.lisp	5 Apr 2003 13:04:15 -0000	1.3
@@ -1,6 +1,6 @@
 (in-package "SB!THREAD")
 
-#-sb-fluid (declaim (inline sb!vm::current-thread-offset-sap))
+#!-sb-fluid (declaim (inline sb!vm::current-thread-offset-sap))
 (defun sb!vm::current-thread-offset-sap (n) 
   (declare (type (unsigned-byte 27) n))
   (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))

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

Modified Files:
	version.lisp-expr 
Log Message:
0.pre8.39:
	          === Threads merge, 0.78125 metres ===

Merge patch (CSR sbcl-devel 2003-04-04) supporting SPARC/SunOS.  This version
builds on SPARC/SunOS and x86/Linux in #!-sb-thread mode; it has not been
tested on x86/Linux with threads enabled (and will obviously not run on 
SPARC/SunOS with threads, because of the minor matter of various implementation
details such as a garbage collector and multiprocessing primitives).


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.863
retrieving revision 1.864
diff -u -d -r1.863 -r1.864
--- version.lisp-expr	4 Apr 2003 14:46:18 -0000	1.863
+++ version.lisp-expr	5 Apr 2003 13:04:14 -0000	1.864
@@ -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.38"
+"0.pre8.39"