source: branches/streams/abcl/src/org/armedbear/lisp/top-level.lisp

;;; top-level.lisp
;;;
;;; Copyright (C) 2003-2006 Peter Graves
;;; $Id: top-level.lisp 14105 2012-08-17 08:50:58Z ehuelsmann $
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

;;; Adapted from SB-ACLREPL (originally written by Kevin Rosenberg).

(in-package #:top-level)

(require 'inspect)

(defvar *null-cmd* (gensym))
(defvar *handled-cmd* (gensym))

(defvar *command-char* #\:)

(defvar *cmd-number* 1
  "Number of the next command")

(defun prompt-package-name ()
  (let ((result (package-name *package*)))
    (dolist (nickname (package-nicknames *package*))
      (when (< (length nickname) (length result))
        (setf result nickname)))
    result))

(defun repl-prompt-fun (stream)
  (fresh-line stream)
  (when (> *debug-level* 0)
    (sys::%format stream "[~D~A] "
             *debug-level*
             (if sys::*inspect-break* "i" "")))
  (sys::%format stream "~A(~D): " (prompt-package-name) *cmd-number*))

(defparameter *repl-prompt-fun* #'repl-prompt-fun)

(defun peek-char-non-whitespace (stream)
  (loop
    (let ((c (read-char stream nil)))
      (when (null c) ; control d
        (quit))
      (unless (eql c #\space)
        (unread-char c stream)
        (return c)))))

(defun apropos-command (args)
  (when args (apropos args)))

(defun continue-command (args)
  (when args
    (let ((n (read-from-string args)))
      (let ((restarts (compute-restarts)))
        (when (< -1 n (length restarts))
          (invoke-restart-interactively (nth n restarts)))))))

(defun describe-command (args)
  (let ((obj (eval (read-from-string args))))
    (describe obj)))

(defun error-command (ignored)
  (declare (ignore ignored))
  (when *debug-condition*
    (let* ((s (sys::%format nil "~A" *debug-condition*))
           (len (length s)))
      (when (plusp len)
        (setf (schar s 0) (char-upcase (schar s 0)))
        (unless (eql (schar s (1- len)) #\.)
          (setf s (concatenate 'string s "."))))
      (sys::%format *debug-io* "~A~%" s))
    (show-restarts (compute-restarts) *debug-io*)))

(defun print-frame (frame stream &key prefix)
  (when prefix
    (write-string prefix stream))
  (etypecase frame
    (sys::lisp-stack-frame
     (let ((frame (sys:frame-to-list frame)))
       (pprint-logical-block (stream nil :prefix "(" :suffix ")")
         (ignore-errors
           (prin1 (car frame) stream)
           (let ((args (cdr frame)))
             (if (listp args)
                 (format stream "~{ ~_~S~}" args)
                 (format stream " ~S" args)))))))
    (sys::java-stack-frame
     (write-string (sys:frame-to-string frame) stream))))


(defun backtrace-command (args)
  (let ((count (or (and args (ignore-errors (parse-integer args)))
                   8))
        (n 0))
    (with-standard-io-syntax
      (let ((*print-pretty* t)
            (*print-readably* nil)
            (*print-structure* nil)
            (*print-array* nil))
        (dolist (frame *saved-backtrace*)
          (fresh-line *debug-io*)
          (print-frame frame *debug-io* :prefix (format nil "~3D: " n))
          (incf n)
          (when (>= n count)
            (fresh-line *debug-io*)
            (return))))))
  (fresh-line *debug-io*)
  (values))

(defun frame-command (args)
  (let* ((n (or (and args (ignore-errors (parse-integer args)))
                0))
         (frame (nth n *saved-backtrace*)))
    (when frame
      (with-standard-io-syntax
        (let ((*print-pretty* t)
              (*print-readably* nil)
              (*print-structure* nil))
          (fresh-line *debug-io*)
    (print-frame frame *debug-io*)))
      (setf *** **
            ** *
            * frame)))
  (values))

(defun inspect-command (args)
  (let ((obj (eval (read-from-string args))))
    (inspect obj)))

(defun istep-command (args)
  (sys::istep args))

(defun macroexpand-command (args)
  (let ((s (with-output-to-string (stream)
             (pprint (macroexpand (read-from-string args)) stream))))
    (write-string (string-left-trim '(#\return #\linefeed) s)))
  (values))

(defvar *old-package* nil)

(defun package-command (args)
  (cond ((null args)
         (sys::%format *standard-output* "The ~A package is current.~%"
                  (package-name *package*)))
        ((and *old-package* (string= args "-") (null (find-package "-")))
         (rotatef *old-package* *package*))
        (t
         (when (and (plusp (length args)) (eql (char args 0) #\:))
           (setf args (subseq args 1)))
         (setf args (nstring-upcase args))
         (let ((pkg (find-package args)))
           (if pkg
               (setf *old-package* *package*
                     *package* pkg)
               (sys::%format *standard-output* "Unknown package ~A.~%" args))))))

(defun reset-command (ignored)
  (declare (ignore ignored))
  (invoke-restart 'top-level))

(defun exit-command (ignored)
  (declare (ignore ignored))
  (exit))

(defvar *old-pwd* nil)

(defun cd-command (args)
  (cond ((null args)
         (setf args (if (featurep :windows)
                        "C:\\"
                        (namestring (user-homedir-pathname)))))
        ((string= args "-")
         (if *old-pwd*
             (setf args (namestring *old-pwd*))
             (progn
               (sys::%format t "No previous directory.")
               (return-from cd-command))))
        ((and (> (length args) 1) (string= (subseq args 0 2) "~/")
              (setf args (concatenate 'string
                                      (namestring (user-homedir-pathname))
                                      (subseq args 2))))))
  (let ((dir (probe-directory args)))
    (if dir
        (progn
          (unless (equal dir *default-pathname-defaults*)
            (setf *old-pwd* *default-pathname-defaults*
                  *default-pathname-defaults* dir))
          (sys::%format t "~A" (namestring *default-pathname-defaults*)))
        (sys::%format t "Error: no such directory (~S).~%" args))))

(defun ls-command (args)
  (let ((args (if (stringp args) args ""))
        (ls-program (if (featurep :windows) "dir" "ls")))
    (run-shell-command (concatenate 'string ls-program " " args)
                       :directory *default-pathname-defaults*))
  (values))

(defun tokenize (string)
  (do* ((res nil)
        (string (string-left-trim " " string)
                (string-left-trim " " (subseq string end)))
        (end (position #\space string) (position #\space string)))
       ((zerop (length string)) (nreverse res))
    (unless end
      (setf end (length string)))
    (push (subseq string 0 end) res)))

(defvar *last-files-loaded* nil)

(defun ld-command (args)
  (let ((files (if args (tokenize args) *last-files-loaded*)))
    (setf *last-files-loaded* files)
    (dolist (file files)
      (load file))))

(defun cf-command (args)
  (let ((files (tokenize args)))
    (dolist (file files)
      (compile-file file))))

(defvar *last-files-cloaded* nil)

(defun cload-command (args)
  (let ((files (if args (tokenize args) *last-files-cloaded*)))
    (setf *last-files-cloaded* files)
    (dolist (file files)
      (load (compile-file file)))))

(defun rq-command (args)
  (let ((modules (tokenize (string-upcase args))))
    (dolist (module modules)
      (require module))))

(defun pwd-command (ignored)
  (declare (ignore ignored))
  (sys::%format t "~A~%" (namestring *default-pathname-defaults*)))

(defun trace-command (args)
  (if (null args)
    (sys::%format t "~A~%" (sys::list-traced-functions))
    (dolist (f (tokenize args))
      (sys::trace-1 (read-from-string f)))))

(defun untrace-command (args)
  (if (null args)
    (sys::untrace-all)
    (dolist (f (tokenize args))
      (sys::untrace-1 (read-from-string f)))))

(defconstant spaces (make-string 32 :initial-element #\space))

(defun pad (string width)
  (if (< (length string) width)
      (concatenate 'string string (subseq spaces 0 (- width (length string))))
      string))

(defparameter *command-table*
  '(("apropos" "ap" apropos-command "apropos")
    ("bt" nil backtrace-command "backtrace n stack frames (default 8)")
    ("cd" nil cd-command "change default directory")
    ("cf" nil cf-command "compile file(s)")
    ("cload" "cl" cload-command "compile and load file(s)")
    ("continue" "cont" continue-command "invoke restart n")
    ("describe" "de" describe-command "describe an object")
    ("error" "err" error-command "print the current error message")
    ("exit" "ex" exit-command "exit lisp")
    ("frame" "fr" frame-command "set the value of cl:* to be frame n (default 0)")
    ("help" "he" help-command "print this help")
    ("inspect" "in" inspect-command "inspect an object")
    ("istep" "i" istep-command "navigate within inspection of an object")
    ("ld" nil ld-command "load a file")
    ("ls" nil ls-command "list directory")
    ("macroexpand" "ma" macroexpand-command "macroexpand an expression")
    ("package" "pa" package-command "change *PACKAGE*")
    ("pwd" "pw" pwd-command "print current directory")
    ("reset" "res" reset-command "return to top level")
    ("rq" nil rq-command "require a module")
    ("trace" "tr" trace-command "trace function(s)")
    ("untrace" "untr" untrace-command "untrace function(s)")))

(defun %help-command (prefix)
  (let ((prefix-len (length prefix)))
    (when (and (> prefix-len 0)
               (eql (schar prefix 0) *command-char*))
      (setf prefix (subseq prefix 1))
      (decf prefix-len))
    (sys::%format t "~%  COMMAND     ABBR DESCRIPTION~%")
    (dolist (entry *command-table*)
      (when (or (null prefix)
                (and (<= prefix-len (length (entry-name entry)))
                     (string-equal prefix (subseq (entry-name entry) 0 prefix-len))))
        (sys::%format t "  ~A~A~A~%"
                 (pad (entry-name entry) 12)
                 (pad (entry-abbreviation entry) 5)
                 (entry-help entry))))
    (sys::%format t "~%Commands must be prefixed by the command character, which is '~A'~A.~%~%"
             *command-char* (if (eql *command-char* #\:) " by default" ""))))

(defun help-command (&optional ignored)
  (declare (ignore ignored))
  (%help-command nil))

(defun entry-name (entry)
  (first entry))

(defun entry-abbreviation (entry)
  (second entry))

(defun entry-command (entry)
  (third entry))

(defun entry-help (entry)
  (fourth entry))

(defun find-command (string)
  (let ((len (length string)))
    (when (and (> len 0)
               (eql (schar string 0) *command-char*))
      (setf string (subseq string 1)
            len (1- len)))
    (dolist (entry *command-table*)
      (when (or (string-equal string (entry-abbreviation entry))
                (string-equal string (entry-name entry)))
        (return (entry-command entry))))))

(defun process-cmd (form)
  (when (eq form *null-cmd*)
    (return-from process-cmd t))
  (when (and (stringp form)
             (> (length form) 1)
             (eql (char form 0) *command-char*))
    (let* ((pos (or (position #\space form)
                    (position #\return form)))
           (command-string (subseq form 0 pos))
           (args (if pos (subseq form (1+ pos)) nil)))
      (let ((command (find-command command-string)))
        (cond ((null command)
               (sys::%format t "Unknown top-level command \"~A\".~%" command-string)
               (sys::%format t "Type \"~Ahelp\" for a list of available commands." *command-char*))
              (t
               (when args
                 (setf args (string-trim (list #\space #\return) args))
                 (when (zerop (length args))
                   (setf args nil)))
               (funcall command args)))))
      t))

(defun read-cmd (stream)
  (let ((c (peek-char-non-whitespace stream)))
    (cond ((eql c *command-char*)
           (let* ((input (read-line stream))
      (name (symbol-name (read-from-string input))))
       (if (find-command name)
     (progn (process-cmd input) *handled-cmd*)
         (read-from-string (concatenate 'string ":" name)))))
          ((eql c #\newline)
           (read-line stream)
           *null-cmd*)
          (t
           (read stream nil *null-cmd*)))))

(defun repl-read-form-fun (in out)
  (loop
    (funcall *repl-prompt-fun* out)
    (finish-output out)
    (let ((form (read-cmd in)))
      (setf (charpos out) 0)
      (unless (eq form *null-cmd*)
        (incf *cmd-number*))
      (cond ((or (eq form *null-cmd*)
     (eq form *handled-cmd*)))
            ((and (> *debug-level* 0)
                  (fixnump form))
             (let ((n form)
                   (restarts (compute-restarts)))
               (if (< -1 n (length restarts))
                   (invoke-restart-interactively (nth n restarts))
                   (return form))))
            (t
             (return form))))))

(defparameter *repl-read-form-fun* #'repl-read-form-fun)

(defun repl (&optional (in *standard-input*) (out *standard-output*))
    (loop
       (let* ((form (funcall *repl-read-form-fun* in out))
              (results (multiple-value-list (sys:interactive-eval form))))
         (dolist (result results)
           (fresh-line out)
           (prin1 result out)))))

(defun top-level-loop ()
  (fresh-line)
  (unless sys:*noinform*
    (sys::%format t "Type \"~Ahelp\" for a list of available commands.~%" *command-char*))
  (loop
    (setf *inspected-object* nil
          *inspected-object-stack* nil
          *inspect-break* nil)
    (with-simple-restart (top-level
                          "Return to top level.")
      (if (featurep :j)
          (handler-case
              (repl)
            (stream-error (c) (declare (ignore c)) (return-from top-level-loop)))
          (repl)))))