+INTRODUCTION
+============
+
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.
+USAGE
+=====
+To start sb-aclrepl as your read-eval-print loop, execute the command
+ (require 'sb-aclrepl)
+
+You can also all this command to your ~/.sbclrc to have sb-aclrepl be the default REPL
+for your SBCL sessions.
+
+EXAMPLE ~/.sbclrc FILE
+======================
+
+(ignore-errors (require 'sb-aclrepl))
+
+(when (find-package 'sb-aclrepl)
+ (push :aclrepl *features*))
+
+#+aclrepl
+(progn
+ (setq sb-aclrepl:*max-history* 100)
+ (setf (sb-aclrepl:alias "asdc") #'(lambda (sys) (asdf:oos 'asdf:load-op sys)))
+ (sb-aclrepl:alias "l" (sys) (asdf:oos 'asdf:load-op sys))
+ (sb-aclrepl:alias "t" (sys) (asdf:oos 'asdf:test-op sys))
+ ;; The 1 below means that two characaters ("up") are required
+ (sb-aclrepl:alias ("up" 1 "Use package") (package) (use-package package))
+ ;; The 0 below means only the first letter ("r") is required, such as ":r base64"
+ (sb-aclrepl:alias ("require" 0 "Require module") (sys) (require sys))
+)
+
Questions, comments, or bug reports should be sent to Kevin Rosenberg
-<kevin@rosenbrg.net>.
+<kevin@rosenberg.net>.
(defun debugger (condition)
"Enter the debugger."
- (print "Entering debugger")
(let ((old-hook *debugger-hook*))
(when old-hook
(let ((*debugger-hook* nil))
(funcall old-hook condition old-hook))))
+ (%debugger condition))
- (format t "~&Error: ~A~%" condition)
- (format t "~& [Condition type: ~A]~%" (type-of condition))
- (format t "~%")
- (format t "~&Restart actions (select using :continue)~%")
+#+ignore
+(when (boundp 'sb-debug::*invoke-debugger-fun*)
+ (setq sb-debug::*invoke-debugger-fun* #'debugger))
+
+(defun print-condition (condition)
+ (format *output* "~&Error: ~A~%" condition))
+
+(defun print-condition-type (condition)
+ (format *output* "~& [Condition type: ~A]~%" (type-of condition)))
+
+(defun print-restarts ()
+ (format *output* "~&Restart actions (select using :continue)~%")
(let ((restarts (compute-restarts)))
(dotimes (i (length restarts))
- (format t "~&~2D: ~A~%" i (nth i restarts)))
- (new-break :restarts (cons condition restarts)))
- (sb-impl::toplevel-repl nil))
+ (format *output* "~&~2D: ~A~%" i (nth i restarts)))))
+
+(defun %debugger (condition)
+ (print-condition condition)
+ (print-condition-type condition)
+ (princ #\newline *output*)
+ (print-restarts)
+ (debug-loop))
+
+(defun continuable-break-p ()
+ (when (eq 'continue
+ (restart-name (car (compute-restarts))))
+ t))
+
+
+(declaim (special
+ sb-debug::*debug-command-level sb-debug::*debug-command-level*
+ sb-debug::*real-stack-top* sb-debug::*stack-top*
+ sb-debug::*stack-top-hint* sb-debug::*current-frame*
+ sb-debug::*flush-debug-errors*))
+
+(defun debug-loop ()
+ (let* ((sb-debug::*debug-command-level* (1+ sb-debug::*debug-command-level*))
+ (sb-debug::*real-stack-top* (sb-di:top-frame))
+ (sb-debug::*stack-top* (or sb-debug::*stack-top-hint*
+ sb-debug::*real-stack-top*))
+ (sb-debug::*stack-top-hint* nil)
+ (sb-debug::*current-frame* sb-debug::*stack-top*))
+ (handler-bind ((sb-di:debug-condition
+ (lambda (condition)
+ (princ condition sb-debug::*debug-io*)
+ (sb-int:/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
+ (throw 'debug-loop-catcher nil))))
+ (fresh-line)
+ (sb-debug::print-frame-call sb-debug::*current-frame* :verbosity 2)
+ (loop
+ (catch 'debug-loop-catcher
+ (handler-bind ((error (lambda (condition)
+ (when sb-debug::*flush-debug-errors*
+ (clear-input *debug-io*)
+ (princ condition)
+ ;; FIXME: Doing input on *DEBUG-IO*
+ ;; and output on T seems broken.
+ (format t
+ "~&error flushed (because ~
+ ~S is set)"
+ 'sb-debug::*flush-debug-errors*)
+ (sb-int:/show0 "throwing DEBUG-LOOP-CATCHER")
+ (throw 'debug-loop-catcher nil)))))
+ ;; We have to bind LEVEL for the restart function created by
+ ;; WITH-SIMPLE-RESTART.
+ (let ((level sb-debug::*debug-command-level*)
+ (restart-commands (sb-debug::make-restart-commands)))
+ (with-simple-restart (abort
+ "~@<Reduce debugger level (to debug level ~W).~@:>"
+ level)
+ (sb-debug::debug-prompt *debug-io*)
+ (force-output *debug-io*)
+ (let* ((exp (read *debug-io*))
+ (cmd-fun (sb-debug::debug-command-p exp restart-commands)))
+ (cond ((not cmd-fun)
+ (sb-debug::debug-eval-print exp))
+ ((consp cmd-fun)
+ (format t "~&Your command, ~S, is ambiguous:~%"
+ exp)
+ (dolist (ele cmd-fun)
+ (format t " ~A~%" ele)))
+ (t
+ (funcall cmd-fun))))))))))))
+
+#+ignore
+(defun debug-loop ()
+ (let ((continuable (continuable-break-p)))
+ (if continuable
+ (aclrepl :continuable t)
+ (with-simple-restart (abort
+ "~@<Reduce debugger level (to debug level ~W).~@:>"
+ *break-level*)
+ (aclrepl)))))
-;(setq sb-debug::*invoke-debugger-fun* #'debugger)
+#+ignore
+(when (boundp 'sb-debug::*debug-loop-fun*)
+ (setq sb-debug::*debug-loop-fun* #'debug-loop))
(cl:in-package #:sb-aclrepl)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant +default-inspect-length+ 10))
+ (defconstant +default-inspect-length+ 20))
(defstruct inspect
;; stack of parents of inspected object
"Raw mode for object display.")
(defparameter *inspect-length* +default-inspect-length+
"maximum number of components to print")
-(defparameter *inspect-skip* 0
- "number of initial components to skip when displaying an object")
(defparameter *skip-address-display* nil
"Skip displaying addresses of objects.")
:i ? display this help
:i * inspect the current * value
:i + <form> inspect the (eval form)
+:i slot <name> inspect component of object, even if name is an istep cmd
:i <index> inspect the numbered component of object
:i <name> inspect the named component of object
:i <form> evaluation and inspect form
: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
(defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-")))
-;; Setup binding for multithreading
-(let ((*current-inspect* nil)
- (*inspect-raw* nil)
- (*inspect-length* +default-inspect-length+)
- (*inspect-skip* 0)
- (*skip-address-display* nil))
-
- (defun inspector (object input-stream output-stream)
- (declare (ignore input-stream))
+(defun inspector (object input-stream output-stream)
+ (declare (ignore input-stream))
+ (let ((*current-inspect* nil)
+ (*inspect-raw* nil)
+ (*inspect-length* *inspect-length*)
+ (*skip-address-display* nil))
(setq object (eval object))
(setq *current-inspect* (make-inspect))
- (new-break :inspect *current-inspect*)
- (reset-stack)
- (setf (inspect-object-stack *current-inspect*) (list object))
- (setf (inspect-select-stack *current-inspect*)
- (list (format nil "(inspect ...)")))
- (redisplay output-stream))
-
- (setq sb-impl::*inspect-fun* #'inspector)
-
- (defun istep (args stream)
- (unless *current-inspect*
- (setq *current-inspect* (make-inspect)))
- (istep-dispatch args
- (first args)
- (when (first args) (read-from-string (first args)))
- stream))
-
- (defun istep-dispatch (args option-string option stream)
- (cond
- ((or (string= "=" option-string) (zerop (length args)))
- (istep-cmd-redisplay stream))
- ((or (string= "-" option-string) (string= "^" option-string))
- (istep-cmd-parent stream))
- ((string= "*" option-string)
- (istep-cmd-inspect-* stream))
- ((string= "+" option-string)
- (istep-cmd-inspect-new-form (read-from-string (second args)) stream))
- ((or (string= "<" option-string)
- (string= ">" option-string))
- (istep-cmd-select-parent-component option-string stream))
- ((string-equal "set" option-string)
- (istep-cmd-set (second args) (third args) stream))
- ((string-equal "raw" option-string)
- (istep-cmd-set-raw (second args) stream))
- ((string-equal "q" option-string)
- (istep-cmd-reset))
- ((string-equal "?" option-string)
- (istep-cmd-help stream))
- ((string-equal "skip" option-string)
- (istep-cmd-skip (second args) stream))
- ((string-equal "tree" option-string)
- (istep-cmd-tree stream))
- ((string-equal "print" option-string)
- (istep-cmd-print (second args) stream))
- ((or (symbolp option)
- (integerp option))
- (istep-cmd-select-component option stream))
- (t
- (istep-cmd-set-stack option stream))))
+ (reset-stack object "(inspect ...)")
+ (redisplay output-stream)
+ (catch 'inspect-quit
+ (aclrepl :inspect t))
+ (values)))
+
+(setq sb-impl::*inspect-fun* #'inspector)
+
+(defun istep (args stream)
+ (unless *current-inspect*
+ (setq *current-inspect* (make-inspect)))
+ (istep-dispatch args
+ (first args)
+ (when (first args) (read-from-string (first args)))
+ stream))
+
+(defun istep-dispatch (args option-string option stream)
+ (cond
+ ((or (string= "=" option-string) (zerop (length args)))
+ (istep-cmd-redisplay stream))
+ ((or (string= "-" option-string) (string= "^" option-string))
+ (istep-cmd-parent stream))
+ ((string= "*" option-string)
+ (istep-cmd-inspect-* stream))
+ ((string= "+" option-string)
+ (istep-cmd-inspect-new-form (read-from-string (second args)) stream))
+ ((or (string= "<" option-string)
+ (string= ">" option-string))
+ (istep-cmd-select-parent-component option-string stream))
+ ((string-equal "set" option-string)
+ (istep-cmd-set (second args) (third args) stream))
+ ((string-equal "raw" option-string)
+ (istep-cmd-set-raw (second args) stream))
+ ((string-equal "q" option-string)
+ (istep-cmd-reset))
+ ((string-equal "?" option-string)
+ (istep-cmd-help stream))
+ ((string-equal "skip" option-string)
+ (istep-cmd-skip (second args) stream))
+ ((string-equal "tree" option-string)
+ (istep-cmd-tree stream))
+ ((string-equal "print" option-string)
+ (istep-cmd-print (second args) stream))
+ ((string-equal "slot" option-string)
+ (istep-cmd-select-component (read-from-string (second args)) stream))
+ ((or (symbolp option)
+ (integerp option))
+ (istep-cmd-select-component option stream))
+ (t
+ (istep-cmd-set-stack option stream))))
- (defun set-current-inspect (inspect)
- (setq *current-inspect* inspect))
+(defun set-current-inspect (inspect)
+ (setq *current-inspect* inspect))
- (defun reset-stack ()
- (setf (inspect-object-stack *current-inspect*) nil)
- (setf (inspect-select-stack *current-inspect*) nil))
+(defun reset-stack (&optional object label)
+ (cond
+ ((null label)
+ (setf (inspect-object-stack *current-inspect*) nil)
+ (setf (inspect-select-stack *current-inspect*) nil))
+ (t
+ (setf (inspect-object-stack *current-inspect*) (list object))
+ (setf (inspect-select-stack *current-inspect*) (list label)))))
- (defun output-inspect-note (stream note &rest args)
- (apply #'format stream note args)
- (princ #\Newline stream))
+(defun output-inspect-note (stream note &rest args)
+ (apply #'format stream note args)
+ (princ #\Newline stream))
- (defun stack ()
- (inspect-object-stack *current-inspect*))
+(defun stack ()
+ (inspect-object-stack *current-inspect*))
- (defun redisplay (stream)
- (display-current stream))
+(defun redisplay (stream &optional (skip 0))
+ (display-current stream *inspect-length* skip))
- ;;;
- ;;; istep command processing
- ;;;
-
- (defun istep-cmd-redisplay (stream)
- (redisplay stream))
+;;;
+;;; istep command processing
+;;;
- (defun istep-cmd-parent (stream)
- (cond
- ((> (length (inspect-object-stack *current-inspect*)) 1)
- (setf (inspect-object-stack *current-inspect*)
- (cdr (inspect-object-stack *current-inspect*)))
- (setf (inspect-select-stack *current-inspect*)
- (cdr (inspect-select-stack *current-inspect*)))
- (redisplay stream))
- ((stack)
+(defun istep-cmd-redisplay (stream)
+ (redisplay stream))
+
+(defun istep-cmd-parent (stream)
+ (cond
+ ((> (length (inspect-object-stack *current-inspect*)) 1)
+ (setf (inspect-object-stack *current-inspect*)
+ (cdr (inspect-object-stack *current-inspect*)))
+ (setf (inspect-select-stack *current-inspect*)
+ (cdr (inspect-select-stack *current-inspect*)))
+ (redisplay stream))
+ ((stack)
(output-inspect-note stream "Object has no parent"))
- (t
- (no-object-msg stream))))
-
- (defun istep-cmd-inspect-* (stream)
- (reset-stack)
- (setf (inspect-object-stack *current-inspect*) (list *))
- (setf (inspect-select-stack *current-inspect*) (list "(inspect *)"))
- (set-break-inspect *current-inspect*)
- (redisplay stream))
-
- (defun istep-cmd-inspect-new-form (form stream)
- (inspector (eval form) nil stream))
-
- (defun istep-cmd-select-parent-component (option stream)
- (if (stack)
- (if (eql (length (stack)) 1)
- (output-inspect-note stream "Object does not have a parent")
- (let ((parent (second (stack)))
- (id (car (inspect-select-stack *current-inspect*))))
- (multiple-value-bind (position parts)
- (find-part-id parent id)
- (let ((new-position (if (string= ">" option)
- (1+ position)
- (1- position))))
- (if (< -1 new-position (parts-count parts))
- (let* ((value (component-at parts new-position)))
- (setf (car (inspect-object-stack *current-inspect*))
- value)
- (setf (car (inspect-select-stack *current-inspect*))
- (id-at parts new-position))
- (redisplay stream))
- (output-inspect-note stream
- "Parent has no selectable component indexed by ~d"
- new-position))))))
- (no-object-msg stream)))
-
- (defun istep-cmd-set-raw (option-string stream)
- (when (inspect-object-stack *current-inspect*)
- (cond
- ((null option-string)
- (setq *inspect-raw* t))
- ((eq (read-from-string option-string) t)
- (setq *inspect-raw* t))
- ((eq (read-from-string option-string) nil)
- (setq *inspect-raw* nil)))
- (redisplay stream)))
-
- (defun istep-cmd-reset ()
- (reset-stack)
- (set-break-inspect *current-inspect*))
-
- (defun istep-cmd-help (stream)
- (format stream *inspect-help*))
-
- (defun istep-cmd-skip (option-string stream)
- (if option-string
- (let ((len (read-from-string option-string)))
- (if (and (integerp len) (>= len 0))
- (let ((*inspect-skip* len))
- (redisplay stream))
- (output-inspect-note stream "Skip length invalid")))
- (output-inspect-note stream "Skip length missing")))
-
- (defun istep-cmd-print (option-string stream)
- (if option-string
- (let ((len (read-from-string option-string)))
- (if (and (integerp len) (plusp len))
- (setq *inspect-length* len)
- (output-inspect-note stream "Cannot set print limit to ~A~%" len)))
- (output-inspect-note stream "Print length missing")))
-
- (defun select-description (select)
- (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 ~A" select))
- (t
- (write-to-string select))))
-
- (defun istep-cmd-tree (stream)
- (let ((stack (inspect-object-stack *current-inspect*)))
- (if stack
- (progn
- (output-inspect-note stream "The current object is:")
- (dotimes (i (length stack))
- (output-inspect-note
+ (t
+ (no-object-msg stream))))
+
+(defun istep-cmd-inspect-* (stream)
+ (reset-stack * "(inspect *")
+ (redisplay stream))
+
+(defun istep-cmd-inspect-new-form (form stream)
+ (inspector (eval form) nil stream))
+
+(defun istep-cmd-select-parent-component (option stream)
+ (if (stack)
+ (if (eql (length (stack)) 1)
+ (output-inspect-note stream "Object does not have a parent")
+ (let ((parent (second (stack)))
+ (id (car (inspect-select-stack *current-inspect*))))
+ (multiple-value-bind (position parts)
+ (find-part-id parent id)
+ (let ((new-position (if (string= ">" option)
+ (1+ position)
+ (1- position))))
+ (if (< -1 new-position (parts-count parts))
+ (let* ((value (component-at parts new-position)))
+ (setf (car (inspect-object-stack *current-inspect*))
+ value)
+ (setf (car (inspect-select-stack *current-inspect*))
+ (id-at parts new-position))
+ (redisplay stream))
+ (output-inspect-note stream
+ "Parent has no selectable component indexed by ~d"
+ new-position))))))
+ (no-object-msg stream)))
+
+(defun istep-cmd-set-raw (option-string stream)
+ (when (inspect-object-stack *current-inspect*)
+ (cond
+ ((null option-string)
+ (setq *inspect-raw* t))
+ ((eq (read-from-string option-string) t)
+ (setq *inspect-raw* t))
+ ((eq (read-from-string option-string) nil)
+ (setq *inspect-raw* nil)))
+ (redisplay stream)))
+
+(defun istep-cmd-reset ()
+ (reset-stack)
+ (throw 'inspect-quit nil))
+
+(defun istep-cmd-help (stream)
+ (format stream *inspect-help*))
+
+(defun istep-cmd-skip (option-string stream)
+ (if option-string
+ (let ((len (read-from-string option-string)))
+ (if (and (integerp len) (>= len 0))
+ (redisplay stream len)
+ (output-inspect-note stream "Skip length invalid")))
+ (output-inspect-note stream "Skip length missing")))
+
+(defun istep-cmd-print (option-string stream)
+ (if option-string
+ (let ((len (read-from-string option-string)))
+ (if (and (integerp len) (plusp len))
+ (setq *inspect-length* len)
+ (output-inspect-note stream "Cannot set print limit to ~A~%" len)))
+ (output-inspect-note stream "Print length missing")))
+
+(defun select-description (select)
+ (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 ~A" select))
+ (t
+ (write-to-string select))))
+
+(defun istep-cmd-tree (stream)
+ (let ((stack (inspect-object-stack *current-inspect*)))
+ (if stack
+ (progn
+ (output-inspect-note stream "The current object is:")
+ (dotimes (i (length stack))
+ (output-inspect-note
stream "~A, ~A"
(inspected-description (nth i stack))
(select-description
(nth i (inspect-select-stack *current-inspect*))))))
- (no-object-msg stream))))
-
- (defun istep-cmd-set (id-string value-string stream)
- (if (stack)
- (let ((id (when id-string (read-from-string id-string))))
- (multiple-value-bind (position parts)
- (find-part-id (car (stack)) id)
- (if parts
- (if position
- (when value-string
- (let ((new-value (eval (read-from-string value-string))))
- (let ((result (set-component-value (car (stack))
- id
- new-value
- (component-at
- parts position))))
- (typecase result
- (string
- (output-inspect-note stream result))
- (t
- (redisplay stream))))))
- (output-inspect-note
- stream
- "Object has no selectable component named by ~A" id))
- (output-inspect-note stream
- "Object has no selectable components"))))
- (no-object-msg stream)))
-
- (defun istep-cmd-select-component (id stream)
- (if (stack)
+ (no-object-msg stream))))
+
+(defun istep-cmd-set (id-string value-string stream)
+ (if (stack)
+ (let ((id (when id-string (read-from-string id-string))))
(multiple-value-bind (position parts)
(find-part-id (car (stack)) id)
- (cond
- ((integerp position)
- (let* ((value (component-at parts position)))
- (cond ((eq value *inspect-unbound-object-marker*)
- (output-inspect-note stream "That slot is unbound"))
- (t
- (push value (inspect-object-stack *current-inspect*))
- (push id (inspect-select-stack *current-inspect*))
- (redisplay stream)))))
- ((null parts)
- (output-inspect-note stream "Object does not contain any subobjects"))
- (t
- (typecase id
- (symbol
- (output-inspect-note
- stream "Object has no selectable component named ~A"
- id))
- (integer
- (output-inspect-note
- stream "Object has no selectable component indexed by ~d"
- id)
- (output-inspect-note
- stream "Enter a valid index (~:[0-~W~;0~])"
- (= (parts-count parts) 1)
- (1- (parts-count parts))))))))
- (no-object-msg stream)))
-
- (defun istep-cmd-set-stack (form stream)
- (reset-stack)
- (let ((object (eval form)))
- (setf (inspect-object-stack *current-inspect*) (list object))
- (setf (inspect-select-stack *current-inspect*)
- (list (format nil ":i ..."))))
- (set-break-inspect *current-inspect*)
- (redisplay stream))
-
- ;;;
- ;;; aclrepl-specific inspection display
- ;;;
-
- (defun no-object-msg (s)
- (output-inspect-note s "No object is being inspected"))
-
- (defun display-current (s)
- (if (stack)
- (let ((inspected (car (stack))))
- (setq cl:* inspected)
- (display-inspect inspected s *inspect-length* *inspect-skip*))
- (no-object-msg)))
-
- ) ;; end binding for multithreading
+ (if parts
+ (if position
+ (when value-string
+ (let ((new-value (eval (read-from-string value-string))))
+ (let ((result (set-component-value (car (stack))
+ id
+ new-value
+ (component-at
+ parts position))))
+ (typecase result
+ (string
+ (output-inspect-note stream result))
+ (t
+ (redisplay stream))))))
+ (output-inspect-note
+ stream
+ "Object has no selectable component named by ~A" id))
+ (output-inspect-note stream
+ "Object has no selectable components"))))
+ (no-object-msg stream)))
+
+(defun istep-cmd-select-component (id stream)
+ (if (stack)
+ (multiple-value-bind (position parts)
+ (find-part-id (car (stack)) id)
+ (cond
+ ((integerp position)
+ (let* ((value (component-at parts position)))
+ (cond ((eq value *inspect-unbound-object-marker*)
+ (output-inspect-note stream "That slot is unbound"))
+ (t
+ (push value (inspect-object-stack *current-inspect*))
+ (push id (inspect-select-stack *current-inspect*))
+ (redisplay stream)))))
+ ((null parts)
+ (output-inspect-note stream "Object does not contain any subobjects"))
+ (t
+ (typecase id
+ (symbol
+ (output-inspect-note
+ stream "Object has no selectable component named ~A"
+ id))
+ (integer
+ (output-inspect-note
+ stream "Object has no selectable component indexed by ~d"
+ id))))))
+ (no-object-msg stream)))
+
+(defun istep-cmd-set-stack (form stream)
+ (reset-stack (eval form) ":i ...")
+ (redisplay stream))
+(defun no-object-msg (s)
+ (output-inspect-note s "No object is being inspected"))
+
+(defun display-current (s length skip)
+ (if (stack)
+ (let ((inspected (car (stack))))
+ (setq cl:* inspected)
+ (display-inspect inspected s length skip))
+ (no-object-msg s)))
+
+
+;;;
+;;; aclrepl-specific inspection display
+;;;
+
(defun display-inspect (object stream &optional length (skip 0))
(multiple-value-bind (elements labels count)
(inspected-elements object length skip)
(fresh-line stream)
(format stream "~A" (inspected-description object))
(unless (or *skip-address-display*
+ (eq object *inspect-unbound-object-marker*)
(characterp object) (typep object 'fixnum))
- (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object)))
+ (format stream " at #x~X" (logand
+ (sb-kernel:get-lisp-obj-address object)
+ (lognot sb-vm:lowtag-mask))))
(dotimes (i count)
(fresh-line stream)
(display-labeled-element (elt elements i) (elt labels i) stream))))
+(defun hex32-label-p (label)
+ (and (consp label) (eq (cdr label) :hex32)))
+
(defun array-label-p (label)
- (and (stringp (cdr label)) (char= (char (cdr label) 0) #\[)))
+ (and (consp label)
+ (stringp (cdr label))
+ (char= (char (cdr label) 0) #\[)))
(defun named-or-array-label-p (label)
- (consp label))
+ (and (consp label)
+ (not (hex32-label-p label))))
(defun display-labeled-element (element label stream)
(cond
(car label)
(format nil "~A " (cdr label))
(inspected-description element)))
+ ((hex32-label-p label)
+ (format stream "~4,' D-> #x~8,'0X" (car label) element))
(t
(format stream "~4,' D-> ~A" label (inspected-description element)))))
(let* ((parts (inspected-parts object))
(name (if (symbolp id) (symbol-name id) id)))
(values
- (if (numberp id)
- (when (< -1 id (parts-count parts)) id)
- (case (parts-seq-type parts)
- (:named
- (position name (the list (parts-components parts))
- :key #'car :test #'string-equal))
- ((:dotted-list :cyclic-list)
- (when (string-equal name "tail")
- (1- (parts-count parts))))))
+ (cond
+ ((and (numberp id)
+ (< -1 id (parts-count parts))
+ (not (eq (parts-seq-type parts) :bignum)))
+ id)
+ (t
+ (case (parts-seq-type parts)
+ (:named
+ (position name (the list (parts-components parts))
+ :key #'car :test #'string-equal))
+ ((:dotted-list :cyclic-list)
+ (when (string-equal name "tail")
+ (1- (parts-count parts)))))))
parts)))
(defun component-at (parts position)
(cdr (elt components position)))
(:array
(aref (the array components) position))
+ (:bignum
+ (bignum-component-at components position))
(t
(elt components position))))))
"Helper function for inspected-elements. Conses the
position with the label if the label is a string."
(let ((id (id-at parts position)))
- (if (stringp id)
- (cons position id)
- id)))
+ (cond
+ ((stringp id)
+ (cons position id))
+ ((eq (parts-seq-type parts) :bignum)
+ (cons position :hex32))
+ (t
+ id))))
(defun array-index-string (index parts)
"Formats an array index in row major format."
((:dotted :cyclic) "+tail")
(t "")))))
+
+(defun ref32-hexstr (obj &optional (offset 0))
+ (format nil "~8,'0X" (ref32 obj offset)))
+
+(defun ref32 (obj &optional (offset 0))
+ (sb-sys::without-gcing
+ (sb-sys:sap-ref-32
+ (sb-sys:int-sap
+ (logand (sb-kernel:get-lisp-obj-address obj) (lognot sb-vm:lowtag-mask)))
+ offset)))
+
+(defun description-maybe-internals (fmt objects internal-fmt &rest args)
+ (let ((base (apply #'format nil fmt objects)))
+ (if *skip-address-display*
+ base
+ (concatenate 'string
+ base " " (apply #'format nil internal-fmt args)))))
+
(defmethod inspected-description ((object double-float))
- (format nil "double-float ~W" object))
+ (description-maybe-internals "double-float ~W" (list object)
+ "[#~A ~A]"
+ (ref32-hexstr object 12)
+ (ref32-hexstr object 8)))
(defmethod inspected-description ((object single-float))
- (format nil "single-float ~W" object))
+ (description-maybe-internals "single-float ~W" (list object)
+ "[#x~A]"
+ (ref32-hexstr object 4)))
(defmethod inspected-description ((object fixnum))
- (format nil "fixnum ~W~A" object
- (if *skip-address-display*
- ""
- (format nil " [#x~8,'0X]" object
- (sb-kernel:get-lisp-obj-address object)))))
+ (description-maybe-internals "fixnum ~W" (list object)
+ "[#x~8,'0X]"
+ (sb-kernel:get-lisp-obj-address object)))
(defmethod inspected-description ((object complex))
(format nil "complex number ~W" object))
(defmethod inspected-description ((object simple-string))
(format nil "a simple-string (~W) ~W" (length object) object))
+(defun bignum-words (bignum)
+ "Return the number of 32-bit words in a bignum"
+ (ash
+ (logand (ref32 bignum)
+ (lognot sb-vm:widetag-mask))
+ (- sb-vm:n-widetag-bits)))
+
+(defun bignum-component-at (bignum offset)
+ "Return the 32-bit word at 32-bit wide offset"
+ (ref32 bignum (* 4 (1+ offset))))
+
(defmethod inspected-description ((object bignum))
- (format nil "bignum ~W" object))
+ (format nil "bignum ~W with ~D 32-bit word~:*~P" object
+ (bignum-words object)))
(defmethod inspected-description ((object ratio))
(format nil "ratio ~W" object))
(defmethod inspected-description ((object character))
- (format nil "character ~W char-code~A" object (char-code object)
- (if *skip-address-display*
- ""
- (format nil " [#x~8,'0X]" object
- (sb-kernel:get-lisp-obj-address object)))))
+ (description-maybe-internals "character ~W char-code #x~4,'0X"
+ (list object (char-code object))
+ "[#x~8,'0X]"
+ (sb-kernel:get-lisp-obj-address object)))
(defmethod inspected-description ((object t))
(format nil "a generic object ~W" object))
;;; If SEQ-TYPE is :vector, then each element is a value of an vector
;;; If SEQ-TYPE is :array, then each element is a value of an array
;;; with rank >= 2. The
+;;; If SEQ-TYPE is :bignum, then object is just a bignum and not a
+;;; a sequence
;;;
;;; COUNT is the total number of components in the OBJECT
;;;
(cons "denominator" (denominator object)))))
(list components (length components) :named nil)))
+(defmethod inspected-parts ((object bignum))
+ (list object (bignum-words object) :bignum nil))
+
(defmethod inspected-parts ((object t))
(list nil 0 nil nil))
;;;; 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)
(defstruct user-cmd
(args nil) ; args for cmd func
(hnum nil)) ; history number
-(defstruct break-data
- ;; numeric break level
- level
- ;; inspect data for a break level
- inspect
- ;; T when break initiated by an inspect
- inspect-initiated
- ;; restarts list for a break level
- restarts
- ;; T if break level is a continuable break
- continuable)
;;; cmd table entry
(defstruct cmd-table-entry
"The top-level directory stack")
(defparameter *command-char* #\:
"Prefix character for a top-level command")
-(defvar *max-history* 24
+(defvar *max-history* 100
"Maximum number of history commands to remember")
(defvar *exit-on-eof* t
"If T, then exit when the EOF character is entered.")
"History list")
(defparameter *cmd-number* 1
"Number of the next command")
-(defparameter *repl-output* nil
- "The output stream for the repl")
-(defparameter *repl-input* nil
- "The input stream for the repl")
-(defparameter *break-stack* (list (make-break-data :level 0))
- "A stack of break data stored as a list of break-level structs")
(declaim (type list *history*))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(*prompt* *exit-on-eof* *max-history*
+ *use-short-package-name* *command-char*
+ alias)))
+
(defvar *eof-marker* :eof)
(defvar *eof-cmd* (make-user-cmd :func :eof))
(defvar *null-cmd* (make-user-cmd :func :null-cmd))
(*use-short-package-name* t)
(*dir-stack* nil)
(*command-char* #\:)
- (*max-history* 24)
+ (*max-history* 100)
(*exit-on-eof* t)
(*history* nil)
(*cmd-number* 1)
- (*repl-output* nil)
- (*repl-input* nil)
- (*break-stack* (list (make-break-data :level 0)))
)
(defun prompt-package-name ()
(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)
+ (cond
+ ((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)
+ :hnum *cmd-number*))))
+ ((or (zerop (length cmd-string))
+ (whitespace-char-p (char cmd-string 0)))
+ *null-cmd*)
+ (t
+ (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)
- )))))
+ :hnum *cmd-number*)
+ (make-user-cmd :func :cmd-error
+ :input cmd-string)))))))
((eql next-char #\newline)
(read-char input-stream)
*null-cmd*)
- (t
- (let* ((eof (cons nil *eof-marker*))
- (form (read input-stream nil eof)))
- (if (eq form eof)
- *eof-cmd*
- (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
+ ((eql next-char :eof)
+ *eof-cmd*)
+ (t
+ (let* ((eof (cons nil *eof-marker*))
+ (form (read input-stream nil eof)))
+ (if (eq form eof)
+ *eof-cmd*
+ (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
(defun make-cte (name-param func desc parsing group abbr-len)
(let ((name (etypecase name-param
(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))))
+ (setq *history* (nbutlast *history*
+ (1+ (- (length *history*) *max-history*)))))
(push cmd *history*)
(incf *cmd-number*)))
(let ((new (truename string-dir)))
(when (pathnamep new)
(setf cl:*default-pathname-defaults* new)))))
- (format *repl-output* "~A~%" (namestring cl:*default-pathname-defaults*))
+ (format *output* "~A~%" (namestring cl:*default-pathname-defaults*))
(values))
(defun pwd-cmd ()
- (format *repl-output* "Lisp's current working directory is ~s.~%"
+ (format *output* "Lisp's current working directory is ~s.~%"
(namestring cl:*default-pathname-defaults*))
(values))
(defun trace-cmd (&rest args)
(if args
- (format *repl-output* "~A~%" (eval (sb-debug::expand-trace args)))
- (format *repl-output* "~A~%" (sb-debug::%list-traced-funs)))
+ (format *output* "~A~%" (eval (sb-debug::expand-trace args)))
+ (format *output* "~A~%" (sb-debug::%list-traced-funs)))
(values))
(defun untrace-cmd (&rest args)
(if args
- (format *repl-output* "~A~%"
+ (format *output* "~A~%"
(eval
(sb-int:collect ((res))
(let ((current args))
`(sb-debug::untrace-1 ,(pop current))
`(sb-debug::untrace-1 ',name))))))
`(progn ,@(res) t))))
- (format *repl-output* "~A~%" (eval (sb-debug::untrace-all))))
+ (format *output* "~A~%" (eval (sb-debug::untrace-all))))
(values))
#+sb-thread
#+sb-thread
(let ((other-pids (other-thread-pids)))
(when other-pids
- (format *repl-output* "There exists the following processes~%")
- (format *repl-output* "~{~5d~%~}" other-pids)
- (format *repl-output* "Do you want to exit lisp anyway [n]? ")
- (force-output *repl-output*)
- (let ((input (string-trim-whitespace (read-line *repl-input*))))
+ (format *output* "There exists the following processes~%")
+ (format *output* "~{~5d~%~}" other-pids)
+ (format *output* "Do you want to exit lisp anyway [n]? ")
+ (force-output *output*)
+ (let ((input (string-trim-whitespace (read-line *input*))))
(if (and (plusp (length input))
(or (char= #\y (char input 0))
(char= #\Y (char input 0))))
(map nil #'sb-thread:destroy-thread pids)
(sleep 0.2))
(return-from exit-cmd)))))
- (quit :unix-status status)
+ (sb-ext:quit :unix-status status)
(values))
(defun package-cmd (&optional pkg)
(cond
((null pkg)
- (format *repl-output* "The ~A package is current.~%"
+ (format *output* "The ~A package is current.~%"
(package-name cl:*package*)))
((null (find-package (write-to-string pkg)))
- (format *repl-output* "Unknown package: ~A.~%" pkg))
+ (format *output* "Unknown package: ~A.~%" pkg))
(t
(setf cl:*package* (find-package (write-to-string pkg)))))
(values))
(string-left-trim "~/" arg))
(user-homedir-pathname))
arg)))
- (format *repl-output* "loading ~S~%" file)
+ (format *output* "loading ~S~%" file)
(load file))))
(values))
(setq last-files-loaded string-files)
(setq string-files last-files-loaded))
(dolist (arg (string-to-list-skip-spaces string-files))
- (format *repl-output* "loading ~a~%" arg)
+ (format *output* "loading ~a~%" arg)
(load (compile-file-as-needed arg)))
(values)))
(defun inspect-cmd (arg)
- (inspector arg nil *repl-output*)
+ (inspector arg nil *output*)
(values))
(defun istep-cmd (&optional arg-string)
- (istep (string-to-list-skip-spaces arg-string) *repl-output*)
+ (istep (string-to-list-skip-spaces arg-string) *output*)
(values))
(defun describe-cmd (&rest args)
(values))
(defun macroexpand-cmd (arg)
- (pprint (macroexpand arg) *repl-output*)
+ (pprint (macroexpand arg) *output*)
(values))
(defun history-cmd ()
(dotimes (i n)
(declare (fixnum i))
(let ((hist (nth (- n i 1) *history*)))
- (format *repl-output* "~3A " (user-cmd-hnum hist))
+ (format *output* "~3A " (user-cmd-hnum hist))
(if (stringp (user-cmd-input hist))
- (format *repl-output* "~A~%" (user-cmd-input hist))
- (format *repl-output* "~W~%" (user-cmd-input hist))))))
+ (format *output* "~A~%" (user-cmd-input hist))
+ (format *output* "~W~%" (user-cmd-input hist))))))
(values))
(defun help-cmd (&optional cmd)
(cmd
(let ((cmd-entry (find-cmd cmd)))
(if cmd-entry
- (format *repl-output* "Documentation for ~A: ~A~%"
+ (format *output* "Documentation for ~A: ~A~%"
(cmd-table-entry-name cmd-entry)
(cmd-table-entry-desc cmd-entry)))))
(t
- (format *repl-output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
- (format *repl-output* "~11A ~4A ~A~%" "<n>" ""
+ (format *output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
+ (format *output* "~11A ~4A ~A~%" "<n>" ""
"re-execute <n>th history command")
(dolist (doc-entry (get-cmd-doc-list :cmd))
- (format *repl-output* "~11A ~4A ~A~%" (first doc-entry)
+ (format *output* "~11A ~4A ~A~%" (first doc-entry)
(second doc-entry) (third doc-entry)))))
(values))
(let ((doc-entries (get-cmd-doc-list :alias)))
(typecase doc-entries
(cons
- (format *repl-output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
+ (format *output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
(dolist (doc-entry doc-entries)
- (format *repl-output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
+ (format *output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
(t
- (format *repl-output* "No aliases are defined~%"))))
+ (format *output* "No aliases are defined~%"))))
(values))
(defun shell-cmd (string-arg)
(sb-ext:run-program "/bin/sh" (list "-c" string-arg)
- :input nil :output *repl-output*)
+ :input nil :output *output*)
(values))
(defun pushd-cmd (string-arg)
(push string-arg *dir-stack*)
- (cd-cmd *repl-output* string-arg)
+ (cd-cmd *output* string-arg)
(values))
(defun popd-cmd ()
(if *dir-stack*
(let ((dir (pop *dir-stack*)))
(cd-cmd dir))
- (format *repl-output* "No directory on stack to pop.~%"))
+ (format *output* "No directory on stack to pop.~%"))
(values))
(defun pop-cmd (&optional (n 1))
+ #+ignore
(let ((new-level (- (length *break-stack*) n 1)))
(when (minusp new-level)
(setq new-level 0))
(dotimes (i (- (length *break-stack*) new-level 1))
(pop *break-stack*)))
;; Find inspector
+ #+ignore
(do* ((i (1- (length *break-stack*)) (1- i))
(found nil))
((or found (minusp i)))
(when inspect
(set-current-inspect inspect)
(setq found t))))
+ (when *inspect-reason*
+ (throw 'inspect-quit nil))
(values))
-(defun continue-cmd (n)
- (let ((restarts (break-data-restarts (car *break-stack*))))
+(defun continue-cmd (&optional (n 0))
+ (let ((restarts (compute-restarts)))
(if restarts
(if (< -1 n (length restarts))
- (progn
- (invoke-restart-interactively (nth n restarts))
- )
- (format *repl-output* "~&There is no such restart"))
- (format *repl-output* "~&There are no restarts"))))
+ (invoke-restart-interactively (nth n restarts))
+ (format *output* "~&There is no such restart"))
+ (format *output* "~&There are no restarts"))))
(defun error-cmd ()
- )
+ (print-restarts))
(defun current-cmd ()
)
(let ((pids (thread-pids))
(current-pid (sb-thread:current-thread-id)))
(dolist (pid pids)
- (format *repl-output* "~&~D" pid)
+ (format *output* "~&~D" pid)
(when (= pid current-pid)
- (format *repl-output* " [current listener]"))))
+ (format *output* " [current listener]"))))
#-sb-thread
- (format *repl-output* "~&Threads are not supported in this version of sbcl")
+ (format *output* "~&Threads are not supported in this version of sbcl")
(values))
(defun kill-cmd (&rest selected-pids)
(if (find selected-pid pids :test #'eql)
(progn
(sb-thread:destroy-thread selected-pid)
- (format *repl-output* "~&Thread ~A destroyed" selected-pid))
- (format *repl-output* "~&No thread ~A exists" selected-pid))))
+ (format *output* "~&Thread ~A destroyed" selected-pid))
+ (format *output* "~&No thread ~A exists" selected-pid))))
#-sb-thread
(declare (ignore selected-pids))
#-sb-thread
- (format *repl-output* "~&Threads are not supported in this version of sbcl")
+ (format *output* "~&Threads are not supported in this version of sbcl")
(values))
(defun signal-cmd (signal &rest selected-pids)
(if (find selected-pid pids :test #'eql)
(progn
(sb-unix:unix-kill selected-pid signal)
- (format *repl-output* "~&Signal ~A sent to thread ~A"
+ (format *output* "~&Signal ~A sent to thread ~A"
signal selected-pid))
- (format *repl-output* "~&No thread ~A exists" selected-pid))))
+ (format *output* "~&No thread ~A exists" selected-pid))))
#-sb-thread
(declare (ignore signal selected-pids))
#-sb-thread
- (format *repl-output* "~&Threads are not supported in this version of sbcl")
+ (format *output* "~&Threads are not supported in this version of sbcl")
(values))
(defun focus-cmd (&optional process)
(declare (ignore process))
#+sb-thread
(when process
- (format *repl-output* "~&Focusing on next thread waiting waiting for the debugger~%"))
+ (format *output* "~&Focusing on next thread waiting waiting for the debugger~%"))
#+sb-thread
(progn
(sb-thread:release-foreground)
(sleep 1))
#-sb-thread
- (format *repl-output* "~&Threads are not supported in this version of sbcl")
+ (format *output* "~&Threads are not supported in this version of sbcl")
(values))
(defun reset-cmd ()
+ #+ignore
(setf *break-stack* (last *break-stack*))
(values))
(defun dirs-cmd ()
(dolist (dir *dir-stack*)
- (format *repl-output* "~a~%" dir))
+ (format *output* "~a~%" dir))
(values))
\f
("cf" 2 cf-cmd "compile file" :parsing :string)
("cload" 2 cload-cmd "compile if needed and load file"
:parsing :string)
- #+aclrepl-debugger("current" 3 current-cmd "print the expression for the current stack frame")
- #+aclrepl-debugger ("continue" 4 continue-cmd "continue from a continuable error")
+ ("current" 3 current-cmd "print the expression for the current stack frame")
+ ("continue" 4 continue-cmd "continue from a continuable error")
("describe" 2 describe-cmd "describe an object")
("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
("package" 2 package-cmd "change current package")
- #+aclrepl-debugger ("error" 3 error-cmd "print the last error message")
+ ("error" 3 error-cmd "print the last error message")
("exit" 2 exit-cmd "exit sbcl")
- #+aclrepl-debugger("frame" 2 frame-cmd "print info about the current frame")
+ ("frame" 2 frame-cmd "print info about the current frame")
("help" 2 help-cmd "print this help")
("history" 3 history-cmd "print the recent history")
("inspect" 2 inspect-cmd "inspect an object")
#+sb-thread ("kill" 2 kill-cmd "kill (destroy) processes")
#+sb-thread ("signal" 2 signal-cmd "send a signal to processes")
#+sb-thread ("focus" 2 focus-cmd "focus the top level on a process")
- #+aclrepl-debugger("local" 3 local-cmd "print the value of a local variable")
+ ("local" 3 local-cmd "print the value of a local variable")
("pwd" 3 pwd-cmd "print current directory")
("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
("pop" 3 pop-cmd "pop up `n' (default 1) break levels")
("untrace" 4 untrace-cmd "untrace a function")
("dirs" 2 dirs-cmd "show directory stack")
("shell" 2 shell-cmd "execute a shell cmd" :parsing :string)
- #+aclrepl-debugger ("zoom" 2 zoom-cmd "print the runtime stack")
+ ("zoom" 2 zoom-cmd "print the runtime stack")
)))
(dolist (cmd cmd-table)
(destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
(string-trim '(#\space #\tab #\return)
str))
-(defun whitespace-char-not-newline-p (x)
+(defun whitespace-char-p (x)
(and (characterp x)
(or (char= x #\space)
(char= x #\tab)
+ (char= x #\newline)
(char= x #\return))))
+(defun whitespace-char-not-newline-p (x)
+ (and (whitespace-char-p x)
+ (not (char= x #\newline))))
+
\f
;;;; linking into SBCL hooks
(defun repl-prompt-fun (stream)
- (let* ((break-data (car *break-stack*))
- (break-level (break-data-level break-data)))
- (when (zerop break-level)
- (setq break-level nil))
+ (let ((break-level
+ (if (zerop *break-level*) nil *break-level*)))
#+sb-thread
(let ((lock sb-thread::*session-lock*))
(sb-thread::get-foreground)
(when stopped-threads
(format stream "~{~&Thread ~A suspended~}~%" stopped-threads))))
(if (functionp *prompt*)
- (write-string (funcall *prompt* break-level
- (break-data-inspect-initiated break-data)
- (break-data-continuable break-data)
+ (write-string (funcall *prompt*
+ *inspect-reason*
+ *continuable-reason*
(prompt-package-name) *cmd-number*)
stream)
(handler-case
(format nil *prompt* break-level
- (break-data-inspect-initiated break-data)
- (break-data-continuable break-data)
+ *inspect-reason*
+ *continuable-reason*
(prompt-package-name) *cmd-number*)
(error ()
(format stream "~&Prompt error> "))
(:no-error (prompt)
(format stream "~&~A" prompt))))))
-(defun process-cmd (user-cmd input-stream output-stream)
+(defun process-cmd (user-cmd)
;; 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~%")
+ (sb-ext:quit))
+ (format *output* "EOF~%")
t)
((eq user-cmd *null-cmd*)
t)
((eq (user-cmd-func user-cmd) :cmd-error)
- (format output-stream "Unknown top-level command: ~s.~%"
+ (format *output* "Unknown top-level command: ~s.~%"
(user-cmd-input user-cmd))
- (format output-stream "Type `:help' for the list of commands.~%")
+ (format *output* "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~%"
+ (format *output* "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)
- (let ((*repl-output* output-stream)
- (*repl-input* input-stream))
- (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd)))
+ (apply (user-cmd-func user-cmd) (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)
+(defun repl-read-form-fun (input output)
;; 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 input-stream output-stream)
+ (let ((*input* input)
+ (*output* output))
+ (loop for user-cmd = (read-cmd *input*) do
+ (if (process-cmd user-cmd)
(progn
- (funcall sb-int:*repl-prompt-fun* output-stream)
- (force-output output-stream))
- (return (user-cmd-input user-cmd)))))
+ (funcall sb-int:*repl-prompt-fun* *output*)
+ (force-output *output*))
+ (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)
-;;; Break level processing
-
-;; use an initial break-level to hold current inspect toplevel at
-;; break-level 0
-
-(defun new-break (&key restarts inspect continuable)
- (push
- (make-break-data :level (length *break-stack*)
- :restarts restarts
- :inspect inspect
- :inspect-initiated (when inspect t)
- :continuable continuable)
- *break-stack*))
-
-(defun set-break-inspect (inspect)
- "sets the inspect data for the current break level"
- (setf (break-data-inspect (car *break-stack*)) inspect))
-
) ;; close special variables bindings
(defsystem sb-aclrepl
:author "Kevin Rosenberg <kevin@rosenberg.net>"
:description "An AllegroCL compatible REPL"
- :components ((:file "repl")
+ :components ((:file "toplevel")
+ (:file "repl" :depends-on ("toplevel"))
(:file "inspect" :depends-on ("repl"))
(:file "debug" :depends-on ("repl"))))
--- /dev/null
+;;;; Toplevel for sb-aclrepl
+
+(cl:defpackage :sb-aclrepl
+ (:use :cl :sb-ext))
+
+(cl:in-package :sb-aclrepl)
+
+(defvar *break-level* 0 "Current break level")
+(defvar *inspect-reason* nil
+ "Boolean if break level was started for inspecting.")
+(defvar *continuable-reason* nil
+ "Boolean if break level was started by continuable error.")
+(defvar *noprint* nil "Boolean is output should be displayed")
+(defvar *input* nil "Input stream")
+(defvar *output* nil "Output stream")
+
+(defun aclrepl (&key
+ (break-level (1+ *break-level*))
+ ;; Break level is started to inspect an object
+ inspect
+ ;; Signals a continuable error
+ continuable)
+ (let ((*break-level* break-level)
+ (*inspect-reason* inspect)
+ (*continuable-reason* continuable))
+ (loop
+ ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
+ (sb-impl::scrub-control-stack)
+ (unless *noprint*
+ (funcall (the function sb-int:*repl-prompt-fun*) *output*)
+ (force-output *output*))
+ (let* ((form (funcall (the function sb-int:*repl-read-form-fun*)
+ *input* *output*))
+ (results (multiple-value-list (interactive-eval form))))
+ (unless *noprint*
+ (dolist (result results)
+ (fresh-line *output*)
+ (prin1 result *output*)))))))
+
+
+;;; read-eval-print loop for the default system toplevel
+(defun toplevel-aclrepl-fun (noprint)
+ (let ((* nil) (** nil) (*** nil)
+ (- nil)
+ (+ nil) (++ nil) (+++ nil)
+ (/// nil) (// nil) (/ nil))
+ ;; WITH-SIMPLE-RESTART doesn't actually restart its body as some
+ ;; (like WHN for an embarrassingly long time ca. 2001-12-07) might
+ ;; think, but instead drops control back out at the end. So when a
+ ;; TOPLEVEL or outermost-ABORT restart happens, we need this outer
+ ;; LOOP wrapper to grab control and start over again. (And it also
+ ;; wraps CATCH 'TOPLEVEL-CATCHER for similar reasons.)
+ (loop
+ ;; There should only be one TOPLEVEL restart, and it's here, so
+ ;; restarting at TOPLEVEL always bounces you all the way out here.
+ (with-simple-restart (toplevel
+ "Restart at toplevel READ/EVAL/PRINT loop.")
+ ;; We add a new ABORT restart for every debugger level, so
+ ;; restarting at ABORT in a nested debugger gets you out to the
+ ;; innermost enclosing debugger, and only when you're in the
+ ;; outermost, unnested debugger level does restarting at ABORT
+ ;; get you out to here.
+ (with-simple-restart
+ (abort
+ "~@<Reduce debugger level (leaving debugger, returning to toplevel).~@:>")
+ (catch 'toplevel-catcher
+ #-sunos (sb-unix:unix-sigsetmask 0) ; FIXME: What is this for?
+ ;; in the event of a control-stack-exhausted-error, we should
+ ;; have unwound enough stack by the time we get here that this
+ ;; is now possible
+ (sb-kernel::protect-control-stack-guard-page 1)
+ (let ((*noprint* noprint)
+ (*input* *standard-input*)
+ (*output* *standard-output*))
+ (aclrepl :break-level 0))
+ (sb-impl::critically-unreachable "after REPL")))))))
+
+#+ignore
+(when (boundp 'sb-impl::*toplevel-repl-fun*)
+ (setq sb-impl::*toplevel-repl-fun* #'toplevel-aclrepl-fun))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre8.100"
+"0.pre8.101"
projects / sbcl.git / commitdiff