lstoplevel.lsp

   1 #+:CLtL2
   2 (in-package lisp-stat)
   3 #-:CLtL2
   4 (in-package 'lisp-stat)
   5
   6 ;;;;
   7 ;;;; AKCL Top Level (Modified from AKCL source file unixport/kcltop.lsp)
   8 ;;;;
   9
  10 #+:kcl
  11 (import '(si::*quit-tag* si::*eof* si::*lisp-initialized*
  12                          si::reset-stack-limits si::break-current))
  13
  14 (defvar +)
  15 (defvar ++)
  16 (defvar +++)
  17 (defvar -)
  18 (defvar *)
  19 (defvar **)
  20 (defvar ***)
  21 (defvar /)
  22 (defvar //)
  23 (defvar ///)
  24
  25 #+:kcl
  26 (defun ls-top-level ()
  27   (when (> (system:argc) 1)
  28         (setq system:*system-directory* (system:argv 1)))
  29   (let ((lslib (si:getenv "LSLIB")))
  30     (if lslib (setf *default-path* lslib)))
  31   (format t
  32           "AKCL (Austin Kyoto Common Lisp)~%~
  33            Contains Enhancements by W. Schelter~%~
  34            Lisp-Stat ~a, Copyright (c) by Luke Tierney, 1990~%~
  35            Type :q to continue after an error~2%"
  36           *common-lisp-stat-version*)
  37   (setq si::*ihs-top* 1)
  38
  39   (in-package 'system::user)
  40   (incf system::*ihs-top* 2)
  41   (let ((+ nil) (++ nil) (+++ nil)
  42         (- nil)
  43         (* nil) (** nil) (*** nil)
  44         (/ nil) (// nil) (/// nil))
  45     (setq *lisp-initialized* t)
  46     (catch *quit-tag* (when (probe-file "init.lsp") (load "init.lsp")))
  47     (catch *quit-tag* (when (probe-file "statinit.lsp") (load "statinit.lsp")))
  48     (loop
  49      (setq +++ ++ ++ + + -)
  50      (format t "~%~a>"
  51              (if (eq *package* (find-package 'user))
  52                  ""
  53                  (package-name *package*)))
  54      (reset-stack-limits)
  55      (when (catch *quit-tag*
  56              (setq - (locally (declare (notinline read))
  57                               (read *standard-input* nil *eof*)))
  58              (when (eq - *eof*) (bye))
  59              (let ((values (multiple-value-list
  60                             (locally (declare (notinline eval)) (eval -)))))
  61                (setq /// // // / / values *** ** ** * * (car /))
  62                (fresh-line)
  63                (dolist (val /)
  64                        (locally (declare (notinline prin1)) (prin1 val))
  65                        (terpri))
  66                nil))
  67            (terpri *error-output*)
  68            (break-current)))))
  69
  70 ;;;;
  71 ;;;; Macintosh CL Top Level
  72 ;;;; This does not quite properly work with the event loop of
  73 ;;;; the system.
  74 ;;;;
  75
  76 #|
  77 #+:mcl
  78 (defun ls-init-top-level ()
  79   (in-package cl-user)
  80   (setf + nil ++ nil +++ nil
  81         - nil
  82         * nil ** nil *** nil
  83         / nil // nil /// nil)
  84   (format t
  85           "Lisp-Stat ~a, Copyright (c) by Luke Tierney, 1990~%~
  86            Type COMMAND-. to continue after an error~2%"
  87           *common-lisp-stat-version*))
  88
  89 #+:mcl
  90 (defun ls-top-level ()
  91   (catch :stat-abort
  92     (catch :abort
  93       (loop
  94         (setq +++ ++ ++ + + -)
  95         (format t "~%~a> "
  96                 (if (eq *package* (find-package 'cl-user))
  97                   ""
  98                   (package-name *package*)))
  99         (loop (if (listen *standard-input*) (return t))
 100               (event-dispatch))
 101         (setq - (locally (declare (notinline read))
 102                          (read *standard-input* t)))
 103         (if (consp -) (read-line *standard-input* t))
 104         (let ((*idle* nil)
 105               (values (multiple-value-list
 106                        (locally (declare (notinline eval)) (eval -)))))
 107           (setq /// // // / / values *** ** ** * * (car /))
 108           (fresh-line)
 109           (dolist (val /)
 110             (locally (declare (notinline prin1)) (prin1 val))
 111             (terpri))
 112           nil)))))
 113 |#
 114
 115 ;;;;
 116 ;;;; EXCL (Allegro) Top Level
 117 ;;;;
 118
 119 #+:excl
 120 (defun ls-top-level-eval (expr)
 121   (setq +++ ++ ++ + + - - expr)
 122   (let ((values (multiple-value-list
 123                  (locally (declare (notinline eval)) (eval -)))))
 124     (setq /// // // / / values *** ** ** * * (car /))
 125     (car values)))
 126
 127 #+:excl
 128 (defun ls-top-level ()
 129   (format t
 130           "Lisp-Stat ~a, Copyright (c) by Luke Tierney, 1990~%~
 131            Type :reset to continue after an error~2%"
 132           *common-lisp-stat-version*)
 133
 134   (in-package 'user)
 135   (let ((tpl:*eval* 'ls-top-level-eval)
 136         (tpl:*prompt* "<cls> ")
 137         (*read-default-float-format* *stat-float-type*)
 138         (+ nil) (++ nil) (+++ nil)
 139         (- nil)
 140         (* nil) (** nil) (*** nil)
 141         (/ nil) (// nil) (/// nil))
 142     (catch '*ls-quit-tag* (tpl:top-level-read-eval-print-loop))))
 143
 144 #+:excl
 145 (defun exit-ls () (throw '*ls-quit-tag* nil))