LISP     TITLE     'LISP360'                                       UOM 
******                                                                  00000010
         MACRO                                                          00000020
&NAME    ERROR     &MSG                                                 00000030
         LCLA      &L                                                   00000040
&L       SETA  K'&MSG 
LISPMSG  CSECT 
MSG&SYSNDX DC  Y(&L-3),C&MSG 
&SYSECT  CSECT 
&NAME    LA    14,MSG&SYSNDX-LISPMSG 
         B     ERROR 
         MEND                                                           00000090
******                                                                  00000100
         MACRO                                                          00000110
&NAME    SNAPS     &IDENT,&FROM,&TO                                     00000120
         CNOP      0,4                                                  00000130
&NAME    STM       13,3,SNPPSER                                         00000140
         BAL       14,SNAPROUT                                          00000150
         DC        CL8'&IDENT',A(&FROM,&TO),PL2'0'                      00000160
         LM        13,3,SNPPSER                                         00000170
         MEND                                                           00000180
******                                                                  00000190
         MACRO                                                          00000200
&NAME    PUTMSG    &DATA                                                00000210
         LCLA      &L                                                   00000220
&NAME    STM       13,1,WRSV                                            00000230
         AIF       (T'&DATA EQ 'U').A                                   00000240
         LA        14,&DATA                                             00000250
         BAL       2,PUTMSG                                             00000260
         MEXIT                                                          00000270
.A       ANOP 
&L       SETA  K'&DATA 
LISPMSG  CSECT 
MSG&SYSNDX DC  Y(&L-3),C&DATA 
&SYSECT  CSECT 
         LA    14,MSG&SYSNDX-LISPMSG 
         BAL   2,PUTMSG 
         MEND                                                           00000330
******                                                                  00000340
         MACRO                                                          00000350
&LABEL   ECHO      &NAME,&PROP,&RTN,&ACNT                               00000360
         LCLA      &LNGTH,&K,&KK,&ARGS                                  00000370
         LCLC      &P,&PP,&N,&NN,&PPP,&NNN                              00000380
&ARGS    SETA      0                                                    00000390
&LNGTH   SETA      K'&NAME                                              00000400
&K       SETA      20                                                   00000410
&KK      SETA  12                                                       00000420
&P       SETC      'NIL'                                                00000430
&PP      SETC      'NIL'                                                00000440
&PPP     SETC      'NIL'                                                00000450
&N       SETC      '&NAME'(1,4).''                                   00000460
         AIF       (&LNGTH LT 5).A                                      00000470
&KK      SETA      &KK+8                                                00000480
&K       SETA      &K+8                                                 00000490
&PP      SETC  '*+3'                                                    00000500
&NN      SETC      '&NAME'(5,4).''                                   00000510
.A       AIF       (&LNGTH LT 9).G                                      00000520
&KK      SETA      &KK+8                                                00000530
&K       SETA      &K+8                                                 00000540
&PPP     SETC  '*+3'                                                    00000550
&NNN     SETC      '&NAME'(9,4).''                                   00000560
.G       AIF       (T'&PROP EQ 'O').B                                   00000570
         AIF       (T'&ACNT EQ 'O').F                                   00000580
&ARGS    SETA      &ARGS+&ACNT                                          00000590
.F     ANOP                                                             00000600
&P       SETC      '*+'.'&KK'                                           00000610
&K       SETA      &K+24                                                00000620
.B       DC        A(*+8,*+&K)                                          00000630
&LABEL   DC    XL1'80'                                                  00000640
         DC    AL3(*+7)                                                 00000650
         DC    A(&P)                                                    00000660
         DC    CL4'&N'                                                  00000670
         DC    XL1'60'                                                  00000680
         DC    AL3(&PP)                                                 00000690
         AIF       (&LNGTH LT 5).C                                      00000700
         DC    CL4'&NN'                                                 00000710
         DC    XL1'60'                                                  00000720
         DC    AL3(&PPP)                                                00000730
.C       AIF       (&LNGTH LT 9).E                                      00000740
         DC    CL4'&NNN',XL1'60',AL3(NIL)                               00000750
.E       AIF       (T'&PROP EQ 'O').D                                   00000760
         DC        A(&PROP,*+4),A(*+8,NIL)                              00000770
         DC        AL1(&ARGS),AL3(&RTN),XL1'40',AL3(NIL)                00000780
.D       MEXIT                                                          00000790
         MEND                                                           00000800
******                                                                  00000810
         MACRO                                                          00000820
&NAME    SAVE      &R                                                   00000830
&NAME    ST    &R,0(,PDS) 
         BXH       PDS,K4,ERG2                                          00000850
         MEND                                                           00000860
******                                                                  00000870
         MACRO                                                          00000880
&NAME    UNSAVE    &R                                                   00000890
&NAME    SR         PDS,K4                                              00000900
         L     &R,0(,PDS) 
         MEND                                                           00000920
         MACRO                                                     UOM 
&LABEL   TTIMER    &XXX                                            UOM 
&LABEL   SVC       38                                              UOM 
         AR        0,1                                             UOM 
         LCR       0,0                                             UOM 
         MEND                                                      UOM 
         SPACE     1                                               UOM 
         MACRO                                                     UOM 
&LABEL   OPEN      &XXX                                            UOM 
&LABEL   L         15,=A(MAROPEN)                                  UOM 
         BALR      14,15                                           UOM 
         MEND                                                      UOM 
         SPACE     1                                               UOM 
         MACRO                                                     UOM 
&LABEL   CLOSE     &DCB                                            UOM 
         AIF       (T'&DCB EQ 'O').NOD                             UOM 
&LABEL   LA        1,&DCB                                          UOM 
.CON1    L         15,=A(MARCLOSE)                                 UOM 
         BALR      14,15                                           UOM 
         MEXIT                                                     UOM 
.NOD     ANOP                                                      UOM 
&LABEL   L         15,=A(MARCLOSE)                                 UOM 
         BALR      14,15                                           UOM 
         MEND                                                      UOM 
         SPACE     1                                               UOM 
         MACRO                                                    UOM 
&NAME    GET       &DCB,&AREA                                     UOM 
         AIF       ('&DCB' EQ '').E1                              UOM 
&NAME    IHBINNRA &DCB,&AREA                                      UOM 
         L         15,=A(GETPRO)       LOAD GET ROUTINE ADDR.     UOM 
         BALR      14,15               LINK TO GET ROUTINE        UOM 
         MEXIT                                                    UOM 
.E1      IHBERMAC  06                                             UOM 
         MEND                                                     UOM 
         SPACE     2                                              UOM 
         MACRO                                                    UOM 
&NAME    PUT       &DCB,&AREA                                     UOM 
         AIF       ('&DCB' EQ '').ERR                             UOM 
&NAME    IHBINNRA &DCB,&AREA                                      UOM 
         USING     DCBDS,1                                        UOM 
         ST        0,BFR$                                         UOM 
         L         15,IORTN$                                      UOM 
         DROP      1                                              UOM 
         BASR      14,15                                          UOM 
         MEXIT                                                    UOM 
.ERR     IHBERMAC  6                                              UOM 
         MEND 
         SPACE     1                                               UOM 
         MACRO                                                     UOM 
&LABEL   DCB       &IOR,&BFR,&EOD,&IOCODE,&LEN,&MOD,&TXTLEN        UOM 
&LABEL   DC        A(&BFR)             I/O BUFFER                  UOM 
         DS        A                   LENGTH LOC                  UOM 
         DS        A                   MODIFIERS LOC               UOM 
         DS        A                   LINE NUMBER LOC             UOM 
         DS        A                   FDUB PTR LOC                UOM 
         AIF       (T'&IOR EQ 'O').NOR                             UOM 
         DC        V(&IOR)             I/O ROUTINE                 UOM 
         AGO       .CON1                                           UOM 
.NOR     DC        A(0)                I/O ROUTINE                 UOM 
.CON1    ANOP                                                      UOM 
         DC        Y(&LEN)             LRECL                       UOM 
         DC        Y(&LEN)             TEXT LENGTH                 UOM 
         DS        F                   LINE NUMBER                 UOM 
         AIF       (T'&MOD EQ 'O').NOMOD                           UOM 
         DC        XL4&MOD             MODIFIERS                   UOM 
         AGO       .CON2                                           UOM 
.NOMOD   DC        XL4'0'              MODIFIERS                   UOM 
.CON2    DC        A(0)                FDUB PTR OR LOG. UNIT NO.   UOM 
         DC        A(&EOD)             EOD ADDRESS                 UOM 
         DC        A(&IOCODE)          I/O CODE 0->INPUT 1->OUTPUT UOM 
         DS        A                   FDUB PTR                    UOM 
         DS        A                   GDINFO VECTOR               UOM 
         DS        F                   INPUT BUFFER SIZE           UOM 
         AIF       (T'&TXTLEN EQ 'O').NT                           UOM 
         DC        A(&TXTLEN)          TEXT LENGTH                 UOM 
         AGO       .CON3                                           UOM 
.NT      DC        A(0)                TEXT LENGTH                 UOM 
.CON3    DC    A(0)               NEXT-CHARACTER ADRS 
         MEND 
         EJECT                                                          00000930
*        INTERPRETER DESIGNED AND CODED BY-                             00000940
*                 J.G.KENT, J.F.BOLCE & R.I.BERNS                       00000950
*********************************************************************** 00000960
*********          REGISTER ASSIGNMENTS      **************             00000970
***********************************************************             00000980
*********          0       LOCAL WORK REGISTER                          00000990
*********          1       LOCAL WORK REGISTER                          00001000
*********          2       LINKAGE REGISTER                             00001010
*********          3       BASE & WORK REGISTER - RESTORE PLEASE        00001020
*********                    DO NOT USE 3 INSIDE BASE 3 SECTION         00001030
*********          4  K4    CONSTANT F'4'-FOR UNSAVE ETC                00001040
*********          5  NILR  ADDR OF NIL                                 00001050
*********          6  FREE  FWS POINTER                                 00001060
*********          7  PDS  STACK POINTER                                00001070
*********          8  A    FIRST ARGUMENT                               00001080
*********          9  Q    SECOND ARGUMENT                              00001090
*********          10 M    TEMP LIST SAVE- GARBAGE COLLECTED            00001100
*********          11      BASE REGISTER                                00001110
*********          12      BASE REGISTER                                00001120
*********          13      SAVE AREA AND BASE REGISTER                  00001130
*********          14      LOCAL WORK REGISTER                          00001140
*********          15      LOCAL WORK REGISTER                          00001150
***********************************************************             00001160
LISP     START                                                          00001170
*******************   ASSEMBLY OPTIONS    *****************             00001180
STACKSIZ EQU       8000                WORDS FOR PUSHDOWN STACK    UOM 
BPSSIZE  EQU       43550               BINARY PROGRAM SPACE       UOM 
STORESIZ EQU   24000              STATIC LISP CELLS 
SBLKSIZ  EQU   4*4096             DYNAMIC CELL BLOCK SIZE 
ATMSZ    EQU       80                  SIZE OF PNAME MAX                00001220
CDEND     EQU      72                  MAX CD COL FOR S-EXPR            00001230
*                                                                       00001240
*******************   REGISTER DEFINITIONS   **************             00001250
K4       EQU       4                                                    00001260
FREE     EQU       6                                                    00001270
NILR     EQU       5                                                    00001280
PDS      EQU       7                                                    00001290
PDL      EQU   15                                                       00001300
A        EQU       8                   REGISTER DEFINITION              00001310
Q        EQU       9                                                    00001320
M        EQU       10                                                   00001330
F0       EQU       0                                                    00001340
F2       EQU       2                                                    00001350
F4       EQU       4                                                    00001360
F6       EQU       6                                                    00001370
R0       EQU       0                                                    00001380
R1       EQU       1                                                    00001390
R2       EQU       2                                                    00001400
R3       EQU       3                                                    00001410
R14      EQU       14                                                   00001420
*                                                                       00001430
CAR      EQU       0                                                    00001440
CDR      EQU       4                                                    00001450
LOGIC    EQU       X'D0'    NOTE.. FLOAT & BOOL ARE ALSO FIX            00001460
FLOAT    EQU       X'E0'                                                00001470
FIX      EQU       X'C0'                                                00001480
ATOM     EQU       X'80'                                                00001490
FWD      EQU   X'60'                                                    00001500
         EJECT                                                          00001520
*  ==================================================================== 00001530
*  ====== THE BEGINNING OF THE INTERPRETER IS COVERED BY BASE- ======== 00001540
*  ======      REGISTER 4  ============================================ 00001550
*********************************************************************** 00001560
*******************   MAIN PROGRAM   ********************************** 00001570
*********************************************************************** 00001580
MAIN     STM       14,12,12(13)                                         00001590
         LR        K4,15                                                00001600
         USING     MAIN,K4                                              00001610
         L         11,ADOFAGN                                           00001620
         USING     AGN,11                                               00001630
         LA    12,BASE12                                                00001640
         USING BASE12,12                                                00001650
         LA    3,REMFLAG                                                00001660
         USING  REMFLAG,3                                               00001670
         ST        13,SAVEBLK+4                                         00001680
         LA        13,SAVEBLK                                           00001690
         USING     SAVEBLK,13                                           00001700
         L         NILR,NILA                                            00001710
         USING     NIL,NILR            NOTE USE OF NILR AS A BASE       00001720
*                                      REGISTER TO COVER OBJECT LIST    00001730
         L         1,0(1)              LOAD PARM POINTER                00001740
         LH        2,0(1)              COUNT                            00001750
         LTR       2,2                                                  00001760
         BZ        NOPARM                                               00001770
         CLC       2(3,1),=C'BCD'                                       00001780
         BE        RDBCD                                                00001790
         PUTMSG    ' *** INVALID PARM'                                  00001800
         B         NOPARM                                               00001810
RDBCD    MVI       NOTDOT+1,C'<'                                        00001820
         MVI       CKLP+1,C'%'                                          00001830
         MVI       NOTMIN+1,X'50'      +                                00001840
         MVI       TRYRPAR+1,C'<'                                       00001850
NOPARM   EQU       *                                                    00001860
         SPIE      TRAPS,((1,13),15)                                    00001870
         SR        0,0                 INPUT CODE                  UOM 
         LA        1,=CL8'SCARDS'      LISPIN                      UOM 
         LA        2,CARDIN            INPUT DCB                   UOM 
         OPEN      ,                                               UOM 
         LA        0,1                 OUTPUT CODE                 UOM 
         LA        1,=CL8'SPRINT'      LISPOUT                     UOM 
         LA        2,PRINTCB           OUTPUT DCB                  UOM 
         OPEN      ,                                               UOM 
         LA        A,LISPIN            RDS(LISPIN)                 UOM 
         BAL       2,RDSS                                          UOM 
         LA        A,LISPOUT           WRS(LISPOUT)                UOM 
         BAL       2,WRS                                           UOM 
         L         15,=V(CANREPLY)     BATCH MODE?                 UOM 
         BALR      14,15                                           UOM 
         B         *+4(15)                                         UOM 
         B         BATCH2              NO                         UOM 
         OI        BUFFPR,X'01'        YES - ECHO INPUT            UOM 
         MVI       BATCHF,X'FF'        SET "BATCH" FLAG           UOM 
BATCH2   LA        0,ATNPRO            ATN INT PROCESSOR           UOM 
         LA        1,ATNSA             ATN SAVE AREA               UOM 
         MVI       0(1),X'00'                                      UOM 
         L         15,=V(ATTNTRP)                                  UOM 
         BALR      14,15 
         L     FREE,ADOFTOP       INITIALIZE STATIC 
         LR    2,FREE             LISP CELL STORAGE. 
         LA    A,8 
         L     Q,BOTTOM 
         SR    0,0 
         LA    1,8(,2) 
INITL    STM   0,1,0(2) 
         LR    2,1 
         BXLE  1,A,INITL 
         LA    1,1 
         STM   0,1,0(2) 
         L     0,=A(STORESIZ) 
         ST    0,CELLCNT 
         L     PDS,PUSHA          SET UP STACK POINTER. 
         LA        K4,4                                                 00002040
         BR        11                                                   00002050
ADOFAGN  DC        A(AGN)                                               00002060
ADOFTOP  DC    A(TOP1)                                                  00002070
         DROP      K4                                                   00002080
*  ======  END OF THIS BASE 4 SECTION  ================================ 00002090
*  ===================================================================  00002100
         EJECT                                                          00002110
*  ===================================================================  00002120
*  ======  BEGINNING OF SPECIAL BASE 4 SECTION  ======================= 00002130
*  ======  ONLY OPEN IS IN THIS SECTION  ============================== 00002140
         USING     BASE4,K4                                             00002150
*********************************************************************** 00002160
*********  OPEN  ****************************************************** 00002170
*********************************************************************** 00002180
OPEN     BALR      K4,0                                                 00002190
BASE4    ST        2,OPENTEMP                                           00002200
         ST    A,OPENTEMP+4                                             00002210
*                  IS OPEN GIVEN ON SYSTEM DATASETS?                    00002220
         LA        0,LISPIN                                             00002230
         CR        A,0                                                  00002240
         BE        USEREXIT            YES, LISPIN                      00002250
         LA        0,LISPOUT                                            00002260
         CR        A,0                                                  00002270
         BE        USEREXIT            YES, LISPOUT                     00002280
         LA        0,LISPUNCH                                           00002290
         CR        A,0                                                  00002300
         BNE       USERFILE                                             00002310
         L         0,PUNCHOPN          YES, LISPUNCH                    00002320
         LTR       0,0                                                  00002330
         BNZ       USEREXIT            LISPUNCH WAS ALREADY OPENED      00002340
         BAL       M,GETSTOR           OPEN LISPUNCH. PUNCOPN WILL      00002350
         ST        2,PUNCHOPN           BE 0 IF LISPUNCH IS UNOPENED.   00002360
         MVC       0(LDCB,R2),OTMDLDCB OUTPUT BCD                  UOM 
         MVC   DDAREA(8),LUPCH    MAKE IT USE SCARDS. 
         B         USEREX1                                              00002390
USERFILE LR    M,Q                                                      00002400
         LA    Q,APVAL                                                  00002410
         BAL   2,GET                                                    00002420
         CR    A,NILR                                                   00002430
         BNE       USEREXIT                                             00002440
         L     A,OPENTEMP+4                                             00002450
         LR    Q,M                                                      00002460
         LA    0,SYSIN                                                  00002470
         CR        Q,0                  OWN DDNAME. IS THE DCB          00002480
         BNE       USERFIL2            DESCRIPTOR A SYSTEMDESCRIPTOR?   00002490
         BAL       M,GETSTOR           YES, SYSIN                       00002500
         MVC       0(LDCB,R2),INMDLDCB INPUT DCB                   UOM 
         USING     DCBDS,2                                         UOM 
         MVC       LRECL#,LRECL2                                   UOM 
         B         USEREX4                                              00002540
USERFIL2 LA        0,SYSOUT                                             00002550
         CR        Q,0                                                  00002560
         BNE       USERFIL3                                             00002570
         BAL       M,GETSTOR           YES, SYSOUT                      00002580
         MVC       0(LDCB,R2),OTMDLDCB OUTPUT DCB                  UOM 
         MVC       LRECL#,LRECL3                                   UOM 
         B         USEREX5                                              00002630
USERFIL3 LA        0,SYSPUNCH                                           00002640
         CR        Q,0                                                  00002650
         BNE       USERFIL4                                             00002660
         BAL       M,GETSTOR           YES, SYSPUNCH                    00002670
         MVC       0(LDCB,R2),OTMDLDCB OUTPUT DCB                  UOM 
         BAL       1,DDNAMSET                                           00002690
         B         USEREX1                                              00002700
USERFIL4 LA        0,SYSFILE                                            00002710
         CR        Q,0                                                  00002720
         BNE       USERFIL6                                             00002730
         BAL       M,GETSTOR           YES, SYSFILE WHICH IS            00002740
*                                      USED FOR CHKPOINT OR             00002750
         LA        0,OUTPUT            RESTORE                          00002760
         C         0,ARGS              REQUIRED FOR INPUT OR OUTPUT?    00002770
         BNE       USERFIL5               (DEFAULT: INPUT)              00002780
         MVC       0(LDCB,R2),OTMDLDCB OUTPUT DCB                  UOM 
         MVC       LRECL#,LRECL2                                   UOM 
         B         USEREX5                                              00002820
USERFIL5 MVC       0(LDCB,R2),INMDLDCB INPUT DCB                   UOM 
         MVC       LRECL#,LRECL2                                   UOM 
         B         USEREX4                                              00002860
USERFIL6 LA        0,OUTPUT            THE USER HAS SPECIFIED           00002870
         C         0,ARGS               HIS OWN DDNAME AND DCB          00002880
         BNE       USERFIL7            DESCRIPTOR LIST.                 00002890
         BAL       M,GETSTOR           DCB REQUIRED FOR OUTPUT OR       00002900
         MVC       0(LDCB,R2),OTMDLDCB OUTPUT DCB                  UOM 
         TM        CAR(Q),ATOM                                     UOM 
         BNZ   USEREX5                                                  00002930
         BAL       1,SETPARAM                                           00002940
         B         USEREX5                                              00002950
USERFIL7 BAL       M,GETSTOR                                            00002960
         MVC       0(LDCB,R2),INMDLDCB INPUT DCB                   UOM 
         TM        CAR(Q),ATOM                                     UOM 
         BNZ   USEREX4                                                  00002990
         BAL       1,SETPARAM                                           00003000
         B         USEREX4                                              00003010
USEREX5  BAL       1,DDNAMSET                                           00003020
USEREX3  LA        0,1                 OUTPUT CODE                 UOM 
         LA        1,DDAREA            UNIT NAME                   UOM 
         OPEN      ,                                               UOM 
USEREXIT L         2,OPENTEMP                                           00003040
         L     A,OPENTEMP+4                                             00003050
         LA        K4,4                                                 00003060
         BR        2                                                    00003070
USEREX4  BAL       1,DDNAMSET                                           00003080
USEREX2  SR        0,0                 INPUT CODE                  UOM 
         LA        1,DDAREA            UNIT NAME                   UOM 
         OPEN      ,                                               UOM 
         B         USEREXIT                                             00003100
USEREX1  MVC       LRECL#,LRECL1                                   UOM 
         B         USEREX3                                              00003130
GETSTOR  GETSPACE  LDCB,T=2            SPACE FOR A DCB             UOM 
         LTR       15,15                                                00003150
         BZ        GETSTOR1                                             00003160
         SR        Q,Q                                                  00003170
         ERROR     ' *** D2-FILE CANNOT BE OPENED - NO STORAGE AVLBL.'  00003180
GETSTOR1 LR        2,1                 UOM 
         BR        M                                                    00003200
DDNAMSET LR        14,2                                                 00003210
         ST        2,SAVE2A            SAVE R2                     UOM 
         LR        15,A                                                 00003220
         LR        A,2                                                  00003230
         LR        Q,NILR                                               00003240
         A         Q,=X'60000000'                                       00003250
         LA        K4,4                                                 00003260
         BAL       2,CONS                                               00003270
         LR        Q,A                                                  00003280
         LR        A,15                                                 00003290
         LR        0,1                                                  00003300
         BAL       2,CSET                                               00003310
         LR        1,0                                                  00003320
         L         K4,ADBASE4                                           00003330
         MVC   DDAREA,BLANKS      BLANK UNIT NAME AREA. 
         L         15,CAR(15)                                           00003350
         LM        Q,M,0(15)                                            00003360
         CLI       0(15),X'00'         NAME OR INTEGER?            UOM 
         BNE       SHHV                NAME                        UOM 
         ST        Q,DDAREA            NUMBER                      UOM 
         B         DDNAMX2                                         UOM 
SHHV     SR        15,15                                           UOM 
         LA        14,DDAREA           POINT TO UNIT NAME AREA     UOM 
NAMAGAIN SLDL      A,8                                                  00003380
         STC       A,0(15,14)                                      UOM 
         LTR       Q,Q                                                  00003400
         LA        15,1(0,15)                                           00003410
         BZ        NAMTEST                                              00003420
         B         NAMAGAIN                                             00003430
NAMTEST  LA    M,0(0,M)                                                 00003440
         CR    M,NILR                                                   00003450
         BE        DDNAMX2                                         UOM 
         L         Q,CAR(M)                                             00003470
NAMAGN   SLDL  A,8                                                      00003480
         STC       A,0(15,14)                                      UOM 
         LTR       Q,Q                                                  00003500
         LA        15,1(,15)                                      UOM 
         BZ        DDNAMX                                         UOM 
         B     NAMAGN                                                   00003530
DDNAMX   L         M,CDR(M)            NEXT BCD CELL               UOM 
         B         NAMTEST                                         UOM 
DDNAMX2  L         2,SAVE2A                                        UOM 
         BR        1                                                    00003550
SETPARAM ST        1,PARTEMP                                            00003560
PARMAGN  LA        M,LRECL                                              00003570
         CR        Q,NILR                                               00003580
         BE        PARMEXIT                                             00003590
         LM        A,Q,0(Q)                                             00003600
         BAL       1,FINDPARM                                           00003610
         STH       15,LRECL#           BUFFER SIZE                 UOM 
         LA        M,TXTLEN                                        UOM 
         BAL       1,FINDPARM                                           00003640
         ST        15,TXTLEN#                                      UOM 
         LA        M,AA                                                 00003660
         BAL       1,FINDPARM                                           00003670
         NOP       0                                               UOM 
         B         PARMAGN                                              00003690
FINDPARM LM        14,15,0(A)                                           00003700
         CR        14,M                                                 00003710
         BNE       4(1)                                                 00003720
         L         15,CAR(15)                                           00003730
         L         15,CAR(15)                                           00003740
         BR        1                                                    00003750
PARMEXIT L         A,OPENTEMP+4                                         00003760
         L         1,PARTEMP                                            00003770
         BR        1                                                    00003780
OPENTEMP DC        2F'0'                                                00003790
PARTEMP  DC        F'0'                                                 00003800
STORADDR DC        2F'0'                                                00003810
PUNCHDDN DC        CL8'LISPUNCH'                                        00003830
LRECL2   DC    AL2(80)                                                  00003840
LRECL1   EQU       LRECL2                                               00003850
LRECL3   DC        AL2(132)                                       UOM 
OTMDLDCB DCB       ,0,0,1,0            OUTPUT DCB                  UOM 
INMDLDCB DCB       ,0,EOF,0,0,'80000000'                           UOM 
SAVE2A   DS        A                   SAVE R2                     UOM 
DDAREA   DS        CL84                BUILD UNIT NAME             UOM 
         DROP      2                                               UOM 
         DROP      K4                                                   00003920
*  ======  END OF THIS SPECIAL BASE 4 SECTION  ======================== 00003930
*  ===================================================================  00003940
         EJECT                                                          00003950
*                                                                  UOM 
*        ENTER WITH GR0 CONTAINING I/O CODE (0->INPUT, 1->OUTPUT)  UOM 
*        GR1 POINTS TO LOGICAL UNIT NAME OR FDNAME                 UOM 
*        GR2 POINTS TO DCB                                         UOM 
*                                                                  UOM 
         USING     MAROPEN,15                                      UOM 
MAROPEN  STM       0,15,GETSA          SHARE SAVE AREA WITH GETPRO UOM 
         LR        8,15                                            UOM 
         LR        10,0                I/O CODE                    UOM 
         LR        11,1                UNIT NAME                   UOM 
         LR        12,2                DCB LOC                     UOM 
         DROP      15                                              UOM 
         USING     MAROPEN,8                                       UOM 
         USING     DCBDS,12                                        UOM 
         CLI       0(11),X'00'         A UNIT NUMBER?              UOM 
         BNE       LUNLU               NO                          UOM 
         OI        INOUT#,X'80'        INDICATE LOGICAL UNIT       UOM 
         MVC       FDUB#,0(1)          YES - MOVE TO PARM LIST     UOM 
         MVC       BCDUN(1),0(1)       BUILD BCD UNIT NAME         UOM 
         LM        0,1,BCDUN           SET FOR CALL TO GDINFO      UOM 
         B         CGDIN                                           UOM 
         SPACE     1                                               UOM 
*                                                                  UOM 
*        LOOK UP NAME IN LOGICAL UNIT TABLE                        UOM 
*                                                                  UOM 
         SPACE     1                                               UOM 
LUNLU    LA        5,LUNAM             POINT TO UNIT TABLE         UOM 
         LA        6,LUCNT             NO. OF ENTRIES              UOM 
LULUL    CLC       0(8,5),0(11)        NAMES MATCH?                UOM 
         BE        GOTUN               YES                         UOM 
         LA        5,12(,5)            POINT TO NEXT ENTRY         UOM 
         BCT       6,LULUL                                         UOM 
FDNAME   L         15,=V(GETFD)        MIGHT BE AN FDNAME          UOM 
         BASR      14,15                                           UOM 
         ST        0,FDUB#             SAVE FDUB                   UOM 
         SR        1,1                 CALL GDINFO WITH FDUB       UOM 
CGDIN    L         15,=V(GDINFO)                                   UOM 
         BALR      14,15                                           UOM 
         ST        1,GDIV#             SAVE PTR TO VECTOR          UOM 
         MVC       FDUB2#,0(1)         SAVE FDUB                   UOM 
LRHBS    LTR       10,10               INPUT OR OUTPUT             UOM 
         BZ        INLGL               INPUT                       UOM 
         OI    INOUT#,X'01'       SET "OUTPUT" BIT. 
         LH        0,LRECL#            USER-LENGTH                 UOM 
         LTR       0,0                 SPECIFIED?                  UOM 
         BZ        LA120               NO - ASSUME 120             UOM 
         C         0,=F'120'                                       UOM 
         BNH       *+8                                             UOM 
LA120    LA        0,120                                           UOM 
         LH        6,10(,1)            GDINFO LENGTH               UOM 
         CR        0,6                                             UOM 
         BNH       *+6                                             UOM 
         LR        0,6                                             UOM 
         ST        0,TXTLEN#                                       UOM 
         STH       0,LEN#                                          UOM 
         CLC       IORTN$,=F'0'        IS THERE AN I/O ROUTINE?    UOM 
         BNE       RISU                YES                         UOM 
         MVC       IORTN$,=V(WRITE)    NO - USE WRITE              UOM 
         B         RISU                                            UOM 
         SPACE     1                                               UOM 
*                                                                  UOM 
*        PROCESS "INPUT" TYPE                                      UOM 
*                                                                  UOM 
         SPACE     1                                               UOM 
INLGL    LH        6,8(,1)             INPUT LENGTH                UOM 
         LH        0,LRECL#            USER-SPECIFIED REC LEN      UOM 
         CR        0,6                 CHOOSE MAX                  UOM 
         BNH       *+6                                             UOM 
         LR        6,0                                             UOM 
         ST        6,BUFSIZ#           THIS IS INPUT BUFFER SIZE   UOM 
         LTR   0,0                DID USER GIVE LRECL? 
         BP    *+10               YES -- SKIP. 
         STH   6,LRECL#           NO; USE GDINFO LENGTH. 
         LR    0,6 
         L     6,TXTLEN#          GET TXTLEN. 
         LTR   6,6                DID USER SPECIFY IT? 
         BNP   OPENO              NO -- USE LRECL. 
         CR    6,0                YES; LIMIT TXTLEN TO LRECL. 
         BNH   *+6 
OPENO    LR    6,0 
         ST    6,TXTLEN# 
         LA    0,3                NOW GET BUFFER. 
         L         1,BUFSIZ#                                       UOM 
         L         15,=V(GETSPACE)                                 UOM 
         BALR      14,15                                           UOM 
         ST        1,BFR$                                          UOM 
         CLC       IORTN$,=F'0'        IS THERE AN I/O ROUTINE?    UOM 
         BNE       RISU                YES                         UOM 
         MVC       IORTN$,=V(READ)     NO - USE READ               UOM 
*                                                                  UOM 
RISU     LA        0,LEN#                                          UOM 
         ST        0,LEN$                                          UOM 
         LA        0,LIN#                                          UOM 
         ST        0,LIN$                                          UOM 
         LA        0,MOD#                                          UOM 
         ST        0,MDF$                                          UOM 
         LA        0,FDUB#                                         UOM 
         ST        0,FDUB$                                         UOM 
         LM        0,15,GETSA          RESTORE EVERYBODY           UOM 
         BR        14                                              UOM 
*                                                                  UOM 
GOTUN    MVC       IORTN$,8(5)         MOVE I/O ROUTINE            UOM 
         OI        INOUT#,X'80'                                    UOM 
         LM        0,1,0(5)            GET BCD UNIT NAME           UOM 
         B         CGDIN                                           UOM 
*                                                                  UOM 
         DROP      8                                               UOM 
         USING     BASE12,12                                       UOM 
         DS        0F                                              UOM 
BCDUN    DC        CL8' '              BUILD 8-BYTE UNIT NAME      UOM 
*                                                                  UOM 
*        TABLE OF NON-NUMERIC LOGICAL UNIT NAMES                   UOM 
*                                                                  UOM 
LUNAM    DC        CL8'SCARDS',V(SCARDS)                           UOM 
         DC        CL8'SPRINT',V(SPRINT)                           UOM 
LUPCH    DC    CL8'SPUNCH',V(SPUNCH) 
         DC        CL8'GUSER',V(GUSER)                             UOM 
         DC        CL8'SERCOM',V(SERCOM)                           UOM 
LUCNT    EQU       (*-LUNAM)/12 
         EJECT                                                     UOM 
*                                                                  UOM 
*        SUPPORT FOR "CLOSE" MACRO                                 UOM 
*                                                                  UOM 
         SPACE     1                                               UOM 
         USING     MARCLOSE,15                                     UOM 
MARCLOSE STM       0,15,GETSA                                      UOM 
         LR        Q,15                                            UOM 
         LR        M,1                 COPY DCB PTR                UOM 
         USING     MARCLOSE,Q                                      UOM 
         USING     DCBDS,M                                         UOM 
         DROP      15                                              UOM 
         L         0,FDUB2#            GET FDUB                    UOM 
         TM        INOUT#,X'80'        LOGICAL UNIT?               UOM 
         BO        NOFREEFD            YES - DON'T FREE            UOM 
         LTR       0,0                 WAS THERE EVER AN FDUB?     UOM 
         BZ        NOFREEFD            NO - DON'T FREE             UOM 
         L         15,=V(FREEFD)       FREE IT                     UOM 
         BALR      14,15                                           UOM 
NOFREEFD TM        INOUT#,X'01'        INPUT DEVICE?               UOM 
         BO        NOFREEB             NO - DON'T FREE BUFFER      UOM 
         L         1,BFR$              POINT TO BUFFER             UOM 
         LTR       1,1                 A BUFFER TO FREE?           UOM 
         BZ        NOFREEB                                         UOM 
         SR        0,0                 FREE IT ALL                 UOM 
         L         15,=V(FREESPAC)                                 UOM 
         BASR      14,15                                           UOM 
NOFREEB  L     1,GDIV#            FREE THE FDINFO INFO 
         LTR   1,1                IF ANY 
         BZ    NOFREEG 
         L     15,=V(FREESPAC) 
         SR    0,0 
         BASR  14,15 
NOFREEG  LR        1,M                 FREE THE DCB                UOM 
         LA        0,CARDIN            IGNORE LISPIN & LISPOUT     UOM 
         CR        0,1                                             UOM 
         BE        NOFREED                                         UOM 
         LA        0,PRINTCB                                       UOM 
         CR        0,1                                             UOM 
         BE        NOFREED                                         UOM 
         SR        0,0                                             UOM 
         L         15,=V(FREESPAC)                                 UOM 
         BASR      14,15                                           UOM 
NOFREED  LM        0,15,GETSA                                     UOM 
         BR        14                                              UOM 
         DROP      M,Q                                             UOM 
         EJECT                                                     UOM 
*                                                                  UOM 
*        PROCESS "ATTN"                                            UOM 
*                                                                  UOM 
         SPACE     1                                               UOM 
ATTN     BALR      1,0                                             UOM 
         USING     *,1                                             UOM 
         L         15,=V(ATTNTRP)                                  UOM 
         LR        14,2                COPY RETURN ADDRESS         UOM 
         SR        0,0                 ASSUME ATN OFF              UOM 
         CR        A,NILR              ATTN OFF?                   UOM 
         BE        ATNOFF              YES                         UOM 
         LA        0,ATNPRO            ATN ON                      UOM 
ATNOFF   LA        1,ATNSA                                         UOM 
         DROP      1                                               UOM 
         MVI       0(1),X'00'                                      UOM 
         BR        15                                              UOM 
         SPACE     2                                               UOM 
*                                                                  UOM 
*        ATTENTION INTERRUPT PROCESSOR                             UOM 
*                                                                  UOM 
         SPACE     1                                               UOM 
ATNPRO   LR        10,15                                           UOM 
         USING     ATNPRO,10                                       UOM 
         LM        11,13,=A(AGN,BASE12,SAVEBLK)                    UOM 
         LM        2,9,16(1)                                       UOM 
         CR    FREE,K4            IN GARBAGE COLLECTION? 
         BL    ATNOTNOW           YES. 
         L         2,INDCBADR          LOOK AT INPUT DCB           UOM 
         USING     DCBDS,2                                         UOM 
         L     0,LASTCHAR         SAVE CHARACTER PTR. 
         ST    0,NXTCHR# 
         L         1,GDIV#             POINT TO GDINFO VECTOR      UOM 
         CLI       12(1),X'01'         *MSOURCE*?                  UOM 
         BE    ATNP3              YES -- LOOK AT *SINK*. 
         TM        MSFLOC,X'01'        *MSOURCE* OPENED?           UOM 
         BO        MSNP                YES                         UOM 
         OI        MSFLOC,X'01'        SET SWITCH                  UOM 
         LA        2,MSRCDCB           POINT TO *MSOURCE* DCB      UOM 
         LA        1,=C'*MSOURCE* '                                UOM 
         SR        0,0                 INPUT CODE                  UOM 
         OPEN      ,                   OPEN *MSOURCE*              UOM 
MSNP     L     0,MSRCDCB+TXTLEN#-DCBDS   FAKE RDS(*MSOURCE*). 
         ST        0,CARDLNTH                                      UOM 
         LA        0,MSRCDCB                                       UOM 
         ST    0,INDCBADR                                          UOM 
ATNP3    SR    0,0                FORCE NEW INPUT LINE. 
         ST        0,LASTCHAR                                      UOM 
         L     2,OTDCBADR         LOOK AT OUTPUT DCB. 
         L         1,GDIV#                                         UOM 
         CLI       12(1),X'02'         *MSINK*?                    UOM 
         BE        NOMO                *MSINK* OPEN?               UOM 
         TM        MSFLOC,X'02'        *MSINK* OPEN?               UOM 
         BO        WHATTN              YES                         UOM 
         OI        MSFLOC,X'02'        SET BIT                     UOM 
         LA        2,MSNKDCB           POINT TO *MSINK* DCB        UOM 
         LA        1,=C'*MSINK* '                                  UOM 
         LA        0,1                 OUTPUT CODE                 UOM 
         OPEN      ,                                               UOM 
WHATTN   LA    14,MSGBUFFR        FAKE WRS(*MSINK*) 
         ST        14,MARGIN2                                      UOM 
         LA        0,MSNKDCB                                       UOM 
         ST        0,OTDCBADR                                      UOM 
         LA        14,LINE                                         UOM 
         ST        14,MARGIN1                                      UOM 
         LA        14,100(,14)                                     UOM 
         ST        14,LINEMAX                                      UOM 
         LA        14,20(,14)                                      UOM 
         ST        14,SUPMAX                                       UOM 
         DROP      2                                               UOM 
NOMO     MVC   MSGBUFFR,BLANKS    CLEAR MESSAGE BUFFER. 
         PUTMSG    ' LISP ATTN'                                    UOM 
         SR    0,0 
ATNCALL  LA    1,ATNSA 
         STC   0,0(,1) 
         ST    NILR,ERRARG 
         LR        0,10                ATN TRAP PROCESSOR          UOM 
         L     15,=V(ATTNTRP) 
         BALR      14,15                                           UOM 
         B         ERRPU                                           UOM 
ATNOTNOW LA    0,255 
         B     ATNCALL 
         DROP      10                                              UOM 
         EJECT                                                    UOM 
*                                                                 UOM 
*        PROCESS "BATCH"                                          UOM 
*                                                                 UOM 
         SPACE     1                                              UOM 
BATCH    BALR      1,0                                            UOM 
         USING     *,1                                            UOM 
         LR        A,NILR              ASSUME CONVERSATIONAL      UOM 
         CLI       BATCHF,X'00'        TRUE?                      UOM 
         BER       2                   YES                        UOM 
         LA        A,T                 NO - CONVERSATIONAL        UOM 
         BR        2                                              UOM 
         SPACE     1                                              UOM 
*                                                                 UOM 
*        PROCESS "MTS"                                            UOM 
*                                                                 UOM 
         SPACE     1                                              UOM 
MTS      BALR      1,0                                            UOM 
         USING     *,1                                            UOM 
         STM       0,15,GETSA                                     UOM 
         L         15,=V(MTS)                                     UOM 
         BALR      14,15                                          UOM 
         USING     *,14                                           UOM 
         LM        0,15,GETSA                                     UOM 
         LR        A,NILR                                         UOM 
         BR        2                                              UOM 
         DROP      1,14                                           UOM 
         EJECT                                                     UOM 
*                                                                  UOM 
*        PROCESS "GET" MACRO                                       UOM 
*        GR1 POINTS TO DCB                                         UOM 
*                                                                  UOM 
         SPACE     1                                               UOM 
         USING     GETPRO,15                                       UOM 
         USING     DCBDS,8                                         UOM 
GETPRO   STM       0,15,GETSA                                      UOM 
         LR        10,15                                           UOM 
         LR        8,1                                             UOM 
         DROP      15                                              UOM 
         USING     GETPRO,10                                       UOM 
CRING2   L         15,IORTN$           I/O ROUTINE ADDRESS         UOM 
         BALR      14,15                                           UOM 
         LTR       15,15               EOF                         UOM 
         BNZ       GETEOF              YES                         UOM 
         LTR       0,0                 READ OK?                    UOM 
         BZ        LROK                NO - NEW FDUB OPENED        UOM 
         L     1,GDIV#            FREE OLD GDINFO INFO 
         SR    0,0 
         L     15,=V(FREESPAC) 
         LTR   1,1                IF ANY 
         BZ    *+6 
         BASR  14,15 
         L         0,FDUB2#            POINT TO IT                 UOM 
         SR        1,1                                             UOM 
         L         15,=V(GDINFO)       GET NEW INFO                UOM 
         BALR      14,15                                           UOM 
         ST        1,GDIV#             SAVE VECTOR PTR             UOM 
         LTR       15,15                                           UOM 
         BNZ       CRING                                           UOM 
         CLC       =C'NONE',4(1)                                   UOM 
         BE        CRING                                           UOM 
         LH    6,8(,1)            MAX. INPUT LENGTH 
         C     6,BUFSIZ#          IS BUFFER BIG ENOUGH? 
         BNH   CRING              YES -- SKIP. 
         SR        0,0                 NO - FREE OLD BUFFER        UOM 
         L         1,BFR$              POINT TO BUFFER             UOM 
         L         15,=V(FREESPAC)                                 UOM 
         BALR      14,15                                           UOM 
         LR        1,6                 GET NEW BUFFER              UOM 
         LA        0,3                                             UOM 
         L         15,=V(GETSPACE)                                 UOM 
         BALR      14,15                                           UOM 
         ST        1,BFR$                                          UOM 
         ST    6,BUFSIZ#          STORE NEW BUFFER SIZE. 
CRING    LR        1,8                 POINT TO DCB                UOM 
         B         CRING2                                          UOM 
LROK     L         1,BFR$              POINT TO INPUT BUFFER 
         LH        2,LEN#              INPUT LENGTH                UOM 
         L         3,BUFSIZ#           BUFFER SIZE                 UOM 
         CR        2,3                 OVERFLOW?                   UOM 
         BH        GETABORT            YES                         UOM 
         BE        GETEQ               ON THE NOSE                 UOM 
         LA    4,0(1,2)           POINT TO END OF TEXT. 
         LA    5,X'07'            MAKE 3-BIT MASK. 
         NR    5,4                GET POS'N IN DOUBLEWORD. 
         LA    5,BLANKS(5)        ADD TO ADRS. OF BLANKS. 
         SR    3,2                COMPUTE NBR BLANKS NEEDED. 
         LA    0,128              MOVE UP TO 128 AT A TIME. 
GETM     CR    3,0 
         BNH   GETN 
         MVC   0(128,4),0(5) 
         AR    4,0 
         SR    3,0 
         B     GETM 
GETN     BCTR  3,0 
         EX    3,GETMVC 
GETEQ    LM        2,15,GETSA+8                                    UOM 
         BR        14                                              UOM 
GETMVC   MVC   0(0,4),0(5) 
GETEOF   L         15,EODAD#           EOF EXIT                    UOM 
         LM        0,14,GETSA                                      UOM 
         BR        15                                              UOM 
GETABORT LM        0,15,GETSA                                      UOM 
         DROP      8,10                                            UOM 
         MVI       ERRORIND,X'03'      ERROR ON                    UOM 
         ERROR     ' *** RECORD LENGTH EXCEEDS BUFFER SIZE'        UOM 
GETSA    DS        18F                                             UOM 
ATNSA    DS        18F                 ATNTTRP SAVE AREA           UOM 
MSRCDCB  DCB       READ,0,LASTCARD,0,0,'80000000' *MSOURCE* DCB    UOM 
MSNKDCB  DCB       WRITE,0,0,1,132     *MSINK* DCB                 UOM 
MSFLOC   DC        X'00'               *MSOURCE*/*MSINK* OPEN      UOM 
         LTORG                                                     UOM 
         EJECT 
*        SPECIAL BASE 4 SECTION TO INITIALIZE THE HASH TABEL FOR ATOMS 
* 
HASHINIT LR    K4,15 
         USING HASHINIT,K4 
         GETSPACE 4*4096,T=3      GET A HASH TABLE 
         ST    1,HASHTBL          SAVE IT 
         A     1,=A(4*4096-1)     FIND END 
         ST    1,ENDHASH 
         L     1,HASHTBL          BEGINNING AGAIN 
         SR    0,0                LEAR IT 
         ST    0,0(0,1) 
         LA    1,4(0,1) 
         C     1,ENDHASH 
         BL    *-12 
         L     1,OBJECTA          OBJECT LIST 
HSHI1    L     14,CAR(0,1)        POINT TO ATOM 
         L     14,CAR(0,14)       POINT TO FULL WORD 
         LH    15,0(0,14)         COMPUT HASH 
         AH    15,2(0,14) 
         MH    15,=X'7A3C' 
         N     15,=X'00003FE0' 
         A     15,HASHTBL 
HSHI2    MVI   LPSW,0             NO LOOP YET 
         C     0,0(0,15)          EMPTY ENTRY? 
         BE    HSHI3              YES 
         LA    15,4(0,15)         NEXT 
         C     15,ENDHASH         END? 
         BL    HSHI2              NO 
         L     15,HASHTBL         WRAP AROUND 
         XI    LPSW,1             AVOID INFINITE LOOPS 
         BNZ   HSHI2              NOPE 
         B     TMNYATM            TOO MANY ATOMES 
HSHI3    L     14,CAR(0,1)        POINT TO ATOM 
         ST    14,0(0,15)         INTO HSH TBL 
         L     1,CDR(0,1)         NEXT ATOM 
         CR    1,NILR             END? 
         BNE   HSHI1              NOPE 
         LA    K4,4               RESTORE 4 
         DROP  K4 
         B     SCH1 
         LTORG 
         EJECT 
* ===================================================================== 00003960
* =====  BEGINNING OF ANOTHER SPECIAL BASE 4 SECTION ================== 00003970
* =====  ONLY EXITERR IN THIS SECTION  ================================ 00003980
         USING BASE4A,K4                                                00003990
*********************************************************************** 00004000
*****    EXITERR  ***************************************************** 00004010
*********************************************************************** 00004020
EXITERR  BALR  K4,0                                                     00004030
BASE4A   CR    A,NILR                                                   00004040
         BE    EXOFF         RESET TO NORMAL                            00004050
         MVI   T1+1,X'F0'    SET FOR EXITS                              00004060
         MVI   T2+1,X'F0'                                               00004070
         MVI   T3+1,X'F0'                                               00004080
         MVI   T4+1,X'F0'                                               00004090
         MVI   T5+1,X'F0'                                               00004100
         MVI   T6+1,X'F0'                                               00004110
         MVI   T7+1,X'F0'                                               00004120
         MVI   T8+1,X'F0'                                               00004130
         MVI   T9+1,X'F0'                                               00004140
         B     EXOUT                                                    00004160
EXOFF    MVI   T1+1,X'00'                                               00004170
         MVI   T2+1,X'00'                                               00004180
         MVI       T3+1,X'10'                                      UOM 
         MVI   T4+1,X'00'                                               00004200
         MVI   T5+1,X'00'                                               00004210
         MVI   T6+1,X'00'                                               00004220
         MVI   T7+1,X'00'                                               00004230
         MVI   T8+1,X'00'                                               00004240
         MVI   T9+1,X'00'                                               00004250
EXOUT    LA    K4,4                                                     00004270
         BR    2                                                        00004280
         DROP  K4                                                       00004290
* =====  END OF THIS SPECIAL BASE 4 SECTION  ========================== 00004300
* ===================================================================== 00004310
BATCHF   DC        X'00'               BATCH FLAG 00 -> CONV      UOM 
         EJECT                                                          00004320
*  ==================================================================== 00004330
*  ======  BEGINNING OF BASEREGISTER 11 SECTION. THIS SECTION IS FULL = 00004340
AGN      DS        0H                                             UOM 
         NI        MAININD,X'00'                                        00004360
         BAL       2,READ              READ THE FUNCTION                00004370
         ST        A,GARBT             HOLD IT                          00004380
         BAL       2,READ              READ ARGUMENTS                   00004390
         ST        A,GARBT+4           HOLD THEM                        00004400
         TM    MAININD,X'05'                                            00004410
         BZ        NOBUG                                                00004420
         PUTMSG     READERR                                             00004430
         L     A,GARBT                                                  00004440
         BAL   2,PRINT                                                  00004450
         L     A,GARBT+4                                                00004460
         BAL   2,PRINT                                                  00004470
         NI    MAININD,X'00'                                            00004480
         B     AGN                                                      00004490
*         TM       DBIND,X'01'          DEBUG MODE                      00004500
*        BZ        NOBUG                NO                              00004510
NOBUG    TM        GARBSW,X'01'        IGNORE TITLES?              UOM 
         BZ        SEQM1               YES                         UOM 
         PUTMSG    MA                                              UOM 
         L         A,GARBT                                              00004530
         BAL       2,PRINT                                              00004540
         L         A,GARBT+4                                            00004550
         BAL       2,PRINT                                              00004560
SEQM1    L         Q,GARBT+4                                       UOM 
         L         A,GARBT                                              00004580
         TTIMER                                                         00004590
         ST        0,STIM              DONT COUNT READ TIME             00004600
         BAL       2,EVALQUOT                                           00004610
         TTIMER                                                         00004620
         L         1,STIM                                               00004630
         ST        0,STIM                                               00004640
         SR        1,0                                                  00004650
         M         0,=F'5'                                         UOM 
         D         0,=F'384'                                       UOM 
         CVD       1,TEA               INTO DECIMAL                     00004680
         MVC   MB+9(8),MASK                                             00004690
         ED    MB+9(8),TEA+4                                            00004700
         TM        GARBSW,X'01'                                    UOM 
         BZ        SEQM2                                           UOM 
         PUTMSG    MB                                                   00004710
SEQM2    BAL       2,PRINT                                         UOM 
         B         AGN                                                  00004730
*        SNAPS BPS,BPSST,BPSST+4*BPSSIZE                                00004740
*        SNAPS     STACK,PUSH,PUSH+4*STACKSIZ                           00004750
*        SNAPS     OBJLIST,OBJECT,OBJECT+8*STORESIZ                     00004760
STOP     EQU       *                                                    00004770
         CLOSE (PRINTCB)                                                00004780
         L         13,SAVEBLK+4                                         00004790
         RETURN (14,12)                                                 00004800
MA       DC    AL2(29),C'0  ARGUMENTS FOR EVALQUOTE ...'                00004810
STIM     DC        F'2000000000'       20                               00004820
TEA      DC        D'0'                DP WORK AREA                     00004830
MASK     DC        X'40',5X'20',X'2120'                                 00004840
MB       DC    AL2(31),C'0  TIME        MS,  VALUE IS ...'              00004850
READERR  DC    AL2(66),C' *** ERRORS ENCOUNTERED WHILE READING.'        00004860
         DC    C' CONTINUING WITH NEXT DOUBLET'                         00004870
MAININD  DC    X'00'                                                    00004880
         EJECT                                                          00004890
*********************************************************************** 00004900
*******************   TRAP SUPERVISOR   ******************************* 00004910
*********************************************************************** 00004920
TRAPS    CR        FREE,K4             A GARBCOLL TRAP                  00004930
         BL        GARBCOLL                                             00004940
         CLI       7(1),X'08'                                           00004950
         BL        TRAPS1                                               00004960
         MVC       OFLOW(1),7(1)                                        00004970
         UNPK      OFLOWTP(3),OFLOW(2)                                  00004980
         TR        OFLOWTP(2),SNPTR-240                                 00004990
         PUTMSG    OFLOWMSG                                             00005000
T1       BC    0,STOP                                                   00005010
         BR        14                                                   00005020
TRAPS1   MVC       SAVEBLK+12(8),4(1)    MOVE PSW                       00005030
         SNAPS     TRAP_PSW,SAVEBLK+12,SAVEBLK+19                       00005040
         MVC       SAVEBLK+12(12),20(1)                                 00005050
         STM       3,7,SAVEBLK+24                                       00005060
         SNAPS     REGS0-7,SAVEBLK+12,SAVEBLK+43                        00005070
         STM       8,13,SAVEBLK+12                                      00005080
         MVC       SAVEBLK+36(8),12(1)                                  00005090
         SNAPS     REGS8-15,SAVEBLK+12,SAVEBLK+43                       00005100
         MVC       9(3,1),=AL3(SYSER)                                   00005110
T2       BC    0,STOP                                                   00005120
         BR        14                                                   00005130
CONS1    ST        A,CAR(FREE)                                          00005140
         BR        14                                                   00005150
SYSER    ERROR     '0*** ERROR: CAR TAKEN OF FULLCELL'                  00005160
OFLOWMSG DC    AL2(33),C' *** OVER-OR UNDERFLOW OF TYPE '               00005170
OFLOWTP  DC        X'00000000'                                          00005180
OFLOW    DC        H'0'                                                 00005190
         EJECT                                                          00005200
CARDIN   DCB       SCARDS,0,LASTCARD,0,0,'80000000'                UOM 
PRINTCB  DCB       SPRINT,0,0,1,132                                UOM 
SNAPROUT ST        14,SNPSV                                             00005250
         L         2,8(14)             LOWER BOUND                      00005260
         MVC       SNPA(8),0(14)                                        00005270
         AP        16(2,14),SNP1                                        00005280
         UNPK      SNPA+9(3),16(2,14)                                   00005290
         OI        SNPA+11,X'F0'                                        00005300
SNPLN    ST        2,SNPA+31                                            00005310
         UNPK      SNPA+13(7),SNPA+31(5)                                00005320
         TR        SNPA+13(6),SNPTR-240                                 00005330
         MVC   SNPA+19(100),BLANKS+4 
         LA        1,SNPA+22                                            00005360
         LA        3,8                                                  00005370
SNPAL    C         2,12(14)                                             00005380
         BH        SNPOUT                                               00005390
         UNPK      0(9,1),0(5,2)                                        00005400
         TR        0(8,1),SNPTR-240                                     00005410
         MVI       8(1),C' '                                            00005420
         LA        1,09(,1)                                             00005430
         LA        2,4(,2)                                              00005440
         BCT       3,SNPAL                                              00005450
SNPOUT   L         R1,OTDCBADR                                          00005460
         L         0,MARGIN2                                            00005470
         PUT       (R1),(0)                                             00005480
         L         14,SNPSV                                             00005490
         C         2,12(14)            UPPER                            00005500
         BNH       SNPLN                                                00005510
         MVC   MSGBUFFR,BLANKS 
         BH        18(14)                                               00005540
SNP1     DC        PL1'1'                                               00005550
SNPSV    DC        F'0'                                                 00005560
SNPPSER  DC        7F'0'                                                00005570
         DS    0D 
MSGBUFFR DC    CL129' '           FOR MESSAGES AND DUMPS 
SNPA     EQU   MSGBUFFR+1 
SNPPP    DC        CL13' '                                              00005600
SNPTR    DC        C'0123456789ABCDEF'                                  00005610
DTRAH    DC    H'-78,-68,-58,-49,-39,-29,-20,-10,0,9,19,28,38'          00005620
         DC    H'48,57,67'                                              00005630
         DS    0D 
BLANKS   DC    CL(128+8)'  ' 
LINE     DC    CL124' ',CL14' ' 
         EJECT                                                          00005640
*********************************************************************** 00005650
*******************   EVALQUOTE(FN,ARGS)   NON REC  ******************* 00005660
*********************************************************************** 00005670
EVS      DC        3F'0'                                                00005680
EVALQUOT STM       A,Q,EVS+4                                            00005690
         ST        2,EVS                                                00005700
         LA        Q,FEXPR             TRY FEXPR                        00005710
         BAL       2,GET                                                00005720
         CR        A,NILR              IS IT                            00005730
         BNE       EVL                 ITS EXPR                         00005740
         L         A,EVS+4                                              00005750
         LA        Q,FSUBR             TRY FSUBR                        00005760
         BAL       2,GET                                                00005770
         CR        A,NILR              IS IT                            00005780
         BNE       EVL                 IT IS FSUBR                      00005790
*        APPLY(FN,ARGS,NIL)                                             00005800
         ST        NILR,ARGS                                            00005810
         LM        A,Q,EVS+4                                            00005820
         BAL       2,APPLY                                              00005830
         B         EVQS                                            UOM 
*        EVAL(CONS(FN,ARGS),NIL)                                        00005860
EVL      LM        A,Q,EVS+4                                            00005870
         BAL       2,CONS                                               00005880
         LR        Q,NILR                                               00005890
         BAL       2,EVAL                                               00005900
EVQS     ST        A,ER##              SAVE FOR RES#               UOM 
         L         2,EVS                                                00005910
         BR        2                                                    00005920
         EJECT                                                          00005930
*********************************************************************** 00005940
*******************    EVAL(FORM,A)   RECURSIVE   ********************* 00005950
*********************************************************************** 00005960
TRACEIND DC        X'0000'                                              00005970
EVAL     SAVE      2                   SAVE RET                         00005980
EVALL    CR        A,NILR                                               00005990
         BE        RETURN              RET NIL                          00006000
         TM        CAR(A),FIX          A NUMBER                         00006010
         BO        RETURN              YES                              00006020
         STM       A,Q,EVLSV           SAVE PARAMS                      00006030
         TM        CAR(A),ATOM                                          00006040
         BZ        EVALST              NO                               00006050
         LA        Q,APVAL             IS IT APVAL                      00006060
         BAL       2,GET                                                00006070
         CR        A,NILR                                               00006080
         BE        EVNAP               NO                               00006090
         L     A,CAR(,A)          YES -- RETURN VALUE. 
         B         RETURN                                               00006110
EVNAP    LM        A,Q,EVLSV           AN ATOM AND NOT APVAL            00006120
         LA        1,ERRA8                                              00006130
         BAL       2,SASSOC                                             00006140
         L     A,CDR(,A) 
         B         RETURN                                               00006160
ERRA8    ERROR     ' *** A8-UNDEFINED VARIABLE'                         00006170
ERRA9    ERROR     ' *** A9-FUNCTION NOT DEFINED'                       00006180
EVALST   EQU       *                                                    00006190
NTEV     EQU       *                                                    00006200
         L     A,CAR(,A)          FORM NOT AN ATOM; TRY QUOTE. 
         LA        1,QUOTE                                              00006220
         CR        A,1                                                  00006230
         BNE       EVNQ                NOT QUOTE                        00006240
         L         A,EVLSV                                              00006250
         L         A,CDR(A)                                             00006260
         L         A,CAR(A)            CADR(FORM)                       00006270
         B         RETURN                                               00006280
EVNQ     LA        1,COND              TRY COND                         00006290
         CR        A,1                                                  00006300
         BNE       EVNC                NOT COND                         00006310
         L         A,EVLSV             IT IS COND                       00006320
         L         A,CDR(A)                                             00006330
         BAL       2,EVCON                                              00006340
         B         RETURN                                               00006350
EVNC     TM        CAR(A),ATOM                                          00006360
         BZ        EVNA                NO                               00006370
         ST        A,EVLSV+8                                            00006380
         LA        Q,EXPR                                               00006390
         BAL       2,GET                                                00006400
         CR        A,NILR                                               00006410
         BE        EVNXP               NOT EXPR                         00006420
*        APPLY(---,EVLIS(CDR(FORM),A),A                                 00006430
         TM    TRACEIND,X'01'     TEST FOR TRACING                      00006440
         BNO   NOTRACE            NO TRACE                              00006450
         SAVE  A                  SAVE EXPR DEFN.                       00006460
         L     A,EVLSV+8          RESTORE FUNCTION                      00006470
         SAVE  A                  SAVE IT                               00006480
         LM    A,Q,EVLSV          RESTORE EVALARGS                      00006490
         SAVE  Q                  SAVE  ASSOC.LIST                      00006500
         L     A,CDR(A)           FIND ARGS.                            00006510
         BAL   2,EVLIS                                                  00006520
         ST    A,EVLSV            STORE RESULTS IN                      00006530
         ST    A,PVARG            LOCAL & I/O STORE.                    00006540
         UNSAVE Q                 UNSAVE ASSOC. LIST                    00006550
         ST    Q,ARGS             STORE IT                              00006560
         UNSAVE A                 UNSAVE AND STORE                      00006570
         ST    A,EVLSV+8          THE FUNCTION                          00006580
         TM    0(A),X'01'         SHOULD IT BE TRACED                   00006590
         BNO   NOTRA              NO                                    00006600
         BAL   2,PRARG            YES, PRINT FUNCTION + ARGS.           00006610
NOTRA    L     Q,EVLSV            RESTORE ARGS TO Q                     00006620
         UNSAVE A                 UNSAVE  EXPR POINTER                  00006630
         L     2,EVLSV+8          RESTORE FUNCTION                      00006640
         SAVE  2                  SAVE  IT                              00006650
         BAL   2,APPLY            APPLY FUNCTION                        00006660
         ST    A,EVLSV            STORE VALUE IN                        00006670
         ST    A,PVARG            LOCAL + I/O STORE                     00006680
         UNSAVE A                 UNSAVE FUNCTION                       00006690
         TM    0(A),X'01'         SHOULD IT BE TRACED                   00006700
         BNO   NOTRB              NO                                    00006710
         BAL   2,PRVAL            PRINT FUNTION + VALUE                 00006720
NOTRB    L     A,EVLSV            RESTORE VALUE                         00006730
         B     RETURN             RETURN                                00006740
NOTRACE  SAVE  A                                                        00006750
         LM    A,Q,EVLSV                                                00006760
         SAVE  Q                                                        00006770
         L     A,CDR(A)                                                 00006780
         BAL   2,EVLIS                                                  00006790
         UNSAVE Q                                                       00006800
         ST    Q,ARGS             ASSOC  LIST                           00006810
         LR    Q,A                                                      00006820
         UNSAVE A                                                       00006830
         BAL   2,APPLY                                                  00006840
         B     RETURN                                                   00006850
EVNXP    L     A,EVLSV+8          CAR(FORM)                             00006860
         LA    Q,FEXPR                                                  00006870
         BAL   2,GET              IS IT FEXPR                           00006880
         CR    A,NILR                                                   00006890
         BE    EVNFXP                                                   00006900
*        APPLY(---,LIST(CDR(FORM)A)A)                                   00006910
         LR    M,A                                                      00006920
         L     A,EVLSV+4          ALIST                                 00006930
         ST    A,ARGS                                                   00006940
         LR    Q,NILR                                                   00006950
         BAL   2,CONS                                                   00006960
         LR    Q,A                                                      00006970
         L     A,EVLSV                                                  00006980
         L     A,CDR(A)                                                 00006990
         BAL   2,CONS                                                   00007000
         TM    TRACEIND,X'01'     TEST FOR TRACING                      00007010
         BNO   NOTRACE2           NO                                    00007020
         LR    Q,A                PUT ARGS IN Q                         00007030
         L     A,EVLSV+8          GET FUNCTION                          00007040
         SAVE  A                  SAVE FUNCTION                         00007050
         TM    0(A),X'01'         SHOULD IT BE TRACED                   00007060
         BNO   NOTR2A             NO                                    00007070
         ST    M,EVLSV+4          STORE ADDR OF FEXPR                   00007080
         ST    Q,EVLSV            STORE ARGS                            00007090
         ST    Q,PVARG            ALSO IN I/O ROUTINE                   00007100
         BAL   2,PRARG            PRINT FUNCTION AND ARGS.              00007110
         LM    Q,M,EVLSV          PUT ARGS IN Q, ADDR OF FEXPR IN M     00007120
NOTR2A   LR    A,M                PUT ADDR. OF FEXPR IN A               00007130
         BAL   2,APPLY            CALL APPLY                            00007140
         UNSAVE M                 GET THE FUNCTION                      00007150
         TM    0(M),X'01'         SHOULD IT BE TRACED                   00007160
         BNO   RETURN             NO, RETURN                            00007170
         ST    A,EVLSV            STORE VALUE                           00007180
         ST    A,PVARG            ALSO IN I/O ROUTINE                   00007190
         LR    A,M                PUT FUNCTION IN A                     00007200
         BAL   2,PRVAL            PRINT FUNCTION AND VALUE              00007210
         L     A,EVLSV            RESTORE VALUE                         00007220
         B     RETURN             RETURN                                00007230
NOTRACE2 LR    Q,A                                                      00007240
         LR    A,M                                                      00007250
         B     APPLYY                                                   00007260
EVNFXP   L     A,EVLSV+8                                                00007270
         LA    Q,SUBR             TRY SUBR                              00007280
         BAL   2,GET                                                    00007290
         CR    A,NILR                                                   00007300
         BE    EVNS               NOT SUBR                              00007310
         L         Q,ALIST                                              00007320
         SAVE      Q                                                    00007330
         SAVE  A                  SUBR ADDR.                            00007340
         LM    A,M,EVLSV                                                00007350
         SAVE  Q                  ALIST                                 00007360
         SAVE  M                  FUNCTION                              00007370
         L     A,CDR(A)                                                 00007380
         BAL   2,EVLIS                                                  00007390
         UNSAVE Q                 UNSAVE FUNCTION                       00007400
         TM    TRACEIND,X'01'     TEST FOR TRACING                      00007410
         BNO   NOTRACE3           NO                                    00007420
         ST    Q,EVLSV+8          STORE FUNCTION                        00007430
         TM    0(Q),X'01'         SHOULD FUNCTION BE TRACED             00007440
         BNO   NOTR3A             NO                                    00007450
         ST    A,EVLSV            SAVE  ARGS                            00007460
         ST    A,PVARG            ALSO IN I/O ROUTINE                   00007470
         LR    A,Q                PUT  FUNCTION IN A                    00007480
         BAL   2,PRARG            PRINT FUNCTION AND ARGS.              00007490
         L     A,EVLSV            RESTORE  ARGS.                        00007500
         L     Q,EVLSV+8          RESTORE  FUNCTION                     00007510
NOTR3A   STM   A,Q,TAPPL          IN CASE OF ARG. CT. ERROR             00007520
         UNSAVE Q                 GET ASSOC LIST                        00007530
         ST    Q,ALIST            PUT IN ALIST                          00007540
         BAL   2,SPREAD           RETURNS ARG CT. IN REG 1              00007550
         UNSAVE 14                SUBR ADDR.                            00007560
         L     M,EVLSV+8          RESTORE FUNCTION                      00007570
         SAVE  M                  SAVE IT                               00007580
         STC   1,*+5              CHECK ARG CT.                         00007590
         CLI   0(14),X'00'                                              00007600
         BE    EVNOERR                                                  00007610
         LM    A,Q,TAPPL                                                00007620
         BL    SUBRER             TO MANY ARGS.                         00007630
         B     SUBRERO            TO FEW                                00007640
EVNOERR  L     14,0(14)           SUBR ADR.                             00007650
         BALR  2,14               CALL SUBR                             00007660
         UNSAVE M                 RESTORE FUNCTION                      00007670
         UNSAVE    Q                                                    00007680
         ST        Q,ALIST                                              00007690
         TM    0(M),X'01'         SHOULD IT BE TRACED                   00007700
         BNO   RETURN             NO, RETURN                            00007710
         ST    A,EVLSV            STORE VALUE                           00007720
         ST    A,PVARG            ALSO  IN  I/O ROUTINE                 00007730
         LR    A,M                PUT FUNCTION IN A                     00007740
         BAL   2,PRVAL            PRINT FUNCTION AND VALUE              00007750
         L     A,EVLSV            RESTORE VALUE                         00007760
         B     RETURN             RETURN                                00007770
NOTRACE3 STM   A,Q,TAPPL                                                00007780
         UNSAVE Q                 ALIST                                 00007790
         ST    Q,ALIST                                                  00007800
         BAL   2,SPREAD                                                 00007810
         UNSAVE 14                SUBR ADR.                             00007820
         B     EXSUBR             EXECUTE SUBR. COUNT ARGS              00007830
EVNS     L     A,EVLSV+8                                                00007840
         LA    Q,FSUBR                                                  00007850
         BAL   2,GET                                                    00007860
         CR    A,NILR                                                   00007870
         BE    EVNFS                                                    00007880
         LR    14,A               ADR OF FSUBR IN 14                    00007890
         L         Q,ALIST                                              00007900
         SAVE      Q                                                    00007910
         LM    A,Q,EVLSV          PICK UP EVALARGS                      00007920
         ST    Q,ALIST            SET UP ALIST                          00007930
         L     A,CDR(A)           RESULT                                00007940
         TM    TRACEIND,X'01'     TEST FOR TRACING                      00007950
         BNO   EXSUBRB            NO,  EXECUTE FSUBR                    00007960
         L     M,EVLSV+8          RESTORE FUNCTION                      00007970
         SAVE  M                  SAVE IT                               00007980
         TM    0(M),X'01'         SHOULD IT BE TRACED                   00007990
         BNO   NOTR4A             NO                                    00008000
         ST    14,EVLSV+8         STORE FSUBR ADR.                      00008010
         ST    A,EVLSV            STORE RESULT                          00008020
         ST    A,PVARG            ALSO IN I/O ROUTINE                   00008030
         LR    A,M                PUT FUNCTION IN A                     00008040
         BAL   2,PRARG            PRINT FUNCTION AND ARGS.              00008050
         LM    A,M,EVLSV          RESTORE RESULT,ALIST,FSUBR ADR.       00008060
         LR    14,M               FSUBR ADR. IN  14                     00008070
NOTR4A   L     14,CAR(14)         FSUBR  ADR.                           00008080
         BALR  2,14               CALL FSUBR                            00008090
         UNSAVE M                 UNSAVE FUNCTION                       00008100
         UNSAVE    Q                                                    00008120
         ST        Q,ALIST                                              00008130
         TM    0(M),X'01'         SHOULD IT BE TRACED 
         BNO   RETURN             NO, RETURN                            00008140
         ST    A,EVLSV            SAVE VALUE                            00008150
         ST    A,PVARG            ALSO IN I/O ROUTINE                   00008160
         LR    A,M                PUT FUNCTION IN A                     00008170
         BAL   2,PRVAL            PRINT FUNCTION AND VALUE              00008180
         L     A,EVLSV            RESTORE VALUE                         00008190
         B     RETURN             RETURN                                00008200
*        EVAL(CONS(CDR(SASSOC(CAR(FORM),A,U)),CDR(FORM)),A)             00008210
EVNFS    L         A,EVLSV+8           CAR(FORM)                        00008220
         L         Q,EVLSV+4                                            00008230
         LA        1,ERRA9                                              00008240
         BAL       2,SASSOC                                             00008250
         L         A,CDR(A)                                             00008260
         L         Q,EVLSV                                              00008270
         L         Q,CDR(Q)                                             00008280
         BAL       2,CONS                                               00008290
         L         Q,EVLSV+4                                            00008300
         B         EVALL                                                00008310
*        APPLY(CAR(FORM),EVLIS(CDR(FORM),A),A)                          00008320
EVNA     SAVE      A                   CAR(FORM)                        00008330
         L         Q,EVLSV+4                                            00008340
         SAVE      Q                   ALIST                            00008350
         L         A,EVLSV                                              00008360
         L         A,CDR(A)                                             00008370
         BAL       2,EVLIS                                              00008380
         UNSAVE    Q                                                    00008390
         ST        Q,ARGS                                               00008400
         LR        Q,A                                                  00008410
         UNSAVE    A                                                    00008420
         BAL       2,APPLY                                              00008430
         B         RETURN                                               00008440
         EJECT                                                          00008450
*********************************************************************** 00008460
*******************   APPLY(FN,ARGS,A)   RECURSIVE  ******************* 00008470
*********************************************************************** 00008480
APPLY    SAVE      2                                                    00008490
APPLYY   CR        A,NILR                                               00008500
         BE        RETURN    IF FN=NIL RETURN NIL                       00008510
NTAP     EQU       *                                                    00008520
         TM        CAR(A),ATOM         IS FN ATOM                       00008530
         BZ        APPNATM             NO                               00008540
         STM       A,Q,TAPPL           SAVE ARGS                        00008550
         LA        Q,EXPR                                               00008560
         BAL       2,GET                                                00008570
         CR        A,NILR                                               00008580
         BE        APNEXPR             LIST WASNT AN EXPR               00008590
*        APPLY(---,ARGS)                                                00008600
         L     Q,TAPPL+4          PUT ARGS IN Q                         00008610
         TM    TRACEIND,X'01'     TEST FOR TRACING                      00008620
         BNO   APPLYY             NO, CALL APPLY                        00008630
         ST    A,EVLSV            SAVE EXPR ADR.                        00008640
         L     A,TAPPL            GET FUNCTION                          00008650
         SAVE  A                  SAVE IT                               00008660
         TM    0(A),X'01'         SHOULD IT BE TRACED                   00008670
         BNO   NOTR5A             NO                                    00008680
         ST    Q,PVARG            SAVE ARGS IN I/O ROUTINE              00008690
         BAL   2,PRARG            WRITE FUNCTIONS AND ARGS.             00008700
         L     Q,TAPPL+4          RESTORE ARGS.                         00008710
NOTR5A   L     A,EVLSV            RESTORE EXPR  ADR                     00008720
         BAL   2,APPLY            CALL APPLY                            00008730
         UNSAVE M                 UNSAVE FUNCTION                       00008740
         TM    0(M),X'01'         SHOULD IT BE TRACED                   00008750
         BNO   RETURN             NO                                    00008760
         ST    A,TAPPL            SAVE VALUE                            00008770
         ST    A,PVARG            ALSO IN I/O ROUTINES                  00008780
         LR    A,M                PUT FUNCTION IN A                     00008790
         BAL   2,PRVAL            WRITE FUNCTION AND VALUES             00008800
         L     A,TAPPL            RESTORE VALUE RETURN                  00008810
         B     RETURN                                                   00008820
APNEXPR  LA    Q,SUBR             TRY SUBR                              00008830
         L     A,TAPPL                                                  00008840
         BAL   2,GET                                                    00008850
         CR    A,NILR                                                   00008860
         BE    APNSUBR            NOT A SUBR                            00008870
         L         Q,ALIST                                              00008880
         SAVE      Q                                                    00008890
         L     Q,ARGS             ITS A SUBR                            00008900
         ST    Q,ALIST            SET UP ALIST                          00008910
         LR    14,A               ADDR OF SUBR                          00008920
         L     A,TAPPL+4                                                00008930
         BAL   2,SPREAD           RETURNS ARG CNT IN REG 1              00008940
         TM    TRACEIND,X'01'     TEST FOR TRACING                      00008950
         BNO   EXSUBR             NO                                    00008960
         L     M,TAPPL            GET FUNCTION                          00008970
         SAVE  M                  SAVE IT                               00008980
         TM    0(M),X'01'         SHOULD IT BE TRACED                   00008990
         BNO   NOTR6A             NO                                    00009000
         ST    14,EVLSV           SAVE SUBR. ADR.                       00009010
         ST    1,EVLSV+4          SAVE ARG. CT.                         00009020
         STM   A,Q,GARBT                                                00009030
         L     A,TAPPL+4                                                00009040
         ST    A,TAPPL            SAVE ARGS                             00009050
         ST    A,PVARG            ALSO IN I/O ROUTINE                   00009060
         LR    A,M                PUT FUNCTION IN A                     00009070
         BAL   2,PRARG            WRITE FUNCTION AND ARGS.              00009080
         L     14,EVLSV           RESTORE  SUBR ADR.                    00009090
         L     1,EVLSV+4          RESTORE ARG CNT.                      00009100
         LM    A,Q,GARBT                                                00009110
NOTR6A   STC   1,*+5                                                    00009120
         CLI   0(14),X'00'                                              00009130
         BE    APNOERR                                                  00009140
         LM    A,Q,TAPPL                                                00009150
         BL    SUBRER                                                   00009160
         B     SUBRERO                                                  00009170
APNOERR  L     14,0(14)           ROUTINE  ADR.                         00009180
         BALR  2,14                                                     00009190
         UNSAVE M                 UNSAVE FUNCTION                       00009200
         UNSAVE    Q                                                    00009210
         ST        Q,ALIST                                              00009220
         TM    0(M),X'01'         SHOULD IT BE TRACED                   00009230
         BNO   RETURN             NO                                    00009240
         ST    A,TAPPL            STORE  VALUE                          00009250
         ST    A,PVARG            ALSO IN I/O ROUTINE                   00009260
         LR    A,M                PUT FUNCTION IN A                     00009270
         BAL   2,PRVAL            WRITE FUNCTION AND VALUE              00009280
         L     A,TAPPL            RESTORE VALUE                         00009290
         B     RETURN                                                   00009300
EXSUBR   STC   1,*+5                                                    00009310
         CLI   0(14),X'00'                                              00009320
         BE    EXSUBRB                                                  00009330
         LM    A,Q,TAPPL                                                00009340
         BL    SUBRER                                                   00009350
SUBRERO  ERROR ' *** F3-TOO FEW ARGUMENTS-SUBR'                         00009360
SUBRER   ERROR ' *** F2-TOO MANY ARGUMENTS-SUBR'                        00009370
EXSUBRB  L     14,0(14)           ROUTINE  ADR.                         00009380
         BALR  2,14                                                     00009390
         UNSAVE    Q                                                    00009400
         ST        Q,ALIST                                              00009410
         B     RETURN                                                   00009420
*        APPLY(CDR(SASSOC(FN,A,U)),ARGS,A)                              00009430
APNSUBR  L         Q,ARGS                                               00009440
         L         A,TAPPL                                              00009450
         LA        1,ERRA2                                              00009460
         BAL       2,SASSOC                                             00009470
         L         A,CDR(A)                                             00009480
         L         Q,TAPPL+4                                            00009490
         B         APPLYY                                               00009500
APPNATM  L         14,CAR(A)                                            00009510
         LA        15,LABEL            TRY LABEL                        00009520
         CR        14,15                                                00009530
         BE        APLBL               A LABEL                          00009540
         LA        15,FUNARG           TRY FUNARG                       00009550
          CR       14,15                                                00009560
         BE        APFUN               YES                              00009570
         LA        15,LAMBDA           TRY LAMBDA                       00009580
         CR        14,15                                                00009590
         BE        APLAM               ITS LAMBDA                       00009600
*        APPLY(EVAL(FN,A),ARGS,A)                                       00009610
         SAVE      Q                                                    00009620
         L         Q,ARGS              ASSOC LIST                       00009630
         SAVE      Q                                                    00009640
         BAL       2,EVAL                                               00009650
         UNSAVE    Q                                                    00009660
         ST        Q,ARGS                                               00009670
         UNSAVE    Q                                                    00009680
         B         APPLYY                                               00009690
*        APPLY(CADDR(FN),ARGS,CONS(CONS(CADR(FN),CADDR(FN)),A))         00009700
APLBL    SAVE      Q                   PROCESS LABEL                    00009710
         L         Q,CDR(A)                                             00009720
         L         A,CAR(Q)            CADR                             00009730
         L         Q,CDR(Q)            CDDR                             00009740
         L         Q,CAR(Q)            CADDR                            00009750
         SAVE      Q                                                    00009760
         BAL       2,CONS                                               00009770
         L         Q,ARGS                                               00009780
         BAL       2,CONS                                               00009790
         ST        A,ARGS                                               00009800
         UNSAVE    A                   CADDR                            00009810
         UNSAVE    Q                   ARGS                             00009820
         B         APPLYY                                               00009830
*        APPLY(CADR(FN),ARGS,CADDR(FN))                                 00009840
APFUN    L         A,CDR(A)                                             00009850
         L         14,CDR(A)           CDDR                             00009860
         L         14,CAR(14)          CADDR                            00009870
         ST        14,ARGS                                              00009880
         L         A,CAR(A)            CADR                             00009890
         B         APPLYY                                               00009900
*        EVAL(CADDR(FN),NCONC(PAIR(CADR(FN),ARGS),A))                   00009910
APLAM    L         A,CDR(A)            LAMBDA                           00009920
         ST        A,TAPPL                                              00009930
         L         A,CAR(A)            CADR                             00009940
         BAL       2,PAIR                                               00009950
         L         Q,ARGS                                               00009960
         BAL       2,NCONC                                              00009970
         LR        Q,A                                                  00009980
         L         A,TAPPL                                              00009990
         L         A,CDR(A)                                             00010000
         L         A,CAR(A)                                             00010010
         MVI       PROGIND,0           SET OFF FOR LAMBDA EXPR          00010020
         BAL       2,EVAL                                               00010030
         B         RETURN                                               00010040
ERRA2    ERROR     ' *** A2-FUNCTION NOT DEFINED'                       00010050
         EJECT                                                          00010060
*********************************************************************** 00010070
*******************   EVCON(C,A)   RECURSIVE   ************************ 00010080
*********************************************************************** 00010090
EVCON    SAVE      2                                                    00010100
         SAVE      A                   EXTRA SAVE IN CASE OF COND ERROR 00010110
EVCONN   CR        A,NILR                                               00010120
         BE        EVERA3                                               00010130
         C     NILR,CAR(,A) 
         BE    EVNIL              SKIP NIL 
*        EVAL(CAAR(C),A)                                                00010140
         O         A,PROGIND           SAVE PROGIND ALSO                00010150
         SAVE      A                                                    00010160
         SAVE      Q                                                    00010170
         L     A,CAR(,A) 
         L     A,CAR(,A)          CAAR 
         BAL       2,EVAL                                               00010200
         LR        M,A                                                  00010210
         UNSAVE    Q                                                    00010220
         UNSAVE    A                                                    00010230
         LR        1,A                                                  00010240
         SRL       1,24                                                 00010250
         STC       1,PROGIND                                            00010260
         CR        M,NILR                                               00010270
         BNE       EVCE                                                 00010280
*        EVCON(CDR(C),A)                                                00010290
EVNIL    L     A,CDR(,A) 
         B         EVCONN                                               00010310
*        EVAL(CADAR(C),A)                                               00010320
EVCE     L         A,CAR(A)                                             00010330
         L         A,CDR(A)            CADR                             00010340
         L         A,CAR(A)            CADAR                            00010350
         BAL       2,EVAL                                               00010360
         UNSAVE    1                   EXTRA SAVE WASNT NEEDED          00010370
         B         RETURN                                               00010380
EVERA3   UNSAVE    A                   PRINT ORIGINAL LIST              00010390
         TM        PROGIND,X'01'       IF PROG ITS OK                   00010400
         BO        RETURN                                               00010410
CONDER   ERROR ' *** A3-NO ARGS OF COND TRUE'                           00010420
         EJECT                                                          00010430
*********************************************************************** 00010440
*******************   EVLIS(M,A)   RECURSIVE    *********************** 00010450
*********************************************************************** 00010460
EVLIS    CR        A,NILR              NIL LIST                         00010470
         BE        0(2)                                                 00010480
         SAVE      2                                                    00010490
         LR        1,NILR                                               00010500
EVLISS   SAVE      A                                                    00010510
         SAVE      Q                                                    00010520
         SAVE      1                                                    00010530
         L         A,CAR(A)                                             00010540
         BAL       2,EVAL                                               00010550
         LR        Q,NILR                                               00010560
         BAL       2,CONS                                               00010570
         LR        Q,A                                                  00010580
         UNSAVE    A                                                    00010590
         BAL       2,NCONC                                              00010600
         LR        1,A                                                  00010610
         UNSAVE    Q                                                    00010620
         UNSAVE    A                                                    00010630
         L         A,CDR(A)                                             00010640
         CR        A,NILR                                               00010650
         BNE       EVLISS                                               00010660
         LR        A,1                                                  00010670
         B         RETURN                                               00010680
         EJECT                                                          00010690
*********************************************************************** 00010700
*******************    GET(X,Y)    NON REC    ************************  00010710
**********************************************************************  00010720
*        SEARCH LIST X FOR ITEM Y, RETURN CAR OF REST OF LIST, ELSE NIL 00010730
GET      CR        A,NILR              IS X NIL                         00010740
         BCR       8,2                 YES, EXIT                        00010750
         C     Q,CAR(,A)          COMPARE Y TO CAR(X). 
         L     A,CDR(,A) 
         BNE   GET 
         L     A,CAR(,A) 
         BR        2                                                    00010800
         EJECT                                                          00010810
*********************************************************************** 00010820
*******************   SASSOC(X,Y,U)  NON REC   ************************ 00010830
*********************************************************************** 00010840
*        SEARCHES LIST Y OF DOTTED PAIRS FOR X IN CAR, RET PTR TO PAIR  00010850
*        INTERNAL ENTRY POINT SASSOC - R1 IS ERROR MACRO ADDRESS        00010860
*        LISP ENTRY POINT SASSOCC - U IS ERROR FUNCTION                 00010870
INER     DC        X'00'               INTERNAL CALL TO SASSOC          00010880
DBIND    DC        X'00'               ON IF DEBUG TRACING              00010890
SASSOC   MVI       INER,X'01'                                           00010900
         STM       A,Q,ERSV            IN CASE OF SASSOC ERROR          00010910
         B         SASSOCC+4                                            00010920
SASSOCC  MVI       INER,X'00'                                           00010930
         LR        M,Q                                                  00010940
SASSOCS  CR        M,NILR                                               00010950
         BE        SASSER                                               00010960
         LM        Q,M,CAR(M)                                           00010970
         C     A,CAR(,Q) 
         BNE       SASSOCS                                              00010990
         LR        A,Q                                                  00011000
         BR        2                                                    00011010
SASSER   TM        INER,X'01'                                           00011020
         BO        SINER               INTRNAL CALL                     00011030
         L         A,ARGS                                               00011040
         L         Q,ALIST                                              00011050
         ST        Q,ARGS                                               00011060
         LR        Q,NILR                                               00011070
         B         APPLY                                                00011080
SINER    LM        A,Q,ERSV                                             00011090
         BR        1                                                    00011100
         EJECT                                                          00011110
*********************************************************************** 00011120
*******************    PAIR(X,Y)    NON REC    ************************ 00011130
*********************************************************************** 00011140
*        PAIR FORMS LIST ((XN YN)...(X1 Y1)) FROM LISTS X AND Y         00011150
TA       EQU       14                  POINTS AT X LIST                 00011160
TQ       EQU       15                  POINTS AT Y LIST                 00011170
PAIR     STM       A,Q,GARBT+4         IN CASE OF GARB COLLN            00011180
         ST        2,PSV                                                00011190
         LR        TA,A                                                 00011200
         LR        TQ,Q                                                 00011210
         LR        M,NILR              LINK OF NEW LIST                 00011220
PAIRR    CR        TA,NILR                                              00011230
         BE        PANIL               END OF X LIST                    00011240
         CR        TQ,NILR                                              00011250
         BE        PQNIL               END OF Y LIST                    00011260
         L         A,CAR(TA)                                            00011270
         L         Q,CAR(TQ)                                            00011280
         BAL       2,CONS              (XN.YN)                          00011290
         LR        Q,M                 LAST LINK IN LIST                00011300
         BAL       2,CONS              ADD TO LIST                      00011310
         LR        M,A                                                  00011320
         L         TA,CDR(TA)                                           00011330
         L         TQ,CDR(TQ)                                           00011340
         B         PAIRR                                                00011350
PANIL    L         2,PSV                                                00011360
         CR        TQ,NILR                                              00011370
         BE        0(2)      BOTH A AND Q NIL                           00011380
         LM        A,Q,GARBT+4                                          00011390
         ERROR     ' *** F2-TOO MANY ARGUMENTS-EXPR'                    00011400
PQNIL    LM        A,Q,GARBT+4                                          00011410
         ERROR     ' *** F3-TOO FEW ARGUMENTS-EXPR'                     00011420
         EJECT                                                          00011430
*********************************************************************** 00011440
*******************  APPEND(X,Y)       NON REC   ******************$$$  00011450
**********************************************************************  00011460
*        FORM LIST (X Y) FROM LISTS X AND Y                             00011470
*        NCONC(COPY(X),Y)                                               00011480
APT      DC        F'0'                                                 00011490
APPEND   ST        2,APT                                                00011500
APPEND2  EQU   *                                                        00011510
         CR        A,NILR              A NIL                            00011520
         BE        APXNIL              YES                              00011530
         ST        Q,GARBT             HOLD Q                           00011540
         LM        A,Q,CAR(A)            MAKE NEW X LIST                00011550
         BAL       2,CONS                                               00011560
         LR        M,A                 SAVE NEW LIST                    00011570
APAGN    CR        Q,NILR              AT END                           00011580
         BE        APDN                YES                              00011590
         LR        1,A                 HOLD A A SEC                     00011600
         LM        A,Q,CAR(Q)            NEXT CELL                      00011610
         BAL       2,CONS                                               00011620
         ST        A,CDR(1)            LINK IT                          00011630
         B         APAGN                                                00011640
APDN     L         Q,GARBT                                              00011650
         ST        Q,CDR(A)            LINK ON Y                        00011660
         LR        A,M                                                  00011670
         B         EPX                                                  00011680
APXNIL   LR        A,Q                 RETURN Y                         00011690
EPX      L         2,APT                                                00011700
         BR        2                                                    00011710
*******************   APPEND1(X,Y)  **  SUBR  ************************* 00011720
*        NCONC(X,CONS(Y,NIL))                                           00011730
APPEND1  LR        1,2                                                  00011740
         LR        M,A                                                  00011750
         LR        A,Q                                                  00011760
         LR        Q,NILR                                               00011770
         BAL       2,CONS                                               00011780
         LR        Q,A                                                  00011790
         LR        A,M                                                  00011800
         LR        2,1                                                  00011810
         B         NCONC                                                00011820
         EJECT                                                          00011830
*********************************************************************** 00011840
*******************          SPREAD(X)   NON REC     *****************  00011850
**********************************************************************  00011860
*        PUTS ELEMENTS OF LIST X INTO ARG CELLS.                        00011870
*        REG1 RETURNS NUMBER OF ARGUMENTS FOUND, MAX IS 22.             00011880
SPREAD   SR    1,1                ZERO THE ARGUMENT COUNT. 
         CR    A,NILR             IS LIST EMPTY? 
         BER   2                  YES -- RETURN NIL. 
         LR    0,A                SAVE X, IN CASE OF ERROR. 
         LM    A,Q,CAR(A)         GET 1ST ARG. 
         LA    1,1(,1)            COUNT IT. 
         CR    Q,NILR             JUST ONE ARG? 
         BER   2                  YES -- RETURN. 
         LM    Q,M,CAR(Q)         NO; GET 2ND ARG. 
         LA    1,1(,1)            COUNT IT. 
         CR    M,NILR             ANY MORE ARGS? 
         BER   2                  NO -- RETURN. 
         SLA   1,2 
SPRNXT   C     1,=F'88'           MORE THAN 22 ARGS? 
         BNL   SPERR              YES -- ERROR. 
         L     15,CAR(,M)         GET NEXT ARG. 
         ST    15,ARGS-8(1)       STORE IT. 
         L     M,CDR(,M) 
         AR    1,K4               INCREMENT INDEX. 
         CR    M,NILR             ANY MORE ON LIST? 
         BNE   SPRNXT             YES. 
         SRA   1,2                NO; CONVERT INDEX TO COUNT. 
         BR    2                  RETURN. 
SPERR    LR    A,0                RESTORE X. 
         ERROR     ' *** A7-MORE THAN 22 ARGS'                          00012140
         EJECT                                                          00012150
*********************************************************************** 00012160
*******************    NCONC(X,Y)  NON REC   ************************** 00012170
*********************************************************************** 00012180
*        JOINS LIST X TO LIST Y                                         00012190
NCONC    LR        1,A                                                  00012200
         CR        A,NILR                                               00012210
         BNE       NCA                                                  00012220
         LR        A,Q                                                  00012230
         BR        2                                                    00012240
NCC      L     1,CDR(,1) 
NCA      C     NILR,CDR(,1) 
         BNE       NCC                                                  00012270
         ST        Q,CDR(1)                                             00012280
         BR        2                                                    00012290
*********************************************************************** 00012300
*******************   ATTRIB(X,E)   NON REC   ************************* 00012310
*********************************************************************** 00012320
*        PUTS LIST E ON END OF LIST X, RETURNS E                        00012330
ATTRIB   ST        Q,GARBT                                              00012340
         LR        15,2                                                 00012350
         BAL       2,NCONC                                              00012360
         L         A,GARBT                                              00012370
         BR        15                                                   00012380
         EJECT                                                          00012390
*********************************************************************** 00012400
*******************   PROG((X1,X2,...),A)  REC    ********************* 00012410
*********************************************************************** 00012420
PROGIND  DC        F'0'                PROG SWITCH                      00012430
PROG     SAVE      2                                                    00012440
         ST        A,PROGT             HOLD PRGM                        00012450
         SAVE      A                   SAVE IT WHILE WE EVALUATE IT     00012460
         ST        NILR,GOLIST                                          00012470
*          PUT PROG VARIABLES ON ALIST                                  00012480
         ST        Q,ALIST                                              00012490
         L         A,CAR(A)                                             00012500
PROGV    CR        A,NILR              AT NIL                           00012510
         BE        PROGA               YES                              00012520
         LR        M,A                 SAVE A                           00012530
         L         A,CAR(A)            VARIABLE                         00012540
         LR        Q,NILR                                               00012550
         BAL       2,CONS              PAIR IT TO NIL                   00012560
         L         Q,ALIST                                              00012570
         BAL       2,CONS              ADD TO ALIST                     00012580
         ST        A,ALIST                                              00012590
         L         A,CDR(M)            NEXT VAR                         00012600
         B         PROGV                                                00012610
PROGA    L         A,PROGT                                              00012620
*          BUILD GOLIST                                                 00012630
PROGL    L         M,CDR(A)                                             00012640
         CR        M,NILR              END OF PROG                      00012650
         BE        PROGE               YES                              00012660
         L         A,CAR(M)            TRY FOR LABEL                    00012670
         TM        CAR(A),ATOM         LABEL                            00012680
         BO        PROGY               YES                              00012690
         LR        A,M                 RESET A                          00012700
         B         PROGL               TRY AGAIN                        00012710
PROGY    L         Q,CDR(M)            ADDR OF PGM STMT                 00012720
         BAL       2,CONS                                               00012730
         L         Q,GOLIST                                             00012740
         BAL       2,CONS              LINK INTO GOLIST                 00012750
         ST        A,GOLIST                                             00012760
         LR        A,M                 RESET A                          00012770
         B         PROGL               FIND NEXT LABEL                  00012780
*          BEGIN EXECUTION OF PROG                                      00012790
PROGE    L         Q,PROGT             START OF PROGM                   00012800
PROGEX   L         Q,CDR(Q)            FIRST STMT                       00012810
         CR        Q,NILR              AT END                           00012820
         LR        A,NILR                                               00012830
         BE        PEX                 END OF PROG LIST                 00012840
         L         A,CAR(Q)            -A- HAS PTR TO STMT              00012850
         TM        CAR(A),ATOM         IS NEXT PGM STMT A LABEL         00012860
         BO        PROGEX              YES SKIP OVER IT                 00012870
         MVI       PROGIND,X'01'       SET IND ON                       00012880
         SAVE      Q                   SAVE PTR TO REST OF PGM          00012890
         L         Q,GOLIST                                             00012900
         SAVE      Q                   SAVE GOLIST                      00012910
         L         Q,ALIST                                              00012920
         SAVE      Q                   SAVE ALIST                       00012930
         BAL       2,EVAL              EVAL STMT                        00012940
*        NOTE AT THIS POINT (PROGR) IS ADDR IN STACK- USED IN GO & RET  00012950
PROGR    UNSAVE    Q                                                    00012960
         ST        Q,ALIST                                              00012970
         UNSAVE    Q                                                    00012980
         ST        Q,GOLIST                                             00012990
         UNSAVE    Q                   REST OF PGM                      00013000
         B         PROGEX              NEXT STMT                        00013010
         EJECT                                                          00013020
SPECBIND ST    3,PVARG                                                  00013030
         DROP  3                                                        00013040
         LA    3,BASE3                                                  00013050
         USING BASE3,3                                                  00013060
         B     SPECBIN1                                                 00013070
SPECRSTR ST    3,PVARG                                                  00013080
         DROP  3                                                        00013090
         LA    3,BASE3                                                  00013100
         USING BASE3,3                                                  00013110
         B     SPECRST1                                                 00013120
*  ==================================================================== 00013130
*  ======  END OF BASE 11 SECTION  ==================================== 00013140
         EJECT                                                          00013150
*  ==================================================================== 00013160
*  ======  BEGINNING OF BASE 12 SECTION  ============================== 00013170
*  ======  THE INSTRUCTIONS AND CONSTANTS IN THE BEGINNING  =========== 00013180
*  ======      OF THIS SECTION ARE USED BY LAPASSEMBLED PROGRAMS  ===== 00013190
*  ======      THEIR POSITION RELATIVE TO THE BEGGINNING OF THIS  ===== 00013200
*  ======      SECTION IS FIXED AND MUST NOT BE CHANGED  ============== 00013210
         CNOP  0,4                                                      00013220
BASE12   EQU   *                                                        00013230
         B     ERG2               0(12)                                 00013240
         B     CALL               4(12)                                 00013250
         DC    A(ARGS)            8(12)                                 00013260
         DC    A(BOTTOM)          12(12)                                00013270
         B     LSTCMP             16(12)                                00013280
         B     SPECBIND           20(12)                                00013290
         B     SPECRSTR           24(12)                                00013300
         B     CONDER             28(12)                                00013310
         B     FUNCTIO2           32(12)                                00013320
         B     EVAL               36(12)                                00013330
         B     COMBIND            40(12)                                00013340
         B     COMRSTR            44(12)                                00013350
         B     RTRN               48(12)                                00013360
         B     MOVIT              52(12)                                00013370
         B     LINK               56(12)                                00013380
         EJECT                                                          00013390
*********************************************************************** 00013400
********* CALL ******************************************************** 00013410
*********************************************************************** 00013420
CALL     SAVE  3                                                        00013430
         DROP  3                                                        00013440
         LA    3,BASE3            RESET BASE 3                          00013450
         USING BASE3,3                                                  00013460
         SAVE  15                                                       00013470
         SAVE  2                                                        00013480
         L     1,0(0,2)                                                 00013490
         BAL   2,0(NILR,1)                                              00013500
CALLEXIT UNSAVE  2                                                      00013510
         UNSAVE  15                                                     00013520
         UNSAVE  3                                                      00013530
         B     8(2)                                                     00013540
LINK     SAVE  3                                                        00013550
         SAVE  15                                                       00013560
         SAVE  2                                                        00013570
         DROP  3                                                        00013580
         LA    3,BASE3                                                  00013590
         USING  BASE3,3                                                 00013600
         B     LINK1                                                    00013610
MOVIT    ST    3,PVARG                                                  00013620
         DROP  3                                                        00013630
         LA    3,BASE3                                                  00013640
         USING BASE3,3                                                  00013650
         B     MOVIT1                                                   00013660
FUNCTIO2 STM       2,3,PVARG                                            00013670
         DROP      3                                                    00013680
         LA        3,BASE3                                              00013690
         USING     BASE3,3                                              00013700
         BAL   2,FUNCTIO1                                               00013710
         LM        2,3,PVARG                                            00013720
         BR        2                                                    00013730
COMBIND  ST    3,PVARG                                                  00013740
         DROP  3                                                        00013750
         LA    3,BASE3                                                  00013760
         USING BASE3,3                                                  00013770
         B     COMBIND1                                                 00013780
COMRSTR  ST    3,PVARG                                                  00013790
         DROP  3                                                        00013800
         LA    3,BASE3                                                  00013810
         USING BASE3,3                                                  00013820
         B     COMRSTR1                                                 00013830
LSTCMP   ST    3,PVARG                                                  00013840
         DROP  3                                                        00013850
         LA    3,BASE3                                                  00013860
         USING BASE3,3                                                  00013870
         B     LSTCMP1                                                  00013880
         EJECT                                                          00013890
*********************************************************************** 00013900
*******************   GO(X)   FSUBR     ******************************* 00013910
*********************************************************************** 00013920
ERA6     ERROR     ' ***A6-UNDEF LABEL IN GO'                           00013930
GO       LA        1,PROGR                                              00013940
GOL      UNSAVE    15                  SCAN DOWN STACK FOR EVAL         00013950
         LA        15,0(,15)           STRIP OFF BITS FOR COMPARE       00013960
         CR        15,1                                                 00013970
         BNE       GOL                 R14 HAS RET ADDR -DONT LOSE IT   00013980
         UNSAVE    Q                   ALIST                            00013990
         ST        Q,ALIST                                              00014000
         UNSAVE    Q                                                    00014010
         ST        Q,GOLIST                                             00014020
         UNSAVE    M                   REST OF PGM, NOT NEEDED          00014030
         L         A,CAR(A)            CAR(X)                           00014040
         LA        1,ERA6                                               00014050
         BAL       2,SASSOC            FIND ON ASSOC LIST               00014060
         LR    Q,A 
         B     PROGEX 
*********************************************************************** 00014200
*******************   RETURN(X)   **   SUBR      *********************  00014210
*********************************************************************** 00014220
GORET    LA        1,PROGR                                              00014230
GORR     UNSAVE    Q                                                    00014240
         LA        Q,0(,Q)             STRIP BITS                       00014250
         CR        1,Q                                                  00014260
         BNE       GORR                                                 00014270
         UNSAVE    Q                   ALIST                            00014280
         UNSAVE    Q                   GOLIST                           00014290
         UNSAVE    Q                   PGM                              00014300
PEX      UNSAVE    Q                   PROG                             00014310
         MVI       PROGIND,0                                            00014320
         B         RETURN              EXIT FROM PROG                   00014330
         EJECT                                                          00014340
*********************************************************************** 00014350
********* READCH(X)   SUBR  ******************************************* 00014360
*********************************************************************** 00014370
*   READCH GIVES CHROBJ READ IF ARGUMENT IS NIL, OTHERWISE              00014380
*     READCH WILL BACKSPACE: BACKSPACE MUST BE DONE ONLY ONCE AT        00014390
*     A TIME, AND ONLY AFTER READCH HAVE BEEN EXECUTED                  00014400
BACKSPAC DC        X'00'                                                00014410
READCHTP DC        2F'0'                                                00014420
LASTREAD DC        A(BLANK,BLANK)                                       00014430
READCH   CR        A,NILR              IF ARG IS TRUE READCH SHOULD     00014440
*                                                        BACKSPACE      00014450
         BE        READCH1             OTHERWISE PICK NEXT CAR          00014460
         OI        BACKSPAC,X'01'     SET BACKSPACE MARKER              00014470
         L         A,LASTREAD          VALUE IS CHR JUST IN FRONT       00014480
*                                          OF CHAR JUST READ            00014490
         BR        2                                                    00014500
READCH1  L         A,LASTREAD+4        PICK UP CHROBJ JUST READ         00014510
         TM        BACKSPAC,X'01'      IS BACKSPACE MARKER SET          00014520
         BO        READCH2             YES                              00014530
         ST        A,LASTREAD          OTHERWISE REMEMBER CHROBJ        00014540
*                                            JUST READ                  00014550
         TM    EOFIND,X'FF'       END-OF-FILE FLAG ON? 
         BZ    *+14               NO. 
         LA    A,ATEOF            YES; GIVE EOF ATOM. 
         ST    A,LASTREAD+4 
         BR    2 
         STM       2,3,READCHTP        STORE R2 AND R3 = CHAR           00014560
         L         CHAR,LASTCHAR                                        00014570
         OI    READCHID,X'01'     SAY IS READCH FOR EOF PROCESSOR 
         LTR   CHAR,CHAR          IS THERE A CHARACTER YET? 
         BNZ   *+8                YES. 
         BAL   2,GETCD            NO; START AN INPUT RECORD. 
         IC        Q,0(CHAR)                                            00014580
         N         Q,=X'0000003F'                                       00014590
         M         A,=F'24'                                             00014600
         LA        A,CHROBJ(Q)                                          00014610
         ST        A,LASTREAD+4                                         00014620
         BAL       2,GETCHAR           PICK UP NEXT CHAR                00014640
READCH3  NI    READCHID,X'00' 
         ST        CHAR,LASTCHAR                                        00014660
         LM        2,3,READCHTP                                         00014670
         BR        2                                                    00014680
READCH2  NI        BACKSPAC,X'00'                                       00014690
         BR        2                                                    00014700
         EJECT                                                          00014710
*********************************************************************** 00014720
*********  FIX   SUBR  NON RECURS ************************************* 00014730
*********************************************************************** 00014740
*        FIX MAKES AN INTEGER OUT OF A FLOATING POINT NUMBER            00014750
*        RETURNS INTEGER 0 IF ALL SIGNIFICANCE IS LOST                  00014760
FIXIT    SWR   0,0 
         L     A,CAR(,A) 
         LE    0,CAR(,A)          GET FLOATING-POINT VALUE. 
         AW    0,NZERO            TAKE THE INTEGER PART. 
         STD   0,STORE            STORE IT. 
         L     A,STORE+4          TAKE THE LOW-ORDER PART. 
         BNM   *+6                SKIP IF NOT NEGATIVE. 
         LCR   A,A                COMPLEMENT NEGATIVE VALUES. 
         LR    14,2 
         B     MKFXAT             MAKE A FIXED ATOM. 
STORE    DC    D'0'                                                     00015030
*********************************************************************** 00015040
*********   EXPLODE   SUBR  NON RECURS  ******************************* 00015050
*********************************************************************** 00015060
*        EXPLODE MAKES A LIST OF CHAR IN ATOM'S PRINTNAME               00015070
EXPLODE  ST    2,PVARG                                                  00015080
         ST    NILR,GARBT                                               00015090
         L    15,CAR(A)                                                 00015100
EXPL2    SR        14,14                                                00015110
EXPL1    SR    Q,Q                                                      00015120
         SR    M,M                                                      00015130
         IC    Q,CAR(14,15)                                             00015140
         CR    Q,M                                                      00015150
         BE    EXPLEXIT                                                 00015160
         N     Q,=X'0000003F'                                           00015170
         M     A,=F'24'                                                 00015180
         LA    Q,CHROBJ(Q)                                              00015190
         L     A,GARBT                                                  00015200
         BAL   2,APPEND1                                                00015210
         ST    A,GARBT                                                  00015220
         LA        14,1(0,14)                                           00015230
         CR        14,K4                                                00015240
         BL    EXPL1                                                    00015250
EXPLODE1 L         15,CDR(15)                                           00015260
         LA        15,0(0,15)                                           00015270
         CR        15,NILR                                              00015280
         BNE   EXPL2                                                    00015290
EXPLEXIT L     2,PVARG                                                  00015300
         L         A,GARBT                                              00015310
         BR    2                                                        00015320
*********************************************************************** 00015330
*********  GENSYM   SUBR  NON RECURS  ********************************* 00015340
*********************************************************************** 00015350
GENSYMBL DC    C'0000'                                                  00015360
GENSYMSK DC        XL6'21202020202020'                                  00015370
GENSYMNR DC    F'0'                                                     00015380
GENSYM   ST    2,PVARG                                                  00015390
         L     Q,GENSYMNR                                               00015400
         AH    Q,=H'1'                                                  00015410
         ST    Q,GENSYMNR                                               00015420
         CVD   Q,GARBTM2                                                00015430
         MVC       NEWGENSM(8),GENSYMSK-3                               00015440
         ED        NEWGENSM(8),GARBTM2+5                                00015450
         SR    1,1                                                      00015460
         SR    M,M                                                      00015470
         SR    Q,Q                                                      00015480
         MVC   NEWGENSM(4),GENSYMBL                                     00015490
         L     A,CAR(A)                                                 00015500
GENSYM2  IC    Q,CAR(1,A)              PICK UP CHAR                     00015510
         CR    Q,M           IS IT BLANK                                00015520
         BE    GENSYM1                                                  00015530
         STC   Q,NEWGENSM(1)                                            00015540
         LA    1,1(0,1)                                                 00015550
         CR    1,K4                                                     00015560
         BL    GENSYM2                                                  00015570
GENSYM1  L     A,NEWGENSM+4                                             00015580
         LR    Q,NILR                                                   00015590
         BAL   2,CONS                                                   00015600
         LR    Q,A                                                      00015610
         MVI   CDR(A),FWD                                               00015620
         L     A,NEWGENSM                                               00015630
         BAL   2,CONS                                                   00015640
         MVI   CDR(A),FWD                                               00015650
         LR    Q,NILR                                                   00015660
         BAL   2,CONS                                                   00015670
         MVI   CAR(A),ATOM                                              00015680
         L     2,PVARG                                                  00015690
         BR    2                                                        00015700
         EJECT                                                          00015710
**********************************************************************  00015720
********* PRARG  *** PRVAL  ******************************************* 00015730
*********************************************************************** 00015740
PRARG    STM       2,3,PVARG+4         STORE 2 AND 3                    00015750
         MVC   LINE(18),TROUT1    SET UP TO WRITE FUNCTION              00015760
         LA    P,LINE+18                                                00015770
         BAL   2,PUTATOM                                                00015780
         BAL   2,WRLINE           WRITE FUNCTION                        00015790
         L     A,PVARG            SET UP TO WRITE ARGUMENTS             00015800
         BAL   2,PRINT            WRITE  ARGUMENTS                      00015810
         LM        2,3,PVARG+4                                          00015820
         BR    2                  RETURN                                00015830
TROUT1   DC    C'0*** ARGUMENTS OF '                                    00015840
TROUT2   DC    C'0*** VALUE OF '                                        00015850
PVARG    DC        3F'0'                                                00015860
PRVAL    STM       2,3,PVARG+4                                          00015870
         MVC   LINE(14),TROUT2                                          00015880
         LA    P,LINE+14                                                00015890
         BAL   2,PUTATOM                                                00015900
         BAL   2,WRLINE                                                 00015910
         L     A,PVARG                                                  00015920
         BAL   2,PRINT                                                  00015930
         LM        2,3,PVARG+4         RESTORE 2 AND 3                  00015940
         BR    2                                                        00015950
*********************************************************************** 00015960
**********   ORDERP  ************************************************** 00015970
*********************************************************************** 00015980
ORDERP   CR    A,Q                COMPARE ARG1 TO ARG2                  00015990
         BNH       ORDERT                                               00016000
         LR    A,NILR             ARG1 CHKPOINT UNDEFINED. 
         LA        Q,APVAL                                              00030720
         BAL       2,GET                                                00030730
         CR        A,NILR                                               00030740
         BNE       RELOCATE                                             00030750
         L         A,PUNCHOPN+4                                         00030760
        SR        Q,Q                                                   00030770
         ERROR     ' *** D5-CHKPOINT FILE NOT OPENED'                   00030780
RELOCATE L         A,CAR(A)                                             00030790
         L         M,CAR(A)            M NOW CONTAINS DCB ADDRESS       00030800
         L         A,PUNCHOPN+4                                         00030810
         BAL       2,REMPROP           REMOVE APVAL FROM CHKPOINTDDNAME 00030820
         LR        A,M                                                  00030830
         L     M,BPSSTART                                               00030840
         SR    M,NILR                                                   00030850
         ST    M,CHKREG+4                                               00030860
         LR    M,FREE                                                   00030870
         SR    M,NILR                                                   00030880
         ST    M,CHKREG                                                 00030890
         PUT       (A),CHKPCHK                                          00030900
         STM   14,12,12(13) 
         BAL   15,MARK            MARK A-L UNUSED CELLS 
         LM    14,12,12(13) 
*                  NOW ALL THE USED CELLS WILL HAVE BIT 32 TURNED ON 
         LA    Q,CARDOUT           Q POINTS TO LOCATION ON THE CARD 
         LR    M,NILR              M POINTS TO LOCATION IN LISTS 
CHOVER   DS    0H 
         TM    4(M),X'80'          IS THE ELEMENT MARKED 
         BO    CHOK                YES THEN HANDLE IT NORMALLY 
         LA    1,1                 IF NOT THEN WE COUNT THE NUMBER 
*                                  OF CONTINGUOUS FREE ELEMENTS, SO 
*                                  THAT WE MAY COMPRESS THEN INTO ONE 
CHINK    C      M,BOTTOM          END OF THE LISTS? 
         BNL   CHSTORE             YES, THAT'S ALL 
         TM    12(M),X'80'         IS THE NEXT ONE MARKES 
         BO    CHSTORE             IF SO, END IT 
         LA    1,1(,1)             IF NOT, COUNT 
         LA    M,8(,M)             NEXT 
         B     CHINK 
CHSTORE  SR    2,2 
         BCTR  2,0                 PUT ALL 'F'S IN CDR 
         STM   1,2,0(Q)            STORE THE COUNT 
         B     CHQ 
* 
CHOK     LM    14,15,0(M)          GET CAR AND CDR 
         CLI   4(M),FWD+X'80'      IS THE CSR RELOCATABLE 
         BE    CHNOREL             NO 
         SR    14,NILR             RELOCATE CAR 
CHNOREL  SR    15,NILR             RELOCATE CDR 
         STM   14,15,0(Q)          STORE IN CARD 
CHQ      LA    Q,8(,Q)             INCREMENT CARD 
         C     Q,=A(CARDOUT+80) 
         BL    CHM 
         PUT   (A),CARDOUT 
         LA    Q,CARDOUT           RESET Q 
CHM      LA    M,8(,M)             INCREMENT M 
         C     M,BOTTOM 
         BNH   CHOVER              LOOP IF LOW 
         LA    M,CARDOUT           * WE WANT TO SEE IF WE NEED TO 
         CR    Q,M                 * FLUSH THE BUFFER 
         BE    CHOUT               NO 
         PUT   (A),CARDOUT         YES 
* 
*                  NOW WE DUMP BPS 
CHBL     EQU   80 
CHOUT    L     M,=A(BPSST) 
         C     M,BPSSTART          THIS HAS THE UPPER LIMIT OF BPS USED 
         BH    CHALL 
         PUT   (A),(M) 
         LA    M,CHBL(,M) 
         B     CHOUT+4 
CHALL    LA    FREE,1              PRETEND WE HIT THE END 
         BAL   14,GARBCOLL         COLLECT THE GARBAGE AND TURN BITS OF 
         LR    M,A 
         B     CLOSE2              DROP THE FILE 
*********************************************************************** 00031190
*********  RESTORE   ************************************************** 00031200
*********************************************************************** 00031210
RESTORE  ST        2,PUNCHOPN+8                                         00031220
         ST        A,PUNCHOPN+4                                         00031230
         LA        Q,APVAL                                              00031240
         BAL       2,GET                                                00031250
         CR        A,NILR                                               00031260
         BNE       RELOC                                                00031270
         L         A,PUNCHOPN+4                                         00031280
        SR        Q,Q                                                   00031290
         ERROR     ' *** D6-RESTORE FILE NOT OPENED'                    00031300
RELOC    L         A,CAR(A)                                             00031310
         L         A,CAR(A)            A NOW CONTAINS DCB ADDRESS       00031320
         GET       (A)                                                  00031330
         CLC   CHKPCHK(8),0(1)                                          00031340
         BE        RELOCOK                                              00031350
         L         A,PUNCHOPN+4                                         00031360
         SR        Q,Q                                                  00031370
         ERROR     ' *** D7-RESTORE GIVEN FILE INCOMPATIBLE WITH SYSTEMC00031380
                SPECIFIED'                                              00031390
RELOCOK  LR    Q,1 
         L     1,STORBLKS         RELEASE DYNAMIC BLOCKS. 
         L     M,CELLCNT 
RELST1   LTR   1,1                ANY MORE BLOCKS? 
         BZ    RELST2             NO. 
         L     2,0(,1)            YES; GET NEXT NOW. 
         SR    0,0                FREE ALL THIS ONE. 
         L     15,=V(FREESPAC) 
         BASR  14,15 
         S     M,=A((SBLKSIZ-8)/8)   REDUCE CELL COUNT. 
         LR    1,2                TRY THE NEXT. 
         B     RELST1 
RELST2   ST    1,STORBLKS         RESET BLOCKS POINTER. 
         ST    M,CELLCNT          RESET CELL COUNT. 
         L     1,HASHTBL          RELEASE THE HASH TBL 
         LTR   1,1                IF ANY 
         BZ    RELST3             NONE 
         SR    0,0 
         ST    0,HASHTBL          NONE NOW 
         L     15,=V(FREESPAC) 
         BASR  14,15 
RELST3   LR    1,Q 
         L     M,12(,1) 
         AR    M,NILR                                                   00031410
         ST    M,BPSSTART                                               00031420
         LR    M,NILR                                                   00031430
         L     FREE,8(1)                                                00031440
         AR    FREE,NILR                                                00031450
         LR    Q,NILR              POINT TO START OF LISTA 
         L     M,=F'-1'            -1 MEANS FREE STUFF 
REGET    GET   (A)                 RETURNS ADDR IN REG 1 
         LA    2,80(0,1)           POINTS TO END OF CARD 
RELOOK   LM    14,15,0(1)          GET CAR AND CDR 
         CR    15,M                IS IT FREE LIST 
         BNE   REREL               NO, GO RELOCATE IT 
         SLA   14,3                LEAVE THE SPACE (ELS X 8) 
         AR    Q,14                ADD IT TO THE CORE POINTER 
         B     RELOOP 
REREL    CLI   4(1),FWD+X'80'      IS IT RELOCATABLE 
         BE    RENOREL             NO, GO 
         AR    14,NILR             RELOCATE THE CAR 
RENOREL  AR    15,NILR             REL. CDR 
         STM   14,15,0(Q)          STORE INTO CORE 
         LA    Q,8(,Q)             NEXT PLEASE 
RELOOP   C     Q,BOTTOM            TEST FOR END 
         BH    REOUT 
         LA    1,8(,1)             INCREMENT POINTER TO THE CARD 
         CR    1,2                 OFF THE END? 
         BL    RELOOK 
         B     REGET 
* 
REOUT    L     M,=A(BPSST)         START OF BPS 
RENEXT   GET   (A) 
         MVC   0(CHBL,M),0(1)      MOVE  PROGRAM INTO CORE 
         LA    M,CHBL(,M)          INCREMENT 
         C     M,BPSSTART 
         BL    RENEXT              IF LOW DO IT AGAIN 
* 
RESTORX  SR        M,M                                                  00031700
         LA    2,GARBT 
         L     1,PUSHA 
         BCTR  1,0 
         LR        0,K4                                                 00031730
ZEROTEMP ST        M,0(2)                                               00031740
         BXLE      2,0,ZEROTEMP                                         00031750
         LA    FREE,1             TURN OFF THE FUNNY BITS 
         BAL   14,GARBCOLL        AND BUILD A FREE LIST 
         LR        M,A                                                  00031760
         ST        NILR,PUNCHOPN+4                                      00031770
         B         CLOSE2                                               00031780
*********************************************************************** 00031790
*********  CLOSE  ***************************************************** 00031800
*********************************************************************** 00031810
PUNCHOPN DC    3F'0'                                                    00031820
CLOSE    LA        0,LISPIN                                             00031830
         CR        A,0                                                  00031840
         BCR       8,2                                                  00031850
         LA        0,LISPOUT                                            00031860
         CR        A,0                                                  00031870
         BCR       8,2                                                  00031880
         ST    A,PUNCHOPN+4                                             00031890
         ST    2,PUNCHOPN+8                                             00031900
         LA        0,LISPUNCH                                           00031910
         CR        A,0                                                  00031920
         BNE       CLOSUSFL                                             00031930
         L         M,PUNCHOPN                                           00031940
         LTR       M,M                                                  00031950
         BZ        CLOSEERR                                             00031960
         SR        0,0                                                  00031970
         ST        0,PUNCHOPN                                           00031980
         B         CLOSE2                                               00031990
CLOSUSFL LA        Q,APVAL                                              00032000
         BAL       2,GET                                                00032010
         CR        A,NILR                                               00032020
         BE        CLOSEERR                                             00032030
CLOSE1   L         M,CAR(A)                                             00032040
         L         M,CAR(M)                                             00032050
         L     A,PUNCHOPN+4                                             00032060
         BAL       2,REMPROP                                            00032070
CLOSE2   LR        1,M                                             UOM 
         CLOSE     ,                   CLOSE PRINTCB               UOM 
CLOSEERR LM    A,Q,PUNCHOPN+4                                           00032160
         BR    Q                                                        00032170
*********************************************************************** 00032180
*********  VERBOS   *************************************************** 00032190
*********************************************************************** 00032200
**** ARG=T PRINTS IN GARB. COL....ARG=NIL NO PRINT ON GARB. COL.        00032210
PRBUFFER LA        1,BUFFPR                                             00032220
         B         COMSECT                                              00032230
VERBOS   LA        1,GARBSW                                             00032240
COMSECT  NI        0(1),X'00'                                           00032250
         CR        A,NILR                                               00032260
         BCR       8,2                                                  00032270
         OI        0(1),X'01'                                           00032280
         BR        2                                                    00032290
*********************************************************************** 00032300
*********  FLOAT   SUBR NON REC  ************************************** 00032310
*********************************************************************** 00032320
*    FLOAT CONVERTS INTEGER INTO FLOATING POINT *********************** 00032330
FLOATIT  LR    14,2                                                     00032340
         L     A,CAR(A)                                                 00032350
         L     1,CAR(A)                NUMBER INTO R1                   00032360
         BAL   2,FLOAT1                FLOAT IT                         00032370
         B     MKFLAT                  MAKE ATOM                        00032380
*********************************************************************** 00032390
*******************    EQ(X,Y)     NON REC    ************************  00032400
**********************************************************************  00032410
*        RETURN TRUE IF X=Y                                             00032420
EQ       CR        A,Q                 ARE THEY EQUAL                   00032430
         LR        A,NILR              NO MAYBE                         00032440
         BNE       0(2)                THEY ARENT                       00032450
         LA        A,T                 TRUE                             00032460
         BR        2                                                    00032470
*********************************************************************** 00032480
*******************   REPLACA(X,Y)   NON REC   ***********************  00032490
**********************************************************************  00032500
*        REPLACE CAR OF X BY Y                                          00032510
RPLACA   IC        1,CAR(A)                                             00032520
         ST        Q,CAR(A)                                             00032530
         STC       1,CAR(A)                                             00032540
         BR        2                                                    00032550
*********************************************************************** 00032560
*******************   REPLACD(X,Y)   NON REC   ***********************  00032570
**********************************************************************  00032580
*        REPLACE CDR OF X BY Y                                          00032590
RPLACD   IC        1,CDR(A)                                             00032600
         ST        Q,CDR(A)                                             00032610
         STC       1,CDR(A)                                             00032620
         BR        2                                                    00032630
*********************************************************************** 00032640
*******************    NULL(X)    NON REC    *************************  00032650
**********************************************************************  00032660
*        RETURN TRUE IF X IS NIL                                        00032670
NULL     CR        A,NILR              IS IT NIL                        00032680
         LR        A,NILR              IS NOW                           00032690
         BNE       0(2)                IT WASNT, FALSE RETURN           00032700
         LA        A,T                 IT WAS                           00032710
         BR        2                                                    00032720
*********************************************************************** 00032730
*******************   FUNCTION(X)  NON REC   FSUBR   ****************** 00032740
*********************************************************************** 00032750
FUNCTIO1 ST    A,RESAV                                                  00032760
         LA    A,RESAV                                                  00032770
FUNCTION LR        14,2                SAVE RET                         00032780
         LR        M,A                 SAVE A                           00032790
         LR        A,Q                 ALIST                            00032800
         LR        Q,NILR                                               00032810
         BAL       2,CONS                                               00032820
         LR        Q,A                                                  00032830
         L         A,CAR(M)                                             00032840
         BAL       2,CONS                                               00032850
         LR        Q,A                                                  00032860
         LA        A,FUNARG                                             00032870
         BAL       2,CONS                                               00032880
         BR        14                  EXIT                             00032890
         EJECT                                                          00032900
*********************************************************************** 00032910
*********   SPECBIND   ENTRY FROM COMPILER  *************************** 00032920
*********************************************************************** 00032930
SPECBIN1 L     A,0(2)                                                   00032940
         AR    A,NILR                                                   00032950
         L     14,CAR(A)                                                00032960
         L     M,4(2)                                                   00032970
         L     Q,0(M,PDL)                                               00032980
         ST    14,0(M,PDL)                                              00032990
         ST    Q,0(A)                                                   00033000
         LA    2,8(0,2)                                                 00033010
         BCT   1,SPECBIN1                                               00033020
         L     3,PVARG                                                  00033030
         BR    2                                                        00033040
*********************************************************************** 00033050
*********   SPECRSTR   ENTRY FROM COMPILER  *************************** 00033060
*********************************************************************** 00033070
SPECRST1 L     A,0(2)                                                   00033080
         AR    A,NILR                                                   00033090
         L     M,4(2)                                                   00033100
         L     14,0(M,PDL)                                              00033110
         ST    14,0(A)                                                  00033120
         LA    2,8(0,2)                                                 00033130
         BCT   1,SPECRST1                                               00033140
         L     3,PVARG                                                  00033150
         BR    2                                                        00033160
*********************************************************************** 00033170
*********   COMBIND    ENTRY FROM COMPILER  *************************** 00033180
*********************************************************************** 00033190
COMBIND1 ST    2,RESAV                                                  00033200
         LR    0,15                                                     00033210
         BAL   2,PAIR                                                   00033220
         LR    15,0                                                     00033230
         L     Q,ALIST                                                  00033240
         BAL   2,NCONC                                                  00033250
         ST    A,ALIST                                                  00033260
         L     2,RESAV                                                  00033270
         L     3,PVARG                                                  00033280
         BR    2                                                        00033290
*********************************************************************** 00033300
*********   COMBRSTR   ENTRY FROM COMPILER  *************************** 00033310
*********************************************************************** 00033320
COMRSTR1 L     A,CAR(A)                                                 00033330
         L     Q,CAR(A)                                                 00033340
         L     A,ALIST                                                  00033350
COMLOP   L     A,CDR(A)                                                 00033360
         BCT   Q,COMLOP                                                 00033370
         ST    A,ALIST                                                  00033380
         L     3,PVARG                                                  00033390
         BR    2                                                        00033400
*********************************************************************** 00033410
*********MOVIT   ENTERED FROM COMPILER  ******************************* 00033420
*********************************************************************** 00033430
MOVIT1   CR        PDS,NILR                                             00033440
         BH    ERG2                                                     00033450
         ST    NILR,0(0,PDL)                                            00033460
         ST    A,4(0,PDL)                                               00033470
         ST    Q,8(0,PDL)                                               00033480
         SR    M,K4                                                     00033490
         CR    M,K4                                                     00033500
         BNH   MOVOUT                                                   00033510
         SR    M,K4                                                     00033520
         BCTR  M,0                                                      00033530
         STC   M,MOVINST+1                                              00033540
MOVINST  MVC   12(1,PDL),ARGS                                           00033550
MOVOUT   L     3,PVARG                                                  00033560
         BR    2                                                        00033570
*********************************************************************** 00033580
*********LSTCMP  ENTERED FROM COMPILER  ******************************* 00033590
*********************************************************************** 00033600
LSTCMP1  LR    14,0                                                     00033610
         BCTR  14,0                                                     00033620
         SLL   14,2                                                     00033630
         AR    14,2                                                     00033640
         LA    1,4(0,14)                                                00033650
         LR    Q,NILR                                                   00033660
         SR    2,2                                                      00033670
LSTLOP   SR    A,A                                                      00033680
         SR    M,M                                                      00033690
         L     3,PVARG                                                  00033700
         EX    0,0(14)                                                  00033710
         DROP  3                                                        00033720
         LA    3,BASE3                                                  00033730
         USING BASE3,3                                                  00033740
         LTR   A,A                                                      00033750
         BNE   LSTA                                                     00033760
         LTR   M,M                                                      00033770
         BNE   LSTASPEC                                                 00033780
         AR    2,NILR                                                   00033790
         LR    A,2                                                      00033800
         B     LSTA                                                     00033810
LSTASPEC L     A,0(M,NILR)                                              00033820
LSTA     BAL   2,CONS                                                   00033830
         LR    Q,A                                                      00033840
         SR    14,K4                                                    00033850
         BCT   0,LSTLOP                                                 00033860
         L     3,PVARG                                                  00033870
         BR    1                                                        00033880
*********************************************************************** 00033890
*********  LINK  ****************************************************** 00033900
*********  LINK  ESTABLISHES LINKAGES FOR THE COMPILER **************** 00033910
*********  LINK  WILL ALSO MAKE A FAST CALL WHENEVER POSSIBLE  ******** 00033920
*********        BY CHANGING THE CODE IN THE FUNCTION THAT LINKED ***** 00033930
*********************************************************************** 00033940
LINKSAVE DC        2F'0'                                                00033950
ASUBR    DC        A(SUBR)                                              00033960
AFSUBR   DC        A(FSUBR)                                             00033970
AEXPR    DC        A(EXPR)                                              00033980
AFEXPR   DC        A(FEXPR)                                             00033990
LINK1    L         1,0(0,2)            PICK UP FN NAME IN A             00034000
         AR        1,NILR                                               00034010
         LR        15,1                SET UP TO SEARCH PROPERTYLIST    00034020
LINKGET  L         15,CDR(15)                                           00034030
         CR        15,NILR                                              00034040
         BE        NOPROPRT            FN IS NOT DEFINED BY PROPERTY    00034050
         L         0,CAR(15)                                            00034060
         C         0,ASUBR                                              00034070
         BE        SUBRLINK                                             00034080
         C         0,AFSUBR                                             00034090
         BE        SUBRLINK                                             00034100
         C         0,AEXPR                                              00034110
         BE        EXPRLINK                                             00034120
         C         0,AFEXPR                                             00034130
         BNE       LINKGET                                              00034140
EXPRLINK L         15,CDR(15)          PICK UP LAMBDA DEF.              00034150
         L         15,CAR(15)           OF EXPR OR FEXPR                00034160
FNALIST  L         0,4(0,2)            PICK UP NO. OF ARGS IN R0        00034170
         BAL       2,LISTARG           LIST ARGS                        00034180
         TM        0(1),X'01'          SHOULD FN BE TRACED?             00034190
         BO        TRACEXPR            YES, GO TRACE IT                 00034200
         L         Q,ALIST             NO, SET UP FOR APPLY             00034210
         ST        Q,ARGS                                               00034220
         LR        Q,A                                                  00034230
         LR        A,15                                                 00034240
         BAL       2,APPLY             CALL APPLY AND EXIT              00034250
         B     CALLEXIT                                                 00034260
TRACEXPR ST        A,PVARG                                              00034270
         LR        A,1                                                  00034280
         SAVE      A                                                    00034290
         BAL       2,PRARG             TRACE ARGS                       00034300
         LR        Q,A                 ARGS TO Q                        00034310
         L         A,ALIST                                              00034320
         ST        A,ARGS              SET UP FOR APPLY                 00034330
         LR        A,15                                                 00034340
         BAL       2,APPLY             CALL APPLY                       00034350
TRRET    ST    A,PVARG 
         UNSAVE 2 
         TM    0(2),X'01'         SHOULD IT BE TRACED 
         BZ    CALLEXIT           NOPE 
         LR    A,2                MOVE FOR PRVAL 
         BAL       2,PRVAL             TRACE VALUE                      00034380
         B     CALLEXIT                                                 00034390
NOPROPRT LR        15,1                FUNCTION IS DEFINED ON ALIST     00034400
         B         FNALIST               SO CALL APPLY                  00034410
SUBRLINK L         15,CDR(15)          PICK UP ADDR. OF FSUBR           00034420
         L         15,CAR(15)            OR SUBR                        00034430
         L         15,CAR(15)                                           00034440
         TM    TRACEIND,X'01'     IS ANYTHING BEING TRACED 
         BO    TRACSUBR           YES - DON'T MAKE ANY FAST LINKS THEN 
         SR        2,K4                NO, SET UP TO MAKE FAST CALL     00034470
         LR        1,15                                                 00034480
         SR        1,NILR              MAKE SUBR ADDR. RELOCATABLE      00034490
         STC       K4,3(0,2)           MODIFY BAL INST.                 00034500
         ST        1,4(0,2)            STORE RELOC. SUBR ADDR.          00034510
         BALR      2,15                GO TO FN                         00034520
         B     CALLEXIT                                                 00034530
TRACSUBR STM       A,Q,GARBT+4         PROTECT ARG1 AND ARG2            00034540
         L         0,4(0,2)            PICK UP NO. OF ARGS IN R0        00034550
         BAL       2,LISTARG           LIST ARGS FOR TRACING            00034560
         ST        A,PVARG                                              00034570
         LR        A,1                                                  00034580
         SAVE      A                                                    00034590
         TM    0(A),X'01'         IS FN BEING TRACED 
         BZ    *+8                NO 
         BAL       2,PRARG             TRACE ARGS                       00034600
         LM        A,Q,GARBT+4                                          00034610
         BALR      2,15                CALL FN                          00034620
         B     TRRET              TRACE RETURNED VALUE 
LISTARG  LTR       0,0                                                  00034670
         BNE       LISTARG1                                             00034680
         LR        A,NILR                                               00034690
         BR        2                                                    00034700
LISTARG1 ST        2,LINKSAVE+4                                         00034710
         SR        0,K4                                                 00034720
         BNE       LISTARG2                                             00034740
         LR        Q,NILR                                               00034750
         BAL       2,CONS                                               00034760
         L         2,LINKSAVE+4                                         00034770
         BR        2                                                    00034780
LISTARG2 ST        A,GARBT                                              00034790
         LR        A,Q                                                  00034800
         LR        Q,NILR                                               00034810
         BAL       2,CONS                                               00034820
         LR        Q,A                                                  00034830
         L         A,GARBT                                              00034840
         BAL       2,CONS                                               00034850
         SR        0,K4                                                 00034860
         BNE       LISTARG3                                             00034880
         L         2,LINKSAVE+4                                         00034890
         BR        2                                                    00034900
LISTARG3 ST        1,LINKSAVE                                           00034910
         SR        14,14                                                00034920
LISTARG4 L         Q,ARGS(14)                                           00034930
         BAL       2,APPEND1                                            00034940
         AR        14,K4                                                00034950
         CR        14,0                                                 00034960
         BL        LISTARG4                                             00034970
         LM        1,2,LINKSAVE                                         00034980
         BR        2                                                    00034990
         EJECT                                                          00035000
*********************************************************************** 00035010
*******************   CAR  *  CDR  *  CADR  * ETC  ***SUBRS  ********** 00035020
**********************************************************************  00035030
CAAAR    L     A,CAR(,A) 
CAAR     L     A,CAR(,A) 
CARR     L     A,CAR(,A) 
         BR    2 
CAADR    L     A,CDR(,A) 
         L     A,CAR(,A) 
         L     A,CAR(,A) 
         BR    2 
CADAR    L     A,CAR(,A) 
CADR     L     A,CDR(,A) 
         L     A,CAR(,A) 
         BR    2 
CADDR    L     A,CDR(,A) 
         L     A,CDR(,A) 
         L     A,CAR(,A) 
         BR    2 
CDAAR    L     A,CAR(,A) 
CDAR     L     A,CAR(,A) 
CDRR     L     A,CDR(,A) 
         BR    2 
CDADR    L     A,CDR(,A) 
         L     A,CAR(,A) 
         L     A,CDR(,A) 
         BR    2 
CDDAR    L     A,CAR(,A) 
CDDR     L     A,CDR(,A) 
         L     A,CDR(,A) 
         BR    2 
CDDDR    L     A,CDR(,A) 
         L     A,CDR(,A) 
         L     A,CDR(,A) 
         BR    2                                                        00035350
PROG2    LR        A,Q                                                  00035360
         BR        2                                                    00035370
*  ======  END OF BASE 3 SECTION  ===================================== 00035380
*  ==================================================================== 00035390
         EJECT                                                          00035400
*  ==================================================================== 00035410
*  ======  BEGINNING OF BASEREGISTER 13 SECTION. PLEASE NOTE THAT  ==== 00035420
*  ======      REGISTER 13 IS ALSO POINTING TO THE INTERPRETERS  ====== 00035430
*  ======      SAVEAREA  ============================================== 00035440
SAVEBLK  DC        18F'0'                                               00035450
*********************************************************************** 00035460
*********          READ ROUTINE        ********************             00035470
***********************************************************             00035480
*        SYNTAX ERRORS                                                  00035490
*        ERRB      A . AFTER A (                                        00035500
*        DOTERR1   THE SECOND S-EXPRESSION IN DOTTED PAIR IS NOT        00035510
*                   FOLLOWED BY )                                       00035520
*        DOTERR2   A , . OR ) FOLLOWS A .                               00035530
*        REG -CHAR- HAS POINTER TO CURRENT CHARACTER                    00035540
CHAR     EQU       3                   POINTER TO CURRENT CHARACTER     00035550
WKU      EQU       1                   WORK REGISTER                    00035560
ERRIND   DC        X'00'               X'01' INDICATES SYNTAX ERROR     00035570
*                                      X'04' LABEL OR NUMB TRUNC        00035580
LASTCHAR DC    A(0) 
RDSV2    DC        2F'0'               NOT RECURSIVE                    00035600
READ     EQU       *                                                    00035610
         STM       2,3,RDSV2           SAVE EM                          00035620
         L         CHAR,LASTCHAR                                        00035630
         MVI       ERRIND,X'00'        SET ERRIND OFF                   00035640
         LR        A,NILR              SET TO NIL LIST                  00035650
         LR        Q,NILR                                               00035660
         BAL       2,CONS              START NEW LIST                   00035670
         MVI       LINKS+3,X'00'       SET FOR CAR ATOM                 00035680
         MVI       ATOMEQ+3,X'00'      SET FOR CAR ATOM                 00035690
         LTR   CHAR,CHAR          IS THERE A CHARACTER YET? 
         BNZ   *+8                YES. 
         BAL   2,GETCD            NO; START AN INPUT RECORD. 
RDIG     BAL       2,TRYATOM           -A- IS ADDR OF CELL              00035700
         B         RDOUT               GOT ATOM                         00035710
         B         RDIG                DOT OR RT PAR                    00035720
         OI        ERRIND,X'10'        STARTING READ                    00035730
         BAL       2,TRYRPAR                                            00035740
         B         RDOUT               ATOM IS NIL                      00035750
         ST        A,EVLSV                                              00035760
         BAL       2,UPPER                                              00035770
RDOUT    ST        CHAR,LASTCHAR       -A- HAS POINTER TO TOP OF LI     00035780
         L         A,CAR(A)                                             00035790
         TM        ERRIND,X'01'                                         00035800
         BZ        RT2                                                  00035810
         PUTMSG    SYNTAXMS                                             00035820
T8       BC    0,STOP                                                   00035830
RT2      TM        ERRIND,X'04'                                         00035840
         BZ        RTOK                                                 00035850
         PUTMSG  TRUNCMSG                                               00035860
T9       BC    0,STOP                                                   00035870
RTOK     LM        2,3,RDSV2                                            00035880
         NI        ATOMIND,X'00'                                        00035890
         OC        MAININD(1),ERRIND   INDICATE ERROR TO MAIN PROGRAM   00035900
         NI        ERRIND,X'00'                                         00035910
         BR        2                                                    00035920
*                                                                       00035930
*********          RECURSIVE ENTRY FOR UPPER BRANCH      *********      00035940
*                                                                       00035950
UPPER    SAVE      2                                                    00035960
         SAVE      A                                                    00035970
         LR        WKU,A               HOLD -A-                         00035980
         BAL       2,CONS              GET A CELL                       00035990
         ST        A,CAR(WKU)            SET PTR DOWN                   00036000
         B         RDS                 READ S EXPRESSION                00036010
*                                                                       00036020
*********          RECURSIVE ENTRY FOR LOWER BRANCH     ************    00036030
*                                                                       00036040
LOWER    SAVE      2                                                    00036050
         SAVE      A                                                    00036060
RDCNO    LR        WKU,A                                                00036070
         LR        A,NILR              PREVENT A LOOP IN PRINT IF ABEND 00036080
         BAL       2,CONS              GET A CELL                       00036090
         ST        A,CDR(WKU)            SET PTR DOWN                   00036100
RDS      MVI       LINKS+3,CAR         SET FOR CAR ATOM                 00036110
         MVI       ATOMEQ+3,CAR        SET FOR CAR ATOM                 00036120
         BAL       2,TRYATOM                                            00036130
         B         RDBATM              GOT ONE                          00036140
         B         RDBERB                                               00036150
         BAL       2,TRYRPAR                                            00036160
         B         RDBRP                                                00036170
         BAL       2,UPPER                                              00036180
RDBATM   BAL       2,TRYRPAR                                            00036190
         B         RDRET                                                00036200
         B         RDCDOT                                               00036210
RDRET    UNSAVE    A                                                    00036220
         B         RETURN                                               00036230
RDBERB   LA        1,ERRB              LOAD ADDR OF ERRB                00036240
         ST        1,CAR(A)                                             00036250
         OI        ERRIND,X'01'                                         00036260
         B         RDBATM                                               00036270
RDBRP    ST        NILR,CAR(A)           SET CAR TO NIL                 00036280
         B         RDBATM                                               00036290
RDCDOT   BAL       2,TRYDOT                                             00036300
         B         RDCDOTT                                              00036310
         B         RDCNO                                                00036320
RDCDOTT  MVI       LINKS+3,CDR         SET FOR CDR ATOM                 00036330
         MVI       ATOMEQ+3,CDR        SET FOR CDR ATOM                 00036340
         BAL       2,TRYATOM                                            00036350
         B         RDCATM                                               00036360
         B         RDCDTER                                              00036370
         BAL       2,TRYRPAR                                            00036380
         B         RDRET                                                00036390
         BAL       2,LOWER                                              00036400
RDCATM   BAL       2,TRYRPAR                                            00036410
         B         RDRET                                                00036420
         LA        1,DOTERR1                                            00036430
         ST        1,CDR(A)              SET CDR TO DOTERR1             00036440
         OI        ERRIND,X'01'                                         00036450
         B         RDRET                                                00036460
RDCDTER  LA        1,DOTERR2                                            00036470
         ST        1,CDR(A)              SET CDR TO DOTERR2             00036480
         OI        ERRIND,X'01'                                         00036490
         B         RDCATM                                               00036500
         EJECT                                                          00036510
*********************************************************************** 00036520
*********          TRYATOM             **************************       00036530
*****************************************************************       00036540
ATOMIND  DC        X'00'               BIT SWITCHES                     00036550
*   BIT  8         ATOMIND                                              00036560
*        7         NUMIND                                               00036570
*        6         FLOATIND                                             00036580
*        5         EXPIND                                               00036590
*        4         NEGEXP                                               00036600
*        3         NEGINT                                               00036610
*        2         LOGICAL                                              00036620
ATMSV2   DC        1F'0'               SAVE RETURN, NON RECURSIVE       00036630
NEWGENSM EQU   CHARATA+4                                                00036660
         CNOP      4,8                                                  00036670
DIGATA   DC        H'0',H'10',4F'0'                                     00036680
EXPA     DC        H'0',H'2',F'0'      EXP SCAN AREA                    00036690
EXP      DC        H'0'                                                 00036700
*        SCAN AREA= CURR LENGTH,MAX LENGTH,DATA                         00036710
*        REG -A- CONTAINS CURRENT CELL IN LIST                          00036720
TRYATOM  EQU       *                                                    00036730
         ST        2,ATMSV2            SAVE RETURN                      00036740
         NI        ATOMIND,X'00'       CLEAR BITS                       00036750
         CLI       0(CHAR),C' '        BLANK                            00036760
         BNE       NOTBL                                                00036770
NEXTCHAR BAL       2,GETCHAR                                            00036780
ATLOK    CLI       0(CHAR),C' '        BLANK                            00036790
         BNE       NOTBL                                                00036800
         TM        ATOMIND,X'80'                                        00036810
         BZ        NEXTCHAR                                             00036820
         B         ALLATOM                                              00036830
NOTBL    CLI       0(CHAR),C','                                         00036840
         BNE       NOTCOM                                               00036850
         TM        ATOMIND,X'80'                                        00036860
         BO        ALLATOM                                              00036870
         B         NEXTCHAR            IGNORE COMMA                     00036880
NOTCOM   CLI       0(CHAR),C'.'                                         00036890
         BNE       NOTDOT                                               00036900
         TM        ATOMIND,X'40'       WAS IT A NUMBER COLLECTION       00036910
         BZ        CKATM               NO                               00036920
         OI        ATOMIND,X'20'       SET FLOAT IND ON                 00036930
         B         NEXTCHAR                                             00036940
CKATM    TM        ATOMIND,X'80'                                        00036950
         BO        ALLATOM                                              00036960
         BAL       2,GETCHAR                                            00036970
         L         2,ATMSV2                                             00036980
         B         4(2)                DOT & RT PAR RETURN              00036990
NOTDOT   CLI       0(CHAR),C')'                                         00037000
         BE        CKATM                                                00037010
CKLP     CLI       0(CHAR),C'('                                         00037020
         BNE       NOTLP                                                00037030
         TM        ATOMIND,X'80'                                        00037040
         BO        ALLATOM                                              00037050
         BAL       2,GETCHAR                                            00037060
         L         2,ATMSV2                                             00037070
         B         8(2)               LEFT PAR RETURN                   00037080
NOTLP    CLI       0(CHAR),C'-'                                         00037090
         BNE       NOTMIN                                               00037100
         LA        1,CHARATA                                            00037110
         BAL       2,STOCHAR                                            00037120
         BAL       2,GETCHAR                                            00037130
         BAL       2,CKDIG             IS IT DIGIT                      00037140
         B         RDDASH              NO                               00037150
         TM        ATOMIND,X'10'       IN EXPONENT                      00037160
         BZ        NOEXP                                                00037170
         OI        ATOMIND,X'08'       SET NEG EXPONENT                 00037180
         B         NOTBL                                                00037190
NOEXP    OI        ATOMIND,X'04'       SET NEG INTEGER                  00037200
         B         NOTBL                                                00037210
NOTMIN   CLI       0(CHAR),C'+'                                         00037220
         BNE       NOTPLUS                                              00037230
         LA        1,CHARATA                                            00037240
         BAL       2,STOCHAR                                            00037250
         BAL       2,GETCHAR                                            00037260
         BAL       2,CKDIG             IS IT DIGIT                      00037270
         B         RDPLUSS             NO                               00037280
         B         NOTBL               YES                              00037290
NOTPLUS  BAL       2,CKDIG             IS IT DIGIT                      00037300
         B         NOTDIGIT            NO                               00037310
         TM        ATOMIND,X'40'                                        00037320
         BO        STNAT                                                00037330
         TM        ATOMIND,X'80'                                        00037340
         BO        CHARATM                                              00037350
         OI        ATOMIND,X'C0'       ATOMIND & NUMBIND                00037360
         LA        1,0                                                  00037370
         MVC   DIGATA+4(16),CHZERO     INITIALIZATION                   00037380
         STH       1,DIGATA           ZEROING THE DIGIT AREAS           00037390
         STH       1,EXPA                                               00037400
         ST        1,EXPA+4                                             00037410
         STH       1,EXP                                                00037420
STNAT    TM        ATOMIND,X'10'       IN EXPONENT                      00037430
         BO        ACEXP               YES                              00037440
STNATT   LA        1,DIGATA            SET PTR                          00037450
         BAL       2,STOCHAR                                            00037460
         TM        ATOMIND,X'20'       FLOAT NUMBER                     00037470
         BNO       NEXTCHAR                                             00037480
         LH        1,EXP                                                00037490
         BCTR      1,0                                                  00037500
         STH       1,EXP                                                00037510
         B         NEXTCHAR                                             00037520
ACEXP    LA        1,EXPA              EXPONENT AREA                    00037530
         BAL       2,STOCHAR           STORE IT                         00037540
         B         NEXTCHAR            CONT                             00037550
CKDIG    CLI       0(CHAR),C'0'                                         00037560
         BL        0(2)                NOT DIGIT                        00037570
         CLI       0(CHAR),C'9'                                         00037580
         BH        0(2)                NOT DIGIT                        00037590
         B         4(2)                DIGIT                            00037600
NOTDIGIT TM        ATOMIND,X'40'       A NUMBER                         00037610
         BO        CKEXP               YES                              00037620
         CLI       0(CHAR),C'$'        LITERAL                          00037630
         BE        LITERAL                                              00037640
CHARATM  TM        ATOMIND,X'80'        ATOM                            00037650
         BO        ATOK                YES                              00037660
         MVC       CHARATA+4(16),ZERO                                   00037670
         MVC   CHARATA+20(ATMSZ-12),CHARATA+4 
         LA        1,0                                                  00037690
         STH       1,CHARATA                                            00037700
         OI        ATOMIND,X'80'       ATOM & LETTER                    00037710
ATOK     LA        1,CHARATA           SET PTR                          00037720
         BAL       2,STOCHAR                                            00037730
         B         NEXTCHAR                                             00037740
CKEXP    TM        ATOMIND,X'20'       IS IT FLOATNUMBER ?              00037750
         BO        CKEXP1              YES SEE IF THIS IS EXPMARKER     00037760
         CLI       0(CHAR),C'A'        IS CHAR LESS THAN 'A'            00037770
         BL        NOTLOG              NO                               00037780
         CLI       0(CHAR),C'F'        IS CHAR GREATER THAN 'F'         00037790
         BH        NOTEXP              YES                              00037800
         OI        ATOMIND,X'02'                                        00037810
         TR        0(1,CHAR),TABL1-193                                  00037820
         B         STNATT                                               00037830
CKEXP1   CLI       0(CHAR),C'E'        IS CHAR EXP MARK ?               00037840
         BNE       NOTEXP                                               00037850
         OI        ATOMIND,X'10'       SET EXP ON                       00037860
         B         NEXTCHAR                                             00037870
NOTEXP   CLI       0(CHAR),C'X'        LOGICAL                          00037880
         BNE       NOTLOG                                               00037890
         OI        ATOMIND,X'12'       SET EXP, LOG ON                  00037900
         B         NEXTCHAR                                             00037910
NOTLOG   OI        ERRIND,X'01'        INVALID SYNTAX                   00037920
         NI        ATOMIND,X'00'                                        00037930
         B         NEXTCHAR                                             00037940
RDDASH   EQU       *                                                    00037950
         TM        ATOMIND,X'80'                                        00037960
         BO        ATLOK                                                00037970
         LA        14,DASH                                              00037980
         B         ATOMEQ                                               00037990
RDPLUSS  EQU       *                                                    00038000
         TM        ATOMIND,X'80'                                        00038010
         BO        ATLOK                                                00038020
         LA        14,PLUSS                                             00038030
         B         ATOMEQ                                               00038040
STOCHAR  LH        15,0(1)             CURR LENGTH                      00038050
         CH        15,2(1)             AT MAX                           00038060
         BL        STOIT               NO                               00038070
         OI        ERRIND,X'04'        LABEL OR NUMBER TRUNCATED        00038080
         BR        2                   DROP CHAR                        00038090
STOIT    IC        0,0(CHAR)          PICK IT UP                        00038100
         STC       0,4(1,15)                                            00038110
         LA        0,1(,15)            ADD 1                            00038120
         STH       0,0(1)                                               00038130
         BR        2                                                    00038140
LITERAL  TM        ATOMIND,X'80'       LITERAL=>$$D..  ...D             00038150
         BO        ATOK                BUILDING ATOM                    00038160
         MVC       CHARATA+4(16),ZERO                                   00038170
         MVC   CHARATA+20(ATMSZ-12),CHARATA+4 
         LA        0,0                                                  00038190
         STH       0,CHARATA                                            00038200
         OI        ATOMIND,X'80'       ATOM & LETTER                    00038210
         LA        1,CHARATA                                            00038220
         BAL       2,STOCHAR           STO IT FOR NOW                   00038230
         BAL       2,GETCHAR           GET NEXT CHAR                    00038240
         CLI       0(CHAR),C'$'                                         00038250
         BNE       ATLOK               NOT A LITERAL                    00038260
         LH        15,CHARATA                                           00038270
         BCTR      15,0                BACK UP ONE, IE TO $             00038280
         STH       15,CHARATA                                           00038290
LITOK    BAL       2,GETCHAR           GET DELIMETER                    00038300
         IC        0,0(CHAR)          PICK IT UP                        00038310
         STC       0,DELM+1           STO IT                            00038320
LITON    BAL       2,GETCHAR           NEXT CHAR                        00038330
DELM     CLI       0(CHAR),C'9'        SCAN FOR DELIMETER               00038340
         BE        LITDN                                                00038350
         LA        1,CHARATA           SET PTR                          00038360
         BAL       2,STOCHAR                                            00038370
         B         LITON                                                00038380
LITDN    BAL       2,GETCHAR                                            00038390
         EJECT                                                          00038410
*        ALL REQUIRED CHARACTERS HAVE BEEN PICKED OFF THE CARD.         00038420
*        AN ALPHABETIC OR NUMERIC ATOM MAY NOW BE CONSTRUCTED.          00038430
*        REGISTERS 0,1,14,15 USED HERE- CONS MUST NOT ALTER THEM.       00038440
ALLATOM  TM        ATOMIND,X'40'       NUMB ATOM                        00038450
         BO        NUMAT     YES                                        00038460
         MVI       ATMTYP+1,ATOM       SET ATOM TYPE                    00038470
STSCH    L     1,HASHTBL          LOOK IN HASH TABLE 
         LTR   1,1                NONE 
         BNZ   SCH1               NOPE 
         L     15,=A(HASHINIT)    BUILD ONE 
         BR    15 
SCH1     LH    15,CHARATA+4       GET THE HASH KEY 
         AH    15,CHARATA+6 
         MH    15,=X'7A3C' 
         N     15,=X'00003FE0' 
         A     15,HASHTBL 
         MVI   LPSW,0             USED TO LOOK FOR LOOPS 
SCH2     L     14,0(0,15)         FIND NEXT ATOM 
         LR    1,15               SAVE LOCN IN HASH TBL 
         LTR   14,14              HOLE? 
         BZ    BUILDATM           YES - NEW ATOM 
         L     1,CAR(0,14)        FIND FULL WORD 
         L     0,CHARATA+4        NEW ATOM FULL WORD 
         C     0,CAR(0,1)         COMPARE 
         BNE   SCHAGN             NOT IT 
         LR    2,1                SET UP FOR REST OF COMPARE 
         SR    1,1 
         B     SCHEQ 
SCHAGN   LA    15,4(0,15)         NEXT ATOM 
         C     15,ENDHASH         END? 
         BL    SCH2               NOPE 
         L     15,HASHTBL         WRAP AROUND 
         XI    LPSW,1             BUT ONLY ONCE 
         BNZ   SCH2               OK 
TMNYATM  ERROR ' *** TOO MANY ATOMS (>4096)' 
LPSW     DC    X'0' 
***       FOUND ONE, SO COMPARE REST OF NAME                            00038520
SCHEQ    L         2,CDR(2)                                             00038550
         LA        2,0(,2)             ZERO EXTRA BITS                  00038560
         CR        2,NILR              NIL YET                          00038570
         BE        CKATEND             CHECK END OF AREA                00038580
         L         0,CAR(2)              NEXT PART OF NAME              00038590
         C         0,CHARATA+8(1)                                       00038600
         BNE       SCHAGN              SEARCH REST OF OBJLIST           00038610
         AR        1,K4                                                 00038620
         B         SCHEQ               TRY NEXT 4 BYTES                 00038630
CKATEND  SR    2,2 
         C         2,CHARATA+8(1)      SHOULD BE ZERO                   00038650
         BNE       SCHAGN              CHECK REST OF LIST               00038660
ATOMEQ   ST        14,CAR(A)             SET PTR TO ATOM                00038670
ATEXIT   L         2,ATMSV2            RESTORE 2                        00038680
         BR        2                   FOUND ATOM                       00038690
***  ATOM NOT ON OBJLIST SO WE ADD IT TO FRONT                          00038810
BUILDATM LR        15,A      SAVE-A- PNTS TO CURR CELL ABUILDING        00038820
         LR        Q,NILR    Q=NIL                                      00038830
         BAL       2,CONS              ATOM HEAD                        00038840
         ST    A,0(0,1)           STORE INTO HASH TABLE 
LINKS    ST        A,CAR(15)             LINK CELL TO LIST              00038850
         LR        14,A      SAVE-A- PNTS TO ATOM HEAD                  00038860
         L         1,OBJECTA           ADD ATOM TO FRONT OF OBJLIST     00038870
         L         Q,CDR(1)                                             00038880
         BAL       2,CONS              ADD TO OBJECT LIST               00038890
         ST        A,CDR(1)            LINK IT                          00038900
         LR        Q,NILR                                               00038910
         BAL       2,CONS              FIRST DATA CELL                  00038920
         ST        A,CAR(14)             LINK TO ATOM HEAD              00038930
ATMTYP   MVI       CAR(14),ATOM        MARK ATOM HEAD                   00038940
         LA        1,0                                                  00038950
         MVI       CDR(A),FWD          MARK ALPHA CELL                  00038960
         L         0,CHARATA+4         PNAME                            00038970
STNEXT   ST        0,CAR(A)              STORE NAME                     00038980
         L         0,CHARATA+8(1)      GET NEXT PART OF NAM E           00038990
         C         0,ZERO              END OF ST R ING                  00039000
         BE        BTEXIT              YES                              00039010
         LR        14,A                SAVE-A-                          00039020
         BAL       2,CONS              ANOTHER CELL                     00039030
         MVI       CDR(A),FWD          MARK AS ALPHA                    00039040
         ST        A,CDR(14)             LINK INTO LIST                 00039050
         MVI       CDR(14),FWD          MARK AS ALPHA                   00039060
         AR        1,K4                                                 00039070
         B         STNEXT                                               00039080
BTEXIT   LR        A,15                RESET A                          00039090
         B         ATEXIT                                               00039100
***  DATA SCANNED WAS A NUMERIC ATOM -- CONVERT TO FIX OR FLOAT         00039110
NUMAT    TM        ATOMIND,X'20'       FLOATIND                         00039120
         BO        FLOATINP                                             00039130
         TM        ATOMIND,X'02'       LOGICAL                          00039140
         BO        LOGINP                                               00039150
         LH        1,DIGATA            CONST LENGTH                     00039160
         BCTR      1,0                 LESS ONE                         00039170
         EX        1,PCK               PACK IT                          00039180
         CVB       1,DIGATA+12         TO BIN                           00039190
         TM        ATOMIND,X'04'       NUMB NEG                         00039200
         BZ        *+6                                                  00039210
         LCR       1,1                 YES, COMPLEMENT IT               00039220
         MVI       ATMTYP+1,FIX        SET CORRECT TYPE                 00039230
NUMIT    ST        1,CHARATA+4                                          00039240
         MVC       CHARATA+8(4),ZERO                                    00039250
         B         STSCH               MAKE AN ATOM                     00039260
LOGINP   LH        2,DIGATA            GET NUMBER OF LOGICAL DIGITS     00039270
         LA        14,DIGATA+4         R14 = LOWER BOUNDARY OF FIELD    00039280
         SR        0,0                 STE R0 TO 0                      00039290
LOGLOP   IC        1,0(14)             FIND FIRST DIGIT                 00039300
         SLL       1,28                AND PUT IT IN R0                 00039310
         SLDL      0,4                                                  00039320
         LA        14,1(0,14)          HAVE ALL DIGITS BEEN PROCESSED   00039330
         BCT       2,LOGLOP            IF SO BRANCH TO LOGLOP           00039340
         LH        2,EXPA              GET NUMBER OF DIGITS IN EXPONENT 00039350
         LTR       2,2                 TEST FOR ZERO                    00039360
         BZ        NUMITT              NO EXPONENT                      00039370
         BCTR      2,0                                                  00039380
         EX        2,PCK1              CONVERT EXPONENT TO BINARY       00039390
         CVB       2,CHARATA+4                                          00039400
         SLL   2,2                MULTIPLY EXPONENT BY 4                00039410
         SLL       0,0(2)              SHIFT LOGICAL NUMBER             00039420
*   CONSTRUCT A NONUNIQUE ATOM OUT OF THE LOGICAL NUMBER IN R0          00039430
NUMITT   LR        15,A                                                 00039440
         LR        Q,NILR                                               00039450
         LR        A,0                                                  00039460
         BAL       2,CONS                                               00039470
         MVI       CDR(A),FWD                                           00039480
         BAL       2,CONS                                               00039490
         MVI       CAR(A),LOGIC                                         00039500
         LR        14,A                                                 00039510
         LR        A,15                                                 00039520
         B         ATOMEQ                                               00039530
FLOATINP LH    0,EXP              EXP HAD MINUS NO. OF FRAC. DIG.S      00039540
         SR        2,2                                             UOM 
         TM    ATOMIND,X'10'      IS THERE AN EXP. FIELD  ?             00039550
         LH    1,DIGATA           GET NO. OF NOS.                       00039570
         BZ    NONEGXP            NO EXP.                               00039580
         LH    2,EXPA             GET EXP. DIG. COUNT                   00039590
         BCTR 2,0                 SUBTRACT 1 FOR PACK                   00039600
         EX    2,PCK1             PACK                                  00039610
         CVB   2,CHARATA+4        CONV. TO BIN.                         00039620
         TM    ATOMIND,X'08'      WAS EXP. NEG.                         00039630
         BZ    NONEGXP            NO                                    00039640
         LCR   2,2                YES, COMPLIMENT                       00039650
NONEGXP  AR    0,2                REG 0 NOW CONTAINS NO. OF FRAC. DIGIT 00039660
*                                 IN THE NUMBER RELATIVE TO THE END OF  00039670
*                                 THE FIELD  (ADJUSTED FOR EXPA)        00039680
         AR    1,0                REG 1 NOW CONTAINS NO. OF WHOLE NO.   00039690
*                                 DIGITS IN THE NUMBER RELATIVE TO THE  00039700
*                                 START OF THE FIELD                    00039710
         LR    15,0                                                     00039720
         LA    14,DIGATA+4                                              00039730
         LR    2,14                                                     00039740
         AR    14,1               GET ADDR. OF POS. OF D.P.             00039750
         SR    2,14               TO SEE IF D.P. BELOW START OF FIELD   00039760
         BC    11,LOWEQXP         BRANCH ZERO OR POS.  NOT INSIDE FIELD 00039770
         LA        2,DIGATA+12         ADDR. OF END OF FIELD            00039780
         SR    2,14               TO SEE IF ADDR. ABOVE END OF FIELD    00039790
         BC    13,UPEQXP               BRANCH IF ZER OR NEG. NOT IN FD  00039800
         SR        2,2                                             UOM 
         LTR   15,15              CHECK FOR NO EXP. BUT IN FIELD        00039810
         BC    11,NOXPATAL        ZERO OR POS. THEN BRANCH              00039830
         BCTR  1,0                REDUCE NO. COUNT FOR PACK             00039840
         EX    1,PCK2             PACK                                  00039850
         LCR   1,0                GET NO. OF FRAC. DIGITS               00039860
         BCTR  1,0                SUBTRACT 1 FOR PACK                   00039870
         EX    1,PCK3             PACK FRAC.    -THAT RHYMES-           00039880
         CVB   2,CHARATA+4        CONV. NO. AND FRAC. TO FLT. PT.       00039890
         MVI   DPA,X'4E'                                                00039900
         ST    2,DPA+4                                                  00039910
         LD    0,DPA                                                    00039920
         AD    0,ZERO             NO. IN FLT. PT. REG. 0                00039930
         CVB   2,CHARATA+12                                             00039940
         MVI   DPA,X'4E'                                                00039950
         ST    2,DPA+4                                                  00039960
         LD    2,DPA                                                    00039970
         AD    2,ZERO             FRAC. IN FLT. PT. REG. 2              00039980
         SLL   1,3                ADJUST TO FIND N IN 10**N             00039990
         MD    2,CTBL+8(1)        COMPUTE FRAC.*10**(-N)                00040000
         ADR   0,2                NO. + FRAC.*10**(-N)                  00040010
         B     COMNPART                                                 00040020
LOWEQXP  LH    1,DIGATA           GET LENGTH OF NO.                     00040030
         BCTR  1,0                SUBTRACT 1 FOR PACK                   00040040
         EX    1,PCK2             PACK                                  00040050
         CVB   14,CHARATA+4       CONVERT TO BIN.                       00040060
         LA    0,1(1,2)                                                 00040070
COMPNO   MVI   DPA,X'4E'          CONVERT NO. TO FLT. PT.               00040080
         ST    14,DPA+4                                                 00040090
         LD    0,DPA                                                    00040100
         AD    0,ZERO                                                   00040110
         SR    1,1                COMPUTE NO.                           00040120
         LCR   0,0                                                      00040130
         BZ    COMNPART           DONE IF NO EXP.                       00040140
         AH    0,=H'64'                                                 00040150
         BP    PLEXP                                                    00040160
         DD    0,DTBL+16          REDUCE NO.                            00040170
         AH    0,=H'32'           RAISE EXP                             00040180
PLEXP    SRDL  0,4                4 BITS                                00040190
         SRL   1,25                                                     00040200
         DD    0,CTBL(1)          FIRST 4 BITS OF EXP                   00040210
         SRDL  0,3                NEXT 3 BITS                           00040220
         SRL   1,26                                                     00040230
         DD    0,DTBL(1)                                                00040240
         B     COMNPART                                                 00040250
UPEQXP   AH        2,=H'1'                                              00040260
         LA        1,9                                                  00040270
NOXPATAL BCTR  1,0                SUBTRACT 1 FOR PACK                   00040280
         EX    1,PCK2             PACK                                  00040290
         CVB   14,CHARATA+4       CONVERT TO BIN.                       00040300
         LR    0,2                0 NOW CONTAINS POWER OF 10            00040310
         B     COMPNO                                                   00040320
COMNPART LTER      0,0                 IS THE NUMBER 0.0 ?              00040330
         BZ        BERNS               YES                              00040340
         STE       0,PVARG             ROUND RESULT IF NOT              00040350
         L     14,PVARG                                                 00040360
         SRL   14,24                                                    00040370
         STC   14,DOUBLCST                                              00040380
         AD    0,DOUBLCST                                               00040390
BERNS    LR        15,A                SAVE A                           00040400
         LR    Q,NILR             CREATE ATOM                           00040410
         BAL   2,CONS                                                   00040420
         STE   0,0(A)                                                   00040430
         TM    ATOMIND,X'04'      CHECK FOR NEG. NO.                    00040440
         BZ    NUMBPOS            NO.                                   00040450
         OI    0(A),X'80'                                               00040460
NUMBPOS  MVI   CDR(A),FWD                                               00040470
         BAL   2,CONS                                                   00040480
         MVI   CAR(A),FLOAT                                             00040490
         LR    14,A                                                     00040500
         LR    A,15                                                     00040510
         B     ATOMEQ                                                   00040520
         EJECT                                                          00040530
*********************************************************************** 00040540
*********          TRYDOT *** TRYRPAR         *******************       00040550
*****************************************************************       00040560
TRSV2    DC        F'0'                SAVE RETURN, NOT RECURSIVE       00040570
TRYDOT   MVI       TC+1,C'.'           SET TEST CHAR TO .               00040580
         B         TRYBL                                                00040590
TRYRPAR  MVI       TC+1,C')'           SET TEST CHAR TO )               00040600
TRYBL    CLI       0(CHAR),C' '        SCAN OUT BLANKS                  00040610
         BNE       TC                                                   00040620
         ST        2,TRSV2                                              00040630
NXTBL    BAL       2,GETCHAR                                            00040640
         CLI       0(CHAR),C' '                                         00040650
         BE        NXTBL                                                00040660
         L         2,TRSV2                                              00040670
TC       CLI       0(CHAR),C'.'                                         00040680
         BNE       4(2)                NOT . OR )                       00040690
         ST        2,TRSV2                                              00040700
         BAL       2,GETCHAR                                            00040710
         L         2,TRSV2                                              00040720
         BR        2                                                    00040730
         EJECT                                                          00040740
*********************************************************************** 00040750
*******************    PRINT    *************************************** 00040760
*********************************************************************** 00040770
P        EQU       3                   POINTER TO LINE POSITION         00040780
PRARGMNT DC    F'0'                                                     00040790
PRSV     DC        2F'0'               SAVE 2,3                         00040800
PSV      DC        F'0'                                                 00040810
LINEMAX  DC        A(LINE+100)         LIMIT WHEN OUTPUTING CHARS       00040820
SUPMAX   DC        A(LINE+120)         LIMIT FOR ATOMS                  00040830
PRINT    STM       2,3,PRSV                                             00040840
         ST    A,PRARGMNT                                               00040850
         L         P,PRTAB                                              00040860
         TM    CDR(A),X'40'                                             00040870
         BZ        PGOES               NO                               00040880
PEXIT    LM        2,3,PRSV                                             00040890
         L     A,PRARGMNT                                               00040900
         BR        2                                                    00040910
PGOES    TM        CAR(A),ATOM                                          00040920
         BZ        PUTLIST             ITS A LIST                       00040930
         BAL       2,PUTATOM                                            00040940
PWRT     BAL       2,WRLINE                                             00040950
         B         PEXIT                                                00040960
PUTLIST  LR        Q,A                                                  00040970
         LA        A,0                                                  00040980
*********          Q POINTS TO LIST BEING CURRENTLY OUTPUT              00040990
*********          A IS A SCRATCH REG USED FOR SAVING PTRS              00041000
         SAVE      A                                                    00041010
PLFTP    MVI       0(P),C'('      LEFT PAREN                            00041020
         BAL       2,PCKOVR            CHECK BUFFER AREA                00041030
PRNXT    L         A,CAR(Q)                                             00041040
         LR    0,A                CHECK CAR. 
         BAL   14,CKADDR 
         BZ    PRCDR              INVALID -- SKIP. 
         TM        CAR(A),ATOM                                          00041050
         BO        PATM                YES                              00041060
         LM        Q,M,CAR(Q)                                           00041070
         SAVE      M                                                    00041080
         B         PLFTP                                                00041090
PATM     BAL       2,PUTATOM                                            00041100
PRCDR    L     Q,CDR(,Q) 
         CR        Q,NILR                                               00041120
         BE        FNDNIL                                               00041130
PRLIST   LR    0,Q                CHECK CDR. 
         BAL   14,CKADDR 
         BZ    FNDNIL             INVALID -- SKIP. 
         TM    CAR(Q),ATOM 
         BO        PRDOT               YES                              00041150
         BAL       2,PCKOVR                                             00041160
         B         PRNXT                                                00041170
PRDOT    MVC       0(3,P),SNPPP+1                                       00041180
         MVI       1(P),C'.'                                            00041190
         LA        P,2(0,P)                                             00041200
         BAL       2,PCKOVR                                             00041210
         LR        A,Q                                                  00041220
         BAL       2,PUTATOM                                            00041230
FNDNIL   MVI       0(P),C')'                                            00041240
         BAL       2,PCKOVR                                             00041250
         UNSAVE    Q                                                    00041260
         LTR       Q,Q                                                  00041270
         BZ        PWRT                                                 00041280
         CR        Q,NILR                                               00041290
         BE        FNDNIL                                               00041300
         B         PRLIST                                               00041310
PCKOVR   LA        P,1(,P)             UP BY ONE                        00041320
         C         P,LINEMAX                                            00041330
         BL        0(2)                OK YET                           00041340
         ST        2,PSV               BETTER PRINT                     00041350
         BAL       2,WRLINE                                             00041360
         L         2,PSV               RESTORE 2                        00041370
         BR        2                                                    00041380
***      PUT ATOM -A- TO BUFFER, PRINT IF OVER, -P- POINTS TO BUFF      00041390
PUTATOM  ST        2,PSV               SAVE IT                          00041400
         TM        CAR(A),FIX                                           00041410
         BO        PRNUMB                                               00041420
         L         A,CAR(A)                                             00041430
PUTNXT   LR        0,Q                                                  00041440
         LR    1,P 
         LR    14,A 
PUTOFLO  LR    M,14 
NEXTFWD  LM        Q,M,CAR(M)                                           00041460
NEXTCHR  SLDL      A,8                                                  00041470
         STC       A,0(P)                                               00041480
         LA        P,1(0,P)                                             00041490
         C         P,SUPMAX                                             00041500
         BL        COMPRQ                                               00041510
         LTR   1,1 
         BZ    *+10 
         SR    P,1 
         EX    P,SPLAT 
         BAL   2,WRLINE 
         LTR   1,1 
         BZ    COMPRQ 
         SR    1,1 
         B     PUTOFLO 
SPLAT    MVC   0(0,1),BLANKS 
COMPRQ   LTR       Q,Q                                                  00041530
         BNZ       NEXTCHR                                              00041540
         LA        M,0(0,M)                                             00041550
         CR        M,NILR                                               00041560
         BNE       NEXTFWD                                              00041570
         LR        Q,0                                                  00041580
         B         PUTAX                                                00041590
PRNUMB   TM        CAR(A),FLOAT                                         00041600
         BO        PRFLT               YES                              00041610
         TM        CAR(A),LOGIC        IS IT A LOGICAL NUMBER ?         00041620
         BO        PRLOGIC             YES                              00041630
         L         A,CAR(A)                                             00041640
         L         A,CAR(A)            NUMBER                           00041650
         CVD       A,TEA               TO PACKED                        00041660
         MVC       WKA(12),MSK         EDIT MASK                        00041670
         LA        1,WKA+11                                             00041680
         EDMK      WKA(12),TEA+2                                        00041690
         BNM       PRNO                NOT NEG                          00041700
         BCTR      1,0                 ROOM FOR SIGN                    00041710
         MVI       0(1),C'-'           SET SIGN                         00041720
PRNO     LA        2,WKA+11            END OF AREA                      00041730
         SR        2,1                 LENGTH OF NUMB-1                 00041740
         LA    0,1(P,2) 
         C     0,SUPMAX 
         BNH   *+12 
         BAL   2,WRLINE 
         B     PRNO 
         STC       2,*+5               SET LENGTH                       00041750
         MVC       0(1,P),0(1)         TO PRINT AREA                    00041760
         LA        P,1(P,2)            UP P                             00041770
TSTOVR   C         P,LINEMAX                                            00041780
         BL        PUTAX                                                00041790
         BAL       2,WRLINE                                             00041800
PUTAX    L         2,PSV                                                00041810
         LR        A,NILR                                               00041820
         BR        2                                                    00041830
PRLOGIC  L         A,CAR(A)            GET ADDRESS OF PRINTNAME         00041840
         LA    0,10(,P) 
         C     0,SUPMAX 
         BNH   *+8 
         BAL   2,WRLINE 
         MVC       TEA(4),CAR(A)       MOVE LOGICAL NUMBER TO PACK AREA 00041850
         MVC       TEA+4(1),ZERO                                        00041860
         MVI       0(P),C'0'                                            00041870
         UNPK      1(9,P),TEA(5)                                        00041880
         TR        1(8,P),SNPTR-240    TRANSLATE THE LOGICAL NO.        00041890
         MVI       9(P),C'X'                                            00041900
         LA        P,10(0,P)                                            00041910
         B         TSTOVR                                               00041920
PRFLT    EQU       *                                                    00041930
         L         A,CAR(A)                                             00041940
         L     0,CAR(A)                                                 00041950
         LTR       0,0                                                  00041960
         BZ        FPA0                                                 00041970
         LA    2,13(,P) 
         C     2,SUPMAX 
         BNH   *+8 
         BAL   2,WRLINE 
         MVC       TEA(4),CAR(A)         MOVE NUMBER                    00041980
         MVI       TEA,X'40'           SET EXP                          00041990
         LE        0,TEA               LOAD FP REG                      00042000
         IC        1,CAR(A)            EXPONENT                         00042010
         SLDL      0,29                ALL BUT 3 BITS                   00042020
         SRL       1,26                BACK TO ADDRESS DBL WORDS        00042030
         LR        2,1                 SAVE IT                          00042040
         SRDL      0,4                 NEXT 4                           00042050
         SRL       1,25                TO ADDR DBL WD                   00042060
         DD        0,DTRA(1)                                            00042070
         SRL       1,2                 TO HALF                          00042080
         LH        M,DTRAH(1)                                           00042090
         CE        0,DPNCON                                             00042100
         BL        *+20                                                 00042110
         LA        2,8(,2)             UP BY ONE DBL WD                 00042120
         STE       0,TEA                                                00042130
         MVI       TEA,X'40'                                            00042140
         LE        0,TEA                                                00042150
         DD        0,DTRB(2)                                            00042160
         SRL       2,2                 TO HALF                          00042170
         AH        M,DTRBH(2)                                           00042180
         STD       0,TEA                                                00042190
         TM        TEA,X'01'                                            00042200
         MVI       TEA,X'00'                                            00042210
         LM        0,1,TEA                                              00042220
         BZ        *+8                                                  00042230
         SLDA      0,4                                                  00042240
*          AT THIS POINT 0 AND 1 CONTAIN A 14 DIGIT BINARY INTEGER      00042250
*          M HAS DECIMAL EXPONENT                                       00042260
FPA      EQU       CHARATA+4                                            00042270
         D         0,=F'1000000000'     10**9                           00042280
         CVD       0,TEA               LT 10**9                         00042290
         UNPK      FPA+10(9),TEA+3(5)                                   00042300
         OI        FPA+18,X'F0'        SET ZONE                         00042310
         CVD       1,TEA                                                00042320
         UNPK      FPA(10),TEA+2(6)    NOW A 19 DIGIT NUMBER AT FPA     00042330
         OI        FPA+9,X'F0'         DECIMAL POINT AT RIGHT OF FPA+18 00042340
         LA        1,FPA+3             SET UP TRT                       00042350
         TRT       FPA(3),TRTBL-240    FIND FIRST NON ZERO              00042360
         LA        2,FPA+18                                             00042370
         SR        2,1                 COMPUTE DECIMAL POINT            00042380
         AR        M,2                 EXPONENT                         00042390
         TM        CAR(A),X'80'          WAS NUMB NEG                   00042400
         BZ        *+12                                                 00042410
         MVI       0(P),C'-'           YES                              00042420
         LA        P,1(,P)                                              00042430
         MVC       0(1,P),0(1)         MOVE ONE DIGIT                   00042440
         MVI       1(P),C'.'                                            00042450
         MVC       2(6,P),1(1)         6 MORE DIGITS                    00042460
         MVC       8(4,P),DMSK                                          00042470
         CVD       M,TEA                                                00042480
         ED        8(4,P),TEA+6        EDIT EXP                         00042490
         MVI       9(P),C'+'           SET PLUS                         00042500
         BP        *+8                 SHOULD IT BE                     00042510
         MVI       9(P),C'-'           NO                               00042520
         LA        P,13(,P)            -N.NNNNNNE-NN                    00042530
         B         TSTOVR                                               00042540
FPA0     LA    0,3(,P) 
         C     0,SUPMAX 
         BNH   *+8 
         BAL   2,WRLINE 
         MVC   0(3,P),CHZERO 
         MVI       1(P),C'.'                                            00042560
         LA        P,3(0,P)                                             00042570
         B         TSTOVR                                               00042580
***                                                                     00042590
PRTAB    DC        A(LINE+5)           START VALUE                      00042600
PRIN1    STM       2,3,PRSV                                             00042610
         TM    CAR(A),ATOM        MUST BE AN ATOM 
         BZR   2                  IGNORE IF NOT 
         L     P,PRTAB            LEFT OFF HERE 
         BAL       2,PUTATOM                                            00042650
         BCTR      P,0                                                  00042660
         BAL       2,PCKOVR                                             00042670
         ST        P,PRTAB                                              00042680
         LM        2,3,PRSV                                             00042690
         BR        2                                                    00042700
***                                                                     00042710
*        MOVE OVER N POSNS                                              00042720
XTAB     L         Q,CAR(A)                                             00042730
         L         Q,CAR(Q)                                             00042740
         LPR       Q,Q                 MUST BE POSITIVE                 00042750
         A         Q,PRTAB                                              00042760
         LR        A,NILR                                               00042770
         C         Q,LINEMAX                                            00042780
         BH        TERPRI              PRINT IT                         00042790
         ST        Q,PRTAB                                              00042800
         BR        2                                                    00042810
*        MOVE TO N'TH POSITION                                          00042820
TTAB     L         Q,CAR(A)                                             00042830
         L         Q,CAR(Q)                                             00042840
         LPR       Q,Q                 MUST BE POS                      00042850
         LA        M,LINE                                               00042860
         AR        Q,M                                                  00042870
         LR        A,NILR                                               00042880
         C         Q,SUPMAX                                             00042890
         BH        0(2)                                                 00042900
         ST        Q,PRTAB                                              00042910
         BR        2                                                    00042920
***                                                                     00042930
TERPRI   STM       2,3,PRSV                                             00042940
         BAL       2,WRLINE                                             00042950
         LM        2,3,PRSV                                             00042960
         BR        2                                                    00042970
DMSK     DC        X'C5212020'                                          00042980
TRTBL    DC        X'00'               MUST HAVE 8 NON ZERO DIGITS AFT  00042990
MSK      DC        X'402020202020202020202120'  BDD,DDD,DDD,DSD         00043000
WKA      DC        4F'0'                                                00043010
TEN8     DC        F'100000000'                                         00043020
DPNCON   DC        X'41100000'                                          00043030
         EJECT                                                          00043040
*********************************************************************** 00043050
*********  RTRN  ENTERED FROM COMPILER  ******************************* 00043060
*********************************************************************** 00043070
RTRN     UNSAVE 3                                                       00043080
*********************************************************************** 00043090
*******  RETURN    ***************************************************  00043100
**********************************************************************  00043110
RETURN   UNSAVE    2                   GET LINK ADDR                    00043120
         BR        2                                                    00043130
*********************************************************************** 00043140
*******  SAVE      ***************************************************  00043150
**********************************************************************  00043160
         CNOP      0,4                                                  00043170
NILG     DC        X'80',AL3(NILF)                                      00043180
ERG2     L         A,NILG                                               00043190
         ST        A,NIL                                                00043200
         PUTMSG    ' *** G2-PUSHDOWN STACK OVERFLOW'                    00043210
         CR        FREE,K4             STACK OFLOW IN GARBAGECOLL?      00043220
         BNL   ERDAN              NO. 
         MVI       ERRORIND,X'03'      YES, FATAL ERROR                 00043240
         ERROR     ' WHILE GARBAGECOLLECTING'                           00043250
         EJECT                                                          00043340
*********************************************************************** 00043350
*******  CONS      ***************************************************  00043360
**********************************************************************  00043370
*        MUST NOT DESTROY ANY REGISTERS                                 00043380
*         END OF FREE LIST IS MARKED BY FREE EQUAL TO 1. THIS GIVES A   00043390
*        SPECIFICATION EXCEPTION TO CAUSE A GARBAGE COLLECTION          00043400
CONS     ST    A,CAR(,FREE) 
         LR    A,FREE 
         L     FREE,CDR(,FREE) 
         ST    Q,CDR(,A) 
         BR        2                                                    00043450
         EJECT                                                          00043460
*********************************************************************** 00043470
*******  GETCHAR   ***************************************************  00043480
**********************************************************************  00043490
CARDEND  DC    A(0) 
CARDLNTH DC    A(CDEND) 
INDCBADR DC    A(0) 
GETCHAR  LA        CHAR,1(,CHAR)       NEXT CHAR                        00043540
         C     CHAR,CARDEND                                             00043550
         BLR       2                                              UOM 
GETCD    EQU       *                                                    00043570
         L         R1,INDCBADR                                          00043580
         GET       (R1)                                                 00043590
         LR        CHAR,1              LOCN OF CARD                     00043600
         ST    CHAR,LASTCHAR 
         A     1,CARDLNTH                                               00043610
         ST    1,CARDEND                                                00043620
         TM        BUFFPR,X'01'                                         00043630
         BZR       2                                              UOM 
         LA    0,120              COMPUTE MIN(LRECL,120). 
         L     1,INDCBADR 
         USING DCBDS,1 
         LH    1,LRECL# 
         DROP  1 
         CR    1,0 
         BNH   *+6 
         LR    1,0 
         BCTR  1,0 
         MVC   MSGBUFFR(8),=C' =>     '  PUT IN PREFIX. 
         STC   1,*+5              NOT RE-ENTRANT !! 
         MVC   MSGBUFFR+8(0),0(CHAR)  COPY LINE FOR PRINTING. 
         L     R1,OTDCBADR        USE OUTPUT DCB. 
         STM   13,1,WRSV 
         B     PUTMSG2            PRINT THE INPUT LINE. 
LASTCARD TM        ERRIND,X'10'        WERE WE READING A LIST           00043700
         BZ        OKEOF               NO                               00043710
         MVI       ERRORIND,X'03'      TERMINAL ERROR                   00043720
         L         A,EVLSV                                              00043730
         L         A,CAR(A)                                             00043740
         SR        Q,Q                                                  00043750
         ERROR     ' *** R2-BAD BRACKET COUNT'                          00043760
OKEOF    PUTMSG    ' *** END OF DATA'                                   00043770
         B         STOP                                                 00043780
         EJECT                                                          00043790
*********************************************************************** 00043800
*******  WRLINE    ***************************************************  00043810
**********************************************************************  00043820
MARGIN1  DC        A(LINE)                                              00043830
MARGIN2  DC        A(MSGBUFFR)                                          00043840
OTDCBADR DC        A(PRINTCB)                                           00043850
WRSV     DC        6F'0'                                                00043860
***      WRLINE IS USED TO OUTPUT DATA AREA 'LINE' AND RESET IT         00043870
*        TO BLANKS                                                      00043880
WRLINE   STM       13,1,WRSV                                            00043910
         L         0,MARGIN1                                            00043920
         L         R1,OTDCBADR                                          00043930
         PUT       (R1),(0)                                             00043940
         MVC   LINE,BLANKS 
         LA        P,LINE+5                                             00043970
         ST        P,PRTAB                                              00043980
         LM    13,1,WRSV                                                00043990
         BR        2                                                    00044000
***      PUTMSG IS USED TO OUTPUT A MESSAGE, A VARIABLE LENGTH RECO€:   00044010
PUTMSG   L         R1,OTDCBADR                                          00044020
         CL    14,=F'4095'        TEST MESSAGE LOCATION. 
         BH    *+8                ADDRESS -- SKIP. 
         AL    14,=A(LISPMSG)     DISPLACEMENT; CONVERT TO ADDRESS. 
         LH    15,0(,14)          GET MESSAGE LENGTH-1. 
         STC       15,MSGMOVE+1                                         00044040
MSGMOVE  MVC       MSGBUFFR(1),2(14)                                    00044050
PUTMSG2  L     0,MARGIN2 
         PUT       (R1),(0)                                             00044070
         MVC   MSGBUFFR,BLANKS 
         LM        13,1,WRSV                                            00044100
         BR        2                                                    00044110
EJECT    ST        2,RESAV                                              00044120
         PUTMSG    SKIP                                                 00044130
         L         2,RESAV                                              00044140
         LR        A,NILR                                               00044150
         BR        2                                                    00044160
SKIP     DC        AL2(2),C'1 '                                         00044170
         EJECT                                                          00044180
*********************************************************************** 00044190
*******************   GARBAGE COLLECTOR   ***************************** 00044200
**********************************************************************  00044210
LISPMSG  CSECT 
         CNOP  6,8 
GARBMS   DC    AL2(73) 
GARBMS1  DC    C'XXXXXXXX CELLS TOTAL;   ' 
GARBMS2  DC    C'XXXXXXXX CELLS ACTIVE;  ' 
GARBMS3  DC    C'XXXXXXXX STACK UNITS LEFT.' 
LISP     CSECT 
CELLCNT  DC    F'0'               NUMBER OF LISP CELLS. 
GARBTM2  DC    D'0'               SAVE COUNTS AND CONVERT. 
GARBTEMP DC    6F'0'              SAVE ALL NEEDED REGISTERS 
GARBCOLL STM   14,3,GARBTEMP 
         SAVE      A                                                    00044290
         SAVE      Q                                                    00044300
         SAVE      M                                                    00044310
         LA    15,GARBCNT5 
MARK     DS    0H                 ENTRY TO MARK CELLS AND NOT COLLECT 
         LR    Q,NILR                  COMPUTE PDS LEFT                 00044320
         SR    Q,PDS                                                    00044330
         SRL   Q,2(0)                                                   00044340
         ST    Q,GARBTM2+4                                              00044350
         LR        A,K4                                                 00044360
         LR        Q,PDS               TOP OF STACK                     00044370
**       TRACE ALL ACTIVE LISTS AND MARK CELLS. 
         LA    M,TEMPORAR         USE STACK AND MISC. POINTERS. 
NXTPUSH  L     2,0(,M)            GET NEXT ADDRESS ON STACK. 
         LR    0,2 
         BAL   14,CKADDR          IS IT A VALID CELL ADDRESS? 
         BZ    GARBCONT           NO -- SKIP. 
         SR    3,3                YES; STACK ZERO. 
         SAVE  3 
GARB2    TM    CDR(2),X'80'       IS CELL (R2) ALREADY MARKED? 
         BO    GARB4              YES. 
         TM    CDR(2),X'40'       NO; IS IT A FULLCELL? 
         BO    GARB3              YES. 
         OI    CDR(2),X'80'       NO; SET ACTIVE MARK. 
         LM    2,3,CAR(2)         GET ITS CAR AND CDR. 
         TM    CDR(3),X'80'       IS CDR CELL MARKED? 
         BO    GARB2              YES -- TRACE CAR. 
         SAVE  3                  NO; STACK ADDRESS. 
         B     GARB2 
GARB3    OI    CDR(2),X'80'       MARK FULLCELL ACTIVE. 
         L     2,CDR(,2)          GO DOWN FULLCELL LIST. 
         TM    CDR(2),X'80'       MARKED? 
         BZ    GARB3              NO. 
GARB4    UNSAVE 2                 UNSTACK AN ADDRESS. 
         LTR   2,2                MORE ON THIS LIST? 
         BNZ   GARB2              YES. 
GARBCONT BXLE  M,A,NXTPUSH        ADVANCE STACK POINTER. 
         BR    15                 RETURN IF ENTERED AT MARK 
**       NOW SCAN STORAGE FOR INACTIVE CELLS, AND COLLECT THEM. 
GARBCNT5 DS    0H 
         AR    A,A                CELL LENGTH. 
         LR    3,NILR             START WITH STATIC BLOCK. 
         L     Q,BOTTOM 
         SR    M,M                ZERO THE INACTIVE COUNT. 
         LA    1,1 
GARB51   TM    CDR(3),X'80'       IS CELL ACTIVE? 
         BNZ   GARB6              YES -- SKIP. 
         ST    FREE,CDR(,3)       NO; PUT IT ON FREE LIST. 
         LR    FREE,3 
         AR    M,1                KEEP COUNT OF INACTIVE CELLS. 
GARB6    NI    CDR(3),X'7F'       SET COLLECTION BIT OFF. 
         BXLE  3,A,GARB51         REPEAT FOR WHOLE BLOCK. 
         CL    Q,BOTTOM           WAS THIS THE STATIC BLOCK? 
         BNE   *+8                NO. 
         LA    2,STORBLKS         YES -- START DYNAMIC BLOCKS. 
         L     2,0(,2)            GET NEXT BLOCK. 
         LTR   2,2                ALL BLOCKS SCANNED? 
         BZ    GARB7              YES. 
         LA    3,8(,2)            NO; POINT TO 1ST CELL. 
         L     Q,4(,2)            POINT TO END OF BLOCK. 
         B     GARB51             GO SCAN IT. 
GARB7    C     M,=F'400'          DID WE COLLECT ENOUGH? 
         BNL   GARB10             YES -- SKIP. 
         LA    0,2                NO; GET ANOTHER BLOCK. 
         L     1,=A(SBLKSIZ) 
         L     15,=V(GETSPACE) 
         BASR  14,15 
         LTR   15,15              DID WE GET IT? 
         BNZ   GARB10             NO -- SETTLE FOR WHAT WE HAVE. 
         LR    3,1                YES; COPY BLOCK ADDRESS. 
         LR    Q,1                COMPUTE END OF BLOCK. 
         AL    Q,=A(SBLKSIZ) 
         BCTR  Q,0 
         ST    Q,4(,3)            SAVE END IN BLOCK HEADER. 
         SR    0,0 
         LA    2,8(,3)            POINT TO 1ST CELL. 
         LA    1,8(,2)            INITIALIZE THE BLOCK. 
GARB8    STM   0,1,0(2) 
         LR    2,1 
         BXLE  1,A,GARB8 
         LR    1,FREE             LINK AT HEAD OF FREE LIST. 
         STM   0,1,0(2) 
         LA    FREE,8(,3) 
         L     1,STORBLKS         ADD BLOCK TO BLOCK LIST. 
         ST    1,0(,3) 
         ST    3,STORBLKS 
         L     3,=A((SBLKSIZ-8)/8)  GET NBR CELLS IN BLOCK. 
         AR    M,3                ADD TO INACTIVE COUNT. 
         A     3,CELLCNT          ADD TO TOTAL COUNT. 
         ST    3,CELLCNT 
GARB10   TM    GARBSW,X'01'       IS VERBOS SWITCH ON? 
         BZ    GARBSWT            NO -- SKIP PRINTOUT. 
         L     3,GARBTM2+4        YES; GET PDS SPACE. 
         L     2,CELLCNT          GET NBR OF LISP CELLS. 
         CVD   2,GARBTM2          PLUG INTO MESSAGE. 
         L     1,=A(GARBMS)       BASE FOR MESSAGE 
         USING GARBMS,1 
         MVC   GARBMS1(8),MASK 
         ED    GARBMS1(8),GARBTM2+4 
         SR    2,M                COMPUTE NBR ACTIVE CELLS. 
         CVD   2,GARBTM2          PLUG IN. 
         MVC   GARBMS2(8),MASK 
         ED    GARBMS2(8),GARBTM2+4 
         CVD   3,GARBTM2          STACK UNITS LEFT. 
         MVC   GARBMS3(8),MASK                                          00044800
         ED    GARBMS3(8),GARBTM2+4                                     00044810
         PUTMSG GARBMS                                                  00044820
         DROP  1 
GARBSWT  UNSAVE M                                                       00044830
         UNSAVE    Q                                                    00044840
         UNSAVE    A                                                    00044850
         LM    14,3,GARBTEMP 
         CR        FREE,K4             COLLECT ANY                      00044870
         BNL       CONS1                                                00044880
         OI        ERRORIND,X'03'      TERMINAL ERROR AND NO PDL PRINT  00044890
         ERROR     ' *** GC2-STORAGE EXHAUSTED'                         00044900
         EJECT 
*        CHECK CELL ADDRESS IN GR0. 
* 
CKADDR   LR    1,0                CLEAR ANY FLAG BITS. 
         LA    0,0(,1) 
         N     1,=X'00000007'     MUST BE DOUBLEWORD. 
         BNZ   CKADNO 
         CLR   0,NILR             IS IT IN THE STATIC BLOCK? 
         BL    CKADB 
         CL    0,BOTTOM 
         BNH   CKADOK             YES. 
CKADB    LA    1,STORBLKS         NO; SEARCH DYNAMIC BLOCKS. 
CKADNXT  L     1,0(,1) 
         LTR   1,1                END OF LIST? 
         BZ    CKADNO             YES. 
         CLR   0,1                CHECK BEGINNING. 
         BNH   CKADNXT            NOT HERE. 
         CL    0,4(,1)            CHECK END. 
         BH    CKADNXT            NOT HERE. 
CKADOK   LTR   0,0                OK; SET CC ~= 0. 
         BR    14 
CKADNO   SR    1,1                NO GOOD; SET CC=0. 
         BR    14 
         EJECT                                                          00044950
         LTORG                                                          00044960
PUSHA    DC        A(PUSH)                                              00044970
NILA     DC        A(NIL)                                               00044980
BOTTOM   DC        A(TOP1+8*STORESIZ-8)  POINTER TO END OF FWS          00044990
STORBLKS DC    A(0)               HEAD OF STORAGE BLOCK LIST 
BPSSTART DC    A(BPSST)                                                 00045010
         DC    A(BPSST+4*BPSSIZE)                                       00045020
HASHTBL  DC    A(0)               HASH TABLE POINTER 
ENDHASH  DC    A(0)               END OF HASH TALE 
TEMPORAR EQU       *                   THIS IS THE START OF A 25        00045030
*        WORD AREA FOR THE STORAGE OF PTRS THAT MAY BE NEEDED AT        00045040
*        GARBAGE COLLECTION.                                            00045050
OBJECTA  DC        A(OBJECT)           POINTER TO START OF OBJECTLIST   00045060
GARBT    DC        3F'0'                                                00045080
PROGT    EQU       GARBT               TEMP IN CASE OF GARB COLLN       00045090
GOLIST   EQU       GARBT+4             TEMP IN CASE OF GARB COLLN       00045100
EVLSV    DC        3F'0'                                                00045110
TAPPL    DC    2F'0'                                                    00045120
ARGS     DC    20A(0)             FOR ARGS 3 TO 22 
*  ======  END OF BASE 13 SECTION  ==================================== 00045130
*  ==================================================================== 00045140
*  ==================================================================== 00045150
*  ======  REGISTER 7 IS ALWAYS POINTING TO THE LAST SAVED  =========== 00045160
*  ======      ELEMENT IN THE STACK. REGISTER 7 MUST THEREFORE NEVER BE 00045170
*  ======      USED IN THE ASSEMBLER OR IN THE INTERPRETER  =========== 00045180
PUSH     DS        (STACKSIZ)F                                          00045190
         CNOP      0,8                                                  00045200
         EJECT                                                          00045210
*********************************************************************** 00045220
******************    OBJECT LIST    ********************************** 00045230
*********************************************************************** 00045240
*        THE MACRO 'ECHO' IS USED TO DEFINE THE OBJECT LIST.            00045250
*        THE MACRO IS LABELLED IF THE GENERATED ATOM IS TO BE           00045260
*        REFERRED TO BY ANOTHER ATOM.                                   00045270
*        THE PARAMETERS ARE AS FOLLOWS.                                 00045280
*        1 - PRINT NAME (1 TO 8 CHARS)           REQD                   00045290
*        2 - PROPERTY                            OPTIONAL               00045300
*        3 - INTERNAL SUBRTN NAME                REQD WITH 2            00045310
*        4 - NUMBER OF ARGS FOR 3                ZERO ASSUMED           00045320
*                                                                       00045330
*                  *******************************************          00045340
* ATOMHEAD         *X'MM'          A(P1)*               A(P2)*          00045350
*                  *******************************************          00045360
*                                                                       00045370
*                  *******************************************          00045380
*        P1        *'ABCD'              *X'40'          A(P3)*          00045390
*                  *******************************************          00045400
*                                                                       00045410
*                  *******************************************          00045420
*        P3        *'EF00'              *X'40'         A(NIL)*          00045430
*                  *******************************************          00045440
*                                                                       00045450
*                  *******************************************          00045460
*        P2        *         A(PROPERTY)*               A(P4)*          00045470
*                  *******************************************          00045480
*                                                                       00045490
*                  *******************************************          00045500
*        P4        *               A(P5)*              A(NIL)*          00045510
*                  *******************************************          00045520
*                                                                       00045530
*                  *******************************************          00045540
*        P5        *X'NN'      A(SUBRTN)*X'40'         A(NIL)*          00045550
*                  *******************************************          00045560
*                                                                       00045570
*                                                                       00045580
*    MM  X'80'     ALPHABETIC ATOM                                      00045590
*        X'C0'     FIXED POINT ATOM                                     00045600
*        X'E0'     FLOATING POINT ATOM                                  00045610
*        X'D0'     LOGICAL ATOM                                         00045620
*                                                                       00045630
*        NN IS THE NUMBER OF ARGUMENTS REQUIRED BY SUBRTN               00045640
*        P2 AND P3 MAY BE NIL                                           00045650
*  ==================================================================== 00045660
*  ======  REGISTER 5 WHICH IS ALWAYS POINTING TO THE ATOM NIL  ======= 00045670
*  ======      IS ALSO USED AS A BASEREGISTER FOR THE BEGINNING OF  === 00045680
*  ======      THE OBJECT LIST  ======================================= 00045690
*  ======  REGISTER 5 IS ALSO USED AS A POINTER TO THE END OF THE  ==== 00045700
*  ======      STACK. BECAUSE THE ATOMHEAD OF NIL OCCUPIES THE FIRST  = 00045710
*  ======      WORD BEHIND THE STACK  ================================= 00045720
         PRINT     NOGEN                                           UOM 
NIL      DC        X'80',AL3(NILF),A(NILB)                              00045730
OBJECT   DC        A(NIL,NILF+8)       START OF OBJECT LIST             00045740
NILB     DC        A(APVAL,NILC)                                        00045750
NILC     DC        A(NILE,NIL)                                          00045760
NILE     DC        A(NIL,NIL)                                           00045770
NILF     DC    CL4'NIL',XL1'60',AL3(NIL)                               00045780
         ECHO      CAR,SUBR,CARR,1                                      00045790
         ECHO      CDR,SUBR,CDRR,1                                      00045800
QUOTE    ECHO      QUOTE                                                00045810
         ECHO      CONS,SUBR,CONS,2                                     00045820
         ECHO      EVAL,SUBR,EVAL,2                                     00045830
         ECHO      DEFINE,SUBR,DEFINE,1                                 00045840
         ECHO      EQ,SUBR,EQ,2                                         00045850
         ECHO      EQUAL,SUBR,EQUAL,2                                   00045860
         ECHO      ATOM,SUBR,ATOMP,1                                    00045870
APVAL    ECHO      APVAL                                                00045880
EXPR     ECHO      EXPR                                                 00045890
SUBR     ECHO      SUBR                                                 00045900
COND     ECHO      COND                                                 00045910
LAMBDA   ECHO      LAMBDA                                               00045920
         DC        A(*+8,*+20)                                          00045930
CHROBJ   EQU       *                                                    00045940
BLANK    DC    XL1'80'                                                  00045950
         DC    AL3(*+7)                                                 00045960
         DC    A(NIL)                                                   00045970
         DC    CL4' ',XL1'60',AL3(NIL)                               00045980
AA       ECHO      A                                                    00045990
         ECHO      B                                                    00046000
         ECHO      C                                                    00046010
         ECHO      D                                                    00046020
         ECHO      E                                                    00046030
         DC        A(F,G-8)                                             00046040
F        DC        XL1'80',AL3(PRINF),A(PROPF)                          00046050
PRINF    DC    CL4'F',XL1'60',AL3(NIL)                               00046060
G        ECHO      G                                                    00046070
         ECHO      H                                                    00046080
         ECHO      I                                                    00046090
         ECHO      €                                                    00046100
PERIOD   ECHO      .                                                    00046110
         ECHO      <                                                    00046120
         DC        A(*+8,*+20)                                          00046130
LPAR     DC    XL1'80'                                                  00046140
         DC    AL3(*+7)                                                 00046150
         DC    A(NIL)                                                   00046160
         DC    CL4'(',XL1'60',AL3(NIL)                               00046170
PLUSS    ECHO      +                                                    00046180
         ECHO      |                                                    00046190
         DC        A(*+8,*+20)                                          00046200
         DC    XL1'80'                                                  00046210
         DC    AL3(*+7)                                                 00046220
         DC    A(NIL)                                                   00046230
         DC    CL4'&&',XL1'60',AL3(NIL)                              00046240
         ECHO      J                                                    00046250
         ECHO      K                                                    00046260
         ECHO      L                                                    00046270
         ECHO      M                                                    00046280
         ECHO      N                                                    00046290
         ECHO      O                                                    00046300
         ECHO      P                                                    00046310
         ECHO      Q                                                    00046320
         ECHO      R                                                    00046330
         ECHO      !                                                    00046340
DOLLAR   ECHO      $                                                    00046350
STAR     ECHO      *                                                    00046360
         DC        A(*+8,*+20)                                          00046370
RPAR     DC    XL1'80'                                                  00046380
         DC    AL3(*+7)                                                 00046390
         DC    A(NIL)                                                   00046400
         DC    CL4')',XL1'60',AL3(NIL)                               00046410
         ECHO      ;                                                    00046420
         ECHO      ~                                                    00046430
DASH     ECHO      -                                                    00046440
SLASH    ECHO      /                                                    00046450
         ECHO      S                                                    00046460
         DC        A(T,U-8)                                             00046470
T        DC        XL1'80',AL3(PRINTT),A(PROPT)                         00046480
PRINTT   DC    CL4'T',XL1'60',AL3(NIL)                               00046490
U        ECHO      U                                                    00046500
         ECHO      V                                                    00046510
         ECHO      W                                                    00046520
         ECHO      X                                                    00046530
         ECHO      Y                                                    00046540
         ECHO      Z                                                    00046550
         ECHO      ó                                                    00046560
         DC        A(*+8,*+20)                                          00046570
COMMA    DC    XL1'80'                                                  00046580
         DC    AL3(*+7)                                                 00046590
         DC    A(NIL)                                                   00046600
         DC    CL4',',XL1'60',AL3(NIL)                               00046610
         ECHO      %                                                    00046620
         ECHO      _                                                    00046630
         ECHO      >                                                    00046640
         ECHO      ?                                                    00046650
         ECHO      0                                                    00046660
         ECHO      1                                                    00046670
         ECHO      2                                                    00046680
         ECHO      3                                                    00046690
         ECHO      4                                                    00046700
         ECHO      5                                                    00046710
         ECHO      6                                                    00046720
         ECHO      7                                                    00046730
         ECHO      8                                                    00046740
         ECHO      9                                                    00046750
         ECHO      :                                                    00046760
         ECHO      #                                                    00046770
         ECHO      @                                                    00046780
         DC        A(*+8,*+20)                                          00046790
         DC    XL1'80'                                                  00046800
         DC    AL3(*+7)                                                 00046810
         DC    A(NIL)                                                   00046820
         DC    CL4'''',XL1'60',AL3(NIL)                              00046830
EQSIGN   ECHO      =                                                    00046840
         DC        A(PP,FEXPR-8)                                        00046850
PP       DC        XL1'80',AL3(PRINTPP),A(NIL)                          00046860
PRINTPP  DC    CL4'"',XL1'60',AL3(NIL)                               00046870
PROPT    DC        A(APVAL,PROPT1)                                      00046880
PROPT1   DC        A(PROPT2,NIL)                                        00046890
PROPT2   DC        A(T,NIL)                                             00046900
PROPF    DC        A(APVAL,PROPF1)                                      00046910
PROPF1   DC        A(PROPF2,NIL)                                        00046920
PROPF2   DC        A(NIL,NIL)                                           00046930
FEXPR    ECHO      FEXPR                                                00046940
FSUBR    ECHO      FSUBR                                                00046950
LABEL    ECHO      LABEL                                                00046960
FUNARG   ECHO      FUNARG                                               00046970
         DC    A(ZEERO,ZEEROPNM+8)                                      00046980
ZEERO    DC    XL1'C0',AL3(ZEEROPNM),A(NIL)                             00046990
ZEEROPNM DC    F'0',XL1'60',AL3(NIL)                                    00047000
BPS      ECHO  BPS,APVAL,BPSSTART                                       00047010
ERRB     ECHO      ERRB                                                 00047020
DOTERR1  ECHO      DOTERR1                                              00047030
DOTERR2  ECHO      DOTERR2                                              00047040
SYSIN    ECHO      SYSIN                                                00047050
SYSOUT   ECHO      SYSOUT                                               00047060
SYSPUNCH ECHO      SYSPUNCH                                             00047070
INPUT    ECHO      INPUT                                                00047080
OUTPUT   ECHO      OUTPUT                                               00047090
LISPIN   ECHO      LISPIN                                               00047100
LISPOUT  ECHO      LISPOUT                                              00047110
LISPUNCH ECHO      LISPUNCH                                             00047120
SYSFILE  ECHO      SYSFILE                                              00047130
LRECL    ECHO      LRECL                                                00047140
BLKSIZE  ECHO      BLKSIZE                                              00047150
TXTLEN   ECHO      TXTLEN                                          UOM 
ATEOF    ECHO      EOF                                                  00047160
         DC        A(*+8,EEVQR)                                    UOM 
         DC        X'80'                                           UOM 
         DC        AL3(*+7)                                        UOM 
         DC        A(PRPEVQR)                                      UOM 
         DC        CL4'RES#',X'60',AL3(NIL)                        UOM 
PRPEVQR  DC        A(APVAL,PROPEVQR)                               UOM 
PROPEVQR DC        A(ER##,PROP2EVQ)                                UOM 
PROP2EVQ DC        A(SPECIAL,PROP3EVQ)                             UOM 
PROP3EVQ DC        A(ER##,NIL)                                     UOM 
ER##     DC        A(NIL,NIL)                                      UOM 
EEVQR    DS        0F 
         DC    A(*+8,SPECIAL-8)                                         00047170
         DC    XL1'80'                                                  00047180
         DC    AL3(*+7)                                                 00047190
         DC    A(PRPALIST)                                              00047200
         DC    CL4'ALIS',XL1'60',AL3(PRNTALIS)                          00047210
PRNTALIS DC    CL4'T',XL1'60',AL3(NIL)                               00047220
PRPALIST DC    A(APVAL,PROPALIS)                                        00047230
PROPALIS DC    A(ALIST,SPECPROP)                                        00047240
ALIST    DC    A(NIL,NIL)                                               00047250
SPECPROP DC    A(SPECIAL,PROPSPEC)                                      00047260
PROPSPEC DC    A(ALIST,NIL)                                             00047270
SPECIAL  ECHO  SPECIAL                                                  00047280
COMMON   ECHO  COMMON                                                   00047290
TRACE    ECHO      TRACE,SUBR,TRACEE,1                                  00047300
         ECHO      BLANK,APVAL,BLANK                                    00047310
         ECHO      PERIOD,APVAL,PERIOD                                  00047320
         ECHO      LPAR,APVAL,LPAR                                      00047330
         ECHO      PLUSS,APVAL,PLUSS                                    00047340
         ECHO      DOLLAR,APVAL,DOLLAR                                  00047350
         ECHO      STAR,APVAL,STAR                                      00047360
         ECHO      RPAR,APVAL,RPAR                                      00047370
         ECHO      DASH,APVAL,DASH                                      00047380
         ECHO      SLASH,APVAL,SLASH                                    00047390
         ECHO      COMMA,APVAL,COMMA                                    00047400
         ECHO      EQSIGN,APVAL,EQSIGN                                  00047410
         ECHO  REMFLAG,SUBR,REMFLAG,2                                   00047420
         ECHO  FLAGP,SUBR,FLAGP,2                                       00047430
         ECHO  FLAG,SUBR,FLAG,2                                         00047440
         ECHO      READCH,SUBR,READCH,1                                 00047450
         ECHO  MAPLIST,SUBR,MAPLIST,2                                   00047460
         ECHO  VERBOS,SUBR,VERBOS,1                                     00047470
         ECHO  LITP,SUBR,LITP,1                                         00047480
         ECHO  FLOAT,SUBR,FLOATIT,1                                     00047490
         ECHO  FIX,SUBR,FIXIT,1                                         00047500
         ECHO  DIGP,SUBR,DIGP,1                                         00047510
         ECHO  BREAKP,SUBR,BREAKP,1                                     00047520
         ECHO  PLANT,SUBR,PLANT,2                                       00047530
         ECHO  PLANT1,SUBR,PLANT1,2                                     00047540
         ECHO  PLANTDC,SUBR,PLANTDC,2                                   00047550
         ECHO  PLANTSQ,SUBR,PLANTSQ,2                                   00047560
         ECHO  EXPLODE,SUBR,EXPLODE,1                                   00047570
         ECHO      GENSYM1,SUBR,GENSYM,1                                00047580
         ECHO      CAAAR,SUBR,CAAAR,1                                   00047590
         ECHO      CDAAR,SUBR,CDAAR,1                                   00047600
         ECHO      CDDAR,SUBR,CDDAR,1                                   00047610
         ECHO      CDDDR,SUBR,CDDDR,1                                   00047620
         ECHO      CDADR,SUBR,CDADR,1                                   00047630
         ECHO  LAST,SUBR,LAST,1                                         00047640
         ECHO  RECLAIM,SUBR,RECLAIM                                     00047650
         ECHO  REMOB,SUBR,REMOB,1                                       00047660
         ECHO  RECIP,SUBR,RECIP,1                                       00047670
         ECHO  MAX,FSUBR,MAX                                            00047680
         ECHO  MIN,FSUBR,MIN                                            00047690
         ECHO  CSETQ,FSUBR,CSETQ,2                                      00047700
         ECHO      OPEN,SUBR,OPEN,3                                     00047710
         ECHO      CHKPOINT,SUBR,CHKPOINT,1                             00047720
         ECHO      RESTORE,SUBR,RESTORE,1                               00047730
         ECHO      CLOSE,SUBR,CLOSE,1                                   00047740
         ECHO  RDS,SUBR,RDSS,1                                          00047750
         ECHO  WRS,SUBR,WRS,1                                           00047760
         ECHO  INLL,SUBR,INLL,1                                         00047770
         ECHO  OTLL,SUBR,OTLL,1                                         00047780
         ECHO  LETP,SUBR,LETP,1                                         00047790
         ECHO  LENGTH,SUBR,LENGTH,1                                     00047800
         ECHO      ASA,SUBR,ASA,1                                       00047810
         PRINT GEN                                                      00047820
         ECHO      BPSZ,SUBR,BPSZ,0                                     00047830
         PRINT NOGEN                                                    00047840
         ECHO      MTS,SUBR,MTS                                    UOM 
         ECHO      BATCH,SUBR,BATCH                                UOM 
         ECHO      ATTN,SUBR,ATTN,1                                UOM 
         ECHO  OTLLNG,SUBR,OTLLNG,0 
         ECHO  ERRORSET,SUBR,ERRORSET,2 
         ECHO  EXITERR,SUBR,EXITERR,1                                   00047850
         ECHO      MAPCAR,SUBR,MAPCAR,2                                 00047860
         ECHO      RLIT,SUBR,RLIT,1                                     00047870
         ECHO      RNUMB,SUBR,RNUMB,1                                   00047880
         ECHO      MKATOM,SUBR,MKATOM                                   00047890
         ECHO  ORDERP,SUBR,ORDERP,2                                     00047900
         ECHO      PRBUFFER,SUBR,PRBUFFER,1                             00047910
         ECHO      EXPT,SUBR,EXPT,2                                     00047920
         ECHO  CAADR,SUBR,CAADR,1                                       00047930
         ECHO      EVCON,SUBR,EVCON,2                                   00047940
         ECHO      LEFTSHIFT,SUBR,LEFTSHIF,2                            00047950
         ECHO      DIFFERENCE,SUBR,DIFF,2                               00047960
         ECHO      REMAINDER,SUBR,REMAIND,2                             00047970
         ECHO      LOGOR,FSUBR,LOGOR                                    00047980
         ECHO      LOGAND,FSUBR,LOGAND                                  00047990
         ECHO      LOGXOR,FSUBR,LOGXOR                                  00048000
         ECHO      EVENP,SUBR,EVENP,1                                   00048010
         ECHO      XTAB,SUBR,XTAB,1                                     00048020
         ECHO      TTAB,SUBR,TTAB,1                                     00048030
         ECHO      QUOTIENT,SUBR,QUOTIENT,2                             00048040
         ECHO      NULL,SUBR,NULL,1                                     00048050
         ECHO      ADD1,SUBR,ADD1,1                                     00048060
         ECHO      SUB1,SUBR,SUB1,1                                     00048070
         ECHO      MINUS,SUBR,MINUS,1                                   00048080
         ECHO      PLUS,FSUBR,PLUS                                      00048090
         ECHO      TIMES,FSUBR,TIMES                                    00048100
         ECHO      APPEND,SUBR,APPEND,2                                 00048110
         ECHO      PROG,FSUBR,PROG                                      00048120
         ECHO      GO,FSUBR,GO,1                                        00048130
         ECHO      RETURN,SUBR,GORET,1                                  00048140
         ECHO      SET,SUBR,SET,2                                       00048150
         ECHO      CSET,SUBR,CSET,2                                     00048160
         ECHO      SETQ,FSUBR,SETQ,2                                    00048170
         ECHO      OBLIST,APVAL,OBJECT                                  00048180
         ECHO      CADR,SUBR,CADR,1                                     00048190
         ECHO      CDDR,SUBR,CDDR,1                                     00048200
         ECHO      CAAR,SUBR,CAAR,1                                     00048210
         ECHO      CDAR,SUBR,CDAR,1                                     00048220
         ECHO      CADDR,SUBR,CADDR,1                                   00048230
         ECHO      CADAR,SUBR,CADAR,1                                   00048240
         ECHO      PRINT,SUBR,PRINT,1                                   00048250
         ECHO      READ,SUBR,READ                                       00048260
         ECHO      GET,SUBR,GET,2                                       00048270
         ECHO      MEMBER,SUBR,MEMBER,2                                 00048280
         ECHO      EVLIS,SUBR,EVLIS,2                                   00048290
         ECHO      NCONC,SUBR,NCONC,2                                   00048300
         ECHO      PAIR,SUBR,PAIR,2                                     00048310
         ECHO      APPLY,SUBR,APPLY,3                                   00048320
         ECHO      APPEND1,SUBR,APPEND1,2                               00048330
         ECHO      UNTRACE,SUBR,UNTRACE,1                               00048340
         ECHO      AND,FSUBR,AND                                        00048350
         ECHO      OR,FSUBR,OR                                          00048360
         ECHO      MINUSP,SUBR,MINUSP,1                                 00048370
         ECHO      ZEROP,SUBR,ZEROP,1                                   00048380
         ECHO      LESSP,SUBR,LESSP,2                                   00048390
         ECHO      GREATERP,SUBR,GREATERP,2                             00048400
         ECHO      ERROR,SUBR,ERRORR,1                                  00048410
         ECHO      NOT,SUBR,NULL,1                                      00048420
         ECHO      FIXP,SUBR,FIXP,1                                     00048430
         ECHO      FLOATP,SUBR,FLOATP,1                                 00048440
         ECHO      LIST,FSUBR,EVLIS,2                                   00048450
         ECHO      LOGP,SUBR,LOGP,1                                     00048460
         ECHO      PRIN1,SUBR,PRIN1,1                                   00048470
         ECHO      TERPRI,SUBR,TERPRI,0                                 00048480
         ECHO      DEFLIST,SUBR,DEFLIST,2                               00048490
         ECHO      REMPROP,SUBR,REMPROP,2                               00048500
         ECHO      FUNCTION,FSUBR,FUNCTION,1                            00048510
         ECHO      ATTRIB,SUBR,ATTRIB,2                                 00048520
         ECHO      PROG2,SUBR,PROG2,2                                   00048530
         ECHO      NUMBERP,SUBR,NUMBERP,1                               00048540
         ECHO      RPLACA,SUBR,RPLACA,2                                 00048550
         ECHO      RPLACD,SUBR,RPLACD,2                                 00048560
         ECHO      EJECT,SUBR,EJECT                                     00048570
         ECHO      DEBUG,SUBR,DEBUG,1                                   00048580
         DC        A(*+16,NIL)         MARK END OF LIST                 00048590
         ECHO      SASSOC,SUBR,SASSOCC,3                                00048600
TOP1     DS        (STORESIZ)D                                          00048610
BPSST    DS    (BPSSIZE+1)F                                             00048620
         DS        CL80                BUFFER                      UOM 
         EJECT                                                     UOM 
*                                                                  UOM 
*        DSECT FOR A LISP DCB                                      UOM 
*                                                                  UOM 
         SPACE     1                                               UOM 
DCBDS    DSECT                                                     UOM 
BFR$     DS        A                   BUFFER LOC                  UOM 
LEN$     DS        A                   LENGTH LOC                  UOM 
MDF$     DS        A                   MODIFIERS LOC               UOM 
LIN$     DS        A                   LINE NUMBER LOC             UOM 
FDUB$    DS        A                   FDUB PTR LOC                UOM 
IORTN$   DS        A                   I/O ROUTINE                 UOM 
LRECL#   DS    H                  RECORD LENGTH 
LEN#     DS        H                   TEXT LENGTH                 UOM 
LIN#     DS        F                   LINE NUMBER                 UOM 
MOD#     DS        F                   MODIFIERS                   UOM 
FDUB#    DS        A                   FDUB PTR                    UOM 
EODAD#   DS        A                   EOD ADDRESS                 UOM 
INOUT#   DS        F                   I/O CODE                    UOM 
FDUB2#   DS        XL4                 FDUB PTR                    UOM 
GDIV#    DS        A                   GDINFO OUTPUT VECTOR        UOM 
BUFSIZ#  DS        F                   BUFFER SIZE                 UOM 
TXTLEN#  DS        F                   TEXT LENGTH                 UOM 
NXTCHR#  DS    F                  NEXT-CHARACTER ADRS 
LDCB     EQU       *-DCBDS             LENGTH OF A LISP DCB        UOM 
         END       MAIN                                                 00048630