← Back to branch summary

~ubuntu-branches/debian/squeeze/maxima/squeeze

« back to all changes in this revision

Viewing changes to src/macsys.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-10-18 14:52:42 UTC
  • mto: (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20061018145242-vzyrm5hmxr8kiosf
Import upstream version 5.10.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/macsys.lisp
12
12
;;;
13
13
;;; *** NOTE *** this file uses common-lisp read syntax.
14
14
 
15
 
(in-package "MAXIMA")
 
15
(in-package :maxima)
16
16
(macsyma-module system)
17
17
 
18
 
 
19
 
(eval-when (eval compile load) (sstatus feature maxii))
 
18
;;(eval-when (:execute :compile-toplevel :load-toplevel)
 
19
;;  (sstatus feature maxii))
20
20
 
21
21
;;; Standard Kinds of Input Prompts
22
22
 
24
24
(defvar *prompt-suffix* "")
25
25
(defvar *general-display-prefix* "")
26
26
 
27
 
(DEFUN MAIN-PROMPT ()
 
27
(defun main-prompt ()
28
28
  ;; instead off using this STRIPDOLLAR hackery, the
29
29
  ;; MREAD function should call MFORMAT to print the prompt,
30
30
  ;; and take a format string and format arguments.
31
31
  ;; Even easier and more general is for MREAD to take
32
32
  ;; a FUNARG as the prompt. -gjc
33
 
  (FORMAT () "~A(~A~D) ~A" *prompt-prefix* 
34
 
(STRIPDOLLAR $INCHAR) $LINENUM *prompt-suffix*))
 
33
  (format () "~A(~A~D) ~A" *prompt-prefix* 
 
34
          (print-invert-case (stripdollar $inchar)) $linenum *prompt-suffix*))
35
35
 
36
 
(DEFUN BREAK-PROMPT ()
 
36
(defun break-prompt ()
37
37
  (declare (special $prompt))
38
 
  (STRIPDOLLAR $PROMPT))
 
38
  (stripdollar $prompt))
39
39
 
40
 
 
41
40
 
42
41
;; there is absoletely no need to catch errors here, because
43
42
;; they are caught by the macsyma-listener window process on
44
43
;; the lisp machine, or by setting the single toplevel process in Maclisp. -gjc
45
44
 
46
 
(defmacro toplevel-macsyma-eval (x) `(meval* ,x))
 
45
;; Replacing the defmacro definition with a defun version, in order to
 
46
;; allow more flexibility with evaluation order via redefinition
 
47
;;(defmacro toplevel-macsyma-eval (x) `(meval* ,x))
 
48
 
 
49
(defun toplevel-macsyma-eval (x) (meval* x))
47
50
 
48
51
(defmvar $_ '$_ "last thing read in, cooresponds to lisp +")
49
 
;Also defined in JPG;SUPRV
50
 
#-CL (defmvar $% '$% "last thing printed out, cooresponds to lisp *")
 
52
;;Also defined in JPG;SUPRV
 
53
#-cl (defmvar $% '$% "last thing printed out, cooresponds to lisp *")
51
54
(defmvar $__ '$__ "thing read in which will be evaluated, cooresponds to -")
52
55
 
53
56
(declare-top (special *mread-prompt*  $file_search_demo))
55
58
(defvar accumulated-time 0.0)
56
59
#-cl
57
60
(defun fixnum-char-upcase (x) (char-upcase x))
58
 
;#-ti
59
 
;(defun get-internal-real-time () (time:microsecond-time))
60
 
;#-ti
61
 
;(defun get-internal-run-time ()  (* 1000 (send current-process :cpu-time)) )
62
 
;(defvar internal-time-units-per-second  1000000)
63
 
 
64
 
#+lispm
65
 
(defun used-area ( &optional (area working-storage-area ))
66
 
  (multiple-value-bind (nil used)(si:room-get-area-length-used area)
67
 
    used))
68
 
 
69
 
#+cmu
 
61
;;#-ti
 
62
;;(defun get-internal-real-time () (time:microsecond-time))
 
63
;;#-ti
 
64
;;(defun get-internal-run-time ()  (* 1000 (send current-process :cpu-time)) )
 
65
;;(defvar internal-time-units-per-second  1000000)
 
66
 
 
67
;;#+lispm
 
68
;;(defun used-area ( &optional (area working-storage-area ))
 
69
;;  (multiple-value-bind (nil used)(si:room-get-area-length-used area)
 
70
;;    used))
 
71
 
 
72
#+(or cmu scl)
70
73
(defun used-area (&optional unused)
71
74
  (declare (ignore unused))
72
75
  (ext:get-bytes-consed))
89
92
    (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
90
93
    (dpb space1 (byte 24 24) space2)))
91
94
 
92
 
#-(or lispm cmu sbcl clisp)
 
95
#-(or lispm cmu scl sbcl clisp)
93
96
(defun used-area (&optional unused)
94
97
  (declare (ignore unused))
95
98
  0)
96
99
 
97
 
(DEFUN CONTINUE (&OPTIONAL (input-stream *standard-input*)
98
 
                           BATCH-OR-DEMO-FLAG)
99
 
 (if (eql BATCH-OR-DEMO-FLAG :demo)
100
 
     (format t "~% At the _ prompt, type ';' followed by enter to get next demo"))
101
 
 (catch 'abort-demo
102
 
  (DO ((R)
103
 
       (time-before)
104
 
       (time-after)
105
 
       (time-used)
106
 
       (EOF (LIST NIL))
107
 
       (etime-before)
108
 
       (etime-after)
109
 
       (area-before)
110
 
       (area-after)
111
 
       (etime-used)
112
 
       (c-tag)
113
 
       (d-tag))
114
 
      (NIL)
115
 
(catch 'return-from-debugger
116
 
    (when (not (checklabel $inchar))
 
100
(defun continue (&optional (input-stream *standard-input*)
 
101
                 batch-or-demo-flag)
 
102
  (declare (special *socket-connection*))
 
103
  (if (eql batch-or-demo-flag :demo)
 
104
      (format t "~% At the _ prompt, type ';' followed by enter to get next demo~&"))
 
105
  (catch 'abort-demo
 
106
    (do ((r)
 
107
         (time-before)
 
108
         (time-after)
 
109
         (time-used)
 
110
         (eof (list nil))
 
111
         (etime-before)
 
112
         (etime-after)
 
113
         (area-before)
 
114
         (area-after)
 
115
         (etime-used)
 
116
         (c-tag)
 
117
         (d-tag))
 
118
        (nil)
 
119
      (catch 'return-from-debugger
 
120
        (when (or (not (checklabel $inchar))
 
121
              (not (checklabel $outchar)))
117
122
          (setq $linenum (f1+ $linenum)))
118
 
    #+akcl(si::reset-stack-limits)
119
 
    (setq c-tag (makelabel $inchar))
120
 
    (LET ((*MREAD-PROMPT* (if batch-or-demo-flag nil (MAIN-PROMPT)))
121
 
          (eof-count 0))
122
 
    (tagbody
123
 
     top
124
 
     (SETQ R      (dbm-read input-stream nil eof))
125
 
     ; This is something of a hack. If we are running in a server mode
126
 
     ; (which we determine by checking *socket-connection*) and we get
127
 
     ; an eof on an input-stream that is not *standard-input*, switch
128
 
     ; the input stream to *standard-input*.
129
 
     ; There should probably be a better scheme for server mode.
130
 
     ; jfa 10/09/2002.
131
 
     (if (and
132
 
          (eq r eof)
133
 
           (not (eq input-stream *standard-input*))
134
 
           (boundp '*socket-connection*))
135
 
         (progn
136
 
               (setq input-stream *standard-input*)
137
 
               (setq *mread-prompt* nil)
138
 
               (setq r (dbm-read input-stream nil eof))))
 
123
        #+akcl(si::reset-stack-limits)
 
124
        (setq c-tag (makelabel $inchar))
 
125
        (let ((*mread-prompt* (if batch-or-demo-flag nil (main-prompt)))
 
126
              (eof-count 0))
 
127
          (tagbody
 
128
           top
 
129
             (setq r (dbm-read input-stream nil eof))
 
130
             ;; This is something of a hack. If we are running in a server mode
 
131
             ;; (which we determine by checking *socket-connection*) and we get
 
132
             ;; an eof on an input-stream that is not *standard-input*, switch
 
133
             ;; the input stream to *standard-input*.
 
134
             ;; There should probably be a better scheme for server mode.
 
135
             ;; jfa 10/09/2002.
 
136
             (if (and
 
137
                  (eq r eof)
 
138
                  (not (eq input-stream *standard-input*))
 
139
                  (boundp '*socket-connection*))
 
140
                 (progn
 
141
                   (setq input-stream *standard-input*)
 
142
                   (setq *mread-prompt* nil)
 
143
                   (setq r (dbm-read input-stream nil eof))))
139
144
 
140
 
     (cond ((and (eq r eof) (boundp '*socket-connection*)
141
 
                 (eq input-stream *socket-connection*))
142
 
            (cond ((>=  (setq eof-count (+ 1 eof-count)) 10)
143
 
                   (print "exiting on eof")
144
 
                   ($quit))
145
 
                  (t (go top)))))
146
 
                 
147
 
     (cond ((and (consp r) (keywordp (car r)))
148
 
            (break-call (car r) (cdr r) 'break-command)
149
 
              (go top)))
150
 
              
151
 
     )
152
 
    )
153
 
    
154
 
    (format t "~a" *general-display-prefix*)
155
 
    (cond (#.writefilep ;write out the c line to the dribble file
156
 
            (let ( (#.ttyoff t) smart-tty  $linedisp)
157
 
              (displa `((mlable) , c-tag , $__)))))
158
 
    (IF (EQ R EOF) (RETURN '$DONE))
159
 
    (fresh-line *standard-output*)
160
 
    #+lispm (SEND *standard-output* :SEND-IF-HANDLES ':FORCE-OUTPUT)
161
 
    (SETQ $__ (CADDR R))
162
 
    (SET  C-TAG $__)
163
 
    (cond (batch-or-demo-flag
164
 
           (displa `((mlable) ,c-tag , $__))))
165
 
    (setq time-before (get-internal-run-time)
166
 
          etime-before (get-internal-real-time))
167
 
    (setq area-before (used-area))
168
 
    (SETQ $% (TOPLEVEL-MACSYMA-EVAL $__))
169
 
    (setq etime-after (get-internal-real-time)
170
 
          time-after (get-internal-run-time))
171
 
    (setq area-after (used-area))
172
 
    (setq time-used (quotient (float (difference time-after time-before))
173
 
                              internal-time-units-per-second)
174
 
          etime-used (quotient (float (difference etime-after etime-before))
175
 
                               internal-time-units-per-second))
176
 
    (setq accumulated-time (plus accumulated-time time-used))
177
 
    (SET (setq D-TAG (makelabel $outchar)) $%)
178
 
    (SETQ $_ $__)
179
 
    (when $showtime
180
 
          #+NIL (format t "~&Evaluation took ~$ seconds (~$ elapsed)."
181
 
                    time-used etime-used)
182
 
          #-(or NIL cl) (mtell "Evaluation took ~S seconds (~S elapsed)."
183
 
                           time-used etime-used)
184
 
          (format t "~&Evaluation took ~$ seconds (~$ elapsed)"
185
 
                    time-used etime-used )
186
 
          #+lispm (format t "using ~A words." (f-  area-after area-before))
187
 
          #+(or cmu sbcl clisp)
 
145
             (cond ((and (eq r eof) (boundp '*socket-connection*)
 
146
                         (eq input-stream *socket-connection*))
 
147
                    (cond ((>=  (setq eof-count (+ 1 eof-count)) 10)
 
148
                           (print "exiting on eof")
 
149
                           ($quit))
 
150
                          (t (go top)))))
 
151
             (cond ((and (consp r) (keywordp (car r)))
 
152
                    (break-call (car r) (cdr r) 'break-command)
 
153
                    (go top)))))
 
154
        (format t "~a" *general-display-prefix*)
 
155
        (cond (#.writefilep  ;write out the c line to the dribble file
 
156
               (let ( (#.ttyoff t) smart-tty  $linedisp)
 
157
                 (displa `((mlable) , c-tag , $__)))))
 
158
        (if (eq r eof) (return '$done))
 
159
        (setq $__ (caddr r))
 
160
        (unless $nolabels (set  c-tag $__))
 
161
        (cond (batch-or-demo-flag
 
162
               (displa `((mlable) ,c-tag , $__))))
 
163
        (setq time-before (get-internal-run-time)
 
164
              etime-before (get-internal-real-time))
 
165
        (setq area-before (used-area))
 
166
        (setq $% (toplevel-macsyma-eval $__))
 
167
        (setq etime-after (get-internal-real-time)
 
168
              time-after (get-internal-run-time))
 
169
        (setq area-after (used-area))
 
170
        (setq time-used (quotient 
 
171
                         (float (difference time-after time-before))
 
172
                         internal-time-units-per-second)
 
173
              etime-used (quotient 
 
174
                          (float (difference etime-after etime-before))
 
175
                          internal-time-units-per-second))
 
176
        (setq accumulated-time (plus accumulated-time time-used))
 
177
        (setq d-tag (makelabel $outchar))
 
178
        (unless $nolabels (set d-tag $%))
 
179
        (setq $_ $__)
 
180
        (when $showtime
 
181
          (format t "Evaluation took ~$ seconds (~$ elapsed)"
 
182
                  time-used etime-used )  
 
183
          #+gcl 
 
184
          (format t "~%")
 
185
          #+(or cmu scl sbcl clisp)
188
186
          (let ((total-bytes (- area-after area-before)))
189
 
            (cond ((> total-bytes 1024)
190
 
                   (format t " using ~,3F KB." (/ total-bytes 1024.0))
191
 
                   )
192
 
                  ((> total-bytes (* 1024 1024))
193
 
                   (format t " using ~,3F MB." (/ total-bytes (* 1024.0 1024.0)))
194
 
                   )
 
187
            (cond ((> total-bytes (* 1024 1024))
 
188
                   (format t " using ~,3F MB.~%"
 
189
                           (/ total-bytes (* 1024.0 1024.0))))
 
190
                  ((> total-bytes 1024)
 
191
                   (format t " using ~,3F KB.~%" (/ total-bytes 1024.0)))
195
192
                  (t
196
 
                   (format t " using ~:D bytes." total-bytes))))
197
 
 
198
 
      )
199
 
    (UNLESS $NOLABELS
200
 
                     (PUTPROP d-tag
201
 
                              (cons time-used  0)
202
 
                              'TIME))
203
 
    (fresh-line *standard-output*)
204
 
    #+never(let ((tem (read-char-no-hang)))
205
 
      (or (eql tem #\newline) (and tem (unread-char tem))))
206
 
    (IF (EQ (CAAR R) 'DISPLAYINPUT)
207
 
        (DISPLA `((MLABLE) ,D-TAG ,$%)))
208
 
    (when (eq batch-or-demo-flag ':demo)
209
 
      (mtell "~&~A_~A" *prompt-prefix* *prompt-suffix*)
210
 
      (let (quitting)     
211
 
       (do ((char)) (nil)
212
 
             ;;those are common lisp characters you'r reading here
213
 
            (case
214
 
             (setq char (read-char *terminal-io*))
215
 
             ((#\page) (unless (cursorpos 'c input-stream) (terpri *standard-output*))
216
 
              (princ "_" *standard-output*))
217
 
             ((#\?) (mtell "  Pausing.  Type a ';' and Enter to continue demo.~%_"))
218
 
             ((#\space #\; #\n #\e #\x #\t))
219
 
             ((#\newline )
220
 
              (if quitting (throw 'abort-demo nil) (return nil))) 
221
 
             (t (setq quitting t)
222
 
                )))))
223
 
    ;; This is sort of a kludge -- eat newlines and blanks so that they don't echo
224
 
    (AND BATCH-OR-DEMO-FLAG
225
 
         #+lispm
226
 
         (send input-stream :operation-handled-p :read-char-no-echo)
227
 
         #+lispm
228
 
         (send input-stream :operation-handled-p :unread-char-no-echo)
229
 
         (do ((char)) (())
230
 
           (setq char (read-char input-stream nil #+cl nil)) 
231
 
 
232
 
;;;; INSERTED BY MASAMI 
233
 
           (when (null char) 
234
 
             (throw 'MACSYMA-QUIT NIL)) 
235
 
;;;; END INSERT 
236
 
 
237
 
           (unless (zl-MEMBER char '(#\space #\newline #\return #\tab))
238
 
               (unread-char char input-stream)  
239
 
             (return nil)))))))) 
240
 
 
241
 
 
242
 
(DEFUN $BREAK (&REST ARG-LIST)
243
 
  (PROG1 (apply #'$PRINT ARG-LIST)
244
 
         (MBREAK-LOOP)))
245
 
 
246
 
 
247
 
 
248
 
(DEFUN MBREAK-LOOP ()
249
 
  (LET ((*standard-input* #+nil (make-synonym-stream '*terminal-io*)
250
 
                        #-nil *debug-io*)
 
193
                   (format t " using ~:D bytes.~%" total-bytes)))))
 
194
        (unless $nolabels
 
195
          (putprop d-tag (cons time-used  0) 'time))
 
196
        (if (eq (caar r) 'displayinput)
 
197
            (displa `((mlable) ,d-tag ,$%)))
 
198
        (when (eq batch-or-demo-flag ':demo)
 
199
          (mtell "~A_~A" *prompt-prefix* *prompt-suffix*)
 
200
          (let (quitting)         
 
201
            (do ((char)) (nil)
 
202
              ;;those are common lisp characters you're reading here
 
203
              (case
 
204
                  (setq char (read-char *terminal-io*))
 
205
                ((#\page) (unless (cursorpos 'c input-stream) 
 
206
                            (terpri *standard-output*))
 
207
                 (princ "_" *standard-output*))
 
208
                ((#\?) (mtell "  Pausing.  Type a ';' and Enter to continue demo.~%_"))
 
209
                ((#\space #\; #\n #\e #\x #\t))
 
210
                ((#\newline )
 
211
                 (if quitting (throw 'abort-demo nil) (return nil))) 
 
212
                (t (setq quitting t)
 
213
                   )))))
 
214
        ;; This is sort of a kludge -- eat newlines and blanks so that
 
215
        ;; they don't echo
 
216
        (and batch-or-demo-flag
 
217
             (do ((char)) (())
 
218
               (setq char (read-char input-stream nil #+cl nil))
 
219
               (when (null char) 
 
220
                 (throw 'macsyma-quit nil)) 
 
221
               (unless (zl-member char '(#\space #\newline #\return #\tab))
 
222
                 (unread-char char input-stream)  
 
223
                 (return nil)))))))) 
 
224
 
 
225
 
 
226
(defun $break (&rest arg-list)
 
227
  (prog1 (apply #'$print arg-list)
 
228
    (mbreak-loop)))
 
229
 
 
230
 
 
231
 
 
232
(defun mbreak-loop ()
 
233
  (let ((*standard-input* #+nil (make-synonym-stream '*terminal-io*)
 
234
                          #-nil *debug-io*)
251
235
        (*standard-output* *debug-io*))
252
 
    (CATCH 'BREAK-EXIT
253
 
      (format t "~%Entering a Macsyma break point. Type EXIT; to resume")
254
 
      (DO ((R)) (NIL)
 
236
    (catch 'break-exit
 
237
      (format t "~%Entering a Maxima break point. Type exit; to resume")
 
238
      (do ((r)) (nil)
255
239
        (fresh-line)
256
 
        (SETQ R (CADDR (LET ((*MREAD-PROMPT* (BREAK-PROMPT)))
257
 
                         (MREAD *standard-input*))))
258
 
        (CASE R
259
 
          (($EXIT) (THROW 'BREAK-EXIT T))
260
 
          (T (ERRSET (DISPLA (MEVAL R)) T)))))))
 
240
        (setq r (caddr (let ((*mread-prompt* (break-prompt)))
 
241
                         (mread *standard-input*))))
 
242
        (case r
 
243
          (($exit) (throw 'break-exit t))
 
244
          (t (errset (displa (meval r)) t)))))))
261
245
 
262
246
(defun merrbreak (&optional arg)
263
247
  (format *debug-io* "~%Merrbreak:~A" arg)
264
248
  (mbreak-loop))
265
249
 
266
250
#-cl
267
 
(DEFUN RETRIEVE (MSG FLAG &AUX (PRINT? NIL))
268
 
  (DECLARE (SPECIAL MSG FLAG PRINT?))
269
 
  (OR (EQ FLAG 'NOPRINT) (SETQ PRINT? T))
270
 
  (MREAD-TERMINAL
271
 
    (CLOSURE '(MSG FLAG)
272
 
       #'(LAMBDA (STREAM CHAR) STREAM CHAR
273
 
           (COND ((NOT PRINT?) (SETQ PRINT? T))
274
 
                 ((NULL MSG))
275
 
                 ((ATOM MSG) (PRINC MSG) (MTERPRI))
276
 
                 ((EQ FLAG T) (MAPC #'PRINC (CDR MSG)) (MTERPRI))
277
 
                 (T (DISPLA MSG) (MTERPRI)))))))
 
251
(defun retrieve (msg flag &aux (print? nil))
 
252
  (declare (special msg flag print?))
 
253
  (or (eq flag 'noprint) (setq print? t))
 
254
  (mread-terminal
 
255
   (closure '(msg flag)
 
256
            #'(lambda (stream char) stream char
 
257
                      (cond ((not print?) (setq print? t))
 
258
                            ((null msg))
 
259
                            ((atom msg) (princ msg) (mterpri))
 
260
                            ((eq flag t) (mapc #'princ (cdr msg)) (mterpri))
 
261
                            (t (displa msg) (mterpri)))))))
278
262
#+cl
279
 
(DEFUN RETRIEVE (MSG FLAG &AUX (PRINT? NIL))
280
 
  (DECLARE (SPECIAL MSG FLAG PRINT?))
281
 
  (OR (EQ FLAG 'NOPRINT) (SETQ PRINT? T))
282
 
  (COND ((NOT PRINT?) 
283
 
         (SETQ PRINT? T)
284
 
         (princ *prompt-prefix*)
285
 
         (princ *prompt-suffix*))
286
 
        ((NULL MSG)
287
 
         (princ *prompt-prefix*)
288
 
         (princ *prompt-suffix*))
289
 
        ((ATOM MSG) 
290
 
         (format t "~a~a~a" *prompt-prefix* MSG *prompt-suffix*) 
291
 
         (MTERPRI))
292
 
        ((EQ FLAG T)
 
263
(defun retrieve (msg flag &aux (print? nil))
 
264
  (declare (special msg flag print?))
 
265
  (or (eq flag 'noprint) (setq print? t))
 
266
  (cond ((not print?) 
 
267
         (setq print? t)
 
268
         (princ *prompt-prefix*)
 
269
         (princ *prompt-suffix*))
 
270
        ((null msg)
 
271
         (princ *prompt-prefix*)
 
272
         (princ *prompt-suffix*))
 
273
        ((atom msg) 
 
274
         (format t "~a~a~a" *prompt-prefix* msg *prompt-suffix*) 
 
275
         (mterpri))
 
276
        ((eq flag t)
293
277
         (princ *prompt-prefix*) 
294
 
         (MAPC #'PRINC (CDR MSG)) 
 
278
         (mapc #'princ (cdr msg)) 
295
279
         (princ *prompt-suffix*)
296
 
         (MTERPRI))
297
 
        (T 
 
280
         (mterpri))
 
281
        (t 
298
282
         (princ *prompt-prefix*)
299
 
         (displa MSG) 
 
283
         (displa msg) 
300
284
         (princ *prompt-suffix*)
301
 
         (MTERPRI)))
302
 
  (mread-noprompt *query-io* nil))
303
 
 
304
 
 
305
 
(DEFMFUN $READ (&REST L)
306
 
  (MEVAL (APPLY #'$READONLY L)))
307
 
 
308
 
(DEFMFUN $READONLY (&REST L)
 
285
         (mterpri)))
 
286
  (let ((res (mread-noprompt *query-io* nil)))
 
287
       (princ *general-display-prefix*) res))
 
288
 
 
289
 
 
290
(defmfun $read (&rest l)
 
291
  (meval (apply #'$readonly l)))
 
292
 
 
293
(defmfun $readonly (&rest l)
309
294
  (let ((*mread-prompt*
310
295
         (if l (string-right-trim '(#\n)
311
296
                                  (with-output-to-string (*standard-output*)
312
297
                                    (apply '$print l))) "")))
313
298
    (setf *mread-prompt* (format nil "~a~a~a" *prompt-prefix* *mread-prompt* 
314
 
                                *prompt-suffix*))
 
299
                                 *prompt-suffix*))
315
300
    (setf answer (third (mread *query-io*)))))
316
301
 
317
302
 
318
 
#-cl
319
 
(DEFUN MREAD-TERMINAL (PROMPT)
320
 
  (prog1 (let (#+NIL (si:*ttyscan-dispatch-table *macsyma-ttyscan-operators*))
321
 
            (CADDR (send *terminal-io* ':RUBOUT-HANDLER
322
 
                         `((:PROMPT ,PROMPT) #+NIL (:reprompt ,prompt))
323
 
                         #'MREAD-RAW *terminal-io*)))
324
 
         (fresh-line *terminal-io*)))
325
 
 
326
 
 
327
 
 
328
 
(DEFUN MAKE-INPUT-STREAM (X Y) Y ;ignore
329
 
  X)
330
 
 
331
 
(DEFUN BATCH (FILENAME &OPTIONAL DEMO-P
332
 
              &AUX (orig filename )
 
303
;;#-cl
 
304
;;(DEFUN MREAD-TERMINAL (PROMPT)
 
305
;;  (prog1 (let (#+NIL (si:*ttyscan-dispatch-table *macsyma-ttyscan-operators*))
 
306
;;          (CADDR (send *terminal-io* ':RUBOUT-HANDLER
 
307
;;                       `((:PROMPT ,PROMPT) #+NIL (:reprompt ,prompt))
 
308
;;                       #'MREAD-RAW *terminal-io*)))
 
309
;;       (fresh-line *terminal-io*)))
 
310
 
 
311
 
 
312
(defun make-input-stream (x y) y        ;ignore
 
313
       x)
 
314
 
 
315
(defun batch (filename &optional demo-p
 
316
              &aux (orig filename )
333
317
              list
334
 
              FILE-OBJ (accumulated-time 0.0) (abortp t))
 
318
              file-obj (accumulated-time 0.0) (abortp t))
335
319
  (setq list (if demo-p '$file_search_demo '$file_search_maxima))
336
320
  (setq filename ($file_search filename (symbol-value list)))
337
321
  (or filename (merror "Could not find ~M in ~M: ~M"
338
322
                       orig list (symbol-value list)))
339
323
  
340
 
  (UNWIND-PROTECT
341
 
    (progn (batch-internal (setq file-obj (open filename)) demo-p)
342
 
           (setq abortp nil)
343
 
           (when $showtime
344
 
             (format t "~&Batch spent ~$ seconds in evaluation.~%"
345
 
                     accumulated-time)))
346
 
    (IF FILE-OBJ (CLOSE FILE-OBJ))
 
324
  (unwind-protect
 
325
       (progn (batch-internal (setq file-obj (open filename)) demo-p)
 
326
              (setq abortp nil)
 
327
              (when $showtime
 
328
                (format t "~&Batch spent ~$ seconds in evaluation.~%"
 
329
                        accumulated-time)))
 
330
    (if file-obj (close file-obj))
347
331
    (when abortp (format t "~&(Batch of ~A aborted.)~%" filename))))
348
332
 
349
333
 
350
334
(defun batch-internal (fileobj demo-p)
351
 
  (CONTINUE (MAKE-ECHO-INPUT-STREAM
352
 
              (MAKE-INPUT-STREAM fileobj "Batch Input Stream"))
353
 
              (IF DEMO-P ':DEMO ':BATCH)))
 
335
  (continue (make-echo-stream
 
336
             (make-input-stream fileobj "Batch Input Stream")
 
337
             *standard-output*)
 
338
            (if demo-p ':demo ':batch)))
354
339
#-cl
355
 
(DEFUN $BATCH (&REST ARG-LIST)
356
 
  (BATCH (FILENAME-FROM-ARG-LIST ARG-LIST) NIL))
 
340
(defun $batch (&rest arg-list)
 
341
  (batch (filename-from-arg-list arg-list) nil))
357
342
 
358
 
(DEFUN FILENAME-FROM-ARG-LIST (ARG-LIST)
359
 
  (IF (= (LENGTH ARG-LIST) 1)
360
 
      ($FILENAME_MERGE (CAR ARG-LIST))
361
 
      ($FILENAME_MERGE `((MLIST),@ARG-LIST))))
 
343
(defun filename-from-arg-list (arg-list)
 
344
  (if (= (length arg-list) 1)
 
345
      ($filename_merge (car arg-list))
 
346
      ($filename_merge `((mlist),@arg-list))))
362
347
 
363
348
(defmspec $grindef (form)
364
349
  (eval `(grindef ,@(cdr form)))
365
 
  '$DONE)
 
350
  '$done)
 
351
 
366
352
#+cl
367
 
(DEFUN $DEMO (&REST ARG-LIST)
 
353
(defun $demo (&rest arg-list)
368
354
  (let ((tem ($file_search (car arg-list) $file_search_demo)))
369
355
    (or tem (merror "Could not find ~M in  ~M: ~M" (car arg-list) '$file_search_demo $file_search_demo   ))
370
 
    ($BATCH tem   '$demo)))
 
356
    ($batch tem   '$demo)))
371
357
 
372
358
#-cl
373
 
(DEFUN $DEMO (&REST ARG-LIST)
374
 
  (BATCH (FILENAME-FROM-ARG-LIST ARG-LIST) T))
 
359
(defun $demo (&rest arg-list)
 
360
  (batch (filename-from-arg-list arg-list) t))
375
361
 
376
362
(defmfun $bug_report ()
377
363
  (format t "~%The Maxima bug database is available at~%")
387
373
(defmfun $build_info ()
388
374
  (format t "~%Maxima version: ~a~%" *autoconf-version*)
389
375
  (format t "Maxima build date: ~a:~a ~a/~a/~a~%"
390
 
          (third user:*maxima-build-time*)
391
 
          (second user:*maxima-build-time*)
392
 
          (fifth user:*maxima-build-time*)
393
 
          (fourth user:*maxima-build-time*)
394
 
          (sixth user:*maxima-build-time*))
 
376
          (third cl-user:*maxima-build-time*)
 
377
          (second cl-user:*maxima-build-time*)
 
378
          (fifth cl-user:*maxima-build-time*)
 
379
          (fourth cl-user:*maxima-build-time*)
 
380
          (sixth cl-user:*maxima-build-time*))
395
381
  (format t "host type: ~a~%" *autoconf-host*)
396
382
  (format t "lisp-implementation-type: ~a~%" (lisp-implementation-type))
397
383
  (format t "lisp-implementation-version: ~a~%~%" (lisp-implementation-version))
400
386
(defvar *maxima-started* nil)
401
387
(defvar *maxima-prolog* "")
402
388
(defvar *maxima-epilog* "")
403
 
(defun meshugena-clisp-banner ()
404
 
  (format t "  i i i i i i i       ooooo    o        ooooooo   ooooo   ooooo~%")
405
 
  (format t "  I I I I I I I      8     8   8           8     8     o  8    8~%")
406
 
  (format t "  I  \\ `+' /  I      8         8           8     8        8    8~%")
407
 
  (format t "   \\  `-+-'  /       8         8           8      ooooo   8oooo~%");
408
 
  (format t "    `-__|__-'        8         8           8           8  8~%")
409
 
  (format t "        |            8     o   8           8     o     8  8~%")
410
 
  (format t "  ------+------       ooooo    8oooooo  ooo8ooo   ooooo   8~%")
411
 
  (format t "~%")
412
 
  (format t "Copyright (c) Bruno Haible, Michael Stoll 1992, 1993~%")
413
 
  (format t "Copyright (c) Bruno Haible, Marcus Daniels 1994-1997~%")
414
 
  (format t "Copyright (c) Bruno Haible, Pierpaolo Bernardi, Sam Steingold 1998~%")
415
 
  (format t "Copyright (c) Bruno Haible, Sam Steingold 1999-2003~%")
416
 
  (format t 
417
 
          "--------------------------------------------------------------~%~%"))
 
389
 
 
390
(defvar *maxima-quiet* nil)
418
391
 
419
392
#-lispm
420
 
(defun macsyma-top-level (&OPTIONAL (input-stream *standard-input*)
 
393
(defun macsyma-top-level (&optional (input-stream *standard-input*)
421
394
                          batch-flag)
422
 
  (let ((*package* (find-package "MAXIMA")))
 
395
  (let ((*package* (find-package :maxima)))
423
396
    (if *maxima-started*
424
397
        (format t "Maxima restarted.~%")
425
398
        (progn
426
 
          #+clisp (meshugena-clisp-banner)
427
 
          (format t *maxima-prolog*)
428
 
          (format t "~&Maxima ~a http://maxima.sourceforge.net~%"
429
 
                  *autoconf-version*)
430
 
          (format t "Using Lisp ~a ~a" (lisp-implementation-type)
431
 
                  #-clisp (lisp-implementation-version)
432
 
                  #+clisp (subseq (lisp-implementation-version)
433
 
                                  0 (+ 1 (search
434
 
                                          ")" (lisp-implementation-version)))))
435
 
          #+gcl (format t " (aka GCL)")
436
 
          (format t "~%")
437
 
          (format t "Distributed under the GNU Public License. See the file COPYING.~%")
438
 
          (format t "Dedicated to the memory of William Schelter.~%")
439
 
          (format t "This is a development version of Maxima. The function bug_report()~%")
440
 
          (format t "provides bug reporting information.~%")
 
399
      (if (not *maxima-quiet*) (maxima-banner))
441
400
          (setq *maxima-started* t)))
442
401
    (if ($file_search "maxima-init.lisp") ($load ($file_search "maxima-init.lisp")))
443
402
    (if ($file_search "maxima-init.mac") ($batchload ($file_search "maxima-init.mac")))
444
403
    
445
404
    (catch 'quit-to-lisp
446
 
      (in-package "MAXIMA")
447
 
      (sloop 
 
405
      (in-package :maxima)
 
406
      (loop 
448
407
       do
449
 
       (catch #+kcl si::*quit-tag* #+(or cmu sbcl) 'continue #-(or kcl cmu sbcl) nil
 
408
       (catch #+kcl si::*quit-tag* #+(or cmu scl sbcl) 'continue #-(or kcl cmu scl sbcl) nil
450
409
              (catch 'macsyma-quit
451
410
                (continue input-stream batch-flag)
452
411
                (format t *maxima-epilog*)
453
412
                (bye)))))))
454
413
 
 
414
(defun maxima-banner ()
 
415
  (format t *maxima-prolog*)
 
416
  (format t "~&Maxima ~a http://maxima.sourceforge.net~%"
 
417
      *autoconf-version*)
 
418
  (format t "Using Lisp ~a ~a" (lisp-implementation-type)
 
419
      #-clisp (lisp-implementation-version)
 
420
      #+clisp (subseq (lisp-implementation-version)
 
421
              0 (+ 1 (search
 
422
                  ")" (lisp-implementation-version)))))
 
423
  #+gcl (format t " (aka GCL)")
 
424
  (format t "~%")
 
425
  (format t "Distributed under the GNU Public License. See the file COPYING.~%")
 
426
  (format t "Dedicated to the memory of William Schelter.~%")
 
427
  (format t "This is a development version of Maxima. The function bug_report()~%")
 
428
  (format t "provides bug reporting information.~%"))
 
429
 
455
430
#-lispm
456
431
(progn 
457
432
  
458
 
#+kcl
459
 
(si::putprop :t 'throw-macsyma-top 'si::break-command)
460
 
 
461
 
(defun throw-macsyma-top ()
462
 
  (throw 'macsyma-quit t))
463
 
 
464
 
 
465
 
(defmfun $writefile (x) (dribble (subseq (string x) 1)))
466
 
(defvar $appendfile nil )
467
 
(defmfun $appendfile (name)
468
 
  (if (and (symbolp name)
469
 
           (member (getcharn name 1) '(#\& #\$)))
470
 
      (setq name (subseq (symbol-name name) 1)))
471
 
  (if $appendfile (merror "already in appendfile, use closefile first"))
472
 
  (let ((stream  (open name :direction :output
473
 
                                       :if-exists :append
474
 
                                       :if-does-not-exist :create)))
475
 
  (setq *appendfile-data* (list stream *terminal-io* name ))
476
 
  
477
 
  (setq $appendfile (make-two-way-stream
478
 
                     (make-echo-stream *terminal-io* stream)
479
 
                     (make-broadcast-stream *terminal-io* stream))
480
 
        *terminal-io* $appendfile)
481
 
  (multiple-value-bind (sec min hour day month year)
482
 
                       (get-decoded-time)
483
 
                       (format t
484
 
                               "~&/* Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d).*/"
485
 
                               name year month day hour min sec))
486
 
  '$done))
487
 
  
488
 
(defmfun $closefile ()
489
 
  (cond ($appendfile
 
433
  #+kcl
 
434
  (si::putprop :t 'throw-macsyma-top 'si::break-command)
 
435
 
 
436
  (defun throw-macsyma-top ()
 
437
    (throw 'macsyma-quit t))
 
438
 
 
439
 
 
440
  (defmfun $writefile (x) (dribble (maxima-string x)))
 
441
 
 
442
  (defvar $appendfile nil )
 
443
 
 
444
  (defvar *appendfile-data*)
 
445
 
 
446
  (defmfun $appendfile (name)
 
447
    (if (and (symbolp name)
 
448
             (member (getcharn name 1) '(#\& #\$)))
 
449
        (setq name (maxima-string name)))
 
450
    (if $appendfile (merror "already in appendfile, use closefile first"))
 
451
    (let ((stream  (open name :direction :output
 
452
                         :if-exists :append
 
453
                         :if-does-not-exist :create)))
 
454
      (setq *appendfile-data* (list stream *terminal-io* name ))
 
455
  
 
456
      (setq $appendfile (make-two-way-stream
 
457
                         (make-echo-stream *terminal-io* stream)
 
458
                         (make-broadcast-stream *terminal-io* stream))
 
459
            *terminal-io* $appendfile)
 
460
      (multiple-value-bind (sec min hour day month year)
 
461
          (get-decoded-time)
 
462
        (format t
 
463
                "~&/* Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d).*/"
 
464
                name year month day hour min sec))
 
465
      '$done))
 
466
  
 
467
  (defmfun $closefile ()
 
468
    (cond ($appendfile
490
469
         
491
 
         (cond ((eq $appendfile *terminal-io*)
492
 
                 (format t "~&/*Finished dribbling to ~A.*/"
493
 
                         (nth 2 *appendfile-data*))
494
 
                (setq *terminal-io* (nth 1 *appendfile-data*))
495
 
                )
496
 
               (t  (warn "*TERMINAL-IO* was rebound while APPENDFILE is on.~%~
 
470
           (cond ((eq $appendfile *terminal-io*)
 
471
                  (format t "~&/*Finished dribbling to ~A.*/"
 
472
                          (nth 2 *appendfile-data*))
 
473
                  (setq *terminal-io* (nth 1 *appendfile-data*))
 
474
                  )
 
475
                 (t  (warn "*TERMINAL-IO* was rebound while APPENDFILE is on.~%~
497
476
                   You may miss some dribble output.")))
498
 
         (close (nth 0 *appendfile-data*))
499
 
         (setq *appendfile-data* nil $appendfile nil)
 
477
           (close (nth 0 *appendfile-data*))
 
478
           (setq *appendfile-data* nil $appendfile nil)
500
479
         
501
 
         )
502
 
        (t (dribble))))
503
 
 
504
 
 
505
 
(defmfun $ed (x) (ed (subseq (string x) 1))) 
506
 
 
507
 
(defmfun $cli () (process ":CLI.PR")) 
508
 
 
509
 
(defun nsubstring (x y) (subseq x y)) 
510
 
 
511
 
(defun filestrip (x) (subseq (string (car x)) 1)) 
512
 
)
513
 
 
514
 
(defmspec $with_stdout ( arg) (setq arg (cdr arg))
515
 
 (let ((body (cdr arg)) res)
516
 
   (with-open-file (*standard-output* (NAMESTRING (maxima-string (car arg)))
517
 
                                      :direction :output)
518
 
                   (dolist (v body)
519
 
                             (setq res (meval* v)))
520
 
                   res)))
521
 
 
522
 
 
 
480
           )
 
481
          (t (dribble))))
 
482
 
 
483
 
 
484
  (defmfun $ed (x) (ed (maxima-string x))) 
 
485
 
 
486
  (defmfun $cli () (merror "Not implemented!") )
 
487
 
 
488
  (defun nsubstring (x y) (subseq x y)) 
 
489
 
 
490
  (defun filestrip (x) (subseq (print-invert-case (car x)) 1)) 
 
491
  )
 
492
 
 
493
(defmspec $with_stdout (arg)
 
494
  (setq arg (cdr arg))
 
495
  (let*
 
496
    ((fname (namestring (maxima-string (car arg))))
 
497
     (filespec
 
498
       (if (or (eq $file_output_append '$true) (eq $file_output_append t))
 
499
         `(*standard-output* ,fname :direction :output :if-exists :append :if-does-not-exist :create)
 
500
         `(*standard-output* ,fname :direction :output :if-exists :supersede :if-does-not-exist :create))))
 
501
    (eval
 
502
      `(with-open-file ,filespec
 
503
         (let ((body ',(cdr arg)) res)
 
504
           (dolist (v body)
 
505
             (setq res (meval* v)))
 
506
           res)))))
523
507
 
524
508
(defun $sconcat(&rest x)
525
509
  (let ((ans "") )
526
 
  (dolist (v x)
527
 
          (setq ans (concatenate 'string ans
 
510
    (dolist (v x)
 
511
      (setq ans (concatenate 'string ans
528
512
                                   
529
 
          (cond ((and (symbolp v) (eql (getcharn v 1)
530
 
                                       #\&))
531
 
                 (subseq (symbol-name v) 1))
532
 
                ((stringp v) v)
533
 
                (t
534
 
                 (coerce (mstring v) 'string))))))
535
 
  ans))
 
513
                             (cond ((and (symbolp v) (eql (getcharn v 1)
 
514
                                                          #\&))
 
515
                                    (subseq (print-invert-case v) 1))
 
516
                                   ((stringp v) v)
 
517
                                   (t
 
518
                                    (coerce (mstring v) 'string))))))
 
519
    ans))
536
520
                                        ;
537
521
 
538
 
#+gcl
539
 
(defun $system (&rest x) (system (apply '$sconcat x)))
540
 
 
541
 
#+clisp
542
 
(defun $system (&rest x) (ext:run-shell-command (apply '$sconcat x)))
543
 
 
544
 
#+cmu
545
 
(defun $system (&rest args)
546
 
  (ext:run-program "/bin/sh" (list "-c" (apply '$sconcat args)) :output t))
547
 
 
548
 
#+allegro
549
 
(defun $system (&rest args)
550
 
  (excl:run-shell-command (apply '$sconcat args) :wait t))
551
 
 
552
 
#+sbcl
553
 
(defun $system (&rest args)
554
 
  (sb-ext:run-program "/bin/sh" (list "-c" (apply '$sconcat args)) :output t))
555
 
 
556
 
#+openmcl
557
 
(defun $system (&rest args)
558
 
  (ccl::run-program "/bin/sh" (list "-c" (apply '$sconcat args)) :output t))
 
522
(defun $system (&rest args)
 
523
  #+gcl   (lisp:system (apply '$sconcat args))
 
524
  #+clisp (ext:run-shell-command (apply '$sconcat args))
 
525
  #+(or cmu scl) (ext:run-program "/bin/sh"
 
526
                                  (list "-c" (apply '$sconcat args)) :output t)
 
527
  #+allegro (excl:run-shell-command (apply '$sconcat args) :wait t)
 
528
  #+sbcl  (sb-ext:run-program "/bin/sh"
 
529
                              (list "-c" (apply '$sconcat args)) :output t)
 
530
  #+openmcl (ccl::run-program "/bin/sh"
 
531
                              (list "-c" (apply '$sconcat args)) :output t)
 
532
  )
559
533
 
560
534
(defun $room (&optional (arg nil arg-p))
561
535
  (if arg-p
563
537
      (room)))
564
538
 
565
539
(defun maxima-lisp-debugger (condition me-or-my-encapsulation)
 
540
  (declare (ignore me-or-my-encapsulation))
566
541
  (format t "~&Maxima encountered a Lisp error:~%~% ~A" condition)
567
542
  (format t "~&~%Automatically continuing.~%To reenable the Lisp debugger set *debugger-hook* to nil.~%")
568
543
  (throw 'return-from-debugger t))