1;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3;;;     The data in this file contains enhancements.                   ;;;;;
4;;;                                                                    ;;;;;
5;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
6;;;     All rights reserved                                            ;;;;;
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8
9(in-package :maxima)
10
11;;	** (c) Copyright 1982 Massachusetts Institute of Technology **
12
13;;note in converting this file (originally suprv.lisp) to common lisp
14;;for the lisp machine, I removed a lot of the old stuff which did not
15;;apply, and tried to eliminate any / quoting.  Most of the relevant
16;;stuff is in system.lisp for the lispm and nil friends.--wfs
17
18(eval-when
19    #+gcl (compile eval)
20    #-gcl (:compile-toplevel :execute)
21  (setq old-ibase *read-base* old-base *print-base*)
22  (setq *read-base* 10. *print-base* 10.))
23
24(declare-top  (special bindlist loclist errset *mopl*
25		       $values $functions $arrays $gradefs $dependencies
26		       $rules $props $ratvars
27		       varlist genvar
28		       $gensumnum checkfactors $features featurel
29		       tellratlist $dontfactor
30		       dispflag savefile $%% $error
31		       opers *ratweights $ratweights
32		       $stringdisp $lispdisp
33		       transp $contexts $setcheck $macros autoload))
34
35(defvar thistime 0)
36(defvar *refchkl* nil)
37(defvar *mdebug* nil)
38(defvar *baktrcl* nil)
39(defvar errcatch nil)
40(defvar mcatch nil)
41(defvar brklvl -1)
42(defvar allbutl nil)
43(defvar lessorder nil)
44(defvar greatorder nil)
45(defvar *in-translate-file* nil)
46(defvar *linelabel* nil)
47
48(defmvar $disptime nil)
49(defmvar $strdisp t)
50(defmvar $grind nil)
51(defmvar $backtrace '$backtrace)
52(defmvar $debugmode nil)
53(defmvar $poislim 5)
54(defmvar $loadprint nil)
55(defmvar $nolabels nil)
56(defmvar $aliases '((mlist simp)))
57
58(defmvar $infolists
59  '((mlist simp) $labels $values $functions $macros $arrays
60                 $myoptions $props $aliases $rules $gradefs
61                 $dependencies $let_rule_packages $structures))
62
63(defmvar $labels (list '(mlist simp)))
64(defmvar $dispflag t)
65
66(defmvar $% '$% "The last out-line computed, corresponds to lisp *"
67	 no-reset)
68
69(defmvar $inchar '$%i
70  "The alphabetic prefix of the names of expressions typed by the user.")
71
72(defmvar $outchar '$%o
73  "The alphabetic prefix of the names of expressions returned by the system.")
74
75(defmvar $linechar '$%t
76  "The alphabetic prefix of the names of intermediate displayed expressions.")
77
78(defmvar $linenum 1 "the line number of the last expression."
79	 fixnum no-reset)
80
81(defmvar $file_output_append nil
82  "Flag to tell file-writing functions whether to append or clobber the output file.")
83
84;; This version of meval* makes sure, that the facts from the global variable
85;; *local-signs* are cleared with a call to clearsign. The facts are added by
86;; asksign and friends. The function meval* is only used for top level
87;; evaluations.  For other cases the function meval can be used.
88
89(defmvar $ratvarswitch t) ; If T, start an evaluation with a fresh list VARLIST.
90
91(defun meval* (expr)
92  ;; Make sure that clearsign is called after the evaluation.
93  (unwind-protect
94    (let (*refchkl* *baktrcl* checkfactors)
95      (if $ratvarswitch (setq varlist (cdr $ratvars)))
96      (meval expr))
97    ;; Clear the facts from asksign and friends.
98    (clearsign)))
99
100(defun makelabel (x)
101  (setq *linelabel* ($concat '|| x $linenum))
102  (unless $nolabels
103    (when (or (null (cdr $labels))
104	      (when (member *linelabel* (cddr $labels) :test #'equal)
105		(setf $labels (delete *linelabel* $labels :count 1 :test #'eq)) t)
106	      (not (eq *linelabel* (cadr $labels))))
107      (setq $labels (cons (car $labels) (cons *linelabel* (cdr $labels))))))
108  *linelabel*)
109
110(defun printlabel ()
111  (mtell-open "(~A) " (subseq (print-invert-case *linelabel*) 1)))
112
113(defun mexploden (x)
114  (let (*print-radix*
115	(*print-base* 10))
116    (exploden x)))
117
118(defun addlabel (label)
119  (setq $labels (cons (car $labels) (cons label (delete label (cdr $labels) :count 1 :test #'eq)))))
120
121(defun tyi* ()
122  (clear-input)
123  (do ((n (tyi) (tyi))) (nil)
124    (cond ((or (char= n #\newline) (and (> (char-code n) 31) (char/= n #\rubout)))
125	   (return n))
126	  ((char= n #\page) (format t "~|") (throw 'retry nil)))))
127
128(defun continuep ()
129  (loop
130   (catch 'retry
131     (unwind-protect
132	  (progn
133	    (fresh-line)
134	    (princ (break-prompt))
135	    (finish-output)
136	    (return (char= (tyi*) #\newline)))
137       (clear-input)))))
138
139(defun checklabel (x)	; CHECKLABEL returns T iff label is not in use
140  (not (or $nolabels
141	   (= $linenum 0)
142	   (boundp ($concat '|| x $linenum)))))
143
144(defun gctimep (timep tim)
145  (cond ((and (eq timep '$all) (not (zerop tim))) (princ (intl:gettext "Total time = ")) t)
146	(t (princ (intl:gettext "Time = ")) nil)))
147
148; Following GENERIC-AUTOLOAD is copied from orthopoly/orthopoly-init.lisp.
149; Previous version didn't take Clisp, CMUCL, or SBCL into account.
150
151(defvar *autoloaded-files* ())
152
153(defun generic-autoload (file &aux type)
154  (unless (member file *autoloaded-files* :test #'equal)
155    (push file *autoloaded-files*)
156    (setq file (pathname (cdr file)))
157    (setq type (pathname-type file))
158    (let ((bin-ext #+gcl "o"
159		   #+cmu (c::backend-fasl-file-type c::*target-backend*)
160		   #+clisp "fas"
161		   #+allegro "fasl"
162		   #+openmcl (pathname-type ccl::*.fasl-pathname*)
163		   #+lispworks (pathname-type (compile-file-pathname "foo.lisp"))
164		   #-(or gcl cmu clisp allegro openmcl lispworks) ""))
165      (if (member type (list bin-ext "lisp" "lsp")  :test 'equalp)
166	  (let ((*read-base* 10.)) #-sbcl (load file) #+sbcl (with-compilation-unit nil (load file)))
167	  ($load file)))))
168
169(defvar autoload 'generic-autoload)
170
171(defun load-function (func mexprp)	; The dynamic loader
172  (declare (ignore mexprp))
173  (let ((file (get func 'autoload)))
174    (if file (funcall autoload (cons func file)))))
175
176(defmspec $loadfile (form)
177  (loadfile (namestring (maxima-string (meval (cadr form)))) nil
178	    (not (member $loadprint '(nil $autoload) :test #'equal))))
179
180(defmfun $setup_autoload (filename &rest functions)
181  (let ((file ($file_search filename)))
182    (dolist (func functions)
183      (nonsymchk func '$setup_autoload)
184      (putprop (setq func ($verbify func)) file 'autoload)
185      (add2lnc func $props)))
186  '$done)
187
188(defun dollarify (l)
189  (let ((errset t))
190    (cons '(mlist simp)
191	  (mapcar #'(lambda (x)
192		      (let (y)
193			(cond ((numberp x) x)
194			      ((numberp (setq y (car (errset (readlist (mexploden x))))))
195			       y)
196			      (t (makealias x)))))
197		  l))))
198
199(defun mfboundp (func)
200  (or (mgetl func '(mexpr mmacro))
201      (getl func '(translated-mmacro mfexpr* mfexpr*s))))
202
203(defun loadfile (file findp printp)
204  (and findp (member $loadprint '(nil $loadfile) :test #'equal) (setq printp nil))
205  ;; Should really get the truename of FILE.
206  (if printp (format t (intl:gettext "loadfile: loading ~A.~%") file))
207  (let* ((path (pathname file))
208	 (*package* (find-package :maxima))
209	 ($load_pathname path)
210	 (*read-base* 10.)
211	 (tem (errset #-sbcl (load (pathname file)) #+sbcl (with-compilation-unit nil (load (pathname file))))))
212    (or tem (merror (intl:gettext "loadfile: failed to load ~A") (namestring path)))
213    (namestring path)))
214
215(defmfun $directory (path)
216  (cons '(mlist) (mapcar 'namestring (directory ($filename_merge path)))))
217
218(defmspec $kill (form)
219  (clear)	;; get assume db into consistent state
220  (mapc #'kill1 (cdr form))
221  '$done)
222
223;;; The following *builtin- variables are used to keep/restore builtin
224;;; symbols and values during kill operations. Their values are set at
225;;; the end of init-cl.lisp, after all symbols have been defined.
226
227(defvar *builtin-symbols* nil)
228(defvar *builtin-symbol-props* (make-hash-table))
229(defvar *builtin-$props* nil)
230(defvar *builtin-$rules* nil)
231(defvar *builtin-symbols-with-values* nil)
232(defvar *builtin-symbol-values* (make-hash-table))
233(defvar *builtin-numeric-constants* '($%e $%pi $%phi $%gamma))
234
235(defun kill1-atom (x)
236  (let ((z (or (and (member x (cdr $aliases) :test #'equal) (get x 'noun)) (get x 'verb))))
237    (when (or (null allbutl) (not (member z allbutl :test #'equal)))
238      (remvalue x '$kill)
239      (mget x 'array)
240      (remcompary x)
241      (when (member x (cdr $contexts) :test #'equal)
242	($killcontext x))
243      (when (mget x '$rule)
244	(let ((y (ruleof x)))
245	  (cond (y ($remrule y x))
246		(t (when (not (member x *builtin-$rules* :test #'equal))
247		     (fmakunbound x)
248		     (setf $rules (delete x $rules :count 1 :test #'eq)))))))
249      (when (and (get x 'operators) (rulechk x))
250	($remrule x '$all))
251      (when (mget x 'trace)
252	(macsyma-untrace x))
253      (when (get x 'translated)
254	(when (not (member x *builtin-symbols* :test #'equal))
255			 (remove-transl-fun-props x)
256			 (remove-transl-array-fun-props x)))
257      (when (not (get x 'sysconst))
258	(remprop x 'lineinfo)
259	(remprop x 'mprops))
260      (dolist (u '(bindtest nonarray evfun evflag opers special mode))
261	(remprop x u))
262      (dolist (u opers)
263	(when (and (remprop x u)
264		 (let ((xopval (get x 'operators)))
265		   (or (eq xopval 'simpargs1) (eq xopval nil))))
266	    (remprop x 'operators)))
267      (when (member x (cdr $props) :test #'equal)
268	(remprop x 'sp2)
269	(killframe x)
270	(i-$remove (list x $features)))
271      (let ((y (get x 'op)))
272        (when (and y
273                   (not (member y *mopl* :test #'equal))
274                   (member y (cdr $props) :test #'equal))
275	  (kill-operator x)))
276      (remalias x nil)
277      (setf $arrays (delete x $arrays :count 1 :test #'eq))
278      (rempropchk x)
279      (setf *autoloaded-files*
280	    (delete (assoc x *autoloaded-files* :test #'eq) *autoloaded-files* :count 1 :test #'equal))
281      (setf $functions
282	    (delete (assoc (ncons x) $functions :test #'equal) $functions :count 1 :test #'equal))
283      (setf $macros
284	    (delete (assoc (ncons x) $macros :test #'equal) $macros :count 1 :test #'equal))
285      (let ((y (assoc (ncons x) $gradefs :test #'equal)))
286	(when y
287	  (remprop x 'grad)
288	  (setf $gradefs (delete y $gradefs :count 1 :test #'equal))))
289      (setf $dependencies
290	    (delete (assoc (ncons x) $dependencies :test #'equal) $dependencies :count 1 :test #'equal))
291      (let ((y (assoc-if #'(lambda (e) (equal x (car e))) (cdr $structures))))
292        (when y
293          (remprop x 'dimension)
294          (remprop x 'defstruct-template)
295          (remprop x 'defstruct-default)
296          (remprop x 'translate)
297          (setf $structures (delete y $structures :count 1 :test #'equal))))
298      (when (and (member x *builtin-symbols* :test #'equal)
299		 (gethash x *builtin-symbol-props*))
300	(setf (symbol-plist x)
301	      (copy-tree (gethash x *builtin-symbol-props*))))
302      (when (member x *builtin-numeric-constants*)
303	(initialize-numeric-constant x))	;; reset db value for $%pi, $%e, etc
304      (if z (kill1 z)))))
305
306(defun kill1 (x)
307  (if (and (stringp x) (not (getopr0 x))) (return-from kill1 nil))
308  (funcall
309   #'(lambda (z)
310       (cond ((and allbutl (member x allbutl :test #'equal)))
311	     ((eq (setq x (getopr x)) '$labels)
312	      (dolist (u (cdr $labels))
313		(cond ((and allbutl (member u allbutl :test #'equal))
314		       (setq z (nconc z (ncons u))))
315		      (t (makunbound u) (remprop u 'time)
316			 (remprop u 'nodisp))))
317	      (setq $labels (cons '(mlist simp) z) $linenum 0))
318	     ((member x '($values $arrays $aliases $rules $props
319			$let_rule_packages) :test #'equal)
320	      (mapc #'kill1 (cdr (symbol-value x))))
321	     ((member x '($functions $macros $gradefs $dependencies $structures) :test #'equal)
322	      (mapc #'(lambda (y) (kill1 (caar y))) (cdr (symbol-value x))))
323	     ((eq x '$myoptions))
324	     ((eq x '$tellrats) (setq tellratlist nil))
325	     ((eq x '$ratweights) (setq *ratweights nil
326					$ratweights '((mlist simp))))
327	     ((eq x '$features)
328	      (cond ((not (equal (cdr $features) featurel))
329		     (setq $features (cons '(mlist simp) (copy-list featurel))))))
330	     ((or (eq x t) (eq x '$all))
331	      (mapc #'kill1 (cdr $infolists))
332	      (setq $ratvars '((mlist simp)) varlist nil genvar nil
333		    checkfactors nil greatorder nil lessorder nil $gensumnum 0
334		    *ratweights nil $ratweights
335		    '((mlist simp))
336		    tellratlist nil $dontfactor '((mlist)) $setcheck nil)
337	      (killallcontexts))
338	     ((setq z (assoc x '(($inlabels . $inchar) ($outlabels . $outchar) ($linelabels . $linechar)) :test #'eq))
339	      (mapc #'(lambda (y) (remvalue y '$kill))
340		    (getlabels* (eval (cdr z)) nil)))
341	     ((and (fixnump x) (>= x 0)) (remlabels x))
342	     ((atom x) (kill1-atom x))
343	     ((and (eq (caar x) 'mlist) (fixnump (cadr x))
344		   (or (and (null (cddr x))
345                         (setq x (append x (ncons (cadr x)))))
346                      (and (fixnump (caddr x))
347                         (not (> (cadr x) (caddr x))))))
348	      (let (($linenum (caddr x))) (remlabels (- (caddr x) (cadr x)))))
349	     ((setq z (mgetl (caar x) '(hashar array))) (remarrelem z x))
350	     ((and ($subvarp x)
351		   (boundp (caar x))
352		   (hash-table-p (setq z (symbol-value (caar x)))))
353	      ; Evaluate the subscripts (as is done in ARRSTORE)
354	      (let ((indices (mevalargs (cdr x))))
355		(if (gethash 'dim1 z)
356		  (remhash (car indices) z)
357		  (remhash indices z))))
358         ((eq (caar x) '$@) (mrecord-kill x))
359	     ((and (eq (caar x) '$allbut)
360		   (not (dolist (u (cdr x))
361			  (if (not (symbolp u)) (return t)))))
362	      (let ((allbutl (cdr x))) (kill1 t)))
363	     (t (improper-arg-err x '$kill))))
364   nil))
365
366
367(defun remlabels (n)
368  (prog (l x)
369     (setq l (list (exploden $inchar)
370		   (exploden $outchar)
371		   (exploden $linechar)))
372     loop (setq x (mexploden $linenum))
373     (do ((l l (cdr l)))
374	 ((null l))
375       (remvalue (implode (append (car l) x)) '$kill))
376     (if (or (minusp (setq n (1- n))) (= $linenum 0)) (return nil))
377     (decf $linenum)
378     (go loop)))
379
380(defun remvalue (x fn)
381  (cond ((not (symbolp x)) (improper-arg-err x fn))
382	((boundp x)
383	 (let (y)
384	   (cond ((or (setq y (member x (cdr $values) :test #'equal))
385		      (member x (cdr $labels) :test #'equal))
386		  (cond (y (setf $values (delete x $values :count 1 :test #'eq)))
387			(t (setf $labels (delete x $labels :count 1 :test #'eq))
388			   (remprop x 'time) (remprop x 'nodisp)))
389		  (makunbound x)
390		  (when (member x *builtin-symbols-with-values* :test #'equal)
391		    (setf (symbol-value x)
392			  (gethash x *builtin-symbol-values*)))
393		  t)
394		 ((get x 'special)
395		  (makunbound x)
396		  (when (member x *builtin-symbols-with-values* :test #'equal)
397		    (setf (symbol-value x)
398			  (gethash x *builtin-symbol-values*)))
399		    t)
400		 (transp (setf (symbol-value x) x) t)
401		 ((eq x '$default_let_rule_package) t)
402		 ;; Next case: X is bound to itself but X is not on values list.
403		 ;; Translation code does that; I don't know why.
404		 ;; Silently let it stand and hope it doesn't cause trouble.
405		 ((eq (symbol-value x) x) t)
406		 (t
407		  (mtell (intl:gettext "remvalue: ~M doesn't appear to be a known variable; just unbind it anyway.~%") x)
408		  (makunbound x)
409		  t))))))
410
411(defun ruleof (rule)
412  (or (mget rule 'ruleof)
413      (let* ((pattern (cadr (mget rule '$rule)))
414	     (op (if (atom pattern) nil (caar pattern))) l)
415	(and (setq l (get op 'rules))
416	     (member rule l :test #'equal) op))))
417
418(defmfun $debugmode (x)
419  (setq $debugmode x)
420  (debugmode1 nil x))
421
422(defun debugmode1 (assign-var y)
423  (declare (ignore assign-var))
424  (setq *mdebug* y))
425
426(defun errlfun1 (mpdls)
427  (do ((l bindlist (cdr l))
428       (l1))
429      ((eq l (car mpdls)) (munbind l1))
430    (setq l1 (cons (car l) l1)))
431  (do ()
432      ((eq loclist (cdr mpdls)))
433    (munlocal)))
434
435(defun getalias (x)
436  (cond ((get x 'alias))
437	((eq x '$false) nil)
438	(t x)))
439
440(defun makealias (x)
441  (implode (cons #\$ (exploden x))))
442
443;; (DEFMSPEC $F (FORM) (SETQ FORM (FEXPRCHECK FORM)) ...)
444;; makes sure that F was called with exactly one argument and
445;; returns that argument.
446
447(defun fexprcheck (form)
448  (if (or (null (cdr form)) (cddr form))
449      (merror (intl:gettext "~:M: expected just one argument; found: ~M") (caar form) form)
450      (cadr form)))
451
452(defun nonsymchk (x fn)
453  (unless (symbolp x)
454    (merror (intl:gettext "~:M: argument must be a symbol; found: ~M") fn x)))
455
456(defmfun $print (&rest args)
457  (if (null args)
458      '((mlist simp))
459      (let ((l args) $stringdisp) ;; Don't print out strings with quotation marks!
460	(do ((l l (cddr l)))
461	    ((null l))
462	  (rplacd l (cons " " (cdr l))))
463	(displa (cons '(mtext) l))
464	(cadr (reverse l)))))
465
466(defmspec $playback (x)
467  (declare (special $showtime))
468  (setq x (cdr x))
469  (prog (l l1 l2 numbp slowp nostringp inputp timep grindp inchar largp)
470     (setq inchar (getlabcharn $inchar)) ; Only the 1st alphabetic char. of $INCHAR is tested
471     (setq timep $showtime grindp $grind)
472     (do ((x x (cdr x)))( (null x))
473       (cond ((fixnump (car x)) (setq numbp (car x)))
474             ((eq (car x) '$all))
475             ((eq (car x) '$slow) (setq slowp t))
476             ((eq (car x) '$nostring) (setq nostringp t))
477             ((eq (car x) '$grind) (setq grindp t))
478             ((eq (car x) '$input) (setq inputp t))
479             ((member (car x) '($showtime $time) :test #'equal) (setq timep (or timep t)))
480             ((member (car x) '($gctime $totaltime) :test #'equal) (setq timep '$all))
481             ((setq l2 (listargp (car x)))
482              (setq l1 (nconc l1 (getlabels (car l2) (cdr l2) nil)) largp t))
483             (t (improper-arg-err (car x) '$playback))))
484     (cond ((and largp (null numbp)) (go loop))
485           ((and (setq l (cdr $labels)) (not $nolabels)) (setq l (cdr l))))
486     (when (or (null numbp) (< (length l) numbp))
487       (setq l1 (reverse l)) (go loop))
488     (do ((i numbp (1- i)) (l2)) ((zerop i) (setq l1 (nconc l1 l2)))
489       (setq l2 (cons (car l) l2) l (cdr l)))
490     loop (if (null l1) (return '$done))
491     (let ((errset t)
492           (incharp (char= (getlabcharn (car l1)) inchar)))
493       (errset
494        (cond ((and (not nostringp) incharp)
495               (let ((*linelabel* (car l1))) (mterpri) (printlabel))
496               (if grindp
497                   (mgrind (meval1 (car l1)) nil)
498                   (mapc #'(lambda (x) (write-char x)) (mstring (meval1 (car l1))))) ;gcl doesn't like a
499                                      ; simple write-char, therefore wrapped it up in a lambda - are_muc
500               (if (get (car l1) 'nodisp) (princ "$") (princ ";"))
501               (mterpri))
502              ((or incharp
503                   (prog2 (when (and timep (setq l (get (car l1) 'time)))
504                            (setq x (gctimep timep (cdr l)))
505                            (mtell (intl:gettext "~A seconds") (car l))
506                            (if x (mtell (intl:gettext "  GC time = ~A seconds") (cdr l)))
507                            (mterpri))
508                       (not (or inputp (get (car l1) 'nodisp)))))
509               (mterpri) (displa (list '(mlabel) (car l1) (meval1 (car l1)))))
510              (t (go a)))))
511     (when (and slowp (cdr l1) (not (continuep)))
512       (return '$terminated))
513     a    (setq l1 (cdr l1))
514     (go loop)))
515
516(defun listargp (x)
517  (let (high)
518    (if (and ($listp x) (fixnump (cadr x))
519           (or (and (null (cddr x)) (setq high (cadr x)))
520              (and (fixnump (setq high (caddr x)))
521                 (not (> (cadr x) high)))))
522	(cons (cadr x) high))))
523
524(defmspec $alias (form)
525  (if (oddp (length (setq form (cdr form))))
526      (merror (intl:gettext "alias: expected an even number of arguments.")))
527  (do ((l nil (cons (alias (pop form) (pop form))
528		    l)))
529      ((null form)
530       `((mlist simp),@(nreverse l)))))
531
532(defun alias (x y)
533  (cond ((nonsymchk x '$alias))
534	((nonsymchk y '$alias))
535        ((eq x y) y) ; x is already the alias of y
536	((get x 'reversealias)
537	 (if (not (eq x y))
538	     (merror (intl:gettext "alias: ~M already has an alias.") x)))
539	(t (putprop x y'alias)
540	   (putprop y x 'reversealias)
541	   (add2lnc y $aliases)
542	   y)))
543
544(defun remalias (x &optional remp)
545  (let ((y (and (or remp (member x (cdr $aliases) :test #'equal)) (get x 'reversealias))))
546    (cond ((and y (eq x '%derivative))
547	   (remprop x 'reversealias)
548	   (setf $aliases (delete x $aliases :count 1 :test #'eq))
549	   (remprop '$diff 'alias) '$diff)
550	  (y (remprop x 'reversealias)
551	     (remprop x 'noun)
552	     (setf $aliases (delete x $aliases :count 1 :test #'eq))
553	     (remprop (setq x y) 'alias) (remprop x 'verb) x))))
554
555(defun stripdollar (x)
556  (cond ((not (atom x))
557	 (cond ((and (eq (caar x) 'bigfloat) (not (minusp (cadr x)))) (implode (fpformat x)))
558	       (t (merror (intl:gettext "STRIPDOLLAR: argument must be an atom; found: ~M") x))))
559	((numberp x) x)
560	((null x) 'false)
561	((eq x t) 'true)
562        ((member (get-first-char x) '(#\$ #\%) :test #'char=)
563         (intern (subseq (string x) 1)))
564	(t x)))
565
566(defun fullstrip (x)
567  (mapcar #'fullstrip1 x))
568
569(defun fullstrip1 (x)
570  (or (and (numberp x) x)
571      (let ((y (get x 'reversealias))) (if y (stripdollar y)))
572      (stripdollar x)))
573
574(defun string* (x)
575  (or (and (numberp x) (exploden x))
576      (string*1 x)))
577
578(defun string*1 (x)
579  (let ($stringdisp $lispdisp)
580    (makestring x)))
581
582;;; Note that this function had originally stripped a prefix of '|M|.  This
583;;; was intended for operators such as 'MABS, but with the case flipping
584;;; performed by explodec this test would always fail.  Dependent code has
585;;; been written assuming the '|M| prefix is not stripped so this test has
586;;; been disabled for now.
587;;;
588(defmfun $nounify (x)
589  (if (not (or (symbolp x) (stringp x)))
590    (merror (intl:gettext "nounify: argument must be a symbol or a string; found: ~M") x))
591  (setq x (amperchk x))
592  (cond ((get x 'verb))
593	((get x 'noun) x)
594	(t
595	 (let* ((y (explodec x))
596		(u #+nil (member (car y) '($ |M| |m|) :test 'eq)
597		   (eq (car y) '$)))
598	   (cond ((or u (not (eq (car y) '%)))
599		  (setq y (implode (cons '% (if u (cdr y) y))))
600		  (putprop y x 'noun) (putprop x y 'verb))
601		 (t x))))))
602
603(defmfun $verbify (x)
604  (if (not (or (symbolp x) (stringp x)))
605    (merror (intl:gettext "verbify: argument must be a symbol or a string; found: ~M") x))
606  (setq x (amperchk x))
607  (cond ((get x 'noun))
608        ((eq x '||) x)
609	((and (char= (char (symbol-name x) 0) #\%)
610	      (prog2
611		  ($nounify (implode (cons #\$ (cdr (exploden x)))))
612		  (get x 'noun))))
613	(t x)))
614
615(defmspec $string (form)
616  (let (($lispdisp t))
617    (setq form (strmeval (fexprcheck form)))
618    (setq form (if $grind (strgrind form) (mstring form)))
619    (coerce form 'string)))
620
621(defun makstring (x)
622  (setq x (mstring x))
623  (do ((l x (cdr l)))
624      ((null l))
625    (rplaca l (ascii (car l))))
626  x)
627
628(defun strmeval (x)
629  (cond ((atom x) (meval1 x))
630	((member (caar x) '(msetq mdefine mdefmacro) :test #'equal) x)
631	(t (meval x))))
632
633
634(mapc #'(lambda (x) (putprop (car x) (cadr x) 'alias)
635		(putprop (cadr x) (car x) 'reversealias))
636      '(($block mprog block) ($lambda lambda lambda)
637	($subst $substitute subst)
638	($go mgo go) ($signum %signum signum)
639	($return mreturn return) ($factorial mfactorial factorial)
640        ($ibase *read-base* *read-base*) ($obase *print-base* obase)
641        ($nopoint *nopoint nopoint)
642	($modulus modulus modulus) ($zunderflow zunderflow zunderflow)
643	($ttyoff #.ttyoff ttyoff)
644	($mode_declare $modedeclare mode_declare)))
645
646(mapc #'(lambda (x) (putprop (car x) (cadr x) 'alias))
647      '(($ratcoeff $ratcoef) ($ratnum $ratnumer) ($true t)
648        ($derivative $diff) ($prod $product)
649	($bothcoeff $bothcoef)))
650
651(defun amperchk (name)
652  (cond
653    ((symbolp name) name)
654    ((stringp name)
655     (getalias (or (getopr0 name) (implode (cons #\$ (coerce name 'list))))))
656    (t name)))
657
658(defmspec $stringout (x)
659  (setq x (cdr x))
660  (let*
661    ((file (namestring (maxima-string (meval (car x)))))
662     (filespec (if (or (eq $file_output_append '$true) (eq $file_output_append t))
663	`(savefile ,file :direction :output :if-exists :append :if-does-not-exist :create)
664	`(savefile ,file :direction :output :if-exists :supersede :if-does-not-exist :create))))
665    (setq x (cdr x))
666    (eval
667      `(let (maxima-error l1 truename)
668	(declare (special $grind $strdisp))
669	    (with-open-file ,filespec
670	      (cond ((null
671		      (errset
672		       (do ((l ',x (cdr l)))( (null l))
673			 (cond ((member (car l) '($all $input) :test #'equal)
674				(setq l (nconc (getlabels* $inchar t) (cdr l))))
675			       ((eq (car l) '$values)
676				(setq l (nconc (mapcan
677						#'(lambda (x)
678						    (if (boundp x)
679							(ncons (list '(msetq) x (symbol-value x)))))
680						(cdr $values))
681					       (cdr l))))
682			       ((eq (car l) '$functions)
683				(setq l (nconc (mapcar
684						#'(lambda (x) (consfundef (caar x) nil nil))
685						(cdr $functions))
686					       (mapcan
687						#'(lambda (x)
688						    (if (mget x 'aexpr)
689							(ncons (consfundef x t nil))))
690						(cdr $arrays))
691					       (mapcar
692						#'(lambda (x) (consfundef (caar x) nil nil))
693						(cdr $macros))
694					       (cdr l))))
695			       ((setq l1 (listargp (car l)))
696				(setq l (nconc (getlabels (car l1) (cdr l1) t) (cdr l)))))
697			 (if (null l) (return nil))
698			 (terpri savefile)
699			 (if $grind (mgrind (strmeval (car l)) savefile)
700			     (princ (print-invert-case (maknam (mstring (strmeval (car l)))))
701					    savefile))
702			 (if (or (and (symbolp (car l)) (get (car l) 'nodisp)) (not $strdisp))
703			     (write-char #\$ savefile)
704			     (write-char #\; savefile)))))
705		     (setq maxima-error t)))
706	      (setq truename (truename savefile))
707	      (terpri savefile))
708	    (if maxima-error (merror (intl:gettext "stringout: unspecified error.")))
709	    (cl:namestring truename)))))
710
711(defmfun $labels (label-prefix)
712  (nonsymchk label-prefix '$labels)
713  (cons '(mlist simp) (nreverse (getlabels* label-prefix nil))))
714
715(defmfun $%th (x)
716  (prog (l outchar)
717     (if (or (not (fixnump x)) (zerop x))
718	 (improper-arg-err x '$%th))
719     (if (> x 0) (setq x (- x)))
720     (if (cdr $labels)
721	 (setq l (cddr $labels) outchar (getlabcharn $outchar)))
722     loop (if (null l) (merror (intl:gettext "%th: no such previous output: ~M") x))
723     (if (and (char= (getlabcharn (car l)) outchar) (= (setq x (1+ x)) 0))
724					; Only the 1st alphabetic character of $OUTCHAR is tested.
725	 (return (meval (car l))))
726     (setq l (cdr l))
727     (go loop)))
728
729(defun getlabels (n1 n2 flag)	; FLAG = T for STRINGOUT, = NIL for PLAYBACK and SAVE.
730  (do ((i n1 (1+ i)) (l1)
731       (l (if flag (list (exploden $inchar))
732	      (list (exploden $inchar) (exploden $linechar)
733		    (exploden $outchar)))))
734      ((> i n2) (nreverse l1))
735    (do ((l l (cdr l)) (x (mexploden i)) (z)) ((null l))
736      (if (boundp (setq z (implode (append (car l) x))))
737	  (setq l1 (cons z l1))))))
738
739(defun getlabels* (label-prefix flag)		; FLAG = T only for STRINGOUT
740  (let*
741    ((label-prefix-name (symbol-name label-prefix))
742     (label-prefix-length (length label-prefix-name)))
743    (do ((l (if flag (cddr $labels) (cdr $labels)) (cdr l)) (l1))
744        ((null l) l1)
745        (let ((label-name-1 (symbol-name (car l))))
746          (if
747            (and
748              (<= label-prefix-length (length label-name-1))
749              (string= label-name-1 label-prefix-name :end1 label-prefix-length))
750            (setq l1 (cons (car l) l1)))))))
751
752(defun getlabcharn (label)
753  (let ((c (char (symbol-name label) 1)))
754    (if (char= c #\%)
755	(char (symbol-name label) 2)
756	c)))
757
758(defmspec $errcatch (form)
759  (let ((errcatch (cons bindlist loclist))
760        (*mdebug* nil))
761    (handler-case (list '(mlist) (rat-error-to-merror (mevaln (cdr form))))
762      (maxima-$error ()
763        ; merror already set the error variable and printed the error
764        ; message if errormsg is true, so we just need to clean up.
765        (errlfun1 errcatch)
766        (list '(mlist simp)))
767      (error (e)
768        ; We store the error report message in the error variable and
769        ; print the message if errormsg is true.  Then we clean up.
770        (setq $error (list '(mlist simp) (princ-to-string e)))
771        (when $errormsg
772          ($errormsg))
773        (errlfun1 errcatch)
774        (list '(mlist simp))))))
775
776(defmspec $catch (form)
777  (let ((mcatch (cons bindlist loclist)))
778    (prog1
779	(catch 'mcatch (rat-error-to-merror (mevaln (cdr form))))
780      (errlfun1 mcatch))))
781
782(defmfun $throw (exp)
783  (if (null mcatch) (merror (intl:gettext "throw: not within 'catch'; expression: ~M") exp))
784  (throw 'mcatch exp))
785
786(defmspec $time (l)
787  (setq l (cdr l))
788  (cons '(mlist simp)
789	(mapcar
790	 #'(lambda (x)
791	     (or (and (symbolp x)
792		      (setq x (get x 'time))
793		      (if (= (cdr x) 0)
794			  (car x)
795			  (list '(mlist simp) (car x) (cdr x))))
796		 '$unknown))
797	 l)))
798
799(defun timeorg (tim)
800  (if (> thistime 0)
801      (incf thistime (- (get-internal-run-time) tim))))
802
803
804(defmfun $quit ()
805  (princ *maxima-epilog*)
806  (bye)
807  (mtell (intl:gettext "quit: No known quit function for this Lisp.~%")))
808
809;; File-processing stuff.
810
811(defun mterpri ()
812   (terpri)
813   (finish-output))
814
815(defmspec $status (form)
816  (setq form (cdr form))
817  (let* ((keyword (car form))
818         (feature (cadr form)))
819    (when (not (symbolp keyword))
820      (merror (intl:gettext "status: first argument must be a symbol; found: ~M") keyword))
821    (when (not (or (stringp feature) (symbolp feature)))
822      (merror
823        (intl:gettext "status: second argument must be symbol or a string; found: ~M") feature))
824    (case keyword
825      ($feature (cond ((null feature) (dollarify *features*))
826                      ((member (intern (if (stringp feature)
827                                           (maybe-invert-string-case feature)
828                                           (symbol-name (fullstrip1 feature)))
829                                       'keyword)
830                               *features* :test #'equal) t)))
831      (t (merror (intl:gettext "status: unknown argument: ~M") keyword)))))
832
833(defquote $sstatus (keyword item)
834  (cond ((equal keyword '$feature)
835         (pushnew ($mkey item) *features*) t)
836        ((equal keyword '$nofeature)
837         (setq *features* (delete ($mkey item) *features*)) t)
838        (t
839         (merror (intl:gettext "sstatus: unknown argument: ~M") keyword))))
840
841(dolist (l '($sin $cos $tan $log $plog $sec $csc $cot $sinh $cosh
842	     $tanh $sech $csch $coth $asin $acos $atan $acot $acsc $asec $asinh
843	     $acosh $atanh $acsch $asech $acoth $binomial $gamma $genfact $del))
844  (let ((x ($nounify l)))
845    (putprop l x 'alias)
846    (putprop x l 'reversealias)))
847
848($nounify '$sum)
849($nounify '$lsum)
850($nounify '$product)
851($nounify '$integrate)
852($nounify '$limit)
853
854(defprop $diff %derivative verb)
855(defprop %derivative $diff noun)
856
857(mapc #'(lambda (x) (putprop (car x) (cadr x) 'assign))
858      '(($debugmode debugmode1)
859	($fpprec fpprec1) ($poislim poislim1)
860	($default_let_rule_package let-rule-setter)
861	($current_let_rule_package let-rule-setter)
862	($let_rule_packages let-rule-setter)))
863
864(mapc #'(lambda (x) (putprop x 'neverset 'assign)) (cdr $infolists))
865
866(defprop $contexts neverset assign)
867
868(eval-when
869    #+gcl (compile eval)
870    #-gcl (:compile-toplevel :execute)
871    (setq *print-base* old-base *read-base* old-ibase))
872