diff --git a/build/lisp.tcl b/build/lisp.tcl index 7343f38b..35801b70 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -527,12 +527,13 @@ respond "*" "(quit)" respond "*" "aljabr\033\023" respond "*" ":lisp\r" -type "(load \"libmax;module\")" -respond "132170" "(load \"libmax;define\")" -respond "134541" "(load \"libmax;maxmac\")" -respond "140351" "(load \"libmax;displm\")" -respond "141162" "(load \"aljabr;loader\")" -respond "T" "(loader 999)" +type "(load \"lisp;mlsub\")" +respond "124656" "(load \"libmax;module\")" +respond "133046" "(load \"libmax;define\")" +respond "135417" "(load \"libmax;maxmac\")" +respond "141227" "(load \"libmax;displm\")" +respond "142040" "(load \"aljabr;loader\")" +respond "T" "(loader 1000)" respond "(C1)" "quit();" respond "*" ":link sys3;ts macsym,maxdmp;loser >\r" diff --git a/src/jpg/comm.415 b/src/jpg/comm.415 new file mode 100644 index 00000000..e9569aa5 --- /dev/null +++ b/src/jpg/comm.415 @@ -0,0 +1,964 @@ +;; -*- Mode: Lisp; Package: Macsyma; -*- + +;; (c) Copyright 1976, 1984 Massachusetts Institute of Technology +;; All Rights Reserved. + +;; Enhancements (c) Copyright 1984 Symbolics Inc. +;; All Rights Reserved. + +;; The data and information in the Enhancements are proprietary to, and +;; a valuable trade secret of, SYMBOLICS, INC., a Delaware corporation. +;; They are given in confidence by SYMBOLICS, pursuant to the license +;; agreement between Symbolics and their recipient, and may not be used, +;; reproduced, or copied, or distributed to any other party, in whole or +;; in part, without the prior written consent of SYMBOLICS except as +;; permitted by the license agreement. + +(macsyma-module comm) + +(DECLARE (GENPREFIX C) + (SPECIAL $EXPTSUBST $LINECHAR $NOLABELS $INFLAG $PIECE $DISPFLAG + $GRADEFS $PROPS $DEPENDENCIES DERIVFLAG DERIVLIST + $LINENUM $PARTSWITCH LINELABLE NN* DN* ISLINP + $POWERDISP ATVARS ATP $ERREXP $DERIVSUBST $DOTDISTRIB + $OPSUBST $SUBNUMSIMP $TRANSRUN IN-P SUBSTP $SQRTDISPFLAG + $PFEFORMAT DUMMY-VARIABLE-OPERATORS) + (*LEXPR FACTOR) + (FIXNUM I N LARGL LVRS COUNT TIM (SIGNUM1))) + +(PROG1 '(OP and OPR properties) + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP) + (PUTPROP (CADR X) (CAR X) 'OPR)) + '((MPLUS &+) (MMINUS &-) (MTIMES &*) (MEXPT &**) (MEXPT &^) + (MNCTIMES &/.) (RAT &//) (MQUOTIENT &//) (MNCEXPT &^^) + (MEQUAL &=) (MGREATERP &>) (MLESSP &<) (MLEQP &<=) (MGEQP &>=) + (MNOTEQUAL &/#) (MAND &AND) (MOR &OR) (MNOT &NOT) (MSETQ &/:) + (MDEFINE &/:=) (MDEFMACRO &/:/:=) (MQUOTE &/') (MLIST &[) + (MSET &/:/:) (MFACTORIAL &!) (MARROW &->) (MPROGN &/() + (MCOND &IF))) + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP)) + '((MQAPPLY $SUBVAR) (BIGFLOAT $BFLOAT))) + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OPR)) + #-(or Franz Multics) + '((|&and| MAND) (|&or| MOR) (|¬| MNOT) (|&if| MCOND)) + #+(or Franz Multics) + '((|&AND| MAND) (|&OR| MOR) (|&NOT| MNOT) (|&IF| MCOND)))) + +(SETQ $EXPTSUBST NIL $PARTSWITCH NIL $INFLAG NIL $GRADEFS '((MLIST SIMP)) + $DEPENDENCIES '((MLIST SIMP)) ATVARS '(&@1 &@2 &@3 &@4) ATP NIL + ISLINP NIL LNORECURSE NIL &** '&^ $DERIVSUBST NIL TIMESP NIL + $OPSUBST T IN-P NIL SUBSTP NIL) + +(DEFMVAR $VECT_CROSS NIL + "If TRUE allows DIFF(X~Y,T) to work where ~ is defined in + SHARE;VECT where VECT_CROSS is set to TRUE.") + +(DEFMFUN $SUBSTITUTE N + (COND ((= N 2) + (LET ((L (ARG 1)) (Z (ARG 2))) + (COND ((AND ($LISTP L) ($LISTP (CADR L)) (NULL (CDDR L))) + ($SUBSTITUTE (CADR L) Z)) + ((NOTLOREQ L) (IMPROPER-ARG-ERR L '$SUBSTITUTE)) + ((EQ (CAAR L) 'MEQUAL) (SUBSTITUTE (CADDR L) (CADR L) Z)) + (T (DO ((L (CDR L) (CDR L))) ((NULL L) Z) + (SETQ Z ($SUBSTITUTE (CAR L) Z))))))) + ((= N 3) (SUBSTITUTE (ARG 1) (ARG 2) (ARG 3))) + (T (WNA-ERR '$SUBSTITUTE)))) + +(DECLARE (SPECIAL X Y OPRX OPRY NEGXPTY TIMESP)) + +(DEFMFUN SUBSTITUTE (X Y Z) ; The args to SUBSTITUTE are assumed to be simplified. + (LET ((IN-P T) (SUBSTP T)) + (IF (AND (MNUMP Y) (= (SIGNUM1 Y) 1)) + (LET ($SQRTDISPFLAG ($PFEFORMAT T)) (SETQ Z (NFORMAT-ALL Z)))) + (SIMPLIFYA + (IF (ATOM Y) + (COND ((EQUAL Y -1) + (SETQ Y '((MMINUS) 1)) (SUBST2 (NFORMAT-ALL Z))) + (T (LET ((OPRX (GETOPR X)) (OPRY (GETOPR Y))) + (SUBST1 Z)))) + (LET ((NEGXPTY (IF (AND (EQ (CAAR Y) 'MEXPT) + (= (SIGNUM1 (CADDR Y)) 1)) + (MUL2 -1 (CADDR Y)))) + (TIMESP (IF (EQ (CAAR Y) 'MTIMES) (SETQ Y (NFORMAT Y))))) + (SETQ SUBSTP 'MQAPPLY) (SUBST2 Z))) + NIL))) + +(DEFUN SUBST1 (Z) ; Y is an atom + (COND ((ATOM Z) (IF (EQUAL Y Z) X Z)) + ((SPECREPP Z) (SUBST1 (SPECDISREP Z))) + ((EQ (CAAR Z) 'BIGFLOAT) Z) + ((AND (EQ (CAAR Z) 'RAT) (OR (EQUAL Y (CADR Z)) (EQUAL Y (CADDR Z)))) + (DIV (SUBST1 (CADR Z)) (SUBST1 (CADDR Z)))) + ((AT-SUBSTP Z) Z) + ((AND (EQ Y T) (EQ (CAAR Z) 'MCOND)) + (LIST (NCONS (CAAR Z)) (SUBST1 (CADR Z)) (SUBST1 (CADDR Z)) + (CADDDR Z) (SUBST1 (CAR (CDDDDR Z))))) + (T (LET ((MARGS (MAPCAR #'SUBST1 (CDR Z)))) + (IF (AND $OPSUBST + (OR (EQ OPRY (CAAR Z)) + (AND (EQ (CAAR Z) 'RAT) (EQ OPRY 'MQUOTIENT)))) + (IF (OR (NUMBERP X) + (MEMQ X '(T NIL $%E $%PI $%I)) + (AND (NOT (ATOM X)) + (NOT (OR (EQ (CAR X) 'LAMBDA) + (EQ (CAAR X) 'LAMBDA))))) + (IF (OR (AND (MEMQ 'ARRAY (CDAR Z)) + (OR (AND (MNUMP X) $SUBNUMSIMP) + (AND (NOT (MNUMP X)) (NOT (ATOM X))))) + ($SUBVARP X)) + (LET ((SUBSTP 'MQAPPLY)) + (SUBST0 (LIST* '(MQAPPLY) X MARGS) Z)) + (MERROR + "Attempt to substitute ~M for ~M in ~M~ + ~%Illegal substitution for operator of expression" + X Y Z)) + (SUBST0 (CONS (NCONS OPRX) MARGS) Z)) + (SUBST0 (CONS (NCONS (CAAR Z)) MARGS) Z)))))) + +(DEFUN SUBST2 (Z) + (LET (NEWEXPT) + (COND ((ATOM Z) Z) + ((SPECREPP Z) (SUBST2 (SPECDISREP Z))) + ((AT-SUBSTP Z) Z) + ((ALIKE1 Y Z) X) + ((AND TIMESP (EQ (CAAR Z) 'MTIMES) (ALIKE1 Y (SETQ Z (NFORMAT Z)))) X) + ((AND (EQ (CAAR Y) 'MEXPT) (EQ (CAAR Z) 'MEXPT) (ALIKE1 (CADR Y) (CADR Z)) + (SETQ NEWEXPT (COND ((ALIKE1 NEGXPTY (CADDR Z)) -1) + ($EXPTSUBST (EXPTHACK (CADDR Y) (CADDR Z)))))) + (LIST '(MEXPT) X NEWEXPT)) + ((AND $DERIVSUBST (EQ (CAAR Y) '%DERIVATIVE) (EQ (CAAR Z) '%DERIVATIVE) + (ALIKE1 (CADR Y) (CADR Z))) + (LET ((TAIL (SUBST-DIFF-MATCH (CDDR Y) (CDR Z)))) + (COND ((NULL TAIL) Z) + (T (CONS (NCONS (CAAR Z)) (CONS X (CDR TAIL))))))) + (T (RECUR-APPLY #'SUBST2 Z))))) + +(DECLARE (UNSPECIAL X Y OPRX OPRY NEGXPTY TIMESP)) + +(DEFMFUN SUBST0 (NEW OLD) + (COND ((ALIKE (CDR NEW) (CDR OLD)) + (COND ((EQ (CAAR NEW) (CAAR OLD)) OLD) + (T (SIMPLIFYA (CONS (CONS (CAAR NEW) (MEMQ 'ARRAY (CDAR OLD))) (CDR OLD)) + NIL)))) + ((MEMQ 'ARRAY (CDAR OLD)) + (SIMPLIFYA (CONS (CONS (CAAR NEW) '(ARRAY)) (CDR NEW)) NIL)) + (T (SIMPLIFYA NEW NIL)))) + +(DEFUN EXPTHACK (Y Z) + (PROG (NN* DN* YN YD ZN ZD QD) + (COND ((AND (MNUMP Y) (MNUMP Z)) + (RETURN (IF (NUMBERP (SETQ Y (DIV* Z Y))) Y))) + ((ATOM Z) (IF (NOT (MNUMP Y)) (RETURN NIL))) + ((OR (RATNUMP Z) (EQ (CAAR Z) 'MPLUS)) (RETURN NIL))) + (NUMDEN Y) ; (CSIMP) sets NN* and DN* + (SETQ YN NN* YD DN*) + (NUMDEN Z) + (SETQ ZN NN* ZD DN*) + (SETQ QD (COND ((AND (EQUAL ZD 1) (EQUAL YD 1)) 1) + ((PROG2 (NUMDEN (DIV* ZD YD)) + (AND (EQUAL DN* 1) (EQUAL NN* 1))) + 1) + ((EQUAL NN* 1) (DIV* 1 DN*)) + ((EQUAL DN* 1) NN*) + (T (RETURN NIL)))) + (NUMDEN (DIV* ZN YN)) + (IF (EQUAL DN* 1) (RETURN (DIV* NN* QD))))) + +(DEFUN SUBST-DIFF-MATCH (L1 L2) + (DO ((L L1 (CDDR L)) (L2 (APPEND L2 NIL)) (FAILED NIL NIL)) + ((NULL L) L2) + (DO ((L2 L2 (CDDR L2))) + ((NULL (CDR L2)) (SETQ FAILED T)) + (IF (ALIKE1 (CAR L) (CADR L2)) + (IF (AND (FIXNUMP (CADR L)) + (FIXNUMP (CADDR L2))) + (COND ((< (CADR L) (CADDR L2)) + (RETURN (RPLACD (CDR L2) + (CONS (- (CADDR L2) (CADR L)) + (CDDDR L2))))) + ((= (CADR L) (CADDR L2)) + (RETURN (RPLACD L2 (CDDDR L2)))) + (T (RETURN (SETQ FAILED T)))) + (RETURN (SETQ FAILED T))))) + (IF FAILED (RETURN NIL)))) + +(DEFUN AT-SUBSTP (Z) + (AND ATP (OR (MEMQ (CAAR Z) '(%DERIVATIVE %DEL)) + (MEMQ (CAAR Z) DUMMY-VARIABLE-OPERATORS)))) +(DEFMFUN RECUR-APPLY (FUN E) + (COND ((EQ (CAAR E) 'BIGFLOAT) E) + ((SPECREPP E) (FUNCALL FUN (SPECDISREP E))) + (T (LET ((NEWARGS (MAPCAR FUN (CDR E)))) + (IF (ALIKE NEWARGS (CDR E)) + E + (SIMPLIFYA (CONS (CONS (CAAR E) (MEMQ 'ARRAY (CDAR E))) NEWARGS) + NIL)))))) + +(DEFMFUN $DEPENDS N + (IF (ODDP N) (MERROR "DEPENDS takes an even number of arguments.")) + (DO ((I 1 (+ I 2)) (L)) + ((> I N) (I-$DEPENDENCIES (NREVERSE L))) + (COND (($LISTP (ARG I)) + (DO L1 (CDR (ARG I)) (CDR L1) (NULL L1) + (SETQ L (CONS (DEPENDS1 (CAR L1) (ARG (1+ I))) L)))) + (T (SETQ L (CONS (DEPENDS1 (ARG I) (ARG (1+ I))) L)))))) + +(DEFUN DEPENDS1 (X Y) + (NONSYMCHK X '$DEPENDS) + (CONS (NCONS X) (IF ($LISTP Y) (CDR Y) (NCONS Y)))) + +(DEFMSPEC $DEPENDENCIES (FORM) (I-$DEPENDENCIES (CDR FORM))) + +(DEFMFUN I-$DEPENDENCIES (L) + (DOLIST (Z L) + (COND ((ATOM Z) (MERROR "Wrong format. Try F(X).")) + ((OR (EQ (CAAR Z) 'MQAPPLY) (MEMQ 'ARRAY (CDAR Z))) + (MERROR "Improper form for DEPENDS:~%~M" Z)) + (T (LET ((Y (MGET (CAAR Z) 'DEPENDS))) + (MPUTPROP (CAAR Z) + (SETQ Y (UNION* (REVERSE (CDR Z)) Y)) + 'DEPENDS) + (ADD2LNC (CONS (NCONS (CAAR Z)) Y) $DEPENDENCIES))))) + (CONS '(MLIST SIMP) L)) + +(DEFMSPEC $GRADEF (L) (SETQ L (CDR L)) + (LET ((Z (CAR L)) (N 0)) + (COND ((ATOM Z) + (IF (NOT (= (LENGTH L) 3)) (MERROR "Wrong arguments to GRADEF")) + (MPUTPROP Z + (CONS (CONS (CADR L) (MEVAL (CADDR L))) + (MGET Z '$ATOMGRAD)) + '$ATOMGRAD) + (I-$DEPENDENCIES (NCONS (LIST (NCONS Z) (CADR L)))) + (ADD2LNC Z $PROPS) + Z) + ((OR (MOPP1 (CAAR Z)) (MEMQ 'ARRAY (CDAR Z))) + (MERROR "Wrong arguments to GRADEF:~%~M" Z)) + ((PROG2 (SETQ N (- (LENGTH Z) (LENGTH L))) (MINUSP N)) + (WNA-ERR '$GRADEF)) + (T (DO ZL (CDR Z) (CDR ZL) (NULL ZL) + (IF (NOT (SYMBOLP (CAR ZL))) + (MERROR "Parameters to GRADEF must be names:~%~M" + (CAR ZL)))) + (SETQ L (NCONC (MAPCAR #'(LAMBDA (X) (REMSIMP (MEVAL X))) + (CDR L)) + (MAPCAR #'(LAMBDA (X) (LIST '(%DERIVATIVE) Z X 1)) + (NTHCDR (- (LENGTH Z) N) Z)))) + (PUTPROP (CAAR Z) + (SUBLIS (MAPCAR #'CONS (CDR Z) (MAPCAR #'STRIPDOLLAR (CDR Z))) + (CONS (CDR Z) L)) + 'GRAD) + (ADD2LNC (CONS (NCONS (CAAR Z)) (CDR Z)) $GRADEFS) + Z)))) + +(DEFMFUN $DIFF N (LET (DERIVLIST) (DERIV (LISTIFY N)))) + +(DEFMFUN $DEL (E) (STOTALDIFF E)) + +(DEFUN DERIV (E) + (PROG (EXP Z COUNT) + (COND ((NULL E) (WNA-ERR '$DIFF)) + ((NULL (CDR E)) (RETURN (STOTALDIFF (CAR E)))) + ((NULL (CDDR E)) (NCONC E '(1)))) + (SETQ EXP (CAR E) Z (SETQ E (APPEND E NIL))) + LOOP (IF (OR (NULL DERIVLIST) (MEMBER (CADR Z) DERIVLIST)) (GO DOIT)) + ; DERIVLIST is set by $EV + (SETQ Z (CDR Z)) + LOOP2(COND ((CDR Z) (GO LOOP)) + ((NULL (CDR E)) (RETURN EXP)) + (T (GO NOUN))) + DOIT (COND ((NONVARCHECK (CADR Z) '$DIFF)) + ((NULL (CDDR Z)) (WNA-ERR '$DIFF)) + ((NOT (FIXNUMP (CADDR Z))) (GO NOUN)) + ((MINUSP (SETQ COUNT (CADDR Z))) + (MERROR "Improper count to DIFF:~%~M" COUNT))) + LOOP1(COND ((ZEROP COUNT) (RPLACD Z (CDDDR Z)) (GO LOOP2)) + ((EQUAL (SETQ EXP (SDIFF EXP (CADR Z))) 0) (RETURN 0))) + (SETQ COUNT (1- COUNT)) + (GO LOOP1) + NOUN (RETURN (DIFF%DERIV (CONS EXP (CDR E)))))) + +(DEFUN CHAINRULE (E X) + (LET (W) + (COND (ISLINP (IF (AND (NOT (ATOM E)) + (EQ (CAAR E) '%DERIVATIVE) + (NOT (FREEL (CDR E) X))) + (DIFF%DERIV (LIST E X 1)) + 0)) + ((ATOMGRAD E X)) + ((NOT (SETQ W (MGET (COND ((ATOM E) E) + ((MEMQ 'ARRAY (CDAR E)) (CAAR E)) + ((ATOM (CADR E)) (CADR E)) + (T (CAAADR E))) + 'DEPENDS))) + 0) + (T (LET (DERIVFLAG) + (ADDN (MAPCAR + #'(LAMBDA (U) + (LET ((Y (SDIFF U X))) + (IF (EQUAL Y 0) + 0 + (LIST '(MTIMES) + (OR (ATOMGRAD E U) + (LIST '(%DERIVATIVE) E U 1)) + Y)))) + W) + NIL)))))) + +(DEFUN ATOMGRAD (E X) + (LET (Y) (AND (ATOM E) (SETQ Y (MGET E '$ATOMGRAD)) (ASSOLIKE X Y)))) + +(DEFUN DEPENDS (E X) + (COND ((ALIKE1 E X) T) + ((MNUMP E) NIL) + ((ATOM E) (MGET E 'DEPENDS)) + (T (OR (DEPENDS (CAAR E) X) (DEPENDSL (CDR E) X))))) + +(DEFUN DEPENDSL (L X) (DOLIST (U L) (IF (DEPENDS U X) (RETURN T)))) + +(DEFMFUN SDIFF (E X) ; The args to SDIFF are assumed to be simplified. + (COND ((ALIKE1 E X) 1) + ((MNUMP E) 0) + ((OR (ATOM E) (MEMQ 'ARRAY (CDAR E))) (CHAINRULE E X)) + ((EQ (CAAR E) 'MRAT) (RATDX E X)) + ((EQ (CAAR E) 'MPLUS) (ADDN (SDIFFMAP (CDR E) X) T)) + ((MBAGP E) (CONS (CAR E) (SDIFFMAP (CDR E) X))) + ((MEMQ (CAAR E) '(%SUM %PRODUCT)) (DIFFSUMPROD E X)) + ((NOT (DEPENDS E X)) 0) + ((EQ (CAAR E) 'MTIMES) (ADDN (SDIFFTIMES (CDR E) X) T)) + ((EQ (CAAR E) 'MEXPT) (DIFFEXPT E X)) + ((EQ (CAAR E) 'MNCTIMES) + (LET (($DOTDISTRIB T)) + (ADD2 (NCMULN (CONS (SDIFF (CADR E) X) (CDDR E)) T) + (NCMUL2 (CADR E) (SDIFF (CONS '(MNCTIMES) (CDDR E)) X))))) + ((AND $VECT_CROSS (EQ (CAAR E) '|$~|)) + (ADD2* `((|$~|) ,(CADR E) ,(SDIFF (CADDR E) X)) + `((|$~|) ,(SDIFF (CADR E) X) ,(CADDR E)))) + ((EQ (CAAR E) 'MNCEXPT) (DIFFNCEXPT E X)) + ((MEMQ (CAAR E) '(%LOG %PLOG)) + (SDIFFGRAD (IF (AND (NOT (ATOM (CADR E))) (EQ (CAAADR E) 'MABS)) + (CONS (CAR E) (CDADR E)) + E) + X)) + ((EQ (CAAR E) '%DERIVATIVE) + (COND ((OR (ATOM (CADR E)) (MEMQ 'ARRAY (CDAADR E))) (CHAINRULE E X)) + ((FREEL (CDDR E) X) (DIFF%DERIV (CONS (SDIFF (CADR E) X) (CDDR E)))) + (T (DIFF%DERIV (LIST E X 1))))) + ((MEMQ (CAAR E) '(%BINOMIAL $BETA)) + (LET ((EFACT ($MAKEFACT E))) + (MUL2 (FACTOR (SDIFF EFACT X)) (DIV E EFACT)))) + ((EQ (CAAR E) '%INTEGRATE) (DIFFINT E X)) + ((EQ (CAAR E) '%LAPLACE) (DIFFLAPLACE E X)) + ((EQ (CAAR E) '%AT) (DIFF-%AT E X)) + ((MEMQ (CAAR E) '(%REALPART %IMAGPART)) + (LIST (NCONS (CAAR E)) (SDIFF (CADR E) X))) + (T (SDIFFGRAD E X)))) + +(DEFUN SDIFFGRAD (E X) + (LET ((FUN (CAAR E)) GRAD ARGS) + (COND ((AND (EQ FUN 'MQAPPLY) (GET (CAAADR E) 'GRAD)) + (SDIFFGRAD (CONS (NCONS (CAAADR E)) (APPEND (CDADR E) (CDDR E))) + X)) + ((OR (EQ FUN 'MQAPPLY) (NULL (SETQ GRAD (GET FUN 'GRAD)))) + (IF (NOT (DEPENDS E X)) 0 (DIFF%DERIV (LIST E X 1)))) + ((NOT (= (LENGTH (CDR E)) (LENGTH (CAR GRAD)))) + (MERROR "Wrong number of arguments for ~:M" FUN)) + (T (SETQ ARGS (SDIFFMAP (CDR E) X)) + (ADDN (MAPCAR + #'MUL2 + (CDR (SUBSTITUTEL + (CDR E) (CAR GRAD) + (DO ((L1 (CDR GRAD) (CDR L1)) + (ARGS ARGS (CDR ARGS)) (L2)) + ((NULL L1) (CONS '(MLIST) (NREVERSE L2))) + (SETQ L2 (CONS (COND ((EQUAL (CAR ARGS) 0) 0) + (T (CAR L1))) + L2))))) + ARGS) + T))))) + +(DEFUN SDIFFMAP (E X) (MAPCAR #'(LAMBDA (TERM) (SDIFF TERM X)) E)) + +(DEFUN SDIFFTIMES (L X) + (PROG (TERM LEFT OUT) + LOOP (SETQ TERM (CAR L) L (CDR L)) + (SETQ OUT (CONS (MULN (CONS (SDIFF TERM X) (APPEND LEFT L)) T) OUT)) + (IF (NULL L) (RETURN OUT)) + (SETQ LEFT (CONS TERM LEFT)) + (GO LOOP))) + +(DEFUN DIFFEXPT (E X) + (IF (MNUMP (CADDR E)) + (MUL3 (CADDR E) (POWER (CADR E) (ADDK (CADDR E) -1)) (SDIFF (CADR E) X)) + (MUL2 E (ADD2 (MUL3 (POWER (CADR E) -1) (CADDR E) (SDIFF (CADR E) X)) + (MUL2 (SIMPLIFYA (LIST '(%LOG) (CADR E)) T) + (SDIFF (CADDR E) X)))))) + +(DEFUN DIFF%DERIV (E) (LET (DERIVFLAG) (SIMPLIFYA (CONS '(%DERIVATIVE) E) T))) + +(PROG1 '(GRAD properties) + (LET ((HEADER (PURCOPY '(X)))) + (MAPC #'(LAMBDA (Z) (PUTPROP (CAR Z) (CONS HEADER (CDR Z)) 'GRAD)) + ; All these GRAD templates have been simplified and then the SIMP flags + ; (which are unnecessary) have been removed to save core space. + '((%LOG ((MEXPT) X -1)) (%PLOG ((MEXPT) X -1)) + (%GAMMA ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) X) ((%GAMMA) X))) + (MFACTORIAL ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) ((MPLUS) 1 X)) + ((MFACTORIAL) X))) + (%SIN ((%COS) X)) + (%COS ((MTIMES) -1 ((%SIN) X))) + (%TAN ((MEXPT) ((%SEC) X) 2)) + (%COT ((MTIMES) -1 ((MEXPT) ((%CSC) X) 2))) + (%SEC ((MTIMES) ((%SEC) X) ((%TAN) X))) + (%CSC ((MTIMES) -1 ((%COT) X) ((%CSC) X))) + (%ASIN ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2))) + (%ACOS ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) + ((RAT) -1 2)))) + (%ATAN ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1)) + (%ACOT ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1))) + (%ACSC ((MTIMES) -1 ((MEXPT) X -1) + ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2)))) + (%ASEC ((MTIMES) ((MEXPT) X -1) ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2)))) + (%SINH ((%COSH) X)) + (%COSH ((%SINH) X)) + (%TANH ((MEXPT) ((%SECH) X) 2)) + (%COTH ((MTIMES) -1 ((MEXPT) ((%CSCH) X) 2))) + (%SECH ((MTIMES) -1 ((%SECH) X) ((%TANH) X))) + (%CSCH ((MTIMES) -1 ((%COTH) X) ((%CSCH) X))) + (%ASINH ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2))) + (%ACOSH ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2))) + (%ATANH ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) -1)) + (%ACOTH ((MTIMES) -1 ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) -1))) + (%ASECH ((MTIMES) -1 ((MEXPT) X -1) + ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2)))) + (%ACSCH ((MTIMES) -1 ((MEXPT) X -1) + ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2)))) + (MABS ((MTIMES) X ((MEXPT) ((MABS) X) -1))) + (%ERF ((MTIMES) 2 ((MEXPT) $%PI ((RAT) -1 2)) + ((MEXPT) $%E ((MTIMES) -1 ((MEXPT) X 2))))) +; ($LI2 ((MTIMES) -1 ((%LOG) ((MPLUS) 1 ((MTIMES) -1 X))) ((MEXPT) X -1))) + ($EI ((MTIMES) ((MEXPT) X -1) ((MEXPT) $%E X)))))) + + (DEFPROP $ATAN2 ((X Y) ((MTIMES) Y ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1)) + ((MTIMES) -1 X ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1))) + GRAD) + + (DEFPROP $%J ((N X) ((%DERIVATIVE) ((MQAPPLY) (($%J ARRAY) N) X) N 1) + ((MPLUS) ((MQAPPLY) (($%J ARRAY) ((MPLUS) -1 N)) X) + ((MTIMES) -1 N ((MQAPPLY) (($%J ARRAY) N) X) ((MEXPT) X -1)))) + GRAD) + + (DEFPROP $LI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($LI ARRAY) N) X) N 1) + ((MTIMES) ((MQAPPLY) (($LI ARRAY) ((MPLUS) -1 N)) X) ((MEXPT) X -1))) + GRAD) + + (DEFPROP $PSI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($PSI ARRAY) N) X) N 1) + ((MQAPPLY) (($PSI ARRAY) ((MPLUS) 1 N)) X)) + GRAD)) + +(DEFMFUN ATVARSCHK (ARGL) + (DO ((LARGL (LENGTH ARGL) (1- LARGL)) (LATVRS (LENGTH ATVARS)) (L)) + ((NOT (< LATVRS LARGL)) (NCONC ATVARS L)) + (SETQ L (CONS (IMPLODE (CONS '& (CONS '@ (MEXPLODEN LARGL)))) L)))) + +(DEFMFUN NOTLOREQ (X) + (OR (ATOM X) + (NOT (MEMQ (CAAR X) '(MLIST MEQUAL))) + (AND (EQ (CAAR X) 'MLIST) + (DOLIST (U (CDR X)) (IF (NOT (MEQUALP U)) (RETURN T)))))) + +(DEFMFUN SUBSTITUTEL (L1 L2 E) + (DO ((L1 L1 (CDR L1)) (L2 L2 (CDR L2))) ((NULL L1) E) + (SETQ E (SUBSTITUTE (CAR L1) (CAR L2) E)))) + +(DEFMFUN UNION* (A B) + (DO ((A A (CDR A)) (X B)) ((NULL A) X) + (IF (NOT (MEMALIKE (CAR A) B)) (SETQ X (CONS (CAR A) X))))) + +(DEFMFUN INTERSECT* (A B) + (DO ((A A (CDR A)) (X)) ((NULL A) X) + (IF (MEMALIKE (CAR A) B) (SETQ X (CONS (CAR A) X))))) + +(DEFMFUN NTHELEM (N E) (CAR (NTHCDR (1- N) E))) + +(DEFMFUN DELSIMP (E) (DELQ 'SIMP (APPEND E NIL) 1)) + +(DEFMFUN REMSIMP (E) + (IF (ATOM E) E (CONS (DELSIMP (CAR E)) (MAPCAR #'REMSIMP (CDR E))))) + +(DEFMFUN $TRUNC (E) + (COND ((ATOM E) E) + ((EQ (CAAR E) 'MPLUS) (CONS (APPEND (CAR E) '(TRUNC)) (CDR E))) + ((MBAGP E) (CONS (CAR E) (MAPCAR #'$TRUNC (CDR E)))) + ((SPECREPP E) ($TRUNC (SPECDISREP E))) + (T E))) + +(DEFMFUN NONVARCHECK (E FN) + (IF (OR (MNUMP E) + (AND (NOT (ATOM E)) (NOT (EQ (CAAR E) 'MQAPPLY)) (MOPP1 (CAAR E)))) + (MERROR "Non-variable 2nd argument to ~:M:~%~M" FN E))) + +(DEFMSPEC $LDISPLAY (FORM) (DISP1 (CDR FORM) T T)) + +(DEFMFUN $LDISP N (DISP1 (LISTIFY N) T NIL)) + +(DEFMSPEC $DISPLAY (FORM) (DISP1 (CDR FORM) NIL T)) + +(DEFMFUN $DISP N (DISP1 (LISTIFY N) NIL NIL)) + +(DEFUN DISP1 (LL LABLIST EQNSP) + (IF LABLIST (SETQ LABLIST (NCONS '(MLIST SIMP)))) + (DO ((LL LL (CDR LL)) (L) (ANS) ($DISPFLAG T) (TIM 0)) + ((NULL LL) (OR LABLIST '$DONE)) + (SETQ L (CAR LL) ANS (IF EQNSP (MEVAL L) L)) + (IF (AND EQNSP (NOT (MEQUALP ANS))) + (SETQ ANS (LIST '(MEQUAL SIMP) (DISP2 L) ANS))) + (IF LABLIST (NCONC LABLIST (NCONS (ELABEL ANS)))) + (SETQ TIM (RUNTIME)) + (DISPLA (LIST '(MLABLE) (IF LABLIST LINELABLE) ANS)) + (MTERPRI) + (TIMEORG TIM))) + +(DEFUN DISP2 (E) + (COND ((ATOM E) E) + ((EQ (CAAR E) 'MQAPPLY) + (CONS '(MQAPPLY) (CONS (CONS (CAADR E) (MAPCAR #'MEVAL (CDADR E))) + (MAPCAR #'MEVAL (CDDR E))))) + ((EQ (CAAR E) 'MSETQ) (DISP2 (CADR E))) + ((EQ (CAAR E) 'MSET) (DISP2 (MEVAL (CADR E)))) + ((EQ (CAAR E) 'MLIST) (CONS (CAR E) (MAPCAR #'DISP2 (CDR E)))) + ((MSPECFUNP (CAAR E)) E) + (T (CONS (CAR E) (MAPCAR #'MEVAL (CDR E)))))) + +(DEFMFUN ELABEL (E) + (IF (NOT (CHECKLABEL $LINECHAR)) (SETQ $LINENUM (1+ $LINENUM))) + (MAKELABEL $LINECHAR) + (IF (NOT $NOLABELS) (SET LINELABLE E)) + LINELABLE) + +(DEFMFUN $DISPTERMS (E) + (COND ((OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT)) (DISPLA E)) + ((SPECREPP E) ($DISPTERMS (SPECDISREP E))) + (T (LET (($DISPFLAG T)) + (MTERPRI) + (DISPLA (GETOP (MOP E))) + (DO E (IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP)) + (REVERSE (CDR E)) + (MARGS E)) + (CDR E) (NULL E) (MTERPRI) (DISPLA (CAR E)) (MTERPRI))) + (MTERPRI))) + '$DONE) + +(DEFMFUN $DISPFORM N + (IF (NOT (OR (= N 1) (AND (= N 2) (EQ (ARG 2) '$ALL)))) + (MERROR "Incorrect arguments to DISPFORM")) + (LET ((E (ARG 1))) + (IF (OR (ATOM E) + (ATOM (SETQ E (IF (= N 1) (NFORMAT E) (NFORMAT-ALL E)))) + (MEMQ 'SIMP (CDAR E))) + E + (CONS (CONS (CAAR E) (CONS 'SIMP (CDAR E))) + (IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP)) + (REVERSE (CDR E)) + (CDR E)))))) + +(DEFMFUN $PART N (MPART (LISTIFY N) NIL NIL $INFLAG '$PART)) + +(DEFMFUN $INPART N (MPART (LISTIFY N) NIL NIL T '$INPART)) + +(DEFMSPEC $SUBSTPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL $INFLAG '$SUBSTPART))) + +(DEFMSPEC $SUBSTINPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL T '$SUBSTINPART))) + +(DEFMFUN PART1 (ARGLIST SUBSTFLAG DISPFLAG INFLAG) ; called only by TRANSLATE + (LET ((SUBSTP T)) (MPART ARGLIST SUBSTFLAG DISPFLAG INFLAG '$SUBSTPART))) + +(DEFMFUN MPART (ARGLIST SUBSTFLAG DISPFLAG INFLAG FN) + (PROG (SUBSTITEM ARG ARG1 EXP EXP1 EXP* SEVLIST COUNT PREVCOUNT N SPECP + LASTELEM LASTCOUNT) + (DECLARE (FIXNUM PREVCOUNT LASTELEM LASTCOUNT)) + (SETQ SPECP (OR SUBSTFLAG DISPFLAG)) + (IF SUBSTFLAG (SETQ SUBSTITEM (CAR ARGLIST) ARGLIST (CDR ARGLIST))) + (IF (NULL ARGLIST) (WNA-ERR '$PART)) + (SETQ EXP (IF SUBSTFLAG (MEVAL (CAR ARGLIST)) (CAR ARGLIST))) + (WHEN (NULL (SETQ ARGLIST (CDR ARGLIST))) + (SETQ $PIECE EXP) + (RETURN (COND (SUBSTFLAG (MEVAL SUBSTITEM)) + (DISPFLAG (BOX EXP DISPFLAG)) + (T EXP)))) + (COND ((NOT INFLAG) + (COND ((OR (AND ($LISTP EXP) (NULL (CDR ARGLIST))) + (AND ($MATRIXP EXP) + (OR (NULL (CDR ARGLIST)) (NULL (CDDR ARGLIST))))) + (SETQ INFLAG T)) + ((NOT SPECP) (SETQ EXP (NFORMAT EXP))) + (T (SETQ EXP (NFORMAT-ALL EXP))))) + ((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP)))) + (IF (AND (ATOM EXP) (NULL $PARTSWITCH)) + (MERROR "~:M called on atom: ~:M" FN EXP)) + (IF (AND INFLAG SPECP) (SETQ EXP (SUBST NIL NIL EXP))) + (SETQ EXP* EXP) + START(COND ((OR (ATOM EXP) (EQ (CAAR EXP) 'BIGFLOAT)) (GO ERR)) + ((EQUAL (SETQ ARG (COND (SUBSTFLAG (MEVAL (CAR ARGLIST))) + (T (CAR ARGLIST)))) + 0) + (SETQ ARGLIST (CDR ARGLIST)) + (COND ((MNUMP SUBSTITEM) + (MERROR "~M is an invalid operator in ~:M" + SUBSTITEM FN)) + ((AND SPECP ARGLIST) + (IF (EQ (CAAR EXP) 'MQAPPLY) + (PROG2 (SETQ EXP (CADR EXP)) (GO START)) + (MERROR "Invalid operator in ~:M" FN))) + (T (SETQ $PIECE (GETOP (MOP EXP))) + (RETURN + (COND (SUBSTFLAG + (SETQ SUBSTITEM (GETOPR (MEVAL SUBSTITEM))) + (COND ((MNUMP SUBSTITEM) + (MERROR "Invalid operator in ~:M:~%~M" + FN SUBSTITEM)) + ((NOT (ATOM SUBSTITEM)) + (IF (NOT (EQ (CAAR EXP) 'MQAPPLY)) + (RPLACA (RPLACD EXP (CONS (CAR EXP) + (CDR EXP))) + '(MQAPPLY))) + (RPLACA (CDR EXP) SUBSTITEM) + (RETURN (RESIMPLIFY EXP*))) + ((EQ (CAAR EXP) 'MQAPPLY) + (RPLACD EXP (CDDR EXP)))) + (RPLACA EXP (CONS SUBSTITEM + (IF (AND (MEMQ 'ARRAY (CDAR EXP)) + (NOT (MOPP SUBSTITEM))) + '(ARRAY)))) + (RESIMPLIFY EXP*)) + (DISPFLAG + (RPLACD EXP (CDR (BOX (SUBST NIL NIL EXP) DISPFLAG))) + (RPLACA EXP (IF (EQ DISPFLAG T) + '(MBOX) + '(MLABOX))) + (RESIMPLIFY EXP*)) + (T (WHEN ARGLIST (SETQ EXP $PIECE) (GO A)) + $PIECE)))))) + ((NOT (ATOM ARG)) (GO SEVERAL)) + ((NOT (FIXNUMP ARG)) + (MERROR "Non-integer argument to ~:M:~%~M" FN ARG)) + ((< ARG 0) (GO BAD))) + (IF (EQ (CAAR EXP) 'MQAPPLY) (SETQ EXP (CDR EXP))) + LOOP (COND ((NOT (ZEROP ARG)) (SETQ ARG (1- ARG) EXP (CDR EXP)) + (IF (NULL EXP) (GO ERR)) (GO LOOP)) + ((NULL (SETQ ARGLIST (CDR ARGLIST))) + (RETURN (COND (SUBSTFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP))) + (RPLACA EXP (MEVAL SUBSTITEM)) + (RESIMPLIFY EXP*)) + (DISPFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP))) + (RPLACA EXP (BOX (CAR EXP) DISPFLAG)) + (RESIMPLIFY EXP*)) + (INFLAG (SETQ $PIECE (CAR EXP))) + (T (SETQ $PIECE (SIMPLIFY (CAR EXP)))))))) + (SETQ EXP (CAR EXP)) + A (COND ((AND (NOT INFLAG) (NOT SPECP)) (SETQ EXP (NFORMAT EXP))) + ((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP)))) + (GO START) + ERR (COND ((EQ $PARTSWITCH 'MAPPLY) + (MERROR "Improper index to list or matrix")) + ($PARTSWITCH (RETURN (SETQ $PIECE '$END))) + (T (MERROR "~:M fell off end." FN))) + BAD (IMPROPER-ARG-ERR ARG FN) + SEVERAL + (IF (OR (NOT (MEMQ (CAAR ARG) '(MLIST $ALLBUT))) (CDR ARGLIST)) + (GO BAD)) + (SETQ EXP1 (CONS (CAAR EXP) (IF (MEMQ 'ARRAY (CDAR EXP)) '(ARRAY)))) + (IF (EQ (CAAR EXP) 'MQAPPLY) + (SETQ SEVLIST (LIST (CADR EXP) EXP1) EXP (CDDR EXP)) + (SETQ SEVLIST (NCONS EXP1) EXP (CDR EXP))) + (SETQ ARG1 (CDR ARG) PREVCOUNT 0 EXP1 EXP) + (DOLIST (ARG* ARG1) + (IF (NOT (FIXNUMP ARG*)) + (MERROR "Non-integer argument to ~:M:~%~M" FN ARG*))) + (WHEN (AND SPECP (EQ (CAAR ARG) 'MLIST)) + (IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1)))) + (SETQ ARG1 (SORT (APPEND ARG1 NIL) #'<))) + (WHEN (EQ (CAAR ARG) '$ALLBUT) + (SETQ N (LENGTH EXP)) + (DOLIST (I ARG1) + (IF (OR (< I 1) (> I N)) + (MERROR "Invalid argument to ~:M:~%~M" FN I))) + (DO ((I N (1- I)) (ARG2)) + ((= I 0) (SETQ ARG1 ARG2)) + (IF (NOT (MEMBER I ARG1)) (SETQ ARG2 (CONS I ARG2)))) + (IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1))))) + (IF (NULL ARG1) (IF SPECP (GO BAD) (GO END))) + (IF SUBSTFLAG (SETQ LASTCOUNT LASTELEM)) + SEVLOOP + (IF SPECP + (SETQ COUNT (- (CAR ARG1) PREVCOUNT) PREVCOUNT (CAR ARG1)) + (SETQ COUNT (CAR ARG1))) + (IF (< COUNT 1) (GO BAD)) + (IF (AND SUBSTFLAG (< (CAR ARG1) LASTELEM)) + (SETQ LASTCOUNT (1- LASTCOUNT))) + COUNT(COND ((NULL EXP) (GO ERR)) + ((NOT (= COUNT 1)) (SETQ COUNT (1- COUNT) EXP (CDR EXP)) (GO COUNT))) + (SETQ SEVLIST (CONS (CAR EXP) SEVLIST)) + (SETQ ARG1 (CDR ARG1)) + END (COND ((NULL ARG1) + (SETQ SEVLIST (NREVERSE SEVLIST)) + (SETQ $PIECE (IF (OR INFLAG (NOT SPECP)) + (SIMPLIFY SEVLIST) + (RESIMPLIFY SEVLIST))) + (RETURN (COND (SUBSTFLAG (RPLACA (NTHCDR (1- LASTCOUNT) EXP1) + (MEVAL SUBSTITEM)) + (RESIMPLIFY EXP*)) + (DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG)) + (RESIMPLIFY EXP*)) + (T $PIECE)))) + (SUBSTFLAG (IF (NULL (CDR EXP)) (GO ERR)) + (RPLACA EXP (CADR EXP)) (RPLACD EXP (CDDR EXP))) + (DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG)) + (SETQ EXP (CDR EXP))) + (T (SETQ EXP EXP1))) + (GO SEVLOOP))) + +(DEFMFUN GETOP (X) (OR (AND (SYMBOLP X) (GET X 'OP)) X)) + +(DEFMFUN GETOPR (X) (OR (AND (SYMBOLP X) (GET X 'OPR)) X)) + +#-Franz +(DEFMFUN $LISTP (X) + (AND (NOT (ATOM X)) + (NOT (ATOM (CAR X))) + (EQ (CAAR X) 'MLIST))) + +#+Franz ;; -Franz uses a macro definition in MAXMAC. +(defmfun mlistp (x) + (and (not (atom x)) + (or (eq (caar x) 'mlist) ($featurep (caar x) '$list)))) + +#+Franz +(putd '$listp (getd 'mlistp)) + +(DEFMFUN $CONS (X E) + (ATOMCHK (SETQ E (SPECREPCHECK E)) '$CONS T) + (MCONS-EXP-ARGS E (CONS X (MARGS E)))) + +(DEFMFUN $ENDCONS (X E) + (ATOMCHK (SETQ E (SPECREPCHECK E)) '$ENDCONS T) + (MCONS-EXP-ARGS E (APPEND (MARGS E) (NCONS X)))) + +(DEFMFUN $REVERSE (E) + (ATOMCHK (SETQ E (FORMAT1 E)) '$REVERSE NIL) + (MCONS-EXP-ARGS E (REVERSE (MARGS E)))) + +(DEFMFUN $APPEND N + (IF (= N 0) + '((MLIST SIMP)) + (LET ((ARG1 (SPECREPCHECK (ARG 1))) OP ARRP) + (ATOMCHK ARG1 '$APPEND NIL) + (SETQ OP (MOP ARG1) ARRP (IF (MEMQ 'ARRAY (CDAR ARG1)) T)) + (MCONS-EXP-ARGS + ARG1 + (APPLY #'APPEND + (MAPCAR #'(LAMBDA (U) + (ATOMCHK (SETQ U (SPECREPCHECK U)) '$APPEND NIL) + (IF (OR (NOT (ALIKE1 OP (MOP U))) + (NOT (EQ ARRP (IF (MEMQ 'ARRAY (CDAR U)) T)))) + (MERROR "Arguments to APPEND are not compatible.")) + (MARGS U)) + (LISTIFY N))))))) + +(DEFUN MCONS-EXP-ARGS (E ARGS) + (IF (EQ (CAAR E) 'MQAPPLY) + (LIST* (DELSIMP (CAR E)) (CADR E) ARGS) + (CONS (IF (MLISTP E) (CAR E) (DELSIMP (CAR E))) ARGS))) + +(DEFMFUN $MEMBER (X E) + (ATOMCHK (SETQ E ($TOTALDISREP E)) '$MEMBER T) + (IF (MEMALIKE ($TOTALDISREP X) (MARGS E)) T)) + +(DEFMFUN ATOMCHK (E FUN 2NDP) + (IF (OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT)) + (MERROR "~Margument to ~:M was atomic: ~M" + (IF 2NDP '|2nd | '||) FUN E))) + +(DEFMFUN FORMAT1 (E) + (COND (($LISTP E) E) ($INFLAG (SPECREPCHECK E)) (T (NFORMAT E)))) + +(DEFMFUN $FIRST (E) + (ATOMCHK (SETQ E (FORMAT1 E)) '$FIRST NIL) + (IF (NULL (CDR E)) (MERROR "Argument to FIRST is empty.")) + (CAR (MARGS E))) + +(DEFMFUN $REST N + (PROG (M FUN FUN1 REVP) + (IF (AND (= N 2) (EQUAL (ARG 2) 0)) (RETURN (ARG 1))) + (ATOMCHK (SETQ M (FORMAT1 (ARG 1))) '$REST NIL) + (COND ((= N 1)) + ((NOT (= N 2)) (WNA-ERR '$REST)) + ((NOT (FIXNUMP (ARG 2))) + (MERROR "2nd argument to REST must be an integer:~%~M" + (ARG 2))) + ((MINUSP (SETQ N (ARG 2))) (SETQ N (- N) REVP T))) + (IF (< (LENGTH (MARGS M)) N) + (IF $PARTSWITCH (RETURN '$END) (MERROR "REST fell off end."))) + (SETQ FUN (CAR M)) + (IF (EQ (CAR FUN) 'MQAPPLY) (SETQ FUN1 (CADR M) M (CDR M))) + (SETQ M (CDR M)) + (IF REVP (SETQ M (REVERSE M))) + (DO N N (1- N) (ZEROP N) (SETQ M (CDR M))) + (SETQ M (CONS (IF (EQ (CAR FUN) 'MLIST) FUN (DELSIMP FUN)) + (IF REVP (NREVERSE M) M))) + (IF (EQ (CAR FUN) 'MQAPPLY) + (RETURN (CONS (CAR M) (CONS FUN1 (CDR M))))) + (RETURN M))) + +(DEFMFUN $LAST (E) + (ATOMCHK (SETQ E (FORMAT1 E)) '$LAST NIL) + (IF (NULL (CDR E)) (MERROR "Argument to LAST is empty.")) + (CAR (LAST E))) + +(DEFMFUN $ARGS (E) (ATOMCHK (SETQ E (FORMAT1 E)) '$ARGS NIL) + (CONS '(MLIST) (MARGS E))) + +(DEFMFUN $DELETE N + (COND ((= N 2) (SETQ N -1)) + ((NOT (= N 3)) (WNA-ERR '$DELETE)) + ((OR (NOT (FIXNUMP (ARG 3))) (MINUSP (SETQ N (ARG 3)))) + (MERROR "Improper 3rd argument to DELETE:~%~M" (ARG 3)))) + (LET ((X (ARG 1)) (L (ARG 2))) + (ATOMCHK (SETQ L (SPECREPCHECK L)) '$DELETE T) + (SETQ X (SPECREPCHECK X) L (CONS (DELSIMP (CAR L)) (APPEND (CDR L) NIL))) + (PROG (L1) + (SETQ L1 (IF (EQ (CAAR L) 'MQAPPLY) (CDR L) L)) + LOOP (COND ((OR (NULL (CDR L1)) (ZEROP N)) (RETURN L)) + ((ALIKE1 X (SPECREPCHECK (CADR L1))) + (SETQ N (1- N)) (RPLACD L1 (CDDR L1))) + (T (SETQ L1 (CDR L1)))) + (GO LOOP)))) + +(DEFMFUN $LENGTH (E) + (SETQ E (COND (($LISTP E) E) + ((OR $INFLAG (NOT ($RATP E))) (SPECREPCHECK E)) + (T ($RATDISREP E)))) + (COND ((SYMBOLP E) 0) + ((OR (NUMBERP E) (EQ (CAAR E) 'BIGFLOAT)) + (IF (AND (NOT $INFLAG) (MNEGP E)) 1 0)) + ((OR $INFLAG (NOT (MEMQ (CAAR E) '(MTIMES MEXPT)))) (LENGTH (MARGS E))) + ((EQ (CAAR E) 'MEXPT) + (IF (AND (ALIKE1 (CADDR E) '((RAT SIMP) 1 2)) $SQRTDISPFLAG) 1 2)) + (T (LENGTH (CDR (NFORMAT E)))))) + +(DEFMFUN $ATOM (X) + (SETQ X (SPECREPCHECK X)) (OR (ATOM X) (EQ (CAAR X) 'BIGFLOAT))) + +(DEFMFUN $SYMBOLP (X) (SETQ X (SPECREPCHECK X)) (SYMBOLP X)) + +(DEFMFUN $NUM (E) + (LET (X) + (COND ((ATOM E) E) + ((EQ (CAAR E) 'MRAT) ($RATNUMER E)) + ((EQ (CAAR E) 'RAT) (CADR E)) + ((EQ (CAAR (SETQ X (NFORMAT E))) 'MQUOTIENT) (SIMPLIFY (CADR X))) + ((AND (EQ (CAAR X) 'MMINUS) (NOT (ATOM (SETQ X (CADR X)))) + (EQ (CAAR X) 'MQUOTIENT)) + (SIMPLIFY (LIST '(MTIMES) -1 (CADR X)))) + (T E)))) + +(DEFMFUN $DENOM (E) + (COND ((ATOM E) 1) + ((EQ (CAAR E) 'MRAT) ($RATDENOM E)) + ((EQ (CAAR E) 'RAT) (CADDR E)) + ((OR (EQ (CAAR (SETQ E (NFORMAT E))) 'MQUOTIENT) + (AND (EQ (CAAR E) 'MMINUS) (NOT (ATOM (SETQ E (CADR E)))) + (EQ (CAAR E) 'MQUOTIENT))) + (SIMPLIFY (CADDR E))) + (T 1))) + + +(DEFMFUN $FIX (E) ($ENTIER E)) + +(DEFMFUN $ENTIER (E) + (LET ((E1 (SPECREPCHECK E))) + (COND ((NUMBERP E1) (FIX E1)) + ((RATNUMP E1) (SETQ E (QUOTIENT (CADR E1) (CADDR E1))) + (IF (MINUSP (CADR E1)) (SUB1 E) E)) + (($BFLOATP E1) + (SETQ E (FPENTIER E1)) + (IF (AND (MINUSP (CADR E1)) (NOT (ZEROP1 (SUB E E1)))) + (SUB1 E) + E)) + (T (LIST '($ENTIER) E))))) + +(DEFMFUN $FLOAT (E) + (COND ((NUMBERP E) (FLOAT E)) + ((OR (ATOM E) (MEMQ 'ARRAY (CDAR E))) E) + ((EQ (CAAR E) 'RAT) (FPCOFRAT E)) + ((EQ (CAAR E) 'BIGFLOAT) (FP2FLO E)) + ((MEMQ (CAAR E) '(MEXPT MNCEXPT)) + (LIST (NCONS (CAAR E)) ($FLOAT (CADR E)) (CADDR E))) + (T (RECUR-APPLY #'$FLOAT E)))) + +(DEFMFUN $COEFF N + (COND ((= N 3) (IF (EQUAL (ARG 3) 0) + (COEFF (ARG 1) (ARG 2) (ARG 3)) + (COEFF (ARG 1) (POWER (ARG 2) (ARG 3)) 1))) + ((= N 2) (COEFF (ARG 1) (ARG 2) 1)) + (T (WNA-ERR '$COEFF)))) + +(DEFMFUN COEFF (E VAR POW) + (SIMPLIFY + (COND ((ALIKE1 E VAR) (IF (EQUAL POW 1) 1 0)) + ((ATOM E) (IF (EQUAL POW 0) E 0)) + ((EQ (CAAR E) 'MEXPT) + (COND ((ALIKE1 (CADR E) VAR) + (IF (OR (EQUAL POW 0) (NOT (ALIKE1 (CADDR E) POW))) 0 1)) + ((EQUAL POW 0) E) + (T 0))) + ((OR (EQ (CAAR E) 'MPLUS) (MBAGP E)) + (CONS (IF (EQ (CAAR E) 'MPLUS) '(MPLUS) (CAR E)) + (MAPCAR #'(LAMBDA (E) (COEFF E VAR POW)) (CDR E)))) + ((EQ (CAAR E) 'MRAT) (RATCOEFF E VAR POW)) + ((EQUAL POW 0) (IF (FREE E VAR) E 0)) + ((EQ (CAAR E) 'MTIMES) + (LET ((TERM (IF (EQUAL POW 1) VAR (POWER VAR POW)))) + (IF (MEMALIKE TERM (CDR E)) ($DELETE TERM E 1) 0))) + (T 0)))) + +(DECLARE (SPECIAL POWERS VAR HIFLG NUM FLAG)) + +(DEFMFUN $HIPOW (E VAR) (FINDPOWERS E T)) + ; These work best on expanded "simple" expressions. + +(DEFMFUN $LOPOW (E VAR) (FINDPOWERS E NIL)) + +(DEFUN FINDPOWERS (E HIFLG) + (LET (POWERS NUM FLAG) + (FINDPOWERS1 E) + (COND ((NULL POWERS) (IF (NULL NUM) 0 NUM)) + (T (IF NUM (SETQ POWERS (CONS NUM POWERS))) + (MAXIMIN POWERS (IF HIFLG '$MAX '$MIN)))))) + +(DEFUN FINDPOWERS1 (E) + (COND ((ALIKE1 E VAR) (CHECKPOW 1)) + ((ATOM E)) + ((EQ (CAAR E) 'MPLUS) + (COND ((NOT (FREEL (CDR E) VAR)) + (DO E (CDR E) (CDR E) (NULL E) + (SETQ FLAG NIL) (FINDPOWERS1 (CAR E)) + (IF (NULL FLAG) (CHECKPOW 0)))))) + ((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADR E) VAR)) (CHECKPOW (CADDR E))) + ((SPECREPP E) (FINDPOWERS1 (SPECDISREP E))) + (T (MAPC #'FINDPOWERS1 (CDR E))))) + +(DEFUN CHECKPOW (POW) + (SETQ FLAG T) + (COND ((NOT (NUMBERP POW)) (SETQ POWERS (CONS POW POWERS))) + ((NULL NUM) (SETQ NUM POW)) + (HIFLG (IF (GREATERP POW NUM) (SETQ NUM POW))) + ((LESSP POW NUM) (SETQ NUM POW)))) + +(DECLARE (UNSPECIAL POWERS VAR HIFLG NUM FLAG)) + + +; Undeclarations for the file: +(DECLARE (NOTYPE I N LARGL LVRS COUNT TIM)) + \ No newline at end of file diff --git a/src/jpg/suprv.642 b/src/jpg/suprv.642 new file mode 100644 index 00000000..495e8851 --- /dev/null +++ b/src/jpg/suprv.642 @@ -0,0 +1,2754 @@ +;;; -*- Mode: Lisp; Package: Macsyma; Base: 10 -*- + +; ** (c) Copyright 1976, 1983 Massachusetts Institute of Technology ** + +(macsyma-module suprv) + +;; #+MACLISP is ITS, Twenex, or Multics MacLisp. +;; #+PDP10 is ITS or Twenex MacLisp. +;; #+LISPM is the Lisp Machine or the Lisp Machine compiler running on ITS. +;; #+MACLISP and #+LISPM indicate which system a piece of code is intended +;; "for", not which system the code is being compiled "in". +;; #+GC means include gctime messages, and ok to call GCTWA here and there. +;; #-MAXII means not needed in new macsyma I/O and system organization. + +;; Setting BASE to 10 at compile time needed for LAP to work. + +(EVAL-WHEN (EVAL COMPILE) + (SETQ OLD-IBASE IBASE OLD-BASE BASE) + (SETQ IBASE 10. BASE 10.)) + +#+NIL +(EVAL-WHEN (EVAL COMPILE) + (SET-FEATURE 'MAXII)) + +(DECLARE (GENPREFIX /\S) + (SPECIAL M$+ GCFLAG GCT $LASTTIME $PARSETIME $DISPTIME + BINDLIST LOCLIST ERRSET $LABELS LINELABLE $BATCOUNT $FILESIZE + ST REPHRASE $DISPFLAG REFCHKL BAKTRCL RUBOUT TTYHEIGHT + CNTLY NEWLINE DSKFNP DSKSAVEP MOPL *RSET CNTL@ + ^W ^R ^Q ^D LF TAB FF CNTLC ALT BATCONL CR VT ^H ^S BSP + $VALUES $FUNCTIONS $ARRAYS $ALIASES $GRADEFS $DEPENDENCIES + $RULES $PROPS $RATVARS $RATVARSWITCH DEBUG ERRBRKSW ERRCATCH + VARLIST GENVAR $DEVICE $FILENAME $FILENUM LBP RBP + $GENSUMNUM CHECKFACTORS $FEATURES FEATUREL $BACKTRACE + $WEIGHTLEVELS TELLRATLIST $DONTFACTOR $INFOLISTS LOADFILES + $DSKALL ERRLIST ALLBUTL LISPERRPRINT BACKRUB + GC-DAEMON GC-OVERFLOW DEMONL $DYNAMALLOC ALLOCLEVEL INFILE + ALARMCLOCK $C18MAXTIME $FILEID DCOUNT GCLINENUM THISTIME + $NOLABELS $BATCHKILL DISPFLAG SAVENO MCATCH BRKLVL SAVEFILE + STRING ST1 $PROMPT STIME0 $%% $ERROR + *IN-$BATCHLOAD* *IN-TRANSLATE-FILE* + LESSORDER GREATORDER $ERRORFUN MBREAK REPRINT POS $STRDISP + $DSKUSE SMART-TTY RUBOUT-TTY MORE-^W OLDST ALPHABET + $LOADPRINT TTYINTS OPERS + *RATWEIGHTS $RATWEIGHTS QUITMSG MQUITMSG CONTMSG + LOADF DISPLAY-FILE $GRIND SCROLLP $CURSORDISP + STRINGDISP $LISPDISP MEXPRP DEFAULTF READING + BPORG GCSYML ^AMSG ^BMSG ^HMSG + STATE-PDL PROMPTMSG GCPROMPT COMMAND PRINTMSG MRG-PUNT + NEW-C-LINE-HOOK TRANSP $CONTEXTS $SETCHECK $MACROS + UNDF-FNCTN AUTOLOAD) +#+LISPM (SPECIAL ERROR-CALL) +#+Franz (special ptport display-to-disk) + (*EXPR REPRINT) + (*LEXPR CONCAT $FILEDEFAULTS $PRINT) + (FIXNUM $FILESIZE DCOUNT $BATCOUNT I N N1 N2 TTYHEIGHT + $FILENUM THISTIME GCT TIM GCLINENUM ALLOCLEVEL + BRKLVL CMTCNT BPORG BPORG0 (COMPUTIME FIXNUM FIXNUM) + (CASIFY FIXNUM) (GETLABCHARN)) + (FLONUM U1 STIME0) + (NOTYPE (ASCII-NUMBERP FIXNUM)) + (ARRAY* (FIXNUM DISPLAY-FILE 1))) + +;; This affects the runtime environment. ALJABR;LOADER also does this, but +;; leave it here for other systems. On the Lisp Machine, this is bound +;; per stack group. + +#-LISPM (SETQ BASE 10. IBASE 10. *NOPOINT T) + +#+PDP10 +(PROG1 '(AUTOLOAD properties) + (LET ((FILESPEC (PURCOPY '(FASL DSK MACSYM)))) + (MAPC #'(LAMBDA (X) + (LET ((FILE (IF (ATOM (CAR X)) (CONS (CAR X) FILESPEC) (CAR X)))) + (DOLIST (FUN (CDR X)) (PUTPROP FUN FILE 'AUTOLOAD)))) + '((LIMIT $LIMIT $LDEFINT) (IRINTE INTE) + (MATCOM $MATCHDECLARE $DEFMATCH $TELLSIMP $TELLSIMPAFTER $DEFRULE) + (MATRUN $DISPRULE $REMRULE $APPLY1 $APPLYB1 $APPLY2 $APPLYB2 + APPLY1 APPLY1HACK APPLY2 APPLY2HACK + FINDBE FINDFUN FINDEXPON FINDBASE PART+ PART*) +; (MATCH $MATCHDECLARE $DEFRULE $DEFMATCH $RPPLY $MARKOV $MARKOB +; $APPLYTD1 $APPLYTD2 $APPLYBP1 $APPLYBP2 $ENABLE $DISABLE +; $TELLSIMP $TELLSIMPAFTER $TELLPRESIMP $TELLPOSTSIMP $BUILTIN +; $RULES $DISPRULE $REMRULE NEWRULE PRENABLE SIMPRULE DEFMRUN +; $APPLY1 $APPLY2 $APPLYB1 $APPLYB2 KILLRULE) + (TLIMIT $TLIMIT $TLDEFINT TLIMP) (HOMOG HREDUCE) + ((APLOT2 FASL DSK SHARE) + $PLOT2 $PLOT3D $PARAMPLOT2 $CONTOURPLOT2 $LOADPLOTS $GRAPH2 + $GRAPH3D $NAMEPLOT $REPLOT $REPLOT4 $SAVEPLOTS) + ((TEKPLT FASL DSK SHARE) + $PLOTMODE $CLEAR $HARDCOPY $NAMEFILE PLOTMODE1) + ((LISPT FASL DSK LIBLSP) $TECO $TSTRING $EMACS) + (FORTRA $FORTRAN $FORTMX) (SCS $SCSIMP $DISTRIB $FACOUT) + (TRANSS $TRANSLATE $TRANSLATE_FILE $COMPFILE) + (TRANSL TRANSLATE-FUNCTION TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION + UPDATE-GLOBAL-DECLARES) + (MCOMPI $COMPILE $COMPILE_LISP_FILE) + (ALGFAC CPBGZASS CPTOM FIXMINPOLY FINDIBASE) + (NALGFA $SPLITFIELD $ALGFAC $PFACTORALG NALGFAC) + (OPTION $OPTIONS) (CPOLY $ALLROOTS) (LDISP LINEAR-DISPLA) + (DEFINT $DEFINT) (POLYRZ $NROOTS $REALROOTS STURM1) + (RISCH $RISCH RISCHINT) (OPTIM $OPTIMIZE $COLLAPSE) + (POIS3 $POISSIMP $PRINTPOIS $INTOPOIS $OUTOFPOIS) (POIS2 POISLIM1) + (ALGSYS $ALGSYS) (RESIDU $RESIDUE) + (MTRACE $TRACE $UNTRACE MACSYMA-UNTRACE $TIMER) (PRIMER $PRIMER) + (NEWDET $NEWDET $PERMANENT) ((CTENSR FASL DSK SHARE) $TSETUP) + (LAPLAC $LAPLACE $ILT) (SIN SININT INTEGRATOR) + (PADE $PADE) (SININT RATINT) (UFACT CPRES1) + (SERIES $POWERSERIES) (TRGRED $TRIGREDUCE SP1) + (HAYAT SRDISREP SRF SRCONVERT $TAYLOR $TAYLORINFO TAY-ORDER PSCOEFF1) + (FLOAT FPFORMAT BIGFLOAT2RAT FPPREC1 $BFLOAT FPSCAN FPENTIER + *FPATAN DIM-BIGFLOAT FP2FLO) + (EEZ EEZGCD) (NEWFAC NMULTFACT LCCHECK NCPBER3) + ((FASDMP FASL DSK LIBLSP) *FASDUMP) (SCHATC M1 M2 SCHATCHEN) + (NISIMP $LET $LETSIMP $LETRULES $REMLET LET-RULE-SETTER) + (MDOT SIMPNCT SIMPNCEXPT) + (SUMCON $SUMCONTRACT $INTOSUM $BASHINDICES $NICEINDICES) + (SYNEX $PREFIX $INFIX $POSTFIX $NOFIX $MATCHFIX $NARY) + (RPART $REALPART $IMAGPART RIPART CABS $RECTFORM $POLARFORM $CABS + $CARG TRISPLIT) + (ZERO $ZEROEQUIV) (LOGARC $LOGARC LOGARC HALFANGLE) (SPRDET SPRDET) + (NEWINV NEWINV) (LINNEW TMLATTICE) (APROPO $APROPOS) + (NUMTH $PRIME $TOTIENT $DIVSUM $JACOBI $GCFACTOR) + ((ODE FASL DSK SHARE) $ODE) + ((ODE2 FASL DSK SHARE) $ODE2) ((ELIM FASL DSK SHARE1) $ELIMINATE) + (ROMBRG $ROMBERG $ROMBERG_SUBR) ((DESOLN LISP DSK SHARE) $DESOLVE) + (NUMAPL SUBRCALLP SUBRCALL$P MACSYMACALLP FMAPPLY) + ((BESSEL FASL DSK SHARE) $BESSEL) ((INTSCE LISP DSK SHARE1) $INTSCE) + ((NUSUM > DSK SHARE) $NUSUM $FUNCSOLVE) + (SOLVE $SOLVE $LINSOLVE SOLVE SOLVEX) + (EZGCD $EZGCD FASTCONT EZGCD EZGCD2) ((HENSEL FASL DSK NRAT) SPHGCD) + ((INVERT LISP DSK SHARE1) $ADJOINT $INVERT) + (ASKP $ASKINTEGER ASK-INTEGER ASK-EVOD ASK-INTEGERP ASK-PROP) + ((DUMP FASL DSK SHARE) $DUMPARRAYS $LOADARRAYS) + (UPDATE $UPDATE_SAVED_FILE) (CHAR $GETCHARN) + (FCALL MFUNCTION-CALL TRD-MSYMEVAL EXPT$ M-TLAMBDA M-TLAMBDA& + M-TLAMBDA&ENV M-TLAMBDA&ENV& FUNGEN&ENV-FOR-MEVAL + FUNGEN&ENV-FOR-MEVALSUMARG M-TLAMBDA-I + COMPILE-FORMS-TO-COMPILE-QUEUE) + (EVALW $EVAL_WHEN) (SUSPEN $SUSPEND) + ((TRGSMP FASL DSK SHARE) $TRIGSIMP) + (INTPOL $INTERPOLATE $INTERPOLATE_SUBR) + ((ARRAY FASL DSK SHARE) $LISTARRAY $FILLARRAY $REARRAY) + ((DSKUSE FASL DSK SHARE2) $DISKUSE $FULLDISKUSE $PRINTDISKUSE $DISKFREE) + ((EIGEN FASL DSK SHARE) $EIGENVALUES $EIGENVECTORS) + (ACALL MARRAYREF MARRAYSET $ARRAYAPPLY $ARRAYSETAPPLY MFUNCALL + DISPLAY-FOR-TR INSURE-ARRAY-PROPS MAPPLY-TR INTERVAL-ERROR + IS-BOOLE-CHECK MAKE-ALAMBDA $MAYBE *MMINUS) + (TRMODE $MODEDECLARE $DEFINE_VARIABLE DEF-MTRVAR $MODE_IDENTITY + ASSIGN-MODE-CHECK FLUIDIZE $BIND_DURING_TRANSLATION) + (TRPROP META-ADD2LNC META-PUTPROP META-MPUTPROP META-FSET) + (SUBLIS $SUBLIS) (MTREE $APPLY_NOUNS) + (MDEFUN MDEFUN MDEFUN-TR DEFMTRFUN DEFMTRFUN-EXTERNAL) + ((FILEOP FASL DSK SHARE) + $PRINTFILE $LISTFILES $QLISTFILES $FILELENGTH $FILELIST $RENAMEFILE) + (MMACRO MDEFMACRO $MACROEXPAND $MACROEXPAND1 MMACRO-APPLY MMACROEXPANDED + MMACROEXPAND MMACROEXPAND1) + ((LRATS FASL DSK SHARE2) $LRATSUBST $FULLRATSUBST) + ((PACKG FASL DSK SHAREM) $HERALD_PACKAGE $LOAD_PACKAGE) + (DOVER $DOVER_FILE $DOVARD_FILE) + (TRDEBG $LISPDEBUGMODE) (MTAGS TAGS-START//END) + (AR $MAKE_ARRAY DIMENSION-ARRAY-OBJECT ARRSTORE-EXTEND + MEVAL1-EXTEND) + (NUMER GET-ARRAY MAKE-TRAMP$) + ((QQ FASL DSK SHARE1) $QUANC8) + ((HYP FASL DSK SHARE1) $HGFRED HGFSIMP-EXEC CHECKSIGNTM) + ((HYPGEO FASL DSK SHARE1) $SPECINT) + ((BFFAC BFZETA DSK SHARE2) $BFPSI0) + ((RNCOMB FASL DSK SHARE1) $RNCOMBINE) + (BUILDQ $BUILDQ MBUILDQ-SUBST))))) + +; This page is for SPLITFILE AUTOLOAD properties + +#+PDP10 +(PROG1 '(SPLITFILE AUTOLOAD properties) + (LET ((FILESPEC (PURCOPY '(FASL DSK MAXOUT)))) + (MAPC #'(LAMBDA (X) + (LET ((FILE (CONS (CAR X) FILESPEC))) + (DOLIST (FUN (CDR X)) (PUTPROP FUN FILE 'AUTOLOAD)))) + '((DIFF2 DIFFINT DIFFSUMPROD DIFFLAPLACE DIFF-%AT DIFFNCEXPT + STOTALDIFF) ; JPG;COMM2 + (AT $ATVALUE $AT AT1) (DERIVD $DERIVDEGREE) + (BOX $DPART $LPART $BOX $REMBOX) + (ATAN2 SIMPATAN2) (ARITHF $FIBTOPHI $NUMERVAL) + (MAPF $SCANMAP SUBGEN) (LOGCON $LOGCONTRACT) + (RTCON $ROOTSCONTRACT) (NTERMS $NTERMS) + (GENMAT $GENMATRIX $COPYMATRIX $COPYLIST) + (ARRAYF $ARRAYMAKE $ARRAYINFO) (ADDROW $ADDROW $ADDCOL) + (ALIAS $MAKEATOMIC $ORDERGREAT $ORDERLESS $UNORDER) + (CONCAT $CONCAT $GETCHAR) (TTYINI $TTY_INIT) + (PLOG SIMPPLOG) (BINOML SIMPBINOCOEF BINOCOMP) ; PAULW;CSIMP2 + (GAMMA SIMPBETA SIMPGAMMA) (ERF SIMPERF) + (EMATRIX $ZEROMATRIX $EMATRIX) (COEFM $COEFMATRIX $AUGCOEFMATRIX) + (ENTERM $ENTERMATRIX) (XTHRU $XTHRU) (XRTOUT XRUTOUT) + (KRONEC PKRONECK) (RATWT $RATWEIGHT WTPTIMES WTPEXPT) ; RAT;RATOUT + (FASTT $FASTTIMES) (HORNER $HORNER) (RATDIF $RATDIFF) (PFET $PFET) + (PFRAC $PARTFRAC PARTFRAC) (MODGCD NEWGCD) + (MRESUL $RESULTANT RESULTANT $POLY_DISCRIMINANT) ;RAT;RESULT + (SUBRES SUBRESULT) + (REDRES REDRESULT) (MODRES MODRESULT) (BEZOUT $BEZOUT) + (PLYGAM PSISIMP) (PLYLOG LISIMP) ;WGD;SPECFN + (MSORT $SORT) (MAKEL $MAKELIST $SUBLIST) ; DAS;MSTUFF + (SCUBIC SOLVECUBIC) (SQUART SOLVEQUARTIC) ; MAXSRC;PSOLVE + (GRAPH $PLOT $GRAPH) (GRAPH2 $PARAMPLOT $MULTIGRAPH) ; JPG;PLOT + (CFFUN $CF $CFEXPAND $CFDISREP $QUNIT) ; RZ;COMBIN + (SUM SIMPSUM2) (MINFCT $MINFACTORIAL $FACTCOMB $MAKEFACT $MAKEGAMMA) + (DECOMP $POLYDECOMP POLYDECOMP) + (EULBRN $EULER SIMPEULER $BERN SIMPBERN $BERNPOLY) + (ZETA $ZETA $FIB) (PRODCT $PRODUCT SIMPPROD) + (TAYRAT $TAYTORAT) (DEFTAY $DEFTAYLOR) + (TRIGEX $TRIGEXPAND TRIGEXPAND) ; MRG;TRIGO + (HYPER SIMP-%SINH SIMP-%COSH SIMP-%TANH SIMP-%COTH SIMP-%CSCH SIMP-%SECH) + (ATRIG SIMP-%ASIN SIMP-%ACOS SIMP-%ACOT SIMP-%ACSC SIMP-%ASEC) + (AHYPER SIMP-%ASINH SIMP-%ACOSH SIMP-%ATANH SIMP-%ACOTH SIMP-%ACSCH SIMP-%ASECH) + (OUTEX $MAKE_INDEX_FILE) (OUTEY $OPEN_INDEX_FILE) ; MAXSRC;OUTEX + (DESCR $DESCRIBE MDESCRIBE $HELP) (EXAMPL $EXAMPLE) ; MAXSRC;DESCRI + (STATUS $ALARMCLOCK $SEND $BUG $MAIL $WHO $TIMEDATE) ; MAXSRC;OUTMIS + (ISOLAT $ISOLATE $PICKAPART $REVEAL) + (PROPFN $PROPERTIES $PROPVARS $PRINTPROPS) + (SCREEN $PAUSE $CLEARSCREEN) + (CHANGV $CHANGEVAR) (COMBF $COMBINE) + (FACSUM $FACTORSUM $GFACTORSUM) (FACOUT $FACTOROUT))))) + +#+Franz +(eval-when (compile eval) (setsyntax '/ 2)) ; make esc a character +#+Franz (setq infile nil) + +(PROGN (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OPALIAS)) + '((+ $+) (- $-) (* $*) (// $//) (^ $^) (/. $/.) (< $<) (= $=) + (> $>) (/( $/() (/) $/)) (/[ $/[) (/] $/]) (/, $/,) (/: $/:) + (/! $/!) (/# $/#) (/' $/') (/; $/;))) + #-MAXII + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP2C)) + '((* ((#/* . $**))) (^ ((#/^ . $^^))) + (/: ((#/= . $/:=) (#/: . $/:/:))) (/! ((#/! . $/!/!))) + (< ((#/= . $<=))) (> ((#/= . $>=))) (/' ((#/' . $/'/'))))) + #-MAXII + (DEFPROP /: (((#/: #/=) . $/:/:=)) OP3C) + (MAPC #'(LAMBDA (X) (SET (CAR X) (ASCII (CADR X)))) + '((CNTL@ #^@) (CNTLC #^C) (BSP #\BS) (TAB #\TAB) (LF #\LF) + (VT #\VT) (FF #\FF) (CR #\CR) (CNTLY #^Y) (SP #\SP) + (NEWLINE #\NEWLINE) (RUBOUT #\RUBOUT))) + (SETQ GCSYML NIL) + (DOTIMES (I 14.) (PUSH (GENSYM) GCSYML)) + (SETQ ALT #-MULTICS ' #+MULTICS '&) +#-LISPM (SETQ $PLOTUNDEFINED (*$ 2.0 -8.5070591E+37)) + (SETQ $LASTTIME '((MLIST) 0 0) THISTIME 0 GCT 0 GCFLAG NIL + $PARSETIME NIL $DISPTIME NIL MEXPRP NIL) + (SETQ BATCONL NIL $BATCOUNT 0 $BATCHKILL NIL $STRDISP T $GRIND NIL) + (SETQ $RATVARSWITCH T ZUNDERFLOW T MOPL NIL ALIASCNTR 100.) + (SETQ REFCHKL NIL DEBUG NIL BAKTRCL NIL ERRBRKSW NIL MBREAK NIL $ERRORFUN NIL + ERRCATCH NIL DEMONL (LIST NIL) MCATCH NIL BRKLVL -1 + ALLBUTL NIL LOADF NIL $BACKTRACE '$BACKTRACE) + (SETQ *IN-$BATCHLOAD* NIL *IN-TRANSLATE-FILE* NIL) + (SETQ BACKRUB #-Franz nil #+Franz t) + (SETQ $DEBUGMODE NIL $BOTHCASES NIL + $PAGEPAUSE NIL $DSKGC NIL $POISLIM 5) + (SETQ $PROMPT '_ $LOADPRINT T ^S NIL LOADFILES NIL) +; (SETQ $FILEID NIL $C18MAXTIME 150.0E6) + (SETQ $NOLABELS NIL $ALIASES '((MLIST SIMP)) LESSORDER NIL GREATORDER NIL) + (SETQ $INFOLISTS + (PURCOPY '((MLIST SIMP) $LABELS $VALUES $FUNCTIONS $MACROS $ARRAYS + $MYOPTIONS $PROPS $ALIASES $RULES $GRADEFS + $DEPENDENCIES $LET_RULE_PACKAGES))) + (SETQ $LABELS '((MLIST SIMP)) $DSKUSE NIL $DEVICE '$DSK $DISPFLAG T LINELABLE NIL) + (SETQ REPHRASE NIL ST NIL OLDST NIL REPRINT NIL POS NIL) + (SETQ DCOUNT 0 $FILENUM 0 $STORENUM 1000. $FILESIZE 16. $DSKALL T + NEW-C-LINE-HOOK NIL DSKFNP NIL TTYINTS T + GCLINENUM 0 DSKSAVEP NIL SAVENO 0 $DYNAMALLOC NIL ALLOCLEVEL 0) + (SETQ QUITMSG " " + MQUITMSG " (Into LISP. Type control-G to get to MACSYMA.)" + CONTMSG "(Type to continue, to terminate.)" + ^AMSG " (Type EXIT; to exit.)" + ^BMSG #-Multics "LISP (Type P to continue.)" + #+Multics "LISP (Type P to continue)" + ^HMSG " +(Use the RUBOUT or DEL(ETE) key to erase a character.)" ^DMSG-ON " +(Printout of GC statistics turned on. Type control-D again to turn them off.) +" ^DMSG-OFF " +(Printout of GC statistics turned off.) +" GCPROMPT "Type ALL; NONE; a level-no. or the name of the space. +" MORE-^W NIL + LISPERRPRINT T PRINTMSG NIL PROMPTMSG NIL MRG-PUNT NIL READING NIL) +; (SETQ $CALCOMPNUM 100.) + (SETQ STATE-PDL (PURCOPY (NCONS 'LISP-TOPLEVEL))) +#+MULTICS (SETQ $PLOT3DSIZE 20 $MULTGRAPH T) +#-Lispm (SETSYNTAX '/: #o502 '/:) + ; Slashify ':' on printout on other systems for the benefit of Lispm. +#+MACLISP (SSTATUS _ T) +#+MACLISP (SSTATUS FEATURE NOLDMSG) +#+MULTICS (ALLOC '(LIST (150000. NIL 0.2))) + '(Random properties)) + +;; Global variables defined by this package. + +(DEFMVAR $% '$% "The last D-line computed, corresponds to lisp *" NO-RESET) +(DEFMVAR $INCHAR '$C + "The alphabetic prefix of the names of expressions typed by the user.") +(DEFMVAR $OUTCHAR '$D + "The alphabetic prefix of the names of expressions returned by the system.") +(DEFMVAR $LINECHAR '$E + "The alphabetic prefix of the names of intermediate displayed expressions.") +(DEFMVAR $LINENUM 1 "the line number of the last expression." FIXNUM NO-RESET) +(DEFMVAR $DIREC 'JRMU + "The default file directory for SAVE, STORE, FASSAVE, and STRINGOUT." + NO-RESET) +(DEFMVAR CASEP T + "Causes translation of characters from lower to upper case on ITS, + and from upper to lower case on Multics and Franz.") +;(DEFMVAR $ERREXP '$ERREXP) +(DEFMVAR USER-TIMESOFAR NIL) + +#+Franz +(defmvar $ignoreeof nil + "Causes EOFs at top level to be ignored, else an EOF brings the user to LISP level.") + +#+PDP10 (DEFMVAR $TTYINTNUM #^U) +#+PDP10 (DEFMVAR $TTYINTFUN NIL) + +(DEFVAR MOREMSG "--Pause--") +(DEFVAR MORECONTINUE "--Continued--") +(DEFVAR MOREFLUSH NIL) +(DEFMVAR $MOREWAIT NIL "needs to be documented" NO-RESET) + +(DEFMVAR $SHOWTIME NIL) + +(DEFMVAR ALIASLIST NIL + "is used by the MAKEATOMIC scheme which has never been completed" + NO-RESET) + +;; Again, something to do with a LAP intermediate. +#-NIL +(DECLARE (SETQ BASE 8)) + +;; Various system incompatibilities. This should be restructured at some point. +;; System dependent functions are prefixed with "SYS-". + +#-Multics +(DEFMACRO SYS-DEFAULTF (X) `(DEFAULTF ,X)) + +#+Multics +(DEFUN SYS-DEFAULTF (X) + (SETQ X (NAMELIST X)) + (IF (EQ (CAR X) '*) + (DEFAULTF (CONS (CAR (DEFAULTF NIL)) (CDR X))) + (DEFAULTF X))) + +(DEFUN SYS-GCTIME () + #-(or Franz Lispm) (STATUS GCTIME) + #+Lispm 0 + #+Franz (cadr (ptime))) + +#.(SETQ NALT #-MULTICS #\ALT #+MULTICS #/&) + +(DEFMVAR $CHANGE_FILEDEFAULTS #+PDP10 T #-PDP10 NIL + "Does DDT-style file defaulting iff T") + +(DEFMVAR $FILE_STRING_PRINT #+PDP10 NIL #-PDP10 T + "If TRUE, filenames are output as strings; if FALSE, as lists.") + + + +#-MAXII +(DEFUN CONTINUE NIL + (LET ((STATE-PDL (CONS 'MACSYMA-TOPLEVEL STATE-PDL))) + (PROG ($DISPFLAG TEST N REPRINT POS) + #-(or Multics Franz) (SETQ ERRLIST '((ERRLFUN NIL)) QUITMSG MQUITMSG) + #+(or Multics Franz) (SETQ ERRLIST '((SUPUNBIND) (CONTINUE))) + (IF (NULL REPHRASE) (SETQ ST NIL)) + A2 (IF (NOT (CHECKLABEL $INCHAR)) (SETQ $LINENUM (1+ $LINENUM))) + A (MAKELABEL $INCHAR) + A1 (IF ^S (SETQ #.TTYOFF NIL ^S NIL)) + (MTERPRI) + (PRINTLABEL) + (SETQ POS (CURSORPOS)) + (IF (NOT (ZEROP (LISTEN))) (SETQ REPRINT T)) + (IF NEW-C-LINE-HOOK (FUNCALL NEW-C-LINE-HOOK)) + B (SETQ N (LET ((READING T)) (TYI))) + #+Franz (cond ((greaterp n 0)) + ($ignoreeof (go b)) + (t (*break T '|Entering lisp:|) (go b))) + (COND ((= N #\FF) (FORMFEED) (GO VT)) + ((= N #\VT) (GO VT)) + ((= N #\BS) (COND (BACKRUB (IF ST (POP ST)) (GO B)) + (T (LET (#.WRITEFILEP) (PRINC ^HMSG)) (GO VT)))) + #+Franz ((= N #^B) (*break T '|Entering lisp:|) (go b)) + ((= N #^Y) + (IF REPHRASE (SETQ REPHRASE NIL) (SETQ ST (APPEND OLDST ST))) + (GO REPRT)) + ((OR (= N #\SP) (= N #\CR) (= N #\TAB)) + (COND ((AND (NOT REPHRASE) ST) (PUSH N ST)) + ((AND (NULL ST) (= N #\CR)) (SETQ POS (CURSORPOS)))) + (GO B)) + #-LISPM + ((= N #.NALT) ; Enter the editor + (SETQ TEST (EDIT* (REVERSE ST))) (SETQ REPHRASE NIL) + (WHEN TEST (SETQ REPRINT T) (GO A1)) (GO REPRT)) + (#-LISPM (< N 32.) #+LISPM (NOT (ZEROP (LDB %%KBD-CONTROL N))) + (SETQ REPRINT T) (GO B)) ; Test for control characters + (REPHRASE (SETQ REPHRASE NIL ST NIL))) + (COND ((= N #/;) (SETQ $DISPFLAG T) (GO D)) + ((= N #/$) (SETQ $DISPFLAG NIL) (GO D)) + ((= N #/?) + (WHEN (AND ST (= (CAR ST) #/?) + (NOT (AND (CDR ST) (= (CADR ST) #/\)))) + (SETQ ST NIL) (GO A1))) + ((AND (= N #/\) (PROG2 (SETQ ST (CONS N ST) N (TYI)) NIL))) + #-(or Franz Multics) + ((= N #\RUBOUT) (RUBOUT* ST) (IF ST (POP ST)) (GO B))) + (PUSH N ST) + (GO B) + VT (IF REPHRASE (SETQ REPHRASE NIL ST NIL)) + REPRT(REPRINT ST (= N #\FF)) (GO B) + D (SETQ REPRINT NIL) + (COND ((NULL ST) (GO A1)) + (#.WRITEFILEP + (LET ((#.TTYOFF T)) + (PRINC (MAKNAM (REVERSE (CONS N ST)))) + #+Franz (terpr)))) + (SETQ REPHRASE T OLDST ST) + (COND ((NULL (SETQ TEST (PARSE1))) (GO A)) + ((NULL (SETQ TEST (CONTINUE1 (CAR TEST)))) + (COND (MBREAK (ERRLFUN1 MBREAK)) (T (ERRLFUN T) (GO A2)))) + (T (SETQ $% (CAR TEST)) (MAKELABEL $OUTCHAR) + (WHEN (NOT $NOLABELS) + (SET LINELABLE $%) + (PUTPROP LINELABLE (CONS (CADR $LASTTIME) (CADDR $LASTTIME)) + 'TIME)) + (COND ($DISPFLAG (REMPROP LINELABLE 'NODISP) (DISPLAY*)) + (T (PUTPROP LINELABLE T 'NODISP))) + (SETQ $LINENUM (1+ $LINENUM)))) + (GO A)))) +#+NIL +(DEFUN LINE-PROMPT () + (FORMAT () "(~A) " (MAKNAM (CDR (EXPLODEN LINELABLE))))) +#+NIL +;; this can be used anywere MREAD-WITH-PROMPT is defined. +(DEFUN CONTINUE () + (IF (NOT (CHECKLABEL $INCHAR)) (SETQ $LINENUM (1+ $LINENUM))) + (DO ((STATE-PDL (CONS 'MACSYMA-TOPLEVEL STATE-PDL)) + ($DISPFLAG) + (TEST)) + (()) + (MAKELABEL $INCHAR) + (SETQ TEST (MREAD-WITH-PROMPT (LINE-PROMPT))) + (IF (EQ (CAAR TEST) 'DISPLAYINPUT) (SETQ $DISPFLAG T)) + (SETQ TEST (CONTINUE1 (CADDR TEST))) + (SETQ $% TEST) + (MAKELABEL $OUTCHAR) + (WHEN (NOT $NOLABELS) + (SET LINELABLE $%) + (PUTPROP LINELABLE (CONS (CADR $LASTTIME) (CADDR $LASTTIME)) + 'TIME)) + (COND ($DISPFLAG (REMPROP LINELABLE 'NODISP) (DISPLAY*)) + (T (PUTPROP LINELABLE T 'NODISP))) + (SETQ $LINENUM (1+ $LINENUM)))) + +#-MAXII +(DEFUN CONTINUE1 (TEST) + (LET ((STATE-PDL (CONS 'COMPUTING STATE-PDL))) + (PROG (X THISTIME #+GC GCT) + #-Franz (MTERPRI) + (SETQ M$+ TEST) + (WHEN (NOT $NOLABELS) + (SET LINELABLE TEST) + (IF $DISPFLAG (REMPROP LINELABLE 'NODISP) + (PUTPROP LINELABLE T 'NODISP))) + #+GC (IF GCFLAG (LET (^D) (GC))) + #+GC (SETQ GCT (SYS-GCTIME)) + (SETQ THISTIME (RUNTIME)) + (SETQ TEST #-LISPM (ERRSET (MEVAL* TEST)) + #+LISPM (TOP-MEVAL TEST) + $LASTTIME (LIST '(MLIST SIMP) + (COMPUTIME (RUNTIME) THISTIME) + #+GC (COMPUTIME (SYS-GCTIME) GCT) + #-GC 0)) + (WHEN $SHOWTIME (IF (NOT (ZEROP (CHARPOS T))) (MTERPRI)) + (SETQ X (GCTIMEP $SHOWTIME (CADDR $LASTTIME))) + (MTELL-OPEN "~A msec." (CADR $LASTTIME)) + (IF (NULL TEST) (PRINC " so far")) + #+GC (IF X (MTELL-OPEN " GCtime= ~A msec." + (CADDR $LASTTIME))) + (MTERPRI)) + (RETURN TEST)))) +#+NIL +(DEFUN CONTINUE1 (TEST) + (LET ((STATE-PDL (CONS 'COMPUTING STATE-PDL)) + X THISTIME #+GC GCT WIN) + (MTERPRI) + (WHEN (NOT $NOLABELS) + (SET LINELABLE TEST) + (IF $DISPFLAG (REMPROP LINELABLE 'NODISP) + (PUTPROP LINELABLE T 'NODISP))) + #+GC (IF GCFLAG (LET (^D) (GC))) + #+GC (SETQ GCT (SYS-GCTIME)) + (SETQ THISTIME (RUNTIME)) + (UNWIND-PROTECT + (PROG1 (MEVAL* TEST) (SETQ WIN T)) + (SETQ $LASTTIME (LIST '(MLIST SIMP) + (COMPUTIME (RUNTIME) THISTIME) + #+GC (COMPUTIME (SYS-GCTIME) GCT) + #-GC 0)) + (WHEN $SHOWTIME (IF (NOT (ZEROP (CHARPOS T))) (MTERPRI)) + (SETQ X (GCTIMEP $SHOWTIME (CADDR $LASTTIME))) + (MTELL-OPEN "~A msec." (CADR $LASTTIME)) + #+GC (IF X (MTELL-OPEN " GCtime= ~A msec." + (CADDR $LASTTIME))) + (IF (NOT WIN) (PRINC " so far")) + (MTERPRI))))) + +(DEFMFUN MEVAL* (TEST) + (LET (REFCHKL BAKTRCL CHECKFACTORS) + (PROG2 (IF $RATVARSWITCH (SETQ VARLIST (CDR $RATVARS))) + (MEVAL TEST) + (CLEARSIGN)))) + +(DEFMFUN MAKELABEL (X) + (WHEN (AND $DSKUSE (NOT $NOLABELS) (> (SETQ DCOUNT (1+ DCOUNT)) $FILESIZE)) + (SETQ DCOUNT 0) (DSKSAVE)) + (SETQ LINELABLE (CONCAT X $LINENUM)) + (IF (NOT $NOLABELS) + (IF (OR (NULL (CDR $LABELS)) + (WHEN (MEMQ LINELABLE (CDDR $LABELS)) + (DELQ LINELABLE $LABELS 1) T) + (NOT (EQ LINELABLE (CADR $LABELS)))) + (SETQ $LABELS (CONS (CAR $LABELS) (CONS LINELABLE (CDR $LABELS)))))) + LINELABLE) + +(DEFMFUN PRINTLABEL NIL + (MTELL-OPEN "(~A) " (MAKNAM (CDR (EXPLODEN LINELABLE))))) + +(DEFMFUN MEXPLODEN (X &AUX (BASE 10.) (*NOPOINT T)) (EXPLODEN X)) + +(DEFMFUN ADDLABEL (LABEL) + (SETQ $LABELS (CONS (CAR $LABELS) (CONS LABEL (DELQ LABEL (CDR $LABELS) 1))))) + +(DEFMFUN TYI* NIL + #+Multics (CLEAR-INPUT NIL) + (DO N (TYI) (TYI) NIL + (COND ((OR (= N #\NewLine) (AND (> N 31) (NOT (= N #\RUBOUT)))) + (RETURN N)) + ((= N #\FORM) (FORMFEED) (PRINC (STRIPDOLLAR $PROMPT)))))) + +#+(or PDP10 Lispm) +(DEFUN CONTINUEP NIL (PRINC (STRIPDOLLAR $PROMPT)) (= (TYI*) #\Space)) + +#-(or PDP10 Lispm) +(DEFUN CONTINUEP NIL (PRINC (STRIPDOLLAR $PROMPT)) (= (TYI*) #\NewLine)) + +(DEFUN CHECKLABEL (X) ; CHECKLABEL returns T iff label is not in use. + (NOT (OR $NOLABELS (= $LINENUM 0) (BOUNDP (CONCAT X $LINENUM))))) + +(DEFUN GCTIMEP (TIMEP TIM) + (COND ((AND (EQ TIMEP '$ALL) (NOT (ZEROP TIM))) (PRINC "Totaltime= ") T) + (T (PRINC "Time= ") NIL))) + +;; If $BOTHCASES is T, lower case letters will not be converted to upper case. + +(DEFMFUN $BOTHCASES (X) (BOTHCASES1 NIL X)) + +(DEFUN BOTHCASES1 (SYMBOL VALUE) + SYMBOL ;Always bound to $BOTHCASES. Ignored. + ;; This won't work with the Lisp Machine reader. + #+MacLisp (DO I 97. (1+ I) (> I 122.) + (SETSYNTAX I (IF VALUE 1 321.) (IF VALUE I (- I 32.)))) + (SETQ CASEP (NOT VALUE)) VALUE) + +;(DEFUN BACKSPACE1 (NIL X) +; (COND (X (ADD2LNC 8 ALPHABET) +; (SETSYNTAX 8 322. NIL)) +; (T (DELETE 8 ALPHABET 1) +; (SETSYNTAX 8 131392. NIL))) +; (SETQ BSPP X)) + +#+LISPM +(DEFUN LISTEN () 0) ; Doesn't exist yet. + +(DEFUN DISPLAY* (&AUX (RET NIL) (TIM 0)) + #+GC (IF (EQ GCFLAG '$ALL) (LET (^D) (GC))) + (SETQ TIM (RUNTIME) + RET (LET ((ERRSET 'ERRBREAK2) (THISTIME -1)) + (ERRSET (DISPLA (LIST '(MLABLE) LINELABLE $%))))) + (IF (NULL RET) (MTELL "~%Error during display~%")) + (IF $DISPTIME (MTELL-OPEN "Displaytime= ~A msec.~%" (COMPUTIME (RUNTIME) TIM))) + RET) + +#+PDP10 +(DEFMFUN FORMFEED NIL (LET (#.TTYOFF) (CURSORPOS 'C))) + +#+Franz +(defmfun formfeed nil (tyo #\ff)) + +#+MULTICS +(DEFMFUN FORMFEED NIL + (IF (NOT (ZEROP (PAGEL NIL))) + (IOG VT (MAPC 'TYO '(31. 32. 48. 119. 100. 74. 126. 36. 13.)) + (CHARPOS NIL 0) (LINENUM NIL 0)) + (TYO 12.))) + +#-(or Franz Multics) +(DEFMFUN RUBOUT* (STG) + (LET (#.TTYOFF #.WRITEFILEP) + (COND (RUBOUT-TTY + (COND ((OR REPRINT (NULL STG) + (= (CAR STG) #\CR) (= (CAR STG) #\TAB)) + (COND (SMART-TTY + (CURSORPOS (CAR POS) (CDR POS)) (CURSORPOS 'L) + (IF (CDR STG) (PRINC (MAKNAM (REVERSE (CDR STG))))) + (SETQ REPRINT NIL)) + ((OR REPRINT STG) (REPRINT (CDR STG) NIL)))) + (T (IF (EQ RUBOUT-TTY '$TOPS20_MODE) + (PROGN (TYO #\BS) (TYO #\SP) (TYO #\BS)) + (CURSORPOS 'X))))) + (STG (TYO (CAR STG)))))) + +(DEFMFUN REPRINT (STG FFP) + (LET (#.TTYOFF #.WRITEFILEP) + (IF (NOT FFP) (MTERPRI)) + (CASEQ (CAR STATE-PDL) + (MACSYMA-TOPLEVEL (PRINTLABEL)) + (RETRIEVE (IF (EQ MRG-PUNT 'BREAK) (PRINC (STRIPDOLLAR $PROMPT))))) + (SETQ POS (CURSORPOS)) + (IF STG (PRINC (MAKNAM (REVERSE STG)))) + (SETQ REPRINT NIL))) + +;; The PDP10 is one of the only systems which autoload. +;; The definition for non-autoloading systems is in MAXMAC. - CWH +;; For now we'll let a USER put autoload properties on symbols +;; and at least let them get found on Multics. - Jim 3/24/81 +;; Franz also autoloads -- jkf +;; +#+(or Franz PDP10) +(DEFMFUN FIND-FUNCTION (FUNC) (OR (FBOUNDP FUNC) (LOAD-FUNCTION FUNC NIL))) + +#+(or Franz MACLISP) +(DEFMFUN LOAD-FUNCTION (FUNC MEXPRP) ; The dynamic loader + (LET ((FILE (GET FUNC 'AUTOLOAD))) + (IF FILE (FUNCALL AUTOLOAD (CONS FUNC FILE))))) + +#+(or Franz MACLISP) +(DEFMFUN FIND0 (FUNCPAIR) ; This is the normal value of AUTOLOAD. + (LET (((FUNC . FILE) FUNCPAIR)) + (LET (MEXPRP) (LOAD-FILE FILE)) + (COND ((AND MEXPRP (GET FUNC 'MACRO)) + (MERROR "LISP MACROs may not be called from MACSYMA level.")) + ((OR (FBOUNDP FUNC) (AND MEXPRP (MFBOUNDP FUNC))) + ;; Win. Lisp-defined, or called from macsyma level and + ;; is macsyma-defined. + (NCONS FUNC)) + ((AND (NOT MEXPRP) (MFBOUNDP FUNC)) + ;; Sort of a loss, called from lisp level, but defined + ;; only at macsyma level. We want the undefined function + ;; handler to take over now, and make sure we never get called + ;; on this loser again. + (REMPROP FUNC 'AUTOLOAD) + (FUNCALL UNDF-FNCTN (NCONS FUNC))) + (T (MERROR "~A not found" FUNC))))) + +(DEFMFUN LOAD-FILE (FILE) ($LOAD (TO-MACSYMA-NAMESTRING FILE))) + +(DEFMSPEC $LOADFILE (FORM) + (LOADFILE (FILESTRIP (CDR FORM)) NIL (NOT (MEMQ $LOADPRINT '(NIL $AUTOLOAD))))) + +#-Franz +(DEFMSPEC $SETUP_AUTOLOAD (L) + (SETQ L (CDR L)) + (IF (NULL (CDR L)) (WNA-ERR '$SETUP_AUTOLOAD)) + (LET ((FILE #-(or Lispm Multics) + (NAMELIST (MERGEF ($FILENAME_MERGE (CAR L)) + `((DSK ,(STATUS UDIR)) NOFILE))) + #+(or Lispm Multics) + ($FILENAME_MERGE (CAR L)))) + (DOLIST (FUNC (CDR L)) + (NONSYMCHK FUNC '$SETUP_AUTOLOAD) + (PUTPROP (SETQ FUNC (DOLLARIFY-NAME FUNC)) FILE 'AUTOLOAD) + (ADD2LNC FUNC $PROPS))) + '$DONE) + +(DEFMFUN DOLLARIFY (L) + (LET ((ERRSET 'ERRBREAK1)) + (CONS '(MLIST SIMP) + (MAPCAR #'(LAMBDA (X) + (LET (Y) + (COND ((NUMBERP X) X) + ((NUMBERP (SETQ Y (CAR (ERRSET + (READLIST + (MEXPLODEN X)) + NIL)))) + Y) + (T (MAKEALIAS X))))) + L)))) + +(DEFMFUN MFBOUNDP (FUNC) + (OR (MGETL FUNC '(MEXPR MMACRO)) + (GETL FUNC '(TRANSLATED-MMACRO MFEXPR* MFEXPR*S)))) + +(DEFMFUN FILENAMEL (FILE) + (COND ((ATOM FILE) (SETQ FILE (NCONS FILE))) + (($LISTP FILE) (SETQ FILE (CDR FILE))) + (T (MERROR "Not a proper filename ~M" FILE))) + (FILESTRIP FILE)) + +#+MACLISP +(DEFMFUN LOADFILE (FILE FINDP PRINTP) ; FILE may be in any acceptable LISP format. + (LET ((TIM 0) ERROR (SAVENO 0) TRUEF RECURP (BPORG0 BPORG)) + (WHEN FINDP (SETQ TIM (RUNTIME)) + (IF (NULL LOADF) (SETQ LOADF DEFAULTF) (SETQ RECURP T)) + (IF (MEMQ $LOADPRINT '(NIL $LOADFILE)) (SETQ PRINTP NIL))) + (SETQ TRUEF (TRUEFNAME FILE)) + (WHEN PRINTP (OR RECURP (MTERPRI)) + (IF $FILE_STRING_PRINT + (MTELL-OPEN "~A being loaded" (NAMESTRING TRUEF)) + (PRINL (APPEND (CDR TRUEF) (CAR TRUEF) '(|being loaded|)))) + (MTERPRI)) + (WHEN (NULL + (ERRSET + (COND (FINDP (LET ((Y (NOINTERRUPT 'TTY))) (LOAD FILE) (NOINTERRUPT Y))) + (T (IF $CHANGE_FILEDEFAULTS (SYS-DEFAULTF FILE)) (LOAD FILE))))) + (NOINTERRUPT NIL) (SETQ ERROR T)) + (IF (NOT (= BPORG BPORG0)) + (SETQ LOADFILES (CONS (LIST (NAMESTRING TRUEF) BPORG0 BPORG) LOADFILES))) + (COND ((NOT FINDP) (IF $CHANGE_FILEDEFAULTS (SYS-DEFAULTF FILE))) + ((NOT RECURP) (IF LOADF (SETQ DEFAULTF LOADF LOADF NIL)) (TIMEORG TIM))) + (WHEN ERROR + (WHEN (AND (= (SYS-FREE-MEMORY) 0) FINDP (FASLP TRUEF)) + (MTELL-OPEN "Package not entirely loaded in.~%") + (MTELL-OPEN "You will probably have to load up a new MACSYMA!!~%") + (LET ((ERRSET 'ERRBREAK1)) + (MERROR "Error while loading ~:M" (MFILE-OUT TRUEF)))) + (LET ((ERRSET 'ERRBREAK1)) + (MTELL-OPEN "~%Error in LOADFILE attempt") (ERROR))) + (IF PRINTP (MTELL-OPEN "Loading done~%")) + '$DONE)) + +#+LISPM ; This is quite different from the Maclisp version. +(DEFMFUN LOADFILE (FILE FINDP PRINTP &AUX (SAVENO 0)) + (AND FINDP (MEMQ $LOADPRINT '(NIL $LOADFILE)) (SETQ PRINTP NIL)) + ;; Should really get the truename of FILE. + (IF PRINTP (FORMAT T "~%~A being loaded.~%" FILE)) + (LOAD FILE) ; LOAD will decide whether fasl or not, etc. + '$DONE) + +#+Franz +(DEFUN LOADFILE (FILE FINDP PRINTP ) + (AND FINDP (MEMQ $LOADPRINT '(NIL $LOADFILE)) (SETQ PRINTP NIL)) + (COND (PRINTP (MTERPRI) + (PRINC FILE) ; Should really get the truename. + (PRINC '| being loaded.|) + (MTERPRI))) + (Load FILE) ; LOAD will have to figure out whether fasl or not, etc. + '$DONE) + +(DEFMFUN TRUEFNAME (FILE) + (OR (PROBEF FILE) + (CLOSE (OPEN FILE '(IN FIXNUM))) + ; The OPEN is to generate the appropriate error handling. + ; The CLOSE is just to be nice. + #+Multics FILE + ; The Multics CLOSE function returns T always. + ; At least we know we can open and close the file. + ; On Multics PROBEF calls ALLFILES which demands access to + ; the directory. + )) + +#-LISPM +(DEFMFUN MTRUENAME (FILEOBJ) + (LET ((FILE #+PDP10 (IF (EQ (STATUS OPSYS) 'ITS) + (TRUENAME FILEOBJ) + (TRUEFNAME (NAMELIST FILEOBJ))) + #-PDP10 (TRUEFNAME (NAMELIST FILEOBJ)))) + (MFILE-OUT FILE))) + +#+LISPM +(DEFMFUN MTRUENAME (STREAM) + (MFILE-OUT (UNEXPAND-PATHNAME (FUNCALL STREAM ':NAME)))) + +(DEFMFUN CARFILE (FILE) ; FILE is in OldIO list format. + (IF (= (LENGTH FILE) 3) (CDR FILE) FILE)) + +#-MAXII +(DEFMSPEC $BATCON (L) (SETQ L (CDR L)) + (COND ((OR (NULL L) (> (LENGTH L) 2)) (WNA-ERR '$BATCON)) + ((NULL BATCONL) (MERROR "BATCH and DEMO have never been called."))) + (LET ((X (MEVAL (CAR L)))) + (BATCH1 (LIST (CONS '(MLIST) (CAR BATCONL)) + (COND ((NULL X) $BATCOUNT) + ((EQ (TYPEP X) 'FIXNUM) X) + ((NOT (EQ X T)) (CAR L)) + (T (1+ $BATCOUNT))) + (COND ((NULL (CDR L)) + (COND ((EQ (TYPEP X) 'FIXNUM) (1- X)) + ((OR (NULL X) (EQ X T)) (CADR BATCONL)) + (T T))) + (T (MEVAL (CADR L))))) + (CADDR BATCONL) + $BATCOUNT + NIL))) + +#-MAXII +(DEFMSPEC $BATCH (L) (BATCH1 (CDR L) NIL NIL NIL)) + +#-MAXII +(DEFMSPEC $DEMO (L) (BATCH1 (CDR L) T NIL NIL)) + +;; SPECP is T if the file is being batched for TRANSL, or $LOAD, +;; or some other special purpose. +#-Franz +(DEFMACRO FILEPOS-CHECK () `(IF SPECP (SETQ FILEPOS (FILEPOS FILE-OBJ)))) +#+Franz +(defmacro filepos-check () nil) + +#-MAXII +(DEFMFUN BATCH1 (L DEMOP BATCONP SPECP) + (LET ((FN (IF DEMOP '$DEMO '$BATCH))) + (LET ((STATE-PDL (LIST* 'BATCH (IF *IN-TRANSLATE-FILE* '$TRANSLATE FN) STATE-PDL)) + (INFILE INFILE) + (TRANSLP (AND SPECP (NOT *IN-$BATCHLOAD*)))) + (PROG (FILE TEST TEST1 TEST2 INDEX HIGH $DISPFLAG + FILEPOS ;; set to filepos at first token of expression read. + EOF /\FLAG X CMTP ^Q CMTCNT FILE-OBJ FILE-NAME) + (SETQ EOF (NCONS NIL) INDEX 1 HIGH -1 CMTCNT 0) + + (COND ((OR (NULL L) (ATOM (CAR L))) + (SETQ FILE L) + (GO Z)) + ((NOT (EQ (CAAAR L) 'MLIST)) (IMPROPER-ARG-ERR (CAR L) FN)) + (T (SETQ FILE (CDAR L)))) + Z1 (COND ((NULL (SETQ L (CDR L))) (GO Z)) + ((NOT (ATOM (SETQ INDEX (MEVAL (CAR L))))) + (IMPROPER-ARG-ERR INDEX FN)) + ((MEMQ INDEX '(T NIL)) (SETQ INDEX 1) (GO Z1)) + ((NOT (EQ (TYPEP INDEX) 'FIXNUM)) + (SETQ INDEX (MAKSTRING* INDEX)))) + (WHEN (CDR L) + (IF (CDDR L) (WNA-ERR FN)) + (SETQ X (MEVAL (CADR L))) + (COND ((AND (EQ (TYPEP INDEX) 'FIXNUM) (EQ (TYPEP X) 'FIXNUM)) + (SETQ HIGH (- X INDEX))) + ((NULL X) (SETQ HIGH NIL)) + ((NOT (EQ X T)) (IMPROPER-ARG-ERR X FN)))) + + + Z (SETQ FILE (COND (BATCONP FILE) + ((AND BATCONL (NULL FILE)) (CAR (LAST BATCONL))) + (T (FILESTRIP FILE)))) + + (SETQ INFILE (SETQ FILE-OBJ (OPEN FILE '(READ ASCII)))) + ;; If user does BATCH or DEMO, update the file defaults. + ;; Don't do this for file translation. + #+MACLISP (IF (AND (NOT TRANSLP) $CHANGE_FILEDEFAULTS) (SYS-DEFAULTF FILE)) + #+LISPM (SETQ FILE-NAME (FILE-EXPAND-PATHNAME FILE)) + #+MACLISP (SETQ FILE-NAME (TRUENAME FILE-OBJ)) + #+Franz (setq file-name file) + ; Multics returns a true STRING from TRUENAME above. -JIM + #+PDP10 (SETQ FILE-NAME (APPEND (CDR FILE-NAME) (CAR FILE-NAME))) + (IF TRANSLP (GO A)) + (WHEN (AND $BATCHKILL BATCONL + #+MACLISP (NOT (EQUAL FILE-NAME (CAR BATCONL))) + #+LISPM (NOT (EQUAL FILE-NAME (CAR (LAST BATCONL))))) + (KILL1 (IF (EQ $BATCHKILL T) '$ALL $BATCHKILL)) + (IF (EQ $BATCHKILL T) ($RESET)) + #+GC (GCTWA)) + (SETQ BATCONL (LIST #-LISPM FILE-NAME + #+LISPM (UNEXPAND-PATHNAME FILE-NAME) + HIGH DEMOP + #+PDP10 FILE #-PDP10 FILE-NAME) + $BATCOUNT 0) + + + (COND (SPECP (GO A)) + ((EQUAL INDEX 1) (GO READ)) + ((NOT (EQ (TYPEP INDEX) 'FIXNUM)) (GO ALOOP))) + + ;; skip over 'index' input expressions. + ;; 'test' will be the current character and 'test1' the + ;; previous character + + + ILOOP (COND ((EQ (SETQ TEST (READCH FILE-OBJ EOF)) EOF) + (SETQ $BATCOUNT (OR BATCONP 0)) + (MERROR "Premature EOF in file")) + ((EQ TEST '/\) (READCH FILE-OBJ)) + ((AND (EQ TEST '*) (EQ TEST1 '//)) (SETQ TEST1 NIL CMTP 1) (GO CMT)) + ((MEMQ TEST '(/; $)) + (SETQ $BATCOUNT (1+ $BATCOUNT)) + (IF (= (SETQ INDEX (1- INDEX)) 1) (GO READ)))) + (SETQ TEST1 TEST) + (GO ILOOP) + + ALOOP (COND ((= (SETQ TEST2 (TYI FILE-OBJ -1)) -1) + (SETQ $BATCOUNT (OR BATCONP 0)) + (MERROR "~A not found in file" (MAKNAM INDEX))) + ((AND (PROG2 (SETQ TEST (ASCII (CASIFY TEST2))) (NULL TEST1)) + (OR (< TEST2 32.) (EQ TEST '/ ))) + (GO ALOOP)) + ((AND (EQ TEST '*) (EQ (CAR TEST1) '//)) (SETQ CMTP 2) (GO CMT)) + ((MEMQ TEST '(/; $)) + (SETQ $BATCOUNT (1+ $BATCOUNT) TEST1 NIL) (GO ALOOP)) + ((OR (EQ TEST CR) (EQ TEST LF)) + (SETQ TEST1 NIL) (GO ALOOP)) + ((EQ TEST '/\) (SETQ TEST1 (CONS TEST TEST1) TEST (READCH FILE-OBJ))) + ((EQ TEST '&) + (IF (EQ (CAR TEST1) '/ ) (SETQ TEST1 (CDR TEST1))) + (IF (AND (EQ (CAR TEST1) '&) (CDR TEST1) (NOT (EQ (CADR TEST1) '/\)) + (EQUAL INDEX (REVERSE (CDR TEST1)))) + (GO READ)))) + (SETQ TEST1 (CONS TEST TEST1)) + (GO ALOOP) + READ (SETQ $LINENUM (1+ $LINENUM)) + A #+(OR PDP10 LISPM) + (SETQ TEST (IF #+PDP10 (NULL (STATUS FILEMODE FILE-OBJ)) + #+LISPM (NOT (FILE-OPEN FILE-OBJ)) + EOF + (READCH FILE-OBJ EOF))) + #-(OR PDP10 LISPM) + (SETQ TEST (READCH FILE-OBJ EOF)) + (COND ((EQ TEST EOF) (MTERPRI) + ;; PDP10 Lisps do this automatically + #-PDP10 (CLOSE FILE-OBJ) + (RETURN '|&BATCH DONE|)) + ((OR (EQ TEST '/ ) (EQ TEST CR) (EQ TEST LF) + (EQ TEST FF) (EQ TEST TAB) + #+MACLISP (OR (EQ TEST CNTLC) (EQ TEST CNTL@))) + (GO A)) + (T ;; end of whitespace loop. + (FILEPOS-CHECK))) + (SETQ ST NIL) + (MAKELABEL $INCHAR) (MTERPRI) (PRINTLABEL) + (WHEN TEST2 (SETQ TEST2 NIL) (PRINC (MAKNAM INDEX)) (PRINC '|&& |)) + (GO B1) + + ;; collecting loop + ;; characters are collected in list 'st'. + ;; Collection ends when a ; or $ is seen and in that case + ;; control transfers to label 'd' + ;; + B (SETQ TEST (READCH FILE-OBJ EOF)) + B1 (COND (/\FLAG (SETQ /\FLAG NIL)) + ((EQ TEST EOF) + (WHEN (NULL ST) + (MTERPRI) #+LISPM (CLOSE FILE-OBJ) (RETURN '|&BATCH DONE|)) + (IF SPECP (SETQ #.TTYOFF NIL)) + (MTELL "~%EOF met") (SETQ REPHRASE T) (GO ERR)) + ((OR (EQ TEST '/ ) (EQ TEST CR) (EQ TEST TAB) + #-PDP10 (EQ TEST LF)) + (IF (NULL ST) (GO B))) + #+PDP10 ((EQ TEST LF) (GO B)) + #+MACLISP ((OR (EQ TEST CNTLC) (EQ TEST CNTL@)) (GO B)) + ((EQ TEST FF) (WHEN ST (MTERPRI) (SETQ TEST '/ ) (GO C)) (GO B)) + ((PROG2 (FILEPOS-CHECK) + ;; must be set here too because of whitespace loop above. + (AND (EQ TEST '*) ST (EQ (CAR ST) '//))) + (PRINC '*) (SETQ TEST1 NIL) (GO CMT)) + ((EQ TEST '&) + (WHEN (AND (EQ (CAR ST) '&) (CDR ST) (NOT (EQ (CADR ST) '/\))) + (PRINC TEST) (PRINC '/ ) (SETQ ST NIL) + (WHEN (NULL HIGH) (CLOSE FILE-OBJ) + (RETURN '|&BATCH TERMINATED|)) + (GO B))) + ((EQ TEST '/\) (SETQ /\FLAG T)) + ((EQ TEST '/;) (SETQ $DISPFLAG T) (GO D)) + ((EQ TEST '$) (SETQ $DISPFLAG NIL) (GO D))) + (PRINC TEST) + C (IF REPHRASE (SETQ REPHRASE NIL ST NIL)) + (SETQ ST (CONS TEST ST)) + (GO B) + + CMT ;; comment scanner + ;; this is reached via a 'go' from a number of places. + ;; If 'cmtp' is 1 then go to 'iloop' after comment + ;; If 'cmtp' is 2 then go to 'aloop' after comment + ;; Otherwise go to B + (SETQ TEST (READCH FILE-OBJ EOF)) + (COND ((EQ TEST EOF) (IF SPECP (SETQ #.TTYOFF NIL)) + (MTELL "EOF met inside of comment") + (SETQ REPHRASE T) (GO ERR)) + ((NOT (OR CMTP + #-(or Franz Multics) (EQ TEST LF) + #+MACLISP (OR (EQ TEST CNTLC) (EQ TEST CNTL@)))) + (PRINC TEST))) + (COND ((AND (EQ TEST '//) (EQ TEST1 '*)) + (UNLESS (ZEROP CMTCNT) + (SETQ TEST1 NIL CMTCNT (1- CMTCNT)) (GO CMT)) + (COND ((EQUAL CMTP 1) (SETQ CMTP NIL) (GO ILOOP)) + ((EQUAL CMTP 2) (SETQ TEST1 NIL CMTP NIL) (GO ALOOP))) + (WHEN (NULL (SETQ ST (CDR ST))) (MTERPRI) (MTERPRI)) (GO B)) + ((AND (EQ TEST '*) (EQ TEST1 '//)) + (SETQ TEST1 NIL CMTCNT (1+ CMTCNT)) (GO CMT))) + (SETQ TEST1 TEST) + (GO CMT) + + ;; end of scan. At this point, a $ or ; has terminated + ;; a line of input which is sitting reversed in the list 'st'. + ;; The symbol 'test' still holds the $ or ; + ;; + D (PRINC TEST) + + #+Franz (terpr) + + (DO L ST (CDR L) (NULL L) (RPLACA L (ASCII-CHK (CAR L)))) + (SETQ OLDST ST $BATCOUNT (1+ $BATCOUNT)) + (COND ((NULL ST) (GO D1)) + ((NULL (SETQ REPHRASE T + TEST (IF SPECP (LET (#.TTYOFF) (PARSE1)) (PARSE1)))) + (GO ERR)) + (SPECP (TRANSLATE-MACEXPR (CAR TEST) FILEPOS) (GO A)) + ((NULL (SETQ TEST (CONTINUE1 (CAR TEST)))) (GO ERR))) + (SETQ $% (CAR TEST)) + (MAKELABEL $OUTCHAR) + (UNLESS $NOLABELS + (SET LINELABLE $%) + (PUTPROP LINELABLE (CONS (CADR $LASTTIME) (CADDR $LASTTIME)) 'TIME)) + (COND ($DISPFLAG (REMPROP LINELABLE 'NODISP) + (IF (NULL (DISPLAY*)) (GO ERR))) + (T (PUTPROP LINELABLE T 'NODISP))) + (SETQ $LINENUM (1+ $LINENUM)) + D1 (WHEN (AND DEMOP (LET (#.TTYOFF) (NOT (CONTINUEP)))) + (CLOSE FILE-OBJ) (RETURN '|&DEMO TERMINATED|)) + (WHEN (AND (EQ (TYPEP HIGH) 'FIXNUM) + (NOT (< HIGH 0)) + (< (SETQ HIGH (1- HIGH)) 0)) + (CLOSE FILE-OBJ) (RETURN '|&BATCH DONE|)) + (GO A) + ERR (CLOSE FILE-OBJ) + (LET ((ERRSET 'ERRBREAK1)) + (IF SPECP (SETQ #.TTYOFF NIL)) + (DO L ST (CDR L) (NULL L) (RPLACA L (ASCII-CHK (CAR L)))) + (MTELL-OPEN "~%Error in ~:M file" + (IF *IN-TRANSLATE-FILE* '$TRANSLATE FN)) + (ERROR)))))) + +(DEFMSPEC $KILL (FORM) (MAPC #'KILL1 (CDR FORM)) #+GC (GCTWA) '$DONE) + +(DEFMFUN KILL1 (X) + ((LAMBDA (Z) + (COND ((AND ALLBUTL (MEMQ X ALLBUTL))) + ((EQ (SETQ X (GETOPR X)) '$LABELS) + (DOLIST (U (CDR $LABELS)) + (COND ((AND ALLBUTL (MEMQ U ALLBUTL)) + (SETQ Z (NCONC Z (NCONS U)))) + (T (MAKUNBOUND U) (REMPROP U 'TIME) + (REMPROP U 'NODISP)))) + (SETQ $LABELS (CONS '(MLIST SIMP) Z) $LINENUM 0 DCOUNT 0)) + ((MEMQ X '($VALUES $ARRAYS $ALIASES $RULES $PROPS $LET_RULE_PACKAGES)) + (MAPC #'KILL1 (CDR (SYMEVAL X)))) + ((MEMQ X '($FUNCTIONS $MACROS $GRADEFS $DEPENDENCIES)) + (MAPC #'(LAMBDA (Y) (KILL1 (CAAR Y))) (CDR (SYMEVAL X)))) + ((EQ X '$MYOPTIONS)) + ((EQ X '$TELLRATS) (SETQ TELLRATLIST NIL)) + ((EQ X '$RATWEIGHTS) (SETQ *RATWEIGHTS NIL $RATWEIGHTS '((MLIST SIMP)))) + ((EQ X '$FEATURES) + (COND ((NOT (EQUAL (CDR $FEATURES) FEATUREL)) + (SETQ $FEATURES (CONS '(MLIST SIMP) (APPEND FEATUREL NIL)))))) + ((EQ X '$ALL) + (MAPC #'KILL1 (CDR $INFOLISTS)) + (SETQ $RATVARS '((MLIST SIMP)) VARLIST NIL GENVAR NIL + CHECKFACTORS NIL GREATORDER NIL LESSORDER NIL $GENSUMNUM 0 + $WEIGHTLEVELS '((MLIST)) *RATWEIGHTS NIL $RATWEIGHTS '((MLIST SIMP)) + TELLRATLIST NIL $DONTFACTOR '((MLIST)) $SETCHECK NIL) + (KILLALLCONTEXTS)) + ((SETQ Z (ASSQ X '(($CLABELS . $INCHAR) ($DLABELS . $OUTCHAR) + ($ELABELS . $LINECHAR)))) + (MAPC #'(LAMBDA (Y) (REMVALUE Y '$KILL)) (GETLABELS* (EVAL (CDR Z)) NIL))) + ((AND (EQ (TYPEP X) 'FIXNUM) (NOT (< X 0))) (REMLABELS X)) + ((ATOM X) + (SETQ Z (OR (AND (MEMQ X (CDR $ALIASES)) (GET X 'NOUN)) (GET X 'VERB))) + (COND ((OR (NULL ALLBUTL) (NOT (MEMQ Z ALLBUTL))) + (REMVALUE X '$KILL) (REMCOMPARY X) + (IF (MEMQ X (CDR $CONTEXTS)) (KILLCONTEXT X)) + (IF (MGET X '$RULE) + (LET ((Y (RULEOF X))) + (COND (Y ($REMRULE Y X)) + (T #+MACLISP (REMPROP X 'EXPR) + #-MACLISP (FMAKUNBOUND X) + (DELQ X $RULES 1))))) + (IF (AND (GET X 'OPERATORS) (RULECHK X)) ($REMRULE X '$ALL)) + (IF (MGET X 'TRACE) (MACSYMA-UNTRACE X)) + (WHEN (GET X 'TRANSLATED) + (REMOVE-TRANSL-FUN-PROPS X) + (REMOVE-TRANSL-ARRAY-FUN-PROPS X)) + (IF (NOT (GET X 'SYSCONST)) (REMPROP X 'MPROPS)) + (DOLIST (U '(BINDTEST NONARRAY EVFUN EVFLAG OPERS SPECIAL MODE)) + (REMPROP X U)) + (DOLIST (U OPERS) + (IF (AND (REMPROP X U) + (EQ (GET X 'OPERATORS) 'SIMPARGS1)) + (REMPROP X 'OPERATORS))) + (WHEN (MEMQ X (CDR $PROPS)) + (REMPROP X 'SP2) (REMPROP X 'SP2SUBS) + (KILLFRAME X) + (LET ((Y (STRIPDOLLAR X))) + (REMPROP Y 'ALPHABET) (DELETE (GETCHARN Y 1) ALPHABET 1))) + (LET ((Y (GET X 'OP))) + (IF (AND Y (NOT (MEMQ Y MOPL)) (MEMQ Y (CDR $PROPS))) + (KILL-OPERATOR X))) + (REMALIAS X NIL) (DELQ X $ARRAYS 1) (REMPROPCHK X) + #+MACLISP (ARGS X NIL) + (DELETE (ASSOC (NCONS X) $FUNCTIONS) $FUNCTIONS 1) + (DELETE (ASSOC (NCONS X) $MACROS) $MACROS 1) + (LET ((Y (ASSOC (NCONS X) $GRADEFS))) + (WHEN Y (REMPROP X 'GRAD) (DELETE Y $GRADEFS 1))) + (DELETE (ASSOC (NCONS X) $DEPENDENCIES) $DEPENDENCIES 1) + (IF Z (KILL1 Z))))) + ((AND (EQ (CAAR X) 'MLIST) (EQ (TYPEP (CADR X)) 'FIXNUM) + (OR (AND (NULL (CDDR X)) (SETQ X (APPEND X (NCONS (CADR X))))) + (AND (EQ (TYPEP (CADDR X)) 'FIXNUM) (NOT (> (CADR X) (CADDR X)))))) + (LET (($LINENUM (CADDR X))) (REMLABELS (- (CADDR X) (CADR X))))) + ((SETQ Z (MGETL (CAAR X) '(HASHAR ARRAY))) (REMARRELEM Z X)) + ((AND (EQ (CAAR X) '$ALLBUT) + (NOT (DOLIST (U (CDR X)) (IF (NOT (SYMBOLP U)) (RETURN T))))) + (LET ((ALLBUTL (CDR X))) (KILL1 '$ALL))) + (T (IMPROPER-ARG-ERR X '$KILL)))) + NIL)) + +(DEFMFUN REMLABELS (N) + (PROG (L X) + (SETQ L (LIST (EXPLODEN $INCHAR) (EXPLODEN $OUTCHAR) (EXPLODEN $LINECHAR))) + LOOP (SETQ X (MEXPLODEN $LINENUM)) + (DO L L (CDR L) (NULL L) (REMVALUE (IMPLODE (APPEND (CAR L) X)) '$KILL)) + (IF (OR (MINUSP (SETQ N (1- N))) (= $LINENUM 0)) (RETURN NIL)) + (SETQ $LINENUM (1- $LINENUM)) + (GO LOOP))) + +(DEFMFUN REMVALUE (X FN) + (COND ((NOT (SYMBOLP X)) (IMPROPER-ARG-ERR X FN)) + ((BOUNDP X) + (LET (Y) + (COND ((OR (SETQ Y (MEMQ X (CDR $VALUES))) (MEMQ X (CDR $LABELS))) + (COND (Y (DELQ X $VALUES 1)) + (T (DELQ X $LABELS 1) + (REMPROP X 'TIME) (REMPROP X 'NODISP) + (IF (NOT (ZEROP DCOUNT)) (SETQ DCOUNT (1- DCOUNT))))) + (MAKUNBOUND X) T) + ((GET X 'SPECIAL) (MAKUNBOUND X) T) + (TRANSP (SET X X) T) + ((EQ X '$DEFAULT_LET_RULE_PACKAGE) T) + (T (MTELL "Warning: Illegal REMVALUE attempt:~%~M" X) NIL)))))) + +(DEFMFUN RULEOF (RULE) + (OR (MGET RULE 'RULEOF) + (LET ((OP (CAAADR (MGET RULE '$RULE))) L) + (AND (SETQ L (GET OP 'RULES)) (MEMQ RULE L) OP)))) + +(DEFMFUN $DEBUGMODE (X) (DEBUGMODE1 NIL X)) + +#-NIL +(DEFUN DEBUGMODE1 (ASSIGN-VAR Y) + ASSIGN-VAR ; ignored + #+MACLISP (SETQ DEBUG (COND (Y (*RSET T) Y) (T (*RSET NIL)))) + #+Franz (prog2 (setq debug y) (debugging y)) + #+LISPM (SETQ DEBUG (SETQ *RSET Y))) + +#-NIL +(DEFMFUN ERRBREAK (Y) ; The ERRSET interrupt function + (COND + (DEBUG + ((LAMBDA (BRKLVL VARLIST GENVAR ERRBRKL LINELABLE) + (PROG (X ^Q #.TTYOFF O^R #+MACLISP ERRSET #+LISPM ERROR-CALL TIM $%% + #+Franz errset + $BACKTRACE #+LISPM RETVAL OLDST) + (SETQ #+(or Franz MACLISP) ERRSET #+LISPM ERROR-CALL 'ERRBREAK1) + (SETQ TIM (RUNTIME) $%% '$%% + $BACKTRACE (CONS '(MLIST SIMP) BAKTRCL)) + (SETQ O^R #.WRITEFILEP #.WRITEFILEP (AND #.WRITEFILEP (NOT DSKFNP))) + (MTERPRI) + (IF Y (PRINC 'MACSYMA-BREAK) (PRINC 'ERROR-BREAK)) + (UNLESS (ZEROP BRKLVL) (PRINC " level ") (PRINC BRKLVL)) + (PRINC ^AMSG) + (MTERPRI) + A (COND + ((NULL + (*CATCH 'MACSYMA-BREAK + (LET ((STATE-PDL (CONS 'MACSYMA-BREAK STATE-PDL))) + (ERRSET + (COND ((EQ (SETQ X (RETRIEVE1 NIL 'BREAK)) '$EXIT) + (TIMEORG TIM) #+LISPM (SETQ RETVAL 'EXIT) (GO END)) + ((EQ X '$LISP) +#+MACLISP (LET ((STATE-PDL (CONS 'LISP-BREAK STATE-PDL))) + (*BREAK T 'LISP) (MTERPRI)) ; ^B also works +#+LISPM (SETQ RETVAL 'LISP) +#+LISPM (GO END)) + ((EQ X '$TOPLEVEL) + (COND ((*CATCH 'MBREAK + (LET (ST OLDST REPHRASE + (MBREAK (CONS BINDLIST LOCLIST))) + (SETQ $LINENUM (1+ $LINENUM)) + (CONTINUE))) + (GO END)) + (T (MTELL-OPEN "Back to the break~%")))) + (T (LET (($DISPFLAG DISPFLAG)) (SETQ $%% (MEVAL X))) + (IF DISPFLAG (DISPLA $%%) (MTERPRI)))))))) + (ERRLFUN1 ERRBRKL) + (MTELL-OPEN "~%(Still in break loop)~%"))) + (GO A) + END (PRINC "Exited from the break ") + (IF (NOT (ZEROP BRKLVL)) (PRINC BRKLVL)) + (MTERPRI) + (IF O^R (SETQ #.WRITEFILEP T)) +#+(or Franz MACLISP) (RETURN NIL) #+LISPM (RETURN RETVAL))) + (1+ BRKLVL) VARLIST GENVAR (CONS BINDLIST LOCLIST) LINELABLE)))) + +#-NIL +(DEFUN ERRBREAK1 (IGNORE) IGNORE NIL) ; Used to nullify ERRSETBREAKs + +#-NIL +(DEFUN ERRBREAK2 (IGNORE) + ; An alternate ERRSET interr. function; used by PARSE and DISPLAY + IGNORE ; ignored + (LET ((STATE-PDL (CONS 'LISP-BREAK STATE-PDL))) (*BREAK ERRBRKSW 'ERST))) + +#-MAXII +(DEFUN MERRBREAK (X) ; The ^A interrupt function + (COND ((NOT (MEMQ 'EDIT STATE-PDL)) + (LET ((DEBUG T) + (STATE-PDL (CONS '^A-BREAK STATE-PDL)) + #-Multics (MOREMSG "--Pause--")) + #+PDP10 (ENDPAGEFN T 'MORE-FUN) + #+PDP10 (IF (NULL X) (BUFFCLEAR NIL)) + (IF (OR (NULL X) $SHOWTIME) (TIMESOFAR T)) + #+MACLISP (NOINTERRUPT NIL) + (ERRBREAK T)) + #+PDP10 (TTYRETFUN T)) + (T (MTELL "~%Control-A does not work while editing~%")))) + +#-LISPM +;; The ^B interrupt function +(DEFUN MPAUSE (X) + X ;Ignored + (LET ((STATE-PDL (LIST* 'LISP-BREAK '^B-BREAK STATE-PDL)) + (MOREMSG "--Pause--")) + #+PDP10 (ENDPAGEFN T 'MORE-FUN) + #+PDP10 (BUFFCLEAR NIL) + (TIMESOFAR T) + #+MACLISP (NOINTERRUPT NIL) + (*BREAK T ^BMSG)) + #+PDP10 (TTYRETFUN T)) + +#+PDP10 +(DEFUN BUFFCLEAR (FLAG) + (COND (SMART-TTY (CLEAR-INPUT T) (IF FLAG (CLEAR-OUTPUT T))) + (T (IF FLAG (CLEAR-OUTPUT T)) (CLEAR-INPUT T)))) + +#+(or Franz MACLISP) +(DEFUN TIMESOFAR (X) ; The ^] interrupt function + (LET ((#.TTYOFF (AND (EQUAL X 1) #.TTYOFF)) + (#.WRITEFILEP (AND #.WRITEFILEP (NOT DSKFNP)))) + (COND ((= THISTIME -1) (MTELL-OPEN "~%Computing the display now")) + ((NOT (ZEROP THISTIME)) + (LET ((BASE 10.) (N 0)) + (MTELL-OPEN "~%~A msec." (COMPUTIME (RUNTIME) THISTIME)) + (IF (AND (EQ $SHOWTIME '$ALL) + (NOT (ZEROP GCT)) + (NOT (ZEROP (SETQ N (COMPUTIME (SYS-GCTIME) GCT))))) + (MTELL-OPEN " (~A msec.)" N)) + (IF USER-TIMESOFAR (MAPC #'FUNCALL (REVERSE USER-TIMESOFAR)))))) + (IF (NULL X) (MTERPRI)))) + +#+MACLISP +(DEFUN MQUIT (X) ; The ^G interrupt function + (IF (NULL X) (BUFFCLEAR T)) + (ERRLFUN 'MQUIT) (SETQ ERRLIST '((SUPUNBIND) (CONTINUE))) (^G)) + +#+PDP10 +;; The ^S interrupt function +(DEFUN MQUIET (X Y) + X Y ;Ignored. + (CLEAR-OUTPUT T) (SETQ #.TTYOFF T ^S T)) + +(DEFMSPEC $TOBREAK (X) + (IF MBREAK (*THROW 'MBREAK (CDR X)) + (MERROR "TOBREAK may be used only within a MACSYMA break."))) + +(DEFUN ERRLFUN (X) + (WHEN (NULL + (ERRSET + (PROGN #-LISPM (SETQ ^S NIL) + #+PDP10 (CLOSE SAVEFILE) + #-LISPM (IF LOADF (SETQ DEFAULTF LOADF LOADF NIL)) + #+PDP10 (ENDPAGEFN T 'MORE-FUN)))) + #-LISPM (SETQ ^Q NIL) (MTELL-OPEN "~%ERRLFUN has been clobbered.")) + (IF $ERRORFUN (IF (NULL (ERRSET (MAPPLY $ERRORFUN NIL $ERRORFUN))) + (MTELL "~%Incorrect ERRORFUN"))) + (WHEN (NULL + (ERRSET + (PROGN (IF (NOT (EQ X 'MQUIT)) (SUPUNBIND)) (CLEARSIGN)))) + #-LISPM (SETQ ^Q NIL) (MTELL-OPEN "~%ERRLFUN has been clobbered.")) + (WHEN (NULL X) (PRINC QUITMSG) (SETQ QUITMSG " "))) + +(DEFUN SUPUNBIND NIL + (MUNBIND (REVERSE BINDLIST)) (DO NIL ((NULL LOCLIST)) (MUNLOCAL))) + +(DEFUN ERRLFUN1 (MPDLS) + (DO ((L BINDLIST (CDR L)) (L1)) ((EQ L (CAR MPDLS)) (MUNBIND L1)) + (SETQ L1 (CONS (CAR L) L1))) + (DO NIL ((EQ LOCLIST (CDR MPDLS))) (MUNLOCAL))) + +(DEFUN GETALIAS (X) (COND ((GET X 'ALIAS)) ((EQ X '$FALSE) NIL) (T X))) + +(DEFUN MAKEALIAS (X) (IMPLODE (CONS #/$ (EXPLODEN X)))) + +#-MAXII +(PROGN 'COMPILE + +(DEFUN PARSE1 NIL + (LET (RET (TIM 0)) + #+GC (IF (EQ GCFLAG '$ALL) (LET (^D) (GC))) + (SETQ TIM (RUNTIME) RET (PARSE2)) + (IF $PARSETIME (MTELL-OPEN "~%Parsetime= ~A msec." (COMPUTIME (RUNTIME) TIM))) + RET)) + +(DEFUN PARSE2 NIL + (LET ((ERRSET #+(OR Franz MACLISP) 'ERRBREAK2 #+LISPM NIL)) + (ERRSET (PARSE3 (SCAN (REVERSE (CONS #/; ST)))) #+LISPM NIL))) + +(DEFUN PARSE3 (STRING) + (LET ((LINELABLE LINELABLE) (ST1 STRING)) (PARSE '$ANY 0))) + +(DEFUN SCAN (INPUT) + (PROG (ANS TOKEN CHAR X DOTP FLAG) + B (COND ((NULL INPUT) (COND ((NOT (EQ (CAR ANS) '$/;)) + (MERROR "~%Dangling /\"))) + (RETURN (NREVERSE ANS))) + ((ASCII-NUMBERP (CAR INPUT)) (SETQ DOTP NIL) (GO NLOOP)) + ((AND (= (CAR INPUT) #/.) (ASCII-NUMBERP (CADR INPUT))) + (SETQ DOTP T) (GO NLOOP)) + ((= (CAR INPUT) #/") (GO DQUOT)) + ((MEMBER (CAR INPUT) '(#\SP #\CR #\newline #\TAB)) (GO C)) + ((ALPHABETP (CAR INPUT)) (GO VLOOP)) + ((= (CAR INPUT) #/\) + (COND ((NOT (ALPHABETP (CADR INPUT))) (SETQ FLAG '/\))) (GO V\)) + ((= (CAR INPUT) #/?) + (SETQ FLAG '?) + (COND ((= (CADR INPUT) #/") (SETQ INPUT (CDR INPUT)) (GO DQUOT)) + ((= (CADR INPUT) #/\) + (SETQ TOKEN (CONS '// TOKEN)) (SETQ INPUT (CDR INPUT)))) + (COND ((NULL (CDDR INPUT)) (MERROR "~%Misuse of ?"))) + (GO V\))) + (SETQ CHAR (ASCII (CAR INPUT))) + (COND ((AND (SETQ X (GET CHAR 'OP3C)) + (SETQ X (ASSOC (LIST (CADR INPUT) (CADDR INPUT)) X))) + (SETQ ANS (CONS (CDR X) ANS) INPUT (CDDDR INPUT)) (GO B)) + ((AND (SETQ X (GET CHAR 'OP2C)) (SETQ X (ASSQ (CADR INPUT) X))) + (SETQ ANS (CONS (CDR X) ANS) INPUT (CDDR INPUT)) (GO B))) + (SETQ ANS (CONS (OR (GET CHAR 'OPALIAS) + (IMPLODE (LIST '$ (CAR INPUT)))) + ANS)) + C (SETQ INPUT (CDR INPUT)) + (GO B) + V\ (SETQ INPUT (CDR INPUT)) + (SETQ TOKEN (CONS (CAR INPUT) TOKEN) INPUT (CDR INPUT)) + (GO VL1) + VLOOP(SETQ TOKEN (CONS (CASIFY (CAR INPUT)) TOKEN) INPUT (CDR INPUT)) + VL1 (COND ((NULL INPUT) (MERROR "~%Dangling /\")) + ((OR (ASCII-NUMBERP (CAR INPUT)) (ALPHABETP (CAR INPUT))) + (GO VLOOP)) + ((= (CAR INPUT) #/\) + (COND ((EQ FLAG '?) (SETQ TOKEN (CONS '// TOKEN)))) (GO V\))) + (SETQ ANS (CONS (COND (FLAG (PROG2 NIL + (COND ((EQ FLAG '/\) + (IMPLODE (CONS '& (NREVERSE TOKEN)))) + ((NULL (SETQ TOKEN (ERRSET + (READLIST + (NREVERSE TOKEN)) + NIL))) + (MERROR "~%Misuse of ?")) + (T (CAR TOKEN))) + (SETQ FLAG NIL))) + (T (GETALIAS (IMPLODE (CONS '$ (NREVERSE TOKEN)))))) + ; note that only $-ed tokens are GETALIASed. + ANS) + TOKEN NIL) + (GO B) + NLOOP(SETQ TOKEN (CONS (CASIFY (CAR INPUT)) TOKEN) INPUT (CDR INPUT)) + (COND ((OR (ASCII-NUMBERP (CAR INPUT)) + (AND (= (CAR INPUT) #/.) (NOT DOTP) (SETQ DOTP T))) + (GO NLOOP)) + ((AND (= (CAR TOKEN) #/.) (SETQ TOKEN (CONS '/0 TOKEN)) NIL)) + ((AND (MEMBER (CAR INPUT) '(#/E #/B #/e #/b)) DOTP (NULL FLAG) + (OR (AND (OR (= (CADR INPUT) #/+) (= (CADR INPUT) #/-)) + (ASCII-NUMBERP (CADDR INPUT))) + (ASCII-NUMBERP (CADR INPUT)))) + (SETQ TOKEN (CONS (CASIFY (CAR INPUT)) TOKEN) + FLAG (CASIFY (CAR INPUT)) + INPUT (CDR INPUT)) + (GO NLOOP))) + (SETQ ANS (CONS (COND ((MEMBER FLAG '(#/B #/b)) (SCANBF TOKEN)) + (T (READLIST (NREVERSE TOKEN)))) + ANS) + TOKEN NIL FLAG NIL) + (GO B) + DQUOT(SETQ INPUT (CDR INPUT)) + (COND ((NULL INPUT) (MERROR "~%/" must occur in pairs.")) + ((= (CAR INPUT) #/\) (SETQ INPUT (CDR INPUT))) + ((= (CAR INPUT) #/") + (SETQ INPUT (CDR INPUT) + ANS (CONS (IMPLODE + (COND (FLAG (SETQ FLAG NIL) (NREVERSE TOKEN)) + (T (CONS '& (NREVERSE TOKEN))))) + ANS) + TOKEN NIL) + (GO B))) + (SETQ TOKEN (CONS (CAR INPUT) TOKEN)) + (GO DQUOT))) + +#+PDP10 +(DEFUN CASIFY (N) ; lower case to upper case + (IF (AND (>= N #/a) (<= N #/z) CASEP) (- N #.(- #/a #/A)) N)) + +#+(or Franz Multics) +(DEFUN CASIFY (N) ; upper case to lower case + (IF (AND (>= N #/A) (<= N #/Z) CASEP) (+ N #.(- #/a #/A)) N)) + +#+LISPM +(DEFUN CASIFY (N) + (IF (OR CASEP (NOT (ZEROP (LDB %%KBD-CONTROL-META N)))) (CHAR-UPCASE N) N)) + +(DEFUN SCANBF (TOKEN) + (PROG (FRAC XPT) + (IF (MEMBER (CAR TOKEN) '(#/+ #/-)) (SETQ TOKEN (CONS #/0 TOKEN))) + XPT (SETQ XPT (CONS (CAR TOKEN) XPT) TOKEN (CDR TOKEN)) + (IF (NOT (MEMBER (CAR TOKEN) '(#/B #/b))) (GO XPT)) + (SETQ TOKEN (CDR TOKEN)) + FRAC (SETQ FRAC (CONS (CAR TOKEN) FRAC) TOKEN (CDR TOKEN)) + (IF (NOT (= (CAR TOKEN) #/.)) (GO FRAC)) + (SETQ TOKEN (CDR TOKEN)) + (RETURN (FPSCAN (CONS #/0 (NREVERSE TOKEN)) FRAC XPT)))) + +(DEFUN ASCII-CHK (X) (IF (NUMBERP X) X (GETCHARN X 1))) + +;; END of MOBY #-MAXII PROGN 'COMPILE +) + +;; (DEFMSPEC $F (FORM) (SETQ FORM (FEXPRCHECK FORM)) ...) +;; makes sure that F was called with exactly one argument and +;; returns that argument. + +(DEFMFUN FEXPRCHECK (FORM) + (IF (OR (NULL (CDR FORM)) (CDDR FORM)) + (MERROR "~:M takes just one argument." (CAAR FORM)) + (CADR FORM))) + +(DEFMFUN NONSYMCHK (X FN) + (UNLESS (SYMBOLP X) + (MERROR "The argument to ~:M must be a symbolic name:~%~M" FN X))) + +;(DEFMFUN NONVARCHK (X FN FLAG 2NDP) +; (WHEN (OR (MNUMP X) (INTEGERP X) (AND FLAG (ATOM X) (CONSTANT X)) +; (AND (NOT (ATOM X)) (NOT (EQ (CAAR X) 'MQAPPLY)) (MOPP1 (CAAR X)))) +; (MERROR "Non-variable~Margument to ~:M: ~M" +; (IF 2NDP '|& 2nd | '|& |) FN X))) + +(DEFMFUN PRINL (L) (DOLIST (X L) (PRINC X) (TYO #\SP))) + +(DEFMFUN $PRINT N + (IF (= N 0) + '((MLIST SIMP)) + (LET ((L (LISTIFY N))) + (DO L L (CDDR L) (NULL L) (RPLACD L (CONS '| | (CDR L)))) + (DISPLA (SETQ PRINTMSG (CONS '(MTEXT) L))) + (CADR (REVERSE L))))) + +#-MAXII +(DEFMFUN $READ N + (LET (PRINTMSG) + (IF (> N 0) (APPLY #'$PRINT (LISTIFY N))) + (MEVAL (RETRIEVE PRINTMSG 'NOPRINT)))) + +#-MAXII +(DEFMFUN $READONLY N + (LET (PRINTMSG) + (IF (> N 0) (APPLY #'$PRINT (LISTIFY N))) (RETRIEVE PRINTMSG 'NOPRINT))) + +#-MAXII +(DEFUN RETR-PRINT (MSG FLAG) + (COND ((NULL MSG)) + ((ATOM MSG) (PRINC MSG) (MTERPRI)) + (FLAG (MAPC #'PRINC (CDR MSG)) (MTERPRI)) + (T (DISPLA MSG) (MTERPRI)))) + +#-MAXII +(DEFMFUN RETRIEVE (MSG FLAG) (LET (OLDST) (RETRIEVE1 MSG FLAG))) + +; RETRIEVE1 is also called by ERRBREAK. +; If MRG-PUNT is T, a (MAPC 'PRINC (CDR PROMPTMSG)) is done. +; This is to get around DISPLA bugs re terpri's in atoms +#-MAXII +(DEFUN RETRIEVE1 (MSG MRG-PUNT) + (COND ((NOT (EQ MRG-PUNT 'NOPRINT)) (RETR-PRINT MSG MRG-PUNT))) + (LET ((PROMPTMSG MSG) (STATE-PDL (CONS 'RETRIEVE STATE-PDL))) + (PROG (TEST N ST REPRINT POS #.TTYOFF) + A (IF (EQ MRG-PUNT 'BREAK) (PRINC (STRIPDOLLAR $PROMPT))) + #-Franz (SETQ POS (CURSORPOS)) + #-Franz (IF (NOT (ZEROP (LISTEN))) (SETQ REPRINT T)) + B (SETQ N (LET ((READING T)) (TYI))) + C (COND ((= N #.NALT) + (WHEN (EDIT* (REVERSE ST)) (SETQ REPRINT T) (MTERPRI) (GO A)) + (GO VT)) + ((= N #/?) + (WHEN (AND ST (= (CAR ST) #/?) + (NOT (AND (CDR ST) (= (CADR ST) #/\)))) + (SETQ ST NIL) (MTERPRI) (GO A))) + ((= N #\VT) (GO VT)) + ((= N #\BS) (COND (BACKRUB (IF ST (POP ST)) (GO B)) + (T (LET (#.WRITEFILEP) (PRINC ^HMSG)) (GO VT)))) + ((= N #\FF) (FORMFEED) (GO FF)) + (#+(or Franz MACLISP) (= N #^Y) + #+LISPM (AND (NOT (ZEROP (LDB %%KBD-CONTROL N))) (= N #^Y)) + (SETQ ST (APPEND OLDST ST)) (GO VT)) + ((OR (= N #\SP) (= N #\CR) (= N #\TAB)) + (WHEN (NULL ST) (IF (= N #\CR) (SETQ POS (CURSORPOS))) (GO B))) + ((< N 32.) (SETQ REPRINT T) (GO B)) ; Test for control characters + ((OR (= N #/;) (= N #/$)) + (IF (EQ MRG-PUNT 'BREAK) (SETQ DISPFLAG (= N #/;))) (GO D)) + ((AND (= N #/\) (PROG2 (SETQ ST (CONS N ST) N (TYI)) NIL))) + ((= N #\RUBOUT) (RUBOUT* ST) (IF ST (POP ST)) (GO B))) + (PUSH N ST) + (GO B) + FF (LET (#.TTYOFF #.WRITEFILEP) (RETR-PRINT MSG (EQ MRG-PUNT T))) + VT (REPRINT ST (= N #\FF)) + (GO B) + D (SETQ REPRINT NIL) + (COND ((NULL ST) (MTERPRI) (GO A)) + (#.WRITEFILEP + (LET ((#.TTYOFF T)) + (PRINC (MAKNAM (REVERSE (CONS N ST)))) + #+Franz (terpr)))) + (SETQ OLDST ST) + (WHEN (SETQ TEST (PARSE2)) + (IF (NULL ^Q) (MTERPRI)) (RETURN (CAR TEST))) + (MTERPRI) + (IF (EQ MRG-PUNT 'BREAK) (PRINC (STRIPDOLLAR $PROMPT))) + #-Franz (SETQ POS (CURSORPOS)) + #-Franz (IF (NOT (ZEROP (LISTEN))) (SETQ REPRINT T)) + (SETQ N (LET ((READING T)) (TYI))) + (COND (#+(or Franz MACLISP) (= N #^Y) + #+LISPM (AND (NOT (ZEROP (LDB %%KBD-CONTROL N))) (= N #^Y)) + (GO VT)) + ((NOT (= N #.NALT)) (SETQ ST NIL))) + (GO C)))) + +(DEFMSPEC $PLAYBACK (X) (SETQ X (CDR X)) + (LET ((STATE-PDL (CONS 'PLAYBACK STATE-PDL))) + (PROG (L L1 L2 NUMBP SLOWP NOSTRINGP INPUTP TIMEP GRINDP INCHAR LARGP) + (SETQ INCHAR (GETLABCHARN $INCHAR)) + ; Only the 1st alphabetic char. of $INCHAR is tested + (SETQ TIMEP $SHOWTIME GRINDP $GRIND) + (DO X X (CDR X) (NULL X) + (COND ((EQ (TYPEP (CAR X)) 'FIXNUM) (SETQ NUMBP (CAR X))) + ((EQ (CAR X) '$ALL)) + ((EQ (CAR X) '$SLOW) (SETQ SLOWP T)) + ((EQ (CAR X) '$NOSTRING) (SETQ NOSTRINGP T)) + ((EQ (CAR X) '$GRIND) (SETQ GRINDP T)) + ((EQ (CAR X) '$INPUT) (SETQ INPUTP T)) + ((MEMQ (CAR X) '($SHOWTIME $TIME)) (SETQ TIMEP (OR TIMEP T))) + ((MEMQ (CAR X) '($GCTIME $TOTALTIME)) (SETQ TIMEP '$ALL)) + ((SETQ L2 (LISTARGP (CAR X))) + (SETQ L1 (NCONC L1 (GETLABELS (CAR L2) (CDR L2) NIL)) LARGP T)) + (T (IMPROPER-ARG-ERR (CAR X) '$PLAYBACK)))) + (COND ((AND LARGP (NULL NUMBP)) (GO LOOP)) + ((AND (SETQ L (CDR $LABELS)) (NOT $NOLABELS)) (SETQ L (CDR L)))) + (WHEN (OR (NULL NUMBP) (< (LENGTH L) NUMBP)) + (SETQ L1 (REVERSE L)) (GO LOOP)) + (DO ((I NUMBP (1- I)) (L2)) ((ZEROP I) (SETQ L1 (NCONC L1 L2))) + (SETQ L2 (CONS (CAR L) L2) L (CDR L))) + LOOP (IF (NULL L1) (RETURN '$DONE)) + ((LAMBDA (ERRSET INCHARP) + (ERRSET + (COND ((AND (NOT NOSTRINGP) INCHARP) + (LET ((LINELABLE (CAR L1))) (MTERPRI) (PRINTLABEL)) + (IF GRINDP (MGRIND (MEVAL1 (CAR L1)) NIL) + (MAPC #'TYO (MSTRING (MEVAL1 (CAR L1))))) + (IF (GET (CAR L1) 'NODISP) (PRINC '$) (PRINC '/;)) + (MTERPRI)) + ((OR INCHARP + (PROG2 (WHEN (AND TIMEP (SETQ L (GET (CAR L1) 'TIME))) + (SETQ X (GCTIMEP TIMEP (CDR L))) + (MTELL-OPEN "~A msec." (CAR L)) + #+GC (IF X (MTELL-OPEN " GCtime= ~A msec." (CDR L))) + (MTERPRI)) + (NOT (OR INPUTP (GET (CAR L1) 'NODISP))))) + (MTERPRI) (DISPLA (LIST '(MLABLE) (CAR L1) (MEVAL1 (CAR L1))))) + (T (GO A))))) + 'ERRBREAK2 (= (GETLABCHARN (CAR L1)) INCHAR)) + (IF (AND SLOWP (CDR L1) (NOT (CONTINUEP))) (RETURN '$TERMINATED)) + A (SETQ L1 (CDR L1)) + (GO LOOP)))) + +(DEFUN LISTARGP (X) + (LET (HIGH) + (IF (AND ($LISTP X) (EQ (TYPEP (CADR X)) 'FIXNUM) + (OR (AND (NULL (CDDR X)) (SETQ HIGH (CADR X))) + (AND (EQ (TYPEP (SETQ HIGH (CADDR X))) 'FIXNUM) + (NOT (> (CADR X) HIGH))))) + (CONS (CADR X) HIGH)))) + +;(DEFUN C18BATCHER NIL +; ((LAMBDA (L USER) +; (GCTWA) +; (SETQ ALARMCLOCK '(LAMBDA (X) (*THROW 'TIMECHECK 'TOOMUCHTIME))) +; (ALARMCLOCK 'RUNTIME $C18MAXTIME) +; (COND ((NULL (ERRSET (UREAD BATIN /< DSK C18) NIL)) ($QUIT))) +; (TERPRI) +; (PRINL (APPEND (STATUS UREAD) '(BEGUN))) +; (TERPRI) +; (UWRITE DSK C18) +; (SETQ #.WRITEFILEP T #.TTYOFF T) +; (ERRSET (COND ((EQ (*CATCH 'TIMECHECK ($BATCH BATIN /< DSK C18)) 'TOOMUCHTIME) +; (PRINC '|/ +;you've taken more than the allotted time!|)) +; (T (SETQ $% '$BATCH/ DONE) (MAKELABEL $OUTCHAR) (DISPLAY*)))) +; (APPLY #'UFILE (LIST 'BATOUT (MAKNAM (COND ($FILEID (SETQ L (STRING* $FILEID))) +; (T (NREVERSE (MEXPLODEN (RUNTIME)))))))) +; (UKILL BATIN /< DSK C18) +; (COND ((AND $FILEID (> (LENGTH L) 3)) +; (SETQ USER (LIST (CAR L) (CADR L) (CADDR L))) +; (VALRET (MAKNAM (APPEND (EXPLODEN '/:SEND/ ) USER (EXPLODEN '/ BATOUT/ ) +; L (EXPLODEN '/ IS/ NOW/ AVAILABLE/./ +;// P)))))) +; (COND ((NULL (ERRSET (UREAD BATIN /< DSK C18) NIL)) ($QUIT)) +; (T (VALRET '/:MACSYMA/ +;)))) +; NIL NIL)) + +(DEFMSPEC $ALIAS (FORM) + (IF (ODDP (LENGTH (SETQ FORM (CDR FORM)))) + (MERROR "ALIAS takes an even number of arguments.")) + (DO ((L NIL (CONS (ALIAS (POP FORM) (POP FORM)) + L))) + ((NULL FORM) + `((MLIST SIMP),@(NREVERSE L))))) + +(DEFMFUN ALIAS (X Y) + (COND ((NONSYMCHK X '$ALIAS)) + ((NONSYMCHK Y '$ALIAS)) + ((NOT (EQ (GETCHAR X 1) '$)) + (MERROR "/"-ed symbols may not be aliased. ~M" X)) + ((GET X 'REVERSEALIAS) + (IF (NOT (EQ X Y)) + (MERROR "~M already is aliased." X))) + (T (PUTPROP X Y'ALIAS) + (PUTPROP Y (STRIPDOLLAR X) 'REVERSEALIAS) + (ADD2LNC Y $ALIASES) + Y))) + +(DEFMFUN REMALIAS (X REMP) + (LET ((Y (AND (OR REMP (MEMQ X (CDR $ALIASES))) (GET X 'REVERSEALIAS)))) + (COND ((AND Y (EQ X '%DERIVATIVE)) + (REMPROP X 'REVERSEALIAS) (DELQ X $ALIASES 1) + (REMPROP '$DIFF 'ALIAS) '$DIFF) + (Y (REMPROP X 'REVERSEALIAS) (REMPROP X 'NOUN) (DELQ X $ALIASES 1) + (REMPROP (SETQ X (MAKEALIAS Y)) 'ALIAS) (REMPROP X 'VERB) X)))) + +(DEFMFUN STRIPDOLLAR (X) + (COND ((NOT (ATOM X)) + (COND ((AND (EQ (CAAR X) 'BIGFLOAT) (NOT (MINUSP (CADR X)))) (IMPLODE (FPFORMAT X))) + (T (MERROR "Atomic arg required:~%~M" X)))) + ((NUMBERP X) X) + ((NULL X) 'FALSE) + ((EQ X T) 'TRUE) + ((MEMQ (GETCHAR X 1) '($ % &)) #-Franz (IMPLODE (CDR (EXPLODEN X))) + #+Franz (concat (substring x 2))) + (T X))) + +(DEFMFUN FULLSTRIP (X) (MAPCAR #'FULLSTRIP1 X)) + +(DEFMFUN FULLSTRIP1 (X) + (OR (AND (NUMBERP X) X) + (GET X 'REVERSEALIAS) + (LET ((U (ASSQR X ALIASLIST))) (IF U (IMPLODE (STRING*1 (CAR U))))) + (STRIPDOLLAR X))) + +(DEFUN STRING* (X) + (OR (AND (NUMBERP X) (EXPLODEN X)) + (LET ((U (ASSQR X ALIASLIST))) (IF U (STRING*1 (CAR U)))) + (STRING*1 X))) + +(DEFUN STRING*1 (X) (LET (STRINGDISP $LISPDISP) (MAKESTRING X))) + +(DEFUN MAKSTRING* (X) + (SETQ X (STRING* X)) + (DO L X (CDR L) (NULL L) (RPLACA L (ASCII (CAR L)))) + X) + +(DEFMFUN $NOUNIFY (X) + (LET (Y U) + (NONSYMCHK X '$NOUNIFY) + (SETQ X (AMPERCHK X)) + (COND ((GET X 'VERB)) + ((GET X 'NOUN) X) + ((OR (SETQ U (MEMQ (CAR (SETQ Y (EXPLODEC X))) '($ M))) + (NOT (EQ (CAR Y) '%))) + (SETQ Y (IMPLODE (CONS '% (IF U (CDR Y) Y)))) + (PUTPROP Y X 'NOUN) (PUTPROP X Y 'VERB)) + (T X)))) + +(DEFMFUN $VERBIFY (X) + (NONSYMCHK X '$VERBIFY) + (SETQ X (AMPERCHK X)) + (COND ((GET X 'NOUN)) + ((AND (= (GETCHARN X 1) #/%) + (PROG2 ($NOUNIFY (IMPLODE (CONS #/$ (CDR (EXPLODEN X))))) (GET X 'NOUN)))) + (T X))) + +(DEFMFUN AMPERCHK (NAME) + (IF (= (GETCHARN NAME 1) #/&) + (OR (GET NAME 'OPR) (IMPLODE (CONS #/$ (CASIFY-EXPLODEN NAME)))) + NAME)) + +(DEFMFUN DOLLARIFY-NAME (NAME) + (LET ((N (GETCHARN NAME 1))) + (COND ((= N #/&) + (OR (GET NAME 'OPR) + (LET ((NAMEL (CASIFY-EXPLODEN NAME)) AMPNAME DOLNAME) + (COND ((GET (SETQ AMPNAME (IMPLODE (CONS #/& NAMEL))) 'OPR)) + (T (SETQ DOLNAME (IMPLODE (CONS #/$ NAMEL))) + (PUTPROP DOLNAME AMPNAME 'OP) + (PUTPROP AMPNAME DOLNAME 'OPR) + (ADD2LNC AMPNAME $PROPS) + DOLNAME))))) + ((= N #/%) ($VERBIFY NAME)) + (T NAME)))) + +(DEFMFUN $RANDOM N (APPLY #'RANDOM (LISTIFY N))) + +(DEFMSPEC $STRING (FORM) + (SETQ FORM (STRMEVAL (FEXPRCHECK FORM))) + (SETQ FORM (IF $GRIND (STRGRIND FORM) (MSTRING FORM))) + (SETQ ST (REVERSE FORM) REPHRASE T) + (IMPLODE (CONS #/& FORM))) + +(DEFMFUN MAKSTRING (X) + (SETQ X (MSTRING X)) (DO L X (CDR L) (NULL L) (RPLACA L (ASCII (CAR L)))) X) + +(DEFMFUN STRMEVAL (X) + (COND ((ATOM X) (MEVAL1 X)) + ((MEMQ (CAAR X) '(MSETQ MDEFINE MDEFMACRO)) X) + (T (MEVAL X)))) + +(PROG1 '(ALIAS properties) + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ALIAS) + (PUTPROP (CADR X) (CADDR X) 'REVERSEALIAS)) + '(($BLOCK MPROG BLOCK) ($LAMBDA LAMBDA LAMBDA) + ($ABS MABS ABS) ($SUBST $SUBSTITUTE SUBST) + ($GO MGO GO) ($SIGNUM %SIGNUM SIGNUM) + ($RETURN MRETURN RETURN) ($FACTORIAL MFACTORIAL FACTORIAL) + ($NOUUO NOUUO NOUUO) ($RSET *RSET RSET) + ($IBASE IBASE IBASE) ($OBASE BASE OBASE) ($NOPOINT *NOPOINT NOPOINT) + ($MODULUS MODULUS MODULUS) ($ZUNDERFLOW ZUNDERFLOW ZUNDERFLOW) + ($TTYOFF #.TTYOFF TTYOFF) ($WRITEFILE_ON #.WRITEFILEP WRITEFILE_ON) + ($MODE_DECLARE $MODEDECLARE MODE_DECLARE))) + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ALIAS)) + '(($RATCOEFF $RATCOEF) ($RATNUM $RATNUMER) ($TRUE T) + ($BINOM %BINOMIAL) ($DERIVATIVE $DIFF) ($PROD $PRODUCT) + ($BOTHCOEFF $BOTHCOEF)))) + +(DEFMFUN CASIFY-EXPLODEN (X) + (SETQ X (EXPLODEN X)) + (IF (= (CAR X) #/&) (MAPCAR #'CASIFY (CDR X)) (CDR X))) + +(DEFMSPEC $STRINGOUT (X) (SETQ X (CDR X)) + (LET (FILE ERROR L1) + (SETQ FILE #-Franz (IF ($LISTP (CAR X)) + (PROG1 #+MACLISP (FILESTRIP (CDAR X)) + #+LISPM (car (FULLSTRIP (CDAR X))) + (SETQ X (CDR X))) + (MFILE)) + #+Franz (prog1 (filestrip x) (setq x (cdr x)))) + #+PDP10 + (OPEN (CNAMEF SAVEFILE (CONS (CARFILE (CDDR FILE)) '(|!STRG!| OUTPUT))) + '(OUT ASCII)) + #+Multics + (SETQ SAVEFILE (OPEN (CONS (CAR (NAMELIST FILE)) '(|!STRG!| OUTPUT)) '(OUT ASCII))) + #+LISPM + (SETQ SAVEFILE (OPEN file '(OUT ASCII))) + #+Franz + (setq savefile (outfile file)) + (COND ((NULL + (ERRSET + (DO L X (CDR L) (NULL L) + (COND ((MEMQ (CAR L) '($ALL $INPUT)) + (SETQ L (NCONC (GETLABELS* $INCHAR T) (CDR L)))) + ((EQ (CAR L) '$VALUES) + (SETQ L (NCONC (MAPCAN + #'(LAMBDA (X) + (IF (BOUNDP X) + (NCONS (LIST '(MSETQ) X (SYMEVAL X))))) + (CDR $VALUES)) + (CDR L)))) + ((EQ (CAR L) '$FUNCTIONS) + (SETQ L (NCONC (MAPCAR + #'(LAMBDA (X) (CONSFUNDEF (CAAR X) NIL NIL)) + (CDR $FUNCTIONS)) + (MAPCAN + #'(LAMBDA (X) + (IF (MGET X 'AEXPR) + (NCONS (CONSFUNDEF X T NIL)))) + (CDR $ARRAYS)) + (MAPCAR + #'(LAMBDA (X) (CONSFUNDEF (CAAR X) NIL NIL)) + (CDR $MACROS)) + (CDR L)))) + ((SETQ L1 (LISTARGP (CAR L))) + (SETQ L (NCONC (GETLABELS (CAR L1) (CDR L1) T) (CDR L))))) + (IF (NULL L) (RETURN NIL)) + (TERPRI SAVEFILE) + (IF $GRIND (MGRIND (STRMEVAL (CAR L)) SAVEFILE) + #-Franz (PRINC (MAKNAM (MSTRING (STRMEVAL (CAR L)))) + SAVEFILE) + #+Franz (mapc #'(lambda (ch) (tyo ch savefile)) + (mstring (strmeval (car l))))) + (IF (OR (AND (ATOM (CAR L)) (GET (CAR L) 'NODISP)) (NOT $STRDISP)) + (TYO #/$ SAVEFILE) + (TYO #/; SAVEFILE))))) + (SETQ ERROR T))) + (TERPRI SAVEFILE) + #-(or Franz LispM) (RENAMEF SAVEFILE FILE) + #+(OR Franz Multics LispM) (CLOSE SAVEFILE) + #+MacLisp (SYS-DEFAULTF FILE) + (IF ERROR (LET ((ERRSET 'ERRBREAK1)) (MERROR "Error in STRINGOUT attempt"))) + #+PDP10 (MTRUENAME SAVEFILE) + #+(or Franz LISPM) (MFILE-OUT FILE) + #+Multics FILE)) + +;; Obsolete. FPPREC:10 is the replacement. + +#+PDP10 (PROGN 'COMPILE + (DEFMFUN $FPPREC (X) (FPPREC1 NIL X)) + (DEFMFUN $POISLIM (X) (POISLIM1 NIL X))) + +(DEFMSPEC $LABELS (CHAR) + (SETQ CHAR (FEXPRCHECK CHAR)) + (NONSYMCHK CHAR '$LABELS) + (CONS '(MLIST SIMP) (NREVERSE (GETLABELS* CHAR NIL)))) + +(DEFMFUN $%TH (X) + (PROG (L OUTCHAR) + (IF (OR (NOT (EQ (TYPEP X) 'FIXNUM)) (= X 0)) + (IMPROPER-ARG-ERR X '$%TH)) + (IF (> X 0) (SETQ X (- X))) + (IF (CDR $LABELS) + (SETQ L (CDDR $LABELS) OUTCHAR (GETLABCHARN $OUTCHAR))) + LOOP (IF (NULL L) (MERROR "Improper call to %TH")) + (IF (AND (= (GETLABCHARN (CAR L)) OUTCHAR) (= (SETQ X (1+ X)) 0)) + ; Only the 1st alphabetic character of $OUTCHAR is tested. + (RETURN (MEVAL (CAR L)))) + (SETQ L (CDR L)) + (GO LOOP))) + +(DEFMFUN GETLABELS (N1 N2 FLAG) ; FLAG = T for STRINGOUT, = NIL for PLAYBACK and SAVE. + (DO ((I N1 (1+ I)) (L1) + (L (IF FLAG (LIST (EXPLODEN $INCHAR)) + (LIST (EXPLODEN $INCHAR) (EXPLODEN $LINECHAR) + (EXPLODEN $OUTCHAR))))) + ((> I N2) (NREVERSE L1)) + (DO ((L L (CDR L)) (X (MEXPLODEN I)) (Z)) ((NULL L)) + (IF (BOUNDP (SETQ Z (IMPLODE (APPEND (CAR L) X)))) + (SETQ L1 (CONS Z L1)))))) + +(DEFMFUN GETLABELS* (CHAR FLAG) ; FLAG = T only for STRINGOUT + (DO ((L (IF FLAG (CDDR $LABELS) (CDR $LABELS)) (CDR L)) + (CHAR (GETLABCHARN CHAR)) (L1)) + ((NULL L) L1) + (IF (= (GETLABCHARN (CAR L)) CHAR) + ; Only the 1st alphabetic character is tested. + (SETQ L1 (CONS (CAR L) L1))))) + +(DEFMFUN GETLABCHARN (LABEL) + (LET ((CHAR (GETCHARN LABEL 2))) (IF (= CHAR #/%) (GETCHARN LABEL 3) CHAR))) + +#+MACLISP +(DEFMFUN $UUO NIL (SSTATUS UUOLINKS)) + +#+MULTICS +(DEFMFUN $CLINE (X) (CLINE (GET_PNAME (STRIPDOLLAR X))) '$DONE) + +; Error-handling stuff, not converted for lisp-machine yet. + +(DEFMSPEC $ERRCATCH (FORM) + (LET ((ERRCATCH (CONS BINDLIST LOCLIST)) RET) + (IF (NULL (SETQ RET (LET (DEBUG) + (ERRSET (MEVALN (CDR FORM)) LISPERRPRINT)))) + (ERRLFUN1 ERRCATCH)) + (CONS '(MLIST) RET))) + +;(DEFMFUN $ERROR N ; Moved to MAXSRC;MERROR +; (LET ((MSG (LISTIFY N))) +; (IF (> N 0) (APPLY #'$PRINT MSG)) +; (IF ERRCATCH (ERROR)) +; (IF DEBUG (LET (($ERROR (CONS '(MLIST SIMP) (FSTRINGC MSG)))) +; (ERRBREAK NIL))) +; (MQUIT T))) + +#-MAXII +(DEFMFUN $BREAK N (PROG1 (APPLY #'$PRINT (LISTIFY N)) (MERRBREAK T))) + +(DEFMSPEC $CATCH (FORM) + (LET ((MCATCH (CONS BINDLIST LOCLIST))) + (PROG1 (*CATCH 'MCATCH (MEVALN (CDR FORM))) (ERRLFUN1 MCATCH)))) + +(DEFMFUN $THROW (EXP) + (IF (NULL MCATCH) (MERROR "THROW not within CATCH:~%~M" EXP)) + (*THROW 'MCATCH EXP)) + +(DEFMSPEC $TIME (L) (SETQ L (CDR L)) + (MTELL-OPEN "TIME or [TOTALTIME, GCTIME] in msecs.:~%") + (CONS '(MLIST SIMP) + (MAPCAR + #'(LAMBDA (X) + (OR (AND (SETQ X (OR (GET X 'TIME) + (AND (EQ X '$%) (CONS (CADR $LASTTIME) + (CADDR $LASTTIME))))) + (IF (= (CDR X) 0) + (CAR X) + (LIST '(MLIST SIMP) (CAR X) (CDR X)))) + '$UNKNOWN)) + L))) + +(DEFMFUN TIMEORG (TIM) + (IF (> THISTIME 0) (SETQ THISTIME (+ THISTIME (- (RUNTIME) TIM))))) + +; Take difference of two times, return result in milliseconds. +#+LISPM (DEFMFUN COMPUTIME (N1 N2) (// (* 50. (TIME-DIFFERENCE N1 N2)) 3.)) + +#+MACLISP +(DEFMFUN COMPUTIME (N1 N2) (// (- (+ N1 500.) N2) 1000.)) + +#+Franz (progn 'compile + +;--- computime (n1,n2) :: compute time difference in milliseconds +; n1,n2 : times in jiffies (1/60 ths of a second) +; return: length of time from n2 to n1 in milliseconds +(defmfun computime (n1 n2) (// (* (- n1 n2) 1000.) 60.)) + +;--- runtime :: return total runtime for this process (in jiffies) +(defun runtime nil (car (ptime))) + +) + +#+PDP10 (PROGN 'COMPILE + +(DEFMFUN $TO_LISP NIL (^G)) + +(DEFMFUN $QUIT NIL (VALRET '//.)) ; this format does a silent kill + +(DEFMFUN $LOGOUT NIL + (IF (STATUS HACTRN) (VALRET '/:LOGOUT/ +) ($QUIT))) + +;;Circlecross does something to the Lisp Machine reader at a very +;;low level. It must be slashified here. + +(DEFMFUN $DDT NIL (VALRET '|:/into DDT: // +|) '$DONE) +) + +#+LISPM (PROGN 'COMPILE +(DEFMFUN $QUIT () (*THROW 'MACSYMA-QUIT NIL)) +(DEFMFUN $LOGOUT () (LOGOUT)) +) + +#+Multics (PROGN 'COMPILE +(DEFMFUN $QUIT () (QUIT)) +(DEFMFUN $LOGOUT () (CLINE "logout")) +(DEFMFUN $DDT () (IOC Z)) +) + +#+PDP10 +(DEFMFUN FILESTRIP (X) + (COND ((NULL X) (APPEND (CDR DEFAULTF) (CAR DEFAULTF))) + ((NULL (CDR (SETQ X (FULLSTRIP X)))) + (SETQ X (MERGEF (CAR X) (CONS (CAR DEFAULTF) + (IF (EQ (STATUS OPSYS) 'ITS) '(* >) + '(* /1))))) + (APPEND (CDR X) (CAR X))) + ((NULL (CDDR X)) (APPEND X (CAR DEFAULTF))) + ((NULL (CDDDR X)) + (IF (NUMBERP (CADDR X)) (MERROR "Bad file specification")) + ; To get around a bug in MERGEF. + (SETQ X (MERGEF X DEFAULTF)) (APPEND (CDR X) (CAR X))) + (T X))) + +#+MULTICS +(DEFMFUN FILESTRIP (X) + (COND ((NULL X) NIL) + ((ATOM X) (FULLSTRIP1 X)) + (T (IF (NULL (CDR (SETQ X (FULLSTRIP X)))) (SETQ X (CAR X))) X))) + + +;--- filestrip +; argument is a list containing the filename, which is a symbol or string. +; +#+Franz +(defmfun filestrip (f) + (cond ((null f) (merror "You must supply a filename~%")) + ((and (dtpr f) + (cond ((or (symbolp (car f)) (stringp (car f))) + (stripdollar (car f)))))) + (t (merror "Illegal filename ~M" f)))) + +(DEFMFUN FILEPRINT (FNAME) ; Takes filename in NAMELIST format. + (COND ($FILE_STRING_PRINT (PRINC (NAMESTRING FNAME)) (PRINC " ")) + (T (PRINC "[") + (PRINC (CADR FNAME)) (PRINC ", ") + (PRINC (CADDR FNAME)) (PRINC ", ") + (WHEN (CDDDR FNAME) (PRINC (CADDDR FNAME)) (PRINC ", ")) ; For TOPS-20 + (PRINC (CAAR FNAME)) (PRINC ", ") + (PRINC (CADAR FNAME)) (PRINC "] ")))) + +(DEFMFUN MFILE-OUT (FNAME) ; Takes filename in NAMELIST or OldIO list format. + (IF $FILE_STRING_PRINT + (IMPLODE (CONS #/& (EXPLODEN (NAMESTRING FNAME)))) + (DOLLARIFY (IF (ATOM (CAR FNAME)) FNAME (APPEND (CDR FNAME) (CAR FNAME)))))) + +; File-processing stuff. Lisp Machine version in MC:LMMAX;LMSUP. + +#+PDP10 +(DEFMSPEC $WRITEFILE (L) (SETQ L (CDR L)) + (IF #.WRITEFILEP (MERROR "File already open for writing.")) + (IF (> (LENGTH L) 2) (WNA-ERR '$WRITEFILE)) + (LET (U) + (SETQ U (IF (AND L (NULL (CDR L)) + (PROG2 (SETQ U (NAMELIST (FULLSTRIP1 (CAR L)))) + (NOT (EQUAL (CAR U) (IF (EQ (STATUS OPSYS) 'ITS) + '(* *) + '(|| ||)))))) + (CAR U) + (FULLSTRIP L))) + (SETQ U (APPLY #'UWRITE U) #.WRITEFILEP T) + (IF $FILE_STRING_PRINT + (IF (EQ (STATUS OPSYS) 'ITS) + (CONCAT '/& (CAR U) '/: (CADR U) '/;) + (CONCAT '/& (CAR U) '/: '< (CADR U) '>)) + (DOLLARIFY U)))) + +#+Franz +(defmspec $writefile (l) + (setq display-to-disk (cadr l)) + (setq ptport (outfile (filestrip (cdr l)))) + display-to-disk) + +#+PDP10 +(DEFMSPEC $APPENDFILE (L) (SETQ L (CDR L)) + (IF #.WRITEFILEP (MERROR "File already open for writing.")) + (APPLY #'UAPPEND (FILESTRIP L)) (SETQ #.WRITEFILEP T) ($FILEDEFAULTS)) + +#+Franz +(DEFMSPEC $APPENDFILE (L) + (setq display-to-disk (cadr l)) + (setq ptport (outfile (filestrip (cdr l)) 'append)) + display-to-disk) + +#+PDP10 +(DEFMSPEC $CLOSEFILE (L) (SETQ L (CDR L)) + (APPLY #'UFILE (IF (NULL L) (MFILE) (FILESTRIP L))) + (IF (AND (= (LENGTH L) 4) + (NOT (EQ (CADAR DEFAULTF) (FULLSTRIP1 (CAR (LAST L)))))) + (MTELL "Warning: Specified CLOSEFILE directory is incorrect.")) + ($FILEDEFAULTS)) + +#+Franz +(DEFMSPEC $closefile (l) (SETQ L (CDR L)) + (close ptport) + (prog1 display-to-disk (setq display-to-disk nil ptport nil))) + +#-Franz +(DEFUN MFILE NIL + (FULLSTRIP (LIST $FILENAME (SETQ $FILENUM (1+ $FILENUM)) $DEVICE $DIREC))) + + +#+MACLISP +(DEFMSPEC $DELFILE (L) (SETQ L (CDR L)) + (PROG2 (SETQ L (SYS-DEFAULTF (FILESTRIP L))) ($FILEDEFAULTS) (DELETEF L))) + +#+MACLISP +(DEFMFUN $FILEDEFAULTS N + (COND ((= N 1) (SYS-DEFAULTF (FILENAMEL (ARG 1)))) + ((> N 1) (WNA-ERR '$FILEDEFAULTS))) + (LET ((FILE (OR (PROBEF DEFAULTF) DEFAULTF))) (MFILE-OUT FILE))) + +;;; The Multics Version of Writefile and Closefile. +;;; Appendfile is not implemented yet. +#+MULTICS (PROGN 'COMPILE +(LOAD-MACSYMA-MACROS SYSTEM_ERROR_HANDLER) + +(DEFMVAR WRITEFILE-IN-PROGRESS () "T if there is a writefile happening") +(DEFMVAR WRITEFILE-^R () "Value of ^R before writefile") +(DEFMVAR WRITEFILE-NAME "" "Full pathname of temporary writefile file") + +(DEFUN MAKE-WRITEFILE-FILENAME (USER-SUPPLIED-NAME) + (LET ((IS-A-DIR (SYSTEM-INTERFACE-ERROR ("Writefile") + (DIRECTORY-OR-FILE USER-SUPPLIED-NAME "")))) + (COND ((NOT (STRING-EQUAL IS-A-DIR "directory")) + (MERROR "Writefile: ~:M is not a directory" USER-SUPPLIED-NAME)))) + (COND ((SYSTEM-INTERFACE-ERROR ("Writefile") + (DIRECTORY-P USER-SUPPLIED-NAME 'APPEND)) + (STRING-APPEND USER-SUPPLIED-NAME ">writefile.output")) + (T (MERROR "Writefile: You have incorrect directory access to ~:M." + USER-SUPPLIED-NAME)))) + +(DEFUN MAKE-CLOSEFILE-FILENAME (TEMPORARY-WRITEFILE-NAME ENTRYNAME + &AUX (DIR-NAME + (DIRECTORY-NAME TEMPORARY-WRITEFILE-NAME))) + (IF (OR (STRING-SEARCH-CHAR #/> ENTRYNAME) + (STRING-SEARCH-CHAR #/< ENTRYNAME)) + (MERROR "Closefile: illegal entryname. ~:M" ENTRYNAME)) + (LET ((PATHNAME (SYSTEM-INTERFACE-ERROR ("Closefile") + (ABSOLUTE-PATHNAME (STRING-APPEND DIR-NAME ">" + ENTRYNAME))))) + PATHNAME)) + +(DEFMSPEC $WRITEFILE (X) (SETQ X (CDR X)) + (IF (NOT (NULL WRITEFILE-IN-PROGRESS)) + (MERROR "Writefile: writefile already in progress.")) + (LET ((USER-SUPPLIED-NAME ())) + (COND ((> (LENGTH X) 1) (WNA-ERR '$WRITEFILE)) + ((= (LENGTH X) 1) (SETQ USER-SUPPLIED-NAME (STRIPDOLLAR (CAR X)))) + (T (SETQ USER-SUPPLIED-NAME (PATHNAME-UTIL "hd")))) + (SETQ WRITEFILE-NAME (MAKE-WRITEFILE-FILENAME USER-SUPPLIED-NAME)) +;;;THE ABOVE EITHER ERRS OUT OR GIVES SOMETHING BACK. + (PUSH (OPEN WRITEFILE-NAME '(OUT ASCII)) OUTFILES) + (SETQ WRITEFILE-^R #.WRITEFILEP) + (SETQ #.WRITEFILEP T) + (SETQ WRITEFILE-IN-PROGRESS T) + `((MLIST) ,(STRING-TO-MSTRING WRITEFILE-NAME)))) + +(DEFMSPEC $CLOSEFILE (ENTRY-NAME) (SETQ ENTRY-NAME (CDR ENTRY-NAME)) + (IF (NOT (EQUAL (LENGTH ENTRY-NAME) 1)) + (WNA-ERR '$CLOSEFILE)) + (SETQ ENTRY-NAME (CAR ENTRY-NAME)) + (COND ((MSTRINGP ENTRY-NAME) + (SETQ ENTRY-NAME (MSTRING-TO-STRING ENTRY-NAME))) + ((SYMBOLP ENTRY-NAME) + (SETQ ENTRY-NAME (STRING (STRIPDOLLAR ENTRY-NAME)))) + (T (MERROR "Closefile: ~:M illegal argument" ENTRY-NAME))) + (LET ((NEW-FILENAME (MAKE-CLOSEFILE-FILENAME WRITEFILE-NAME ENTRY-NAME)) + (OPEN-WRITEFILE (CAR OUTFILES))) + (CLOSE OPEN-WRITEFILE) + (RENAMEF OPEN-WRITEFILE NEW-FILENAME) + (POP OUTFILES) + (SETQ #.WRITEFILEP WRITEFILE-^R) + (SETQ WRITEFILE-^R ()) + (SETQ WRITEFILE-IN-PROGRESS ()) + (SETQ WRITEFILE-NAME ()) + `((MLIST) ,(STRING-TO-MSTRING NEW-FILENAME)))) +) +;;; End of Multics version of WRITEFILE, CLOSEFILE code. + +;; This prevents single blank lines from appearing at the top of video +;; terminals. If at the upper left corner and we want to print a blank +;; line, leave the cursor there and send the blank line to transcript +;; files only. + +#+(OR PDP10 NIL LISPM) +(DEFMFUN MTERPRI (&AUX (X (CURSORPOS))) + (IF (AND SMART-TTY X (EQUAL X '(0 . 0))) + (LET ((#.TTYOFF T)) (TERPRI)) + (TERPRI))) + +#+(or Franz Multics) +(DEFMFUN MTERPRI () (TERPRI)) + +#+PDP10 +(DEFMFUN MORE-FUN (NIL) + (ENDPAGEFN T NIL) + (COND ((NOT (OR (< (CAR (OR (CURSORPOS) '(0 . 0))) 10.) + (= (- TTYHEIGHT 2) (CAR (CURSORPOS))))) + (CURSORPOS 'E) (SLEEP .01))) + (NOINTERRUPT NIL) + (COND ((= 0 (BOOLE 1 1_25. (CADDR (STATUS TTY)))) + (CURSORPOS 'Z) (CURSORPOS '/]) + ((LAMBDA (^Q) + ((LAMBDA (#.WRITEFILEP #.TTYOFF STATE-PDL) + (PRINC MOREMSG) (TYIPEEK) + (IF $MOREWAIT + (DO ((L (IF (EQ $MOREWAIT '$ALL) + '(#\SP #\CR) + '(#\SP #\CR #\RUBOUT)))) + ((MEMBER (TYIPEEK) L)) + (TYI)) + (DO () ((NOT (MEMBER (TYIPEEK) '(#^D #^S #^U #^V #^])))) + (TYI))) + (COND (SMART-TTY (CURSORPOS 'Z) (CURSORPOS '/])) (T (TERPRI)))) + NIL NIL (CONS 'MORE-WAIT STATE-PDL)) + (COND ((= #\SP (TYIPEEK)) + (IF MORECONTINUE (LET (#.WRITEFILEP #.TTYOFF) (PRINC MORECONTINUE))) (TYI)) + ((= #\RUBOUT (TYIPEEK)) + (LET ((#.TTYOFF T)) (TERPRI)) + (IF MOREFLUSH (PRINC MOREFLUSH)) + (TYI) + (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T)) + #.WRITEFILEP (AND #.WRITEFILEP (NULL MOREFLUSH)))) + (T (COND ((OR (MEMQ 'BATCH STATE-PDL) + (AND (< (TYIPEEK) 32.) + (NOT (MEMBER (TYIPEEK) + '(2 7 11. 12. 25. 27. + 28. 29. 30.))))) + (TYI))) + (IF MOREFLUSH (LET (#.WRITEFILEP #.TTYOFF) (PRINC MOREFLUSH))) + (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T)))))) + NIL))) + (IF (AND SMART-TTY (NOT (AND SCROLLP (NOT $CURSORDISP)))) + (COND (RUBOUT-TTY (LET (#.TTYOFF) (CURSORPOS T T) (CURSORPOS '/]))) + (T (SLEEP 0.4) (FORMFEED))) + (LET (#.TTYOFF #.WRITEFILEP) (TERPRI))) + (ENDPAGEFN T 'MORE-FUN)) + +#+PDP10 (ENDPAGEFN T 'MORE-FUN) + +; More processing stuff. +; This isn't the best way to do it on the Lisp machine, +; it's a minimally modified version of the Maclisp one. + +#+LISPM (DECLARE (SPECIAL TV:MORE-PROCESSING-GLOBAL-ENABLE)) + +#+LISPM +(DEFMFUN MORE-FUN (FILE) + FILE ;ignored + (FUNCALL TERMINAL-IO ':MORE-EXCEPTION)) + +#+LISPM +(DEFUN MORE-FUN-INTERNAL (TERMINAL-IO &AUX (STANDARD-INPUT SI:SYN-TERMINAL-IO)) + ; This clears the rest of the screen, unless we're at the bottom + ; or too close to the top. + (COND ((NOT (OR (< (CAR (CURSORPOS)) 10.) + (= (- TTYHEIGHT 2) (CAR (CURSORPOS))))) + (CURSORPOS 'E))) + ; Now go to the bottom of the screen and cause a more, unless disabled. + (COND (TV:MORE-PROCESSING-GLOBAL-ENABLE + (CURSORPOS 'Z) (CURSORPOS 'L) + ((LAMBDA (^Q) + ((LAMBDA (#.WRITEFILEP #.TTYOFF STATE-PDL) + (PRINC MOREMSG) (TYIPEEK) + ; Now see what the user feels like typing in. + (COND ($MOREWAIT + (DO ((L (COND ((EQ $MOREWAIT '$ALL) '(#\SPACE #\RETURN)) + (T '(#\SPACE #\RETURN #\RUBOUT))))) + ((MEMBER (TYIPEEK) L)) + (TYI T))) ; eat other characters + (T (DO () ((NOT (MEMBER (TYIPEEK) '(4 19. 21. 22. 29.)))) + (TYI T)))) ; eat ^], etc. + ; Now erase the MORE message + (COND (SMART-TTY (CURSORPOS 'Z) (CURSORPOS 'L)) (T (TERPRI)))) + NIL NIL (CONS 'MORE-WAIT STATE-PDL)) + ; Now decide whether to continue or flush + (COND ((= #\SP (TYIPEEK)) + (IF MORECONTINUE (LET (#.WRITEFILEP #.TTYOFF) (PRINC MORECONTINUE))) + (TYI T)) ; eat the space + ((= #\RUBOUT (TYIPEEK)) + (LET ((#.TTYOFF T)) (TERPRI)) + (IF MOREFLUSH (PRINC MOREFLUSH)) + (TYI T) ; eat the rubout + (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T)) + #.WRITEFILEP (AND #.WRITEFILEP (NULL MOREFLUSH)))) + (T (COND ((OR (MEMQ 'BATCH STATE-PDL) + (AND (< (TYIPEEK) #\SPACE) + (NOT (MEMBER (TYIPEEK) + '(2 7 11. 12. 25. 27. 28. 29. 30.)))) + (>= (TYIPEEK) 128.)) + (TYI T))) ; eat cr or other control character. + (IF MOREFLUSH (LET (#.WRITEFILEP #.TTYOFF) (PRINC MOREFLUSH))) + (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T)))))) + NIL))) + ; Now home up, or advance to next line, and continue display. + (IF SMART-TTY + (COND (RUBOUT-TTY (LET (#.TTYOFF) (CURSORPOS T T) (CURSORPOS 'L))) + (T (SLEEP 0.4) (FORMFEED))) + (LET (#.TTYOFF #.WRITEFILEP) (TERPRI)))) + +;; More PDP10-only stuff + +#+PDP10 (PROGN 'COMPILE + +(DEFMFUN $PAGEPAUSE (X) (PAGEPAUSE1 NIL X)) + +(DEFUN PAGEPAUSE1 (NIL X) + (SYSCALL 0 'TTYSET TYO (CAR (STATUS TTY)) (CADR (STATUS TTY)) + (BOOLE (COND (X 4) (T 7)) (CADDR (STATUS TTY)) 1_25.))) + ; Bit 3.8 (%TSMOR) of TTYSTS + +(DEFUN TTYINTSOFF NIL + (COND ((STATUS TTY) ; If NIL, we don't have the TTY + (NOINTERRUPT 'TTY) + (SSTATUS TTY (CAR (STATUS TTY)) (CADR (STATUS TTY)) ; Defer echoing + (BOOLE 7 8._18. (CADDR (STATUS TTY)))) + ; Bit 3.4 (%TSNOE) of TTYSTS + (SETQ TTYINTS NIL)))) + +(DEFUN TTYINTSON NIL + ((LAMBDA (TTY-STATUS) + (SSTATUS TTY (CAR TTY-STATUS) (CADR TTY-STATUS) ; Allow echoing + (BOOLE 2 8._18. (CADDR TTY-STATUS))) + (SETQ TTYINTS T) (NOINTERRUPT NIL)) + (SYSCALL 3 'TTYGET TYO))) + +(DEFUN SETCURSORPOS (N1 N2) (SYSCALL 0 'SCPOS TYO N1 N2)) + +) ;; End of PDP10-only stuff + +;;; TRANSL properties for STATUS and SSTATUS in MAXSRC;TRANS5 > +#+(or Franz MACLISP NIL) +(DEFMSPEC $STATUS (L) (SETQ L (CDR L)) + (IF L (NONSYMCHK (CAR L) '$STATUS)) + (COND ((OR (NULL L) + (AND (EQ (CAR L) '$FEATURE) (CDDR L)) + (AND (NOT (EQ (CAR L) '$FEATURE)) (CDR L))) + (WNA-ERR '$STATUS))) + (LET ((KEYWORD (CAR L))) + (CASEQ KEYWORD + ($RUNTIME (LIST '(MTIMES SIMP) (// (+ (RUNTIME) 500.) 1000.) '$MSEC)) + ($TOTALGCTIME (LIST '(MTIMES SIMP) (COMPUTIME (STATUS GCTIME) 0) '$MSEC)) + ($TIME (COND ((PLUSP THISTIME) + (LIST '(MTIMES SIMP) (COMPUTIME (RUNTIME) THISTIME) '$MSEC)) + (T '$UNKNOWN))) + ($GCTIME (COND ((PLUSP GCT) + (LIST '(MTIMES SIMP) (COMPUTIME (STATUS GCTIME) GCT) '$MSEC)) + (T '$UNKNOWN))) + ($REALTIME (LIST '(MTIMES SIMP) (-$ (TIME) STIME0) '%SEC)) + ($DAYTIME (CONS '(MLIST) (STATUS DAYTIME))) + ($DATE (CONS '(MLIST) (STATUS DATE))) + ($DAY (MAKEALIAS (STATUS DOW))) + ($FREECORE (LIST '(MTIMES SIMP) (// (sys-free-memory) 1024.) + '$BLOCKS)) + ($FEATURE (COND ((NULL (CDR L)) (DOLLARIFY (STATUS FEATURES))) + (T #-NIL + (APPLY #'STATUS + `(FEATURE ,(FULLSTRIP1 (CADR L)))) + #+NIL + (FEATUREP (FULLSTRIP1 (CADR L))) + ))) + ($STATUS '((MLIST SIMP) $RUNTIME $TOTALGCTIME $TIME $GCTIME $REALTIME $DAYTIME + $DATE $DAY $FREECORE $FEATURE $STATUS)) + (T (MERROR "Unknown argument - STATUS:~%~M" KEYWORD))))) + +#+LISPM +(DEFMSPEC $STATUS (FORM) (POP FORM) + (LET ((KEYWORD (POP FORM)) + (FEATURE (POP FORM))) + (CHECK-ARG KEYWORD SYMBOLP "a symbolic name") + (CHECK-ARG FEATURE ATOM "an atom") + (COMPILER-LET ((OBSOLETE-FUNCTION-WARNING-SWITCH NIL)) + (CASEQ KEYWORD + ($FEATURE (COND ((NULL FEATURE) (DOLLARIFY (STATUS FEATURES))) + (T (LOOP FOR KNOWN-FEATURE IN (STATUS FEATURES) + WITH ITEM = (FULLSTRIP1 FEATURE) + WHEN (or (and (symbolp item) + (string-equal known-feature item)) + (EQUAL KNOWN-FEATURE ITEM)) RETURN T + FINALLY (RETURN NIL))))) + ($STATUS '((MLIST SIMP) $FEATURE $STATUS)) + (T (MERROR "Unknown argument - STATUS:~%~M" KEYWORD)))))) + +#+(or Franz MACLISP LispM) +(DEFMSPEC $SSTATUS (L) (SETQ L (CDR L)) + (COND ((OR (NULL L) (NULL (CDR L))) (MERROR "SSTATUS takes >1 argument."))) + (LET (((KEYWORD ACT . REST) L)) + (NONSYMCHK KEYWORD '$SSTATUS) + (COND ((EQ KEYWORD '$FEATURE) + (COND ((NOT (NULL REST)) (WNA-ERR '$SSTATUS))) + (NONSYMCHK ACT '$SSTATUS) + (APPLY #'SSTATUS `(FEATURE ,(FULLSTRIP1 ACT)))) + (T (MERROR "Unknown argument - SSTATUS:~%~M" KEYWORD))))) + +; Allocation level 0 is +; (ALLOC '(LIST (16000. 30000. 0.3) FIXNUM (5000. 9000. 0.3) +; FLONUM (1600. 3000. 0.3) BIGNUM (1600. 3000. 0.3) +; SYMBOL (6200. 7200. 0.15) ARRAY (150. 400. 50.))) + +#+MACLISP +(PROGN 'COMPILE +(DEFMSPEC $ALLOC (FORM) (I-$ALLOC (CDR FORM))) +(DEFMFUN I-$ALLOC (L) + (DO ((L L (CDR L)) (X)) ((NULL L) '$DONE) + (COND ((OR (AND (EQ (TYPEP (CAR L)) 'FIXNUM) (> (CAR L) 0) (< (CAR L) 5) + (OR (NOT (> (CAR L) ALLOCLEVEL)) (SETQ ALLOCLEVEL (1- (CAR L))))) + (MEMQ (CAR L) '($ALL $LIST))) + (COND ((= ALLOCLEVEL 0) + (ALLOC '(LIST (16000. 39000. NIL) FIXNUM (5000. 10000. NIL) + FLONUM (1600. 3500. NIL) BIGNUM (1600. 3500. NIL) + SYMBOL (6200. 7600. NIL) ARRAY (150. 450. NIL)))) + ((= ALLOCLEVEL 1) + (ALLOC '(LIST (18000. 48000. NIL) FIXNUM (6000. 11000. NIL) + FLONUM (1800. 4000. NIL) BIGNUM (1800. 4000. NIL) + SYMBOL (6500. 8000. NIL) ARRAY (180. 500. NIL)))) + ((= ALLOCLEVEL 2) + (ALLOC '(LIST (18000. 57000. NIL) FIXNUM (6000. 12000. NIL) + FLONUM (1800. 4500. NIL) BIGNUM (1800. 4500. NIL) + SYMBOL (6500. 8500. NIL) ARRAY (180. 550. NIL)))) + ((= ALLOCLEVEL 3) + (ALLOC '(LIST (20000. 67000. NIL) FIXNUM (8000. 14000. NIL) + FLONUM (2000. 5000. NIL) BIGNUM (2000. 5000. NIL) + SYMBOL (7000. 9000. NIL) ARRAY (200. 600. NIL)))) + (T (PRINC "You're already at maximum allocation") (RETURN '$DONE))) + (SETQ ALLOCLEVEL (1+ ALLOCLEVEL))) + ((SETQ X (ASSQ (STRIPDOLLAR (CAR L)) + '((FIXNUM . 2000.) (FLONUM . 1500.) (BIGNUM . 1500.) + (SYMBOL . 1000.) (ARRAY . 100.) (HUNK2 . 1000.) (HUNK4 . 1000.) + (HUNK8 . 1000.) (HUNK16 . 1000.) (HUNK32 . 1000.)))) + (ALLOC (LIST (CAR X) + (LIST NIL (+ (CDR X) (CADR (GET (CONS NIL (ALLOC T)) (CAR X)))) + NIL)))) + (T (MERROR "Incorrect argument to ALLOC:~%~M" (CAR L)))))) +) +#+Franz +(defmfun $alloc (type pages) (allocate (stripdollar type) pages)) +; type should be list, fixnum etc. + + +;; GC Interrupt functions. + +#+PDP10 (PROGN 'COMPILE + +(DEFUN GCLFUN (SPACE) ; The GC-LOSSAGE and PDL-OVERFLOW interrupt function + (COND ((AND (NOT (= ALLOCLEVEL 5)) (= (SYS-FREE-MEMORY) 0) + ; i.e. state is "NO CORE AVAILABLE". + (MEMQ SPACE '(LIST FIXNUM FLONUM BIGNUM SYMBOL ARRAY))) + (SETQ ALLOCLEVEL 4) (GCOFUN SPACE)) + (T (LET (FREECOREP) + (WHEN (EQ SPACE 'SYMBOL) (SETQ GCSYML NIL) (GCTWA)) + (TERPRI) + (COND ((AND (= (SYS-FREE-MEMORY) 0) + (NOT (MEMQ SPACE '(REGPDL SPECPDL)))) + (MTELL-OPEN "CORE capacity exceeded (while requesting ~A space).~%" + SPACE) + (MTELL-OPEN "SAVE a few expressions if you can.~%") + (PRINC "You will probably have to load up a new MACSYMA!!")) + (T (SETQ FREECOREP T) + (MTELL-OPEN "~A storage capacity exceeded " SPACE))) + (IF (MEMQ SPACE '(REGPDL SPECPDL)) (PRINC "(Infinite recursion?)")) + (TERPRI) + (LET ((MTOP (MEMQ 'MACSYMA-TOPLEVEL STATE-PDL))) + (WHEN MTOP (TIMESOFAR 1) + (IF (> THISTIME 0) (MTELL-OPEN " so far~%") + (TERPRI))) + (COND (DEBUG (LET (($ERROR (CONS '(MLIST SIMP) + (IF FREECOREP + (LIST "~A storage capacity exceeded " SPACE) + (LIST "CORE capacity exceeded (while requesting ~A space).~%" + SPACE))))) + (ERRBREAK NIL))) + ((AND *RSET (NOT MTOP)) (*RSETFUN NIL))) + (COND (ERRCATCH (ERROR)) (MTOP (MQUIT T)) (T (^G)))))))) + +(DEFUN GCOFUN (SPACE) ; The GC-OVERFLOW interrupt function + (IF (NULL TTYINTS) (PROG2 (TTYINTSON) (GCOFUN1 SPACE) (TTYINTSOFF)) + (GCOFUN1 SPACE))) + +(DEFUN GCOFUN1 (SPACE) + ((LAMBDA (#.TTYOFF #.WRITEFILEP) + (PROG (^Q X) + (COND ((= ALLOCLEVEL 4) + (ALLOC '(LIST (NIL NIL 1000) FIXNUM (NIL NIL 100) + FLONUM (NIL NIL 100) BIGNUM (NIL NIL 100) + SYMBOL (NIL NIL 100) ARRAY (NIL NIL 6))) + (SETQ ALLOCLEVEL 5) (RETURN '(T))) + ((= ALLOCLEVEL 5) (MTELL-OPEN "~%Maximum allocation exceeded") + (GCLFUN SPACE)) + ($DYNAMALLOC + (SETQ X (COND ((MEMQ SPACE '(FIXNUM FLONUM BIGNUM SYMBOL ARRAY + HUNK2 HUNK4 HUNK8 HUNK16 HUNK32)) + SPACE) + (T '$ALL))) + (COND ((EQ $DYNAMALLOC '$PRINT) + (MTELL-OPEN "~%More ~A space was needed.~%" SPACE))) + (GO ALLOC))) + (SETQ #.TTYOFF NIL) + (IF (= THISTIME -1) (MTELL-OPEN "~%(Computing the display now)")) + (SETQ X (LIST '(MTEXT) + " +You have run out of " SPACE " space. +Do you want more? +" GCPROMPT)) + (SETQ X (RETRIEVE X T)) + LOOP (COND ((NOT (MEMQ X '($ALL $NONE $OK 1 2 3 4 $LIST $FIXNUM + $FLONUM $BIGNUM $SYMBOL $ARRAY + $HUNK2 $HUNK4 $HUNK8 $HUNK16 $HUNK32))) + (CURSORPOS 'A) + (SETQ X (RETRIEVE GCPROMPT NIL)) + (GO LOOP)) + ((EQ X '$NONE) (GCLFUN SPACE)) + ((EQ X '$OK) (RETURN '(T)))) + ALLOC(I-$ALLOC (LIST X)) (RETURN '(T)))) + #.TTYOFF (AND #.WRITEFILEP (NOT DSKFNP)))) + +(DEFUN GCDEMON (SPACES) ; The GC-DAEMON interrupt function + (DO ((X (IF (= (SYS-FREE-MEMORY) 0) (SETQ GC-DAEMON NIL) SPACES) (CDR X)) + (Y) (N1 0) (N2 0)) + ((NULL X)) + (COND ((ZEROP (CADAR X)) + ((LAMBDA (U1) + (COND ((OR (NOT (EQ (CAR DEMONL) (CAAR X))) + (> (ABS (//$ (-$ U1 (CAR (LAST DEMONL))) U1)) 0.03)) + (SETQ DEMONL (LIST (CAAR X) U1))) + ((= (LENGTH DEMONL) 3) + (SETQ Y (GET (CONS NIL (ALLOC T)) (CAAR X))) + (COND ((AND Y (PROG2 (SETQ N1 (CAR Y) N2 (CADR Y)) (< N1 (- N2 1000)))) + (ALLOC (LIST (CAAR X) (LIST (MIN N2 (+ N1 2000)) NIL NIL))))) + (SETQ DEMONL (LIST NIL))) + (T (NCONC DEMONL (NCONS U1)))) + (RETURN T)) + (FLOAT (CADDAR X))))))) + +) ;; End of GC interrupt functions. + +;; DSKGC(TRUE); will cause user defined values, functions, arrays and line +;; labelled expressions to be stored on disk whenever the system determines +;; storage is getting low. Only needed on PDP10s. Other systems have this +;; built in. Its called paging. + +#+PDP10 (PROGN 'COMPILE + +(DEFMFUN $DSKGC (X) (DSKGC1 NIL X)) + +(DEFUN DSKGC1 (NIL X) + (SETQ GC-OVERFLOW + (COND (X (IF (< ALLOCLEVEL 4) (I-$ALLOC '(4))) 'GCDFUN) + (T 'GCOFUN))) + '$DONE) + +(DEFUN GCDFUN (SPACE) ; The DSKGC interrupt function + (COND ((OR (= GCLINENUM $LINENUM) (STATUS FILEMODE SAVEFILE)) (GCOFUN SPACE)) + (T (SETQ GCLINENUM $LINENUM) + (LET ((GC-OVERFLOW 'GCOFUN) (DSKSAVEP T)) + (I-$STORE '($LABELS $VALUES $FUNCTIONS $ARRAYS)))))) + +) ;; End of disk GC conditionalization. + +#-PDP10 (PROGN 'COMPILE +(DEFMFUN $DSKGC (X) X NIL) +(DEFUN DSKGC1 (X Y) X Y NIL) +) + +;; Various functions which get run when interrupts go off. The interrupt +;; functions in this form are present only in PDP10 and Multics MacLisp. + +#+MacLisp +(PROGN 'COMPILE + +(DEFUN *RSETFUN (NIL) ; The *RSET interrupt function + (AND *RSET (PROG (#.TTYOFF ^Q) (*BREAK T '*RSET)))) + +(DEFUN FAILFUN (X) ; The FAIL-ACT interrupt function + (COND #+PDP10 ((EQ (CAR X) 'ERRLIST) '(T)) + ((MEMQ (CAR X) '(BASE IBASE)) (SET (CAR X) 10) '(T)) + (T (ERRPRINT NIL) NIL))) + +) ;; End of *RSET, FAIL-ACT interrupt functions. + +#+PDP10 (PROGN 'COMPILE + +;; Functions for the Macsyma-user-level tty interrupt facility. + +(DEFMFUN TTYINTFUNSETUP (NIL FLAG) + (IF FLAG (SSTATUS TTYINT $TTYINTNUM 'TTYINTFUN) + (SSTATUS TTYINT $TTYINTNUM NIL))) + +(DEFMFUN TTYINTFUN (NIL NIL) ; The ^U (or other) interrupt function + (NOINTERRUPT NIL) + (MAPPLY $TTYINTFUN NIL $TTYINTFUN)) + +;; These interrupt functions are present only in PDP10 MacLisp. + +;; This function gets called when the operating system supervisor +;; returns the console to Macsyma. It reprints the current c-line, or the +;; editor buffer, or whatever is appropriate. + +(defmfun ttyretfun (x) + (let (#.TTYOFF #.WRITEFILEP (readp (and reading (zerop (listen))))) + (cursorpos 'a) + (when (not (or (eq x T) + (and (eq (car state-pdl) 'MACSYMA-TOPLEVEL) readp))) + ; Do nothing if you never left MACSYMA or are at + ; top level MACSYMA read. + (PRINC "Back to MACSYMA") + (caseq (memq-stpdl '(LISP-TOPLEVEL LISP-BREAK RETRIEVE + MACSYMA-TOPLEVEL)) + ((LISP-TOPLEVEL LISP-BREAK) + (PRINC ", at LISP level. ")) + (T (PRINC ". ")))) + + (or (memq (car state-pdl) '(COMPUTING PLAYBACK BATCH)) + (let ((F (TO-MACSYMA-NAMESTRING + `((DSK ,(STATUS HSNAME)) ,(STATUS UNAME) |_MAXIM|)))) + ;; $LOAD is good for hacking lisp or macsyma level code. + (AND (PROBEF F) + (UNWIND-PROTECT (ERRSET ($LOAD F)) + (DELETEF F) + (CURSORPOS 'a))))) + + (caseq (car state-pdl) + (COMPUTING (PRINC "Computation continuing.")) + (EDIT (PRINC "Inside Editor.")) + ((RETRIEVE MACSYMA-BREAK) + (COND ((OR (EQ (CAR STATE-PDL) 'MACSYMA-BREAK) + (EQ (CADR STATE-PDL) 'MACSYMA-BREAK)) + (PRINC "MACSYMA-BREAK") + (UNLESS (ZEROP BRKLVL) (PRINC " level ") (PRINC BRKLVL)) + (PRINC ".")) + (T (PRINC "Waiting for input.")))) + (BATCH (caseq (cadr state-pdl) + ($TRANSLATE (PRINC "TRANSLATE_FILE continuing.")) + ($DEMO (PRINC "DEMO continuing.")) + (T (PRINC "BATCH continuing.")))) + (PLAYBACK (PRINC "PLAYBACK continuing.")) + (LISP-BREAK (PRINC "LISP-BREAK."))) + (if (not (and (eq (car state-pdl) 'MACSYMA-TOPLEVEL) readp)) (terpri)) +;; Maybe do some redisplay + (caseq (car state-pdl) + (EDIT (prtext) (if readp (reprint command t))) + ((MACSYMA-TOPLEVEL RETRIEVE) + (retr-print promptmsg (eq mrg-punt t)) + (if readp (reprint (if (or (not rephrase) + (eq (car state-pdl) 'RETRIEVE)) + st) + t))) + (MORE-WAIT (PRINC moremsg))))) + +;;; MEMQ-STPDL is like a MEMQ, except that it finds the first cons of the +;;; STATE-PDL who's car is an EQ member of a list, rather than EQ to a +;;; single item. + +(DEFUN MEMQ-STPDL (ATOMS) + (DO ((LIST STATE-PDL (CDR LIST))) + ((OR (NULL LIST) (MEMQ (CAR LIST) ATOMS)) (CAR LIST)))) + +(DEFMFUN IOLFUN (X) ; The IO-LOSSAGE interrupt function + (COND ((EQ (CAR X) 'OPEN) + (FILEPRINT (NAMELIST (CADR X))) ; the file + (PRINC (CAADDR (ERRFRAME NIL)))) ; the error msg + (T (ERRPRINT NIL))) + NIL) + +(DEFMFUN MACHERRFUN (TYPE LOC PC JPC) ; Machine Error Handler + LOC JPC ;Ignored. + (TERPRI) + (COND ((EQ TYPE 'EXAMINE) (MTELL ";reference to non-existent memory")) + ((EQ TYPE 'DEPOSIT) (MTELL ";write into read-only memory")) + ((EQ TYPE 'EVAL) (MTELL ";illegal machine operation")) + ((EQ TYPE 'ODDP) (MTELL ";parity error")) + (T (MTELL ";~A error" TYPE))) + (MERROR " from location ~S~%;program trapped while in ~S" PC (SUBR PC))) + +) ;; End of PDP-10 only interrupt functions. + +;; TTY interrupt functions. This form for PDP10 MacLisp only. + +#+PDP10 (PROGN 'COMPILE + +(DECLARE (SETQ BASE 10.)) ; Must be set to 10 for outputting lap code. + +(DEFUN XQUIT (NIL NIL) ; The ^X interrupt function + (CASEQ (MEMQ-STPDL '(MACSYMA-TOPLEVEL MACSYMA-BREAK LISP-TOPLEVEL LISP-BREAK)) + (MACSYMA-BREAK (*THROW 'MACSYMA-BREAK NIL)) + (MACSYMA-TOPLEVEL (COND (MBREAK (*THROW 'MBREAK NIL)) (T (MQUIT NIL)))) + (T (ERROR 'QUIT)))) + +(PROGN (SSTATUS TTYINT #^A '(LAMBDA (NIL NIL) (MERRBREAK NIL))) + (SSTATUS TTYINT #^B '(LAMBDA (NIL NIL) (MPAUSE NIL))) + (SSTATUS TTYINT #^C NIL) + (SSTATUS TTYINT #^D + '(LAMBDA (NIL NIL) + (COND (^D (PRINC ^DMSG-OFF) (SETQ ^D NIL)) + (T (PRINC ^DMSG-ON) (SETQ ^D T))))) + (SSTATUS TTYINT #^G '(LAMBDA (NIL NIL) (MQUIT NIL))) + (SSTATUS TTYINT #^H NIL) ; This line is unnecessary. + (SSTATUS MACRO #^Q NIL) + (SSTATUS TTYINT #^R NIL) + (SSTATUS TTYINT #^S 'MQUIET) + (SSTATUS TTYINT #^T NIL) + (SSTATUS TTYINT #^X 'XQUIT) + (SSTATUS TTYINT #^] '(LAMBDA (NIL NIL) (TIMESOFAR NIL))) + (SSTATUS TTYINT #^^ #^G) ; quits into LISP + '(Setup of TTY interrupt functions)) +) ;; End of TTY interrupt functions. + +#+Multics (PROGN 'COMPILE + +(DECLARE (SETQ BASE 10.)) ; Must be set to 10 for outputting lap code. + +(PROGN (SSTATUS interrupt 2 'MERRBREAK) ;^A break. + (SSTATUS interrupt 1 'MPAUSE) ;^B break. + ;(SSTATUS TTYINT #^C NIL) ;Done by the LISP. + ;(SSTATUS TTYINT #^D + ; '(LAMBDA (NIL NIL) + ; (COND (^D (PRINC ^DMSG-OFF) (SETQ ^D NIL)) + ; (T (PRINC ^DMSG-ON) (SETQ ^D T))))) ;Done by the LISP. + ;(SSTATUS TTYINT #^G '(LAMBDA (NIL NIL) (MQUIT NIL))) ;Doesn't exist. + ;(SSTATUS TTYINT #^H NIL) ; This line is unnecessary. + ;(SSTATUS MACRO #^Q NIL) ;I don't know what this is for -Jim. + ;(SSTATUS TTYINT #^R NIL) + ;(SSTATUS TTYINT #^S 'MQUIET) + ;(SSTATUS TTYINT #^T NIL) + ;(SSTATUS TTYINT #^X 'XQUIT) ;This has gotta get caught by an errset. + (sstatus interrupt 15. '(lambda (x) + x ;ignored + (timesofar nil))) ;^] interrupt. + (sstatus interrupt 16 '(lambda (x) + ((lambda (errlist) + (^g)) + '((errlfun ()))))) ;^^ interrupt. + '(Setup of TTY interrupt functions)) +) + +#+LISPM (SETQ ERROR-CALL 'ERRBREAK) + +(PROGN (DO L '($SQRT $ERF $SIN $COS $TAN $LOG $PLOG $SEC $CSC $COT $SINH $COSH + $TANH $SECH $CSCH $COTH $ASIN $ACOS $ATAN $ACOT $ACSC $ASEC $ASINH + $ACOSH $ATANH $ACSCH $ASECH $ACOTH $BINOMIAL $GAMMA $GENFACT $DEL) + (CDR L) (NULL L) + ((LAMBDA (X) + (PUTPROP (CAR L) X 'ALIAS) + (PUTPROP X (STRIPDOLLAR (CAR L)) 'REVERSEALIAS)) + ($NOUNIFY (CAR L)))) + ($NOUNIFY '$SUM) ($NOUNIFY '$PRODUCT) + ($NOUNIFY '$INTEGRATE) ($NOUNIFY '$LIMIT) ($NOUNIFY '$MATRIX) + (DEFPROP $DIFF %DERIVATIVE VERB) (DEFPROP %DERIVATIVE $DIFF NOUN) + '(NOUN properties)) + +(PROGN (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ASSIGN)) + '(($DEBUGMODE DEBUGMODE1) ($BOTHCASES BOTHCASES1) + ($PAGEPAUSE PAGEPAUSE1) ($DSKGC DSKGC1) + ($TTYINTFUN TTYINTFUNSETUP) + ($FPPREC FPPREC1) ($POISLIM POISLIM1) + ($default_let_rule_package let-rule-setter) + ($current_let_rule_package let-rule-setter) + ($let_rule_packages let-rule-setter))) + (MAPC #'(LAMBDA (X) (PUTPROP X 'NEVERSET 'ASSIGN)) (CDR $INFOLISTS)) + (DEFPROP $CONTEXTS NEVERSET ASSIGN) + '(ASSIGN properties)) + +;; Do this last so that all of the preceding forms are evaluated using +;; the standard error handlers and interrupt functions. + +#+MACLISP +(SETQ ERRSET 'ERRBREAK ALARMCLOCK NIL AUTOLOAD 'FIND0 + UNDF-FNCTN 'UUF-HANDLER UNBND-VRBL 'M-UBV-EH WRNG-TYPE-ARG 'M-WTA-EH + UNSEEN-GO-TAG NIL + WRNG-NO-ARGS 'M-WNA-EH FAIL-ACT 'FAILFUN *RSET-TRAP '*RSETFUN) + +#+Franz +(setq errset 'errbreak undf-fnctn 'uuf-handler autoload 'find0) + +#+Franz +(signal 2 'errbreak) ; have errbreak handle interrupts + +#+PDP10 +(SETQ GC-LOSSAGE 'GCLFUN GC-DAEMON 'GCDEMON GC-OVERFLOW 'GCOFUN + PDL-OVERFLOW 'GCLFUN IO-LOSSAGE 'IOLFUN MACHINE-ERROR 'MACHERRFUN) + + +; Undeclarations for the file: +(DECLARE (NOTYPE I N N1 N2 U1)) + +(EVAL-WHEN (EVAL COMPILE) (SETQ BASE OLD-BASE IBASE OLD-IBASE)) + \ No newline at end of file diff --git a/src/mrg/compar.864 b/src/mrg/compar.864 new file mode 100644 index 00000000..e9962a80 --- /dev/null +++ b/src/mrg/compar.864 @@ -0,0 +1,1320 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module compar) + +(LOAD-MACSYMA-MACROS MRGMAC) + +(DECLARE (SPECIAL $FLOAT2BF $RADEXPAND $RATPRINT $RATSIMPEXPONS $LISTCONSTVARS + SUCCESS %INITIALLEARNFLAG $PROPS *X*) + ;; Variables defined in DB + (SPECIAL CONTEXT CURRENT DOBJECTS DBTRACE +LABS) + (*EXPR $BFLOAT SIGN RETRIEVE WNA-ERR $LISTOFVARS)) + +(DEFMVAR $CONTEXT '$INITIAL + "Whenever a user assumes a new fact, it is placed in the context +named as the current value of the variable CONTEXT. Similarly, FORGET +references the current value of CONTEXT. To add or delete a fact from a +different context, one must bind CONTEXT to the intended context and then +perform the desired additions or deletions. The context specified by the +value of CONTEXT is automatically activated. All of MACSYMA's built-in +relational knowledge is contained in the default context GLOBAL." + NO-RESET) + +(DEFMVAR $CONTEXTS '((MLIST) $INITIAL $GLOBAL) + "A list of the currently active contexts." + NO-RESET) + +(DEFMVAR $ACTIVECONTEXTS '((MLIST)) + "A list of the currently activated contexts" + NO-RESET) + +(DEFMVAR SIGN-IMAG-ERRP T + "If T errors out in case COMPAR meets up with an imaginary quantity. + If NIL THROWs in that case." + NO-RESET) + +(DEFMVAR COMPLEXSIGN NIL + "If T, COMPAR attempts to work in a complex mode. + This scheme is only very partially developed at this time." + NO-RESET) + +(DEFMVAR $PREDERROR T) +(DEFMVAR $SIGNBFLOAT T) +(DEFMVAR $ASKEXP) +(DEFMVAR LIMITP) +(DEFMVAR $ASSUME_POS NIL) +(DEFMVAR $ASSUME_POS_PRED NIL) + +(DEFVAR FACTORED NIL) +(DEFVAR LOCALS NIL) +(DEFVAR PATEVALLED NIL) +(DEFVAR SIGN NIL) +(DEFVAR MINUS NIL) +(DEFVAR ODDS NIL) +(DEFVAR EVENS NIL) +(DEFVAR LHS NIL) +(DEFVAR RHS NIL) + +;; This variable is also initialized in DB for its own purposes. +;; COMPAR is loaded after DB. +(setq context '$global) + +;; Load-time environment for COMPAR. $CONTEXT and $CONTEXTS will be +;; reset at the end of the file via a call to ($newcontext '$initial). +(setq $context '$global $contexts '((mlist) $global)) + +(defun ask macro (x) `(retrieve (list '(mtext) . ,(cdr x)) nil)) +(defun pow macro (x) `(power . ,(cdr x))) + +(defun lmul (l) (simplify (cons '(mtimes) l))) + +(defun conssize (x) + (if (atom x) 0 + (setq x (cdr x)) + (do ((sz 1)) + ((null x) sz) + (setq sz (+ 1 (conssize (car x)) sz) x (cdr x))))) + +;;; Functions for creating, activating, manipulating, and killing contexts + +(DEFMFUN $context flush + flush ;Ignored + (merror "The CONTEXT function no longer exists.")) + +;;; This "turns on" a context, making its facts visible. + +(defmfun $activate n + (do i 1 (1+ i) (> i n) + (cond ((not (symbolp (arg i))) (nc-err)) + ((memq (arg i) (cdr $activecontexts))) + ((memq (arg i) (cdr $contexts)) + (setq $activecontexts (mcons (arg i) $activecontexts)) + (activate (arg i))) + (t (merror "There is no context with the name ~:M" (arg i))))) + '$DONE) + +;;; This "turns off" a context, keeping the facts, but making them +;;; invisible + +(defmfun $deactivate n + (do i 1 (1+ i) (> i n) + (cond ((not (symbolp (arg i))) (nc-err)) + ((memq (arg i) (cdr $contexts)) + (setq $activecontexts ($delete (arg i) $activecontexts)) + (deactivate (arg i))) + (t (merror "There is no context with the name ~:M" (arg i))))) + '$DONE) + +;;; This function of 0 or 1 argument prints out a list of the facts +;;; in the specified context. No argument implies the current context. + +(DEFMFUN $facts n + (cond ((= n 0) (facts1 $context)) + ((= n 1) (facts1 (arg n))) + (t (merror "FACTS takes zero or one argument only.")))) + +(defun facts1 (con) + (contextmark) + (do ((l (get con 'data) (cdr l)) (nl) (u)) + ((null l) (cons '(mlist) nl)) + (when (visiblep (car l)) + (setq u (intext (caaar l) (cdaar l))) + (if (not (memalike u nl)) (setq nl (cons u nl)))))) + +(defun intext (rel body) + (setq body (mapcar #'doutern body)) + (cond ((eq 'kind rel) (cons '($kind) body)) + ((eq 'par rel) (cons '($par) body)) + ((eq 'mgrp rel) (cons '(mgreaterp) body)) + ((eq 'mgqp rel) (cons '(mgeqp) body)) + ((eq 'meqp rel) (cons '($equal) body)) + ((eq 'mnqp rel) (list '(mnot) (cons '($equal) body))))) + +(defprop $context asscontext assign) + +;;; This function switches contexts, creating one if necessary. + +(defun asscontext (x y) x ;Ignored + (cond ((not (symbolp y)) (nc-err)) + ((memq y $contexts) (setq context y $context y)) + (t ($newcontext y)))) + +;;; This function actually creates a context whose subcontext is $GLOBAL. +;;; It also switches contexts to the newly created one. + +(DEFMFUN $newcontext (x) + (cond ((not (symbolp x)) (nc-err)) + ((memq x $contexts) + (mtell "Context ~M already exists." x) nil) + (t (setq $contexts (mcons x $contexts)) + (putprop x '($global) 'subc) + (setq context x $context x)))) + +;;; This function creates a supercontext. If given one argument, it +;;; makes the current context be the subcontext of the argument. If +;;; given more than one argument, the first is assumed the name of the +;;; supercontext and the rest are the subcontexts. + +(DEFMSPEC $supcontext (x) (SETQ x (CDR x)) + (cond ((null x) (merror "You must supply a name for the context.")) + ((caddr x) (merror "SUPCONTEXT takes either one or two arguments.")) + ((not (symbolp (car x))) (nc-err)) + ((memq (car x) $contexts) + (merror "Context ~M already exists." (car x))) + ((and (cadr x) (not (memq (cadr x) $contexts))) + (merror "Nonexistent context ~M." (cadr x))) + (t (setq $contexts (mcons (car x) $contexts)) + (putprop (car x) (ncons (or (cadr x) $context)) 'subc) + (setq context (car x) $context (car x))))) + +;;; This function kills a context or a list of contexts + +(defmfun $killcontext n + (do i 1 (1+ i) (> i n) + (if (symbolp (arg i)) (killcontext (arg i)) (nc-err))) + (if (and (= n 1) (eq (arg 1) '$global)) '$not_done '$done)) + +(defun killallcontexts () + (mapc #'killcontext (cdr $contexts)) + (setq $context '$initial context '$initial current '$initial + $contexts '((mlist) $initial $global) dobjects ()) + ;The DB variables + ;conmark, conunmrk, conindex, connumber, and contexts + ;concern garbage-collectible contexts, and so we're + ;better off not resetting them. + (defprop $global 1 cmark) (defprop $initial 1 cmark) + (defprop $initial ($global) subc)) + +(defun killcontext (x) + (cond ((not (memq x $contexts)) + (mtell "The context ~M doesn't exist." x)) + ((eq x '$global) '$global) + ((eq x '$initial) + (mapc #'remov (get '$initial 'data)) + (remprop '$initial 'data) + '$initial) + ((and (not (eq $context x)) (contextmark) (< 0 (get x 'cmark))) + (mtell "The context ~M is currently active." x)) + (t (setq $contexts ($delete x $contexts)) + (cond ((and (eq x $context) + (eq (get x 'subc) '($global))) + (setq $context '$initial) + (setq context '$initial)) + ((eq x $context) + (setq $context (car (get x 'subc))) + (setq context (car (get x 'subc))))) + (killc x) + x))) + +(defun nc-err () (merror "Contexts must be symbolic atoms.")) + +(defmspec $is (form) (mevalp (fexprcheck form))) + +(defmfun is (pred) (let (($prederror t)) (mevalp pred))) + +;; =>* N.B. *<= +;; The function IS-BOOLE-CHECK, used by the translator, depends +;; on some stuff in here. Check it out in the transl module +;; ACALL before proceeding. + +(defmfun mevalp (pat) + (let (patevalled ans) + (setq ans (mevalp1 pat)) + (cond ((memq ans '(#.(NOT ()) ())) + ans) + ($prederror (pre-err patevalled)) + (t '$unknown)))) + +(defun mevalp1 (pat) + (cond ((and (not (atom pat)) (memq (caar pat) '(mnot mand mor))) + (cond ((eq 'mnot (caar pat)) (is-mnot (cadr pat))) + ((eq 'mand (caar pat)) (is-mand (cdr pat))) + (t (is-mor (cdr pat))))) + ((atom (setq patevalled (meval pat))) patevalled) + ((memq (caar patevalled) '(mnot mand mor)) (mevalp1 patevalled)) + (t (mevalp2 (caar patevalled) (cadr patevalled) (caddr patevalled))))) + +(defmfun mevalp2 (pred arg1 arg2) + (cond ((eq 'mequal pred) (like arg1 arg2)) + ((eq '$equal pred) (meqp arg1 arg2)) + ((eq 'mnotequal pred) (not (like arg1 arg2))) + ((eq '$notequal pred) (mnqp arg1 arg2)) + ((eq 'mgreaterp pred) (mgrp arg1 arg2)) + ((eq 'mlessp pred) (mgrp arg2 arg1)) + ((eq 'mgeqp pred) (mgqp arg1 arg2)) + ((eq 'mleqp pred) (mgqp arg2 arg1)) + (t (isp (munformat patevalled))))) + +(defmfun pre-err (pat) + (merror "MACSYMA was unable to evaluate the predicate:~%~M" pat)) + +(defun is-mnot (pred) + (setq pred (mevalp pred)) + (cond ((eq t pred) nil) + ((not pred)) + (t (pred-reverse pred)))) + +(defmfun pred-reverse (pred) + (cond ((atom pred) (list '(mnot) pred)) + ((eq 'mnot (caar pred)) (cadr pred)) + ((eq 'mgreaterp (caar pred)) (cons '(mleqp) (cdr pred))) + ((eq 'mgeqp (caar pred)) (cons '(mlessp) (cdr pred))) + ((eq 'mequal (caar pred)) (cons '(mnotequal) (cdr pred))) + ((eq '$equal (caar pred)) (cons '($notequal) (cdr pred))) + ((eq '$notequal (caar pred)) (cons '($equal) (cdr pred))) + ((eq 'mnotequal (caar pred)) (cons '(mequal) (cdr pred))) + ((eq 'mleqp (caar pred)) (cons '(mgreaterp) (cdr pred))) + ((eq 'mlessp (caar pred)) (cons '(mgeqp) (cdr pred))) + (t (list '(mnot) pred)))) + +(defun is-mand (pl) + (do ((dummy) (npl)) + ((null pl) (cond ((null npl)) + ((null (cdr npl)) (car npl)) + (t (cons '(mand) (nreverse npl))))) + (setq dummy (mevalp (car pl)) pl (cdr pl)) + (cond ((eq t dummy)) + ((null dummy) (return nil)) + (t (setq npl (cons dummy npl)))))) + +(defun is-mor (pl) + (do ((dummy) (npl)) + ((null pl) (cond ((null npl) nil) + ((null (cdr npl)) (car npl)) + (t (cons '(mor) (nreverse npl))))) + (setq dummy (mevalp (car pl)) pl (cdr pl)) + (cond ((eq t dummy) (return t)) + ((null dummy)) + (t (setq npl (cons dummy npl)))))) + +(DEFMSPEC $assume (x) (SETQ x (CDR x)) + (do ((nl)) ((null x) (cons '(mlist) (nreverse nl))) + (cond ((atom (car x)) (setq nl (cons (assume (meval (car x))) nl))) + ((eq 'mand (caaar x)) + (mapc #'(lambda (l) (setq nl (cons (assume (meval l)) nl))) + (cdar x))) + ((eq 'mnot (caaar x)) + (setq nl (cons (assume (meval (pred-reverse (cadar x)))) nl))) + ((eq 'mor (caaar x)) + (merror "ASSUME: Macsyma is unable to handle assertions involving 'OR'.")) + ((eq (caaar x) 'mequal) + (merror "ASSUME: = means syntactic equality in Macsyma. +Maybe you want to use EQUAL.")) + ((eq (caaar x) 'mnotequal) + (merror "ASSUME: # means syntactic unequality in Macsyma. +Maybe you want to use NOT EQUAL.")) + (t (setq nl (cons (assume (meval (car x))) nl)))) + (setq x (cdr x)))) + +(defmfun assume (pat) + (if (and (not (atom pat)) + (eq (caar pat) 'mnot) + (eq (caaadr pat) '$equal)) + (setq pat `(($notequal) ,@(cdadr pat)))) + (let ((dummy (let (patevalled $assume_pos) (mevalp1 pat)))) + (cond ((eq dummy t) '$redundant) + ((null dummy) '$inconsistent) + ((atom dummy) '$meaningless) + (t (learn pat t))))) + +(defmfun learn (pat flag) + (cond ((atom pat)) + ((get (caar pat) (if flag 'learn 'unlearn)) + (funcall (get (caar pat) (if flag 'learn 'unlearn)) pat)) + ((eq (caar pat) 'mgreaterp) (daddgr flag (sub (cadr pat) (caddr pat)))) + ((eq (caar pat) 'mgeqp) (daddgq flag (sub (cadr pat) (caddr pat)))) + ((memq (caar pat) '(mequal $equal)) + (daddeq flag (sub (cadr pat) (caddr pat)))) + ((memq (caar pat) '(mnotequal $notequal)) + (daddnq flag (sub (cadr pat) (caddr pat)))) + ((eq (caar pat) 'mleqp) (daddgq flag (sub (caddr pat) (cadr pat)))) + ((eq (caar pat) 'mlessp) (daddgr flag (sub (caddr pat) (cadr pat)))) + (flag (true* (munformat pat))) + (t (untrue (munformat pat))))) + +(DEFMSPEC $forget (x) (SETQ x (CDR x)) + (do ((nl)) ((null x) (cons '(mlist) (nreverse nl))) + (cond ((atom (car x)) (setq nl (cons (forget (meval (car x))) nl))) + ((eq 'mand (caaar x)) + (mapc #'(lambda (l) (setq nl (cons (forget (meval l)) nl))) + (cdar x))) + ((eq 'mnot (caaar x)) + (setq nl (cons (forget (meval (pred-reverse (cadar x)))) nl))) + ((eq 'mor (caaar x)) + (merror "MACSYMA is unable to handle assertions involving 'OR'.")) + (t (setq nl (cons (forget (meval (car x))) nl)))) + (setq x (cdr x)))) + +(defmfun forget (pat) + (cond (($listp pat) + (cons '(mlist simp) (mapcar #'forget1 (cdr pat)))) + (t (forget1 pat)))) + +(defun forget1 (pat) + (cond ((and (not (atom pat)) + (eq (caar pat) 'mnot) + (eq (caaadr pat) '$equal)) + (setq pat `(($notequal) ,@(cdadr pat))))) + (learn pat nil)) + +(defmfun restore-facts (factl) ; used by SAVE + (dolist (fact factl) + (cond ((eq (caar fact) '$kind) + (declarekind (cadr fact) (caddr fact)) + (add2lnc (getop (cadr fact)) $props)) + ((eq (caar fact) '$par)) + (t (assume fact))))) + + +(defun compare macro (x) `(sign1 (sub* ,(cadr x) ,(caddr x)))) + +(defmfun $compare (x y) (compare x y) sign) + +(defmfun $max n (if (= n 0) (wna-err '$max) (maximin (listify n) '$max))) + +(defmfun $min n (if (= n 0) (wna-err '$min) (maximin (listify n) '$min))) + +(defmfun maximum (l) (maximin l '$max)) + +(defmfun minimum (l) (maximin l '$min)) + +(defmfun maximin (l sw) + (if (dolist (x l) (if (not (atom x)) (return t))) + (setq l (total-nary (cons (ncons sw) l)))) + (do ((ll nil nil) (reject nil nil) (nl) (arg) (xarg)) + ((null l) (if (null (cdr nl)) (car nl) (cons (ncons sw) (sort nl 'great)))) + (dolist (x (cdr l)) + (compare (car l) x) + (cond ((eq sign '$zero) + (setq arg (specrepcheck (car l)) xarg (specrepcheck x)) + (if (and (not (alike1 arg xarg)) (great xarg arg)) + (setq reject t ll (cons x ll)))) + ((memq sign '($pos $pz)) + (if (eq sw '$min) (setq reject t ll (cons x ll)))) + ((memq sign '($neg $nz)) + (if (eq sw '$max) (setq reject t ll (cons x ll)))) + (t (setq ll (cons x ll))))) + (if (not reject) (setq nl (cons (car l) nl))) + (setq l (nreverse ll)))) + +(defmspec mnot (form) (setq form (cdr form)) + (let ((x (mevalp (car form)))) + (if (eq x '$unknown) x (not x)))) + +(defmspec mand (form) (setq form (cdr form)) + (do ((l form (cdr l)) (x)) ((null l) t) + (cond ((not (setq x (mevalp (car l)))) (return nil)) + ((eq x '$unknown) (return x))))) + +(defmspec mor (form) (setq form (cdr form)) + (do ((l form (cdr l)) (x)) ((null l) nil) + (cond ((eq (setq x (mevalp (car l))) '$unknown) (return x)) + (x (return t))))) + +;;;Toplevel functions- $ASKSIGN, $SIGN. +;;;Switches- LIMITP If TRUE $ASKSIGN and $SIGN will look for special +;;; symbols such as EPSILON, $INF, $MINF and attempt +;;; to do the correct thing. In addition calls to +;;; $REALPART and $IMAGPART are made to assure that +;;; the expression is real. +;;; +;;; if NIL $ASKSIGN and $SIGN assume the expression +;;; given is real unless it contains an $%I, in which +;;; case they call $RECTFORM. + +(setq limitp nil) + +(defmfun $asksign (exp) + (let (sign minus odds evens factored) + (asksign01 (cond (limitp (restorelim exp)) + ((among '$%i exp) ($rectform exp)) + (t exp))))) + +(defmfun asksign-p-or-n (e) + (unwind-protect (prog2 (assume `(($notequal) ,e 0)) + ($asksign e)) + (forget `(($notequal) ,e 0)))) + +(defun asksign01 (a) + (let ((e (sign-prep a))) + (cond ((eq e '$pnz) '$pnz) + ((memq (setq e (asksign1 e)) '($pos $neg)) e) + (limitp (eps-sign a)) + (t '$zero)))) + +(defmfun csign (x) ;; csign returns t if x appears to be complex. + ;; Else, it returns the sign. + (or (not (free x '$%i)) + (let (sign-imag-errp limitp) (*catch 'sign-imag-err ($sign x))))) + +(defmfun $sign (x) + (let (sign minus odds evens factored) + (sign01 (cond (limitp (restorelim x)) + ((not (free x '$%i)) ($rectform x)) + (t x))))) + +(defun sign01 (a) + (let ((e (sign-prep a))) + (cond ((eq e '$pnz) '$pnz) + (t (setq e (sign1 e)) + (if (and limitp (eq e '$zero)) (eps-sign a) e))))) + +;;; Preparation for asking questions from DEFINT or LIMIT. +(defun sign-prep (x) + (if limitp + (let (((rpart . ipart) (trisplit x))) + (cond ((and (equal (sratsimp ipart) 0) + (free rpart '$infinity)) + (setq x (nmr (sratsimp rpart))) + (if (free x 'prin-inf) + x + ($limit x 'prin-inf '$inf '$minus))) + (t '$PNZ))) ; Confess ignorance if COMPLEX. + x)) + +;;; Do substitutions for special symbols. +(defun nmr (a) + (if (not (free a '$zeroa)) (setq a ($limit a '$zeroa 0 '$plus))) + (if (not (free a '$zerob)) (setq a ($limit a '$zerob 0 '$minus))) + (if (not (free a 'z**)) (setq a ($limit a 'z** 0 '$plus))) + (if (not (free a '*z*)) (setq a ($limit a '*z* 0 '$plus))) + (if (not (free a 'epsilon)) (setq a ($limit a 'epsilon 0 '$plus))) + a) ;;; Give A back. + +;;; Get the sign of EPSILON-like terms. Could be made MUCH hairier. +(defun eps-sign (b) + (let (temp1 temp2 temp3 free1 free2 free3) + (cond ((not (free b '$zeroa)) + (setq temp1 (eps-coef-sign b '$zeroa))) + (t (setq free1 t))) + (cond ((not (free b '$zerob)) + (setq temp2 (eps-coef-sign b '$zerob))) + (t (setq free2 t))) + (cond ((not (free b 'epsilon)) + (setq temp3 (eps-coef-sign b 'epsilon))) + (t (setq free3 t))) + (cond ((and free1 free2 free3) '$zero) + ((or (not (null temp1)) (not (null temp2)) (not (null temp3))) + (cond ((and (null temp1) (null temp2)) temp3) + ((and (null temp2) (null temp3)) temp1) + ((and (null temp1) (null temp3)) temp2) + (t (merror + "~%ASKSIGN: Internal error. See Maintainers."))))))) + +(defun eps-coef-sign (exp epskind) + (let ((eps-power ($lopow exp epskind)) eps-coef) + (cond ((and (not (equal eps-power 0)) + (not (equal (setq eps-coef (ratcoeff exp epskind eps-power)) + 0)) + (eq (ask-integer eps-power '$integer) '$yes)) + (cond ((eq (ask-integer eps-power '$even) '$yes) + ($asksign eps-coef)) + ((eq (ask-integer eps-power '$odd) '$yes) + (setq eps-coef ($asksign eps-coef)) + (cond ((or (and (eq eps-coef '$pos) + (or (eq epskind 'epsilon) + (eq epskind '$zeroa))) + (and (eq eps-coef '$neg) + (or (alike epskind (mul2* -1 'epsilon)) + (eq epskind '$zerob)))) + '$pos) + (t '$neg))) + (t (merror "~%ASKSIGN or SIGN: Insufficient information.~%")))) + (t (let ((deriv (sdiff exp epskind)) deriv-sign) + (cond ((not (eq (setq deriv-sign ($asksign deriv)) '$zero)) + (total-sign epskind deriv-sign)) + ((not + (eq (let ((deriv (sdiff deriv epskind))) + (setq deriv-sign ($asksign deriv))) + '$zero)) + deriv-sign) + (t (merror "~%ASKSIGN or SIGN: Insufficient data.~%")))))))) + +;;; The above code does a partial Taylor series analysis of something +;;; that isn't a polynomial. + +(defun total-sign (epskind factor-sign) + (cond ((or (eq epskind '$zeroa) (eq epskind 'epsilon)) + (cond ((eq factor-sign '$pos) '$pos) + ((eq factor-sign '$neg) '$neg) + ((eq factor-sign '$zero) '$zero))) + ((eq epskind '$zerob) + (cond ((eq factor-sign '$pos) '$neg) + ((eq factor-sign '$neg) '$pos) + ((eq factor-sign '$zero) '$zero))))) + +(defun asksign (x) + (setq x ($asksign x)) + (cond ((eq '$pos x) '$positive) + ((eq '$neg x) '$negative) + ((eq '$PNZ x) '$pnz) ;COMPLEX expression encountered here. + (t '$zero))) + +(defun asksign1 ($askexp) + (let ($radexpand) (sign1 $askexp)) + (cond ((memq sign '($pos $neg $zero)) sign) + ((null odds) + (setq $askexp (lmul evens) + sign (cdr (assol $askexp locals))) + (do () (nil) + (cond ((member sign '($zero $z 0 0.0)) + (tdzero $askexp) (setq sign '$zero) (return t)) + ((memq sign '($pn $nonzero $n $nz $nonz $non0)) + (tdpn $askexp) (setq sign '$pos) (return t)) + ((memq sign '($pos $p $positive)) + (tdpos $askexp) (setq sign '$pos) (return t)) + ((memq sign '($neg $n $negative)) + (tdneg $askexp) (setq sign '$pos) (return t))) + (setq sign (ask "Is " $askexp " zero or nonzero?"))) + (if minus (flip sign) sign)) + (t (if minus (setq sign (flip sign))) + (setq $askexp (lmul (nconc odds (mapcar #'(lambda (l) (pow l 2)) + evens)))) + (do ((dom (cond ((eq '$pz sign) " positive or zero?") + ((eq '$nz sign) " negative or zero?") + ((eq '$pn sign) " positive or negative?") + (t " positive, negative, or zero?"))) + (ans (cdr (assol $askexp locals)))) (nil) + (cond ((and (memq ans '($pos $p $positive)) + (memq sign '($pz $pn $pnz))) + (tdpos $askexp) (setq sign '$pos) (return t)) + ((and (memq ans '($neg $n $negative)) + (memq sign '($nz $pn $pnz))) + (tdneg $askexp) (setq sign '$neg) (return t)) + ((and (member ans '($zero $z 0 0.0)) + (memq sign '($pz $nz $pnz))) + (tdzero $askexp) (setq sign '$zero) (return t))) + (setq ans (ask "Is " $askexp dom))) + (if minus (flip sign) sign)))) + +(defun clearsign () + (do () ((null locals)) + (cond ((eq '$pos (cdar locals)) (daddgr nil (caar locals))) + ((eq '$neg (cdar locals)) (daddgr nil (neg (caar locals)))) + ((eq '$zero (cdar locals)) (daddeq nil (caar locals))) + ((eq '$pn (cdar locals)) (daddnq nil (caar locals))) + ((eq '$pz (cdar locals)) (daddgq nil (caar locals))) + ((eq '$nz (cdar locals)) (daddgq nil (neg (caar locals))))) + (setq locals (cdr locals)))) + +(defmfun like (x y) (alike1 (specrepcheck x) (specrepcheck y))) + +(defmfun meqp (x y) + (cond ((like x y)) + (t (compare x y) + (cond ((eq '$zero sign)) + ((memq sign '($pos $neg $pn)) nil) + (t (c-$zero odds evens)))))) + +(defmfun mgrp (x y) + (compare x y) + (cond ((eq '$pos sign)) + ((memq sign '($neg $zero $nz)) nil) + (t (c-$pos odds evens)))) + +(defun mlsp (x y) (mgrp y x)) + +(defmfun mgqp (x y) + (compare x y) + (cond ((memq sign '($pos $zero $pz)) t) + ((eq '$neg sign) nil) + ((eq '$nz sign) (c-$zero odds evens)) + ((eq '$pn sign) (c-$pos odds evens)) + (t (c-$pz odds evens)))) + +(defmfun mnqp (x y) + (cond ((like x y) nil) + (t (compare x y) + (cond ((memq sign '($pos $neg $pn)) t) + ((eq sign '$zero) nil) + ((eq sign '$pz) (c-$pos odds evens)) + ((eq sign '$nz) + (c-$pos (mapcar #'neg odds) (mapcar #'neg evens))) + (t (c-$pn odds evens)))))) + +(defun c-$pn (o e) (list '(mnot) (c-$zero o e))) + +(defun c-$zero (o e) (list '($equal) (lmul (nconc o e)) 0)) + +(defun c-$pos (o e) + (cond ((null o) (list '(mnot) (list '($equal) (lmul e) 0))) + ((null e) (list '(mgreaterp) (lmul o) 0)) + (t (setq e (mapcar #'(lambda (l) (pow l 2)) e)) + (list '(mgreaterp) (lmul (nconc o e)) 0)))) + +(defun c-$pz (o e) + (cond ((null o) (list '(mnot) (list '($equal) (lmul e) 0))) + ((null e) (list '(mgeqp) (lmul o) 0)) + (t (setq e (mapcar #'(lambda (l) (pow l 2)) e)) + (list '(mgeqp) (lmul (nconc o e)) 0)))) + +;;; These functions are for old translated files to work 6/4/76. +; (defprop greater mgrp expr) +; (defprop geq mgqp expr) +; (defprop equals meqp expr) + +(defun sign* (x) (let (sign minus odds evens) (sign1 x))) + +(defun sign1 (x) + (if (not (free x '$inf)) + (let (($listconstvars t) l) + (setq l ($listofvars x)) + (if (and (null (cddr l)) (eq (cadr l) '$inf)) + (setq x (infsimp x))))) + (prog (dum exp) + (setq dum (constp x) exp x) + (cond ((or (numberp x) (ratnump x))) + ((eq dum 'bigfloat) + (if (and (setq dum ($bfloat x)) ($bfloatp dum)) (setq exp dum))) + ((eq dum 'float) + (if (and (setq dum (numer x)) (numberp dum)) (setq exp dum))) + ((and (memq dum '(numer symbol)) + (prog2 (setq dum (numer x)) + (or (null dum) + (and (numberp dum) + (prog2 (setq exp dum) + (lessp (abs dum) 1.0e-6)))))) + (cond ($signbfloat + (and (setq dum ($bfloat x)) ($bfloatp dum) (setq exp dum))) + (t (setq sign '$pnz evens nil odds (ncons x) minus nil) + (return sign))))) + (or (and (not (atom x)) (not (mnump x)) (equal x exp) + (let (s o e m) + (compsplt x) + (dcompare lhs rhs) + (cond ((memq sign '($pos $neg $zero))) + ((eq sign '$pnz) nil) + (t (setq s sign o odds e evens m minus) + (sign x) + (if (not (strongp sign s)) + (if (and (eq sign '$pnz) (eq s '$pn)) + (setq sign s) + (setq sign s odds o evens e minus m))) + t)))) + (sign exp)) + (return sign))) + +(defun numer (x) + (let ($ratsimpexpons) + (car (errset (meval `(($ev) ,x $numer $%enumer)) nil)))) + +(defun constp (x) + (cond ((floatp x) 'float) + ((numberp x) 'numer) + ((symbolp x) (if (memq x '($%pi $%e $%phi $%gamma)) 'symbol)) + ((eq (caar x) 'rat) 'numer) + ((eq (caar x) 'bigfloat) 'bigfloat) + ((specrepp x) (constp (specdisrep x))) + (t (do ((l (cdr x) (cdr l)) (dum) (ans 'numer)) + ((null l) ans) + (setq dum (constp (car l))) + (cond ((eq dum 'float) (return 'float)) + ((eq dum 'numer)) + ((eq dum 'bigfloat) (setq ans 'bigfloat)) + ((eq dum 'symbol) + (if (eq ans 'numer) (setq ans 'symbol))) + (t (return nil))))))) + +(defmfun sign (x) + (cond ((mnump x) (setq sign (rgrp x 0) minus nil odds nil evens nil)) + ((atom x) (if (eq x '$%i) (imag-err x)) (sign-any x)) + ((eq (caar x) 'mtimes) (sign-mtimes x)) + ((eq (caar x) 'mplus) (sign-mplus x)) + ((eq (caar x) 'mexpt) (sign-mexpt x)) + ((eq (caar x) '%log) (compare (cadr x) 1)) + ((eq (caar x) 'mabs) (sign-mabs x)) + ((memq (caar x) '(%csc %csch)) + (sign (inv* (cons (ncons (get (caar x) 'recip)) (cdr x))))) + ((specrepp x) (sign (specdisrep x))) + ((kindp (caar x) '$posfun) (sign-posfun x)) + ((or (memq (caar x) '(%signum %erf)) + (and (kindp (caar x) '$oddfun) (kindp (caar x) '$increasing))) + (sign-oddinc x)) + (t (sign-any x)))) + +(defun sign-any (x) + (dcompare x 0) + (if (and $assume_pos + (memq sign '($pnz $pz $pn)) + (if $assume_pos_pred (let ((*x* x)) (is '(($assume_pos_pred) *x*))) + (mapatom x))) + (setq sign '$pos)) + (setq minus nil evens nil + odds (if (not (memq sign '($pos $neg $zero))) (ncons x)))) + +(defun sign-mtimes (x) + (setq x (cdr x)) + (do ((s '$pos) (m) (o) (e)) ((null x) (setq sign s minus m odds o evens e)) + (sign1 (car x)) + (cond ((eq sign '$zero) (return t)) + ((eq sign '$pos)) + ((eq sign '$neg) (setq s (flip s) m (not m))) + ((prog2 (setq m (not (eq m minus)) o (nconc odds o) e (nconc evens e)) + nil)) + ((eq s sign)) + ((eq s '$pos) (setq s sign)) + ((eq s '$neg) (setq s (flip sign))) + ((or (and (eq s '$pz) (eq sign '$nz)) + (and (eq s '$nz) (eq sign '$pz))) + (setq s '$nz)) + (t (setq s '$pnz))) + (setq x (cdr x)))) + +(defun sign-mplus (x &aux s o e m) + (cond ((signdiff x)) + ((prog2 (setq s sign e evens o odds m minus) nil)) + ((signsum x)) + ((prog2 (cond ((strongp s sign)) + (t (setq s sign e evens o odds m minus))) + nil)) + ((and (not factored) (signfactor x))) + ((strongp sign s)) + (t (setq sign s evens e odds o minus m)))) + +(defun signdiff (x) + (setq sign '$pnz) + (compsplt x) + (if (and (mplusp lhs) (equal rhs 0) + (null (cdddr lhs)) + (negp (cadr lhs)) (not (negp (caddr lhs)))) + (setq rhs (neg (cadr lhs)) lhs (caddr lhs))) + (let (dum) + (cond ((or (equal rhs 0) (mplusp lhs)) nil) + ((and (memq (constp rhs) '(numer symbol)) + (numberp (setq dum (numer rhs))) + (prog2 (setq rhs dum) nil))) + ((mplusp rhs) nil) + ((and (dcompare lhs rhs) (memq sign '($pos $neg $zero)))) + ((and (not (atom lhs)) (not (atom rhs)) + (eq (caar lhs) (caar rhs)) + (kindp (caar lhs) '$increasing)) + (sign (sub (cadr lhs) (cadr rhs))) + t) + ((signdiff-special lhs rhs))))) + +(defun signdiff-special (xlhs xrhs) + (cond ((or (and (numberp xrhs) (minusp xrhs) + (not (atom xlhs)) (eq (sign* xlhs) '$pos)) + ; e.g. sign(a^3+%pi-1) where a>0 + (and (mexptp xlhs) ; e.g. sign(%e^x-1) where x>0 + (memq (sign* (sub 1 xrhs)) '($pos $zero $pz)) + (eq (sign* (caddr xlhs)) '$pos) + (eq (sign* (sub (cadr xlhs) 1)) '$pos)) + (and (mexptp xlhs) (mexptp xrhs) ; e.g. sign(2^x-2^y) where x>y + (alike1 (cadr xlhs) (cadr xrhs)) + (eq (sign* (sub (cadr xlhs) 1)) '$pos) + (eq (sign* (sub (caddr xlhs) (caddr xrhs))) '$pos))) + (setq sign '$pos minus nil odds nil evens nil) t) + ((and (not (atom xlhs)) (eq (caar xlhs) 'mabs) + (alike1 (cadr xlhs) xrhs)) + (setq sign '$pz minus nil odds nil evens nil) t))) + +(defun signsum (x) + (do ((l (cdr x) (cdr l)) (s '$zero)) + ((null l) (setq sign s minus nil odds (list x) evens nil) t) + (sign (car l)) + (cond ((or (and (eq sign '$zero) + (setq x (sub x (car l)))) + (and (eq s sign) (not (eq s '$pn))) ; $PN + $PN = $PNZ + (and (eq s '$pos) (eq sign '$pz)) + (and (eq s '$neg) (eq sign '$nz)))) + ((or (and (memq sign '($pz $pos)) (memq s '($zero $pz))) + (and (memq sign '($nz $neg)) (memq s '($zero $nz))) + (and (eq sign '$pn) (eq s '$zero))) + (setq s sign)) + (t (setq sign '$pnz odds (list x) evens nil minus nil) + (return nil))))) + +(defun signfactor (x) + (let (y (factored t)) + (setq y (factor-if-small x)) + (cond ((or (mplusp y) (> (conssize y) 50.)) + (prog2 (setq sign '$pnz) nil)) + (t (sign y))))) + +(defun factor-if-small (x) + (if (< (conssize x) 51.) (let ($ratprint) (factor x)) x)) + +(defun sign-mexpt (x) + (let* ((expt (caddr x)) (base1 (cadr x)) + (sign-expt (sign1 expt)) (sign-base (sign1 base1)) + (evod (evod expt))) + (cond ((and (eq sign-base '$zero) + (memq sign-expt '($zero $neg))) + (dbzs-err x)) + ((eq sign-expt '$zero) (setq sign '$pos) (tdzero (sub x 1))) + ((eq sign-base '$pos)) + ((eq sign-base '$zero) (tdpos expt)) + ((eq evod '$even) + (cond ((eq sign-expt '$neg) + (setq sign '$pos minus nil evens (ncons base1) odds nil) + (tdpn base1)) + ((memq sign-base '($pn $neg)) + (setq sign '$pos minus nil + evens (nconc odds evens) + odds nil)) + (t (setq sign '$pz minus nil + evens (nconc odds evens) + odds nil)))) + ((and (memq sign-expt '($neg $nz)) + (memq sign-base '($nz $pz $pnz))) + (tdpn base1) + (setq sign (cond ((eq sign-base '$pnz) '$pn) + ((eq sign-base '$pz) '$pos) + ((eq sign-expt '$neg) '$neg) + (t '$pn)))) + ((memq sign-expt '($pz $nz $pnz)) + (cond ((eq sign-base '$neg) + (setq odds (ncons x) sign '$pn)))) + ((eq sign-expt '$pn)) + (t (cond ((ratnump expt) + (cond ((mevenp (cadr expt)) + (cond ((memq sign-base '($pn $neg)) + (setq sign-base '$pos)) + ((memq sign-base '($pnz $nz)) + (setq sign-base '$pz))) + (setq evens (nconc odds evens) + odds nil minus nil)) + ((mevenp (caddr expt)) + (cond (complexsign + (setq sign-base (setq sign-expt '$pnz))) + ((eq sign-base '$neg) (imag-err x)) + ((eq sign-base '$pn) + (setq sign-base '$pos) + (tdpos base1)) + ((eq sign-base '$nz) + (setq sign-base '$zero) + (tdzero base1)) + (t (setq sign-base '$pz) + (tdpz base1))))))) + (cond ((eq sign-expt '$neg) + (cond ((eq sign-base '$zero) (dbzs-err x)) + ((eq sign-base '$pz) + (setq sign-base '$pos) + (tdpos base1)) + ((eq sign-base '$nz) + (setq sign-base '$neg) + (tdneg base1)) + ((eq sign-base '$pnz) + (setq sign-base '$pn) + (tdpn base1))))) + (setq sign sign-base))))) + +(defun sign-mabs (x) + (sign (cadr x)) + (cond ((memq sign '($pos $zero))) + ((memq sign '($neg $pn)) (setq sign '$pos)) + (t (setq sign '$pz minus nil evens (nconc odds evens) odds nil)))) + +(defun sign-posfun (x) x ;Ignored + (setq sign '$pos minus nil odds nil evens nil)) + +(defun sign-oddinc (x) (sign (cadr x))) + +(defun imag-err (x) + (if sign-imag-errp (merror "SIGN called on an imaginary argument:~%~M" x) + (*throw 'sign-imag-err t))) + +(defun dbzs-err (x) (merror "Division by zero detected in SIGN:~%~M" x)) + + +(DEFMFUN $featurep (x y) + (cond ((not (atom y)) (mtell "~M is not an atom - FEATUREP." y)) + ((eq '$integer y) (integerp x)) + ((eq '$even y) (mevenp x)) + ((eq '$odd y) (moddp x)) + ((eq '$real y) + (cond ((atom x) + (or (numberp x) (kindp x '$real) (numberp (numer x)))) + (t (free ($rectform x) '$%i)))) + ((eq '$complex y) t) + ((symbolp x) (kindp x y)))) + +(defun integerp (x) + (cond ((fixp x)) + ((mnump x) nil) + ((atom x) (kindp x '$integer)) + ((eq 'mrat (caar x)) (and (fixp (cadr x)) (equal 1 (cddr x)))) + ((memq (caar x) '(mtimes mplus)) (intp x)) + ((eq 'mexpt (caar x)) (intp-mexpt x)))) + +(defun intp (x) + (setq x (cdr x)) + (do () ((null x) t) + (cond ((integerp (car x)) (setq x (cdr x))) (t (return nil))))) + +(defun intp-mexpt (x) (and (fixp (caddr x)) (not (minusp (caddr x))) (integerp (cadr x)))) + + +(defun mevenp (x) + (cond ((fixp x) (not (oddp x))) + ((mnump x) nil) + (t (eq '$even (evod x))))) + +(defun moddp (x) + (cond ((fixp x) (oddp x)) + ((mnump x) nil) + (t (eq '$odd (evod x))))) + +(defun evod (x) + (cond ((fixp x) (cond ((oddp x) '$odd) (t '$even))) + ((mnump x) nil) + ((atom x) (cond ((kindp x '$odd) '$odd) ((kindp x '$even) '$even))) + ((eq 'mtimes (caar x)) (evod-mtimes x)) + ((eq 'mplus (caar x)) (evod-mplus x)) + ((eq 'mexpt (caar x)) (evod-mexpt x)))) + +(defun evod-mtimes (x) + (do ((l (cdr x) (cdr l)) (flag '$odd)) + ((null l) flag) + (setq x (evod (car l))) + (cond ((eq '$odd x)) + ((eq '$even x) (setq flag '$even)) + ((integerp (car l)) (cond ((eq '$odd flag) (setq flag nil)))) + (t (return nil))))) + +(defun evod-mplus (x) + (do ((l (cdr x) (cdr l)) (flag)) + ((null l) (cond (flag '$odd) (t '$even))) + (setq x (evod (car l))) + (cond ((eq '$odd x) (setq flag (not flag))) + ((eq '$even x)) + (t (return nil))))) + +(defun evod-mexpt (x) + (cond ((and (fixp (caddr x)) (not (minusp (caddr x)))) (evod (cadr x))))) + + +(declare (special mgqp mlqp)) + +(defmode cl () (atom (selector +labs) (selector -labs) (selector data))) +(defun c-dobj macro (x) `(list . ,(cdr x))) + +(defun dcompare (x y) + (setq odds (list (sub x y)) evens nil minus nil + sign (cond ((eq x y) '$zero) + ((or (eq '$inf x) (eq '$minf y)) '$pos) + ((or (eq '$minf x) (eq '$inf y)) '$neg) + (t (dcomp x y))))) + +(defun dcomp (x y) + (let (mgqp mlqp) + (setq x (dinternp x) y (dinternp y)) + (cond ((or (null x) (null y)) '$pnz) + ((progn (clear) (deq x y) (sel y +labs))) + (t '$pnz)))) + + +(defun deq (x y) + (cond ((dmark x '$zero) nil) + ((eq x y)) + (t (do l (sel x data) (cdr l) (null l) + (if (and (visiblep (car l)) (deqf x y (car l))) (return t)))))) + +(defun deqf (x y f) + (cond ((eq 'meqp (caar f)) + (if (eq x (cadar f)) (deq (caddar f) y) (deq (cadar f) y))) + ((eq 'mgrp (caar f)) + (if (eq x (cadar f)) (dgr (caddar f) y) (dls (cadar f) y))) + ((eq 'mgqp (caar f)) + (if (eq x (cadar f)) (dgq (caddar f) y) (dlq (cadar f) y))) + ((eq 'mnqp (caar f)) + (if (eq x (cadar f)) (dnq (caddar f) y) (dnq (cadar f) y))))) + +(defun dgr (x y) + (cond ((dmark x '$pos) nil) + ((eq x y)) + (t (do l (sel x data) (cdr l) (null l) + (if (or mlqp (and (visiblep (car l)) (dgrf x y (car l)))) (return t)))))) + +(defun dgrf (x y f) + (cond ((eq 'mgrp (caar f)) (if (eq x (cadar f)) (dgr (caddar f) y))) + ((eq 'mgqp (caar f)) (if (eq x (cadar f)) (dgr (caddar f) y))) + ((eq 'meqp (caar f)) + (if (eq x (cadar f)) (dgr (caddar f) y) (dgr (cadar f) y))))) + +(defun dls (x y) + (cond ((dmark x '$neg) nil) + ((eq x y)) + (t (do l (sel x data) (cdr l) (null l) + (if (or mgqp (and (visiblep (car l)) (dlsf x y (car l)))) (return t)))))) + +(defun dlsf (x y f) + (cond ((eq 'mgrp (caar f)) (if (eq x (caddar f)) (dls (cadar f) y))) + ((eq 'mgqp (caar f)) (if (eq x (caddar f)) (dls (cadar f) y))) + ((eq 'meqp (caar f)) + (if (eq x (cadar f)) (dls (caddar f) y) (dls (cadar f) y))))) + +(defun dgq (x y) + (cond ((memq (sel x +labs) '($pos $zero)) nil) + ((eq '$nz (sel x +labs)) (deq x y)) + ((eq '$pn (sel x +labs)) (dgr x y)) + ((dmark x '$pz) nil) + ((eq x y) (setq mgqp t) nil) + (t (do l (sel x data) (cdr l) (null l) + (if (and (visiblep (car l)) (dgqf x y (car l))) (return t)))))) + +(defun dgqf (x y f) + (cond ((eq 'mgrp (caar f)) (if (eq x (cadar f)) (dgr (caddar f) y))) + ((eq 'mgqp (caar f)) (if (eq x (cadar f)) (dgq (caddar f) y))) + ((eq 'meqp (caar f)) + (if (eq x (cadar f)) (dgq (caddar f) y) (dgq (cadar f) y))))) + +(defun dlq (x y) + (cond ((memq (sel x +labs) '($neg $zero)) nil) + ((eq '$pz (sel x +labs)) (deq x y)) + ((eq '$pn (sel x +labs)) (dgr x y)) + ((dmark x '$nz) nil) + ((eq x y) (setq mlqp t) nil) + (t (do l (sel x data) (cdr l) (null l) + (if (and (visiblep (car l)) (dlqf x y (car l))) (return t)))))) + +(defun dlqf (x y f) + (cond ((eq 'mgrp (caar f)) (if (eq x (caddar f)) (dls (cadar f) y))) + ((eq 'mgqp (caar f)) (if (eq x (caddar f)) (dlq (cadar f) y))) + ((eq 'meqp (caar f)) + (if (eq x (cadar f)) (dlq (caddar f) y) (dlq (cadar f) y))))) + +(defun dnq (x y) + (cond ((memq (sel x +labs) '($pos $neg)) nil) + ((eq '$pz (sel x +labs)) (dgr x y)) + ((eq '$nz (sel x +labs)) (dls x y)) + ((dmark x '$pn) nil) + ((eq x y) nil) + (t (do l (sel x data) (cdr l) (null l) + (if (and (visiblep (car l)) (dnqf x y (car l))) (return t)))))) + +(defun dnqf (x y f) + (cond ((eq 'meqp (caar f)) + (if (eq x (cadar f)) (dnq (caddar f) y) (dnq (cadar f) y))))) + + +(defun dmark (x m) + (cond ((eq m (sel x +labs))) + ((and dbtrace (PROG1 t (mtell "marking ~M ~M" + (if (atom x) x (car x)) + m)) + nil)) + (t (setq +labs (cons x +labs)) (_ (sel x +labs) m) nil))) + +(defun daddgr (flag x) + (let (lhs rhs) + (compsplt x) + (mdata flag 'mgrp (dintern lhs) (dintern rhs)) + (if (or (mnump lhs) (constant lhs)) + (list '(mlessp) rhs lhs) + (list '(mgreaterp) lhs rhs)))) + +(defun daddgq (flag x) + (let (lhs rhs) + (compsplt x) + (mdata flag 'mgqp (dintern lhs) (dintern rhs)) + (if (or (mnump lhs) (constant lhs)) + (list '(mleqp) rhs lhs) + (list '(mgeqp) lhs rhs)))) + +(defun daddeq (flag x) + (let (lhs rhs) + (compsplt-eq x) + (mdata flag 'meqp (dintern lhs) (dintern rhs)) + (list '($equal) lhs rhs))) + +(defun daddnq (flag x) + (let (lhs rhs) + (compsplt-eq x) + (cond ((and (mtimesp lhs) (equal rhs 0)) + (dolist (term (cdr lhs)) (daddnq flag term))) + ((and (mexptp lhs) (mexptp rhs) + (fixp (caddr lhs)) (fixp (caddr rhs)) + (equal (caddr lhs) (caddr rhs))) + (mdata flag 'mnqp (dintern (cadr lhs)) (dintern (cadr rhs))) + (cond ((not (oddp (caddr lhs))) + (mdata flag 'mnqp (dintern (cadr lhs)) + (dintern (neg (cadr rhs))))))) + (t (mdata flag 'mnqp (dintern lhs) (dintern rhs)))) + (list '(mnot) (list '($equal) lhs rhs)))) + +(defun tdpos (x) (daddgr t x) (setq locals (cons (cons x '$pos) locals))) + +(defun tdneg (x) (daddgr t (neg x)) (setq locals (cons (cons x '$neg) locals))) + +(defun tdzero (x) (daddeq t x) (setq locals (cons (cons x '$zero) locals))) + +(defun tdpn (x) (daddnq t x) (setq locals (cons (cons x '$pn) locals))) + +(defun tdpz (x) (daddgq t x) (setq locals (cons (cons x '$pz) locals))) + +(defun compsplt-eq (x) + (compsplt x) + (if (equal lhs 0) (setq lhs rhs rhs 0)) + (if (and (equal rhs 0) + (or (mexptp lhs) + (and (not (atom lhs)) + (kindp (caar lhs) '$oddfun) + (kindp (caar lhs) '$increasing)))) + (setq lhs (cadr lhs)))) + +(defun mdata (flag r x y) (if flag (mfact r x y) (mkill r x y))) + +(defun mfact (r x y) + (let ((f (datum (list r x y)))) + (cntxt f context) + (addf f x) + (addf f y))) + +(defun mkill (r x y) + (let ((f (car (datum (list r x y))))) + (kcntxt f context) + (remf f x) + (remf f y))) + +(defun mkind (x y) (kind (dintern x) (dintern y))) + +(defmfun rgrp (x y) + (cond ((or ($bfloatp x) ($bfloatp y)) + (setq x (let (($float2bf t)) (cadr ($bfloat (sub x y)))) y 0)) + ((numberp x) + (cond ((numberp y)) + (t (setq x (times x (caddr y)) y (cadr y))))) + ((numberp y) (setq y (times (caddr x) y) x (cadr x))) + (t (let ((dummy x)) + (setq x (times (cadr x) (caddr y))) + (setq y (times (caddr dummy) (cadr y)))))) + (cond ((greaterp x y) '$pos) + ((greaterp y x) '$neg) + (t '$zero))) + +(defun mcons (x l) (cons (car l) (cons x (cdr l)))) + +(defun flip (s) + (cond ((eq '$pos s) '$neg) + ((eq '$neg s) '$pos) + ((eq '$pz s) '$nz) + ((eq '$nz s) '$pz) + (t s))) + +(defun strongp (x y) + (cond ((eq '$pnz y)) + ((eq '$pnz x) nil) + ((memq y '($pz $nz $pn))))) + +(defun munformat (form) + (if (atom form) form (cons (caar form) (mapcar #'munformat (cdr form))))) + +(defmfun declarekind (var prop) ; This function is for $DECLARE to use. + (let (prop2) + (cond ((truep (list 'kind var prop)) t) + ((or (falsep (list 'kind var prop)) + (and (setq prop2 (assq prop '(($integer . $noninteger) + ($noninteger . $integer) + ($increasing . $decreasing) + ($decreasing . $increasing) + ($symmetric . $antisymmetric) + ($antisymmetric . $symmetric) + ($oddfun . $evenfun) + ($evenfun . $oddfun)))) + (truep (list 'kind var (cdr prop2))))) + (merror "Inconsistent Declaration: ~:M" `(($DECLARE) ,var ,prop))) + (t (mkind var prop) t)))) + +;;; These functions reformat expressions to be stored in the data base. + +(defun compsplt (x) + (cond ((or (atom x) (atom (car x))) (setq lhs x rhs 0)) + ((cdr (symbols x)) (compsplt2 x)) + (t (compsplt1 x)))) + +(defun compsplt1 (x) + (do ((exp (list x 0)) (success nil)) + ((or success (symbols (cadr exp))) (setq lhs (car exp) rhs (cadr exp))) + (cond ((atom (car exp)) (setq success t)) + ((eq (caaar exp) 'mplus) (setq exp (splitsum exp))) + ((eq (caaar exp) 'mtimes) (setq exp (splitprod exp))) + (t (setq success t))))) + +(defun compsplt2 (x) + (cond ((or (atom x) (atom (car x))) ; If x is an atom or a single level + (setq lhs x rhs 0)) ; list then we won't change it any. + ((negp x) ; If x is a negative expression but not a + (setq lhs 0 rhs (neg x))) ; sum, then get rid of the negative sign. + ((or (cdddr x) ; If x is not a sum, or is a sum + (not (eq (caar x) 'mplus)) ; with more than 2 terms, or has + (intersect* (symbols (cadr x)) (symbols (caddr x)))) + ; some symbols common to both summands, then do nothing. + (setq lhs x rhs 0)) + ((and (or (negp (cadr x)) (mnump (cadr x))) + (not (negp (caddr x)))) + (setq lhs (caddr x) rhs (neg (cadr x)))) + ((and (not (negp (cadr x))) + (or (negp (caddr x)) (mnump (caddr x)))) + (setq lhs (cadr x) rhs (neg (caddr x)))) + ((and (negp (cadr x)) (negp (caddr x))) + (setq lhs 0 rhs (neg x))) + (t (setq lhs x rhs 0)))) + +(defun negp (x) (and (mtimesp x) (mnegp (cadr x)))) + +(defun splitsum (exp) + (do ((list (cdar exp) (cdr list)) (lhs (car exp)) (rhs (cadr exp))) + ((null list) (if (mplusp lhs) (setq success t)) + (list lhs rhs)) + (cond ((memq '$inf list) (setq rhs (add2 '$inf (sub* rhs (addn list t))) + lhs (add2 '$inf (sub* lhs (addn list t))) + list nil)) + ((memq '$minf list) (setq rhs + (add2 '$minf (sub* rhs (addn list t))) + lhs + (add2 '$minf (sub* lhs (addn list t))) + list nil)) + ((null (symbols (car list))) (setq lhs (sub lhs (car list)) + rhs (sub rhs (car list))))))) + +(defun splitprod (exp) + (do ((flipsign) (lhs (car exp)) (rhs (cadr exp)) (list (cdar exp) (cdr list)) + (sign) (minus) (evens) (odds)) + ((null list) (if (mtimesp lhs) (setq success t)) + (cond (flipsign (compsplt (sub lhs rhs)) + (setq success t) + (list rhs lhs)) + (t (list lhs rhs)))) + (when (null (symbols (car list))) + (sign (car list)) + (if (eq sign '$neg) (setq flipsign (not flipsign))) + (if (memq sign '($pos $neg)) + (setq lhs (div lhs (car list)) rhs (div rhs (car list))))))) + +(defun symbols (x) + (let (($listconstvars %initiallearnflag)) (cdr ($listofvars x)))) + +;; %initiallearnflag is only necessary so that %PI, %E, etc. can be LEARNed. +(setq %initiallearnflag t) +(learn `((mequal) $%e ,(mget '$%e '$numer)) t) +(learn `((mequal) $%pi ,(mget '$%pi '$numer)) t) +(learn `((mequal) $%phi ,(mget '$%phi '$numer)) t) +(learn `((mequal) $%gamma ,(mget '$%gamma '$numer)) t) +(setq %initiallearnflag nil) + +(mapc #'TRUE* + '((par ($even $odd) $integer) + (kind $integer $rational) + (par ($rational $irrational) $real) + (par ($real $imaginary) $complex) + + (kind %log $increasing) + (kind %atan $increasing) (kind %atan $oddfun) + (kind $delta $evenfun) + (kind %sinh $increasing) (kind %sinh $oddfun) + (kind %cosh $posfun) + (kind %tanh $increasing) (kind %tanh $oddfun) + (kind %coth $oddfun) + (kind %csch $oddfun) + (kind %sech $posfun) + (kind $li $complex) + (kind %cabs $complex) + (kind $zeta $posfun))) + +($newcontext '$initial) ; Create an initial context for the user + ; which is a subcontext of $global. + \ No newline at end of file diff --git a/src/mrg/db.1149 b/src/mrg/db.1149 new file mode 100644 index 00000000..a4674383 --- /dev/null +++ b/src/mrg/db.1149 @@ -0,0 +1,710 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module db) + +(LOAD-MACSYMA-MACROS MRGMAC) + +;; This file uses its own special syntax which is set up here. The function +;; which does it is defined in LIBMAX;MRGMAC. It sets up <, >, and : for +;; structure manipulation. A major bug with this package is that the code is +;; almost completely uncommented. Someone with nothing better to do should go +;; through it, figure out how it works, and write it down. +;; Note: After recompiling all of macsyma for the Lispm it was found +;; that some files were compiled with the syntax of ":" set up +;; incorrectly. The (MODE-SYNTAX-OFF) function, which calls +;; undocumented system-internal routines evidently did not work anymore. +;; Therefore I removed the need for MODE-SYNTAX-ON from this file. +;; 7:57pm Thursday, 25 February 1982 -GJC + + +;; On systems which cons fixnums, a fixnum is used as a single label cell +;; and a pointer to the fixnum is passed around (i.e. the particular fixnum +;; is passed around. On systems which have immediate fixnums, a single cons +;; cell is created and the fixnum is stored in the car of the cell. Fixnums +;; are consed only in PDP-10 MacLisp and Franz Lisp. + +#+(OR PDP10 Franz) +(EVAL-WHEN (EVAL COMPILE) (SSTATUS FEATURE FIXCONS)) +#+NIL +(EVAL-WHEN (EVAL COMPILE) (SET-NOFEATURE 'FIXCONS)) + +(DECLARE (GENPREFIX DB) + ;; LAB is not a special. This declares all occurrences of LAB + ;; as a local or a parameter to be a fixnum. This should really + ;; be done using a LOCAL-DECLARE around the entire file so as to + ;; make sure any global compiler state gets undone. + #+FIXCONS (FIXNUM LAB) + (*LEXPR CONTEXT)) + +;; External specials +;; Please do not use DEFMVAR on these because some of them contain +;; circular list structure, and we want to be able to load in the +;; English version of the file at times. (DEFMVAR tries to print +;; out their values when the value in core is different from the +;; value in the file.) - JPG +;; Why don't you set PRINLEVEL and PRINLENGTH in your macsyma? -GJC + +(DEFVAR CONTEXT 'GLOBAL) +(DEFVAR CONTEXTS NIL) +(DEFVAR CURRENT 'GLOBAL) +(DEFVAR +LABS NIL) +(DEFVAR -LABS NIL) +(DEFVAR DBTRACE NIL) +(DEFVAR DBCHECK NIL) +(DEFVAR DOBJECTS NIL) +(DEFVAR NOBJECTS NIL) + +;; Internal specials + +(DEFVAR MARKS 0) (DECLARE (FIXNUM MARKS)) +(DEFVAR +L) (DECLARE (FIXNUM +L)) +(DEFVAR -L) (DECLARE (FIXNUM -L)) +(DEFVAR ULABS NIL) + +(DEFVAR CONINDEX 0) (DECLARE (FIXNUM CONINDEX)) +(DEFVAR CONNUMBER 50.) (DECLARE (FIXNUM CONNUMBER)) + +;; The most negative fixnum. On the PDP-10, this is 1_35. +(DEFVAR LAB-HIGH-BIT (ROT 1 -1)) +;; One less than the number of bits in a fixnum. On the PDP-10, this is 35. +(DEFVAR LABNUMBER (1- (HAULONG LAB-HIGH-BIT))) +;; A cell with the high bit turned on. +(DEFVAR LAB-HIGH-LAB #+FIXCONS LAB-HIGH-BIT #-FIXCONS (LIST LAB-HIGH-BIT)) + +(DECLARE (SPECIAL +S +SM +SL -S -SM -SL LABS LPRS LABINDEX LPRINDEX WORLD *)) + +;; Macro for indirecting through the contents of a cell. + +(DEFMACRO UNLAB (CELL) + #+FIXCONS CELL #-FIXCONS `(CAR ,CELL)) + +(DEFMACRO SETQ-UNLAB (CELL) + #+FIXCONS NIL + #-FIXCONS `(SETQ ,CELL (UNLAB ,CELL))) + +(DEFMACRO SETQ-COPYN (CELL) + #+FIXCONS NIL + #-FIXCONS `(SETQ ,CELL (COPYN ,CELL))) + +;; Conditionalize primitive functions used in this file. These are in +;; LAP for Lisp implementations which cons fixnums. This interface +;; is poorly designed since the meaning of COPYN is varies slightly +;; between systems. In one case it means "take a cell and produce a +;; new one with the same contents". In the other, it means "take an +;; immediate fixnum and return a cell containing it." As a result of +;; this, #+FIXCONS conditionalizations appear in the actual source code. + +#-FIXCONS +(PROGN 'COMPILE + (DEFMACRO COPYN (N) `(LIST ,N)) + (DEFMACRO IORM (CELL N) + `(RPLACA ,CELL (LOGIOR (CAR ,CELL) (CAR ,N)))) + (DEFMACRO XORM (CELL N) + `(RPLACA ,CELL (LOGXOR (CAR ,CELL) (CAR ,N)))) + ) + +;; The LAP for the PDP-10 version. + +#+PDP10 (LAP-A-LIST '( +(LAP COPYN SUBR) +(MOVE TT 0 A) +(JSP T FWCONS) +(POPJ P) +NIL + +(LAP IORM SUBR) +(MOVE B 0 B) +(IORM B 0 A) +(POPJ P) +NIL + +(LAP XORM SUBR) +(MOVE B 0 B) +(XORM B 0 A) +(POPJ P) +NIL )) + +#+Franz +(progn 'compile + (defmacro copyn (n) `(copyint* ,n)) + (defmacro iorm (cell n) `(replace ,cell (logior ,cell ,n))) + (defmacro xorm (cell n) `(replace ,cell (logxor ,cell ,n))) ) + +(DEFPROP GLOBAL 1 CMARK) + +(ARRAY CONUNMRK NIL (1+ CONNUMBER)) +(ARRAY CONMARK T (1+ CONNUMBER)) + +(DEFMFUN MARK (X) (PUTPROP X T 'MARK)) +(DEFMFUN MARKP (X) (AND (SYMBOLP X) (GET X 'MARK))) +(DEFMFUN UNMRK (X) (REMPROP X 'MARK)) +(DEFUN MARKS (X) (COND ((NUMBERP X)) ((ATOM X) (MARK X)) (T (MAPC #'MARKS X)))) +(DEFUN UNMRKS (X) + (COND ((NUMBERP X)) + ((OR (ATOM X) (NUMBERP (CAR X))) (UNMRK X)) + (T (MAPC #'UNMRKS X)))) + +(DEFMODE TYPE () + (ATOM (SELECTOR +LABS) (SELECTOR -LABS) (SELECTOR DATA)) + SELECTOR) +(DEFMODE INDV () + (ATOM (SELECTOR =LABS) (SELECTOR NLABS) (SELECTOR DATA) (SELECTOR IN)) + SELECTOR) +(DEFMODE UNIV () + (ATOM (SELECTOR =LABS) (SELECTOR NLABS) (SELECTOR DATA) (SELECTOR UN)) + SELECTOR) +(DEFMODE DATUM () + (ATOM (SELECTOR ULABS) (SELECTOR CON) (SELECTOR WN)) + SELECTOR) +(DEFMODE CONTEXT () + (ATOM (SELECTOR CMARK FIXNUM 0) (SELECTOR SUBC) (SELECTOR DATA))) + +;; Is (COPYN 0) really needed in these next four macros instead of simply 0? +;; If the fixnum were to get clobbered, then it would seem that (LIST 0) would +;; be the correct thing to return in the #-FIXCONS case. -cwh + +(DEFMACRO +LABZ (X) + `(COND ((+LABS ,X)) + (T #+FIXCONS (COPYN 0) #-FIXCONS '(0)))) + +(DEFMACRO -LABZ (X) + `(COND ((-LABS ,X)) + (T #+FIXCONS (COPYN 0) #-FIXCONS '(0)))) + +(DEFMACRO =LABZ (X) + `(COND ((=LABS ,X)) + (T #+FIXCONS (COPYN 0) #-FIXCONS '(0)))) + +(DEFMACRO NLABZ (X) + `(COND ((NLABS ,X)) + (T #+FIXCONS (COPYN 0) #-FIXCONS '(0)))) + +(DEFMACRO ULABZ (X) + `(COND ((ULABS ,X)) + (T #+FIXCONS 0 #-FIXCONS '(0)))) + +(DEFMACRO SUBP X + #-FIXCONS (SETQ X (MAPCAR #'(LAMBDA (FORM) `(UNLAB ,FORM)) X)) + `(= ,(CAR X) (LOGAND . ,X))) + +(DEFUN DBNODE (X) (IF (SYMBOLP X) X (LIST X))) +(DEFUN NODEP (X) (OR (ATOM X) (MNUMP (CAR X)))) +(DEFUN DBVARP (X) (GETL X '(UN EX))) + +;; Is this supposed to return a fixnum or a cell? + +(DEFUN LAB (N) (LSH 1 (1- N))) + +(DEFUN LPR (M N) + (COND ((DO L LPRS (CDR L) (NULL L) + (IF (AND (LABEQ M (CAAAR L)) (LABEQ N (CDAAR L))) + (RETURN (CDAR L))))) + ((= (SETQ LPRINDEX (1- LPRINDEX)) LABINDEX) (BREAK LPR T)) + (T (SETQ LPRS (CONS (CONS (CONS M N) (LSH 1 LPRINDEX)) LPRS)) + (CDAR LPRS)))) + +(DEFUN LABEQ (X Y) (EQUAL (LOGIOR X LAB-HIGH-BIT) (LOGIOR Y LAB-HIGH-BIT))) + +(DEFUN MARKND (ND) + (COND ((+LABS ND)) + ((= LPRINDEX (SETQ LABINDEX (1+ LABINDEX))) (BREAK MARKND T)) + (T (SETQ LABS (CONS (CONS ND (LAB LABINDEX)) LABS)) + (BEG ND (LAB LABINDEX)) + (CDAR LABS)))) + +(DEFUN DBV (X R) + (DECLARE (FIXNUM X R Y)) + (DO ((L LPRS (CDR L)) (Y 0)) ((NULL L) Y) + (IF (AND (NOT (= 0 (LOGAND R (CDAR L)))) (NOT (= 0 (LOGAND X (CAAAR L))))) + (SETQ Y (LOGIOR (CDAAR L) Y))))) + +(DEFUN DBA (R Y) + (DECLARE (FIXNUM X R Y)) + (DO ((L LPRS (CDR L)) (X 0)) ((NULL L) X) + (IF (AND (NOT (= 0 (LOGAND R (CDAR L)))) (NOT (= 0 (LOGAND (CDAAR L) Y)))) + (SETQ X (LOGIOR X (CAAAR L)))))) + +(DEFUN PRLAB (X) + (SETQ-UNLAB X) + (SETQ X (LET ((BASE 2)) (EXPLODEN (BOOLE 2 LAB-HIGH-BIT X)))) + (DO I (\ (LENGTH X) 3) 3 (NULL X) + (DO J I (1- J) (= 0 J) (TYO (CAR X)) (SETQ X (CDR X))) + (TYO #\SP))) + +(DEFUN ONP (CL LAB) (SUBP LAB (+LABZ CL))) +(DEFUN OFFP (CL LAB) (SUBP LAB (-LABZ CL))) +(DEFUN ONPU (LAB FACT) (SUBP LAB (ULABZ FACT))) +(DEFMFUN VISIBLEP (DAT) (AND (NOT (ULABS DAT)) (CNTP DAT))) + +(DEFUN CANCEL (LAB DAT) + (IF (SETQ * (ULABS DAT)) (IORM * LAB) + (SETQ ULABS (CONS DAT ULABS)) + (SETQ-UNLAB LAB) + (PUTPROP DAT (COPYN LAB) 'ULABS))) + +(DEFUN BEG (ND LAB) + (SETQ-COPYN LAB) + (IF (QUEUE+P ND LAB) + (IF (NULL +S) (SETQ +S (NCONS ND) +SM +S +SL +S) + (SETQ +S (CONS ND +S))))) + +(DEFUN BEG- (ND LAB) + (SETQ-COPYN LAB) + (IF (QUEUE-P ND LAB) + (IF (NULL -S) (SETQ -S (NCONS ND) -SM -S -SL -S) + (SETQ -S (CONS ND -S))))) + +(DEFUN MID (ND LAB) + (IF (QUEUE+P ND LAB) + (IF (NULL +SM) (SETQ +S (NCONS ND) +SM +S +SL +S) + (RPLACD +SM (CONS ND (CDR +SM))) + (IF (EQ +SM +SL) (SETQ +SL (CDR +SL))) + (SETQ +SM (CDR +SM))))) + +(DEFUN MID- (ND LAB) + (IF (QUEUE-P ND LAB) + (IF (NULL -SM) (SETQ -S (NCONS ND) -SM -S -SL -S) + (RPLACD -SM (CONS ND (CDR -SM))) + (IF (EQ -SM -SL) (SETQ -SL (CDR -SL))) + (SETQ -SM (CDR -SM))))) + +(DEFUN END (ND LAB) + (IF (QUEUE+P ND LAB) + (IF (NULL +SL) (SETQ +S (NCONS ND) +SM +S +SL +S) + (RPLACD +SL (NCONS ND)) + (SETQ +SL (CDR +SL))))) + +(DEFUN END- (ND LAB) + (IF (QUEUE-P ND LAB) + (IF (NULL -SL) (SETQ -S (NCONS ND) -SM -S -SL -S) + (RPLACD -SL (NCONS ND)) + (SETQ -SL (CDR -SL))))) + +(DEFUN QUEUE+P (ND LAB) + (COND ((NULL (SETQ * (+LABS ND))) + (SETQ +LABS (CONS ND +LABS)) + (SETQ-UNLAB LAB) + (PUT ND (COPYN (LOGIOR LAB-HIGH-BIT LAB)) '+LABS)) + ((SUBP LAB *) NIL) + ((SUBP LAB-HIGH-LAB *) (IORM * LAB) NIL) + (T (IORM * (LOGIOR LAB-HIGH-BIT (UNLAB LAB)))))) + +(DEFUN QUEUE-P (ND LAB) + (COND ((NULL (SETQ * (-LABS ND))) + (SETQ -LABS (CONS ND -LABS)) + (SETQ-UNLAB LAB) + (PUT ND (COPYN (LOGIOR LAB-HIGH-BIT LAB)) '-LABS)) + ((SUBP LAB *) NIL) + ((SUBP LAB-HIGH-LAB *) (IORM * LAB) NIL) + (T (IORM * (LOGIOR LAB-HIGH-BIT (UNLAB LAB)))))) + +(DEFUN DQ+ () + (IF +S (PROG2 (XORM (+LABS (CAR +S)) LAB-HIGH-LAB) + (CAR +S) + (COND ((NOT (EQ +S +SM)) (SETQ +S (CDR +S))) + ((NOT (EQ +S +SL)) (SETQ +S (CDR +S) +SM +S)) + (T (SETQ +S NIL +SM NIL +SL NIL)))))) + +(DEFUN DQ- () + (IF -S (PROG2 (XORM (-LABS (CAR -S)) LAB-HIGH-LAB) + (CAR -S) + (COND ((NOT (EQ -S -SM)) (SETQ -S (CDR -S))) + ((NOT (EQ -S -SL)) (SETQ -S (CDR -S) -SM -S)) + (T (SETQ -S NIL -SM NIL -SL NIL)))))) + +(DEFMFUN CLEAR () + (IF DBTRACE (MTELL "~%Clearing ~A" MARKS)) + (MAPC #'(LAMBDA (L) (_ (SEL L +LABS) NIL)) +LABS) + (MAPC #'(LAMBDA (L) (_ (SEL L -LABS) NIL)) -LABS) + (MAPC #'(LAMBDA (L) (REM L 'ULABS)) ULABS) + (SETQ +S NIL +SM NIL +SL NIL -S NIL -SM NIL -SL NIL + LABS NIL LPRS NIL LABINDEX 0 LPRINDEX LABNUMBER + MARKS 0 +LABS NIL -LABS NIL ULABS NIL) + (CONTEXTMARK)) + +(DEFMFUN TRUEP (PAT) + (CLEAR) + (COND ((ATOM PAT) PAT) + ((PROG2 (SETQ PAT (MAPCAR #'SEMANT PAT)) NIL)) + ((EQ (CAR PAT) 'KIND) (BEG (CADR PAT) 1) (BEG- (CADDR PAT) 1) (PROPG)) + (T (BEG (CADR PAT) 1) (BEG- (CADDR PAT) 2) (BEG (CAR PAT) (LPR 1 2)) (PROPG)))) + +(DEFMFUN FALSEP (PAT) + (CLEAR) + (COND ((EQ (CAR PAT) 'KIND) + (BEG (CADR PAT) 1) (BEG (CADDR PAT) 1) (PROPG)))) + +(DEFMFUN ISP (PAT) (COND ((TRUEP PAT)) ((FALSEP PAT) NIL) (T 'UNKNOWN))) + +(DEFMFUN KINDP (X Y) + (IF (NOT (SYMBOLP X)) (MERROR "KINDP called on a non-symbolic atom.")) + (CLEAR) (BEG X 1) + (DO P (DQ+) (DQ+) (NULL P) + (IF (EQ Y P) (RETURN T) (MARK+ P (+LABS P))))) + +(DEFMFUN TRUE* (PAT) + (LET ((DUM (SEMANT PAT))) (IF DUM (CNTXT (IND (NCONS DUM)) CONTEXT)))) + +(DEFMFUN FACT (FUN ARG VAL) (CNTXT (IND (DATUM (LIST FUN ARG VAL))) CONTEXT)) + +(DEFMFUN KIND (X Y) + (SETQ Y (DATUM (LIST 'KIND X Y))) (CNTXT Y CONTEXT) (ADDF Y X)) + +(DEFMFUN PAR (S Y) + (SETQ Y (DATUM (LIST 'PAR S Y))) (CNTXT Y CONTEXT) + (MAPC #'(LAMBDA (L) (ADDF Y L)) S)) + +(DEFMFUN DATUM (PAT) (NCONS PAT)) + +(DEFUN IND (DAT) + (MAPC #'(LAMBDA (L) (IND1 DAT L)) (CDAR DAT)) + (MAPC #'IND2 (CDAR DAT)) + DAT) + +(DEFUN IND1 (DAT PAT) + (COND ((NOT (NODEP PAT)) (MAPC #'(LAMBDA (L) (IND1 DAT L)) PAT)) + ((OR (MARKP PAT) (EQ 'UNKNOWN PAT))) + (T (ADDF DAT PAT) (MARK PAT)))) + +(DEFUN IND2 (ND) (IF (NODEP ND) (UNMRK ND) (MAPC #'IND2 ND))) + + +(DEFMFUN ADDF (DAT ND) (_ (SEL ND DATA) (CONS DAT (SEL ND DATA)))) +(DEFMFUN REMF (DAT ND) (_ (SEL ND DATA) (FDEL DAT (SEL ND DATA)))) + +(DEFUN FDEL (FACT DATA) + (IF (AND (EQ (CAR FACT) (CAAAR DATA)) + (EQ (CADR FACT) (CADAAR DATA)) + (EQ (CADDR FACT) (CADDAAR DATA))) + (CDR DATA) + (DO ((DS DATA (CDR DS)) (D)) ((NULL (CDR DS))) + (SETQ D (CAADR DS)) + (COND ((AND (EQ (CAR FACT) (CAR D)) + (EQ (CADR FACT) (CADR D)) + (EQ (CADDR FACT) (CADDR D))) + (_ (SEL D CON DATA) (DELQ D (SEL D CON DATA))) + (RPLACD DS (CDDR DS)) (RETURN T)))) + DATA)) + +(DEFUN SEMANTICS (PAT) (IF (ATOM PAT) PAT (LIST (SEMANT PAT)))) + +(DEFUN DB-MNUMP (X) + (OR (NUMBERP X) + (AND (NOT (ATOM X)) + (NOT (ATOM (CAR X))) + (MEMQ (CAAR X) '(RAT BIGFLOAT))))) + +(DEFUN SEMANT (PAT) + (COND ((SYMBOLP PAT) (OR (GET PAT 'VAR) PAT)) + ((DB-MNUMP PAT) (DINTNUM PAT)) + (T (MAPCAR #'SEMANT PAT)))) + +(DEFMFUN DINTERNP (X) + (COND ((MNUMP X) (DINTNUM X)) + ((ATOM X) X) + ((ASSOL X DOBJECTS)))) + +(DEFMFUN DINTERN (X) + (COND ((MNUMP X) (DINTNUM X)) + ((ATOM X) X) + ((ASSOL X DOBJECTS)) + (T (SETQ DOBJECTS (CONS (DBNODE X) DOBJECTS)) + (CAR DOBJECTS)))) + +(DEFUN DINTNUM (X) + (COND ((ASSOL X NOBJECTS)) + ((PROGN (SETQ X (DBNODE X)) NIL)) + ((NULL NOBJECTS) (SETQ NOBJECTS (LIST X)) X) + ((EQ '$POS (RGRP (CAR X) (CAAR NOBJECTS))) + (LET ((CONTEXT 'GLOBAL)) + (FACT 'MGRP X (CAR NOBJECTS))) + (SETQ NOBJECTS (CONS X NOBJECTS)) X) + (T (DO ((L NOBJECTS (CDR L)) (CONTEXT '$GLOBAL)) + ((NULL (CDR L)) + (LET ((CONTEXT 'GLOBAL)) + (FACT 'MGRP (CAR L) X)) (RPLACD L (LIST X)) X) + (COND ((EQ '$POS (RGRP (CAR X) (CAADR L))) + (LET ((CONTEXT 'GLOBAL)) + (FACT 'MGRP (CAR L) X) (FACT 'MGRP X (CADR L))) + (RPLACD L (CONS X (CDR L))) + (RETURN X))))))) + +(DEFMFUN DOUTERN (X) (IF (ATOM X) X (CAR X))) + +(DEFMFUN UNTRUE (PAT) + (KILL (CAR PAT) (SEMANT (CADR PAT)) (SEMANT (CADDR PAT)))) + +(DEFMFUN KILL (FUN ARG VAL) (KILL2 FUN ARG VAL ARG) (KILL2 FUN ARG VAL VAL)) + +(DEFUN KILL2 (FUN ARG VAL CL) + (COND ((NOT (ATOM CL)) (MAPC #'(LAMBDA (L) (KILL2 FUN ARG VAL L)) CL)) + ((NUMBERP CL)) + (T (_ (SEL CL DATA) (KILL3 FUN ARG VAL (SEL CL DATA)))))) + +(DEFUN KILL3 (FUN ARG VAL DATA) + (IF (AND (EQ FUN (CAAAR DATA)) + (EQ ARG (CADAAR DATA)) (EQ VAL (CADDAAR DATA))) + (CDR DATA) + (DO ((DS DATA (CDR DS)) (D)) ((NULL (CDR DS))) + (SETQ D (CAADR DS)) + (IF (NOT (AND (EQ FUN (CAR D)) + (EQ ARG (CADR D)) + (EQ VAL (CADDR D)))) + T + (_ (SEL D CON DATA) (DELQ D (SEL D CON DATA))) + (RPLACD DS (CDDR DS)) (RETURN T))) + DATA)) + +(DEFMFUN UNKIND (X Y) + (setq y (car (datum (LIST 'kind x y)))) + (kcntxt y context) + (remf y x)) + +(defmfun remov (fact) + (remov4 fact (cadar fact)) + (remov4 fact (caddar fact))) + +(defun remov4 (fact cl) + (cond ((or (symbolp cl) ;if CL is a symbol or + (and (listp cl) ;an interned number, then we want to REMOV4 FACT + (numberp (car cl)))) ;from its property list. + (_ (sel cl data) (delq fact (sel cl data)))) + ((or (atom cl) (atom (car cl)))) ;if CL is an atom (not a symbol) + ;or its CAR is an atom then we don't want to do + ;anything to it. + (t (mapc #'(lambda (l) (remov4 fact l)) + (cond ((atom (caar cl)) (cdr cl)) ;if CL's CAAR is + ;an atom, then CL is an expression, and + ;we want to REMOV4 FACT from the parts + ;of the expression. + ((atom (caaar cl)) (cdar cl))))))) + ;if CL's CAAAR is an atom, then CL is a + ;fact, and we want to REMOV4 FACT from + ;the parts of the fact. + +(DEFMFUN KILLFRAME (CL) + (MAPC #'REMOV (SEL CL DATA)) + (REMPROP CL '+LABS) (REMPROP CL '-LABS) + (REMPROP CL 'OBJ) (REMPROP CL 'VAR) + (REMPROP CL 'FACT) + (REMPROP CL 'WN)) + +(DEFMFUN ACTIVATE N + (DO I 1 (1+ I) (> I N) + (IF (MEMQ (ARG I) CONTEXTS) NIL + (SETQ CONTEXTS (CONS (ARG I) CONTEXTS)) + (CMARK (ARG I))))) + +(DEFMFUN DEACTIVATE N + (DO I 1 (1+ I) (> I N) + (IF (NOT (MEMQ (ARG I) CONTEXTS)) NIL + (CUNMRK (ARG I)) + (SETQ CONTEXTS (DELQ (ARG I) CONTEXTS))))) + +(DEFMFUN CONTEXT N (NEWCON (LISTIFY N))) + +(DEFUN NEWCON (C) + (IF (> CONINDEX CONNUMBER) (GCCON)) + (SETQ C (IF (NULL C) (LIST '*GC NIL) (LIST '*GC NIL 'SUBC C))) + #-LISPM (STORE (CONUNMRK CONINDEX) C) + #-LISPM (STORE (CONMARK CONINDEX) (CDR C)) + #+LISPM (SETF (AREF #'CONUNMRK CONINDEX) C) + #+LISPM (SETF (AREF #'CONMARK CONINDEX) (CDR C)) + (SETQ CONINDEX (1+ CONINDEX)) + C) + +;; To be used with the WITH-NEW-CONTEXT macro. +(DEFUN CONTEXT-UNWINDER () + (KILLC (CONMARK CONINDEX)) + (SETQ CONINDEX (1- CONINDEX)) + #-LISPM (STORE (CONUNMRK CONINDEX) ()) + #+LISPM (SETF (AREF #'CONUNMRK CONINDEX) ()) + ) + +(DEFUN GCCON () + (GCCON1) + (WHEN (> CONINDEX CONNUMBER) + #+GC (GC) + (GCCON1) + (WHEN (> CONINDEX CONNUMBER) + (MERROR "~%Too many contexts.")))) + +(DEFUN GCCON1 () + (SETQ CONINDEX 0) + (DO I 0 (1+ I) (> I CONNUMBER) + (IF (NOT (EQ (CONMARK I) (CDR (CONUNMRK I)))) + (KILLC (CONMARK I)) + #-LISPM (STORE (CONUNMRK CONINDEX) (CONUNMRK I)) + #+LISPM (SETF (AREF #'CONUNMRK CONINDEX) (CONUNMRK I)) + #-LISPM (STORE (CONMARK CONINDEX) (CONMARK I)) + #+LISPM (SETF (AREF #'CONMARK CONINDEX) (CONMARK I)) + (SETQ CONINDEX (1+ CONINDEX))))) + +(DEFMFUN CNTXT (DAT CON) + (IF (NOT (ATOM CON)) (SETQ CON (CDR CON))) + (PUT CON (CONS DAT (GET CON 'DATA)) 'DATA) + (IF (NOT (EQ 'GLOBAL CON)) (PUT DAT CON 'CON)) + DAT) + +(defmfun kcntxt (fact con) + (if (not (atom con)) (setq con (cdr con))) + (put con (fdel fact (get con 'data)) 'data) + (if (not (eq 'global con)) (rem fact 'con)) + fact) + +(DEFUN CNTP (F) + (COND ((NOT (SETQ F (SEL F CON)))) + ((SETQ F (GET F 'CMARK)) (> F 0)))) + +(DEFMFUN CONTEXTMARK () + (LET ((CON CONTEXT)) + (UNLESS (EQ CURRENT CON) + (CUNMRK CURRENT) (SETQ CURRENT CON) (CMARK CON)))) + +(DEFUN CMARK (CON) + (IF (NOT (ATOM CON)) (SETQ CON (CDR CON))) + (LET ((CM (GET CON 'CMARK))) + (PUTPROP CON (IF CM (1+ CM) 1) 'CMARK) + (MAPC #'CMARK (GET CON 'SUBC)))) + +(DEFUN CUNMRK (CON) + (IF (NOT (ATOM CON)) (SETQ CON (CDR CON))) + (LET ((CM (GET CON 'CMARK))) + (COND (CM (PUTPROP CON (1- CM) 'CMARK))) + (MAPC #'CUNMRK (GET CON 'SUBC)))) + +(DEFMFUN KILLC (CON) + (CONTEXTMARK) + (COND ((NOT (NULL CON)) + (MAPC #'REMOV (GET CON 'DATA)) + (REMPROP CON 'DATA) + (REMPROP CON 'CMARK) + (REMPROP CON 'SUBC))) + T) + +(DEFUN PROPG () + (DO ((X) (LAB)) (NIL) + (COND ((SETQ X (DQ+)) + (SETQ LAB (+LABS X)) + (IF (= 0 (LOGAND (UNLAB LAB) (UNLAB (-LABZ X)))) + (MARK+ X LAB) (RETURN T))) + ((SETQ X (DQ-)) + (SETQ LAB (-LABS X)) + (IF (= 0 (LOGAND (UNLAB LAB) (UNLAB (+LABZ X)))) + (MARK- X LAB) (RETURN T))) + (T (RETURN NIL))))) + +(DEFUN MARK+ (CL LAB) + (COND (DBTRACE (SETQ MARKS (1+ MARKS)) + (MTELL "~%Marking ~A +" CL) (PRLAB LAB))) + (MAPC #'(LAMBDA (L) (MARK+0 CL LAB L)) (SEL CL DATA))) + +(DEFUN MARK+0 (CL LAB FACT) + (COND (DBCHECK (MTELL "~%Checking ~A from ~A+" (CAR FACT) CL) (PRLAB LAB))) + (COND ((ONPU LAB FACT)) + ((NOT (CNTP FACT))) + ((NULL (SEL FACT WN)) (MARK+1 CL LAB FACT)) + ((ONP (SEL FACT WN) WORLD) (MARK+1 CL LAB FACT)) + ((OFFP (SEL FACT WN) WORLD) NIL) + (T (MARK+3 CL LAB FACT)))) + +(DEFUN MARK+1 (CL LAB DAT) + (COND ((EQ (CAAR DAT) 'KIND) + (IF (EQ (CADAR DAT) CL) (MID (CADDAR DAT) LAB))) ; E1 + ((EQ (CAAR DAT) 'PAR) + (IF (NOT (EQ (CADDAR DAT) CL)) + (PROGN (CANCEL LAB DAT) ; PR1 + (MID (CADDAR DAT) LAB) + (DO L (CADAR DAT) (CDR L) (NULL L) + (IF (NOT (EQ (CAR L) CL)) (MID- (CAR L) LAB)))))) + ((EQ (CADAR DAT) CL) + (IF (+LABS (CAAR DAT)) ; V1 + (END (CADDAR DAT) (DBV LAB (+LABS (CAAR DAT))))) + (IF (-LABS (CADDAR DAT)) ; F4 + (END- (CAAR DAT) (LPR LAB (-LABS (CADDAR DAT)))))))) + +(DEFUN MARK+3 (CL LAB DAT) CL LAB ;Ignored + (IFN (= 0 (LOGAND (UNLAB (+LABZ (CADDAR DAT))) + (UNLAB (DBV (+LABZ (CADAR DAT)) (-LABZ (CAAR DAT)))))) + (BEG- (SEL DAT WN) WORLD))) + +(DEFUN MARK- (CL LAB) + (WHEN DBTRACE + (SETQ MARKS (1+ MARKS)) (MTELL "Marking ~A -" CL) (PRLAB LAB)) + (MAPC #'(LAMBDA (L) (MARK-0 CL LAB L)) (SEL CL DATA))) + +(DEFUN MARK-0 (CL LAB FACT) + (WHEN DBCHECK (MTELL "~%Checking ~A from ~A-" (CAR FACT) CL) (PRLAB LAB)) + (COND ((ONPU LAB FACT)) + ((NOT (CNTP FACT))) + ((NULL (SEL FACT WN)) (MARK-1 CL LAB FACT)) + ((ONP (SEL FACT WN) WORLD) (MARK-1 CL LAB FACT)) + ((OFFP (SEL FACT WN) WORLD) NIL))) + +(DEFUN MARK-1 (CL LAB DAT) + (COND ((EQ (CAAR DAT) 'KIND) + (IF (NOT (EQ (CADAR DAT) CL)) (MID- (CADAR DAT) LAB))) ; E4 + ((EQ (CAAR DAT) 'PAR) + (IF (EQ (CADDAR DAT) CL) + (PROG2 (CANCEL LAB DAT) ; S4 + (DO L (CADAR DAT) (CDR L) (NULL L) (MID- (CAR L) LAB))) + (PROGN (SETQ-UNLAB LAB) ; ALL4 + (DO L (CADAR DAT) (CDR L) (NULL L) + (SETQ LAB (LOGAND (UNLAB (-LABZ (CAR L))) LAB))) + (SETQ-COPYN LAB) + (CANCEL LAB DAT) + (MID- (CADDAR DAT) LAB)))) + ((EQ (CADDAR DAT) CL) + (IF (+LABS (CAAR DAT)) ; A2 + (END- (CADAR DAT) (DBA (+LABS (CAAR DAT)) LAB))) + (IF (+LABS (CADAR DAT)) ; F6 + (END- (CAAR DAT) (LPR (+LABS (CADAR DAT)) LAB)))))) + +; in out in out ins in out +; ----------- ------------- ---------------- +; E1 | + INV1 | + AB1 |(+) + + +; E2 | - INV2 | - AB2 |(+) - + +; E3 | + INV3 | + AB3 |(+) + - +; E4 | - INV4 | - AB4 |(+) - - +; AB5 |(-) + + +; in out in out AB6 |(-) - + +; ----------- ------------- AB7 |(-) + - +; S1 | (+) ALL1 |(+) + AB8 |(-) - - +; S2 | (-) ALL2 |(+) - +; S3 |(+) ALL3 |(-) + +; S4 |(-) ALL4 |(-) - + + + +; in rel out in rel out in rel out +; --------------- --------------- --------------- +; V1 | (+) + A1 | + (+) F1 | + (+) +; V2 | (+) - A2 | - (+) F2 | + (-) +; V3 | (-) + A3 | + (-) F3 | - (+) +; V4 | (-) - A4 | - (-) F4 | - (-) +; F5 |(+) + +; F6 |(+) - +; F7 |(-) + +; F8 |(-) - + + +(DEFUN UNI (P1 P2 AL) + (COND ((DBVARP P1) (DBUNIVAR P1 P2 AL)) + ((NODEP P1) + (COND ((DBVARP P2) (DBUNIVAR P2 P1 AL)) + ((NODEP P2) (IF (EQ P1 P2) AL)))) + ((DBVARP P2) (DBUNIVAR P2 P1 AL)) + ((NODEP P2) NIL) + ((SETQ AL (UNI (CAR P1) (CAR P2) AL)) (UNI (CDR P1) (CDR P2) AL)))) + +(DEFUN DBUNIVAR (P V AL) + (LET ((DUM (ASSQ P AL))) + (COND ((NULL DUM) (CONS (CONS P V) AL)) + (T (UNI (CDR DUM) V AL))))) + +; Undeclarations for the file: + +(DECLARE (NOTYPE LAB)) + diff --git a/src/mrg/displa.780 b/src/mrg/displa.780 new file mode 100644 index 00000000..8f66f4e5 --- /dev/null +++ b/src/mrg/displa.780 @@ -0,0 +1,1589 @@ + +;; -*- Mode: Lisp; Package: Macsyma; -*- + +;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology +;; All Rights Reserved. + +;; Enhancements (c) Copyright 1983 Symbolics Inc. +;; All Rights Reserved. + +;; The data and information in the Enhancements is proprietary to, and +;; a valuable trade secret of, SYMBOLICS, INC., a Delaware corporation. +;; It is given in confidence by SYMBOLICS, and may not be used as the basis +;; of manufacture, or be reproduced or copied, or distributed to any other +;; party, in whole or in part, without the prior written consent of SYMBOLICS. + +(macsyma-module displa) + +;; N.B. You must read the macro file before reading this file. + +(load-macsyma-macros displm) + +;; Read time parameters. ITS only. + +#.(SETQ %TDCRL #O 207) +#.(SETQ %TDLF #O 212) +#.(SETQ %TDQOT #O 215) +#.(SETQ %TDMV0 #O 217) + +;; Global variables defined in this file. Most of these are switches +;; controlling display format + +(DEFMVAR CHARACTER-GRAPHICS-TTY NIL + "If T, then console can draw lines and math symbols using + an extended character set.") + +(DEFMVAR LINE-GRAPHICS-TTY NIL + "If T, then console can draw lines and math symbols using + vector graphics.") + +(DEFMVAR $CURSORDISP T + "If T, causes expressions to be drawn by the displayer in logical + sequence. This only works with a console which can do cursor + movement. + If NIL, expressions are simply printed line by line. + CURSORDISP is NIL when a WRITEFILE is in effect." + NO-RESET) + +(DEFMVAR $STARDISP NIL + "Causes factors of products are separated by * when displayed.") + +(DEFMVAR $LEFTJUST NIL + "Causes equations to be drawn left justified rather than centered. + For slow consoles.") + +(DEFMVAR $DISPLAY2D T + "Causes equations to be drawn in two dimensions. Otherwise, drawn + linearly.") + +(DEFMVAR $LISPDISP NIL + "Causes symbols not having $ as the first character in their pnames + to be preceded with a ? when displayed.") + +;; This may be flushed in the future if nobody dislikes the graphics crocks. + +(DEFMVAR $LINEDISP T + "Causes quotients, matrices, and boxes to be drawn with straight + lines, if possible. This will work on graphic terminals or + video terminals with line drawing character sets. If enabled, + the values of LMXCHAR, RMXCHAR, ABSBOXCHAR, and BOXCHAR are ignored.") + +(DEFMVAR $DERIVABBREV NIL) + +(DEFMVAR $NOUNDISP NIL) + +(DEFMVAR STRINGDISP NIL + "Causes strings to be bracketed in double quotes when displayed. + Normally this is off, but is turned on when a procedure definition is + being displayed.") +#+Franz +(defmvar $typeset nil + "Causes equations to be output in a typesetter readable form if t.") + +(DEFMVAR DISPLAYP NIL "Is T when inside of DISPLA") + +;; More messages which appear during the middle of display. Different +;; from those which appear during typein. MOREMSG and MOREFLUSH get +;; bound to these. + +(DEFVAR D-MOREMSG "--More Display?--") +(DEFVAR D-MOREFLUSH "--Display Flushed--") + +;; Parameters which control how boxes, absolute value signs, +;; evaluation-at-a-point bars, and matrices are drawn. + +(DEFMVAR $BOXCHAR '|&/"| + "Character used for drawing boxes.") +(DEFMVAR $ABSBOXCHAR '|&!| + "Character used for drawing absolute value signs and 'evaluation at' signs.") +(DEFMVAR $LMXCHAR '|&[| + "Character used for drawing the left edge of a matrix.") +(DEFMVAR $RMXCHAR '|&]| + "Character used for drawing the right edge of a matrix.") + +;; These variables are bound within Macsyma Listeners since they are different +;; for each window. Set them here, anyway, so that RETRIEVE can be called from +;; top level. The size of TOP-WINDOW is wired in here. + +#+LISPM (SETQ SMART-TTY T RUBOUT-TTY T LINE-GRAPHICS-TTY T + SCROLLP NIL) +#+LISPM (MULTIPLE-VALUE (LINEL TTYHEIGHT) + (FUNCALL TERMINAL-IO ':SIZE-IN-CHARACTERS)) + +;; Default settings for random systems. + +#-(OR ITS LISPM) +(SETQ SMART-TTY NIL RUBOUT-TTY NIL SCROLLP T + LINEL 79. $LINEL 79. TTYHEIGHT 24.) + +;;;Multics Lisp doesn't fully expand top level Macros. +(DEFVAR LINEARRAY #-Multics(MAKE-LINEARRAY 80.) + #+Multics (*array nil t 80.)) + +(DEFMFUN DISPLA (FORM) + (IF (OR (NOT #.TTYOFF) #.WRITEFILEP) + (cond #+Franz ($typeset (apply #'$photot (list form))) + ($DISPLAY2D + (LET ((DISPLAYP T) + (LINEARRAY (IF DISPLAYP (MAKE-LINEARRAY 80.) LINEARRAY)) + (MRATP (CHECKRAT FORM)) + (#.WRITEFILEP #.WRITEFILEP) + (MAXHT 1) (MAXDP 0) (WIDTH 0) + (HEIGHT 0) (DEPTH 0) (LEVEL 0) (SIZE 2) + (BREAK 0) (RIGHT 0) (LINES 1) BKPT + (BKPTWD 0) (BKPTHT 1) (BKPTDP 0) (BKPTOUT 0) + (BKPTLEVEL 0) IN-P + (MOREFLUSH D-MOREFLUSH) + MORE-^W + (MOREMSG D-MOREMSG)) + (UNWIND-PROTECT + (PROGN (SETQ FORM (DIMENSION FORM NIL 'MPAREN 'MPAREN 0 0)) + (CHECKBREAK FORM WIDTH) + (OUTPUT FORM (IF (AND (NOT $LEFTJUST) (= 2 LINES)) + (- LINEL (- WIDTH BKPTOUT)) + 0)) + (IF (AND SMART-TTY (NOT (AND SCROLLP (NOT $CURSORDISP))) + (> (CAR (CURSORPOS)) (- TTYHEIGHT 3))) + (LET (#.writefilep) (MTERPRI)))) + + + ;; make sure the linearray gets cleared out. + (CLEAR-LINEARRAY)))) + (T (LINEAR-DISPLA FORM))))) + +(DEFMVAR $DISPLAY_FORMAT_INTERNAL NIL + "Setting this TRUE can help give the user a greater understanding + of the behavior of macsyma on certain of his problems, + especially those involving roots and quotients") + +(DEFUN NFORMAT-CHECK (FORM) + (IF (AND $DISPLAY_FORMAT_INTERNAL + (NOT (OR (ATOM FORM) (ATOM (CAR FORM)) (SPECREPP FORM)))) + FORM + (NFORMAT FORM))) + +(DEFUN DIMENSION (FORM RESULT LOP ROP W RIGHT) + (LET ((LEVEL (1+ LEVEL)) (BREAK (IF (AND W BREAK) (+ W BREAK)))) + (SETQ FORM (NFORMAT-CHECK FORM)) + (COND ((ATOM FORM) + (DIMENSION-ATOM FORM RESULT)) + ((AND (ATOM (CAR FORM)) (SETQ FORM (CONS '(MPROGN) FORM)) NIL)) + ((OR (<= (LBP (CAAR FORM)) (RBP LOP)) (> (LBP ROP) (RBP (CAAR FORM)))) + (DIMENSION-PAREN FORM RESULT)) + ((MEMQ 'ARRAY (CAR FORM)) (DIMENSION-ARRAY FORM RESULT)) + ((GET (CAAR FORM) 'DIMENSION) + (FUNCALL (GET (CAAR FORM) 'DIMENSION) FORM RESULT)) + (T (DIMENSION-FUNCTION FORM RESULT))))) + +(DEFVAR ATOM-CONTEXT 'DIMENSION-LIST) +;; bound by DIMENSION-ARRAY and DIMENSION-FUNCTION. +;; This ATOM-CONTEXT put in by GJC so that MCW could have a clean +;; hook by which to write his extensions for vector-underbars. + +(DECLARE (*EXPR DIMENSION-ARRAY-OBJECT)) ; to be defined someplace else. + +;; Referenced externally by RAT;FLOAT. + +(DEFMFUN DIMENSION-ATOM (FORM RESULT) + (COND ((AND (SYMBOLP FORM) (GET FORM ATOM-CONTEXT)) + (FUNCALL (GET FORM ATOM-CONTEXT) FORM RESULT)) + #+LISPM + ((STRINGP FORM) (DIMENSION-STRING (MAKESTRING FORM) RESULT)) + ((ARRAYP FORM) + (DIMENSION-ARRAY-OBJECT FORM RESULT)) + (T (DIMENSION-STRING (MAKESTRING FORM) RESULT)))) + +;; Referenced externally by anyone who wants to display something as +;; a funny looking atom, e.g. Trace, Mformat. + +(DEFMFUN DIMENSION-STRING (DUMMY RESULT &AUX CRP) + ;; N.B. String is a list of fixnums. + (SETQ WIDTH 0 HEIGHT 1 DEPTH 0) + (DO L DUMMY (CDR L) (NULL L) + (INCREMENT WIDTH) + (IF (= (CAR L) #\NEWLINE) (SETQ CRP T))) + (IF (OR (AND (CHECKFIT WIDTH) (NOT CRP)) (NOT BREAK)) (NRECONC DUMMY RESULT) + (SETQ WIDTH 0) + (DO ((L DUMMY) (W (- LINEL (- BREAK BKPTOUT)))) + ((NULL L) (CHECKBREAK RESULT WIDTH) RESULT) + (SETQ DUMMY L L (CDR L)) + (COND ((= (CAR DUMMY) #\NEWLINE) + (FORCEBREAK RESULT WIDTH) + (SETQ RESULT NIL W (+ LINEL WIDTH))) + (T (INCREMENT WIDTH) + (WHEN (AND (= W WIDTH) L) + (FORCEBREAK (CONS #/# RESULT) WIDTH) + (SETQ RESULT NIL W (+ LINEL WIDTH)) + (INCREMENT WIDTH)) + (SETQ RESULT (RPLACD DUMMY RESULT))))))) + +(DEFMFUN MAKESTRING (ATOM) + (LET (DUMMY) + (COND ((NUMBERP ATOM) (EXPLODEN ATOM)) + #+NIL + ((NOT (SYMBOLP ATOM)) (EXPLODEN ATOM)) + ((AND (SETQ DUMMY (GET ATOM 'REVERSEALIAS)) + (NOT (AND (MEMQ ATOM $ALIASES) (GET ATOM 'NOUN)))) + (EXPLODEN DUMMY)) + ((NOT (EQ (GETOP ATOM) ATOM)) + (SETQ DUMMY (EXPLODEN (GETOP ATOM))) + (IF (= #/& (CAR DUMMY)) + (CONS #/" (NCONC (CDR DUMMY) (LIST #/"))) + (CDR DUMMY))) + (T (SETQ DUMMY (EXPLODEN ATOM)) + (COND ((NULL DUMMY) ()) + ((= #/$ (CAR DUMMY)) (CDR DUMMY)) + ((AND STRINGDISP (= #/& (CAR DUMMY))) + (CONS #/" (NCONC (CDR DUMMY) (LIST #/")))) + ((OR (= #/% (CAR DUMMY)) (= #/& (CAR DUMMY))) (CDR DUMMY)) + ($LISPDISP (CONS #/? DUMMY)) + (T DUMMY)))))) + +(DEFUN DIMENSION-PAREN (FORM RESULT) + (SETQ RESULT (CONS #/) (DIMENSION FORM (CONS #/( RESULT) 'MPAREN 'MPAREN 1 (1+ RIGHT)))) + (SETQ WIDTH (+ 2 WIDTH)) + RESULT) + +(DEFUN DIMENSION-ARRAY (X RESULT) + (PROG (DUMMY BAS W H D SUB) (DECLARE (FIXNUM W H D)) + (SETQ W 0) + (IF (EQ (CAAR X) 'MQAPPLY) (SETQ DUMMY (CADR X) X (CDR X)) + (SETQ DUMMY (CAAR X))) + (COND ((OR (NOT $NOUNDISP) (NOT (SYMBOLP (CAAR X))))) + ((AND (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS)) + (PUSH-STRING "''" RESULT) (SETQ W 2)) + ((AND (GET (CAAR X) 'NOUN) (NOT (MEMQ (CAAR X) (CDR $ALIASES))) + (NOT (GET (CAAR X) 'REVERSEALIAS))) + (SETQ RESULT (CONS #/' RESULT) W 1))) + (SETQ SUB (LET ((LOP 'MPAREN) (ROP 'MPAREN) (BREAK NIL) (SIZE 1)) + (DIMENSION-LIST X NIL)) + W (+ W WIDTH) H HEIGHT D DEPTH) + (SETQ BAS (IF (AND (NOT (ATOM DUMMY)) (MEMQ 'ARRAY (CAR DUMMY))) + (LET ((BREAK NIL) (RIGHT 0)) (DIMENSION-PAREN DUMMY RESULT)) + (LET ((ATOM-CONTEXT 'DIMENSION-ARRAY)) + (DIMENSION DUMMY RESULT LOP 'MFUNCTION NIL 0)))) + (COND ((NOT (CHECKFIT (SETQ WIDTH (+ W WIDTH)))) + (RETURN (DIMENSION-FUNCTION (CONS '(SUBSCRIPT) (CONS DUMMY (CDR X))) RESULT))) + ((= #/) (CAR BAS)) + (SETQ RESULT (CONS (CONS 0 (CONS (- H) SUB)) BAS) DEPTH (MAX (+ H D) DEPTH))) + (T (SETQ RESULT (CONS (CONS 0 (CONS (- (+ DEPTH H)) SUB)) BAS) + DEPTH (+ H D DEPTH)))) + (UPDATE-HEIGHTS HEIGHT DEPTH) + (RETURN RESULT))) + +(DEFUN DIMENSION-FUNCTION (X RESULT) + (PROG (FUN W H D) (DECLARE (FIXNUM W H D)) + (SETQ W 0) + (COND ((NOT $NOUNDISP)) + ((AND (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS)) + (PUSH-STRING "''" RESULT) (SETQ W 2)) + ((AND (GET (CAAR X) 'NOUN) (NOT (MEMQ (CAAR X) (CDR $ALIASES))) + (NOT (GET (CAAR X) 'REVERSEALIAS))) + (SETQ RESULT (CONS #/' RESULT) W 1))) + (IF (EQ (CAAR X) 'MQAPPLY) (SETQ FUN (CADR X) X (CDR X)) (SETQ FUN (CAAR X))) + (SETQ RESULT (LET ((ATOM-CONTEXT 'DIMENSION-FUNCTION)) + (DIMENSION FUN RESULT LOP 'MPAREN 0 1)) + W (+ W WIDTH) H HEIGHT D DEPTH) + (COND ((NULL (CDR X)) + (SETQ RESULT (LIST* #/) #/( RESULT) WIDTH (+ 2 W))) + (T (SETQ RESULT (LET ((LOP 'MPAREN) (ROP 'MPAREN) + (BREAK (IF BREAK (+ 1 W BREAK)))) + (CONS #/) (DIMENSION-LIST X (CONS #/( RESULT)))) + WIDTH (+ 2 W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH)))) + (RETURN RESULT))) + +(DEFMFUN DIMENSION-PREFIX (FORM RESULT) + (PROG (DISSYM SYMLENGTH) + (DECLARE (FIXNUM SYMLENGTH)) + (SETQ DISSYM (GET (CAAR FORM) 'DISSYM) SYMLENGTH (LENGTH DISSYM)) + (SETQ RESULT + (DIMENSION (CADR FORM) (RECONC DISSYM RESULT) (CAAR FORM) ROP SYMLENGTH RIGHT) + WIDTH (+ SYMLENGTH WIDTH)) + (RETURN RESULT))) + +(DEFUN DIMENSION-LIST (FORM RESULT) + (PROG (W H D) + (DECLARE (FIXNUM W H D)) + (SETQ RESULT (DIMENSION (CADR FORM) RESULT LOP 'MCOMMA 0 RIGHT) + W WIDTH H HEIGHT D DEPTH) + (DO L (CDDR FORM) (CDR L) (NULL L) + (PUSH-STRING ", " RESULT) + (INCREMENT W 2) + (CHECKBREAK RESULT W) + (SETQ RESULT (DIMENSION (CAR L) RESULT 'MCOMMA 'MCOMMA W RIGHT) + W (+ W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))) + (SETQ WIDTH W HEIGHT H DEPTH D) + (RETURN RESULT))) + +(DEFMFUN DIMENSION-INFIX (FORM RESULT) + (IF (OR (NULL (CDDR FORM)) (CDDDR FORM)) (WNA-ERR (CAAR FORM))) + (PROG (DISSYM SYMLENGTH W H D) + (DECLARE (FIXNUM SYMLENGTH W H D)) + (SETQ DISSYM (GET (CAAR FORM) 'DISSYM) SYMLENGTH (LENGTH DISSYM) + RESULT (DIMENSION (CADR FORM) RESULT LOP (CAAR FORM) 0 SYMLENGTH) + W WIDTH H HEIGHT D DEPTH) + (SETQ RESULT (RECONC DISSYM RESULT)) + (CHECKBREAK RESULT (+ SYMLENGTH W)) + (SETQ RESULT (DIMENSION (CADDR FORM) RESULT (CAAR FORM) ROP (+ SYMLENGTH W) RIGHT) + WIDTH (+ W SYMLENGTH WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH)) + (RETURN RESULT))) + +(DEFMFUN DIMENSION-NARY (FORM RESULT) + ;; If only 0 or 1 arguments, then print "*"() or "*"(A) + (COND ((NULL (CDDR FORM)) (DIMENSION-FUNCTION FORM RESULT)) + (T (PROG (DISSYM SYMLENGTH W H D) + (DECLARE (FIXNUM SYMLENGTH W H D)) + (SETQ DISSYM (GET (CAAR FORM) 'DISSYM) + SYMLENGTH (LENGTH DISSYM) + RESULT (DIMNARY (CADR FORM) RESULT LOP (CAAR FORM) (CAAR FORM) 0) + W WIDTH H HEIGHT D DEPTH) + (DO ((L (CDDR FORM) (CDR L))) (NIL) + (CHECKBREAK RESULT W) + (SETQ RESULT (RECONC DISSYM RESULT) W (+ SYMLENGTH W)) + (COND ((NULL (CDR L)) + (SETQ RESULT (DIMNARY (CAR L) RESULT (CAAR FORM) (CAAR FORM) ROP W) + WIDTH (+ W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH)) + (RETURN T)) + (T (SETQ RESULT (DIMNARY (CAR L) RESULT (CAAR FORM) + (CAAR FORM) (CAAR FORM) W) + W (+ W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))))) + (RETURN RESULT))))) + +;; Check for (* A (* B C)) --> A*(B*C) + +(DEFUN DIMNARY (FORM RESULT LOP OP ROP W) + (IF (AND (NOT (ATOM FORM)) (EQ (CAAR FORM) OP)) + (DIMENSION-PAREN FORM RESULT) + (DIMENSION FORM RESULT LOP ROP W RIGHT))) + +(DEFMFUN DIMENSION-POSTFIX (FORM RESULT) + (PROG (DISSYM SYMLENGTH) (DECLARE (FIXNUM SYMLENGTH)) + (SETQ DISSYM (GET (CAAR FORM) 'DISSYM) SYMLENGTH (LENGTH DISSYM)) + (SETQ RESULT (DIMENSION (CADR FORM) RESULT LOP (CAAR FORM) 0 (+ SYMLENGTH RIGHT)) + WIDTH (+ SYMLENGTH WIDTH)) + (RETURN (RECONC DISSYM RESULT)))) + +(DEFMFUN DIMENSION-NOFIX (FORM RESULT) + (SETQ FORM (GET (CAAR FORM) 'DISSYM) WIDTH (LENGTH FORM)) + (RECONC FORM RESULT)) + +(DEFUN DIMENSION-MATCH (FORM RESULT) + (PROG (DISSYM SYMLENGTH) + (DECLARE (FIXNUM SYMLENGTH)) + (SETQ DISSYM (GET (CAAR FORM) 'DISSYM) SYMLENGTH (LENGTH (CAR DISSYM))) + (COND ((NULL (CDR FORM)) + (SETQ WIDTH (+ SYMLENGTH (LENGTH (CDR DISSYM))) HEIGHT 1 DEPTH 0) + (RETURN (RECONC (CDR DISSYM) (RECONC (CAR DISSYM) RESULT)))) + (T (SETQ RESULT (LET ((LOP 'MPAREN) + (ROP 'MPAREN) + (BREAK (IF BREAK (+ SYMLENGTH BREAK))) + (RIGHT (+ SYMLENGTH RIGHT))) + (DIMENSION-LIST FORM (RECONC (CAR DISSYM) RESULT)))) + (SETQ WIDTH (+ (LENGTH (CDR DISSYM)) SYMLENGTH WIDTH)) + (RETURN (RECONC (CDR DISSYM) RESULT)))))) + +(DEFMFUN DIMENSION-SUPERSCRIPT (FORM RESULT) + (PROG (EXP W H D BAS) + (DECLARE (FIXNUM W H D W2 H2 D2)) + (SETQ EXP (LET ((SIZE 1)) (DIMENSION (CADDR FORM) NIL 'MPAREN 'MPAREN NIL 0)) + W WIDTH H HEIGHT D DEPTH) + (COND ((AND (NOT (ATOM (CADR FORM))) (MEMQ 'ARRAY (CDAADR FORM))) + (PROG (SUB W2 H2 D2) + (SETQ SUB (IF (EQ 'MQAPPLY (CAAADR FORM)) + (CDADR FORM) (CADR FORM))) + (SETQ SUB (LET ((LOP 'MPAREN) (BREAK NIL) (SIZE 1)) + (DIMENSION-LIST SUB NIL)) + W2 WIDTH H2 HEIGHT D2 DEPTH) + (SETQ BAS (DIMENSION (MOP (CADR FORM)) RESULT LOP 'MEXPT NIL 0)) + (WHEN (NOT (CHECKFIT (+ WIDTH (MAX W W2)))) + (SETQ RESULT (DIMENSION-FUNCTION (CONS '($EXPT) (CDR FORM)) RESULT)) + (RETURN RESULT)) + (SETQ RESULT (CONS (CONS 0 (CONS (+ HEIGHT D) EXP)) BAS)) + (SETQ RESULT (CONS (CONS (- W) (CONS (- (+ DEPTH H2)) SUB)) RESULT)) + (SETQ RESULT (CONS (LIST (- (MAX W W2) W2) 0) RESULT) + WIDTH (+ WIDTH (MAX W W2)) HEIGHT (+ H D HEIGHT) DEPTH (+ D2 H2 DEPTH))) + (UPDATE-HEIGHTS HEIGHT DEPTH) + (RETURN RESULT)) + ((AND (ATOM (CADDR FORM)) + (NOT (ATOM (CADR FORM))) + (NOT (GET (CAAADR FORM) 'DIMENSION)) + (PROG2 (SETQ BAS (NFORMAT-CHECK (CADR FORM))) + (NOT (GET (CAAR BAS) 'DIMENSION)))) + (RETURN (DIMENSION-FUNCTION + (LIST* '(MQAPPLY) (LIST '(MEXPT) (MOP BAS) (CADDR FORM)) (MARGS BAS)) + RESULT))) + (T (SETQ BAS (DIMENSION (CADR FORM) RESULT LOP 'MEXPT NIL 0) WIDTH (+ W WIDTH)) + (IF (NOT (CHECKFIT WIDTH)) + (RETURN (DIMENSION-FUNCTION (CONS '($EXPT) (CDR FORM)) RESULT))) + (IF (AND (NUMBERP (CAR BAS)) (= #/) (CAR BAS))) + (SETQ RESULT (CONS (LIST* 0 (1+ D) EXP) BAS) HEIGHT (MAX (+ 1 H D) HEIGHT)) + (SETQ RESULT (CONS (LIST* 0 (+ HEIGHT D) EXP) BAS) HEIGHT (+ H D HEIGHT))) + (UPDATE-HEIGHTS HEIGHT DEPTH) + (RETURN RESULT))))) + +(DEFUN DSUMPROD (FORM RESULT D-FORM SW SH SD) + (DECLARE (FIXNUM W H D SW SH SD)) + (PROG (DUMMY W H D DUMMY2) + (SETQ DUMMY2 (DIMENSION (CADDR FORM) NIL 'MPAREN 'MEQUAL NIL 0) + W WIDTH H HEIGHT D DEPTH) + (PUSH-STRING " = " DUMMY2) + (SETQ DUMMY2 (DIMENSION (CADDDR FORM) DUMMY2 'MEQUAL 'MPAREN NIL 0) + W (+ 3 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)) + (SETQ DUMMY (DIMENSION (CADR (CDDDR FORM)) NIL 'MPAREN 'MPAREN NIL 0)) + (COND ((NOT (CHECKFIT (MAX W WIDTH))) (RETURN (DIMENSION-FUNCTION FORM RESULT)))) + (SETQ DUMMY2 (CONS (CONS (- SW) (CONS (- (+ SD H)) DUMMY2)) (CONS D-FORM RESULT))) + (COND ((> WIDTH SW) (SETQ SW 0)) + (T (SETQ SW (// (- SW WIDTH) 2) WIDTH (+ SW WIDTH)))) + (SETQ DUMMY (CONS (CONS (- SW W) (CONS (+ SH DEPTH) DUMMY)) DUMMY2) + W (MAX W WIDTH) D (+ SD H D) H (+ SH HEIGHT DEPTH)) + (UPDATE-HEIGHTS H D) + (SETQ DUMMY (DIMENSION (CADR FORM) (CONS (LIST (1+ (- W WIDTH)) 0) DUMMY) + (CAAR FORM) ROP W RIGHT) + WIDTH (+ 1 W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH)) + (RETURN DUMMY))) + +(DISPLA-DEF BIGFLOAT DIM-BIGFLOAT) +(DISPLA-DEF MQUOTE DIMENSION-PREFIX "'") +(DISPLA-DEF MSETQ DIMENSION-INFIX " : ") +(DISPLA-DEF MSET DIMENSION-INFIX " :: ") +(DISPLA-DEF MDEFINE DIM-MDEFINE " := ") +(DISPLA-DEF MDEFMACRO DIM-MDEFINE " ::= ") + +(DEFUN DIM-MDEFINE (FORM RESULT) + (LET (($NOUNDISP T) (STRINGDISP T)) + (DIMENSION-INFIX (IF (CDDDR FORM) + (LIST (CAR FORM) (CADR FORM) (CONS '(MPROGN) (CDDR FORM))) + FORM) + RESULT))) + +(DISPLA-DEF MFACTORIAL DIMENSION-POSTFIX "!") +(DISPLA-DEF MEXPT DIMENSION-SUPERSCRIPT) +(DISPLA-DEF MNCEXPT DIM-MNCEXPT "^^") + +(DEFUN DIM-MNCEXPT (FORM RESULT) + (DIMENSION-SUPERSCRIPT (LIST '(MNCEXPT) (CADR FORM) (CONS '(MANGLE) (CDDR FORM))) + RESULT)) + +(DISPLA-DEF MNCTIMES DIMENSION-NARY " . ") + +(DISPLA-DEF %PRODUCT DIM-%PRODUCT 115.) + +(DEFUN DIM-%PRODUCT (FORM RESULT) (DSUMPROD FORM RESULT '(D-PRODSIGN) 5 3 1)) + +(DISPLA-DEF RAT DIM-RAT "//") + +(DEFUN DIM-RAT (FORM RESULT) + (IF $PFEFORMAT (DIMENSION-NARY FORM RESULT) (DIM-MQUOTIENT FORM RESULT))) + +(DISPLA-DEF MQUOTIENT DIM-MQUOTIENT "//") + +(DEFUN DIM-MQUOTIENT (FORM RESULT) + (IF (OR (NULL (CDDR FORM)) (CDDDR FORM)) (WNA-ERR (CAAR FORM))) + (PROG (NUM W H D DEN) + (DECLARE (FIXNUM W H D)) + (IF (AND (= 1 SIZE) (ATOM (CADR FORM)) (ATOM (CADDR FORM))) + (RETURN (DIMENSION-NARY FORM RESULT))) + (SETQ NUM (DIMENSION (CADR FORM) NIL 'MPAREN 'MPAREN NIL RIGHT) + W WIDTH H HEIGHT D DEPTH) + (IF (NOT (CHECKFIT W)) (RETURN (DIMENSION-NARY FORM RESULT))) + (SETQ DEN (DIMENSION (CADDR FORM) NIL 'MPAREN 'MPAREN NIL RIGHT)) + (IF (NOT (CHECKFIT WIDTH)) (RETURN (DIMENSION-NARY FORM RESULT))) + (RETURN (DRATIO RESULT NUM W H D DEN WIDTH HEIGHT DEPTH)))) + +;; <-- W1 --> +;; ------------------ +;; | ^ | +;; <- X1 -> | | H1 | +;; | | D1 | +;; | v | +;; ------------------ +;; ---------------------------------- +;; (Likewise for X2, H2, D2, W2 in the denominator) + +;; Hack to recycle slots on the stack. Compiler should be doing this. +;; Use different names to preserve sanity. +#.(PROG2 (SETQ X1 'H1 X2 'D2) T) + +(DEFUN DRATIO (RESULT NUM W1 H1 D1 DEN W2 H2 D2) + (DECLARE (FIXNUM W1 H1 D1 W2 H2 D2)) + (SETQ WIDTH (MAX W1 W2) HEIGHT (+ 1 H1 D1) DEPTH (+ H2 D2)) + (SETQ #.X1 (// (- WIDTH W1) 2) #.X2 (// (- WIDTH W2) 2)) + (UPDATE-HEIGHTS HEIGHT DEPTH) + (PUSH `(,#.X1 ,(1+ D1) . ,NUM) RESULT) + (PUSH `(,(- #.X2 (+ #.X1 W1)) ,(- H2) . ,DEN) RESULT) + (PUSH `(,(- 0 #.X2 W2) 0) RESULT) + (PUSH `(D-HBAR ,WIDTH) RESULT) + RESULT) + +(DISPLA-DEF MTIMES DIMENSION-NARY " ") + +;; This code gets run when STARDISP is assigned a value. + +(DEFPROP $STARDISP STARDISP ASSIGN) +(DEFUN STARDISP (SYMBOL VAL) + SYMBOL ;ignored -- always bound to $STARDISP + (PUTPROP 'MTIMES (IF VAL '(#/*) '(#\SP)) 'DISSYM)) + +(DISPLA-DEF %INTEGRATE DIM-%INTEGRATE 115.) + +(DEFUN DIM-%INTEGRATE (FORM RESULT) + (PROG (DUMMY W H D DUMMY2) + (DECLARE (FIXNUM W H D)) + (COND ((NULL (CDDR FORM)) (WNA-ERR (CAAR FORM))) + ((NULL (CDDDR FORM)) + (SETQ DUMMY `(#\SP (D-INTEGRALSIGN) . ,RESULT) W 2 H 3 D 2)) + (T (SETQ DUMMY (DIMENSION (CADR (CDDDR FORM)) NIL 'MPAREN 'MPAREN NIL 0) + W WIDTH H HEIGHT D DEPTH) + (SETQ DUMMY2 (DIMENSION (CADDDR FORM) NIL 'MPAREN 'MPAREN NIL 0)) + (IF (NOT (CHECKFIT (+ 2 (MAX W WIDTH)))) + (RETURN (DIMENSION-FUNCTION FORM RESULT))) + (SETQ DUMMY `((0 ,(+ 3 D) . ,DUMMY) (D-INTEGRALSIGN) . ,RESULT)) + (SETQ DUMMY (CONS (CONS (- W) (CONS (- (+ 2 HEIGHT)) DUMMY2)) DUMMY) + W (+ 2 (MAX W WIDTH)) H (+ 3 H D) D (+ 2 HEIGHT DEPTH) + DUMMY (CONS (LIST (- W 1 WIDTH) 0) DUMMY)))) + (UPDATE-HEIGHTS H D) + (SETQ DUMMY (DIMENSION (CADR FORM) DUMMY '%INTEGRATE 'MPAREN W 2) + W (+ W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)) + (PUSH-STRING " d" DUMMY) + (SETQ DUMMY (DIMENSION (CADDR FORM) DUMMY 'MPAREN ROP (+ 2 W) RIGHT) + WIDTH (+ 2 W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH)) + (RETURN DUMMY))) + +(DISPLA-DEF %DERIVATIVE DIM-%DERIVATIVE 125.) + +(DEFUN DIM-%DERIVATIVE (FORM RESULT) + (PROG () + (COND ((NULL (CDDR FORM)) + (RETURN (DIMENSION-FUNCTION (CONS '(%DIFF) (CDR FORM)) RESULT)))) + (COND ((NULL (CDDDR FORM)) (SETQ FORM (APPEND FORM '(1))))) + (COND ((AND $DERIVABBREV + (DO ((L (CDDR FORM) (CDDR L))) ((NULL L) T) + (COND ((AND (ATOM (CAR L)) (FIXP (CADR L)) (> (CADR L) 0))) + (T (RETURN NIL))))) + (RETURN (DMDERIVABBREV FORM RESULT))) + ((OR (> (RBP LOP) 130.) (> (LBP ROP) 130.) + (AND (NOT (ATOM (CADR FORM))) (OR (> (RBP LOP) 110.) (> (LBP ROP) 110.)))) + (RETURN (DIMENSION-PAREN FORM RESULT))) + (T (RETURN (DMDERIVLONG FORM RESULT)))))) + +(DEFUN DMDERIVABBREV (FORM RESULT) + (PROG (DUMMY W) (DECLARE (FIXNUM W)) + (SETQ W 0) + (DO ((L (CDDR FORM) (CDDR L)) (VAR)) + ((NULL L) (SETQ DUMMY (CDR DUMMY) W (1- W))) + (SETQ VAR (DIMENSION (CAR L) NIL 'MPAREN 'MPAREN NIL 0)) + (DO I (CADR L) (1- I) (= 1 I) (SETQ DUMMY (CONS #\SP (APPEND VAR DUMMY)))) + (SETQ DUMMY (CONS #\SP (NCONC VAR DUMMY)) W (+ W (CADR L) (* (CADR L) WIDTH)))) + (SETQ RESULT (DIMENSION (CADR FORM) RESULT LOP '%DERIV 0 RIGHT)) + (SETQ RESULT (CONS (CONS 0 (CONS (- 0 DEPTH 1) DUMMY)) RESULT) + WIDTH (+ W WIDTH) DEPTH (MAX 1 (1+ DEPTH))) + (UPDATE-HEIGHTS HEIGHT DEPTH) + (RETURN RESULT))) + +(DEFUN DMDERIVLONG (FORM RESULT) + (PROG (NUM W1 H1 D1 DEN W2 H2 D2) + (DECLARE (FIXNUM W1 H1 D1 W2 H2 D2)) + (SETQ NUM (LIST (CADDDR FORM)) + DEN (COND ((EQUAL 1 (CADDDR FORM)) (DIMENSION (CADDR FORM) (LIST #/d) 'MPAREN 'MPAREN NIL 0)) + (T (DIMENSION-SUPERSCRIPT (CONS '(DIFF) (CDDR FORM)) (LIST #/d)))) + W2 (1+ WIDTH) H2 HEIGHT D2 DEPTH) + (DO L (CDDDDR FORM) (CDDR L) (NULL L) + (SETQ NUM (CONS (CADR L) NUM) + DEN (COND ((EQUAL 1 (CADR L)) + (DIMENSION (CAR L) (CONS #/d (CONS #\SP DEN)) + 'MPAREN 'MPAREN NIL 0)) + (T (DIMENSION-SUPERSCRIPT + (CONS '(DIFF) L) (CONS #/d (CONS #\SP DEN))))) + W2 (+ 2 W2 WIDTH) H2 (MAX H2 HEIGHT) D2 (+ D2 DEPTH))) + (SETQ NUM (NFORMAT-CHECK (ADDN NUM T))) + (COND ((EQUAL 1 NUM) (SETQ NUM (LIST #/d) W1 1 H1 1 D1 0)) + (T (SETQ NUM (DIMENSION-SUPERSCRIPT (LIST '(DIFF) '|d| NUM) NIL) + W1 WIDTH H1 HEIGHT D1 DEPTH))) + (COND ((ATOM (SETQ FORM (NFORMAT-CHECK (CADR FORM)))) + (SETQ NUM (DIMENSION FORM NUM '%DERIV 'MPAREN NIL 0) W1 (+ W1 WIDTH)) + (RETURN (DRATIO RESULT NUM W1 H1 D1 DEN W2 H2 D2))) + (T (SETQ RESULT (DRATIO RESULT NUM W1 H1 D1 DEN W2 H2 D2) W1 WIDTH H1 HEIGHT D1 DEPTH) + (SETQ RESULT (DIMENSION FORM (CONS #\SP RESULT) '%DERIV ROP W1 RIGHT) + WIDTH (+ 1 W1 WIDTH) HEIGHT (MAX H1 HEIGHT) DEPTH (MAX D1 DEPTH)) + (UPDATE-HEIGHTS HEIGHT DEPTH) + (RETURN RESULT))))) + +(DISPLA-DEF %AT DIM-%AT 105. 105.) + +(DEFUN DIM-%AT (FORM RESULT) + (PROG (EXP W H D EQS) + (DECLARE (FIXNUM W H D)) + (IF (OR (NULL (CDDR FORM)) (CDDDR FORM)) (WNA-ERR (CAAR FORM))) + (SETQ EXP (DIMENSION (CADR FORM) RESULT LOP '%AT NIL 0) + W WIDTH H HEIGHT D DEPTH) + (SETQ EQS (DIMENSION (COND ((NOT (EQ 'MLIST (CAAR (CADDR FORM)))) (CADDR FORM)) + ((NULL (CDDR (CADDR FORM))) (CADR (CADDR FORM))) + (T (CONS '(MCOMMA) (CDADDR FORM)))) + NIL 'MPAREN 'MPAREN NIL 0)) + (COND ((NOT (CHECKFIT (+ 1 W WIDTH))) (RETURN (DIMENSION-FUNCTION FORM RESULT)))) + (SETQ RESULT (CONS (CONS 0 (CONS (- 0 1 D) EQS)) + (CONS `(D-VBAR ,(1+ H) ,(1+ D) ,(GETCHARN $ABSBOXCHAR 2)) EXP)) + WIDTH (+ 1 W WIDTH) HEIGHT (1+ H) DEPTH (+ 1 D DEPTH)) + (UPDATE-HEIGHTS HEIGHT DEPTH) + (RETURN RESULT))) + +(DISPLA-DEF MMINUS DIMENSION-PREFIX "- ") +(DISPLA-DEF MPLUS DIM-MPLUS) +(DEFPROP MUNARYPLUS (#/+ #\SP) DISSYM) + +(DEFUN DIM-MPLUS (FORM RESULT) + ;; If only 0 or 1 arguments, then print "+"() or +A + (COND ((AND (NULL (CDDR FORM)) + (NOT (MEMQ (CADAR FORM) '(TRUNC EXACT)))) + (IF (NULL (CDR FORM)) + (DIMENSION-FUNCTION FORM RESULT) + (DIMENSION-PREFIX (CONS '(MUNARYPLUS) (CDR FORM)) RESULT))) + (T (SETQ RESULT (DIMENSION (CADR FORM) RESULT LOP 'MPLUS 0 0)) + (CHECKBREAK RESULT WIDTH) + (DO ((L (CDDR FORM) (CDR L)) + (W WIDTH) (H HEIGHT) (D DEPTH) + (TRUNC (MEMQ 'TRUNC (CDAR FORM))) (DISSYM)) + ((NULL L) (COND (TRUNC (SETQ WIDTH (+ 8 W) HEIGHT H DEPTH D) + (PUSH-STRING " + . . ." RESULT))) + RESULT) + (DECLARE (FIXNUM W H D)) + (IF (MMMINUSP (CAR L)) + (SETQ DISSYM '(#\SP #/- #\SP) FORM (CADAR L)) + (SETQ DISSYM '(#\SP #/+ #\SP) FORM (CAR L))) + (COND ((AND (NOT TRUNC) (NULL (CDR L))) + (SETQ RESULT (DIMENSION FORM (APPEND DISSYM RESULT) + 'MPLUS ROP (+ 3 W) RIGHT) + WIDTH (+ 3 W WIDTH) + HEIGHT (MAX H HEIGHT) + DEPTH (MAX D DEPTH)) + (RETURN RESULT)) + (T (SETQ RESULT + (DIMENSION FORM (APPEND DISSYM RESULT) + 'MPLUS 'MPLUS (+ 3 W) 0) + W (+ 3 W WIDTH) + H (MAX H HEIGHT) + D (MAX D DEPTH)) + (CHECKBREAK RESULT W))))))) + +(DISPLA-DEF %SUM DIM-%SUM 110.) +(DISPLA-DEF %LIMIT DIM-%LIMIT 90. 90.) + +(DEFUN DIM-%SUM (FORM RESULT) (DSUMPROD FORM RESULT '(D-SUMSIGN) 4 3 2)) + +(DEFUN DIM-%LIMIT (FORM RESULT) + (PROG (DUMMY W H D) (DECLARE (FIXNUM W H D)) + (IF (NULL (CDDR FORM)) (RETURN (DIMENSION-FUNCTION FORM RESULT))) + (IF (NULL (CDDDR FORM)) (WNA-ERR (CAAR FORM))) + (SETQ DUMMY (DIMENSION (THIRD FORM) NIL 'MPAREN 'MPAREN NIL 0) + W WIDTH H HEIGHT D DEPTH) + (PUSH-STRING " -> " DUMMY) + (SETQ DUMMY (DIMENSION (FOURTH FORM) DUMMY 'MPAREN 'MPAREN NIL 0) + W (+ 4 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)) + (COND ((NULL (CDDDDR FORM))) + ((EQ '$PLUS (FIFTH FORM)) + (PUSH #/+ DUMMY) + (INCREMENT W)) + (T (PUSH #/- DUMMY) + (INCREMENT W))) + (PUSH-STRING "limit" RESULT) + (SETQ DUMMY (CONS (LIST* -5 (- H) DUMMY) RESULT) D (+ H D)) + (UPDATE-HEIGHTS 1 D) + (SETQ DUMMY (DIMENSION (CADR FORM) (CONS '(1 0) DUMMY) '%LIMIT ROP (1+ W) RIGHT)) + (SETQ WIDTH (+ 1 W WIDTH) DEPTH (MAX D DEPTH)) + (RETURN DUMMY))) + +;; Some scheme needs to be worked out to allow use of mathematical character +;; sets on consoles which have them. + +(DISPLA-DEF MARROW DIMENSION-INFIX " -> " 80. 80.) +(DISPLA-DEF MGREATERP DIMENSION-INFIX " > ") +(DISPLA-DEF MGEQP DIMENSION-INFIX " >= ") +(DISPLA-DEF MEQUAL DIMENSION-INFIX " = ") +(DISPLA-DEF MNOTEQUAL DIMENSION-INFIX " # ") +(DISPLA-DEF MLEQP DIMENSION-INFIX " <= ") +(DISPLA-DEF MLESSP DIMENSION-INFIX " < ") +(DISPLA-DEF MNOT DIMENSION-PREFIX "NOT ") +(DISPLA-DEF MAND DIMENSION-NARY " AND ") +(DISPLA-DEF MOR DIMENSION-NARY " OR ") +(DISPLA-DEF MCOND DIM-MCOND) + +(DEFUN DIM-MCOND (FORM RESULT) + (PROG (W H D) (DECLARE (FIXNUM W H D)) + (PUSH-STRING "IF " RESULT) + (SETQ RESULT (DIMENSION (CADR FORM) RESULT 'MCOND 'MPAREN 3 0) + W (+ 3 WIDTH) H HEIGHT D DEPTH) + (CHECKBREAK RESULT W) + (PUSH-STRING " THEN " RESULT) + (SETQ RESULT (DIMENSION (CADDR FORM) RESULT 'MCOND 'MPAREN (+ 6 W) 0) + W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)) + (UNLESS (EQ '$FALSE (FIFTH FORM)) + (CHECKBREAK RESULT W) + (PUSH-STRING " ELSE " RESULT) + (SETQ RESULT (DIMENSION (FIFTH FORM) RESULT 'MCOND ROP (+ 6 W) RIGHT) + W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))) + (SETQ WIDTH W HEIGHT H DEPTH D) + (RETURN RESULT))) + + +(DISPLA-DEF MDO DIM-MDO) + +(DEFUN DIM-MDO (FORM RESULT) + (PROG (W H D BRKFLAG) (DECLARE (FIXNUM W H D)) + (SETQ W 0 H 0 D 0) + (COND ((NOT (NULL (CADR FORM))) + (PUSH-STRING "FOR " RESULT) + (SETQ RESULT (CONS #\SP (DIMENSION (CADR FORM) RESULT 'MDO 'MPAREN 4 RIGHT)) + W (+ 4 WIDTH) H HEIGHT D DEPTH BRKFLAG T))) + (COND ((OR (NULL (CADDR FORM)) (EQUAL 1 (CADDR FORM)))) + (T (PUSH-STRING "FROM " RESULT) + (SETQ RESULT + (CONS #\SP (DIMENSION (CADDR FORM) RESULT 'MDO 'MPAREN (+ 6 W) 0)) + W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)))) + (SETQ FORM (CDDDR FORM)) + (COND ((EQUAL 1 (CAR FORM))) + ((NOT (NULL (CAR FORM))) + (PUSH-STRING "STEP " RESULT) + (SETQ RESULT (CONS #\SP (DIMENSION (CAR FORM) RESULT 'MDO 'MPAREN (+ 6 W) 0)) + W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))) + ((NOT (NULL (CADR FORM))) + (PUSH-STRING "NEXT " RESULT) + (SETQ RESULT (CONS #\SP (DIMENSION (CADR FORM) RESULT 'MDO 'MPAREN (+ 6 W) 0)) + W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)))) + (COND ((NOT (NULL (CADDR FORM))) + (PUSH-STRING "THRU " RESULT) + (SETQ RESULT (CONS #\SP (DIMENSION (CADDR FORM) RESULT 'MDO 'MPAREN (+ 6 W) 0)) + W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH) BRKFLAG T))) + (COND ((NOT (NULL (CADDDR FORM))) + (COND ((AND (NOT (ATOM (CADDDR FORM))) (EQ (CAAR (CADDDR FORM)) 'MNOT)) + (PUSH-STRING "WHILE " RESULT) + (SETQ RESULT + (CONS #\SP (DIMENSION (CADR (CADDDR FORM)) RESULT 'MDO 'MPAREN (+ 7 W) 0)) + W (+ 7 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH))) + (T (PUSH-STRING "UNLESS " RESULT) + (SETQ RESULT + (CONS #\SP (DIMENSION (CADDDR FORM) RESULT 'MDO 'MPAREN (+ 8 W) 0)) + W (+ 8 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)))))) + (IF BRKFLAG (CHECKBREAK RESULT W)) + (PUSH-STRING "DO " RESULT) + (SETQ RESULT (DIMENSION (CAR (CDDDDR FORM)) RESULT 'MDO ROP (+ 4 W) RIGHT) + WIDTH (+ 4 W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH)) + (RETURN RESULT))) + + +(DISPLA-DEF MDOIN DIM-MDOIN) + +(DEFUN DIM-MDOIN (FORM RESULT) + (PROG (W H D) (DECLARE (FIXNUM W H D)) + (PUSH-STRING "FOR " RESULT) + (SETQ RESULT (DIMENSION (CADR FORM) RESULT 'MDO 'MPAREN 4 0) + W (+ 4 WIDTH) H HEIGHT D DEPTH) + (PUSH-STRING " IN " RESULT) + (SETQ RESULT (DIMENSION (CADDR FORM) RESULT 'MDO 'MPAREN (+ 4 W) 0) + W (+ 4 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)) + (SETQ FORM (CDR (CDDDDR FORM))) + (COND ((NOT (NULL (CAR FORM))) + (PUSH-STRING " THRU " RESULT) + (SETQ RESULT (DIMENSION (CAR FORM) RESULT 'MDO 'MPAREN (+ 6 W) 0) + W (+ 6 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)))) + (COND ((NOT (NULL (CADR FORM))) + (PUSH-STRING " UNLESS " RESULT) + (SETQ RESULT (DIMENSION (CADR FORM) RESULT 'MDO 'MPAREN (+ 8 W) 0) + W (+ 8 W WIDTH) H (MAX H HEIGHT) D (MAX D DEPTH)))) + (PUSH-STRING " DO " RESULT) + (SETQ RESULT (DIMENSION (CADDR FORM) RESULT 'MDO ROP (+ 4 W) RIGHT) + WIDTH (+ 4 W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH)) + (RETURN RESULT))) + +(DISPLA-DEF MPROGN DIMENSION-MATCH "(" ")") +(DISPLA-DEF MLIST DIMENSION-MATCH "[" "]") +(DISPLA-DEF MANGLE DIMENSION-MATCH "<" ">") +(DISPLA-DEF MCOMMA DIMENSION-NARY ", " 20. 20.) +(DISPLA-DEF MABS DIM-MABS) + +(DEFUN DIM-MABS (FORM RESULT &AUX ARG BAR) + (SETQ ARG (DIMENSION (CADR FORM) NIL 'MPAREN 'MPAREN NIL 0)) + (COND ((OR (> (+ 2 WIDTH) LINEL) (AND (= 1 HEIGHT) (= 0 DEPTH))) + (DIMENSION-FUNCTION FORM RESULT)) + (T (SETQ WIDTH (+ 2 WIDTH)) + (UPDATE-HEIGHTS HEIGHT DEPTH) + (SETQ BAR `(D-VBAR ,HEIGHT ,DEPTH ,(GETCHARN $ABSBOXCHAR 2))) + (CONS BAR (NCONC ARG (CONS BAR RESULT)))))) + +(DISPLA-DEF $MATRIX DIM-$MATRIX) + +(DEFUN DIM-$MATRIX (FORM RESULT) + (PROG (DMSTR RSTR CSTR LISTP) + (IF (OR (NULL (CDR FORM)) + (NOT (MEMQ 'SIMP (CDAR FORM))) + (MEMALIKE '((MLIST SIMP)) (CDR FORM)) + (DOLIST (ROW (CDR FORM)) (IF (NOT ($LISTP ROW)) (RETURN T)))) + (RETURN (DIMENSION-FUNCTION FORM RESULT))) + (DO L (CDADR FORM) (CDR L) (NULL L) + (SETQ DMSTR (CONS NIL DMSTR) CSTR (CONS 0 CSTR))) + (DO ((R (CDR FORM) (CDR R)) (H1 0) (D1 0)) + ((OR LISTP (NULL R)) + (SETQ WIDTH 0) + (DO CS CSTR (CDR CS) (NULL CS) (SETQ WIDTH (+ 2 (CAR CS) WIDTH))) + (SETQ H1 (1- (+ H1 D1)) DEPTH (// H1 2) HEIGHT (- H1 DEPTH))) + (DECLARE (FIXNUM H1 D1)) + (DO ((C (CDAR R) (CDR C)) + (NC DMSTR (CDR NC)) + (CS CSTR (CDR CS)) (DUMMY) (H2 0) (D2 0)) + ((NULL C) (SETQ D1 (+ D1 H1 H2) H1 (1+ D2))) + (DECLARE (FIXNUM H2 D2)) + (SETQ DUMMY (DIMENSION (CAR C) NIL 'MPAREN 'MPAREN NIL 0) + H2 (MAX H2 HEIGHT) D2 (MAX D2 DEPTH)) + (COND ((NOT (CHECKFIT (+ 14. WIDTH))) (SETQ LISTP T) (RETURN NIL)) + (T (RPLACA NC (CONS (LIST* WIDTH HEIGHT DEPTH DUMMY) (CAR NC))) + (RPLACA CS (MAX WIDTH (CAR CS)))))) + (SETQ RSTR (CONS D1 RSTR))) + (IF (> (+ HEIGHT DEPTH) + (LINEARRAY-DIM) + ) + (SETQ LISTP T)) + (RETURN + (COND ((AND (NOT LISTP) (CHECKFIT (+ 2 WIDTH))) + (MATOUT DMSTR CSTR RSTR RESULT)) + ((AND (NOT LISTP) (<= LEVEL 2)) (COLOUT DMSTR CSTR RESULT)) + (T (DIMENSION-FUNCTION FORM RESULT)))))) + +(DEFUN MATOUT (DMSTR CSTR RSTR RESULT) + (PUSH `(D-MATRIX LEFT ,HEIGHT ,DEPTH) RESULT) + (PUSH #\SP RESULT) + (DO ((D DMSTR (CDR D)) (C CSTR (CDR C)) (W 0 0)) ((NULL D)) + (DECLARE (FIXNUM W)) + (DO ((D (CAR D) (CDR D)) (R RSTR (CDR R))) ((NULL D)) + (RPLACA (CDDAR D) (- HEIGHT (CAR R))) + (RPLACA (CDAR D) (- (// (- (CAR C) (CAAR D)) 2) W)) + (SETQ W (// (+ (CAR C) (CAAR D)) 2)) + (RPLACA D (CDAR D))) + (SETQ RESULT (CONS (LIST (+ 2 (- (CAR C) W)) 0) (NRECONC (CAR D) RESULT)))) + (SETQ WIDTH (+ 2 WIDTH)) + (UPDATE-HEIGHTS HEIGHT DEPTH) + (RPLACA (CAR RESULT) (1- (CAAR RESULT))) + (PUSH `(D-MATRIX RIGHT ,HEIGHT ,DEPTH) RESULT) + RESULT) + +(DEFUN COLOUT (DMSTR CSTR RESULT) + (SETQ WIDTH 0 HEIGHT 1 DEPTH 0) + (DO ((R DMSTR (CDR R)) (C CSTR (CDR C)) (COL 1 (1+ COL)) (W 0 0) (H -1 -1) (D 0)) + ((NULL R)) + (DECLARE (FIXNUM COL W H D)) + (PUSH-STRING " Col " RESULT) + (SETQ RESULT (NRECONC (EXPLODEN COL) RESULT)) + (PUSH-STRING " = " RESULT) + (SETQ WIDTH (+ 8 (FLATC COL) WIDTH)) + (DO ((R (CAR R) (CDR R))) ((NULL R)) + (SETQ H (+ 1 H (CADAR R) (CADDAR R))) + (RPLACA (CDDAR R) (- H (CADAR R))) + (RPLACA (CDAR R) (- (// (- (CAR C) (CAAR R)) 2) W)) + (SETQ W (// (+ (CAR C) (CAAR R)) 2)) + (RPLACA R (CDAR R))) + (SETQ D (// H 2) H (- H D)) + (PUSH `(D-MATRIX LEFT ,H ,D) RESULT) + (PUSH #\SP RESULT) + (PUSH `(0 ,(- D) . ,(NREVERSE (CAR R))) RESULT) + (PUSH `(,(1+ (- (CAR C) W)) 0) RESULT) + (PUSH `(D-MATRIX RIGHT ,H ,D) RESULT) + (SETQ WIDTH (+ 4 (CAR C) WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH)) + (UPDATE-HEIGHTS H D) + (CHECKBREAK RESULT WIDTH)) + RESULT) + +(DISPLA-DEF MBOX DIM-MBOX) + +(DEFUN DIM-MBOX (FORM RESULT &AUX DUMMY) + (SETQ DUMMY (DIMENSION (CADR FORM) NIL 'MPAREN 'MPAREN NIL 0)) + (COND ((NOT (CHECKFIT (+ 2 WIDTH))) + (DIMENSION-FUNCTION (CONS '($BOX) (CDR FORM)) RESULT)) + (T (PUSH `(D-BOX ,HEIGHT ,DEPTH ,WIDTH ,(NREVERSE DUMMY)) RESULT) + (SETQ WIDTH (+ 2 WIDTH) HEIGHT (1+ HEIGHT) DEPTH (1+ DEPTH)) + (UPDATE-HEIGHTS HEIGHT DEPTH) + RESULT))) + +(DISPLA-DEF MLABOX DIM-MLABOX) + +(DEFUN DIM-MLABOX (FORM RESULT) + (PROG (DUMMY CH) + (SETQ DUMMY (DIMENSION (CADR FORM) NIL 'MPAREN 'MPAREN NIL 0)) + (COND ((NOT (CHECKFIT (+ 2 WIDTH))) + (RETURN (DIMENSION-FUNCTION (CONS '($BOX) (CDR FORM)) RESULT)))) + (SETQ WIDTH (+ 2 WIDTH) HEIGHT (1+ HEIGHT) DEPTH (1+ DEPTH)) + (SETQ CH (GETCHARN $BOXCHAR 2)) + (SETQ RESULT + (CONS (DO ((L (MAPCAR #'(LAMBDA (L) (GETCHARN L 1)) + (MAKSTRING (CADDR FORM))) (CDR L)) + (W 0) (NL)) + ((OR (NULL L) (= WIDTH W)) + (CONS 0 (CONS (1- HEIGHT) + (COND ((< W WIDTH) + (CONS `(D-HBAR ,(- WIDTH W) ,CH) NL)) + (T NL))))) + (DECLARE (FIXNUM W)) + (SETQ NL (CONS (CAR L) NL) W (1+ W))) + RESULT)) + (SETQ RESULT (NCONC DUMMY (LIST* `(D-VBAR ,(1- HEIGHT) ,(1- DEPTH) ,CH) + (LIST (- WIDTH) 0) RESULT))) + (SETQ RESULT (CONS (LIST (- 1 WIDTH) (- DEPTH) `(D-HBAR ,WIDTH ,CH)) RESULT)) + (SETQ RESULT (LIST* `(D-VBAR ,(1- HEIGHT) ,(1- DEPTH) ,CH) '(-1 0) RESULT)) + (UPDATE-HEIGHTS HEIGHT DEPTH) + (RETURN RESULT))) + +(DISPLA-DEF MTEXT DIM-MTEXT 1 1) + +(DEFUN DIM-MTEXT (FORM RESULT) + (IF (NULL (CDDR FORM)) (DIMENSION (CADR FORM) RESULT LOP ROP 0 0) + (DIMENSION-NARY FORM RESULT))) + +(DISPLA-DEF MLABLE DIM-MLABEL 0 0) + +(DEFUN DIM-MLABEL (FORM RESULT) + (PROG (DUMMY W H D) (DECLARE (FIXNUM W H D)) + (COND ((EQ NIL (CADR FORM)) (SETQ W 0 H 0 D 0)) + (MRATP (SETQ RESULT (APPEND MRATP (DIMENSION-PAREN (CADR FORM) RESULT)) + W (+ 4 WIDTH) H HEIGHT D DEPTH)) + (T (SETQ RESULT (CONS #\SP (DIMENSION-PAREN (CADR FORM) RESULT)) + W (1+ WIDTH) H HEIGHT D DEPTH))) + (LET ((LEVEL LINEL)) (CHECKBREAK RESULT W)) + (SETQ DUMMY (LIST 0 0)) + (SETQ RESULT (DIMENSION (CADDR FORM) (CONS DUMMY RESULT) 'MLABLE ROP W RIGHT)) + (COND ((AND (NOT $LEFTJUST) (= 0 BKPTOUT)) + (RPLACA DUMMY (MAX 0 (- (// (- LINEL WIDTH) 2) W))) + (SETQ WIDTH (+ (CAR DUMMY) WIDTH)))) + (SETQ WIDTH (+ W WIDTH) HEIGHT (MAX H HEIGHT) DEPTH (MAX D DEPTH)) + (RETURN RESULT))) + +(DEFPROP MPAREN -1. LBP) +(DEFPROP MPAREN -1. RBP) + +(DEFUN CHECKRAT (FORM) + (COND ((ATOM FORM) NIL) + ((AND (NOT (ATOM (CAR FORM))) (EQ (CAAR FORM) 'MRAT)) + (IF (MEMQ 'TRUNC (CDAR FORM)) '(#\SP #// #/T #//) + '(#\SP #// #/R #//))) + ((AND (NOT (ATOM (CAR FORM))) (EQ (CAAR FORM) 'MPOIS)) + '(#\SP #// #/P #//)) + (T (DO L (CDR FORM) (CDR L) (NULL L) + (COND ((ATOM L) + (MERROR "~S has an atomic cdr - DISPLAY" FORM)) + ((SETQ FORM (CHECKRAT (CAR L))) (RETURN FORM))))))) + +(DEFUN CHECKFIT (W) + (DECLARE (FIXNUM W)) + (OR (NOT BREAK) (<= (- (+ W BREAK RIGHT 1) BKPTWD) LINEL))) + +(DEFUN CHECKBREAK (RESULT W) + (DECLARE (FIXNUM W)) + (COND ((NOT BREAK)) + ((> (- (SETQ W (+ W BREAK)) BKPTOUT) LINEL) + (IF (OR (NULL BKPT) (EQ RESULT BKPT)) + (MERROR "Expression is too wide to be displayed.")) + (DO ((L RESULT (CDR L))) ((EQ BKPT (CDR L)) (RPLACD L NIL)) + (IF (NULL L) (MERROR "CHECKBREAK not found in DISPLAY"))) + (OUTPUT BKPT 0) + #-Franz (LET ((#.TTYOFF (OR #.TTYOFF MORE-^W))) (MTERPRI)) + + (SETQ LINES (1+ LINES) BKPT RESULT BKPTOUT BKPTWD BKPTWD W + BKPTHT MAXHT BKPTDP MAXDP BKPTLEVEL LEVEL MAXHT 1 MAXDP 0)) + ((OR (NULL BKPT) (<= LEVEL BKPTLEVEL) (> (// LINEL 2) (- BKPTWD BKPTOUT))) + (SETQ BKPT RESULT BKPTWD W BKPTLEVEL LEVEL + BKPTHT (MAX MAXHT BKPTHT) BKPTDP (MAX MAXDP BKPTDP) MAXHT 1 MAXDP 0)))) + +(DEFUN FORCEBREAK (RESULT W) + (OUTPUT RESULT 0) (MTERPRI) + (SETQ LINES (+ 2 LINES) BKPT NIL BKPTOUT (+ W BREAK) MAXHT 1 MAXDP 0)) + +(DEFUN UPDATE-HEIGHTS (HT* DP*) + (DECLARE (FIXNUM HT* DP*)) + (IF BREAK (SETQ MAXHT (MAX MAXHT HT*) MAXDP (MAX MAXDP DP*)))) + +;;; BKPT dimension structure for last breakpoint saved +;;; BKPTWD width at last bkpt +;;; BKPTHT height of current line to last bkpt +;;; BKPTDP depth of current line to last bkpt +;;; BKPTOUT width of stuff already output + +;;; MAXHT height from last bkpt saved to current point +;;; MAXDP depth from last bkpt saved to current point + +;;; BREAK width up to last call to DIMENSION +;;; RESULT dimension structure to current point minus output +;;; W width from last call to DIMENSION to current point + +;; Code above this point deals with dimensioning and constructing +;; up dimension strings. Code past this point deals with printing +;; them. + +;; ::= () | ( . ) +;; ::= character | +;; ( . ) | +;; ( . args) +;; ::= +;; ::= +;; ::= D-HBAR | D-VBAR | D-INTEGRALSIGN | ... + +;; When a character appears in a dimension string, it is printed and +;; the cursor moves forward a single position. (The variable OLDCOL is +;; incremented) When a form with a fixnum car is encountered, the +;; first two elements of the form are taken to be relative displacements +;; for OLDCOL and OLDROW. *** NOTE *** After drawing the cddr of the form, +;; OLDROW is reset to its original value, but OLDCOL is left in the new +;; position. Why this is done is beyond me. It only appears to complicate +;; things. + +;; There are two basic output functions. OUTPUT-2D draws equations in the same +;; order they are dimensioned, and OUTPUT-LINEAR draws equations line by line. +;; When a is invoked, the first argument passed to it is a +;; flag which is T for linear output and NIL for 2D output. A +;; is also expected to return the new column position. + +(DEFUN OUTPUT (RESULT W) + (DECLARE (FIXNUM W)) + (IF (NOT (OR #.ttyoff MORE-^W (ZEROP (CHARPOS T)))) (MTERPRI)) + (IF (AND (NOT (OR #.ttyoff MORE-^W)) + SMART-TTY (NOT (AND SCROLLP (NOT $CURSORDISP))) + (< (+ BKPTHT BKPTDP) (1- TTYHEIGHT)) + ;;If (STATUS TTY) is NIL, then we don't have the console. + #+PDP10 (STATUS TTY) + (> (+ BKPTHT BKPTDP) (- (1- TTYHEIGHT) (CAR (CURSORPOS))))) + (MORE-FUN T)) + (COND + ;; If output is turned off to the console and no WRITEFILE is taking + ;; place, then don't output anything. + ((AND (OR #.ttyoff MORE-^W) (NOT #.writefilep))) + ;; If the terminal can't do cursor movement, or we are writing + ;; to a WRITEFILE (#.writefilep is on) or the terminal is scrolling or + ;; something else random, then draw equations line by line. + ((> (+ BKPTHT BKPTDP) 80.) + (MERROR "Expression is too high to be displayed.")) + ((OR (NOT (AND SMART-TTY $CURSORDISP)) + #.writefilep SCROLLP (> (+ BKPTHT BKPTDP) (- TTYHEIGHT 2))) + (OUTPUT-LINEAR (NREVERSE RESULT) W)) + ;; Otherwise, draw equations in the same order as they are dimensioned. + (T (OUTPUT-2D (NREVERSE RESULT) W)))) + +;; Output function for terminals without cursor positioning capability. +;; Characters are drawn into LINEARRAY instead. Each element of LINEARRAY is a +;; list -- the car is how many spaces to indent; the cdr is a list of +;; characters to draw. After drawing into this array, lines are printed one at +;; a time. This is used for printing terminals and when writing to files. +;; Block mode i/o isn't needed since PRINC is used instead of TYO and +;; CURSORPOS. + +(DEFUN OUTPUT-LINEAR (RESULT W) + (DECLARE (FIXNUM W)) + (DRAW-LINEAR RESULT BKPTDP W) + (DO (#+PDP10 (TERPRI T) (I (1- (+ BKPTHT BKPTDP)) (1- I))) + ((< I 0)) + (DECLARE (FIXNUM I)) + (COND ((NULL (LINEARRAY I))) + (MORE-^W (SAFE-PRINT (OUTPUT-LINEAR-ONE-LINE I))) + (T (OUTPUT-LINEAR-ONE-LINE I))))) + +(DEFUN OUTPUT-LINEAR-ONE-LINE (I) (DECLARE (FIXNUM I N)) + (PROG (LINE N) + (SETQ LINE (LINEARRAY I) LINE (NREVERSE (CDR LINE)) N (CAR LINE)) + (SET-LINEARRAY I NIL) + (TYOTBSP N) + ;; This is inefficient. Should cons up a string if possible. + (PRINC (MAKNAM (CDR LINE))) + (MTERPRI))) + +;; Move the cursor over N spaces to the left by outputting tabs and spaces. +;; This function assumes that the cursor is in the left margin when +;; it is called. This is only called from OUTPUT-LINEAR, so it is +;; used only for printing terminals or for file output. + +(DEFUN TYOTBSP (N) + (DECLARE (FIXNUM N)) + (DO () ((< N (TABLEN))) (TYO #\TAB) (DECREMENT N (TABLEN))) + (DO () ((< N 1)) (TYO #\SP) (DECREMENT N))) + +(DEFUN DRAW-LINEAR (DMSTR OLDROW OLDCOL) + (DO ((LINE)) ((NULL DMSTR)) + (COND ((ATOM (CAR DMSTR)) + (SETQ LINE (LINEARRAY OLDROW)) + (COND ((NULL LINE) (SETQ LINE (LIST OLDCOL))) + (T (PROG (N) (DECLARE (FIXNUM N M)) + (SETQ N (CAR LINE) LINE (CDR LINE)) + (DO ((M (+ (TABLEN) (* (TABLEN) (// N (TABLEN)))) + (+ (TABLEN) M))) + ((NOT (< M OLDCOL)) (SETQ N (MAX N (- M (TABLEN))))) + (SETQ LINE (CONS #\TAB LINE))) + (DO () ((= OLDCOL N)) + (PUSH #\SP LINE) + (INCREMENT N))))) + (DO () ((OR (NULL DMSTR) (NOT (ATOM (CAR DMSTR)))) + (SET-LINEARRAY OLDROW (CONS OLDCOL LINE))) + (INCREMENT OLDCOL) + (PUSH (CAR DMSTR) LINE) + (POP DMSTR))) + ((FIXP (CAAR DMSTR)) + ;; Why update OLDCOL and not OLDROW? Should either update both + ;; (requiring multiple value return) or neither (analagous to lambda + ;; binding). + (SETQ OLDCOL (DRAW-LINEAR (REVERSE (CDDAR DMSTR)) + (+ OLDROW (CADAR DMSTR)) + (+ OLDCOL (CAAR DMSTR)))) + (POP DMSTR)) + (T (SETQ OLDCOL (LEXPR-FUNCALL (CAAR DMSTR) T (CDAR DMSTR))) + (POP DMSTR)))) + ;; Be sure to return this. + OLDCOL) + + +;; Output function for terminals with cursor positioning capability. Draws +;; equations in the order they are dimensioned. To be efficient, it does block +;; mode i/o into a stream called DISPLAY-FILE, set up in ALJABR;LOADER. +;; This function is not used if a WRITEFILE is taking place. + +;; TTY interrupts are turned off for some reason, probably to protect global +;; state. + +;; Bug in COMPLR necessitates binding H to 0 initially. +;; (PROG (H) (DECLARE (FIXNUM H)) ...) doesn't try binding it to NIL as +;; this does. + +#+ITS +(DEFUN OUTPUT-2D (RESULT W &AUX (H 0)) + (DECLARE (FIXNUM W H CH)) + (UNWIND-PROTECT + (PROGN (TTYINTSOFF) + (SETQ OLDROW (CAR (CURSORPOS)) OLDCOL 0 H (+ OLDROW BKPTHT BKPTDP)) + ;; Move the cursor to the left edge of the screen. + (CURSORPOS* OLDROW 0) + ;; Then print CRLFs from the top of the expression to the bottom. + ;; The purpose of this is to clear the appropriate section of the + ;; screen. If RUBOUT-TTY is NIL (i.e. we are using a storage tube + ;; display), then only print LFs since the entire screen is cleared + ;; anyway. %TDCRL = carriage return, line feed. %TDLF = line feed. + (DO ((CH (IF RUBOUT-TTY #.%TDCRL #.%TDLF))) ((= H OLDROW)) + (TYO* CH) (INCREMENT OLDROW)) + (DRAW-2D RESULT (- OLDROW BKPTDP 1) W) + ;; Why is this necessary? Presumably, we never go off the bottom + ;; of the screen. + (SETQ H (MIN (- TTYHEIGHT 2) H)) + ;; Leave the cursor at the bottom of the expression. + (CURSORPOS* H 0) + ;; Output is buffered for efficiency. + (FORCE-OUTPUT DISPLAY-FILE) + ;; Let ITS know where the cursor is now. This does not do + ;; cursor movement. :CALL SCPOS for information. + (SETCURSORPOS H 0) + ;; Gobble any characters the poor user may have typed during display. + (LISTEN)) + (TTYINTSON)) + (NOINTERRUPT NIL)) + +;; I/O is much simpler on the Lisp Machine. + +#+LISPM +(DEFUN OUTPUT-2D (RESULT W &AUX H) + (DECLARE (FIXNUM W H CH)) + (SETQ OLDROW (CAR (CURSORPOS)) OLDCOL 0 H (+ OLDROW BKPTHT BKPTDP)) + (CURSORPOS* OLDROW 0) + ;; Move the cursor vertically until we are at the bottom line of the + ;; new expression. + (DO () ((= H OLDROW)) (TYO* #\NEWLINE) (INCREMENT OLDROW)) + (DRAW-2D RESULT (- OLDROW BKPTDP 1) W) + (CURSORPOS* (SETQ H (MIN (- TTYHEIGHT 2) H)) 0)) + +;; For now, cursor movement is only available on ITS and the Lisp +;; Machine. But define this to catch possible errors. + +#-(OR LISPM ITS) +(DEFUN OUTPUT-2D (RESULT W) + RESULT W ;Ignored. + (MERROR "OUTPUT-2D called on system without display support.")) + +#+(OR LISPM ITS) +(DEFUN DRAW-2D (DMSTR ROW COL) + (DECLARE (FIXNUM ROW COL)) + (CURSORPOS* ROW COL) + (DO ((L DMSTR)) ((NULL L)) + (COND ((FIXP (CAR L)) (TYO* (CAR L)) (POP L)) + ((FIXP (CAAR L)) + (SETQ COL OLDCOL) + (DO () ((OR (FIXP (CAR L)) (NOT (FIXP (CAAR L))))) + (IF (NULL (CDDAR L)) (SETQ COL (+ COL (CAAR L))) + (DRAW-2D (REVERSE (CDDAR L)) + (- ROW (CADAR L)) (+ COL (CAAR L))) + (SETQ COL OLDCOL)) + (POP L)) + (CURSORPOS* ROW COL)) + (T (LEXPR-FUNCALL (CAAR L) NIL (CDAR L)) + (POP L))))) + +#-(OR LISPM ITS) +(DEFUN DRAW-2D (DMSTR ROW COL) + DMSTR ROW COL ;Ignored. + (MERROR "DRAW-2D called on system without display support.")) + + +;; Crude line graphics. The interface to a graphics device is via the +;; functions LG-SET-POINT, LG-DRAW-VECTOR, LG-END-VECTOR and via the +;; LG-CHARACTER specials. LG-END-VECTOR is needed since many consoles +;; (including those supporting ARDS protocol) must "exit" graphics mode. +;; LG-CHARACTER-X and LG-CHARACTER-Y give the width and height of a character +;; in pixels, and the -2 variables are simply those numbers divided by 2. LG +;; stands for "Line Graphics". See MAXSRC;ARDS for a sample ctl. + +(DECLARE (*EXPR LG-SET-POINT LG-DRAW-VECTOR LG-END-VECTOR) + #-NIL + (NOTYPE (LG-SET-POINT FIXNUM FIXNUM) + (LG-DRAW-VECTOR FIXNUM FIXNUM) + (LG-END-VECTOR FIXNUM FIXNUM)) + (SPECIAL LG-CHARACTER-X LG-CHARACTER-X-2 + LG-CHARACTER-Y LG-CHARACTER-Y-2)) + +;; Make this work in the new window system at some point. + +#+LISPM (PROGN 'COMPILE + +(DECLARE (SPECIAL LG-OLD-X LG-OLD-Y)) + +(DEFUN LG-SET-POINT (X Y) + (SETQ LG-OLD-X (- X 1) LG-OLD-Y (- Y 2))) + +(DEFUN LG-DRAW-VECTOR (X Y) + (SETQ X (- X 1) Y (- Y 2)) + (FUNCALL STANDARD-OUTPUT ':DRAW-LINE LG-OLD-X LG-OLD-Y X Y) + (WHEN (> LG-CHARACTER-Y 20) + (LET ((DELTA-X (- X LG-OLD-X)) + (DELTA-Y (- Y LG-OLD-Y))) + (IF (> (ABS DELTA-X) (ABS DELTA-Y)) + (FUNCALL STANDARD-OUTPUT ':DRAW-LINE LG-OLD-X (1- LG-OLD-Y) X (1- Y)) + (FUNCALL STANDARD-OUTPUT ':DRAW-LINE (1- LG-OLD-X) LG-OLD-Y (1- X) Y)))) + (SETQ LG-OLD-X X LG-OLD-Y Y)) + +;; Set these so that DISPLA can be called from top-level. The size +;; of TERMINAL-IO is wired in here. +;; These should be bound at time of call to DISPLA. + +(SETQ LG-CHARACTER-X (FUNCALL TERMINAL-IO ':CHAR-WIDTH)) +(SETQ LG-CHARACTER-Y (FUNCALL TERMINAL-IO ':LINE-HEIGHT)) + +(SETQ LG-CHARACTER-X-2 (// LG-CHARACTER-X 2)) +(SETQ LG-CHARACTER-Y-2 (// LG-CHARACTER-Y 2)) + +) ;; End of Lispm Graphics definitions. + +;; Even cruder character graphics. Interface to the ctl is via functions +;; which draw lines and corners. CG means "Character Graphics". See +;; MAXSRC;VT100 for a sample ctl. Note that these functions do not modify +;; the values of OLDROW and OLDCOL. + +(DECLARE (*EXPR CG-BEGIN-GRAPHICS CG-END-GRAPHICS + CG-UL-CORNER CG-UR-CORNER CG-LL-CORNER CG-LR-CORNER + CG-VERTICAL-BAR CG-HORIZONTAL-BAR + CG-D-SUMSIGN CG-D-PRODSIGN)) + +;; Special form for turning on and turning off character graphics. +;; Be sure to turn of character graphics if we throw out of here. + +;; (DEFMACRO CG-WITH-GRAPHICS (&BODY BODY) +;; `(UNWIND-PROTECT (PROGN (CG-BEGIN-GRAPHICS) . ,BODY) (CG-END-GRAPHICS))) +;; Not needed after all. - JPG + +;; Special symbol drawing functions -- lines, boxes, summation signs, etc. +;; Every drawing function must take at least one argument. The first +;; argument is T if equations must be printed line-by-line. Otherwise, +;; draw them using cursor movement, character graphics, or line graphics +;; if possible. + +;; Most of these functions just invoke DRAW-XXX on some constant +;; list structure, so be careful about NREVERSEing. In other cases, +;; stuff is consed only for the linear case, but direct calls are used +;; in the 2D case. This should work for both cases. (See end of +;; program.) + +(DEFUN D-HBAR (LINEAR? W &OPTIONAL (CHAR #/-) &AUX NL) + (DECLARE (FIXNUM W CHAR GY)) + (COND (LINEAR? (DOTIMES (I W) (PUSH CHAR NL)) + (DRAW-LINEAR NL OLDROW OLDCOL)) + ((AND LINE-GRAPHICS-TTY $LINEDISP) + (LET ((GY (+ (* LG-CHARACTER-Y OLDROW) LG-CHARACTER-Y-2))) + (LG-SET-POINT (* OLDCOL LG-CHARACTER-X) GY) + (LG-END-VECTOR (* (+ OLDCOL W) LG-CHARACTER-X) GY)) + (CURSORPOS* OLDROW (+ OLDCOL W))) + ((AND CHARACTER-GRAPHICS-TTY $LINEDISP) + (CG-BEGIN-GRAPHICS) + (DOTIMES (I W) (CG-HORIZONTAL-BAR)) + (INCREMENT OLDCOL W) + (CG-END-GRAPHICS)) + (T (DOTIMES (I W) (TYO* CHAR))))) + +;; Notice that in all of the height computations, an offset of 2 is added or +;; subtracted to the y-dimension. This is to get the lines to fit within the +;; character cell precisely and not get clipped when moving things around in +;; the equation editor. + +(DEFUN D-VBAR (LINEAR? H D &OPTIONAL (CHAR #/|)) + (DECLARE (FIXNUM H D CHAR GX)) + (COND (LINEAR? (SETQ D (- D)) + (DO ((I (- H 2) (1- I)) + (NL `((0 ,(1- H) ,CHAR)))) + ((< I D) (DRAW-LINEAR (NREVERSE NL) OLDROW OLDCOL)) + (PUSH `(-1 ,I ,CHAR) NL))) + ((AND LINE-GRAPHICS-TTY $LINEDISP) + (LET ((GX (+ (* LG-CHARACTER-X OLDCOL) LG-CHARACTER-X-2))) + (LG-SET-POINT GX (- (* (+ OLDROW D 1) LG-CHARACTER-Y) 2)) + (LG-END-VECTOR GX (+ (* (+ OLDROW 1 (- H)) LG-CHARACTER-Y) 2))) + (CURSORPOS* OLDROW (1+ OLDCOL))) + ((AND CHARACTER-GRAPHICS-TTY $LINEDISP) + (CURSORPOS* (+ OLDROW 1 (- H)) OLDCOL) + (CG-BEGIN-GRAPHICS) + (CG-VERTICAL-BAR) + (DOTIMES (I (+ H D -1)) + (CURSORPOS* (1+ OLDROW) OLDCOL) + (CG-VERTICAL-BAR)) + (CG-END-GRAPHICS) + (CURSORPOS* (- OLDROW D) (1+ OLDCOL))) + (T (CURSORPOS* (+ OLDROW 1 (- H)) OLDCOL) + (TYO* CHAR) + (DOTIMES (I (+ H D -1)) + (CURSORPOS* (1+ OLDROW) (1- OLDCOL)) + (TYO* CHAR)) + (CURSORPOS* (- OLDROW D) OLDCOL)))) + +(DEFUN D-INTEGRALSIGN (LINEAR? &AUX DMSTR) + (DECLARE (FIXNUM X-MIN X-1 X-2 X-MAX Y-MIN Y-1 Y-2 Y-MAX)) + (COND ((AND (NOT LINEAR?) LINE-GRAPHICS-TTY $LINEDISP) + (LET ((X-MIN (* LG-CHARACTER-X OLDCOL)) + (X-1 (1- LG-CHARACTER-X-2)) + (X-2 LG-CHARACTER-X-2) + (X-MAX (* LG-CHARACTER-X (1+ OLDCOL))) + (Y-MIN (+ (* LG-CHARACTER-Y (- OLDROW 2)) LG-CHARACTER-Y-2)) + (Y-1 LG-CHARACTER-Y-2) + (Y-2 (+ LG-CHARACTER-Y LG-CHARACTER-Y-2)) + (Y-MAX (+ (* LG-CHARACTER-Y (+ OLDROW 2)) LG-CHARACTER-Y-2))) + (DOLIST (X '(0 -1)) + (LG-SET-POINT (+ X X-MAX) Y-MIN) + (LG-DRAW-VECTOR (+ X X-MAX (- X-1)) (+ Y-MIN Y-1)) + (LG-DRAW-VECTOR (+ X X-MAX (- X-2)) (+ Y-MIN Y-2)) + (LG-DRAW-VECTOR (+ X X-MIN X-2) (- Y-MAX Y-2)) + (LG-DRAW-VECTOR (+ X X-MIN X-1) (- Y-MAX Y-1)) + (LG-END-VECTOR (+ X X-MIN) Y-MAX))) + (CURSORPOS* OLDROW (1+ OLDCOL))) + (T (SETQ DMSTR + `((0 2 #//) (-1 1 #/[) (-1 0 #/I) (-1 -1 #/]) (-1 -2 #//))) + (IF LINEAR? + (DRAW-LINEAR DMSTR OLDROW OLDCOL) + (DRAW-2D DMSTR OLDROW OLDCOL))))) + +(DEFUN D-PRODSIGN (LINEAR? &AUX DMSTR) + (COND ((AND (NOT LINEAR?) $LINEDISP (FBOUNDP 'CG-D-PRODSIGN)) + (CG-BEGIN-GRAPHICS) + (CG-D-PRODSIGN) + (CG-END-GRAPHICS) + (INCREMENT OLDCOL 5)) + (T (SETQ DMSTR '((0 2 #/\ (D-HBAR 3 #/=) #//) + (-4 0) (D-VBAR 2 1 #/!) #\SP (D-VBAR 2 1 #/!) (1 0))) + (IF LINEAR? + (DRAW-LINEAR DMSTR OLDROW OLDCOL) + (DRAW-2D DMSTR OLDROW OLDCOL))))) + +(DEFUN D-SUMSIGN (LINEAR? &AUX DMSTR) + (DECLARE (FIXNUM X-MIN X-HALF X-MAX Y-MIN Y-HALF Y-MAX)) + (COND ((AND (NOT LINEAR?) $LINEDISP LINE-GRAPHICS-TTY) + (LET ((X-MIN (* LG-CHARACTER-X OLDCOL)) + (X-HALF (* LG-CHARACTER-X (+ OLDCOL 2))) + (X-MAX (* LG-CHARACTER-X (+ OLDCOL 4))) + (Y-MIN (+ (* LG-CHARACTER-Y (- OLDROW 2)) LG-CHARACTER-Y-2)) + (Y-HALF (+ (* LG-CHARACTER-Y OLDROW) LG-CHARACTER-Y-2)) + (Y-MAX (+ (* LG-CHARACTER-Y (+ OLDROW 2)) LG-CHARACTER-Y-2))) + (LG-SET-POINT (+ X-MAX 4) (+ Y-MIN 6)) + (MAPC #'(LAMBDA (X) (LG-DRAW-VECTOR (CAR X) (CDR X))) + `((,X-MAX . ,Y-MIN) + (,(1+ X-MIN) . ,Y-MIN) + (,(1+ X-HALF) . ,Y-HALF) + (,(1+ X-MIN) . ,Y-MAX) + (,X-MIN . ,Y-MAX) + (,X-HALF . ,Y-HALF) + (,X-MIN . ,Y-MIN) + (,(1- X-MIN) . ,Y-MIN) + (,(1- X-HALF) . ,Y-HALF))) + (LG-SET-POINT (+ X-MAX 4) (- Y-MAX 6)) + (LG-DRAW-VECTOR X-MAX Y-MAX) + (LG-DRAW-VECTOR X-MIN Y-MAX) + (LG-DRAW-VECTOR X-MIN (1- Y-MAX)) + (LG-END-VECTOR X-MAX (1- Y-MAX))) + (CURSORPOS* OLDROW (+ OLDCOL 4))) + ((AND (NOT LINEAR?) $LINEDISP (FBOUNDP 'CG-D-SUMSIGN)) + (CG-BEGIN-GRAPHICS) + (CG-D-SUMSIGN) + (CG-END-GRAPHICS) + (INCREMENT OLDCOL 4)) + (T (SETQ DMSTR '((0 2 (D-HBAR 4 #/=)) + (-4 1 #/\) #/> (-2 -1 #//) + (-1 -2 (D-HBAR 4 #/=)))) + (IF LINEAR? + (DRAW-LINEAR DMSTR OLDROW OLDCOL) + (DRAW-2D DMSTR OLDROW OLDCOL))))) + +;; Notice how this calls D-VBAR in the non-graphic case. The entire output +;; side should be structured this way, with no consing of intermediate +;; dimension strings. + +(DEFUN D-MATRIX (LINEAR? DIRECTION H D) + (DECLARE (FIXNUM H D X-MIN X-MAX Y-MIN Y-MAX)) + (COND ((AND (NOT LINEAR?) LINE-GRAPHICS-TTY $LINEDISP) + (LET ((X-MIN (1+ (* LG-CHARACTER-X OLDCOL))) + (X-MAX (1- (* LG-CHARACTER-X (1+ OLDCOL)))) + (Y-MIN (+ (* LG-CHARACTER-Y (+ OLDROW 1 (- H))) 2)) + (Y-MAX (- (* LG-CHARACTER-Y (+ OLDROW 1 D)) 2))) + (IF (EQ DIRECTION 'RIGHT) (PSETQ X-MIN X-MAX X-MAX X-MIN)) + (LG-SET-POINT X-MAX Y-MIN) + (LG-DRAW-VECTOR X-MIN Y-MIN) + (LG-DRAW-VECTOR X-MIN Y-MAX) + (LG-END-VECTOR X-MAX Y-MAX)) + (CURSORPOS* OLDROW (1+ OLDCOL))) + ((AND (NOT LINEAR?) CHARACTER-GRAPHICS-TTY $LINEDISP) + (COND ((= (+ H D) 1) + (TYO* (GETCHARN (IF (EQ DIRECTION 'RIGHT) $RMXCHAR $LMXCHAR) + 2))) + (T (CURSORPOS* (+ OLDROW 1 (- H)) OLDCOL) + (CG-BEGIN-GRAPHICS) + (IF (EQ DIRECTION 'RIGHT) (CG-UR-CORNER) (CG-UL-CORNER)) + (CG-END-GRAPHICS) + (CURSORPOS* (+ OLDROW -1 H) OLDCOL) + (COND ((> (+ H D) 2) + (D-VBAR NIL (1- H) (1- D)) + (CURSORPOS* (+ OLDROW D) (1- OLDCOL))) + (T (CURSORPOS* (+ OLDROW D) OLDCOL))) + (CG-BEGIN-GRAPHICS) + (IF (EQ DIRECTION 'RIGHT) (CG-LR-CORNER) (CG-LL-CORNER)) + (CG-END-GRAPHICS) + (CURSORPOS* (- OLDROW D) (1+ OLDCOL))))) + (T (D-VBAR LINEAR? H D + (GETCHARN (IF (EQ DIRECTION 'RIGHT) $RMXCHAR $LMXCHAR) + 2))))) + +;; There is wired knowledge of character offsets here. + +(DEFUN D-BOX (LINEAR? H D W BODY &AUX (CHAR 0) DMSTR) + (DECLARE (FIXNUM H D W CHAR X-MIN X-MAX Y-MIN Y-MAX)) + (COND ((AND (NOT LINEAR?) LINE-GRAPHICS-TTY $LINEDISP) + (LET ((X-MIN (* LG-CHARACTER-X OLDCOL)) + (X-MAX (* LG-CHARACTER-X (+ OLDCOL W 2))) + (Y-MIN (+ (* LG-CHARACTER-Y (- OLDROW H)) 2)) + (Y-MAX (- (* LG-CHARACTER-Y (+ OLDROW D 2)) 2))) + (LG-SET-POINT X-MIN Y-MIN) + (LG-DRAW-VECTOR X-MAX Y-MIN) + (LG-DRAW-VECTOR X-MAX Y-MAX) + (LG-DRAW-VECTOR X-MIN Y-MAX) + (LG-END-VECTOR X-MIN Y-MIN)) + (CURSORPOS* OLDROW (1+ OLDCOL)) + (DRAW-2D BODY OLDROW OLDCOL) + (CURSORPOS* OLDROW (+ OLDCOL 1))) + ((AND (NOT LINEAR?) CHARACTER-GRAPHICS-TTY $LINEDISP) + (D-MATRIX NIL 'LEFT (1+ H) (1+ D)) + (CURSORPOS* (- OLDROW H) OLDCOL) + (D-HBAR NIL W) + (CURSORPOS* (+ OLDROW H) (- OLDCOL W)) + (DRAW-2D BODY OLDROW OLDCOL) + (CURSORPOS* (+ OLDROW D 1) (- OLDCOL W)) + (D-HBAR NIL W) + (CURSORPOS* (- OLDROW D 1) OLDCOL) + (D-MATRIX NIL 'RIGHT (1+ H) (1+ D))) + (T (SETQ CHAR (GETCHARN $BOXCHAR 2)) + (SETQ DMSTR + `((0 ,H (D-HBAR ,(+ 2 W) ,CHAR)) + (,(- (+ W 2)) 0) + (D-VBAR ,H ,D ,CHAR) + ,@BODY + (,(- (1+ W)) ,(- (1+ D)) (D-HBAR ,(+ W 2) ,CHAR)) + (-1 0) + (D-VBAR ,H ,D ,CHAR))) + (IF LINEAR? + (DRAW-LINEAR DMSTR OLDROW OLDCOL) + (DRAW-2D DMSTR OLDROW OLDCOL))))) + + +;; Primitive functions for doing equation drawing. + +;; Position the cursor at a given place on the screen. %TDMV0 does +;; absolute cursor movement. + +#+ITS +(DEFUN CURSORPOS* (ROW COL) + (DECLARE (FIXNUM ROW COL)) + (+TYO #.%TDMV0 DISPLAY-FILE) + (+TYO ROW DISPLAY-FILE) + (+TYO COL DISPLAY-FILE) + (SETQ OLDROW ROW OLDCOL COL)) + +#-ITS +(DEFUN CURSORPOS* (ROW COL) + (DECLARE (FIXNUM ROW COL)) + (CURSORPOS ROW COL) + (SETQ OLDROW ROW OLDCOL COL)) + +;; This function is transmitting ITS output buffer codes in addition to +;; standard ascii characters. See INFO;ITSTTY > for documentation. This +;; should convert tabs to direct cursor positioning commands since otherwise +;; they get stuffed down the raw stream and appear as gammas on sail consoles +;; and lose completely on terminals which can't tab. Backspace also loses, +;; but its nearly impossible to get a string with backspace in it in Macsyma. +;; Also, DISPLA can't dimension it correctly. + +#+ITS +(DEFUN TYO* (CHAR) + (DECLARE (FIXNUM CHAR)) + (COND ((= #\BS CHAR) (SETQ OLDCOL (1- OLDCOL))) ;Backspace + ((< CHAR 128.) (SETQ OLDCOL (1+ OLDCOL)))) ;Printing graphic + (+TYO CHAR DISPLAY-FILE)) + +#-ITS +(DEFUN TYO* (CHAR) + (DECLARE (FIXNUM CHAR)) + (IF (< CHAR 128.) (SETQ OLDCOL (1+ OLDCOL))) ;Printing graphic + (TYO CHAR)) + + +;; Functions used by the packages for doing character graphics. +;; See MAXSRC;H19 or VT100. + +#+ITS (PROGN 'COMPILE + +(DEFMFUN CG-TYO (CHAR) (+TYO CHAR DISPLAY-FILE)) + +;; ITS does not change its idea of where the cursor position is when characters +;; are slipped by it using %TDQOT. This is used for operations which just +;; change the state of the terminal without moving the cursor. For actually +;; drawing characters, we use ordinary tyo since the cursor does indeed get +;; moved forward a position. Fortunately, it only takes one character to draw +;; each of the special characters. + +(DEFMFUN CG-IMAGE-TYO (CHAR) + (CG-TYO #.%TDQOT) + (CG-TYO CHAR)) + +) ;; End of conditional + +#-ITS (PROGN 'COMPILE + +(DEFMFUN CG-TYO (CHAR) `(TYO ,CHAR)) +(DEFMFUN CG-IMAGE-TYO (CHAR) `(TYO ,CHAR)) + +) ;; End of conditional + +(DEFMFUN CG-TYO-N (L) (MAPC #'CG-TYO L)) +(DEFMFUN CG-IMAGE-TYO-N (L) (MAPC #'CG-IMAGE-TYO L)) + +;; Things to do: +;; * Rewrite TYO* and CURSORPOS* to be "stream" oriented, i.e. they +;; either draw directly to the screen or into the linearray depending +;; upon the mode of output. This way, the HBAR and VBAR drawing functions +;; can be written only in terms of TYO*, etc. and never cons. +;; DRAW-LINEAR and DRAW-2D can be merged into a single function. +;; * Instead of calling NREVERSE from OUTPUT, call a function which +;; reverses at all levels and remove calls to REVERSE from DRAW-LINEAR +;; and DRAW-2D. +;; * Dimension functions should know whether the output must be linear. +;; This way they can do variable sized summation and integral signs, +;; graphical square root or SQRT(X), %PI  , >=  , etc. +;; These are situations where the size of the dimensioned +;; result depends upon the form of the output. +;; * Fix display of MLABOX for graphic consoles. + \ No newline at end of file diff --git a/src/mrg/fortra.66 b/src/mrg/fortra.66 new file mode 100644 index 00000000..05303136 --- /dev/null +++ b/src/mrg/fortra.66 @@ -0,0 +1,158 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module fortra) + +(DECLARE (SPECIAL LB RB ;Used for communication with MSTRING. + $LOADPRINT ;If NIL, no load message gets printed. + 1//2 -1//2) + (*LEXPR FORTRAN-PRINT $FORTMX)) + +(DEFMVAR $FORTSPACES NIL + "If T, Fortran card images are filled out to 80 columns using spaces." + BOOLEAN + MODIFIED-COMMANDS '$FORTRAN) + +(DEFMVAR $FORTINDENT 0 + "The number of spaces (beyond 6) to indent Fortran statements as they + are printed." + FIXNUM + MODIFIED-COMMANDS '$FORTRAN) + +;;; Output the EXP to the editor buffer Macsyma-Generated-Fortran. +#+LispM +(DEFMSPEC $FORTRAN_TO_EDITOR (EXP) + (ZWEI:WITH-EDITOR-STREAM (STANDARD-OUTPUT ':BUFFER-NAME "Macsyma-Generated-Fortran") + (FUNCALL (GET '$FORTRAN 'MFEXPR*) EXP))) + +;; This function is called from Macsyma toplevel. If the argument is a +;; symbol, and the symbol is bound to a matrix, then the matrix is printed +;; using an array assignment notation. + +(DEFMSPEC $FORTRAN (L) + (SETQ L (FEXPRCHECK L)) + (LET ((VALUE (STRMEVAL L))) + (COND ((MSETQP L) (SETQ VALUE `((MEQUAL) ,(CADR L) ,(MEVAL L))))) + (COND ((AND (SYMBOLP L) ($MATRIXP VALUE)) + ($FORTMX L VALUE)) + ((AND (NOT (ATOM VALUE)) (EQ (CAAR VALUE) 'MEQUAL) + (SYMBOLP (CADR VALUE)) ($MATRIXP (CADDR VALUE))) + ($FORTMX (CADR VALUE) (CADDR VALUE))) + (T (FORTRAN-PRINT VALUE))))) + +;; This function is called from Lisp programs. It takes an expression and +;; a stream argument. Default stream is NIL in MacLisp and STANDARD-OUTPUT +;; in LMLisp. This should be canonicalized in Macsyma at some point. + +;; TERPRI is a PDP10 MacLisp flag which, if set to T, will keep symbols and +;; bignums from being broken across page boundaries when printed. $LOADPRINT +;; is NIL to keep a message from being printed when the file containing MSTRING +;; is loaded. (MRG;GRIND) + +(DEFPROP MEXPT (#/* #/*) DISSYM) + +(DEFUN FORTRAN-PRINT (X &OPTIONAL (STREAM #-LISPM NIL #+LISPM STANDARD-OUTPUT) + &AUX #+PDP10 (TERPRI T) #+PDP10 ($LOADPRINT NIL) + ;; This is a poor way of saying that array references + ;; are to be printed with parens instead of brackets. + (LB #/( ) (RB #/) )) + ;; Restructure the expression for displaying. + (SETQ X (FORTSCAN X)) + ;; Linearize the expression using MSTRING. Some global state must be + ;; modified for MSTRING to generate using Fortran syntax. This must be + ;; undone so as not to modify the toplevel behavior of MSTRING. + (UNWIND-PROTECT + (PROGN + (DEFPROP MEXPT MSIZE-INFIX GRIND) + (DEFPROP MMINUS 100. LBP) + (DEFPROP MSETQ (#/=) STRSYM) + (SETQ X (MSTRING X))) + ;; Make sure this gets done before exiting this frame. + (DEFPROP MEXPT MSZ-MEXPT GRIND) + (REMPROP 'MMINUS 'LBP) + (DEFPROP MSETQ (#/:) STRSYM)) + ;; MSTRING returns a list of characters. Now print them. + (DO ((C #/0 (+ 1 (\ (- c #/0) 16) #/0)) + (COLUMN (+ 6 $FORTINDENT) (+ 9 $FORTINDENT))) + ((NULL X)) + ;; Print five spaces, a continuation character if needed, and then + ;; more spaces. COLUMN points to the last column printed in. When + ;; it equals 80, we should quit. + (COND ((= C #/0) + (PRINT-SPACES COLUMN STREAM)) + (T (PRINT-SPACES 5 STREAM) + (TYO C STREAM) + (PRINT-SPACES (- COLUMN 6) STREAM))) + ;; Print the expression. Remember, Fortran ignores blanks and line + ;; terminators, so we don't care where the expression is broken. + (DO () + ((= COLUMN 72.)) + (IF (NULL X) + (IF $FORTSPACES (TYO #\SP STREAM) (RETURN NIL)) + (progn (and (equal (car x) #/\) (setq x (cdr x))) + (TYO (POP X) STREAM))) + (INCREMENT COLUMN)) + ;; Columns 73 to 80 contain spaces + (IF $FORTSPACES (PRINT-SPACES 8 STREAM)) + (TERPRI STREAM)) + '$DONE) + +(DEFUN PRINT-SPACES (N STREAM) + (DOTIMES (I N) (TYO #\SP STREAM))) + +;; This function is similar to NFORMAT. Prepare an expression +;; for printing by converting x^(1/2) to sqrt(x), etc. A better +;; way of doing this would be to have a programmable printer and +;; not cons any new expressions at all. Some of this formatting, such +;; as E^X --> EXP(X) is specific to Fortran. + +(DEFUN FORTSCAN (E) + (COND ((ATOM E) (cond ((eq e '$%i) '((mprogn) 0.0 1.0)) + (t E))) ;%I is (0,1) + ((AND (EQ (CAAR E) 'MEXPT) (EQ (CADR E) '$%E)) + (LIST '($EXP SIMP) (FORTSCAN (CADDR E)))) + ((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADDR E) 1//2)) + (LIST '(%SQRT SIMP) (FORTSCAN (CADR E)))) + ((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADDR E) -1//2)) + (LIST '(MQUOTIENT SIMP) 1 (LIST '(%SQRT SIMP) (FORTSCAN (CADR E))))) + ((AND (EQ (CAAR E) 'MTIMES) (RATNUMP (CADR E)) + (MEMBER (CADADR E) '(1 -1))) + (COND ((EQUAL (CADADR E) 1) (FORTSCAN-MTIMES E)) + (T (LIST '(MMINUS SIMP) (FORTSCAN-MTIMES E))))) + ((EQ (CAAR E) 'RAT) + (LIST '(MQUOTIENT SIMP) (FLOAT (CADR E)) (FLOAT (CADDR E)))) + ((EQ (CAAR E) 'MRAT) (FORTSCAN (RATDISREP E))) + ;; complex numbers to f77 syntax a+b%i ==> (a,b) + ((and (memq (caar e) '(mtimes mplus)) + ((lambda (a) + (and (numberp (cadr a)) + (numberp (caddr a)) + (not (zerop1 (cadr a))) + (list '(mprogn) (caddr a) (cadr a)))) + (simplify ($bothcoef e '$%i))))) + (T (CONS (CAR E) (MAPCAR 'FORTSCAN (CDR E)))))) + +(DEFUN FORTSCAN-MTIMES (E) + (LIST '(MQUOTIENT SIMP) + (COND ((NULL (CDDDR E)) (FORTSCAN (CADDR E))) + (T (CONS (CAR E) (MAPCAR 'FORTSCAN (CDDR E))))) + (FLOAT (CADDR (CADR E))))) + +;; Takes a name and a matrix and prints a sequence of Fortran assignment +;; statements of the form +;; NAME(I,J) = + +(DEFMFUN $FORTMX (NAME MAT &OPTIONAL (STREAM #-LISPM NIL #+LISPM STANDARD-OUTPUT) + &AUX ($LOADPRINT NIL)) + (DECLARE (FIXNUM I J)) + (COND ((NOT (EQ (TYPEP NAME) 'SYMBOL)) + (MERROR "~%First argument to FORTMX must be a symbol.")) + ((NOT ($MATRIXP MAT)) + (MERROR "Second argument to FORTMX not a matrix: ~M" MAT))) + (DO ((MAT (CDR MAT) (CDR MAT)) (I 1 (1+ I))) ((NULL MAT)) + (DO ((M (CDAR MAT) (CDR M)) (J 1 (1+ J))) ((NULL M)) + (FORTRAN-PRINT `((MEQUAL) ((,NAME) ,I ,J) ,(CAR M)) STREAM))) + '$DONE) + + \ No newline at end of file diff --git a/src/mrg/gram.487 b/src/mrg/gram.487 new file mode 100644 index 00000000..016a5d35 --- /dev/null +++ b/src/mrg/gram.487 @@ -0,0 +1,565 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module gram) + +;;; Notes: +;;; +;;; KMP 12/14/80 -- Modified $DO and friends (things with NUD prop of NUD-$DO) +;;; to have an LBP of 5. instead 30. New operators introduced +;;; after this time should have an LBP of 5 if they have an +;;; NUD but no LED property unless there is a *very* good +;;; reason for that not to be so. +;;; +;;; Note also that the binding powers for - are incorrectly +;;; set also. New operators with LBP's in the range 120.-130. +;;; should beware of this. My new parser scheme has the +;;; correction for this. It's too much pain right now to +;;; integrate the correct thing into this parser. Due to some +;;; inelegant and inefficient patches to special-case "-" here +;;; and there throughout this code, the user doesn't see the +;;; difference, so we can live with current lossage for now. + + + +(LOAD-MACSYMA-MACROS MRGMAC) + +(DECLARE (GENPREFIX GRM) + (SPECIAL ST1 STRING MOPL $PROPS ALIASLIST) + (*EXPR MEVAL MEVAL1 GETOP ADD2LNC REMCHK + FULLSTRIP1 STRING* WNA-ERR GETOPR REMPROPCHK $LISTP)) + +;; "First character" and "Pop character" + +(DEFMACRO FIRST-C () `(FIRST STRING)) +(DEFMACRO POP-C () `(POP STRING)) + +(DEFMACRO CONVERT-$ANY (X) `(CDR ,X)) + +(DEFMACRO MATCH (X) `(GET ,X 'MATCH)) + +(DEFMVAR $PARSEWINDOW 10. + "The maximum number of 'lexical tokens' that are printed out on +each side of the error-point when a syntax (parsing) error occurs. This +option is especially useful on slow terminals. Setting it to -1 causes the +entire input string to be printed out when an error occurs." + FIXNUM) + + +(DEFUN PARSE (MODE RBP) + (DO ((LEFT (IF (OPERATORP (FIRST-C)) (NUD (POP-C)) (CONS '$ANY (POP-C))) + (LED (POP-C) LEFT))) + ((>= RBP (LBP (FIRST-C))) (CONVERT LEFT MODE)))) + +(DEFUN PARSE-PREFIX (OP) + (LIST (POS OP) (LIST OP) (PARSE (RPOS OP) (RBP OP)))) + +(DEFUN PARSE-POSTFIX (OP L) + (LIST (POS OP) (LIST OP) (CONVERT L (LPOS OP)))) + +(DEFUN PARSE-INFIX (OP L) + (LIST (POS OP) (LIST OP) (CONVERT L (LPOS OP)) (PARSE (RPOS OP) (RBP OP)))) + +(DEFUN PARSE-NARY (OP L) + (CONS (POS OP) (CONS (LIST OP) (CONS (CONVERT L (LPOS OP)) (PRSNARY OP (LPOS OP) (LBP OP)))))) + +(DEFUN PARSE-MATCHFIX (OP) + (CONS (POS OP) (CONS (LIST OP) (PRSMATCH (MATCH OP) (LPOS OP))))) + +(DEFUN PARSE-NOFIX (OP) (LIST (POS OP) (LIST OP))) + +(DEFUN PRSNARY (OP MODE RBP) + (DO ((NL (LIST (PARSE MODE RBP)) (CONS (PARSE MODE RBP) NL))) + ((NOT (EQ OP (FIRST-C))) (NREVERSE NL)) + (POP-C))) + +(DEFUN PRSMATCH (MATCH MODE) + (COND ((EQ MATCH (FIRST-C)) (POP-C) NIL) + (T (DO ((NL (LIST (PARSE MODE 10.)) (CONS (PARSE MODE 10.) NL))) + ((EQ MATCH (FIRST-C)) (POP-C) (NREVERSE NL)) + (IF (EQ '|$,| (FIRST-C)) (POP-C) (MRP-ERR MATCH)))))) + + +(DEFUN CONVERT (ITEM MODE) + (IF (OR (EQ MODE (CAR ITEM)) (EQ '$ANY MODE) (EQ '$ANY (CAR ITEM))) + (CDR ITEM) + (PARSE-ERR))) + +(DEFUN OPERATORP (LEX) (OR (GET LEX 'LED) (GET LEX 'NUD))) +(DEFUN OPERATORP1 (LEX) (OR (GET LEX 'LED) (GET LEX 'NUD) + (GET LEX 'LBP) (GET LEX 'RBP))) +(DEFUN NUD (OP) (IF (GET OP 'NUD) (FUNCALL (GET OP 'NUD) OP) (UDN-ERR OP))) +(DEFUN LED (OP L) (IF (GET OP 'LED) (FUNCALL (GET OP 'LED) OP L) (UDL-ERR OP))) + +(DEFMFUN LBP (LEX) (COND ((GET LEX 'LBP)) (T 200.))) +(DEFMFUN RBP (LEX) (COND ((GET LEX 'RBP)) (T 200.))) + +(DEFUN LPOS (OP) (COND ((GET OP 'LPOS)) (T '$ANY))) +(DEFUN RPOS (OP) (COND ((GET OP 'RPOS)) (T '$ANY))) +(DEFUN POS (OP) (COND ((GET OP 'POS)) (T '$ANY))) + +;; This is all going to have to be made to signal if it is to work through +;; ZWEI or a display front end. We can't pass format strings in MacLisp, and +;; we can't pass symbols either (address space). So I guess we use a +;; PARSE-ERROR macro which becomes PRINC on ITS. This doesn't solve the +;; problem for the ITS display front end, unless separate fasl files are used. + +;; N.B. Format strings can now be passed in Maclisp on ITS due to the +;; out-of-core error-string system. So whoever wrote the above comment +;; might want to do something about it. -gjc + +(DEFUN PARSE-ERR () + (MTELL-OPEN "~%Syntax error") (PRSYNERR)) + +(DEFUN MRP-ERR (MATCH) + (MTELL-OPEN "~%Missing /"~A/"" (STRIPDOLLAR MATCH)) + (PRSYNERR)) + +(DEFUN ERP-ERR (OP L) OP L ;Ignored + (MTELL-OPEN "~%Too many /)") + (PRSYNERR)) + +(DEFUN ERB-ERR (OP L) OP L ;Ignored + (MTELL-OPEN "~%Too many ]") + (PRSYNERR)) + +(DEFUN UDN-ERR (OP) + (MTELL-OPEN "~%/"~A/" is not a prefix operator." (FULLSTRIP1 OP)) + (PRSYNERR)) + +(DEFUN UDL-ERR (OP) + (MTELL-OPEN "~%/"~A/" is not an infix operator." (FULLSTRIP1 OP)) + (PRSYNERR)) + +(DEFUN DELIM-ERR (OP) OP ;Ignored + (MTELL-OPEN "~%Illegal use of delimiter.") + (PRSYNERR)) + +(DEFUN PRSYNERR () + (IF (NULL STRING) (RPLACA (LAST ST1) '**$**) + (RPLACD STRING (CONS (CAR STRING) (CDR STRING))) + (RPLACA STRING '**$**) + (RPLACA (LAST ST1) '| |)) + (TERPRI) + (COND ((NOT (= $PARSEWINDOW 0)) + (COND ((NOT (= $PARSEWINDOW -1)) + (COND ((NOT (NULL STRING)) + (DO ((STR (LIST NIL) (CONS (CAR S) STR)) + (S (CDR STRING) (CDR S))) + ((OR (NULL S) (> (LENGTH STR) $PARSEWINDOW)) + (RPLACD STRING (CDR (NREVERSE STR))))))) + (DO ((STR ST1 (CDR STR))) + ((NOT (> (- (LENGTH STR) (LENGTH (MEMBER '**$** STR))) + $PARSEWINDOW)) + (SETQ ST1 STR))))) + (MAPC #'(LAMBDA (L) (PRINC (FULLSTRIP1 L)) (TYO #\SPACE)) ST1) + (TERPRI))) + (PRINC "Please rephrase or edit.") + (IF (NOT (= $PARSEWINDOW 0)) (TERPRI)) + (MERROR "")) + +(DEFMFUN DEFINE-SYMBOL (SYM) + (PROG (DUMMY LEN X Y) + (SETQ DUMMY (MAPCAR 'ASCII (CASIFY-EXPLODEN SYM)) + SYM (IMPLODE (CONS '$ DUMMY)) + LEN (LENGTH DUMMY)) + (COND ((= LEN 2) + (COND ((NOT (AND (SETQ X (GET (CAR DUMMY) 'OP2C)) + (ASSOC (GETCHARN (CADR DUMMY) 1) X))) + (PUTPROP (CAR DUMMY) + (CONS (CONS (GETCHARN (CADR DUMMY) 1) SYM) + (GET (CAR DUMMY) 'OP2C)) + 'OP2C)))) + ((= LEN 3) + (SETQ Y (MAPCAR #'(LAMBDA (X) (GETCHARN X 1)) (CDR DUMMY))) + (COND ((NOT (AND (SETQ X (GET (CAR DUMMY) 'OP3C)) + (ASSOC Y X))) + (PUTPROP (CAR DUMMY) + (CONS (CONS Y SYM) (GET (CAR DUMMY) 'OP3C)) + 'OP3C)))) +; ((> LEN 3) ; This error check needs more work. - JPG +; (PRINC (FULLSTRIP1 SYM)) +; (MERROR "~%User defined operators can have at most 3 characters.")) + ) + (RETURN SYM))) + +(DEFUN KILL-OPERATOR (OP) + (REM OP 'NUD) (REM OP 'LED) + (REM OP 'LBP) (REM OP 'RBP) + (REM OP 'LPOS) (REM OP 'RPOS) (REM OP 'POS) + (REM OP 'GRIND) + (REM OP 'DIMENSION) (REM OP 'DISSYM) + (LET ((OPR (GET OP 'OP))) (REM OP 'OP) (REM OPR 'OPR) (REMPROPCHK OPR)) + (SETQ OP ($NOUNIFY OP)) + (REM OP 'DIMENSION) (REM OP 'DISSYM) + (REM OP 'LBP) (REM OP 'RBP)) + +(DEFPROP $/[ NUD-$/[ NUD) +(DEFPROP $/[ LED-$/[ LED) +(DEFPROP $/[ 200. LBP) +(DEFPROP $/] DELIM-ERR NUD) +(DEFPROP $/] ERB-ERR LED) +(DEFPROP $/] 5. LBP) + +(DEFUN NUD-$/[ (OP) OP ;Ignored + (CONS '$ANY (CONS '(MLIST) (PRSMATCH '$/] '$ANY)))) + +(DEFUN LED-$/[ (OP LEFT) OP ;Ignored + (LET ((RIGHT)) + (SETQ LEFT (CONVERT-$ANY LEFT)) + (IF (NUMBERP LEFT) (PARSE-ERR)) + (SETQ RIGHT (PRSMATCH '$/] '$ANY)) + (IF (NULL RIGHT) (NSUB-ERR)) + (CONS '$ANY + (COND ((ATOM LEFT) + (SETQ RIGHT (CONS (LIST (AMPERCHK LEFT) 'ARRAY) RIGHT)) + (OR (CDR (ASSOL RIGHT ALIASLIST)) RIGHT)) + (T (LIST* '(MQAPPLY ARRAY) LEFT RIGHT)))))) + +(DEFUN NSUB-ERR () + (MTELL-OPEN "~%No subscripts given") (PRSYNERR)) + + +(DEFPROP $/( NUD-$/( NUD) +(DEFPROP $/( LED-$/( LED) +(DEFPROP $/( 200. LBP) +(DEFPROP $/) DELIM-ERR NUD) +(DEFPROP $/) ERP-ERR LED) +(DEFPROP $/) 5. LBP) + +(DEFUN NUD-$/( (OP) OP ;Ignored + (LET ((RIGHT)) + (IF (EQ (FIRST-C) '$/)) (PARSE-ERR)) + (CONS '$ANY + (COND ((OR (NULL (SETQ RIGHT (PRSMATCH '$/) '$ANY))) (CDR RIGHT)) + (CONS '(MPROGN) RIGHT)) + (T (CAR RIGHT)))))) + +(DEFUN LED-$/( (OP LEFT) OP ;Ignored + (LET ((RIGHT)) + (SETQ LEFT (CONVERT-$ANY LEFT)) + (IF (NUMBERP LEFT) (PARSE-ERR)) + (SETQ RIGHT (PRSMATCH '$/) '$ANY)) + (CONS '$ANY + (COND ((ATOM LEFT) (CONS (NCONS (AMPERCHK LEFT)) RIGHT)) + (T (LIST* '(MQAPPLY) LEFT RIGHT)))))) + +(DEFPROP $/' NUD-$/' NUD) + +(DEFUN NUD-$/' (OP) OP ;Ignored + (LET ((RIGHT)) + (CONS '$ANY + (COND ((EQ (FIRST-C) '$/() + (LIST '(MQUOTE) (PARSE '$ANY 190.))) + ((OR (ATOM (SETQ RIGHT (PARSE '$ANY 190.))) + (MEMQ (CAAR RIGHT) + '(MQUOTE MLIST MPROG MPROGN LAMBDA MDO MDOIN))) + (LIST '(MQUOTE) RIGHT)) + ((EQ (CAAR RIGHT) 'MQAPPLY) + (COND ((EQ (CAAADR RIGHT) 'LAMBDA) + (LIST '(MQUOTE) RIGHT)) + (T (RPLACA (CDR RIGHT) + (CONS (CONS ($NOUNIFY (CAAADR RIGHT)) + (CDAADR RIGHT)) + (CDADR RIGHT))) + RIGHT))) + (T (CONS (CONS ($NOUNIFY (CAAR RIGHT)) (CDAR RIGHT)) + (CDR RIGHT))))))) + + +(DEFPROP |$''| |NUD-$''| NUD) + +(DEFUN |NUD-$''| (OP) OP ;Ignored + (LET ((RIGHT)) + (CONS '$ANY + (COND ((EQ (FIRST-C) '$/() (MEVAL (PARSE '$ANY 190.))) + ((ATOM (SETQ RIGHT (PARSE '$ANY 190.))) (MEVAL1 RIGHT)) + ((EQ (CAAR RIGHT) 'MQAPPLY) + (RPLACA (CDR RIGHT) + (CONS (CONS ($VERBIFY (CAAADR RIGHT)) + (CDAADR RIGHT)) + (CDADR RIGHT))) + RIGHT) + (T (CONS (CONS ($VERBIFY (CAAR RIGHT)) (CDAR RIGHT)) + (CDR RIGHT))))))) + + +(DEFPROP |$:| |LED-$:| LED) +(DEFPROP |$:| 180. LBP) + +(DEFUN |LED-$:| (OP LEFT) OP ;Ignored + (LIST '$ANY '(MSETQ) (CDR LEFT) (PARSE '$ANY 20.))) + + +(DEFPROP |$::| |LED-$::| LED) +(DEFPROP |$::| 180. LBP) + +(DEFUN |LED-$::| (OP LEFT) OP ;Ignored + (LIST '$ANY '(MSET) (CDR LEFT) (PARSE '$ANY 20.))) + + +(DEFPROP |$:=| |LED-$:=| LED) +(DEFPROP |$:=| 180. LBP) + +(DEFUN |LED-$:=| (OP LEFT) OP ;Ignored + (COND ((ATOM (CDR LEFT)) (ATM-ERR)) + (T (LIST '$ANY '(MDEFINE) (CDR LEFT) (PARSE '$ANY 20.))))) + +(DEFPROP |$::=| |LED-$::=| LED) +(DEFPROP |$::=| 180. LBP) + +(DEFUN |LED-$::=| (OP LEFT) OP ;Ignored + (LIST '$ANY '(MDEFMACRO) (CDR LEFT) (PARSE '$ANY 20.))) + +(DEFUN ATM-ERR () + (MTELL-OPEN "~%Atom passed to /":=/" or /"::=/"; try /":/"") + (PRSYNERR)) + + +(DEFPROP $! LED-$! LED) +(DEFPROP $! 160. LBP) + +(DEFUN LED-$! (OP LEFT) OP ;Ignored + (LIST '$EXPR '(MFACTORIAL) (CONVERT LEFT '$EXPR))) + + +(DEFPROP $!! LED-$!! LED) +(DEFPROP $!! 160. LBP) + +(DEFUN LED-$!! (OP LEFT) OP ;Ignored + (LIST '$EXPR '($GENFACT) (CONVERT LEFT '$EXPR) + (LIST '(MQUOTIENT) (CONVERT LEFT '$EXPR) 2) 2)) + + +(DEFPROP $^ LED-$^ LED) +(DEFPROP $^ 140. LBP) +(DEFPROP $** LED-$^ LED) +(DEFPROP $** 140. LBP) + +(DEFUN LED-$^ (OP LEFT) OP ;Ignored + (SETQ LEFT (LIST '(MEXPT) (CONVERT LEFT '$EXPR) + (COND ((EQ '$- (FIRST-C)) (POP-C) (LIST '(MMINUS) (PARSE '$EXPR 139.))) + (T (PARSE '$EXPR 139.))))) + (CONS '$EXPR (COND ((CDR (ASSOL LEFT ALIASLIST))) (T LEFT)))) + + +(DEFPROP $^^ LED-$^^ LED) +(DEFPROP $^^ 135. LBP) + +(DEFUN LED-$^^ (OP LEFT) OP ;Ignored + (SETQ LEFT (LIST '(MNCEXPT) (CONVERT LEFT '$EXPR) + (IFN (EQ '$- (FIRST-C)) (PARSE '$EXPR 134.) + (POP-C) (LIST '(MMINUS) (PARSE '$EXPR 134.))))) + (CONS '$EXPR (COND ((CDR (ASSOL LEFT ALIASLIST))) (T LEFT)))) + + +(DEFPROP $/. LED-$/. LED) +(DEFPROP $/. 110. LBP) + +(DEFUN LED-$/. (OP LEFT) OP ;Ignored + (LIST '$EXPR '(MNCTIMES) (CONVERT LEFT '$EXPR) (PARSE '$EXPR 109.))) + +(DEFPROP $* LED-$* LED) +(DEFPROP $* 120. LBP) + +(DEFUN LED-$* (OP LEFT) OP ;Ignored + (LIST* '$EXPR '(MTIMES) (CONVERT LEFT '$EXPR) (PRSNARY '$* '$EXPR 120.))) + + +(DEFPROP $// LED-$// LED) +(DEFPROP $// 120. LBP) + +(DEFUN LED-$// (OP LEFT) OP ;Ignored + (LIST '$EXPR '(MQUOTIENT) (CONVERT LEFT '$EXPR) (PARSE '$EXPR 120.))) + + +(DEFPROP $+ NUD-$+ NUD) +(DEFPROP $+ LED-$+ LED) +(DEFPROP $+ 100. LBP) + +(DEFUN NUD-$+ (OP) OP ;Ignored + (COND ((MEMQ (FIRST-C) '($+ $-)) (PARSE-ERR)) + (T (LIST '$EXPR '(MPLUS) (PARSE '$EXPR 100.))))) + +(DEFUN LED-$+ (OP LEFT) OP ;Ignored + (DO ((NL (LIST (PARSE '$EXPR 100.) (CONVERT LEFT '$EXPR)))) + (NIL) + (COND ((EQ '$+ (FIRST-C)) (POP-C) (SETQ NL (CONS (PARSE '$EXPR 100.) NL))) + ((EQ '$- (FIRST-C)) (POP-C) + (SETQ NL (CONS (LIST '(MMINUS) (PARSE '$EXPR 100.)) NL))) + (T (RETURN (CONS '$EXPR (CONS '(MPLUS) (NREVERSE NL)))))))) + + +(DEFPROP $- NUD-$- NUD) +(DEFPROP $- LED-$- LED) +(DEFPROP $- 100. LBP) + +(DEFUN NUD-$- (OP) OP ;Ignored + (IF (EQ '$+ (FIRST-C)) (PARSE-ERR) + (LIST '$EXPR '(MMINUS) (PARSE '$EXPR 100.)))) + +(DEFUN LED-$- (OP LEFT) OP ;Ignored + (DO ((NL (LIST (LIST '(MMINUS) (PARSE '$EXPR 100.)) (CONVERT LEFT '$EXPR)))) (NIL) + (COND ((EQ '$+ (FIRST-C)) (POP-C) + (SETQ NL (CONS (PARSE '$EXPR 100.) NL))) + ((EQ '$- (FIRST-C)) (POP-C) + (SETQ NL (CONS (LIST '(MMINUS) (PARSE '$EXPR 100.)) NL))) + (T (RETURN (CONS '$EXPR (CONS '(MPLUS) (NREVERSE NL)))))))) + + +(DEFPROP $= LED-$= LED) +(DEFPROP $= 80. LBP) + +(DEFUN LED-$= (OP LEFT) OP ;Ignored + `($CLAUSE (MEQUAL) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.))) + +(DEFPROP $/# LED-$/# LED) +(DEFPROP $/# 80. LBP) + +(DEFUN LED-$/# (OP LEFT) OP ;Ignored + `($CLAUSE (MNOTEQUAL) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.))) + +(DEFPROP $/> NUD-$/> NUD) + +(DEFUN NUD-$/> (OP) OP ;Ignored + '($ANY . $/>)) + + +(DEFPROP $/> LED-$/> LED) +(DEFPROP $/> 80. LBP) + +(DEFUN LED-$/> (OP LEFT) OP ;Ignored + `($CLAUSE (MGREATERP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.))) + + +(DEFPROP $/>= LED-$/>= LED) +(DEFPROP $/>= 80. LBP) + +(DEFUN LED-$/>= (OP LEFT) OP ;Ignored + `($CLAUSE (MGEQP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.))) + + +(DEFPROP $/< LED-$/< LED) +(DEFPROP $/< 80. LBP) + +(DEFUN LED-$/< (OP LEFT) OP ;Ignored + `($CLAUSE (MLESSP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.))) + +(DEFPROP $/<= LED-$/<= LED) +(DEFPROP $/<= 80. LBP) + +(DEFUN LED-$/<= (OP LEFT) OP ;Ignored + `($CLAUSE (MLEQP) ,(CONVERT LEFT '$EXPR) ,(PARSE '$EXPR 80.))) + +(DEFPROP $NOT NUD-$NOT NUD) +(DEFUN NUD-$NOT (OP) OP ;Ignored + `($CLAUSE (MNOT) ,(PARSE '$CLAUSE 70.))) + + +(DEFPROP $AND LED-$AND LED) +(DEFPROP $AND 60. LBP) + +(DEFUN LED-$AND (OP LEFT) OP ;Ignored + `($CLAUSE (MAND) ,(CONVERT LEFT '$CLAUSE) . ,(PRSNARY '$AND '$CLAUSE 60.))) + +(DEFPROP $OR LED-$OR LED) +(DEFPROP $OR 50. LBP) + +(DEFUN LED-$OR (OP LEFT) OP ;Ignored + `($CLAUSE (MOR) ,(CONVERT LEFT '$CLAUSE) . ,(PRSNARY '$OR '$CLAUSE 50.))) + +(DEFPROP $/, LED-$/, LED) +(DEFPROP $/, 10. LBP) + +(DEFUN LED-$/, (OP LEFT) OP ;Ignored + `($ANY ($EV) ,(CDR LEFT) . ,(PRSNARY '$/, '$ANY 10.))) + +(DEFPROP $IF NUD-$IF NUD) +(DEFPROP $THEN DELIM-ERR NUD) +(DEFPROP $THEN 5. LBP) +(DEFPROP $ELSE DELIM-ERR NUD) +(DEFPROP $ELSE 5. LBP) + +(DEFUN NUD-$IF (OP) OP ;Ignored + (LIST '$ANY '(MCOND) + (PARSE '$CLAUSE 45.) + (COND ((EQ '$THEN (FIRST-C)) (POP-C) (PARSE '$ANY 25.)) + (T (TERPRI) (PRINC '|Missing "THEN"|) (PRSYNERR))) + T + (COND ((EQ '$ELSE (FIRST-C)) (POP-C) (PARSE '$ANY 25.)) (T '$FALSE)))) + +(DEFPROP $FOR NUD-$DO NUD) +(DEFPROP $FOR 5. LBP) + +(DEFPROP $FROM NUD-$DO NUD) +(DEFPROP $FROM 5. LBP) + +(DEFPROP $STEP NUD-$DO NUD) +(DEFPROP $STEP 5. LBP) + +(DEFPROP $NEXT NUD-$DO NUD) +(DEFPROP $NEXT 5. LBP) + +(DEFPROP $THRU NUD-$DO NUD) +(DEFPROP $THRU 5. LBP) + +(DEFPROP $UNLESS NUD-$DO NUD) +(DEFPROP $UNLESS 5. LBP) + +(DEFPROP $WHILE NUD-$DO NUD) +(DEFPROP $WHILE 5. LBP) + +(DEFPROP $DO NUD-$DO NUD) +(DEFPROP $DO 5. LBP) + +(DEFUN NUD-$DO (LEX) + (DO ((OP LEX (POP-C)) (LEFT (MAKE-MDO))) + ((EQ '$DO OP) (SETF (MDO-BODY LEFT) (PARSE '$ANY 25.)) + (CONS '$ANY LEFT)) + (COND ((AND (EQ '$FOR OP) (NULL (MDO-FOR LEFT))) + (SETF (MDO-FOR LEFT) (PARSE '$ANY 200.))) + ((AND (OR (EQ '$FROM OP) (EQ '$/: OP)) + (NULL (MDO-FROM LEFT)) + (EQ 'MDO (MDO-OP LEFT))) + (SETF (MDO-FROM LEFT) (PARSE '$ANY 95.))) + ((AND (EQ '$IN OP) (NULL (MDO-STEP LEFT)) (NULL (MDO-NEXT LEFT))) + (SETF (MDO-OP LEFT) 'MDOIN) + (SETF (MDO-FROM LEFT) (PARSE '$ANY 95.))) + ((AND (EQ '$STEP OP) (NULL (MDO-STEP LEFT)) (NULL (MDO-NEXT LEFT)) + (EQ 'MDO (MDO-OP LEFT))) + (SETF (MDO-STEP LEFT) (PARSE '$EXPR 95.))) + ((AND (EQ '$NEXT OP) (NULL (MDO-NEXT LEFT)) (NULL (MDO-STEP LEFT)) + (EQ 'MDO (MDO-OP LEFT))) + (SETF (MDO-NEXT LEFT) (PARSE '$ANY 45.))) + ((AND (EQ '$THRU OP) (NULL (MDO-THRU LEFT))) + (SETF (MDO-THRU LEFT) (PARSE '$EXPR 95.))) + ((EQ '$WHILE OP) + (SETF (MDO-UNLESS LEFT) + (COND ((NULL (MDO-UNLESS LEFT)) (LIST '(MNOT) (PARSE '$CLAUSE 45.))) + (T (LIST '(MOR) (MDO-UNLESS LEFT) + (LIST '(MNOT) (PARSE '$CLAUSE 45.))))))) + ((EQ '$UNLESS OP) + (SETF (MDO-UNLESS LEFT) + (COND ((NULL (MDO-UNLESS LEFT)) (PARSE '$CLAUSE 45.)) + (T (LIST '(MOR) (MDO-UNLESS LEFT) (PARSE '$CLAUSE 45.)))))) + (T (PARSE-ERR))))) + + +(DEFPROP |$;| |NUD-$;| NUD) +(DEFPROP |$;| |LED-$;| LED) +(DEFPROP |$;| -1 LBP) + +(DEFUN |NUD-$;| (OP) OP ;Ignored + (MTELL-OPEN "Premature termination of input.") + (PRSYNERR)) + +(DEFUN |LED-$;| (OP LEFT) OP ;Ignored + (CDR LEFT)) + + +;; Local Modes: +;; Mode: LISP +;; Comment Col: 40 +;; END: + \ No newline at end of file diff --git a/src/mrg/grind.153 b/src/mrg/grind.153 new file mode 100644 index 00000000..f8b2ba80 --- /dev/null +++ b/src/mrg/grind.153 @@ -0,0 +1,427 @@ +;;;;;;;;;;;;;;;;;;; -*- 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)))) + + \ No newline at end of file diff --git a/src/mrg/nforma.18 b/src/mrg/nforma.18 new file mode 100644 index 00000000..8a47981e --- /dev/null +++ b/src/mrg/nforma.18 @@ -0,0 +1,118 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module nforma) + +(DECLARE (SPECIAL 1//2 -1//2 DISPLAYP ALIASLIST IN-P)) + +(DEFMVAR $POWERDISP NIL) +(DEFMVAR $PFEFORMAT NIL) +(DEFMVAR $%EDISPFLAG NIL) +(DEFMVAR $EXPTDISPFLAG T) +(DEFMVAR $SQRTDISPFLAG T) +(DEFMVAR $NEGSUMDISPFLAG T) +(SETQ IN-P NIL) + +(DEFMFUN NFORMAT (FORM) + (COND ((ATOM FORM) + (COND ((AND (NUMBERP FORM) (MINUSP FORM)) (LIST '(MMINUS) (MINUS FORM))) + ((EQ T FORM) (IF IN-P T '$TRUE)) + ((EQ NIL FORM) (IF IN-P NIL '$FALSE)) + ((AND DISPLAYP (CAR (ASSQR FORM ALIASLIST)))) + (T FORM))) + ((ATOM (CAR FORM)) FORM) + ((EQ 'RAT (CAAR FORM)) + (COND ((MINUSP (CADR FORM)) + (LIST '(MMINUS) (LIST '(RAT) (MINUS (CADR FORM)) (CADDR FORM)))) + (T (CONS '(RAT) (CDR FORM))))) + ((EQ 'MMACROEXPANDED (CAAR FORM)) (NFORMAT (CADDR FORM))) + ((NULL (CDAR FORM)) FORM) + ((EQ 'MPLUS (CAAR FORM)) (FORM-MPLUS FORM)) + ((EQ 'MTIMES (CAAR FORM)) (FORM-MTIMES FORM)) + ((EQ 'MEXPT (CAAR FORM)) (FORM-MEXPT FORM)) + ((EQ 'MRAT (CAAR FORM)) (FORM-MRAT FORM)) + ((EQ 'MPOIS (CAAR FORM)) (NFORMAT ($OUTOFPOIS FORM))) + ((EQ 'BIGFLOAT (CAAR FORM)) + (IF (MINUSP (CADR FORM)) + (LIST '(MMINUS) (LIST (CAR FORM) (MINUS (CADR FORM)) (CADDR FORM))) + (CONS (CAR FORM) (CDR FORM)))) + (T FORM))) + +(DEFUN FORM-MPLUS (FORM &AUX ARGS TRUNC) + (SETQ ARGS (MAPCAR #'NFORMAT (CDR FORM))) + (SETQ TRUNC (MEMQ 'TRUNC (CDAR FORM))) + (CONS (IF TRUNC '(MPLUS TRUNC) '(MPLUS)) + (COND ((AND (MEMQ 'RATSIMP (CDAR FORM)) (NOT (MEMQ 'SIMP (CDAR FORM)))) + (IF $POWERDISP (NREVERSE ARGS) ARGS)) + ((AND TRUNC (NOT (MEMQ 'SIMP (CDAR FORM)))) (NREVERSE ARGS)) + ((OR $POWERDISP TRUNC (MEMQ 'CF (CDAR FORM))) ARGS) + ((AND $NEGSUMDISPFLAG (NULL (CDDDR FORM))) + (IF (AND (NOT (MMMINUSP (CAR ARGS))) + (MMMINUSP (CADR ARGS))) + ARGS + (NREVERSE ARGS))) + (T (NREVERSE ARGS))))) + +(DEFUN FORM-MTIMES (FORM) + (COND ((NULL (CDR FORM)) '((MTIMES))) + ((EQUAL -1 (CADR FORM)) (LIST '(MMINUS) (FORM-MTIMES (CDR FORM)))) + (T (PROG (NUM DEN MINUS FLAG) + (DO ((L (CDR FORM) (CDR L)) (DUMMY)) ((NULL L)) + (SETQ DUMMY (NFORMAT (CAR L))) + (COND ((ATOM DUMMY) (SETQ NUM (CONS DUMMY NUM))) + ((EQ 'MMINUS (CAAR DUMMY)) + (SETQ MINUS (NOT MINUS) L (APPEND DUMMY (CDR L)))) + ((OR (EQ 'MQUOTIENT (CAAR DUMMY)) + (AND (NOT $PFEFORMAT) (EQ 'RAT (CAAR DUMMY)))) + (COND ((NOT (EQUAL 1 (CADR DUMMY))) + (SETQ NUM (CONS (CADR DUMMY) NUM)))) + (SETQ DEN (CONS (CADDR DUMMY) DEN))) + (T (SETQ NUM (CONS DUMMY NUM))))) + (SETQ NUM (COND ((NULL NUM) 1) + ((NULL (CDR NUM)) (CAR NUM)) + (T (CONS '(MTIMES) (NREVERSE NUM)))) + DEN (COND ((NULL DEN) (SETQ FLAG T) NIL) + ((NULL (CDR DEN)) (CAR DEN)) + (T (CONS '(MTIMES) (NREVERSE DEN))))) + (IF (NOT FLAG) (SETQ NUM (LIST '(MQUOTIENT) NUM DEN))) + (RETURN (IF MINUS (LIST '(MMINUS) NUM) NUM)))))) + +(DEFUN FORM-MEXPT (FORM &AUX EXP) + (COND ((AND $SQRTDISPFLAG (ALIKE1 1//2 (CADDR FORM))) (LIST '(%SQRT) (CADR FORM))) + ((AND $SQRTDISPFLAG (ALIKE1 -1//2 (CADDR FORM))) + (LIST '(MQUOTIENT) 1 (LIST '(%SQRT) (CADR FORM)))) + ((AND (OR (AND $%EDISPFLAG (EQ '$%E (CADR FORM))) + (AND $EXPTDISPFLAG (NOT (EQ '$%E (CADR FORM))))) + (NOT (ATOM (SETQ EXP (NFORMAT (CADDR FORM))))) + (EQ 'MMINUS (CAAR EXP))) + (LIST '(MQUOTIENT) 1 (IF (EQUAL 1 (CADR EXP)) (CADR FORM) + (LIST '(MEXPT) (CADR FORM) (CADR EXP))))) + (T (CONS '(MEXPT) (CDR FORM))))) + +(DEFUN FORM-MRAT (FORM) + (LET ((TRUNC (MEMQ 'TRUNC (CDAR FORM))) EXACT) + (IF (AND TRUNC (EQ (CADR FORM) 'PS)) + (SETQ EXACT (NULL (CAR (CADDDR FORM))))) + (SETQ FORM (RATDISREPD FORM)) + (RDIS1 FORM) + (IF (AND TRUNC (OR (ATOM FORM) + ;; A constant, e.g. ((mplus) $a 1) + (not (member (car form) + '((mplus exact) (mplus trunc)))))) + (CONS (IF EXACT '(MPLUS EXACT) '(MPLUS TRUNC)) (NCONS FORM)) + (NFORMAT FORM)))) + +(DEFUN RDIS1 (FORM) + (COND ((OR (ATOM FORM) (SPECREPP FORM))) + ((NULL (CDAR FORM)) (RPLACA FORM (LIST (CAAR FORM) 'RATSIMP))) + (T (MAPC #'RDIS1 (CDR FORM))))) + +(DEFMFUN NFORMAT-ALL (FORM) + (SETQ FORM (NFORMAT FORM)) + (IF (OR (ATOM FORM) (EQ (CAAR FORM) 'BIGFLOAT)) + FORM + (CONS (DELSIMP (CAR FORM)) + (IF (MEMQ (CAAR FORM) '(MDO MDOIN)) + (MAPCAR #'(LAMBDA (U) (IF U (NFORMAT-ALL U))) (CDR FORM)) + (MAPCAR #'NFORMAT-ALL (CDR FORM)))))) diff --git a/src/mrg/optim.16 b/src/mrg/optim.16 new file mode 100644 index 00000000..2ae2888d --- /dev/null +++ b/src/mrg/optim.16 @@ -0,0 +1,146 @@ +;;; -*- Mode:LISP; Package:MACSYMA -*- + +; ** (c) Copyright 1982 Massachusetts Institute of Technology ** + +(macsyma-module optim) + +(DECLARE (SPECIAL VARS SETQS OPTIMCOUNT XVARS) + (FIXNUM N (OPT-HASH)) + (ARRAY* (NOTYPE (SUBEXP 1))) + (UNSPECIAL ARGS)) + +(ARRAY SUBEXP T 64.) + +(DEFMVAR $OPTIMPREFIX '$%) + +(DEFMVAR $OPTIMWARN T "warns if OPTIMIZE encounters a special form.") + +;; $OPTIMIZE takes a Macsyma expression and returns a BLOCK form which is +;; equivalent, but which uses local variables to store the results of computing +;; common subexpressions. These subexpressions are found by hashing them. + +(DEFMFUN $OPTIMIZE (X0) + (LET (($OPTIMWARN $OPTIMWARN)) + (PROG (VARS SETQS OPTIMCOUNT XVARS X) + (SETQ OPTIMCOUNT 0 XVARS (CDR ($LISTOFVARS X0))) + (FILLARRAY 'SUBEXP '(NIL)) + (SETQ X (COLLAPSE (OPFORMAT (COLLAPSE X0)))) + (IF (ATOM X) (RETURN X)) + (COMEXP X) + (SETQ X (OPTIM X)) + (RETURN (PROG1 (COND ((NULL VARS) X0) + (T (IF (OR (NOT (EQ (CAAR X) 'MPROG)) + (AND ($LISTP (CADR X)) (CDADR X))) + (SETQ X (NREVERSE (CONS X SETQS))) + (SETQ X (NCONC (NREVERSE SETQS) (CDDR X)))) + `((MPROG SIMP) ((MLIST) . ,(NREVERSE VARS)) . ,X))) + (FILLARRAY 'SUBEXP '(NIL))))))) + +(DEFUN OPFORMAT (X) + (COND ((ATOM X) X) + ((SPECREPP X) (OPFORMAT (SPECDISREP X))) + ((AND $OPTIMWARN + (MSPECFUNP (CAAR X)) + (PROG2 (MTELL "OPTIMIZE has met up with a special form - ~ + answer may be wrong.") + (SETQ $OPTIMWARN NIL)))) + ((EQ (CAAR X) 'MEXPT) (OPMEXPT X)) + (T (LET ((NEWARGS (MAPCAR #'OPFORMAT (CDR X)))) + (IF (ALIKE NEWARGS (CDR X)) X (CONS (CAR X) NEWARGS)))))) + +(DEFUN OPMEXPT (X) + (LET ((*BASE (OPFORMAT (CADR X))) (EXP (OPFORMAT (CADDR X))) XNEW NEGEXP) + (SETQ NEGEXP + (COND ((AND (NUMBERP EXP) (MINUSP EXP)) (MINUS EXP)) + ((AND (RATNUMP EXP) (MINUSP (CADR EXP))) + (LIST (CAR EXP) (MINUS (CADR EXP)) (CADDR EXP))) + ((AND (MTIMESP EXP) (NUMBERP (CADR EXP)) (MINUSP (CADR EXP))) + (IF (EQUAL (CADR EXP) -1) + (IF (NULL (CDDDR EXP)) (CADDR EXP) + (CONS (CAR EXP) (CDDR EXP))) + (LIST* (CAR EXP) (MINUS (CADR EXP)) (CDDR EXP)))) + ((AND (MTIMESP EXP) (RATNUMP (CADR EXP)) (MINUSP (CADADR EXP))) + (LIST* (CAR EXP) + (LIST (CAADR EXP) (MINUS (CADADR EXP)) (CADDR (CADR EXP))) + (CDDR EXP))))) + (SETQ XNEW + (COND (NEGEXP + `((MQUOTIENT) + 1 + ,(COND ((EQUAL NEGEXP 1) *BASE) + (T (SETQ XNEW (LIST (CAR X) *BASE NEGEXP)) + (IF (AND (RATNUMP NEGEXP) (EQUAL (CADDR NEGEXP) 2)) + (OPMEXPT XNEW) + XNEW))))) + ((AND (RATNUMP EXP) (EQUAL (CADDR EXP) 2)) + (SETQ EXP (CADR EXP)) + (IF (EQUAL EXP 1) `((%SQRT) ,*BASE) + `((MEXPT) ((%SQRT) ,*BASE) ,EXP))) + (T (LIST (CAR X) *BASE EXP)))) + (IF (ALIKE1 X XNEW) X XNEW))) + +(DEFMFUN $COLLAPSE (X) + (FILLARRAY 'SUBEXP '(NIL)) + (PROG1 (COLLAPSE X) (FILLARRAY 'SUBEXP '(NIL)))) + +(DEFUN COLLAPSE (X) + (COND ((ATOM X) X) + ((SPECREPP X) (COLLAPSE (SPECDISREP X))) + (T (LET ((N (OPT-HASH (CAAR X)))) + (DO ((L (CDR X) (CDR L))) + ((NULL L)) + (IF (NOT (EQ (COLLAPSE (CAR L)) (CAR L))) + (RPLACA L (COLLAPSE (CAR L)))) + (SETQ N (\ (+ (OPT-HASH (CAR L)) N) 12553.))) + (SETQ N (LOGAND 63. N)) + (DO ((L (SUBEXP N) (CDR L))) + ((NULL L) (STORE (SUBEXP N) (CONS (LIST X) (SUBEXP N))) X) + (IF (ALIKE1 X (CAAR L)) (RETURN (CAAR L)))))))) + +(DEFUN COMEXP (X) + (IF (NOT (OR (ATOM X) (EQ (CAAR X) 'RAT))) + (LET ((N (OPT-HASH (CAAR X)))) + (DOLIST (U (CDR X)) (SETQ N (\ (+ (OPT-HASH U) N) 12553.))) + (SETQ X (ASSOL X (SUBEXP (LOGAND 63. N)))) + (COND ((NULL (CDR X)) (RPLACD X 'SEEN) (MAPC #'COMEXP (CDAR X))) + (T (RPLACD X 'COMEXP)))))) + +(DEFUN OPTIM (X) + (COND ((ATOM X) X) + ((AND (MEMQ 'ARRAY (CDAR X)) + (NOT (EQ (CAAR X) 'MQAPPLY)) + (NOT (MGET (CAAR X) 'ARRAYFUN-MODE))) + X) + ((EQ (CAAR X) 'RAT) X) + (T (LET ((N (OPT-HASH (CAAR X))) (NX (LIST (CAR X)))) + (DOLIST (U (CDR X)) + (SETQ N (\ (+ (OPT-HASH U) N) 12553.) + NX (CONS (OPTIM U) NX))) + (SETQ X (ASSOL X (SUBEXP (LOGAND 63. N))) NX (NREVERSE NX)) + (COND ((EQ (CDR X) 'SEEN) NX) + ((EQ (CDR X) 'COMEXP) + (RPLACD X (GETOPTIMVAR)) + (SETQ SETQS (CONS `((MSETQ) ,(CDR X) ,NX) SETQS)) + (CDR X)) + (T (CDR X))))))) + +(DEFUN OPT-HASH (EXP) ; EXP is in general representation. + (\ (IF (ATOM EXP) + (SXHASH EXP) + (DO ((N (OPT-HASH (CAAR EXP))) + (ARGS (CDR EXP) (CDR ARGS))) + ((NULL ARGS) N) + (SETQ N (\ (+ (OPT-HASH (CAR ARGS)) N) 12553.)))) + 12553.)) ; a prime number < 2^14 ; = PRIME(1500) + +(DEFUN GETOPTIMVAR () + (PROG (VAR) + LOOP (INCREMENT OPTIMCOUNT) + (SETQ VAR (INTERN #-Lispm (MAKNAM (NCONC (EXPLODEN $OPTIMPREFIX) + (MEXPLODEN OPTIMCOUNT))) + #+Lispm (MAKE-SYMBOL + (FORMAT NIL "~A~D" $OPTIMPREFIX OPTIMCOUNT)))) + (IF (MEMQ VAR XVARS) (GO LOOP)) + (SETQ VARS (CONS VAR VARS)) + (RETURN VAR))) + \ No newline at end of file diff --git a/src/mrg/scs.61 b/src/mrg/scs.61 new file mode 100644 index 00000000..f2c02e9c --- /dev/null +++ b/src/mrg/scs.61 @@ -0,0 +1,55 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module scs) + +(DECLARE (*EXPR $RATSUBST CONSSIZE)) + +(DEFMFUN $SCSIMP N + (DO ((I N (1- I)) (ZRS)) ((= 1 I) (SCS (ARG 1) ZRS)) + (SETQ ZRS (CONS (IFN (EQ 'MEQUAL (CAAR (ARG I))) (ARG I) + (SUB (CADR (ARG I)) (CADDR (ARG I)))) ZRS)))) + +(DEFUN SCS (X ZRS) + (DO ((FLAG T) (SZ (CONSSIZE X)) (NX) (NSZ)) ((NOT FLAG) X) + (DO ((L ZRS (CDR L))) ((NULL L) (SETQ FLAG NIL)) + (SETQ NX (SUBSCS 0 (CAR L) X) NSZ (CONSSIZE NX)) + (IF (< NSZ SZ) (RETURN (SETQ X NX SZ NSZ)))))) + +(DEFUN SUBSCS (A B C) + (COND ((ATOM B) (SUBSC A B C)) + ((EQ 'MPLUS (CAAR B)) + (DO ((L (CDR B) (CDR L)) (SZ (CONSSIZE C)) (NL) (NC) (NSZ)) ((NULL L) C) + (SETQ NC (SUBSCS (SUB A (ADDN (RECONC NL (CDR L)) T)) (CAR L) C) + NSZ (CONSSIZE NC) NL (CONS (CAR L) NL)) + (IF (< NSZ SZ) (SETQ C NC SZ NSZ)))) + (T (SUBSC A B C)))) + +(DEFUN SUBSC (A B C) ($EXPAND ($RATSUBST A B C))) + +(DEFMFUN $DISTRIB (EXP) + (COND ((OR (MNUMP EXP) (SYMBOLP EXP)) EXP) + ((EQ 'MTIMES (CAAR EXP)) + (SETQ EXP (MAPCAR '$DISTRIB (CDR EXP))) + (DO ((L (CDR EXP) (CDR L)) + (NL (IF (MPLUSP (CAR EXP)) (CDAR EXP) (LIST (CAR EXP))))) + ((NULL L) (ADDN NL T)) + (IF (MPLUSP (CAR L)) + (DO ((M (CDAR L) (CDR M)) (ML)) ((NULL M) (SETQ NL ML)) + (SETQ ML (DSTRB (CAR M) NL ML))) + (SETQ NL (DSTRB (CAR L) NL NIL))))) + ((EQ 'MEQUAL (CAAR EXP)) + (LIST '(MEQUAL) ($DISTRIB (CADR EXP)) ($DISTRIB (CADDR EXP)))) + ((EQ 'MRAT (CAAR EXP)) ($DISTRIB (RATDISREP EXP))) + (T EXP))) + +(DEFUN DSTRB (X L NL) + (DO () ((NULL L) NL) + (SETQ NL (CONS (MUL X (CAR L)) NL) L (CDR L)))) + +(DEFMFUN $FACOUT (X Y) + (IFN (AND (NOT (ATOM Y)) + (EQ 'MPLUS (CAAR Y))) Y + (MUL X (ADDN (MAPCAR #'(LAMBDA (L) (DIV L X)) (CDR Y)) T)))) + diff --git a/src/mrg/trigi.358 b/src/mrg/trigi.358 new file mode 100644 index 00000000..a1d467d9 --- /dev/null +++ b/src/mrg/trigi.358 @@ -0,0 +1,636 @@ +;; -*- Mode: Lisp; Package: Macsyma; -*- + +;; (c) Copyright 1976, 1984 Massachusetts Institute of Technology +;; All Rights Reserved. + +;; Enhancements (c) Copyright 1984 Symbolics Inc. +;; All Rights Reserved. + +;; The data and information in the Enhancements are proprietary to, and +;; a valuable trade secret of, SYMBOLICS, INC., a Delaware corporation. +;; They are given in confidence by SYMBOLICS, pursuant to the license +;; agreement between Symbolics and their recipient, and may not be used, +;; reproduced, or copied, or distributed to any other party, in whole or +;; in part, without the prior written consent of SYMBOLICS except as +;; permitted by the license agreement. + +(macsyma-module trigi) + +(LOAD-MACSYMA-MACROS MRGMAC) + +(DECLARE (GENPREFIX TRI) + (SPECIAL VARLIST ERRORSW $DEMOIVRE) + (FLONUM (TAN) (COT) (SEC) (CSC) + (ATAN2) (ATAN1) (ACOT) + (SINH) (COSH) (TANH) (COTH) (CSCH) (SECH) + (ASINH) (ACSCH) + (T//$ FLONUM FLONUM NOTYPE)) + (*EXPR $BFLOAT TEVAL SIGNUM1 ZEROP1 ISLINEAR EXPAND1 + TIMESK ADDK INTEGERP EVOD LOGARC + MEVENP EQTEST HALFANGLE COEFF)) + +(DEFMVAR $%PIARGS T) +(DEFMVAR $%IARGS T) +(DEFMVAR $TRIGINVERSES '$ALL) +(DEFMVAR $TRIGEXPAND NIL) +(DEFMVAR $TRIGEXPANDPLUS T) +(DEFMVAR $TRIGEXPANDTIMES T) +(DEFMVAR $TRIGSIGN T) +(DEFMVAR $EXPONENTIALIZE NIL) +(DEFMVAR $LOGARC NIL) +(DEFMVAR $HALFANGLES NIL) + +(DEFMVAR 1//2 '((RAT SIMP) 1 2)) +(DEFMVAR -1//2 '((RAT SIMP) -1 2)) +(DEFMVAR %PI//4 '((MTIMES SIMP) ((RAT SIMP) 1 4.) $%PI)) +(DEFMVAR %PI//2 '((MTIMES SIMP) ((RAT SIMP) 1 2) $%PI)) +(DEFMVAR SQRT2//2 '((MTIMES SIMP) ((RAT SIMP) 1 2) + ((MEXPT SIMP) 2 ((RAT SIMP) 1 2)))) +(DEFMVAR -SQRT2//2 '((MTIMES SIMP) ((RAT SIMP) -1 2) + ((MEXPT SIMP) 2 ((RAT SIMP) 1 2)))) +(DEFMVAR SQRT3//2 '((MTIMES SIMP) ((RAT SIMP) 1 2) + ((MEXPT SIMP) 3 ((RAT SIMP) 1 2)))) +(DEFMVAR -SQRT3//2 '((MTIMES SIMP) ((RAT SIMP) -1 2) + ((MEXPT SIMP) 3 ((RAT SIMP) 1 2)))) + +;;; Arithmetic utilities. + +(DEFMFUN SQRT1-X^2 (X) (POWER (SUB 1 (POWER X 2)) 1//2)) + +(DEFMFUN SQRT1+X^2 (X) (POWER (ADD 1 (POWER X 2)) 1//2)) + +(DEFMFUN SQRTX^2-1 (X) (POWER (ADD (POWER X 2) -1) 1//2)) + +(DEFMFUN SQ-SUMSQ (X Y) (POWER (ADD (POWER X 2) (POWER Y 2)) 1//2)) + +(DEFMFUN TRIGP (FUNC) (MEMQ FUNC '(%SIN %COS %TAN %CSC %SEC %COT + %SINH %COSH %TANH %CSCH %SECH %COTH))) + +(DEFMFUN ARCP (FUNC) (MEMQ FUNC '(%ASIN %ACOS %ATAN %ACSC %ASEC %ACOT + %ASINH %ACOSH %ATANH %ACSCH %ASECH %ACOTH))) + +(DEFPROP %SIN SIMP-%SIN OPERATORS) +(DEFPROP %COS SIMP-%COS OPERATORS) +(DEFPROP %TAN SIMP-%TAN OPERATORS) +(DEFPROP %COT SIMP-%COT OPERATORS) +(DEFPROP %CSC SIMP-%CSC OPERATORS) +(DEFPROP %SEC SIMP-%SEC OPERATORS) +(DEFPROP %SINH SIMP-%SINH OPERATORS) +(DEFPROP %COSH SIMP-%COSH OPERATORS) +(DEFPROP %TANH SIMP-%TANH OPERATORS) +(DEFPROP %COTH SIMP-%COTH OPERATORS) +(DEFPROP %CSCH SIMP-%CSCH OPERATORS) +(DEFPROP %SECH SIMP-%SECH OPERATORS) +(DEFPROP %ASIN SIMP-%ASIN OPERATORS) +(DEFPROP %ACOS SIMP-%ACOS OPERATORS) +(DEFPROP %ATAN SIMP-%ATAN OPERATORS) +(DEFPROP %ACOT SIMP-%ACOT OPERATORS) +(DEFPROP %ACSC SIMP-%ACSC OPERATORS) +(DEFPROP %ASEC SIMP-%ASEC OPERATORS) +(DEFPROP %ASINH SIMP-%ASINH OPERATORS) +(DEFPROP %ACOSH SIMP-%ACOSH OPERATORS) +(DEFPROP %ATANH SIMP-%ATANH OPERATORS) +(DEFPROP %ACOTH SIMP-%ACOTH OPERATORS) +(DEFPROP %ACSCH SIMP-%ACSCH OPERATORS) +(DEFPROP %ASECH SIMP-%ASECH OPERATORS) + +(DEFMFUN SIMP-%SIN (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SIN Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (COND ((ZEROP1 Y) 0) ((LINEARP Y '$%PI) (%PIARGS-SIN\COS Y))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%SINH (COEFF Y '$%I 1)))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) + (COND ((EQ '%ASIN (SETQ Z (CAAR Y))) (CADR Y)) + ((EQ '%ACOS Z) (SQRT1-X^2 (CADR Y))) + ((EQ '%ATAN Z) (DIV (CADR Y) (SQRT1+X^2 (CADR Y)))) + ((EQ '%ACOT Z) (DIV 1 (SQRT1+X^2 (CADR Y)))) + ((EQ '%ASEC Z) (DIV (SQRTX^2-1 (CADR Y)) (CADR Y))) + ((EQ '%ACSC Z) (DIV 1 (CADR Y))) + ((EQ '$ATAN2 Z) (DIV (CADR Y) (SQ-SUMSQ (CADR Y) (CADDR Y))))))) + ((AND $TRIGEXPAND (TRIGEXPAND '%SIN Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%SIN Y)) + ((AND $HALFANGLES (HALFANGLE '%SIN Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%SIN (NEG Y)))) + (T (EQTEST (LIST '(%SIN) Y) FORM)))) + +(DEFMFUN SIMP-%COS (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COS Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (COND ((ZEROP1 Y) 1) ((LINEARP Y '$%PI) (%PIARGS-SIN\COS (ADD %PI//2 Y)))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%COSH (COEFF Y '$%I 1))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) + (COND ((EQ '%ACOS (SETQ Z (CAAR Y))) (CADR Y)) + ((EQ '%ASIN Z) (SQRT1-X^2 (CADR Y))) + ((EQ '%ATAN Z) (DIV 1 (SQRT1+X^2 (CADR Y)))) + ((EQ '%ACOT Z) (DIV (CADR Y) (SQRT1+X^2 (CADR Y)))) + ((EQ '%ASEC Z) (DIV 1 (CADR Y))) + ((EQ '%ACSC Z) (DIV (SQRTX^2-1 (CADR Y)) (CADR Y))) + ((EQ '$ATAN2 Z) (DIV (CADDR Y) (SQ-SUMSQ (CADR Y) (CADDR Y))))))) + ((AND $TRIGEXPAND (TRIGEXPAND '%COS Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%COS Y)) + ((AND $HALFANGLES (HALFANGLE '%COS Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%COS (NEG Y))) + (T (EQTEST (LIST '(%COS) Y) FORM)))) + +(DEFUN %PIARGS-SIN\COS (X) + (LET ($FLOAT COEFF RATCOEFF REM) + (SETQ RATCOEFF (COEFFICIENT X '$%PI 1) + COEFF (LINEARIZE RATCOEFF) REM (COEFFICIENT X '$%PI 0)) + (COND ((ZEROP1 REM) (%PIARGS COEFF RATCOEFF)) + ((NOT (MEVENP (CAR COEFF))) NIL) + ((EQUAL 0 (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%SIN REM)) + ((EQUAL 1 X) (NEG (CONS-EXP '%SIN REM))) + ((ALIKE1 1//2 X) (CONS-EXP '%COS REM)) + ((ALIKE1 '((RAT) 3 2) X) (NEG (CONS-EXP '%COS REM)))))) + +(DEFMFUN SIMP-%TAN (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (TAN Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (COND ((ZEROP1 Y) 0) ((LINEARP Y '$%PI) (%PIARGS-TAN\COT Y))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%TANH (COEFF Y '$%I 1)))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) + (COND ((EQ '%ATAN (SETQ Z (CAAR Y))) (CADR Y)) + ((EQ '%ASIN Z) (DIV (CADR Y) (SQRT1-X^2 (CADR Y)))) + ((EQ '%ACOS Z) (DIV (SQRT1-X^2 (CADR Y)) (CADR Y))) + ((EQ '%ACOT Z) (DIV 1 (CADR Y))) + ((EQ '%ASEC Z) (SQRTX^2-1 (CADR Y))) + ((EQ '%ACSC Z) (DIV 1 (SQRTX^2-1 (CADR Y)))) + ((EQ '$ATAN2 Z) (DIV (CADR Y) (CADDR Y)))))) + ((AND $TRIGEXPAND (TRIGEXPAND '%TAN Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%TAN Y)) + ((AND $HALFANGLES (HALFANGLE '%TAN Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%TAN (NEG Y)))) + (T (EQTEST (LIST '(%TAN) Y) FORM)))) + +(DEFMFUN SIMP-%COT (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COT Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'COT)) + ((AND (LINEARP Y '$%PI) (SETQ Z (%PIARGS-TAN\COT (ADD %PI//2 Y)))) (NEG Z))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%COTH (COEFF Y '$%I 1)))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) + (COND ((EQ '%ACOT (SETQ Z (CAAR Y))) (CADR Y)) + ((EQ '%ASIN Z) (DIV (SQRT1-X^2 (CADR Y)) (CADR Y))) + ((EQ '%ACOS Z) (DIV (CADR Y) (SQRT1-X^2 (CADR Y)))) + ((EQ '%ATAN Z) (DIV 1 (CADR Y))) + ((EQ '%ASEC Z) (DIV 1 (SQRTX^2-1 (CADR Y)))) + ((EQ '%ACSC Z) (SQRTX^2-1 (CADR Y))) + ((EQ '$ATAN2 Z) (DIV (CADDR Y) (CADR Y)))))) + ((AND $TRIGEXPAND (TRIGEXPAND '%COT Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%COT Y)) + ((AND $HALFANGLES (HALFANGLE '%COT Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%COT (NEG Y)))) + (T (EQTEST (LIST '(%COT) Y) FORM)))) + +(DEFUN %PIARGS-TAN\COT (X) + (PROG ($FLOAT COEFF REM) + (SETQ COEFF (LINEARIZE (COEFFICIENT X '$%PI 1)) REM (COEFFICIENT X '$%PI 0)) + (RETURN (COND ((AND (ZEROP1 REM) + (SETQ REM (%PIARGS COEFF NIL)) + (SETQ COEFF (%PIARGS (CONS (CAR COEFF) (RPLUS 1//2 (CDR COEFF))) + NIL))) + (DIV REM COEFF)) + ((NOT (MEVENP (CAR COEFF))) NIL) + ((FIXP (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%TAN REM)) + ((OR (ALIKE1 1//2 X) (ALIKE1 '((RAT) 3 2) X)) (NEG (CONS-EXP '%COT REM))))))) + +(DEFMFUN SIMP-%CSC (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (CSC Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'CSC)) + ((LINEARP Y '$%PI) (%PIARGS-CSC\SEC Y))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%CSCH (COEFF Y '$%I 1)))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) + (COND ((EQ '%ACSC (SETQ Z (CAAR Y))) (CADR Y)) + ((EQ '%ASIN Z) (DIV 1 (CADR Y))) + ((EQ '%ACOS Z) (DIV 1 (SQRT1-X^2 (CADR Y)))) + ((EQ '%ATAN Z) (DIV (SQRT1+X^2 (CADR Y)) (CADR Y))) + ((EQ '%ACOT Z) (SQRT1+X^2 (CADR Y))) + ((EQ '%ASEC Z) (DIV (CADR Y) (SQRTX^2-1 (CADR Y)))) + ((EQ '$ATAN2 Z) (DIV (SQ-SUMSQ (CADR Y) (CADDR Y)) (CADR Y)))))) + ((AND $TRIGEXPAND (TRIGEXPAND '%CSC Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%CSC Y)) + ((AND $HALFANGLES (HALFANGLE '%CSC Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%CSC (NEG Y)))) + + (T (EQTEST (LIST '(%CSC) Y) FORM)))) + +(DEFMFUN SIMP-%SEC (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SEC Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (COND ((ZEROP1 Y) 1) ((LINEARP Y '$%PI) (%PIARGS-CSC\SEC (ADD %PI//2 Y)))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%SECH (COEFF Y '$%I 1))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) + (COND ((EQ '%ASEC (SETQ Z (CAAR Y))) (CADR Y)) + ((EQ '%ASIN Z) (DIV 1 (SQRT1-X^2 (CADR Y)))) + ((EQ '%ACOS Z) (DIV 1 (CADR Y))) + ((EQ '%ATAN Z) (SQRT1+X^2 (CADR Y))) + ((EQ '%ACOT Z) (DIV (SQRT1+X^2 (CADR Y)) (CADR Y))) + ((EQ '%ACSC Z) (DIV (CADR Y) (SQRTX^2-1 (CADR Y)))) + ((EQ '$ATAN2 Z) (DIV (SQ-SUMSQ (CADR Y) (CADDR Y)) (CADDR Y)))))) + ((AND $TRIGEXPAND (TRIGEXPAND '%SEC Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%SEC Y)) + ((AND $HALFANGLES (HALFANGLE '%SEC Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%SEC (NEG Y))) + + (T (EQTEST (LIST '(%SEC) Y) FORM)))) + +(DEFUN %PIARGS-CSC\SEC (X) + (PROG ($FLOAT COEFF REM) + (SETQ COEFF (LINEARIZE (COEFFICIENT X '$%PI 1)) REM (COEFFICIENT X '$%PI 0)) + (RETURN (COND ((AND (ZEROP1 REM) (SETQ REM (%PIARGS COEFF NIL))) (DIV 1 REM)) + ((NOT (MEVENP (CAR COEFF))) NIL) + ((EQUAL 0 (SETQ X (MMOD (CDR COEFF) 2))) (CONS-EXP '%CSC REM)) + ((EQUAL 1 X) (NEG (CONS-EXP '%CSC REM))) + ((ALIKE1 1//2 X) (CONS-EXP '%SEC REM)) + ((ALIKE1 '((RAT) 3 2) X) (NEG (CONS-EXP '%SEC REM))))))) + +(DEFMFUN SIMP-%ATAN (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ATAN1 Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS + (COND ((ZEROP1 Y) 0) + ((EQUAL Y 1) (SIMPLIFY FOURTH%PI)) + ((EQUAL Y -1) (NEG (SIMPLIFY FOURTH%PI)))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) + (MUL '$%I (CONS-EXP '%ATANH (COEFF Y '$%I 1)))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) + (COND ((EQ (CAAR Y) '%TAN) (CADR Y)) + ((EQ (CAAR Y) '%COT) (SUB (SIMPLIFY HALF%PI) (CADR Y)))))) + ($LOGARC (LOGARC '%ATAN Y)) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ATAN (NEG Y)))) + (T (EQTEST (LIST '(%ATAN) Y) FORM)))) + +(DEFUN %PIARGS (X RATCOEFF) + (COND ((AND (FIXP (CAR X)) (FIXP (CDR X))) 0) + ((NOT (MEVENP (CAR X))) + (COND ((NULL RATCOEFF) NIL) + ((ALIKE1 (CDR X) '((RAT) 1 2)) + (POWER -1 (ADD RATCOEFF -1//2))))) + ((OR (ALIKE1 '((RAT) 1 6) (SETQ X (MMOD (CDR X) 2))) (ALIKE1 '((RAT) 5 6) X)) + 1//2) + ((OR (ALIKE1 '((RAT) 1 4) X) (ALIKE1 '((RAT) 3 4) X)) + (DIV (POWER 2 1//2) 2)) + ((OR (ALIKE1 '((RAT) 1 3) X) (ALIKE1 '((RAT) 2 3) X)) + (DIV (POWER 3 1//2) 2)) + ((ALIKE1 1//2 X) 1) + ((OR (ALIKE1 '((RAT) 7 6) X) (ALIKE1 '((RAT) 11 6) X)) -1//2) + ((OR (ALIKE1 '((RAT) 4 3) X) (ALIKE1 '((RAT) 5 3) X)) + (DIV (POWER 3 1//2) -2)) + ((OR (ALIKE1 '((RAT) 5 4) X) (ALIKE1 '((RAT) 7 4) X)) + (MUL -1//2 (POWER 2 1//2))) + ((ALIKE1 '((RAT) 3 2) X) -1))) + +(DEFUN LINEARIZE (FORM) + (COND ((FIXP FORM) (CONS 0 FORM)) + ((NUMBERP FORM) NIL) + ((ATOM FORM) + (LET (DUM) + (COND ((SETQ DUM (EVOD FORM)) + (IF (EQ '$EVEN DUM) '(2 . 0) '(2 . 1))) + ((INTEGERP FORM) '(1 . 0))))) + ((EQ 'RAT (CAAR FORM)) (CONS 0 FORM)) + ((EQ 'MPLUS (CAAR FORM)) (LIN-MPLUS FORM)) + ((EQ 'MTIMES (CAAR FORM)) (LIN-MTIMES FORM)) + ((EQ 'MEXPT (CAAR FORM)) (LIN-MEXPT FORM)))) + +(DEFUN LIN-MPLUS (FORM) + (DO ((TL (CDR FORM) (CDR TL)) (DUMMY) (COEFF 0) (REM 0)) + ((NULL TL) (IF (FIXNUMP COEFF) (CONS COEFF (MMOD REM COEFF)))) + (SETQ DUMMY (LINEARIZE (CAR TL))) + (IF (NULL DUMMY) + (RETURN NIL) + (SETQ COEFF (RGCD (CAR DUMMY) COEFF) REM (RPLUS (CDR DUMMY) REM))))) + +(DEFUN LIN-MTIMES (FORM) + (DO ((FL (CDR FORM) (CDR FL)) (DUMMY) (COEFF 0) (REM 1)) + ((NULL FL) (IF (FIXNUMP COEFF) (CONS COEFF (MMOD REM COEFF)))) + (SETQ DUMMY (LINEARIZE (CAR FL))) + (IF (NULL DUMMY) + (RETURN NIL) + (SETQ COEFF (RGCD (RTIMES COEFF (CAR DUMMY)) + (RGCD (RTIMES COEFF (CDR DUMMY)) + (RTIMES REM (CAR DUMMY)))) + REM (RTIMES (CDR DUMMY) REM))))) + +(DEFUN LIN-MEXPT (FORM) + (LET (DUMMY) + (IF (AND (FIXNUMP (CADDR FORM)) + (NOT (MINUSP (CADDR FORM))) + (NOT (NULL (SETQ DUMMY (LINEARIZE (CADR FORM)))))) + (CONS (CAR DUMMY) (MMOD (CDR DUMMY) (CADDR FORM)))))) + + +(DEFUN LCM (X Y) (QUOTIENT (TIMES X Y) (GCD X Y))) + +(DEFUN RGCD (X Y) + (COND ((FIXP X) + (COND ((FIXP Y) (GCD X Y)) + (T (LIST '(RAT) (GCD X (CADR Y)) (CADDR Y))))) + ((FIXP Y) (LIST '(RAT) (GCD (CADR X) Y) (CADDR X))) + (T (LIST '(RAT) (GCD (CADR X) (CADR Y)) (LCM (CADDR X) (CADDR Y)))))) + +(DEFUN REDUCE (X Y) + (PROG (GCD) + (SETQ GCD (GCD X Y) X (QUOTIENT X GCD) Y (QUOTIENT Y GCD)) + (IF (MINUSP Y) (SETQ X (MINUS X) Y (MINUS Y))) + (RETURN (IF (EQUAL Y 1) X (LIST '(RAT SIMP) X Y))))) + +;; The following four functions are generated in code by TRANSL. - JPG 2/1/81 + +(DEFMFUN RPLUS (X Y) (ADDK X Y)) + +(DEFMFUN RDIFFERENCE (X Y) (ADDK X (TIMESK -1 Y))) + +(DEFMFUN RTIMES (X Y) (TIMESK X Y)) + +(DEFMFUN RREMAINDER (X Y) + (COND ((EQUAL 0 Y) (DBZ-ERR)) + ((FIXP X) + (COND ((FIXP Y) (REDUCE X Y)) + (T (REDUCE (TIMES X (CADDR Y)) (CADR Y))))) + ((FIXP Y) (REDUCE (CADR X) (TIMES (CADDR X) Y))) + (T (REDUCE (TIMES (CADR X) (CADDR Y)) (TIMES (CADDR X) (CADR Y)))))) + +(DEFMFUN $EXPONENTIALIZE (EXP) + (LET ($DEMOIVRE) + (COND ((ATOM EXP) EXP) + ((TRIGP (CAAR EXP)) + (EXPONENTIALIZE (CAAR EXP) ($EXPONENTIALIZE (CADR EXP)))) + (T (RECUR-APPLY #'$EXPONENTIALIZE EXP))))) + +(DEFMFUN EXPONENTIALIZE (OP ARG) + (COND ((EQ '%SIN OP) + (DIV (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG))) + (MUL 2 '$%I))) + ((EQ '%COS OP) + (DIV (ADD (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG))) 2)) + ((EQ '%TAN OP) + (DIV (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG))) + (MUL '$%I (ADD (POWER '$%E (MUL '$%I ARG)) + (POWER '$%E (MUL -1 '$%I ARG)))))) + ((EQ '%COT OP) + (DIV (MUL '$%I (ADD (POWER '$%E (MUL '$%I ARG)) + (POWER '$%E (MUL -1 '$%I ARG)))) + (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG))))) + ((EQ '%CSC OP) + (DIV (MUL 2 '$%I) + (SUB (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG))))) + ((EQ '%SEC OP) + (DIV 2 (ADD (POWER '$%E (MUL '$%I ARG)) (POWER '$%E (MUL -1 '$%I ARG))))) + ((EQ '%SINH OP) + (DIV (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG))) 2)) + ((EQ '%COSH OP) + (DIV (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG))) 2)) + ((EQ '%TANH OP) + (DIV (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG))) + (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG))))) + ((EQ '%COTH OP) + (DIV (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG))) + (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG))))) + ((EQ '%CSCH OP) + (DIV 2 (SUB (POWER '$%E ARG) (POWER '$%E (NEG ARG))))) + ((EQ '%SECH OP) + (DIV 2 (ADD (POWER '$%E ARG) (POWER '$%E (MUL -1 ARG))))))) + +(DEFUN COEFFICIENT (EXP VAR POW) + (LET ($NUMER $FLOAT) (COEFF (EXPAND1 EXP 1 0) VAR POW))) + +(DEFUN LINEARP (EXP VAR) + (LET ($NUMER $FLOAT) + (AND (SETQ EXP (ISLINEAR (EXPAND1 EXP 1 0) VAR)) + (NOT (EQUAL (CAR EXP) 0))))) + +(DEFUN MMOD (X MOD) + (COND ((FIXNUMP X) + (IF (MINUSP (SETQ X (- X (* MOD (// X MOD))))) (+ X MOD) X)) + ((RATNUMP X) + (LIST '(RAT) (MMOD (CADR X) (* MOD (CADDR X))) (CADDR X))))) + +(DEFUN MULTIPLEP (EXP VAR) + (AND (NOT (ZEROP1 EXP)) (ZEROP1 (SUB EXP (MUL VAR (COEFF EXP VAR 1)))))) + +(DEFMFUN MMINUSP (X) (= -1 (SIGNUM1 X))) + +(DEFMFUN MMINUSP* (X) (MMINUSP X)) ;; This could be done by a macro in + ;; LIBMAX;MAXMAC . - JPG + +;; The following definition for MMINUSP* was used experimentally to test +;; for e.g. SIN(-X) -> -SIN(X) using the Macsyma database. However, this +;; approach was found to be very slow in many cases. Instead the syntactic +;; check offered by MMINUSP should be quite sufficient. - JPG + +;;(DEFMFUN MMINUSP* (X) +;; (LET (SIGN) +;; (SETQ SIGN (CSIGN X)) +;; (OR (MEMQ SIGN '($NEG $NZ)) +;; (AND (MMINUSP X) (NOT (MEMQ SIGN '($POS $PZ))))))) + +(DEFUN DBZ-ERR () + (IF (NOT ERRORSW) (MERROR "Division by zero") (*THROW 'ERRORSW T))) + +(DEFUN DBZ-ERR1 (FUNC) + (IF (NOT ERRORSW) (MERROR "Division by zero in ~A function" FUNC) + (*THROW 'ERRORSW T))) + +;; Only used by LAP code right now. + +#+PDP10 +(DEFUN NUMERIC-ERR (X MSG) (MERROR "~A in ~A function" MSG X)) + +;; Trig, hyperbolic functions, and inverses, which take real floating args +;; and return real args. Checks made for overflow and out of range args. +;; The following are read-time constants. +;; This seems bogus. Probably want (FSC (LSH 1 26.) 0) for the PDP10. -cwh + +#.(SETQ EPS #+PDP10 (FSC 1.0 -26.) + #+LispM (ASH 1.0 #+3600 -24. #-3600 -31.) + #-(or PDP10 LispM) 1.4E-8) + +#.(SETQ PI (ATAN 0.0 -1.0) PIBY2 (//$ PI 2.0)) + +;; This function is in LAP for PDP10 systems. On the Lisp Machine and +;; in NIL, this should CONDITION-BIND the appropriate arithmetic overflow +;; signals and do whatever NUMERIC-ERR or DBZ-ERR does. Fix later. + +#-(OR PDP10 LISPM) (DEFMACRO T//$ (X Y FUNCTION) FUNCTION ;Ignored + `(//$ ,X ,Y)) +#+LISPM +(DEFMACRO T//$ (X Y FUNCTION) + (IF (EQUAL Y 0.0) + ;; DEFEAT INCOMPETENTLY DONE COMPILER:OPTIMIZATION. + `(T//$-FOO ,X ,Y ,FUNCTION) + `(//$ ,X ,Y))) +#+LISPM +(DEFUN T//$-FOO (X Y FUNCTION) FUNCTION + (//$ X Y)) + +#+PDP10 (LAP-A-LIST '( + +(LAP T//$ SUBR) +(ARGS T//$ (NIL . 3)) + (PUSH P (% 0 0 FLOAT1)) + (JRST 2 @ (% 0 0 NEXTA)) +NEXTA (MOVE TT 0 A) + (FDVR TT 0 B) ;DIVIDE TT BY SECOND ARG + (JFCL 10 UFLOW) +ANS (POPJ P) +UFLOW (MOVE A C) + (SKIPN 0 0 B) + (JCALL 1 'DBZ-ERR1) + (MOVEI B 'OVERFLOW) + (JSP T NEXTB) +NEXTB (TLNN T 64.) + (JCALL 2 'NUMERIC-ERR) + (MOVEI B 'UNDERFLOW) + (SKIPN 0 (SPECIAL ZUNDERFLOW)) + (JCALL 2 'NUMERIC-ERR) + (MOVEI TT 0) + (JRST 0 ANS) +NIL )) + +;; Numeric functions (SIN, COS, LOG, EXP are built in to Lisp). + +(DEFMFUN TAN (X) (T//$ (SIN X) (COS X) 'TAN)) + +(DEFMFUN COT (X) (T//$ (COS X) (SIN X) 'COT)) + +(DEFMFUN SEC (X) (T//$ 1.0 (COS X) 'SEC)) + +(DEFMFUN CSC (X) (T//$ 1.0 (SIN X) 'CSC)) + +;; #.
means to evaluate at read-time. + +(DECLARE (FLONUM YY YFLO)) + +;; We don't use the built-in Franz definitions of ASIN and ACOS because +;; they obviously don't know about LOGARC. - JPG + +(DEFMFUN ASIN (NUM) + (LET ((YFLO (FLOAT NUM))) + (COND ((> (ABS YFLO) 1.0) (LOGARC '%ASIN YFLO)) + ((< (ABS YFLO) #.(SQRT EPS)) YFLO) + (T (*$ (ATAN (ABS YFLO) (SQRT (-$ 1.0 (*$ YFLO YFLO)))) + (IF (< YFLO 0.0) -1.0 1.0)))))) + +(DEFMFUN ACOS (NUM) + (LET ((YFLO (FLOAT NUM))) + (COND ((> (ABS YFLO) 1.0) (LOGARC '%ACOS YFLO)) + ((< (ABS YFLO) #.(SQRT EPS)) (-$ #.PIBY2 YFLO)) + (T (ATAN (SQRT (-$ 1.0 (*$ YFLO YFLO))) YFLO))))) +#-LispM +(DEFMFUN ATAN2 (Y X) + (LET ((YFLO (ATAN (ABS Y) X))) (IF (MINUSP Y) (-$ YFLO) YFLO))) + +(DEFMFUN ATAN1 (NUM) + (LET ((YFLO (FLOAT NUM))) + (*$ (ATAN (ABS YFLO) 1.0) (IF (MINUSP YFLO) -1.0 1.0)))) + +(DEFMFUN ACOT (NUM) + (LET ((YFLO (FLOAT NUM))) + (*$ (ATAN 1.0 (ABS YFLO)) (IF (MINUSP YFLO) -1.0 1.0)))) + +(DEFMFUN ASEC (NUM) + (LET ((YFLO (FLOAT NUM))) + (IF (< (ABS YFLO) 1.0) (LOGARC '%ASEC YFLO)) (ACOS (//$ YFLO)))) + +(DEFMFUN ACSC (NUM) + (LET ((YFLO (FLOAT NUM))) + (IF (< (ABS YFLO) 1.0) (LOGARC '%ACSC YFLO)) (ASIN (//$ YFLO)))) + +(DEFMFUN SINH (NUM) + (LET ((YY (FLOAT NUM)) (YFLO 0.0)) + (COND ((< (ABS YY) #.(SQRT EPS)) YY) + (T (SETQ YFLO (EXP (ABS YY)) YFLO (//$ (-$ YFLO (//$ YFLO)) 2.0)) + (IF (< YY 0.0) (-$ YFLO) YFLO))))) + +(DEFMFUN COSH (NUM) + (LET ((YFLO (FLOAT NUM))) + (SETQ YFLO (EXP (ABS YFLO))) (//$ (+$ YFLO (//$ YFLO)) 2.0))) + +#-Lispm +(DEFMFUN TANH (NUM) + (LET ((YY (FLOAT NUM)) (YFLO 0.0)) + (COND ((< (ABS YY) #.(SQRT EPS)) YY) + (T (SETQ YFLO (EXP (*$ -2.0 (ABS YY))) + YFLO (//$ (1-$ YFLO) (1+$ YFLO))) + (IF (PLUSP YY) (-$ YFLO) YFLO))))) + +#+Lispm +(DEFMFUN TANH (NUM) + (LET ((YY (FLOAT NUM)) (YFLO 0.0)) + (COND ((< (ABS YY) #.(SQRT EPS)) YY) + (T (LET ((ANSWER 0.0)) + (SETQ ANSWER + (COND ((> (ABS YY) #.(//$ (-$ (LOG EPS)) 2.0)) -1.0) + (T (SETQ YFLO (EXP (*$ -2.0 (ABS YY))) + ANSWER (//$ (1-$ YFLO) (1+$ YFLO)))))) + (IF (PLUSP YY) (-$ ANSWER) ANSWER)))))) + +(DEFMFUN COTH (NUM) + (LET ((YY (FLOAT NUM)) (YFLO 0.0)) + (COND ((< (ABS YY) #.(SQRT EPS)) (T//$ 1.0 YY 'COTH)) + (T (SETQ YFLO (EXP (*$ -2.0 (ABS YY))) + YFLO (T//$ (1+$ YFLO) (1-$ YFLO) 'COTH)) + (IF (PLUSP YY) (-$ YFLO) YFLO))))) + +(DEFMFUN CSCH (NUM) + (LET ((YY (FLOAT NUM)) (YFLO 0.0)) + (COND ((< (ABS YY) #.(SQRT EPS)) (//$ YY)) + (T (SETQ YFLO (EXP (-$ (ABS YY))) + YFLO (T//$ (*$ 2.0 YFLO) + (1-$ (IF (< YFLO #.(SQRT EPS)) 0.0 (*$ YFLO YFLO))) 'CSCH)) + (IF (PLUSP YY) (-$ YFLO) YFLO))))) + +(DEFMFUN SECH (NUM) + (LET ((YFLO (FLOAT NUM))) (SETQ YFLO (EXP (-$ (ABS YFLO)))) + (//$ YFLO 0.5 (1+$ (IF (< YFLO #.(SQRT EPS)) 0.0 (*$ YFLO YFLO)))))) + +(DEFMFUN ACOSH (NUM) + (LET ((YFLO (FLOAT NUM))) + (COND ((< YFLO 1.0) (LOGARC '%ACOSH YFLO)) + ((> YFLO #.(SQRT (//$ EPS))) (LOG (*$ 2.0 YFLO))) + (T (LOG (+$ (SQRT (1-$ (*$ YFLO YFLO))) YFLO)))))) + +(DEFMFUN ASINH (NUM) + (LET* ((YY (FLOAT NUM)) + (YFLO (ABS YY))) + (COND ((< YFLO #.(SQRT EPS)) YFLO) + (T (SETQ YFLO (LOG (COND ((> YFLO #.(SQRT (//$ EPS))) (*$ 2.0 YFLO)) + (T (+$ (SQRT (1+$ (*$ YFLO YFLO))) YFLO))))) + (COND ((MINUSP YY) (-$ YFLO)) (T YFLO)))))) + +(DEFMFUN ATANH (NUM) + (LET ((YFLO (FLOAT NUM))) + (COND ((< (ABS YFLO) #.(SQRT EPS)) YFLO) + ((< (ABS YFLO) 1.0) (//$ (LOG (T//$ (1+$ YFLO) (-$ 1.0 YFLO) 'ATANH)) 2.0)) + ((= 1.0 (ABS YFLO)) (T//$ 1.0 0.0 'ATANH)) + (T (LOGARC '%ATANH YFLO))))) + +(DEFMFUN ACOTH (NUM) + (LET ((YFLO (FLOAT NUM))) + (COND ((> (ABS YFLO) 1.0) (//$ (LOG (//$ (-$ 1.0 YFLO) (1+$ YFLO))) 2.0)) + ((= 1.0 (ABS YFLO)) (T//$ 1.0 0.0 'ACOTH)) + (T (LOGARC '%ACOTH YFLO))))) + +(DEFMFUN ASECH (NUM) + (LET ((YFLO (FLOAT NUM))) + (COND ((OR (MINUSP YFLO) (> YFLO 1.0)) (LOGARC '%ASECH YFLO))) + (ACOSH (T//$ 1.0 YFLO 'ASECH)))) + +(DEFMFUN ACSCH (NUM) (ASINH (T//$ 1.0 (FLOAT NUM) 'ACSCH))) + \ No newline at end of file diff --git a/src/mrg/trigo.333 b/src/mrg/trigo.333 new file mode 100644 index 00000000..cba327b1 --- /dev/null +++ b/src/mrg/trigo.333 @@ -0,0 +1,378 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module trigo) + +(LOAD-MACSYMA-MACROS MRGMAC) + +(DECLARE (GENPREFIX TRI) + (SPECIAL VARLIST ERRORSW) + (FLONUM (TAN) (COT) (SEC) (CSC) + (ATAN2) (ATAN1) (ACOT) + (SINH) (COSH) (TANH) (COTH) (CSCH) (SECH) + (ASINH) (ACSCH) + (T//$ FLONUM FLONUM NOTYPE)) + (*EXPR $BFLOAT TEVAL SIGNUM1 ZEROP1 ISLINEAR + TIMESK ADDK INTEGERP EVOD LOGARC MEVENP HALFANGLE COEFF)) + +(DECLARE (SPLITFILE HYPER)) + +(DEFMFUN SIMP-%SINH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SINH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (IF (ZEROP1 Y) 0))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%SIN (COEFF Y '$%I 1)))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ASINH (CAAR Y)) (CADR Y)))) + ((AND $TRIGEXPAND (TRIGEXPAND '%SINH Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%SINH Y)) + ((AND $HALFANGLES (HALFANGLE '%SINH Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%SINH (NEG Y)))) + (T (EQTEST (LIST '(%SINH) Y) FORM)))) + +(DEFMFUN SIMP-%COSH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COSH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (IF (ZEROP1 Y) 1))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%COS (COEFF Y '$%I 1))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACOSH (CAAR Y)) (CADR Y)))) + ((AND $TRIGEXPAND (TRIGEXPAND '%COSH Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%COSH Y)) + ((AND $HALFANGLES (HALFANGLE '%COSH Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%COSH (NEG Y))) + (T (EQTEST (LIST '(%COSH) Y) FORM)))) + +(DEFMFUN SIMP-%TANH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (TANH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (IF (ZEROP1 Y) 0))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%TAN (COEFF Y '$%I 1)))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ATANH (SETQ Z (CAAR Y))) (CADR Y)))) + ((AND $TRIGEXPAND (TRIGEXPAND '%TANH Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%TANH Y)) + ((AND $HALFANGLES (HALFANGLE '%TANH Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%TANH (NEG Y)))) + (T (EQTEST (LIST '(%TANH) Y) FORM)))) + +(DEFMFUN SIMP-%COTH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (COTH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (IF (ZEROP1 Y) (DBZ-ERR1 'COTH)))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%COTH (COEFF Y '$%I 1)))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACOTH (CAAR Y)) (CADR Y)))) + ((AND $TRIGEXPAND (TRIGEXPAND '%COTH Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%COTH Y)) + ((AND $HALFANGLES (HALFANGLE '%COTH Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%COTH (NEG Y)))) + (T (EQTEST (LIST '(%COTH) Y) FORM)))) + +(DEFMFUN SIMP-%CSCH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (CSCH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (COND ((ZEROP1 Y) (DBZ-ERR1 'CSCH))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%CSC (COEFF Y '$%I 1)))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ACSCH (CAAR Y)) (CADR Y)))) + ((AND $TRIGEXPAND (TRIGEXPAND '%CSCH Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%CSCH Y)) + ((AND $HALFANGLES (HALFANGLE '%CSCH Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%CSCH (NEG Y)))) + (T (EQTEST (LIST '(%CSCH) Y) FORM)))) + +(DEFMFUN SIMP-%SECH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (SECH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (ZEROP1 Y)) 1) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (CONS-EXP '%SEC (COEFF Y '$%I 1))) + ((AND $TRIGINVERSES (NOT (ATOM Y)) (IF (EQ '%ASECH (CAAR Y)) (CADR Y)))) + ((AND $TRIGEXPAND (TRIGEXPAND '%SECH Y))) + ($EXPONENTIALIZE (EXPONENTIALIZE '%SECH Y)) + ((AND $HALFANGLES (HALFANGLE '%SECH Y))) + ((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%SECH (NEG Y))) + (T (EQTEST (LIST '(%SECH) Y) FORM)))) + +(DECLARE (SPLITFILE ATRIG)) + +(DEFMFUN SIMP-%ASIN (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASIN Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS + (COND ((ZEROP1 Y) 0) ((EQUAL 1 Y) %PI//2) ((EQUAL -1 Y) (NEG %PI//2)) + ((ALIKE1 Y 1//2) (MUL '((RAT SIMP) 1 6) '$%PI))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ASINH (COEFF Y '$%I 1)))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) (IF (EQ '%SIN (CAAR Y)) (CADR Y)))) + ($LOGARC (LOGARC '%ASIN Y)) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ASIN (NEG Y)))) + (T (EQTEST (LIST '(%ASIN) Y) FORM)))) + +(DEFMFUN SIMP-%ACOS (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOS Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS + (COND ((ZEROP1 Y) %PI//2) ((EQUAL 1 Y) 0) ((EQUAL -1 Y) '$%PI) + ((ALIKE1 Y 1//2) (MUL '((RAT SIMP) 1 3) '$%PI))))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) + (IF (EQ '%COS (CAAR Y)) (CADR Y)))) + ($LOGARC (LOGARC '%ACOS Y)) + ((AND $TRIGSIGN (MMINUSP* Y)) (SUB '$%PI (CONS-EXP '%ACOS (NEG Y)))) + (T (EQTEST (LIST '(%ACOS) Y) FORM)))) + +(DEFMFUN SIMP-%ACOT (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOT Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS + (COND ((ZEROP1 Y) %PI//2) ((EQUAL 1 Y) %PI//4) ((EQUAL -1 Y) (NEG %PI//4))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACOTH (COEFF Y '$%I 1)))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) + (IF (EQ '%COT (CAAR Y)) (CADR Y)))) + ($LOGARC (LOGARC '%ACOT Y)) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACOT (NEG Y)))) + (T (EQTEST (LIST '(%ACOT) Y) FORM)))) + +(DEFMFUN SIMP-%ACSC (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACSC Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS + (COND ((EQUAL 1 Y) %PI//2) ((EQUAL -1 Y) (NEG %PI//2))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACSCH (COEFF Y '$%I 1)))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) + (IF (EQ '%CSC (CAAR Y)) (CADR Y)))) + ($LOGARC (LOGARC '%ACSC Y)) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACSC (NEG Y)))) + (T (EQTEST (LIST '(%ACSC) Y) FORM)))) + +(DEFMFUN SIMP-%ASEC (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASEC Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS + (COND ((EQUAL 1 Y) 0) ((EQUAL -1 Y) '$%PI)))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) + (IF (EQ '%SEC (CAAR Y)) (CADR Y)))) + ($LOGARC (LOGARC '%ASEC Y)) + ((AND $TRIGSIGN (MMINUSP* Y)) (SUB '$%PI (CONS-EXP '%ASEC (NEG Y)))) + (T (EQTEST (LIST '(%ASEC) Y) FORM)))) + +(DECLARE (SPLITFILE AHYPER)) + +(DEFMFUN SIMP-%ASINH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASINH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (IF (ZEROP1 Y) Y))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ASIN (COEFF Y '$%I 1)))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) + (IF (EQ '%SINH (CAAR Y)) (CADR Y)))) + ($LOGARC (LOGARC '%ASINH Y)) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ASINH (NEG Y)))) + (T (EQTEST (LIST '(%ASINH) Y) FORM)))) + +(DEFMFUN SIMP-%ACOSH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOSH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (IF (EQUAL Y 1) 0))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) + (IF (EQ '%COSH (CAAR Y)) (CADR Y)))) + ($LOGARC (LOGARC '%ACOSH Y)) + (T (EQTEST (LIST '(%ACOSH) Y) FORM)))) + +(DEFMFUN SIMP-%ATANH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ATANH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (COND ((ZEROP1 Y) 0) + ((OR (EQUAL Y 1) (EQUAL Y -1)) (DBZ-ERR1 'ATANH))))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL '$%I (CONS-EXP '%ATAN (COEFF Y '$%I 1)))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) + (IF (EQ '%TANH (CAAR Y)) (CADR Y)))) + ($LOGARC (LOGARC '%ATANH Y)) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ATANH (NEG Y)))) + (T (EQTEST (LIST '(%ATANH) Y) FORM)))) + +(DEFMFUN SIMP-%ACOTH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACOTH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (IF (OR (EQUAL Y 1) (EQUAL Y -1)) (DBZ-ERR1 'ACOTH)))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACOT (COEFF Y '$%I 1)))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) + (IF (EQ '%COTH (CAAR Y)) (CADR Y)))) + ($LOGARC (LOGARC '%ACOTH Y)) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACOTH (NEG Y)))) + (T (EQTEST (LIST '(%ACOTH) Y) FORM)))) + +(DEFMFUN SIMP-%ACSCH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ACSCH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (IF (ZEROP1 Y) (DBZ-ERR1 'ACSCH)))) + ((AND $%IARGS (MULTIPLEP Y '$%I)) (MUL -1 '$%I (CONS-EXP '%ACSC (COEFF Y '$%I 1)))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) + (IF (EQ '%CSCH (CAAR Y)) (CADR Y)))) + ($LOGARC (LOGARC '%ACSCH Y)) + ((AND $TRIGSIGN (MMINUSP* Y)) (NEG (CONS-EXP '%ACSCH (NEG Y)))) + (T (EQTEST (LIST '(%ACSCH) Y) FORM)))) + +(DEFMFUN SIMP-%ASECH (FORM Y Z) + (ONEARGCHECK FORM) + (SETQ Y (SIMPCHECK (CADR FORM) Z)) + (COND ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) (ASECH Y)) + (($BFLOATP Y) ($BFLOAT FORM)) + ((AND $%PIARGS (COND ((EQUAL Y 1) 0) + ((ZEROP1 Y) (DBZ-ERR1 'ASECH))))) + ((AND (EQ $TRIGINVERSES '$ALL) (NOT (ATOM Y)) + (IF (EQ '%SECH (CAAR Y)) (CADR Y)))) + ($LOGARC (LOGARC '%ASECH Y)) + ((AND $TRIGSIGN (MMINUSP* Y)) (CONS-EXP '%ASECH (NEG Y))) + (T (EQTEST (LIST '(%ASECH) Y) FORM)))) + +(DECLARE (SPLITFILE TRIGEX) (SPECIAL $TRIGEXPANDPLUS $TRIGEXPANDTIMES)) + +(DEFMFUN $TRIGEXPAND (E) + (COND ((ATOM E) E) + ((SPECREPP E) ($TRIGEXPAND (SPECDISREP E))) + ((TRIGEXPAND (CAAR E) (CADR E))) + (T (RECUR-APPLY #'$TRIGEXPAND E)))) + +(DEFMFUN TRIGEXPAND (OP ARG) + (COND ((ATOM ARG) NIL) + ((AND $TRIGEXPANDPLUS (EQ 'MPLUS (CAAR ARG))) + (COND ((EQ '%SIN OP) (SIN\COS-PLUS (CDR ARG) 1 '%SIN '%COS -1)) + ((EQ '%COS OP) (SIN\COS-PLUS (CDR ARG) 0 '%SIN '%COS -1)) + ((EQ '%TAN OP) (TAN-PLUS (CDR ARG) '%TAN -1)) + ((EQ '%COT OP) (COT-PLUS (CDR ARG) '%COT -1)) + ((EQ '%CSC OP) (CSC\SEC-PLUS (CDR ARG) 1 '%CSC '%SEC -1)) + ((EQ '%SEC OP) (CSC\SEC-PLUS (CDR ARG) 0 '%CSC '%SEC -1)) + ((EQ '%SINH OP) (SIN\COS-PLUS (CDR ARG) 1 '%SINH '%COSH 1)) + ((EQ '%COSH OP) (SIN\COS-PLUS (CDR ARG) 0 '%SINH '%COSH 1)) + ((EQ '%TANH OP) (TAN-PLUS (CDR ARG) '%TANH 1)) + ((EQ '%COTH OP) (COT-PLUS (CDR ARG) '%COTH 1)) + ((EQ '%CSCH OP) (CSC\SEC-PLUS (CDR ARG) 1 '%CSCH '%SECH 1)) + ((EQ '%SECH OP) (CSC\SEC-PLUS (CDR ARG) 0 '%CSCH '%SECH 1)))) + ((AND $TRIGEXPANDTIMES (EQ 'MTIMES (CAAR ARG)) (EQ (TYPEP (CADR ARG)) 'FIXNUM)) + (COND ((EQ '%SIN OP) (SIN\COS-TIMES (CDDR ARG) 1 (CADR ARG) '%SIN '%COS -1)) + ((EQ '%COS OP) (SIN\COS-TIMES (CDDR ARG) 0 (CADR ARG) '%SIN '%COS -1)) + ((EQ '%TAN OP) (TAN-TIMES (CDDR ARG) (CADR ARG) '%TAN -1)) + ((EQ '%COT OP) (COT-TIMES (CDDR ARG) (CADR ARG) '%COT -1)) + ((EQ '%CSC OP) (CSC\SEC-TIMES (CDDR ARG) 1 (CADR ARG) '%CSC '%SEC -1)) + ((EQ '%SEC OP) (CSC\SEC-TIMES (CDDR ARG) 0 (CADR ARG) '%CSC '%SEC -1)) + ((EQ '%SINH OP) (SIN\COS-TIMES (CDDR ARG) 1 (CADR ARG) '%SINH '%COSH 1)) + ((EQ '%COSH OP) (SIN\COS-TIMES (CDDR ARG) 0 (CADR ARG) '%SINH '%COSH 1)) + ((EQ '%TANH OP) (TAN-TIMES (CDDR ARG) (CADR ARG) '%TANH 1)) + ((EQ '%COTH OP) (COT-TIMES (CDDR ARG) (CADR ARG) '%COTH 1)) + ((EQ '%CSCH OP) (CSC\SEC-TIMES (CDDR ARG) 1 (CADR ARG) '%CSCH '%SECH 1)) + ((EQ '%SECH OP) (CSC\SEC-TIMES (CDDR ARG) 0 (CADR ARG) '%CSCH '%SECH 1)))))) + + +(DEFUN SIN\COS-PLUS (L N F1 F2 FLAG) + (DO ((I N (+ 2 I)) (LEN (LENGTH L)) (SIGN 1 (* FLAG SIGN)) (RESULT)) + ((> I LEN) (SIMPLIFY (CONS '(MPLUS) RESULT))) + (SETQ RESULT (MPC (COND ((MINUSP SIGN) '(-1 (MTIMES))) (T '((MTIMES)))) L RESULT F1 F2 LEN I)))) + +(DEFUN TAN-PLUS (L F FLAG) + (DO ((I 1 (+ 2 I)) (SIGN 1 (* FLAG SIGN)) (LEN (LENGTH L)) (NUM) (DEN (LIST 1))) + ((> I LEN) (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN))) + (SETQ NUM (MPC1 (LIST SIGN '(MTIMES)) L NUM F LEN I) + DEN (COND ((= LEN I) DEN) + (T (MPC1 (LIST (* FLAG SIGN) '(MTIMES)) L DEN F LEN (1+ I))))))) + +(DEFUN COT-PLUS (L F FLAG) + (DO ((I (LENGTH L) (- I 2)) (LEN (LENGTH L)) (SIGN 1 (* FLAG SIGN)) (NUM) (DEN)) + ((< I 0) (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN))) + (SETQ NUM (MPC1 (LIST SIGN '(MTIMES)) L NUM F LEN I) + DEN (COND ((= 0 I) DEN) + (T (MPC1 (LIST SIGN '(MTIMES)) L DEN F LEN (1- I))))))) + +(DEFUN CSC\SEC-PLUS (L N F1 F2 FLAG) + (DIV* (DO ((L L (CDR L)) (RESULT)) ((NULL L) (CONS '(MTIMES) RESULT)) + (SETQ RESULT (CONS (CONS-EXP F1 (CAR L)) (CONS (CONS-EXP F2 (CAR L)) RESULT)))) + (SIN\COS-PLUS L N F1 F2 FLAG))) + +(DEFUN SIN\COS-TIMES (L M N F1 F2 FLAG) +;; Assume m,n < 2^17, but Binom may become big +;; Flag is 1 or -1 + (SETQ F1 (CONS-EXP F1 (CONS '(MTIMES) L)) F2 (CONS-EXP F2 (CONS '(MTIMES) L))) + (DO ((I M (+ 2 I)) (END (ABS N)) (RESULT) + (BINOM (COND ((= 0 M) 1) (T (ABS N))) (quotient (times (* FLAG (- END I 1) (- END I)) BINOM) (* (+ 2 I) (1+ I))))) + ((> I END) (SETQ RESULT (SIMPLIFY (CONS '(MPLUS) RESULT))) + (COND ((AND (= 1 M) (MINUSP N)) (NEG RESULT)) (T RESULT))) + (SETQ RESULT (CONS (MUL BINOM (POWER F1 I) (POWER F2 (- END I))) RESULT)))) + +(DEFUN TAN-TIMES (L N F FLAG) + (SETQ F (CONS-EXP F (CONS '(MTIMES) L))) + (DO ((I 1 (+ 2 I)) (END (ABS N)) (NUM) (DEN (LIST 1)) + (BINOM (ABS N) (quotient (times (- END I 1) BINOM) (+ 2 I)))) + ((> I END) (SETQ NUM (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN))) + (COND ((MINUSP N) (NEG NUM)) (T NUM))) + (SETQ NUM (CONS (MUL BINOM (POWER F I)) NUM) + DEN (COND ((= END I) DEN) + (T (CONS (MUL (SETQ BINOM (quotient (times (* FLAG (- END I)) BINOM) (1+ I))) + (POWER F (1+ I))) + DEN)))))) + +(DEFUN COT-TIMES (L N F FLAG) + (SETQ F (CONS-EXP F (CONS '(MTIMES) L))) + (DO ((I (ABS N) (- I 2)) (END (ABS N)) (NUM) (DEN) + (BINOM 1 (quotient (times (* FLAG (1- I)) BINOM) (- END I -2)))) + ((< I 0) (SETQ NUM (DIV* (CONS '(MPLUS) NUM) (CONS '(MPLUS) DEN))) + (IF (MINUSP N) (NEG NUM) NUM)) + (SETQ NUM (CONS (MUL BINOM (POWER F I)) NUM) + DEN (IF (= 0 I) DEN + (CONS (MUL (SETQ BINOM (quotient (times I BINOM) (- END I -1))) (POWER F (1- I))) DEN))))) + +(DEFUN CSC\SEC-TIMES (L M N F1 F2 FLAG) + (DIV* (MUL (POWER (CONS-EXP F1 (CONS '(MTIMES) L)) (ABS N)) + (POWER (CONS-EXP F2 (CONS '(MTIMES) L)) (ABS N))) + (SIN\COS-TIMES L M N F1 F2 FLAG))) + +(DEFUN MPC (DL UL RESULT F1 F2 DI UI) + (COND ((= 0 UI) + (CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F2 L)) UL)) + RESULT)) + ((= DI UI) + (CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F1 L)) UL)) + RESULT)) + (T (MPC (CONS (CONS-EXP F1 (CAR UL)) DL) (CDR UL) + (MPC (CONS (CONS-EXP F2 (CAR UL)) DL) + (CDR UL) RESULT F1 F2 (1- DI) UI) F1 F2 + (1- DI) (1- UI))))) + +(DEFUN MPC1 (DL UL RESULT F DI UI) + (COND ((= 0 UI) (CONS (REVERSE DL) RESULT)) + ((= DI UI) + (CONS (RECONC DL (MAPCAR #'(LAMBDA (L) (CONS-EXP F L)) UL)) RESULT)) + (T (MPC1 (CONS (CONS-EXP F (CAR UL)) DL) (CDR UL) + (MPC1 DL (CDR UL) RESULT F (1- DI) UI) F + (1- DI) (1- UI))))) + +;; Local Modes: +;; Mode: LISP +;; Comment Col: 40 +;; End: + \ No newline at end of file