github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-06 19:31:20 +00:00
Code Issues Releases Wiki Activity
Files
b3d29a54cb8a5d69e023fdb292d7467aa2d82e18
PDP-10.its/src/mrg/grind.153
Eric Swenson bf8f96b837 This fixes the declare command in macsyma. 
Also updates a bunch of Macsyma sources to latest versions, which
was needed to get declare working with consistent sources.
Resolves #960.
2018-07-08 07:06:20 -07:00

427 lines
13 KiB
Common Lisp
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macsyma-module grind)
(DECLARE (GENPREFIX GRI)
(SPECIAL LOP ROP STRING CHRPS $ALIASES ALIASLIST LINEL)
(FIXNUM (CHRCT*))
(*EXPR LBP RBP))
(DEFUN CHRCT* () (- LINEL CHRPS))
(DEFVAR ALPHABET '(#/% #/_))
(DEFVAR FORTRANP NIL)
(DEFMSPEC $GRIND (X) (SETQ X (CDR X))
(LET (Y)
(IF (NOT (ZEROP (CHARPOS T))) (MTERPRI))
(COND ((OR (NULL X) (CDR X)) (WNA-ERR '$GRIND))
((SYMBOLP (SETQ X (STRMEVAL (CAR X))))
(SETQ X ($VERBIFY X))
(COND ((SETQ Y (MGET X 'MEXPR))
(MGRIND (LIST '(MDEFINE) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
((SETQ Y (MGET X 'MMACRO))
(MGRIND (LIST '(MDEFMACRO) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
((SETQ Y (MGET X 'AEXPR))
(MGRIND (LIST '(MDEFINE) (CONS (LIST X 'ARRAY) (CDADR Y)) (CADDR Y)) NIL))
(T (MGRIND X NIL)))
(TYO #/$ NIL))
(T (MGRIND X NIL) (TYO #/$ NIL)))
'$DONE))
(DEFUN MGRIND (X OUT)
(SETQ CHRPS 0)
(MPRINT (MSIZE X NIL NIL 'MPAREN 'MPAREN) OUT))
(DEFUN MPRINT (X OUT)
(COND ((FIXP X) (SETQ CHRPS (1+ CHRPS)) (TYO X OUT))
((< (CAR X) (CHRCT*)) (MAPC #'(LAMBDA (L) (MPRINT L OUT)) (CDR X)))
(T (PROG (I) (SETQ I CHRPS)
(MPRINT (CADR X) OUT)
(COND ((NULL (CDDR X)) (RETURN NIL))
((AND (OR (ATOM (CADR X)) (< (CAADR X) (CHRCT*)))
(OR (> (CHRCT*) (// LINEL 2))
(ATOM (CADDR X)) (< (CAADDR X) (CHRCT*))))
(SETQ I CHRPS)
(MPRINT (CADDR X) OUT))
(T (SETQ I (1+ I)) (SETQ CHRPS 0) (TERPRI OUT)
(MTYOTBSP I OUT) (MPRINT (CADDR X) OUT)))
(DO L (CDDDR X) (CDR L) (NULL L)
(IF (OR (ATOM (CAR L)) (< (CAAR L) (CHRCT*))) NIL
(SETQ CHRPS 0) (TERPRI OUT) (MTYOTBSP I OUT))
(MPRINT (CAR L) OUT))))))
(DEFUN MTYOTBSP (N OUT) (DECLARE (FIXNUM N))
(SETQ CHRPS (+ N CHRPS))
(DO () ((< N 8)) (TYO #\TAB OUT) (SETQ N (- N 8)))
(DO () ((< N 1)) (TYO #\SP OUT) (SETQ N (1- N))))
(DEFUN STRGRIND (X)
(LET (STRING (CHRPS 0))
(STRPRINT (MSIZE X NIL NIL 'MPAREN 'MPAREN))
(NREVERSE STRING)))
(DEFUN STRPRINT (X)
(COND ((ATOM X) (STYO X))
((< (CAR X) (CHRCT*)) (MAPC #'STRPRINT (CDR X)))
(T (PROG (I)
(SETQ I CHRPS)
(STRPRINT (CADR X))
(COND ((NULL (CDDR X)) (RETURN NIL))
((AND (OR (ATOM (CADR X)) (< (CAADR X) (CHRCT*)))
(OR (> (CHRCT*) (// LINEL 2))
(ATOM (CADDR X)) (< (CAADDR X) (CHRCT*))))
(SETQ I CHRPS)
(STRPRINT (CADDR X)))
(T (SETQ I (1+ I)) (SETQ CHRPS 0) (STERPRI)
(STYOTBSP I) (STRPRINT (CADDR X))))
(DO L (CDDDR X) (CDR L) (NULL L)
(IF (OR (ATOM (CAR L)) (< (CAAR L) (CHRCT*))) NIL
(SETQ CHRPS 0) (STERPRI) (STYOTBSP I))
(STRPRINT (CAR L)))))))
(DEFUN STYO (X) (SETQ STRING (CONS X STRING) CHRPS (1+ CHRPS)))
(DEFUN STERPRI () (SETQ STRING (CONS #\NEWLINE STRING) CHRPS 0))
(DEFUN STYOTBSP (N) (DECLARE (FIXNUM N)) (SETQ CHRPS N)
(DO () ((< N 8)) (SETQ STRING (CONS #\TAB STRING) N (- N 8)))
(DO () ((< N 1)) (SETQ STRING (CONS #\SP STRING) N (1- N))))
(DEFMFUN MSTRING (X)
(NREVERSE (STRING1 (MSIZE X NIL NIL 'MPAREN 'MPAREN) NIL)))
(DEFUN STRING1 (X L)
(IF (ATOM X) (CONS X L)
(SETQ X (CDR X))
(DO () ((NULL X) L) (SETQ L (STRING1 (CAR X) L) X (CDR X)))))
(DEFUN MSIZE (X L R LOP ROP)
(SETQ X (NFORMAT X))
(COND ((ATOM X) (IF FORTRANP (MSZ (MAKESTRING X) L R) (MSIZE-ATOM X L R)))
((OR (<= (LBP (CAAR X)) (RBP LOP)) (> (LBP ROP) (RBP (CAAR X))))
(MSIZE-PAREN X L R))
((MEMQ 'ARRAY (CDAR X)) (MSIZE-ARRAY X L R))
((GET (CAAR X) 'GRIND) (FUNCALL (GET (CAAR X) 'GRIND) X L R))
(T (MSIZE-FUNCTION X L R NIL))))
(DEFUN MSIZE-ATOM (X L R)
(PROG (Y)
(COND ((NUMBERP X) (SETQ Y (EXPLODEN X)))
((AND (SETQ Y (GET X 'REVERSEALIAS))
(NOT (AND (MEMQ X $ALIASES) (GET X 'NOUN))))
(SETQ Y (EXPLODEN Y)))
((SETQ Y (ASSQR X ALIASLIST)) (RETURN (MSIZE (CAR Y) L R LOP ROP)))
((NULL (SETQ Y (IF (EQ '%DERIVATIVE X)
(COPY-TOP-LEVEL '(#/% #/D #/I #/F #/F))
(EXPLODEN X)))))
((= #/$ (CAR Y)) (SETQ Y (SLASH (CDR Y))))
((= #/% (CAR Y)) (SETQ Y (SLASH (CDR Y))))
((= #/& (CAR Y))
(DO L (CDR Y) (CDR L) (NULL L)
(COND ((OR (MEMBER (CAR L) '(#/" #/\ #/; #/$))
(AND (< (CAR L) 32.) (NOT (= (CAR L) 13.))))
(RPLACD L (CONS (CAR L) (CDR L)))
(RPLACA L #/\) (SETQ L (CDR L)))))
(SETQ Y (CONS #/" (NCONC (CDR Y) (LIST #/")))))
(T (SETQ Y (CONS #/? (SLASH Y)))))
(RETURN (MSZ Y L R))))
(DEFUN MSZ (X L R) (SETQ X (NRECONC L (NCONC X R))) (CONS (LENGTH X) X))
(DEFUN SLASH (X)
(DO L (CDR X) (CDR L) (NULL L)
(IF (ALPHANUMP (CAR L)) NIL
(RPLACD L (CONS (CAR L) (CDR L)))
(RPLACA L #/\) (SETQ L (CDR L))))
(IF (ALPHABETP (CAR X)) X (CONS #/\ X)))
(DEFUN ALPHANUMP (N) (DECLARE (FIXNUM N))
(OR (ASCII-NUMBERP N) (ALPHABETP N)))
(DEFUN MSIZE-PAREN (X L R) (MSIZE X (CONS #/( L) (CONS #/) R) 'MPAREN 'MPAREN))
;; The variables LB and RB are not uses here syntactically, but for
;; communication. The FORTRAN program rebinds them to #/( and #/) since
;; Fortran array references are printed with parens instead of brackets.
(DEFVAR LB #/[)
(DEFVAR RB #/])
(DEFUN MSIZE-ARRAY (X L R &AUX F)
(IF (EQ 'MQAPPLY (CAAR X)) (SETQ F (CADR X) X (CDR X)) (SETQ F (CAAR X)))
(COND ((AND (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS))
(SETQ L (RECONC '(#/' #/') L)))
((AND (GET (CAAR X) 'NOUN) (NOT (MEMQ (CAAR X) (CDR $ALIASES)))
(NOT (GET (CAAR X) 'REVERSEALIAS)))
(SETQ L (CONS #/' L))))
(SETQ L (MSIZE F L (LIST LB) LOP 'MFUNCTION)
R (MSIZE-LIST (CDR X) NIL (CONS RB R)))
(CONS (+ (CAR L) (CAR R)) (CONS L (CDR R))))
(DEFUN MSIZE-FUNCTION (X L R OP)
(COND ((AND (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS))
(SETQ L (RECONC '(#/' #/') L)))
((AND (GET (CAAR X) 'NOUN) (NOT (MEMQ (CAAR X) (CDR $ALIASES)))
(NOT (GET (CAAR X) 'REVERSEALIAS)))
(SETQ L (CONS #/' L))))
(SETQ L (MSIZE (IF OP (GETOP (CAAR X)) (CAAR X)) L (NCONS #/( ) 'MPAREN 'MPAREN)
R (MSIZE-LIST (CDR X) NIL (CONS #/) R)))
(CONS (+ (CAR L) (CAR R)) (CONS L (CDR R))))
(DEFUN MSIZE-LIST (X L R)
(DECLARE (FIXNUM W))
(IF (NULL X) (MSZ NIL L R)
(DO ((NL) (W 0))
((NULL (CDR X))
(SETQ NL (CONS (MSIZE (CAR X) L R 'MPAREN 'MPAREN) NL))
(CONS (+ W (CAAR NL)) (NREVERSE NL)))
(SETQ NL (CONS (MSIZE (CAR X) L (LIST #/,) 'MPAREN 'MPAREN) NL)
W (+ W (CAAR NL)) X (CDR X) L NIL))))
(DEFUN MSIZE-PREFIX (X L R)
(MSIZE (CADR X) (RECONC (STRSYM (CAAR X)) L) R (CAAR X) ROP))
(DEFUN MSIZE-INFIX (X L R)
(IF (OR (NULL (CDDR X)) (CDDDR X)) (WNA-ERR (CAAR X)))
(SETQ L (MSIZE (CADR X) L NIL LOP (CAAR X))
R (MSIZE (CADDR X) (REVERSE (STRSYM (CAAR X))) R (CAAR X) ROP))
(LIST (+ (CAR L) (CAR R)) L R))
(DEFUN MSIZE-POSTFIX (X L R)
(MSIZE (CADR X) L (APPEND (STRSYM (CAAR X)) R) LOP (CAAR X)))
(DEFUN MSIZE-NARY (X L R) (MSZNARY X L R (STRSYM (CAAR X))))
(DEFUN MSIZE-NOFIX (X L R) (MSIZE (CAAR X) L R (CAAR X) ROP))
(DEFUN MSIZE-MATCHFIX (X L R)
(SETQ L (NRECONC L (CAR (STRSYM (CAAR X))))
L (CONS (LENGTH L) L)
R (APPEND (CDR (STRSYM (CAAR X))) R)
X (MSIZE-LIST (CDR X) NIL R))
(CONS (+ (CAR L) (CAR X)) (CONS L (CDR X))))
(DEFUN MSZNARY (X L R DISSYM)
(DECLARE (FIXNUM W))
(COND ((NULL (CDDR X)) (MSIZE-FUNCTION X L R T))
(T (SETQ L (MSIZE (CADR X) L NIL LOP (CAAR X)))
(DO ((OL (CDDR X) (CDR OL)) (NL (LIST L)) (W (CAR L)))
((NULL (CDR OL))
(SETQ R (MSIZE (CAR OL) (REVERSE DISSYM) R (CAAR X) ROP))
(CONS (+ (CAR R) W) (NREVERSE (CONS R NL))))
(SETQ NL (CONS (MSIZE (CAR OL) (REVERSE DISSYM) NIL (CAAR X) (CAAR X))
NL)
W (+ (CAAR NL) W))))))
(DEFUN STRSYM (X) (OR (GET X 'STRSYM) (GET X 'DISSYM)))
(DEFPROP BIGFLOAT MSZ-BIGFLOAT GRIND)
(DEFUN MSZ-BIGFLOAT (X L R)
(MSZ (MAPCAR '(LAMBDA (L) (GETCHARN L 1)) (FPFORMAT X)) L R))
(DEFPROP MPROGN MSIZE-MATCHFIX GRIND)
(DEFPROP MLIST MSIZE-MATCHFIX GRIND)
(DEFPROP MQAPPLY MSZ-MQAPPLY GRIND)
(DEFUN MSZ-MQAPPLY (X L R)
(SETQ L (MSIZE (CADR X) L (LIST #/( ) LOP 'MFUNCTION)
R (MSIZE-LIST (CDDR X) NIL (CONS #/) R)))
(CONS (+ (CAR L) (CAR R)) (CONS L (CDR R))))
(DEFPROP MQUOTE MSIZE-PREFIX GRIND)
(DEFPROP MQUOTE 201. RBP)
(DEFPROP MSETQ MSIZE-INFIX GRIND)
(DEFPROP MSETQ (#/:) STRSYM)
(DEFPROP MSETQ 180. RBP)
(DEFPROP MSETQ 20. RBP)
(DEFPROP MSET MSIZE-INFIX GRIND)
(DEFPROP MSET (#/: #/:) STRSYM)
(DEFPROP MSET 180. LBP)
(DEFPROP MSET 20. RBP)
(DEFPROP MDEFINE MSZ-MDEF GRIND)
(DEFPROP MDEFINE (#/: #/=) STRSYM)
(DEFPROP MDEFINE 180. LBP)
(DEFPROP MDEFINE 20. RBP)
(DEFPROP MDEFMACRO MSZ-MDEF GRIND)
(DEFPROP MDEFMACRO (#/: #/: #/=) STRSYM)
(DEFPROP MDEFMACRO 180. LBP)
(DEFPROP MDEFMACRO 20. RBP)
(DEFUN MSZ-MDEF (X L R)
(SETQ L (MSIZE (CADR X) L (COPY-TOP-LEVEL (STRSYM (CAAR X))) LOP (CAAR X))
R (MSIZE (CADDR X) NIL R (CAAR X) ROP))
(SETQ X (CONS (- (CAR L) (CAADR L)) (CDDR L)))
(IF (AND (NOT (ATOM (CADR R))) (NOT (ATOM (CADDR R)))
(< (+ (CAR L) (CAADR R) (CAADDR R)) LINEL))
(SETQ X (NCONC X (LIST (CADR R) (CADDR R)))
R (CONS (CAR R) (CDDDR R))))
(CONS (+ (CAR L) (CAR R)) (CONS (CADR L) (CONS X (CDR R)))))
(DEFPROP MFACTORIAL MSIZE-POSTFIX GRIND)
(DEFPROP MFACTORIAL 160. LBP)
(DEFPROP MEXPT MSZ-MEXPT GRIND)
(DEFPROP MEXPT 140. LBP)
(DEFPROP MEXPT 139. RBP)
(DEFUN MSZ-MEXPT (X L R)
(SETQ L (MSIZE (CADR X) L NIL LOP 'MEXPT)
R (IF (MMMINUSP (SETQ X (NFORMAT (CADDR X))))
(MSIZE (CADR X) (REVERSE '(#/^ #/-)) R 'MEXPT ROP)
(MSIZE X (LIST #/^) R 'MEXPT ROP)))
(LIST (+ (CAR L) (CAR R)) L R))
(DEFPROP MNCEXPT MSIZE-INFIX GRIND)
(DEFPROP MNCEXPT 135. LBP)
(DEFPROP MNCEXPT 134. RBP)
(DEFPROP MNCTIMES MSIZE-NARY GRIND)
(DEFPROP MNCTIMES 110. LBP)
(DEFPROP MNCTIMES 109. RBP)
(DEFPROP MTIMES MSZ-MTIMES GRIND)
(DEFPROP MTIMES 120. LBP)
(DEFPROP MTIMES 120. RBP)
(DEFUN MSZ-MTIMES (X L R) (MSZNARY X L R '(#/*)))
(DEFPROP MQUOTIENT MSIZE-INFIX GRIND)
(DEFPROP MQUOTIENT 120. LBP)
(DEFPROP MQUOTIENT 121. RBP)
(DEFPROP RAT MSIZE-INFIX GRIND)
(DEFPROP RAT 120. LBP)
(DEFPROP RAT 121. RBP)
(DEFPROP MPLUS MSZ-MPLUS GRIND)
(DEFPROP MPLUS 100. LBP)
(DEFPROP MPLUS 100. RBP)
(DEFUN MSZ-MPLUS (X L R)
(DECLARE (FIXNUM W))
(COND ((NULL (CDDR X))
(IF (NULL (CDR X))
(MSIZE-FUNCTION X L R T)
(MSIZE (CADR X) (APPEND (NCONS #/+) L) R 'MPLUS ROP)))
(T (SETQ L (MSIZE (CADR X) L NIL LOP 'MPLUS) X (CDDR X))
(DO ((NL (LIST L)) (W (CAR L)) (DISSYM))
((NULL (CDR X))
(IF (MMMINUSP (CAR X)) (SETQ L (CADAR X) DISSYM (LIST #/-))
(SETQ L (CAR X) DISSYM (LIST #/+)))
(SETQ R (MSIZE L DISSYM R 'MPLUS ROP))
(CONS (+ (CAR R) W) (NREVERSE (CONS R NL))))
(IF (MMMINUSP (CAR X)) (SETQ L (CADAR X) DISSYM (LIST #/-))
(SETQ L (CAR X) DISSYM (LIST #/+)))
(SETQ NL (CONS (MSIZE L DISSYM NIL 'MPLUS 'MPLUS) NL)
W (+ (CAAR NL) W)
X (CDR X))))))
(DEFPROP MMINUS MSIZE-PREFIX GRIND)
(DEFPROP MMINUS (#/-) STRSYM)
(DEFPROP MMINUS 100. RBP)
(DEFPROP MMINUS 100. LBP)
(DEFPROP MEQUAL MSIZE-INFIX GRIND)
(DEFPROP MEQUAL 80. LBP)
(DEFPROP MEQUAL 80. RBP)
(DEFPROP MNOTEQUAL MSIZE-INFIX GRIND)
(DEFPROP MNOTEQUAL 80. LBP)
(DEFPROP MNOTEQUAL 80. RBP)
(DEFPROP MGREATERP MSIZE-INFIX GRIND)
(DEFPROP MGREATERP 80. LBP)
(DEFPROP MGREATERP 80. RBP)
(DEFPROP MGEQP MSIZE-INFIX GRIND)
(DEFPROP MGEQP 80. LBP)
(DEFPROP MGEQP 80. RBP)
(DEFPROP MLESSP MSIZE-INFIX GRIND)
(DEFPROP MLESSP 80. LBP)
(DEFPROP MLESSP 80. RBP)
(DEFPROP MLEQP MSIZE-INFIX GRIND)
(DEFPROP MLEQP 80. LBP)
(DEFPROP MLEQP 80. RBP)
(DEFPROP MNOT MSIZE-PREFIX GRIND)
(DEFPROP MNOT 70. RBP)
(DEFPROP MAND MSIZE-NARY GRIND)
(DEFPROP MAND 60. LBP)
(DEFPROP MAND 60. RBP)
(DEFPROP MOR MSIZE-NARY GRIND)
(DEFPROP MOR 50. LBP)
(DEFPROP MOR 50. RBP)
(DEFPROP MCOND MSZ-MCOND GRIND)
(DEFPROP MCOND 25. LBP)
(DEFPROP MCOND 25. RBP)
(DEFUN MSZ-MCOND (X L R &AUX IF)
(SETQ IF (NRECONC L '(#/I #/F #\SP)) IF (CONS (LENGTH IF) IF)
L (MSIZE (CADR X) NIL NIL 'MCOND 'MPAREN))
(COND ((EQ '$FALSE (FIFTH X))
(SETQ X (MSIZE (CADDR X)
(REVERSE '(#\SP #/T #/H #/E #/N #\SP))
R 'MCOND ROP))
(LIST (+ (CAR IF) (CAR L) (CAR X)) IF L X))
(T (SETQ R (MSIZE (FIFTH X)
(REVERSE '(#\SP #/E #/L #/S #/E #\SP))
R 'MCOND ROP)
X (MSIZE (CADDR X)
(REVERSE '(#\SP #/T #/H #/E #/N #\SP))
NIL 'MCOND 'MPAREN))
(LIST (+ (CAR IF) (CAR L) (CAR X) (CAR R)) IF L X R))))
(DEFPROP MDO MSZ-MDO GRIND)
(DEFPROP MDO 30. LBP)
(DEFPROP MDO 30. RBP)
(DEFPROP MDOIN MSZ-MDOIN GRIND)
(DEFPROP MDOIN 30. RBP)
(DEFUN MSZ-MDO (X L R)
(MSZNARY (CONS '(MDO) (STRMDO X)) L R '(#\SP)))
(DEFUN MSZ-MDOIN (X L R)
(MSZNARY (CONS '(MDO) (STRMDOIN X)) L R '(#\SP)))
(DEFUN STRMDO (X)
(NCONC (COND ((SECOND X) `($FOR ,(SECOND X))))
(COND ((EQUAL 1 (THIRD X)) NIL)
((THIRD X) `($FROM ,(THIRD X))))
(COND ((EQUAL 1 (FOURTH X)) NIL)
((FOURTH X) `($STEP ,(FOURTH X)))
((FIFTH X) `($NEXT ,(FIFTH X))))
(COND ((SIXTH X) `($THRU ,(SIXTH X))))
(COND ((NULL (SEVENTH X)) NIL)
((EQ 'MNOT (CAAR (SEVENTH X)))
`($WHILE ,(CADR (SEVENTH X))))
(T `($UNLESS ,(SEVENTH X))))
`($DO ,(EIGHTH X))))
(DEFUN STRMDOIN (X)
(NCONC `($FOR ,(SECOND X) $IN ,(THIRD X))
(COND ((SIXTH X) `($THRU ,(SIXTH X))))
(COND ((NULL (SEVENTH X)) NIL)
((EQ 'MNOT (CAAR (SEVENTH X)))
`($WHILE ,(CADR (SEVENTH X))))
(T `($UNLESS ,(SEVENTH X))))
`($DO ,(EIGHTH X))))
Reference in New Issue View Git Blame Copy Permalink