reduce-historical/reduce2/reduce2.os_source.s.2

                                                                        00000010
OPEN (COMPILE SYSFILE INPUT) RESTORE (COMPILE) CLOSE (COMPILE)          00000020
                                                                        00000030
                                                                        00000040
DEFLIST (((COMMENT (LAMBDA (U A) NIL))) FEXPR)                          00000050
                                                                        00000051
COMMENT (***** DATE OF LAST SYSTEM UPDATE *****)                        00000052
                                                                        00000053
DEFLIST (((DATE* (                                                      00000054
                                                                        00000055
$$$15-SEP-72$                                                           00000056
                                                                        00000057
))) SPECIAL)                                                            00000058
                                                                        00000059
COMMENT (THE FOLLOWING COMMANDS ARE USED BY THE COMPILER)               00000060
                                                                        00000061
OPTIMIZE (T) BPSUSED (T)                                                00000062
                                                                        00000063
COMMENT((R E D U C E    P R E P R O C E S S O R   F O R   L I S P /360))00000090
                                                                        00000100
OVOFF NIL                                                               00000110
                                                                        00000120
COMMENT ((REDUCE CONVERTOR))                                            00000130
                                                                        00000140
REMPROP (DEFINE SUBR)                                                   00000150
                                                                        00000160
SPECIAL ((NOCMP*))                                                      00000170
                                                                        00000180
(LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) ((                      00000190
                                                                        00000200
(DEFINE (LAMBDA (U)                                                     00000210
   (DEF1 U (QUOTE EXPR))))                                              00000220
                                                                        00000230
(DEF1 (LAMBDA (U V)                                                     00000240
  (PROG (X Y)                                                           00000250
   A   (COND ((NULL U) (RETURN Y))                                      00000260
             ((FLAGP (SETQ X (CAAR U)) (QUOTE LOSE)) (GO B))            00000270
             ((GETD (SETQ X (TRANS X NIL)))                             00000280
               (PRINT (LIST (QUOTE *****) X (QUOTE REDEFINED)))))       00000290
       (SETQ Y (NCONC Y (LIST X)))                                      00000300
       (COND (NOCMP* (DEFLIST (LIST (TRANS (CAR U) T)) V))              00000310
             ((EQ V (QUOTE EXPR))                                       00000320
               (COM1 X (TRANS (CADAR U) NIL) NIL))                      00000330
             (T (COM1 X NIL (TRANS (CADAR U) NIL))))                    00000340
   B   (SETQ U (CDR U)) (GO A))))                                       00000350
                                                                        00000360
(TRANS (LAMBDA (U V)                                                    00000370
   (COND   ((NULL U) NIL)                                               00000380
           ((ATOM U) (COND   ((NUMBERP U) U)                            00000390
                             (T                                         00000400
                              ((LAMBDA(X)                               00000410
                                (COND   (X                              00000420
                                         (LIST                          00000430
                                          (QUOTE QUOTE)                 00000440
                                          X))                           00000450
                                        (T ((LAMBDA (Y)                 00000460
                                            (COND (Y Y)                 00000470
   ((AND NOCMP* (GET U (QUOTE SPECIAL)))                                00000480
       (LIST (QUOTE GTS) (LIST (QUOTE QUOTE) U)))                       00000490
                                                  (T U)))               00000500
                                         (GET U (QUOTE NEWNAM))))))     00000510
                                  (GET U (QUOTE CONSTANT))))))          00000520
           ((ATOM (CAR U))                                              00000530
            (COND   ((EQ (CAR U) (QUOTE QUOTE)) U)                      00000540
                    ((NUMBERP (CAR U))                                  00000550
                     (CONS (CAR U) (MAPTR (CDR U))))                    00000560
   ((AND NOCMP* (EQ (CAR U) (QUOTE SETQ))                               00000570
      (GET (CADR U) (QUOTE SPECIAL)))                                   00000580
     (LIST (QUOTE PTS) (LIST (QUOTE QUOTE) (CADR U)) (TRANS             00000590
        (CADDR U) V)))                                                  00000600
                    (T                                                  00000610
                     ((LAMBDA(X)                                        00000620
                       (COND   (X                                       00000630
                                (SUBLIS                                 00000640
                                 (PAIR (CADR X) (MAPTR (CDR U) V))      00000650
                                 (CADDR X)))                            00000660
                                (T (CONS ((LAMBDA (Y)                   00000670
                                   (COND (Y Y)                          00000680
                                         (T ((LAMBDA (Z)                00000690
                                             (COND (Z(LIST (QUOTE QUOTE)00000700
                                                           Z))          00000710
                        (T (TRANS (CAR U) V))))                         00000720
                                       (GET(CAR U) (QUOTE CONSTANT))))))00000730
                                       (GET (CAR U) (QUOTE NEWNAM)))    00000740
                                 (MAPTR (CDR U) V)))))                  00000750
                      (GET (CAR U) (QUOTE NEWFORM))))))                 00000760
           (T (MAPTR U V)))))                                           00000770
                                                                        00000780
(MAPTR (LAMBDA (U V)                                                    00000790
   (COND   ((ATOM U) (TRANS U V))                                       00000800
           (T (CONS (TRANS (CAR U) V) (MAPTR (CDR U) V))))))            00000810
                                                                        00000820
(GETD(LAMBDA(U)                                                         00000830
    (OR (GET U (QUOTE EXPR))                                            00000840
        (GET U (QUOTE FEXPR))                                           00000850
        (GET U (QUOTE SUBR))                                            00000860
        (GET U (QUOTE FSUBR))                                           00000870
        (GET U (QUOTE MACRO)))))                                        00000880
                                                                        00000890
))                                                                      00000900
                                                                        00000910
(LAMBDA NIL (PROG NIL (DEFLIST (LIST (LIST (QUOTE CONVRT)               00000912
           (GET (QUOTE TRANS) (QUOTE SUBR)))) (QUOTE SUBR)))) NIL       00000914
                                                                        00000916
(LAMBDA (U) (DEFLIST U (QUOTE EXPR))) ((                                00000920
                                                                        00000930
(CONSTANT (LAMBDA (U)                                                   00000940
   (DEFLIST U (QUOTE CONSTANT))))                                       00000950
                                                                        00000960
(LOSE (LAMBDA (U)                                                       00000970
   (FLAG U (QUOTE LOSE))))                                              00000980
                                                                        00000990
(NEWFORM (LAMBDA (U)                                                    00001000
   (DEFLIST U (QUOTE NEWFORM))))                                        00001010
                                                                        00001020
(NEWNAM (LAMBDA (U)                                                     00001030
   (DEFLIST U (QUOTE NEWNAM))))                                         00001040
                                                                        00001050
))                                                                      00001060
                                                                        00001070
                                                                        00001080
(LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) ((                      00001090
                                                                        00001100
(SUBLIS (LAMBDA (U V) (COND                                             00001110
  ((NULL U) V)                                                          00001120
        (T ((LAMBDA (X) (COND                                           00001130
      (X (CDR X))                                                       00001140
      ((ATOM V) V)                                                      00001150
      (T (CONS (SUBLIS U (CAR V)) (SUBLIS U (CDR V))))))                00001160
     (SASSOC V U (FUNCTION (LAMBDA NIL NIL))))))))                      00001170
))                                                                      00001180
                                                                        00001190
CONSTANT ((                                                             00001200
 (**BLANK $$$ $)                                                        00001210
 (**COMMA $$$,$)                                                        00001220
 (**DOLLAR $$/$/)                                                       00001230
 (**ESC ESC)                                                            00001240
 (**LPAR $$$($)                                                         00001250
 (**MILLION 1000000)                                                    00001260
 (**DASH $$$-$)                                                         00001270
 (**DOT $$$.$)                                                          00001280
 (**RPAR $$$)$)                                                         00001290
 (**SEMICOL $$$;$)                                                      00001300
 (**STAR $$$*$)                                                         00001310
(**EMARK $$/$/)                                                         00001320
 (**FMARK $$$&$)                                                        00001330
 (**QMARK $$$'$)                                                        00001340
 (**SMARK $$$"$)                                                        00001350
 (**XMARK $$$!$)                                                        00001360
 (**EOF EOF)                                                            00001370
 (**PLUSS $$$+$)                                                        00001380
 (**ENDMSG $$$LEAVING REDUCE ...$)                                      00001390
))                                                                      00001400
                                                                        00001410
NEWNAM ((                                                               00001420
 (DIGIT DIGP)                                                           00001430
 (EVENP *EVENP)                                                         00001440
 (EXPLODE *EXPLODE)                                                     00001450
 (LITER LETP)                                                           00001460
 (OPEN *OPEN)                                                           00001470
(PAIR PAIRX)                                                            00001471
(PAUSE TERPRI)                                                          00001472
 (PRINC PRIN1)                                                          00001480
 (RDS *RDS)                                                             00001500
 (SPACES XTAB)                                                          00001510
 (WRS *WRS)                                                             00001520
))                                                                      00001530
                                                                        00001540
                                                                        00001550
NEWFORM ((                                                              00001560
 (*APPLY (LAMBDA (U V) (APPLY U V ALIST)))                              00001570
 (CAAAAR (LAMBDA (U) (CAAR (CAAR U))))                                  00001580
 (CAAADR (LAMBDA (U) (CAAR (CADR U))))                                  00001590
 (CAADAR (LAMBDA (U) (CAAR (CDAR U))))                                  00001600
 (CAADDR (LAMBDA (U) (CAAR (CDDR U))))                                  00001610
 (CADAAR (LAMBDA (U) (CADR (CAAR U))))                                  00001620
 (CADADR (LAMBDA (U) (CADR (CADR U))))                                  00001630
 (CADDAR (LAMBDA (U) (CADR (CDAR U))))                                  00001640
 (CADDDR (LAMBDA (U) (CADR (CDDR U))))                                  00001650
 (CDAAAR (LAMBDA (U) (CDAR (CAAR U))))                                  00001660
 (CDAADR (LAMBDA (U) (CDAR (CADR U))))                                  00001670
 (CDADAR (LAMBDA (U) (CDAR (CDAR U))))                                  00001680
 (CDDAAR (LAMBDA (U) (CDDR (CAAR U))))                                  00001690
 (CDDADR (LAMBDA (U) (CDDR (CADR U))))                                  00001700
 (CDDDAR (LAMBDA (U) (CDDR (CDAR U))))                                  00001710
 (CDDDDR (LAMBDA (U) (CDDR (CDDR U))))                                  00001720
 (DIVIDE (LAMBDA (U V) (CONS (QUOTIENT U V) (REMAINDER U V))))          00001730
 (ERRORSET (LAMBDA (U V) (LIST (*EVAL U))))                             00001740
 (GENSYM (LAMBDA NIL (GENSYM1 (QUOTE $$$   G$))))                       00001750
 (ONEP (LAMBDA (N) (EQUAL N 1)))                                        00001760
 (READCH (LAMBDA NIL (READCH NIL)))                                     00001770
))                                                                      00001780
                                                                        00001790
                                                                        00001800
                                                                        00001810
COMMENT ((DECLARATION OF SPECIAL AND GLOBAL VARIABLES))                 00001820
                                                                        00001830
COMMENT ((THE FOLLOWING ARE EXTENDED SPECIAL VARIABLES))                00001840
                                                                        00001850
SPECIAL ((*S* *S1*))                                                    00001860
                                                                        00001870
COMMENT ((THE FOLLOWING VARIABLES ARE GLOBAL TO ALL FUNCTIONS))         00001880
                                                                        00001890
SPECIAL((                                                               00001900
 IFL* OFL* IPL* OPL* PRI* CRCHAR* SV* MCOND*                            00001910
 *FORT *ECHO *INT PRECLIS* ORIG* POSN* *NAT YCOORD*                     00001920
 YMIN* YMAX* *LIST COUNT* *CARDNO ECHO* FORTVAR*                        00001930
 LLENGTH* PLINE* CURSYM* *MODE MATP* DEFN*                              00001940
 SEMIC* SYMFG* VARS* TMODE* *SQVAR* PROGRAM* PROGRAML*                  00001950
 *GCD *EXP *MCD *FLOAT MATCH* *DIV *RAT *SUPER *MSG                     00001960
 *ALLFAC *NCMP SUBFG* FRLIS1* FRLIS* GAMIDEN* SUB2*                     00001970
 RPLIS* SUBL* DSUBL* FACTORS* FRASC* VREP* INDICES*                     00001980
 WTP* SNO* *RAT *OUTP DIAG*                                             00001990
 MCHFG* SYMFG* *ANS *RESUBS *NERO EXLIST* ORDN*                         00002000
NAT**                                                                   00002001
))                                                                      00002010
                                                                        00002020
COMMENT ((THE FOLLOWING VARIABLE IS USED AS A FUNCTIONAL ARGUMENT))     00002030
                                                                        00002040
COMMON ((*PI*))                                                         00002050
                                                                        00002060
REMPROP (F APVAL)                                                       00002070
                                                                        00002080
                                                                        00002090
COMMENT ((REDUCE FUNCTIONS WITH SYSTEM DEPENDENT PROPERTIES))           00002100
                                                                        00002110
DEFLIST ((                                                              00002120
                                                                        00002130
(INIT (LAMBDA NIL (PROG NIL                                             00002140
 (PTS (QUOTE NOCMP*) T)                                                 00002150
 (RECLAIM)                                                              00002160
 (OPEN (QUOTE REDUCE) (QUOTE SYSFILE) (QUOTE OUTPUT))                   00002170
 (REMPROP (QUOTE INIT) (QUOTE EXPR))                                    00002200
 (RETURN (QUOTE ***)))))                                                00002210
                                                                        00002220
) EXPR)                                                                 00002230
                                                                        00002240
(LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) ((                      00002250
                                                                        00002260
(MKSTRING (LAMBDA (U)                                                   00002270
(LIST (QUOTE QUOTE)(COMPRESS (DELETE (QUOTE $$$"$) (CDR U))))))         00002280
                                                                        00002281
(PRINTTY (LAMBDA (U)                                                    00002282
   (AND *NAT (PRINT U))))                                               00002283
                                                                        00002290
(READCH* (LAMBDA NIL                                                    00002300
   (SETQ CRCHAR* (READCH NIL))))                                        00002310
                                                                        00002320
))                                                                      00002330
                                                                        00002340
(LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) ((                      00002390
                                                                        00002400
(BEGIN (LAMBDA NIL (PROG NIL                                            00002410
 (OVOFF)                                                                00002420
 (SETQ NOCMP* T)                                                        00002430
 (SETQ *INT NIL)                                                        00002440
 (SETQ *ECHO T)                                                         00002450
 (SETQ ORIG* 0)                                                         00002460
 (SETP)                                                                 00002470
 (SETQ *MODE (QUOTE ALGEBRAIC))                                         00002480
         (COND ((NULL DATE*) (GO A0)))                                  00002490
 (VERBOS NIL)                                                           00002500
 (EXCISE T)                                                             00002510
 (EXITERR T)                                                            00002520
         (EJECT)                                                        00002521
         (PRIN1 (QUOTE $$$REDUCE2($))                                   00002522
         (PRIN1 DATE*)                                                  00002523
         (PRIN1 (QUOTE $$$) ...$))                                      00002524
         (TERPRI) (SETQ DATE* NIL)                                      00002525
 A0  (SETQ IFL* NIL)                                                    00002540
 (SETQ OFL* NIL)                                                        00002550
 (RETURN (BEGIN1)))))                                                   00002570
                                                                        00002580
))                                                                      00002590
                                                                        00002600
                                                                        00002610
COMMENT ((REDUCE FUNCTIONS DEFINED IN TERMS OF SYSTEM FUNCTIONS         00002620
          OF THE SAME NAME))                                            00002630
                                                                        00002640
COMMENT ((THE FOLLOWING LIST IS USED BY EXPLODN1 DEFINED BELOW))        00002650
                                                                        00002660
DEFLIST (((NASL* (((0 . $$$0$) (1 . $$$1$) (2 . $$$2$) (3 . $$$3$)      00002670
            (4 . $$$4$) (5 . $$$5$) (6 . $$$6$) (7 . $$$7$)             00002680
            (8 . $$$8$) (9 . $$$9$))))) SPECIAL)                        00002690
                                                                        00002700
DEFLIST (((BLKSIZE* (80))) SPECIAL)                                     00002701
                                                                        00002702
(LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) ((                      00002710
                                                                        00002720
(*EXPLODE (LAMBDA (U) (COND                                             00002730
  ((NUMBERP U) (EXPLODN U))                                             00002740
  (T (EXPLODE U)))))                                                    00002750
                                                                        00002760
(EXPLODN (LAMBDA (U) (COND                                              00002770
  ((ZEROP U) (LIST (QUOTE $$$0$)))                                      00002780
  ((MINUSP U) (CONS (QUOTE $$$-$) (EXPLODN (MINUS U))))                 00002790
  ((NOT (FIXP U)) (LIST 1 2 3 4 5 6 7 8 9 0 1 2))                       00002800
  (T (EXPLODN1 U)))))                                                   00002810
                                                                        00002820
(EXPLODN1 (LAMBDA (U) (PROG (Z)                                         00002830
 A (COND ((ZEROP U) (RETURN Z)))                                        00002840
   (SETQ Z (CONS (CDR (ASSOC* (REMAINDER U 10) NASL*)) Z))              00002850
   (SETQ U (QUOTIENT U 10))                                             00002860
   (GO A))))                                                            00002870
                                                                        00002880
(ASSOC* (LAMBDA (U V)                                                   00002890
  (COND ((NULL V) NIL)                                                  00002900
    ((EQUAL U (CAAR V)) (CAR V))                                        00002910
    (T (ASSOC* U (CDR V))))))                                           00002920
                                                                        00002930
(*OPEN (LAMBDA (U V) (PROG2                                             00002935
   (OPEN U (LIST (QUOTE (LRECL . 80)) (CONS (QUOTE BLKSIZE)             00002940
                            BLKSIZE*)) V)                               00002945
   U)))                                                                 00002950
                                                                        00002960
(*RDS (LAMBDA (U) (COND                                                 00002970
  ((NULL U) (RDS (QUOTE LISPIN)))                                       00002980
  (T (RDS U)))))                                                        00002990
                                                                        00003000
(*WRS (LAMBDA (U) (COND                                                 00003010
  ((NULL U) (WRS (QUOTE LISPOUT)))                                      00003020
  (T (PROG NIL (OTLL 72) (ASA NIL) (WRS U))))))                         00003030
))                                                                      00003040
                                                                        00003050
LOSE ((ASSOC* REMK* TERMS CKRN* UP DOWN SYMMETRIC ANTISYMMETRIC))       00003060
                                                                        00003070
COMMENT ((STANDARD LISP FUNCTIONS NOT DEFINED IN LISP/360))             00003080
                                                                        00003090
                                                                        00003100
DEFINE ((                                                               00003110
                                                                        00003120
(COMPRESS (LAMBDA (U)                                                   00003130
   (PROG2 (COND ((DIGIT (CAR U))                                        00003140
                 (MAP U (FUNCTION (LAMBDA (J) (RNUMB (CAR J))))))       00003150
           (T    (MAP U (FUNCTION (LAMBDA (J) (RLIT (CAR J)))))))       00003160
          (MKATOM))))                                                   00003170
                                                                        00003180
(GTS (LAMBDA (U) ((LAMBDA (X) (COND                                     00003190
  ((NULL X) (ERROR (LIST (QUOTE GTS) U)))                               00003200
  (T (CAR X))))  (GET U (QUOTE SPECIAL)))))                             00003210
                                                                        00003220
(PTS (LAMBDA (U V) (CAR ((LAMBDA (X) (COND                              00003230
  ((NULL X) (PUT U (QUOTE SPECIAL) (LIST V)))                           00003240
  (T (RPLACA X V)))) (GET U (QUOTE SPECIAL))))))                        00003250
                                                                        00003260
(PUT (LAMBDA (U V W)                                                    00003270
  (PROG2 (DEFLIST (LIST (LIST U W)) V) W)))                             00003280
                                                                        00003290
(*EVAL (LAMBDA (U) ((LAMBDA (X) (COND                                   00003300
      (X (CAR X))                                                       00003310
      (T (EVAL U ALIST))))                                              00003320
    (GET* U (QUOTE SPECIAL)))))                                         00003330
                                                                        00003340
(PAIRX (LAMBDA (U V)                                                    00003341
   (COND ((AND (NULL U) (NULL V)) NIL)                                  00003342
      ((OR (NULL U) (NULL V)) (ERROR (QUOTE (PAIR MISMATCH))))          00003343
    (T (CONS (CONS (CAR U) (CAR V)) (PAIRX (CDR U) (CDR V)))))))        00003344
                                                                        00003345
))                                                                      00003350
                                                                        00003360
COMMENT ((REDEFINING SOME FUNCTIONS EXCISED FROM THE COMPILER))         00003370
                                                                        00003380
DEFINE ((                                                               00003390
                                                                        00003400
(MAP (LAMBDA (U *PI*)                                                   00003410
  (PROG NIL                                                             00003420
   A  (COND ((NULL U) (RETURN NIL)))                                    00003430
      (*PI* U)                                                          00003440
      (SETQ U (CDR U))                                                  00003450
      (GO A))))                                                         00003460
                                                                        00003470
(MAPCON (LAMBDA (U *PI*)                                                00003480
   (COND ((NULL U) NIL)                                                 00003490
    (T (NCONC (*PI* U) (MAPCON (CDR U) *PI*))))))                       00003500
                                                                        00003510
(REVERSE (LAMBDA (U)                                                    00003520
   (PROG (V)                                                            00003530
    A (COND ((NULL U) (RETURN V)))                                      00003540
      (SETQ V (CONS (CAR U) V))                                         00003550
      (SETQ U (CDR U))                                                  00003560
      (GO A))))                                                         00003570
                                                                        00003580
(SUBST (LAMBDA (U V W)                                                  00003590
   (COND ((NULL W) NIL)                                                 00003600
      ((EQUAL V W) U)                                                   00003610
      ((ATOM W) W)                                                      00003620
      (T (CONS (SUBST U V (CAR W)) (SUBST U V (CDR W)))))))             00003630
                                                                        00003640
))                                                                      00003650
                                                                        00003660
COMMENT (ARRAY HANDLING ROUTINES)                                       00003670
                                                                        00003680
DEFINE ((                                                               00003690
                                                                        00003700
(*ARRAY (LAMBDA (U)                                                     00003710
  (MAP U (FUNCTION (LAMBDA (J)                                          00003720
      (PUT (CAAR J) (QUOTE ARRAY) (MKARRAY (CDAR J))))))))              00003730
                                                                        00003740
(MKARRAY (LAMBDA (U)                                                    00003750
  (COND ((NULL U) NIL)                                                  00003760
   (T (ARLIST (CDR U) (CAR U))))))                                      00003770
                                                                        00003772
(ARLIST (LAMBDA (U N)                                                   00003774
  (COND ((ZEROP N) NIL) (T (CONS (MKARRAY U) (ARLIST U (SUB1 N)))))))   00003776
                                                                        00003780
(GETEL (LAMBDA (U)                                                      00003790
  (GETEL1 (GET (CAR U) (QUOTE ARRAY)) (CDR U))))                        00003800
                                                                        00003810
(GETEL1 (LAMBDA (U V)                                                   00003820
  (COND ((NULL V) U)                                                    00003830
  (T (GETEL1 (NTH U (ADD1 (CAR V))) (CDR V))))))                        00003840
                                                                        00003850
(SETEL (LAMBDA (U V)                                                    00003860
   (PROG (X N)                                                          00003870
      (SETQ X (REVERSE (CDR U)))                                        00003880
      (SETQ N (CAR X))                                                  00003890
      (SETQ X (GETEL1 (GET (CAR U) (QUOTE ARRAY))                       00003900
                      (REVERSE (CDR X))))                               00003910
  A    (COND ((EQUAL N 0) (RETURN (RPLACA X V))))                       00003920
      (SETQ N (SUB1 N))                                                 00003930
      (SETQ X (CDR X))                                                  00003940
      (GO A))))                                                         00003950
                                                                        00003960
))                                                                      00003970
                                                                        00003980
COMMENT ((I O HANDLING ROUTINES))                                       00003990
                                                                        00004000
DEFINE ((                                                               00004010
                                                                        00004020
(IN (LAMBDA (U)                                                         00004030
  (INOUT U (QUOTE INPUT))))                                             00004040
                                                                        00004050
(OUT (LAMBDA (U)                                                        00004060
  (INOUT U (QUOTE OUTPUT))))                                            00004070
                                                                        00004080
(INOUT (LAMBDA (U V)                                                    00004090
  (PROG (ECHO INT)                                                      00004100
    (SETQ ECHO *ECHO)                                                   00004110
    (SETQ INT *INT)                                                     00004120
 A  (COND ((NULL U) (GO E))                                             00004130
       ((EQ V (QUOTE OUTPUT)) (GO C))                                   00004140
       ((EQ (CAR U) (QUOTE T)) (GO L)))                                 00004150
    (SETQ IFL* (CAR U))                                                 00004160
    (COND ((MEMBER IFL* IPL*) (GO B)))                                  00004170
    (OPEN IFL* V)                                                       00004180
    (SETQ IPL* (CONS IFL* IPL*))                                        00004190
  B (RDS IFL*)                                                          00004200
    (SETQ *ECHO T)                                                      00004210
    (SETQ *INT NIL)                                                     00004220
    (BEGIN1)                                                            00004230
    (SETQ U (CDR U))                                                    00004240
    (GO A)                                                              00004250
  C (COND ((EQ (CAR U) (QUOTE T)) (GO M)))                              00004260
    (SETQ OFL* (CAR U))                                                 00004270
    (COND ((MEMBER OFL* OPL*) (GO D)))                                  00004280
    (OPEN OFL* V)                                                       00004290
    (SETQ OPL* (CONS OFL* OPL*))                                        00004300
  D (WRS OFL*)                                                          00004310
  E (SETQ *ECHO ECHO)                                                   00004320
    (SETQ *INT INT)                                                     00004330
    (RETURN NIL)                                                        00004340
  L (SETQ IFL* NIL)                                                     00004350
    (RDS NIL)                                                           00004360
    (GO E)                                                              00004370
  M (SETQ OFL* NIL)                                                     00004380
    (WRS NIL)                                                           00004390
    (GO E)                                                              00004400
)))                                                                     00004410
                                                                        00004420
(SHUT (LAMBDA (U)                                                       00004430
  (PROG (X)                                                             00004440
 A  (COND ((NULL U) (RETURN NIL)))                                      00004450
    (SETQ X (CAR U))                                                    00004460
    (COND ((MEMBER X OPL*) (GO B))                                      00004470
       ((NOT (MEMBER X IPL*))                                           00004480
         (REDERR (CONS X (QUOTE (NOT OPEN))))))                         00004490
    (CLOSE X)                                                           00004500
    (SETQ IPL* (DELETE X IPL*))                                         00004510
    (COND ((NOT (EQUAL X IFL*)) (GO C)))                                00004520
       (RDS (SETQ IFL* (COND (IPL* (CAR IPL*)) (T NIL))))               00004530
    (GO C)                                                              00004540
  B (SETQ OPL* (DELETE X OPL*))                                         00004550
    (CLOSE X)                                                           00004560
    (COND ((NOT (EQ X OFL*)) (GO C)))                                   00004570
    (SETQ OFL* NIL)                                                     00004580
    (WRS NIL)                                                           00004590
  C  (SETQ U (CDR U))                                                   00004600
    (GO A))))                                                           00004610
                                                                        00004620
))                                                                      00004630
                                                                        00004640
DEFLIST (((SHUT RLIS) (IN RLIS) (OUT RLIS)) STAT)                       00004650
                                                                        00004660
                                                                        00004670
COMMENT ((INITIALIZATION OF INPUT AND OUTPUT CHARACTER STRINGS))        00004680
                                                                        00004690
CSET (SWITCH* (                                                         00004700
 ($$*$* NIL *SEMICOL* NIL)                                              00004710
 ($$$;$ NIL *SEMICOL* NIL)                                              00004720
 ($$$+$ NIL PLUS NIL $$$ + $)                                           00004730
 ($$$-$ NIL MINUS NIL $$$ - $)                                          00004740
 ($$$*$ $$$*$ TIMES EXPT)                                               00004750
($$$/$ NIL QUOTIENT NIL)                                                00004760
 ($$$=$ NIL EQUAL NIL)                                                  00004770
 ($$$,$ NIL *COMMA* NIL)                                                00004780
 ($$$($ NIL *LPAR* NIL)                                                 00004790
 ($$$)$ NIL *RPAR* NIL)                                                 00004800
 ($$$.$ NIL CONS NIL)                                                   00004810
 ($$$:$ $$$=$ *COLON* SETQ)                                             00004820
 ($$$<$ $$$=$ LESSP LESSEQ)                                             00004830
 ($$$>$ $$$=$ GREATERP GREATEQ)                                         00004840
))                                                                      00004850
                                                                        00004860
                                                                        00004870
COMMENT ((E N D   O F   R E D U C E   P R E P R O C E S S O R))         00004880
                                                                        00004890
                                                                        00004900
                                                                        00004910
                                                                        00010000
                                                                        00010010
                                                                        00010020
COMMENT ((R E D U C E    M A I N    P R O G R A M))                     00010030
                                                                        00010040
(LAMBDA (U) (MAP U (FUNCTION (LAMBDA (J) (PTS (CAR J) NIL))))) ((*FORT  00010050
 *ECHO *INT PRECLIS* ORIG* POSN* *NAT YCOORD* YMIN* YMAX* *LIST COUNT*  00010060
 *CARDNO ECHO* FORTVAR* LLENGTH* PLINE* CURSYM* *MODE MATP* DEFN*       00010070
 SEMIC* SYMFG* *MSG TMODE* *SQVAR* PROGRAM* PROGRAML* DIAG* VARS*       00010080
 CRCHAR* IFL* OFL* IPL* OPL* PRI* ERFG*))                               00010090
                                                                        00010100
(LAMBDA (U) (MAP U (FUNCTION (LAMBDA (J) (PTS (CAAR J) (CADAR J))))))   00010110
(((*NAT T) (COUNT* 1) (*CARDNO 20) (ORIG* 0) (LLENGTH* 67) (*SQVAR* (T  00010120
))))                                                                    00010130
                                                                        00010140
DEFINE ((                                                               00010150
                                                                        00010160
(FLAGP** (LAMBDA (U V)                                                  00010170
   (AND (ATOM U) (NOT (NUMBERP U)) (FLAGP U V))))                       00010180
                                                                        00010190
(GET* (LAMBDA (U V)                                                     00010200
   (COND ((NUMBERP U) NIL) (T (GET U V)))))                             00010210
                                                                        00010220
(EQCAR (LAMBDA (U V)                                                    00010230
   (AND (NOT (ATOM U)) (EQ (CAR U) V))))                                00010240
                                                                        00010250
(MKPREC (LAMBDA NIL                                                     00010260
   (PROG (X Y)                                                          00010270
       (SETQ X (CONS (QUOTE SETQ) PRECLIS*))                            00010280
       (SETQ Y 2)                                                       00010290
    A    (COND ((NULL X) (RETURN NIL)))                                 00010300
       (PUT (CAR X) (QUOTE INFIX) Y)                                    00010310
       (SETQ X (CDR X))                                                 00010320
       (SETQ Y (ADD1 Y))                                                00010330
       (GO A))))                                                        00010340
                                                                        00010350
))                                                                      00010360
                                                                        00010370
PTS (PRECLIS* (AND OR MEMBER EQUAL UNEQ EQ GREATEQ GREATERP LESSEQ      00010380
 LESSP PLUS MINUS TIMES QUOTIENT EXPT CONS))                            00010390
                                                                        00010400
(LAMBDA NIL (PROG (W X Y Z) (MKPREC) (SETQ X SWITCH*) (MAP X (FUNCTION  00010410
 (LAMBDA (J) (PUT (CAAR J) (QUOTE SWITCH*) (CDAR J))))) A (COND ((NULL  00010420
 X) (RETURN NIL))) (SETQ W (CDAR X)) (PUT (CADR W) (QUOTE PRTCH) (LIST  00010430
 (CAAR X) (CAAR X))) (COND ((CAR (SETQ Y (CDDR W))) (PROG2 (SETQ Z      00010440
(COMPRESS (LIST (CAAR X)(CAR W))))(PUT (CAR Y)(QUOTE PRTCH) (LIST Z Z)  00010450
)))) (COND ((NULL (CDR Y)) (GO B)) ((CADR Y) (RPLACA (GET (CADR W)      00010460
(QUOTE PRTCH))(CADR Y))))(COND ((CDDR Y)(RPLACA (GET (CAR Y) (QUOTE     00010470
 PRTCH)) (CADDR Y)))) B (SETQ X (CDR X)) (GO A))) NIL                   00010480
                                                                        00010490
DEFLIST (((MINUS (PLUS . MINUS))) ALT)                                  00010500
                                                                        00010510
DEFINE ((                                                               00010520
                                                                        00010530
(RVLIS (LAMBDA NIL                                                      00010540
   (PROG (X)                                                            00010550
    A    (SETQ X (CONS (SCAN) X))                                       00010560
       (COND                                                            00010570
        ((OR (FLAGP** (SCAN) (QUOTE DELIM))                             00010580
             (MEMBER CURSYM* (QUOTE (CLEAR LET MATCH SAVEAS))))         00010590
         (RETURN X))                                                    00010600
        ((NOT (EQ CURSYM* (QUOTE *COMMA*))) (CURERR NIL T)))            00010610
       (GO A))))                                                        00010620
                                                                        00010630
(INFIXFN (LAMBDA NIL                                                    00010640
   (PROG (X)                                                            00010650
       (SETQ X (RVLIS))                                                 00010660
       (COND                                                            00010670
        ((EQ *MODE (QUOTE ALGEBRAIC))                                   00010680
         (*APPLY (QUOTE OPERATOR) (LIST X))))                           00010690
       (SETQ PRECLIS* (APPEND X PRECLIS*))                              00010700
       (MKPREC))))                                                      00010710
                                                                        00010720
(PRECEDFN (LAMBDA NIL                                                   00010730
   (PROG (W X Y Z)                                                      00010740
       (SETQ X (RVLIS))                                                 00010750
       (SETQ Y (CAR X))                                                 00010760
       (SETQ X (CADR X))                                                00010770
       (SETQ PRECLIS* (DELETE X PRECLIS*))                              00010780
       (SETQ W PRECLIS*)                                                00010790
    A    (COND ((NULL W) (REDERR (CONS Y (QUOTE (NOT FOUND)))))         00010800
             ((EQ Y (CAR W)) (GO B)))                                   00010810
       (SETQ Z (CONS (CAR W) Z))                                        00010820
       (SETQ W (CDR W))                                                 00010830
       (GO A)                                                           00010840
    B    (SETQ PRECLIS*                                                 00010850
             (NCONC (REVERSE Z) (CONS (CAR W) (CONS X (CDR W)))))       00010860
       (MKPREC))))                                                      00010870
                                                                        00010880
))                                                                      00010890
                                                                        00010900
DEFINE ((                                                               00010910
                                                                        00010920
(MATHPRINT (LAMBDA (L)                                                  00010930
   (PROG NIL (MAPRIN L) (TERPRI*))))                                    00010940
                                                                        00010950
(MAPRIN (LAMBDA (U)                                                     00010960
   (MAPRINT U 0)))                                                      00010970
                                                                        00010980
(MAPRINT (LAMBDA (L P)                                                  00010990
   (PROG (X Y)                                                          00011000
       (COND ((NULL L) (RETURN NIL))                                    00011010
             ((ATOM L) (GO B))                                          00011020
             ((NOT (ATOM (CAR L))) (MAPRINT (CAR L) P))                 00011030
             ((SETQ X (GET* (CAR L) (QUOTE INFIX))) (GO A))             00011040
             ((SETQ X (GET* (CAR L) (QUOTE SPECPRN)))                   00011050
            (RETURN (*APPLY X (LIST (CDR L)))))                         00011060
             (T (PRINC* (CAR L))))                                      00011070
       (PRINC* **LPAR)                                                  00011080
       (INPRINT (QUOTE *COMMA*) 0 (CDR L))                              00011090
    E    (RETURN (PRINC* **RPAR))                                       00011100
    B    (COND ((NUMBERP L) (GO D))                                     00011110
             ((SETQ X (GET L (QUOTE OLDNAME)))                          00011120
            (RETURN (PRINC* X))))                                       00011130
    C    (RETURN (PRINC* L))                                            00011140
    D    (COND ((NOT (MINUSP L)) (GO C)))                               00011150
       (PRINC* **LPAR)                                                  00011160
       (PRINC* L)                                                       00011170
       (GO E)                                                           00011180
    A    (SETQ P (NOT (GREATERP X P)))                                  00011190
       (COND ((NOT P) (GO G)))                                          00011200
       (SETQ Y ORIG*)                                                   00011210
       (PRINC* **LPAR)                                                  00011220
       (COND ((LESSP POSN* 15) (SETQ ORIG* POSN*)))                     00011230
    G    (INPRINT (CAR L) X (CDR L))                                    00011240
       (COND ((NOT P) (RETURN NIL)))                                    00011250
       (PRINC* **RPAR)                                                  00011260
       (SETQ ORIG* Y))))                                                00011270
                                                                        00011280
(INPRINT (LAMBDA (OP P L)                                               00011290
   (PROG NIL                                                            00011300
       (COND ((FLAGP OP (QUOTE UNIP)) (GO A)))                          00011310
       (MAPRINT (CAR L) P)                                              00011320
       (GO C)                                                           00011330
    A    (COND ((NULL L) (RETURN NIL))                                  00011340
             ((AND (NOT (ATOM (CAR L)))                                 00011350
                 (GET* (CAAR L) (QUOTE ALT))                            00011360
                 (EQ OP (CAR (GET* (CAAR L) (QUOTE ALT)))))             00011370
            (GO B)))                                                    00011380
       (OPRIN OP)                                                       00011390
    B    (MAPRINT (CAR L) P)                                            00011400
       (COND ((OR (NOT *NAT) (NOT (EQ OP (QUOTE EXPT)))) (GO C)))       00011410
       (SETQ YCOORD* (SUB1 YCOORD*))                                    00011420
       (SETQ YMIN* (*EVAL (LIST (QUOTE MIN) YMIN* YCOORD*)))            00011430
    C    (SETQ L (CDR L))                                               00011440
       (GO A))))                                                        00011450
                                                                        00011460
))                                                                      00011470
                                                                        00011480
DEFINE ((                                                               00011490
                                                                        00011500
(OPRIN (LAMBDA (OP)                                                     00011510
   ((LAMBDA(X)                                                          00011520
     (COND ((NULL X) (PRINC* OP))                                       00011530
         (*FORT (PRINC* (CADR X)))                                      00011540
         (*NAT                                                          00011550
          (COND ((EQ OP (QUOTE EXPT))                                   00011560
               (PROG NIL                                                00011570
                   (SETQ YCOORD* (ADD1 YCOORD*))                        00011580
                   (SETQ YMAX*                                          00011590
                         (*EVAL                                         00011600
                        (LIST (QUOTE MAX) YMAX* YCOORD*)))))            00011610
              ((AND *LIST                                               00011620
                  (MEMBER OP (QUOTE (PLUS MINUS QUOTIENT))))            00011630
               (PROG NIL (CLOSELINE) (TERPRI) (PPRINT (CAR X))))        00011640
              (T (PPRINT (CAR X)))))                                    00011650
         (T (PRINC (CAR X)))))                                          00011660
    (GET OP (QUOTE PRTCH)))))                                           00011670
                                                                        00011680
(PRINC* (LAMBDA (U)                                                     00011690
   (COND (*NAT (PPRINT U))                                              00011700
       ((NULL *FORT) (PRINC U))                                         00011710
       (T                                                               00011720
        (PROG NIL                                                       00011730
            (COND                                                       00011740
             ((AND (EQUAL COUNT* *CARDNO)                               00011750
                   (OR (EQ U **PLUSS) (EQ U **DASH)))                   00011760
              (GO B))                                                   00011770
             ((NOT                                                      00011780
               (GREATERP (SETQ POSN*                                    00011790
                           (PLUS POSN* (LENGTH (EXPLODE U))))           00011800
                             69))                                       00011810
              (GO A)))                                                  00011820
            (TERPRI)                                                    00011830
            (SPACES 5)                                                  00011840
            (PRINC (QUOTE X))                                           00011850
         (SETQ POSN* (PLUS 6 (LENGTH (EXPLODE U))))                     00011860
            (SETQ COUNT* (ADD1 COUNT*))                                 00011870
          A    (RETURN (COND (ECHO* (PRINC U)) (T NIL)))                00011880
          B    (TERPRI)                                                 00011890
            (SPACES 6)                                                  00011900
            (PRINC FORTVAR*)                                            00011910
            (OPRIN (QUOTE EQUAL))                                       00011920
            (PRINC FORTVAR*)                                            00011930
            (SETQ COUNT* 1)                                             00011940
                (SETQ POSN* 20)                                         00011941
            (GO A))))))                                                 00011950
                                                                        00011960
(TERPRI* (LAMBDA NIL                                                    00011970
   (COND (*NAT (PROG NIL (CLOSELINE) (COND (ECHO* (TERPRI)))))          00011980
         (*FORT (COND ((ZEROP POSN*) NIL)                               00011990
                      (T (PROG NIL (TERPRI) (SETQ COUNT* 1)             00011992
                             (SETQ POSN* 0)))))                         00011994
       (T (TERPRI)))))                                                  00012000
                                                                        00012010
(PPRINT (LAMBDA (U)                                                     00012020
   (PROG (M N)                                                          00012030
       (SETQ N (LENGTH (EXPLODE U)))                                    00012040
       (COND ((GREATERP N LLENGTH*) (GO A1)))                           00012050
    C    (SETQ M (PLUS POSN* N))                                        00012060
       (COND ((AND (GREATERP M LLENGTH*) (NOT (TERPRI*))) (GO C)))      00012070
       (SETQ PLINE*                                                     00012080
             (CONS (CONS (CONS (CONS POSN* M) YCOORD*) U) PLINE*))      00012090
    A    (RETURN (SETQ POSN* M))                                        00012100
    A1   (TERPRI*)                                                      00012110
       (PRINC U)                                                        00012120
       (RETURN (SETQ POSN* (REMAINDER N LLENGTH*))))))                  00012130
                                                                        00012140
(CLOSELINE (LAMBDA NIL                                                  00012150
   (PROG (N)                                                            00012160
       (COND ((OR (NULL PLINE*) (NULL ECHO*)) (GO C)))                  00012170
       (SETQ N YMAX*)                                                   00012180
       (SETQ PLINE* (REVERSE PLINE*))                                   00012190
    A    (SCPRINT PLINE* N)                                             00012200
       (COND ((EQUAL N YMIN*) (GO B)))                                  00012210
       (TERPRI)                                                         00012220
       (SETQ N (SUB1 N))                                                00012230
       (GO A)                                                           00012240
    B    (COND ((EQ ECHO* (QUOTE RESULT)) (TERPRI)))                    00012250
    C    (SETP))))                                                      00012260
                                                                        00012270
(SCPRINT (LAMBDA (U N)                                                  00012280
   (PROG (M)                                                            00012290
       (SETQ POSN* 0)                                                   00012300
    A    (COND ((NULL U) (RETURN NIL))                                  00012310
             ((NOT (EQUAL (CDAAR U) N)) (GO B))                         00012320
             ((NOT (MINUSP (SETQ M (DIFFERENCE (CAAAAR U) POSN*))))     00012330
            (SPACES M)))                                                00012340
       (PRINC (CDAR U))                                                 00012350
       (SETQ POSN* (CDAAAR U))                                          00012360
    B    (SETQ U (CDR U))                                               00012370
       (GO A))))                                                        00012380
                                                                        00012390
(SPACES* (LAMBDA (N)                                                    00012400
   (COND (*NAT (SETQ POSN* (PLUS N POSN*))) (T (SPACES N)))))           00012410
                                                                        00012420
))                                                                      00012430
                                                                        00012440
DEFINE ((                                                               00012450
                                                                        00012460
(SETP (LAMBDA NIL                                                       00012470
   (PROG NIL                                                            00012480
       (SETQ PLINE* NIL)                                                00012490
       (SETQ POSN* ORIG*)                                               00012500
       (SETQ YMAX* 0)                                                   00012510
       (SETQ YMIN* 0)                                                   00012520
       (SETQ YCOORD* 0))))                                              00012530
                                                                        00012540
))                                                                      00012550
                                                                        00012560
FLAG ((MINUS NOT) UNIP)                                                 00012570
                                                                        00012580
DEFINE ((                                                               00012590
                                                                        00012600
(MREAD* (LAMBDA (J)                                                     00012610
   (PROG2 (SCAN) (MREAD J))))                                           00012620
                                                                        00012630
(MREAD (LAMBDA (J)                                                      00012640
   (PROG (U V W W1 X Y Z)                                               00012650
       (SETQ Z -1)                                                      00012660
    A    (SETQ V CURSYM*)                                               00012670
       (COND ((OR (NOT (ATOM V)) (NUMBERP V)) (GO B))                   00012680
             ((FLAGP V (QUOTE DELIM)) (GO ERR1))                        00012682
             ((EQ V (QUOTE *LPAR*)) (GO E))                             00012690
             ((AND (EQ V (QUOTE *RPAR*)) (NULL U)) (RETURN NIL)))       00012700
       (SETQ X (GET V (QUOTE INFIX)))                                   00012710
    B0   (COND ((SETQ W (GET* V (QUOTE ISTAT))) (GO L)))                00012720
    B    (SETQ W (SCAN))                                                00012750
    BX   (SETQ Y NIL)                                                   00012760
       (COND ((OR (NOT (ATOM W)) (NUMBERP W)) (GO B2))                  00012762
            ((FLAGP W (QUOTE DELIM)) (GO ENDD))                         00012764
             ((EQ W (QUOTE *LPAR*)) (GO E2))                            00012770
             ((EQ W (QUOTE *RPAR*)) (GO END0))                          00012780
             (U (GO B1)))                                               00012790
    BY   (COND                                                          00012800
        ((AND J                                                         00012870
            (EQ W (QUOTE *COMMA*))                                      00012880
            (NOT (MEMBER J (QUOTE (MAT PAREN FUNC)))))                  00012890
         (RETURN V)))                                                   00012900
    B1   (SETQ Y (GET W (QUOTE INFIX)))                                 00012910
  B2        (COND ((NULL X) (GO SYM))                                   00012920
             ((NOT (FLAGP V (QUOTE UNARY))) (GO ERR3)))                 00012930
    C    (SETQ Z X)                                                     00012940
       (SETQ U (CONS (LIST V) U))                                       00012950
       (SETQ V W)                                                       00012960
       (SETQ X Y)                                                       00012970
       (COND ((OR (NOT (ATOM V)) (NUMBERP V)) (GO B)) (T (GO B0)))      00012980
    SYM  (COND ((NULL Y) (GO M))                                        00012990
             ((AND (NULL W1)                                            00013000
                 (SETQ W1 (GET W (QUOTE ALT)))                          00013010
                 (SETQ W (CAR W1)))                                     00013020
            (GO B1)))                                                   00013030
 SYM1   (COND  ((OR (NULL Z) (LESSP Y Z)) (GO H))                       00013040
             ((OR (GREATERP Y Z) (FLAGP W (QUOTE BINARY))) (GO G)))     00013050
       (SETQ U (CONS (ACONC (CAR U) V) (CDR U)))                        00013060
       (GO G1)                                                          00013070
    E    (SETQ V                                                        00013080
             (MREAD*                                                    00013090
            (COND ((EQ J (QUOTE MAT)) (QUOTE FUNC))                     00013100
                  (T (QUOTE PAREN)))))                                  00013110
       (GO B)                                                           00013130
    E2   (COND ((EQ V (QUOTE MAT))                                      00013140
            (SETQ V (CONS V (REMCOMMA (MREAD* (SETQ MATP* V))))))       00013150
                ((AND (ATOM V) (GET V (QUOTE UNARY))                    00013152
                 (SETQ W (CAR (MREAD* (QUOTE FUNC))))) (GO C))          00013154
             ((OR (ATOM V) (EQ *MODE (QUOTE SYMBOLIC)))                 00013160
            (SETQ V (CONS V (MREAD* (QUOTE FUNC)))))                    00013170
             (T (GO ERR4)))                                             00013180
         (SETQ X NIL)                                                   00013185
         (GO B)                                                         00013190
    G    (SETQ U (CONS (LIST W V) U))                                   00013200
       (SETQ Z Y)                                                       00013210
    G1   (COND (W1 (GO G2)))                                            00013220
       (SCAN)                                                           00013230
  G3     (SETQ X NIL)                                                   00013232
       (GO A)                                                           00013240
    G2   (SETQ CURSYM* (CDR W1))                                        00013250
       (SETQ W1 NIL)                                                    00013260
       (GO G3)                                                          00013270
    H    (SETQ V (ACONC (CAR U) V))                                     00013280
       (SETQ U (CDR U))                                                 00013290
       (COND ((AND (NULL U) (SETQ Z 0)) (GO BY)))                       00013300
       (SETQ Z (GET (CAAR U) (QUOTE INFIX)))                            00013310
       (GO SYM1)                                                        00013320
    L    (SETQ V (*APPLY W NIL))                                        00013330
       (SETQ W CURSYM*)                                                 00013340
       (GO BX)                                                          00013350
    M    (COND ((NUMBERP V) (GO ERR4))                                  00013360
             ((PROGVR V)                                                00013370
            (LPRIM*                                                     00013380
             (APPEND (QUOTE (PROGRAM VARIABLE))                         00013390
                   (CONS V                                              00013400
                         (QUOTE (USED AS OPERATOR)))))))                00013410
       (GO C)                                                           00013420
    END0 (COND ((NULL J) (GO ERR21)) (T (GO END2)))                     00013430
    ENDD (COND ((MEMBER J (QUOTE (MAT PAREN FUNC))) (GO ERR22)))        00013440
    END2 (COND (X (GO ERR1)))                                           00013450
    END1 (COND                                                          00013460
        ((NULL U)                                                       00013470
         (RETURN (COND ((EQ J (QUOTE FUNC)) (REMCOMMA V)) (T V)))))     00013480
       (SETQ V (ACONC (CAR U) V))                                       00013490
       (SETQ U (CDR U))                                                 00013500
       (GO END1)                                                        00013510
    ERR1 (CURERR (QUOTE (SYNTAX ERROR)) NIL)                            00013520
    ERR21                                                               00013530
       (CURERR (QUOTE (TOO MANY RIGHT PARENTHESES)) NIL)                00013540
    ERR22                                                               00013550
       (CURERR (QUOTE (TOO FEW RIGHT PARENTHESES)) NIL)                 00013560
    ERR3 (CURERR (QUOTE (REDUNDANT OPERATOR)) 1)                        00013570
    ERR4 (CURERR (QUOTE (MISSING OPERATOR)) NIL))))                     00013580
                                                                        00013590
(ACONC (LAMBDA (U V)                                                    00013600
   (NCONC U (LIST V))))                                                 00013610
                                                                        00013620
(REMCOMMA (LAMBDA (U)                                                   00013630
   (COND ((EQCAR U (QUOTE *COMMA*)) (CDR U)) (T (LIST U)))))            00013640
                                                                        00013650
(SCAN (LAMBDA NIL                                                       00013660
   (PROG (X Y)                                                          00013670
       (COND ((EQ CURSYM* (QUOTE *SEMICOL*)) (TERPRI*)))                00013680
    A    (COND ((EQ CRCHAR* **BLANK) (GO L))                            00013690
             ((DIGIT CRCHAR*) (GO G))                                   00013700
             ((LITER CRCHAR*) (GO E))                                   00013710
             ((EQ CRCHAR* **XMARK) (GO E0))                             00013720
             ((EQ CRCHAR* **QMARK) (GO P))                              00013730
             ((EQ CRCHAR* **SMARK) (RETURN (COMM1 NIL)))                00013740
             ((NULL (SETQ X (GET* CRCHAR* (QUOTE SWITCH*))))            00013750
            (GO B))                                                     00013760
             ((EQ (SETQ Y (CADR X)) (QUOTE *SEMICOL*)) (GO J))          00013770
             ((EQ (READCH*) (CAR X)) (GO K)))                           00013780
    C    (SETQ CURSYM* (CADR X))                                        00013790
   D     (COND ((AND *ECHO *NAT) (SYMPRI CURSYM*)))                     00013800
       (COND                                                            00013810
        ((SETQ X (GET* CURSYM* (QUOTE NEWNAME))) (SETQ CURSYM* X)))     00013820
    D1   (RETURN CURSYM*)                                               00013830
    E0   (READCH*)                                                      00013840
    E    (SETQ Y (CONS CRCHAR* Y))                                      00013850
       (COND                                                            00013860
        ((OR (DIGIT (READCH*)) (LITER CRCHAR*)) (GO E))                 00013870
        ((EQ CRCHAR* **XMARK) (GO E0)))                                 00013880
       (GO H)                                                           00013890
    G    (SETQ Y (CONS CRCHAR* Y))                                      00013900
       (SETQ X CRCHAR*)                                                 00013910
       (COND                                                            00013920
        ((OR (DIGIT (READCH*))                                          00013930
             (EQ CRCHAR* **DOT)                                         00013940
             (EQ CRCHAR* (QUOTE E))                                     00013950
             (EQ X (QUOTE E)))                                          00013960
         (GO G)))                                                       00013970
    H    (SETQ CURSYM* (COMPRESS (REVERSE Y)))                          00013980
       (GO D)                                                           00013990
    J    (SETQ SEMIC* CRCHAR*)                                          00014000
       (SETQ CRCHAR* **BLANK)                                           00014010
       (GO C)                                                           00014020
    K    (READCH*)                                                      00014030
       (SETQ CURSYM* (CADDR X))                                         00014040
       (GO D)                                                           00014050
    B    (COND ((EQ CRCHAR* **ESC) (ERROR **ESC))                       00014060
             (Y                                                         00014070
            (CURERR (CONS CRCHAR* (QUOTE (INVALID CHARACTER)))          00014080
                   NIL)))                                               00014090
       (SETQ CURSYM* CRCHAR*)                                           00014100
       (READCH*)                                                        00014110
       (GO D)                                                           00014120
    L    (READCH*)                                                      00014130
       (GO A)                                                           00014140
    P    (SETQ CURSYM* (LIST (QUOTE QUOTE) (READ)))                     00014150
       (READCH*)                                                        00014160
       (COND ((OR *ECHO *NAT) (MAPRIN CURSYM*)))                        00014170
       (GO D1))))                                                       00014180
                                                                        00014190
))                                                                      00014200
                                                                        00014210
DEFINE ((                                                               00014220
                                                                        00014230
(LPRI (LAMBDA (U)                                                       00014240
   (PROG NIL                                                            00014250
    A    (COND ((NULL U) (RETURN NIL)))                                 00014260
       (PRINC* (CAR U))                                                 00014270
       (SPACES* 1)                                                      00014280
       (SETQ U (CDR U))                                                 00014290
       (GO A))))                                                        00014300
                                                                        00014310
(LPRIE (LAMBDA (U X)                                                    00014320
   (PROG NIL (SETQ ERFG* T) (LPRIW U X (QUOTE *****)))))                00014330
                                                                        00014340
(REDERR (LAMBDA (U)                                                     00014350
   (PROG2 (LPRIE U T) (ERROR*))))                                       00014360
                                                                        00014370
(LPRIW (LAMBDA (U X Y)                                                  00014380
   (PROG (V W)                                                          00014390
         (COND ((AND OFL* (OR *FORT (NOT *NAT))) (GO D)))               00014392
       (TERPRI*)                                                        00014400
    A    (SETQ V U)                                                     00014410
       (PRINC Y)                                                        00014420
       (PRINC **BLANK)                                                  00014430
    B    (COND ((NULL V) (GO C)))                                       00014440
       (PRINC (CAR V))                                                  00014450
       (PRINC **BLANK)                                                  00014460
       (SETQ V (CDR V))                                                 00014470
       (GO B)                                                           00014480
    C    (COND (X (TERPRI)))                                            00014490
       (COND ((NULL OFL*) (RETURN NIL)) (W (RETURN (WRS OFL*))))        00014500
     D (WRS NIL)                                                        00014510
       (SETQ W T)                                                       00014520
       (GO A))))                                                        00014530
                                                                        00014540
))                                                                      00014550
                                                                        00014560
DEFLIST (((*COMMA* 1)) INFIX)                                           00014570
                                                                        00014580
FLAG ((CONS EXPT QUOTIENT) BINARY)                                      00014590
                                                                        00014600
FLAG ((PLUS MINUS TIMES NOT *COMMA*) UNARY)                             00014610
                                                                        00014620
FLAG ((*COLON* *SEMICOL*) DELIM)                                        00014630
                                                                        00014640
DEFINE ((                                                               00014670
                                                                        00014680
(COMMAND (LAMBDA NIL                                                    00014690
   (PROG2 (SCAN) (COMMAND1 (QUOTE TOP)))))                              00014700
                                                                        00014710
(COMMAND1 (LAMBDA (U)                                                   00014720
   (PROG (V X Y)                                                        00014730
  A0        (COND ((NOT (ATOM U)) (SETQ V (CAR U)))                     00014740
               ((AND (EQ CURSYM* (QUOTE *SEMICOL*))                     00014750
                 (LIST (SCAN))) (GO A0))                                00014760
             ((NOT (SETQ Y (GET* (SETQ V CURSYM*) (QUOTE STAT))))       00014770
            (SETQ V (MREAD                                              00014780
                     (AND (NOT (EQ U (QUOTE TOP)))                      00014790
                       (OR (EQ U (QUOTE IF))                            00014800
                          (EQ *MODE (QUOTE SYMBOLIC))))))))             00014810
       (SETQ U                                                          00014820
             (AND (NOT (EQ *MODE (QUOTE SYMBOLIC)))                     00014830
                (OR PRI* (EQ U (QUOTE TOP)))))                          00014840
       (COND (Y (GO B))                                                 00014850
             ((EQ CURSYM* (QUOTE *COLON*)) (RETURN V))                  00014860
             ((EQCAR V (QUOTE SETQ)) (GO C))                            00014870
             ((OR (EQUAL *MODE (QUOTE SYMBOLIC))                        00014880
                (EQCAR V (QUOTE QUOTE))                                 00014890
                (AND (NUMBERP V) (FIXP V)))                             00014900
            (SETQ Y V))                                                 00014910
             ((EQCAR V (QUOTE EQUAL)) (GO C))                           00014920
             (T (SETQ Y (LIST (QUOTE AEVAL) (MKARG V)))))               00014930
    A    (COND ((AND U (EQ SEMIC* **SEMICOL))                           00014940
            (SETQ Y (LIST (QUOTE VARPRI) X Y PRI*)))                    00014950
             ((AND PRI* (EQ *MODE (QUOTE SYMBOLIC)))                    00014960
            (SETQ Y (LIST (QUOTE PRINC) Y))))                           00014970
       (RETURN Y)                                                       00014980
    B    (SETQ Y (*APPLY Y NIL))                                        00014990
       (SETQ U (AND U (MEMBER V (QUOTE (BEGIN FOR IF)))))               00015000
       (GO A)                                                           00015010
    C    (SETQ V (CDR V))                                               00015020
       (COND ((NULL (CDDR V)) (GO D)))                                  00015030
       (SETQ X PRI*)                                                    00015040
       (SETQ PRI* NIL)                                                  00015050
       (SETQ Y (COMMAND1 (LIST (CONS (QUOTE SETQ) (CDR V)))))           00015060
       (SETQ PRI* X)                                                    00015070
       (SETQ X NIL)                                                     00015080
    D    (COND ((EQ *MODE (QUOTE SYMBOLIC)) (GO E))                     00015090
             (U                                                         00015100
            (SETQ X                                                     00015110
                  (CONS (QUOTE LIST)                                    00015120
                      (MAPCAR                                           00015130
                       (REVERSE (CDR (REVERSE V)))                      00015140
                       (FUNCTION MKARG*))))))                           00015150
       (COND ((NULL (CDDR V))                                           00015160
         (SETQ Y (LIST (QUOTE AEVAL) (MKARG (CADR V))))))               00015170
       (SETQ Y                                                          00015180
             (COND                                                      00015190
            ((AND (ATOM (CAR V)) (PROGVR (CAR V)))                      00015200
             (LIST (QUOTE SETQ) (CAR V) Y))                             00015210
            (T (LIST (QUOTE SETK) (MKARG (CAR V)) Y))))                 00015220
       (GO A)                                                           00015230
    E    (COND ((NULL (CDDR V)) (SETQ Y (CADR V))))                     00015240
       (SETQ Y                                                          00015250
             (COND                                                      00015260
            ((ATOM (CAR V)) (LIST (QUOTE SETQ) (CAR V) Y))              00015270
            ((GET* (CAAR V) (QUOTE **ARRAY))                            00015280
             (LIST (QUOTE SETEL) (CAR V) Y))                            00015282
            (T (PROCDEF1 (CAR V) Y))))                                  00015284
       (GO A))))                                                        00015286
                                                                        00015290
(MKARG (LAMBDA (U)                                                      00015300
   (COND ((NULL U) NIL)                                                 00015310
       ((ATOM U) (COND ((PROGVR U) U) (T (LIST (QUOTE QUOTE) U))))      00015320
       ((MEMBER (CAR U) (QUOTE (COND PROG QUOTE))) U)                   00015330
       (T (CONS (QUOTE LIST) (MAPCAR U (FUNCTION MKARG)))))))           00015340
                                                                        00015350
(MKARG* (LAMBDA (U)                                                     00015360
   (COND ((NULL U) NIL)                                                 00015370
         ((ATOM U) (LIST (QUOTE QUOTE) U))                              00015420
       (T (CONS (QUOTE LIST) (MAPCAR U (FUNCTION MKARG)))))))           00015430
                                                                        00015440
(MKPROG (LAMBDA (U V)                                                   00015480
   (CONS (QUOTE PROG) (CONS U V))))                                     00015490
                                                                        00015510
(PROGVR (LAMBDA (VAR)                                                   00015520
   (COND ((NOT (ATOM VAR)) NIL)                                         00015530
       ((NUMBERP VAR) T)                                                00015540
       (T                                                               00015550
        ((LAMBDA (X) (COND (X (CAR X)) (T NIL)))                        00015560
         (GET VAR (QUOTE DATATYPE)))))))                                00015570
                                                                        00015580
))                                                                      00015590
                                                                        00015600
DEFINE ((                                                               00015610
                                                                        00015620
(LPRIM* (LAMBDA (U)                                                     00015630
   (PROG (X Y)                                                          00015640
       (COND ((AND OFL* (OR *FORT (NOT *NAT))) (GO C)))                 00015650
  A        (SETQ X *NAT)                                                00015660
       (SETQ *NAT NIL)                                                  00015670
       (LPRI (CONS (QUOTE ***) U))                                      00015680
       (TERPRI)                                                         00015690
       (SETQ *NAT X)                                                    00015700
      (COND ((NULL Y) (GO B)))                                          00015701
      (WRS Y)                                                           00015702
       (RETURN NIL)                                                     00015703
  B        (COND ((NULL OFL*) (RETURN NIL)))                            00015704
     C (SETQ Y OFL*)                                                    00015705
       (WRS NIL)                                                        00015706
       (GO A))))                                                        00015707
                                                                        00015710
(SYMPRI (LAMBDA (U)                                                     00015720
   (PROG (X)                                                            00015730
       (COND                                                            00015740
        ((EQ U (QUOTE *SEMICOL*)) (PRINC* SEMIC*))                      00015750
        ((SETQ X (GET* U (QUOTE PRTCH))) (PRINC* (CAR X)))              00015760
        (T (GO B)))                                                     00015770
       (RETURN (SETQ SYMFG* NIL))                                       00015780
    B    (COND (SYMFG* (SPACES* 1)))                                    00015790
       (PRINC* U)                                                       00015800
       (SETQ SYMFG* T))))                                               00015810
                                                                        00015820
(CURERR (LAMBDA (U V)                                                   00015830
   (PROG (X)                                                            00015840
       (SETQ ECHO* T)                                                   00015850
       (TERPRI)                                                         00015860
       (SETQ X CURSYM*)                                                 00015870
       (COND ((NULL PLINE*) (GO B))                                     00015880
             ((EQUAL V 1)                                               00015890
            (SETQ PLINE*                                                00015900
                  (CONS (CAR PLINE*)                                    00015910
                      (CONS                                             00015920
                       (CONS (CONS (CAAADR PLINE*) -1) **EMARK)         00015930
                       (CDR PLINE*)))))                                 00015940
             (T                                                         00015950
            (SETQ PLINE*                                                00015960
                  (CONS (CONS (CONS (CAAAR PLINE*) -1) **EMARK)         00015970
                       PLINE*))))                                       00015980
       (SETQ YMIN* -1)                                                  00015990
    B    (COMM1*)                                                       00016000
       (COND ((NUMBERP V) (SETQ V NIL)))                                00016010
       (COND ((AND (NULL U) (NULL V)) (GO A))                           00016020
             ((NULL V) (LPRIE U T))                                     00016030
             (T (LPRIE                                                  00016040
               (CONS X                                                  00016050
                   (CONS (QUOTE INVALID)                                00016060
                         (COND                                          00016070
                        (U                                              00016080
                         (LIST (QUOTE IN)                               00016090
                                U                                       00016100
                               (QUOTE STATEMENT)))                      00016110
                        (T NIL))))                                      00016120
               T)))                                                     00016130
    A    (ERROR*))))                                                    00016140
                                                                        00016150
(ERROR* (LAMBDA NIL                                                     00016160
   (PROG2 (TERPRI*) (ERROR NIL))))                                      00016170
                                                                        00016180
))                                                                      00016190
                                                                        00016200
DEFINE ((                                                               00016210
                                                                        00016220
(GREATEQ (LAMBDA (U V)                                                  00016230
   (OR (EQUAL U V) (GREATERP U V))))                                    00016240
                                                                        00016250
(LESSEQ (LAMBDA (U V)                                                   00016260
   (OR (EQUAL U V) (LESSP U V))))                                       00016270
                                                                        00016280
(UNEQ (LAMBDA (U V)                                                     00016290
   (NOT (EQUAL U V))))                                                  00016300
                                                                        00016310
(REDMSG (LAMBDA (U V W)                                                 00016320
   (COND ((NULL *MSG) T)                                                00016330
       ((AND *INT W) (REDMSG1 U V))                                     00016340
       (T (NULL (LPRIM* (LIST U (QUOTE DECLARED) V)))))))               00016350
                                                                        00016360
(DELETE (LAMBDA (U V)                                                   00016370
   (COND ((NULL V) NIL)                                                 00016380
       ((EQUAL U (CAR V)) (CDR V))                                      00016390
       (T (CONS (CAR V) (DELETE U (CDR V)))))))                         00016400
                                                                        00016410
(SETDIFF (LAMBDA (U V)                                                  00016420
   (COND ((NULL V) U) (T (SETDIFF (DELETE (CAR V) U) (CDR V))))))       00016430
                                                                        00016440
(XN (LAMBDA (U V)                                                       00016450
   (COND ((NULL U) NIL)                                                 00016460
       ((MEMBER (CAR U) V)                                              00016470
        (CONS (CAR U) (XN (CDR U) (DELETE (CAR U) V))))                 00016480
       (T (XN (CDR U) V)))))                                            00016490
                                                                        00016500
))                                                                      00016510
                                                                        00016520
DEFINE ((                                                               00016530
                                                                        00016540
(PROCDEF (LAMBDA NIL                                                    00016550
   (PROG (X Y)                                                          00016560
       (COND ((ATOM (SETQ X (MREAD* NIL))) (SETQ X (LIST X))))          00016570
       (SCAN)                                                           00016580
         (SETQ Y (FLAGTYPE (CDR X) (QUOTE SCALAR)))                     00016581
         (SETQ X (PROCDEF1 X (COMMAND1 NIL)))                           00016582
         (REMTYPE Y)                                                    00016583
         (RETURN X))))                                                  00016584
                                                                        00016600
(PROCDEF1 (LAMBDA (U BODY)                                              00016602
   (PROG (NAME VARLIS)                                                  00016604
       (SETQ NAME (CAR U))                                              00016610
       (COND                                                            00016620
        ((OR (NULL NAME) (NOT (ATOM NAME)) (NUMBERP NAME))              00016630
         (CURERR NAME NIL))                                             00016640
        ((NOT (GETD NAME)) (FLAG (LIST NAME) (QUOTE FNC))))             00016650
       (COND ((EQCAR BODY (QUOTE PROG)) (SETQ VARLIS (CADR BODY))))     00016660
       (COND (VARLIS (RPLACA (CDR BODY) (SETDIFF VARLIS (CDR U)))))     00016680
       (SETQ VARLIS (CDR U))                                            00016690
       (AND (NOT (FLAGP NAME (QUOTE FNC)))                              00016710
            (LPRIM* (LIST NAME (QUOTE REDEFINED))))                     00016720
       (DEF* NAME VARLIS BODY DEFN*)                                    00016730
       (REMPROP NAME (QUOTE FNC))                                       00016740
       (RETURN (LIST (QUOTE QUOTE) NAME)))))                            00016760
                                                                        00016780
(FLAGTYPE (LAMBDA (U V)                                                 00016790
   (PROG (X Y Z)                                                        00016800
    A    (COND ((NULL U) (RETURN (REVERSE Z))))                         00016810
       (SETQ X (CAR U))                                                 00016820
       (COND ((GET X (QUOTE SIMPFN))                                    00016830
              (REDERR (APPEND (QUOTE (TYPE CONFLICT FOR)) (LIST X)))))  00016830
       (SETQ Y (GET X (QUOTE DATATYPE)))                                00016840
       (PUT X (QUOTE DATATYPE) (CONS V Y))                              00016910
       (SETQ Z (CONS X Z))                                              00016920
    C  (SETQ U (CDR U))                                                 00016930
       (GO A))))                                                        00016940
                                                                        00016970
(REMTYPE (LAMBDA (VARLIS)                                               00016980
   (PROG (X Y)                                                          00016990
    A    (COND ((NULL VARLIS) (RETURN NIL)))                            00017000
       (SETQ X (CAR VARLIS))                                            00017010
       (SETQ Y (CDR (GET X (QUOTE DATATYPE))))                          00017020
       (COND (Y (PUT X (QUOTE DATATYPE) Y))                             00017060
             (T (REMPROP X (QUOTE DATATYPE))))                          00017070
       (SETQ VARLIS (CDR VARLIS))                                       00017080
       (GO A))))                                                        00017090
                                                                        00017100
(NEWVAR (LAMBDA (U)                                                     00017110
   (COMPRESS (CONS **FMARK (EXPLODE U)))))                              00017120
                                                                        00017130
(DEF* (LAMBDA (NAME VARLIS BODY FN)                                     00017140
   (*APPLY FN                                                           00017150
         (LIST                                                          00017160
          (LIST (LIST NAME (LIST (QUOTE LAMBDA) VARLIS BODY)))))))      00017170
                                                                        00017180
))                                                                      00017190
                                                                        00017200
DEFINE ((                                                               00017210
                                                                        00017220
(PROCBLOCK (LAMBDA NIL                                                  00017230
   (PROG (X HOLD VARLIS)                                                00017240
       (SCAN)                                                           00017250
       (COND ((MEMBER CURSYM* (QUOTE (NIL *RPAR*))) (ERROR **ESC)))     00017260
       (SETQ VARLIS (DECL T))                                           00017270
    A    (COND ((EQ CURSYM* (QUOTE END)) (GO B)))                       00017280
       (SETQ X (COMMAND1 NIL))                                          00017290
       (COND ((EQCAR X (QUOTE END)) (GO C)))                            00017300
       (AND (NOT (EQ CURSYM* (QUOTE END))) (SCAN))                      00017310
       (COND (X (SETQ HOLD (ACONC HOLD X))))                            00017320
       (GO A)                                                           00017330
    B    (COMM1 (QUOTE END))                                            00017340
    C    (REMTYPE VARLIS)                                               00017350
         (COND ((NOT (EQ *MODE (QUOTE SYMBOLIC)))                       00017351
            (SETQ HOLD (ACONC HOLD (QUOTE (RETURN 0))))))               00017352
       (RETURN (MKPROG VARLIS HOLD)))))                                 00017360
                                                                        00017380
(DECL* (LAMBDA NIL                                                      00017390
   (MAP (DECL NIL) (FUNCTION (LAMBDA (J)                                00017400
        (PUT (CAR J) (QUOTE SPECIAL) (LIST NIL)))))))                   00017400
                                                                        00017410
(DECL (LAMBDA (U)                                                       00017420
   (PROG (V W VARLIS)                                                   00017430
    A    (COND                                                          00017440
        ((NOT (MEMBER CURSYM* (QUOTE (REAL INTEGER SCALAR))))           00017450
         (RETURN VARLIS)))                                              00017460
       (SETQ W CURSYM*)                                                 00017470
       (COND ((EQ (SCAN) (QUOTE PROCEDURE)) (RETURN (ALGFN))))          00017480
       (SETQ V (FLAGTYPE (REMCOMMA (MREAD NIL)) W))                     00017490
       (SETQ VARLIS (APPEND V VARLIS))                                  00017500
       (AND (NOT (EQ CURSYM* (QUOTE *SEMICOL*))) (CURERR NIL T))        00017510
       (AND U (SCAN))                                                   00017520
       (GO A))))                                                        00017530
                                                                        00017540
(GOFN (LAMBDA NIL                                                       00017550
   (PROG (VAR)                                                          00017560
       (SETQ VAR                                                        00017570
             (COND ((EQ (SCAN) (QUOTE TO)) (SCAN)) (T CURSYM*)))        00017580
       (SCAN)                                                           00017590
       (RETURN (LIST (QUOTE GO) VAR)))))                                00017600
                                                                        00017610
(RETFN (LAMBDA NIL                                                      00017620
   (LIST (QUOTE RETURN)                                                 00017630
         (COND ((FLAGP** (SCAN) (QUOTE DELIM)) NIL)                     00017635
               (T (COMMAND1 NIL))))))                                   00017640
                                                                        00017650
(ENDFN (LAMBDA NIL                                                      00017660
   (PROG2 (COMM1 (QUOTE END)) (QUOTE (END)))))                          00017670
                                                                        00017680
))                                                                      00017690
                                                                        00017700
DEFINE ((                                                               00017710
                                                                        00017720
(FORSTAT (LAMBDA NIL                                                    00017730
   (COND ((EQ (SCAN) (QUOTE ALL)) (FORALLFN*)) (T (FORLOOP)))))         00017740
                                                                        00017750
(FORLOOP (LAMBDA NIL                                                    00017760
   (PROG (CURS EXP INCR INDX CONDLIST BODY FLG FNC LAB1 LAB2)           00017770
       (SETQ FNC (GENSYM))                                              00017780
       (SETQ EXP (MREAD T))                                             00017790
       (COND                                                            00017800
        ((AND (EQ (CAR EXP) (QUOTE *COMMA*))                            00017810
            (EQCAR (CADR EXP) (QUOTE SETQ)))                            00017820
         (SETQ EXP                                                      00017830
             (LIST NIL                                                  00017840
                   (CADADR EXP)                                         00017850
                   (CONS (QUOTE *COMMA*)                                00017860
                       (NCONC (CDDADR EXP) (CDDR EXP))))))              00017870
        ((NOT (MEMBER (CAR EXP) (QUOTE (SETQ EQUAL)))) (GO ERR)))       00017880
       (SETQ EXP (CDR EXP))                                             00017890
       (COND                                                            00017900
        ((OR (NOT (ATOM (SETQ INDX (CAR EXP)))) (NUMBERP INDX))         00017910
         (GO ERR)))                                                     00017920
       (SETQ INDX (CAR (FLAGTYPE (LIST INDX) (QUOTE INTEGER))))         00017920
    A    (SETQ EXP (REMCOMMA (CADR EXP)))                               00017930
    A1   (COND ((NULL EXP) (GO B2))                                     00017940
             ((CDR EXP) (SETQ FLG T))                                   00017950
             ((EQ CURSYM* (QUOTE STEP)) (GO B1))                        00017960
             ((EQ CURSYM* (QUOTE *COLON*)) (GO BB)))                    00017970
       (SETQ CONDLIST                                                   00017980
             (NCONC CONDLIST                                            00017990
                  (LIST (LIST (QUOTE SETQ) INDX (MKEX (CAR EXP)))       00018000
                      (LIST FNC))))                                     00018010
    B0   (SETQ EXP (CDR EXP))                                           00018020
       (GO A1)                                                          00018030
    B1   (SETQ INCR (MKEX (MREAD* NIL)))                                00018040
       (COND                                                            00018050
        ((NOT (MEMBER (SETQ CURS CURSYM*) (QUOTE (UNTIL WHILE))))       00018060
         (GO ERR)))                                                     00018070
    AA   (SETQ LAB1 (GENSYM))                                           00018080
       (SETQ LAB2 (GENSYM))                                             00018090
       (SETQ CONDLIST                                                   00018100
             (ACONC CONDLIST(LIST (QUOTE SETQ) INDX (MKEX (CAR EXP))))) 00018110
       (SETQ EXP (REMCOMMA (MREAD* NIL)))                               00018120
       (SETQ BODY (MKEX (CAR EXP)))                                     00018130
       (SETQ CONDLIST                                                   00018140
             (NCONC CONDLIST                                            00018150
                  (LIST LAB1                                            00018160
                      (LIST (QUOTE COND)                                00018170
                          (LIST                                         00018180
                           (COND                                        00018190
                            ((EQ CURS (QUOTE UNTIL))                    00018200
                             (COND                                      00018210
                              ((NUMBERP INCR)                           00018220
                               (LIST                                    00018230
                              (COND                                     00018240
                               ((MINUSP INCR)                           00018250
                                (QUOTE LESSP))                          00018260
                               (T (QUOTE GREATERP)))                    00018270
                              INDX                                      00018280
                              BODY))                                    00018290
                              (T                                        00018300
                               (LIST                                    00018310
                              (QUOTE MINUSP)                            00018320
                              (LIST                                     00018330
                               (QUOTE TIMES)                            00018340
                               (LIST                                    00018350
                                (QUOTE DIFFERENCE)                      00018360
                                BODY                                    00018370
                                INDX)                                   00018380
                               INCR)))))                                00018390
                            (T (LIST (QUOTE NOT) BODY)))                00018400
                           (LIST (QUOTE GO) LAB2)))                     00018410
                      (LIST FNC)                                        00018420
                      (LIST (QUOTE SETQ)                                00018430
                           INDX                                         00018440
                          (LIST (QUOTE PLUS) INDX INCR))                00018450
                      (LIST (QUOTE GO) LAB1)                            00018460
                       LAB2)))                                          00018470
       (AND (CDR EXP) (SETQ FLG T))                                     00018480
       (GO B0)                                                          00018490
    BB   (SETQ INCR 1)                                                  00018500
       (SETQ CURS (QUOTE UNTIL))                                        00018510
       (GO AA)                                                          00018520
    B2   (COND ((NULL CONDLIST) (GO ERR))                               00018530
             ((MEMBER CURSYM* (QUOTE (SUM PRODUCT))) (GO C))            00018540
             ((NOT (EQ CURSYM* (QUOTE DO))) (GO ERR)))                  00018550
       (SCAN)                                                           00018560
       (SETQ BODY (COMMAND1 NIL))                                       00018570
    B    (COND (FLG (DEF* FNC NIL BODY (QUOTE DEFINE)))                 00018590
             (T (SETQ CONDLIST (ADFORM BODY (LIST FNC) CONDLIST))))     00018600
         (REMTYPE (LIST INDX))                                          00018602
       (RETURN (MKPROG (CONS INDX EXP) (ACONC CONDLIST                  00018610
                                 (QUOTE (RETURN NIL)))))                00018612
    C    (SETQ CURS CURSYM*)                                            00018620
       (SETQ EXP (GENSYM))                                              00018630
       (SETQ BODY                                                       00018640
             (LIST (QUOTE SETQ)                                         00018650
                  EXP                                                   00018660
                 (LIST                                                  00018670
                  (COND                                                 00018680
                   ((EQ CURS (QUOTE SUM)) (QUOTE ADDSQ))                00018690
                   (T (QUOTE MULTSQ)))                                  00018700
                  (LIST (QUOTE AEVAL1) (MKARG (MREAD* T)))              00018710
                  EXP)))                                                00018720
       (SETQ CONDLIST                                                   00018730
             (CONS (LIST (QUOTE SETQ)                                   00018740
                      EXP                                               00018750
                     (LIST (QUOTE CONS)                                 00018760
                         (COND                                          00018770
                          ((EQ CURS (QUOTE SUM)) NIL)                   00018780
                          (T 1))                                        00018790
                          1))                                           00018800
                 (ACONC CONDLIST                                        00018810
                      (LIST (QUOTE RETURN)                              00018820
                          (LIST (QUOTE MK*SQ)                           00018830
                              (LIST (QUOTE SUBS2) EXP))))))             00018840
       (SETQ EXP (LIST EXP))                                            00018840
       (GO B)                                                           00018850
    ERR  (CURERR (QUOTE FOR) T))))                                      00018900
                                                                        00018910
(ADFORM (LAMBDA (U V W)                                                 00018920
   (COND ((NULL W) NIL)                                                 00018930
       ((EQUAL V (CAR W))                                               00018940
        ((LAMBDA(X)                                                     00018950
          (COND (X (APPEND X (CDR W))) (T (CONS U (CDR W)))))           00018960
         (PROGCHK U)))                                                  00018970
       (T (CONS (CAR W) (ADFORM U V (CDR W)))))))                       00018980
                                                                        00018990
(PROGCHK (LAMBDA (U)                                                    00019000
   (PROG (X)                                                            00019010
       (COND                                                            00019020
        ((OR (NOT (EQCAR U (QUOTE PROG))) (CADR U)) (RETURN NIL)))      00019030
       (SETQ U (CDR U))                                                 00019040
    A    (SETQ U (CDR U))                                               00019050
       (COND ((NULL U) (RETURN (REVERSE X)))                            00019060
             ((ATOM (CAR U)) (GO B))                                    00019070
             ((EQCAR (CAR U) (QUOTE RETURN)) (GO RET))                  00019080
             ((EQCAR (CAR U) (QUOTE PROG)) (GO B))                      00019090
             ((MEMBER (QUOTE RETURN) (FLATTEN (CAR U)))                 00019100
            (RETURN NIL)))                                              00019110
    B    (SETQ X (CONS (CAR U) X))                                      00019120
       (GO A)                                                           00019130
   RET   (COND ((CDR U) (RETURN NIL))                                   00019135
               ((NOT (ATOM (CADAR U))) (SETQ X (CONS (CADAR U) X))))    00019140
         (GO A))))                                                      00019145
                                                                        00019150
(FLATTEN (LAMBDA (U)                                                    00019160
   (COND ((NULL U) NIL)                                                 00019170
       ((ATOM U) (LIST U))                                              00019180
       ((ATOM (CAR U)) (CONS (CAR U) (FLATTEN (CDR U))))                00019190
       (T (NCONC (FLATTEN (CAR U)) (FLATTEN (CDR U)))))))               00019200
                                                                        00019210
))                                                                      00019220
                                                                        00019230
DEFINE ((                                                               00019240
                                                                        00019250
(IFSTAT (LAMBDA NIL                                                     00019260
   (PROG (CONDX CONDIT)                                                 00019270
       (FLAG (QUOTE (CLEAR LET MATCH)) (QUOTE DELIM))                   00019280
    A    (SETQ CONDX (MREAD* T))                                        00019290
         (REMFLAG (QUOTE (CLEAR LET MATCH)) (QUOTE DELIM))              00019300
       (COND ((NOT (EQ CURSYM* (QUOTE THEN))) (GO C)))                  00019330
       (SCAN)                                                           00019340
         (SETQ CONDIT(ACONC CONDIT (LIST (MKEX CONDX) (COMMAND1 NIL)))) 00019350
       (COND ((NOT (EQ CURSYM* (QUOTE ELSE))) (GO B))                   00019360
             ((EQ (SCAN) (QUOTE IF)) (GO A))                            00019370
             (T                                                         00019380
            (SETQ CONDIT                                                00019390
                  (ACONC CONDIT                                         00019400
                       (LIST T (COMMAND1 (QUOTE IF)))))))               00019410
    B    (RETURN (CONS (QUOTE COND) CONDIT))                            00019420
    C    (COND                                                          00019430
        ((NOT (MEMBER CURSYM* (QUOTE (CLEAR LET MATCH))))               00019440
         (CURERR (QUOTE IF) T)))                                        00019450
       (SETQ MCOND* (MKEX CONDX))                                       00019460
       (RETURN (FORALLFN (GVARB CONDX))))))                             00019470
                                                                        00019480
(MKEX (LAMBDA (U)                                                       00019490
  (COND ((EQ *MODE (QUOTE SYMBOLIC)) U) (T (APROC U)))))                00019500
                                                                        00019510
(APROC (LAMBDA (U)                                                      00019520
   (COND ((NULL U) NIL)                                                 00019530
       ((ATOM U)                                                        00019540
        (COND ((AND (NUMBERP U) (FIXP U)) U)                            00019550
            (T (LIST (QUOTE REVAL) (MKARG U)))))                        00019560
       ((MEMBER (CAR U) (QUOTE (COND PROG))) U)                         00019570
       ((MEMBER (CAR U) (QUOTE (EQUAL UNEQ)))                           00019580
        (LIST (CAR U)                                                   00019590
            (LIST (QUOTE REVAL)                                         00019600
                  (MKARG                                                00019610
                   (LIST (QUOTE PLUS)                                   00019620
                       (CADR U)                                         00019630
                       (LIST (QUOTE MINUS) (CARX (CDDR U))))))          00019640
             0))                                                        00019650
       (T (CONS (CAR U) (MAPCAR (CDR U) (FUNCTION APROC)))))))          00019660
                                                                        00019670
(ARB (LAMBDA (U)                                                        00019680
   T))                                                                  00019690
                                                                        00019700
(GVARB (LAMBDA (U)                                                      00019710
   (COND ((ATOM U) (COND ((NUMBERP U) NIL) (T (LIST U))))               00019720
       ((EQ (CAR U) (QUOTE QUOTE)) NIL)                                 00019730
       (T                                                               00019740
        (MAPCON (CDR U) (FUNCTION (LAMBDA (J) (GVARB (CAR J)))))))))    00019750
                                                                        00019760
))                                                                      00019770
                                                                        00019780
FLAG ((THEN ELSE END STEP DO SUM PRODUCT UNTIL WHILE) DELIM)            00019790
                                                                        00019800
DEFINE ((                                                               00019810
                                                                        00019820
(ALGFN (LAMBDA NIL                                                      00019830
   (ALGFN* (QUOTE ALGEBRAIC))))                                         00019840
                                                                        00019850
(LSPFN (LAMBDA NIL                                                      00019860
   (ALGFN* (QUOTE SYMBOLIC))))                                          00019870
                                                                        00019880
(ALGFN* (LAMBDA (U)                                                     00019890
   (PROG (X)                                                            00019900
       (COND ((EQ CURSYM* (QUOTE PROCEDURE)) (GO A))                    00019910
             ((EQ CURSYM* (QUOTE MACRO)) (SETQ DEFN* CURSYM*))          00019920
             ((EQ CURSYM* (QUOTE FEXPR))                                00019930
            (SETQ DEFN* (QUOTE DEFEXPR))))                              00019940
       (COND                                                            00019950
        ((FLAGP** (SCAN) (QUOTE DELIM)) (GO B)))                        00019960
    A    (SETQ TMODE* *MODE)                                            00019970
       (SETQ *MODE U)                                                   00019980
       (COND                                                            00019990
        ((NOT (EQ CURSYM* (QUOTE PROCEDURE)))                           00020000
         (RETURN (COMMAND1 NIL))))                                      00020010
       (SETQ X (PROCDEF))                                               00020020
       (COND                                                            00020030
            ((NOT (EQ U (QUOTE SYMBOLIC)))(FLAG (CDR X)(QUOTE OPFN))))  00020035
         (RETURN (CONS (QUOTE QUOTE) (CDR X)))                          00020040
    B  (SETQ *MODE U))))                                                00020050
                                                                        00020060
(RLIS (LAMBDA NIL                                                       00020070
   (RLIS* T)))                                                          00020080
                                                                        00020090
(NORLIS (LAMBDA NIL                                                     00020100
   (RLIS* NIL)))                                                        00020110
                                                                        00020120
(RLIS* (LAMBDA (U)                                                      00020130
   (PROG (X Y)                                                          00020140
       (SETQ X CURSYM*)                                                 00020150
         (COND ((FLAGP** (SCAN) (QUOTE DELIM)) (GO A)))                 00020160
       (SETQ Y (REMCOMMA (MREAD NIL)))                                  00020170
       (COND (U (SETQ Y (LIST Y))))                                     00020180
    A    (RETURN (CONS X (MAPCAR Y (FUNCTION MKARG)))))))               00020190
                                                                        00020200
))                                                                      00020210
                                                                        00020220
DEFINE ((                                                               00020230
                                                                        00020240
(COMM1* (LAMBDA NIL                                                     00020250
   (COMM1 T)))                                                          00020260
                                                                        00020270
(COMM1 (LAMBDA (U)                                                      00020280
   (PROG (X Y)                                                          00020290
         (SETQ X (AND (OR *ECHO ECHO*) *NAT))                           00020300
       (COND                                                            00020310
        ((AND (EQ U (QUOTE END))                                        00020320
            (MEMBER (SCAN) (QUOTE (ELSE END UNTIL *RPAR*))))            00020330
         (GO RET1)))                                                    00020340
       (COND (U (GO LOOP)) (X (PRINC* CRCHAR*)))                        00020350
       (SETQ Y (LIST CRCHAR*))                                          00020360
       (GO A)                                                           00020370
    LOOP (COND ((NULL U) (GO L1))                                       00020380
             ((EQ CURSYM* (QUOTE *SEMICOL*)) (GO RET1))                 00020390
             ((OR (EQ CRCHAR* **SEMICOL)                                00020400
                (EQ CRCHAR* **DOLLAR)                                   00020410
                (EQ CRCHAR* **ESC))                                     00020420
            (GO RET)))                                                  00020430
    L1   (COND (X (PRINC* CRCHAR*)))                                    00020440
       (COND                                                            00020450
        ((OR (NULL U) (EQ U (QUOTE END)))                               00020460
         (SETQ Y (CONS CRCHAR* Y))))                                    00020470
       (COND                                                            00020480
        ((AND (EQ U (QUOTE END))                                        00020490
            (EQ CRCHAR* (QUOTE D))                                      00020500
            (EQCAR (CDR Y) (QUOTE N))                                   00020510
            (EQCAR (CDDR Y) (QUOTE E))                                  00020520
            (SETQ CRCHAR* **BLANK)                                      00020530
            (SETQ CURSYM* (QUOTE END)))                                 00020540
         (GO RET1))                                                     00020550
        ((AND (NULL U) (EQ CRCHAR* **SMARK)) (GO RETS)))                00020560
    A    (SETQ CRCHAR* (READCH*))                                       00020570
       (GO LOOP)                                                        00020580
    RET  (SCAN)                                                         00020590
    RET1 (RETURN (COND (X (TERPRI*)) (T NIL)))                          00020600
    RETS (SETQ CURSYM* (MKSTRING (REVERSE Y)))                          00020610
       (READCH*)                                                        00020620
       (RETURN CURSYM*))))                                              00020630
                                                                        00020640
(QOTPRI (LAMBDA (U)                                                     00020650
   (PROG2 (PRINC* **QMARK) (PRIN0* (CAR U)))))                          00020660
                                                                        00020670
(PRIN0* (LAMBDA (U)                                                     00020680
   (PROG NIL                                                            00020690
       (COND ((ATOM U) (RETURN (PRINC* U))))                            00020700
       (PRINC* **LPAR)                                                  00020710
    A    (COND ((NULL U) (GO B)) ((ATOM U) (GO C)))                     00020720
       (PRIN0* (CAR U))                                                 00020730
       (COND ((CDR U) (PRINC* **BLANK)))                                00020740
       (SETQ U (CDR U))                                                 00020750
       (GO A)                                                           00020760
    B    (RETURN (PRINC* **RPAR))                                       00020770
    C    (PRINC* **DOT)                                                 00020780
       (PRINC* **BLANK)                                                 00020790
       (PRINC* U)                                                       00020800
       (GO B))))                                                        00020810
                                                                        00020820
))                                                                      00020830
                                                                        00020840
DEFLIST (((QUOTE QOTPRI)) SPECPRN)                                      00020850
                                                                        00020860
DEFINE ((                                                               00020870
                                                                        00020880
(LMDEF (LAMBDA NIL                                                      00020890
   (PROG (X)                                                            00020900
       (COND                                                            00020910
        ((NOT (EQ *MODE (QUOTE SYMBOLIC)))                              00020920
         (CURERR (QUOTE ALGEBRAIC) T)))                                 00020930
       (SETQ CURSYM* (QUOTE *COMMA*))                                   00020940
       (SETQ X (MREAD NIL))                                             00020950
       (RETURN (LIST (QUOTE LAMBDA) (CDR X) (COMMAND1 NIL))))))         00020960
                                                                        00020970
(WRITEFN (LAMBDA NIL                                                    00020980
   (PROG (X Y Z)                                                        00020990
       (SETQ X (MREAD* NIL))                                            00021000
       (SETQ PRI* T)                                                    00021010
       (SETQ X                                                          00021020
             (COND                                                      00021030
            ((EQCAR X (QUOTE *COMMA*)) (CDR X))                         00021040
            (T (LIST X))))                                              00021050
    A    (COND ((NULL X) (GO B)))                                       00021060
         (SETQ Z (COMMAND1 (LIST (CAR X))))                             00021065
         (COND ((NULL (CDR X)) (SETQ Z (LIST (QUOTE RETURN) Z))))       00021070
         (SETQ Y (ACONC Y Z))                                           00021075
       (SETQ X (CDR X))                                                 00021080
       (GO A)                                                           00021090
    B    (SETQ PRI* NIL)                                                00021100
       (RETURN (MKPROG NIL (CONS (QUOTE (TERPRI*)) Y))))))              00021110
                                                                        00021120
))                                                                      00021130
                                                                        00021140
DEFINE ((                                                               00021150
                                                                        00021160
(ON1 (LAMBDA (U V)                                                      00021170
   (PROG (X)                                                            00021180
    A    (COND ((NULL U) (RETURN NIL)))                                 00021190
       (PTS (COMPRESS (APPEND (EXPLODE **STAR) (EXPLODE (CAR U))))      00021200
             V)                                                         00021210
       (COND                                                            00021220
        ((SETQ X (ASSOC V (GET* (CAR U) (QUOTE SIMPFG))))               00021230
           (*APPLY (CONVRT (CDR X) NIL) NIL)))                          00021240
       (SETQ U (CDR U))                                                 00021250
       (GO A))))                                                        00021260
                                                                        00021270
(ON (LAMBDA (U)                                                         00021280
   (ON1 U T)))                                                          00021290
                                                                        00021300
(OFF (LAMBDA (U)                                                        00021310
   (ON1 U NIL)))                                                        00021320
                                                                        00021330
))                                                                      00021340
                                                                        00021350
DEFINE ((                                                               00021360
                                                                        00021370
(AARRAY (LAMBDA (U)                                                     00021380
   (PROG (X Y)                                                          00021390
    A    (COND ((NULL U) (RETURN NIL)))                                 00021400
       (SETQ X (CAR U))                                                 00021410
       (COND                                                            00021420
        ((OR (NUMBERP (CAR X))                                          00021430
               (NOT (ATOM (CAR X)))                                     00021440
             (GET (CAR X) (QUOTE SIMPFN))                               00021460
               (GET (CAR X) (QUOTE APROP)))                             00021465
           (REDERR (APPEND (QUOTE (TYPE CONFLICT FOR))                  00021470
                (LIST (CAR X)))))                                       00021475
          ((NOT (NUMLIS (SETQ Y (MAPCAR (CDR X)                         00021480
                 (FUNCTION REVAL))))) (ERRPRI2 X)))                     00021485
         (PUT (CAR X) (QUOTE **ARRAY) Y)                                00021490
         (*ARRAY                                                        00021495
          (LIST (CONS (CAR X) (MAPCAR Y (FUNCTION ADD1)))))             00021500
    B    (SETQ U (CDR U))                                               00021520
       (GO A))))                                                        00021530
                                                                        00021560
(NUMLIS (LAMBDA (U)                                                     00021570
   (OR (NULL U) (AND (NUMBERP (CAR U)) (NUMLIS (CDR U))))))             00021580
                                                                        00021590
))                                                                      00021600
                                                                        00021610
DEFLIST (((AARRAY RLIS)) STAT)                                          00021620
                                                                        00021630
(LAMBDA NIL (PUT (QUOTE ARRAY) (QUOTE NEWNAME) (QUOTE AARRAY))) NIL     00021640
                                                                        00021650
DEFINE ((                                                               00021660
                                                                        00021670
(BEGIN1 (LAMBDA NIL                                                     00021680
   (PROG (RESULT)                                                       00021690
       (SETQ CURSYM* NIL)                                               00021700
  A    (TERPRI)                                                         00021710
         (COND ((AND TMODE* (SETQ *MODE TMODE*)) (SETQ TMODE* NIL)))    00021720
       (SETQ ECHO* *ECHO)                                               00021730
       (SETQ ERFG* NIL)                                                 00021740
         (COND ((EQ CURSYM* (QUOTE END)) (GO ND0)))                     00021750
       (SETQ CRCHAR* **BLANK)                                           00021760
       (SETQ DEFN* (QUOTE DEFINE))                                      00021770
         (OVOFF)                                                        00021771
       (SETQ PROGRAM* (ERRORSET (QUOTE (COMMAND)) T))                   00021780
       (COND ((OR (ATOM PROGRAM*) (CDR PROGRAM*)) (GO ERR1)))           00021790
       (SETQ PROGRAM* (CAR PROGRAM*))                                   00021800
       (COND                                                            00021810
        ((EQ (CAR PROGRAM*) (QUOTE RETRY))                              00021820
         (SETQ PROGRAM* PROGRAML*))                                     00021830
          ((EQCAR PROGRAM* (QUOTE *COMMA*)) (GO ER))                    00021835
        ((EQ (CAR PROGRAM*) (QUOTE END)) (GO ND1))                      00021840
        (DIAG* (GO D)))                                                 00021850
  B        (COND (PLINE* (TERPRI*)))                                    00021852
       (SETQ ECHO* (QUOTE RESULT))                                      00021860
       (SETP)                                                           00021870
         (OVON)                                                         00021871
       (SETQ RESULT                                                     00021880
             (ERRORSET (CONVRT (GTS (QUOTE PROGRAM*)) NOCMP*) T))       00021890
       (COND ((OR (ATOM RESULT) (CDR RESULT)) (GO ERR2))                00021900
        ((EQ *MODE (QUOTE SYMBOLIC)) (AND (EQ SEMIC* **SEMICOL)         00021910
         (PROG2 (PRINT (CAR RESULT)) (TERPRI))))                        00021920
         ((CAR RESULT) (SETQ *ANS (CAR RESULT))))                       00021930
       (SETQ ORIG* 0)                                                   00021940
       (CLOSELINE)                                                      00021950
       (COND ((NULL *INT) (PRINTTY **STAR)))                            00021960
       (GO A)                                                           00021970
  D        (COND ((OR (ATOM PROGRAM*)(EQ (CAR PROGRAM*) (QUOTE QUOTE))) 00021972
            (GO A))                                                     00021974
          ((FLAGP (CAR PROGRAM*) (QUOTE IGNORE)) (GO B)))               00021975
         (PRINT (CONVRT PROGRAM* NIL))                                  00021978
       (GO A)                                                           00021979
  ND0    (COMM1 (QUOTE END))                                            00021980
  ND1                                                                   00022000
       (RETURN (FINF))                                                  00022010
    ERR1 (COND ((OR (EQ PROGRAM* **ESC) (EQ PROGRAM* **EOF)) (GO A)))   00022020
       (GO ERR3)                                                        00022030
    ER        (LPRIE (COND ((NOT (ATOM (CADR PROGRAM*)))                00022032
            (LIST (CAADR PROGRAM*) (QUOTE UNDEFINED)))                  00022034
               (T (QUOTE (SYNTAX ERROR)))) T)                           00022036
       (GO ERR3)                                                        00022038
    ERR2 (SETQ PROGRAML* PROGRAM*)                                      00022040
    ERR3 (COND                                                          00022050
          ((NULL ERFG*)                                                 00022060
         (LPRIE (QUOTE (ERROR TERMINATION *****)) NIL)))                00022070
       (SETQ ORIG* 0)                                                   00022080
       (TERPRI*)                                                        00022090
       (COND (IFL* (PAUSE)) (OFL* (PRINTTY **STAR)))                    00022100
       (GO A))))                                                        00022110
                                                                        00022120
(FINF (LAMBDA NIL                                                       00022130
   (PROG NIL                                                            00022140
       (COND (IFL* (GO A)))                                             00022150
       (MAPCAR (APPEND IPL* OPL*) (FUNCTION CLOSE))                     00022160
       (SETQ IPL* NIL)                                                  00022170
       (SETQ OPL* NIL)                                                  00022180
       (SETQ OFL* NIL)                                                  00022190
       (LPRIW NIL T **ENDMSG)                                           00022200
       (RETURN (QUOTE ***))                                             00022210
  A      (CLOSE IFL*)                                                   00022220
         (SETQ IPL* (DELETE IFL* IPL*))                                 00022221
         (RDS (SETQ IFL* (COND (IPL* (CAR IPL*)) (T NIL))))             00022222
       (LPRIM* NIL))))                                                  00022260
                                                                        00022270
))                                                                      00022280
                                                                        00022290
DEFLIST (((FOR FORSTAT) (FORALL FORALLFN*) (IF IFSTAT) (BEGIN PROCBLOCK 00022300
) (IN RLIS) (OUT RLIS) (SHUT RLIS) (GO GOFN) (GOTO GOFN) (RETURN RETFN  00022310
 ) (INTEGER DECL*) (SCALAR DECL*) (WRITE WRITEFN) (                     00022320
REAL DECL*) (LISP LSPFN) (ALGEBRAIC ALGFN) (RETRY NORLIS) (PROCEDURE    00022330
 ALGFN)(MACRO LSPFN)(FEXPR LSPFN) (SYMBOLIC LSPFN) (ON RLIS) (OFF RLIS  00022340
) (END ENDFN) (COMMENT COMM1*) (INFIX INFIXFN) (PRECEDENCE PRECEDFN))   00022350
STAT)                                                                   00022360
                                                                        00022370
DEFLIST (((BEGIN PROCBLOCK) (FOR FORSTAT) (IF IFSTAT) (LAMBDA LMDEF))   00022380
ISTAT)                                                                  00022390
                                                                        00022400
(LAMBDA (U) (MAP U (FUNCTION (LAMBDA (J) (PTS (CAR J) NIL))))) ((*GCD   00022410
*EXP *MCD *FLOAT MATCH* *DIV *RAT *SUPER MCOND* *ALLFAC *NCMP SUBFG*    00022420
FRLIS1* FRLIS* GAMIDEN* SUB2* RPLIS* SUBL* DSUBL* FACTORS* FRASC* VREP* 00022430
 INDICES* WTP* SNO* PNO* *RAT *OUTP MCHFG* *ANS *RESUBS *NERO EXLIST*   00022440
ORDN* *XDN SV* DNL* UPL* EXPTL*))                                       00022450
                                                                        00022460
(LAMBDA (U) (MAP U (FUNCTION (LAMBDA (J) (PTS (CAAR J) (CADAR J))))))   00022470
(((*EXP T) (*MSG T) (*ALLFAC T) (*MCD T) (SUBFG* T) (EXLIST* ((*)))     00022480
 (*RESUBS T) (ORDN* 0) (*ANS 0) (SNO* 500) (*XDN T)))                   00022490
                                                                        00022500
DEFLIST (((EXP ((NIL . RMSUBS1) (T . RMSUBS))) (MCD ((NIL . RMSUBS1) (  00022510
T . RMSUBS))) (FORT ((NIL LAMBDA NIL (SETQ *NAT NAT**)) (T LAMBDA NIL   00022520
(PROG2 (SETQ NAT** *NAT) (SETQ *NAT NIL))))) (GCD ((T . RMSUBS)))       00022530
 (FLOAT ((T . RMSUBS)))) SIMPFG)                                        00022540
                                                                        00022550
DEFLIST (((ANTISYMMETRIC RLIS)(CLEAR RLIS)(DENOM NORLIS) (FACTOR RLIS)  00022560
 (LET RLIS) (MATCH RLIS) (MKCOEFF NORLIS) (ND NORLIS) (NUMER NORLIS)    00022570
 (OPERATOR RLIS) (ORDER RLIS) (REMFAC RLIS) (SAVEAS NORLIS) (SYMMETRIC  00022580
 RLIS) (TERMS NORLIS) (WEIGHT RLIS)) STAT)                              00022590
                                                                        00022600
DEFLIST (((PLUS SIMPPLUS) (MINUS SIMPMINUS) (EXPT SIMPEXPT) (SUB        00022610
SIMPSUBS)(DF SIMPDF)(RECIP SIMPRECIP)(QUOTIENT SIMPQUOT) (*SQ SIMP*SQ)  00022620
 (TIMES SIMPTIMES)) SIMPFN)                                             00022630
                                                                        00022640
DEFLIST (((*ANS (SCALAR)) (*MODE (SCALAR))) DATATYPE)                   00022650
                                                                        00022660
DEFLIST (((I (I NIL (REP (MINUS 1) 2 NIL)))) APROP)                     00022670
                                                                        00022680
DEFINE ((                                                               00022690
                                                                        00022700
(ABS (LAMBDA (N)                                                        00022710
   (COND ((MINUSP N) (MINUS N)) (T N))))                                00022720
                                                                        00022730
(ASSOC (LAMBDA (U V)                                                    00022740
   (SASSOC U V (FUNCTION (LAMBDA NIL NIL)))))                           00022750
                                                                        00022760
(ASSOC* (LAMBDA (U V)                                                   00022770
   (COND ((NULL V) NIL)                                                 00022780
       ((EQUAL U (CAAR V)) (CAR V))                                     00022790
       (T (ASSOC* U (CDR V))))))                                        00022800
                                                                        00022810
(ATOMLIS (LAMBDA (U)                                                    00022820
   (OR (NULL U) (AND (ATOM (CAR U)) (ATOMLIS (CDR U))))))               00022830
                                                                        00022840
(CARX (LAMBDA (U)                                                       00022850
   (COND ((NULL (CDR U)) (CAR U)) (T (ERRACH (LIST (QUOTE CARX) U)))))  00022860
)                                                                       00022870
                                                                        00022880
(DELASC (LAMBDA (U V)                                                   00022890
   (COND ((NULL V) NIL)                                                 00022900
       ((OR (ATOM (CAR V)) (NOT (EQUAL U (CAAR V))))                    00022910
        (CONS (CAR V) (DELASC U (CDR V))))                              00022920
       (T (CDR V)))))                                                   00022930
                                                                        00022940
(MAPCONS (LAMBDA (U *S*)                                                00022980
   (MAPCAR U (FUNCTION (LAMBDA (J) (CONS *S* J))))))                    00022990
                                                                        00023000
(MAPC2 (LAMBDA (U *PI*)                                                 00023010
   (MAPCAR U                                                            00023020
         (FUNCTION                                                      00023030
          (LAMBDA(J)                                                    00023040
           (MAPCAR J (FUNCTION (LAMBDA (K) (*PI* K)))))))))             00023050
                                                                        00023060
(MEXPR (LAMBDA (U V)                                                    00023070
   (COND ((NULL V) NIL)                                                 00023080
       ((ATOM V) (EQ U V))                                              00023090
       (T (OR (MEXPR U (CAR V)) (MEXPR U (CDR V)))))))                  00023100
                                                                        00023110
(NCONS (LAMBDA (U V)                                                    00023120
   (COND ((NULL U) V) (T (CONS U V)))))                                 00023130
                                                                        00023140
(NLIST (LAMBDA (U N)                                                    00023150
   (COND ((ZEROP N) NIL) (T (CONS U (NLIST U (SUB1 N)))))))             00023160
                                                                        00023170
(NTH (LAMBDA (U N)                                                      00023180
   (COND ((ONEP N) (CAR U)) (T (NTH (CDR U) (SUB1 N))))))               00023190
                                                                        00023200
(POSN (LAMBDA (U V)                                                     00023210
   (COND ((EQ U (CAR V)) 1) (T (ADD1 (POSN U (CDR V)))))))              00023220
                                                                        00023230
(REMOVE (LAMBDA (X N)                                                   00023240
   (COND ((MINUSP N) (ERRACH (LIST (QUOTE REMOVE) X N)))                00023250
       ((NULL X) NIL)                                                   00023260
       ((ZEROP N) (CDR X))                                              00023270
       (T (CONS (CAR X) (REMOVE (CDR X) (SUB1 N)))))))                  00023280
                                                                        00023290
(REVPR (LAMBDA (U)                                                      00023300
   (CONS (CDR U) (CAR U))))                                             00023310
                                                                        00023320
(RPLACW (LAMBDA (U V)                                                   00023330
   (COND                                                                00023340
    ((OR (ATOM U) (ATOM V)) (ERRACH (LIST (QUOTE RPLACW) U V)))         00023350
    (T (RPLACD (RPLACA U (CAR V)) (CDR V))))))                          00023360
                                                                        00023370
(REPEATS (LAMBDA (X)                                                    00023380
   (COND ((NULL X) NIL)                                                 00023390
       ((MEMBER (CAR X) (CDR X)) (CONS (CAR X) (REPEATS (CDR X))))      00023400
       (T (REPEATS (CDR X))))))                                         00023410
                                                                        00023420
(UNION (LAMBDA (X Y)                                                    00023430
   (COND ((NULL X) Y)                                                   00023440
       (T                                                               00023450
        (UNION (CDR X)                                                  00023460
             (COND ((MEMBER (CAR X) Y) Y)                               00023470
                   (T (CONS (CAR X) Y))))))))                           00023480
                                                                        00023490
))                                                                      00023500
                                                                        00023510
DEFINE ((                                                               00023520
                                                                        00023530
(REPPRI (LAMBDA (U V)                                                   00023540
   (MESPRI NIL U (QUOTE (REPRESENTED BY)) V NIL)))                      00023550
                                                                        00023560
(REDEFPRI (LAMBDA (U)                                                   00023570
   (COND ((NULL U) NIL)                                                 00023580
       (T                                                               00023590
        (MESPRI (QUOTE (ASSIGNMENT FOR))                                00023600
               U                                                        00023610
              (QUOTE (REDEFINED))                                       00023620
               NIL                                                      00023630
               NIL)))))                                                 00023640
                                                                        00023650
(MESPRI (LAMBDA (U V W X Y)                                             00023660
   (PROG (Z)                                                            00023670
       (COND                                                            00023680
        ((AND (NULL Y) (NULL *MSG)) (RETURN NIL))                       00023690
        ((AND OFL* (OR *FORT (NOT *NAT))) (GO B)))                      00023700
    A    (LPRIM U)                                                      00023710
       (MAPRIN V)                                                       00023720
       (PRINC* **BLANK)                                                 00023730
       (LPRI W)                                                         00023740
       (MATHPRINT X)                                                    00023750
       (COND ((NULL OFL*) (RETURN NIL)) (Z (RETURN (WRS OFL*))))        00023760
    B    (WRS NIL)                                                      00023770
       (SETQ Z T)                                                       00023780
       (GO A))))                                                        00023790
                                                                        00023800
(LPRIM (LAMBDA (U)                                                      00023810
   (PROG2 (TERPRI*) (LPRI (CONS (QUOTE ***) U)))))                      00023820
                                                                        00023830
(ERRACH (LAMBDA (U)                                                     00023840
   (PROG NIL                                                            00023850
       (LPRIE (QUOTE (CATASTROPHIC ERROR *****)) T)                     00023860
       (PRINTTY U)                                                      00023870
       (PRINTTY **BLANK)                                                00023880
       (LPRIE (QUOTE                                                    00023890
             (PLEASE SEND                                               00023900
                    OUTPUT                                              00023910
                    AND                                                 00023920
                    INPUT                                               00023930
                    LISTING                                             00023940
                    TO                                                  00023950
                    A                                                   00023960
                    C                                                   00023970
                    HEARN                                               00023980
                    *****))                                             00023990
             T)                                                         00024000
       (ERROR*))))                                                      00024010
                                                                        00024020
(ERRPRI1 (LAMBDA (U)                                                    00024030
   (MESPRI (QUOTE (ASSIGNMENT)) U (QUOTE (NOT ALLOWED)) NIL T)))        00024040
                                                                        00024050
(ERRPRI2 (LAMBDA (U)                                                    00024060
   (MESPRI (QUOTE (FORMAT)) U (QUOTE (INCORRECT)) NIL T)))              00024070
                                                                        00024080
))                                                                      00024090
                                                                        00024100
DEFINE ((                                                               00024110
                                                                        00024120
(ORDAD (LAMBDA (A U)                                                    00024130
   (COND ((NULL U) (LIST A))                                            00024140
       ((ORDP A (CAR U)) (CONS A U))                                    00024150
       (T (CONS (CAR U) (ORDAD A (CDR U)))))))                          00024160
                                                                        00024170
(ORDN (LAMBDA (U)                                                       00024180
   (COND ((NULL U) NIL)                                                 00024190
       ((NULL (CDR U)) U)                                               00024200
       ((NULL (CDDR U)) (ORD2 (CAR U) (CADR U)))                        00024210
       (T (ORDAD (CAR U) (ORDN (CDR U)))))))                            00024220
                                                                        00024230
(ORD2 (LAMBDA (U V)                                                     00024240
   (COND ((ORDP U V) (LIST U V)) (T (LIST V U)))))                      00024250
                                                                        00024260
(ORDP (LAMBDA (U V)                                                     00024270
   (COND ((NULL U) (NULL V))                                            00024280
         ((NULL V) T)                                                   00024290
       ((ATOM U)                                                        00024300
        (COND                                                           00024310
         ((ATOM V)                                                      00024320
          (COND ((NUMBERP U) (AND (NUMBERP V) (NOT (LESSP U V))))       00024330
              ((NUMBERP V) T)                                           00024340
              (T (ORDERP U V))))                                        00024350
         (T T)))                                                        00024360
       ((ATOM V) NIL)                                                   00024370
       ((EQUAL (CAR U) (CAR V)) (ORDP (CDR U) (CDR V)))                 00024380
       (T (ORDP (CAR U) (CAR V))))))                                    00024390
                                                                        00024400
))                                                                      00024410
                                                                        00024420
DEFINE ((                                                               00024430
                                                                        00024440
(ADDSQ (LAMBDA (U V)                                                    00024450
   (COND ((EQUAL (CDR U) (CDR V))                                       00024460
        (CONS (ADDF (CAR U) (CAR V)) (CDR U)))                          00024470
       ((NULL (CAR U)) V)                                               00024480
       ((NULL (CAR V)) U)                                               00024490
       ((NULL *MCD) (CONS (ADDF (MKSQP U) (MKSQP V)) 1))                00024500
       (T                                                               00024510
        ((LAMBDA(Z)                                                     00024520
          ((LAMBDA(X Y)                                                 00024530
         (COND ((OR (NULL X) (NULL Y)) (ERRACH (QUOTE ADDSQ))) (T       00024531
            (CONS (ADDF (MULTF Y (CAR U)) (MULTF X (CAR V)))            00024540
                (MULTF Y (CDR U))))                                     00024550
                   ))                                                   00024551
           (QUOTF (CDR U) Z)                                            00024560
           (QUOTF (CDR V) Z)))                                          00024570
         (GCD1 (CDR U) (CDR V)))))))                                    00024580
                                                                        00024590
(ADDF (LAMBDA (U V)                                                     00024600
   (COND ((NULL U) V)                                                   00024610
       ((NULL V) U)                                                     00024620
       ((ATOM U) (ADDN U V))                                            00024630
       ((ATOM V) (ADDN V U))                                            00024640
       ((EQUAL (CAAR U) (CAAR V))                                       00024650
        ((LAMBDA(X)                                                     00024660
          (COND ((NULL X) (ADDF (CDR U) (CDR V)))                       00024670
              (T                                                        00024680
               (CONS (CONS (CAAR U) X) (ADDF (CDR U) (CDR V))))))       00024690
         (ADDF (CDAR U) (CDAR V))))                                     00024700
       ((ORDP (CAAR U) (CAAR V)) (CONS (CAR U) (ADDF (CDR U) V)))       00024710
       (T (CONS (CAR V) (ADDF U (CDR V)))))))                           00024720
                                                                        00024730
(ADDN (LAMBDA (N V)                                                     00024740
   (COND ((NULL V) N)                                                   00024750
       ((ATOM V)                                                        00024760
        ((LAMBDA (M) (COND ((ZEROP M) NIL) (T M))) (PLUS N V)))         00024770
       (T (CONS (CAR V) (ADDN N (CDR V)))))))                           00024780
                                                                        00024790
(MULTSQ (LAMBDA (U V)                                                   00024800
   (COND                                                                00024810
    ((OR (NULL (CAR U)) (NULL (CAR V))) (CONS NIL 1))                   00024820
    (T                                                                  00024830
     ((LAMBDA(X Y)                                                      00024840
       (COND ((AND X Y) (CONS (MULTF X Y) 1))                           00024850
           (X (CONS (MULTF X (CAR V)) (CDR U)))                         00024860
           (Y (CONS (MULTF (CAR U) Y) (CDR V)))                         00024870
           (T                                                           00024880
            (CONS (MULTF (CAR U) (CAR V))                               00024890
                (MULTF (CDR U) (CDR V))))))                             00024900
      (QUOTF (CAR U) (CDR V))                                           00024910
      (QUOTF (CAR V) (CDR U)))))))                                      00024920
                                                                        00024930
(MULTF (LAMBDA (U V)                                                    00024940
   (PROG (X Y Z)                                                        00024950
       (COND ((OR (NULL U) (NULL V)) (RETURN NIL))                      00024960
             ((ATOM U) (RETURN (MULTN U V)))                            00024970
             ((ATOM V) (RETURN (MULTN V U)))                            00024980
             ((OR *EXP *NCMP) (GO A)))                                  00024990
       (SETQ U (MKSFP U 1))                                             00025000
       (SETQ V (MKSFP V 1))                                             00025010
       (COND ((ATOM U) (RETURN (MULTN U V)))                            00025020
             ((ATOM V) (RETURN (MULTN V U))))                           00025030
    A    (SETQ X (CAAAR U))                                             00025040
       (SETQ Y (CAAAR V))                                               00025050
       (COND                                                            00025060
        ((OR (ATOM X)                                                   00025070
             (ATOM Y)                                                   00025080
             (NOT (ATOM (CAR X)))                                       00025090
             (NOT (ATOM (CAR Y))))                                      00025100
         (GO B))                                                        00025110
        ((AND (EQ (CAR X) (CAR Y))                                      00025120
            (SETQ Z (GET (CAR X) (QUOTE MRULE)))                        00025130
            (NOT                                                        00025140
             (EQ (SETQ Z (*APPLY Z (LIST (CAAR U) (CAAR V))))           00025150
                 (QUOTE FAILED))))                                      00025160
         (RETURN                                                        00025170
          (ADDF (MULTF Z (MULTF (CDAR U) (CDAR V)))                     00025180
              (ADDF (MULTF (LIST (CAR U)) (CDR V))                      00025190
                  (MULTF (CDR U) V)))))                                 00025200
        ((AND (FLAGP (CAR X) (QUOTE NONCOM))                            00025210
            (FLAGP (CAR Y) (QUOTE NONCOM)))                             00025220
         (GO B1)))                                                      00025230
    B    (COND ((EQ X Y) (GO C))                                        00025240
            ((ORDP (CAAR U) (CAAR V)) (GO B1)))                         00025250
         (SETQ X (MULTF U (CDAR V)))                                    00025260
         (SETQ Y (MULTF U (CDR V)))                                     00025270
         (RETURN (COND ((NULL X) Y) (T (CONS (CONS (CAAR V) X) Y))))    00025280
    B1   (SETQ X (MULTF (CDAR U) V))                                    00025290
         (SETQ Y (MULTF (CDR U) V))                                     00025300
         (RETURN (COND ((NULL X) Y) (T (CONS (CONS (CAAR U) X) Y))))    00025310
    C    (SETQ X (MKSP X (PLUS (CDAAR U) (CDAAR V))))                   00025320
       (SETQ Y                                                          00025330
             (ADDF (MULTF (LIST (CAR U)) (CDR V))                       00025340
                 (MULTF (CDR U) V)))                                    00025350
       (RETURN                                                          00025360
        (COND                                                           00025370
         ((NULL (CDR X))                                                00025380
          (COND ((NULL (CAAR X)) Y)                                     00025390
              (T                                                        00025400
               (ADDF (MULTF (CAAR X)                                    00025410
                        (MULTF (CDAR U)                                 00025420
                               (COND                                    00025430
                              ((EQUAL (CDAR X) 1) (CDAR V))             00025440
                              (T                                        00025450
                               (MULTF                                   00025460
                                (MKSQP (CONS 1 (CDAR X)))               00025470
                                (CDAR V))))))                           00025480
                    Y))))                                               00025490
           ((NULL (SETQ U (MULTF (CDAR U) (CDAR V)))) Y)                00025495
           (T (CONS (CONS X U) Y)))))))                                 00025500
                                                                        00025510
(MULTF2 (LAMBDA (U V)                                                   00025520
   (MULTF (LIST (CONS U 1)) V)))                                        00025530
                                                                        00025540
(MULTN (LAMBDA (N V)                                                    00025550
   (COND ((NULL V) NIL)                                                 00025560
       ((ZEROP N) NIL)                                                  00025570
       ((ONEP N) V)                                                     00025580
       ((NUMBERP V) (TIMES N V))                                        00025590
         ((EQ (CAR V) (QUOTE QUOTIENT))                                 00025591
                (MKFR (TIMES N (CADR V)) (CADDR V)))                    00025592
       (T                                                               00025600
        (CONS (CONS (CAAR V) (MULTN N (CDAR V)))                        00025610
            (MULTN N (CDR V)))))))                                      00025620
                                                                        00025630
))                                                                      00025640
                                                                        00025650
DEFINE ((                                                               00025660
                                                                        00025670
(REVAL (LAMBDA (U)                                                      00025680
   (COND ((AND (NUMBERP U) (FIXP U)) U)                                 00025690
       ((VECTORP U) U)                                                  00025700
       (T ((LAMBDA (X)                                                  00025710
           (COND ((AND (EQCAR X (QUOTE MINUS)) (NUMBERP (CADR X)))      00025712
                   (MINUS (CADR X)))                                    00025714
               (T X)))                                                  00025716
           (PREPSQ (AEVAL1 U)))))))                                     00025718
                                                                        00025720
(AEVAL (LAMBDA (U)                                                      00025730
   (COND                                                                00025740
    ((EQCAR U (QUOTE *COMMA*)) (REDERR (QUOTE (SYNTAX ERROR))))         00025750
    (T (MK*SQ (AEVAL1 U))))))                                           00025760
                                                                        00025770
(AEVAL1 (LAMBDA (U)                                                     00025780
   (PROG2 (RSET2)                                                       00025790
        (COND ((MATEXPR U) (MATSM U)) (T (SUBS2 (SIMP* U)))))))         00025800
                                                                        00025810
(MATEXPR (LAMBDA (U)                                                    00025820
   NIL))                                                                00025830
                                                                        00025840
(MK*SQ (LAMBDA (U)                                                      00025880
   (COND ((NULL (CAR U)) 0)                                             00025890
       ((AND (ATOM (CAR U)) (EQUAL (CDR U) 1)) (CAR U))                 00025900
       ((EQCAR U (QUOTE MAT)) U)                                        00025910
       (T (CONS (QUOTE *SQ) (CONS U *SQVAR*))))))                       00025920
                                                                        00025930
(RSET2 (LAMBDA NIL                                                      00025940
   (PROG2 (MAP RPLIS*                                                   00025950
             (FUNCTION (LAMBDA (J) (RPLACW (CDAR J) (CAAR J)))))        00025960
        (SETQ RPLIS* NIL))))                                            00025970
                                                                        00025980
))                                                                      00025990
                                                                        00026000
DEFINE ((                                                               00026010
                                                                        00026020
(MKSP (LAMBDA (U P)                                                     00026030
   (PROG (V X Y)                                                        00026040
       (SETQ U (FKERN U))                                               00026050
    A0   (SETQ V (CDDR U))                                              00026060
    A    (COND ((OR (NULL V) (NULL SUBFG*)) (GO B))                     00026070
             ((SETQ X (ASSOC (QUOTE ASYMP) V)) (GO L1))                 00026080
             ((SETQ X (ASSOC (QUOTE REP) V)) (GO L2))                   00026090
             ((AND (NOT (ATOM (CAR U)))                                 00026110
                 (ATOM (CAAR U))                                        00026120
                 (FLAGP (CAAR U) (QUOTE VOP))                           00026130
                 (VCREP U))                                             00026140
            (GO A0)))                                                   00026150
    B    (RETURN (GETPOWER U P))                                        00026170
    L1   (COND                                                          00026180
        ((NOT (LESSP P (CDR X))) (RETURN (LIST (CONS NIL 1)))))         00026190
       (SETQ V (DELASC (CAR X) V))                                      00026200
       (GO A)                                                           00026210
    L2   (SETQ V (CDDDR X))                                             00026220
       (COND ((LESSP P (CADDR X)) (GO B))                               00026230
               ((AND (CAR V)                                            00026231
                 (NOT (FLAGP** (CAR U) (QUOTE WEIGHT)))) (GO L3)))      00026232
       (SETQ SUBL* (CONS V SUBL*))                                      00026240
       (SETQ Y (SIMPCAR (CDR X)))                                       00026250
       (COND                                                            00026260
        ((NOT (ASSOC (QUOTE HOLD) (CDDR U))) (GO L21))                  00026270
        ((EQUAL (CDR Y) 1) (SETQ Y (CONS (MKSFP (CAR Y) 1) 1)))         00026280
        (T (SETQ Y (MKSQP Y))))                                         00026290
   L21   (RPLACA V (MK*SQ Y))                                           00026295
         (GO L31)                                                       00026300
   L3    (SETQ Y (SIMPCAR V))                                           00026305
         (COND((AND(EQCAR (CAR V)(QUOTE *SQ))(NULL(CADDAR V)))(GO L21)))00026310
   L31   (SETQ V Y)                                                     00026315
         (SETQ X (CADDR X))                                             00026320
       (COND ((ONEP X) (RETURN (LIST (NMULTSQ V P)))))                  00026330
       (SETQ Y (DIVIDE P X))                                            00026340
    C    (SETQ V (NMULTSQ V (CAR Y)))                                   00026370
       (COND                                                            00026380
        ((NOT (ZEROP (CDR Y)))                                          00026390
         (SETQ V                                                        00026400
             (CONS (MULTF2 (GETPOWER U (CDR Y)) (CAR V))                00026410
                   (CDR V)))))                                          00026420
         (RETURN (LIST V)))))                                           00026470
                                                                        00026500
(FKERN (LAMBDA (U)                                                      00026510
   (PROG (V)                                                            00026520
       (COND ((NOT (ATOM U)) (GO A0))                                   00026530
             ((SETQ V (GET U (QUOTE APROP))) (RETURN V)))               00026540
       (SETQ V (LIST U NIL))                                            00026550
       (PUT U (QUOTE APROP) V)                                          00026560
       (RETURN V)                                                       00026570
    A0   (COND ((NOT (ATOM (CAR U))) (SETQ V EXLIST*))                  00026580
             ((NOT (SETQ V (GET (CAR U) (QUOTE KLIST)))) (GO B)))       00026590
    A    (COND ((EQUAL U (CAAR V)) (RETURN (CAR V)))                    00026600
             ((ORDP U (CAAR V))                                         00026610
            (RETURN                                                     00026620
             (CAR                                                       00026630
              (RPLACW V                                                 00026640
                    (CONS (LIST U NIL)                                  00026650
                        (CONS (CAR V) (CDR V)))))))                     00026660
             ((NULL (CDR V))                                            00026670
            (RETURN (CADR (RPLACD V (LIST (LIST U NIL)))))))            00026680
       (SETQ V (CDR V))                                                 00026690
       (GO A)                                                           00026700
    B    (SETQ V (LIST (LIST U NIL)))                                   00026710
       (PUT (CAR U) (QUOTE KLIST) V)                                    00026720
       (GO A))))                                                        00026730
                                                                        00026740
(GETPOWER (LAMBDA (U N)                                                 00026750
   (PROG (V)                                                            00026760
         (COND ((AND SUBFG* (NOT (ASSOC (QUOTE USED*) (CDR U))))        00026761
                (ACONC U (LIST (QUOTE USED*)))))                        00026762
       (SETQ V (CADR U))                                                00026770
       (COND                                                            00026780
        ((NULL V)                                                       00026790
         (RETURN (CAAR (RPLACA (CDR U) (LIST (CONS (CAR U) N)))))))     00026800
    A    (COND ((EQUAL N (CDAR V)) (RETURN (CAR V)))                    00026810
             ((LESSP N (CDAR V))                                        00026820
            (RETURN                                                     00026830
             (CAR                                                       00026840
              (RPLACW V                                                 00026850
                    (CONS (CONS (CAAR V) N)                             00026860
                                 (CONS (CAR V) (CDR V)))))))            00026870
       ((NULL (CDR V))                                                  00026880
          (RETURN (CADR (RPLACD V (LIST (CONS (CAAR V) N)))))))         00026890
       (SETQ V (CDR V))                                                 00026900
       (GO A))))                                                        00026910
                                                                        00026920
(NMULTSQ (LAMBDA (U N)                                                  00026930
   (PROG (X)                                                            00026940
       (COND                                                            00026950
          ((NULL (CAR U)) (RETURN U))                                   00026955
        ((NULL *EXP)                                                    00026960
         (RETURN (CONS (MKSFP (CAR U) N) (MKSFP (CDR U) N)))))          00026970
       (SETQ X U)                                                       00026980
    A    (COND ((ONEP N) (RETURN X)))                                   00026990
       (SETQ X (MULTSQ U X))                                            00027000
       (SETQ N (SUB1 N))                                                00027010
       (GO A))))                                                        00027020
                                                                        00027030
))                                                                      00027040
                                                                        00027050
DEFINE ((                                                               00027060
                                                                        00027070
(MKSF (LAMBDA (U N)                                                     00027080
   ((LAMBDA(X)                                                          00027090
     (COND                                                              00027100
      ((NULL (CDR X))                                                   00027110
       (COND ((EQUAL (CDAR X) 1) (CAAR X))                              00027120
           (T (MULTF (MKSQP (CONS 1 (CDAR X))) (CAAR X)))))             00027130
      (T (LIST (CONS X 1)))))                                           00027140
    (MKSP U N))))                                                       00027150
                                                                        00027160
(MKSFP (LAMBDA (U N)                                                    00027170
   (COND ((KERNLP U) (NMULTF U N))                                      00027180
       (T                                                               00027190
        (PROG2 (SETQ SUB2* T)                                           00027200
             (COND ((MINUSF U) (MULTN -1 (MKSF (MULTN -1 U) N)))        00027210
                   (T (MKSF U N))))))))                                 00027220
                                                                        00027230
(MKSQP (LAMBDA (U)                                                      00027240
   (COND ((NULL (CAR U)) NIL)                                           00027250
       ((OR (EQUAL (CDR U) 1) (EQUAL (CDR (SETQ U (CANCEL U))) 1))      00027260
        (COND (*EXP (CAR U)) (T (MKSFP (CAR U) 1))))                    00027270
       (T                                                               00027280
        (PROG NIL                                                       00027290
            (SETQ SUB2* T)                                              00027300
            (RETURN                                                     00027310
             (COND (*EXP                                                00027320
                  (MULTF (CAR U)                                        00027330
                         (MKSF (MK*SQ                                   00027340
                              (CONS 1 (MKSFP (CDR U) 1)))               00027350
                              1)))                                      00027360
                   ((MINUSF (CAR U))                                    00027370
                  (MULTN -1                                             00027380
                         (MKSF                                          00027390
                        (MK*SQ                                          00027400
                         (CONS (MULTN -1 (CAR U))                       00027410
                               (MKSFP (CDR U) 1)))                      00027420
                        1)))                                            00027430
                   (T                                                   00027440
                  (MKSF (MK*SQ                                          00027450
                         (CONS (CAR U) (MKSFP (CDR U) 1)))              00027460
                         1)))))))))                                     00027470
                                                                        00027480
(MKSQ (LAMBDA (U N)                                                     00027570
   ((LAMBDA(X)                                                          00027580
     (COND ((NULL (CDR X)) (CAR X)) (T (CONS (LIST (CONS X 1)) 1))))    00027590
    (MKSP U N))))                                                       00027600
                                                                        00027610
))                                                                      00027620
                                                                        00027630
DEFINE ((                                                               00027640
                                                                        00027650
(SIMP* (LAMBDA (U)                                                      00027660
   (COND ((LESSP (SCNT U) SNO*) (ISIMPQ (SIMP U)))                      00027670
       ((EQ (CAR U) (QUOTE PLUS)) (SIMPADD (CDR U)))                    00027680
       ((EQ (CAR U) (QUOTE MINUS)) (NEGSQ (SIMP* (CARX (CDR U)))))      00027690
       ((EQ (CAR U) (QUOTE TIMES)) (ISIMPQ* (TSCAN (CDR U))))           00027700
       (T (ISIMPQ (SIMP U))))))                                         00027710
                                                                        00027720
(SIMPADD (LAMBDA (U)                                                    00027730
   (PROG (Z)                                                            00027740
       (SETQ Z (CONS NIL 1))                                            00027750
    A    (COND ((NULL U) (RETURN Z)))                                   00027760
       (SETQ Z (ADDSQ (SIMP* (CAR U)) Z))                               00027770
       (SETQ U (CDR U))                                                 00027780
       (GO A))))                                                        00027790
                                                                        00027800
(ISIMPQ* (LAMBDA (U)                                                    00027810
   (PROG (X)                                                            00027820
       (SETQ U (REVERSE (MAPCAR U (FUNCTION SIMP))))                    00027830
       (SETQ SV* (CONS NIL 1))                                          00027840
       (ISIMPQ*1 (CDR U) (CAR U))                                       00027850
       (SETQ X SV*)                                                     00027860
       (SETQ SV* NIL)                                                   00027870
       (RETURN X))))                                                    00027880
                                                                        00027890
(ISIMPQ*1 (LAMBDA (U V)                                                 00027900
   (PROG (X Y)                                                          00027910
       (COND ((NULL U) (RETURN (SETQ SV* (ADDSQ (ISIMPQ V) SV*)))))     00027920
       (SETQ X (CAAR U))                                                00027930
       (SETQ Y (MULTF (CDAR U) (CDR V)))                                00027940
       (SETQ V (CAR V))                                                 00027950
    A    (COND ((NULL X) (RETURN NIL))                                  00027960
             ((ATOM X)                                                  00027970
            (RETURN (ISIMPQ*1 (CDR U) (CONS (MULTN X V) Y)))))          00027980
       (ISIMPQ*1 (CDR U) (CONS (MULTF (LIST (CAR X)) V) Y))             00027990
       (SETQ X (CDR X))                                                 00028000
       (GO A))))                                                        00028010
                                                                        00028020
(ISIMPQ (LAMBDA (U)                                                     00028020
   U))                                                                  00028020
                                                                        00028020
(TSCAN (LAMBDA (U)                                                      00028030
   (COND ((NULL U) NIL)                                                 00028040
       ((ATOM U) (ERRACH (LIST (QUOTE TSCAN) U)))                       00028050
       ((EQ (CAR U) (QUOTE TIMES)) (TSCAN (CDR U)))                     00028060
       ((AND (NOT (ATOM (CAR U))) (EQ (CAAR U) (QUOTE TIMES)))          00028070
        (APPEND (TSCAN (CDAR U)) (TSCAN (CDR U))))                      00028080
       (T (CONS (CAR U) (TSCAN (CDR U)))))))                            00028090
                                                                        00028100
(SCNT (LAMBDA (U)                                                       00028110
   (COND ((OR (NULL U) (EQUAL U 0)) 0)                                  00028120
       ((ATOM U) 1)                                                     00028130
       ((EQ (CAR U) (QUOTE PLUS))                                       00028140
        (*EVAL                                                          00028150
         (CONS (QUOTE PLUS) (MAPCAR (CDR U) (FUNCTION SCNT)))))         00028160
       ((MEMBER (CAR U) (QUOTE (TIMES G CONS EPS)))                     00028170
        (*EVAL                                                          00028180
         (CONS (QUOTE TIMES) (MAPCAR (CDR U) (FUNCTION SCNT)))))        00028190
       ((FLAGP (CAR U) (QUOTE UNIP)) (SCNT (CADR U)))                   00028200
       ((EQ (CAR U) (QUOTE EXPT))                                       00028210
        (COND                                                           00028220
         ((OR (ATOM (CADR U)) (NOT (NUMBERP (CADDR U)))) 1)             00028230
         (T                                                             00028240
          ((LAMBDA(X)                                                   00028250
            (COND ((LESSP X 2) 1)                                       00028260
                (T (TIMES 2 X (ABS (*EVAL (CADDR U)))))))               00028270
           (SCNT (CADR U))))))                                          00028280
       ((AND (EQ (CAR U) (QUOTE *SQ)) GAMIDEN*) (TERMS1 (CAADR U)))     00028290
       (T 1))))                                                         00028300
                                                                        00028310
))                                                                      00028320
                                                                        00028330
DEFINE ((                                                               00028340
                                                                        00028350
(SIMP (LAMBDA (U)                                                       00028360
   (PROG (X)                                                            00028370
    A    (COND ((ATOM U) (RETURN (SIMPATOM U)))                         00028380
             ((OR (NOT (ATOM (CAR U))) (NUMBERP (CAR U))) (GO E))       00028390
             ((AND (SETQ X (OPMTCH U)) (SETQ U X)) (GO A))              00028400
             ((SETQ X (GET (CAR U) (QUOTE SIMPFN)))                     00028410
            (RETURN                                                     00028420
             (COND                                                      00028430
              ((EQ X (QUOTE IDEN)) (SIMPIDEN U))                        00028440
              (T (*APPLY X (LIST (CDR U)))))))                          00028450
             ((GET (CAR U) (QUOTE **ARRAY)) (GO D))                     00028460
             ((FLAGP (CAR U) (QUOTE OPFN))                              00028470
            (SETQ U (*APPLY (CAR U) (CDR U))))                          00028480
             ((GET (CAR U) (QUOTE INFIX)) (GO E))                       00028490
             ((MEMBER (CAR U) (QUOTE (COND PROG)))                      00028500
            (RETURN (SIMP (*EVAL U))))                                  00028510
             ((NOT (REDMSG (CAR U) (QUOTE OPERATOR) T)) (ERROR*))       00028520
             (T (MKOP (CAR U))))                                        00028530
       (GO A)                                                           00028540
    D    (SETQ U (CONS (CAR U) (MAPCAR (CDR U) (FUNCTION REVAL))))      00028550
       (COND                                                            00028560
        ((NOT (NUMLIS (CDR U)))                                         00028570
         (REDERR                                                        00028580
          (APPEND (QUOTE (INCORRECT ARRAY ARGUMENTS FOR))               00028590
                (LIST (CAR U)))))                                       00028600
        ((AND (SETQ X (GETEL U)) (SETQ U X)) (GO A))                    00028610
          (T (RETURN (MKSQ U 1))))                                      00028620
    E    (CURERR (QUOTE (SYNTAX ERROR)) NIL))))                         00028630
                                                                        00028640
(SIMPATOM (LAMBDA (U)                                                   00028650
    (COND((NULL U)(REDERR(QUOTE(NIL USED IN ALGEBRAIC EXPRESSION))))    00028660
       ((NUMBERP U)                                                     00028670
        (COND ((ZEROP U) (CONS NIL 1))                                  00028680
            ((FIXP U) (CONS U 1))                                       00028690
            (*FLOAT (CONS (PLUS 0.0 U) 1))                              00028700
            (T                                                          00028710
             ((LAMBDA(Z)                                                00028720
               (PROG2 (REPPRI U                                         00028730
                          (LIST                                         00028740
                           (QUOTE QUOTIENT)                             00028750
                           (CAR Z)                                      00028760
                           (CDR Z)))                                    00028770
                     Z))                                                00028780
              (MAKFRC U)))))                                            00028790
       ((VECTORP U)                                                     00028800
        (REDERR                                                         00028810
         (CONS (QUOTE VECTOR) (CONS U (QUOTE (USED AS SCALAR))))))      00028820
         (T (MKSQ U 1)))))                                              00028830
                                                                        00028840
(MAKFRC (LAMBDA (U)                                                     00028850
   (PROG (X Y)                                                          00028860
       (SETQ X (FIX (TIMES **MILLION U)))                               00028870
       (SETQ Y (GCDN **MILLION X))                                      00028880
       (RETURN (CONS (QUOTIENT X Y) (QUOTIENT **MILLION Y))))))         00028890
                                                                        00028900
(MKOP (LAMBDA (U)                                                       00028910
  (COND ((MEMBER U FRLIS*) (REDERR (CONS (QUOTE OPERATOR)               00028920
            (CONS U (QUOTE (CANNOT BE ARBITRARY))))))                   00028922
   (T (PUT U (QUOTE SIMPFN) (QUOTE IDEN))))))                           00028924
                                                                        00028930
(SIMPCAR (LAMBDA (U)                                                    00028940
   (SIMP (CAR U))))                                                     00028950
                                                                        00028960
(VECTORP (LAMBDA (U)                                                    00028970
   NIL))                                                                00028980
                                                                        00028990
(SIMPEXPT (LAMBDA (U)                                                   00029000
   (PROG (N X)                                                          00029010
       (COND                                                            00029020
        ((AND (NUMBERP (SETQ N (CARX (CDR U)))) (FIXP N)) (GO A)))      00029030
       (SETQ X *FLOAT)                                                  00029040
       (SETQ *FLOAT NIL)                                                00029050
       (SETQ N (CANCEL (SIMP N)))                                       00029060
       (SETQ *FLOAT X)                                                  00029070
       (COND ((AND (ATOM (CAR N)) (EQUAL (CDR N) 1)) (GO A0)))          00029080
       (SETQ X (PREPSQ (SIMPCAR U)))                                    00029090
       (SETQ N (PREPSQ N))                                              00029100
         (COND ((EQCAR X (QUOTE TIMES)) (GO B))                         00029101
               ((AND (EQCAR X (QUOTE MINUS))                            00029102
                     (NOT (NUMBERP (CADR X))))                          00029103
                (RETURN                                                 00029104
                 (MULTSQ (SIMPEXPT (LIST -1 N))                         00029105
                         (SIMPEXPT (LIST (CADR X) N)))))                00029106
               ((EQCAR X (QUOTE QUOTIENT))                              00029107
                (RETURN                                                 00029108
                 (MULTSQ (SIMPEXPT (LIST (CADR X) N))                   00029109
                         (SIMPEXPT                                      00029110
                          (LIST (CADDR X) (LIST (QUOTE MINUS) N))))))   00029111
               ((EQCAR X (QUOTE EXPT))                                  00029112
                (AND (SETQ N                                            00029113
                           (REVAL (LIST (QUOTE TIMES) (CADDR X) N)))    00029114
                     (SETQ X (CADR X)))))                               00029115
         (RETURN                                                        00029116
          (COND ((EQUAL X 0) (CONS NIL 1))                              00029117
                ((EQUAL X 1) (CONS 1 1))                                00029118
                ((AND (ATOM X) (MEMBER N FRLIS*))                       00029119
                 (CONS (LIST (CONS (CONS X N) 1)) 1))                   00029120
                (T                                                      00029121
                 (PROG2 (AND (NOT (MEMBER X EXPTL*))                    00029122
                             (NOT (NUMBERP X))                          00029123
                             (SETQ EXPTL* (CONS X EXPTL*)))             00029124
                        (MKSQ (LIST (QUOTE EXPT) X N) 1)))))            00029125
    A0   (SETQ N (CAR N))                                               00029170
      (COND ((NULL N) (SETQ N 0)))                                      00029172
    A    (RETURN                                                        00029180
        (COND ((EQUAL N 0) (CONS 1 1))                                  00029190
            ((ATOM (CAR U))                                             00029200
             (COND ((NULL N) (CONS 1 1))                                00029210
                   ((NUMBERP (CAR U))                                   00029220
                  (COND                                                 00029230
                   ((ZEROP (CAR U)) (CONS NIL 1))                       00029240
                   ((MINUSP N)                                          00029250
                    (CONS 1 (EXPT (CAR U) (MINUS N))))                  00029260
                   (T (CONS (EXPT (CAR U) N) 1))))                      00029270
                   ((MINUSP N)                                          00029280
                    (LIST 1 (CONS (MKSP (CAR U) (MINUS N)) 1)))         00029290
                       (T (MKSQ (CAR U) N))))                           00029300
            ((MINUSP N) (REVPR (NMULTSQ (SIMPCAR U) (MINUS N))))        00029310
                (T (NMULTSQ (SIMPCAR U) N))))                           00029311
   B     (SETQ U (CDDR X))                                              00029312
         (SETQ X (SIMPEXPT (LIST (CADR X) N)))                          00029313
   C     (COND ((NULL U) (RETURN X)))                                   00029314
         (SETQ X (MULTSQ (SIMPEXPT (LIST (CAR U) N)) X))                00029315
         (SETQ U (CDR U))                                               00029316
         (GO C))))                                                      00029317
                                                                        00029318
(MEXPT (LAMBDA (U V)                                                    00029340
   (COND                                                                00029350
    ((NOT (EQUAL (CADAR U) (CADAR V))) (QUOTE FAILED))                  00029360
    (T                                                                  00029370
     ((LAMBDA(X)                                                        00029380
       (COND ((EQUAL X 0) 1)                                            00029390
             ((AND (NUMBERP X) (EQUAL (CADAR U) (QUOTE (MINUS 1))))     00029400
              (COND ((ZEROP (REMAINDER X 2)) 1) (T -1)))                00029410
           (T (MKSQP (MKSQ (LIST (QUOTE EXPT) (CADAR U) X) 1)))))       00029450
      (REVAL                                                            00029460
       (LIST (QUOTE PLUS)                                               00029470
           (LIST (QUOTE TIMES) (CDR U) (CADDAR U))                      00029480
           (LIST (QUOTE TIMES) (CDR V) (CADDAR V)))))))))               00029490
                                                                        00029500
))                                                                      00029510
                                                                        00029520
DEFLIST (((EXPT MEXPT)) MRULE)                                          00029530
                                                                        00029540
DEFINE ((                                                               00029550
                                                                        00029560
(SIMPIDEN (LAMBDA (*S*)                                                 00029570
   (PROG (Y Z)                                                          00029580
       (COND ((FLAGP (CAR *S*) (QUOTE VOP)) (GO E)))                    00029590
       (SETQ *S*                                                        00029600
             (CONS (CAR *S*) (MAPCAR (CDR *S*) (FUNCTION REVAL))))      00029610
    B    (COND ((SETQ Z (OPMTCH *S*)) (RETURN (SIMP Z)))                00029620
             ((FLAGP (CAR *S*) (QUOTE SYMMETRIC))                       00029630
            (SETQ *S* (CONS (CAR *S*) (ORDN (CDR *S*)))))               00029640
             ((FLAGP (CAR *S*) (QUOTE ANTISYMMETRIC)) (GO D)))          00029650
    C    (SETQ *S* (MKSQ *S* 1))                                        00029660
       (RETURN (COND (Y (NEGSQ *S*)) (T *S*)))                          00029670
    D    (COND ((REPEATS (CDR *S*)) (RETURN (CONS NIL 1)))              00029680
             ((NOT (PERMP (SETQ Z (ORDN (CDR *S*))) (CDR *S*)))         00029690
            (SETQ Y T)))                                                00029700
       (SETQ *S* (CONS (CAR *S*) Z))                                    00029710
       (GO C)                                                           00029720
    E    (COND ((ATOMLIS (CDR *S*)) (GO B)))                            00029730
       (RETURN                                                          00029740
        (MKVARG (CDR *S*)                                               00029750
              (FUNCTION                                                 00029760
               (LAMBDA (J) (SIMPIDEN (CONS (CAR *S*) J)))))))))         00029770
                                                                        00029780
(NEGSQ (LAMBDA (U)                                                      00029790
   (CONS (MULTN -1 (CAR U)) (CDR U))))                                  00029800
                                                                        00029810
(SIMPMINUS (LAMBDA (U)                                                  00029820
   (NEGSQ (SIMP (CARX U)))))                                            00029830
                                                                        00029840
(SIMPPLUS (LAMBDA (U)                                                   00029850
   (PROG (Z)                                                            00029860
       (SETQ Z (CONS NIL 1))                                            00029870
    A    (COND ((NULL U) (RETURN Z)))                                   00029880
       (SETQ Z (ADDSQ (SIMPCAR U) Z))                                   00029890
       (SETQ U (CDR U))                                                 00029900
       (GO A))))                                                        00029910
                                                                        00029920
(SIMPQUOT (LAMBDA (U)                                                   00029930
   ((LAMBDA(X)                                                          00029940
     (COND                                                              00029950
      ((NULL (CDR X)) (REDERR (QUOTE (ZERO DENOMINATOR))))              00029960
      (T (MULTSQ (SIMPCAR U) X))))                                      00029970
    (SIMPRECIP (CDR U)))))                                              00029980
                                                                        00029990
(SIMPRECIP (LAMBDA (U)                                                  00030000
   ((LAMBDA(X)                                                          00030010
     (COND                                                              00030020
      ((NULL (CAR X)) (REDERR (QUOTE (ZERO DENOMINATOR))))              00030030
      ((AND *FLOAT (ATOM (CAR X)))                                      00030040
       (CONS (MULTN (RECIP (PLUS 0.0 (CAR X))) (CDR X)) 1))             00030050
      (T (REVPR X))))                                                   00030060
    (SIMP (CARX U)))))                                                  00030070
                                                                        00030080
(SIMPTIMES (LAMBDA (U)                                                  00030090
   (PROG (X)                                                            00030100
       (SETQ X (SIMPCAR U))                                             00030110
    A    (SETQ U (CDR U))                                               00030120
       (COND ((NULL (CAR X)) (RETURN (CONS NIL 1)))                     00030130
             ((NULL U) (RETURN X)))                                     00030140
       (SETQ X (MULTSQ X (SIMPCAR U)))                                  00030150
       (GO A))))                                                        00030160
                                                                        00030170
(SIMPSUBS (LAMBDA (U)                                                   00030180
   (PROG (X Y Z)                                                        00030190
       (SETQ U (REVERSE U))                                             00030200
       (SETQ Y (SUBS2 (SIMPCAR U)))                                     00030210
       (SETQ U (CDR U))                                                 00030220
    A    (COND ((NULL U) (GO B))                                        00030230
             ((NOT (MEMBER (CAAR U) (QUOTE (EQUAL SETQ))))              00030240
            (GO ERR))                                                   00030250
             ((VECTORP (SETQ X (CADAR U))) (GO C))                      00030260
             ((OR (NOT (KERNP (SETQ X (SIMP X))))                       00030270
                (NOT (EQUAL (CDR X) 1))                                 00030280
                (NOT (EQUAL (CDAAR X) 1))                               00030290
                (NOT (EQUAL (CDAAAR X) 1)))                             00030300
            (GO ERR)))                                                  00030310
       (SETQ X (CAAAAR X))                                              00030320
    C    (SETQ Z (CONS (CONS X (CADDAR U)) Z))                          00030330
       (SETQ U (CDR U))                                                 00030340
       (GO A)                                                           00030350
    B    (RETURN (SIMP (SUBLIS Z (PREPSQ Y))))                          00030360
    ERR  (ERRPRI1 (CAR U))                                              00030370
       (ERROR*))))                                                      00030380
                                                                        00030390
(SIMP*SQ (LAMBDA (U)                                                    00030400
   (COND ((NULL (CADR U)) (SIMP (PREPSQ (CAR U)))) (T (CAR U)))))       00030410
                                                                        00030420
))                                                                      00030430
                                                                        00030440
DEFINE ((                                                               00030450
                                                                        00030460
(SUBS2 (LAMBDA (U)                                                      00030470
   (PROG (X)                                                            00030480
       (RSET2)                                                          00030490
       (SETQ U (EXPSQ U))                                               00030500
         (COND ((AND (NULL EXPTL*)                                      00030505
                     (OR (NULL MATCH*) (NULL SUBFG*))) (GO A)))         00030510
         (COND (EXPTL* (SETQ U (EXPTCHK U))))                           00030515
       (SETQ X MCHFG*)                                                  00030520
       (SETQ U (MULTSQ (SUBS31 (CAR U)) (REVPR (SUBS31 (CDR U)))))      00030530
       (SETQ MCHFG* X)                                                  00030540
    A    (RETURN (CANCEL U)))))                                         00030550
                                                                        00030560
(CANCEL (LAMBDA (U)                                                     00030570
   (PROG (X)                                                            00030580
       (COND ((NULL (CAR U)) (RETURN (CONS NIL 1)))                     00030590
             ((OR *FLOAT (EQUAL (CDR U) 1)) (GO C)))                    00030600
       (SETQ X (GCD1 (CDR U) (CAR U)))                                  00030610
       (SETQ U (CONS (QUOTF (CAR U) X) (QUOTF (CDR U) X)))              00030620
    C    (RETURN (MKCANON U)))))                                        00030630
                                                                        00030640
(MKCANON (LAMBDA (U)                                                    00030650
   (COND ((MINUSF (CDR U))                                              00030660
        (CONS (MULTN -1 (CAR U)) (MULTN -1 (CDR U))))                   00030670
       (T U))))                                                         00030680
                                                                        00030690
(MINUSF (LAMBDA (U)                                                     00030700
   (COND ((NULL U) NIL)                                                 00030701
         ((ATOM U) (MINUSP U))                                          00030702
         ((EQ (CAR U) (QUOTE QUOTIENT)) (MINUSP (CADR U)))              00030703
         (T (MINUSF (CDAR U))))))                                       00030704
                                                                        00030720
))                                                                      00030730
                                                                        00030740
DEFINE ((                                                               00030750
                                                                        00030760
(EXPSQ (LAMBDA (U)                                                      00030770
   (COND ((OR (NULL SUB2*) (NULL *EXP)) U)                              00030780
       (T                                                               00030790
        ((LAMBDA(X Y)                                                   00030800
          (CONS (MULTF (CAR X) (CDR Y)) (MULTF (CDR X) (CAR Y))))       00030810
         (EXPAND (CAR U))                                               00030820
         (COND (*XDN (EXPAND (CDR U))) (T (CONS (CDR U) 1))))))))       00030830
                                                                        00030840
(EXPAND (LAMBDA (U)                                                     00030850
   (PROG (W X Y Z)                                                      00030860
       (COND ((ATOM U) (RETURN (CONS U 1))))                            00030870
       (SETQ X U)                                                       00030880
       (SETQ Z (CONS NIL 1))                                            00030890
    A    (COND                                                          00030900
        ((NULL X)                                                       00030910
         (RETURN                                                        00030920
          (COND ((EQUAL (CAR Z) U) (CONS U (CDR Z))) (T Z))))           00030930
        ((ATOM X) (GO E)))                                              00030940
       (SETQ Y (EXPAND (CDAR X)))                                       00030950
       (COND                                                            00030960
        ((AND (NOT (ATOM (SETQ W (CAAAR X))))                           00030970
            (OR (EQ (CAR W) (QUOTE *SQ)) (NOT (ATOM (CAR W)))))         00030980
         (GO C)))                                                       00030990
       (SETQ Z (ADDSQ (CONS (MULTF2 (CAAR X) (CAR Y)) (CDR Y)) Z))      00031000
    B    (SETQ X (CDR X))                                               00031010
       (GO A)                                                           00031020
    C    (SETQ Z                                                        00031030
             (ADDSQ                                                     00031040
            (MULTSQ                                                     00031050
             (COND                                                      00031060
              ((EQ (CAR W) (QUOTE *SQ))                                 00031070
               (NMULTSQ (EXPSQ (CADR W)) (CDAAR X)))                    00031080
              ((NULL (CDAAR X)) (EXPSQ W))                              00031090
              (T (NMULTSQ (EXPAND W) (CDAAR X))))                       00031100
             Y)                                                         00031110
            Z))                                                         00031120
       (GO B)                                                           00031130
    E    (SETQ Z (ADDSQ (CONS X 1) Z))                                  00031140
       (SETQ X NIL)                                                     00031150
       (GO A))))                                                        00031160
                                                                        00031170
))                                                                      00031180
                                                                        00031181
DEFINE ((                                                               00031182
                                                                        00031183
(EXSCAN (LAMBDA (U)                                                     00031184
   (COND ((ATOM U) U)                                                   00031185
         (T                                                             00031186
          (ADDF                                                         00031187
           (MULTF2                                                      00031188
            (COND                                                       00031189
             ((MEMBER (CAAAR U) EXPTL*)                                 00031190
              (MKSP (LIST (QUOTE EXPT) (CAAAR U) 1) (CDAAR U)))         00031191
             (T (CAAR U)))                                              00031192
            (EXSCAN (CDAR U)))                                          00031193
           (EXSCAN (CDR U)))))))                                        00031194
                                                                        00031195
(EXPTCHK (LAMBDA (U)                                                    00031196
   (PROG (V W X Y Y1 Z)                                                 00031197
         (SETQ V (EXSCAN (CAR U)))                                      00031198
         (SETQ W (CDR U))                                               00031199
         (SETQ X (CONS FACTORS* ORDN*))                                 00031200
         (SETQ FACTORS* NIL)                                            00031201
         (SETQ ORDN* 0)                                                 00031202
         (SETQ Y (CKRN W))                                              00031203
   A     (COND ((ATOM Y) (GO C)))                                       00031204
         (SETQ Y1 (CAAAR Y))                                            00031205
         (COND                                                          00031206
          ((AND (NOT (MEMBER Y1 EXPTL*)) (NOT (EQCAR Y1 (QUOTE EXPT)))) 00031207
           (GO B)))                                                     00031208
         (SETQ V                                                        00031209
               (MULTF2                                                  00031210
                (MKSP                                                   00031211
                 (COND                                                  00031212
                  ((MEMBER Y1 EXPTL*) (LIST (QUOTE EXPT) Y1 -1))        00031213
                  (T                                                    00031214
                   (LIST (QUOTE EXPT)                                   00031215
                         (CADR Y1)                                      00031216
                         (PREPSQ (SIMPMINUS (CDDR Y1))))))              00031217
                 (CDAAR Y))                                             00031218
                V))                                                     00031219
         (SETQ Z (CONS (CAAR Y) Z))                                     00031220
   B     (SETQ Y (CDAR Y))                                              00031221
         (GO A)                                                         00031222
   C     (SETQ FACTORS* (CAR X))                                        00031223
         (SETQ ORDN* (CDR X))                                           00031224
         (SETQ X 1)                                                     00031225
   D     (COND ((NULL Z) (GO E)))                                       00031226
         (SETQ X (LIST (CONS (CAR Z) X)))                               00031227
         (SETQ Z (CDR Z))                                               00031228
         (GO D)                                                         00031229
         (COND ((EQUAL V (CAR U)) (SETQ V (CAR U))))                    00031230
   E     (RETURN (CONS V (QUOTF W X))))))                               00031231
                                                                        00031232
))                                                                      00031233
                                                                        00031234
DEFINE ((                                                               00031235
                                                                        00031236
(SUBS31 (LAMBDA (U)                                                     00031237
   (COND ((ATOM U) (CONS U 1))                                          00031238
         (T                                                             00031239
        (ADDSQ                                                          00031250
         ((LAMBDA(X)                                                    00031260
           (COND ((NULL MCHFG*) (CONS (LIST (CAR U)) 1))                00031270
               ((AND MCHFG* (NOT (SETQ MCHFG* NIL)) *RESUBS)            00031280
                (SUBS2 X))                                              00031290
               (T X)))                                                  00031300
          (SUBS3T (CAR U) MATCH*))                                      00031310
         (SUBS31 (CDR U)))))))                                          00031320
                                                                        00031330
(SUBS3T (LAMBDA (U V)                                                   00031340
   (SUBS3T0 (SUBS3T1 U V))))                                            00031350
                                                                        00031360
(SUBS3T0 (LAMBDA (X)                                                    00031370
   (PROG (Y)                                                            00031380
       (COND ((OR (CAR X) (ATOM (CDR X))) (RETURN X)))                  00031390
       (SETQ Y (MULTSQ (SIMP (CAADR X)) (CADDR X)))                     00031400
       (COND                                                            00031410
        ((CDADR X)                                                      00031420
         (SETQ Y                                                        00031430
             (MULTSQ                                                    00031440
              (REVPR (SIMPTIMES (EXCHK (CDADR X) NIL)))                 00031450
              Y))))                                                     00031460
       (RETURN (CANCEL Y)))))                                           00031470
                                                                        00031480
(SUBS3T1 (LAMBDA (U V)                                                  00031490
   (PROG (X Y Z)                                                        00031500
       (SETQ X (MTCHK (CAR U) V))                                       00031510
       (COND                                                            00031520
        ((NULL X)                                                       00031530
         (RETURN (COND ((NULL MCHFG*) U) (T (CONS (LIST U) 1)))))       00031540
        ((AND (NULL (CAAR X))                                           00031550
            (SETQ MCHFG* T)                                             00031560
            (SETQ Y                                                     00031570
                  (LIST NIL                                             00031580
                      (CONS (CADDAR X) (CADR (CDDAR X)))                00031590
                      (SUBS32 (CDR U) MATCH*))))                        00031600
         (GO B))                                                        00031610
        ((AND (NOT (ATOM (CDR U))) (NULL (CDDR U))) (GO A)))            00031620
       (SETQ Y (SUBS32 (CDR U) X))                                      00031630
       (COND ((NULL MCHFG*) (RETURN (CONS (CAR U) Y))))                 00031640
    A0   (SETQ X (LIST (CONS (CAR U) 1)))                               00031650
       (SETQ Z (GCD1 X (CDR Y)))                                        00031660
       (RETURN                                                          00031670
        (COND ((NULL Z) (MULTS2 (CAR U) Y))                             00031680
            ((EQUAL X Z) (CONS (CAR Y) (QUOTF (CDR Y) X)))              00031690
            (T                                                          00031700
             (CONS (MULTF (QUOTF X Z) (CAR Y))                          00031710
                   (QUOTF (CDR Y) Z)))))                                00031720
    A    (SETQ Y (SUBS3T1 (CADR U) X))                                  00031730
         (COND ((AND (NULL (CAR Y)) (NOT (ATOM (CDR Y)))) (GO B))       00031740
             ((NULL MCHFG*) (RETURN (LIST (CAR U) Y)))                  00031750
             (T (GO A0)))                                               00031760
    B    (COND                                                          00031770
        ((AND (CDADR Y) (EQUAL (CADADR Y) (CAR U)))                     00031780
         (RETURN (LIST NIL (CONS (CAADR Y) (CDDADR Y)) (CADDR Y))))     00031790
        ((AND (NOT (ATOM (CAAR U)))                                     00031800
            (FLAGP** (CAAAR U) (QUOTE NONCOM))                          00031810
            (SETQ Y (SUBS3T0 Y)))                                       00031820
         (GO A0))                                                       00031830
        (T                                                              00031840
         (RETURN (LIST NIL (CADR Y) (MULTS2 (CAR U) (CADDR Y))))))))    00031850
)                                                                       00031860
                                                                        00031870
(MULTS2 (LAMBDA (U V)                                                   00031880
   (CONS (MULTF2 U (CAR V)) (CDR V))))                                  00031890
                                                                        00031900
(SUBS32 (LAMBDA (U V)                                                   00031910
   (PROG (B X Y)                                                        00031920
    A    (COND                                                          00031930
        ((ATOM U)                                                       00031940
         (RETURN                                                        00031950
          (COND (MCHFG*                                                 00031960
               (COND ((NULL X) (CONS U 1))                              00031970
                   (T (ADDSQ (CONS U 1) X))))                           00031980
              (T (APPEND X U))))))                                      00031990
       (SETQ Y (SUBS3T (CAR U) V))                                      00032000
       (COND ((NULL MCHFG*) (SETQ X (APPEND X (LIST Y))))               00032010
             (B (SETQ X (ADDSQ Y X)))                                   00032020
             ((SETQ B T) (SETQ X (ADDSQ (CONS X 1) Y))))                00032030
       (SETQ U (CDR U))                                                 00032040
       (GO A))))                                                        00032050
                                                                        00032060
(MKKL (LAMBDA (U V)                                                     00032070
   (COND ((NULL U) V) (T (MKKL (CDR U) (LIST (CONS (CAR U) V)))))))     00032080
                                                                        00032090
))                                                                      00032100
                                                                        00032110
DEFINE ((                                                               00032120
                                                                        00032130
(MTCHK (LAMBDA (U V1)                                                   00032140
   (PROG (V W X Y Z)                                                    00032150
    A0   (COND ((NULL V1) (RETURN Z)))                                  00032160
       (SETQ V (CAR V1))                                                00032170
       (SETQ W (CAR V))                                                 00032180
    A    (COND ((NULL W) (GO D))                                        00032190
             ((AND (EQUAL U (CAR W)) (SETQ Y (LIST NIL))) (GO B))       00032200
             ((NOT (ATOM (CAR U))) (GO A1))                             00032210
             ((NOT (ATOM (CAAR W))) (GO D))                             00032220
             ((OR FRLIS* (ORDP (CAR U) (CAAR W))) (GO A2))              00032230
             (T (GO E)))                                                00032231
    A1   (COND ((EQ (CAAR U) (CAAAR W)) (GO A2))                        00032232
             ((FLAGP** (CAAR U) (QUOTE NONCOM)) (GO C1))                00032234
             ((NULL (ORDP (CAAR U) (CAAAR W))) (GO E))                  00032240
             (T (GO D)))                                                00032250
    A2   (COND                                                          00032260
        ((OR (AND (NOT (MEMBER (CDAR W) FRLIS*))                        00032270
                 (OR (AND (CAADR V)                                     00032280
                        (NOT (EQUAL (CDR U) (CDAR W))))                 00032290
                   (LESSP (CDR U) (CDAR W))))                           00032300
             (NOT (SETQ Y (MCHK (CAR U) (CAAR W)))))                    00032310
         (GO C))                                                        00032320
        ((MEMBER (CDAR W) FRLIS*)                                       00032321
         (SETQ Y                                                        00032322
                (MAPCONS U (CONS (CDAR W) (CDR U))))))                  00032324
    B    (COND ((NULL Y) (GO C))                                        00032330
             ((AND (NULL                                                00032340
                  (CAR                                                  00032350
                   (SETQ X                                              00032360
                       (CONS (SUBLIS (CAR Y)                            00032370
                                 (DELETE (CAR W) (CAR V)))              00032380
                           (LIST (CADR V)                               00032390
                               (SUBLIS (CAR Y) (CADDR V))               00032400
                               (CONS                                    00032410
                                (SUBLIS (CAR Y) (CAR W))                00032420
                                (CADDDR V)))))))                        00032430
                 (*EVAL (SUBLIS (CAR Y) (CDADR V))))                    00032440
            (RETURN (LIST X))))                                         00032450
       (SETQ Z (CONS X Z))                                              00032460
       (SETQ Y (CDR Y))                                                 00032470
       (GO B)                                                           00032480
    C    (COND                                                          00032490
        ((AND (NOT (ATOM (CAR U)))                                      00032500
            (FLAGP** (CAAR U) (QUOTE NONCOM)))                          00032510
         (GO C1)))                                                      00032520
       (SETQ W (CDR W))                                                 00032530
       (GO A)                                                           00032540
    C1   (COND ((AND (CADDDR V) (NOT (NOCP (CADDDR V)))) (GO E)))       00032550
    D    (SETQ Z (APPEND Z (LIST V)))                                   00032580
    E    (SETQ V1 (CDR V1))                                             00032590
       (GO A0))))                                                       00032600
                                                                        00032710
(NOCP (LAMBDA (U)                                                       00032720
   (OR (NULL U)                                                         00032730
       (AND (OR (ATOM (CAAR U))                                         00032740
            (NOT (FLAGP** (CAAAR U) (QUOTE NONCOM))))                   00032750
          (NOCP (CDR U))))))                                            00032760
                                                                        00032770
(MCHK (LAMBDA (U V)                                                     00032780
   (COND ((EQUAL U V) (LIST NIL))                                       00032790
       ((OR (NULL U) (NULL V)) NIL)                                     00032800
       ((MEMBER V FRLIS*) (LIST (LIST (CONS V (EMTCH U)))))             00032810
       ((OR (ATOM U) (ATOM V)) NIL)                                     00032820
       ((EQ (CAR U) (CAR V)) (MCHARG (CDR U) (CDR V) (CAR U)))          00032830
       (T NIL))))                                                       00032840
                                                                        00032850
(MCHARG (LAMBDA (*S* V W)                                               00032860
   ((LAMBDA(X)                                                          00032870
     (COND                                                              00032880
      ((MTP V)                                                          00032890
       (COND                                                            00032900
      (X                                                                00032910
       (COND                                                            00032920
        ((FLAGP W (QUOTE SYMMETRIC))                                    00032930
         (MAPLIST (PERMUTATIONS V)                                      00032940
                (FUNCTION                                               00032950
                 (LAMBDA(J)                                             00032960
                  (PAIR (CAR J)                                         00032970
                      (MAPCAR *S* (FUNCTION EMTCH)))))))                00032980
        ((FLAGP W (QUOTE ANTISYMMETRIC))                                00032990
         (ERRACH (QUOTE (NOT YET))))                                    00033000
        (T (LIST (PAIR V (MAPCAR *S* (FUNCTION EMTCH)))))))             00033010
      ((AND (EQUAL (LENGTH V) 2) (FLAGP W (QUOTE NARY)))                00033020
       (MCHARG (CDR (MKBIN (CONS W *S*))) V W))                         00033030
      (T NIL)))                                                         00033040
      (X (MCHARG1 *S* V (FLAGP W (QUOTE SYMMETRIC)) (LIST NIL)))        00033050
      (T NIL)))                                                         00033060
    (EQUAL (LENGTH *S*) (LENGTH V)))))                                  00033070
                                                                        00033080
(MCHARG1 (LAMBDA (U V FLG W)                                            00033090
   (PROG (X Z)                                                          00033100
       (COND ((NULL U) (RETURN W))                                      00033110
             ((NULL FLG)                                                00033120
            (RETURN                                                     00033130
             (MCHARG3 U (CDR V) (MCHK (CAR U) (CAR V)) FLG W))))        00033140
       (SETQ X (MCHARG2 (CAR U) V))                                     00033150
    A    (COND ((NULL X) (RETURN Z)))                                   00033160
       (SETQ Z (APPEND (MCHARG3 U (CDAR X) (CAAR X) FLG W) Z))          00033170
       (SETQ X (CDR X))                                                 00033180
       (GO A))))                                                        00033190
                                                                        00033200
(MCHARG2 (LAMBDA (U V)                                                  00033210
   (PROG (X Y Z)                                                        00033220
    A    (COND ((NULL V) (RETURN (REVERSE Z)))                          00033230
             ((SETQ Y (MCHK U (CAR V)))                                 00033240
            (SETQ Z                                                     00033250
                  (CONS (CONS Y (APPEND (REVERSE X) (CDR V)))           00033260
                       Z))))                                            00033270
       (SETQ X (CONS (CAR V) X))                                        00033280
       (SETQ V (CDR V))                                                 00033290
       (GO A))))                                                        00033300
                                                                        00033310
(MCHARG3 (LAMBDA (U V *S* FLG W)                                        00033320
   (PROG (Z)                                                            00033330
    A    (COND ((NULL *S*) (RETURN Z)))                                 00033340
       (SETQ Z                                                          00033350
             (APPEND (MCHARG1 (CDR U)                                   00033360
                        (SUBLIS (CAR *S*) V)                            00033370
                         FLG                                            00033380
                        (MAPLIST W                                      00033390
                               (FUNCTION                                00033400
                                (LAMBDA(J)                              00033410
                                 (APPEND                                00033420
                                  (CAR *S*)                             00033430
                                  (CAR J))))))                          00033440
                    Z))                                                 00033450
       (SETQ *S* (CDR *S*))                                             00033460
       (GO A))))                                                        00033470
                                                                        00033480
(MKBIN (LAMBDA (U)                                                      00033490
   (COND ((OR (NULL (CDDR U)) (NULL (CDDDR U))) U)                      00033500
       (T (MKBIN1 (CAR U) (CDR U))))))                                  00033510
                                                                        00033520
(MKBIN1 (LAMBDA (U V)                                                   00033530
   (COND ((NULL (CDDR V)) (CONS U V))                                   00033540
       (T (LIST U (CAR V) (MKBIN1 U (CDR V)))))))                       00033550
                                                                        00033560
(MTP (LAMBDA (V)                                                        00033570
   (OR (NULL V)                                                         00033580
       (AND (MEMBER (CAR V) FRLIS*)                                     00033590
          (NOT (MEMBER (CAR V) (CDR V)))                                00033600
          (MTP (CDR V))))))                                             00033610
                                                                        00033620
(PERMUTATIONS (LAMBDA (*S*)                                             00033630
   (COND ((NULL *S*) (LIST NIL))                                        00033640
       ((NULL (CDR *S*)) (LIST *S*))                                    00033650
       (T                                                               00033660
        (MAPCON *S*                                                     00033670
              (FUNCTION                                                 00033680
               (LAMBDA(J)                                               00033690
                (MAPCONS                                                00033700
                 (PERMUTATIONS (DELETE (CAR J) *S*))                    00033710
                 (CAR J)))))))))                                        00033720
                                                                        00033730
))                                                                      00033740
                                                                        00033750
DEFINE ((                                                               00033760
                                                                        00033770
(EMTCH (LAMBDA (U)                                                      00033780
   (COND ((ATOM U) U)                                                   00033790
       (T ((LAMBDA (X) (COND (X X) (T U))) (OPMTCH U))))))              00033800
                                                                        00033810
(OPMTCH (LAMBDA (U)                                                     00033820
   (PROG (X Y)                                                          00033830
       (COND ((NULL SUBFG*) (RETURN NIL)))                              00033840
       (SETQ X (GET (CAR U) (QUOTE OPMTCH*)))                           00033850
    A    (COND ((NULL X) (RETURN NIL))                                  00033860
             ((AND (NULL (CAADAR X))                                    00033870
                 (SETQ Y (MCHARG (CDR U) (CAAR X) (CAR U)))             00033880
                 (*EVAL (SUBLIS (CAR Y) (CDADAR X))))                   00033890
            (GO B)))                                                    00033900
       (SETQ X (CDR X))                                                 00033910
       (GO A)                                                           00033920
    B    (RETURN (SUBLIS (CAR Y) (CADDAR X))))))                        00033930
                                                                        00033940
))                                                                      00033950
                                                                        00033960
DEFINE ((                                                               00033970
                                                                        00033980
(ORDER (LAMBDA (U)                                                      00033990
   (PROG NIL                                                            00034000
    A    (COND ((NULL U) (RETURN NIL))                                  00034010
             ((OR (NOT (ATOM (CAR U))) (NUMBERP (CAR U))) (GO B)))      00034020
       (PUT (CAR U) (QUOTE ORDER) ORDN*)                                00034030
       (SETQ ORDN* (ADD1 ORDN*))                                        00034040
    B    (SETQ U (CDR U))                                               00034050
       (GO A))))                                                        00034060
                                                                        00034070
(FORMOP (LAMBDA (U)                                                     00034080
   (COND ((ATOM U) U)                                                   00034090
       (T                                                               00034100
        (ADDOF (MULTOP (CAAR U) (FORMOP (CDAR U)))                      00034110
             (FORMOP (CDR U)))))))                                      00034120
                                                                        00034130
(ADDOF (LAMBDA (U V)                                                    00034140
   (COND ((NULL U) V)                                                   00034150
       ((NULL V) U)                                                     00034160
       ((ATOM U) (CONS (CAR V) (ADDOF U (CDR V))))                      00034170
       ((ATOM V) (ADDOF V U))                                           00034180
       ((EQUAL (CAAR U) (CAAR V))                                       00034190
        (CONS (CONS (CAAR U) (ADDOF (CDAR U) (CDAR V)))                 00034200
            (ADDOF (CDR U) (CDR V))))                                   00034210
       ((ORDOP (CAAR U) (CAAR V)) (CONS (CAR U) (ADDOF (CDR U) V)))     00034220
       (T (CONS (CAR V) (ADDOF U (CDR V)))))))                          00034230
                                                                        00034240
(MULTOP (LAMBDA (U V)                                                   00034250
   (COND ((EQ (CAR U) (QUOTE K*)) V) (T (MULTOP1 U V)))))               00034260
                                                                        00034270
(MULTOP1 (LAMBDA (U V)                                                  00034280
   (COND ((NULL V) NIL)                                                 00034290
       ((OR (ATOM V) (ORDOP U (CAAR V))) (LIST (CONS U V)))             00034300
       (T                                                               00034310
        (CONS (CONS (CAAR V) (MULTOP1 U (CDAR V)))                      00034320
            (MULTOP1 U (CDR V)))))))                                    00034330
                                                                        00034340
(ORDOP (LAMBDA (U V)                                                    00034350
   (COND ((NULL U) (NULL V))                                            00034360
       ((NULL V) NIL)                                                   00034370
       ((AND (MEMBER U FACTORS*) (NOT (MEMBER V FACTORS*))) T)          00034380
         ((AND (MEMBER V FACTORS*) (NOT (MEMBER U FACTORS*))) NIL)      00034390
       ((ATOM U)                                                        00034400
        (COND                                                           00034410
         ((ATOM V)                                                      00034420
          (COND ((NUMBERP U) (AND (NUMBERP V) (NOT (LESSP U V))))       00034430
              ((NUMBERP V) T)                                           00034440
                  ((ZEROP ORDN*) (ORDERP U V))                          00034445
              (T                                                        00034450
               ((LAMBDA(X Y)                                            00034460
                 (COND ((AND X Y) (LESSP X Y))                          00034470
                     (X T)                                              00034480
                     (Y NIL)                                            00034490
                     (T (ORDERP U V))))                                 00034500
                (GET U (QUOTE ORDER))                                   00034510
                (GET V (QUOTE ORDER))))))                               00034520
         ((MEMBER U FACTORS*) T)                                        00034530
         (T (NOT (MEMBER (CAR V) FACTORS*)))))                          00034540
       ((ATOM V) (MEMBER (CAR U) FACTORS*))                             00034550
       ((EQUAL (CAR U) (CAR V)) (ORDOP (CDR U) (CDR V)))                00034560
       (T (ORDOP (CAR U) (CAR V))))))                                   00034570
                                                                        00034580
(QUOTOF (LAMBDA (P Q)                                                   00034590
   (COND ((NULL P) NIL)                                                 00034600
       ((EQUAL P Q) 1)                                                  00034610
       ((EQUAL Q 1) P)                                                  00034620
       ((NUMB Q)                                                        00034630
        (COND                                                           00034640
         ((NUMB P)                                                      00034650
          (COND ((AND (ATOM P) (ATOM Q)) (MKFR P Q))                    00034660
              (T (ERRACH (LIST (QUOTE QUOTOF) P Q)))))                  00034670
         (T                                                             00034680
          (CONS (CONS (CAAR P) (QUOTOF (CDAR P) Q))                     00034690
              (QUOTOF (CDR P) Q)))))                                    00034700
       ((NUMB P)                                                        00034710
        (LIST                                                           00034720
         (CONS (CONS (CAAAR Q) (MINUS (CDAAR Q)))                       00034730
             (QUOTOF P (CDARX Q)))))                                    00034740
       (T                                                               00034750
        ((LAMBDA(X Y)                                                   00034760
          (COND                                                         00034770
           ((EQ (CAR X) (CAR Y))                                        00034780
            ((LAMBDA(N W Z)                                             00034790
            (COND ((ZEROP N) (ADDOF W Z))                               00034800
                  (T (CONS (CONS (CONS (CAR Y) N) W) Z))))              00034810
             (DIFFERENCE (CDR X) (CDR Y))                               00034820
             (QUOTOF (CDAR P) (CDARX Q))                                00034830
             (QUOTOF (CDR P) Q)))                                       00034840
           ((ORDOP X Y)                                                 00034850
            (CONS (CONS X (QUOTOF (CDAR P) Q)) (QUOTOF (CDR P) Q)))     00034860
           (T                                                           00034870
            (LIST                                                       00034880
             (CONS (CONS (CAR Y) (MINUS (CDR Y)))                       00034890
                 (QUOTOF P (CDARX Q)))))))                              00034900
         (CAAR P)                                                       00034910
         (CAAR Q))))))                                                  00034920
                                                                        00034930
))                                                                      00034940
                                                                        00034950
DEFINE ((                                                               00034960
                                                                        00034970
(CKRN (LAMBDA (U)                                                       00034980
   (PROG (X)                                                            00034990
       (COND ((KERNLOP U) (RETURN U)))                                  00035000
    A    (SETQ X (CONS (CKRN (CDAR U)) X))                              00035010
       (COND                                                            00035020
        ((NULL (CDR U)) (RETURN (LIST (CONS (CAAR U) (GCK X)))))        00035030
        ((OR (ATOM (CDR U)) (NOT (EQ (CAAAR U) (CAAADR U))))            00035040
         (RETURN (GCK (CONS (CKRN (CDR U)) X)))))                       00035050
       (SETQ U (CDR U))                                                 00035060
       (GO A))))                                                        00035070
                                                                        00035080
(GCK (LAMBDA (U)                                                        00035090
   (COND ((NULL U) 1)                                                   00035100
       ((NULL (CDR U)) (CAR U))                                         00035110
       (T (GCK (CONS (GCK1 (CAR U) (CADR U)) (CDDR U)))))))             00035120
                                                                        00035130
(GCK1 (LAMBDA (U V)                                                     00035140
   (COND ((OR (NULL U) (NULL V)) (ERRACH (QUOTE GCK1)))                 00035150
       ((EQUAL U V) U)                                                  00035160
       ((NUMB U)                                                        00035170
        (COND                                                           00035180
         ((NUMB V)                                                      00035190
          (COND ((AND (ATOM U) (ATOM V)) (GCDN U V)) (T 1)))            00035200
         (T (GCK1 U (CDARX V)))))                                       00035210
       ((NUMB V) (GCK1 (CDARX U) V))                                    00035220
       (T                                                               00035230
        ((LAMBDA(X Y)                                                   00035240
          (COND                                                         00035250
           ((EQ (CAR X) (CAR Y))                                        00035260
            (LIST                                                       00035270
             (CONS                                                      00035280
            (COND ((GREATERP (CDR X) (CDR Y)) Y) (T X))                 00035290
            (GCK1 (CDARX U) (CDARX V)))))                               00035300
             ((ORDOP X Y) (GCK1 (CDARX U) V))                           00035310
           (T (GCK1 U (CDARX V)))))                                     00035320
         (CAAR U)                                                       00035330
         (CAAR V))))))                                                  00035340
                                                                        00035350
))                                                                      00035360
                                                                        00035370
DEFINE ((                                                               00035380
                                                                        00035390
(PREPSQ (LAMBDA (U)                                                     00035400
   (COND ((NULL (CAR U)) 0)                                             00035410
       (T                                                               00035420
        ((LAMBDA(X)                                                     00035430
          (COND                                                         00035440
           ((OR *RAT (AND (NOT *FLOAT) *DIV) UPL* DNL*)                 00035450
            (REPLUS (PREPSQ1 (CAR X) NIL (CDR X))))                     00035460
           (T                                                           00035470
            (SQFORM X                                                   00035480
                  (FUNCTION                                             00035490
                   (LAMBDA (J) (REPLUS (PREPSQ1 J NIL 1))))))))         00035500
         (CONS (FORMOP (CAR U)) (FORMOP (CDR U))))))))                  00035510
                                                                        00035520
(SQFORM (LAMBDA (U *PI*)                                                00035530
   ((LAMBDA(X Y)                                                        00035540
     (COND ((EQUAL Y 1) X) (T (LIST (QUOTE QUOTIENT) X Y))))            00035550
    (*PI* (CAR U))                                                      00035560
    (*PI* (CDR U)))))                                                   00035570
                                                                        00035580
(PREPSQ1 (LAMBDA (U V W)                                                00035590
   (PROG (X Y Z)                                                        00035600
       (COND ((NULL U) (RETURN NIL))                                    00035610
             ((AND (NOT (ATOM U))                                       00035620
                 (OR (MEMBER (CAAAR U) FACTORS*)                        00035630
                   (AND (NOT (ATOM (CAAAR U)))                          00035640
                        (MEMBER (CAAAAR U) FACTORS*))))                 00035650
            (RETURN                                                     00035660
             (NCONC (PREPSQ1 (CDAR U) (CONS (CAAR U) V) W)              00035670
                  (PREPSQ1 (CDR U) V W))))                              00035680
             ((NULL (KERNLP U)) (GO A)))                                00035690
       (SETQ U (MKKL V U))                                              00035700
       (SETQ V NIL)                                                     00035710
    A    (SETQ X (CKRN U))                                              00035720
       (COND ((NULL DNL*) (GO A1)))                                     00035730
       (SETQ Z (CKRN* X DNL*))                                          00035740
       (SETQ X (QUOTOF X Z))                                            00035750
       (SETQ U (QUOTF U Z))                                             00035760
       (SETQ W (QUOTOF W Z))                                            00035770
    A1   (SETQ Y (CKRN W))                                              00035780
       (COND ((NULL UPL*) (GO A2)))                                     00035790
       (SETQ Z (CKRN* Y UPL*))                                          00035800
       (SETQ Y (QUOTOF Y Z))                                            00035810
       (SETQ U (QUOTOF U Z))                                            00035820
       (SETQ W (QUOTOF W Z))                                            00035830
    A2   (COND ((AND (NULL *DIV) (NULL *FLOAT)) (SETQ Y (GCK1 X Y))))   00035840
       (SETQ U (MKCANON (CONS (QUOTOF U Y) (QUOTOF W Y))))              00035850
       (COND ((AND *GCD (ZEROP ORDN*)) (SETQ U (CANCEL U))))            00035852
       (SETQ X (QUOTOF X Y))                                            00035860
       (COND                                                            00035870
        ((AND *ALLFAC (NULL *DIV) (NOT (EQUAL X (CAR U)))) (GO B))      00035880
        ((NULL V) (GO D)))                                              00035890
       (SETQ V (EXCHK V NIL))                                           00035900
       (GO C)                                                           00035910
    D    (SETQ U (PREPSQ2 U))                                           00035920
       (RETURN                                                          00035930
        (COND ((EQCAR U (QUOTE PLUS)) (CDR U)) (T (LIST U))))           00035940
    B    (COND ((AND (EQUAL X 1) (NULL V)) (GO D)))                     00035950
       (SETQ U (CONS (QUOTOF (CAR U) X) (CDR U)))                       00035960
       (SETQ V (PREPF (MKKL V X)))                                      00035970
       (COND ((EQUAL U (CONS 1 1)) (RETURN V))                          00035980
             ((EQCAR V (QUOTE TIMES)) (SETQ V (CDR V)))                 00035990
             (T (SETQ V (LIST V))))                                     00036000
    C    (RETURN (LIST (RETIMES (ACONC V (PREPSQ2 U))))))))             00036010
                                                                        00036020
(CKRN* (LAMBDA (U V)                                                    00036030
   (COND ((NULL U) (ERRACH (QUOTE CKRN*)))                              00036040
       ((ATOM U) 1)                                                     00036050
       ((MEMBER (CAAAR U) V)                                            00036060
        (LIST (CONS (CAAR U) (CKRN* (CDARX U) V))))                     00036070
       (T (CKRN* (CDARX U) V)))))                                       00036080
                                                                        00036090
(UP (LAMBDA (U)                                                         00036100
   (FACTOR1 U T (QUOTE UPL*))))                                         00036110
                                                                        00036120
(DOWN (LAMBDA (U)                                                       00036130
   (FACTOR1 U T (QUOTE DNL*))))                                         00036140
                                                                        00036150
))                                                                      00036160
                                                                        00036170
DEFLIST (((UP RLIS) (DOWN RLIS)) STAT)                                  00036180
                                                                        00036190
DEFINE ((                                                               00036200
                                                                        00036210
(REPLUS (LAMBDA (U)                                                     00036220
   (COND ((ATOM U) U)                                                   00036230
       ((NULL (CDR U)) (CAR U))                                         00036240
       (T (CONS (QUOTE PLUS) U)))))                                     00036250
                                                                        00036260
(RETIMES (LAMBDA (U)                                                    00036270
   (PROG (X Y)                                                          00036275
    A    (COND ((NULL U) (GO D))                                        00036280
               ((NOT (EQCAR (CAR U) (QUOTE MINUS))) (GO B)))            00036285
         (SETQ X (NOT X))                                               00036290
         (COND ((EQUAL (CADAR U) 1) (GO C))                             00036295
               (T (SETQ U (CONS (CADAR U) (CDR U)))))                   00036300
    B    (SETQ Y (CONS (CAR U) Y))                                      00036305
    C    (SETQ U (CDR U))                                               00036310
         (GO A)                                                         00036315
    D    (SETQ Y (COND ((NULL Y) 1)                                     00036320
                       ((CDR Y) (CONS (QUOTE TIMES) (REVERSE Y)))       00036325
                       (T (CAR Y))))                                    00036330
         (RETURN (COND (X (LIST (QUOTE MINUS) Y)) (T Y))))))            00036335
                                                                        00036350
(PREPSQ2 (LAMBDA (U)                                                    00036360
   (SQFORM U (FUNCTION PREPF))))                                        00036370
                                                                        00036380
(PREPF (LAMBDA (U)                                                      00036390
   (PROG (X)                                                            00036395
         (COND ((AND (MINUSF U) (SETQ X T)) (SETQ U (MULTN -1 U))))     00036400
         (SETQ U (REPLUS (PREPF1 U NIL)))                               00036405
         (RETURN (COND (X (LIST (QUOTE MINUS) U)) (T U))))))            00036410
                                                                        00036415
(PREPF1 (LAMBDA (U V)                                                   00036420
   (COND ((NULL U) NIL)                                                 00036430
       ((NUMB U)                                                        00036440
        (LIST (RETIMES (NUMCONS (MINUSCHK U) (EXCHK V NIL)))))          00036450
       (T                                                               00036460
        (NCONC (PREPF1 (CDAR U) (CONS (CAAR U) V))                      00036470
             (PREPF1 (CDR U) V))))))                                    00036480
                                                                        00036490
(NUMB (LAMBDA (U)                                                       00036500
   (OR (NUMBERP U) (EQCAR U (QUOTE QUOTIENT)))))                        00036510
                                                                        00036520
(NUMCONS (LAMBDA (N V)                                                  00036530
   (COND ((NULL V) (LIST N)) ((EQUAL N 1) V) (T (CONS N V)))))          00036540
                                                                        00036550
(KERNLOP (LAMBDA (U)                                                    00036560
   (OR (NUMB U) (AND (NULL (CDR U)) (KERNLOP (CDAR U))))))              00036570
                                                                        00036580
(EXCHK (LAMBDA (U V)                                                    00036590
   (COND ((NULL U) V)                                                   00036600
       ((ONEP (CDAR U)) (EXCHK (CDR U) (CONS (SQCHK (CAAR U)) V)))      00036610
       (T                                                               00036620
        (EXCHK (CDR U)                                                  00036630
             (CONS (LIST (QUOTE EXPT) (SQCHK (CAAR U)) (CDAR U))        00036640
                    V))))))                                             00036650
                                                                        00036660
(SQCHK (LAMBDA (U)                                                      00036670
   (COND ((ATOM U) ((LAMBDA (X)                                         00036675
             (COND (X X) (T U))) (GET U (QUOTE NEWNAME))))              00036680
         ((EQ (CAR U) (QUOTE *SQ)) (PREPSQ (CADR U)))                   00036685
         ((AND (EQ (CAR U) (QUOTE EXPT)) (EQUAL (CADDR U) 1))           00036690
                (CADR U))                                               00036695
       ((ATOM (CAR U)) U)                                               00036700
       (T (PREPF U)))))                                                 00036710
                                                                        00036720
(MINUSCHK (LAMBDA (U)                                                   00036730
   (COND                                                                00036740
    ((ATOM U)                                                           00036750
     (COND ((MINUSP U) (LIST (QUOTE MINUS) (MINUS U))) (T U)))          00036760
    ((MINUSP (CADR U))                                                  00036770
     (LIST (QUOTE MINUS)                                                00036780
         (LIST (QUOTE QUOTIENT) (MINUS (CADR U)) (CADDR U))))           00036790
    (T U))))                                                            00036800
                                                                        00036810
(MKFR (LAMBDA (U V)                                                     00036820
   (COND (*FLOAT (QUOTIENT (PLUS 0.0 U) V))                             00036830
       (T                                                               00036840
        ((LAMBDA(M)                                                     00036850
          ((LAMBDA(N1 N2)                                               00036860
            (COND ((ONEP N2) N1)                                        00036870
                (T (LIST (QUOTE QUOTIENT) N1 N2))))                     00036880
           (QUOTIENT U M)                                               00036890
           (QUOTIENT V M)))                                             00036900
            (GCDN U V))))))                                             00036910
                                                                        00036920
))                                                                      00036930
                                                                        00036940
DEFLIST (((*SQ SQPRINT)) SPECPRN)                                       00036950
                                                                        00036960
DEFINE ((                                                               00036970
                                                                        00036980
(SQPRINT (LAMBDA (U)                                                    00036990
   (PROG (Z)                                                            00037000
       (SETQ Z ORIG*)                                                   00037010
       (COND ((LESSP POSN* 20) (SETQ ORIG* POSN*)))                     00037020
       (MAPRIN                                                          00037030
        (SETQ *OUTP                                                     00037040
            (COND ((NULL (CAAR U)) 0) (T (PREPSQ (CAR U))))))           00037050
       (SETQ ORIG* Z))))                                                00037060
                                                                        00037070
(VARPRI (LAMBDA (U V W)                                                 00037080
   (PROG NIL                                                            00037090
       (COND ((NULL V) (RETURN NIL))                                    00037100
             (*FORT (GO D))                                             00037110
             ((AND (EQUAL V 0) U *NERO) (GO C)))                        00037120
       (COND ((NULL W) (TERPRI*)))                                      00037130
       (COND ((EQCAR V (QUOTE MAT)) (GO M)) ((NULL U) (GO A)))          00037140
       (INPRINT (QUOTE SETQ) (GET (QUOTE SETQ) (QUOTE INFIX)) U)        00037150
       (OPRIN (QUOTE SETQ))                                             00037160
    A    (MAPRIN V)                                                     00037170
       (COND (W (GO C))                                                 00037180
             ((AND (NULL *NAT) (NULL *FORT)) (PRINC* **DOLLAR)))        00037190
    C    (RETURN V)                                                     00037210
    D    (SETQ COUNT* 1)                                                00037220
         (COND ((AND (ATOM V) (NOT (NUMBERP V))) (GO A)))               00037221
       (SETQ FORTVAR* (QUOTE ANS))                                      00037230
       (COND ((OR (NULL U) (NOT (ATOM (CAR U)))) (GO E)))               00037240
       (SETQ FORTVAR* (CAR U))                                          00037250
E        (COND ((GREATERP POSN* 5) (GO A)))                             00037260
         (SPACES 6)                                                     00037265
       (PRINC FORTVAR*)                                                 00037270
       (OPRIN (QUOTE EQUAL))                                            00037280
         (SETQ POSN* (PLUS 7 (LENGTH (EXPLODE FORTVAR*))))              00037281
       (GO A)                                                           00037290
    M    (MATPRI (CDR V) (COND (U (CAR U)) (T NIL)))                    00037300
       (GO C))))                                                        00037310
                                                                        00037320
))                                                                      00037330
                                                                        00037340
DEFINE ((                                                               00037350
                                                                        00037360
(SIMPDF (LAMBDA (U)                                                     00037370
   (PROG (V X Y N)                                                      00037380
       (COND ((NULL SUBFG*) (RETURN (MKSQ (CONS (QUOTE DF) U) 1))))     00037390
       (SETQ V (CDR U))                                                 00037400
       (SETQ U (SIMPCAR U))                                             00037410
    A    (COND ((OR (NULL V) (NULL (CAR U))) (RETURN U)))               00037420
       (SETQ X (COND ((NULL Y) (SIMP (CAR V))) (T Y)))                  00037430
       (SETQ Y NIL)                                                     00037440
       (COND                                                            00037450
        ((OR (NULL (KERNP X)) (NOT (ONEP (CDAAAR X)))) (GO E))          00037460
        ((OR (NULL (CDR V))                                             00037470
             (NOT                                                       00037480
            (NUMBERP                                                    00037490
             (SETQ N (PREPSQ (SETQ Y (SIMP (CADR V))))))))              00037500
         (GO C1)))                                                      00037510
       (SETQ Y NIL)                                                     00037520
       (SETQ V (CDR V))                                                 00037530
       (SETQ X (CAAAAR X))                                              00037540
    C    (COND ((ZEROP N) (GO D)))                                      00037550
       (SETQ U (DIFF1 U X))                                             00037560
       (SETQ N (SUB1 N))                                                00037570
       (GO C)                                                           00037580
    C1   (SETQ U (DIFF1 U (CAAAAR X)))                                  00037590
    D    (SETQ V (CDR V))                                               00037600
       (GO A)                                                           00037610
    E    (MESPRI (QUOTE (DIFFERENTIATION WITH RESPECT TO))              00037620
             (CAR V)                                                    00037630
             (QUOTE (NOT ALLOWED))                                      00037640
              NIL                                                       00037650
              T)                                                        00037660
       (ERROR*))))                                                      00037670
                                                                        00037680
(DIFF1 (LAMBDA (U V)                                                    00037690
   (PROG (W X Y Z Z1)                                                   00037700
       (COND                                                            00037710
        ((KERNP (CONS (CDR U) 1)) (SETQ W (CONS (CAAADR U) 1))))        00037720
       (SETQ X (DIFF2 (CAR U) V))                                       00037730
       (SETQ Y                                                          00037740
             (COND ((NULL W) (DIFF2 (CDR U) V))                         00037750
                 (T (DIFFK (LIST (CONS W 1)) V))))                      00037760
       (SETQ Z                                                          00037770
             (COND ((NULL (CAR X)) (CONS NIL 1))                        00037780
                 (T (CONS (CAR X) (MULTF (CDR X) (CDR U))))))           00037790
       (COND ((NULL (CAR Y)) (RETURN Z)))                               00037800
       (SETQ Z1                                                         00037810
             (NEGSQ                                                     00037820
            (MULTSQ Y                                                   00037830
                  (COND ((NULL W)                                       00037840
                         (CONS (CAR U) (NMULTF (CDR U) 2)))             00037850
                        (T                                              00037860
                         (CONS (MULTN (CDAADR U) (CAR U))               00037870
                             (MULTF2 W (CDR U))))))))                   00037880
       (RETURN                                                          00037890
        (COND                                                           00037900
         ((AND *EXP *MCD)                                               00037910
          (CANCEL                                                       00037920
           (CONS (ADDF (MULTF (CAR X)                                   00037930
                        (COND                                           00037940
                         ((NULL W) (MULTF (CDR U) (CDR Y)))             00037950
                         (T (MULTF2 W (CDR Y)))))                       00037960
                   (MULTF (CDR X) (CAR Z1)))                            00037970
               (MULTF (CDR X) (CDR Z1)))))                              00037980
         (T (ADDSQ Z Z1)))))))                                          00037990
                                                                        00038000
(DIFF2 (LAMBDA (U V)                                                    00038010
   (COND ((ATOM U) (CONS NIL 1))                                        00038020
       (T                                                               00038030
        (ADDSQ (DIFF2 (CDR U) V)                                        00038040
             (ADDSQ (MULTS2 (CAAR U) (DIFF2 (CDAR U) V))                00038050
                  (DIFFK U V)))))))                                     00038060
                                                                        00038070
(DIFFK (LAMBDA (U *S*)                                                  00038080
   (PROG (V W X Y Z)                                                    00038090
       (SETQ X (CAAR U))                                                00038100
       (COND                                                            00038110
        ((AND (EQ (CAR X) *S*) (SETQ X (CONS 1 1))) (GO D))             00038120
        ((OR (ATOM (CAR X))                                             00038130
             (AND (ATOM (CAAR X)) (GET (CAAR X) (QUOTE **ARRAY))))      00038140
   (RETURN (COND ((AND (SETQ Z (FKERN (CAR X)))                         00038150
                        (ASSOC (QUOTE REP) (CDDR Z)))                   00038151
                  (MKSQ (LIST (QUOTE DF) (CAR X) *S*) 1))               00038152
                 (T (CONS NIL 1))))))                                   00038153
       (SETQ Y (FKERN (CAR X)))                                         00038160
       (COND                                                            00038170
        ((AND (SETQ V (ASSOC (QUOTE DFN) (CDDR Y)))                     00038180
            (SETQ V (ASSOC *S* (CADR V)))                               00038190
            (SETQ X (CDR V)))                                           00038200
         (GO D))                                                        00038210
        ((OR (AND (NOT (ATOM (CAAR X)))                                 00038220
                (SETQ X (NMULTSQ (DIFF2 (CAR X) *S*) (CDR X))))         00038230
             (AND (EQ (CAAR X) (QUOTE *SQ))                             00038240
                (SETQ X (DIFF1 (CADAR X) *S*))))                        00038250
         (GO B))                                                        00038260
        ((OR (NOT (SETQ V (GET* (CAAR X) (QUOTE DFN))))                 00038270
             (NOT                                                       00038280
            (DFP (SETQ W                                                00038290
                     (MAPCAR (CDAR X)                                   00038300
                           (FUNCTION                                    00038310
                            (LAMBDA(J)                                  00038320
                             (DIFF1 (SIMP J) *S*)))))                   00038330
                  V)))                                                  00038340
         (GO H)))                                                       00038350
       (SETQ Z (CDAR X))                                                00038360
       (SETQ X (CONS NIL 1))                                            00038370
       (COND                                                            00038380
        ((NULL                                                          00038390
          (*EVAL                                                        00038400
           (CONS (QUOTE OR)                                             00038410
               (MAPCAR W                                                00038420
                     (FUNCTION                                          00038430
                      (LAMBDA(J)                                        00038440
                       (LIST (QUOTE QUOTE) (CAR J))))))))               00038450
         (GO B)))                                                       00038460
    A    (COND ((NULL W) (GO B))                                        00038470
             ((CAAR W)                                                  00038480
            (SETQ X                                                     00038490
                  (ADDSQ (MULTSQ (CAR W)                                00038500
                             (SIMP                                      00038510
                              (SUBLIS                                   00038520
                               (PAIR (CAAR V) Z)                        00038530
                               (CDAR V))))                              00038540
                        X))))                                           00038550
       (SETQ W (CDR W))                                                 00038560
       (SETQ V (CDR V))                                                 00038570
       (GO A)                                                           00038580
    B    (COND                                                          00038590
        ((SETQ V (ASSOC (QUOTE DFN) (CDDR Y))) (GO C))                  00038600
        (T (ACONC Y (SETQ V (LIST (QUOTE DFN) NIL)))))                  00038610
       (SETQ DSUBL* (CONS (CDR V) DSUBL*))                              00038620
    C    (RPLACA (CDR V) (XADD (CONS *S* X) (CADR V) NIL T))            00038630
       (COND ((NULL (CAR X)) (RETURN X)))                               00038640
    D    (SETQ U (CAR U))                                               00038650
       (SETQ W                                                          00038660
             (COND ((ONEP (CDAR U)) (CDR U))                            00038670
                 (T                                                     00038680
                  (MULTF2 (GETPOWER (COND (Y Y)                         00038690
                                    (T (FKERN (CAAR U))))               00038700
                              (SUB1 (CDAR U)))                          00038710
                        (MULTN (CDAR U) (CDR U))))))                    00038720
       (RETURN (CONS (MULTF (CAR X) W) (CDR X)))                        00038730
    H    (SETQ V                                                        00038740
             (COND                                                      00038750
            ((EQ (CAAR X) (QUOTE DF))                                   00038760
                 (CONS (CAAR X) (CONS (CADAR X)                         00038765
                          (ORDAD *S* (CDDAR X)))))                      00038770
            (T (LIST (QUOTE DF) (CAR X) *S*))))                         00038780
       (SETQ X                                                          00038790
             (COND ((SETQ W (OPMTCH V)) (SIMP W)) (T (MKSQ V 1))))      00038800
       (GO B))))                                                        00038810
                                                                        00038820
(DFP (LAMBDA (U V)                                                      00038830
   (COND ((NULL U) (NULL V))                                            00038840
       ((NULL V) NIL)                                                   00038850
       ((CAAR U) (AND (CAR V) (DFP (CDR U) (CDR V))))                   00038860
       (T (DFP (CDR U) (CDR V))))))                                     00038870
                                                                        00038880
))                                                                      00038890
                                                                        00038900
DEFINE ((                                                               00038910
                                                                        00038920
(GCDN (LAMBDA (P Q)                                                     00038930
   (GCDN0 (ABS P) (ABS Q))))                                            00038940
                                                                        00038950
(GCDN0 (LAMBDA (P Q)                                                    00038960
   (COND ((EQUAL P Q) P)                                                00038970
       (*FLOAT (COND ((GREATERP P Q) Q) (T P)))                         00038980
       ((GREATERP Q P) (GCDN1 Q P))                                     00038990
       (T (GCDN1 P Q)))))                                               00039000
                                                                        00039010
(GCDN1 (LAMBDA (P Q)                                                    00039020
   ((LAMBDA (X) (COND ((ZEROP X) Q) (T (GCDN1 Q X))))                   00039030
    (REMAINDER P Q))))                                                  00039040
                                                                        00039050
))                                                                      00039060
                                                                        00039070
DEFINE ((                                                               00039080
                                                                        00039090
(QUOTF (LAMBDA (P Q)                                                    00039100
   (COND ((NULL P) NIL)                                                 00039110
       ((EQUAL P Q) 1)                                                  00039120
       ((EQUAL Q 1) P)                                                  00039130
       ((ATOM Q)                                                        00039140
        (COND                                                           00039150
         ((ATOM P)                                                      00039160
            (COND (*FLOAT (TIMES P (RECIP (PLUS 0.0 Q))))               00039165
                (T ((LAMBDA (Z)                                         00039170
            (COND ((ZEROP (CDR Z)) (CAR Z))                             00039180
                (T NIL)))                                               00039200
             (DIVIDE P Q)))))                                           00039210
         (T (QUOTK (CAAR P) P Q))))                                     00039220
       ((ATOM P) NIL)                                                   00039230
       (T                                                               00039240
        ((LAMBDA(X Y)                                                   00039250
          (COND                                                         00039260
           ((EQ (CAR X) (CAR Y))                                        00039270
            ((LAMBDA(N)                                                 00039280
            (COND                                                       00039290
             ((NOT (MINUSP N))                                          00039300
              ((LAMBDA(W)                                               00039310
                (COND                                                   00039320
                 (W                                                     00039330
                  ((LAMBDA(V Y)                                         00039340
                  (COND ((NULL Y) V)                                    00039350
                        (T                                              00039360
                         ((LAMBDA(Z)                                    00039370
                         (COND (Z (APPEND V Z)) (T NIL)))               00039380
                        (QUOTF Y Q)))))                                 00039390
                   (COND ((ZEROP N) W)                                  00039400
                       (T (LIST (CONS (MKSP (CAR X) N) W))))            00039410
                   (ADDF P                                              00039420
                       (MULTF                                           00039430
                        (COND ((ZEROP N) Q)                             00039440
                            (T (MULTF2 (MKSP (CAR X) N) Q)))            00039450
                        (MULTN -1 W)))))                                00039460
                 (T NIL)))                                              00039470
               (QUOTF (CDAR P) (CDAR Q))))                              00039480
             (T NIL)))                                                  00039490
             (DIFFERENCE (CDR X) (CDR Y))))                             00039500
           ((ORDP X Y) (QUOTK X P Q))                                   00039510
           (T NIL)))                                                    00039520
         (CAAR P)                                                       00039530
         (CAAR Q))))))                                                  00039540
                                                                        00039550
(QUOTK (LAMBDA (X P Q)                                                  00039560
   ((LAMBDA(W)                                                          00039570
     (COND (W                                                           00039580
          (COND ((NULL (CDR P)) (LIST (CONS X W)))                      00039590
              (T                                                        00039600
               ((LAMBDA(Y)                                              00039610
                 (COND (Y (CONS (CONS X W) Y)) (T NIL)))                00039620
                (QUOTF (CDR P) Q)))))                                   00039630
         (T NIL)))                                                      00039640
    (QUOTF (CDAR P) Q))))                                               00039650
                                                                        00039660
))                                                                      00039670
                                                                        00039680
DEFINE ((                                                               00039690
                                                                        00039700
(ABSONE (LAMBDA (U)                                                     00039710
   (AND (NUMBERP U) (ONEP (ABS U)))))                                   00039720
                                                                        00039730
(CDARX (LAMBDA (U)                                                      00039740
   (COND ((NULL (CDR U)) (CDAR U))                                      00039750
       (T (ERRACH (LIST (QUOTE CDARX) U))))))                           00039760
                                                                        00039770
))                                                                      00039780
                                                                        00039790
DEFINE ((                                                               00039800
                                                                        00039810
(PRMCON (LAMBDA (P)                                                     00039820
   (PROG (X Y Q)                                                        00039830
       (SETQ Q P)                                                       00039840
       (COND ((ATOM P) (ERRACH (LIST (QUOTE PRMCON) P)))                00039850
             ((AND (NULL (CDR P)) (SETQ X (CAR P))) (GO B)))            00039860
       (SETQ Y (CAAAR P))                                               00039870
    A    (COND                                                          00039880
        ((OR (AND (OR (ATOM Q) (NOT (EQ (CAAAR Q) Y)))                  00039890
                (SETQ X (CONS 1 (GCD (REVERSE (CONS Q X))))))           00039900
             (AND (NULL (CDR Q))                                        00039910
                (SETQ X                                                 00039920
                    (CONS (CAAR Q) (GCD (CONS (CDAR Q) X))))))          00039930
         (GO B)))                                                       00039940
       (SETQ X (CONS (CDAR Q) X))                                       00039950
       (SETQ Q (CDR Q))                                                 00039960
       (GO A)                                                           00039970
    B    (RETURN                                                        00039980
        (CONS (QUOTF P                                                  00039990
                   (COND ((ATOM (CAR X)) (CDR X)) (T (LIST X))))        00040000
             X)))))                                                     00040010
                                                                        00040020
(GCD (LAMBDA (L)                                                        00040030
   (COND ((NULL (CDR L)) (CAR L))                                       00040040
       ((MEMBER 1 L) 1)                                                 00040050
       (T (GCD (CONS (GCD1 (CAR L) (CADR L)) (CDDR L)))))))             00040060
                                                                        00040070
(GCD1 (LAMBDA (U V)                                                     00040080
   (COND                                                                00040090
    ((OR (NULL U) (NULL V)) (ERRACH (LIST (QUOTE GCD1) U V)))           00040100
    ((EQUAL U V) U)                                                     00040110
    ((ATOM U)                                                           00040120
     (COND ((ATOM V) (GCDN U V))                                        00040130
         (T (GCD (NCONS (CDR V) (LIST U (CDAR V)))))))                  00040140
    ((ATOM V) (GCD (NCONS (CDR U) (LIST V (CDAR U)))))                  00040150
    (T                                                                  00040160
     ((LAMBDA(X Y)                                                      00040170
       (COND ((EQ X Y)                                                  00040180
            (PROG (N W X1 Y1 Z Z1 Z2 Z3)                                00040190
                (SETQ X1 (PRMCON U))                                    00040200
                (SETQ Y1 (PRMCON V))                                    00040210
                (SETQ W 1)                                              00040220
                (SETQ Z1 (CAR X1))                                      00040230
                (SETQ Z2 (CAR Y1))                                      00040240
                (COND                                                   00040250
                 ((OR (NULL *GCD) (ABSONE Z1) (ABSONE Z2))              00040260
                  (GO A))                                               00040270
                 ((OR (ATOM Z1) (ATOM Z2))                              00040280
                  (ERRACH (LIST (QUOTE GCDK) U V X1 Y1)))               00040290
                 ((EQ (CAAAR Z1) (CAAAR Z2)) (GO C)))                   00040300
              A    (SETQ W (MULTF W (GCD1 (CDDR X1) (CDDR Y1))))        00040310
                (RETURN                                                 00040320
                 (COND                                                  00040330
                  ((OR (ATOM (CADR X1)) (ATOM (CADR Y1))) W)            00040340
                  ((ORDP (CADR X1) (CADR Y1))                           00040350
                   (MULTF2 (CADR Y1) W))                                00040360
                  (T (MULTF2 (CADR X1) W))))                            00040370
              C    (COND ((ORDP Z1 Z2) (GO D)))                         00040380
                (SETQ Z Z1)                                             00040390
              D1   (SETQ Z1 Z2)                                         00040400
                (SETQ Z2 Z)                                             00040410
              D    (SETQ Z (REMK Z1 Z2))                                00040420
                (COND (Z (GO G)))                                       00040430
                (SETQ W (CAR (PRMCON Z2)))                              00040440
                (GO A)                                                  00040450
              G    (COND ((NULL N) (GO H)))                             00040460
                (SETQ Z (QUOTF Z (NMULTF Z3 N)))                        00040470
                (COND                                                   00040480
                 ((NULL Z)                                              00040490
                  (REDERR                                               00040500
                   (LIST (QUOTE (INTEGER OVERFLOW)) Z3 N))))            00040510
              H    (SETQ N                                              00040520
                    (ADD1 (DIFFERENCE (CDAAR Z1) (CDAAR Z2))))          00040530
                (SETQ Z3 (CDAR Z2))                                     00040540
                (COND                                                   00040550
                 ((OR (ATOM Z)                                          00040560
                    (NULL (CDR Z))                                      00040570
                    (NOT (EQ (CAAAR Z) (CAAAR Z1))))                    00040580
                  (GO A)))                                              00040590
                (GO D1)))                                               00040600
           ((ORDP X Y) (GCD (CONS V (COEFF U X))))                      00040610
           (T (GCD (CONS U (COEFF V Y))))))                             00040620
      (CAAAR U)                                                         00040630
      (CAAAR V))))))                                                    00040640
                                                                        00040650
(COEFF (LAMBDA (U A)                                                    00040660
   (COND ((NULL U) NIL)                                                 00040670
       ((OR (ATOM U) (NOT (EQ (CAAAR U) A))) (LIST U))                  00040680
       (T (CONS (CDAR U) (COEFF (CDR U) A))))))                         00040690
                                                                        00040700
(REMK (LAMBDA (U V)                                                     00040710
   (REMK1 U V (CAAR V) NIL)))                                           00040720
                                                                        00040730
(REMK1 (LAMBDA (U V W Z)                                                00040740
   (COND                                                                00040750
    ((AND (NOT (ATOM U)) (ORDP (CAAR U) W))                             00040760
     (REMK1 (ADDF (MULTF (CDAR V) U)                                    00040770
              ((LAMBDA(M X)                                             00040780
                (COND ((ZEROP M) (MULTN -1 X))                          00040790
                    (T                                                  00040800
                     (MULTF                                             00040810
                      (LIST (CONS (MKSP (CAAAR U) M) -1))               00040820
                      X))))                                             00040830
               (DIFFERENCE (CDAAR U) (CDR W))                           00040840
               (MULTF (CDAR U) V)))                                     00040850
           V                                                            00040860
           W                                                            00040870
          (MULTF Z (CDAR V))))                                          00040880
    ((NULL Z) U)                                                        00040890
    (T (CANCEL (CONS U Z))))))                                          00040900
                                                                        00040910
(REMK* (LAMBDA (U V)                                                    00040920
   (REMK1 U V (CAAR V) 1)))                                             00040930
                                                                        00040940
(NMULTF (LAMBDA (U N)                                                   00040950
   (COND ((OR *EXP (KERNLP U)) (NMULTF1 U N)) (T (MKSFP U N)))))        00040960
                                                                        00040970
(NMULTF1 (LAMBDA (U N)                                                  00040980
   (COND ((ONEP N) U) (T (MULTF U (NMULTF1 U (SUB1 N)))))))             00040990
                                                                        00041000
))                                                                      00041010
                                                                        00041020
DEFINE ((                                                               00041030
                                                                        00041040
(OPERATOR (LAMBDA (U)                                                   00041050
   (PROG NIL                                                            00041060
       (COND                                                            00041070
        ((EQ *MODE (QUOTE SYMBOLIC))                                    00041080
         (RETURN (FLAG U (QUOTE OPFN)))))                               00041090
    A    (COND ((NULL U) (RETURN NIL))                                  00041100
             ((OR (NUMBERP (CAR U)) (NOT (ATOM (CAR U))))               00041110
            (LPRIM*                                                     00041120
             (CONS (CAR U) (QUOTE (CANNOT BE AN OPERATOR)))))           00041130
             ((GET (CAR U) (QUOTE SIMPFN))                              00041140
            (LPRIM* (CONS (CAR U) (QUOTE (ALREADY DEFINED)))))          00041150
             (T (MKOP (CAR U))))                                        00041160
       (SETQ U (CDR U))                                                 00041170
       (GO A))))                                                        00041180
                                                                        00041190
(FACTOR (LAMBDA (U)                                                     00041200
   (FACTOR1 U T (QUOTE FACTORS*))))                                     00041210
                                                                        00041220
(FACTOR1 (LAMBDA (U V W)                                                00041230
   (PROG (X Y)                                                          00041240
       (SETQ Y (GTS W))                                                 00041250
   A     (COND ((NULL U) (GO B))                                        00041260
             ((OR (KERNP (SETQ X (SIMPCAR U)))                          00041270
                (AND *SUPER (KERNP (SETQ X (MKSFP X 1)))))              00041280
            (GO C))                                                     00041290
             (T (ERRPRI2 (CAR U))))                                     00041300
       (GO D)                                                           00041310
    C    (SETQ X (CAAAAR X))                                            00041320
       (COND (V (SETQ Y (CONS X Y)))                                    00041330
             ((NOT (MEMBER X Y))                                        00041340
            (MESPRI NIL (CAR U) (QUOTE (NOT FOUND)) NIL NIL))           00041350
             (T (SETQ Y (DELETE X Y))))                                 00041360
    D    (SETQ U (CDR U))                                               00041370
         (GO A)                                                         00041375
   B     (PTS W Y))))                                                   00041380
                                                                        00041390
(REMFAC (LAMBDA (U)                                                     00041400
   (FACTOR1 U NIL (QUOTE FACTORS*))))                                   00041410
                                                                        00041420
))                                                                      00041430
                                                                        00041440
DEFINE ((                                                               00041450
                                                                        00041460
(FORALLFN* (LAMBDA NIL                                                  00041470
   (FORALLFN (RVLIS))))                                                 00041480
                                                                        00041490
(FORALLFN (LAMBDA (U)                                                   00041500
   (PROG (X Y)                                                          00041510
       (SETQ X (MAPCAR U (FUNCTION NEWVAR)))                            00041520
       (SETQ Y (PAIR U X))                                              00041530
       (SETQ MCOND* (SUBLIS Y MCOND*))                                  00041540
       (SETQ FRLIS* (UNION X FRLIS*))                                   00041550
       (SETQ X (LIST (COMMAND1 NIL)))                                   00041560
      (COND (MCOND* (SETQ X (CONS (LIST (QUOTE SETQ)                    00041570
                (QUOTE MCOND*) (LIST (QUOTE QUOTE) MCOND*)) X))))       00041580
      (COND (Y (SETQ X (CONS (LIST (QUOTE SETQ) (QUOTE FRASC*)          00041590
            (LIST (QUOTE QUOTE) Y)) X))))                               00041592
       (RETURN (MKPROG NIL X)))))                                       00041594
                                                                        00041600
))                                                                      00041610
                                                                        00041620
DEFINE ((                                                               00041630
                                                                        00041640
(LET (LAMBDA (U)                                                        00041650
   (LET0 U NIL)))                                                       00041660
                                                                        00041670
(LET0 (LAMBDA (U V)                                                     00041680
   (PROG NIL                                                            00041690
    A    (COND ((NULL U) (RETURN (SETQ MCOND* (SETQ FRASC* NIL))))      00041700
             ((OR (NOT (EQCAR (CAR U) (QUOTE EQUAL))) (CDDDAR U))       00041710
            (ERRPRI2 (CAR U))))                                         00041720
       (LET2 (CADAR U) (CAR (CDDAR U)) V T)                             00041730
       (SETQ U (CDR U))                                                 00041740
       (GO A))))                                                        00041750
                                                                        00041760
(LET1 (LAMBDA (U V)                                                     00041770
   (LET2 U V NIL T)))                                                   00041780
                                                                        00041790
(LET2 (LAMBDA (U V W B)                                                 00041800
   (PROG (X Y Z)                                                        00041810
       (SETQ U (SUBLIS FRASC* U))                                       00041812
       (SETQ V (SUBLIS FRASC* V))                                       00041814
      (COND ((AND FRASC* (EQCAR V (QUOTE *SQ)))                         00041816
            (SETQ V (PREPSQ (CADR  V)))))                               00041818
    A    (SETQ X U)                                                     00041820
       (COND ((NUMBERP X) (GO LER1))                                    00041840
             ((NOT (ATOM X)) (GO D))                                    00041850
                ((AND (SETQ Y (GET X (QUOTE OLDNAME)))                  00041860
                 (NOT (MEMBER Y (FLATTEN V)))) (LET2 Y V W B)))         00041870
         (COND (B (GO A2)))                                             00041880
         (REMPROP X (QUOTE NEWNAME))                                    00041890
         (REMPROP X (QUOTE OLDNAME))                                    00041900
    A2   (COND                                                          00041950
        ((AND (VECTORP X) (VLET X V B)) (RETURN NIL))                   00041960
        ((AND (NULL B) (GET X (QUOTE **ARRAY))) (GO J2))                00041970
        (W (GO H))                                                      00041980
        ((MATEXPR V) (GO J)))                                           00041990
    B1   (SETQ X (SIMP0 X))                                             00042000
    C    (SETQ X (CAAAR X))                                             00042010
       (SETQ Z (FKERN (CAR X)))                                         00042020
         (COND ((NULL B) (RETURN (RPLACD (CDR Z) NIL)))                 00042025
               ((ASSOC (QUOTE USED*) (CDR Z)) (RMSUBS2)))               00042030
       (XADD                                                            00042040
        (COND                                                           00042050
         ((AND (EQUAL V 0) (NOT (EQUAL (CDR X) 1)))                     00042060
          (CONS (QUOTE ASYMP) (CDR X)))                                 00042070
         (T (LIST (QUOTE REP) V (CDR X) NIL)))                          00042080
        (CDR Z)                                                         00042090
        (SQCHK (CAR Z))                                                 00042100
        T)                                                              00042110
       (RPLACW Z (DELASC (QUOTE DFN) Z))                                00042120
       (RETURN NIL)                                                     00042130
    D    (COND ((NOT (ATOM (CAR X))) (GO LER2))                         00042140
               ((GET* (CAR X) (QUOTE **ARRAY)) (GO L))                  00042150
               ((EQ (CAR X) (QUOTE DF)) (GO K))                         00042160
             ((NOT (GET* (CAR X) (QUOTE SIMPFN))) (GO LER3))            00042180
             ((OR W                                                     00042190
                (EQ (CAR X) (QUOTE TIMES))                              00042200
                (XN (FLATTEN (CDR X)) FRLIS*))                          00042210
            (GO H)))                                                    00042220
       (SETQ X (SIMP0 X))                                               00042230
       (COND ((NOT (EQUAL (CDR X) 1)) (GO LER1)))                       00042240
    E    (COND ((NOT (KERNP X)) (GO G))                                 00042250
             ((NOT (ONEP (CDAAR X)))                                    00042260
            (SETQ V (LIST (QUOTE QUOTIENT) V (CDAAR X)))))              00042270
       (GO C)                                                           00042280
    G    (COND ((NOT (KERNLP (CAR X))) (GO M)))                         00042290
       (SETQ X U)                                                       00042300
   H     (RMSUBS)                                                       00042305
         (COND                                                          00042310
        ((OR (NULL                                                      00042320
            (SETQ Y                                                     00042330
                  (KERNLP                                               00042340
                   (CAR (SETQ X (SIMP0 X))))))                          00042350
             (NOT (ATOM (CDR X))))                                      00042360
         (GO LER2))                                                     00042370
        ((AND (ONEP Y) (ONEP (CDR X))) (GO H1)))                        00042380
       (SETQ V (LIST (QUOTE TIMES) (CDR X) V))                          00042390
       (COND                                                            00042400
        ((NOT (ONEP Y))                                                 00042410
         (SETQ V (ACONC V (LIST (QUOTE QUOTIENT) 1 Y)))))               00042420
    H1   (SETQ X (KLISTT (CAR X)))                                      00042430
       (SETQ Y                                                          00042440
             (LIST (CONS W (COND (MCOND* MCOND*) (T T)))                00042450
                  V                                                     00042460
                  NIL))                                                 00042470
       (COND                                                            00042480
        ((AND (NULL W) (NULL (CDR X)) (ONEP (CDAR X))) (GO H2)))        00042490
       (RETURN (SETQ MATCH* (XADD (CONS X Y) MATCH* U B)))              00042500
    H2   (SETQ X (CAAR X))                                              00042510
         (COND ((NOT (MATEXPR V)) (GO H3))                              00042511
           ((NOT (REDMSG (CAR X) (QUOTE MATRIX) T)) (ERROR*)))          00042512
         (FLAG (LIST (CAR X)) (QUOTE MATFN))                            00042513
   H3    (RETURN (PUT (CAR X)                                           00042514
            (QUOTE OPMTCH*)                                             00042530
                  (XADD (CONS (CDR X) Y)                                00042540
                       (GET (CAR X) (QUOTE OPMTCH*))                    00042550
                     U B)))                                             00042560
    J    (SETQ MATP* T)                                                 00042590
       (COND ((GET X (QUOTE MATRIX)) (GO J1))                           00042600
             ((NOT (REDMSG X (QUOTE MATRIX) T)) (ERROR*)))              00042610
       (PUT X (QUOTE MATRIX) (QUOTE MATRIX))                            00042620
    J1   (COND ((EQCAR V (QUOTE MAT)) (RETURN (SETM X V)))              00042630
             (T (GO B1)))                                               00042640
    J2   (REMPROP X (QUOTE MATRIX))                                     00042650
       (REMPROP X (QUOTE **ARRAY))                                      00042660
       (RETURN NIL)                                                     00042670
    K    (COND                                                          00042680
        ((AND (NOT (ATOMLIS (CADR X))) (CDDDR X)) (GO LER1))            00042690
        ((AND (NOT (GET* (CAADR X) (QUOTE SIMPFN)))                     00042700
            (SETQ X (CADR X)))                                          00042710
         (GO LER3))                                                     00042720
        ((OR (NOT (FRLP (CDADR X)))                                     00042730
             (NOT (FRLP (CDDR X)))                                      00042740
             (NOT (MEMBER (CADDR X) (CDADR X))))                        00042750
         (GO H)))                                                       00042760
       (SETQ Z (POSN (CADDR X) (CDADR X)))                              00042770
       (COND                                                            00042780
        ((NOT (GET (CAADR X) (QUOTE DFN)))                              00042790
         (PUT (CAADR X)                                                 00042800
            (QUOTE DFN)                                                 00042810
            (NLIST NIL (LENGTH (CDADR X))))))                           00042820
       (COND                                                            00042830
        ((NULL (REPN (GET (CAADR X) (QUOTE DFN)) Z V X))                00042840
         (GO LER1)))                                                    00042850
       (RETURN NIL)                                                     00042860
    L    (COND ((AND (SETQ Z (ASSOC* X (GET (CAR X) (QUOTE KLIST))))    00042865
                 (ASSOC (QUOTE USED*) (CDR Z))) (RMSUBS2)))             00042870
         (SETEL (CONS (CAR X) (MAPCAR (CDR X) (FUNCTION                 00042875
                REVAL))) V)                                             00042880
       (RETURN NIL)                                                     00042890
    M    (COND ((NULL *SUPER) (GO LER1)))                               00042900
       (SETQ X (CONS (MKSFP (CAR X) 1) 1))                              00042910
       (GO E)                                                           00042920
    LER1 (ERRPRI2 U)                                                    00042930
       (ERROR*)                                                         00042940
    LER2 (ERRPRI1 U)                                                    00042950
       (ERROR*)                                                         00042960
    LER3 (COND ((NOT (REDMSG (CAR X) (QUOTE OPERATOR) T)) (ERROR*)))    00042970
       (MKOP (CAR X))                                                   00042980
       (GO A))))                                                        00042990
                                                                        00043000
(FRLP (LAMBDA (U)                                                       00043010
   (OR (NULL U) (AND (MEMBER (CAR U) FRLIS*) (FRLP (CDR U))))))         00043020
                                                                        00043030
(SIMP0 (LAMBDA (U)                                                      00043040
   (PROG (X)                                                            00043050
       (SETQ SUBFG* NIL)                                                00043060
       (SETQ X (SIMP U))                                                00043070
       (SETQ SUBFG* T)                                                  00043080
       (RETURN X))))                                                    00043090
                                                                        00043100
(MATCH (LAMBDA (U)                                                      00043220
   (LET0 U T)))                                                         00043230
                                                                        00043240
(CLEAR (LAMBDA (U)                                                      00043250
   (PROG NIL                                                            00043260
         (RMSUBS)                                                       00043270
    A    (COND ((NULL U) (RETURN (SETQ MCOND* (SETQ FRASC* NIL)))))     00043280
    B    (LET2 (CAR U) NIL NIL NIL)                                     00043330
       (SETQ U (CDR U))                                                 00043340
       (GO A))))                                                        00043350
                                                                        00043360
(KLISTT (LAMBDA (U)                                                     00043370
   (COND ((ATOM U) NIL) (T (CONS (CAAR U) (KLISTT (CDARX U)))))))       00043380
                                                                        00043390
))                                                                      00043400
                                                                        00043410
PTS (NOCMP* T)                                                          00043411
                                                                        00043412
DEFINE ((                                                               00043420
                                                                        00043430
(KERNP (LAMBDA (U)                                                      00043440
   (AND (ATOM (CDR U))                                                  00043450
      (NOT (ATOM (CAR U)))                                              00043460
      (NULL (CDAR U))                                                   00043470
      (ATOM (CDAAR U)))))                                               00043480
                                                                        00043490
(KERNLP (LAMBDA (U)                                                     00043500
   (COND ((ATOM U) U) ((NULL (CDR U)) (KERNLP (CDAR U))) (T NIL))))     00043510
                                                                        00043520
(RMSUBS (LAMBDA NIL                                                     00043530
   (PROG2 (RMSUBS1) (RMSUBS2))))                                        00043531
                                                                        00043532
(RMSUBS2 (LAMBDA NIL                                                    00043533
   (PROG2 (RPLACA *SQVAR* NIL) (SETQ *SQVAR* (LIST T)))))               00043534
                                                                        00043550
(RMSUBS1 (LAMBDA NIL                                                    00043560
   (PROG NIL                                                            00043570
       (MAP (APPEND DSUBL* SUBL*)                                       00043580
            (FUNCTION (LAMBDA (J) (RPLACA (CAR J) NIL))))               00043590
       (SETQ SUBL* NIL))))                                              00043600
                                                                        00043610
(XADD (LAMBDA (U V W B)                                                 00043620
   (PROG (X)                                                            00043630
       (SETQ X (ASSOC* (CAR U) V))                                      00043640
       (COND ((NULL X) (GO C)) ((NULL B) (GO B1)))                      00043650
         (RMSUBS1)                                                      00043660
       (RPLACD X (CDR U))                                               00043670
    A    (RETURN V)                                                     00043680
    B1   (SETQ V (DELETE X V))                                          00043690
       (GO A)                                                           00043700
    C    (COND ((NULL B) (MESPRI NIL W (QUOTE (NOT FOUND)) NIL NIL))    00043710
             (T (SETQ V (NCONC V (LIST U)))))                           00043720
       (GO A))))                                                        00043730
                                                                        00043740
(REPN (LAMBDA (U N V W)                                                 00043750
   (PROG NIL                                                            00043760
    A    (COND ((OR (NULL U) (ZEROP N)) (RETURN NIL))                   00043770
             ((NOT (ONEP N)) (GO B))                                    00043780
             ((CAR U) (REDEFPRI W)))                                    00043790
       (RETURN (RPLACA U (CONS (CDADR W) V)))                           00043800
    B    (SETQ U (CDR U))                                               00043810
       (SETQ N (SUB1 N))                                                00043820
       (GO A))))                                                        00043830
                                                                        00043840
(DENOM (LAMBDA (U)                                                      00043850
   (LET1 U (MK*SQ (CONS (CDR (SIMP *ANS)) 1)))))                        00043860
                                                                        00043870
(NUMER (LAMBDA (U)                                                      00043880
   (LET1 U (MK*SQ (CONS (CAR (SIMP *ANS)) 1)))))                        00043890
                                                                        00043900
(ND (LAMBDA (U V)                                                       00043910
   (PROG2 (NUMER U) (DENOM V))))                                        00043920
                                                                        00043930
(SAVEAS (LAMBDA (U)                                                     00043940
   (SETK U *ANS)))                                                      00043950
                                                                        00043960
(SETK (LAMBDA (U V)                                                     00043970
   (PROG2 (LET1 U                                                       00043980
            (COND                                                       00043990
             ((AND(NOT (ATOM U))(NOT (ATOM V))(XN (CDR U) FRLIS*))      00044000
              (PREPSQ (CADR V)))                                        00044010
             (T V)))                                                    00044020
         V)))                                                           00044030
                                                                        00044040
(TERMS (LAMBDA NIL                                                      00044050
   (PRINTTY                                                             00044060
    (COND                                                               00044070
     ((EQCAR *ANS (QUOTE *SQ)) (TERMS1 (CAADR *ANS)))                   00044080
     (T (SCNT *ANS))))))                                                00044090
                                                                        00044100
(TERMS1 (LAMBDA (U)                                                     00044110
   (PROG (N)                                                            00044120
       (SETQ N 0)                                                       00044130
    A    (COND ((NULL U) (RETURN N)) ((ATOM U) (RETURN (ADD1 N))))      00044140
       (SETQ N (PLUS N (TERMS1 (CDAR U))))                              00044150
       (SETQ U (CDR U))                                                 00044160
       (GO A))))                                                        00044170
                                                                        00044180
))                                                                      00044190
                                                                        00044200
DEFINE ((                                                               00044210
                                                                        00044220
(ANTISYMMETRIC (LAMBDA (U)                                              00044230
   (FLAG U (QUOTE ANTISYMMETRIC))))                                     00044240
                                                                        00044250
(SYMMETRIC (LAMBDA (U)                                                  00044260
   (FLAG U (QUOTE SYMMETRIC))))                                         00044270
                                                                        00044280
))                                                                      00044290
                                                                        00044300
FLAG ((PLUS TIMES CONS) SYMMETRIC)                                      00044310
                                                                        00044320
FLAG ((PLUS TIMES) NARY)                                                00044321
                                                                        00044322
DEFINE ((                                                               00044330
                                                                        00044340
(MKCOEFF (LAMBDA (U V)                                                  00044350
   (PROG (W X Y Z)                                                      00044360
       (COND ((NOT (ATOM U)) (SETQ U (REVAL U))))                       00044370
       (SETQ X FACTORS*)                                                00044380
       (SETQ FACTORS* (LIST U))                                         00044390
       (SETQ W                                                          00044400
             (COND                                                      00044410
            ((EQCAR *ANS (QUOTE *SQ)) (CADR *ANS))                      00044420
            (T (SIMP *ANS))))                                           00044430
       (SETQ Y (CONS (FORMOP (CAR W)) (FORMOP (CDR W))))                00044440
       (COND                                                            00044450
        ((NULL (EQUAL (CDR Y) 1))                                       00044460
         (LPRIM* (QUOTE (MKCOEFF GIVEN RATIONAL FUNCTION)))))           00044470
       (SETQ W (CDR Y))                                                 00044480
       (SETQ Y (CAR Y))                                                 00044490
    A    (COND ((OR (ATOM Y) (NOT (EQUAL (CAAAR Y) U))) (GO B)))        00044500
       (SETQ Z                                                          00044510
             (CONS (CONS (CDAAR Y)                                      00044520
                     (PREPSQ (CANCEL (CONS (CDAR Y) W))))               00044530
                  Z))                                                   00044540
       (SETQ Y (CDR Y))                                                 00044550
       (GO A)                                                           00044560
    B    (COND ((NULL Y) (GO B1)))                                      00044570
       (SETQ Z (CONS (CONS 0 (PREPSQ (CANCEL (CONS Y W)))) Z))          00044580
    B1   (COND                                                          00044590
          ((OR (AND (NOT (ATOM V)) (ATOM (CAR V))                       00044595
             (SETQ Y (GET* (CAR V) (QUOTE **ARRAY))))                   00044600
           (AND (ATOM V)                                                00044605
                (SETQ Y (GET* V (QUOTE **ARRAY)))                       00044610
                (NULL (CDR Y))))                                        00044615
         (GO G)))                                                       00044630
       (SETQ Y (EXPLODE V))                                             00044640
       (SETQ V NIL)                                                     00044650
    C    (COND ((NULL Z) (GO D)))                                       00044660
       (SETQ V                                                          00044670
             (CONS (LIST (QUOTE EQUAL)                                  00044680
                     (COMPRESS (APPEND Y (EXPLODE (CAAR Z))))           00044690
                     (CDAR Z))                                          00044700
                  V))                                                   00044710
       (SETQ Z (CDR Z))                                                 00044720
       (GO C)                                                           00044730
    D    (*APPLY (QUOTE LET) (LIST V))                                  00044740
       (COND                                                            00044760
        (*MSG                                                           00044770
         (LPRI                                                          00044780
          (NCONC (MAPLIST V (FUNCTION CADAR))                           00044790
               (QUOTE (ARE NON ZERO))))))                               00044800
    E    (SETQ FACTORS* X)                                              00044805
         (RETURN NIL)                                                   00044810
   G     (SETQ Z (REVERSE Z))                                           00044815
         (COND ((ATOM V) (SETQ V (LIST V (QUOTE *)))))                  00044820
       (COND                                                            00044840
        (*MSG                                                           00044850
         (LPRI                                                          00044860
          (APPEND (QUOTE (HIGHEST POWER IS)) (LIST (CAAR Z))))))        00044870
         (SETQ Y (PAIR (CDR V) Y))                                      00044871
   G0    (COND ((AND (MEMBER (QUOTE *) (FLATTEN (CAAR Y)))              00044872
                     (SETQ Y (PLUS (CDAR Y) (MINUS (REVAL               00044873
                       (SUBST 0 (QUOTE *) (CAAR Y)))))))  (GO G1)))     00044874
         (SETQ Y (CDR Y))                                               00044875
         (GO G0)                                                        00044876
   G1    (COND                                                          00044877
        ((GREATERP (CAAR Z) Y) (REDERR (QUOTE (ARRAY TOO SMALL)))))     00044890
    H    (COND                                                          00044900
        ((OR (NULL Z) (NOT (EQUAL Y (CAAR Z))))                         00044910
           (SETEL (SUBST Y (QUOTE *) V) 0))                             00044915
          (T (PROG2 (SETEL (SUBST Y (QUOTE *) V) (CDAR Z))              00044920
                 (SETQ Z (CDR Z)))))                                    00044925
         (COND ((ZEROP Y) (GO E)))                                      00044930
       (SETQ Y (SUB1 Y))                                                00044950
       (GO H))))                                                        00044960
                                                                        00044970
))                                                                      00044980
                                                                        00044990
                                                                        00045000
DEFINE ((                                                               00045010
                                                                        00045020
(WEIGHT (LAMBDA (U)                                                     00045030
   (PROG (X Y)                                                          00045040
       (RMSUBS)                                                         00045050
    A    (COND ((NULL U) (RETURN NIL))                                  00045060
             ((OR (NOT (EQ (CAAR U) (QUOTE EQUAL)))                     00045070
                    (NOT (AND (ATOM (CADAR U))                          00045075
                           (NOT (NUMBERP (CADAR U)))))                  00045080
                (NOT                                                    00045090
                 (AND (NUMBERP (CADDAR U))                              00045100
                    (FIXP (CADDAR U))                                   00045110
                           (NOT (MINUSP (CADDAR U))))))                 00045115
                (ERRPRI1 (CAR U))))                                     00045120
         (SETQ Y (CADAR U))                                             00045125
         (COND ((SETQ X (GET Y (QUOTE OLDNAME))) (GO C)))               00045130
         (SETQ X (NEWVAR Y))                                            00045135
         (PUT Y (QUOTE NEWNAME) X)                                      00045140
         (PUT X (QUOTE OLDNAME) Y)                                      00045145
         (FLAG (LIST X) (QUOTE WEIGHT))                                 00045150
   B     (LET2 X                                                        00045155
               (LIST (QUOTE TIMES)                                      00045160
                      Y                                                 00045165
                     (LIST (QUOTE EXPT) (QUOTE K*) (CADDAR U)))         00045170
               NIL                                                      00045175
               T)                                                       00045180
         (SETQ U (CDR U))                                               00045185
         (GO A)                                                         00045190
   C     (COND ((NOT (FLAGP Y (QUOTE WEIGHT))) (ERRPRI1 (CAR U))))      00045195
         (SETQ Y X)                                                     00045200
         (SETQ X (CADAR U))                                             00045205
         (GO B))))                                                      00045210
                                                                        00045215
(WTLEVEL (LAMBDA (N)                                                    00045220
   (PROG (X)                                                            00045225
         (SETQ N (REVAL N))                                             00045230
         (COND                                                          00045235
           ((NOT (AND (NUMBERP N) (FIXP N) (NOT (MINUSP N))))           00045240
            (ERRPRI1 N)))                                               00045245
         (SETQ X (ASSOC (QUOTE ASYMP) (CDDR (FKERN (QUOTE K*)))))       00045250
         (COND ((EQUAL N (CDR X)) (RETURN NIL))                         00045255
               ((NOT (GREATERP N (CDR X))) (RMSUBS2)))                  00045260
         (RMSUBS1)                                                      00045265
         (RPLACD X N))))                                                00045270
                                                                        00045300
))                                                                      00045310
                                                                        00045320
PTS (NOCMP* NIL)                                                        00045321
                                                                        00045322
DEFLIST (((WEIGHT RLIS) (WTLEVEL NORLIS)) STAT)                         00045330
                                                                        00045340
LET1 ((EXPT K* 2) 0)                                                    00045350
                                                                        00045360
COMMENT ((ELEMENTARY FUNCTION PROPERTIES))                              00045370
                                                                        00045380
DEFLIST (((LOG IDEN) (COS IDEN) (SIN IDEN)) SIMPFN)                     00045390
                                                                        00045400
DEFLIST ((                                                              00045410
  (LOG (((LOG E) (((LOG E) . 1)) (REP 1 1 NIL))                         00045420
      ((LOG 1) (((LOG 1) . 1)) (REP 0 1 NIL))))                         00045430
  (COS (((COS 0) (((COS 0) . 1)) (REP 1 1 NIL))))                       00045440
  (SIN (((SIN 0) (((SIN 0) . 1)) (REP 0 1 NIL))))                       00045450
) KLIST)                                                                00045460
                                                                        00045470
DEFLIST ((                                                              00045480
  (EXPT (((X Y) TIMES Y (EXPT X (PLUS Y (MINUS 1))))                    00045490
        ((X Y) TIMES (LOG X) (EXPT X Y))))                              00045500
(LOG (((X) QUOTIENT 1 X)))                                              00045510
(COS (((X) MINUS (SIN X))))                                             00045520
(SIN (((X) COS X)))                                                     00045530
) DFN)                                                                  00045540
                                                                        00045550
DEFLIST ((                                                              00045560
  (COS ((((MINUS ***X)) (NIL  . T) (COS ***X) NIL)))                    00045570
  (SIN ((((MINUS ***X)) (NIL . T) (MINUS (SIN ***X)) NIL)))             00045580
) OPMTCH*)                                                              00045590
                                                                        00045600
PTS (FRLIS* (***X))                                                     00045610
                                                                        00045620
DEFINE ((                                                               00045630
                                                                        00045640
(MSIMP (LAMBDA (U V)                                                    00045650
   (PROG (X Y Z)                                                        00045660
       (COND ((AND (NULL V) SUBFG*) (SETQ U (SUBLIS VREP* U))))         00045670
       (SETQ U (MSIMP1 U V))                                            00045680
    A1   (COND ((NULL U) (RETURN Z)))                                   00045690
    A0   (SETQ X (CAR U))                                               00045700
    A    (COND ((AND V (NULL X)) (GO D))                                00045710
             ((NULL X) (GO NULLU))                                      00045720
             ((OR (AND (NULL V) (VECTORP (CAR X)))                      00045730
                (AND V (MATP (CAR X))))                                 00045740
            (GO B)))                                                    00045750
    BACK (SETQ X (CDR X))                                               00045760
       (GO A)                                                           00045770
    B    (SETQ Y (LIST (CAR X)))                                        00045780
       (SETQ X (CDR X))                                                 00045790
    C    (COND ((NULL X) (GO D))                                        00045800
             ((AND (NULL V) (VECTORP (CAR X)))                          00045810
            (REDERR                                                     00045820
             (APPEND (QUOTE (REDUNDANT VECTOR)) (LIST (CAR U)))))       00045830
             ((AND V (MATP (CAR X))) (SETQ Y (ACONC Y (CAR X)))))       00045840
       (SETQ X (CDR X))                                                 00045850
       (GO C)                                                           00045860
    D    (SETQ X (SETDIFF (CAR U) Y))                                   00045870
       (SETQ Z                                                          00045880
             (ADDM1 (CONS (COND ((NULL X) (CONS 1 1))                   00045890
                          (T (SIMPTIMES X)))                            00045900
                      (REVERSE Y))                                      00045910
                   Z))                                                  00045920
       (SETQ U (CDR U))                                                 00045930
       (GO A1)                                                          00045940
    E    (VECTOR (LIST (CAAR U)))                                       00045950
       (GO A0)                                                          00045960
    NULLU                                                               00045970
       (COND                                                            00045980
        ((AND (ATOM (CAAR U))                                           00045990
            (NOT (NUMBERP (CAAR U)))                                    00046000
            (REDMSG (CAAR U) (QUOTE VECTOR) T))                         00046010
         (GO E))                                                        00046020
        (T                                                              00046030
         (REDERR                                                        00046040
          (APPEND (QUOTE (MISSING VECTOR)) (LIST (CAR U))))))           00046050
       (GO BACK))))                                                     00046060
                                                                        00046070
(MSIMP1 (LAMBDA (U1 *S*) ((LAMBDA (U)                                   00046080
   (COND ((NUMBERP U) (LIST (LIST U)))                                  00046090
       ((ATOM U)                                                        00046100
        ((LAMBDA(X)                                                     00046110
            (COND ((AND X SUBFG* (EQUAL (CADDR X) 1))                   00046115
                   (MSIMP1 (CADR X) *S*))                               00046120
              (T                                                        00046130
               (PROG2                                                   00046140
                (COND ((NULL *S*) (FLAG (LIST U) (QUOTE USED*)))        00046150
                    (T NIL))                                            00046160
                (LIST (LIST U))))))                                     00046170
         (ASSOC (QUOTE REP) (CDDR (FKERN U)))))                         00046180
       ((EQ (CAR U) (QUOTE PLUS))                                       00046190
        (MAPCON (CDR U)                                                 00046200
              (FUNCTION (LAMBDA (J) (MSIMP1 (CAR J) *S*)))))            00046210
       ((EQ (CAR U) (QUOTE MINUS))                                      00046220
        (MSIMPTIMES (LIST -1 (CARX (CDR U))) *S*))                      00046230
       ((EQ (CAR U) (QUOTE TIMES)) (MSIMPTIMES (CDR U) *S*))            00046240
         ((EQ (CAR U) (QUOTE QUOTIENT))                                 00046241
          (MSIMPTIMES (LIST (CADR U)                                    00046242
                            (LIST (QUOTE RECIP) (CARX (CDDR U))))       00046243
                      *S*))                                             00046244
       ((OR (NULL *S*) (EQCAR U (QUOTE MAT)) (NOT (MATEXPR U)))         00046250
        (LIST (LIST U)))                                                00046260
       ((EQ (CAR U) (QUOTE RECIP)) (MSIMPRS (CARX (CDR U)) NIL))        00046270
       ((EQ (CAR U) (QUOTE SOLVE))                                      00046280
        (MSIMPRS (CADR U) (MATSIMP (MSIMP (CADDR U) T))))               00046290
       (T                                                               00046340
        ((LAMBDA(Z)                                                     00046350
          (COND                                                         00046360
           ((OR (NOT (EQ (CAR U) (QUOTE EXPT)))                         00046370
              (NOT (NUMBERP Z))                                         00046380
              (NOT (FIXP Z)))                                           00046390
            (REDERR (QUOTE (MATRIX SYNTAX))))                           00046400
           ((MINUSP Z)                                                  00046410
           (MSIMPRS                                                     00046420
            (CONS (QUOTE TIMES) (NLIST (CADR U) (MINUS Z))) NIL))       00046430
           (T (MSIMPTIMES (NLIST (CADR U) Z) T))))                      00046440
         ((LAMBDA(Y)                                                    00046450
           (COND                                                        00046460
            ((AND (EQCAR Y (QUOTE MINUS)) (NUMBERP (CADR Y)))           00046470
             (MINUS (CADR Y)))                                          00046480
            (T Y)))                                                     00046490
            (REVAL (CADDR U))))))) (EMTCH U1))))                        00046500
                                                                        00046510
(MSIMPTIMES (LAMBDA (U V)                                               00046520
   (COND ((NULL U) (ERRACH (QUOTE MSIMPTIMES)))                         00046530
       ((NULL (CDR U)) (MSIMP1 (CAR U) V))                              00046540
       (T                                                               00046550
        ((LAMBDA(*S*)                                                   00046560
          (MAPCON (MSIMPTIMES (CDR U) V)                                00046570
                (FUNCTION                                               00046580
                 (LAMBDA(*S1*)                                          00046590
                  (MAPCAR *S*                                           00046600
                        (FUNCTION                                       00046610
                         (LAMBDA(K)                                     00046620
                        (APPEND (CAR *S1*) K))))))))                    00046630
         (MSIMP1 (CAR U) V))))))                                        00046640
                                                                        00046650
(ADDM1 (LAMBDA (U V)                                                    00046660
   (COND ((NULL V) (LIST U))                                            00046670
       ((EQUAL (CDR U) (CDAR V))                                        00046680
        ((LAMBDA(X)                                                     00046690
          (COND ((NULL (CAR X)) (CDR V))                                00046700
              (T (CONS (CONS X (CDR U)) (CDR V)))))                     00046710
         (ADDSQ (CAR U) (CAAR V))))                                     00046720
       ((ORDP (CDR U) (CDAR V)) (CONS U V))                             00046730
       (T (CONS (CAR V) (ADDM1 U (CDR V)))))))                          00046740
                                                                        00046750
))                                                                      00046760
                                                                        00046770
DEFINE ((                                                               00046780
                                                                        00046790
(MATP (LAMBDA (U)                                                       00046800
   (COND ((ATOM U) (FLAGP** U (QUOTE MATRIX)))                          00046810
       (T (EQCAR U (QUOTE MAT))))))                                     00046820
                                                                        00046830
(MATEXPR (LAMBDA (U)                                                    00046840
   (AND MATP* (MATEXPR1 U))))                                           00046850
                                                                        00046860
(MATEXPR1 (LAMBDA (U)                                                   00046870
   (COND ((NULL U) NIL)                                                 00046880
       ((ATOM U) (MATP U))                                              00046890
       ((MEMBER (CAR U) (QUOTE (*SQ DET TRACE))) NIL)                   00046900
         ((OR (FLAGP** (CAR U) (QUOTE MATFN)) (MATEXPR1 (CADR U))) T)   00046910
       (T                                                               00046920
        (*EVAL                                                          00046930
         (CONS (QUOTE OR) (MAPCAR (CDR U) (FUNCTION MATEXPR1))))))))    00046940
                                                                        00046950
))                                                                      00046960
                                                                        00046970
FLAG ((MAT) MATFN)                                                      00046971
                                                                        00046972
DEFINE ((                                                               00046980
                                                                        00046990
(MATSM (LAMBDA (U)                                                      00047000
   ((LAMBDA(X)                                                          00047010
     (COND                                                              00047020
      ((AND (NULL (CDR X)) (NULL (CDAR X))) (SIMP (CAAR X)))            00047030
      (T (CONS (QUOTE MAT) X))))                                        00047040
    (MAPC2 (MATSIMP (MSIMP U T))                                        00047050
         (FUNCTION (LAMBDA (J) (MK*SQ (SUBS2 J))))))))                  00047060
                                                                        00047070
))                                                                      00047080
                                                                        00047090
DEFINE ((                                                               00047100
                                                                        00047110
(MATSIMP (LAMBDA (U)                                                    00047120
   (PROG (X)                                                            00047130
       (SETQ X (SMMULT (CAAR U) (MMULT (CDAR U))))                      00047140
    A    (SETQ U (CDR U))                                               00047150
       (COND ((NULL U) (RETURN X)))                                     00047160
       (SETQ X (MADD X (SMMULT (CAAR U) (MMULT (CDAR U)))))             00047170
       (GO A))))                                                        00047180
                                                                        00047190
(MMULT (LAMBDA (U)                                                      00047200
   (PROG (Y Z)                                                          00047210
       (SETQ Y (GETM* (CAR U)))                                         00047220
    A    (SETQ U (CDR U))                                               00047230
       (COND ((NULL U) (RETURN Y)))                                     00047240
       (SETQ Z (GETM* (CAR U)))                                         00047250
       (COND                                                            00047260
        ((NOT (EQUAL (LENGTH (CAR Y)) (LENGTH Z)))                      00047270
         (REDERR (QUOTE (MATRIX MISMATCH)))))                           00047280
       (SETQ Y (MULTM Y Z))                                             00047290
       (GO A))))                                                        00047300
                                                                        00047310
(SMMULT (LAMBDA (*S* V)                                                 00047320
   (COND ((EQUAL *S* (CONS 1 1)) V)                                     00047330
       (T (MAPC2 V (FUNCTION (LAMBDA (J) (MULTSQ *S* J))))))))          00047340
                                                                        00047350
(GETM* (LAMBDA (U)                                                      00047360
   (COND ((EQCAR U (QUOTE MAT)) (SIMPDET* (CDR U)))                     00047370
       (T                                                               00047380
        ((LAMBDA(X)                                                     00047390
          (COND                                                         00047400
           ((OR (NULL X) (EQ X (QUOTE MATRIX)))                         00047410
            (REDERR                                                     00047420
             (CONS (QUOTE MATRIX) (CONS U (QUOTE (NOT SET))))))         00047430
           (T (MLIST U (CAR X) (CADR X)))))                             00047440
         (COND ((ATOM U) (GET U (QUOTE MATRIX))) (T NIL)))))))          00047450
                                                                        00047460
(MLIST (LAMBDA (U M N)                                                  00047470
   (PROG (M1 N1 X Y Z)                                                  00047480
       (SETQ M1 M)                                                      00047490
    A    (SETQ Y NIL)                                                   00047500
       (SETQ N1 N)                                                      00047510
    B    (COND                                                          00047520
        ((NULL (SETQ X (GETEL (LIST U M1 N1))))                         00047530
         (REDERR (CONS U (CONS (LIST M1 N1) (QUOTE (NOT SET)))))))      00047540
       (SETQ Y (CONS (SIMP X) Y))                                       00047550
       (SETQ N1 (SUB1 N1))                                              00047560
       (COND ((NOT (ZEROP N1)) (GO B)))                                 00047570
       (SETQ Z (CONS Y Z))                                              00047580
       (SETQ M1 (SUB1 M1))                                              00047590
       (COND ((ZEROP M1) (RETURN Z)))                                   00047600
       (GO A))))                                                        00047610
                                                                        00047620
))                                                                      00047630
                                                                        00047640
DEFINE ((                                                               00047650
                                                                        00047660
(MADD (LAMBDA (U V)                                                     00047670
   (MAPCAR (PAIR U V)                                                   00047680
         (FUNCTION (LAMBDA (J) (MADD1 (CAR J) (CDR J)))))))             00047690
                                                                        00047700
(MADD1 (LAMBDA (U V)                                                    00047710
   (COND ((NULL U) NIL)                                                 00047720
       (T (CONS (ADDSQ (CAR U) (CAR V)) (MADD1 (CDR U) (CDR V)))))))    00047730
                                                                        00047740
))                                                                      00047750
                                                                        00047760
DEFLIST (((MATRIX RLIS)) STAT)                                          00047770
                                                                        00047780
DEFINE ((                                                               00047790
                                                                        00047800
(MATRIX (LAMBDA (U)                                                     00047810
   (PROG NIL                                                            00047820
       (SETQ MATP* T)                                                   00047830
    A    (COND ((NULL U) (RETURN NIL))                                  00047840
             ((ATOM (CAR U))                                            00047850
            (PUT (CAR U)                                                00047860
                 (QUOTE MATRIX)                                         00047870
                 ((LAMBDA (X) (COND (X X) (T (QUOTE MATRIX))))          00047880
                  (GET* (CAR U) (QUOTE **ARRAY)))))                     00047890
             (T                                                         00047900
            (PROG2 (*APPLY (QUOTE AARRAY) (LIST (LIST (CAR U))))        00047910
                       (PUT (CAAR U) (QUOTE MATRIX)                     00047915
                        (MAPCAR (CDAR U) (FUNCTION REVAL))))))          00047920
       (SETQ U (CDR U))                                                 00047930
       (GO A))))                                                        00047940
                                                                        00047950
))                                                                      00047960
                                                                        00047970
DEFINE ((                                                               00047980
                                                                        00047990
(MULTM (LAMBDA (U *S*)                                                  00048000
   (MAPCAR U                                                            00048010
         (FUNCTION                                                      00048020
          (LAMBDA (J) (MULTM1 J *S* (LENGTH (CAR *S*)) NIL))))))        00048030
                                                                        00048040
(MULTM1 (LAMBDA (U V N W)                                               00048050
   (COND ((ZEROP N) W)                                                  00048060
       (T (MULTM1 U V (SUB1 N) (CONS (MELEM U V N) W))))))              00048070
                                                                        00048080
(MELEM (LAMBDA (U V N)                                                  00048090
   (COND ((NULL U) (CONS NIL 1))                                        00048100
       (T                                                               00048110
        ((LAMBDA (X) (COND ((NULL (CAR X)) (CONS NIL 1)) (T X)))        00048120
         (ADDSQ (MULTSQ (CAR U) (NTH (CAR V) N))                        00048130
              (MELEM (CDR U) (CDR V) N)))))))                           00048140
                                                                        00048150
))                                                                      00048160
                                                                        00048170
DEFINE ((                                                               00048180
                                                                        00048190
(MATPRI (LAMBDA (U X)                                                   00048200
   (PROG (V M N)                                                        00048210
       (SETQ M 1)                                                       00048220
       (COND ((NULL X) (SETQ X (QUOTE MAT))))                           00048230
    A    (COND ((NULL U) (RETURN NIL)))                                 00048240
       (SETQ N 1)                                                       00048250
       (SETQ V (CAR U))                                                 00048260
    B    (COND ((NULL V) (GO C))                                        00048270
            ((AND (EQUAL (CAR V) 0) *NERO) (GO B1)))                    00048280
            (MAPRIN (LIST X M N))                                       00048290
       (OPRIN (QUOTE EQUAL))                                            00048350
       (SETQ ORIG* POSN*)                                               00048360
       (MATHPRINT (CAR V))                                              00048370
       (SETQ ORIG* 0)                                                   00048380
       (TERPRI*)                                                        00048390
   B1        (SETQ V (CDR V))                                           00048400
       (SETQ N (ADD1 N))                                                00048410
       (GO B)                                                           00048420
    C    (SETQ U (CDR U))                                               00048430
       (SETQ M (ADD1 M))                                                00048440
       (GO A))))                                                        00048450
                                                                        00048460
))                                                                      00048470
                                                                        00048480
DEFINE ((                                                               00048490
                                                                        00048500
(SETM (LAMBDA (U V)                                                     00048510
   (PROG (N M X Y)                                                      00048520
       (SETQ V (CDR V))                                                 00048530
       (SETQ Y (LIST (LENGTH V) (LENGTH (CAR V))))                      00048540
       (COND                                                            00048550
        ((NOT (EQ (SETQ X (GET U (QUOTE MATRIX))) (QUOTE MATRIX)))      00048560
         (GO A)))                                                       00048570
       (*APPLY (QUOTE AARRAY) (LIST (LIST (CONS U Y))))                 00048580
       (PUT U (QUOTE MATRIX) Y)                                         00048590
       (GO A1)                                                          00048600
    A    (COND                                                          00048610
        ((NOT (EQUAL X Y)) (REDERR (QUOTE (MATRIX MISMATCH)))))         00048620
    A1   (SETQ M 1)                                                     00048630
    B    (SETQ Y (CAR V))                                               00048640
       (SETQ N 1)                                                       00048650
    C    (COND ((NULL Y) (GO D)))                                       00048660
       (SETEL (LIST U M N) (CAR Y))                                     00048670
       (SETQ N (ADD1 N))                                                00048680
       (SETQ Y (CDR Y))                                                 00048690
       (GO C)                                                           00048700
    D    (SETQ V (CDR V))                                               00048710
       (COND ((NULL V) (RETURN NIL)))                                   00048720
       (SETQ M (ADD1 M))                                                00048730
       (GO B))))                                                        00048740
                                                                        00048750
))                                                                      00048760
                                                                        00048770
DEFINE ((                                                               00048780
                                                                        00048790
(MSIMPRS (LAMBDA (U V)                                                  00048800
   ((LAMBDA(X)                                                          00048810
     (LIST                                                              00048820
      (LIST                                                             00048830
       (CONS (QUOTE MAT)                                                00048840
           (MAPC2                                                       00048850
            (COND                                                       00048860
             ((AND (NULL (CDR X)) (NULL V))                             00048870
            (SMMULT (REVPR (CAAR X))                                    00048880
                  (*MATINV (MMULT (CDAR X)) NIL)))                      00048890
             (T (*MATINV (MATSIMP X) V)))                               00048900
            (FUNCTION MK*SQ))))))                                       00048910
    (MSIMP U T))))                                                      00048920
                                                                        00048930
))                                                                      00048940
                                                                        00048950
DEFINE ((                                                               00048960
                                                                        00048970
(AUGMENT (LAMBDA (U V)                                                  00048980
   (COND ((NULL U) NIL)                                                 00048990
       (T                                                               00049000
        (CONS (APPEND (CAR U) (CAR V)) (AUGMENT (CDR U) (CDR V))))))    00049010
)                                                                       00049020
                                                                        00049030
))                                                                      00049040
                                                                        00049050
DEFINE ((                                                               00049060
                                                                        00049070
(SETMATELEM (LAMBDA (U I J ELEM)                                        00049080
   (PROG (A)                                                            00049090
       (SETQ A (NTH U I))                                               00049100
    LOOP (COND ((EQUAL J 1) (RETURN (RPLACA A ELEM))))                  00049110
       (SETQ J (SUB1 J))                                                00049120
       (SETQ A (CDR A))                                                 00049130
       (GO LOOP))))                                                     00049140
                                                                        00049150
))                                                                      00049160
                                                                        00049170
DEFINE ((                                                               00049180
                                                                        00049190
(LIPSON (LAMBDA (U M N V)                                               00049200
   (PROG (AA AA1 K K1 K2 I J TEMP BB C0 CI1 CI2 AAK)                    00049210
       (SETQ AA (CONS 1 1))                                             00049220
       (SETQ K 2)                                                       00049230
    BEG  (SETQ K1 (SUB1 K))                                             00049240
       (SETQ K2 (SUB1 K1))                                              00049250
       (COND ((GREATERP K M) (GO FB)) ((EQUAL K 2) (GO PIVOT)))         00049260
       (SETQ AA (REVPR (NTH (NTH U K2) K2)))                            00049270
    PIVOT                                                               00049280
       (SETQ AA1 (NTH (NTH U K1) K1))                                   00049290
       (COND ((NULL (EQUAL AA1 (CONS NIL 1))) (GO L2)))                 00049300
       (SETQ I K)                                                       00049310
    L    (COND ((GREATERP I M) (GO SING))                               00049320
             ((EQUAL (NTH (NTH U I) K1) (CONS NIL 1)) (GO L1)))         00049330
       (SETQ J K1)                                                      00049340
    L0   (COND ((GREATERP J N) (GO PL2)))                               00049350
       (SETQ TEMP (NTH (NTH U I) J))                                    00049360
       (SETMATELEM U I J (NEGSQ (NTH (NTH U K1) J)))                    00049370
       (SETMATELEM U K1 J TEMP)                                         00049380
       (SETQ J (ADD1 J))                                                00049390
       (GO L0)                                                          00049400
    L1   (SETQ I (ADD1 I))                                              00049410
       (GO L)                                                           00049420
    PL2  (SETQ AA1 (NTH (NTH U K1) K1))                                 00049430
    L2   (SETQ I K)                                                     00049440
    L2A  (COND ((GREATERP I M) (GO SING)))                              00049450
       (SETQ BB                                                         00049460
             (ADDSQ (MULTSQ AA1 (NTH (NTH U I) K))                      00049470
                  (NEGSQ                                                00049480
                   (MULTSQ (NTH (NTH U K1) K)                           00049490
                         (NTH (NTH U I) K1)))))                         00049500
       (COND ((EQUAL BB (CONS NIL 1)) (GO L2B)))                        00049510
       (GO L3)                                                          00049520
    L2B  (SETQ I (ADD1 I))                                              00049530
       (GO L2A)                                                         00049540
    L3   (SETQ C0 (MULTSQ BB AA))                                       00049550
       (COND ((EQUAL K M) (GO EV)) ((EQUAL I K) (GO COMP)))             00049560
       (SETQ J K1)                                                      00049570
    L3A  (COND ((GREATERP J N) (GO COMP)))                              00049580
       (SETQ TEMP (NTH (NTH U I) J))                                    00049590
       (SETMATELEM U I J (NEGSQ (NTH (NTH U K) J)))                     00049600
       (SETMATELEM U K J TEMP)                                          00049610
       (SETQ J (ADD1 J))                                                00049620
       (GO L3A)                                                         00049630
    COMP (SETQ I (ADD1 K))                                              00049640
       (SETQ AAK (NTH (NTH U K) K))                                     00049650
    COMP1                                                               00049660
       (COND ((GREATERP I M) (GO EV)))                                  00049670
       (SETQ CI1                                                        00049680
             (MULTSQ (ADDSQ (MULTSQ (NTH (NTH U K1) K)                  00049690
                              (NTH (NTH U I) K1))                       00049700
                        (NEGSQ (MULTSQ AA1 (NTH (NTH U I) K))))         00049710
                    AA))                                                00049720
       (SETQ CI2                                                        00049730
             (MULTSQ (ADDSQ (MULTSQ (NTH (NTH U K) K1)                  00049740
                              (NTH (NTH U I) K))                        00049750
                        (NEGSQ                                          00049760
                         (MULTSQ AAK (NTH (NTH U I) K1))))              00049770
                    AA))                                                00049780
       (SETQ J (ADD1 K))                                                00049790
    COMP2                                                               00049800
       (COND ((GREATERP J N) (GO COMP3)))                               00049810
       (SETMATELEM U                                                    00049820
                  I                                                     00049830
                  J                                                     00049840
                 (MULTSQ                                                00049850
                  (ADDSQ (MULTSQ (NTH (NTH U I) J) C0)                  00049860
                       (ADDSQ                                           00049870
                        (MULTSQ (NTH (NTH U K) J) CI1)                  00049880
                        (MULTSQ (NTH (NTH U K1) J) CI2)))               00049890
                  AA))                                                  00049900
       (SETQ J (ADD1 J))                                                00049910
       (GO COMP2)                                                       00049920
    COMP3                                                               00049930
       (SETQ I (ADD1 I))                                                00049940
       (GO COMP1)                                                       00049950
    EV   (SETMATELEM U K K C0)                                          00049960
       (SETQ J (ADD1 K))                                                00049970
    EV1  (COND ((GREATERP J N) (GO BOT)))                               00049980
       (SETMATELEM U                                                    00049990
                  K                                                     00050000
                  J                                                     00050010
                 (MULTSQ (ADDSQ (MULTSQ AA1 (NTH (NTH U K) J))          00050020
                            (NEGSQ                                      00050030
                             (MULTSQ                                    00050040
                              (NTH (NTH U K) K1)                        00050050
                              (NTH (NTH U K1) J))))                     00050060
                        AA))                                            00050070
       (SETQ J (ADD1 J))                                                00050080
       (GO EV1)                                                         00050090
    BOT  (SETQ K (ADD1 (ADD1 K)))                                       00050100
       (GO BEG)                                                         00050110
    FB   (COND ((EQUAL (NTH (NTH U M) M) (CONS NIL 1)) (GO SING)))      00050120
       (RETURN U)                                                       00050130
    SING (COND                                                          00050140
        ((NULL V)                                                       00050150
         (RETURN (PROG2 (SETMATELEM U N N (CONS NIL 1)) U))))           00050160
       (REDERR (QUOTE (SINGULAR MATRIX))))))                            00050170
                                                                        00050180
))                                                                      00050190
                                                                        00050200
DEFINE ((                                                               00050210
                                                                        00050220
(BACKSUB (LAMBDA (U M N)                                                00050230
   (PROG (DET IJ I J JJ SUM)                                            00050240
       (SETQ DET (NTH (NTH U M) M))                                     00050250
       (SETQ J (ADD1 M))                                                00050260
    ROWM (COND ((GREATERP J N) (GO ROWS)))                              00050270
       (SETMATELEM U                                                    00050280
                  M                                                     00050290
                  J                                                     00050300
                 (CANCEL (MULTSQ (NTH (NTH U M) J) (REVPR DET))))       00050310
       (SETQ J (ADD1 J))                                                00050320
       (GO ROWM)                                                        00050330
    ROWS (SETQ IJ 1)                                                    00050340
    ROWS1                                                               00050350
       (COND ((GREATERP IJ (SUB1 M)) (GO DONE)))                        00050360
       (SETQ I (DIFFERENCE M IJ))                                       00050370
       (SETQ JJ (ADD1 M))                                               00050380
    ROWS2                                                               00050390
       (COND ((GREATERP JJ N) (GO ROWS5)))                              00050400
       (SETQ J (ADD1 I))                                                00050410
       (SETQ DET (NTH (NTH U I) I))                                     00050420
       (SETQ SUM (CONS NIL 1))                                          00050430
    ROWS3                                                               00050440
       (COND ((GREATERP J M) (GO ROWS4)))                               00050450
       (SETQ SUM                                                        00050460
             (ADDSQ SUM                                                 00050470
          (CANCEL (MULTSQ (NTH (NTH U I) J) (NTH (NTH U J) JJ)))))      00050480
       (SETQ J (ADD1 J))                                                00050490
       (GO ROWS3)                                                       00050500
    ROWS4                                                               00050510
       (SETMATELEM U                                                    00050520
                  I                                                     00050530
                  JJ                                                    00050540
                 (CANCEL                                                00050550
                  (MULTSQ (ADDSQ (NTH (NTH U I) JJ) (NEGSQ SUM))        00050560
                        (REVPR DET))))                                  00050570
       (SETQ JJ (ADD1 JJ))                                              00050580
       (GO ROWS2)                                                       00050590
    ROWS5                                                               00050600
       (SETQ IJ (ADD1 IJ))                                              00050610
       (GO ROWS1)                                                       00050620
    DONE (RETURN U))))                                                  00050630
                                                                        00050640
))                                                                      00050650
                                                                        00050660
DEFINE ((                                                               00050670
                                                                        00050680
(RHSIDE (LAMBDA (U M)                                                   00050690
   (COND ((NULL U) NIL)                                                 00050700
       (T (CONS (RHSIDE1 (CAR U) M) (RHSIDE (CDR U) M))))))             00050710
                                                                        00050720
))                                                                      00050730
                                                                        00050740
DEFINE ((                                                               00050750
                                                                        00050760
(RHSIDE1 (LAMBDA (U M)                                                  00050770
   (PROG NIL                                                            00050780
    A    (COND ((EQUAL M 0) (RETURN U)))                                00050790
       (SETQ U (CDR U))                                                 00050800
       (SETQ M (SUB1 M))                                                00050810
       (GO A))))                                                        00050820
                                                                        00050830
))                                                                      00050840
                                                                        00050850
DEFINE ((                                                               00050860
                                                                        00050870
(GENERATEIDENT (LAMBDA (N)                                              00050880
   (PROG (I K U V)                                                      00050890
       (SETQ I 1)                                                       00050900
       (SETQ V NIL)                                                     00050910
    E    (COND ((GREATERP I N) (GO A)))                                 00050920
       (SETQ U NIL)                                                     00050930
       (SETQ K 1)                                                       00050940
    C    (COND ((GREATERP K N) (GO D)) ((EQUAL K I) (GO B)))            00050950
       (SETQ U (CONS (CONS NIL 1) U))                                   00050960
       (SETQ K (ADD1 K))                                                00050970
       (GO C)                                                           00050980
    B    (SETQ U (CONS (CONS 1 1) U))                                   00050990
       (SETQ K (ADD1 K))                                                00051000
       (GO C)                                                           00051010
    D    (SETQ I (ADD1 I))                                              00051020
       (SETQ V (CONS U V))                                              00051030
       (GO E)                                                           00051040
    A    (RETURN V))))                                                  00051050
                                                                        00051060
(*MATINV (LAMBDA (U V)                                                  00051070
   (PROG (A B M N X)                                                    00051080
       (SETQ A U)                                                       00051090
      (SETQ X SUBFG*)                                                   00051092
      (SETQ SUBFG* NIL)                                                 00051094
       (SETQ M (LENGTH A))                                              00051100
       (SETQ N (LENGTH (CAR A)))                                        00051110
       (COND                                                            00051120
        ((NOT (EQUAL M N)) (REDERR (QUOTE (NON SQUARE MATRIX)))))       00051130
       (SETQ B (COND (V V) (T (GENERATEIDENT M))))                      00051140
       (COND                                                            00051150
        ((AND V (NOT (EQUAL M (LENGTH B))))                             00051160
         (REDERR (QUOTE (EQUATION MISMATCH)))))                         00051170
       (SETQ A (AUGMENT A B))                                           00051180
       (SETQ N (LENGTH (CAR A)))                                        00051190
       (SETQ A (LIPSON A M N T))                                        00051200
       (SETQ A (BACKSUB A M N))                                         00051210
      (SETQ SUBFG* X)                                                   00051212
         (RETURN (MAPC2 (RHSIDE A M) (FUNCTION                          00051220
                         (LAMBDA (J) (SIMP (PREPSQ J)))))))))           00051221
                                                                        00051230
))                                                                      00051240
                                                                        00051250
DEFINE ((                                                               00051260
                                                                        00051270
(SIMPDET (LAMBDA (U)                                                    00051280
   (SIMPDET1 U T)))                                                     00051290
                                                                        00051300
(SIMPTRACE (LAMBDA (U)                                                  00051310
   (SIMPDET1 U NIL)))                                                   00051320
                                                                        00051330
(SIMPDET1 (LAMBDA (U V)                                                 00051340
   (PROG (N)                                                            00051350
       (COND                                                            00051360
        ((AND (NOT (EQCAR (CAR U) (QUOTE *COMMA*)))                     00051370
            (NOT (MATEXPR (CAR U))))                                    00051380
         (REDERR (QUOTE (MATRIX EXPRESSION REQUIRED)))))                00051390
       (SETQ U                                                          00051400
             (COND                                                      00051410
            ((EQCAR (CAR U) (QUOTE *COMMA*))                            00051420
             (MAPCAR U                                                  00051430
                   (FUNCTION                                            00051440
                    (LAMBDA(J)                                          00051450
                     (MAPCAR                                            00051460
                      (COND                                             00051470
                       ((EQCAR J (QUOTE *COMMA*)) (CDR J))              00051480
                       (T J))                                           00051490
                      (FUNCTION SIMP))))))                              00051500
            (T (MATSIMP (MSIMP (CARX U) T)))))                          00051510
       (COND                                                            00051520
        ((NOT (EQUAL (LENGTH U) (LENGTH (CAR U))))                      00051530
         (REDERR (QUOTE (NON SQUARE MATRIX)))))                         00051540
       (COND (V (RETURN (DETQ U))))                                     00051550
       (SETQ N 1)                                                       00051560
       (SETQ V (CONS NIL 1))                                            00051570
    A    (COND ((NULL U) (RETURN V)))                                   00051580
       (SETQ V (ADDSQ (NTH (CAR U) N) V))                               00051590
       (SETQ U (CDR U))                                                 00051600
       (SETQ N (ADD1 N))                                                00051610
       (GO A))))                                                        00051620
                                                                        00051630
(SIMPDET* (LAMBDA (U)                                                   00051640
   (MAPC2 U (FUNCTION SIMP))))                                          00051650
                                                                        00051660
(SIMPMAT (LAMBDA (U)                                                    00051670
   (REDERR (QUOTE (MATRIX MISMATCH)))))                                 00051680
                                                                        00051690
))                                                                      00051700
                                                                        00051710
DEFLIST (((DET SIMPDET) (TRACE SIMPTRACE) (MAT SIMPMAT)) SIMPFN)        00051720
                                                                        00051730
DEFINE ((                                                               00051740
                                                                        00051750
(DETQ (LAMBDA (U)                                                       00051760
   (PROG (V X)                                                          00051770
      (SETQ X SUBFG*)                                                   00051772
      (SETQ SUBFG* NIL)                                                 00051774
      (SETQ V (LENGTH U))                                               00051776
      (SETQ V (NTH (NTH (LIPSON U V V NIL) V) V))                       00051777
      (SETQ SUBFG* X)                                                   00051778
         (RETURN (SIMP (PREPSQ V))))))                                  00051779
                                                                        00051780
))                                                                      00051790
                                                                        00051800
DEFLIST (((CONS SIMPDOT)) SIMPFN)                                       00051810
                                                                        00051820
FLAG ((CONS) VOP)                                                       00051830
                                                                        00051840
DEFINE ((                                                               00051870
                                                                        00051880
(VOP (LAMBDA (U)                                                        00051890
   (FLAG U (QUOTE VOP))))                                               00051900
                                                                        00051910
(VECTORP (LAMBDA (U)                                                    00051920
   (AND (ATOM U)                                                        00051930
      (NOT (NUMBERP U))                                                 00051940
      (OR (FLAGP U (QUOTE MASS))                                        00051950
          (FLAGP U (QUOTE VECTOR))                                      00051960
          (MEMBER U INDICES*)))))                                       00051970
                                                                        00051980
(ISIMPQ (LAMBDA (U)                                                     00051990
   (CONS (ISIMP (CAR U)) (CDR U))))                                     00052000
                                                                        00052010
(ISIMP (LAMBDA (U)                                                      00052020
   (COND                                                                00052030
      ((OR (NULL SUBFG*)                                                00052035
      (AND (NULL INDICES*)                                              00052040
        (NULL GAMIDEN*)                                                 00052050
          (NULL (GET (QUOTE EPS) (QUOTE KLIST)))))                      00052060
     U)                                                                 00052070
    (T (ISIMP1 U INDICES* NIL NIL NIL)))))                              00052080
                                                                        00052090
(ISIMP1 (LAMBDA (U I V W X)                                             00052100
   (COND                                                                00052110
    ((ATOM U)                                                           00052120
     (COND                                                              00052130
      ((OR V X) (REDERR (APPEND (QUOTE (UNMATCHED INDEX ERROR)) I)))    00052140
      (W (MULTF (EMULT W) (ISIMP1 U I V NIL X)))                        00052150
      (T U)))                                                           00052160
    (T                                                                  00052170
     (ADDF (ISIMP2 (CAR U) I V W X)                                     00052180
         (COND ((NULL (CDR U)) NIL)                                     00052190
             (T (ISIMP1 (CDR U) I V W X))))))))                         00052200
                                                                        00052210
(ISIMP2 (LAMBDA (U I V W X)                                             00052220
   (PROG (Z)                                                            00052230
       (COND ((ATOM (SETQ Z (CAAR U))) (GO A))                          00052240
             ((AND (EQ (CAR Z) (QUOTE CONS)) (XN (CDR Z) I))            00052250
            (RETURN (DOTSUM U I V W X)))                                00052260
             ((EQ (CAR Z) (QUOTE G)) (RETURN (SPUR0 U I V W X)))        00052270
             ((EQ (CAR Z) (QUOTE EPS)) (RETURN (ESUM U I V W X))))      00052280
    A    (RETURN (MULTF2 (CAR U) (ISIMP1 (CDR U) I V W X))))))          00052290
                                                                        00052300
(DOTSUM (LAMBDA (U I V W X)                                             00052310
   (PROG (I1 N U1 U2 V1 Y Z)                                            00052320
       (SETQ N (CDAR U))                                                00052330
       (COND                                                            00052340
        ((NOT (MEMBER (CAR (SETQ U1 (CDAAR U))) I))                     00052350
         (SETQ U1 (REVERSE U1))))                                       00052360
       (SETQ U2 (CADR U1))                                              00052370
       (SETQ U1 (CAR U1))                                               00052380
       (SETQ V1 (CDR U))                                                00052390
       (COND ((EQUAL N 2) (GO H)) ((NOT (ONEP N)) (REDERR U)))          00052400
    A    (COND                                                          00052410
        ((NOT (MEMBER U1 I))                                            00052420
         (RETURN (MULTF (MKDOT U1 U2) (ISIMP1 V1 I1 V W X)))))          00052430
    A1   (SETQ I1 (DELETE U1 I))                                        00052440
       (COND ((EQ U1 U2) (RETURN (MULTN 4 (ISIMP1 V1 I1 V W X))))       00052450
             ((NOT (SETQ Z (ASSOC U1 V))) (GO C))                       00052460
             ((MEMBER U2 I) (GO D)))                                    00052470
       (SETQ U1 (CDR Z))                                                00052480
       (GO E)                                                           00052490
    C    (COND                                                          00052500
        ((SETQ Z (MEMLIS U1 X))                                         00052510
         (RETURN                                                        00052520
          (SPUR0 (CONS (CONS (CONS (QUOTE G) (SUBST U2 U1 Z)) 1)        00052530
                    V1)                                                 00052540
                I1                                                      00052550
                V                                                       00052560
                W                                                       00052570
               (DELETE Z X))))                                          00052580
        ((SETQ Z (MEMLIS U1 W))                                         00052590
         (RETURN                                                        00052600
          (ESUM (CONS (CONS (CONS (QUOTE EPS) (SUBST U2 U1 Z)) 1)       00052610
                   V1)                                                  00052620
               I1                                                       00052630
               V                                                        00052640
              (DELETE Z W)                                              00052650
               X)))                                                     00052660
        ((AND (MEMBER U2 I) (NULL Y)) (GO G)))                          00052670
       (RETURN (ISIMP1 V1 I (CONS (CONS U1 U2) V) W X))                 00052680
    D    (SETQ U1 U2)                                                   00052690
       (SETQ U2 (CDR Z))                                                00052700
    E    (SETQ I I1)                                                    00052710
       (SETQ V (DELETE Z V))                                            00052720
       (GO A)                                                           00052730
    G    (SETQ Y T)                                                     00052740
       (SETQ Z U1)                                                      00052750
       (SETQ U1 U2)                                                     00052760
       (SETQ U2 Z)                                                      00052770
       (GO A1)                                                          00052780
    H    (COND ((EQ U1 U2) (REDERR U)))                                 00052790
       (SETQ I (DELETE U1 I))                                           00052800
       (SETQ U1 U2)                                                     00052810
       (GO A))))                                                        00052820
                                                                        00052830
))                                                                      00052840
                                                                        00052850
DEFINE ((                                                               00052860
                                                                        00052870
(VMULT (LAMBDA (U)                                                      00052880
   (PROG (Z)                                                            00052890
       (SETQ U                                                          00052900
             (REVERSE                                                   00052910
            (MAPCAR U (FUNCTION (LAMBDA (J) (MSIMP J NIL))))))          00052920
    A    (COND ((NULL U) (RETURN Z))                                    00052930
             ((NULL Z) (SETQ Z (CAR U)))                                00052940
             (T (SETQ Z (VMULT1 (CAR U) Z))))                           00052950
       (SETQ U (CDR U))                                                 00052960
       (GO A))))                                                        00052970
                                                                        00052980
(VMULT1 (LAMBDA (U *S1*)                                                00052990
   (COND ((NULL *S1*) NIL)                                              00053000
       (T                                                               00053010
        (MAPCON U                                                       00053020
              (FUNCTION                                                 00053030
               (LAMBDA(*S*)                                             00053040
                (MAPCAR *S1*                                            00053050
                      (FUNCTION                                         00053060
                       (LAMBDA(J)                                       00053070
                        (CONS (MULTSQ (CAAR *S*) (CAR J))               00053080
                            (APPEND (CDAR *S*)                          00053090
                                  (CDR J)))))))))))))                   00053100
                                                                        00053110
))                                                                      00053120
                                                                        00053130
DEFINE ((                                                               00053140
                                                                        00053150
(SIMPDOT (LAMBDA (U)                                                    00053160
   (COND ((CDDR U) (ERRACH (LIST (QUOTE SIMPDOT) U)))                   00053170
       (T                                                               00053180
        (MKVARG U                                                       00053190
              (FUNCTION                                                 00053200
               (LAMBDA(J)                                               00053210
                (MKSQ (CONS (QUOTE CONS) (ORD2 (CAR J) (CADR J)))       00053220
                     1))))))))                                          00053230
                                                                        00053240
(MKVARG (LAMBDA (U *PI*)                                                00053250
   (PROG (Z)                                                            00053260
       (SETQ U (VMULT U))                                               00053270
       (SETQ Z (CONS NIL 1))                                            00053280
    A    (COND ((NULL U) (RETURN Z)))                                   00053290
       (SETQ Z (ADDSQ (MULTSQ (*PI* (CDAR U)) (CAAR U)) Z))             00053300
       (SETQ U (CDR U))                                                 00053310
       (GO A))))                                                        00053320
                                                                        00053330
(MKDOT (LAMBDA (U V)                                                    00053340
   (MKSF (CONS (QUOTE CONS) (ORD2 U V)) 1)))                            00053350
                                                                        00053360
(VLET (LAMBDA (U V B)                                                   00053370
  (PROG2                                                                00053375
         (AND B (FLAGP U (QUOTE USED*)) (RMSUBS2))                      00053380
         (SETQ VREP* (XADD (CONS U V)  VREP* U B)))))                   00053385
                                                                        00053390
))                                                                      00053400
                                                                        00053410
DEFINE ((                                                               00053420
                                                                        00053430
(INDEX (LAMBDA (U)                                                      00053440
   (SETQ INDICES* (UNION INDICES* U))))                                 00053450
                                                                        00053460
(REMIND (LAMBDA (U)                                                     00053470
   (PROG2 (VECTOR U) (SETQ INDICES* (SETDIFF INDICES* U)))))            00053480
                                                                        00053490
(MASS (LAMBDA (U)                                                       00053500
   (COND ((NULL U) NIL)                                                 00053510
       (T                                                               00053520
        (PROG2 (PUT (CADAR U) (QUOTE MASS) (CADDAR U))                  00053530
             (MASS (CDR U)))))))                                        00053540
                                                                        00053550
(MSHELL (LAMBDA (U)                                                     00053560
   (PROG (X Z)                                                          00053570
    A    (COND ((NULL U) (RETURN (LET Z))))                             00053580
       (SETQ X (GETMAS (CAR U)))                                        00053590
       (SETQ Z                                                          00053600
             (CONS (LIST (QUOTE EQUAL)                                  00053610
                     (LIST (QUOTE CONS) (CAR U) (CAR U))                00053620
                     (LIST (QUOTE TIMES) X X))                          00053630
                  Z))                                                   00053640
       (SETQ U (CDR U))                                                 00053650
       (GO A))))                                                        00053660
                                                                        00053670
(GETMAS (LAMBDA (U)                                                     00053680
   ((LAMBDA(X)                                                          00053690
     (COND (X X) (T (REDERR (CONS U (QUOTE (HAS NO MASS)))))))          00053700
    (GET* U (QUOTE MASS)))))                                            00053710
                                                                        00053720
(VECTOR (LAMBDA (U)                                                     00053730
   (FLAG U (QUOTE VECTOR))))                                            00053740
                                                                        00053750
))                                                                      00053760
                                                                        00053770
DEFINE ((                                                               00053780
                                                                        00053790
(VCREP (LAMBDA (U)                                                      00053800
   ((LAMBDA(X)                                                          00053810
     (COND                                                              00053820
      ((AND SUBFG* (NOT (EQUAL X (CAR U))))                             00053830
       (NCONC U (LIST (LIST (QUOTE REP) X 1 NIL NIL))))                 00053840
      (T NIL)))                                                         00053850
    (SUBLIS VREP* (CAR U)))))                                           00053860
                                                                        00053870
))                                                                      00053880
                                                                        00053890
DEFLIST (((MSHELL RLIS) (MASS RLIS) (INDEX RLIS) (REMIND RLIS) (VECTOR  00053900
 RLIS) (VOP RLIS)) STAT)                                                00053910
                                                                        00053920
FLAG ((EPS) VOP)                                                        00053950
                                                                        00053960
DEFLIST (((G SIMPGAMMA) (EPS SIMPEPS)) SIMPFN)                          00053970
                                                                        00053980
FLAG ((G) NONCOM)                                                       00053990
                                                                        00054000
DEFLIST (((G GMULT)) MRULE)                                             00054010
                                                                        00054020
DEFINE ((                                                               00054030
                                                                        00054040
(GMULT (LAMBDA (U V)                                                    00054050
   (COND                                                                00054060
    ((OR (NOT (EQUAL (CDR U) 1)) (NOT (EQUAL (CDR V) 1)))               00054070
     (ERRACH (LIST (QUOTE GMULT) U V)))                                 00054080
    ((NOT (EQ (CADAR U) (CADAR V))) (QUOTE FAILED))                     00054090
    (T (GCHECK (REVERSE (CDDAR U)) (CDDAR V) (CADAR U))))))             00054100
                                                                        00054110
(NONCOM (LAMBDA (U)                                                     00054120
   (FLAG U (QUOTE NONCOM))))                                            00054130
                                                                        00054140
))                                                                      00054150
                                                                        00054160
DEFINE ((                                                               00054170
                                                                        00054180
(SPUR (LAMBDA (U)                                                       00054190
   (PROG2 (RMSUBS)                                                      00054200
        (MAP U                                                          00054210
             (FUNCTION                                                  00054220
            (LAMBDA(J)                                                  00054230
                 (PROG2 (REMFLAG (LIST (CAR J)) (QUOTE NOSPUR))         00054240
                        (REMFLAG (LIST (CAR J)) (QUOTE REDUCE)))))))))  00054250
                                                                        00054260
(NOSPUR (LAMBDA (U)                                                     00054270
   (FLAG U (QUOTE NOSPUR))))                                            00054280
                                                                        00054290
(REDUCE (LAMBDA (U)                                                     00054300
   (PROG2 (NOSPUR U) (FLAG U (QUOTE REDUCE)))))                         00054310
                                                                        00054320
(SIMPGAMMA (LAMBDA (*S*)                                                00054330
   (COND                                                                00054340
    ((OR (NULL *S*) (NULL (CDR *S*)))                                   00054350
     (REDERR (QUOTE (MISSING ARGUMENTS FOR G OPERATOR))))               00054360
    (T                                                                  00054370
     (PROG NIL                                                          00054380
         (SETQ GAMIDEN* (UNION (LIST (CAR *S*)) GAMIDEN*))              00054390
         (SETQ *NCMP T)                                                 00054400
         (RETURN                                                        00054410
          (MKVARG (CDR *S*)                                             00054420
                (FUNCTION                                               00054430
                 (LAMBDA(J)                                             00054440
                  (CONS (GCHECK (REVERSE J) NIL (CAR *S*))              00054450
                       1))))))))))                                      00054460
                                                                        00054470
(GCHECK (LAMBDA (U V L)                                                 00054480
   (COND ((EQ (CAR V) (QUOTE A)) (GCHKA U (CDR V) T L))                 00054490
       (T (GCHKV U V T L)))))                                           00054500
                                                                        00054510
(GCHKA (LAMBDA (U V X W)                                                00054520
   (COND ((NULL U) (MULTN (NB X) (MKG (CONS (QUOTE A) V) W)))           00054530
       ((EQ (CAR U) (QUOTE A)) (GCHKV (CDR U) V X W))                   00054540
       (T (GCHKA (CDR U) (CONS (CAR U) V) (NOT X) W)))))                00054550
                                                                        00054560
(GCHKV (LAMBDA (U V X L)                                                00054570
   (COND ((NULL U)                                                      00054580
        (COND ((NULL V) (NB X)) (T (MULTN (NB X) (MKG V L)))))          00054590
       ((EQ (CAR U) (QUOTE A)) (GCHKA (CDR U) V X L))                   00054600
       (T (GCHKV (CDR U) (CONS (CAR U) V) X L)))))                      00054610
                                                                        00054620
(MKG (LAMBDA (U L)                                                      00054630
   (LIST (CONS (CONS (CONS (QUOTE G) (CONS L U)) 1) 1))))               00054640
                                                                        00054650
(MKA (LAMBDA (L)                                                        00054660
   (MKG (LIST (QUOTE A)) L)))                                           00054670
                                                                        00054680
(MKG1 (LAMBDA (U L)                                                     00054690
   (COND                                                                00054700
    ((OR (NOT (FLAGP L (QUOTE NOSPUR)))                                 00054710
       (NULL (CDR U))                                                   00054720
       (CDDR U)                                                         00054730
       (ORDOP (CAR U) (CADR U))                                         00054740
       (EQ (CAR U) (QUOTE A)))                                          00054750
     (MKG U L))                                                         00054760
    (T                                                                  00054770
     (ADDF (MULTN 2 (MKDOT (CAR U) (CADR U)))                           00054780
         (MULTN -1 (MKG (REVERSE U) L)))))))                            00054790
                                                                        00054800
(NB (LAMBDA (U)                                                         00054810
   (COND (U 1) (T -1))))                                                00054820
                                                                        00054830
))                                                                      00054840
                                                                        00054850
DEFINE ((                                                               00054860
                                                                        00054870
(SPUR0 (LAMBDA (U I V1 V2 V3)                                           00054880
   (PROG (L V W I1 Z KAHP)                                              00054890
       (SETQ L (CADAAR U))                                              00054900
       (SETQ V (CDDAAR U))                                              00054910
       (COND ((NOT (ONEP (CDAR U))) (SETQ V (APPN V (CDAR U)))))        00054920
       (SETQ U (CDR U))                                                 00054930
       (COND                                                            00054940
        ((AND (NOT (GET L (QUOTE NOSPUR)))                              00054950
            (OR (AND (EQ (CAR V) (QUOTE A))                             00054960
                   (OR (LESSP (LENGTH V) 5)                             00054970
                       (NOT (EVENP (CDR V)))))                          00054980
                (AND (NOT (EQ (CAR V) (QUOTE A)))                       00054990
                   (NOT (EVENP V)))))                                   00055000
         (RETURN NIL))                                                  00055010
        ((NULL I) (GO END)))                                            00055020
    A    (COND ((NULL V) (GO END1)) ((MEMBER (CAR V) I) (GO B)))        00055030
    A1   (SETQ W (CONS (CAR V) W))                                      00055040
       (SETQ V (CDR V))                                                 00055050
       (GO A)                                                           00055060
    B    (COND ((MEMBER (CAR V) (CDR V)) (GO KAH1))                     00055070
             ((MEMBER (CAR V) I1) (GO A1))                              00055080
             ((SETQ Z (BASSOC (CAR V) V1)) (GO E))                      00055090
             ((SETQ Z (MEMLIS (CAR V) V2))                              00055100
            (RETURN                                                     00055110
             ((LAMBDA(X)                                                00055120
               (COND                                                    00055130
                ((AND (FLAGP L (QUOTE REDUCE))                          00055140
                    (NULL V1)                                           00055150
                    (NULL V3)                                           00055160
                    (NULL (CDR V2)))                                    00055170
                 (MULTF (MKG* X L) (MULTF (MKEPS1 Z) (ISIMP U))))       00055180
                (T                                                      00055190
                 (ISIMP1                                                00055200
                  (SPUR0 (CONS (CAAR (MKG X L)) U)                      00055210
                        NIL                                             00055220
                        V1                                              00055230
                       (DELETE Z V2)                                    00055240
                        V3)                                             00055250
                  I                                                     00055260
                  NIL                                                   00055270
                  (LIST Z)                                              00055280
                  NIL))))                                               00055290
              (APPEND (REVERSE W) V))))                                 00055300
             ((SETQ Z (MEMLIS (CAR V) V3)) (GO C))                      00055310
             (T                                                         00055320
            (RETURN                                                     00055330
             (ISIMP1 U                                                  00055340
                    I                                                   00055350
                    V1                                                  00055360
                    V2                                                  00055370
                   (CONS (CONS L (APPEND (REVERSE W) V))                00055380
                          V3)))))                                       00055390
    C    (SETQ V3 (DELETE Z V3))                                        00055400
       (SETQ KAHP NIL)                                                  00055410
       (COND                                                            00055420
        ((AND (FLAGP L (QUOTE NOSPUR))                                  00055430
            (FLAGP (CAR Z) (QUOTE NOSPUR)))                             00055440
         (ERROR (QUOTE HELP)))                                          00055450
        ((FLAGP (CAR Z) (QUOTE NOSPUR)) (SETQ KAHP (CAR Z))))           00055460
       (SETQ Z (CDR Z))                                                 00055470
       (SETQ I1 NIL)                                                    00055480
    C1   (COND ((EQ (CAR V) (CAR Z)) (GO D)))                           00055490
       (SETQ I1 (CONS (CAR Z) I1))                                      00055500
       (SETQ Z (CDR Z))                                                 00055510
       (GO C1)                                                          00055520
    D    (SETQ Z (CDR Z))                                               00055530
       (SETQ I (DELETE (CAR V) I))                                      00055540
       (SETQ V (CDR V))                                                 00055550
       (COND ((NOT (FLAGP L (QUOTE NOSPUR))) (GO D0)))                  00055560
       (SETQ W (CONS W (CONS V (CONS I1 Z))))                           00055570
       (SETQ I1 (CAR W))                                                00055580
       (SETQ Z (CADR W))                                                00055590
       (SETQ V (CADDR W))                                               00055600
       (SETQ W (CDDDR W))                                               00055610
    D0   (SETQ W (REVERSE W))                                           00055620
       (COND                                                            00055630
        ((AND (OR (NULL V) (NOT (EQ (CAR W) (QUOTE A))))                00055640
            (SETQ V (APPEND V W)))                                      00055650
         (GO D1))                                                       00055660
        ((NOT (EVENP V)) (SETQ U (MULTN -1 U))))                        00055670
       (SETQ V (CONS (QUOTE A) (APPEND V (CDR W))))                     00055680
    D1   (COND (KAHP (SETQ L KAHP)))                                    00055690
       (SETQ VARS* NIL)                                                 00055700
       (SETQ Z (MULTF (MKG (REVERSE I1) L)                              00055710
                 (MULTF (BRACE V L I) (MULTF (MKG1 Z L) U))))           00055720
       (SETQ Z (ISIMP1 Z (APPEND VARS* I) V1 V2 V3))                    00055730
       (COND ((NULL Z) (RETURN Z))                                      00055780
             ((NULL (SETQ Z (QUOTF Z 2)))                               00055790
            (ERRACH (LIST (QUOTE SPUR0) U I V1 V2 V3))))                00055800
       (RETURN Z)                                                       00055810
    E    (SETQ V1 (DELETE Z V1))                                        00055820
       (SETQ I (DELETE (CAR W) I))                                      00055830
       (SETQ V (CONS (OTHER (CAR V) Z) (CDR V)))                        00055840
       (GO A)                                                           00055850
    KAH1 (COND ((EQ (CAR V) (CADR V)) (GO K2)))                         00055860
       (SETQ KAHP T)                                                    00055870
       (SETQ I1 (CONS (CAR V) I1))                                      00055880
       (GO A1)                                                          00055890
    K2   (SETQ I (DELETE (CAR V) I))                                    00055900
       (SETQ V (CDDR V))                                                00055910
       (SETQ U (MULTN 4 U))                                             00055920
       (GO A)                                                           00055930
    END  (SETQ W (REVERSE V))                                           00055940
  END1 (COND (KAHP (GO END2))                                           00055950
             ((NULL (SETQ Z (SPURR W L NIL 1))) (RETURN NIL))           00055960
          (T (RETURN (COND ((AND (GET (QUOTE EPS) (QUOTE KLIST))        00055970
                                  (NOT (FLAGP L (QUOTE NOSPUR))))       00055971
                             (ISIMP1 (MULTF Z U) I V1 V2 V3))           00055972
                         (T (MULTF Z (ISIMP1 U I V1 V2 V3)))))))        00055973
  END2 (SETQ VARS* NIL)                                                 00055980
       (SETQ Z (MULTF (KAHANE (REVERSE W) I1 L) U))                     00055990
       (RETURN (ISIMP1 Z (APPEND VARS* (SETDIFF I I1)) V1 V2 V3)))))    00056000
                                                                        00056040
(APPN (LAMBDA (U N)                                                     00056050
   (COND ((ONEP N) U) (T (APPEND U (APPN U (SUB1 N)))))))               00056060
                                                                        00056070
(OTHER (LAMBDA (U V)                                                    00056080
   (COND ((EQ U (CAR V)) (CDR V)) (T (CAR V)))))                        00056090
                                                                        00056100
))                                                                      00056110
                                                                        00056120
DEFINE ((                                                               00056130
                                                                        00056140
(KAHANE (LAMBDA (U I L)                                                 00056150
   (PROG (K2 LD LU M P V W X Y)                                         00056160
       (SETQ K2 0)                                                      00056170
       (SETQ M 0)                                                       00056180
         (SETQ W (LIST T T NIL))                                        00056190
       (COND ((EQ (CAR U) (QUOTE A)) (GO B)))                           00056200
    A    (COND                                                          00056210
          ((AND (NULL U) (SETQ W (CONS NIL (CONS NIL (CONS NIL W)))))   00056220
         (GO KETJAK))                                                   00056230
        ((MEMBER (CAR U) I) (GO D)))                                    00056240
       (SETQ P (NOT P))                                                 00056250
    B    (SETQ W (CONS (CAR U) W))                                      00056260
    C    (SETQ U (CDR U))                                               00056270
       (GO A)                                                           00056280
   D     (SETQ W (CONS (CAR U) (CONS P (CONS NIL W))))                  00056290
       (SETQ X NIL)                                                     00056300
    KETJAK                                                              00056310
       (SETQ W (REVERSE W))                                             00056320
    TJARUM                                                              00056330
       (COND ((CADR W) (SETQ LU (CONS W LU)))                           00056340
             (T (SETQ LD (CONS W LD))))                                 00056350
       (COND ((NULL U) (GO DJANGER)) (X (GO MAS)))                      00056360
       (SETQ W (REVERSE W))                                             00056370
       (SETQ X T)                                                       00056380
       (GO TJARUM)                                                      00056390
   MAS   (SETQ W (LIST T (SETQ P (NOT P)) (CAR U)))                     00056400
       (SETQ K2 (ADD1 K2))                                              00056410
       (GO C)                                                           00056420
    DJANGER                                                             00056430
       (SETQ LU (REVERSE LU))                                           00056440
    BARUNA                                                              00056450
       (COND ((NULL LU) (GO JAVA)))                                     00056460
       (SETQ V (CAR LU))                                                00056470
       (SETQ LU (CDR LU))                                               00056480
    WAJANG                                                              00056490
         (SETQ X (CONS (CAR V) (CADR V)))                               00056495
         (SETQ P (NULL (CADDR V)))                                      00056500
       (SETQ M (ADD1 M))                                                00056510
       (SETQ W NIL)                                                     00056520
    RINDIK                                                              00056530
       (SETQ Y (REVERSE V))                                             00056540
   R1    (COND ((CADR Y) (SETQ LU (DELETE Y LU)))                       00056545
               (T (SETQ LD (DELETE Y LD))))                             00056550
         (COND ((EQ Y V) (GO RINDIK))                                   00056555
               (P (AND (SETQ V Y)                                       00056560
                        (SETQ X (CONS (CAR V) (CADR V)))                00056565
                        (SETQ P NIL))))                                 00056570
         (SETQ V (CDDDR V))                                             00056575
    BANDJAR                                                             00056580
         (COND ((CDDDR V) (GO SUBAK))                                   00056585
               ((NULL (CADDR V)) (GO WADAH))                            00056590
                ((AND (EQ (CADDR V) (CAR X))                            00056595
                   (EQ (CADR V) (CDR X))) (GO BARIS)))                  00056596
         (SETQ V                                                        00056600
         (SASSOC (CADDR V)                                              00056605
                 (COND ((CADR V) LU) (T LD))                            00056610
                   (FUNCTION                                            00056650
                  (LAMBDA NIL (ERRACH (QUOTE KAHANE))))))               00056660
         (SETQ Y V)                                                     00056670
         (GO R1)                                                        00056680
    SUBAK                                                               00056700
       (SETQ W (CONS (CAR V) W))                                        00056710
       (SETQ V (CDR V))                                                 00056720
       (GO BANDJAR)                                                     00056730
    WADAH                                                               00056740
         (SETQ U (MKG (REVERSE W) L))                                   00056750
       (GO BARUNA)                                                      00056760
    BARIS                                                               00056770
       (COND ((AND W (CDR X)) (SETQ W (NCONC (CDR W) (LIST (CAR W)))))) 00056775
       (SETQ U (MULTF (BRACE W L NIL) U))                               00056780
       (GO BARUNA)                                                      00056790
    JAVA (COND ((NULL LD) (GO HOME)))                                   00056800
       (SETQ V (CAR LD))                                                00056810
       (SETQ LD (CDR LD))                                               00056820
       (GO WAJANG)                                                      00056830
    HOME (SETQ K2 (QUOTIENT K2 2))                                      00056840
       (SETQ X (EXPT 2 K2))                                             00056850
       (COND                                                            00056860
        ((ZEROP (REMAINDER (DIFFERENCE K2 M) 2))                        00056870
         (SETQ X (MINUS X))))                                           00056880
       (RETURN (MULTN X U)))))                                          00056890
                                                                        00056900
(BRACE (LAMBDA (U L I)                                                  00056910
   (COND ((NULL U) 2)                                                   00056920
         ((OR (XN I U) (FLAGP L (QUOTE NOSPUR)))                        00056930
           (ADDF (MKG1 U L) (MKG1 (REVERSE U) L)))                      00056935
       ((EQ (CAR U) (QUOTE A))                                          00056940
           (COND ((EVENP U) (ADDF (MKG U L)                             00056950
                                  (MULTN -1 (MKG (CONS (QUOTE A)        00056952
                                           (REVERSE (CDR U))) L))))     00056954
            (T (MULTF (MKA L) (SPR2 (CDR U) L 2 NIL)))))                00056960
       ((EVENP U) (SPR2 U L 2 NIL))                                     00056970
       (T (SPR1 U L 2 NIL)))))                                          00056980
                                                                        00056990
(SPR1 (LAMBDA (U L N B)                                                 00057000
   (COND ((NULL U) NIL)                                                 00057010
       ((NULL (CDR U)) (MULTN N (MKG1 U L)))                            00057020
       (T                                                               00057030
        (PROG (M X Z)                                                   00057040
            (SETQ X U)                                                  00057050
            (SETQ M 0)                                                  00057060
          A    (COND ((NULL X) (RETURN Z)))                             00057070
            (SETQ Z                                                     00057080
                  (ADDF (MULTF (MKG1 (LIST (CAR X)) L)                  00057090
                           (COND                                        00057100
                            ((NULL B)                                   00057110
                                (SPURR (REMOVE U M) L NIL N))           00057120
                            (T (SPR1 (REMOVE U M) L N NIL))))           00057130
                       Z))                                              00057140
            (SETQ X (CDR X))                                            00057150
            (SETQ N (MINUS N))                                          00057160
            (SETQ M (ADD1 M))                                           00057170
            (GO A))))))                                                 00057180
                                                                        00057190
(SPR2 (LAMBDA (U L N B)                                                 00057200
   (COND ((AND (NULL (CDDR U)) (NULL B))                                00057210
        (MULTN N (MKDOT (CAR U) (CADR U))))                             00057220
       (T                                                               00057230
        ((LAMBDA (X) (COND (B (ADDF (SPR1 U L N B) X)) (T X)))          00057240
           (ADDF (SPURR U L NIL N)                                      00057250
                 (MULTF (MKA L)                                         00057255
              (SPURR (APPEND U (LIST (QUOTE A))) L NIL N))))))))        00057260
                                                                        00057270
(EVENP (LAMBDA (U)                                                      00057410
   (OR (NULL U) (NOT (EVENP (CDR U))))))                                00057420
                                                                        00057430
(BASSOC (LAMBDA (U V)                                                   00057440
   (COND ((NULL V) NIL)                                                 00057450
       ((OR (EQ U (CAAR V)) (EQ U (CDAR V))) (CAR V))                   00057460
       (T (BASSOC U (CDR V))))))                                        00057470
                                                                        00057480
(MEMLIS (LAMBDA (U V)                                                   00057490
   (COND ((NULL V) NIL)                                                 00057500
       ((MEMBER U (CAR V)) (CAR V))                                     00057510
       (T (MEMLIS U (CDR V))))))                                        00057520
                                                                        00057530
))                                                                      00057540
                                                                        00057550
DEFINE ((                                                               00057560
                                                                        00057570
(SPURR (LAMBDA (U L V N)                                                00057580
   (PROG (M W X Y Z)                                                    00057590
    A    (COND ((NULL U) (GO B)) ((MEMBER (CAR U) (CDR U)) (GO G)))     00057600
       (SETQ V (CONS (CAR U) V))                                        00057610
       (SETQ U (CDR U))                                                 00057620
       (GO A)                                                           00057630
    B    (COND ((NULL V) (RETURN N))                                    00057640
             ((FLAGP L (QUOTE NOSPUR))                                  00057650
            (RETURN (MULTN N (MKG* V L))))                              00057660
             (T (RETURN (SPRGEN V N))))                                 00057670
    G    (SETQ X (CAR U))                                               00057680
       (SETQ Y (CDR U))                                                 00057690
       (SETQ W Y)                                                       00057700
       (SETQ M 0)                                                       00057710
    H    (COND                                                          00057720
        ((EQ X (CAR W))                                                 00057730
         (RETURN                                                        00057740
          (ADDF (MULTF (MKDOT X X) (SPURR (DELETE X Y) L V N))          00057750
               Z))))                                                    00057760
       (SETQ Z                                                          00057770
             (ADDF (MULTF (MKDOT X (CAR W))                             00057780
                      (SPURR (REMOVE Y M) L V (TIMES 2 N)))             00057790
                  Z))                                                   00057800
       (SETQ W (CDR W))                                                 00057810
       (SETQ N (MINUS N))                                               00057820
       (SETQ M (ADD1 M))                                                00057830
       (GO H))))                                                        00057840
                                                                        00057850
(SPRGEN (LAMBDA (V N)                                                   00057860
   (PROG (X Z)                                                          00057870
       (COND                                                            00057880
        ((NOT (EQ (CAR V) (QUOTE A))) (RETURN (SPRGEN1 V N)))           00057890
        ((NULL (SETQ X (COMB1 (SETQ V (CDR V)) 4 NIL)))                 00057900
         (RETURN NIL))                                                  00057910
        ((NULL (CDR X)) (GO E)))                                        00057920
    C    (COND ((NULL X) (RETURN (MULTF2 (MKSP (QUOTE I) 1) Z))))       00057930
       (SETQ Z                                                          00057940
              (ADDF (MULTN (ASIGN (CAR X) V N)                          00057950
                      (MULTF (MKEPS1 (CAR X))                           00057960
                           (SPRGEN1 (SETDIFF V (CAR X)) 1)))            00057970
                  Z))                                                   00057980
    D    (SETQ X (CDR X))                                               00057990
       (GO C)                                                           00058000
    E    (SETQ Z (MULTN N (MKEPS1 (CAR X))))                            00058010
       (GO D))))                                                        00058020
                                                                        00058030
(ASIGN (LAMBDA (U V N)                                                  00058031
  (COND ((NULL U) N)                                                    00058032
   (T (ASIGN (CDR U) V (TIMES (ASIGN1 (CAR U) V -1) N))))))             00058033
                                                                        00058034
(ASIGN1 (LAMBDA (U V N)                                                 00058035
  (COND ((NULL V) (ERROR (QUOTE ARG)))                                  00058036
   ((EQ U (CAR V)) N)                                                   00058037
   (T (ASIGN1 U (CDR V) (MINUS N))))))                                  00058038
                                                                        00058039
(SPRGEN1 (LAMBDA (U N)                                                  00058040
   (COND ((NULL U) NIL)                                                 00058050
       ((NULL (CDDR U)) (MULTN N (MKDOT (CAR U) (CADR U))))             00058060
       (T                                                               00058070
        (PROG (W X Y Z)                                                 00058080
            (SETQ X (CAR U))                                            00058090
            (SETQ U (CDR U))                                            00058100
            (SETQ Y U)                                                  00058110
          A    (COND ((NULL U) (RETURN Z))                              00058120
                  ((NULL (SETQ W (MKDOT X (CAR U)))) (GO B)))           00058130
            (SETQ Z                                                     00058140
                  (ADDF (MULTF W (SPRGEN1 (DELETE (CAR U) Y) N))        00058150
                       Z))                                              00058160
          B    (SETQ N (MINUS N))                                       00058170
            (SETQ U (CDR U))                                            00058180
            (GO A))))))                                                 00058190
                                                                        00058200
(COMB1 (LAMBDA (U N V)                                                  00058210
   ((LAMBDA(M)                                                          00058220
     (COND ((ONEP N)                                                    00058230
          (APPEND V (MAPCAR U (FUNCTION (LAMBDA (J) (LIST J))))))       00058240
         ((MINUSP M) NIL)                                               00058250
         ((ZEROP M) (CONS U V))                                         00058260
         (T                                                             00058270
          (COMB1 (CDR U)                                                00058280
                N                                                       00058290
               (APPEND V                                                00058300
                     (MAPCONS (COMB1 (CDR U) (SUB1 N) NIL)              00058310
                            (CAR U)))))))                               00058320
    (DIFFERENCE (LENGTH U) N))))                                        00058330
                                                                        00058340
))                                                                      00058350
                                                                        00058360
DEFINE ((                                                               00058370
                                                                        00058380
(SIMPEPS (LAMBDA (U)                                                    00058390
   (MKVARG U                                                            00058400
         (FUNCTION                                                      00058410
          (LAMBDA(J)                                                    00058420
           (CONS (COND ((REPEATS J) NIL) (T (MKEPS1 J))) 1))))))        00058430
                                                                        00058440
(MKEPS1 (LAMBDA (U)                                                     00058450
   ((LAMBDA(X)                                                          00058460
     (MULTN (NB (PERMP X U)) (MKSF (CONS (QUOTE EPS) X) 1)))            00058470
    (ORDN U))))                                                         00058480
                                                                        00058490
(PERMP (LAMBDA (U V)                                                    00058500
   (COND ((NULL U) T)                                                   00058510
       ((EQ (CAR U) (CAR V)) (PERMP (CDR U) (CDR V)))                   00058520
       (T (NOT (PERMP (CDR U) (SUBST (CAR V) (CAR U) (CDR V))))))))     00058530
                                                                        00058540
))                                                                      00058550
                                                                        00058560
DEFINE ((                                                               00058570
                                                                        00058580
(ESUM (LAMBDA (U I V W XX)                                              00058590
   (PROG (X Y Z)                                                        00058600
       (SETQ X (CAR U))                                                 00058610
       (SETQ U (CDR U))                                                 00058620
       (COND                                                            00058630
        ((NOT (ONEP (CDR X)))                                           00058640
         (SETQ U                                                        00058650
             (MULTF (NMULTF (MKEPS1 (CDAR X)) (SUB1 (CDR X)))           00058660
                   U))))                                                00058670
       (SETQ X (CDAR X))                                                00058680
    A    (COND ((REPEATS X) (RETURN NIL)))                              00058690
    B    (COND ((NULL X)                                                00058700
            (RETURN (ISIMP1 U I V (CONS (REVERSE Y) W) XX)))            00058710
             ((NOT (MEMBER (CAR X) I)) (GO D))                          00058720
             ((NOT (SETQ Z (BASSOC (CAR X) V))) (GO C)))                00058730
       (SETQ V (DELETE Z V))                                            00058740
       (SETQ I (DELETE (CAR X) I))                                      00058750
       (SETQ X                                                          00058760
             (APPEND (REVERSE Y) (CONS (OTHER (CAR X) Z) (CDR X))))     00058770
       (SETQ Y NIL)                                                     00058780
       (GO A)                                                           00058790
    C    (COND ((SETQ Z (MEMLIS (CAR X) W)) (GO C1))                    00058800
             ((SETQ Z (MEMLIS (CAR X) XX))                              00058810
            (RETURN                                                     00058820
             (SPUR0 (CONS (CONS (CONS (QUOTE G) Z) 1) U)                00058830
                   I                                                    00058840
                   V                                                    00058850
                  (CONS (APPEND (REVERSE Y) X) W)                       00058860
                  (DELETE Z XX)))))                                     00058870
       (RETURN (ISIMP1 U I V (CONS (APPEND (REVERSE Y) X) W) XX))       00058880
    C1   (SETQ X (APPEND (REVERSE Y) X))                                00058890
       (SETQ Y (XN I (XN X Z)))                                         00058900
       (RETURN                                                          00058910
        (ISIMP1 (MULTF (EMULT1 Z X Y) U)                                00058920
              (SETDIFF I Y)                                             00058930
               V                                                        00058940
              (DELETE Z W)                                              00058950
               XX))                                                     00058960
    D    (SETQ Y (CONS (CAR X) Y))                                      00058970
       (SETQ X (CDR X))                                                 00058980
       (GO B))))                                                        00058990
                                                                        00059000
(EMULT (LAMBDA (U)                                                      00059010
   (COND ((NULL (CDR U)) (MKEPS1 (CAR U) 1))                            00059020
       ((NULL (CDDR U)) (EMULT1 (CAR U) (CADR U) NIL))                  00059030
       (T (MULTF (EMULT1 (CAR U) (CADR U) NIL) (EMULT (CDDR U)))))))    00059040
                                                                        00059050
(EMULT1 (LAMBDA (U V I)                                                 00059060
   ((LAMBDA(X *S*)                                                      00059070
     ((LAMBDA(M N)                                                      00059080
       (COND ((EQUAL M 4) (TIMES 6 (TIMES 4 N)))                        00059090
           ((EQUAL M 3)                                                 00059100
            (MULTN (TIMES 6 N) (MKDOT (CAR X) (CAR *S*))))              00059110
           (T                                                           00059120
            (MULTN (TIMES N (COND ((ZEROP M) 1) (T M)))                 00059130
                 (CAR                                                   00059140
                  (DETQ                                                 00059150
                   (MAPLIST X                                           00059160
                        (FUNCTION                                       00059170
                         (LAMBDA(*S1*)                                  00059180
                          (MAPLIST *S*                                  00059190
                                 (FUNCTION                              00059200
                                  (LAMBDA                               00059210
                                   (J)                                  00059220
                                   (CONS                                00059230
                                    (MKDOT                              00059240
                                     (CAR *S1*)                         00059250
                                     (CAR J))                           00059260
                                    1)))))))))))))                      00059270
      (LENGTH I)                                                        00059280
 ((LAMBDA (J) (NB(COND((PERMP U (APPEND I X)) (NOT J)) (T J))))         00059290
       (PERMP V (APPEND I *S*)))))                                      00059300
    (SETDIFF U I)                                                       00059310
    (SETDIFF V I))))                                                    00059320
                                                                        00059330
))                                                                      00059340
                                                                        00059350
DEFLIST (((NONCOM RLIS) (SPUR RLIS) (NOSPUR RLIS) (REDUCE RLIS)) STAT)  00059360
                                                                        00059370
                                                                        00059380
PTS (NOCMP* T)                                                          00059381
DEFINE ((                                                               00059390
                                                                        00059400
(MKG* (LAMBDA (U L)                                                     00059410
   (COND ((NULL U) 1)                                                   00059420
       ((NOT (FLAGP L (QUOTE REDUCE))) (MKG1 U L))                      00059430
       ((LESSP (LENGTH U) 3) (MKG1 U L))                                00059440
       ((AND (EQCAR U (QUOTE A)) (EQUAL (LENGTH U) 3))                  00059450
        ((LAMBDA(Y)                                                     00059460
          (PROG2 (SETQ INDICES* (APPEND Y INDICES*))                    00059470
               (ADDF (MULTF (MKA L) (MKDOT (CADR U) (CADDR U)))         00059480
                   (MULTF2 (MKSP (QUOTE I) 1)                           00059490
                         (MULTF (MKG1 Y L)                              00059500
                              (MKEPS1                                   00059510
                               (APPEND (CDR U) Y)))))))                 00059520
         (LIST (GENSYM) (GENSYM))))                                     00059530
       (T (RED* U L)))))                                                00059540
                                                                        00059550
(RED* (LAMBDA (U L)                                                     00059560
   (PROG (I X)                                                          00059570
       (SETQ X (ACONC (EXPLODE L) (QUOTE I)))                           00059580
       (SETQ I                                                          00059590
             (LIST (COMPRESS (APPEND X (QUOTE (1))))                    00059600
                 (COMPRESS (APPEND X (QUOTE (2))))))                    00059610
       (SETQ X (LIST (QUOTE A) (CAR I)))                                00059620
       (RETURN                                                          00059630
        (ADDF (SPURR NIL (QUOTE ***) U 3)                               00059640
            (ADDF (MULTF (MKG (QUOTE (A)) L)                            00059650
                       (ISIMP1                                          00059660
                        (GCHECK (QUOTE (A)) U (QUOTE ***))              00059670
                        NIL                                             00059680
                        NIL                                             00059690
                        NIL                                             00059700
                        NIL))                                           00059710
                  (ADDF                                                 00059720
                   (ISIMP1*                                             00059730
                  (ISIMP1 (GCHECK (LIST (CAR I)) U (QUOTE ***))         00059740
                         NIL                                            00059750
                         NIL                                            00059760
                         NIL                                            00059770
                         NIL)                                           00059780
                  (LIST (CAR I))                                        00059790
                  (LIST (LIST L (CAR I))))                              00059800
                   (ADDF (MULTN -1                                      00059810
                            (ISIMP1*                                    00059820
                             (ISIMP1                                    00059830
                              (GCHECK                                   00059840
                               (REVERSE X)                              00059850
                               U                                        00059860
                               (QUOTE ***))                             00059870
                              NIL                                       00059880
                              NIL                                       00059890
                              NIL                                       00059900
                              NIL)                                      00059910
                             (CDR X)                                    00059920
                             (LIST (CONS L X))))                        00059930
                       (MULTF (MKSQP (CONS -1 2))                       00059940
                            (ISIMP1*                                    00059950
                             (ISIMP1                                    00059960
                              (GCHECK                                   00059970
                               (REVERSE I)                              00059980
                               U                                        00059990
                               (QUOTE ***))                             00060000
                              NIL                                       00060010
                              NIL                                       00060020
                              NIL                                       00060030
                              NIL)                                      00060040
                             I                                          00060050
                             (LIST (CONS L I))))))))))))                00060060
                                                                        00060070
(ISIMP1* (LAMBDA (U I V)                                                00060080
   (COND ((NULL U) NIL) (T (ISIMP1 U I NIL NIL V)))))                   00060090
                                                                        00060100
))                                                                      00060110
                                                                        00060120
INIT NIL                                                                00060130
                                                                        00060140
CHKPOINT (REDUCE)                                                       00060145
                                                                        00060150
COMMENT ((E N D    O F    R E D U C E    P R O G R A M))                00060160
                                                                        00060170
                                                                        00060180