mirror of
https://github.com/PDP-10/its.git
synced 2026-02-02 06:51:04 +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.
187 lines
6.2 KiB
Common Lisp
187 lines
6.2 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
(macsyma-module synex)
|
||
|
||
(LOAD-MACSYMA-MACROS MRGMAC)
|
||
|
||
(DECLARE (GENPREFIX SYN)
|
||
(SPECIAL ST1 STRING MOPL $PROPS)
|
||
(*EXPR LBP RBP NFORMAT MEVAL MEVAL1 GETOP ADD2LNC REMCHK ASSOL
|
||
FULLSTRIP1 STRING* DISPLA WNA-ERR GETOPR REMPROPCHK
|
||
$VERBIFY $NOUNIFY $LISTP))
|
||
|
||
; If an appropriate wrng-no-args handler were set up in maclisp, this
|
||
; stuff could be written like this:
|
||
; (declare (setq defun&-check-args t))
|
||
; (DEFMFUN $prefix (operator &optional (rbp 180.) (rpos '$any) (lpos '$any))
|
||
; (or (fixp rbp) (bp-err rbp))
|
||
; (if (eq '& (getchar operator 1))
|
||
; (setq operator (define-symbol operator)))
|
||
; (define-prefix operator rbp rpos lpos))
|
||
|
||
(DEFMFUN $PREFIX N
|
||
"Sets up a prefix operator, takes a bunch of optional arguments."
|
||
(IF (> N 4) (WNA-ERR '$PREFIX))
|
||
(DEFINE-PREFIX
|
||
(COND ((< N 1) (WNA-ERR '$PREFIX))
|
||
((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
|
||
(T (ARG 1)))
|
||
(COND ((< N 2) 180.) ((FIXP (ARG 2)) (ARG 2)) (T (BP-ERR (ARG 2))))
|
||
(COND ((< N 3) '$ANY) (T (ARG 3)))
|
||
(COND ((< N 4) '$ANY) (T (ARG 4)))))
|
||
|
||
(DEFUN DEFINE-PREFIX (OP RBP RPOS POS)
|
||
(PROG (NOUN)
|
||
(SETQ NOUN ($NOUNIFY OP))
|
||
(OP-SETUP OP)
|
||
(PUT OP RBP 'RBP) (PUT NOUN RBP 'RBP)
|
||
(PUT OP RPOS 'RPOS) (PUT OP POS 'POS)
|
||
(PUT OP 'PARSE-PREFIX 'NUD)
|
||
(PUT OP 'MSIZE-PREFIX 'GRIND)
|
||
(PUT OP 'DIMENSION-PREFIX 'DIMENSION)
|
||
(PUT NOUN 'DIMENSION-PREFIX 'DIMENSION)
|
||
(PUT OP (NCONC (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
|
||
(PUT NOUN (NCONC (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
|
||
(RETURN (GETOPR OP))))
|
||
|
||
|
||
(DEFMFUN $POSTFIX N
|
||
(IF (> N 4) (WNA-ERR '$POSTFIX))
|
||
(DEFINE-POSTFIX
|
||
(COND ((< N 1) (WNA-ERR '$POSTFIX))
|
||
((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
|
||
(T (ARG 1)))
|
||
(COND ((< N 2) 180.) ((FIXP (ARG 2)) (ARG 2)) (T (BP-ERR (ARG 2))))
|
||
(COND ((< N 3) '$ANY) (T (ARG 3)))
|
||
(COND ((< N 4) '$ANY) (T (ARG 4)))))
|
||
|
||
(DEFUN DEFINE-POSTFIX (OP LBP LPOS POS)
|
||
(PROG (NOUN)
|
||
(SETQ NOUN ($NOUNIFY OP))
|
||
(OP-SETUP OP)
|
||
(PUT OP LBP 'LBP) (PUT NOUN LBP 'LBP)
|
||
(PUT OP LPOS 'LPOS) (PUT OP POS 'POS)
|
||
(PUT OP 'PARSE-POSTFIX 'LED)
|
||
(PUT OP 'MSIZE-POSTFIX 'GRIND)
|
||
(PUT OP 'DIMENSION-POSTFIX 'DIMENSION)
|
||
(PUT NOUN 'DIMENSION-POSTFIX 'DIMENION)
|
||
(PUT OP (CONS #\SP (CDR (EXPLODEN OP))) 'DISSYM)
|
||
(PUT NOUN (CONS #\SP (CDR (EXPLODEN OP))) 'DISSYM)
|
||
(RETURN (GETOPR OP))))
|
||
|
||
(DEFMFUN $INFIX N
|
||
(IF (> N 6) (WNA-ERR '$INFIX))
|
||
(DEFINE-INFIX
|
||
(COND ((< N 1) (WNA-ERR '$INFIX))
|
||
((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
|
||
(T (ARG 1)))
|
||
(COND ((< N 2) 180.) ((FIXP (ARG 2)) (ARG 2)) (T (BP-ERR (ARG 2))))
|
||
(COND ((< N 3) 180.) ((FIXP (ARG 3)) (ARG 3)) (T (BP-ERR (ARG 3))))
|
||
(COND ((< N 4) '$ANY) (T (ARG 4)))
|
||
(COND ((< N 5) '$ANY) (T (ARG 5)))
|
||
(COND ((< N 6) '$ANY) (T (ARG 6)))))
|
||
|
||
(DEFUN DEFINE-INFIX (OP LBP RBP LPOS RPOS POS)
|
||
(PROG (NOUN)
|
||
(SETQ NOUN ($NOUNIFY OP))
|
||
(OP-SETUP OP)
|
||
(PUT OP LBP 'LBP) (PUT OP RBP 'RBP)
|
||
(PUT OP LPOS 'LPOS) (PUT OP RPOS 'RPOS) (PUT OP POS 'POS)
|
||
(PUT NOUN LBP 'LBP) (PUT NOUN RBP 'RBP)
|
||
(PUT OP 'PARSE-INFIX 'LED)
|
||
(PUT OP 'MSIZE-INFIX 'GRIND)
|
||
(PUT OP 'DIMENSION-INFIX 'DIMENSION)
|
||
(PUT NOUN 'DIMENSION-INFIX 'DIMENSION)
|
||
(PUT OP (APPEND '(#\SP) (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
|
||
(PUT NOUN (APPEND '(#\SP) (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
|
||
(RETURN (GETOPR OP))))
|
||
|
||
(DEFMFUN $NARY N
|
||
(IF (> N 4) (WNA-ERR '$NARY))
|
||
(DEFINE-NARY
|
||
(COND ((< N 1) (WNA-ERR '$INFIX))
|
||
((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
|
||
(T (ARG 1)))
|
||
(COND ((< N 2) 180.) ((FIXP (ARG 2)) (ARG 2)) (T (BP-ERR (ARG 2))))
|
||
(COND ((< N 3) '$ANY) (T (ARG 3)))
|
||
(COND ((< N 4) '$ANY) (T (ARG 4)))))
|
||
|
||
(DEFUN DEFINE-NARY (OP BP ARGPOS POS)
|
||
(PROG (NOUN)
|
||
(SETQ NOUN ($NOUNIFY OP))
|
||
(OP-SETUP OP)
|
||
(PUT OP BP 'LBP) (PUT OP BP 'RBP)
|
||
(PUT OP ARGPOS 'LPOS) (PUT OP POS 'POS)
|
||
(PUT NOUN BP 'LBP) (PUT NOUN BP 'RBP)
|
||
(PUT OP 'PARSE-NARY 'LED)
|
||
(PUT OP 'MSIZE-NARY 'GRIND)
|
||
(PUT OP 'DIMENSION-NARY 'DIMENSION)
|
||
(PUT NOUN 'DIMENSION-NARY 'DIMENSION)
|
||
(PUT OP (APPEND '(#\SP) (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
|
||
(PUT NOUN (APPEND '(#\SP) (CDR (EXPLODEN OP)) '(#\SP)) 'DISSYM)
|
||
(RETURN (GETOPR OP))))
|
||
|
||
(DEFMFUN $MATCHFIX N
|
||
(IF (> N 4) (WNA-ERR '$MATCHFIX))
|
||
(DEFINE-MATCHFIX
|
||
(COND ((< N 1) (WNA-ERR '$MATCHFIX))
|
||
((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
|
||
(T (ARG 1)))
|
||
(COND ((< N 2) (WNA-ERR '$MATCHFIX))
|
||
((EQ '& (GETCHAR (ARG 2) 1)) (DEFINE-SYMBOL (ARG 2)))
|
||
(T (ARG 2)))
|
||
(COND ((< N 3) '$ANY) (T (ARG 3)))
|
||
(COND ((< N 4) '$ANY) (T (ARG 4)))))
|
||
|
||
(DEFUN DEFINE-MATCHFIX (OP MATCH ARGPOS POS)
|
||
(PROG (NOUN)
|
||
(PUT OP MATCH 'MATCH)
|
||
(SETQ NOUN ($NOUNIFY OP))
|
||
(OP-SETUP OP) (OP-SETUP MATCH)
|
||
(PUT OP ARGPOS 'LPOS) (PUT OP POS 'POS)
|
||
(PUT MATCH 5. 'LBP)
|
||
(PUT OP 'PARSE-MATCHFIX 'NUD)
|
||
(PUT OP 'MSIZE-MATCHFIX 'GRIND)
|
||
(PUT OP 'DIMENSION-MATCH 'DIMENSION)
|
||
(PUT NOUN 'DIMENSION-MATCH 'DIMENSION)
|
||
(PUT OP (CONS (CDR (EXPLODEN OP)) (CDR (EXPLODEN MATCH))) 'DISSYM)
|
||
(PUT NOUN (CONS (CDR (EXPLODEN OP)) (CDR (EXPLODEN MATCH))) 'DISSYM)
|
||
(RETURN (GETOPR OP))))
|
||
|
||
(DEFMFUN $NOFIX N
|
||
(IF (> N 2) (WNA-ERR '$NOFIX))
|
||
(DEFINE-NOFIX
|
||
(COND ((< N 1) (WNA-ERR '$NOFIX))
|
||
((EQ '& (GETCHAR (ARG 1) 1)) (DEFINE-SYMBOL (ARG 1)))
|
||
(T (ARG 1)))
|
||
(COND ((< N 2) '$ANY) (T (ARG 2)))))
|
||
|
||
(DEFUN DEFINE-NOFIX (OP POS)
|
||
(PROG (NOUN)
|
||
(SETQ NOUN ($NOUNIFY OP))
|
||
(OP-SETUP OP)
|
||
(PUT OP POS 'POS)
|
||
(PUT OP 'PARSE-NOFIX 'NUD)
|
||
(PUT OP 'MSIZE-NOFIX 'GRIND)
|
||
(PUT OP 'DIMENSION-NOFIX 'DIMENSION)
|
||
(PUT NOUN 'DIMENSION-NOFIX 'DIMENSION)
|
||
(PUT OP (CDR (EXPLODEN OP)) 'DISSYM)
|
||
(PUT NOUN (CDR (EXPLODEN OP)) 'DISSYM)
|
||
(RETURN (GETOPR OP))))
|
||
|
||
(DEFUN OP-SETUP (OP)
|
||
(PROG (DUMMY)
|
||
(SETQ DUMMY (OR (GET OP 'OP) (IMPLODE (CONS '& (STRING* OP)))))
|
||
(PUT OP DUMMY 'OP)
|
||
(PUT DUMMY OP 'OPR)
|
||
(IF (AND (OPERATORP1 OP) (NOT (MEMQ DUMMY (CDR $PROPS))))
|
||
(SETQ MOPL (CONS DUMMY MOPL)))
|
||
(ADD2LNC DUMMY $PROPS)))
|
||
|
||
(DEFUN BP-ERR (X)
|
||
(MERROR "Non-integer given as binding power: ~M" X))
|
||
|
||
|
||
|