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 makelabel (x)
 100   (setq *linelabel* ($concat '|| x $linenum))
 101   (unless $nolabels
 102     (when (or (null (cdr $labels))
 103               (when (member *linelabel* (cddr $labels) :test #'equal)
 104                 (setf $labels (delete *linelabel* $labels :count 1 :test #'eq)) t)
 105               (not (eq *linelabel* (cadr $labels))))
 106       (setq $labels (cons (car $labels) (cons *linelabel* (cdr $labels))))))
 107   *linelabel*)
 108
 109 (defun printlabel ()
 110   (mtell-open "(~A) " (subseq (print-invert-case *linelabel*) 1)))
 111
 112 (defun mexploden (x)
 113   (let (*print-radix*
 114         (*print-base* 10))
 115     (exploden x)))
 116
 117 (defun addlabel (label)
 118   (setq $labels (cons (car $labels) (cons label (delete label (cdr $labels) :count 1 :test #'eq)))))
 119
 120 (defun tyi* ()
 121   (clear-input)
 122   (do ((n (tyi) (tyi))) (nil)
 123     (cond ((or (char= n #\newline) (and (> (char-code n) 31) (char/= n #\rubout)))
 124            (return n))
 125           ((char= n #\page) (format t "~|") (throw 'retry nil)))))
 126
 127 (defun continuep ()
 128   (loop
 129    (catch 'retry
 130      (unwind-protect
 131           (progn
 132             (fresh-line)
 133             (princ (break-prompt))
 134             (finish-output)
 135             (return (char= (tyi*) #\newline)))
 136        (clear-input)))))
 137
 138 (defun checklabel (x)   ; CHECKLABEL returns T iff label is not in use
 139   (not (or $nolabels
 140            (= $linenum 0)
 141            (boundp ($concat '|| x $linenum)))))
 142
 143 (defun gctimep (timep tim)
 144   (cond ((and (eq timep '$all) (not (zerop tim))) (princ (intl:gettext "Total time = ")) t)
 145         (t (princ (intl:gettext "Time = ")) nil)))
 146
 147 ; Following GENERIC-AUTOLOAD is copied from orthopoly/orthopoly-init.lisp.
 148 ; Previous version didn't take Clisp, CMUCL, or SBCL into account.
 149
 150 (defvar *autoloaded-files* ())
 151
 152 (defun generic-autoload (file &aux type)
 153   (unless (member file *autoloaded-files* :test #'equal)
 154     (push file *autoloaded-files*)
 155     (setq file (pathname (cdr file)))
 156     (setq type (pathname-type file))
 157     (let ((bin-ext #+gcl "o"
 158                    #+cmu (c::backend-fasl-file-type c::*target-backend*)
 159                    #+clisp "fas"
 160                    #+allegro "fasl"
 161                    #+openmcl (pathname-type ccl::*.fasl-pathname*)
 162                    #+lispworks (pathname-type (compile-file-pathname "foo.lisp"))
 163                    #-(or gcl cmu clisp allegro openmcl lispworks) ""))
 164       (if (member type (list bin-ext "lisp" "lsp")  :test 'equalp)
 165           (let ((*read-base* 10.)) #-sbcl (load file) #+sbcl (with-compilation-unit nil (load file)))
 166           ($load file)))))
 167
 168 (defvar autoload 'generic-autoload)
 169
 170 (defun load-function (func mexprp)      ; The dynamic loader
 171   (declare (ignore mexprp))
 172   (let ((file (get func 'autoload)))
 173     (if file (funcall autoload (cons func file)))))
 174
 175 (defmspec $loadfile (form)
 176   (loadfile (namestring (maxima-string (meval (cadr form)))) nil
 177             (not (member $loadprint '(nil $autoload) :test #'equal))))
 178
 179 (defmfun $setup_autoload (filename &rest functions)
 180   (let ((file ($file_search filename)))
 181     (dolist (func functions)
 182       (nonsymchk func '$setup_autoload)
 183       (putprop (setq func ($verbify func)) file 'autoload)
 184       (add2lnc func $props)))
 185   '$done)
 186
 187 (defun dollarify (l)
 188   (let ((errset t))
 189     (cons '(mlist simp)
 190           (mapcar #'(lambda (x)
 191                       (let (y)
 192                         (cond ((numberp x) x)
 193                               ((numberp (setq y (car (errset (readlist (mexploden x))))))
 194                                y)
 195                               (t (makealias x)))))
 196                   l))))
 197
 198 (defun mfboundp (func)
 199   (or (mgetl func '(mexpr mmacro))
 200       (getl func '(translated-mmacro mfexpr* mfexpr*s))))
 201
 202 (defun loadfile (file findp printp)
 203   (and findp (member $loadprint '(nil $loadfile) :test #'equal) (setq printp nil))
 204   ;; Should really get the truename of FILE.
 205   (if printp (format t (intl:gettext "loadfile: loading ~A.~%") file))
 206   (let* ((path (pathname file))
 207          (*package* (find-package :maxima))
 208          ($load_pathname path)
 209          (*read-base* 10.)
 210          (tem (errset #-sbcl (load (pathname file)) #+sbcl (with-compilation-unit nil (load (pathname file))))))
 211     (or tem (merror (intl:gettext "loadfile: failed to load ~A") (namestring path)))
 212     (namestring path)))
 213
 214 (defmfun $directory (path)
 215   (cons '(mlist) (mapcar 'namestring (directory ($filename_merge path)))))
 216
 217 (defmspec $kill (form)
 218   (clear)       ;; get assume db into consistent state
 219   (mapc #'kill1 (cdr form))
 220   '$done)
 221
 222 ;;; The following *builtin- variables are used to keep/restore builtin
 223 ;;; symbols and values during kill operations. Their values are set at
 224 ;;; the end of init-cl.lisp, after all symbols have been defined.
 225
 226 (defvar *builtin-symbols* nil)
 227 (defvar *builtin-symbol-props* (make-hash-table))
 228 (defvar *builtin-$props* nil)
 229 (defvar *builtin-$rules* nil)
 230 (defvar *builtin-symbols-with-values* nil)
 231 (defvar *builtin-symbol-values* (make-hash-table))
 232 (defvar *builtin-numeric-constants* '($%e $%pi $%phi $%gamma))
 233
 234 (defun kill1-atom (x)
 235   (let ((z (or (and (member x (cdr $aliases) :test #'equal) (get x 'noun)) (get x 'verb))))
 236     (when (or (null allbutl) (not (member z allbutl :test #'equal)))
 237       (remvalue x '$kill)
 238       (mget x 'array)
 239       (remcompary x)
 240       (when (member x (cdr $contexts) :test #'equal)
 241         ($killcontext x))
 242       (when (mget x '$rule)
 243         (let ((y (ruleof x)))
 244           (cond (y ($remrule y x))
 245                 (t (when (not (member x *builtin-$rules* :test #'equal))
 246                      (fmakunbound x)
 247                      (setf $rules (delete x $rules :count 1 :test #'eq)))))))
 248       (when (and (get x 'operators) (rulechk x))
 249         ($remrule x '$all))
 250       (when (mget x 'trace)
 251         (macsyma-untrace x))
 252       (when (get x 'translated)
 253         (when (not (member x *builtin-symbols* :test #'equal))
 254                          (remove-transl-fun-props x)
 255                          (remove-transl-array-fun-props x)))
 256       (when (not (get x 'sysconst))
 257         (remprop x 'lineinfo)
 258         (remprop x 'mprops))
 259       (dolist (u '(bindtest nonarray evfun evflag opers special mode))
 260         (remprop x u))
 261       (dolist (u opers)
 262         (when (and (remprop x u)
 263                  (let ((xopval (get x 'operators)))
 264                    (or (eq xopval 'simpargs1) (eq xopval nil))))
 265             (remprop x 'operators)))
 266       (when (member x (cdr $props) :test #'equal)
 267         (remprop x 'sp2)
 268         (killframe x)
 269         (i-$remove (list x $features)))
 270       (let ((y (get x 'op)))
 271         (when (and y
 272                    (not (member y *mopl* :test #'equal))
 273                    (member y (cdr $props) :test #'equal))
 274           (kill-operator x)))
 275       (remalias x nil)
 276       (setf $arrays (delete x $arrays :count 1 :test #'eq))
 277       (rempropchk x)
 278       (setf *autoloaded-files*
 279             (delete (assoc x *autoloaded-files* :test #'eq) *autoloaded-files* :count 1 :test #'equal))
 280       (setf $functions
 281             (delete (assoc (ncons x) $functions :test #'equal) $functions :count 1 :test #'equal))
 282       (setf $macros
 283             (delete (assoc (ncons x) $macros :test #'equal) $macros :count 1 :test #'equal))
 284       (let ((y (assoc (ncons x) $gradefs :test #'equal)))
 285         (when y
 286           (remprop x 'grad)
 287           (setf $gradefs (delete y $gradefs :count 1 :test #'equal))))
 288       (setf $dependencies
 289             (delete (assoc (ncons x) $dependencies :test #'equal) $dependencies :count 1 :test #'equal))
 290       (let ((y (assoc-if #'(lambda (e) (equal x (car e))) (cdr $structures))))
 291         (when y
 292           (remprop x 'dimension)
 293           (remprop x 'defstruct-template)
 294           (remprop x 'defstruct-default)
 295           (remprop x 'translate)
 296           (setf $structures (delete y $structures :count 1 :test #'equal))))
 297       (when (and (member x *builtin-symbols* :test #'equal)
 298                  (gethash x *builtin-symbol-props*))
 299         (setf (symbol-plist x)
 300               (copy-tree (gethash x *builtin-symbol-props*))))
 301       (when (member x *builtin-numeric-constants*)
 302         (initialize-numeric-constant x))        ;; reset db value for $%pi, $%e, etc
 303       (if z (kill1 z)))))
 304
 305 (defun kill1 (x)
 306   (if (and (stringp x) (not (getopr0 x))) (return-from kill1 nil))
 307   (funcall
 308    #'(lambda (z)
 309        (cond ((and allbutl (member x allbutl :test #'equal)))
 310              ((eq (setq x (getopr x)) '$labels)
 311               (dolist (u (cdr $labels))
 312                 (cond ((and allbutl (member u allbutl :test #'equal))
 313                        (setq z (nconc z (ncons u))))
 314                       (t (makunbound u) (remprop u 'time)
 315                          (remprop u 'nodisp))))
 316               (setq $labels (cons '(mlist simp) z) $linenum 0))
 317              ((member x '($values $arrays $aliases $rules $props
 318                         $let_rule_packages) :test #'equal)
 319               (mapc #'kill1 (cdr (symbol-value x))))
 320              ((member x '($functions $macros $gradefs $dependencies $structures) :test #'equal)
 321               (mapc #'(lambda (y) (kill1 (caar y))) (cdr (symbol-value x))))
 322              ((eq x '$myoptions))
 323              ((eq x '$tellrats) (setq tellratlist nil))
 324              ((eq x '$ratvars) (setq $ratvars '((mlist simp)) varlist 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          (merror (intl:gettext "alias: ~M already has an alias.") x))
 538         (t (putprop x y'alias)
 539            (putprop y x 'reversealias)
 540            (add2lnc y $aliases)
 541            y)))
 542
 543 (defun remalias (x &optional remp)
 544   (let ((y (and (or remp (member x (cdr $aliases) :test #'equal)) (get x 'reversealias))))
 545     (cond ((and y (eq x '%derivative))
 546            (remprop x 'reversealias)
 547            (setf $aliases (delete x $aliases :count 1 :test #'eq))
 548            (remprop '$diff 'alias) '$diff)
 549           (y (remprop x 'reversealias)
 550              (remprop x 'noun)
 551              (setf $aliases (delete x $aliases :count 1 :test #'eq))
 552              (remprop (setq x y) 'alias) (remprop x 'verb) x))))
 553
 554 (defun stripdollar (x)
 555   (cond ((not (atom x))
 556          (cond ((and (eq (caar x) 'bigfloat) (not (minusp (cadr x)))) (implode (fpformat x)))
 557                (t (merror (intl:gettext "STRIPDOLLAR: argument must be an atom; found: ~M") x))))
 558         ((numberp x) x)
 559         ((null x) 'false)
 560         ((eq x t) 'true)
 561         ((member (get-first-char x) '(#\$ #\%) :test #'char=)
 562          (intern (subseq (string x) 1)))
 563         (t x)))
 564
 565 (defun fullstrip (x)
 566   (mapcar #'fullstrip1 x))
 567
 568 (defun fullstrip1 (x)
 569   (or (and (numberp x) x)
 570       (let ((y (get x 'reversealias))) (if y (stripdollar y)))
 571       (stripdollar x)))
 572
 573 (defun string* (x)
 574   (or (and (numberp x) (exploden x))
 575       (string*1 x)))
 576
 577 (defun string*1 (x)
 578   (let ($stringdisp $lispdisp)
 579     (makestring x)))
 580
 581 ;;; Note that this function had originally stripped a prefix of '|M|.  This
 582 ;;; was intended for operators such as 'MABS, but with the case flipping
 583 ;;; performed by explodec this test would always fail.  Dependent code has
 584 ;;; been written assuming the '|M| prefix is not stripped so this test has
 585 ;;; been disabled for now.
 586 ;;;
 587 (defmfun $nounify (x)
 588   (if (not (or (symbolp x) (stringp x)))
 589     (merror (intl:gettext "nounify: argument must be a symbol or a string; found: ~M") x))
 590   (setq x (amperchk x))
 591   (cond ((get x 'verb))
 592         ((get x 'noun) x)
 593         (t
 594          (let* ((y (explodec x))
 595                 (u #+nil (member (car y) '($ |M| |m|) :test 'eq)
 596                    (eq (car y) '$)))
 597            (cond ((or u (not (eq (car y) '%)))
 598                   (setq y (implode (cons '% (if u (cdr y) y))))
 599                   (putprop y x 'noun) (putprop x y 'verb))
 600                  (t x))))))
 601
 602 (defmfun $verbify (x)
 603   (if (not (or (symbolp x) (stringp x)))
 604     (merror (intl:gettext "verbify: argument must be a symbol or a string; found: ~M") x))
 605   (setq x (amperchk x))
 606   (cond ((get x 'noun))
 607         ((eq x '||) x)
 608         ((and (char= (char (symbol-name x) 0) #\%)
 609               (prog2
 610                   ($nounify (implode (cons #\$ (cdr (exploden x)))))
 611                   (get x 'noun))))
 612         (t x)))
 613
 614 (defmspec $string (form)
 615   (let (($lispdisp t))
 616     (setq form (strmeval (fexprcheck form)))
 617     (setq form (if $grind (strgrind form) (mstring form)))
 618     (coerce form 'string)))
 619
 620 (defun makstring (x)
 621   (setq x (mstring x))
 622   (do ((l x (cdr l)))
 623       ((null l))
 624     (rplaca l (ascii (car l))))
 625   x)
 626
 627 (defun strmeval (x)
 628   (cond ((atom x) (meval1 x))
 629         ((member (caar x) '(msetq mdefine mdefmacro) :test #'equal) x)
 630         (t (meval x))))
 631
 632
 633 (mapc #'(lambda (x) (putprop (car x) (cadr x) 'alias)
 634                 (putprop (cadr x) (car x) 'reversealias))
 635       '(($block mprog) ($lambda lambda)
 636         ($subst $substitute)
 637         ($go mgo) ($signum %signum)
 638         ($return mreturn) ($factorial mfactorial)
 639         ($ibase *read-base*) ($obase *print-base*)
 640         ($modulus modulus)
 641         ($mode_declare $modedeclare)))
 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 (defmspec $errcatch (form)
 778   (let ((errcatch (cons bindlist loclist))
 779         (*mdebug* nil))
 780     (handler-case (list '(mlist) (with-errcatch-tag-$errors (mevaln (cdr form))))
 781       (maxima-$error ()
 782         ; If this was signaled by MERROR, then it has already handled
 783         ; the setting of the error variable and the printing of any error
 784         ; messages (as applicable).
 785         ;
 786         ; If for some reason this wasn't signaled by MERROR, then it's the
 787         ; signaler's responsibility to handle error messages.
 788         ;
 789         ; Either way, we just need to clean up here.
 790         (errlfun1 errcatch)
 791         (list '(mlist simp)))
 792       (error (e)
 793         ; We store the error report message in the error variable and
 794         ; print the message if errormsg is true.  Then we clean up.
 795         (setq $error (list '(mlist simp) (princ-to-string e)))
 796         (when $errormsg
 797           ($errormsg))
 798         (errlfun1 errcatch)
 799         (list '(mlist simp))))))
 800
 801 (defmspec $catch (form)
 802   (let ((mcatch (cons bindlist loclist)))
 803     (prog1
 804         (catch 'mcatch (rat-error-to-merror (mevaln (cdr form))))
 805       (errlfun1 mcatch))))
 806
 807 (defmfun $throw (exp)
 808   (if (null mcatch) (merror (intl:gettext "throw: not within 'catch'; expression: ~M") exp))
 809   (throw 'mcatch exp))
 810
 811 (defmspec $time (l)
 812   (setq l (cdr l))
 813   (cons '(mlist simp)
 814         (mapcar
 815          #'(lambda (x)
 816              (or (and (symbolp x)
 817                       (setq x (get x 'time))
 818                       (if (= (cdr x) 0)
 819                           (car x)
 820                           (list '(mlist simp) (car x) (cdr x))))
 821                  '$unknown))
 822          l)))
 823
 824 (defun timeorg (tim)
 825   (if (> thistime 0)
 826       (incf thistime (- (get-internal-run-time) tim))))
 827
 828
 829 (defmfun $quit ()
 830   (princ *maxima-epilog*)
 831   (bye)
 832   (mtell (intl:gettext "quit: No known quit function for this Lisp.~%")))
 833
 834 ;; File-processing stuff.
 835
 836 (defun mterpri ()
 837    (terpri)
 838    (finish-output))
 839
 840 (defmspec $status (form)
 841   (setq form (cdr form))
 842   (let* ((keyword (car form))
 843          (feature (cadr form)))
 844     (when (not (symbolp keyword))
 845       (merror (intl:gettext "status: first argument must be a symbol; found: ~M") keyword))
 846     (when (not (or (stringp feature) (symbolp feature)))
 847       (merror
 848         (intl:gettext "status: second argument must be symbol or a string; found: ~M") feature))
 849     (case keyword
 850       ($feature (cond ((null feature) (dollarify *features*))
 851                       ((member (intern (if (stringp feature)
 852                                            (maybe-invert-string-case feature)
 853                                            (symbol-name (fullstrip1 feature)))
 854                                        'keyword)
 855                                *features* :test #'equal) t)))
 856       (t (merror (intl:gettext "status: unknown argument: ~M") keyword)))))
 857
 858 (defquote $sstatus (keyword item)
 859   (cond ((equal keyword '$feature)
 860          (pushnew ($mkey item) *features*) t)
 861         ((equal keyword '$nofeature)
 862          (setq *features* (delete ($mkey item) *features*)) t)
 863         (t
 864          (merror (intl:gettext "sstatus: unknown argument: ~M") keyword))))
 865
 866 (dolist (l '($sin $cos $tan $log $plog $sec $csc $cot $sinh $cosh
 867              $tanh $sech $csch $coth $asin $acos $atan $acot $acsc $asec $asinh
 868              $acosh $atanh $acsch $asech $acoth $binomial $gamma $genfact $del))
 869   (let ((x ($nounify l)))
 870     (putprop l x 'alias)
 871     (putprop x l 'reversealias)))
 872
 873 ($nounify '$sum)
 874 ($nounify '$lsum)
 875 ($nounify '$product)
 876 ($nounify '$integrate)
 877 ($nounify '$limit)
 878
 879 (defprop $diff %derivative verb)
 880 (defprop %derivative $diff noun)
 881
 882 (mapc #'(lambda (x) (putprop (car x) (cadr x) 'assign))
 883       '(($debugmode debugmode1)
 884         ($fpprec fpprec1) ($poislim poislim1)
 885         ($default_let_rule_package let-rule-setter)
 886         ($current_let_rule_package let-rule-setter)
 887         ($let_rule_packages let-rule-setter)))
 888
 889 (mapc #'(lambda (x) (putprop x 'neverset 'assign)) (cdr $infolists))
 890
 891 (defprop $contexts neverset assign)
 892
 893 (eval-when
 894     #+gcl (compile eval)
 895     #-gcl (:compile-toplevel :execute)
 896     (setq *print-base* old-base *read-base* old-ibase))