Ignore:
Timestamp:
10/05/03 01:22:11 (19 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/top-level.lisp

    r4190 r4198  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: top-level.lisp,v 1.3 2003-10-04 10:53:26 piso Exp $
     4;;; $Id: top-level.lisp,v 1.4 2003-10-05 01:22:11 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    1919
    2020;;; Adapted from SB-ACLREPL (originally written by Kevin Rosenberg).
     21
     22;;; A few things we're gonna be needing...
     23(mapc #'sys::resolve '(sort position break write))
    2124
    2225(in-package "EXTENSIONS")
     
    4548  (when (> *break-level* 0)
    4649    (format stream "[~D] " *break-level*))
    47   (write-string (prompt-package-name) stream)
    48   (write-string "(" stream)
    49   (princ *cmd-number* stream)
    50   (write-string "): " stream))
     50  (format stream "~A(~D): " (prompt-package-name) *cmd-number*))
    5151
    5252(defparameter *repl-prompt-fun* #'repl-prompt-fun)
    53 
    54 (defvar *last-files-loaded* nil)
    5553
    5654(defun peek-char-non-whitespace (stream)
     
    6664        (read-line stream)
    6765        (read stream nil))))
     66
     67(defun apropos-command (args)
     68  (when args (apropos args)))
     69
     70(defun backtrace-command (args)
     71  (let ((count (or (and args (ignore-errors (parse-integer args)))
     72                   most-positive-fixnum))
     73        (n 0))
     74    (dolist (frame *saved-backtrace*)
     75      (format t "  ~D: ~A~%" n frame)
     76      (incf n)
     77      (when (>= n count)
     78        (return))))
     79  (values))
     80
     81(defun continue-command (ignored)
     82  (if (> *break-level* 0)
     83      (throw 'continue-catcher nil)))
     84
     85(defun describe-command (args)
     86  (let ((obj (eval (read-from-string args))))
     87    (describe obj)))
     88
     89(defun package-command (args)
     90  (cond ((null args)
     91         (format *standard-output* "The ~A package is current.~%"
     92                 (package-name *package*)))
     93        (t
     94         (when (and (plusp (length args)) (eql (char args 0) #\:))
     95           (setf args (subseq args 1)))
     96         (setf args (nstring-upcase args))
     97         (let ((pkg (find-package args)))
     98           (if pkg
     99               (setf *package* pkg)
     100               (format *standard-output* "Unknown package ~A.~%" args))))))
     101
     102(defun reset-command (ignored)
     103  (throw 'top-level-catcher nil))
     104
     105(defun exit-command (ignored)
     106  (exit))
     107
     108(defun cd-command (args)
     109  (cond ((or (null args) (string= args "~"))
     110         (setf args (namestring (user-homedir-pathname))))
     111        ((and (> (length args) 1) (string= (subseq args 0 2) "~/")
     112              (setf args (concatenate 'string
     113                                      (namestring (user-homedir-pathname))
     114                                      (subseq args 2))))))
     115  (let ((dir (probe-directory args)))
     116    (if dir
     117        (progn
     118          (setf *default-pathname-defaults* dir)
     119          (format t "~A" (namestring *default-pathname-defaults*)))
     120        (format t "Error: no such directory (~S).~%" args))))
     121
     122(defvar *last-files-loaded* nil)
    68123
    69124(defun tokenize (string)
     
    77132    (push (subseq string 0 end) res)))
    78133
    79 (defun backtrace-command (&optional count)
    80   (let ((count (if (fixnump count) count 7))
    81         (n 0))
    82     (dolist (frame *saved-backtrace*)
    83       (format t "  ~D: ~A~%" n frame)
    84       (incf n)
    85       (when (>= n count)
    86         (return))))
    87   (values))
    88 
    89 (defun continue-command ()
    90   (if (> *break-level* 0)
    91       (throw 'continue-catcher nil)))
    92 
    93 (defun reset-command ()
    94   (throw 'top-level-catcher nil))
     134(defun ld-command (args)
     135  (let ((files (if args (tokenize args) *last-files-loaded*)))
     136    (setf *last-files-loaded* files)
     137    (dolist (file files)
     138      (load file))))
     139
     140(defun pwd-command (ignored)
     141  (format t "~A~%" *default-pathname-defaults*))
     142
     143(defconstant spaces (make-string 32 :initial-element #\space))
     144
     145(defun pad (string width)
     146  (if (< (length string) width)
     147      (concatenate 'string string (subseq spaces 0 (- width (length string))))
     148      string))
     149
     150(defun help-command (ignored)
     151  (format t "COMMAND     ABBR DESCRIPTION~%")
     152  (dolist (entry *command-table*)
     153    (format t "~A~A~A~%"
     154            (pad (entry-name entry) 12)
     155            (pad (entry-abbr entry) 5)
     156            (entry-help entry)
     157            )))
     158
     159(defparameter *command-table*
     160  '(("apropos" 2 apropos-command "show apropos")
     161    ("bt" 2 backtrace-command "backtrace n stack frames (default all)")
     162    ("cd" 2 cd-command "change default directory")
     163    ("continue" 4 continue-command "return from break")
     164    ("describe" 2 describe-command "describe an object")
     165    ("exit" 2 exit-command "exit lisp")
     166    ("help" 2 help-command "print this help")
     167    ("ld" 2 ld-command "load a file")
     168    ("package" 2 package-command "change current package")
     169    ("pwd" 3 pwd-command "print current directory")
     170    ("reset" 3 reset-command "return to top level")
     171    ))
     172
     173(defun entry-name (entry)
     174  (first entry))
     175
     176(defun entry-min-len (entry)
     177  (second entry))
     178
     179(defun entry-abbr (entry)
     180  (if (< (entry-min-len entry) (length (entry-name entry)))
     181      (subseq (entry-name entry) 0 (entry-min-len entry))
     182      ""))
     183
     184(defun entry-command (entry)
     185  (third entry))
     186
     187(defun entry-help (entry)
     188  (fourth entry))
     189
     190(defun find-command (string)
     191  (let ((len (length string)))
     192    (dolist (entry *command-table*)
     193      (let ((min-len (entry-min-len entry)))
     194        (when (and (>= len min-len)
     195                   (string-equal (entry-name entry) string :end1 len))
     196          (return (entry-command entry)))))))
    95197
    96198(defun process-cmd (form)
     
    103205        (when (zerop (length args))
    104206          (setf args nil)))
    105       (cond ((string-equal cmd "ld")
    106              (let ((files (if args (tokenize args) *last-files-loaded*)))
    107                (setf *last-files-loaded* files)
    108                (dolist (file files)
    109                  (load file)))
    110              )
    111             ((string-equal cmd "de")
    112              (let ((obj (eval (read-from-string args))))
    113                (describe obj)))
    114             ((string-equal cmd "ap")
    115              (apropos args))
    116             ((string-equal cmd "pwd")
    117              (format t "~A~%" *default-pathname-defaults*))
    118             ((string-equal cmd "cd")
    119              (cond ((or (null args) (string= args "~"))
    120                     (setf args (namestring (user-homedir-pathname))))
    121                    ((and (> (length args) 1) (string= (subseq args 0 2) "~/")
    122                     (setf args (concatenate 'string
    123                                             (namestring (user-homedir-pathname))
    124                                             (subseq args 2))))))
    125              (let ((dir (probe-directory args)))
    126                (if dir
    127                    (progn
    128                      (setf *default-pathname-defaults* dir)
    129                      (format *standard-output* "~A" (namestring *default-pathname-defaults*)))
    130                    (format *standard-output* "Error: no such directory (~S).~%" args))))
    131             ((string-equal cmd "bt")
    132              (let ((count (or (and args (ignore-errors (parse-integer args))) most-positive-fixnum)))
    133                (backtrace-command count)))
    134             ((string-equal cmd "pa")
    135              (cond ((null args)
    136                     (format *standard-output* "The ~A package is current.~%"
    137                             (package-name *package*)))
    138                    (t
    139                     (when (and (plusp (length args)) (eql (char args 0) #\:))
    140                       (setf args (subseq args 1)))
    141                     (setf args (nstring-upcase args))
    142                     (let ((pkg (find-package args)))
    143                       (if pkg
    144                           (setf *package* pkg)
    145                           (format *standard-output* "Unknown package ~A.~%" args))))))
    146             ((or (string-equal cmd "cont") (string-equal cmd "continue"))
    147              (continue-command))
    148             ((or (string-equal cmd "res") (string-equal cmd "reset"))
    149              (reset-command))
    150             ((string-equal cmd "ex")
    151              (format t "Bye!~%")
    152              (exit))
    153             (t
    154              (format *standard-output* "Unknown top-level command ~S.~%" cmd)
    155              )))
    156     (return-from process-cmd t))
     207      (let ((fun (find-command cmd)))
     208        (if fun
     209            (funcall fun args)
     210            (format t "Unknown top-level command ~S.~%" cmd)))
     211      (return-from process-cmd t)))
    157212  nil)
    158213
     
    197252
    198253(defun top-level-loop ()
     254  (fresh-line)
     255  (format t "Type :HELP for a list of top-level commands.~%")
    199256  (loop
    200257    (catch 'top-level-catcher
Note: See TracChangeset for help on using the changeset viewer.