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