mirror of
https://github.com/PDP-10/its.git
synced 2026-01-30 05:34:01 +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.
297 lines
9.6 KiB
Common Lisp
297 lines
9.6 KiB
Common Lisp
;;;-*-lisp-*-
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;To run this primer interpreted, the following files must be LOADFILED into ;;
|
||
;;MACSYMA: MRG;MACROS FASL, ELLEN;CHECK >, ELLEN;SCRIPT >, and this file. ;;
|
||
;;I do not recommend doing that, however. -Ellen ;;
|
||
;;(C) Copyright 1979, Massachusetts Institute of Technology ;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
(DECLARE (SPECIAL CLABEL DLABEL NSP TB LP RP SCRIPTINDEX LISPREADTABLE
|
||
$% $LABELS $LINENUM $INCHAR $OUTCHAR
|
||
LINEL GCT $SHOWTIME $LASTTIME)
|
||
(UNSPECIAL *)
|
||
(*EXPR MEVAL STRIPDOLLAR DISPLA MGRIND MAKSTRING ADD2LNC RETRIEVE)
|
||
(*FEXPR $LOADFILE) (FASLOAD MACROS FASL DSK MRG))
|
||
|
||
(DECLARE (EVAL (READ)))
|
||
(SETSYNTAX '/# 'MACRO 'TYI)
|
||
(SETSYNTAX '/" 'MACRO 'READTEXT)
|
||
(DEFUN READTEXT ()
|
||
(LAMBIND ((READTABLE (GET 'PRIMER 'ARRAY)))
|
||
(DO ((S (READ) (READ)) (NL)) ((EQ '/" S) `(TEXT ',(NREVERSE NL)))
|
||
(SETQ NL (CONS S NL))
|
||
(IF (EQ '/@ S)
|
||
(LAMBIND ((READTABLE LISPREADTABLE)) (SETQ NL (CONS (READ) NL)))))))
|
||
|
||
(SETSYNTAX #~ 'MACRO 'NOFILL)
|
||
(DEFUN NOFILL ()
|
||
(DO ((C (TYI) (TYI)) (CL))
|
||
((= #~ C) `(PRINC ',(MAKNAM (NREVERSE CL))))
|
||
(SETQ CL (CONS C CL))))
|
||
|
||
(*ARRAY 'PRIMER 'READTABLE T)
|
||
(LAMBIND ((READTABLE (GET 'PRIMER 'ARRAY)))
|
||
(DO I ## (1+ I) (> I #@) (SETSYNTAX I 1 I))
|
||
(DO I #a (1+ I) (> I #z) (SETSYNTAX I 1 I))
|
||
(SETSYNTAX #` 'SINGLE #`)
|
||
(SETSYNTAX #@ 'SINGLE #@)
|
||
(SETSYNTAX #" 'SINGLE #"))
|
||
|
||
(DECLARE (COUTPUT (READ)))
|
||
(DEFUN IF MACRO (X)
|
||
(COND ((NULL (CDDDR X)) `(COND (,(CADR X) ,(CADDR X))))
|
||
(T `(COND (,(CADR X) ,(CADDR X)) (T . ,(CDDDR X))))))
|
||
|
||
(SETQ LISPREADTABLE READTABLE
|
||
SCRIPTINDEX '(($INTRO (SCRIPT INTRO DSK ELLEN)(CHECK FASL DSK ELLEN))
|
||
($CONSOLEPRIMER (SCRIPT INTRO DSK ELLEN)
|
||
(CHECK FASL DSK ELLEN))
|
||
($HELP (SCRIPT INTRO DSK ELLEN)(CHECK FASL DSK ELLEN))
|
||
($SYNTAX (SCRIPT INTRO DSK ELLEN)(CHECK FASL DSK ELLEN))
|
||
($SIMPLIFICATION (SCRIPT INTRO DSK ELLEN)
|
||
(CHECK FASL DSK ELLEN))
|
||
($SCRATCHPAD (SCRIPT INTRO DSK ELLEN)
|
||
(CHECK FASL DSK ELLEN))
|
||
($ASSIGNMENT (SCRIPT AUX DSK ELLEN)
|
||
(CHECK FASL DSK ELLEN))
|
||
($FILING (SCRIPT AUX DSK ELLEN)
|
||
(CHECK FASL DSK ELLEN))
|
||
($STRINGCOMMANDS (SCRIPT AUX DSK ELLEN)
|
||
(CHECK FASL DSK ELLEN))
|
||
($MATRICES (SCRIPT MATRIX DSK ELLEN)
|
||
(CHECK FASL DSK ELLEN))
|
||
($SHARE (SHARE SCRIPT DSK ELLEN))
|
||
($ABSIMP (SHARE SCRIPT DSK ELLEN))
|
||
($ROMBER (SHARE SCRIPT DSK ELLEN))
|
||
($FFT (SHARE SCRIPT DSK ELLEN))
|
||
($DESOLN (SHARE SCRIPT DSK ELLEN))
|
||
($UNITS (SHARE SCRIPT DSK ELLEN))
|
||
($ARRAY (SHARE SCRIPT DSK ELLEN))
|
||
($DIMEN (SHARE SCRIPT DSK ELLEN))
|
||
($DUMP (SHARE SCRIPT DSK ELLEN))
|
||
($FACT (SHARE SCRIPT DSK ELLEN))
|
||
($INTPOL (SHARE SCRIPT DSK ELLEN))
|
||
($MATCH (MATCH SCRIPT DSK MRG))))
|
||
|
||
|
||
(DEFUN $PRIMER FEXPR (X)
|
||
(SETQ X (COND (X (CAR X))
|
||
((SEENP (STATUS UNAME) '$CONSOLEPRIMER) '$HELP)
|
||
(T '$CONSOLEPRIMER)))
|
||
(*CATCH 'PQUIT (SCRIPT X T))
|
||
'$DONE)
|
||
|
||
(DEFUN SEENP (USER SC)
|
||
(PROGB (IN)
|
||
(SETQ IN (OPEN '(USER PROFIL DSK ALJABR) 'IN))
|
||
(DO ((U (READ IN 'EOF) (READ IN 'EOF))) ((EQ U 'EOF) (CLOSE IN) NIL)
|
||
(COND ((EQ USER (CAR U)) (CLOSE IN) (RETURN (MEMQ SC (CDR U))))))))
|
||
|
||
(DEFUN SEEN (USER SC)
|
||
(PROGB (IN OUT)
|
||
(SETQ IN (OPEN '(USER PROFIL DSK ALJABR) 'IN)
|
||
OUT (OPEN '(USER PROFIL DSK ALJABR) 'OUT))
|
||
(DO ((U (READ IN NIL) (READ IN NIL)) (SUCCESS))
|
||
((NULL U) (IFN SUCCESS (PRINT (LIST USER SC) OUT)))
|
||
(IFN (EQ USER (CAR U)) T (SETQ SUCCESS T) (RPLACD U (CONS SC (CDR U))))
|
||
(PRINT U OUT))
|
||
(CLOSE IN) (CLOSE OUT)))
|
||
|
||
(DEFUN SCRIPT (SC TOP)
|
||
(SETQ SC (GETSCRIPT SC TOP))
|
||
(*CATCH 'EXIT (DO () ((NULL SC)) (TERPRI) (EVAL (CAR SC))
|
||
(SETQ SC (CDR SC)))))
|
||
|
||
(DEFUN GETSCRIPT (SC TOP)
|
||
(PROGB (*)
|
||
(COND ((GET SC 'SCRIPT))
|
||
((AND (SETQ * (CDR (ASSQ SC SCRIPTINDEX)))
|
||
(DO ((L * (CDR L))) ((NULL L) T)
|
||
(APPLY '$LOADFILE (CAR L)))
|
||
(GET SC 'SCRIPT)))
|
||
(T (TERPRI) (PRINC '|No such script.|) (COND (TOP (ERR)))))))
|
||
|
||
(DEFUN TEXT (L)
|
||
(TERPRI) (TYO TB)
|
||
(DO ((X) (W) (WD 8)) ((NULL L)) (DECLARE (FIXNUM W WD))
|
||
(IF (NOT (EQ '/@ (CAR L))) (SETQ X (CAR L) W (FLATC X))
|
||
(SETQ L (CDR L) X (STRGRIND (EVAL (CAR L))) W (LENGTH X)))
|
||
(COND ((>= (+ 3 W WD) LINEL) (TERPRI) (SETQ WD 0)))
|
||
(IF (ATOM X) (PRINC X) (MAPC 'TYO X)) (TYO NSP)
|
||
(SETQ L (CDR L) WD (+ 1 W WD))))
|
||
|
||
|
||
(DEFUN EXIT () (*THROW 'EXIT NIL))
|
||
(DEFUN PQUIT () (*THROW 'PQUIT NIL))
|
||
|
||
|
||
(DEFUN YESORNO ()
|
||
(TERPRI)
|
||
(DO ANS (RETRIEVE NIL NIL) (RETRIEVE NIL NIL) NIL
|
||
(COND ((MEMQ ANS '($YES $YEP $YEAH $Y $YUP $SURE $OK $T)) (RETURN T))
|
||
((MEMQ ANS '($NO $N $NOPE $NIL)) (RETURN NIL))
|
||
(T (PRINC '|Was that a YES or a NO?|)
|
||
(TERPRI)))))
|
||
|
||
(DEFUN MREAD ()
|
||
(SETQ CLABEL (MAKLABEL $INCHAR $LINENUM)) (ADD2LNC CLABEL $LABELS)
|
||
(TERPRI) (PRLABEL CLABEL) (SET CLABEL (RETRIEVE NIL NIL)))
|
||
|
||
(DEFUN MPRINEVAL ()
|
||
(PROGB (TIME)
|
||
(SETQ TIME (RUNTIME) GCT (STATUS GCTIME) $% (MEVAL (EVAL CLABEL)))
|
||
(SETQ DLABEL (MAKLABEL $OUTCHAR $LINENUM)) (ADD2LNC DLABEL $LABELS)
|
||
(DISPLA `((MLABLE) ,DLABEL ,(SET DLABEL $%)))
|
||
(SETQ $LASTTIME (LIST '(MLIST SIMP)
|
||
(COMPUTIME (RUNTIME) TIME)
|
||
(COMPUTIME (STATUS GCTIME) GCT)))
|
||
(COND ($SHOWTIME (IF (NOT (ZEROP (CHARPOS T))) (TERPRI))
|
||
(PRINC '|time=|) (PRINC (CADR $LASTTIME)) (PRINC '| msec.|)
|
||
(TERPRI)))
|
||
(SETQ $LINENUM (1+ $LINENUM))
|
||
$%))
|
||
|
||
(DEFUN MACSYMA (FORM)
|
||
(SETQ CLABEL (MAKLABEL $INCHAR $LINENUM)) (ADD2LNC CLABEL $LABELS)
|
||
(TERPRI) (PRLABEL CLABEL) (MAPC 'PRINC (MAKSTRING FORM)) (TYO #;)
|
||
(SET CLABEL FORM) (MPRINEVAL))
|
||
|
||
(DEFUN MAKLABEL (C N) (IMPLODE (NCONC (EXPLODEN C) (EXPLODEN N))))
|
||
|
||
(DEFUN PRLABEL (L) (PRINC '|(|) (PRINC (STRIPDOLLAR L)) (PRINC '|) |))
|
||
|
||
(DEFUN CLINE (X)
|
||
(TERPRI)
|
||
(TYO TB)
|
||
(MGRIND X T)) ;MGRIND take OUTPUT file as 2nd arg -- RWK
|
||
|
||
|
||
(DEFUN CENTER (X) (DISPLA (LIST '(MLABLE) NIL X)))
|
||
|
||
|
||
|
||
(DEFUN DEFSCRIPT FEXPR (F) (PUT (CAR F) (CDR F) 'SCRIPT) (CAR F))
|
||
|
||
(DEFUN MACSYM ()
|
||
(DO ((X)) ((NOT (ATOM X)) (CAR X))
|
||
(MREAD) (SETQ X (ERRSET (MPRINEVAL)))))
|
||
|
||
(DEFUN INCHK (PAT)
|
||
(DO ((X (MREAD) (MREAD))) (NIL)
|
||
(COND ((OR (EQ '$EXIT X)(EQ '$QUIT X))
|
||
(EXIT))
|
||
((EQ '$NO X)
|
||
(TERPRI) (PRINC '|O.K., I'll do it for you.|)
|
||
(RETURN (MACSYMA PAT)))
|
||
((PALIKE PAT X) (RETURN (MPRINEVAL)))
|
||
(T (TERPRI) (PRINC '|Try again.|) (TERPRI)))))
|
||
|
||
(DEFUN OUTCHK (PAT)
|
||
(DO X (MACSYM) (MACSYM) (PALIKE PAT X)
|
||
(TERPRI) (PRINC '|Try again.|) (TERPRI)))
|
||
|
||
|
||
(DEFUN INCHKP (P)
|
||
(DO ((X (MREAD) (MREAD))(Y)) (NIL)
|
||
(IF (SETQ Y (FUNCALL P X)) (RETURN (COND ((NOT (EQ Y 'NOLABEL))
|
||
(MPRINEVAL))))
|
||
(TERPRI) (PRINC '|Try again.|))))
|
||
|
||
(DEFUN OUTCHK2 (PRED)
|
||
(DO X (MACSYM)(MACSYM)
|
||
(COND ((OR (EQ '$EXIT X) (EQ '$QUIT X)) (EXIT))
|
||
((EQ '$NO X))
|
||
((FUNCALL PRED X)))
|
||
(TERPRI) (PRINC '|Try again.|) (TERPRI)))
|
||
|
||
(DEFUN PALIKE (PAT X)
|
||
(COND ((EQ PAT X))
|
||
((EQ 'DLABEL PAT) (PALIKE DLABEL X))
|
||
((ATOM PAT) (AND (ATOM X) (EQUAL (MEVAL PAT) (MEVAL X))))
|
||
((ATOM X) NIL)
|
||
((EQ (CAAR PAT) (CAAR X))
|
||
(SETQ PAT (CDR PAT) X (CDR X))
|
||
(DO () ((NOT (PALIKE (CAR PAT) (CAR X))))
|
||
(COND ((NULL PAT) (IF (NULL X) (RETURN T)))
|
||
((NULL X) (RETURN NIL))
|
||
(T (SETQ PAT (CDR PAT) X (CDR X))))))))
|
||
|
||
(DEFUN DECODE (X L)
|
||
(COND ((NOT (EQ (TYPEP X) 'FIXNUM)) (NOR-ERR))
|
||
((OR (NOT (> X 0)) (> X (LENGTH L))) (NOR-ERR))
|
||
((SETQ X (NTHCDR (1- X) L)) (CAR X))
|
||
(T (NOR-ERR))))
|
||
|
||
(DEFUN SPELLCHECK (X L)
|
||
(COND ((NOT (ISITIN X L)) (SPELL-ERR))
|
||
(T X)))
|
||
|
||
(DEFUN MENU (OPTS)
|
||
(DO ((L OPTS (CDR L)) (I 1 (1+ I))) ((NULL L))
|
||
(PRINC I) (PRINC '| - |) (PRINC (FULLSTRIP1 (CAR L)))
|
||
(COND ((GET (CAR L) 'KIND) (TYO NSP) (PRINC (GET (CAR L) 'KIND))))
|
||
(TERPRI)))
|
||
|
||
(DEFUN SPELL-ERR () (PRINC '|No such script. Try again.|) (TERPRI))
|
||
(DEFUN OPT-ERR () (PRINC '|Illegal command to OPTIONS|) (TERPRI))
|
||
(DEFUN NOR-ERR () (PRINC '|Number out of range|) (TERPRI))
|
||
|
||
|
||
(DEFUN SELECT (L) (IF (EQ '$EXIT (SETQ L (SELECT1 L))) (PQUIT) (SCRIPT L NIL)))
|
||
|
||
(DEFUN SELECT1 (L)
|
||
(DO ((ANS)) (NIL)
|
||
(MENU L)
|
||
(SETQ ANS (RETRIEVE NIL NIL))
|
||
(COND ((FIXP ANS) (IF (SETQ ANS (DECODE ANS L)) (RETURN ANS)))
|
||
((ATOM ANS) (IF (SETQ ANS (SPELLCHECK ANS L))(RETURN ANS))))))
|
||
|
||
(DEFUN CMDCHKP (CMD)
|
||
(DO ((X (MREAD) (MREAD))) (NIL)
|
||
(COND ((OR (EQ '$EXIT X)(EQ '$QUIT X))
|
||
(EXIT))
|
||
((EQ '$NO X)
|
||
(TERPRI) (PRINC '|O.K., I'll do it for you.|)
|
||
(RETURN (MACSYMA CMD)))
|
||
((CMDCHKP2 CMD X)(RETURN (MPRINEVAL)))
|
||
(T (TERPRI) (PRINC '|Try again.|)))))
|
||
|
||
|
||
(DEFUN CMDCHKP2 (C D)
|
||
(COND ((ATOM D)
|
||
(TERPRI) (PRINC '|Oops, you typed the ; too soon.|) NIL)
|
||
((NOT (EQ (CAAR C)(CAAR D)))
|
||
(CMDCHKP3 (CAAR D)(CAAR C)) NIL)
|
||
((EQ '$% (CADR D)))
|
||
((NOT (EQUAL (CADR C)(CADR D)))
|
||
(TERPRI) (PRINC '|Use |)
|
||
(PRINC (FULLSTRIP1 (CADR C))) NIL)
|
||
((NOT (PALIKE C D)) NIL)
|
||
(T T)))
|
||
|
||
|
||
(DEFUN CMDCHKP3 (E C)
|
||
(COND ((MEMQ (CAR (PLIST E)) '(SUBR LSUBR EXPR FEXPR))
|
||
(TERPRI)(PRINC '|Please use the |)
|
||
(PRINC (FULLSTRIP1 C))
|
||
(PRINC '| command.|))
|
||
(T (TERPRI) (PRINC '|Check your spelling.|))))
|
||
|
||
(DEFUN INOUTCHK (CMD PAT)
|
||
(DO ((X (MREAD) (MREAD))) (NIL)
|
||
(COND ((ATOM X)
|
||
(TERPRI) (PRINC '|Aw, come on, this is easy.|) NIL)
|
||
((NOT (EQ CMD (CAAR X)))
|
||
(COND ((MEMQ (CAR (PLIST (CAAR X))) '(SUBR LSUBR EXPR FEXPR))
|
||
(TERPRI)(PRINC '|Please use the |)
|
||
(PRINC (FULLSTRIP1 CMD))
|
||
(PRINC '| command.|))
|
||
(T (TERPRI) (PRINC '|Check your spelling.|))) NIL)
|
||
((PALIKE PAT (MPRINEVAL))(RETURN T)))
|
||
(TERPRI) (PRINC '|Try again.|)(TERPRI)))
|
||
|
||
(DEFUN ISITIN (A L)
|
||
(COND ((ATOM L) (EQ A L))
|
||
(T (DO () ((NULL L) NIL)
|
||
(COND ((ISITIN A (CAR L)) (RETURN T))
|
||
(T (SETQ L (CDR L))))))))
|
||
|