C**********************************************************************
C*                                                                    *
C*                           LISP                                     *
C*                           ----                                     *
C*                                                                    *
C*     THE SYSTEM IS WRITTEN BY                                       *
C*     MATS NORDSTROM AND                                             *
C*     ERIK SANDEWALL                                                 *
C*     DEPARTMENT OF COMPUTER SCIENCE                                 *
C*     STUEGATAN 4 B                                                  *
C*     752 23 UPPSALA                                                 *
C*     SWEDEN                                                         *
C*                                                                    *
C*     THE WORK WAS SUPPORTED BY THE SWEDISH RESEARCH INSTITUTE       *
C*     OF NATIONAL DEFENCE (FOA P) UNDER CONTRACT 010-218,1           *
C*                                                                    *
C**********************************************************************
      DIMENSION LERR(3)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
C0000 LOCAL DECLARATIONS
      DIMENSION ISIFF(8)
      DIMENSION IPRI(2)
      INTEGER GET,ADDAL,CONS,OK
      DIMENSION KAR(4500),KDR(4500)
      EQUIVALENCE (KAR,CAR)
      EQUIVALENCE (KDR,CDR)
      EQUIVALENCE (NFREE,NFREET)
      EQUIVALENCE (IRES,ARG)
C
C------------------------------------------------------
C0000 INITIALIZATION
      LERR(1)=2
      LERR(3)=9
      ND=25
      DO 10 I=1,24
   10 DREG(I)=0
      A4=A9+1
      A6=A9+2
C
C
C
      CALL INIT(1)
    4 CALL FPUSH(1,500)
      ARG2=ALIST
      GOTO 1000
C>>>> ATTEMPTED RETURN FROM TOP-LEVEL LOOP
  500 WRITE(LUNUT,501)
  501 FORMAT (36H DONT USE ( - YOU ARE NOT IN A BREAK)
C
C0000 RESTART OF INTERPRETER
    2 IP=0
      JP=NSTACK+1
      GOTO 4
C
C0000 RETURN IN BREAK AND FROM TOP LEVEL LOOP
  997 JP=JP+1
C0000 RECURSIVE RETURN PROCEDURE
  998 I=STACK(IP)
      IP=IP-1
      IF (IP) 990,999,999
  990 WRITE(LUNUT,991)
  991 FORMAT (24H FUNCTION PDL IS EMPTY ?)
      CALL EXCUSE
      GOTO 2
  999 GOTO (500,  1103, 3000, 3501, 4103, 1000, 4501,
C0000 I=     1     2     3     4     5     6     7
     *    2,   5101, 6101, 7710, 9710, 9741,
C0000 I=  8       9    10    11    12    13
     *    9621, 9628, 9653, 9510, 9523, 9533,
C     I=   14    15    16    17    18    19
     *    4000, 2000,
C     I=   20    21
     *    500),I
C
C----------------------------------------------------------------------
C     RECURSIVE FUNCTION LOOP ()
 1000 CALL APUSH(ARG2)
 1001 ARG2=STACK(JP)
      CALL FPUSH(2,1103)
      GOTO (1100,1200,1300),MODE
C
C0000 USE EVAL IN TOP LEVEL LOOP
 1100 IARG=IREAD(0)
      IF (IARG) 1101,4009,4009
 4009 ARG=IARG
      GOTO 4000
C0000 IF IREAD RETURNS A NEGATIVE VALUE, IT WANTS US TO MAKE
C0000 A RETURN FROM LOOP
 1101 IP=IP-1
      JP=JP+1
      GOTO 4000
C>>>> RETURN POSITION FROM EVAL, EVALQUOTE, AND APPLY SYS
 1103 IF (DREG(24)) 1104,1104,1001
 1104 CALL IPRINT(IRES)
      GOTO 1001
C
C0000 USE EVALQUOTE
 1200 IARG=IREAD(0)
      IF (IARG) 1202,1201,1201
 1201 ARG3=IREAD(0)
      ARG=IARG
      IF (ARG3) 1205,2000,2000
 1202 ARG3=IREAD(0)
      IF (ARG3) 1205,1203,1203
 1203 IP=IP-1
      JP=JP+1
      GOTO 2000
 1205 WRITE(LUNUT,1206)
 1206 FORMAT(21H BAD INPUT, TRY AGAIN)
      GOTO 1200
C
C0000 USE APPLY
 1300 ARG=GET(SYS,EXPR)
      IF (ARG) 1302,1340,1302
 1302 ARG3=NIL
      GOTO 3000
 1340 WRITE(LUNUT,1341)
 1341 FORMAT (38H MODE = 3 BUT SYS UNDEF, TALK TO EVAL.)
      GOTO 1100
C
C--------------------------------------------------------
C     RECURSIVE FUNCTION EVQT (SIMILAR TO EVALQUOTE)
 2000 IF (GET(ARG,FEXPR)) 2020,2010,2020
 2010 IF (ARG-SUBR) 3000,3000,2011
 2011 IF (ARG-FSUBR) 2020,2020,3000
 2020 ARG=CONS(ARG,ARG3)
      GOTO 4000
C
C--------------------------------------------------------
C     RECURSIVE FUNCTION APPYL (SIMILAR TO APPLY)
 3000 IF (ARG) 9000,998,3001
 3001 IF (ARG-NATOM) 3002,3002,3200
 3002 IF (CDR(ARG)) 3101,3110,3101
C
C0000 EXPR0S
 3101 L=GET(ARG,EXPR)
      IF (L) 3102, 3110, 3102
 3102 ARG=L
      GOTO 3001
C0000 THAT TAKES US TO APPLY
C
C0000 SUBR0S
 3110 IF (ARG-SUBR) 9001,9001,3130
C
C0000 ALIST DEFINED FUNCTIONS
 3130 CALL FPUSH (3,3131)
      ARG4=A2
C0000 A2 IS SUPPOSED TO BE AN INDICATION OF ERROR A2
      GOTO 7000
C0000 THAT TAKES US TO CASSOC
C>>>> RETURN FROM CASSOC
C3131 = 3000
C
C0000 LAMBDA EXPRESSIONS
 3200 IF (CAR(ARG)-LAMBDA) 3300,3201,3300
 3201 ICAR=KAR(CDR(ARG))
      ARG2=ADDAL(ICAR,ARG3,ARG2)
      ARG=KAR(KDR(CAR(ARG)))
      GOTO 4000
C0000 THAT TAKES US TO EVAL
C
C0000 FUNARG EXPRESSIONS
 3300 IF (CAR(ARG)-FUNARG) 3400,3301,3400
 3301 ARG2=KAR(KDR(CDR(ARG)))
      ARG=KAR(CDR(ARG))
      GOTO 3000
C
C0000 LABEL EXPRESSIONS
 3400 IF (CAR(ARG)-LABEL) 3500,3401,3500
 3401 K=CDR(ARG)
      L=CDR(K)
      ARG=CAR(L)
      ICAR=CAR(K)
      ARG2=CONS(CONS(ICAR,ARG),ARG3)
      GOTO 3000
C
C0000 OTHER EXPRESSIONS (TO BE EVALUATED)
 3500 CALL APUSH (ARG2)
      CALL APUSH (ARG3)
      CALL FPUSH (4,3501)
      GOTO 4000
C>>>> RETURN FROM EVAL
 3501 CALL APOP(ARG3)
      CALL APOP(ARG2)
      GOTO 3000
C-------------------------------------------------
C     RECURSIVE FUNCTION EVAL
 4000 IF (ARG-NATOM) 4001,4001,4090
C
C0000 ARG AN ATOM
 4001 IF (ARG) 9999,998,4002
 4002 I=CAR(ARG)
      IF (I) 7002,4003,4003
 4003 IRES=I
      GOTO 998
C0000 7002 = CASSOC(-,-,A8)
C
 4090 IF (ARG-NFREE) 4100,4100,998
C0000 ARG NOT AN ATOM
 4100 IF (CAR(ARG)-NATOM) 4108,4108,4101
 4101 IF (CDR(ARG)-NFREE) 4600,4600,4500
 4108 IF (KDR(CAR(ARG))) 4102,4300,4102
C
C0000 EXPR IN CAR(ARG)
 4102 ICAR=CAR(ARG)
      L=GET(ICAR,EXPR)
      IF (L) 4104,4200,4104
 4105 L=-L
 4104 CALL APUSH(ARG2)
      CALL APUSH(L)
      CALL FPUSH(5,4103)
      ARG=CDR(ARG)
      GOTO 5000
C>>>> RETURN FROM EVLIS
 4103 ARG3=IRES
      CALL APOP(ARG)
      CALL APOP(ARG2)
      GOTO 3000
C0000 TAKES US TO CHOICE OF APPLY OR MACH
C
C0000 FEXPR
 4200 ICAR=CAR(ARG)
      L=GET(ICAR,FEXPR)
      IF (L) 4201,4300,4201
 4201 ICDR=CDR(ARG)
      ARG3=CONS(ICDR,CONS(ARG2,NIL))
      ARG=L
      GOTO 3001
C
C0000 SUBR, FSUBR
 4300 L=CAR(ARG)
      IF (L-SUBR) 4105,4105,4400
 4400 IF (L-FSUBR) 4401,4401,4500
 4401 ARG=CDR(ARG)
      GOTO 9591
C0000
C0000 FUNCTION DEFINED ON A-LIST
 4500 ICDR=CDR(ARG)
      CALL APUSH(ICDR)
      CALL FPUSH(7,4501)
      ARG=CAR(ARG)
      ARG4=A9
      GOTO 7000
C>>>> RETURN FROM CASSOC
 4501 CALL APOP(I)
      ARG=CONS(IRES,I)
      GOTO 4000
C0000
C0000 EVALUATE THE FUNCTION
 4600 L=CAR(ARG)
      GOTO 4104
C--------------------------------------------------
C     RECURSIVE FUNCTION EVLIS
 5000 IF (ARG) 9977,998,5010
 5010 CALL APUSH(CONS(NIL,NIL))
      CALL APUSH(NIL)
      STACK(JP)=STACK(JP+1)
      CALL APUSH(ARG)
      CALL APUSH(ARG2)
C0000 STACK(JP+3) = BEGINNING OF RESULT LIST FROM EVLIS
C0000 STACK(JP+2) = END OF RESULT LIST
 5020 ARG=CAR(ARG)
      CALL FPUSH(9,5101)
      GOTO 4000
C>>>> RETURN FROM EVAL
 5101 I=STACK(JP+2)
      CAR(I)=IRES
      ARG=KDR(STACK(JP+1))
      IF (ARG) 5299,5200,5110
 5110 ARG2=STACK(JP)
      STACK(JP+1)=ARG
      CDR(I)=CONS(NIL,NIL)
      STACK(JP+2)=CDR(I)
      GOTO 5020
 5200 IRES=STACK(JP+3)
      K=STACK(JP+2)
      CDR(K)=NIL
      JP=JP+4
      GOTO 998
 5299 JP=JP+4
      GOTO 9977
C
C------------------------------------------------
C     RECURSIVE FUNCTION EVCON
 6000 IF (ARG) 9977,998,6010
 6010 CALL APUSH(ARG2)
      CALL APUSH(ARG)
 6020 ICAR=CAR(ARG)
      ARG=KAR(OK(ICAR,6020))
      CALL FPUSH(10,6101)
      GOTO 4000
C>>>> RETURN FROM EVAL
 6101 ARG2=STACK(JP+1)
      IF (IRES) 6200,6110,6200
 6110 ARG=KDR(STACK(JP))
      IF (ARG) 9977,6201,6112
 6112 STACK(JP)=ARG
      GOTO 6020
 6200 ICAR=KDR(KAR(STACK(JP)))
      ARG=KAR(OK(ICAR,6200))
      JP=JP+2
      GOTO 4000
 6201 JP=JP+2
      GOTO 998
C
C----------------------------------------------------
C     SEMI-RECURSIVE FUNCTION CASSOC, SASSOC
C0000 ARGUMENTS IN ARG, ARG2, ARG4, ARG2 AND ARG3 ARE NOT
C0000 TO BE DESTROYED.
C0000 CASSOC(-,-,-) = CDR(SASSOC(-,-,-))
C0000 ENTRY SASSOC
 7010 IASSOC=0
      GOTO 7020
C0000 ENTRY CASSOC(-,-,A8)
 7002 ARG4=A8
C0000 ENTRY CASSOC
 7000 IASSOC=1
 7020 K=ARG2
 7030 IF (K) 9977,7700,7040
 7040 ICAR=CAR(K)
      IF (ARG-KAR(OK(ICAR,7040))) 7050,7100,7050
 7050 K=CDR(K)
      GOTO 7030
C0000 ORDINARY RETURN
 7100 IF (IASSOC) 7101,7101,7102
 7101 IRES=CAR(K)
      GOTO 998
 7102 IRES=KDR(CAR(K))
      GOTO 998
C0000 APPLY ERROR FUNCTION (THIRD ARGUMENT)
 7700 CALL APUSH(ARG2)
      CALL APUSH(ARG3)
      CALL FPUSH(11,7710)
      ARG3=CONS(ARG,CONS(ARG2,NIL))
      ARG=ARG4
      GOTO 3000
C>>>> RETURN FROM APPYL
 7710 CALL APOP(ARG3)
      CALL APOP(ARG2)
      GOTO 998
C
C-------------------------------------------------------
C     RECURSIVE FUNCTION MACH (LIKE APPYL, BUT FOR SUBRS
C0000 AND FSUBR0S)
C
C0000 ON ENTRY HERE, THE FIRST ARGUMENT TO MACH IS NEGATIVE
C0000 AND SUPPOSED TO BE A SUBR
 9000 L=-ARG
      GOTO 9002
C0000 ANOTHER ENTRY, ARG POSITIVE
 9001 L=ARG
 9002 IF (L-SUBR2) 9003,9003,9300
 9003 IF (L-SUBR1) 9004,9004,9200
C
C0000 RETURN CHANNELS FOR TRUTH-VALUED FUNCTIONS
 9010 IRES=NIL
      GOTO 998
 9011 IRES=T
      GOTO 998
C
C..............................................
C0000 SUBR00S AND SUBR10S
 9004 ARG=CAR(ARG3)
      GOTO (
     * 9031, 9032, 9033, 9034, 9035, 9036,
C      ADVAN BREAK EJECT MODE FORCEGBC PEEK
     * 9037, 9038,    2, 9040, 9041, 9042, 9043,
C      OBLIST READ RESTART SIL TALK TERPRI EXIT
     * 9101, 9102, 9103, 9104, 9105, 9106, 9107,
C      ADD1  ATOM  CAR   CDR   CAAR  CADR  CDAR
     * 9108, 9109, 9110, 9111, 9112, 9113, 9114,
C      CDDR CLEARB GENS INUNT  NULL  NUMBP OUTUN
     * 9115, 9116, 9117, 9118,91185,9780, 9119,
C      PACKL PRIN1 PRINT PRPOS RDPOS RETURN SETBIT
     * 9120, 9121, 9122, 9123, 9740, 9125,
C      SUB1  TESTB UNPACK ZEROP GOTO DUMP
     * 9999), L
C
C
C9031 ADVANCE
 9031 CALL SHIFT(IPN1)
      IPN2=ATENDA
      CALL PUTCH(IPN2,IPN1,1)
      IRES=MATOM(IPN2,ATENDA)
      GOTO 998
C
C9032 BREAK
 9032 WRITE(LUNUT,9932)
 9932 FORMAT (24H BREAK CALLED BY PROGRAM )
      GOTO 1000
C
C9033 EJECT
 9033 WRITE(LUNUT,9098)
 9098   FORMAT (1H1)
        GOTO 998
C
C
C9034 MODE
 9034   MODE=ARG-NUMADD
        GOTO 998
C
C9035 FORCEGBC
 9035   CDR(NFREEP)=NIL
        IDUM=CONS(NIL,NIL)
        IRES=LISTNB(NFREEP)+NUMADD
        GOTO 998
C
C9036 PEEK
 9036   CALL TESTUT
        GOTO 998
C
C9037 OBLIST
 9037   I=ARG
        IDUM=CONS(I,NIL)
        IRES=IDUM
90370   IF (I-NATOMP) 90371,998,90371
90371   I=I+1
        CDR(IDUM)=CONS(I,NIL)
        IDUM=CDR(IDUM)
        GOTO 90370
C
C9038 READ
 9038   IRES=IREAD(0)
        IF (IRES) 9604,998,998
 9604 WRITE(LUNUT,9608)
 9608 FORMAT (16H ( INPUT TO READ /6H BREAK )
        GOTO 1000
C
C9040 SILENCE
 9040   DREG(24)=T
        GOTO 998
C
C9041 TALK
 9041   DREG(24)=NIL
        GOTO 998
C
C9042 TERPRI
 9042   CALL PRINAT(-1,IDUM)
        GOTO 998
C
C9043 EXIT
 9043   CALL EXIT
C
C9101 ADD1
 9101   IRES=NBOX(ARG,9101)+1+NUMADD
        GOTO 998
C
C9102 ATOM
 9102   IF (ARG) 9010,9601,9601
 9601   IF (ARG-NATOM) 9011,9011,9113
C
C9103 CAR
 9103   IRES=CAR(ARG)
        GOTO 998
C
C9104 CDR
 9104   IRES=CDR(ARG)
        GOTO 998
C
C9105 CAAR
 9105   IRES=CAR(ARG)
        GOTO 9103
C
C9106 CADR
 9106   IRES=CDR(ARG)
        GOTO 9103
C
C9107 CDAR
 9107   IRES=CAR(ARG)
        GOTO 9104
C
C9108 CDDR
 9108   IRES=CDR(ARG)
        GOTO 9104
C
C9109 CLEARBIT
 9109   I=ARG-NUMADD
        IF (I * (ND - I)) 9611,9611,9610
 9610   DREG(I)=NIL
        IRES=NIL
        GOTO 998
 9611 WRITE(LUNUT,9612) I
 9612   FORMAT (38H BIT ARRAY USED OUT OF BOUNDS, INDEX = , I4)
        GOTO 1000
C
C9110 GENSYM
 9110   IF (IGENF-99) 91101,91102,91101
C         THIS IS THE INITIAL POINT FOR GENSYM
91101   INDSIF=0
        IGENF=99
91102   ISIF=INDSIF
        DO 91103 JENIND=1,4
        JJ=ISIF-ISIF/10*10
        ISIFF(JENIND)=IFIG(JJ+1)
91103   ISIF=ISIF/10
        DO 91104 JENIND=1,4
        III=5-JENIND
91104   CALL PUTCH(IPN2,ISIFF(III),JENIND)
        IPN1=PNAME1(ARG)
        DO 91105 JENIND=1,4
        CALL GETCH(IPN1,ICH,JENIND)
        IF (ICH-ATEND) 91105,91106,91105
91106   CALL PUTCH(IPN1,IFIG(1),JENIND)
91105   CONTINUE
        INDSIF=INDSIF+1
        IRES=MATOM(IPN1,IPN2)
C         L POINTS HERE TO THE ATOM GENSYM
        GOTO 998
C
C9111 INUNIT
 9111   LUNIN=ARG-NUMADD
        GOTO 998
C
C9112 NULL
 9112   IF (ARG) 9010, 9011, 9010
C
C9113 NUMBERP
 9113   IF (ARG-NFREE) 9010,9010,9011
C
C9114 OUTUNIT
 9114   LUNUT=ARG-NUMADD
        GOTO 998
C
C9115 PACKLIST
 9115   IPRI(1)=ATENDA
        IPRI(2)=ATENDA
        IDUM=1
        ISUM=0
        I=ARG
        III=0
        DO 91151 JUN=1,8
        II=CAR(I)
        IF (NFREE-II) 91153,91154,91154
91153   II=II-NUMADD
        II=II-II/10*10
        ISUM=10*ISUM+II
        ICH=IFIG(II+1)
        GOTO 91155
91154   CALL GETCH(PNAME1(II),ICH,1)
        IDUM=2
91155   CALL SBYT(ICH,IPRI,III)
        I=CDR(I)
        IF (I) 91151,91152,91151
91151   CONTINUE
91152   IRES=MATOM(IPRI(1),IPRI(2))
        IF (IDUM-1) 998,91156,998
91156   IRES=ISUM+NUMADD
        GOTO 998
C
C9116 PRIN1
 9116   I=ARG
        CALL PRINAT(4,I)
        PRTPNT=PRTPNT-1
        GOTO 998
C
C9117 PRINT
 9117   CALL IPRINT(ARG)
        GOTO 998
C9118 PRINTPOS
 9118   IF (ARG) 91182,91181,91182
91181   IRES=PRTPNT+NUMADD-1
        GOTO 998
91182   IF (ARG-NUMADD) 91189,91189,91184
91184   PRTPNT=ARG-NUMADD
        GOTO 998
C
C91185 READPOS
91185   IF (ARG) 91187,91186,91187
91186   IRES=RDPNT+NUMADD-1
        GOTO 998
91187   IF (ARG-NUMADD) 91189,91189,91188
91188   RDPNT=ARG-NUMADD
        GOTO 998
91189 WRITE(LUNUT,96189)
96189   FORMAT(45H ARGUMENT FOR READPOS OR PRINTPOS LESS THAN 0
     +  /6H BREAK)
        GOTO 1000
C
C9119 SETBIT
 9119  I=ARG-NUMADD
       IF (I*(ND-I)) 9611,9611,9613
 9613  DREG(I)=T
       IRES=NIL
       GOTO 998
C
C9120 SUB1
 9120   IRES=NBOX(ARG,9120)-1+NUMADD
        GOTO 998
C
C9121 TESTBIT
 9121   I=ARG-NUMADD
        IF (I*(ND-I)) 9611,9611,9614
 9614   ARG=DREG(I)
        GOTO 998
C
C9122 UNPACK
 9122   IF (NFREE-ARG) 91225,91220,91220
91220   DO 91221 JUN=1,4
        ISIFF(JUN)=0
91221   CALL GETCH(PNAME1(ARG),ISIFF(JUN),JUN)
        DO 91222 JUN=1,4
        ISIFF(JUN+4)=0
91222   CALL GETCH(PNAME2(ARG),ISIFF(JUN+4),JUN)
        JUN=1
        IPN1=ATENDA
        CALL PUTCH(IPN1,ISIFF(1),1)
        I=MATOM(IPN1,ATENDA)
        IDUM=CONS(I,NIL)
        IRES=IDUM
91223   JUN=JUN+1
        IF (ISIFF(JUN)-ATEND) 91224, 998, 91224
91224   CALL PUTCH(IPN1,ISIFF(JUN),1)
        CDR(IDUM)=CONS(MATOM(IPN1,ATENDA),NIL)
        IDUM=CDR(IDUM)
        IF (JUN-8) 91223,998,91223
91225   II=ARG-NUMADD
        IRES=NIL
91226   IRES=CONS(NIL,IRES)
        III=II
        II=II/10
        III=III-10*II+NUMADD
        CAR(IRES)=III
        IF (II) 91226,998,91226
C
C9123 ZEROP
 9123   IF (ARG-NUMADD) 9010,9011,9010
C
C9125 DUMP
C     REDEFINED AS SUBR2
 9125 LUNO=LUNUT
      LUNUT=ARG-NUMADD
      IRES=KAR(CDR(ARG3))
        IF (IRES-NATOM) 9622,9622,9624
 9622   IRES=CONS(IRES,NIL)
 9624   IF (IRES) 9633,9633,9665
 9665   M=SUBR+4
        ICAR=CAR(IRES)
        K=GET(ICAR,EXPR)
        IF (K) 9668,9666,9668
 9666   M=SUBR+5
        K=GET(ICAR,FEXPR)
        IF (K) 9632,9632,9668
 9668   ICDR=CDR(K)
        M=CONS(M,CONS(ICAR,ICDR))
        CALL IPRINT(M)
 9632   IRES=CDR(IRES)
        GOTO 9624
 9633   M=SUBR0+11
        M=CONS(M,CONS(LUNIN+NUMADD,NIL))
        CALL IPRINT(M)
C       WRITE (INUNIT 'STANDARD INUNIT') AT END
      LUNUT=LUNO
        GOTO 998
C
C....................................................
C0000 SUBR0S
 9200 ARG=CAR(ARG3)
      ARG3=KAR(CDR(ARG3))
C0000 WE USE ARG3 FOR SECOND ARGUMENT OF THE GIVEN FUNCTION,
C0000 BECAUSE THE SUBR2 SET NEEDS THE OLD ARG2 (= ALIST)
      L=L-SUBR1
      GOTO (
     *   9201, 9202, 9201, 9219, 9220,
C        A2    A8    A9    A4    A6
     *   9203, 9204, 9205, 9206, 9207, 9208, 9209,
C        CONS  DIFFER EQ   EQUAL EVAL  EVLIS GET
     *   9210, 9211, 9212, 9213, 9214, 9215, 9216,
C        GREAT LESSP MEMBER NCONC PAIR QUOT  RPLACA
     *   9217, 9218, 9221,
C        RPLACD SET  MEMB
     *   9999), L
C
C9201 A2, A9
 9201   L=LERR(L)
        IF (ARG-NFREE) 92011,92012,92012
92011 WRITE(LUNUT,9801) L,PNAME1(ARG),PNAME2(ARG)
 9801   FORMAT(21H I FAIL,DIAGNOSTIC A , I1,18H, UNDEF FUNCTION   ,2A4
     +  /6H BREAK)
      GOTO 1000
92012   LL=ARG-NUMADD
      WRITE(LUNUT,98011) L,LL
98011   FORMAT(21H I FAIL, DIAGNOSTIC A , I1,18H, UNDEF FUNCTION   ,I8/
     +  6H BREAK)
      GOTO 1000
C
C9202 A8
 9202 WRITE(LUNUT,9802) PNAME1(ARG),PNAME2(ARG)
 9802   FORMAT(40H I FAIL, DIAGNOSTIC ,A8, UNDEF VARIABLE  ,  2A4
     +  /6H BREAK)
      GOTO 1000
C
C9203 CONS
 9203   IRES=CONS(ARG,ARG3)
C
        GOTO 998
C
C9204 DIFFEREN(CE)
 9204   IRES=ARG-ARG3+NUMADD
        IF (IRES-NFREE) 9955,9955,998
C
C9205 EQ
 9205   IF (ARG-ARG3) 9010,9011,9010
C
C9219 A4
 9219 WRITE(LUNUT,9819)  PNAME1(ARG),PNAME2(ARG)
 9819   FORMAT(24H FIRST ARG OF SET/SETQ  ,2A4,14H NOT ON A-LIST
     +  /6H BREAK)
      GOTO 1000
C
C9220 A6
 9220 WRITE(LUNUT,9820)  PNAME1(ARG),PNAME2(ARG)
 9820   FORMAT (7H GO TO ,2A4,12H NOT DEFINED /6H BREAK )
      GOTO 1000
C
C9206 EQUAL
 9206   IPE=IP
        JPE=JP
C0000   AUXILIARY RECURSIVE FUNCTION EQUALI
 9615   IF (ARG-ARG3) 9616,9011,9616
 9616   IF (ARG-NFREE) 96161,9617,9617
96161   IF ((ARG-NATOM)*(NFREE+1-ARG)) 9617,9617,9619
C0000   EQUALITY FAILS
 9617   IRES=NIL
        IP=IPE
        JP=JPE
        GOTO 998
C0000   ARG NON-ATOMIC
 9619   IF ((ARG3-NATOM)*(NFREE+1-ARG3)) 9617,9617,9620
 9620   ICDR=CDR(ARG)
        CALL APUSH(ICDR)
        ARG=CAR(ARG)
        ICDR=CDR(ARG3)
        CALL APUSH(ICDR)
        ARG3=CAR(ARG3)
        CALL FPUSH(14,9621)
        GOTO 9615
C>>>>   RETURN FROM EQUALI
 9621   CALL APOP(ARG3)
        CALL APOP(ARG)
        GOTO 9615
C
C9207 EVAL
 9207   ARG2=ARG3
        GOTO 4000
C
C9208 EVLIS
 9208   ARG2=ARG3
        GOTO 5000
C
C9209 GET
 9209   IRES=GET(ARG,ARG3)
        GOTO 998
C
C9210 GREATERP
 9210   IF (ARG-ARG3) 9010,9010,9011
C
C9211 LESSP
 9211   IF (ARG-ARG3) 9011,9010,9010
C
C9221 MEMB
 9221   IRES=MEMB(ARG,ARG3)
        GOTO 998
C
C9212 MEMBER
 9212 CALL APUSH(ARG)
      CALL APUSH(ARG3)
96251 IF (ARG3-NFREE) 9625,9625,9977
 9625 IF (ARG3) 9626,9626,9627
 9626 IRES=NIL
      JP=JP+2
      GOTO 998
 9627 CALL FPUSH(15,9628)
      ARG3=CAR(ARG3)
      GOTO 9206
C>>>> RETURN FROM EQUAL
 9628 IF (IRES) 9630,9629,9630
 9629 ARG3=KDR(STACK(JP))
      STACK(JP)=ARG3
      ARG=STACK(JP+1)
      GOTO 96251
 9630 ARG=STACK(JP)
      JP=JP+2
      GOTO 998
C
C9213 NCONC
 9213   IF (ARG) 9638,9638,9639
 9638   IRES=ARG3
        GOTO 998
 9639   I=ARG
 9640   IF (CDR(I)) 9641,9641,9642
 9641   CDR(I)=ARG3
        GOTO 998
 9642   I=CDR(I)
        GOTO 9640
C
C9214 PAIR
 9214   IRES=ADDAL(ARG,ARG3,NIL)
        GOTO 998
C
C9215 QUOTIENT
 9215   I=NBOX(ARG,9215)
        J=NBOX(ARG3,9215)
        IF (J) 9648,9649,9648
 9648   IRES=I/J+NUMADD
        IF (IRES-NFREE) 9955,9955,998
 9649 WRITE(LUNUT,9650) I
 9650   FORMAT (07H DEVIDE,I4,08H BY ZERO/06H BREAK)
        GOTO 1000
C
C9216 RPLACA
 9216   CAR(ARG)=ARG3
        GOTO 998
C
C9217 RPLACD
 9217   CDR(ARG)=ARG3
        GOTO 998
C
C9218 SET
 9218   ARG4=A4
        CALL FPUSH(16,9653)
        GOTO 7010
C>>>>   RETURN FROM SASSOC
 9653   CDR(ARG)=ARG3
        IRES=ARG3
        GOTO 998
C
C....................................................
C0000 SUBR30S AND NOSPREAD SUBR0S
 9300 IF (L-SUBR3) 9309,9309,9400
C
C0000 SUBR30S
 9309 ARG=CAR(ARG3)
      ARG2=KAR(CDR(ARG3))
      ARG3=KAR(KDR(CDR(ARG3)))
      L=L-SUBR2
      GOTO (
     *   9301, 9302, 9305,
C        APPLY PUT  SASSOC
     * 9999),L
C
C9301 APPLY
 9301   I=ARG2
        ARG2=ARG3
        ARG3=I
        GOTO 3000
C
C9302 PUT
 9302   K=ARG
 9303   IF (CDR(K)) 9308,9308,9312
 9308   CDR(K)=CONS(ARG3,CONS(ARG2,NIL))
        GOTO 998
 9312   K=CDR(K)
        IF (CDR(K)-ARG3) 9315,9313,9315
 9313   K=CDR(K)
        IF (K-NFREE) 9314,9314,9311
 9314   CAR(K)=ARG2
        GOTO 998
 9315   K=CDR(K)
        IF (K-NFREE) 9303,9303,9311
 9311 WRITE(LUNUT,9319)
 9319   FORMAT (23H PUT OUTSIDE ITS DOMAIN )
        GOTO 998
C
C9305 SASSOC
 9305   ARG4=ARG3
        GOTO 7010
C
C...................................................
C0000 NO-SPREAD SUBR0S
C
 9400 L=L-SUBR3
      GOTO (
     *   9402, 9410, 9420, 9430,
C        LIST  PLUS  PROGN TIMES
     *   9999),L
C
C9402 LIST
 9402   IRES=ARG3
        GOTO 998
C
C9410 PLUS
 9410   IRES=NUMADD
 9411   IF (ARG3) 9977,998,9412
 9412   ICAR=CAR(ARG3)
        IRES=IRES+NBOX(ICAR,9412)
        ARG3=CDR(ARG3)
        GOTO 9411
C
C9420 PROGN
 9420   IF (ARG3) 9423,9423,9421
 9421   IF (CDR(ARG3)) 9423,9423,9425
 9423   IRES=CAR(ARG3)
        GOTO 998
 9425   ARG3=CDR(ARG3)
        GOTO 9421
C
C9430 TIMES
 9430   IRES=1
 9431   IF (ARG3) 9977,9434,9432
 9432   ICAR=CAR(ARG3)
        IRES=IRES*NBOX(ICAR,9432)
        ARG3=CDR(ARG3)
        GOTO 9431
 9434   IRES=IRES+NUMADD
        GOTO 998
C
C..........................................................
C0000 FSUBR0S
C0000 THIS IS A SEPARATE ENTRY POINT (ACCESSED DIRECTLY
C0000 FROM EVAL). WE ASSUME THAT ARGUMENT LIST AND A-LIST FOR
C0000 THE FSUBR ARE IN ARG. VIS. ARG2, AND THAT THE ATOM INDEX
C0000 IS IN L.
C
 9591 L=L-SUBR
      GOTO (
     *   6000, 9760, 9520, 9502, 9503, 9504, 9505,
C        COND  PROG  AND   DE    DF    FUNCTION GO
     *   9530, 9508, 9509,
C        OR    QUOTE SETQ
     *   9999),L
C9502 DE
 9502   ARG3=EXPR
 9501   ARG2=CDR(ARG)
        ARG=CAR(ARG)
        IF (ARG2) 9302,9302,9541
 9541   ARG2=CONS(LAMBDA,ARG2)
        GOTO 9302
C
C9503 DF
 9503   ARG3=FEXPR
        GOTO 9501
C
C9504 FUNCTION
 9504   ICAR=CAR(ARG)
        IRES=CONS(FUNARG,CONS(ICAR,CONS(ARG2,NIL)))
        GOTO 998
C9505 GO
 9505   ARG=CAR(ARG)
        GOTO 9740
C
C
C9508 QUOTE
 9508   IRES=CAR(ARG)
        GOTO 998
C
C9509 SETQ
 9509   ICAR=CAR(ARG)
        CALL APUSH(ICAR)
        CALL APUSH(ARG2)
        ARG=KAR(CDR(ARG))
        CALL FPUSH(17,9510)
        GOTO 4000
C>>>>   RETURN FROM EVAL
 9510   ARG3=IRES
        CALL APOP(ARG2)
        CALL APOP(ARG)
        GOTO 9218
C
C9520 AND
 9520   IF (ARG) 9011,9011,9521
 9521   CALL APUSH(ARG)
        CALL APUSH(ARG2)
 9522   ARG=KAR(STACK(JP+1))
        CALL FPUSH(18,9523)
        GOTO 4000
C>>>>   RETURN FROM EVAL
 9523   IF (IRES) 9528,9528,9524
 9524   K=KDR(STACK(JP+1))
        IF (K) 9528,9528,9525
 9528   JP=JP+2
        GOTO 998
 9525   ARG2=STACK(JP)
        STACK(JP+1)=K
        GOTO 9522
C
C9530 OR
 9530   IF (ARG) 9010,9010,9531
 9531   CALL APUSH(ARG)
        CALL APUSH(ARG2)
 9532   ARG=KAR(STACK(JP+1))
        CALL FPUSH(19,9533)
        GOTO 4000
C>>>>   RETURN FROM EVAL
 9533   IF (IRES) 9534,9534,9528
 9534   K=KDR(STACK(JP+1))
        IF (K) 9528,9528,9535
 9535   ARG2=STACK(JP)
        STACK(JP+1)=K
        GOTO 9532
C...................................................
C     PROG FEATURE
C
C9740 GOTO
 9740   IP=IPP
        JP=JPP-5
        ARG2=STACK(JP)
        ARG4=A6
        CALL FPUSH(13,9741)
        GOTO 7000
C>>>>   RETURN FROM CASSOC
 9741   STACK(JP+1)=IRES
        ARG2=STACK(JP+2)
        GOTO 9768
C
C9760 PROG
 9760   CALL APUSH(IPP+NUMADD)
        CALL APUSH(JPP+NUMADD)
        IPP=IP
        JPP=JP+2
        ICAR=CAR(ARG)
        ARG2=ADDAL(ICAR,NIL,ARG2)
        CALL APUSH(ARG2)
        ICDR=CDR(ARG)
        CALL APUSH(ICDR)
C0000 PREPARE GO-LIST
        L=CDR(ARG)
        IRES=NIL
 9762   IF (L) 9763,9767,9763
 9763   IF (CAR(L)-NATOM) 9764,9764,9766
 9764   IRES=CONS(L,IRES)
 9766   L=CDR(L)
        GOTO 9762
 9767   CALL APUSH(IRES)
C0000 PROG LOOP (EVALUATE SUCCESSIVE S-EXPRESSIONS)
 9768   ARG=KAR(STACK(JP+1))
        IF (ARG-NATOM) 9771,9771,9769
 9769   CALL FPUSH(12,9710)
        GOTO 4000
C>>>>   RETURN FROM EVAL
 9710   ARG2=STACK(JP+2)
 9771   K=KDR(STACK(JP+1))
        STACK(JP+1)=K
        IF (K) 9768,9780,9768
C
C9780 RETURN
 9780   IP=IPP
        JP=JPP-2
        CALL APOP(JPP)
        CALL APOP(IPP)
        JPP=JPP-NUMADD
        IPP=IPP-NUMADD
        IF (IP) 998,9781,998
 9781 WRITE(LUNUT,9788)
 9788   FORMAT (20H RETURN OUTSIDE PROG/08H RESTART)
        GOTO 2
C---------------------------------------------------
C     ERROR MESSAGES
C
 9911 WRITE(LUNUT,9918) L
 9918 FORMAT (24H I FAIL BECAUSE FUNCTION, I3, 08H NOT YET,12H,IMPLEMENT
     +ED /8H RESTART )
      GOTO 2
C
 9955 WRITE(LUNUT,9958)
 9958 FORMAT (40H I HAVE UNDERFLOW IN NUMERICAL OPERATION/ 8H RESTART )
      GOTO 2
C
C0000 FOLLOWING ERROR MESSAGE USED WHEN WHAT SHOULD BE A
C0000 LIST IS IN FACT (TERMINATED BY) A NUMERICAL ATOM
 9977 WRITE(LUNUT,9978)
 9978 FORMAT( 40H I HAVE S-EXPRESSION WHOSE INDEX .LT. 0  /8H RESTART)
      GOTO 2
C
C0000 FOLLOWING ERROR MESSAGE USED WHEN THE INTERPRETER IS
C0000 ENTIRELY CONFUSED BY THE DATA IT HAS SET UP FOR ITSELF
 9999 WRITE(LUNUT,9998)
 9998 FORMAT (05H  ?  )
      CALL EXCUSE
      GOTO 2
      END
      FUNCTION MEMB(I,JJ)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      J=JJ
    5 IF (J) 100,100,10
   10 IF (I-CAR(J)) 20,100,20
   20 J=CDR(J)
      GOTO 5
  100 MEMB=J
      RETURN
      END
      FUNCTION NBOX(I,J)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      K=I-NUMADD
      IF (I-NFREET) 10,10,20
   10 WRITE(LUNUT,99) K,J
 99   FORMAT(16H BAD ARITHM ARG   ,I5,17H IN PROGRAM POS.   ,I6,
     * 12H DIRTY BREAK  )
      IP=IP+1
      STACK(IP)=6
      NBOX=0
      RETURN
   20 NBOX=K
      RETURN
      END
      INTEGER FUNCTION OK(I,J)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      IF (I) 100,10,10
   10 IF (I-NFREET) 101,101,100
  100 OK=-1
      WRITE(LUNUT,108) J
  108 FORMAT (36H INDEX OUTSIDE  0,NFREE$ IN POSITION, I5, 15H OF INTERP
     +RETER /8H RESTART )
      STACK(IP)=8
      RETURN
  101 OK=I
      RETURN
      END
      INTEGER FUNCTION ADDAL(IA,IV,E)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      INTEGER A,V,E,G,OK,CONS
      EQUIVALENCE (G,LASTR)
C     SAVE LIST IN G IN CASE OF GARBAGE
      A=IA
      V=IV
      G=E
      IF (OK(A,901)) 90,2,2
    2 IF (OK(V,902)) 90,3,3
3     IF (A) 6,40,6
6     IF (A-NATOM) 50,50,10
10    ICAR=CAR(A)
      ICDR=CDR(V)
      G=CONS(CONS(ICAR,ICDR),G)
      V=CDR(V)
      A=CDR(A)
      GOTO 3
   40 ADDAL=G
      RETURN
50    ADDAL=CONS(CONS(A,V),G)
   90 RETURN
      END
      INTEGER FUNCTION GET(J,I)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      K=CDR(J)
    6 IF (K-NFREET) 8,8,40
    8 IF (K) 40,40,10
   10 IF (CAR(K)-I) 12,20,12
   12 K=CDR(K)
      K=CDR(K)
      GOTO 8
   20 K=CDR(K)
      GET=CAR(K)
      RETURN
   40 GET=NIL
      RETURN
      END
      SUBROUTINE APUSH(J)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      JP=JP-1
      IF (IP-JP) 2,9,9
    2 STACK(JP)=J
      RETURN
    9 WRITE(LUNUT,99) JP
   99 FORMAT (29H ARGUMENTS PDL IS FULL; JP=  , I4,/ 8H RESTART )
      JP=JP+1
      STACK(IP)=8
      RETURN
      END
      SUBROUTINE FPUSH(I,J)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      IP=IP+1
      IF (IP-JP) 2,9,9
    2 STACK(IP)=I
      RETURN
    9 WRITE(LUNUT,99) IP
   99 FORMAT (28H FUNCTION PDL IS FULL; IP = , I4/ 8H RESTART )
      IP=IP-1
      STACK(IP)=8
      RETURN
      END
      SUBROUTINE APOP(J)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      JP=JP+1
      IF (JP-NSTACK) 2,2,9
    2 J=STACK(JP-1)
      RETURN
    9 WRITE(LUNUT,99)
   99 FORMAT (19H ARG PDL IS EMPTY ?)
      CALL EXCUSE
      STACK(IP)=8
      RETURN
      END
      SUBROUTINE EXCUSE
C>>>> COMMON AND INTEGER STATEMENTS ADDED
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
C
      WRITE(LUNUT,99)
   99 FORMAT (45H THE LISP SYSTEM IS HAVING INTERNAL TROUBLE.  ,11H YOU A
     +RE NOT / 34H TO BE BLAMED. PLEASE EXCUSE THIS0 / 8H RESTART )
      RETURN
      END
      SUBROUTINE PRINAT(I,IATOM)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
C      PRINAT PRINTS ONE ATOM OR ONE CHARACTER DEPENDING ON I
C      I=1 PRINT (
C      I=2 PRINT )
C      I=3 PRINT .ATOM)
C      I=4 PRINT ATOM
C      IND = CHARACTER POINTER TO OUTPUT BUFFER IBUFF
      DIMENSION IBUFF(18),IPDUM(1),PRST(10),ISIFF(8)
      INTEGER RPARIN,PRST
      EQUIVALENCE (IND,PRTPNT)
      IF (I) 804,804,30
   30 IF (IFIRST-9) 40,50,40
   40 NPRST=0
      IPARIN=0
      IFIRST=9
      ILAST=0
      IBUFF(1)=ALLSP
      IBUFF(2)=ALLSP
   50 GO TO (100,200,300,400),I
C              (   )   .A) A
C0000 ( 000000000000000000000000000000
  100 IF (ILAST-2) 120,105,120
  105 IF (DREG(2)) 120,110,120
  110 CALL OUTSTR(IBUFF,IPARIN,IND)
  120 IF (NPRST) 140,140,130
  130 PRST(NPRST)=PRST(NPRST)+1
  140 CALL PCHAR(IBUFF,LPAR,IND)
      IPARIN=IPARIN+1
      GO TO 800
C0000 ) 000000000000000000000000000000
  200 IF (NPRST) 240,240,210
  210 PRST(NPRST)=PRST(NPRST)-1
      IF (PRST(NPRST)) 230,230,240
  230 NPRST=NPRST-1
  240 CALL PCHAR(IBUFF,RPAR,IND)
      IPARIN=IPARIN-1
      GO TO 800
C0000 .ATOM) 0000000000000000000000000
  300 CALL PCHAR(IBUFF,DOT,IND)
  320 IND=IND+1
      CALL PCHAR(IBUFF,SPACE,IND)
  325 RPARIN=1
      IPARIN=IPARIN-1
      IF (NPRST) 420,420,3250
 3250 PRST(NPRST)=PRST(NPRST)-1
      IF (PRST(NPRST)) 3275,3275,420
 3275 NPRST=NPRST-1
      GO TO 420
C0000 ATOM 000000000000000000000000000
  400 IF (IND-60) 420,410,410
  410 CALL OUTSTR(IBUFF,IPARIN,IND)
C0000 TEST IF LAMBDA OR PROG
  420 IF (DREG(2)) 460,425,460
  425 IF (LAMBDA-IATOM) 440,430,440
  430 PRST(NPRST)=PRST(NPRST)-1
      NPRST=NPRST+1
      PRST(NPRST)=1
      GOTO 460
  440 IF (SUBR+2-IATOM) 450,430,450
C     PROG SHOULD BE SUBR+2
C0000 NOW TEST IF ATOM-LABEL IN PROG.
  450 IF (PRST(NPRST)-1) 460,455,460
  455 CALL OUTSTR(IBUFF,IPARIN,IND)
C0000 NOW TEST IF NUM. ATOM
  460 IF (NATOM-IATOM) 465,470,470
C0000 NUM. ATOM 000000000000000000000
  465 IATO=IATOM-NUMADD
      IF (IATO) 466,467,467
  466 CALL PCHAR(IBUFF,IMINUS,IND)
      IATO=-IATO
      IND=IND+1
  467 ISI=1
      DO 468 J=1,8
      JJ=IATO-IATO/10*10
      ISIFF(J)=IFIG(JJ+1)
      IATO=IATO/10
      IF (IATO) 4675,468,4675
 4675 ISI=ISI+1
  468 CONTINUE
      DO 469 J=1,ISI
      J9=ISI+1-J
      CALL PCHAR(IBUFF,ISIFF(J9),IND)
      IND=IND+1
  469 CONTINUE
      GOTO 4200
C0000 NOT NUM. ATOM 000000000000000000000
  470 DO 475 J=1,4
      CALL GETCH(PNAME1(IATOM),IUT,J)
      IF (IUT-ATEND) 472,4200,472
  472 CALL PCHAR(IBUFF,IUT,IND)
  475 IND=IND+1
      DO 480 J=1,4
      CALL GETCH(PNAME2(IATOM),IUT,J)
      IF (IUT-ATEND) 485,4200,485
  485 CALL PCHAR(IBUFF,IUT,IND)
  480 IND=IND+1
C0000 ATOM READY. TEST IF RPARIN OR PROG-LABEL
 4200 CALL PCHAR(IBUFF,SPACE,IND)
      IND=IND+1
      IF (RPARIN-1) 4300,4210,4300
 4210 CALL PCHAR(IBUFF,RPAR,IND)
      RPARIN=0
      GOTO 800
C0000 TEST IF LAMBDA OR PROG. IN THAT CASE NO NEW LINE.
 4300 IF (DREG(2)) 801,4310,801
 4310 IF (SUBR+2-IATOM) 4320,801,4320
 4320 IF (LAMBDA-IATOM)  4325,801,4325
C0000 TEST IF NEW LINE AFTER ATOM-LABEL IN PROG
 4325 IF (PRST(NPRST)-1) 801,4350,801
 4350 CALL OUTSTR(IBUFF,IPARIN,IND)
      GOTO 801
  800 IND=IND+1
  801 ILAST=I
      IF (IND-60) 810,810,805
  804 IFIRST=0
  805 CALL OUTSTR(IBUFF,IPARIN,IND)
  810 RETURN
      END
      SUBROUTINE OUTSTR(IBUFF,IBL,IND)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      DIMENSION IBUFF(18)
      MAX=IND/4+1
      WRITE(LUNUT,100) (IBUFF(I),I=1,MAX)
      DO 1 I=1,18
    1 IBUFF(I)=ALLSP
      IF (DREG(2)) 3,2,3
    2 IND=2*IBL+1
      RETURN
    3 IND=1
      RETURN
  100 FORMAT(1X,18A4)
      END
      SUBROUTINE PCHAR(IBUFF,NP1,IND)
      DIMENSION IBUFF(18)
      I=(IND-1)/4+1
      J=IND-(IND-1)/4*4
      CALL PUTCH(IBUFF(I),NP1,J)
      RETURN
      END
      SUBROUTINE IPRINT(IJK)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
C
C        NO-RECURSIVE PRINT
C        IUP POINTS TO THE UPPER CELL
C        IDOWN POINTS TO THE LOWER CELL
C        I POINTS TO THE CELL
C        USES THE IDEA OF GARBAGE COLL., BUT
C        SEARCHES ALONG CAR INSTEAD OF CDR
C
C        FIRST TEST IF LIST OR NOT
      IDUM=0
      I=IJK
      IF (I-NATOM) 3,3,2
    2 IF (NFREET-I) 3,4,4
    3 CALL PRINAT(4,I)
      CALL PRINAT(-1,IDUM)
      RETURN
    4 IVAL=I
      IUP=999999
      CALL PRINAT(1,IDUM)
C0000 DOWN SCAN 0000000000000000000000000
    5 IF (CDR(I)) 20,9,9
    9 IF (CAR(I)) 20,10,10
   10 CDR(I)=-CDR(I)-1
      IDOWN=CAR(I)
      CAR(I)=IUP
      IF (IDOWN-NATOM) 25,15,15
   15 IF (IDOWN-NFREET) 16,16,25
16    CALL PRINAT(1,IDUM)
C0000 PRINT (  0000000000
   17 IUP=I
      I=IDOWN
      GO TO 5
   20 I=IUP
      GO TO 50
   25 CALL PRINAT(4,IDOWN)
C0000 PRINT ATOM 0000000000
      GO TO 50
C
C0000 REWERSE SCAN 00000000000000000000000
C
   50 IF (I-999999) 55,95,55
   55 IF (CDR(I)-999999) 60,90,60
   60 IF (CAR(I)) 75,70,70
C 000 NO MARK FOR BRANCH-POINT 000
   70 IUP=CAR(I)
      CAR(I)=IDOWN
      GO TO 80
C0000 MARK FOR BRANCH-POINT FOUND
   75 ISL=I
      I=CDR(I)
      CDR(ISL)=IDOWN
      CAR(ISL)=-CAR(ISL)-1
      IDOWN=ISL
      GO TO 50
C0000 TEST IF CDR(I) = LIST
C0000 OBS. CDR(I) IS NEGATIVE HERE
   80 IF (NATOM+CDR(I)+1) 81,85,85
   81 IF (-1-CDR(I)-NFREET) 82,82,85
C0000 CDR(I) DOES POINT TO A LIST 000
   82 IDOWN=-CDR(I)-1
      CDR(I)=IUP
      CAR(I)=-CAR(I)-1
      GO TO 17
C0000 CAR(I) DOESN'T POINT TO A LIST
   85 CDR(I)=-CDR(I)-1
      IF (CDR(I)) 87,86,87
 86   CALL PRINAT(2,IDUM)
C0000 PRINT ) 000000
      GOTO 88
   87 CALL PRINAT(3,CDR(I))
C0000 PRINT .ATOM)
   88 IDOWN=I
      I=IUP
      GO TO 50
   90 CDR(I)=IDOWN
      CAR(I)=-CAR(I)-1
   95 I=IVAL
      CALL PRINAT(-1,IDUM)
      PRTPNT=1
      RETURN
      END
      SUBROUTINE INIT(IRESTA)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      DIMENSION ITYPAT(8)
C        ITYPV(I)0 BCD VECTOR CONTAINING 0,1,2,3,N,F,-,+
      DIMENSION ITYPV(8)
      INTEGER CONS
      EQUIVALENCE (ITYPV(1),IFIG(1))
C
C***  INIT GIVES INITIAL-VALUES TO SYSTEM CONSTANTS
      NATOM=500
      NFREET=4500
      NSTACK=950
      NFREEB=NATOM+1
      NFREEP=NFREEB
      IP=0
      JP=NSTACK+1
      IBR=0
      IPP=IP
      JPP=JP
      LUNIN=15
      LUNUT=15
      LUNINT=13
      PRTPNT=1
C00000  THE NEXT TWO STMTS ADDED FOR THE U OF M
      WRITE(LUNUT,329)
 329  FORMAT(/' U OF ME  LISP 1.5'/)
      IF (IRESTA) 21,2,2
    2 CONTINUE
      READ(LUNINT,101) ITYPV
C0000 READ 0123NF-+
      NUMADD=50000
      UNDEF=-6000
      I=0
C0000 READ NIL-BCD
      READ(LUNINT,102) ITYP,PNAME1(I),PNAME2(I)
      J=1
C0000 READ BCD FOR SYS-ATOMS
   10 I=I+1
      READ(LUNINT,102) ITYP,PNAME1(I),PNAME2(I)
      IF (ITYP-ITYPV(J)) 15,10,15
  102 FORMAT (A1,2X,2A4)
   15 ITYPAT(J)=I-1
      IF (ITYP-ITYPV(8)) 16,20,16
   16 J=J+1
      GO TO 10
   20 READ (LUNINT,101) SPACE,LPAR,RPAR,COMMA,DOT,LBRACK,RBRACK,
     *              IPROC,IPLUS,IMINUS,IFIG,ATEND,ALLSP
  101 FORMAT(21A1,A4)
      MAX=I-1
      NATOMP=MAX
C0000 READ (),.).(+-0123456789(
      ATENDA=SPACE
      DO 25 I=1,4
   25 CALL PUTCH(ATENDA,ATEND,I)
   21 SUBR0=ITYPAT(1)
      SUBR1=ITYPAT(2)
      SUBR2=ITYPAT(3)
      SUBR3=ITYPAT(4)
      SUBR =ITYPAT(5)
      FSUBR=ITYPAT(6)
      A2=SUBR1+1
      A8=SUBR1+2
      A9=SUBR1+3
      LAMBDA=FSUBR+1
      LABEL=FSUBR+2
      FUNARG=FSUBR+3
      SYS=FSUBR+4
      EXPR=FSUBR+5
      FEXPR=FSUBR+6
      T=FSUBR+7
C===  PUT ATEND IN NIL
      CALL PUTCH(NILPN1,ATEND,4)
      NILPN2=ATENDA
   28 DO 30 I=1,MAX
C0000 PUT ATEND IN PRINTNAME
      DO 29 J=1,4
      CALL GETCH(PNAME2(I),ITYP,J)
      IF (ITYP-SPACE) 29,291,29
  291 CALL PUTCH(PNAME2(I),ATEND,J)
      CALL PUTCH(PNAME1(I),ITYP,J)
      IF (ITYP-SPACE) 29,292,29
  292 CALL PUTCH(PNAME1(I),ATEND,J)
   29 CONTINUE
      CDR(I)=0
   30 CAR(I)=UNDEF
      DO 31 J=1,2
      CAR(J-2)=0
   31 CDR(J-2)=0
      CAR(T)=T
      LASTR=0
      NIL=0
      CALL MAKFRE
      IDUM=RATOM(-1)
      CALL SHIFT(123456)
      CALL JATOM(SPACE,-3)
      ALIST=CONS(CONS(NIL,NIL),NIL)
      MODE=1
      RETURN
      END
      SUBROUTINE MAKFRE
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
C0000 MAKFRE GENERATES A FREE LIST
C0000 THE VALUE IS IN NFREEP
      NFREEP=0
      DO 100 I=NFREEB,NFREET
      IF (CAR(I)) 10,15,15
   10 CAR(I)=-CAR(I)-1
      GOTO 100
   15 IF (NFREEP) 17,16,17
   16 NFREEP=I
      ILAST=I
      CDR(I)=NIL
      GOTO 100
   17 CDR(ILAST)=I
      ILAST=I
  100 CONTINUE
      CDR(ILAST)=NIL
      RETURN
      END
      INTEGER FUNCTION CONS(I1,I2)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
C
C0000 CONS 000000000000
    2 IF (CDR(NFREEP)) 5,10,5
    5 ISL=CDR(NFREEP)
      CAR(NFREEP)=I1
      CDR(NFREEP)=I2
      CONS=NFREEP
      NFREEP=ISL
      RETURN
C
C0000 FREE LIST EMPTY 00000000000000000000
C0000 DO GARB.COLL. ON I1,I2,ARG,ARG2,ARG3,ARG4,LASTR,STACK
   10 CALL GARB(I1)
      CALL GARB(I2)
      CALL GARB(ARG)
      CALL GARB(ARG2)
      CALL GARB(ARG3)
      CALL GARB(ARG4)
      CALL GARB(LASTR)
      DO 20 I=JP,STACK(I)
      ISTACK=STACK(I)
   20 CALL GARB(ISTACK)
      DO 25 I=1,NATOMP
      ICAR=CAR(I)
      ICDR=CDR(I)
      CALL GARB(ICAR)
   25 CALL GARB(ICDR)
      CALL MAKFRE
      IF (DREG(1)-T) 2,30,2
C$$$$$ TESTUTSKRIFT
   30 NR=LISTNB(NFREEP)
      WRITE(LUNUT,100) NR
  100 FORMAT (22H GARB.COLL.  FREELIST=,I5)
      GO TO 2
      END
      FUNCTION LISTNB(IJK)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
C
C0000 COUNTS THE ELEMENT IN A ONE-WAY LIST
      LISTST=IJK
      I=0
      IF (LISTST) 1,10,1
1     I=1
    2 IF (CDR(LISTST)) 5,10,5
    5 I=I+1
      LISTST=CDR(LISTST)
      GO TO 2
   10 LISTNB=I
      RETURN
      END
      FUNCTION IREAD(IDUMMY)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      INTEGER CONS,RATOM
C
C0000IREAD IS A NO RECURSIVE READ WHITCH READ ONE S-EXPRESSION
C0000LASTR SAVES THE READLIST IN CASE OF GARB.COLL.
C0000 FIRST CALL IN ORDER TO GIVE INITIAL VALUES
   10 IDUM=RATOM(-1)
      ITYP=RATOM(NAT)
      IF (ITYP-3) 21,20,21
   20 IF (IPROCI-9) 26,25,26
   25 IPROCI=1
      IREAD=-1
      ARG=NAT
      RETURN
   26 IREAD=NAT
      RETURN
   21 IF (ITYP-5) 22,500,22
   22 LAST=CONS(NIL,NIL)
      LASTR=LAST
C0000 SAVE LASTR IN CASE OF GARB.COLL.
      GO TO 51
   50 ITYP=ITYP1
      NAT=NAT1
   51 ITYP1=RATOM(NAT1)
      GOTO (100,200,300,400,500),ITYP
C           (   )   AT  ERR  (
C0000 ( 00000000000000000000000000
C        FIRST CHECK IF NEXT=)
  100 IF (ITYP1-2) 130,110,130
  110 IF (CDR(LAST)) 125,120,125
  120 IREAD=NIL
      GOTO 1000
  125 NAT=NIL
      ITYP1=RATOM(NAT1)
      GO TO 300
C        GO TO ATOM-ROUTINE
C     NOW DO THE ( ROUTINE
  130 NEW=CONS(NIL,LAST)
      CAR(LAST)=NEW
      LAST=NEW
      GO TO 50
C0000 ATOM 00000000000000000000000
  300 CAR(LAST)=NAT
  305 IF (ITYP1-2) 330,310,330
  310 NEW=CDR(LAST)
      CDR(LAST)=NAT1
      LAST=NEW
      IF (CDR(LAST)) 320,999,320
  320 ITYP1=RATOM(NAT1)
      GO TO 305
C *** ( OR ATOM AFTER ATOM
330   ICDR=CDR(LAST)
      NEW=CONS(NIL,ICDR)
      CDR(LAST)=NEW
      LAST=NEW
      GO TO 50
C>>>>> RETURN
  999 IREAD=CAR(LAST)
 1000 LASTR=NIL
C0000 NO USE OF LASTR ANY LONGER
C0000 IN THAT CASE RETURN WITH THAT VALUE, ELSE
C0000 THE VALUE IS IREAD
      IF (IPROCI-9) 1020,1010,1020
 1010 ARG=IREAD
      IREAD=-1
      IPROCI=1
 1020 RETURN
  200 WRITE(LUNUT,123)
  123 FORMAT (38H --- READ ERROR, S-EXPR. BEGINS WITH ))
  400 CALL SHIFT(123456)
      NAT=0
      GO TO 10
  500 IPROCI=9
      GO TO 10
      END
      FUNCTION MATOM(PN1,PN2)
      INTEGER PN1,PN2
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
C
C0000 MATOM CHECKS IF THE ATOM EXISTS.
C0000 CREATE A NEW ATOM
      I=0
    5 IF (PN1-PNAME1(I)) 10,20,10
   10 I=I+1
      IF (I-NATOMP) 5,5,40
   20 IF (PN2-PNAME2(I)) 10,30,10
C0000 ATOM FOUND. VALUE IS I
   30 MATOM=I
      RETURN
C0000 ATOM NOT FOUND. MAKE NEW ONE.
   40 IF (I-NATOM) 60,60,50
   50 WRITE(LUNUT,501) NATOM
  501 FORMAT (26H OBJECT STACK IS EXCEEDING ,I5)
      MATOM=NIL
      RETURN
   60 NATOMP=I
      MATOM=I
      CAR(I)=UNDEF
      CDR(I)=NIL
      PNAME1(I)=PN1
      PNAME2(I)=PN2
      RETURN
      END
      SUBROUTINE TESTUT
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
    1 WRITE(LUNUT,101)
C.....UNFORMATTED READ OF INPUT PARAMETERS
      READ(LUNIN,*)IT,MIN,MAX
      IF (IT) 10,4,2
    2 DO 3 I=MIN,MAX
    3 WRITE(LUNUT,102) I,CAR(I),CDR(I)
      GO TO 1
    4 DO 5 I=MIN,MAX
    5 WRITE(LUNUT,102) I,CAR(I),CDR(I),PNAME1(I),PNAME2(I)
      GO TO 1
   10 RETURN
  101 FORMAT(' IT MIN MAX')
  102 FORMAT (1X,I4,2I5,2A4)
      END
      INTEGER FUNCTION RATOM(IATOM)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      INTEGER BRDUM(1),SBRACK(5),RBRIND
      IDUM=0
      IF (IATOM) 1,2,2
C0000 FIRST GIVE INITIAL-VALUE IN JATOM
    1 CALL JATOM(1,IATOM)
      IBRACK=0
      RBRIND=1
       BRDUM(1)=0
      DO 123 I=1,5
  123 SBRACK(I)=0
      RETURN
    2 GO TO (10,3),RBRIND
C        RBRACK HAS BEEN READ. RETURN )
    3 IF (SBRACK(IBRACK)) 5,5,4
    4 RATOM=2
      SBRACK(IBRACK)=SBRACK(IBRACK)-1
      IATOM=NIL
      RETURN
    5 RBRIND=1
      IF (IBRACK) 10,10,6
    6 IBRACK=IBRACK-1
      GO TO 10
   10 CALL JATOM(ITYP,IATOM)
      GO TO (20,30,40,11,50,60,70),ITYP
C            A   (  )  .    $  (
   11 CALL JATOM(ITYP,IATOM)
      IF (ITYP-1) 12,13,12
   12 WRITE(LUNUT,100)
  100 FORMAT (41H --- READ ERROR    . NOT FOLLOWED BY ATOM)
  121 CALL SHIFT(123456)
      RATOM=4
      RETURN
13    CALL JATOM(ITYP,IDUM)
      IF (ITYP-3) 14,15,14
   14 WRITE(LUNUT,101)
  101 FORMAT (42H --- READ ERROR   .ATOM) NOT FOLLOWED BY ))
      GOTO 121
   15 RATOM=2
      RETURN
   20 RATOM=3
      RETURN
   30 SBRACK(IBRACK)=SBRACK(IBRACK)+1
      RATOM=1
      RETURN
   40 SBRACK(IBRACK)=SBRACK(IBRACK)-1
      RATOM=2
      IATOM=NIL
      RETURN
   50 IF (IBRACK-5) 51,30,30
   51 IBRACK=IBRACK+1
      GO TO 30
   60 RBRIND=2
      GO TO 3
   70 RATOM=5
      RETURN
      END
      SUBROUTINE SBYT(L,IB,K)
C        USED BY JATOM TO PUT ONE CHARACTER IN IB
      DIMENSION IB(2)
      IF (K-7) 1,1,2
    1 CONTINUE
        I=K/4
        II=K-4*I+1
      CALL PUTCH(IB(I+1),L,II)
        K=K+1
    2 RETURN
        END
      SUBROUTINE SHIFT(IC)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      DIMENSION LIN(72)
      EQUIVALENCE (K,RDPNT)
      IF (IC-123456) 6,5,6
    5 K=1000
      RETURN
    6 IF (K-72) 10,10,20
  20  READ(LUNIN,100,END=21) LIN
  100 FORMAT(72A1)
         K=I
   10 IC=LIN(K)
         K=K+1
         RETURN
  21     STOP
         END
      SUBROUTINE JATOM(IRET,IATOM)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
      DIMENSION IB(2)
      INTEGER CC
      IF (IATOM) 101,103,103
  101 CC=SPACE
      RETURN
  103 IND=1
      IB(1)=ATENDA
      IB(2)=ATENDA
       K1=0
       LAB=2
        ISUM=0
        NUM=2
    1   IF (CC-IPLUS) 2,26,2
    2   IF (CC-IMINUS) 3,20,3
   20 IND=-1
   26 CALL SBYT(CC,IB,K1)
       GO TO 35
    3 IF (CC-SPACE) 4,10,4
   10     GO TO (40,11),LAB
   11  CALL SHIFT(CC)
       GO TO 1
    4  IR=2
       IF (CC-LPAR) 5,25,5
    5  IR=3
       IF (CC-RPAR) 6,25,6
    6  IR=4
       IF (CC-DOT) 7,25,7
    7  IR=5
       IF (CC-LBRACK) 8,25,8
    8  IR=6
       IF (CC-RBRACK) 9,25,9
    9  IR=7
       IF (CC-IPROC) 91,25,91
   25    GO TO (40,50),LAB
   91 CALL SBYT(CC,IB,K1)
         GO TO (35,30),NUM
   30 DO 31 I=1,10
        IF (CC-IFIG(I)) 31,32,31
   31 CONTINUE
      GOTO 36
   32 IF (ISUM-1000000000) 321,35,35
  321 ISUM=ISUM*10+IND*(I-1)
       GO TO 35
   36  NUM=1
   35  LAB=1
        CALL SHIFT(CC)
       GO TO 3
   40  GO TO (41,42),NUM
   41 IATOM=MATOM(IB(1),IB(2))
      IRET=1
      RETURN
   42 IATOM=ISUM+NUMADD
      IRET=1
      RETURN
   50 IRET=IR
       CALL SHIFT(CC)
        RETURN
        END
      SUBROUTINE GARB(IJK)
COMMON AND INTEGER DECLARATIONS
C------------------------------
      COMMON  NILPN1,   PNAME1(500),       NILPN2,   PNAME2(500),
     C        NATOM,    NFREEB,  NFREET,   NSTACK,   NATOMP,   NFREEP,
     C        IP,       JP,      IBR,      IPP,      JPP,      LUNIN,
     C        LUNUT,    SPACE,   LPAR,     RPAR,     COMMA,    DOT,
     C        ALLSP,    IQUOTE,  IPLUS,    IMINUS,   LBRACK,   RBRACK,
     C        NUMADD,   UNDEF,   ATEND,    ARG,      ARG2,     ARG3,
     C        ARG4,     MODE,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     C        SUBR3,    A2,      A8,       A9,       LAMBDA,   LABEL,
     C        FUNARG,   NIL,     EXPR,     FEXPR,    SUBR,     FSUBR,
     C        T,        SYS,     RDPNT,    PRTPNT,   IFIG(10), ATENDA,
     C        IPROC,    LASTR,   BSTACK(5),DREG(24), STACK(950),
     C        NILCAR(2),CAR(4500),NILCDR(2),CDR(4500)
      INTEGER PNAME1,   PNAME2,  SPACE,    RPAR,     COMMA,    DOT,
     I        ALLSP,    RBRACK,  UNDEF,    ATEND,    ARG,      ARG2,
     I        ARG3,     ARG4,    ALIST,    SUBR0,    SUBR1,    SUBR2,
     I        SUBR3,    A2,      A8,       A9,       FUNARG,   EXPR,
     I        FEXPR,    SUBR,    FSUBR,    T,        SYS,      RDPNT,
     I        PRTPNT,   ATENDA,  BSTACK,   DREG,     STACK,    CAR,
     I        CDR
COMMON AND INTEGER DECLARATIONS ENDED
C------------------------------------
C
C       A NO-RECURSIVE GARBAGE-COLLECTOR WHITCH USES THE ALGORITHM
C        DESCRIBED IN CACM AUG 67 (NR 8)
C        ILEFT  POINTS TO THE LEFT CELL
C        I      POINTS TO THIS CELL
C        IRIGHT POINTS TO THE RIGHT CELL
C
      I=IJK
      ILEFT=999999
C0000 FIRST TEST IF I POINTS TO A LIST IN FREE MEMORY
      IF (NFREET-I) 95,2,2
    2 IF (NATOM-I) 5,95,95
C0000 FORWARD SCAN 0000000000000000000000
    5 IF (CAR(I)) 20,9,9
    9 IF (CDR(I)) 20,10,10
   10 CAR(I)=-CAR(I)-1
      IRIGHT=CDR(I)
      CDR(I)=ILEFT
      IF (IRIGHT-NATOM) 50,50,15
   15 IF (IRIGHT-NFREET) 16,16,50
   16 ILEFT=I
      I=IRIGHT
      GO TO 5
C0000 REWERSE SCAN 0000000000000000000000
   20 I=ILEFT
   50 IF (I-999999) 55,90,55
   55 IF (CAR(I)-999999) 60,91,60
   60 IF (CDR(I)) 75,70,70
C0000 NO MARK FOR BRANCH-POINT
   70 ILEFT=CDR(I)
      CDR(I)=IRIGHT
      GO TO 80
C0000 MARK FOR BRANCH-POINT
   75 ISL=I
      I=CAR(I)
      CAR(ISL)=-IRIGHT-1
      CDR(ISL)=-CDR(ISL)-1
      IRIGHT=ISL
      GO TO 50
C0000 OBS  CAR(I) IS NEG. HERE
C0000 TEST FOR SUBLIST
   80 IF (NATOM+CAR(I)+1) 81,85,85
   81 IF (-1-CAR(I)-NFREET) 82,82,85
C0000 CAR(I) POINTS TO A SUBLIST
   82 IRIGHT=-CAR(I)-1
      CAR(I)=ILEFT
      CDR(I)=-CDR(I)-1
      GO TO 16
C0000 CAR(I) DON'T POINT TO A SUBLIST
C0000 GO ON WITH BACK-UP
   85 IRIGHT=I
      I=ILEFT
      GO TO 50
   90 I=IRIGHT
      GO TO 95
   91 CAR(I)=-IRIGHT-1
      CDR(I)=-CDR(I)-1
   95 RETURN
      END