archive/src/lmsup.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 (in-package "MAXIMA")
  10 ;; (c) Copyright 1982 Massachusetts Institute of Technology
  11
  12 ;; Lisp Machine additions to the Macsyma suprvisor -- see
  13 ;; MAXII;SYSTEM > and JPG;SUPRV > for the remaining gory details.
  14
  15
  16
  17 (DEFFLAVOR MACSYMA-LISTENER ()
  18            (TV:NOTIFICATION-MIXIN TV:PROCESS-MIXIN TV:FULL-SCREEN-HACK-MIXIN TV:WINDOW)
  19   (:DEFAULT-INIT-PLIST :SAVE-BITS T
  20                        #-symbolics :FONT-MAP #-symbolics '(FONTS:CPTFONT FONTS:CPTFONTB)
  21                        :border-margin-width 2
  22                        :label
  23                        (zl-string "Utexas Maxima Listener")
  24                        :PROCESS '(MACSYMA-LISTEN-LOOP :REGULAR-PDL-SIZE 40000
  25                                                       :SPECIAL-PDL-SIZE 5000))
  26   (:DOCUMENTATION :COMBINATION #. (zl-string "Normal MACSYMA window")))
  27
  28 (defmethod (macsyma-listener :after :init) (ignore)
  29   (send self :set-borders 1)
  30   (send (send self  :process)
  31         :set-warm-boot-action   'PROCESS-WARM-BOOT-DELAYED-RESTART-no-reset)
  32   (send self :set-label (zl-string ( #+cl global:format #-cl format
  33                           nil "Utexas Affine and ~A" (send self :name)))))
  34
  35 ;;so that the process won't necessarily be reset if you have to start the machine.
  36 (defvar *reset-processes* t)
  37
  38 (DEFUN PROCESS-WARM-BOOT-DELAYED-RESTART-no-reset (PROCESS)
  39   (PUSH (CONS PROCESS (si::PROCESS-RUN-REASONS PROCESS)) si::DELAYED-RESTART-PROCESSES)
  40   (SETF (si::PROCESS-RUN-REASONS PROCESS) NIL)
  41   (si::PROCESS-CONSIDER-RUNNABILITY PROCESS)
  42   (cond ((and (boundp *reset-processes*) *reset-processes*)
  43          (si::PROCESS-RESET PROCESS))
  44         (t (send process :interrupt 'break 'break t))))
  45
  46
  47
  48 ;;; This code tries to make Macsyma deal with Lispm more exceptions correctly.
  49 ;;; You should talk to me if you think it needs tweaking, please! --HIC
  50
  51
  52
  53 (DEFMETHOD (MACSYMA-LISTENER :MORE-EXCEPTION) ()
  54   (cond ((null tv:more-vpos)(let ((tv:more-processing-global-enable))
  55                               (more-fun-internal self)))
  56         (t  (TV:SHEET-MORE-HANDLER ':macsyma-more nil))))
  57
  58
  59 ;(DEFMETHOD (MACSYMA-LISTENER :MORE-EXCEPTION) ()
  60 ;   (TV:SHEET-MORE-HANDLER ':MACSYMA-MORE nil))
  61
  62 (DEFMETHOD (MACSYMA-LISTENER :MACSYMA-MORE) ()
  63   (MORE-FUN-INTERNAL SELF))
  64
  65 (DEFMETHOD (MACSYMA-LISTENER :DEFER-MORE) ()
  66   (OR (NULL TV:MORE-VPOS)
  67       (\x1d TV:MORE-VPOS 100000)
  68       (INCF TV:MORE-VPOS 100000)))
  69
  70 ;; When changing the size or fonts of a window, update the variables DISPLA looks at.  It
  71 ;; would probably be better to make all of the DISPLA variables special instance
  72 ;; variables.  These would be placed inside a listener object, so that they would be
  73 ;; accessible from both the Macsyma listener window and the supdup server.
  74
  75 ;; Check that PROCESS is really a process, since this gets called when the :INIT
  76 ;; method is run, which is before the process has been created.
  77
  78 (DEFmacro REBIND-SPECIALS (&rest specials)
  79   (setq specials (cons 'list (sloop for (v w) on specials by 'cddr
  80                                    collecting (list 'quote v)
  81         collecting w)))
  82   `(LET ((PROCESS (SEND SELF ':PROCESS)))
  83     (IF
  84       #+cl (memq(type-of PROCESS) '(SI:PROCESS si:coroutining-process))
  85       #-cl (ml-typep PROCESS 'SI:PROCESS)
  86         (WITHOUT-INTERRUPTS
  87           (SLOOP WITH STACK-GROUP = (SEND PROCESS ':STACK-GROUP)
  88                 FOR (SPECIAL VALUE) ON ,SPECIALS BY 'CDDR DO
  89                 ;; Though this dual code shouldn't be necessary, on the 3600
  90                 ;; it seems that it is.  Anyway, it's probably the right thing
  91                 ;; to do.  --HIC
  92                 (IF (EQ PROCESS CURRENT-PROCESS)
  93                     (SET SPECIAL VALUE)
  94                     (DBG:REBIND-IN-STACK-GROUP SPECIAL VALUE STACK-GROUP)))))))
  95
  96
  97 (DEFmacro REBIND-SIZE-SPECIALS ()
  98   `(MULTIPLE-VALUE-BIND (X Y)
  99       (SEND SELF ':SIZE-IN-CHARACTERS)
 100     (REBIND-SPECIALS LINEL X TTYHEIGHT Y)))
 101
 102 ;(rebind-size-specials)
 103
 104 (DEFmacro REBIND-FONT-SPECIALS ()
 105  `(progn (REBIND-SIZE-SPECIALS)
 106   (REBIND-SPECIALS LG-CHARACTER-X TV:CHAR-WIDTH
 107                    LG-CHARACTER-Y TV:LINE-HEIGHT
 108                    LG-CHARACTER-X-2 (// TV:CHAR-WIDTH 2)
 109                    LG-CHARACTER-Y-2 (// TV:LINE-HEIGHT 2))
 110   (LET ((BLINKER (TV:SHEET-FOLLOWING-BLINKER SELF)))
 111     (AND BLINKER
 112          (SEND BLINKER ':SET-SIZE (tv:FONT-BLINKER-WIDTH TV:CURRENT-FONT)
 113                                   (tv:FONT-BLINKER-HEIGHT TV:CURRENT-FONT))))))
 114
 115
 116 (DEFMETHOD (MACSYMA-LISTENER :AFTER :CHANGE-OF-SIZE-OR-MARGINS)(&rest ignore) (REBIND-SIZE-SPECIALS))
 117 (DEFMETHOD (MACSYMA-LISTENER :AFTER :SET-CURRENT-FONT)(&rest ignore) (REBIND-FONT-SPECIALS))
 118 (DEFMETHOD (MACSYMA-LISTENER :AFTER :SET-FONT-MAP) (&rest ignore)(REBIND-FONT-SPECIALS))
 119
 120
 121
 122
 123 ;(DEFUN-METHOD REBIND-SPECIALS MACSYMA-LISTENER (&REST SPECIALS)
 124 ;  (LET ((PROCESS (SEND SELF ':PROCESS)))
 125 ;    (IF (ml-typep PROCESS 'SI:PROCESS)
 126 ;       (WITHOUT-INTERRUPTS
 127 ;         (SLOOP WITH STACK-GROUP = (SEND PROCESS ':STACK-GROUP)
 128 ;               FOR (SPECIAL VALUE) ON SPECIALS BY 'CDDR DO
 129 ;               ;; Though this dual code shouldn't be necessary, on the 3600
 130 ;               ;; it seems that it is.  Anyway, it's probably the right thing
 131 ;               ;; to do.  --HIC
 132 ;               (IF (EQ PROCESS CURRENT-PROCESS)
 133 ;                   (SET SPECIAL VALUE)
 134 ;                   (DBG:REBIND-IN-STACK-GROUP SPECIAL VALUE STACK-GROUP)))))))
 135
 136
 137 ;(DEFUN-METHOD REBIND-SIZE-SPECIALS MACSYMA-LISTENER (&REST IGNORE)
 138 ;  (MULTIPLE-VALUE-BIND (X Y)
 139 ;      (SEND SELF ':SIZE-IN-CHARACTERS)
 140 ;    (REBIND-SPECIALS 'LINEL X 'TTYHEIGHT Y)))
 141
 142 ;(DEFUN-METHOD REBIND-FONT-SPECIALS MACSYMA-LISTENER (&REST IGNORE)
 143 ;  (REBIND-SIZE-SPECIALS)
 144 ;  (REBIND-SPECIALS 'LG-CHARACTER-X TV:CHAR-WIDTH
 145 ;                  'LG-CHARACTER-Y TV:LINE-HEIGHT
 146 ;                  'LG-CHARACTER-X-2 (// TV:CHAR-WIDTH 2)
 147 ;                  'LG-CHARACTER-Y-2 (// TV:LINE-HEIGHT 2))
 148 ;  (LET ((BLINKER (TV:SHEET-FOLLOWING-BLINKER SELF)))
 149 ;    (AND BLINKER
 150 ;        (SEND BLINKER ':SET-SIZE (FONT-BLINKER-WIDTH TV:CURRENT-FONT)
 151 ;                                 (FONT-BLINKER-HEIGHT TV:CURRENT-FONT)))))
 152 ;
 153 ;(DEFMETHOD (MACSYMA-LISTENER :AFTER :CHANGE-OF-SIZE-OR-MARGINS) REBIND-SIZE-SPECIALS)
 154 ;(DEFMETHOD (MACSYMA-LISTENER :AFTER :SET-CURRENT-FONT) REBIND-FONT-SPECIALS)
 155 ;(DEFMETHOD (MACSYMA-LISTENER :AFTER :SET-FONT-MAP) REBIND-FONT-SPECIALS)
 156
 157 (COMPILE-FLAVOR-METHODS MACSYMA-LISTENER)
 158
 159 ;; The top level function for Macsyma windows.  The :KILL operation resets
 160 ;; the process and buries the window.  MACSYMA-TOP-LEVEL exits when the user
 161 ;; types QUIT();.  Bind TERMINAL-IO here rather than in MACSYMA-TOP-LEVEL since
 162 ;; it is already bound in the supdup server.
 163
 164 (DEFUN MACSYMA-LISTEN-LOOP (*terminal-io*)
 165   (SLOOP DO
 166         (MACSYMA-TOP-LEVEL)
 167         (SEND *terminal-io* ':BURY)))
 168
 169 ;; Typing (MACSYMA) causes the MACSYMA-TOP-WINDOW to be selected if typed from the Lisp
 170 ;; Machine keyboard (TERMINAL-IO is a window stream).  If typed from some other stream,
 171 ;; just enter the normal read-eval-print loop.  MACSYMA-TOP-WINDOW is analgous to
 172 ;; TV:INITIAL-LISP-LISTENER.
 173
 174 (DEFVAR MACSYMA-TOP-WINDOW (TV:MAKE-WINDOW 'MACSYMA-LISTENER))
 175
 176 (DEFUN FIND-MACSYMA-TOP-WINDOW ()
 177   (IF (NULL MACSYMA-TOP-WINDOW)
 178       (SETQ MACSYMA-TOP-WINDOW (TV:MAKE-WINDOW 'MACSYMA-LISTENER))
 179       MACSYMA-TOP-WINDOW))
 180
 181 (DEFUN MACSYMA ()
 182   (IF (typep *terminal-io* 'tv::sheet)
 183       (SEND (FIND-MACSYMA-TOP-WINDOW) ':SELECT)
 184       (MACSYMA-TOP-LEVEL)))
 185
 186 ;; SMART-TTY and LINE-GRAHPICS-TTY are used by MRG;DISPLA and are set up on ITS in
 187 ;; ALJABR;LOADER.  RUBOUT-TTY is used by SUPRV and can be flushed when we start using the
 188 ;; Lisp Machine editor.  SCROLLP and SMART-TTY are equivalent for our purposes.
 189
 190 (declare-top (SPECIAL SMART-TTY RUBOUT-TTY LINE-GRAPHICS-TTY CHARACTER-GRAPHICS-TTY
 191                   LINEL TTYHEIGHT SCROLLP LG-OLD-X LG-OLD-Y
 192                   LG-CHARACTER-X LG-CHARACTER-Y LG-CHARACTER-X-2 LG-CHARACTER-Y-2))
 193
 194 (DEFUN MACSYMA-TOP-LEVEL ()
 195   (LET* ((*standard-output* #'MACSYMA-OUTPUT )
 196          (^R NIL) (^W NIL)
 197          #-cl
 198          (PACKAGE (#-cl PKG-FIND-PACKAGE #+cl find-package "maxima"))
 199          #+cl
 200          (*package* (find-package 'cl-maxima))
 201          #-cl
 202          (global:readtable (find-lisp-readtable-for-macsyma))
 203          #+cl
 204          (*readtable*  (find-lisp-readtable-for-macsyma))
 205          (*print-base* 10.) (*read-base* 10.) ;(*NOPOINT T)
 206          #+ti (si:*use-old-break* t)
 207          (W-O (FUNCALL *terminal-io* ':WHICH-OPERATIONS))
 208          ;; Bind for multiple instantiations -- these variables
 209          ;; are stream-dependent.
 210          (SMART-TTY (MEMQ ':SET-CURSORPOS W-O))
 211          (RUBOUT-TTY SMART-TTY)
 212          (SCROLLP (NOT SMART-TTY))
 213          (LINE-GRAPHICS-TTY (MEMQ ':DRAW-LINE W-O))
 214          ;; Bind for multiple instantiations -- these variables are stream-dependent.
 215          (SMART-TTY (SEND *terminal-io* ':OPERATION-HANDLED-P ':SET-CURSORPOS))
 216          (RUBOUT-TTY SMART-TTY)
 217          (SCROLLP (NOT SMART-TTY))
 218          (LINE-GRAPHICS-TTY (SEND *terminal-io* ':OPERATION-HANDLED-P ':DRAW-LINE))
 219          (LINEL) (TTYHEIGHT) (LG-OLD-X) (LG-OLD-Y)
 220          #+ (and cl symbolics)
 221          (si:*interactive-bindings* `((*package* ,(find-package 'cl-maxima))
 222                                       (global:package ,(find-package 'cl-maxima))
 223                                       (*readtable* ,(find-lisp-readtable-for-macsyma))
 224                                       (global:readtable ,(find-lisp-readtable-for-macsyma))
 225                                       ))
 226          (LG-CHARACTER-X) (LG-CHARACTER-Y) (LG-CHARACTER-X-2) (LG-CHARACTER-Y-2))
 227     ;; Uncomment this when somebody tries to take car of a number again
 228     ;; (SET-ERROR-MODE 1 1 1 1)
 229     ;; What happens to height on printing ttys?
 230     (MULTIPLE-VALUE-SETQ (LINEL TTYHEIGHT) (SEND *terminal-io* ':SIZE-IN-CHARACTERS))
 231     (COND (LINE-GRAPHICS-TTY
 232            (SETQ LG-CHARACTER-X (SEND *terminal-io* ':CHAR-WIDTH))
 233            (SETQ LG-CHARACTER-Y (SEND *terminal-io* ':LINE-HEIGHT))
 234            (SETQ LG-CHARACTER-X-2 (// LG-CHARACTER-X 2))
 235            (SETQ LG-CHARACTER-Y-2 (// LG-CHARACTER-Y 2))))
 236     (PRINT-MACSYMA-COPYRIGHT *terminal-io*)
 237     (apply 'format t
 238            "Maxima ~a.~a ~a (with enhancements by W. Schelter).~%Licensed under the GNU Public License (see file COPYING)~%"
 239            (get :maxima :version))
 240     (CATCH 'MACSYMA-QUIT
 241       (ERROR-RESTART-LOOP ((SYS:ABORT) "Macsyma Top Level~@[ in ~A~]"
 242                            (SEND *terminal-io* ':SEND-IF-HANDLES ':NAME))
 243         (UNWIND-PROTECT
 244           (CONDITION-CASE ()
 245              #-symbolics (SEND *terminal-io* ':FUNCALL-INSIDE-YOURSELF #'CONTINUE)
 246              #+symbolics
 247              (continue)
 248             (MACSYMA-ERROR))
 249           (SUPUNBIND))))))
 250
 251 ;; Add "Macsyma" to the window creation menu and System key.
 252 (PUSH '("Macsyma" :VALUE MACSYMA-LISTENER
 253         :DOCUMENTATION "Macsyma Symbolic Algebra System")
 254       TV:DEFAULT-WINDOW-TYPES-ITEM-LIST)
 255
 256 (cond ((boundp 'tv:*system-keys*)
 257        (cond ((numberp (caar tv:*system-keys*))
 258               (PUSH '(#. (char-code #\A) MACSYMA-LISTENER "Macsyma" T) TV:*system-KEYS*))
 259              (t
 260               (PUSH '(#\A MACSYMA-LISTENER "Macsyma" T) TV:*system-KEYS*))))
 261       (t #+symbolics       (cond ((numberp (caar tv:*select-keys*))
 262                       (PUSH '(#. (char-code #\A) MACSYMA-LISTENER "Macsyma" T) TV:*select-KEYS*))
 263                      (t
 264                       (PUSH '(#\A MACSYMA-LISTENER "Macsyma" T) TV:*select-KEYS*)))))
 265
 266 (tv:add-to-system-menu-programs-column
 267   (zl-string "Macsyma")
 268   '(tv:select-or-create-window-of-flavor 'macsyma-listener)
 269   (zl-string "Macsyma Symbolic Algebra System, with UT modifications") t)
 270
 271
 272 \f
 273
 274 ;; Print out the Macsyma Copyright notice to the appropriate window
 275
 276 ;(DEFUN PRINT-MACSYMA-COPYRIGHT (WINDOW &AUX TEMP)
 277 ;  (MULTIPLE-VALUE-BIND (MAJOR MINOR) (SI:GET-SYSTEM-VERSION 'cl-MAximA)
 278 ;                                               ; '(FONTS:CPTFONT FONTS:CPTFONTB)
 279 ;    (send window :set-font-map   '(cptfont metsi tiny))
 280 ;    (send window :set-current-font 1)
 281 ;    (send window :string-out-centered
 282 ;         (FORMAT nil "~%MAXIMA ~D.~D" MAJOR MINOR))
 283 ;;        (FORMAT nil "~%          MAXIMA ~D.~D" MAJOR MINOR))
 284 ;;  (FORMAT WINDOW   "~%      with enhancements by")
 285 ;;  (format window   "~%  UNIVERSITY OF TEXAS 1984,1985")
 286 ;;    (SEND WINDOW :SET-CURRENT-FONT 0)
 287 ;;    (SETQ TEMP (SEND WINDOW :FONT-MAP))
 288 ;;    (ASET FONTS:TINY TEMP 2)
 289 ;;    (SEND WINDOW :SET-FONT-MAP TEMP)
 290 ;    (SEND WINDOW :SET-CURRENT-FONT 2)
 291 ;    (send window :string-out-centered
 292 ;         (format nil "~%          ENHANCEMENTS BY WILLIAM SCHELTER 1984,1985"))
 293 ;    (send window :string-out-centered
 294 ;         (FORMAT nil "~%       COPYRIGHT 1976, 1983 MASSACHUSETTS INSTITUTE OF TECHNOLOGY~2%") ))
 295 ;    (SEND WINDOW :SET-CURRENT-FONT 0))
 296
 297 ;; Print out the Macsyma Copyright notice to the appropriate window
 298
 299 (DEFUN PRINT-MACSYMA-COPYRIGHT (WINDOW &AUX TEMP)
 300   (MULTIPLE-VALUE-BIND (MAJOR MINOR) (SI:GET-SYSTEM-VERSION 'cl-MAximA)
 301     (setq major 4 minor 0)
 302     (send window :set-current-font 1)
 303     (FORMAT WINDOW "~%          MAXIMA ~D.~D" MAJOR MINOR))
 304 ;  (FORMAT WINDOW   "~%      with enhancements by")
 305 ;  (format window   "~%  UNIVERSITY OF TEXAS 1984,1985")
 306   #-symbolics
 307  (progn (SEND WINDOW :SET-CURRENT-FONT 0)
 308   (SETQ TEMP (SEND WINDOW :FONT-MAP))
 309   (ASET FONTS:TINY TEMP 2)
 310   (SEND WINDOW :SET-FONT-MAP TEMP)
 311   (SEND WINDOW :SET-CURRENT-FONT 2))
 312   (format window "~%          ENHANCEMENTS BY WILLIAM SCHELTER 1984,1985,1987")
 313   (FORMAT WINDOW "~%       COPYRIGHT 1976, 1983 MASSACHUSETTS INSTITUTE OF TECHNOLOGY~2%")
 314   #-symbolics
 315   (SEND WINDOW :SET-CURRENT-FONT 0))
 316
 317
 318 ;; Random garbage needed to make SUPRV happy.
 319
 320 (DEFUN FORMFEED () (SEND *standard-input* ':CLEAR-SCREEN))
 321
 322 ;; This is used someplace in SUPRV.
 323
 324 (DEFUN FILE-OPEN (FILE-OBJ)
 325   (EQ (SEND FILE-OBJ ':STATUS) ':OPEN))
 326
 327 ;; Takes a string file specification and returns an oldio list specification.  Similar
 328 ;; to MacLisp NAMELIST function. (UNEXPAND-PATHNAME "C: D; A B") --> (A B C D)
 329
 330 (DEFUN UNEXPAND-PATHNAME (SSTRING)
 331   (LET* ((PATHNAME (PATHNAME SSTRING))
 332          (DEV (SEND PATHNAME ':DEVICE)))
 333     (IF (STRING-EQUAL DEV "DSK")
 334         (SETQ DEV (SEND PATHNAME ':HOST)))
 335     (MAPCAR 'INTERN (LIST (SEND PATHNAME ':FN1)
 336                           (SEND PATHNAME ':FN2)
 337                           (SEND DEV ':NAME-AS-FILE-COMPUTER)
 338                           (SEND PATHNAME ':DIRECTORY)))))
 339
 340 ;;; Make this function callable on different types of things.
 341 (DEFUN NAMESTRING (OLDIO-LIST)
 342   (cond ((symbolp oldio-list) (string oldio-list))
 343         ((stringp oldio-list) oldio-list)
 344         (t (INTERN
 345              (FORMAT NIL "~A/:~A/;~A ~A"
 346                      (THIRD OLDIO-LIST)
 347                      (FOURTH OLDIO-LIST)
 348                      (FIRST OLDIO-LIST)
 349                      (SECOND OLDIO-LIST))))))
 350
 351 ;; Takes a list like in ITS Macsyma, returns a string.
 352 ;; Device defaults to MC, as does DSK device specification.
 353 ;; Directory defaults to user-id.  Hack USERSn later.
 354 ;; (FILESTRIP '($A $B $C $D)) --> "C: D; A B"
 355 ;; (FILESTRIP '($A $B $C)) --> "MC: C; A B"
 356
 357 (DEFUN FILESTRIP (X &AUX FN1 FN2 DEV DIR)
 358   (IF (AND (= (LENGTH X) 1) (SYMBOLP (CAR X)) (char= (AREF (STRING (CAR X)) 0) #\&))
 359       ;; A Macsyma string, use it as is
 360       (SUBSTRING (STRING (CAR X)) 1)
 361       ;; Otherwise...
 362       (SETQ X (FULLSTRIP X)) ;Strip the list, leave NIL as NIL.
 363       (SETQ FN1 (CAR X) FN2 (CADR X) DEV (CADDR X) DIR (CADDDR X))
 364       (IF (AND DEV (NULL DIR)) (SETQ DIR DEV DEV NIL))
 365       (IF (EQ DEV 'DSK) (SETQ DEV "MC"))
 366       ;;If case doesn't matter, don't confuse user.
 367       (STRING-UPCASE (FORMAT NIL "~A: ~A; ~A ~A"
 368                               (OR DEV "MC") (OR DIR global:USER-ID)
 369                               (OR FN1 "MAXOUT") (OR FN2 ">")))))
 370
 371 (DEFUN MAXIMA-FIND (FUNC MEXPRP)
 372   MEXPRP
 373   (COND ((safe-GET FUNC 'AUTOLOAD)
 374          (ERROR  "~A is needed from file ~S, but not in core"
 375                  FUNC (GET FUNC 'AUTOLOAD))))
 376   NIL)
 377
 378 ;(DECLARE (SPECIAL ERROR-CALL))
 379 ;(DEFUN MACSYMA-ERROR-HANDLER (&REST IGNORE)
 380 ;   (COND ((NULL ERROR-CALL) NIL)
 381 ;        (T (LET ((SIGNAL))
 382 ;                (SETQ SIGNAL (FUNCALL ERROR-CALL NIL))
 383 ;                (COND ((NULL SIGNAL) NIL)
 384 ;                      ((EQ SIGNAL 'LISP)
 385 ;                       (SETQ EH:ERRSET-STATUS NIL
 386 ;                             EH:ERRSET-PRINT-MSG T)
 387 ;                       NIL)
 388 ;                      ((EQ SIGNAL 'EXIT) (THROW 'SI:TOP-LEVEL NIL))
 389 ;                      (T NIL))))))
 390
 391 (DEFUN TOP-MEVAL (FORM)
 392   (CATCH-ERROR-RESTART (SYS:ABORT #-ti "TOP-MEVAL")
 393     (NCONS (MEVAL* FORM))))
 394
 395 (declare-top (SPECIAL WRITEFILE-OUTPUT))
 396 (declare-top (SPECIAL WRITEFILE-OPERATIONS))
 397 (DEFVAR ^R NIL)
 398 (DEFVAR ^W NIL)
 399 (DEFVAR INFILE NIL)
 400
 401 ;;; *STANDARD-OUTPUT* gets bound to this.
 402 (DEFUN MACSYMA-OUTPUT (OP &REST REST)
 403   (CASE OP
 404     (:WHICH-OPERATIONS (SEND *terminal-io* ':WHICH-OPERATIONS))
 405     (T (IF (AND ^R (MEMQ OP WRITEFILE-OPERATIONS))
 406            (APPLY WRITEFILE-OUTPUT OP REST))
 407        (IF (NOT ^W) (APPLY *terminal-io* OP REST)))))
 408
 409 ;; Specify entire filename when WRITEFILE is done.
 410 (DEFMFUN $WRITEFILE (&REST L)
 411   (LET ((NAME ($FILENAME_MERGE (FILENAME-FROM-ARG-LIST L)
 412                                "MAXOUT"
 413                                (FS:USER-HOMEDIR))))
 414   (SETQ WRITEFILE-OUTPUT #-cl (OPEN NAME  ':OUT)
 415         #+cl (open name :direction :output))
 416   (SETQ WRITEFILE-OPERATIONS (SEND WRITEFILE-OUTPUT ':WHICH-OPERATIONS))
 417   (SETQ ^R T)
 418   NAME))
 419
 420 (DEFMFUN $APPENDFILE (&REST L)
 421   (LET ((NAME ($FILENAME_MERGE (FILENAME-FROM-ARG-LIST L)
 422                                "MAXOUT"
 423                                (FS:USER-HOMEDIR))))
 424   (SETQ WRITEFILE-OUTPUT #-cl (OPEN NAME  ':OUT)
 425         #+cl (open name :direction :output :if-exists :append
 426                    :if-does-not-exist :create
 427                    ))
 428   (SETQ WRITEFILE-OPERATIONS (SEND WRITEFILE-OUTPUT ':WHICH-OPERATIONS))
 429   (SETQ ^R T)
 430   NAME))
 431
 432 (DEFUN $CLOSEFILE ()
 433   (SETQ ^R NIL)
 434   (CLOSE WRITEFILE-OUTPUT)
 435   '$DONE)
 436
 437 ;; Random useful functions to call from Macsyma Toplevel.
 438
 439 (DEFF $ED #'ED)
 440 (DEFF $BEEP #'TV:BEEP)
 441
 442 #-3600
 443 (DEFF $GC_ON #'GC-ON)
 444 #-3600
 445 (DEFF $GC_OFF #'GC-OFF)
 446
 447 (DEFUN $SCHEDULE (&OPTIONAL (N 1)) (DOTIMES (I N) (PROCESS-ALLOW-SCHEDULE)))
 448 (DEFUN $SLEEP (&OPTIONAL (60THS-SEC 60.)) (PROCESS-SLEEP 60THS-SEC))
 449
 450 (DEFMVAR EDITOR-STATE NIL "Alist of editor windows and old strings, one per Macsyma Listener")
 451
 452 ;;; Edit a frob, then read it back in
 453 (DEFMSPEC $EDIT (X)
 454   (SETQ X (SECOND X))
 455   ;; Convert Macsyma expression into a string
 456   (AND X
 457        (LET (($GRIND T))
 458          (declare (special $grind))
 459          (SETQ X (MAPPLY '$STRING (LIST X) '$STRING))))
 460   (LET ((STATE (ASSQ *terminal-io* EDITOR-STATE))
 461         (WINDOW))
 462     (COND ((NULL STATE)
 463            (SETQ STATE (LIST *terminal-io* NIL ""))
 464            (PUSH STATE EDITOR-STATE)))
 465     (LET ((TV:DEFAULT-SCREEN TV:MOUSE-SHEET))
 466       (MULTIPLE-VALUE-SETQ (X WINDOW) (ZWEI:EDSTRING (IF X (NSUBSTRING (STRING X) 1) (THIRD STATE))
 467                                                 (SECOND STATE))))
 468     (SETF (SECOND STATE) WINDOW)
 469     (SETF (THIRD STATE) X)
 470     (WITH-INPUT-FROM-STRING (STREAM (STRING-APPEND X ";"))
 471       (MEVAL* (THIRD (MREAD STREAM))))))
 472
 473
 474 (DEFUN $pbi_pop_up (from-line  &aux input-symbol
 475                                (*print-base* 10.)(*read-base* 10.) *print-radix*
 476                                ;(*nopoint t)
 477                                )
 478   (cond ((null from-line)(setq from-line (max 1 (f- $linenum 40)))))
 479   (USING-RESOURCE (WINDOW tv:POP-UP-FINGER-WINDOW)
 480     (SETF (tv:SHEET-TRUNCATE-LINE-OUT-FLAG WINDOW) 1)
 481     (FUNCALL WINDOW ':SET-LABEL (zl-string "Macsyma Input Playback"))
 482     #+ti
 483     (funcall window :set-process current-process)
 484     (tv:window-call (window :deactivate)
 485       (let ((*standard-input* (send window :io-buffer))(stream window))
 486            (setq #-ti tv:kbd-esc-time #+ti tv:kbd-terminal-time nil)
 487            (format window "Playback of Macsyma input lines:  ")
 488            (let ((linel
 489                    (f- (quotient (send window :width)
 490                                 (send window :char-width)) 10.)))
 491                 (sloop for i from from-line below $linenum
 492                       do
 493                       (setq input-symbol (intern (format nil "$C~A" i) 'maxima ))
 494                       (cond ( (boundp input-symbol)
 495                              (format stream "~% C~3A: ~:M"   i (symbol-value  input-symbol)  ))))
 496                 #+ti (tv:await-user-typeahead window)
 497                 #-ti(tv:type-a-space-to-flush window)
 498                 )))))
 499
 500
 501 (eval-when (load)
 502 (pushnew  (list (zl-char #\E) '$pbi_pop_up
 503                #. (zl-string "Playback Maxima Input lines starting 40 lines back (or at numeric arg)"))
 504          #+ti tv::*terminal-keys* #-ti tv::*function-keys* :test 'equalp)
 505 )
 506
 507 ;; To do:
 508 ;; Figure out some way of making $LINENUM and $% process-specific.
 509 ;; JLK suggests something like D4.23 as meaning D-line 23 in Macsyma Listener #4.
 510 ;; Make Macsyma Windows into scroll windows.
 511