mirror of
https://github.com/PDP-10/its.git
synced 2026-02-03 07:20:35 +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.
318 lines
10 KiB
Plaintext
318 lines
10 KiB
Plaintext
|
||
(DECLARE (MACROS T) (SPECIAL /!MARKS))
|
||
|
||
(SETQ /!MARKS `(,(CAR '`,,A) ,(CAR '`,,@A)))
|
||
|
||
(EVAL-WHEN (EVAL COMPILE LOAD)
|
||
(SETSYNTAX '/: 'MACRO
|
||
'(LAMBDA () (DO ((L (LIST (READ)) (CONS (READ) L)))
|
||
((NOT (= 58. (TYIPEEK))) (CONS 'SEL (NREVERSE L)))
|
||
(TYI))))
|
||
(SETSYNTAX '/! 'MACRO '(LAMBDA () (/! ((LAMBDA (**BACKQUOTE**) (READ)) T))))
|
||
(DEFUN /! (X)
|
||
(COND ((ATOM X) (LIST 'QUOTE X))
|
||
((EQ (CAR X) (CAR /!MARKS)) (CDR X))
|
||
((EQ 'SELECTOR (CAR X)) X)
|
||
(T (LIST 'CONS (/! (CAR X)) (/! (CDR X))))))
|
||
(SETSYNTAX '/< 'MACRO
|
||
'(LAMBDA ()
|
||
(COND ((= 32. (TYIPEEK)) '/<)
|
||
((= 61. (TYIPEEK)) (TYI) '/<=)
|
||
(T (DO ((S (READ) (READ)) (NL))
|
||
((EQ '/> S) (CONS 'SELECTOR (NREVERSE NL)))
|
||
(SETQ NL (CONS S NL)))))))
|
||
(SETSYNTAX '/> 'MACRO
|
||
'(LAMBDA () (IF (NOT (= 61. (TYIPEEK))) '/> (TYI) '/>=)))
|
||
)
|
||
|
||
|
||
(DEFUN LAMBIND MACRO (X)
|
||
(DO ((L (CADR X) (CDR L)) (NL) (VL))
|
||
((NULL L)
|
||
(SETQ VL (NREVERSE VL) NL (NREVERSE NL))
|
||
`((LAMBDA ,VL . ,(CDDR X)) . ,NL))
|
||
(COND ((ATOM (CAR L)) (SETQ VL (CONS (CAR L) VL) NL (CONS NIL NL)))
|
||
(T (SETQ VL (CONS (CAAR L) VL) NL (CONS (CADAR L) NL))))))
|
||
|
||
(DEFUN LAMBIND* MACRO (X)
|
||
(DO ((L (CADR X) (CDR L)) (NL) (VL))
|
||
((NULL L)
|
||
(SETQ VL (NREVERSE VL) NL (NREVERSE NL))
|
||
`((LAMBDA ,VL (PROG NIL . ,(CDDR X))) . ,NL))
|
||
(COND ((ATOM (CAR L)) (SETQ VL (CONS (CAR L) VL) NL (CONS NIL NL)))
|
||
(T (SETQ VL (CONS (CAAR L) VL) NL (CONS (CADAR L) NL))))))
|
||
|
||
(DEFUN PROGB MACRO (X)
|
||
(DO ((L (CADR X) (CDR L)) (NL) (VL))
|
||
((NULL L)
|
||
(SETQ VL (NREVERSE VL) NL (NREVERSE NL))
|
||
`((LAMBDA ,VL . ,(CDDR X)) . ,NL))
|
||
(COND ((ATOM (CAR L)) (SETQ VL (CONS (CAR L) VL) NL (CONS NIL NL)))
|
||
(T (SETQ VL (CONS (CAAR L) VL) NL (CONS (CADAR L) NL))))))
|
||
|
||
(DEFUN PROGB* MACRO (X)
|
||
(DO ((L (CADR X) (CDR L)) (NL) (VL))
|
||
((NULL L)
|
||
(SETQ VL (NREVERSE VL) NL (NREVERSE NL))
|
||
`((LAMBDA ,VL (PROG NIL . ,(CDDR X))) . ,NL))
|
||
(COND ((ATOM (CAR L)) (SETQ VL (CONS (CAR L) VL) NL (CONS NIL NL)))
|
||
(T (SETQ VL (CONS (CAAR L) VL) NL (CONS (CADAR L) NL))))))
|
||
|
||
(DEFUN MAPAND MACRO (X)
|
||
`(DO ((L ,(CADDR X) (CDR L))) ((NULL L) T)
|
||
(IFN (,(CADR X) (CAR L)) (RETURN NIL))))
|
||
|
||
(DEFUN MAPOR MACRO (X)
|
||
`(DO L ,(CADDR X) (CDR L) (NULL L)
|
||
(IF (FUNCALL ,(CADR X) (CAR L)) (RETURN T))))
|
||
|
||
(DEFUN MAPLAC MACRO (X)
|
||
`(DO L ,(CADDR X) (CDR L) (NULL L) (RPLACA L (,(CADR X) (CAR L)))))
|
||
|
||
(DEFUN IF MACRO (X)
|
||
(COND ((NULL (CDDDR X)) `(COND (,(CADR X) ,(CADDR X))))
|
||
(T `(COND (,(CADR X) ,(CADDR X)) (T . ,(CDDDR X))))))
|
||
|
||
(DEFUN IFN MACRO (X)
|
||
(COND ((NULL (CDDDR X)) `(COND ((NOT ,(CADR X)) ,(CADDR X))))
|
||
(T `(COND ((NOT ,(CADR X)) ,(CADDR X)) (T . ,(CDDDR X))))))
|
||
|
||
(DEFUN PUT MACRO (X) `(PUTPROP . ,(CDR X)))
|
||
(DEFUN REM MACRO (X) `(REMPROP . ,(CDR X)))
|
||
|
||
(DEFUN IAND MACRO (X) `(BOOLE 1 . ,(CDR X)))
|
||
(DEFUN IOR MACRO (X) `(BOOLE 7 . ,(CDR X)))
|
||
|
||
(DEFUN XOR MACRO (X) `(NOT (EQ . ,(CDR X))))
|
||
|
||
(DEFUN COPY MACRO (X) `(SUBST NIL NIL ,(CADR X)))
|
||
(DEFUN COPYP MACRO (X) `(CONS (CAR ,(CADR X)) (CDR ,(CADR X))))
|
||
(DEFUN COPYL MACRO (X) `(APPEND ,(CADR X) NIL))
|
||
|
||
(DEFUN >= MACRO (X) `(NOT (< ,(CADR X) ,(CADDR X))))
|
||
(DEFUN <= MACRO (X) `(NOT (> ,(CADR X) ,(CADDR X))))
|
||
|
||
(DEFUN ECONS MACRO (X) `(APPEND ,(CADR X) (LIST ,(CADDR X))))
|
||
|
||
(DEFUN CAAADAR MACRO (X) `(CAAADR (CAR ,(CADR X))))
|
||
(DEFUN CAAADDR MACRO (X) `(CAAADR (CDR ,(CADR X))))
|
||
(DEFUN CAADAAR MACRO (X) `(CAADAR (CAR ,(CADR X))))
|
||
(DEFUN CAADADR MACRO (X) `(CAADAR (CDR ,(CADR X))))
|
||
(DEFUN CADAAAR MACRO (X) `(CADAAR (CAR ,(CADR X))))
|
||
(DEFUN CADADDR MACRO (X) `(CADADR (CDR ,(CADR X))))
|
||
(DEFUN CADDAAR MACRO (X) `(CADDAR (CAR ,(CADR X))))
|
||
(DEFUN CADDADR MACRO (X) `(CADDAR (CDR ,(CADR X))))
|
||
(DEFUN CADDDAR MACRO (X) `(CADDDR (CAR ,(CADR X))))
|
||
(DEFUN CADDDDR MACRO (X) `(CADDDR (CDR ,(CADR X))))
|
||
(DEFUN CDADADR MACRO (X) `(CDADAR (CDR ,(CADR X))))
|
||
(DEFUN CDADDDR MACRO (X) `(CDADDR (CDR ,(CADR X))))
|
||
(DEFUN CDDDDDR MACRO (X) `(CDDDDR (CDR ,(CADR X))))
|
||
|
||
|
||
(DECLARE (SPECIAL NAME BAS MOBJECTS SELECTOR) (*EXPR MODE))
|
||
|
||
|
||
(SETQ MOBJECTS NIL)
|
||
|
||
|
||
(DEFPROP MODE (C-MODE S-MODE A-MODE) MODE)
|
||
|
||
(DEFUN C-MODE MACRO (X) `(LIST . ,(CDR X)))
|
||
|
||
(DEFUN S-MODE MACRO (X)
|
||
(COND ((EQ 'C (CADDR X)) `(CAR ,(CADR X)))
|
||
((EQ 'SEL (CADDR X)) `(CADR ,(CADR X)))
|
||
((EQ '_ (CADDR X)) `(CADDR ,(CADR X)))))
|
||
|
||
(DEFUN A-MODE MACRO (X)
|
||
(COND ((EQ 'C (CADDR X)) `(RPLACA (CADR X) ,(CADDDR X)))
|
||
((EQ 'SEL (CADDR X)) `(RPLACA (CDR ,(CADR X)) ,(CADDDR X)))
|
||
((EQ '_ (CADDR X)) `(RPLACA (CDDR ,(CADR X)) ,(CADDDR X)))))
|
||
|
||
|
||
|
||
(DEFUN DEFMODE MACRO (X)
|
||
(LAMBIND ((SELECTOR (MEMQ 'SELECTOR (CDDDDR X))))
|
||
(DEFINE-MODE (CADR X) (CADDDR X))
|
||
(MAPC 'EVAL (CDDDDR X))
|
||
`',(CADR X)))
|
||
|
||
(DEFUN DEFINE-MODE (NAME DESC)
|
||
(PROG (C S A DUMMY)
|
||
(SETQ DUMMY (EXPLODEC NAME)
|
||
C (IMPLODE (APPEND '(C -) DUMMY))
|
||
S (IMPLODE (APPEND '(S -) DUMMY))
|
||
A (IMPLODE (APPEND '(A -) DUMMY)))
|
||
(PUT C (DEFC DESC) 'MACRO)
|
||
(PUT S (DEFS DESC) 'MACRO)
|
||
(PUT A (DEFA DESC) 'MACRO)
|
||
(PUT NAME (C-MODE C S A) 'MODE)
|
||
(RETURN NAME)))
|
||
|
||
|
||
(DEFUN DEFC (DESC) (LAMBIND ((BAS 'X)) `(LAMBDA (X) ,(DEFC1 DESC))))
|
||
|
||
(DEFUN DEFC1 (DESC)
|
||
(COND ((ATOM DESC) (LIST 'QUOTE DESC))
|
||
((EQ 'SELECTOR (CAR DESC))
|
||
(IF (NOT (NULL (CDDDR DESC))) (LIST 'QUOTE (CADDDR DESC))
|
||
(SETQ BAS (LIST 'CDR BAS)) (LIST 'CAR BAS)))
|
||
((EQ 'ATOM (CAR DESC))
|
||
`(LIST 'C-ATOM '',(MAPCAR 'CADR (CDR DESC)) (CONS 'LIST (CDR X))))
|
||
((EQ 'CONS (CAR DESC)) `(LIST 'CONS ,(DEFC1 (CADR DESC)) ,(DEFC1 (CADDR DESC))))
|
||
((EQ 'LIST (CAR DESC))
|
||
(DO ((L (CDR DESC) (CDR L)) (NL))
|
||
((NULL L) `(LIST 'LIST . ,(NREVERSE NL)))
|
||
(SETQ NL (CONS (DEFC1 (CAR L)) NL))))
|
||
((EQ 'STRUCT (CAR DESC)) (DEFC1 (CONS 'LIST (CDR DESC))))
|
||
(T (LIST 'QUOTE DESC))))
|
||
|
||
|
||
(DEFUN DEFS (DESC)
|
||
`(LAMBDA (X) (COND . ,(NREVERSE (DEFS1 DESC '(CADR X) NIL)))))
|
||
|
||
(DEFUN DEFS1 (DESC BAS RESULT)
|
||
(COND ((ATOM DESC) RESULT)
|
||
((EQ 'SELECTOR (CAR DESC))
|
||
(PUT (CADR DESC) (CONS (CONS NAME (CADDR DESC)) (GET (CADR DESC) 'MODES)) 'MODES)
|
||
(PUT NAME (CONS (CONS (CADR DESC) (CADDR DESC)) (GET NAME 'SELS)) 'SELS)
|
||
(IF SELECTOR (PUT (CADR DESC) 'SELECTOR 'MACRO))
|
||
(CONS `((EQ ',(CADR DESC) (CADDR X)) ,BAS) RESULT))
|
||
((EQ 'ATOM (CAR DESC))
|
||
(DO L (CDR DESC) (CDR L) (NULL L)
|
||
(PUT (CADAR L) (CONS (CONS NAME (CADDAR L)) (GET (CADAR L) 'MODES)) 'MODES)
|
||
(PUT NAME (CONS (CONS (CADAR L) (CADDAR L)) (GET NAME 'SELS)) 'SELS)
|
||
(IF SELECTOR (PUT (CADAR L) 'SELECTOR 'MACRO)))
|
||
(CONS `((MEMQ (CADDR X) ',(MAPCAR 'CADR (CDR DESC))) (LIST 'GET ,BAS (LIST 'QUOTE (CADDR X))))
|
||
RESULT))
|
||
((EQ 'CONS (CAR DESC))
|
||
(SETQ RESULT (DEFS1 (CADR DESC) `(LIST 'CAR ,BAS) RESULT))
|
||
(DEFS1 (CADDR DESC) `(LIST 'CDR ,BAS) RESULT))
|
||
((EQ 'LIST (CAR DESC))
|
||
(DO L (CDR DESC) (CDR L) (NULL L)
|
||
(SETQ RESULT (DEFS1 (CAR L) `(LIST 'CAR ,BAS) RESULT)
|
||
BAS `(LIST 'CDR ,BAS)))
|
||
RESULT)
|
||
((EQ 'STRUCT (CAR DESC)) (DEFS1 (CONS 'LIST (CDR DESC)) BAS RESULT))
|
||
(T RESULT)))
|
||
|
||
(DEFUN DEFA (DESC)
|
||
`(LAMBDA (X) (COND . ,(NREVERSE (DEFA1 DESC '(CADR X) NIL NIL)))))
|
||
|
||
(DEFUN DEFA1 (DESC BAS CDR RESULT)
|
||
(COND ((ATOM DESC) RESULT)
|
||
((EQ 'SELECTOR (CAR DESC))
|
||
(SETQ BAS (COND ((NOT CDR) `(LIST 'CAR (LIST 'RPLACA ,(CADDR BAS) (CADDDR X))))
|
||
(T `(LIST 'CDR (LIST 'RPLACD ,(CADDR BAS) (CADDDR X))))))
|
||
(CONS `((EQ ',(CADR DESC) (CADDR X)) ,BAS) RESULT))
|
||
((EQ 'ATOM (CAR DESC))
|
||
(LIST `(T (LIST 'A-ATOM (CADR X) (LIST 'QUOTE (CADDR X)) (CADDDR X)))))
|
||
((EQ 'CONS (CAR DESC))
|
||
(SETQ RESULT (DEFA1 (CADR DESC) `(LIST 'CAR ,BAS) NIL RESULT))
|
||
(DEFA1 (CADDR DESC) `(LIST 'CDR ,BAS) T RESULT))
|
||
((EQ 'LIST (CAR DESC))
|
||
(DO L (CDR DESC) (CDR L) (NULL L)
|
||
(SETQ RESULT (DEFA1 (CAR L) `(LIST 'CAR ,BAS) NIL RESULT)
|
||
BAS `(LIST 'CDR ,BAS)))
|
||
RESULT)
|
||
((EQ 'STRUCT (CAR DESC)) (DEFA1 (CONS 'LIST (CDR DESC)) BAS CDR RESULT))
|
||
(T RESULT)))
|
||
|
||
|
||
(DEFUN MODE (X) (CDR (ASSOC X MOBJECTS)))
|
||
|
||
(DEFUN MODEDECLARE FEXPR (X)
|
||
(MAPC '(LAMBDA (L) (MAPC '(LAMBDA (V) (SETQ MOBJECTS (CONS (CONS V (CAR L)) MOBJECTS)))
|
||
(CDR L)))
|
||
X))
|
||
|
||
(DEFUN NDM-ERR (X)
|
||
(TERPRI)
|
||
(PRINC '|Cannot determine the mode of |) (PRINC X)
|
||
(ERR))
|
||
|
||
(DEFUN NSM-ERR (X)
|
||
(TERPRI)
|
||
(PRINC '|No such mode as |) (PRINC X)
|
||
(ERR))
|
||
|
||
(DEFUN SEL-ERR (B S)
|
||
(TERPRI)
|
||
(PRINC '/:) (PRINC B)
|
||
(DO () ((NULL S)) (PRINC '/:) (PRINC (CAR S)) (SETQ S (CDR S)))
|
||
(PRINC '|is an impossible selection|)
|
||
(ERR))
|
||
|
||
(DEFUN IA-ERR (X)
|
||
(TERPRI)
|
||
(PRINC '|Cannot assign |) (PRINC X)
|
||
(ERR))
|
||
|
||
|
||
(DEFUN SEL MACRO (X)
|
||
(PROGB ((S (FSEL (MODE (CADR X)) (CDDR X))))
|
||
(IF (NULL S) (SEL-ERR (CADR X) (CDDR X))
|
||
(SETQ X (CADR X))
|
||
(DO () ((NULL (CDR S)) X)
|
||
(SETQ X (CONS (CADR (GET (CAR S) 'MODE)) (RPLACA S X)) S (CDDR S))
|
||
(RPLACD (CDDR X) NIL)))))
|
||
|
||
(DEFUN FSEL (M SELS) ; This has a bug in it.
|
||
(COND ((NULL SELS) (LIST M))
|
||
((NULL M)
|
||
(DO L (GET (CAR SELS) 'MODES) (CDR L) (NULL L)
|
||
(IF (SETQ M (FSEL (CDAR L) (CDR SELS)))
|
||
(RETURN (CONS (CAAR L) (CONS (CAR SELS) M))))))
|
||
((PROGB (DUM)
|
||
(IF (SETQ DUM (ASSQ (CAR SELS) (GET M 'SELS)))
|
||
(CONS M (CONS (CAR SELS) (FSEL (CDR DUM) (CDR SELS)))))))
|
||
(T (DO ((L (GET M 'SELS) (CDR L)) (DUM)) ((NULL L))
|
||
(IF (SETQ DUM (FSEL (CDAR L) SELS))
|
||
(RETURN (CONS M (CONS (CAAR L) DUM))))))))
|
||
|
||
(DEFUN SELECTOR (X)
|
||
(IF (NULL (CDDR X)) `(SEL ,(CADR X) ,(CAR X))
|
||
`(_ (SEL ,(CADR X) ,(CAR X)) ,(CADDR X))))
|
||
|
||
|
||
(DEFUN _ MACRO (X) `(STO . ,(CDR X)))
|
||
|
||
(DEFUN STO MACRO (X)
|
||
(DO ((L (CDR X) (CDDR L)) (S) (NL))
|
||
((NULL L) `(PROGN . ,(NREVERSE NL)))
|
||
(COND ((ATOM (CAR L)) (SETQ NL (CONS `(SETQ ,(CAR L) ,(CADR L)) NL)))
|
||
((AND (EQ 'SEL (CAAR L)) (SETQ S (FSEL (MODE (CADAR L)) (CDDAR L))))
|
||
(SETQ X (CADAR L))
|
||
(DO L (CDDR S) (CDDR L) (NULL (CDR L))
|
||
(SETQ X (CONS (CADR (GET (CAR L) 'MODE)) (RPLACA L X)))
|
||
(RPLACD (CDDR X) NIL))
|
||
(SETQ NL (CONS (LIST (CADDR (GET (CAR S) 'MODE)) X (CADR S) (CADR L)) NL)))
|
||
(T (IA-ERR (CAR L))))))
|
||
|
||
|
||
(DEFUN C-ATOM (SELS ARGS)
|
||
(DO ((NL)) ((NULL SELS) (RPLACD (INTERN (GENSYM)) (NREVERSE NL)))
|
||
(IF (CAR ARGS) (SETQ NL (CONS (CAR ARGS) (CONS (CAR SELS) NL))))
|
||
(SETQ SELS (CDR SELS) ARGS (CDR ARGS))))
|
||
|
||
(DEFUN A-ATOM (BAS SEL VAL)
|
||
(COND ((NULL VAL) (REMPROP BAS SEL) NIL)
|
||
(T (PUTPROP BAS VAL SEL))))
|
||
|
||
(DEFUN DSSQ (X L)
|
||
(DO () ((NULL L)) (COND ((EQ X (CDAR L)) (RETURN (CAR L))) (T (SETQ L (CDR L))))))
|
||
|
||
|
||
(DEFUN IMPVAR MACRO (X) `(SPECIAL . ,(CDR X)))
|
||
(DEFUN IMPFUN MACRO (X) `(*EXPR . ,(CDR X)))
|
||
(DEFUN EXPVAR MACRO (X) `(SPECIAL . ,(CDR X)))
|
||
(DEFUN EXPFUN MACRO (X) (COUTPUT `(EXPORTED-FUNCTIONS . ,(CDR X))))
|
||
|
||
(DEFUN SPLIT MACRO (X) `NIL)
|
||
(DEFUN UNSPLIT MACRO (X) `NIL)
|
||
|
||
;; Local Modes:
|
||
;; Mode: LISP
|
||
;; Comment Col: 40
|
||
;; END:
|