lstoplevel.lsp

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