├── README ├── commands.lisp ├── debug.lisp ├── inspect.lisp ├── package.lisp ├── prepl.asd ├── prepl.lisp └── tests.lisp /README: -------------------------------------------------------------------------------- 1 | INTRODUCTION 2 | ============ 3 | 4 | prepl is a REPL implementation, also known as a Lisp listener. 5 | 6 | It is written in fully portable Common Lisp (aside from minor 7 | workarounds for implementation-specific issues...), with major 8 | unportable bits being handled by external portability libraries. 9 | 10 | 11 | HISTORY 12 | ======= 13 | 14 | prepl is a fork of SBCL's sb-aclrepl module. 15 | 16 | Since then, it has been ported to Clozure CL and other Lisps. 17 | 18 | Debugging capabilities have been added. 19 | 20 | Overall, PREPL does not have Allegro compatibility as a goal, although it 21 | still largely keeps its interface. 22 | 23 | 24 | USAGE 25 | ===== 26 | 27 | Manual startup: 28 | (asdf:operate 'asdf:load-op 'prepl) 29 | (prepl:repl) 30 | 31 | 32 | SEE ALSO 33 | ======== 34 | 35 | The Qt version of Hemlock uses PREPL in its Slave buffers. 36 | 37 | 38 | MAINTAINER 39 | ========== 40 | David Lichteblau 41 | -------------------------------------------------------------------------------- /commands.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*- 2 | 3 | ;;; This file was taken from SBCL's sb-aclrepl contrib, written by Keven 4 | ;;; Rosenberg and available under SBCL's public domain status. 5 | ;;; 6 | ;;; Changes since then are: 7 | 8 | ;;; Copyright (c) 2009 David Lichteblau. All rights reserved. 9 | 10 | ;;; Redistribution and use in source and binary forms, with or without 11 | ;;; modification, are permitted provided that the following conditions 12 | ;;; are met: 13 | ;;; 14 | ;;; * Redistributions of source code must retain the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer. 16 | ;;; 17 | ;;; * Redistributions in binary form must reproduce the above 18 | ;;; copyright notice, this list of conditions and the following 19 | ;;; disclaimer in the documentation and/or other materials 20 | ;;; provided with the distribution. 21 | ;;; 22 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 23 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 24 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 25 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 26 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 27 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 28 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 29 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 30 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 31 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 32 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 | 34 | (cl:in-package :prepl) 35 | 36 | (defstruct user-command 37 | (input nil) ; input, maybe a string or form 38 | (func nil) ; cmd func entered, overloaded 39 | ; (:eof :null-command :cmd-error :cmd-ambiguous :history-error) 40 | (args nil) ; args for cmd func 41 | (hnum nil)) ; history number 42 | 43 | 44 | ;;; cmd table entry 45 | (defstruct command-table-entry 46 | (name nil) ; name of command 47 | (func nil) ; function handler 48 | (desc nil) ; short description 49 | (parsing nil) ; (:string :case-sensitive nil) 50 | (group nil) ; command group (:cmd or :alias) 51 | (abbr-len 0)) ; abbreviation length 52 | 53 | (defparameter *default-prompt* 54 | "~:[~3*~;[~:*~D~:[~;~:*:~D~]~:[~;i~]~:[~;c~]] ~]~A~*> " 55 | "The default prompt.") 56 | (defparameter *prompt* *default-prompt* 57 | "The current prompt string or formatter function.") 58 | (defparameter *use-short-package-name* t 59 | "when T, use the shortnest package nickname in a prompt") 60 | (defparameter *dir-stack* nil 61 | "The top-level directory stack") 62 | (defparameter *command-chars* ":," 63 | "Prefix characters for a top-level command") 64 | (defvar *max-history* 100 65 | "Maximum number of history commands to remember") 66 | (defvar *exit-on-eof* t 67 | "If T, then exit when the EOF character is entered.") 68 | (defparameter *history* nil 69 | "History list") 70 | (defparameter *cmd-number* 1 71 | "Number of the next command") 72 | 73 | (declaim (type list *history*)) 74 | 75 | (defvar *eof-marker* :eof) 76 | (defvar *eof-command* (make-user-command :func :eof)) 77 | (defvar *null-command* (make-user-command :func :null-command)) 78 | 79 | (defmacro define-repl-command 80 | (name-and-options (&rest args) &body docstring-and-forms) 81 | (destructuring-bind (name &key parsing abbr-len aliases) 82 | (if (listp name-and-options) name-and-options (list name-and-options)) 83 | (let ((docstring (when (stringp (car docstring-and-forms)) 84 | (car docstring-and-forms))) 85 | (cmd-name (intern (format nil "~A-CMD" (symbol-name name)) 86 | :prepl)) 87 | (name (string-downcase name))) 88 | `(progn 89 | (defun ,cmd-name (,@args) 90 | ,@docstring-and-forms) 91 | ,@(iter (for alias in (cons name aliases)) 92 | (collect `(add-command-table-entry 93 | ',alias 94 | ',abbr-len 95 | ',cmd-name 96 | ',(if (eq alias name) 97 | docstring 98 | (format nil "Alias for ~A" name)) 99 | ',parsing))))))) 100 | 101 | (defparameter *cmd-table-hash* 102 | (make-hash-table :test #'equal)) 103 | 104 | (defun prompt-package-name () 105 | (if *use-short-package-name* 106 | (car (sort (append 107 | (package-nicknames cl:*package*) 108 | (list (package-name cl:*package*))) 109 | (lambda (a b) (< (length a) (length b))))) 110 | (package-name cl:*package*))) 111 | 112 | (defun read-command (input-stream) 113 | ;; Reads a command from the user and returns a user-command object 114 | (let* ((next-char (peek-char-non-whitespace input-stream)) 115 | (cmd (cond 116 | ((command-char-p next-char) 117 | (dispatch-command-line input-stream)) 118 | ((eql #\newline next-char) 119 | (read-char input-stream) 120 | *null-command*) 121 | ((eql :eof next-char) 122 | *eof-command*) 123 | (t 124 | (let* ((eof (cons nil *eof-marker*)) 125 | (form (read input-stream nil eof))) 126 | (if (eq form eof) 127 | *eof-command* 128 | (make-user-command :input form :func nil :hnum *cmd-number*))))))) 129 | (skip-remaining-whitespace input-stream) 130 | (if (and (eq cmd *eof-command*) (typep input-stream 'string-stream)) 131 | (throw 'repl-catcher cmd) 132 | cmd))) 133 | 134 | (defun command-char-p (char) 135 | (position char *command-chars*)) 136 | 137 | (defun dispatch-command-line (input-stream) 138 | "Processes an input line that starts with *command-chars*" 139 | (let* ((line (string-trim-whitespace (read-line input-stream))) 140 | (first-space-pos (position #\space line)) 141 | (cmd-string (subseq line 1 first-space-pos)) 142 | (cmd-args-string 143 | (if first-space-pos 144 | (string-trim-whitespace (subseq line first-space-pos)) 145 | ""))) 146 | (declare (simple-string line)) 147 | (cond 148 | ((or (zerop (length cmd-string)) 149 | (whitespace-char-p (char cmd-string 0))) 150 | *null-command*) 151 | ((or (numberp (read-from-string cmd-string)) 152 | (char= (char cmd-string 0) #\+) 153 | (char= (char cmd-string 0) #\-)) 154 | (process-command/numeric cmd-string cmd-args-string)) 155 | ((command-char-p (char cmd-string 0)) 156 | (process-history-search (subseq cmd-string 1) cmd-args-string)) 157 | (t 158 | (multiple-value-bind 159 | (override user-command full-name) 160 | (process-command/text cmd-string line cmd-args-string) 161 | (or (unless (or (eq override :override-not-allowed) 162 | (zerop (command-char-p (elt line 0)))) 163 | (process-command/override (or full-name cmd-string) 164 | line 165 | cmd-args-string 166 | override 167 | user-command)) 168 | user-command)))))) 169 | 170 | (defun process-command/numeric (cmd-string cmd-args-string) 171 | "Process a numeric cmd, such as ':123'" 172 | (let* ((first-char (char cmd-string 0)) 173 | (number-string (if (digit-char-p first-char) 174 | cmd-string 175 | (subseq cmd-string 1))) 176 | (is-minus (char= first-char #\-)) 177 | (raw-number (read-from-string number-string)) 178 | (number (if is-minus 179 | (- *cmd-number* raw-number) 180 | raw-number)) 181 | (cmd (get-history number))) 182 | (when (eq cmd *null-command*) 183 | (return-from process-command/numeric 184 | (make-user-command :func :history-error :input (read-from-string 185 | cmd-string)))) 186 | (maybe-return-history-command cmd cmd-args-string))) 187 | 188 | (defun maybe-return-history-command (cmd cmd-args-string) 189 | (format *output* "~A~%" (user-command-input cmd)) 190 | (let ((dont-redo 191 | (when (and (stringp cmd-args-string) 192 | (plusp (length cmd-args-string)) 193 | (char= #\? (char cmd-args-string 0))) 194 | (do ((line nil (read-line *input*))) 195 | ((and line (or (zerop (length line)) 196 | (string-equal line "Y") 197 | (string-equal line "N"))) 198 | (when (string-equal line "N") 199 | t)) 200 | (when line 201 | (format *output* "Type \"y\" for yes or \"n\" for no.~%")) 202 | (format *output* "redo? [y] ") 203 | (force-output *output*))))) 204 | (if dont-redo 205 | *null-command* 206 | (make-user-command :func (user-command-func cmd) 207 | :input (user-command-input cmd) 208 | :args (user-command-args cmd) 209 | :hnum *cmd-number*)))) 210 | 211 | 212 | (defun find-history-matching-pattern (cmd-string) 213 | "Return history item matching cmd-string or NIL if not found" 214 | (dolist (his *history* nil) 215 | (let* ((input (user-command-input his)) 216 | (string-input (if (stringp input) 217 | input 218 | (write-to-string input)))) 219 | (when (search cmd-string string-input :test #'string-equal) 220 | (return-from find-history-matching-pattern his))))) 221 | 222 | (defun process-history-search (pattern cmd-args-string) 223 | (let ((cmd (find-history-matching-pattern pattern))) 224 | (unless cmd 225 | (format *output* "No match on history list with pattern ~S~%" pattern) 226 | (return-from process-history-search *null-command*)) 227 | (maybe-return-history-command cmd cmd-args-string))) 228 | 229 | (defun parse-args (parsing args-string) 230 | (case parsing 231 | (:string 232 | (if (zerop (length args-string)) 233 | nil 234 | (list args-string))) 235 | (t 236 | (let ((string-stream (make-string-input-stream args-string)) 237 | (eof (cons nil *eof-marker*))) ;new cons for eq uniqueness 238 | (loop as arg = (read string-stream nil eof) 239 | until (eq arg eof) 240 | collect arg))))) 241 | 242 | (defun process-command/text (cmd-string line cmd-args-string) 243 | "Process a text cmd, such as ':ld a b c'" 244 | (multiple-value-bind (cmd-entry all-matches) 245 | (completing-find-command cmd-string) 246 | (unless cmd-entry 247 | (return-from process-command/text 248 | (if all-matches 249 | (values 250 | :do-not-override 251 | (make-user-command :func :cmd-ambiguous :input all-matches)) 252 | (values 253 | nil 254 | (make-user-command :func :cmd-error :input cmd-string))))) 255 | (let ((parsing (command-table-entry-parsing cmd-entry))) 256 | (values (or parsing t) 257 | (make-user-command :func (command-table-entry-func cmd-entry) 258 | :input line 259 | :args (parse-args parsing cmd-args-string) 260 | :hnum *cmd-number*) 261 | (command-table-entry-name cmd-entry))))) 262 | 263 | (defvar *next-command*) 264 | 265 | (defun call-next-command (&rest args) 266 | (apply (or (user-command-func *next-command*) 267 | (error "no next command")) 268 | args )) 269 | 270 | (defun process-command/override 271 | (cmd line cmd-args-string override original-command) 272 | (dolist (hook *command-parser-hooks*) 273 | (multiple-value-bind (fun parsing) 274 | (funcall hook cmd override) 275 | (when fun 276 | (return 277 | (make-user-command :func (lambda (&rest args) 278 | (let ((*next-command* original-command)) 279 | (apply fun args))) 280 | :input line 281 | :args (parse-args parsing cmd-args-string) 282 | :hnum *cmd-number*)))))) 283 | 284 | (defun make-cte (name-param func desc parsing group abbr-len) 285 | (let ((name (etypecase name-param 286 | (string 287 | name-param) 288 | (symbol 289 | (string-downcase (write-to-string name-param)))))) 290 | (make-command-table-entry :name name :func func :desc desc 291 | :parsing parsing :group group 292 | :abbr-len (if abbr-len 293 | abbr-len 294 | (length name))))) 295 | 296 | (defun %add-entry (cmd &optional abbr-len) 297 | (let* ((name (command-table-entry-name cmd)) 298 | (alen (if abbr-len 299 | abbr-len 300 | (length name)))) 301 | (dotimes (i (length name)) 302 | (when (>= i (1- alen)) 303 | (setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*) 304 | cmd))))) 305 | 306 | (defun add-command-table-entry (cmd-string abbr-len func-name desc parsing) 307 | (%add-entry 308 | (make-cte cmd-string (symbol-function func-name) desc parsing :cmd abbr-len) 309 | abbr-len)) 310 | 311 | (defun find-command (cmdstr) 312 | (gethash (string-downcase cmdstr) *cmd-table-hash*)) 313 | 314 | (defun completing-find-command (cmdstr) 315 | (or (find-command cmdstr) 316 | (let ((matches 317 | (iter (for (name cmd) in-hashtable *cmd-table-hash*) 318 | (let ((mismatch (mismatch name cmdstr))) 319 | (when (eq mismatch (length cmdstr)) 320 | (collect cmd)))))) 321 | (cond 322 | ((null matches) 323 | nil) 324 | ((cddr matches) 325 | (values nil (mapcar #'command-table-entry-name matches))) 326 | (t 327 | (car matches)))))) 328 | 329 | (defun user-command= (c1 c2) 330 | "Returns T if two user commands are equal" 331 | (and (eq (user-command-func c1) (user-command-func c2)) 332 | (equal (user-command-args c1) (user-command-args c2)) 333 | (equal (user-command-input c1) (user-command-input c2)))) 334 | 335 | (defun add-to-history (cmd) 336 | (unless (and *history* (user-command= cmd (car *history*))) 337 | (when (>= (length *history*) *max-history*) 338 | (setq *history* (nbutlast *history* 339 | (1+ (- (length *history*) *max-history*))))) 340 | (push cmd *history*) 341 | (incf *cmd-number*))) 342 | 343 | (defun get-history (n) 344 | (let ((cmd (find n *history* :key #'user-command-hnum :test #'eql))) 345 | (if cmd 346 | cmd 347 | *null-command*))) 348 | 349 | (defun get-command-doc-list (&optional (group :cmd)) 350 | "Return list of all commands" 351 | (let ((cmds '())) 352 | (maphash (lambda (k v) 353 | (when (and 354 | (= (length k) (length (command-table-entry-name v))) 355 | (eq (command-table-entry-group v) group)) 356 | (push (list k 357 | (if (= (command-table-entry-abbr-len v) 358 | (length k)) 359 | "" 360 | (subseq k 0 (command-table-entry-abbr-len v))) 361 | (command-table-entry-desc v)) cmds))) 362 | *cmd-table-hash*) 363 | (sort cmds #'string-lessp :key #'car))) 364 | 365 | (define-repl-command (cd :parsing :string) (&optional string-dir) 366 | "change default directory" 367 | (cond 368 | ((or (zerop (length string-dir)) 369 | (string= string-dir "~")) 370 | (setf cl:*default-pathname-defaults* (user-homedir-pathname))) 371 | (t 372 | (let ((new (truename string-dir))) 373 | (when (pathnamep new) 374 | (setf cl:*default-pathname-defaults* new))))) 375 | (format *output* "~A~%" (namestring cl:*default-pathname-defaults*)) 376 | (values)) 377 | 378 | (define-repl-command pwd () 379 | "print current directory" 380 | (format *output* "Lisp's current working directory is ~s.~%" 381 | (namestring cl:*default-pathname-defaults*)) 382 | (values)) 383 | 384 | (define-repl-command trace (&rest args) 385 | "trace a function" 386 | (format *output* "~A~%" (eval `(trace ,@args))) 387 | (values)) 388 | 389 | (define-repl-command untrace (&rest args) 390 | "untrace a function" 391 | (format *output* "~A~%" (eval `(untrace ,@args))) 392 | (values)) 393 | 394 | (defun other-threads () 395 | "Returns a list of all threads except the current one" 396 | (remove (bordeaux-threads:current-thread) (bordeaux-threads:all-threads))) 397 | 398 | (defun quit (status) 399 | #+sbcl (sb-ext:quit :unix-status status) 400 | #+openmcl (ccl:quit status) 401 | #+allegro (excl:exit status) 402 | #-(or sbcl openmcl) (error "Sorry, don't know how to quit on this Lisp.")) 403 | 404 | (define-repl-command exit (&optional (status 0)) 405 | "exit lisp" 406 | (let ((other-threads (other-threads))) 407 | (when other-threads 408 | (format *output* "There exists the following processes~%") 409 | (format *output* "~{~A~%~}" other-threads) 410 | (format *output* "Do you want to exit lisp anyway [n]? ") 411 | (force-output *output*) 412 | (let ((input (string-trim-whitespace (read-line *input*)))) 413 | (if (and (plusp (length input)) 414 | (or (char= #\y (char input 0)) 415 | (char= #\Y (char input 0)))) 416 | ;; loop in case more threads get created while trying to exit 417 | (do ((threads other-threads (other-threads))) 418 | ((eq nil threads)) 419 | (map nil #'bordeaux-threads:destroy-thread threads) 420 | (sleep 0.2)) 421 | (return-from exit-cmd))))) 422 | (quit status) 423 | (values)) 424 | 425 | (define-repl-command package (&optional pkg) 426 | "change current package" 427 | (cond 428 | ((null pkg) 429 | (format *output* "The ~A package is current.~%" 430 | (package-name cl:*package*))) 431 | ((null (find-package (write-to-string pkg))) 432 | (format *output* "Unknown package: ~A.~%" pkg)) 433 | (t 434 | (setf cl:*package* (find-package (write-to-string pkg))))) 435 | (values)) 436 | 437 | (defun readtable-name-for-repl (table) 438 | ;; don't want :CURRENT as a readtable name 439 | (let ((name (named-readtables:readtable-name table))) 440 | (if (and name (not (eq name :current))) 441 | name 442 | *readtable*))) 443 | 444 | (define-repl-command readtable (&optional name) 445 | "change current readtable" 446 | (cond 447 | (name 448 | (let ((table (named-readtables:find-readtable name))) 449 | (if table 450 | (prog1 451 | (setf *readtable* (named-readtables:find-readtable name)) 452 | (format *output* "The ~A readtable is now current.~%" 453 | (readtable-name-for-repl *readtable*))) 454 | (format *output* "Unknown readtable: ~A.~%" name)))) 455 | (t 456 | (format *output* "The ~A readtable is current.~%" 457 | (readtable-name-for-repl *readtable*)) 458 | *readtable*))) 459 | 460 | (defun string-to-list-skip-spaces (str) 461 | "Return a list of strings, delimited by spaces, skipping spaces." 462 | (declare (type (or null string) str)) 463 | (when str 464 | (loop for i = 0 then (1+ j) 465 | as j = (position #\space str :start i) 466 | when (not (char= (char str i) #\space)) 467 | collect (subseq str i j) while j))) 468 | 469 | (let ((last-files-loaded nil)) 470 | (define-repl-command (ld :parsing :string) (&optional string-files) 471 | "load a file" 472 | (if string-files 473 | (setq last-files-loaded string-files) 474 | (setq string-files last-files-loaded)) 475 | (dolist (arg (string-to-list-skip-spaces string-files)) 476 | (let ((file 477 | (if (string= arg "~/" :end1 1 :end2 1) 478 | (merge-pathnames (parse-namestring 479 | (string-left-trim "~/" arg)) 480 | (user-homedir-pathname)) 481 | arg))) 482 | (format *output* "loading ~S~%" file) 483 | (load file)))) 484 | (values)) 485 | 486 | (define-repl-command (cf :parsing :string) (string-files) 487 | "compile file" 488 | (when string-files 489 | (dolist (arg (string-to-list-skip-spaces string-files)) 490 | (compile-file arg))) 491 | (values)) 492 | 493 | (defun >-num (x y) 494 | "Return if x and y are numbers, and x > y" 495 | (and (numberp x) (numberp y) (> x y))) 496 | 497 | (defun newer-file-p (file1 file2) 498 | "Is file1 newer (written later than) file2?" 499 | (>-num (if (probe-file file1) (file-write-date file1)) 500 | (if (probe-file file2) (file-write-date file2)))) 501 | 502 | (defun compile-file-as-needed (src-path) 503 | "Compiles a file if needed, returns path." 504 | (let ((dest-path (compile-file-pathname src-path))) 505 | (when (or (not (probe-file dest-path)) 506 | (newer-file-p src-path dest-path)) 507 | (ensure-directories-exist dest-path) 508 | (compile-file src-path :output-file dest-path)) 509 | dest-path)) 510 | 511 | ;;;; implementation of commands 512 | 513 | (define-repl-command (apropos :parsing :string) (string) 514 | "show apropos" 515 | (apropos (string-upcase string)) 516 | (fresh-line *output*) 517 | (values)) 518 | 519 | (let ((last-files-loaded nil)) 520 | (define-repl-command (cload :parsing :string) (&optional string-files) 521 | "compile if needed and load file" 522 | (if string-files 523 | (setq last-files-loaded string-files) 524 | (setq string-files last-files-loaded)) 525 | (dolist (arg (string-to-list-skip-spaces string-files)) 526 | (format *output* "loading ~a~%" arg) 527 | (load (compile-file-as-needed arg))) 528 | (values))) 529 | 530 | (define-repl-command inspect (arg) 531 | "inspect an object" 532 | (inspector-fun (eval arg) nil *output*) 533 | (values)) 534 | 535 | (define-repl-command istep (&optional arg-string) 536 | "navigate within inspection of a lisp object" 537 | (istep (string-to-list-skip-spaces arg-string) *output*) 538 | (values)) 539 | 540 | (define-repl-command describe (&rest args) 541 | "describe an object" 542 | (dolist (arg args) 543 | (eval `(describe ,arg))) 544 | (values)) 545 | 546 | (define-repl-command macroexpand (arg) 547 | "macroexpand an expression" 548 | (pprint (macroexpand arg) *output*) 549 | (values)) 550 | 551 | (define-repl-command history () 552 | "print the recent history" 553 | (let ((n (length *history*))) 554 | (declare (fixnum n)) 555 | (dotimes (i n) 556 | (declare (fixnum i)) 557 | (let ((hist (nth (- n i 1) *history*))) 558 | (format *output* "~3A " (user-command-hnum hist)) 559 | (if (stringp (user-command-input hist)) 560 | (format *output* "~A~%" (user-command-input hist)) 561 | (format *output* "~W~%" (user-command-input hist)))))) 562 | (values)) 563 | 564 | (define-repl-command help (&optional cmd) 565 | "print this help" 566 | (cond 567 | (cmd 568 | (let ((cmd-entry (completing-find-command cmd))) 569 | (if cmd-entry 570 | (format *output* "Documentation for ~A: ~A~%" 571 | (command-table-entry-name cmd-entry) 572 | (command-table-entry-desc cmd-entry))))) 573 | (t 574 | (format *output* "Command characters are ~{'~A'~^ and ~}.~%" 575 | (coerce *command-chars* 'list)) 576 | (format *output* "Names can be abbreviated to any unique prefix.~%") 577 | (format *output* "~%Full list of commands:~%~%") 578 | (format *output* "~11A ~4A ~A~%" "COMMAND" "" "DESCRIPTION") 579 | (format *output* "~11A ~4A ~A~%" "" "" 580 | "re-execute th history command") 581 | (dolist (doc-entry (get-command-doc-list :cmd)) 582 | (format *output* "~11A ~4A ~A~%" (first doc-entry) 583 | (second doc-entry) (third doc-entry))))) 584 | (values)) 585 | 586 | (define-repl-command aliases () 587 | "show aliases" 588 | (let ((doc-entries (get-command-doc-list :alias))) 589 | (typecase doc-entries 590 | (cons 591 | (format *output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION") 592 | (dolist (doc-entry doc-entries) 593 | (format *output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry)))) 594 | (t 595 | (format *output* "No aliases are defined~%")))) 596 | (values)) 597 | 598 | #+nil 599 | ;; later, this command can be defined portably in hemlock, which has a 600 | ;; suitable process abstraction. 601 | (define-repl-command shell (string-arg) 602 | (sb-ext:run-program "/bin/sh" (list "-c" string-arg) 603 | :input nil :output *output*) 604 | (values)) 605 | 606 | (define-repl-command (pushd :parsing :string) (string-arg) 607 | "push directory on stack" 608 | (push string-arg *dir-stack*) 609 | (cd-cmd string-arg) 610 | (values)) 611 | 612 | (define-repl-command popd () 613 | "pop directory from stack" 614 | (if *dir-stack* 615 | (let ((dir (pop *dir-stack*))) 616 | (cd-cmd dir)) 617 | (format *output* "No directory on stack to pop.~%")) 618 | (values)) 619 | 620 | (define-repl-command pop (&optional (n 1)) 621 | "pop up `n' (default 1) break levels" 622 | (cond 623 | (*inspect-break* 624 | (throw 'repl-catcher (values :inspect n))) 625 | ((plusp *break-level*) 626 | (throw 'repl-catcher (values :pop n)))) 627 | (values)) 628 | 629 | (defvar *current-error* nil) 630 | (defvar *debugging-context* nil) 631 | 632 | (define-repl-command bt (&optional (n most-positive-fixnum)) 633 | "backtrace `n' stack frames, default all" 634 | (conium:call-with-debugging-environment 635 | (lambda () 636 | (mapcar (lambda (frame) 637 | (conium:print-frame frame *standard-output*) 638 | (fresh-line)) 639 | (conium:compute-backtrace 0 n))))) 640 | 641 | (define-repl-command current () 642 | "print the expression for the current stack frame" 643 | (if *current-error* 644 | (describe *current-error*) 645 | (write-line "No error."))) 646 | 647 | (define-repl-command top () 648 | "move to top stack frame" 649 | #+implement-the-debugger (sb-debug::frame-debug-command 0)) 650 | 651 | (define-repl-command bottom () 652 | "move to bottom stack frame" 653 | #+implement-the-debugger (sb-debug::bottom-debug-command)) 654 | 655 | (define-repl-command up (&optional (n 1)) 656 | (declare (ignore n)) 657 | "move up `n' stack frames, default 1" 658 | #+implement-the-debugger 659 | (dotimes (i n) 660 | (if (and sb-debug::*current-frame* 661 | (sb-di:frame-up sb-debug::*current-frame*)) 662 | (sb-debug::up-debug-command) 663 | (progn 664 | (format *output* "Top of the stack") 665 | (return-from up-cmd))))) 666 | 667 | (define-repl-command dn (&optional (n 1)) 668 | (declare (ignore n)) 669 | "move down `n' stack frames, default 1" 670 | #+implement-the-debugger 671 | (dotimes (i n) 672 | (if (and sb-debug::*current-frame* 673 | (sb-di:frame-down sb-debug::*current-frame*)) 674 | (sb-debug::down-debug-command) 675 | (progn 676 | (format *output* "Bottom of the stack") 677 | (return-from dn-cmd))))) 678 | 679 | (define-repl-command continue (&optional (num 0)) 680 | "continue from a continuable error" 681 | ;; don't look at first restart 682 | (let ((restarts (compute-restarts))) 683 | (if restarts 684 | (let ((restart 685 | (typecase num 686 | (unsigned-byte 687 | (if (< -1 num (length restarts)) 688 | (nth num restarts) 689 | (progn 690 | (format *output* "There is no such restart") 691 | (return-from continue-cmd)))) 692 | (symbol 693 | (find num (the list restarts) 694 | :key #'restart-name 695 | :test (lambda (sym1 sym2) 696 | (string= (symbol-name sym1) 697 | (symbol-name sym2))))) 698 | (t 699 | (format *output* "~S is invalid as a restart name" num) 700 | (return-from continue-cmd nil))))) 701 | (when restart 702 | (invoke-restart-interactively restart))) 703 | (format *output* "~&There are no restarts")))) 704 | 705 | (define-repl-command abort () 706 | "Invoke ABORT restart." 707 | ;; don't look at first restart 708 | (when (find-restart 'abort) 709 | (invoke-restart 'abort)) 710 | (format *output* "~&No abort restart found.")) 711 | 712 | (define-repl-command error () 713 | "print the last error message" 714 | (if *current-error* 715 | (format t "~&Current condition: ~S:~% ~:*~A~%" *current-error*) 716 | (format t "~&No current error.~%")) 717 | (terpri) 718 | (show-restarts) 719 | (shiftf *** ** * *current-error*)) 720 | 721 | (defun show-restarts () 722 | (format t "Available restarts:~%") 723 | (let ((shadowing-names '())) 724 | (iter (for restart in (compute-restarts)) 725 | (for i from 0) 726 | (let ((name (restart-name restart))) 727 | (if (find name shadowing-names) 728 | (setf name nil) 729 | (push name shadowing-names)) 730 | (format t "~4D ~@[[~A]~]~30T~A~%" i name restart))))) 731 | 732 | (define-repl-command frame () 733 | "print info about the current frame" 734 | #+implement-the-debugger 735 | (sb-debug::print-frame-call sb-debug::*current-frame*)) 736 | 737 | (define-repl-command zoom () 738 | "print the runtime stack" 739 | (conium:call-with-debugging-environment 740 | (lambda () 741 | (mapcar (lambda (frame) 742 | (conium:print-frame frame *standard-output*) 743 | (fresh-line)) 744 | (conium:compute-backtrace 0 most-positive-fixnum))))) 745 | 746 | (define-repl-command local (&optional var) 747 | "print the value of a local variable" 748 | (declare (ignore var)) 749 | #+implement-the-debugger 750 | (sb-debug::list-locals-debug-command)) 751 | 752 | (define-repl-command processes () 753 | (dolist (thread (bordeaux-threads:all-threads)) 754 | (format *output* "~&~A~20T~:[dead~;alive~]~@[~20T[current thread]~]" 755 | (bordeaux-threads:thread-name thread) 756 | (bordeaux-threads:thread-alive-p thread) 757 | (eq thread (bordeaux-threads:current-thread)))) 758 | (values)) 759 | 760 | (define-repl-command kill (&rest selected-threads) 761 | "kill (destroy) processes" 762 | (dolist (thread selected-threads) 763 | (let ((found (find thread (bordeaux-threads:all-threads) 764 | :key 'bordeaux-threads:thread-name 765 | :test 'equal))) 766 | (if found 767 | (progn 768 | (format *output* "~&Destroying thread ~A" thread) 769 | (bordeaux-threads:destroy-thread found)) 770 | (format *output* "~&Thread ~A not found" thread)))) 771 | (values)) 772 | 773 | #+nil 774 | ;; Cute idea, but a hassle to get right and somewhat useless in a 775 | ;; multi-buffer GUI like hemlock. 776 | (define-repl-command focus (&optional process) 777 | (declare (ignore process))) 778 | 779 | (define-repl-command reset () 780 | "reset to top break level" 781 | (when (find-restart 'abort-to-outmost-repl) 782 | (invoke-restart 'abort-to-outmost-repl))) 783 | 784 | (define-repl-command dirs () 785 | "show directory stack" 786 | (dolist (dir *dir-stack*) 787 | (format *output* "~a~%" dir)) 788 | (values)) 789 | 790 | (define-repl-command (load-op :aliases ("make" "load-system") 791 | :parsing :string) 792 | (name) 793 | "Load the specified ASDF system" 794 | (asdf:operate 'asdf:load-op name) 795 | (prin1 (asdf:find-system name))) 796 | 797 | 798 | ;;;; machinery for aliases 799 | 800 | ;;;; Fixme: 801 | ;;;; 802 | ;;;; - ALIAS is a bad name, dating back to Allegro. 803 | ;;;; We should only be talking about commands. 804 | ;;;; 805 | ;;;; - I don't see a reason to have a distiction between built-in commands 806 | ;;;; and user-defined commands. 807 | ;;;; 808 | ;;;; - Little differences between DEFINE-REPL-COMMAND and ALIAS remain. 809 | ;;;; 810 | ;;;; Need to get rid of ALIAS in favour of DEFINE-REPL-COMMAND at some point. 811 | 812 | (defsetf alias (name &key abbr-len description) (user-func) 813 | `(progn 814 | (%add-entry 815 | (make-cte (quote ,name) ,user-func ,description nil :alias ,abbr-len)) 816 | (quote ,name))) 817 | 818 | (defmacro alias (name-param args &rest body) 819 | (let ((parsing nil) 820 | (desc "") 821 | (abbr-index nil) 822 | (name (if (atom name-param) 823 | name-param 824 | (car name-param)))) 825 | (when (consp name-param) 826 | (dolist (param (cdr name-param)) 827 | (cond 828 | ((or 829 | (eq param :case-sensitive) 830 | (eq param :string)) 831 | (setq parsing param)) 832 | ((stringp param) 833 | (setq desc param)) 834 | ((numberp param) 835 | (setq abbr-index param))))) 836 | `(progn 837 | (%add-entry 838 | (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias (when ,abbr-index 839 | (1+ ,abbr-index))) 840 | ,abbr-index) 841 | ,name))) 842 | 843 | 844 | (defun remove-alias (&rest aliases) 845 | (declare (list aliases)) 846 | (let ((keys '()) 847 | (remove-all (not (null (find :all aliases))))) 848 | (unless remove-all ;; ensure all alias are strings 849 | (setq aliases 850 | (loop for alias in aliases 851 | collect 852 | (etypecase alias 853 | (string 854 | alias) 855 | (symbol 856 | (symbol-name alias)))))) 857 | (maphash 858 | (lambda (key cmd) 859 | (when (eq (command-table-entry-group cmd) :alias) 860 | (if remove-all 861 | (push key keys) 862 | (when (some 863 | (lambda (alias) 864 | (let ((klen (length key))) 865 | (and (>= (length alias) klen) 866 | (string-equal (subseq alias 0 klen) 867 | (subseq key 0 klen))))) 868 | aliases) 869 | (push key keys))))) 870 | *cmd-table-hash*) 871 | (dolist (key keys) 872 | (remhash key *cmd-table-hash*)) 873 | keys)) 874 | 875 | ;;;; low-level reading/parsing functions 876 | 877 | ;;; Skip white space (but not #\NEWLINE), and peek at the next 878 | ;;; character. 879 | (defun peek-char-non-whitespace (&optional stream) 880 | (do ((char (peek-char nil stream nil *eof-marker*) 881 | (peek-char nil stream nil *eof-marker*))) 882 | ((not (whitespace-char-not-newline-p char)) char) 883 | (read-char stream))) 884 | 885 | (defun string-trim-whitespace (str) 886 | (string-trim '(#\space #\tab #\return) 887 | str)) 888 | 889 | (defun whitespace-char-p (x) 890 | (and (characterp x) 891 | (or (char= x #\space) 892 | (char= x #\tab) 893 | (char= x #\page) 894 | (char= x #\newline) 895 | (char= x #\return)))) 896 | 897 | (defun whitespace-char-not-newline-p (x) 898 | (and (whitespace-char-p x) 899 | (not (char= x #\newline)))) 900 | 901 | (defun skip-remaining-whitespace (&optional stream) 902 | (iter 903 | (let ((char (read-char-no-hang stream nil *eof-marker*))) 904 | (while char) 905 | (until (eq char *eof-marker*)) 906 | (unless (whitespace-char-p char) 907 | (unread-char char stream) 908 | (return))))) 909 | 910 | ;;;; the following functions used to be hooks in SBCL 911 | 912 | (defun frame-number () 913 | #+implement-the-debugger (when (and (plusp *break-level*) 914 | sb-debug::*current-frame*) 915 | (sb-di::frame-number sb-debug::*current-frame*)) 916 | nil) 917 | 918 | (defvar *prompt-hooks* 919 | (list #+sbcl #'sb-thread::get-foreground)) 920 | 921 | (defun prompt (stream) 922 | (let ((break-level (when (plusp *break-level*) 923 | *break-level*)) 924 | (frame-number (frame-number))) 925 | (run-hooks *prompt-hooks*) 926 | (fresh-line stream) 927 | (if (functionp *prompt*) 928 | (write-string (funcall *prompt* 929 | break-level 930 | frame-number 931 | *inspect-break* 932 | *continuable-break* 933 | (prompt-package-name) 934 | *cmd-number*) 935 | stream) 936 | (handler-case 937 | (format nil *prompt* 938 | break-level 939 | frame-number 940 | *inspect-break* 941 | *continuable-break* 942 | (prompt-package-name) *cmd-number*) 943 | (error () 944 | (format stream "~&Prompt error> ")) 945 | (:no-error (prompt) 946 | (format stream "~A" prompt)))))) 947 | 948 | (defun process-command (user-command) 949 | "list all processes" 950 | ;; Processes a user command. Returns t if the user-command was a top-level 951 | ;; command 952 | (cond ((eq user-command *eof-command*) 953 | (cond 954 | ((plusp *break-level*) 955 | (throw 'repl-catcher (values :pop 1))) 956 | (*exit-on-eof* 957 | (quit 0))) 958 | (format *output* "EOF~%") 959 | t) 960 | ((eq user-command *null-command*) 961 | t) 962 | ((eq (user-command-func user-command) :cmd-error) 963 | (format *output* "Unknown top-level command: ~s.~%" 964 | (user-command-input user-command)) 965 | (format *output* "Type `~Ahelp' for the list of commands.~%" (elt *command-chars* 0)) 966 | t) 967 | ((eq (user-command-func user-command) :cmd-ambiguous) 968 | (format *output* "Ambiguous top-level command. Completions are:~{~% ~A~}.~%" 969 | (user-command-input user-command)) 970 | t) 971 | ((eq (user-command-func user-command) :history-error) 972 | (format *output* "Input numbered ~d is not on the history list~%" 973 | (user-command-input user-command)) 974 | t) 975 | ((functionp (user-command-func user-command)) 976 | (add-to-history user-command) 977 | (apply (user-command-func user-command) (user-command-args user-command)) 978 | t) 979 | (t 980 | (add-to-history user-command) 981 | nil))) ; nope, not in my job description 982 | 983 | (defmacro rebinding ((&rest vars) &body body) 984 | `(let (,@(mapcar (lambda (var) `(,var ,var)) vars)) 985 | ,@body)) 986 | 987 | #+sbcl 988 | ;; unwinding through with-new-session seems to wreak havoc, so let's only 989 | ;; wrap this around the outermost repl. 990 | (defvar *in-session-workaround* nil) 991 | 992 | (defun invoke-with-session-workaround-if-on-sbcl (fun) 993 | #+sbcl (if *in-session-workaround* 994 | (funcall fun) 995 | (let ((*in-session-workaround* t)) 996 | (sb-thread:with-new-session () (funcall fun)))) 997 | #-sbcl (funcall fun)) 998 | 999 | (defmacro session-workaround-if-on-sbcl (&rest forms) 1000 | `(invoke-with-session-workaround-if-on-sbcl (lambda () ,@forms))) 1001 | 1002 | (defvar *entering-prepl-debugger-hook* nil) 1003 | 1004 | (defun debugger (condition hook &optional pre-repl-fun) 1005 | (declare (ignore hook)) 1006 | (let ((*current-error* condition) 1007 | (*debugging-context* (gensym))) 1008 | (flet ((cont () 1009 | (format t "~&Debugger entered for condition: ~S:~% ~:*~A~%" 1010 | *current-error*) 1011 | (show-restarts) 1012 | (conium:call-with-debugging-environment 1013 | (lambda () 1014 | (when pre-repl-fun (funcall pre-repl-fun)) 1015 | (repl))))) 1016 | (if *entering-prepl-debugger-hook* 1017 | (funcall *entering-prepl-debugger-hook* #'cont) 1018 | (cont))))) 1019 | 1020 | (defun repl (&rest args &key break-level noprint inspect continuable nobanner) 1021 | (declare (ignore break-level noprint inspect continuable nobanner)) 1022 | (rebinding 1023 | (*break-level* *inspect-break* *continuable-break* 1024 | *dir-stack* *command-chars* *prompt* 1025 | *use-short-package-name* *max-history* *exit-on-eof* 1026 | *history* *cmd-number*) 1027 | (conium:call-with-debugger-hook 1028 | #'debugger 1029 | (lambda () 1030 | (session-workaround-if-on-sbcl (apply #'%repl args)))))) 1031 | 1032 | (defun global-prepl-debugger-hook (condition hook) 1033 | ;; (session-workaround-if-on-sbcl (lambda ())) 1034 | (debugger condition hook)) 1035 | 1036 | (defun install-global-prepl-debugger-hook () 1037 | (conium:install-debugger-globally #'global-prepl-debugger-hook)) 1038 | 1039 | -------------------------------------------------------------------------------- /debug.lisp: -------------------------------------------------------------------------------- 1 | ;;; This file was taken from SBCL's sb-aclrepl contrib, written by Keven 2 | ;;; Rosenberg and available under SBCL's public domain status. 3 | ;;; 4 | ;;; Changes since then are: 5 | 6 | ;;; Copyright (c) 2009 David Lichteblau. All rights reserved. 7 | 8 | ;;; Redistribution and use in source and binary forms, with or without 9 | ;;; modification, are permitted provided that the following conditions 10 | ;;; are met: 11 | ;;; 12 | ;;; * Redistributions of source code must retain the above copyright 13 | ;;; notice, this list of conditions and the following disclaimer. 14 | ;;; 15 | ;;; * Redistributions in binary form must reproduce the above 16 | ;;; copyright notice, this list of conditions and the following 17 | ;;; disclaimer in the documentation and/or other materials 18 | ;;; provided with the distribution. 19 | ;;; 20 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 21 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 23 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 24 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 26 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 27 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | ;;;; Debugger for prepl 33 | 34 | (in-package :prepl) 35 | 36 | ;;; FIXME: These declaims violate package locks. Are they needed at 37 | ;;; all? Seems not. 38 | #+ignore 39 | (declaim (special 40 | sb-debug::*debug-command-level* 41 | sb-debug::*real-stack-top* sb-debug::*stack-top* 42 | sb-debug::*stack-top-hint* sb-debug::*current-frame* 43 | sb-debug::*flush-debug-errors*)) 44 | 45 | (defun debug-loop () 46 | (let* ((sb-debug::*debug-command-level* (1+ sb-debug::*debug-command-level*)) 47 | (sb-debug::*real-stack-top* (sb-di:top-frame)) 48 | (sb-debug::*stack-top* (or sb-debug::*stack-top-hint* 49 | sb-debug::*real-stack-top*)) 50 | (sb-debug::*stack-top-hint* nil) 51 | (sb-debug::*current-frame* sb-debug::*stack-top*) 52 | (continuable (continuable-break-p))) 53 | (handler-bind ((sb-di:debug-condition 54 | (lambda (condition) 55 | (princ condition sb-debug::*debug-io*) 56 | (sb-int:/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") 57 | (throw 'debug-loop-catcher nil)))) 58 | (fresh-line) 59 | ;;(sb-debug::print-frame-call sb-debug::*current-frame* :verbosity 2) 60 | (loop ;; only valid to way to exit invoke-debugger is by a restart 61 | (catch 'debug-loop-catcher 62 | (handler-bind ((error (lambda (condition) 63 | (when sb-debug::*flush-debug-errors* 64 | (clear-input *debug-io*) 65 | (princ condition) 66 | ;; FIXME: Doing input on *DEBUG-IO* 67 | ;; and output on T seems broken. 68 | (format t 69 | "~&error flushed (because ~ 70 | ~S is set)" 71 | 'sb-debug::*flush-debug-errors*) 72 | (sb-int:/show0 "throwing DEBUG-LOOP-CATCHER") 73 | (throw 'debug-loop-catcher nil))))) 74 | 75 | (if (zerop *break-level*) ; restart added by SBCL 76 | (repl :continuable continuable) 77 | (let ((level *break-level*)) 78 | (with-simple-restart 79 | (abort "~@" 80 | level) 81 | (let ((sb-debug::*debug-restarts* (compute-restarts))) 82 | (repl :continuable continuable))))))) 83 | (throw 'repl-catcher (values :debug :exit)) 84 | )))) 85 | 86 | 87 | (defun continuable-break-p () 88 | (when (eq 'continue 89 | (restart-name (car (compute-restarts)))) 90 | t)) 91 | 92 | #+ignore 93 | (when (boundp 'sb-debug::*debug-loop-fun*) 94 | (setq sb-debug::*debug-loop-fun* #'debug-loop)) 95 | 96 | (defun print-restarts () 97 | ;; (format *output* "~&Restart actions (select using :continue)~%") 98 | (format *standard-output* "~&Restart actions (select using :continue)~%") 99 | (let ((restarts (compute-restarts))) 100 | (dotimes (i (length restarts)) 101 | (format *standard-output* "~&~2D: ~A~%" i (nth i restarts))))) 102 | 103 | 104 | #+ignore 105 | (defun debugger (condition) 106 | "Enter the debugger." 107 | (let ((old-hook *debugger-hook*)) 108 | (when old-hook 109 | (let ((*debugger-hook* nil)) 110 | (funcall old-hook condition old-hook)))) 111 | (%debugger condition)) 112 | 113 | #+ignore 114 | (when (boundp 'sb-debug::*invoke-debugger-fun*) 115 | (setq sb-debug::*invoke-debugger-fun* #'debugger)) 116 | 117 | #+ignore 118 | (defun print-condition (condition) 119 | (format *output* "~&Error: ~A~%" condition)) 120 | 121 | #+ignore 122 | (defun print-condition-type (condition) 123 | (format *output* "~& [Condition type: ~A]~%" (type-of condition))) 124 | 125 | #+ignore 126 | (defun %debugger (condition) 127 | (print-condition condition) 128 | (print-condition-type condition) 129 | (princ #\newline *output*) 130 | (print-restarts) 131 | (acldebug-loop)) 132 | 133 | 134 | #+ignore 135 | (defun acldebug-loop () 136 | (let ((continuable (continuable-break-p))) 137 | (if continuable 138 | (aclrepl :continuable t) 139 | (let ((level *break-level*)) 140 | (with-simple-restart 141 | (abort "~@" level) 142 | (loop 143 | (repl))))))) 144 | 145 | -------------------------------------------------------------------------------- /inspect.lisp: -------------------------------------------------------------------------------- 1 | ;;; This file was taken from SBCL's sb-aclrepl contrib, written by Keven 2 | ;;; Rosenberg and available under SBCL's public domain status. 3 | ;;; 4 | ;;; Changes since then are: 5 | 6 | ;;; Copyright (c) 2009 David Lichteblau. All rights reserved. 7 | 8 | ;;; Redistribution and use in source and binary forms, with or without 9 | ;;; modification, are permitted provided that the following conditions 10 | ;;; are met: 11 | ;;; 12 | ;;; * Redistributions of source code must retain the above copyright 13 | ;;; notice, this list of conditions and the following disclaimer. 14 | ;;; 15 | ;;; * Redistributions in binary form must reproduce the above 16 | ;;; copyright notice, this list of conditions and the following 17 | ;;; disclaimer in the documentation and/or other materials 18 | ;;; provided with the distribution. 19 | ;;; 20 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 21 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 23 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 24 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 26 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 27 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | ;;;; Inspector for prepl 33 | 34 | (in-package :prepl) 35 | 36 | (eval-when (:compile-toplevel :load-toplevel :execute) 37 | (defconstant +default-inspect-length+ 20)) 38 | 39 | (defstruct (%inspect (:constructor make-inspect) 40 | (:conc-name inspect-)) 41 | ;; stack of parents of inspected object 42 | object-stack 43 | ;; a stack of indices of parent object components 44 | select-stack) 45 | 46 | ;; FIXME - raw mode isn't currently used in object display 47 | (defparameter *current-inspect* nil 48 | "current inspect") 49 | (defparameter *inspect-raw* nil 50 | "Raw mode for object display.") 51 | (defparameter *inspect-length* +default-inspect-length+ 52 | "maximum number of components to print") 53 | (defparameter *skip-address-display* nil 54 | "Skip displaying addresses of objects.") 55 | 56 | (defvar *inspect-help* 57 | ":istep takes between 0 to 3 arguments. 58 | The commands are: 59 | :i redisplay current object 60 | :i = redisplay current object 61 | :i nil redisplay current object 62 | :i ? display this help 63 | :i * inspect the current * value 64 | :i +
inspect the (eval form) 65 | :i slot inspect component of object, even if name is an istep cmd 66 | :i inspect the numbered component of object 67 | :i inspect the named component of object 68 | :i evaluation and inspect form 69 | :i - inspect parent 70 | :i ^ inspect parent 71 | :i < inspect previous parent component 72 | :i > inspect next parent component 73 | :i set set indexed component to evalated form 74 | :i print set the maximum number of components to print 75 | :i skip skip a number of components when printing 76 | :i tree print inspect stack 77 | ") 78 | 79 | ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it 80 | ;;; indicates that that a slot is unbound. 81 | (eval-when (:compile-toplevel :load-toplevel :execute) 82 | (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))) 83 | 84 | (defun inspector-fun (object input-stream output-stream) 85 | (let ((*current-inspect* nil) 86 | (*inspect-raw* nil) 87 | (*inspect-length* *inspect-length*) 88 | (*skip-address-display* nil)) 89 | (setq *current-inspect* (make-inspect)) 90 | (reset-stack object "(inspect ...)") 91 | (redisplay output-stream) 92 | (let ((*input* input-stream) 93 | (*output* output-stream)) 94 | (repl :inspect t))) 95 | (values)) 96 | 97 | ;; hook into CL:INSPECT if the implementation supports it 98 | #+ccl (setf *default-inspector-ui-creation-function* 99 | (lambda (thing) (inspector-fun thing *terminal-io* *terminal-io*))) 100 | #+sbcl (setq sb-impl::*inspect-fun* #'inspector-fun) 101 | 102 | (defun istep (args stream) 103 | (unless *current-inspect* 104 | (setq *current-inspect* (make-inspect))) 105 | (istep-dispatch args 106 | (first args) 107 | (when (first args) (read-from-string (first args))) 108 | stream)) 109 | 110 | (defun istep-dispatch (args option-string option stream) 111 | (cond 112 | ((or (string= "=" option-string) (zerop (length args))) 113 | (istep-cmd-redisplay stream)) 114 | ((or (string= "-" option-string) (string= "^" option-string)) 115 | (istep-cmd-parent stream)) 116 | ((string= "*" option-string) 117 | (istep-cmd-inspect-* stream)) 118 | ((string= "+" option-string) 119 | (istep-cmd-inspect-new-form (read-from-string (second args)) stream)) 120 | ((or (string= "<" option-string) 121 | (string= ">" option-string)) 122 | (istep-cmd-select-parent-component option-string stream)) 123 | ((string-equal "set" option-string) 124 | (istep-cmd-set (second args) (third args) stream)) 125 | ((string-equal "raw" option-string) 126 | (istep-cmd-set-raw (second args) stream)) 127 | ((string-equal "q" option-string) 128 | (istep-cmd-reset)) 129 | ((string-equal "?" option-string) 130 | (istep-cmd-help stream)) 131 | ((string-equal "skip" option-string) 132 | (istep-cmd-skip (second args) stream)) 133 | ((string-equal "tree" option-string) 134 | (istep-cmd-tree stream)) 135 | ((string-equal "print" option-string) 136 | (istep-cmd-print (second args) stream)) 137 | ((string-equal "slot" option-string) 138 | (istep-cmd-select-component (read-from-string (second args)) stream)) 139 | ((or (symbolp option) 140 | (integerp option)) 141 | (istep-cmd-select-component option stream)) 142 | (t 143 | (istep-cmd-set-stack option stream)))) 144 | 145 | (defun set-current-inspect (inspect) 146 | (setq *current-inspect* inspect)) 147 | 148 | (defun reset-stack (&optional object label) 149 | (cond 150 | ((null label) 151 | (setf (inspect-object-stack *current-inspect*) nil) 152 | (setf (inspect-select-stack *current-inspect*) nil)) 153 | (t 154 | (setf (inspect-object-stack *current-inspect*) (list object)) 155 | (setf (inspect-select-stack *current-inspect*) (list label))))) 156 | 157 | (defun output-inspect-note (stream note &rest args) 158 | (apply #'format stream note args) 159 | (princ #\Newline stream)) 160 | 161 | (defun stack () 162 | (inspect-object-stack *current-inspect*)) 163 | 164 | (defun redisplay (stream &optional (skip 0)) 165 | (display-current stream *inspect-length* skip)) 166 | 167 | ;;; 168 | ;;; istep command processing 169 | ;;; 170 | 171 | (defun istep-cmd-redisplay (stream) 172 | (redisplay stream)) 173 | 174 | (defun istep-cmd-parent (stream) 175 | (cond 176 | ((> (length (inspect-object-stack *current-inspect*)) 1) 177 | (setf (inspect-object-stack *current-inspect*) 178 | (cdr (inspect-object-stack *current-inspect*))) 179 | (setf (inspect-select-stack *current-inspect*) 180 | (cdr (inspect-select-stack *current-inspect*))) 181 | (redisplay stream)) 182 | ((stack) 183 | (output-inspect-note stream "Object has no parent")) 184 | (t 185 | (no-object-msg stream)))) 186 | 187 | (defun istep-cmd-inspect-* (stream) 188 | (reset-stack * "(inspect *)") 189 | (redisplay stream)) 190 | 191 | (defun istep-cmd-inspect-new-form (form stream) 192 | (inspector-fun (eval form) nil stream)) 193 | 194 | (defun istep-cmd-select-parent-component (option stream) 195 | (if (stack) 196 | (if (eql (length (stack)) 1) 197 | (output-inspect-note stream "Object does not have a parent") 198 | (let ((parent (second (stack))) 199 | (id (car (inspect-select-stack *current-inspect*)))) 200 | (multiple-value-bind (position parts) 201 | (find-part-id parent id) 202 | (let ((new-position (if (string= ">" option) 203 | (1+ position) 204 | (1- position)))) 205 | (if (< -1 new-position (parts-count parts)) 206 | (let* ((value (component-at parts new-position))) 207 | (setf (car (inspect-object-stack *current-inspect*)) 208 | value) 209 | (setf (car (inspect-select-stack *current-inspect*)) 210 | (id-at parts new-position)) 211 | (redisplay stream)) 212 | (output-inspect-note stream 213 | "Parent has no selectable component indexed by ~d" 214 | new-position)))))) 215 | (no-object-msg stream))) 216 | 217 | (defun istep-cmd-set-raw (option-string stream) 218 | (when (inspect-object-stack *current-inspect*) 219 | (cond 220 | ((null option-string) 221 | (setq *inspect-raw* t)) 222 | ((eq (read-from-string option-string) t) 223 | (setq *inspect-raw* t)) 224 | ((eq (read-from-string option-string) nil) 225 | (setq *inspect-raw* nil))) 226 | (redisplay stream))) 227 | 228 | (defun istep-cmd-reset () 229 | (reset-stack) 230 | (throw 'repl-catcher (values :inspect nil))) 231 | 232 | (defun istep-cmd-help (stream) 233 | (format stream *inspect-help*)) 234 | 235 | (defun istep-cmd-skip (option-string stream) 236 | (if option-string 237 | (let ((len (read-from-string option-string))) 238 | (if (and (integerp len) (>= len 0)) 239 | (redisplay stream len) 240 | (output-inspect-note stream "Skip length invalid"))) 241 | (output-inspect-note stream "Skip length missing"))) 242 | 243 | (defun istep-cmd-print (option-string stream) 244 | (if option-string 245 | (let ((len (read-from-string option-string))) 246 | (if (and (integerp len) (plusp len)) 247 | (setq *inspect-length* len) 248 | (output-inspect-note stream "Cannot set print limit to ~A~%" len))) 249 | (output-inspect-note stream "Print length missing"))) 250 | 251 | (defun select-description (select) 252 | (typecase select 253 | (integer 254 | (format nil "which is componenent number ~d of" select)) 255 | (symbol 256 | (format nil "which is the ~a component of" select)) 257 | (string 258 | (format nil "which was selected by ~A" select)) 259 | (t 260 | (write-to-string select)))) 261 | 262 | (defun istep-cmd-tree (stream) 263 | (let ((stack (inspect-object-stack *current-inspect*))) 264 | (if stack 265 | (progn 266 | (output-inspect-note stream "The current object is:") 267 | (dotimes (i (length stack)) 268 | (output-inspect-note 269 | stream "~A, ~A" 270 | (inspected-description (nth i stack)) 271 | (select-description 272 | (nth i (inspect-select-stack *current-inspect*)))))) 273 | (no-object-msg stream)))) 274 | 275 | (defun istep-cmd-set (id-string value-string stream) 276 | (if (stack) 277 | (let ((id (when id-string (read-from-string id-string)))) 278 | (multiple-value-bind (position parts) 279 | (find-part-id (car (stack)) id) 280 | (if parts 281 | (if position 282 | (when value-string 283 | (let ((new-value (eval (read-from-string value-string)))) 284 | (let ((result (set-component-value (car (stack)) 285 | id 286 | new-value 287 | (component-at 288 | parts position)))) 289 | (typecase result 290 | (string 291 | (output-inspect-note stream result)) 292 | (t 293 | (redisplay stream)))))) 294 | (output-inspect-note 295 | stream 296 | "Object has no selectable component named by ~A" id)) 297 | (output-inspect-note stream 298 | "Object has no selectable components")))) 299 | (no-object-msg stream))) 300 | 301 | (defun istep-cmd-select-component (id stream) 302 | (if (stack) 303 | (multiple-value-bind (position parts) 304 | (find-part-id (car (stack)) id) 305 | (cond 306 | ((integerp position) 307 | (let* ((value (component-at parts position))) 308 | (cond ((eq value *inspect-unbound-object-marker*) 309 | (output-inspect-note stream "That slot is unbound")) 310 | (t 311 | (push value (inspect-object-stack *current-inspect*)) 312 | (push id (inspect-select-stack *current-inspect*)) 313 | (redisplay stream))))) 314 | ((null parts) 315 | (output-inspect-note stream "Object does not contain any subobjects")) 316 | (t 317 | (typecase id 318 | (symbol 319 | (output-inspect-note 320 | stream "Object has no selectable component named ~A" 321 | id)) 322 | (integer 323 | (output-inspect-note 324 | stream "Object has no selectable component indexed by ~d" 325 | id)))))) 326 | (no-object-msg stream))) 327 | 328 | (defun istep-cmd-set-stack (form stream) 329 | (reset-stack (eval form) ":i ...") 330 | (redisplay stream)) 331 | 332 | 333 | (defun no-object-msg (s) 334 | (output-inspect-note s "No object is being inspected")) 335 | 336 | (defun display-current (s length skip) 337 | (if (stack) 338 | (let ((inspected (car (stack)))) 339 | (setq cl:* inspected) 340 | (display-inspect inspected s length skip)) 341 | (no-object-msg s))) 342 | 343 | 344 | ;;; 345 | ;;; aclrepl-specific inspection display 346 | ;;; 347 | 348 | (defun display-inspect (object stream &optional length (skip 0)) 349 | (multiple-value-bind (elements labels count) 350 | (inspected-elements object length skip) 351 | (fresh-line stream) 352 | (format stream "~A" (inspected-description object)) 353 | (unless *skip-address-display* 354 | (let ((addr (address-of-object object))) 355 | (when addr 356 | (write-string " at #x" stream) 357 | (format stream (n-word-bits-hex-format) addr)))) 358 | (dotimes (i count) 359 | (fresh-line stream) 360 | (display-labeled-element (elt elements i) (elt labels i) stream)))) 361 | 362 | (defun array-label-p (label) 363 | (and (consp label) 364 | (stringp (cdr label)) 365 | (char= (char (cdr label) 0) #\[))) 366 | 367 | (defun named-or-array-label-p (label) 368 | (and (consp label) (not (hex-label-p label)))) 369 | 370 | (defun hex-label-p (label &optional width) 371 | (and (consp label) 372 | (case width 373 | (32 (eq (cdr label) :hex32)) 374 | (64 (eq (cdr label) :hex64)) 375 | (t (or (eq (cdr label) :hex32) 376 | (eq (cdr label) :hex64)))))) 377 | 378 | (defun display-labeled-element (element label stream) 379 | (cond 380 | ((eq label :ellipses) 381 | (format stream " ...")) 382 | ((eq label :tail) 383 | (format stream "tail-> ~A" (inspected-description element))) 384 | ((named-or-array-label-p label) 385 | (format stream 386 | (if (array-label-p label) 387 | "~4,' D ~A-> ~A" 388 | "~4,' D ~16,1,1,'-A> ~A") 389 | (car label) 390 | (format nil "~A " (cdr label)) 391 | (inspected-description element))) 392 | ((hex-label-p label 32) 393 | (format stream "~4,' D-> #x~8,'0X" (car label) element)) 394 | ((hex-label-p label 64) 395 | (format stream "~4,' D-> #x~16,'0X" (car label) element)) 396 | (t 397 | (format stream "~4,' D-> ~A" label (inspected-description element))))) 398 | 399 | ;;; THE BEGINNINGS OF AN INSPECTOR API 400 | ;;; which can be used to retrieve object descriptions as component values/labels and also 401 | ;;; process print length and skip selectors 402 | ;;; 403 | ;;; FUNCTIONS TO CONSIDER FOR EXPORT 404 | ;;; FIND-PART-ID 405 | ;;; COMPONENT-AT 406 | ;;; ID-AT 407 | ;;; INSPECTED-ELEMENTS 408 | ;;; INSPECTED-DESCRIPTION 409 | ;;; 410 | ;;; will also need hooks 411 | ;;; *inspect-start-inspection* 412 | ;;; (maybe. Would setup a window for a GUI inspector) 413 | ;;; *inspect-prompt-fun* 414 | ;;; *inspect-read-cmd* 415 | ;;; 416 | ;;; and, either an *inspect-process-cmd*, or *inspect-display* hook 417 | ;;; That'll depend if choose to have standardized inspector commands such that 418 | ;;; (funcall *inspect-read-cmd*) will return a standard command that SBCL will 419 | ;;; process and then call the *inspect-display* hook, or if the 420 | ;;; *inspect-read-cmd* will return an impl-dependent cmd that sbcl will 421 | ;;; send to the contributed inspector for processing and display. 422 | 423 | (defun find-part-id (object id) 424 | "COMPONENT-ID can be an integer or a name of a id. 425 | Returns (VALUES POSITION PARTS). 426 | POSITION is NIL if the id is invalid or not found." 427 | (let* ((parts (inspected-parts object)) 428 | (name (if (symbolp id) (symbol-name id) id))) 429 | (values 430 | (cond 431 | ((and (numberp id) 432 | (< -1 id (parts-count parts)) 433 | (not (eq (parts-seq-type parts) :bignum))) 434 | id) 435 | (t 436 | (case (parts-seq-type parts) 437 | (:named 438 | (position name (the list (parts-components parts)) 439 | :key #'car :test #'string-equal)) 440 | ((:dotted-list :cyclic-list) 441 | (when (string-equal name "tail") 442 | (1- (parts-count parts))))))) 443 | parts))) 444 | 445 | (defun component-at (parts position) 446 | (let ((count (parts-count parts)) 447 | (components (parts-components parts))) 448 | (when (< -1 position count) 449 | (case (parts-seq-type parts) 450 | (:dotted-list 451 | (if (= position (1- count)) 452 | (cdr (last components)) 453 | (elt components position))) 454 | (:cyclic-list 455 | (if (= position (1- count)) 456 | components 457 | (elt components position))) 458 | (:named 459 | (cdr (elt components position))) 460 | (:array 461 | (aref (the array components) position)) 462 | (:bignum 463 | (bignum-component-at components position)) 464 | (t 465 | (elt components position)))))) 466 | 467 | (defun id-at (parts position) 468 | (let ((count (parts-count parts))) 469 | (when (< -1 position count) 470 | (case (parts-seq-type parts) 471 | ((:dotted-list :cyclic-list) 472 | (if (= position (1- count)) 473 | :tail 474 | position)) 475 | (:array 476 | (array-index-string position parts)) 477 | (:named 478 | (car (elt (parts-components parts) position))) 479 | (t 480 | position))))) 481 | 482 | (defun inspected-elements (object &optional length (skip 0)) 483 | "Returns elements of an object that have been trimmed and labeled based on 484 | length and skip. Returns (VALUES ELEMENTS LABELS ELEMENT-COUNT) 485 | where ELEMENTS and LABELS are vectors containing ELEMENT-COUNT items. 486 | LABELS elements may be a string, number, cons pair, :tail, or :ellipses. 487 | This function may return an ELEMENT-COUNT of up to (+ 3 length) which would 488 | include an :ellipses at the beginning, :ellipses at the end, 489 | and the last element." 490 | (let* ((parts (inspected-parts object)) 491 | (print-length (if length length (parts-count parts))) 492 | (last-part (last-part parts)) 493 | (last-requested (last-requested parts print-length skip)) 494 | (element-count (compute-elements-count parts print-length skip)) 495 | (first-to (if (first-element-ellipses-p parts skip) 1 0)) 496 | (elements (when (plusp element-count) (make-array element-count))) 497 | (labels (when (plusp element-count) (make-array element-count)))) 498 | (when (plusp element-count) 499 | ;; possible first ellipses 500 | (when (first-element-ellipses-p parts skip) 501 | (set-element-values elements labels 0 nil :ellipses)) 502 | ;; main elements 503 | (do* ((i 0 (1+ i))) 504 | ((> i (- last-requested skip))) 505 | (set-element elements labels parts (+ i first-to) (+ i skip))) 506 | ;; last parts value if needed 507 | (when (< last-requested last-part) 508 | (set-element elements labels parts (- element-count 1) last-part)) 509 | ;; ending ellipses or next to last parts value if needed 510 | (when (< last-requested (1- last-part)) 511 | (if (= last-requested (- last-part 2)) 512 | (set-element elements labels parts (- element-count 2) (1- last-part)) 513 | (set-element-values elements labels (- element-count 2) nil :ellipses)))) 514 | (values elements labels element-count))) 515 | 516 | (defun last-requested (parts print skip) 517 | (min (1- (parts-count parts)) (+ skip print -1))) 518 | 519 | (defun last-part (parts) 520 | (1- (parts-count parts))) 521 | 522 | (defun compute-elements-count (parts length skip) 523 | "Compute the number of elements in parts given the print length and skip." 524 | (let ((element-count (min (parts-count parts) length 525 | (max 0 (- (parts-count parts) skip))))) 526 | (when (and (plusp (parts-count parts)) (plusp skip)) ; starting ellipses 527 | (incf element-count)) 528 | (when (< (last-requested parts length skip) 529 | (last-part parts)) ; last value 530 | (incf element-count) 531 | (when (< (last-requested parts length skip) 532 | (1- (last-part parts))) ; ending ellipses 533 | (incf element-count))) 534 | element-count)) 535 | 536 | (defun set-element (elements labels parts to-index from-index) 537 | (set-element-values elements labels to-index (component-at parts from-index) 538 | (label-at parts from-index))) 539 | 540 | (defun set-element-values (elements labels index element label) 541 | (setf (aref elements index) element) 542 | (setf (aref labels index) label)) 543 | 544 | (defun first-element-ellipses-p (parts skip) 545 | (and (parts-count parts) (plusp skip))) 546 | 547 | (defun label-at (parts position) 548 | "Helper function for inspected-elements. Conses the 549 | position with the label if the label is a string." 550 | (let ((id (id-at parts position))) 551 | (cond 552 | ((stringp id) 553 | (cons position id)) 554 | ((eq (parts-seq-type parts) :bignum) 555 | (cons position (case (n-word-bits) 556 | (32 :hex32) 557 | (64 :hex64)))) 558 | (t 559 | id)))) 560 | 561 | (defun array-index-string (index parts) 562 | "Formats an array index in row major format." 563 | (let ((rev-dimensions (parts-seq-hint parts))) 564 | (if (null rev-dimensions) 565 | "[]" 566 | (let ((list nil)) 567 | (dolist (dim rev-dimensions) 568 | (multiple-value-bind (q r) (floor index dim) 569 | (setq index q) 570 | (push r list))) 571 | (format nil "[~W~{,~W~}]" (car list) (cdr list)))))) 572 | 573 | 574 | ;;; INSPECTED-DESCRIPTION 575 | ;;; 576 | ;;; Accepts an object and returns 577 | ;;; DESCRIPTION is a summary description of the destructured object, 578 | ;;; e.g. "the object is a CONS". 579 | 580 | (defgeneric inspected-description (object)) 581 | 582 | (defmethod inspected-description ((object symbol)) 583 | (format nil "the symbol ~A" object)) 584 | 585 | (defmethod inspected-description ((object structure-object)) 586 | (format nil "~W" (find-class (type-of object)))) 587 | 588 | (defmethod inspected-description ((object package)) 589 | (format nil "the ~A package" (package-name object))) 590 | 591 | (defmethod inspected-description ((object standard-object)) 592 | (format nil "~W" (class-of object))) 593 | 594 | (defmethod inspected-description ((object function)) 595 | (format nil "~S" object) nil) 596 | 597 | (defun displaced-array-p (object) 598 | (or #+ccl (ccl:displaced-array-p object) 599 | #+sbcl (and (sb-kernel:array-header-p object) 600 | (sb-kernel:%array-displaced-p object)) 601 | nil)) 602 | 603 | (defmethod inspected-description ((object vector)) 604 | (declare (vector object)) 605 | (format nil "a ~:[~;displaced ~]vector (~W)" 606 | (displace-array-p object) 607 | (length object))) 608 | 609 | #+nil ;not portably a class 610 | (defmethod inspected-description ((object simple-vector)) 611 | (declare (simple-vector object)) 612 | (format nil "a simple ~A vector (~D)" 613 | (array-element-type object) 614 | (length object))) 615 | 616 | (defmethod inspected-description ((object array)) 617 | (declare (array object)) 618 | (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W" 619 | (displace-array-p object) 620 | (array-element-type object) 621 | (array-dimensions object))) 622 | 623 | (defun simple-cons-pair-p (object) 624 | (atom (cdr object))) 625 | 626 | (defmethod inspected-description ((object cons)) 627 | (if (simple-cons-pair-p object) 628 | "a cons cell" 629 | (inspected-description-of-nontrivial-list object))) 630 | 631 | (defun cons-safe-length (object) 632 | "Returns (VALUES LENGTH LIST-TYPE) where length is the number of 633 | cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" 634 | (do ((length 1 (1+ length)) 635 | (lst (cdr object) (cdr lst))) 636 | ((or (not (consp lst)) 637 | (eq object lst)) 638 | (cond 639 | ((null lst) 640 | (values length :normal)) 641 | ((atom lst) 642 | (values length :dotted)) 643 | ((eq object lst) 644 | (values length :cyclic)))) 645 | ;; nothing to do in body 646 | )) 647 | 648 | (defun inspected-description-of-nontrivial-list (object) 649 | (multiple-value-bind (length list-type) (cons-safe-length object) 650 | (format nil "a ~A list with ~D element~:*~P~A" 651 | (string-downcase (symbol-name list-type)) length 652 | (ecase list-type 653 | ((:dotted :cyclic) "+tail") 654 | (:normal ""))))) 655 | 656 | (defun address-of-object (object) 657 | (unless (or (characterp object) 658 | (typep object 'fixnum)) 659 | #+sbcl (unless (or (eq object *inspect-unbound-object-marker*) 660 | (and (= (n-word-bits) 64) 661 | (typep object 'single-float))) 662 | (logand (sb-kernel:get-lisp-obj-address object) 663 | (lognot sb-vm:lowtag-mask))))) 664 | 665 | (defun n-word-bits-hex-format () 666 | (case (n-word-bits) 667 | (64 "~16,'0X") 668 | (32 "~8,'0X") 669 | (t "~X"))) 670 | 671 | (defmethod inspected-description ((object complex)) 672 | (format nil "complex number ~W" object)) 673 | 674 | (defun n-word-bits () 675 | (or #+sbcl sb-vm::n-word-bits 676 | ;; #+ccl ... 677 | 64)) 678 | 679 | (defmethod inspected-description ((object ratio)) 680 | (format nil "ratio ~W" object)) 681 | 682 | (defmethod inspected-description ((object character)) 683 | (format nil "character ~W char-code #x~4,'0X" object (char-code object))) 684 | 685 | (defmethod inspected-description ((object t)) 686 | (typecase object 687 | (fixnum (format nil "fixnum ~W" object)) 688 | (double-float (format nil "double-float ~W" object)) 689 | (single-float (format nil "single-float ~W" object)) 690 | (simple-string (format nil "a simple-string (~W) ~W" (length object) object)) 691 | (bignum (format nil "bignum ~W; length ~D" object (integer-length object))) 692 | (t (format nil "a generic object ~W" object)))) 693 | 694 | (defmethod inspected-description ((object (eql *inspect-unbound-object-marker*))) 695 | "..unbound..") 696 | 697 | 698 | ;;; INSPECTED-PARTS 699 | ;;; 700 | ;;; Accepts the arguments OBJECT LENGTH SKIP and returns, 701 | ;;; (LIST COMPONENTS SEQ-TYPE COUNT SEQ-HINT) 702 | ;;; where.. 703 | ;;; 704 | ;;; COMPONENTS are the component parts of OBJECT (whose 705 | ;;; representation is determined by SEQ-TYPE). Except for the 706 | ;;; SEQ-TYPE :named and :array, components is just the OBJECT itself 707 | ;;; 708 | ;;; SEQ-TYPE determines what representation is used for components 709 | ;;; of COMPONENTS. 710 | ;;; If SEQ-TYPE is :named, then each element is (CONS NAME VALUE) 711 | ;;; If SEQ-TYPE is :dotted-list, then each element is just value, 712 | ;;; but the last element must be retrieved by 713 | ;;; (cdr (last components)) 714 | ;;; If SEQ-TYPE is :cylic-list, then each element is just value, 715 | ;;; If SEQ-TYPE is :list, then each element is a value of an array 716 | ;;; If SEQ-TYPE is :vector, then each element is a value of an vector 717 | ;;; If SEQ-TYPE is :array, then each element is a value of an array 718 | ;;; with rank >= 2. The 719 | ;;; If SEQ-TYPE is :bignum, then object is just a bignum and not a 720 | ;;; a sequence 721 | ;;; 722 | ;;; COUNT is the total number of components in the OBJECT 723 | ;;; 724 | ;;; SEQ-HINT is a seq-type dependent hint. Used by SEQ-TYPE :array 725 | ;;; to hold the reverse-dimensions of the orignal array. 726 | 727 | (declaim (inline parts-components)) 728 | (defun parts-components (parts) 729 | (first parts)) 730 | 731 | (declaim (inline parts-count)) 732 | (defun parts-count (parts) 733 | (second parts)) 734 | 735 | (declaim (inline parts-seq-type)) 736 | (defun parts-seq-type (parts) 737 | (third parts)) 738 | 739 | (declaim (inline parts-seq-hint)) 740 | (defun parts-seq-hint (parts) 741 | (fourth parts)) 742 | 743 | ;;; FIXME: Most of this should be refactored to share the code 744 | ;;; with the vanilla inspector. Also, we should check what the 745 | ;;; Slime inspector does, and provide a an interface for it to 746 | ;;; use that would propagate any SBCL inspector improvements 747 | ;;; automagically to Slime. -- ns 2005-02-20 748 | (defgeneric inspected-parts (object)) 749 | 750 | (defmethod inspected-parts ((object symbol)) 751 | (let ((components 752 | (list (cons "NAME" (symbol-name object)) 753 | (cons "PACKAGE" (symbol-package object)) 754 | (cons "VALUE" (if (boundp object) 755 | (symbol-value object) 756 | *inspect-unbound-object-marker*)) 757 | (cons "FUNCTION" (if (fboundp object) 758 | (symbol-function object) 759 | *inspect-unbound-object-marker*)) 760 | (cons "PLIST" (symbol-plist object))))) 761 | (list components (length components) :named nil))) 762 | 763 | (defun inspected-structure-parts (object) 764 | (let ((components-list '()) 765 | #+sbcl (info (sb-kernel:wrapper-info (sb-kernel:wrapper-of object)))) 766 | #+sbcl 767 | (when (sb-kernel::defstruct-description-p info) 768 | (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse components-list)) 769 | (push (cons (string (sb-kernel:dsd-name dd-slot)) 770 | (funcall (sb-kernel:dsd-accessor-name dd-slot) object)) 771 | components-list))))) 772 | 773 | (defmethod inspected-parts ((object structure-object)) 774 | (let ((components (inspected-structure-parts object))) 775 | (list components (length components) :named nil))) 776 | 777 | (defun inspected-standard-object-parts (object) 778 | (let ((components nil) 779 | (class-slots (c2mop:class-slots (class-of object)))) 780 | (dolist (class-slot class-slots (nreverse components)) 781 | (let* ((slot-name (c2mop:slot-definition-name class-slot)) 782 | (slot-value (if (slot-boundp object slot-name) 783 | (slot-value object slot-name) 784 | *inspect-unbound-object-marker*))) 785 | (push (cons (symbol-name slot-name) slot-value) components))))) 786 | 787 | 788 | (defmethod inspected-parts ((object standard-object)) 789 | (let ((components (inspected-standard-object-parts object))) 790 | (list components (length components) :named nil))) 791 | 792 | (defmethod inspected-parts ((object condition)) 793 | (let ((components (inspected-standard-object-parts object))) 794 | (list components (length components) :named nil))) 795 | 796 | (defmethod inspected-parts ((object function)) 797 | (let* (#+sbcl (object (if (sb-kernel:closurep object) 798 | (sb-kernel:%closure-fun object) 799 | object)) 800 | (components (list 801 | #+sbcl (cons "arglist" 802 | (sb-kernel:%simple-fun-arglist object))))) 803 | (list components (length components) :named nil))) 804 | 805 | (defmethod inspected-parts ((object vector)) 806 | (list object (length object) :vector nil)) 807 | 808 | (defmethod inspected-parts ((object array)) 809 | (let ((size (array-total-size object))) 810 | (list (make-array size 811 | :element-type (array-element-type object) 812 | :displaced-to object) 813 | size 814 | :array 815 | (reverse (array-dimensions object))))) 816 | 817 | (defmethod inspected-parts ((object cons)) 818 | (if (simple-cons-pair-p object) 819 | (inspected-parts-of-simple-cons object) 820 | (inspected-parts-of-nontrivial-list object))) 821 | 822 | (defun inspected-parts-of-simple-cons (object) 823 | (let ((components (list (cons "car" (car object)) 824 | (cons "cdr" (cdr object))))) 825 | (list components 2 :named nil))) 826 | 827 | (defun inspected-parts-of-nontrivial-list (object) 828 | (multiple-value-bind (count list-type) (cons-safe-length object) 829 | (case list-type 830 | (:normal 831 | (list object count :list nil)) 832 | (:cyclic 833 | (list object (1+ count) :cyclic-list nil)) 834 | (:dotted 835 | ;; count tail element 836 | (list object (1+ count) :dotted-list nil))))) 837 | 838 | (defmethod inspected-parts ((object complex)) 839 | (let ((components (list (cons "real" (realpart object)) 840 | (cons "imag" (imagpart object))))) 841 | (list components (length components) :named nil))) 842 | 843 | (defmethod inspected-parts ((object ratio)) 844 | (let ((components (list (cons "numerator" (numerator object)) 845 | (cons "denominator" (denominator object))))) 846 | (list components (length components) :named nil))) 847 | 848 | (defmethod inspected-parts ((object t)) 849 | (typecase object 850 | #+nil (bignum (list object (bignum-words object) :bignum nil)) 851 | (t (list nil 0 nil nil)))) 852 | 853 | 854 | ;; FIXME - implement setting of component values 855 | 856 | (defgeneric set-component-value (object component-id value element)) 857 | 858 | (defmethod set-component-value ((object cons) id value element) 859 | (format nil "Cons object does not support setting of component ~A" id)) 860 | 861 | (defmethod set-component-value ((object array) id value element) 862 | (format nil "Array object does not support setting of component ~A" id)) 863 | 864 | (defmethod set-component-value ((object symbol) id value element) 865 | (format nil "Symbol object does not support setting of component ~A" id)) 866 | 867 | (defmethod set-component-value ((object structure-object) id value element) 868 | (format nil "Structure object does not support setting of component ~A" id)) 869 | 870 | (defmethod set-component-value ((object standard-object) id value element) 871 | (format nil "Standard object does not support setting of component ~A" id)) 872 | 873 | (defmethod set-component-value ((object t) id value element) 874 | (format nil "Object does not support setting of component ~A" id)) 875 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp; indent-tabs: nil -*- 2 | 3 | ;;; Copyright (c) 2009 David Lichteblau. All rights reserved. 4 | 5 | ;;; Redistribution and use in source and binary forms, with or without 6 | ;;; modification, are permitted provided that the following conditions 7 | ;;; are met: 8 | ;;; 9 | ;;; * Redistributions of source code must retain the above copyright 10 | ;;; notice, this list of conditions and the following disclaimer. 11 | ;;; 12 | ;;; * Redistributions in binary form must reproduce the above 13 | ;;; copyright notice, this list of conditions and the following 14 | ;;; disclaimer in the documentation and/or other materials 15 | ;;; provided with the distribution. 16 | ;;; 17 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 18 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 21 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 23 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 24 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 25 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 26 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 27 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | 29 | (defpackage :prepl 30 | (:use :cl :iterate) 31 | (:export "REPL" 32 | 33 | "DEFINE-REPL-COMMAND" 34 | 35 | "*PROMPT*" 36 | "*EXIT-ON-EOF*" 37 | "*MAX-HISTORY*" 38 | "*USE-SHORT-PACKAGE-NAME*" 39 | "*COMMAND-CHAR*" 40 | 41 | "*COMMAND-PARSER-HOOKS*" 42 | "CALL-NEXT-COMMAND" 43 | 44 | "*CURRENT-ERROR*" 45 | "*DEBUGGING-CONTEXT*" 46 | "DEBUGGER" 47 | "*ENTERING-PREPL-DEBUGGER-HOOK*" 48 | "INSTALL-GLOBAL-PREPL-DEBUGGER-HOOK")) 49 | -------------------------------------------------------------------------------- /prepl.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp; indent-tabs: nil -*- 2 | 3 | (defsystem :prepl 4 | :serial t 5 | :components ((:file "package") 6 | (:file "prepl") 7 | (:file "commands") 8 | (:file "inspect")) 9 | :depends-on (:closer-mop :iterate :bordeaux-threads :conium 10 | :named-readtables)) 11 | -------------------------------------------------------------------------------- /prepl.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp; indent-tabs: nil -*- 2 | 3 | ;;; This file was taken from SBCL's sb-aclrepl contrib, written by Keven 4 | ;;; Rosenberg and available under SBCL's public domain status. 5 | ;;; 6 | ;;; Changes since then are: 7 | 8 | ;;; Copyright (c) 2009 David Lichteblau. All rights reserved. 9 | 10 | ;;; Redistribution and use in source and binary forms, with or without 11 | ;;; modification, are permitted provided that the following conditions 12 | ;;; are met: 13 | ;;; 14 | ;;; * Redistributions of source code must retain the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer. 16 | ;;; 17 | ;;; * Redistributions in binary form must reproduce the above 18 | ;;; copyright notice, this list of conditions and the following 19 | ;;; disclaimer in the documentation and/or other materials 20 | ;;; provided with the distribution. 21 | ;;; 22 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 23 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 24 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 25 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 26 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 27 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 28 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 29 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 30 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 31 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 32 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 | 34 | (in-package :prepl) 35 | 36 | (defvar *noprint* nil 37 | "boolean: T if don't print prompt and output") 38 | (defvar *break-level* -1 39 | "current break level") 40 | (defvar *inspect-break* nil 41 | "boolean: T if break caused by inspect") 42 | (defvar *continuable-break* nil 43 | "boolean: T if break caused by continuable error") 44 | (defvar *command-parser-hooks* nil) 45 | 46 | (defvar *unwind-hooks* 47 | (list #+sbcl #'sb-impl::disable-stepping)) 48 | 49 | (defun run-hooks (hooks &rest args) 50 | (mapc (lambda (hookfun) 51 | (apply hookfun args)) 52 | hooks)) 53 | 54 | (defvar *input*) 55 | (defvar *output*) 56 | 57 | (defvar *outmost-repl* t) 58 | 59 | (defun show-banner () 60 | (format t "~&Portable REPL on ~A, ~A. Type ~Ahelp for help.~%" 61 | (lisp-implementation-type) 62 | (bordeaux-threads:thread-name (bordeaux-threads:current-thread)) 63 | (elt *command-chars* 0))) 64 | 65 | (defun %repl (&key 66 | (break-level (1+ *break-level*)) 67 | (noprint *noprint*) 68 | (inspect nil) 69 | (continuable nil) 70 | (nobanner (or noprint (not *outmost-repl*)))) 71 | (let ((*noprint* noprint) 72 | (*break-level* break-level) 73 | (*inspect-break* inspect) 74 | (*continuable-break* continuable)) 75 | (unless nobanner 76 | (show-banner)) 77 | (iter 78 | (if *outmost-repl* 79 | (with-simple-restart (abort-to-outmost-repl "Abort to outmost REPL") 80 | (with-simple-restart (abort "Abort to REPL") 81 | (let ((*outmost-repl* nil)) 82 | (until (rep-one))))) 83 | (until (rep-one)))) 84 | (unless *outmost-repl* 85 | (throw 'repl-catcher :no-reason)))) 86 | 87 | (defun interactive-eval (form) 88 | "Evaluate FORM, returning whatever it returns and adjusting ***, **, *, 89 | +++, ++, +, ///, //, /, and -." 90 | (setf - form) 91 | (unwind-protect 92 | (let ((results (multiple-value-list (eval form)))) 93 | (setf /// // 94 | // / 95 | / results 96 | *** ** 97 | ** * 98 | * (car results))) 99 | (setf +++ ++ 100 | ++ + 101 | + -)) 102 | (unless (boundp '*) 103 | ;; The bogon returned an unbound marker. 104 | ;; FIXME: It would be safer to check every one of the values in RESULTS, 105 | ;; instead of just the first one. 106 | (setf * nil) 107 | (cerror "Go on with * set to NIL." 108 | "EVAL returned an unbound marker.")) 109 | (values-list /)) 110 | 111 | (defvar *after-prompt-hooks* 112 | (list #+sbcl #'sb-sys:scrub-control-stack)) 113 | 114 | (defun rep-one () 115 | (multiple-value-bind (reason reason-param) 116 | (catch 'repl-catcher 117 | (unwind-protect 118 | (%rep-one) 119 | (run-hooks *unwind-hooks*))) 120 | (declare (ignore reason-param)) 121 | (or (and (eq reason :inspect) 122 | (plusp *break-level*)) 123 | (and (eq reason :pop) 124 | (plusp *break-level*))))) 125 | 126 | (defvar *read-command* 'read-command) 127 | 128 | (defun %rep-one () 129 | "Read-Eval-Print one form" 130 | ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.) 131 | (run-hooks *after-prompt-hooks*) 132 | (unless *noprint* 133 | (prompt *standard-output*) 134 | (force-output *standard-output*)) 135 | (let* ((*input* *standard-input*) 136 | (*output* *standard-output*) 137 | (user-command (funcall *read-command* *input*)) 138 | (level *break-level*)) 139 | (unless (process-command user-command) 140 | (with-simple-restart (abort 141 | "~@" 142 | level) 143 | (let ((results 144 | (multiple-value-list 145 | (interactive-eval 146 | (user-command-input user-command))))) 147 | (unless *noprint* 148 | (dolist (result results) 149 | (prin1 result *standard-output*) 150 | (fresh-line *standard-output*)))))))) 151 | -------------------------------------------------------------------------------- /tests.lisp: -------------------------------------------------------------------------------- 1 | ;;; This file was taken from SBCL's sb-aclrepl contrib, written by Keven 2 | ;;; Rosenberg and available under SBCL's public domain status. 3 | 4 | ;; Tests for prepl 5 | 6 | (defpackage #:aclrepl-tests 7 | (:use #:prepl #:cl #:sb-rt)) 8 | (in-package #:aclrepl-tests) 9 | 10 | (declaim (special prepl::*skip-address-display* 11 | prepl::*inspect-unbound-object-marker*)) 12 | 13 | (setf sb-rt::*catch-errors* nil) 14 | 15 | (rem-all-tests) 16 | 17 | (deftest hook.1 (boundp 'sb-impl::*inspect-fun*) t) 18 | (deftest hook.2 (boundp 'sb-int:*repl-prompt-fun*) t) 19 | (deftest hook.3 (boundp 'sb-int:*repl-read-form-fun*) t) 20 | ;(deftest (boundp 'sb-debug::*invoke-debugger-fun*) t) 21 | 22 | ;;; Inspector tests 23 | 24 | (defclass empty-class () 25 | ()) 26 | (defparameter *empty-class* (make-instance 'empty-class)) 27 | 28 | (defclass empty-class () 29 | ()) 30 | 31 | (defclass simple-class () 32 | ((a) 33 | (second :initform 0) 34 | (really-long-slot-name :initform "abc"))) 35 | 36 | (defstruct empty-struct 37 | ) 38 | 39 | (defstruct tiny-struct 40 | (first 10)) 41 | 42 | (defstruct simple-struct 43 | (first) 44 | (slot-2 'a-value) 45 | (really-long-struct-slot-name "defg")) 46 | 47 | (defparameter *empty-class* (make-instance 'empty-class)) 48 | (defparameter *simple-class* (make-instance 'simple-class)) 49 | (defparameter *empty-struct* (make-empty-struct)) 50 | (defparameter *tiny-struct* (make-tiny-struct)) 51 | (defparameter *simple-struct* (make-simple-struct)) 52 | (defparameter *normal-list* '(a b 3)) 53 | (defparameter *dotted-list* '(a b . 3)) 54 | (defparameter *cons-pair* '(#c(1 2) . a-symbol)) 55 | (defparameter *complex* #c(1 2)) 56 | (defparameter *ratio* 22/7) 57 | (defparameter *double* 5.5d0) 58 | (defparameter *bignum* 1234567890123456789) 59 | (defparameter *array* (make-array '(3 3 2) :initial-element nil)) 60 | (defparameter *vector* (make-array '(20):initial-contents 61 | '(0 1 2 3 4 5 6 7 8 9 62 | 10 11 12 13 14 15 16 17 18 19))) 63 | (eval-when (:compile-toplevel :load-toplevel :execute) 64 | (defparameter *circle-list1* '(a)) 65 | (setf (car *circle-list1*) *circle-list1*) 66 | (defparameter *circle-list2* '(b)) 67 | (setf (cdr *circle-list2*) *circle-list2*) 68 | (defparameter *circle-list3* '(a b c)) 69 | (setf (car *circle-list3*) *circle-list3*) 70 | (defparameter *circle-list4* '(a b c)) 71 | (setf (second *circle-list4*) *circle-list4*) 72 | (defparameter *circle-list5* '(a b c)) 73 | (setf (cddr *circle-list5*) *circle-list5*)) 74 | 75 | (defun find-position (object id) 76 | (nth-value 0 (prepl::find-part-id object id))) 77 | (defun parts (object) 78 | (let ((prepl::*skip-address-display* t)) 79 | (prepl::inspected-parts object))) 80 | (defun description (object) 81 | (let ((prepl::*skip-address-display* t)) 82 | (prepl::inspected-description object))) 83 | (defun elements (object &optional print (skip 0)) 84 | (let ((prepl::*skip-address-display* t)) 85 | (prepl::inspected-elements object print skip))) 86 | (defun elements-components (object &optional print (skip 0)) 87 | (nth-value 0 (elements object print skip ))) 88 | (defun elements-labels (object &optional print (skip 0)) 89 | (nth-value 1 (elements object print skip))) 90 | (defun elements-count (object &optional print (skip 0)) 91 | (nth-value 2 (elements object print skip))) 92 | 93 | (defun labeled-element (object pos &optional print (skip 0)) 94 | (with-output-to-string (strm) 95 | (let ((prepl::*skip-address-display* t)) 96 | (prepl::display-labeled-element 97 | (aref (the simple-vector (elements-components object print skip)) pos) 98 | (aref (the simple-vector (elements-labels object print skip)) pos) 99 | strm)))) 100 | 101 | (defun display (object &optional print (skip 0)) 102 | (with-output-to-string (strm) 103 | (let ((prepl::*skip-address-display* t)) 104 | (prepl::display-inspect object strm print skip)))) 105 | 106 | (defun do-inspect (object) 107 | (with-output-to-string (strm) 108 | (let ((prepl::*skip-address-display* t)) 109 | (prepl::inspector `(quote ,object) nil strm)))) 110 | 111 | (defun istep (args) 112 | (with-output-to-string (strm) 113 | (let ((prepl::*skip-address-display* t)) 114 | (prepl::istep args strm)))) 115 | 116 | (deftest find.list.0 (find-position *normal-list* 0) 0) 117 | (deftest find.list.1 (find-position *normal-list* 0) 0) 118 | (deftest find.list.2 (find-position *normal-list* 1) 1) 119 | (deftest find.list.3 (find-position *normal-list* 2) 2) 120 | (deftest parts.list.1 (prepl::parts-count (parts *normal-list*)) 3) 121 | (deftest parts.list.2 (prepl::component-at (parts *normal-list*) 0) a) 122 | (deftest parts.list.3 (prepl::component-at (parts *normal-list*) 1) b) 123 | (deftest parts.list.4 (prepl::component-at (parts *normal-list*) 2) 3) 124 | (deftest parts.list.5 (prepl::label-at (parts *normal-list*) 0) 0) 125 | (deftest parts.list.6 (prepl::label-at (parts *normal-list*) 1) 1) 126 | (deftest parts.list.7 (prepl::label-at (parts *normal-list*) 2) 2) 127 | (deftest parts.list.8 (prepl::parts-seq-type (parts *normal-list*)) :list) 128 | 129 | (eval-when (:compile-toplevel :load-toplevel :execute) 130 | (defun basename (id &optional print (skip 0)) 131 | (let ((name (typecase id 132 | (symbol (symbol-name id)) 133 | (string (string-upcase id)) 134 | (t (format nil "~A" id))))) 135 | (format nil "~A~A~A" 136 | (string-left-trim "*" (string-right-trim "*" name)) 137 | (if print (format nil ".P~D" print) "") 138 | (if (not (zerop skip)) (format nil ".S~D" skip) "")))) 139 | 140 | (defun elements-tests-name (id ext print skip) 141 | (intern (format nil "ELEM.~A.~A" (basename id print skip) ext)))) 142 | 143 | (defmacro def-elements-tests (object count components labels 144 | &optional (print nil) (skip 0)) 145 | `(progn 146 | (deftest ,(elements-tests-name object "COUNT" print skip) 147 | (elements-count ,object ,print ,skip) ,count) 148 | (unless (eq ,components :dont-check) 149 | (deftest ,(elements-tests-name object "COMPONENTS" print skip) 150 | (elements-components ,object ,print ,skip) ,components)) 151 | (deftest ,(elements-tests-name object "LABELS" print skip) 152 | (elements-labels ,object ,print ,skip) ,labels))) 153 | 154 | (def-elements-tests *normal-list* 3 #(a b 3) #(0 1 2)) 155 | (def-elements-tests *dotted-list* 3 #(a b 3) #(0 1 :tail)) 156 | 157 | (def-elements-tests *circle-list1* 2 :dont-check #((0 . "car") (1 . "cdr"))) 158 | (def-elements-tests *circle-list2* 2 :dont-check #(0 :tail)) 159 | (def-elements-tests *circle-list3* 3 :dont-check #(0 1 2)) 160 | (def-elements-tests *circle-list4* 3 :dont-check #(0 1 2)) 161 | (def-elements-tests *circle-list5* 3 :dont-check #(0 1 :tail)) 162 | 163 | (deftest circle-list1-components 164 | (aref (elements-components *circle-list1*) 0) #.*circle-list1*) 165 | (deftest circle-list2-components.0 166 | (aref (elements-components *circle-list2*) 0) b) 167 | (deftest circle-list2-components.1 168 | (aref (elements-components *circle-list2*) 1) #.*circle-list2*) 169 | (deftest circle-list3-components.0 170 | (aref (elements-components *circle-list3*) 0) #.*circle-list3*) 171 | (deftest circle-list3-components.1 172 | (aref (elements-components *circle-list3*) 1) b) 173 | (deftest circle-list3-components.2 174 | (aref (elements-components *circle-list3*) 2) c) 175 | (deftest circle-list4-components.0 176 | (aref (elements-components *circle-list4*) 0) a) 177 | (deftest circle-list4-components.1 178 | (aref (elements-components *circle-list4*) 1) #.*circle-list4*) 179 | (deftest circle-list4-components.2 180 | (aref (elements-components *circle-list4*) 2) c) 181 | (deftest circle-list5-components.0 182 | (aref (elements-components *circle-list5*) 0) a) 183 | (deftest circle-list5-components.1 184 | (aref (elements-components *circle-list5*) 1) b) 185 | (deftest circle-list5-components.2 186 | (aref (elements-components *circle-list5*) 2) #.*circle-list5*) 187 | 188 | (def-elements-tests *cons-pair* 2 #(#c(1 2) a-symbol) 189 | #((0 . "car") (1 . "cdr"))) 190 | (def-elements-tests *complex* 2 #(1 2) #((0 . "real") (1 . "imag"))) 191 | (def-elements-tests *ratio* 2 #(22 7) 192 | #((0 . "numerator") (1 . "denominator"))) 193 | (case sb-vm::n-word-bits 194 | (32 195 | (def-elements-tests *bignum* 2 196 | #(2112454933 287445236) 197 | #((0 . :HEX32) (1 . :HEX32)))) 198 | (64 199 | (def-elements-tests *bignum* 1 200 | #(1234567890123456789) 201 | #((0 . :HEX64))))) 202 | 203 | (def-elements-tests *vector* 20 204 | #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) 205 | #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)) 206 | (def-elements-tests *vector* 18 207 | #(nil 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) 208 | #(:ellipses 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) 209 | nil 3) 210 | (def-elements-tests *vector* 13 211 | #(nil 3 4 5 6 7 8 9 10 11 12 nil 19) 212 | #(:ellipses 3 4 5 6 7 8 9 10 11 12 :ellipses 19) 213 | 10 3) 214 | (def-elements-tests *vector* 5 215 | #(nil 16 17 18 19) 216 | #(:ellipses 16 17 18 19) 217 | 5 16) 218 | (def-elements-tests *vector* 5 219 | #(nil 16 17 18 19) 220 | #(:ellipses 16 17 18 19) 221 | 2 16) 222 | (def-elements-tests *vector* 5 223 | #(nil 15 16 nil 19) 224 | #(:ellipses 15 16 :ellipses 19) 225 | 2 15) 226 | (def-elements-tests *array* 18 227 | #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL 228 | NIL NIL) 229 | #((0 . "[0,0,0]") (1 . "[0,0,1]") (2 . "[0,1,0]") (3 . "[0,1,1]") 230 | (4 . "[0,2,0]") (5 . "[0,2,1]") (6 . "[1,0,0]") (7 . "[1,0,1]") 231 | (8 . "[1,1,0]") (9 . "[1,1,1]") (10 . "[1,2,0]") 232 | (11 . "[1,2,1]") (12 . "[2,0,0]") (13 . "[2,0,1]") 233 | (14 . "[2,1,0]") (15 . "[2,1,1]") (16 . "[2,2,0]") 234 | (17 . "[2,2,1]"))) 235 | 236 | (def-elements-tests *empty-class* 0 nil nil) 237 | #+ignore ;; FIXME 238 | (def-elements-tests *simple-class* 3 239 | #(#.prepl::*inspect-unbound-object-marker* 0 "abc") 240 | #((0 . "A") (1 . "SECOND") (2 . "REALLY-LONG-SLOT-NAME"))) 241 | (def-elements-tests *empty-struct* 0 nil nil) 242 | (def-elements-tests *simple-struct* 3 243 | #(nil a-value "defg") 244 | #((0 . "FIRST") (1 . "SLOT-2") 245 | (2 . "REALLY-LONG-STRUCT-SLOT-NAME"))) 246 | 247 | (eval-when (:compile-toplevel :load-toplevel :execute) 248 | (defun label-test-name (name pos &optional print (skip 0)) 249 | (intern (format nil "LABEL.~A.~D" (basename name print skip) pos)))) 250 | 251 | (defmacro def-label-test (object pos label &optional print (skip 0)) 252 | `(deftest ,(label-test-name object pos print skip) 253 | (labeled-element ,object ,pos ,print ,skip) ,label)) 254 | 255 | (def-label-test *simple-struct* 0 256 | " 0 FIRST ----------> the symbol NIL") 257 | (def-label-test *simple-struct* 1 258 | " 1 SLOT-2 ---------> the symbol A-VALUE") 259 | (def-label-test *simple-struct* 2 260 | " 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") 261 | (def-label-test *simple-class* 0 262 | " 0 A --------------> ..unbound..") 263 | (def-label-test *simple-class* 1 264 | " 1 SECOND ---------> fixnum 0") 265 | (def-label-test *simple-class* 2 266 | " 2 REALLY-LONG-SLOT-NAME -> a simple-string (3) \"abc\"") 267 | 268 | (def-label-test *complex* 0 " 0 real -----------> fixnum 1") 269 | (def-label-test *complex* 1 " 1 imag -----------> fixnum 2") 270 | 271 | (def-label-test *ratio* 0 " 0 numerator ------> fixnum 22") 272 | (def-label-test *ratio* 1 " 1 denominator ----> fixnum 7") 273 | 274 | (def-label-test *dotted-list* 0 " 0-> the symbol A") 275 | (def-label-test *dotted-list* 1 " 1-> the symbol B") 276 | (def-label-test *dotted-list* 2 "tail-> fixnum 3") 277 | 278 | (def-label-test *normal-list* 0 " 0-> the symbol A") 279 | (def-label-test *normal-list* 1 " 1-> the symbol B") 280 | (def-label-test *normal-list* 2 " 2-> fixnum 3") 281 | 282 | (def-label-test *vector* 0 " 0-> fixnum 0") 283 | (def-label-test *vector* 1 " 1-> fixnum 1") 284 | (def-label-test *vector* 0 " ..." nil 2) 285 | (def-label-test *vector* 1" 2-> fixnum 2" nil 2) 286 | 287 | (def-label-test *cons-pair* 0 288 | " 0 car ------------> complex number #C(1 2)") 289 | (def-label-test *cons-pair* 1 290 | " 1 cdr ------------> the symbol A-SYMBOL") 291 | 292 | (deftest nil.parts.0 (elements-count nil) 5) 293 | 294 | (def-elements-tests *tiny-struct* 1 #(10) #((0 . "FIRST"))) 295 | (def-elements-tests *tiny-struct* 1 296 | #(nil) #(:ellipses) nil 1) 297 | (def-elements-tests *tiny-struct* 1 298 | #(nil) #(:ellipses) nil 2) 299 | 300 | (def-elements-tests *double* 0 nil nil) 301 | (def-elements-tests *double* 0 nil nil nil 1) 302 | 303 | (eval-when (:compile-toplevel :load-toplevel :execute) 304 | (defun display-test-name (name print skip) 305 | (intern (format nil "DISPLAY.~A" (basename name print skip))))) 306 | 307 | (defmacro def-display-test (object string &optional print (skip 0)) 308 | `(deftest ,(display-test-name object print skip) 309 | (display ,object ,print ,skip) ,string)) 310 | 311 | (def-display-test *cons-pair* 312 | "a cons cell 313 | 0 car ------------> complex number #C(1 2) 314 | 1 cdr ------------> the symbol A-SYMBOL") 315 | 316 | (def-display-test *simple-struct* 317 | "# 318 | 0 FIRST ----------> the symbol NIL 319 | 1 SLOT-2 ---------> the symbol A-VALUE 320 | 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") 321 | 322 | (def-display-test *simple-struct* 323 | "# 324 | ... 325 | 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"" 326 | nil 2) 327 | 328 | (case sb-vm::n-word-bits 329 | (32 330 | (def-display-test *bignum* 331 | "bignum 1234567890123456789 with 2 32-bit words 332 | 0-> #x7DE98115 333 | 1-> #x112210F4")) 334 | (64 335 | (def-display-test *bignum* 336 | "bignum 1234567890123456789 with 1 64-bit word 337 | 0-> #x112210F47DE98115" 338 | ))) 339 | 340 | (def-display-test *vector* 341 | "a simple T vector (20) 342 | ... 343 | 6-> fixnum 6 344 | 7-> fixnum 7 345 | 8-> fixnum 8 346 | 9-> fixnum 9 347 | 10-> fixnum 10 348 | ... 349 | 19-> fixnum 19" 350 | 5 6) 351 | 352 | (def-display-test *circle-list1* 353 | "a cons cell 354 | 0 car ------------> a cons cell 355 | 1 cdr ------------> the symbol NIL") 356 | (def-display-test *circle-list2* 357 | "a cyclic list with 1 element+tail 358 | 0-> the symbol B 359 | tail-> a cyclic list with 1 element+tail") 360 | (def-display-test *circle-list3* 361 | "a normal list with 3 elements 362 | 0-> a normal list with 3 elements 363 | 1-> the symbol B 364 | 2-> the symbol C") 365 | (def-display-test *circle-list4* 366 | "a normal list with 3 elements 367 | 0-> the symbol A 368 | 1-> a normal list with 3 elements 369 | 2-> the symbol C") 370 | (def-display-test *circle-list5* 371 | "a cyclic list with 2 elements+tail 372 | 0-> the symbol A 373 | 1-> the symbol B 374 | tail-> a cyclic list with 2 elements+tail") 375 | 376 | 377 | ;;; Inspector traversal tests 378 | (deftest inspect.0 (progn (setq * *simple-struct*) 379 | (istep '("*"))) 380 | "# 381 | 0 FIRST ----------> the symbol NIL 382 | 1 SLOT-2 ---------> the symbol A-VALUE 383 | 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") 384 | 385 | (deftest istep.0 (progn (setq * *simple-struct*) 386 | (istep '("*")) 387 | (istep '("="))) 388 | "# 389 | 0 FIRST ----------> the symbol NIL 390 | 1 SLOT-2 ---------> the symbol A-VALUE 391 | 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") 392 | 393 | 394 | (deftest istep.1 (progn (setq * *simple-struct*) 395 | (istep '("*")) 396 | (istep '("first"))) 397 | "the symbol NIL 398 | 0 NAME -----------> a simple-string (3) \"NIL\" 399 | 1 PACKAGE --------> the COMMON-LISP package 400 | 2 VALUE ----------> the symbol NIL 401 | 3 FUNCTION -------> ..unbound.. 402 | 4 PLIST ----------> the symbol NIL") 403 | 404 | 405 | (deftest istep.2 (progn (setq * *simple-struct*) 406 | (istep '("*")) 407 | (istep '("first")) 408 | (istep '(">"))) 409 | "the symbol A-VALUE 410 | 0 NAME -----------> a simple-string (7) \"A-VALUE\" 411 | 1 PACKAGE --------> the ACLREPL-TESTS package 412 | 2 VALUE ----------> ..unbound.. 413 | 3 FUNCTION -------> ..unbound.. 414 | 4 PLIST ----------> the symbol NIL") 415 | 416 | (deftest istep.3 (progn (setq * *simple-struct*) 417 | (istep '("*")) 418 | (istep '("first")) 419 | (istep '(">")) 420 | (istep '("<"))) 421 | "the symbol NIL 422 | 0 NAME -----------> a simple-string (3) \"NIL\" 423 | 1 PACKAGE --------> the COMMON-LISP package 424 | 2 VALUE ----------> the symbol NIL 425 | 3 FUNCTION -------> ..unbound.. 426 | 4 PLIST ----------> the symbol NIL") 427 | 428 | (deftest istep.4 (progn (setq * *simple-struct*) 429 | (istep '("*")) 430 | (istep '("first")) 431 | (istep '(">")) 432 | (istep '("<")) 433 | (istep '("tree"))) 434 | "The current object is: 435 | the symbol NIL, which was selected by FIRST 436 | #, which was selected by (inspect *) 437 | ") 438 | 439 | (deftest istep.5 (progn (setq * *simple-struct*) 440 | (istep '("*")) 441 | (istep '("first")) 442 | (istep '(">")) 443 | (istep '("<")) 444 | (istep '("-"))) 445 | "# 446 | 0 FIRST ----------> the symbol NIL 447 | 1 SLOT-2 ---------> the symbol A-VALUE 448 | 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") 449 | 450 | (deftest istep.6 (progn (setq * *dotted-list*) 451 | (istep '("*")) 452 | (istep '("tail"))) 453 | "fixnum 3") 454 | 455 | (deftest istep.7 (progn (setq * *dotted-list*) 456 | (istep '("*")) 457 | (istep '("2"))) 458 | "fixnum 3") 459 | 460 | (deftest istep.8 (progn (setq * 5.5d0) 461 | (istep '("*"))) 462 | "double-float 5.5d0") 463 | 464 | (deftest istep.9 (progn (setq * 5.5d0) 465 | (istep '("-"))) 466 | "Object has no parent 467 | ") 468 | 469 | 470 | 471 | --------------------------------------------------------------------------------