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