From 3e991f3ecd3a0a5ba50bc5b43c4ed0133c837701 Mon Sep 17 00:00:00 2001 From: Kevin Rosenberg Date: Fri, 25 Apr 2003 02:54:06 +0000 Subject: [PATCH] 0.pre8.100: * sb-aclrepl changes - Update README with examples and contact information - Strip out break-stack concept from repl.lisp - Fix bug in trimming *history* when *max-history* is reached - Add display of single-float, double-float, bignum hexidecimal contents - Fix reporting of object addresses (mask lowtag bits) - Add ":i slot " command - Some non-active experimental code is in toplevel.lisp and debug.lisp, but this is #+ignore'd while in development. --- contrib/sb-aclrepl/README | 33 +- contrib/sb-aclrepl/debug.lisp | 104 ++++++- contrib/sb-aclrepl/inspect.lisp | 619 ++++++++++++++++++++----------------- contrib/sb-aclrepl/repl.lisp | 280 ++++++++--------- contrib/sb-aclrepl/sb-aclrepl.asd | 3 +- contrib/sb-aclrepl/toplevel.lisp | 80 +++++ version.lisp-expr | 2 +- 7 files changed, 669 insertions(+), 452 deletions(-) create mode 100644 contrib/sb-aclrepl/toplevel.lisp diff --git a/contrib/sb-aclrepl/README b/contrib/sb-aclrepl/README index 7a8161c..6eb65fd 100644 --- a/contrib/sb-aclrepl/README +++ b/contrib/sb-aclrepl/README @@ -1,6 +1,37 @@ +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 -. +. diff --git a/contrib/sb-aclrepl/debug.lisp b/contrib/sb-aclrepl/debug.lisp index 2c96948..250200b 100644 --- a/contrib/sb-aclrepl/debug.lisp +++ b/contrib/sb-aclrepl/debug.lisp @@ -8,20 +8,106 @@ (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 + "~@" + 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 + "~@" + *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)) diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index 96eea04..ff59745 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -10,7 +10,7 @@ (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 @@ -25,8 +25,6 @@ "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.") @@ -39,6 +37,7 @@ The commands are: :i ? display this help :i * inspect the current * value :i +
inspect the (eval form) +:i slot inspect component of object, even if name is an istep cmd :i inspect the numbered component of object :i inspect the named component of object :i evaluation and inspect form @@ -47,7 +46,6 @@ The commands are: :i < inspect previous parent component :i > inspect next parent component :i set set indexed component to evalated form -i set set named component to evalated form :i print set the maximum number of components to print :i skip skip a number of components when printing :i tree print inspect stack @@ -59,296 +57,294 @@ i set set named component to evalated form (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 @@ -364,6 +360,8 @@ i set set named component to evalated form (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))))) @@ -398,15 +396,19 @@ POSITION is NIL if the id is invalid or not found." (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) @@ -426,6 +428,8 @@ POSITION is NIL if the id is invalid or not found." (cdr (elt components position))) (:array (aref (the array components) position)) + (:bignum + (bignum-component-at components position)) (t (elt components position)))))) @@ -513,9 +517,13 @@ and the last element." "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." @@ -610,18 +618,39 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" ((: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)) @@ -629,18 +658,29 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (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)) @@ -670,6 +710,8 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" ;;; 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 ;;; @@ -790,6 +832,9 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (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)) diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index a19b572..69b6314 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -7,12 +7,6 @@ ;;;; any given time, for this functionality is on the ACL website: ;;;; . -(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 @@ -22,17 +16,6 @@ (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 @@ -54,7 +37,7 @@ "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.") @@ -62,15 +45,14 @@ "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)) @@ -84,13 +66,10 @@ (*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 () @@ -126,35 +105,41 @@ (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 @@ -195,7 +180,8 @@ (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*))) @@ -230,23 +216,23 @@ (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)) @@ -257,7 +243,7 @@ `(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 @@ -276,11 +262,11 @@ #+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)))) @@ -290,16 +276,16 @@ (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)) @@ -325,7 +311,7 @@ (string-left-trim "~/" arg)) (user-homedir-pathname)) arg))) - (format *repl-output* "loading ~S~%" file) + (format *output* "loading ~S~%" file) (load file)))) (values)) @@ -365,16 +351,16 @@ (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) @@ -383,7 +369,7 @@ (values)) (defun macroexpand-cmd (arg) - (pprint (macroexpand arg) *repl-output*) + (pprint (macroexpand arg) *output*) (values)) (defun history-cmd () @@ -392,10 +378,10 @@ (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) @@ -403,15 +389,15 @@ (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~%" "" "" + (format *output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION") + (format *output* "~11A ~4A ~A~%" "" "" "re-execute 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)) @@ -419,37 +405,39 @@ (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))) @@ -457,20 +445,20 @@ (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 () ) @@ -490,11 +478,11 @@ (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) @@ -504,12 +492,12 @@ (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) @@ -519,13 +507,13 @@ (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) @@ -533,22 +521,23 @@ (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)) @@ -562,14 +551,14 @@ ("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") @@ -577,7 +566,7 @@ #+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") @@ -588,7 +577,7 @@ ("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 @@ -673,21 +662,24 @@ (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)))) + ;;;; 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) @@ -695,82 +687,64 @@ (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 diff --git a/contrib/sb-aclrepl/sb-aclrepl.asd b/contrib/sb-aclrepl/sb-aclrepl.asd index c53f5c3..0c5b8f8 100644 --- a/contrib/sb-aclrepl/sb-aclrepl.asd +++ b/contrib/sb-aclrepl/sb-aclrepl.asd @@ -6,7 +6,8 @@ (defsystem sb-aclrepl :author "Kevin Rosenberg " :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")))) diff --git a/contrib/sb-aclrepl/toplevel.lisp b/contrib/sb-aclrepl/toplevel.lisp new file mode 100644 index 0000000..c0a4d4e --- /dev/null +++ b/contrib/sb-aclrepl/toplevel.lisp @@ -0,0 +1,80 @@ +;;;; 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 + "~@") + (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)) diff --git a/version.lisp-expr b/version.lisp-expr index e46bf66..6289e59 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4