src/macsys.lisp

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