src/macsys.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 ;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **
  10 ;;;
  11 ;;; SYSTEM: The ``New'' Macsyma System Stuff
  12
  13 (in-package :maxima)
  14
  15 (macsyma-module system)
  16
  17 ;;; Standard Kinds of Input Prompts
  18
  19 (defmvar $prompt '_
  20   "Prompt symbol of the demo function, playback, and the Maxima break loop.")
  21
  22
  23 ;; A prefix and suffix that are wrapped around every prompt that Maxima
  24 ;; emits. This is designed for use with text-based interfaces that drive Maxima
  25 ;; through standard input and output and need to decorate prompts to make the
  26 ;; output easier to parse. There are some more notes in
  27 ;; doc/implementation/external-interface.txt.
  28 (defvar *prompt-prefix* "")
  29 (defvar *prompt-suffix* "")
  30 (defvar *general-display-prefix* "")
  31 (defvar $alt_format_prompt nil "If NIL, use DEFAULT-FORMAT-PROMPT to print input prompt; if a function, use it to print input prompt.")
  32
  33 (defun format-prompt (destination control-string &rest arguments)
  34   "If $ALT_FORMAT_PROMPT is NIL, use DEFAULT-FORMAT-PROMPT to print
  35 prompt; otherwise MFUNCALL $ALT_FORMAT_PROMPT to print prompt."
  36   (funcall (if $alt_format_prompt #'alt-format-prompt #'default-format-prompt)
  37            destination control-string arguments))
  38
  39 (defun alt-format-prompt (destination control-string arguments)
  40   "MFUNCALL $ALT_FORMAT_PROMPT with a heavy coating of error protection."
  41   (handler-bind ((error (lambda(msg) (setq $alt_format_prompt nil)
  42                                (format t (intl:gettext "Error in printing prompt; reverting to default.~%~a") msg)
  43                                (throw 'macsyma-quit 'maxima-error))))
  44     (with-$error (let ((prompt (mfuncall $alt_format_prompt destination control-string arguments)))
  45                    (if (stringp prompt) prompt (merror "alt_format_prompt returned an object of type ~a, needed a string." (type-of prompt)))))))
  46
  47 (defun default-format-prompt (destination control-string arguments)
  48   "Like AFORMAT, but add the prefix and suffix configured for a prompt. This
  49 function deals correctly with the ~M control character, but only when
  50 DESTINATION is an actual stream (rather than nil for a string)."
  51   (let ((*print-circle* nil) (*print-base* 10.) *print-radix*)
  52     (if (null destination)
  53         ;; return value string is important
  54         (concatenate 'string
  55                      *prompt-prefix*
  56                      (apply #'aformat destination
  57                             control-string
  58                             arguments)
  59                      *prompt-suffix*)
  60       (progn
  61         (format destination "~A~A~A"
  62                 *prompt-prefix*
  63                 (apply #'aformat nil
  64                        control-string
  65                        arguments)
  66                 *prompt-suffix*)))))
  67
  68
  69 (defvar $default_format_prompt (symbol-function 'default-format-prompt))
  70
  71 ;;  "When time began" (or at least the start of version control history),
  72 ;;  the following comment was made at this point:
  73 ;;
  74 ;;     instead of using this STRIPDOLLAR hackery, the
  75 ;;     MREAD function should call MFORMAT to print the prompt,
  76 ;;     and take a format string and format arguments.
  77 ;;     Even easier and more general is for MREAD to take
  78 ;;     a FUNARG as the prompt. -gjc
  79 ;;
  80 ;;  I guess we're still failing miserably, but unfortunately MFORMAT/AFORMAT
  81 ;;  don't deal correctly with ~M plus a string output stream.
  82 (defun main-prompt ()
  83   (if *display-labels-p*
  84       (format-prompt nil "(~A~A) "
  85                      (print-invert-case (stripdollar $inchar))
  86                      $linenum)
  87       ""))
  88
  89 (defun break-prompt ()
  90   (format-prompt nil "~A"
  91                  (print-invert-case (stripdollar $prompt))))
  92
  93 (defun toplevel-macsyma-eval (x)
  94   ;; Catch rat-err's here.
  95   ;;
  96   ;; The idea is that eventually there will be quite a few "maybe catch this"
  97   ;; errors, which will be raised and might well get eaten before they get as far
  98   ;; as here. However, we want to display them nicely like merror rather than
  99   ;; letting a lisp error percolate to the debugger and, as such, we catch them
 100   ;; here and replace them with an merror call.
 101   ;;
 102   ;; Other random errors get to the lisp debugger, which is normally set to print
 103   ;; them and continue, via *debugger-hook*.
 104   (rat-error-to-merror (meval* x)))
 105
 106 (declare-top (special *mread-prompt*))
 107
 108 (defvar accumulated-time 0.0)
 109
 110 #+(or cmu scl)
 111 (defun used-area (&optional unused)
 112   (declare (ignore unused))
 113   (ext:get-bytes-consed))
 114
 115 #+sbcl
 116 (defun used-area (&optional unused)
 117   (declare (ignore unused))
 118   (sb-ext:get-bytes-consed))
 119
 120 #+openmcl
 121 (defun used-area (&optional unused)
 122   (declare (ignore unused))
 123   (ccl::total-bytes-allocated))
 124
 125 #+clisp
 126 (defun used-area (&optional unused)
 127   (declare (ignore unused))
 128   (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)
 129       (sys::%%time)
 130     (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
 131     (dpb space1 (byte 24 24) space2)))
 132
 133
 134 #+allegro
 135 (defun used-area (&optional unused)
 136   (declare (ignore unused))
 137   (declare (optimize (speed 3)))
 138   (let ((.oldspace (make-array 4 :element-type
 139                                #-64bit '(unsigned-byte 32)
 140                                #+64bit '(unsigned-byte 64))))
 141     (declare (type (simple-array #-64bit (unsigned-byte 32)
 142                                  #+64bit (unsigned-byte 64) (*))
 143                    .oldspace))
 144
 145     (multiple-value-bind (.olduser .oldsystem .oldgcu .oldgcs)
 146         (excl::get-internal-run-times)
 147       (declare (ignore .olduser .oldsystem .oldgcs))
 148       (sys::gsgc-totalloc .oldspace t)
 149       (list (aref .oldspace 0) (aref .oldspace 2) .oldgcu)))) ;; report just two kinds of space,
 150                                                               ;; cons-cells and other bytes,
 151                                                               ;; also report gc-user time
 152
 153 #+lispworks
 154 (defun used-area (&optional unused)
 155   (declare (ignore unused))
 156   (getf (system:room-values) :total-allocated))
 157
 158 #-(or cmu scl sbcl clisp allegro openmcl lispworks)
 159 (defun used-area (&optional unused)
 160   (declare (ignore unused))
 161   0)
 162
 163 (defun continue (&key ((:stream input-stream) *standard-input*) batch-or-demo-flag one-shot)
 164   (declare (special *socket-connection* *maxima-run-string*))
 165   (if *maxima-run-string* (setq batch-or-demo-flag :batch))
 166   (if (eql batch-or-demo-flag :demo)
 167       (format t
 168         (intl:gettext
 169           "~%At the '~A' prompt, type ';' and <enter> to proceed with the demonstration.~&To abort the demonstration, type 'end;' or 'eof;' and then <enter>.~%")
 170         (print-invert-case (stripdollar $prompt))))
 171   (catch 'abort-demo
 172     (do ((r)
 173          (time-before)
 174          (time-after)
 175          (time-used)
 176          (eof (list nil))
 177          (etime-before)
 178          (etime-after)
 179          (area-before)
 180          (area-after)
 181          (etime-used)
 182          (c-tag)
 183          (d-tag)
 184          (finish nil one-shot))
 185         (finish nil)
 186       (declare (ignorable area-before area-after))
 187       (catch 'return-from-debugger
 188         (when (or (not (checklabel $inchar))
 189                   (not (checklabel $outchar)))
 190           (incf $linenum))
 191         (setq c-tag (makelabel $inchar))
 192         (let ((*mread-prompt* (if batch-or-demo-flag nil (main-prompt)))
 193               (eof-count 0))
 194           (tagbody
 195            top
 196              (setq r (dbm-read input-stream nil eof))
 197              ;; This is something of a hack. If we are running in a server mode
 198              ;; (which we determine by checking *socket-connection*) and we get
 199              ;; an eof on an input-stream that is not *standard-input*, switch
 200              ;; the input stream to *standard-input*.
 201              ;; There should probably be a better scheme for server mode.
 202              ;; jfa 10/09/2002.
 203              (if (and
 204                   (eq r eof)
 205                   (not (eq input-stream *standard-input*))
 206                   (boundp '*socket-connection*))
 207                  (progn
 208                    (setq input-stream *standard-input*)
 209                    (if batch-or-demo-flag
 210                        (return '$done)
 211                        (progn
 212                          (setq *mread-prompt* nil)
 213                          (setq r (dbm-read input-stream nil eof))))))
 214
 215              (cond ((and (eq r eof) (boundp '*socket-connection*)
 216                          (eq input-stream *socket-connection*))
 217                     (cond ((>=  (setq eof-count (+ 1 eof-count)) 10)
 218                            (print "exiting on eof")
 219                            ($quit))
 220                           (t (go top)))))
 221              (cond ((and (consp r) (keywordp (car r)))
 222                     (break-call (car r) (cdr r) 'break-command)
 223                     #+(or sbcl cmu)
 224                     (if (and (not batch-or-demo-flag)
 225                              (not (eq input-stream *standard-input*)))
 226                         (setq input-stream *standard-input*))
 227                     (go top)))))
 228         (format t "~a" *general-display-prefix*)
 229         (if (eq r eof) (return '$done))
 230         (setq $__ (caddr r))
 231         (unless $nolabels (setf (symbol-value c-tag) $__))
 232         (cond (batch-or-demo-flag
 233           (let (($display2d nil))
 234             (displa `((mlabel) ,c-tag , $__)))))
 235         (setq time-before (get-internal-run-time)
 236               etime-before (get-internal-real-time))
 237         (setq area-before (used-area))
 238         (setq $% (toplevel-macsyma-eval $__))
 239         #+(or sbcl cmu)
 240         (if (and (not batch-or-demo-flag)
 241                  (not (eq input-stream *standard-input*)))
 242             (setq input-stream *standard-input*))
 243         (setq etime-after (get-internal-real-time)
 244               time-after (get-internal-run-time))
 245         (setq area-after (used-area))
 246         (setq time-used (quotient
 247                          (float (- time-after time-before))
 248                          internal-time-units-per-second)
 249               etime-used (quotient
 250                           (float (- etime-after etime-before))
 251                           internal-time-units-per-second))
 252         (incf accumulated-time time-used)
 253         (setq d-tag (makelabel $outchar))
 254         (unless $nolabels (setf (symbol-value d-tag) $%))
 255         (setq $_ $__)
 256         (when $showtime ;; we don't distinguish showtime:all?? /RJF
 257           (format t (intl:gettext "Evaluation took ~,4F seconds (~,4F elapsed)")
 258                   time-used etime-used )
 259           #+(or gcl ecl)
 260           (format t "~%")
 261           #+(or cmu scl sbcl clisp openmcl)
 262           (let ((total-bytes (- area-after area-before)))
 263             (cond ((> total-bytes (* 1024 1024))
 264                    (format t (intl:gettext " using ~,3F MB.~%")
 265                            (/ total-bytes (* 1024.0 1024.0))))
 266                   ((> total-bytes 1024)
 267                    (format t (intl:gettext " using ~,3F KB.~%") (/ total-bytes 1024.0)))
 268                   (t
 269                    (format t (intl:gettext " using ~:D bytes.~%") total-bytes))))
 270
 271           #+allegro
 272           (let ((conses (- (car area-after) (car area-before)))
 273                 (other (- (cadr area-after) (cadr area-before)))
 274                 (gctime (- (caddr area-after) (caddr area-before))))
 275             (if (= 0 gctime) nil (format t (intl:gettext " including GC time ~s s,") (* 0.001 gctime)))
 276             (format t (intl:gettext " using ~s cons-cells and ~s other bytes.~%") conses other))
 277           (finish-output))
 278         (unless $nolabels
 279           (putprop '$% (cons time-used 0) 'time)
 280           (putprop d-tag (cons time-used  0) 'time))
 281         (if (eq (caar r) 'displayinput)
 282             (displa `((mlabel) ,d-tag ,$%)))
 283         (when (eq batch-or-demo-flag ':demo)
 284           (princ (break-prompt))
 285           (finish-output)
 286           (let (quitting)
 287             (loop
 288               ;;those are common lisp characters you're reading here
 289               (case (read-char #+(or sbcl cmu) *standard-input*
 290                                #-(or sbcl cmu) *terminal-io*)
 291                 ((#\page)
 292                  (fresh-line)
 293                  (princ (break-prompt))
 294                  (finish-output))
 295                 ((#\?)
 296                  (format t
 297                    (intl:gettext
 298                      "  Pausing. Type a ';' and <enter> to continue demo.~%")))
 299                 ((#\space #\; #\n #\e #\x #\t))
 300                 ((#\newline )
 301                  (if quitting (throw 'abort-demo nil) (return nil)))
 302                 (t (setq quitting t))))))
 303         ;; This is sort of a kludge -- eat newlines and blanks so that
 304         ;; they don't echo
 305         (and batch-or-demo-flag
 306              (do ((char)) (())
 307                (setq char (read-char input-stream nil nil))
 308                (when (null char)
 309                  (when *maxima-run-string*
 310                    (setq batch-or-demo-flag nil
 311                          *maxima-run-string* nil
 312                          input-stream *standard-input*)
 313                    (throw 'return-from-debugger t))
 314                  (throw 'macsyma-quit nil))
 315                (unless (member char '(#\space #\newline #\return #\tab) :test #'equal)
 316                  (unread-char char input-stream)
 317                  (return nil))))))))
 318
 319 (defmfun $break (&rest arg-list)
 320   (prog1 (apply #'$print arg-list)
 321     (mbreak-loop)))
 322
 323 (defun mbreak-loop ()
 324   (let ((*standard-input* *debug-io*)
 325         (*standard-output* *debug-io*))
 326     (catch 'break-exit
 327       (format t (intl:gettext "~%Entering a Maxima break point. Type 'exit;' to resume."))
 328       (do ((r)) (nil)
 329         (fresh-line)
 330         (setq r (caddr (let ((*mread-prompt* (break-prompt)))
 331                          (mread *standard-input*))))
 332         (case r
 333           (($exit) (throw 'break-exit t))
 334           (t (errset (displa (meval r)))))))))
 335
 336 (defun merrbreak (&optional arg)
 337   (format *debug-io* "~%Merrbreak:~A" arg)
 338   (mbreak-loop))
 339
 340 (defun retrieve (msg flag &aux (print? nil))
 341   (declare (special msg flag print?))
 342   (or (eq flag 'noprint) (setq print? t))
 343   (cond ((not print?)
 344          (setq print? t)
 345          (format-prompt *query-io* ""))
 346         ((null msg)
 347          (format-prompt *query-io* ""))
 348         ((atom msg)
 349          (format-prompt *query-io* "~A" msg)
 350          (mterpri *query-io*))
 351         ((eq flag t)
 352          (format-prompt *query-io* "~{~A~}" (cdr msg))
 353          (mterpri *query-io*))
 354         (t
 355          (format-prompt *query-io* "~M" msg)
 356          (mterpri *query-io*)))
 357   (let ((res (mread-noprompt *query-io* nil)))
 358     (princ *general-display-prefix* *query-io*)
 359     (if (null res) (merror "RETRIEVE: End of file encountered.")
 360         res)))
 361
 362 (defmfun $eval_string_lisp (string)
 363   (unless (stringp string)
 364     (merror (intl:gettext "eval_string_lisp: Expected a string, got ~M.") string))
 365   (let ((eof (cons 0 0)))
 366     (with-input-from-string (s string)
 367       ; We do some consing for each form, but I think that'll be OK
 368       (do ((input (read s nil eof) (read s nil eof))
 369            (values nil (multiple-value-list (eval input))))
 370           ((eq input eof)
 371            ; Mark the list as simplified
 372            (cons (list 'mlist 'simp) values))))))
 373
 374 (defmfun $read (&rest l)
 375   (meval (apply #'$readonly l)))
 376
 377 (defmfun $readonly (&rest l)
 378   (let ((*mread-prompt*
 379          (if l
 380              (string-right-trim '(#\n)
 381                                 (with-output-to-string (*standard-output*) (apply #'$print l)))
 382              "")))
 383     (setf *mread-prompt* (format-prompt nil "~A" *mread-prompt*))
 384     (third (mread #+(or sbcl cmu) *standard-input*
 385                   #-(or sbcl cmu) *query-io*))))
 386
 387 ;; FUNCTION BATCH APPARENTLY NEVER CALLED. OMIT FROM GETTEXT SWEEP AND DELETE IT EVENTUALLY
 388 (defun batch (filename &optional demo-p
 389               &aux (orig filename) list
 390               file-obj (accumulated-time 0.0) (abortp t))
 391   (setq list (if demo-p '$file_search_demo '$file_search_maxima))
 392   (setq filename ($file_search filename (symbol-value list)))
 393   (or filename (merror "Could not find ~M in ~M: ~M"
 394                        orig list (symbol-value list)))
 395
 396   (unwind-protect
 397        (progn (batch-internal (setq file-obj (open filename)) demo-p)
 398               (setq abortp nil)
 399               (when $showtime
 400                 (format t "~&Batch spent ~,4F seconds in evaluation.~%"
 401                         accumulated-time)))
 402     (if file-obj (close file-obj))
 403     (when abortp (format t "~&(Batch of ~A aborted.)~%" filename))))
 404
 405
 406 (defun batch-internal (fileobj demo-p)
 407   (continue :stream (make-echo-stream fileobj *standard-output*)
 408             :batch-or-demo-flag (if demo-p ':demo ':batch)))
 409
 410 (defmfun $demo (filename)
 411   (let ((tem ($file_search filename $file_search_demo)))
 412     (or tem (merror (intl:gettext "demo: could not find ~M in ~M.")
 413                     filename '$file_search_demo))
 414     ($batch tem '$demo)))
 415
 416 (defmfun $bug_report ()
 417   (if $maxima_frontend
 418       (format t (intl:gettext
 419                  "~%Please report bugs in maxima, the tool that does the actual maths, to:~%"))
 420       (format t (intl:gettext "~%Please report bugs to:~%")))
 421   (format t "    https://sourceforge.net/p/maxima/bugs~%")
 422   (format t (intl:gettext "To report a bug, you must have a Sourceforge account.~%"))
 423   (if $maxima_frontend
 424       (progn
 425         (format t
 426                 (intl:gettext
 427                  "~%Bugs affecting UI and display should be reported to the frontend's homepage.~%")
 428                 (if $maxima_frontend_bugreportinfo
 429                     (format t (intl:gettext "The front end provides the following info:~%~a~%")
 430                             $maxima_frontend_bugreportinfo)
 431                     (format t (intl:gettext
 432                                "The front end doesn't provide any additional bug report info.~%"))
 433                     ))))
 434   (format t (intl:gettext "Please include the following information with your bug report:~%"))
 435   (format t "-------------------------------------------------------------~%")
 436   ; Display the 2D-formatted build information
 437   (let (($display2d t))
 438     (displa ($build_info)))
 439   (format t "-------------------------------------------------------------~%")
 440   (format t (intl:gettext "The above information is also reported by the function 'build_info()'.~%~%"))
 441   "")
 442
 443 ;; Declare a build_info structure, then remove it from the list of user-defined structures.
 444 (defstruct1 '((%build_info) $version $timestamp $host $lisp_name $lisp_version
 445               $maxima_userdir $maxima_tempdir $maxima_objdir $maxima_frontend $maxima_frontend_version))
 446 (let nil
 447   (setq $structures (cons '(mlist) (remove-if #'(lambda (x) (eq (caar x) '%build_info)) (cdr $structures)))))
 448
 449 (defvar *maxima-build-info* nil)
 450
 451 (defmfun $build_info ()
 452   (or
 453     *maxima-build-info*
 454     (setq
 455       *maxima-build-info*
 456       (let
 457         ((year (sixth cl-user:*maxima-build-time*))
 458          (month (fifth cl-user:*maxima-build-time*))
 459          (day (fourth cl-user:*maxima-build-time*))
 460          (hour (third cl-user:*maxima-build-time*))
 461          (minute (second cl-user:*maxima-build-time*))
 462          (seconds (first cl-user:*maxima-build-time*)))
 463         (mfuncall
 464           '$new
 465           `((%build_info)
 466             ,*autoconf-version*
 467             ,(format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d"
 468                      year month day hour minute seconds)
 469             ,*autoconf-host*
 470             ,(ensure-readably-printable-string (lisp-implementation-type))
 471             ,(ensure-readably-printable-string (lisp-implementation-version))
 472             ,$maxima_userdir
 473             ,$maxima_tempdir
 474             ,$maxima_objdir
 475             ,$maxima_frontend
 476             ,$maxima_frontend_version))))))
 477
 478 ;; SBCL base strings aren't readably printable.  Attempt a work-around
 479 ;; by coercing the string to be an array of characters instead of
 480 ;; base-chars. Yes, this is terribly ugly.  For other Lisps, we can
 481 ;; just return the arg.
 482 (defun ensure-readably-printable-string (x)
 483   #+sbcl
 484   (coerce x '(simple-array character (*)))
 485   #-sbcl
 486   x)
 487
 488 (defun dimension-build-info (form result)
 489   (declare (special bkptht bkptdp lines break))
 490   ;; Usually the result of (MFUNCALL '$@ ...) is a string,
 491   ;; but ensure that output makes sense even if it is not.
 492   (flet ((display-item (item item-label)
 493            (let ((s (format nil
 494                             "~A: ~A"
 495                             (intl:gettext item-label)
 496                             (coerce (mstring (mfuncall '$@ form item)) 'string))))
 497              (forcebreak (reverse (coerce s 'list)) 0))))
 498     (let ((bkptht 1)
 499           (bkptdp 1)
 500           (lines 0)
 501           (break 0))
 502       (forcebreak result 0)
 503       (display-item '$version "Maxima-version")
 504       (display-item '$timestamp "Maxima build date")
 505       (display-item '$host "Host type")
 506       (display-item '$lisp_name "Lisp implementation type")
 507       (display-item '$lisp_version "Lisp implementation version")
 508       (display-item '$maxima_userdir "User dir")
 509       (display-item '$maxima_tempdir "Temp dir")
 510       (display-item '$maxima_objdir "Object dir")
 511       (display-item '$maxima_frontend "Frontend")
 512       (when $maxima_frontend
 513         (display-item '$maxima_frontend_version "Frontend version"))
 514       nil)))
 515
 516 (setf (get '%build_info 'dimension) 'dimension-build-info)
 517
 518 (defvar *maxima-started* nil)
 519
 520 (defvar *maxima-prolog* "")
 521 (defvar *maxima-epilog* "")
 522
 523 (defvar *maxima-quiet* nil)
 524
 525 (defvar *maxima-run-string* nil)
 526
 527 (defun macsyma-top-level (&optional (input-stream *standard-input*) batch-flag)
 528   (let ((*package* (find-package :maxima)))
 529     (if *maxima-started*
 530         (format t (intl:gettext "Maxima restarted.~%"))
 531         (progn
 532           (if (not *maxima-quiet*) (maxima-banner))
 533           (setq *maxima-started* t)))
 534
 535     (catch 'quit-to-lisp
 536       (in-package :maxima)
 537       (loop
 538          do
 539            (catch #+gcl si::*quit-tag*
 540                   #+(or cmu scl sbcl openmcl lispworks) 'continue
 541                   #-(or gcl cmu scl sbcl openmcl lispworks) nil
 542                   (catch 'macsyma-quit
 543                     (continue :stream input-stream :batch-or-demo-flag batch-flag)
 544                     (format t *maxima-epilog*)
 545                     (bye)))))))
 546
 547 (defun maxima-banner ()
 548   (format t *maxima-prolog*)
 549   (format t "~&Maxima ~a https://maxima.sourceforge.io~%"
 550       *autoconf-version*)
 551   (format t (intl:gettext "using Lisp ~a ~a") (lisp-implementation-type)
 552       #-clisp (lisp-implementation-version)
 553       #+clisp (subseq (lisp-implementation-version)
 554               0 (1+ (search ")" (lisp-implementation-version)))))
 555   (format t (intl:gettext "~%Distributed under the GNU Public License. See the file COPYING.~%"))
 556   (format t (intl:gettext "Dedicated to the memory of William Schelter.~%"))
 557   (format t (intl:gettext "The function bug_report() provides bug reporting information.~%")))
 558
 559 #+gcl
 560 (si::putprop :t 'throw-macsyma-top 'si::break-command)
 561
 562 (defun throw-macsyma-top ()
 563   (throw 'macsyma-quit t))
 564
 565 #-(or sbcl cmu)
 566 (defmfun $writefile (x)
 567   (let ((msg (dribble (maxima-string x))))
 568     (format t "~&~A~&" msg)
 569     '$done))
 570
 571 (defvar $appendfile nil )
 572 (defvar *appendfile-data* #+(or sbcl cmu) nil)
 573
 574 #-(or sbcl cmu)
 575 (defmfun $appendfile (name)
 576   (if (and (symbolp name)
 577            (char= (char (symbol-name name) 0) #\$))
 578       (setq name (maxima-string name)))
 579   (if $appendfile (merror (intl:gettext "appendfile: already in appendfile, you must call closefile first.")))
 580   (let ((stream  (open name :direction :output
 581                        :if-exists :append
 582                        :if-does-not-exist :create)))
 583     (setq *appendfile-data* (list stream *terminal-io* name))
 584
 585     (setq $appendfile (make-two-way-stream
 586                        (make-echo-stream *terminal-io* stream)
 587                        (make-broadcast-stream *terminal-io* stream))
 588           *terminal-io* $appendfile)
 589     (multiple-value-bind (sec min hour day month year)
 590         (get-decoded-time)
 591       (format t (intl:gettext "~&/* Starts dribbling to ~A (~d/~d/~d, ~2,'0d:~2,'0d:~2,'0d).*/~&")
 592               name year month day hour min sec))
 593     '$done))
 594
 595 #-(or sbcl cmu)
 596 (defmfun $closefile ()
 597   (cond ($appendfile
 598          (cond ((eq $appendfile *terminal-io*)
 599                 (format t (intl:gettext "~&/*Finished dribbling to ~A.*/~&")
 600                         (nth 2 *appendfile-data*))
 601                 (setq *terminal-io* (nth 1 *appendfile-data*)))
 602                (t (warn "*TERMINAL-IO* was rebound while APPENDFILE is on.~%~
 603                    You may miss some dribble output.")))
 604          (close (nth 0 *appendfile-data*))
 605          (setq *appendfile-data* nil $appendfile nil))
 606         (t (let ((msg (dribble)))
 607              (format t "~&~A~&" msg))))
 608   '$done)
 609
 610 #+(or sbcl cmu)
 611 (defun start-dribble (name)
 612   (let ((msg (dribble (maxima-string name))))
 613     (format t "~&~A~&" msg)
 614     (setq *appendfile-data* (cons name *appendfile-data*))
 615     (multiple-value-bind (sec min hour day month year)
 616         (get-decoded-time)
 617       (format t (intl:gettext "~&/* Starts dribbling to ~A (~d/~d/~d, ~2,'0d:~2,'0d:~2,'0d).*/~&")
 618               name year month day hour min sec))
 619     '$done))
 620
 621 #+(or sbcl cmu)
 622 (defmfun $writefile (name)
 623   (if (member name *appendfile-data* :test #'string=)
 624       (merror (intl:gettext "writefile: already in writefile, you must call closefile first.")))
 625   (start-dribble name))
 626
 627 #+(or sbcl cmu)
 628 (defmfun $appendfile (name)
 629   (if (member name *appendfile-data* :test #'string=)
 630       (merror (intl:gettext "appendfile: already in appendfile, you must call closefile first.")))
 631   (start-dribble name))
 632
 633 #+(or sbcl cmu)
 634 (defmfun $closefile ()
 635   (cond (*appendfile-data*
 636          (let ((msg (dribble)))
 637            (format t "~&~A~&" msg))
 638          (multiple-value-bind (sec min hour day month year)
 639              (get-decoded-time)
 640            (format t (intl:gettext "~&/* Quits dribbling to ~A (~d/~d/~d, ~2,'0d:~2,'0d:~2,'0d).*/~&")
 641                    (car *appendfile-data*) year month day hour min sec))
 642          (setq *appendfile-data* (cdr *appendfile-data*))))
 643   '$done)
 644
 645 (defmfun $ed (x)
 646   (ed (maxima-string x)))
 647
 648 (defun nsubstring (x y)
 649   (subseq x y))
 650
 651 (defun filestrip (x)
 652   (subseq (print-invert-case (car x)) 1))
 653
 654 (defmspec $with_stdout (arg)
 655   (declare (special $file_output_append))
 656   (setq arg (cdr arg))
 657   (let ((output (meval (car arg))))
 658     (if (streamp output)
 659       (let
 660         ((*standard-output* output)
 661          (body (cdr arg))
 662          result)
 663         (dolist (v body)
 664           (setq result (meval* v)))
 665         result)
 666       (let*
 667         ((fname (namestring (maxima-string output)))
 668          (filespec
 669            (if (or (eq $file_output_append '$true)
 670                    (eq $file_output_append t))
 671              `(*standard-output* ,fname :direction :output :if-exists :append :if-does-not-exist :create)
 672              `(*standard-output* ,fname :direction :output :if-exists :supersede :if-does-not-exist :create))))
 673         (eval
 674           `(with-open-file ,filespec
 675              (let ((body ',(cdr arg)) result)
 676                (dolist (v body)
 677                  (setq result (meval* v)))
 678                result)))))))
 679
 680 (defmfun $sconcat (&rest x)
 681   (let ((ans "") )
 682     (dolist (v x)
 683       (setq ans (concatenate 'string ans
 684                              (cond
 685                                    ((stringp v) v)
 686                                    (t
 687                                     (coerce (mstring v) 'string))))))
 688     ans))
 689
 690 (defmfun $system (&rest args)
 691   ;; If XMaxima is running, direct output from command into *SOCKET-CONNECTION*.
 692   ;; From what I can tell, GCL, ECL, and Clisp cannot redirect the output into an existing stream. Oh well.
 693   (let ((s (and (boundp '*socket-connection*) *socket-connection*))
 694         shell shell-opt)
 695     #+(or gcl ecl lispworks)
 696     (declare (ignore s))
 697     (declare (ignorable shell shell-opt))
 698
 699     (cond ((string= *autoconf-windows* "true")
 700            (setf shell "cmd") (setf shell-opt "/c"))
 701           (t (setf shell "/bin/sh") (setf shell-opt "-c")))
 702
 703     #+gcl (system::system (apply '$sconcat args))
 704     #+ecl (si:system (apply '$concat args))
 705     #+clisp (let ((output (ext:run-shell-command (apply '$sconcat args)
 706                                                  :wait t :output :stream)))
 707               (loop for line = (read-line output nil)
 708                  while line do
 709                    (format (or s t) "~a~%" line)))
 710     #+(or cmu scl) (ext:run-program shell (list shell-opt (apply '$sconcat args)) :output (or s t))
 711     #+allegro (excl:run-shell-command (apply '$sconcat args) :wait t :output (or s nil))
 712     #+sbcl (sb-ext:run-program shell
 713                                #+(or win32 win64) (cons shell-opt (mapcar '$sconcat args))
 714                                #-(or win32 win64) (list shell-opt (apply '$sconcat args))
 715                                :search t :output (or s t))
 716     #+openmcl (ccl::run-program shell
 717                                 #+windows (cons shell-opt (mapcar '$sconcat args))
 718                                 #-windows (list shell-opt (apply '$sconcat args))
 719                                 :output (or s t))
 720     #+abcl (extensions::run-shell-command (apply '$sconcat args) :output (or s *standard-output*))
 721     #+lispworks (system:run-shell-command (apply '$sconcat args) :wait t)))
 722
 723 (defmfun $room (&optional (arg nil arg-p))
 724   (if (and arg-p (member arg '(t nil) :test #'eq))
 725       (room arg)
 726       (room)))
 727
 728 (defun maxima-lisp-debugger (condition me-or-my-encapsulation)
 729   (declare (ignore me-or-my-encapsulation))
 730   ;; If outputting an error message creates an error this has the potential to trigger
 731   ;; another error message - which causes an endless loop.
 732   ;;
 733   ;; If maxima is connected to a frontend (for example wxMaxima) using a local network
 734   ;; socket and the frontend suddently crashes the network connection drops -which
 735   ;; has the potential to cause this endless loop to happen.
 736   ;;
 737   ;; most lisps (at least gcl, sbcl and clisp) are intelligent enough to call (bye)
 738   ;; if the socket connected to stdin, stdout and stderr drops.
 739   ;; ECL 16.3.1 ran into an endless loop, though => if maxima runs into an error
 740   ;; and cannot output an error message something is wrong enough to justify maxima
 741   ;; to quit.
 742   (handler-case
 743     (progn
 744       (format t (intl:gettext "~&Maxima encountered a Lisp error:~%~% ~A") condition)
 745       (format t (intl:gettext "~&~%Automatically continuing.~%To enable the Lisp debugger set *debugger-hook* to nil.~%"))
 746       (finish-output)
 747     )
 748     (error () (ignore-errors (bye))))
 749   (throw 'return-from-debugger t))
 750
 751 (let ((t0-real 0) (t0-run 0)
 752       (float-units (float internal-time-units-per-second)))
 753
 754   (defun initialize-real-and-run-time ()
 755     (setq t0-real (get-internal-real-time))
 756     (setq t0-run (get-internal-run-time)))
 757
 758   (defmfun $absolute_real_time () (get-universal-time))
 759
 760   (defmfun $elapsed_real_time ()
 761     (let ((elapsed-real-time (- (get-internal-real-time) t0-real)))
 762       (/ elapsed-real-time float-units)))
 763
 764   (defmfun $elapsed_run_time ()
 765     (let ((elapsed-run-time (- (get-internal-run-time) t0-run)))
 766       (/ elapsed-run-time float-units))))
 767
 768 ;; Tries to manually trigger the lisp's garbage collector
 769 ;; and returns true if it knew how to do that.
 770 (defmfun $garbage_collect ()
 771   #+allegro
 772   (progn (excl::gc) t)
 773   #+(or clisp ecl)
 774   (progn (ext::gc) t)
 775   #+gcl
 776   (progn (si::gbc t) t)
 777   #+sbcl
 778   (progn (sb-ext::gc :full t) t)
 779   #+cmucl
 780   (progn (ext:gc :full t) t)
 781   #-(or allegro clisp ecl gcl sbcl cmucl)
 782   nil)