mirror of
https://github.com/PDP-10/its.git
synced 2026-01-22 18:42:15 +00:00
85994ed770
Resolves #284. Commented out uses of time-origin in maxtul; mcldmp (init) until we can figure out why it gives arithmetic overflows under the emulators. Updated the expect script statements in build_macsyma_portion to not attempt to match expected strings, but simply sleep for some time since in some cases the matching appears not to work.
349 lines
14 KiB
Common Lisp
349 lines
14 KiB
Common Lisp
;;; -*- Mode:LISP; Package:MACSYMA -*-
|
||
|
||
; ** (c) Copyright 1982 Massachusetts Institute of Technology **
|
||
|
||
; Do "ALJABR^S L^K"; the (escape) is for loading in LISP symbols.
|
||
|
||
; "ALJABR;* LISP" which allocates pdls is automatically loaded in.
|
||
; Current contents of that file are:
|
||
(COMMENT CORE 130. REGPDL 2750. FLPDL 400. FXPDL 1500. SPECPDL 1750.)
|
||
|
||
; Load in "ALJABR;LOADER >".
|
||
; Now, all you need do is type "(LOADER version#)" (where version# is an
|
||
; integer) and hope for no bugs. When you are through, you must kill
|
||
; the job yourself. (LISP;LOCK > may need to be updated as to LISP
|
||
; version used.)
|
||
|
||
; The End
|
||
|
||
; All FASL files loaded here were created from compiled LISP files using
|
||
; ALJABR; COMPLR > , except for RATLAP whose source is RAT;RATLAP > .
|
||
|
||
;; The code in this file is run only once when a new Macsyma is created.
|
||
;; For this reason, it is interpreted and not compiled so that the code
|
||
;; can be gc'ed when no longer needed.
|
||
|
||
(PROG2
|
||
(SETQ FILES '(ERMSGM ;ERMSGM *MUST* be the first file loaded, since
|
||
;out-of-core-strings generate SQUIDs that refer to it.
|
||
MERROR MFORMT MUTILS UTILS
|
||
GRAM DISPLA NFORMA MLISP COMM SUPRV MLOAD SIMP OPERS RATLAP
|
||
FACTOR RAT3A RAT3B RAT3D RAT3E RAT3C LESFAC SPGCD
|
||
INMIS DB COMPAR NRAT4 MATRIX MAT CSIMP
|
||
TRIGI ASUM RUNTIM MEDIT DSKFN GRIND))
|
||
'FILES)
|
||
|
||
(SETQ BASE 10. IBASE 10. *NOPOINT T)
|
||
|
||
(SETQ MUNFAS T) ; Set to NIL if you don't want the UNFASL read.
|
||
(SETQ MAXDMP T) ; Set to NIL if you don't want "Being Loaded" to print.
|
||
|
||
(DEFUN STRING-FILE-NAME (FILE)
|
||
(COND ((AND INCORE-FILES (NOT (ASSOC FILE INCORE-FILES)))
|
||
(PRINC '|
|
||
;Out-of-core string file /"|)
|
||
(PRINC (NAMESTRING FILE))
|
||
(COND ((PROBEF FILE)
|
||
(PRINC '|/"
|
||
;has not been merged into /"|)
|
||
(PRINC (NAMESTRING INCORE-MESSAGE-FILE))
|
||
(PRINC '|/"
|
||
|)) (T (PRINC '|/" is ** MISSING **
|
||
|) (BREAK |MISSING STRING FILE|)))))
|
||
())
|
||
|
||
(DEFUN LOADER (VERSION)
|
||
(SETQ $VERSION VERSION SAVENOHACK (READLIST (NCONC (EXPLODEN $VERSION) '(/0))))
|
||
(NOUUO T)
|
||
(SETQ *PURE T)
|
||
(ALLOC '(LIST (4096. 30000. .1) FIXNUM (512. 9000. .1)
|
||
FLONUM (64. 3000. .1) BIGNUM (64. 3000. .1)
|
||
SYMBOL (4096. 7200. .05) ARRAY (64. 400. 50.)))
|
||
(SETQ PUTPROP '(SUBR FSUBR LSUBR ALPHABET NUMBER GRAD DISSYM OP OPR
|
||
RECIP $INVERSE ALIAS REVERSEALIAS NOUN VERB MFEXPR*
|
||
NUD LED LBP RBP EVFLAG OPALIAS OP2C DIMENSION AUTOLOAD
|
||
OPERATORS EVFUN GRIND LDP RDP MSIMPIND ASSIGN EVOK
|
||
$OUTATIVE STRSYM SPECSIMP SYSCONST BINARY MFEXPR*S))
|
||
;; set up information for shared out-of-core message file
|
||
((LAMBDA (FILE POS)
|
||
(SETQ POS (IN FILE))
|
||
(OPEN FILE '(IN ASCII))
|
||
(FILEPOS FILE (* POS 5))
|
||
(SETQ INCORE-FILES (CDR (ASSQ 'FILES (CDR (READ FILE))))))
|
||
(SETQ INCORE-MESSAGE-FILE
|
||
(OPEN '((DSK MAXDMP) INCORE >) '(IN FIXNUM)))
|
||
() )
|
||
(SETQ INCORE-MESSAGE-FILE (TRUENAME INCORE-MESSAGE-FILE))
|
||
(UWRITE DSK MAXDMP) (SETQ ^R T)
|
||
(PRINT '|LISPV: |)
|
||
(PRIN1 (STATUS LISPV))
|
||
(PRINT '|Message file: |)
|
||
(PRIN1 (NAMESTRING INCORE-MESSAGE-FILE)) (TERPRI)
|
||
(PROG NIL A (COND ((NULL FILES) (RETURN NIL))
|
||
(T (READLOOP (CAR FILES)) (SETQ FILES (CDR FILES)) (GO A))))
|
||
(FASLOAD SORT FASL DSK LISP)
|
||
;; Load initializations generated by MDEFVAR.
|
||
(LOAD '|MAXDOC;INIT RESET|)
|
||
(LOAD '|MAXDOC;INIT NORESE|)
|
||
(TOPL) (NOUUO NIL) (NORET NIL)
|
||
(SETQ IBASE 10. *NOPOINT T)
|
||
((LAMBDA (MSGFILES ^D) (GC)) (CONS UWRITE MSGFILES) T)
|
||
(PURIFY 0 0 'BPORG)
|
||
(SETQ PURE NIL FASLOAD NIL *PURE NIL)
|
||
(ALLOC '(LIST (16000. 30000. .3) FIXNUM (5000. 9000. .3)
|
||
FLONUM (1600. 3000. .3) BIGNUM (1600. 3000. .3)
|
||
SYMBOL (6200. 7200. .1) ARRAY (150. 400. 50.)))
|
||
(setq INCORE-FILES ())
|
||
(MAPC 'MAKUNBOUND '(INCORE-MESSAGE-FILE
|
||
MAXDMP MUNFAS))
|
||
(REMPROP 'STRING-FILE-NAME 'EXPR) ;Leaves NO-OP SUBR definition
|
||
(PRINT 'STATUS/ MEMFREE/:/ ) (PRINC (STATUS MEMFREE)) (TERPRI)
|
||
(AND (GETL 'PURE-SUSPEND '(SUBR LSUBR EXPR))
|
||
(PRINT 'PURE-SUSPEND))
|
||
(UFILE MSLOCS > DSK MAXDMP)
|
||
(SSTATUS WHO1 42. '% 118. 0)
|
||
(SSTATUS GCWHO 3)
|
||
(*RSET NIL)
|
||
(NOINTERRUPT 'TTY)
|
||
(SSTATUS FLUSH T)
|
||
(GC)
|
||
(COND ((GETL 'PURE-SUSPEND '(SUBR LSUBR EXPR))
|
||
(PURE-SUSPEND () '|DSK:MAXDMP;LOSER >|))
|
||
(T
|
||
(SUSPEND () '|DSK:MAXDMP;LOSER >|))))
|
||
|
||
(DEFUN READLOOP (FILE)
|
||
(PROG (B ^W ^Q)
|
||
(SETQ B 'LAP)
|
||
FILE (COND ((PROBEF (CONS FILE '(FASL DSK MAXDMP)))
|
||
(AND MAXDMP
|
||
(PRINT (CONS FILE '(FASL DSK MAXDMP LOADING BEGUN))))
|
||
(COND ((NULL (ERRSET (EVAL (LIST 'FASLOAD FILE 'FASL 'DSK 'MAXDMP))))
|
||
(BREAK |error in FASL file| T)
|
||
((LAMBDA (^Q ^R ^W) (PRINC '|/
|
||
Where do we go from here?/
|
||
|) (EVAL (READ)))
|
||
NIL NIL NIL)))
|
||
(AND MAXDMP
|
||
(PRINT (CONS FILE '(FASL DSK MAXDMP LOADED))))
|
||
(COND ((AND MUNFAS
|
||
(ERRSET (EVAL (LIST 'UREAD FILE 'UNFASL 'DSK 'MUNFAS))))
|
||
(AND MAXDMP
|
||
(PRINT (CONS FILE '(UNFASL DSK MUNFAS LOADING BEGUN))))
|
||
(SETQ ^W T B 'UNFASL) (GO C))
|
||
(T (RETURN NIL))))
|
||
((NULL (ERRSET (EVAL (LIST 'UREAD FILE B 'DSK 'MAXDMP)) NIL))
|
||
(PROG (^W) (PRINT (CONS FILE '(FASL NOT FOUND)))
|
||
(PRINT (LIST 'PLEASE 'COMPILE FILE '>))
|
||
(PRINT '(THEN TYPE $P<SPACE> TO CONTINUE)))
|
||
(BREAK WAITING T) (GO FILE))
|
||
(T (AND MAXDMP
|
||
(PRINT (LIST FILE B 'DSK 'MAXDMP 'LOADING 'BEGUN)))))
|
||
C (SETQ ^Q T)
|
||
CONT (COND ((NULL (ERRSET
|
||
(PROG (EXPR *EOF X Y)
|
||
(SETQ *EOF (LIST NIL))
|
||
LOOP (COND ((EQ *EOF (SETQ EXPR (READ *EOF))) (RETURN NIL))
|
||
((EQ B 'UNFASL)
|
||
(COND ((AND (EQ (CAR EXPR) 'COMMENT)
|
||
(EQ (CADR EXPR) '**FASL**)
|
||
(NUMBERP (CADDR EXPR))
|
||
(NOT (ATOM (CADDDR EXPR)))
|
||
(SETQ X (GETL (SETQ Y (CADR (CADDDR EXPR)))
|
||
'(SUBR FSUBR LSUBR))))
|
||
(SETQ EXPR
|
||
(NCONS (LIST Y (CAR X)
|
||
(MAKNUM (CADR X))))))
|
||
((AND (EQ (CAR EXPR) 'QUOTE)
|
||
(NOT (ATOM (CADR EXPR)))
|
||
(MEMQ (CAADR EXPR)
|
||
'(THIS COMPILED ASSEMBLED)))
|
||
(SETQ EXPR (CADR EXPR)))
|
||
(T (GO LOOP))))
|
||
(T (SETQ EXPR (EVAL EXPR))))
|
||
((LAMBDA (BASE) (PRINT EXPR)) 8.)
|
||
(GO LOOP))))
|
||
(BREAK |error in file| T)
|
||
((LAMBDA (^Q ^R ^W) (PRINC '|/
|
||
Where do we go from here?/
|
||
|) (EVAL (READ)))
|
||
NIL NIL NIL))
|
||
(T (SETQ ^W NIL)
|
||
(RETURN (AND MAXDMP
|
||
(PRINT (LIST FILE B 'DSK
|
||
(COND ((EQ B 'UNFASL) 'MUNFAS) (T 'MAXDMP))
|
||
'LOADED))))))))
|
||
|
||
(DEFUN TOPL NIL
|
||
(GCTWA)
|
||
(SSTATUS
|
||
TOPLE
|
||
'(PROGN
|
||
(TOPL-FUN)
|
||
(SSTATUS TOPLE NIL) (REMPROP 'TOPL-FUN 'EXPR)
|
||
(GCTWA) (NOINTERRUPT NIL)
|
||
(COND ((EQ (GETCHAR (STATUS JNAME) 1) 'T) (MEVAL '(($PRIMER)))))
|
||
(CONTINUE)))
|
||
(MAKUNBOUND 'FILES)
|
||
(REMPROP 'READLOOP 'EXPR) (REMPROP 'LOADER 'EXPR)
|
||
(REMPROP 'LAPTEMPS 'FEXPR) (REMPROP 'LAPCHECK 'EXPR)
|
||
(REMPROP 'TOPL 'EXPR))
|
||
|
||
(DEFUN JOB-EXISTS (JNAME) (PROBEF (LIST '(USR *) (STATUS UNAME) JNAME)))
|
||
|
||
(DEFUN TOPL-FUN NIL
|
||
(PROG (USER USRNAM X JCL I DEFAULTF*)
|
||
(SSTATUS TOPLE '(PROG2 (PRINC '|
|
||
THIS MACSYMA IS NO GOOD!|) (VALRET '|:KILL
|
||
|))) (SETQ USER (LIST 'DSK (STATUS UDIR)) USRNAM (STATUS USERID))
|
||
(SSTATUS FEATURE MACSYMA)
|
||
(MTERPRI)
|
||
(PRINC '|This is MACSYMA |)
|
||
(PRINC $VERSION) (MTERPRI)
|
||
(COND ((AND (= (GETCHARN USRNAM 1) 95.) (= (GETCHARN USRNAM 2) 95.)
|
||
(= (GETCHARN USRNAM 3) 95.)) ; test for underscore
|
||
(PRINC 'PLEASE/ LOG/ IN/!) ($QUIT)))
|
||
;; octal: 232020222022 232222220233
|
||
(SSTATUS TTY 20673799186. 20707877019.)
|
||
(SYSCALL 0 'TTYSET TYO
|
||
(CAR (STATUS TTY)) (CADR (STATUS TTY))
|
||
(BOOLE 7 1_34. (CADDR (STATUS TTY)))) ; fixes ^L lossage
|
||
; bit 4.8 (%TSCLE) of TTYSTS
|
||
(SETQ $PAGEPAUSE (= 0 (BOOLE 1 (CADDR (STATUS TTY)) 1_25.)))
|
||
; bit 3.8 (%TSMOR) of TTYSTS
|
||
;; (LINEL T) is (1- (CDR (STATUS TTYSIZE)))
|
||
(SETQ $LINEL (SETQ LINEL (LINEL T)))
|
||
(SETQ SCROLLP (NOT (= 0 (BOOLE 1 (CADDR (STATUS TTY)) 1_30.))))
|
||
;; Load the fix file, if one exists.
|
||
;; If :MACSYMA is being run, load MACSYM;FIXnnn > where nnn
|
||
;; is the version number. If :NMACSYMA is being run, load NFXnnn >.
|
||
(SETQ X (CONS (MAKNAM (APPEND (COND ((EQ (GETCHAR (STATUS JNAME) 1) 'N)
|
||
'(N F X))
|
||
(T '(F I X)))
|
||
(EXPLODEN $VERSION)))
|
||
'(> DSK MACSYM)))
|
||
(COND ((PROBEF X)
|
||
(COND ((NULL (ERRSET (LOADFILE X NIL T)))
|
||
(TERPRI) (PRINC '|Bad FIX file!|) (ERR)))))
|
||
;; If :DMACSYMA (Debug Macsyma) is being run, then also load the
|
||
;; compile time environment. (LIBMAX;PRELUD >)
|
||
;; This should be made to turn on $DEBUGMODE as well.
|
||
(COND ((AND (EQ (GETCHAR (STATUS JNAME) 1) 'D)
|
||
(NULL (ERRSET (LOAD '|LIBMAX;PRELUD >|))))
|
||
(TERPRI) (PRINC '|Bad prelude file!|)))
|
||
(COND ((NULL (SETQ X (STATUS JCL))))
|
||
((NULL (CDR X)) (SETQ JCL 'NO))
|
||
((MEMQ '/; X)
|
||
(SETQ X (NREVERSE (CDR (MEMQ '/; (REVERSE X)))))
|
||
(COND ((NULL (SETQ JCL (ERRSET (READLIST X) NIL)))
|
||
(SETQ JCL (NCONS (IMPLODE X))))))
|
||
((PROG2 (SETQ JCL (COND ((NULL (SETQ JCL (ERRSET (READLIST X) NIL)))
|
||
(IMPLODE X))
|
||
(T (CAR JCL))))
|
||
(EQ JCL 'NEWUSER)) ; sets up super-image mode
|
||
(SYSCALL 0 'TTYSET TYO
|
||
(CAR (STATUS TTY)) (CADR (STATUS TTY))
|
||
(BOOLE 7 1_19. (CADDR (STATUS TTY))))
|
||
;; bit 3.2 (%TSSII) of TTYSTS
|
||
(SSTATUS TTYINT 26. NIL)
|
||
(REMPROP '$QUIT 'SUBR) (SETQ JCL NIL))
|
||
(T (SETQ JCL (CONS JCL T))))
|
||
(SETQ TTYHEIGHT (CAR (STATUS TTYSIZE))
|
||
$PLOTHEIGHT (COND ((< TTYHEIGHT 200.) (- TTYHEIGHT 2)) (T 24.))
|
||
$DIREC (CADR USER) $FILENAME (EXPLODEN USRNAM) I 1)
|
||
(COND ((> (LENGTH $FILENAME) 3) (RPLACD (CDDR $FILENAME) NIL)))
|
||
LOOP (SETQ X (IMPLODE (APPEND $FILENAME (EXPLODEN I))))
|
||
(COND ((PROBEF (LIST X '> 'DNRF $DIREC)) (SETQ I (1+ I)) (GO LOOP)))
|
||
(SETQ $FILENAME (MAKEALIAS X) $DIREC (MAKEALIAS $DIREC))
|
||
(SSTATUS GCTIME 0)
|
||
(SETQ STIME0 (TIME) ERRLIST '((ERRLFUN NIL)))
|
||
(SETQ SAVEFILE (OPEN '((NUL)) '(OUT FIXNUM)))
|
||
(CLOSE SAVEFILE)
|
||
(PROG (TTYOPT)
|
||
(SETQ TTYOPT (CAR (CDDDDR (SYSCALL 6 'CNSGET TYO))))
|
||
;; %TOFCI (bit 3.4) = terminal has a 12 bit keyboard.
|
||
(SETQ 12-BIT-TTY (NOT (= (BOOLE 1 8_18. TTYOPT) 0)))
|
||
;; %TOMVU (bit 3.9) = terminal can do vertical cursor movement.
|
||
;; However, we must also make sure that the screen size
|
||
;; is within the ITS addressing limits.
|
||
(SETQ SMART-TTY (AND (NOT (= (BOOLE 1 256._18. TTYOPT) 0))
|
||
(< TTYHEIGHT 200.)
|
||
(< LINEL 128.)))
|
||
;; %TOERS (bit 4.6) = terminal can selectively erase.
|
||
;; %TOMVB (bit 4.4) = terminal can backspace.
|
||
;; %TOOVR (bit 4.1) = terminal can overstrike (i.e. printing one
|
||
;; character on top of another causes both to
|
||
;; appear.)
|
||
;; If it can either selectively erase, or backspace and not
|
||
;; overstrike, then we can do rubout processing. An example of
|
||
;; a terminal which can backspace and overstrike, but is not
|
||
;; selectively erasable is a storage tube display.
|
||
(SETQ RUBOUT-TTY
|
||
(OR (NOT (= (BOOLE 1 32._27. TTYOPT) 0)) ;%TOERS
|
||
(AND (NOT (= (BOOLE 1 8._27. TTYOPT) 0)) ;%TOMVB
|
||
(= (BOOLE 1 1_27. TTYOPT) 0)))) ;%TOOVR
|
||
;; %TOCID (bit 3.1) = terminal can insert and delete characters.
|
||
;; If the console has a 12-bit keyboard, an 85 by 50 screen, and
|
||
;; can't ins/del characters, then it must be a Plasma console.
|
||
(SETQ PLASMA-TTY
|
||
(AND 12-BIT-TTY (= LINEL 84.) (= TTYHEIGHT 50.)
|
||
(= 0 (BOOLE 1 1_18. TTYOPT))))
|
||
)
|
||
;; ***** Vestigial. To be flushed someday. *****
|
||
(SETQ CURSORPOS SMART-TTY)
|
||
(SETQ $ERROR_SIZE (COND (SMART-TTY 20.) (T 10.)))
|
||
;; Use block mode I/O for efficiency. .SIOT used instead of .IOT.
|
||
;; See DISPLA for how this is used.
|
||
(COND (SMART-TTY
|
||
(SETQ DISPLAY-FILE (OPEN '|TTY:| '(TTY OUT IMAGE BLOCK)))))
|
||
;; Sail characters to be supported someday.
|
||
;; (COND (12-BIT-TTY
|
||
;; (SETQ 12-BIT-INPUT (OPEN '|TTY:| '(TTY IN FIXNUM)))))
|
||
;; Load graphic support package for the particular terminal type.
|
||
;; Vectors are drawn if possible. Otherwise, an extended character
|
||
;; set is used. No TCTYP entry exists for the VT100, so look for
|
||
;; a CRTSTY instead.
|
||
(COND (PLASMA-TTY (LOAD '((MACSYM) ARDS)))
|
||
((OR (= TTY 13.) (JOB-EXISTS 'H19) (JOB-EXISTS 'H19WHO))
|
||
(LOAD '((MACSYM) H19)))
|
||
((JOB-EXISTS 'VT100)
|
||
(LOAD '((MACSYM) VT100))))
|
||
(REMPROP 'JOB-EXISTS 'EXPR)
|
||
;; Why is this necessary? Lisp sets it up to be '(T) by default.
|
||
(SETQ MSGFILES (LIST TYO))
|
||
(SETQ TTY-RETURN 'TTYRETFUN)
|
||
(SETQ DEFAULTF (OR DEFAULTF* (CONS USER '(NOFILE >))))
|
||
(COND ((EQ JCL 'NO))
|
||
((AND JCL (NULL (CDR JCL)))
|
||
(COND ((OR (PROBEF (SETQ X (LIST (CAR JCL) 'MACSYM 'DSK (CAR JCL))))
|
||
(PROBEF (SETQ X (CONS '|.ALL.| (CDR X)))))
|
||
(ERRSET (LOAD-FILE X)))))
|
||
(JCL
|
||
(COND ((OR (PROBEF (SETQ X (LIST (CAR JCL) 'MACSYM 'DSK
|
||
(STATUS HSNAME (CAR JCL)))))
|
||
(PROBEF (SETQ X (CONS '|.ALL.| (CDR X)))))
|
||
(ERRSET (LOAD-FILE X)))))
|
||
((OR (PROBEF (SETQ X (LIST (STATUS XUNAME) 'MACSYM 'DSK (STATUS HSNAME))))
|
||
(PROBEF (SETQ X (CONS '|.ALL.| (CDR X)))))
|
||
(ERRSET (LOAD-FILE X))))
|
||
(SETQ DEFAULTF (OR DEFAULTF* (CONS USER '(NOFILE >))))
|
||
(COND ((GETL 'FIXUP '(SUBR EXPR)) (FIXUP) (REMPROP 'FIXUP 'EXPR)))))
|
||
|
||
(DEFUN LAPTEMPS FEXPR (L)
|
||
((LAMBDA (I) (LAPCHECK (LENGTH L))
|
||
(DO Z L (CDR Z) (NULL Z) (DEFSYM (CAR Z) I) (SETQ I (1+ I))))
|
||
VORG))
|
||
|
||
(DEFUN LAPCHECK (N)
|
||
(COND ((SIGNP LE (SETQ VLNTH (- VLNTH N)))
|
||
(TERPRI) (PRINC 'IMPURE/ AREA/ IS/ TOO/ SMALL) (ERR)))
|
||
(SETQ VORG (+ VORG N)))
|
||
|
||
(PROGN (NORET T) ; GC shouldn't return core.
|
||
; (SSTATUS LOSEF 10.) ; LAP Object Storage Efficiency Factor
|
||
(SETQ VORG BPORG)
|
||
(GETSP 8.)
|
||
(SETQ BPORG (+ BPORG 8.) VLNTH (- BPORG VORG))
|
||
(DEFPROP MACSYMA-MODULE MACSYMA-MODULE-MACRO MACRO)
|
||
(DEFPROP MACSYMA-MODULE-MACRO "DSK:LIBMAX;MODULE" AUTOLOAD))
|