more tests to track down multiple regression failures
[CommonLispStat.git] / lstoplevel.lsp
blob7d2c783ea94c549a2d884271b16b792b710cbebe
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.
6 (in-package :lispstat)
8 ;;;;
9 ;;;; AKCL Top Level (Modified from AKCL source file unixport/kcltop.lsp)
10 ;;;;
12 #+:kcl
13 (import '(si::*quit-tag* si::*eof* si::*lisp-initialized*
14 si::reset-stack-limits si::break-current))
16 (defvar +)
17 (defvar ++)
18 (defvar +++)
19 (defvar -)
20 (defvar *)
21 (defvar **)
22 (defvar ***)
23 (defvar /)
24 (defvar //)
25 (defvar ///)
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)
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)))))
72 ;;;;
73 ;;;; Macintosh CL Top Level
74 ;;;; This does not quite properly work with the event loop of
75 ;;;; the system.
76 ;;;;
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*))
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)))))
117 ;;;;
118 ;;;; EXCL (Allegro) Top Level
119 ;;;;
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)))
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*)
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))))
146 #+:excl
147 (defun exit-ls () (throw '*ls-quit-tag* nil))