src/suprv1.lisp

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