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