Personal tools
You are here: Home Projects LISP Stanford LISP_360 lisp.mts_master.sa.1.html
Document Actions

lisp.mts_master.sa.1.html

by Paul McJones last modified 2017-02-18 04:07

Click here to get the file

Size 413.6 kB - File type text/html

File contents

<html>
<head>
<title>LISP/360 interpreter source code</title>
</head>
<body>
<pre>
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<ARG2 THEN FALSE                  00016010
         BR    2                                                        00016020
ORDERT   LA    A,T                TRUE RETURN                           00016030
         BR    2                                                        00016040
         EJECT                                                          00016050
*********************************************************************** 00016060
************   RLIT(CH) SUBR  NON RECURS  ***************************** 00016070
*********************************************************************** 00016080
RLIT     TM    ATOMIND,X'80'           ATOMIND SET                      00016090
         BO    RLIT1                   YES                              00016100
         MVC       CHARATA+4(16),ZERO                                   00016110
         MVC   CHARATA+20(ATMSZ-12),CHARATA+4 
         SR        0,0                                                  00016130
         STH   0,CHARATA                                                00016140
         NI    ATOMIND,X'00'                                            00016150
         OI    ATOMIND,X'82'                                            00016160
RLIT1    LA    1,CHARATA               SCANAREA                         00016170
STOLIT   IC    0,8(,A)                 PICK UP CHAR                     00016180
STOLITT  LH    15,0(1)                 CURRENT LENGTH OF ATOM           00016190
         CH    15,2(1)                 ATMAX                            00016200
         BL    RLIT2                   NO                               00016210
         OI    ERRIND,X'04'             ATOM IS TRUNCATED               00016220
         BR    2                                                        00016230
RLIT2    STC   0,4(1,15)               STORE CHAR                       00016240
         LA    0,1(,15)                INCREASE CHR COUNT               00016250
         STH   0,0(1)                                                   00016260
         BR    2                                                        00016270
*********************************************************************** 00016280
************  RNUMB(CH) SUBR  NON RECURS  ***************************** 00016290
*********************************************************************** 00016300
RNUMB    TM    ATOMIND,X'80'           ATOMIND SET                      00016310
         BO    RNUMB1                  YES                              00016320
         NI    ATOMIND,X'00'                                            00016330
         OI    ATOMIND,X'C0'           NO NITIALIZE                     00016340
         SR        0,0                                                  00016350
         MVC   DIGATA+4(16),CHZERO     INITIALIZATION                   00016360
         STH   0,DIGATA                                                 00016370
         STH   0,EXPA                                                   00016380
         ST    0,EXPA+4                                                 00016390
         STH       0,EXP                                                00016400
RNUMB1   CLI       8(A),C'0'                                            00016410
         BL        CKNUMB                                               00016420
         CLI       8(A),C'9'                                            00016430
         BH        RNUMBERR                                             00016440
         TM    ATOMIND,X'10'            EXPIND SET                      00016450
         BZ    RNUMB6                  NO                               00016460
         LA    1,EXPA                  YES SET POINTER                  00016470
         B     STOLIT                                                   00016480
RNUMB6   TM    ATOMIND,X'20'           FLOATIND SET                     00016490
         BZ    RNUMB7                  NO                               00016500
         LH    1,EXP                                                    00016510
         BCTR      1,0                                                  00016520
         STH   1,EXP                                                    00016530
RNUMB7   TM        ATOMIND,X'10'                                        00016540
         BZ        RNUMB9                                               00016550
         LA        1,EXPA                                               00016560
         B         STOLIT                                               00016570
RNUMB9   LA    1,DIGATA                                                 00016580
         B     STOLIT                                                   00016590
CKNUMB   CLI   8(A),C'+'               IS IT PLUS                       00016600
         BE    0(2)                    YES                              00016610
         CLI   8(A),C'-'               IS IT MINUS                      00016620
         BNE   RNUMB2                  NO                               00016630
         TM    ATOMIND,X'10'           YES WAS EXPIND SET               00016640
         BZ    RNUMB3                  NO                               00016650
         OI    ATOMIND,X'08'           YES SET NEGEXPONENT IND          00016660
         BR    2                                                        00016670
RNUMB3   OI    ATOMIND,X'04'           SET NEG NUMBER ON                00016680
         BR    2                                                        00016690
RNUMB2   CLI   8(A),C'.'               IS IT DOT                        00016700
         BNE   RNUMB4                  NO                               00016710
         OI    ATOMIND,X'20'           SET FLOATIND                     00016720
         BR    2                                                        00016730
RNUMB4   TM        ATOMIND,X'20'                                        00016740
         BO        RNUMB8                                               00016750
         CLI       8(A),C'A'                                            00016760
         BL        RNUMBERR                                             00016770
         CLI       8(A),C'F'                                            00016780
         BH        CKLOGX                                               00016790
         OI        ATOMIND,X'02'                                        00016800
         MVC       NUMBFLD(1),8(A)                                      00016810
         TR        NUMBFLD(1),TABL1-193                                 00016820
         LA        1,DIGATA                                             00016830
         SR        0,0                                                  00016840
         IC        0,NUMBFLD                                            00016850
         B         STOLITT                                              00016860
RNUMB8   CLI       8(A),C'E'                                            00016870
         BNE       CKLOGX                                               00016880
         OI        ATOMIND,X'10'                                        00016890
         BR        2                                                    00016900
CKLOGX   CLI       8(A),C'X'                                            00016910
         BNE       RNUMBERR                                             00016920
         OI        ATOMIND,X'12'                                        00016930
         BR        2                                                    00016940
RNUMBERR OI        ERRIND,X'01'                                         00016950
         NI        ATOMIND,X'00'                                        00016960
         BR        2                                                    00016970
*********************************************************************** 00016980
************  MKATOM()  SUBR  NON RECURS  ***************************** 00016990
*********************************************************************** 00017000
ATOMPOIN DC        F'0'                                                 00017010
MKATOM   ST        2,RESAV                                              00017020
         TM        ERRIND,X'01'                                         00017030
         BZ        TRNCERR                                              00017040
         PUTMSG    SYNTAXMS                                             00017050
T5       BC    0,STOP                                                   00017060
TRNCERR  TM    ERRIND,X'04'            WAS ATOM TRUNCATED               00017070
         BZ    MKATOM1                 NO                               00017080
         PUTMSG  TRUNCMSG              YES SAY SO                       00017090
T6       BC    0,STOP                                                   00017100
         NI        ERRIND,X'00'                                         00017110
MKATOM1  LA        2,MKATOM2                                            00017120
         ST        2,ATMSV2                                             00017130
         MVI       LINKS+3,CAR                                          00017140
         MVI       ATOMEQ+3,CAR                                         00017150
         LA        A,ATOMPOIN                                           00017160
         B         ALLATOM                                              00017170
MKATOM2  L         A,CAR(A)                                             00017180
         NI        ATOMIND,X'00'                                        00017190
         L         2,RESAV                                              00017200
         BR    2                                                        00017210
TRUNCMSG DC    AL2(30),C' *** R5-NAME OR NUMBER TOO LONG'               00017220
         DC        XL1'00'                                              00017230
SYNTAXMS DC    AL2(19),C' *** R1-SYNTAX ERROR'                          00017240
         EJECT                                                          00017250
*********************************************************************** 00017260
*******************   SET(X,Y)   NON REC   ***************************  00017270
*********************************************************************** 00017280
*        SETS X=Y ON ALIST                                              00017290
SETSV    DC       2F'0'                                                 00017300
SET      ST        2,SETSV                                              00017310
         ST        Q,SETSV+4                                            00017320
         LA        1,ERA5                                               00017330
         L         Q,ALIST                                              00017340
         BAL       2,SASSOC                                             00017350
         LM        1,2,SETSV                                            00017360
         ST        2,CDR(A)                                             00017370
         LR        A,2                                                  00017380
         BR        1                                                    00017390
ERA5     ERROR     ' ***A5-SET VARIABLE UNDEF'                          00017400
*********************************************************************** 00017410
*******************  SETQ(X,A)   REC   ******************************** 00017420
*********************************************************************** 00017430
SETQ     SAVE      2                                                    00017440
         LA        2,SET                                                00017450
SETC     SAVE      2                   COMMON FOR SETQ & CSETQ          00017460
         SAVE      A                   ARG LIST                         00017470
         SAVE      Q                   ALIST                            00017480
         L         A,CDR(A)                                             00017490
         L         A,CAR(A)                                             00017500
         BAL       2,EVAL                                               00017510
         UNSAVE    Q                                                    00017520
         ST        Q,ALIST                                              00017530
         LR        Q,A                                                  00017540
         UNSAVE    A                                                    00017550
         L         A,CAR(A)                                             00017560
         UNSAVE    1                                                    00017570
         UNSAVE    2                                                    00017580
         BR        1                                                    00017590
*********************************************************************** 00017600
*******************   CSET(OB,VAL)   NON REC  ************************  00017610
*********************************************************************** 00017620
*        PUT VAL AS AN APVAL ON PROPERTY LIST OF OB                     00017630
CSET     TM        CAR(A),ATOM         SHOULD BE ATOM                   00017640
         BZ        0(2)                ISNT                             00017650
         ST        2,PVARG                                              00017660
         STM       A,Q,GARBT                                            00017670
         LA        Q,APVAL                                              00017680
         BAL       2,FLAGP                                              00017690
         CR        A,NILR                                               00017700
         BE        CSET1                                                00017710
         L         A,CDR(A)                                             00017720
         L         A,CAR(A)                                             00017730
         L         Q,GARBT+4                                            00017740
         ST        Q,CAR(A)                                             00017750
         L         A,GARBT                                              00017760
         L         2,PVARG                                              00017770
         BR        2                                                    00017780
CSET1    LM        A,Q,GARBT                                            00017790
         L         1,PVARG                                              00017800
         LR        M,A                 HOLD A                           00017810
         LR        A,Q                                                  00017820
         LR        Q,NILR                                               00017830
         BAL       2,CONS                                               00017840
         L         Q,CDR(M)                                             00017850
         BAL       2,CONS                                               00017860
         LR        Q,A                                                  00017870
         LA        A,APVAL             SET IND                          00017880
         BAL       2,CONS                                               00017890
         ST        A,CDR(M)            LINK TO ATOM                     00017900
         L         A,GARBT                                              00017910
         BR        1                   EXIT                             00017920
CSETQ    SAVE      2                                                    00017930
         LA        2,CSET                                               00017940
         B         SETC                                                 00017950
         EJECT                                                          00017960
*********************************************************************** 00017970
********************   REMPROP(X,IND)   NON REC   ********************* 00017980
*********************************************************************** 00017990
*        SEARCH LIST X FOR INDICATOR IND, WHEN FOUND REMOVE IT AND      00018000
*        FOLLOWING PROPERTY FROM LIST                                   00018010
REMPROP  CR        A,NILR              NIL LIST                         00018020
         BE        REX                                                  00018030
         L         1,CDR(A)                                             00018040
         CR        1,NILR              NO INDICATORS                    00018050
         BE        REX                                                  00018060
         C         Q,CAR(1)            CHECK IND                        00018070
         BE        RFND                FOUND                            00018080
         L         A,CDR(1)            CONT SEARCH                      00018090
         B         REMPROP                                              00018100
RFND     L         1,CDR(1)            FOUND IND                        00018110
         CR        1,NILR              NO PROP                          00018120
         BE        REX                                                  00018130
         L         1,CDR(1)            EXISE IND & PROP                 00018140
         ST        1,CDR(A)                                             00018150
         B         REMPROP             TRY FOR MORE                     00018160
REX      LR        A,NILR                                               00018170
         BR        2                   EXIT                             00018180
         EJECT                                                          00018190
*********************************************************************** 00018200
*******************   DEFINE(X)  NON REC   **************************** 00018210
*********************************************************************** 00018220
DEFINE   LA        Q,EXPR                                               00018230
         B         DEFLIST                                              00018240
*********************************************************************** 00018250
*******************   DEFLIST(X,IND)   NON REC    ********************* 00018260
*********************************************************************** 00018270
DEFLIST  ST        2,PVARG                                              00018280
         LR        0,Q                                                  00018290
         ST        NILR,GARBT+4        DEFINE BEGINNING OF NEW LIST     00018300
DAGN     ST        A,GARBT                                              00018310
         L         A,CAR(A)            NEXT DEFINITION ON LIST          00018320
         L         14,CDR(A)           FIND NEW PROPERTY                00018330
         L         14,CAR(14)                                           00018340
         L         A,CAR(A)            FIND ATOM NAME                   00018350
         LR        15,A                AND PUT IT ASIDE                 00018360
         BAL       2,FLAGP             IS IND. ALREADY ON PROPERTYLIST  00018370
         CR        A,NILR                                               00018380
         BE        DAGN1               NO GO TO DAGN1                   00018390
         L         A,CDR(A)            YES INSERT NEW PROPERTY          00018400
         ST        14,CAR(A)                                            00018410
         B         DAGN2                                                00018420
DAGN1    L         Q,CDR(15)           SET UP PROPERTY ON PROPERTYLIST  00018430
         LR        A,14                                                 00018440
         BAL       2,CONS                                               00018450
         LR        Q,A                                                  00018460
         LR        A,0                                                  00018470
         BAL       2,CONS                                               00018480
         ST        A,CDR(15)           LINK INTO ATOM                   00018490
DAGN2    L         A,GARBT+4           CONSTRUCT LIST THAT IS           00018500
         LR        Q,15                 IS VALUE OF DEFLIST             00018510
         BAL       2,APPEND1                                            00018520
         ST        A,GARBT+4                                            00018530
         L         A,GARBT                                              00018540
         L         A,CDR(A)            REST OF LIST                     00018550
         CR        A,NILR              AT END OF LIST ?                 00018560
         BNE       DAGN                NO                               00018570
         L         A,GARBT+4                                            00018580
         L         2,PVARG                                              00018590
         BR        2                                                    00018600
         EJECT                                                          00018610
*********************************************************************** 00018620
*******************   ADD1 * SUB1 * MINUS   SUBR   ******************** 00018630
*********************************************************************** 00018640
ADD1     SR        M,M                 SET ADD SWITCH                   00018650
         B         ASM1                                                 00018660
SUB1     LR        M,K4                SET SUB1 SW                      00018670
         B         ASM1                                                 00018680
MINUS    LA        M,8                                                  00018690
ASM1     LR        14,2                HOLD 2                           00018700
         TM        CAR(A),FLOAT                                         00018710
         BO        ASMFL                                                00018720
         TM        CAR(A),FIX                                           00018730
         BO         ASMFX                                               00018740
ARITHER  ERROR      ' *** I3-BAD ARITH ARG'                             00018750
ASMFX    L         A,CAR(A)                                             00018760
          L        A,CAR(A)                                             00018770
          EX       0,ASMFXT(M)                                          00018780
MKFXAT   LR        Q,NILR                                               00018790
         BAL       2,CONS                                               00018800
         MVI       CDR(A),FWD                                           00018810
         BAL       2,CONS                                               00018820
         MVI       CAR(A),FIX           SET ATOM TYPE                   00018830
         BR        14                                                   00018840
ASMFXT   AH        A,=H'1'             ADD1                             00018850
         SH        A,=H'1'             SUB1                             00018860
         LCR       A,A                 -X                               00018870
ASMFL    L         A,CAR(A)                                             00018880
         LE        0,CAR(A)                                             00018890
         EX        0,ASMFLT(M)                                          00018900
MKFLAT   LR        Q,NILR              MAKE FLOAT ATOM                  00018910
         BAL       2,CONS                                               00018920
         STE       0,CAR(A)                                             00018930
         MVI       CDR(A),FWD                                           00018940
         BAL       2,CONS                                               00018950
         MVI       CAR(A),FLOAT                                         00018960
         BR        14                                                   00018970
ASMFLT   AE        0,=E'1.'            ADD1.                            00018980
         SE        0,=E'1.'            SUB1.                            00018990
         LCER      0,0                 -X                               00019000
DPA      DC        D'0'                                                 00019010
DPAA     DC        D'0'                                                 00019020
NZERO    DC        X'4E',7X'00'        NORMAL ZERO                      00019030
*********************************************************************** 00019040
*******************   PLUS * TIMES    FSUBR    ************************ 00019050
*********************************************************************** 00019060
PLUS     SR        M,M                 SET PLUS SW                      00019070
         B         PLTI                                                 00019080
TIMES    LR        M,K4                SET TIMES SW                     00019090
PLTI     SAVE      2                                                    00019100
         SAVE      M                                                    00019110
         BAL       2,EVLIS             EVAL ARGS                        00019120
         UNSAVE    M                                                    00019130
         SR         15,15              SET FIXPT SW                     00019140
         LR         1,M                                                 00019150
         SRA       1,2                 SET FOR MULT OR ADD              00019160
         LR        Q,A                                                  00019170
PTLOOP   CR        Q,NILR              END OF LIST                      00019180
         BE        PTDONE              YES                              00019190
          LM       A,Q,CAR(Q)                                           00019200
         LTR       15,15               TEST MODE                        00019210
         BNZ       PTFLOAT             FLOAT MODE                       00019220
         TM        CAR(A),FLOAT                                         00019230
         BO        PTFL                                                 00019240
         TM        CAR(A),FIX                                           00019250
         BNO       ARITHER             BAD NUMBER                       00019260
         L         A,CAR(A)                                             00019270
         EX        0,INTI(M)                                            00019280
         B         PTLOOP                                               00019290
INTI     A         1,CAR(A)                                             00019300
         M         0,CAR(A)                                             00019310
PTFL     BAL       2,FLOAT1                                             00019320
         LR        15,K4               SET FLOAT SW                     00019330
PTFFL    L         A,CAR(A)                                             00019340
         MVC       DPAA(4),CAR(A)      MOVE INTO DP AREA                00019350
         EX        0,FLTI(M)                                            00019360
         B         PTLOOP                                               00019370
FLTI     AD        0,DPAA                                               00019380
         MD        0,DPAA                                               00019390
PTFLOAT  TM        CAR(A),FLOAT                                         00019400
         BO    PTFFL              FLOAT MODE & FLOAT NO.                00019410
         TM    CAR(A),FIX                                               00019420
         BO        PTFINT              INTEGER ENCOUNTERED              00019430
         B         ARITHER                                              00019440
PTFINT   L         A,CAR(A)                                             00019450
         L          1,CAR(A)                                            00019460
         LDR       2,0                                                  00019470
         BAL   2,FLOAT1                                                 00019480
          EX       0,FLTII(M)                                           00019490
         B         PTLOOP                                               00019500
FLTII    ADR       0,2                                                  00019510
         NOPR      0                                                    00019520
         MDR       0,2                                                  00019530
PTDONE   UNSAVE    14                                                   00019540
         LTR       15,15                                                00019550
         BNZ       MKFLAT                                               00019560
         LR        A,1                                                  00019570
         B         MKFXAT                                               00019580
FLOAT1   MVI       DPA,X'4E'           SWITCH FIX REG1 TO FLOAT REG0    00019590
         LTR       1,1                                                  00019600
         BNM       *+10                                                 00019610
         LCR       1,1                                                  00019620
         MVI       DPA,X'CE'           NEG EXP                          00019630
         ST        1,DPA+4                                              00019640
         LD        0,DPA                                                00019650
         AD        0,ZERO                                               00019660
         BR        2                                                    00019670
*********************************************************************** 00019680
*******************   DIFFERENCE * QUOTIENT   SUBR   ****************** 00019690
*********************************************************************** 00019700
DIFF     SR        M,M                 SET DIFF SW                      00019710
         B         DIQ                                                  00019720
QUOTIENT LR        M,K4                SET QU SW                        00019730
DIQ      LR        14,2                HOLD 2 FOR MFXAT, MKFLAT         00019740
         BAL       2,GLIP                                               00019750
         B         MKFXAT              FIXED RESULT                     00019760
         B         MKFLAT              FLOAT                            00019770
GLIP     LR        15,2                COMPUTE DIFF OR QUOTIENT         00019780
         TM        CAR(A),FLOAT                                         00019790
         BO        XFLT                                                 00019800
         TM        CAR(A),FIX          X INTEGER                        00019810
         BNO       ARITHER             NO                               00019820
         TM        CAR(Q),FLOAT                                         00019830
         BO        XYM                                                  00019840
         TM        CAR(Q),FIX          X INT, TRY Y                     00019850
         BNO       ARITHER             NO                               00019860
         L         A,CAR(A)                                             00019870
         L         1,CAR(Q)                                             00019880
         L         A,CAR(A)                                             00019890
         SRDA      A,32                                                 00019900
         EX        0,DQB(M)                                             00019910
         LR        A,Q                                                  00019920
         BR        15                  FIX RET                          00019930
DQB      S         Q,CAR(1)                                             00019940
         D         A,CAR(1)                                             00019950
XFLT     TM        CAR(Q),FLOAT        Y FLOAT                          00019960
         BO        XYFLT                                                00019970
         TM        CAR(Q),FIX          X FLOAT, TRY Y                   00019980
         BNO       ARITHER             NO                               00019990
         LR        1,Q                 X FLOAT, Y INTEGER               00020000
         LR        Q,A                 SWITCH A&Q                       00020010
         LR        A,1                                                  00020020
         LA        M,8(,M)                                              00020030
         LA        2,DPAA                                               00020040
         B         MIXED                                                00020050
XYFLT    L         A,CAR(A)            X,Y FLOAT                        00020060
         L         Q,CAR(Q)                                             00020070
         LE        0,CAR(A)                                             00020080
         EX        0,DQT(M)                                             00020090
         B         4(15)               FLOAT RET                        00020100
DQT      SE        0,CAR(Q)                                             00020110
         DE        0,CAR(Q)                                             00020120
XYM      LA        2,DPA               X INT, Y FLOAT                   00020130
MIXED    L         A,CAR(A)                                             00020140
         L         Q,CAR(Q)                                             00020150
         L         1,CAR(A)                                             00020160
         SRL       M,1                                                  00020170
         L         1,CAR(A)                                             00020180
         BAL       2,FLOAT1                                             00020190
         LE        2,CAR(Q)                                             00020200
         EX        0,MTA(M)                                             00020210
         EX        0,MTA+8(M)                                           00020220
         B         4(15)               FLOAT RET                        00020230
MTA      SDR       0,2                                                  00020240
         DDR       0,2                                                  00020250
         SDR       2,0                                                  00020260
         DDR       2,0                                                  00020270
         NOPR      0                                                    00020280
         NOPR      0                                                    00020290
         LDR       0,2                                                  00020300
         LDR       0,2                                                  00020310
*********************************************************************** 00020320
*******************  REMAINDER(X Y)  ***  SUBR  **********************  00020330
*********************************************************************** 00020340
*        FIXPT  REM(X/Y)                                                00020350
*        FLOAT  X-INTEGER(X/Y)*Y                                        00020360
REMAIND  LR        14,2                                                 00020370
         TM        CAR(A),FIX                                           00020380
         BNO       ARITHER                                              00020390
         TM        CAR(Q),FIX                                           00020400
         BNO       ARITHER                                              00020410
         TM        CAR(A),FLOAT                                         00020420
         BO        REMXFL              X FLOAT                          00020430
         TM        CAR(Q),FLOAT                                         00020440
         BO        REMXY               X FIX, Y FLOAT                   00020450
         L         A,CAR(A)            COMPUTE MOD                      00020460
         L         Q,CAR(Q)                                             00020470
         L         0,CAR(A)                                             00020480
         SRDA      0,32                                                 00020490
         D         0,CAR(Q)                                             00020500
         LR    A,0                                                      00020510
         B         MKFXAT                                               00020520
REMXFL   TM        CAR(Q),FLOAT                                         00020530
         BO        REMXYF              X,Y FLOAT                        00020540
         L         Q,CAR(Q)            X FLOAT, Y FIX                   00020550
         L         1,CAR(Q)                                             00020560
         BAL       2,FLOAT1            FLOATED INTO FR0                 00020570
         LDR       F2,F0                                                00020580
         L         A,CAR(A)                                             00020590
         LE        F0,CAR(A)                                            00020600
         B         AMOD                                                 00020610
REMXY    L         A,CAR(A)            X FIX, Y FLOAT                   00020620
         L         1,CAR(A)                                             00020630
         BAL       2,FLOAT1            FLOAT INTO F0                    00020640
         L         Q,CAR(Q)                                             00020650
         LE        F2,CAR(Q)                                            00020660
         B         AMOD                                                 00020670
REMXYF   L         A,CAR(A)            X, Y FLOAT                       00020680
         LE        F0,CAR(A)                                            00020690
         L         Q,CAR(Q)                                             00020700
         LE        F2,CAR(Q)                                            00020710
AMOD     LER   F4,F0                                                    00020720
         DER   F0,F2                                                    00020730
         LD        F6,ZERO                                              00020740
         LER       F6,F0               EXPAND TO DP                     00020750
         LDR       F0,F6                                                00020760
         AW        F0,NZERO            INTEGERIZE IT                    00020770
         AD        F0,ZERO             NORMALIZE                        00020780
         MER       F0,F2                                                00020790
         SER   F4,F0                                                    00020800
         LER   F0,F4                                                    00020810
         B         MKFLAT                                               00020820
*********************************************************************** 00020830
*******************   ZEROP  ***   MINUSP   ***  SUBRS   **********     00020840
*******************************************************************     00020850
***         ZEROP(X) T IF X.EQ.0 OR ABS(X).GT. 1.E-6                    00020860
***         MINUSP(X)   T IF X.LT.0                                     00020870
ZEROP    LR        M,K4                                                 00020880
         B         ZMP                                                  00020890
MINUSP   SR        M,M                 SET MINUSP                       00020900
ZMP      TM        CAR(A),FLOAT                                         00020910
         BO        ZMFLT                                                00020920
         TM        CAR(A),FIX                                           00020930
         BNO       ARITHER                                              00020940
         L         A,CAR(A)                                             00020950
MFP      L         A,CAR(A)                                             00020960
         LTR       A,A                                                  00020970
         LR        A,NILR                                               00020980
         EX        0,ZMBR+6(M)                                          00020990
         LA        A,T                                                  00021000
         BR        2                                                    00021010
ZMFLT    L         A,CAR(A)                                             00021020
         LE        0,CAR(A)                                             00021030
         EX        0,ZMBR(M)           TEST SIGN                        00021040
         SE        0,FTOL                                               00021050
         LR        A,NILR                                               00021060
         BNM       0(2)                                                 00021070
         LA        A,T                                                  00021080
         BR        2                                                    00021090
ZMBR     B         MFP                                                  00021100
         LPER      0,0                                                  00021110
         BNM       0(2)                                                 00021120
         BNZ       0(2)                                                 00021130
*********************************************************************** 00021140
*******************   LESSP  ***  GREATERP  ***  SUBRS  ***********     00021150
*******************************************************************     00021160
****       LESSP(X,Y)   T IF X-Y.LT.0                                   00021170
****         GREATERP(X,Y)  T IF X-Y.GT.0                               00021180
LESSP    ST        2,ERSV                                               00021190
         SR        M,M                 DIFF SW                          00021200
         SR        14,14               LESSP SW                         00021210
         B         TKDIF               TAKE DIFFERENCE                  00021220
GREATERP ST        2,ERSV                                               00021230
         SR        M,M                                                  00021240
         LR        14,K4               SET GP SW                        00021250
TKDIF    BAL       2,GLIP                                               00021260
         B         GLFX                FIXED                            00021270
GLFL     LTER      0,0                                                  00021280
         L         2,ERSV                                               00021290
         LR        A,NILR                                               00021300
         EX        0,GLFC(14)                                           00021310
         LA        A,T                                                  00021320
         BR        2                                                    00021330
GLFX     LTR       A,A                                                  00021340
         B         GLFL+2                                               00021350
GLFC     BNM       0(2)                                                 00021360
         BNP       0(2)                                                 00021370
         EJECT                                                          00021380
*********************************************************************** 00021390
**********   EXPT ***************************************************** 00021400
*********************************************************************** 00021410
R4       EQU       15                                                   00021420
EXPT     STM       2,3,PVARG                                            00021430
         TM        0(Q),FLOAT                                           00021440
         BM        EXPT1                                                00021450
         ERROR     ' *** I8-EXPT CANNOT TAKE REAL EXPONENT'             00021460
EXPT1    TM        0(A),FLOAT                                           00021470
         BM        EXPT2                                                00021480
         LA        R14,EXPTEXT1                                         00021490
         SDR       F4,F4                                                00021500
         L         A,CAR(A)                                             00021510
         LE        F4,0(A)                                              00021520
         L         Q,CAR(Q)                                             00021530
         L         R4,0(Q)                                              00021540
         LD        F0,XEXPLIT                                           00021550
         MVI       XEXPSW1,X'2C'                                        00021560
         LTR       R4,R4                                                00021570
         BH        XEXP21                                               00021580
         BL        XEXP69                                               00021590
         LTER      F4,F4                                                00021600
         BCR       7,R14                                                00021610
         B         XERREX2                                              00021620
XEXP69   MVI       XEXPSW1,X'2D'                                        00021630
         LPR       R4,R4                                                00021640
         LTER      F4,F4                                                00021650
         BNZ       XEXP21                                               00021660
         B         XERREX3                                              00021670
XEXP11   MDR       F4,F4                                                00021680
XEXP21   EX        R4,XEXPTM                                            00021690
         BZ        XEXP31                                               00021700
XEXPSW1  MDR       F0,F4                                                00021710
XEXP31   SRA       R4,1                                                 00021720
         BH        XEXP11                                               00021730
         BR        14                                                   00021740
EXPT2    TM        0(A),FIX                                             00021750
         BM        ARITHER                                              00021760
         TM        0(Q),FIX                                             00021770
         BM        ARITHER                                              00021780
         LA        R14,EXPTEXT2                                         00021790
         L         A,CAR(A)                                             00021800
         L         R2,0(A)                                              00021810
         L         Q,CAR(Q)                                             00021820
         L         R4,0(Q)                                              00021830
         SRDA      R2,32                                                00021840
         LA        R1,1                                                 00021850
         SR        R0,R0                                                00021860
         MVI       XEXPSW+1,X'F0'                                       00021870
         LTR       R4,R4                                                00021880
         BH        XEXP2                                                00021890
         BL        XEXP6                                                00021900
         LTR       R3,R3                                                00021910
         BCR       7,R14                                                00021920
XERREX2  ERROR     ' *** I5-ATTEMPT TO RAISE 0 TO 0'                    00021930
XEXP6    MVI       XEXPSW+1,X'00'                                       00021940
         LPR       R4,R4                                                00021950
         LTR       R3,R3                                                00021960
         BNZ       XEXP2                                                00021970
XERREX3  ERROR     ' *** I6-ATTEMPT TO RAISE 0 TO NEGATIVE POWER'       00021980
XEXP1    MR        R2,R3                                                00021990
XEXP2    EX        R4,XEXPTM                                            00022000
         BZ        XEXP3                                                00022010
         MR        R0,R3                                                00022020
XEXP3    SRA       R4,1                                                 00022030
         BH        XEXP1                                                00022040
XEXPSW   BC        0,0(,R14)                                            00022050
         BAL       2,FLOAT1                                             00022060
         LE        F2,=E'1.'                                            00022070
         DER       F2,F0                                                00022080
         LER       F0,F2                                                00022090
EXPTEXT1 BAL       R14,MKFLAT                                           00022100
         B         EXPTEXIT                                             00022110
EXPTEXT2 LR        A,R1                                                 00022120
         BAL       R14,MKFXAT                                           00022130
EXPTEXIT LM        2,3,PVARG                                            00022140
         LA        K4,4                                                 00022150
         BR        2                                                    00022160
XEXPTM   TM        XTEST,X'00'                                          00022170
XTEST    DC        X'01'                                                00022180
         EJECT                                                          00022190
*********************************************************************** 00022200
*******************          ERROR       *****************************  00022210
**********************************************************************  00022220
ERRORR   SR        Q,Q                 PRINT A ONLY                     00022230
         ST    A,ERRARG           SAVE ERROR'S ARG. 
         CR    A,NILR             IS IT NIL? 
         BNE   ERRPRNT            NO -- PRINT 
         C     NILR,ERRSET        HAS ERRORSET BEEN CALLED? 
         BNE   ERDAN              YES -- NO PRINT. 
         C     NILR,ERRSET+4      CHECK THE 2ND ARG. 
         BE    ERDAN              NIL -- NO PRINT. 
ERRPRNT  DS    0H 
         PUTMSG    ' *** A1-CALL TO ERROR'                              00022240
         BAL       2,PRINT             PRINT ERROR'S ARGUMENT           00022250
         B     ERDAN                                                    00022260
ERRSET   DC    A(NIL,0)           ARGS TO ERRORSET 
ERRARG   DC    A(NIL)             ARG TO ERROR 
ERSV     DC        2F'0'                                                00022270
ERRORIND DC        2X'00'                                               00022280
ERROR    EQU       *                                                    00022290
         STM       13,1,WRSV                                            00022300
         ST    NILR,ERRARG        SET ARG TO NIL. 
         TM    ERRORIND,2         IS IT FATAL ERROR? 
         BO    *+12               YES -- PRINT. 
         C     NILR,ERRSET+4      IS 2ND ARG NIL? 
         BE    ERDAN              YES -- NO PRINT. 
         BAL       2,PUTMSG            PRINT THE ERROR                  00022310
         ST        Q,ERSV                                               00022320
         BAL       2,ERCK                                               00022330
         L         A,ERSV              PRINT Q LIST                     00022340
         BAL       2,ERCK                                               00022350
         TM        ERRORIND,X'01'                                       00022360
         BO        ERDN                NO PDS                           00022370
         PUTMSG    '0*** TRACE-BACK FOLLOWS'                            00022380
ERNXT    CL        PDS,PUSHA                                            00022390
         BE        ERDN                                                 00022400
         UNSAVE    A                                                    00022410
         BAL       2,ERCK                                               00022420
         B         ERNXT                                                00022430
ERDN     EQU       *                                                    00022440
         TM        ERRORIND,X'02'                                       00022450
T3       BO    STOP                                                     00022460
ERDAN    MVI       ERRORIND,X'00'      SET OFF                          00022470
T4       BC    0,STOP                                                   00022480
         DROP      3                                                    00022500
ERRPU    LA    3,BASE3 
         USING     BASE3,3                                              00022520
         LA        K4,4                                                 00022530
         MVC   LINE,BLANKS 
         L     PDS,ERRSET         RESTORE PDS. 
         L     A,ERRARG           GET RETURN VALUE. 
         CR    PDS,NILR           ERRORSET CALLED? 
         BNE   ERRRET             YES. 
         L     PDS,PUSHA          NO; RESET PDS. 
         B         AGN                                                  00022560
ERCK     LR    0,A 
         BAS   14,CKADDR 
         BZR   2 
         ST        2,ERSV+4                                             00022640
         MVI       LINE+1,C'*'                                          00022650
         BAL       2,PRINT                                              00022660
         L         2,ERSV+4                                             00022670
         BR        2                                                    00022680
ERRORSET L     M,ALIST 
         SAVE  M                  SAVE ALIST. 
         LM    0,1,ERRSET 
         SAVE  0                  SAVE OLD PDS. 
         SAVE  1                  SAVE OLD SWITCH. 
         SAVE  2                  SAVE RETURN. 
         ST    PDS,ERRSET         NEW PDS PTR. 
         ST    Q,ERRSET+4         NEW SWITCH. 
         LR    Q,M                ALIST. 
         BAL   2,EVAL             EVALUATE 1ST ARG. 
         LR    Q,NILR             MAKE IT A LIST. 
         BAL   2,CONS 
ERRRET   UNSAVE 2                 RETURN ADRS. 
         UNSAVE 1                 SWITCH. 
         UNSAVE 0                 PDS. 
         STM   0,1,ERRSET         RESTORE PDS AND SWITCH. 
         UNSAVE M                 ALIST. 
         ST    M,ALIST 
         BR    2                  RETURN 
         EJECT                                                          00022690
*********************************************************************** 00022700
************** TABLES USED IN READ AND PRINT, THEY HAD TO BE            00022710
*   MOVED BECAUSE THE SECTION COVERED BY BASEREGISTER 13 WAS FULL       00022720
*    WHILE MORE HAD TO BE ADDED TO THAT VERY SECTION                    00022730
GARBSW   DC    X'01'                   VERBOS SWITCH                    00022740
BUFFPR   DC        X'00'                                                00022750
NUMBFLD  DC        X'00'                                                00022760
EOFIND   DC    X'00'                                                    00022770
READCHID DC        X'00'                                                00022780
         CNOP      0,8                                                  00022790
DOUBLCST DC    XL8'4000000080000000'                                    00022800
DTRA     DC        X'401DA48CE468E7C7'   1                              00022810
         DC        X'404504787C5F878A'   2                              00022820
         DC        X'40A0B19D2AB70E6E'   3                              00022830
         DC        X'40256A18DD89E626'   4                              00022840
         DC        X'40571CBEC554B60D'   5                              00022850
         DC        X'40CAD2F7F5359A3B'   6                              00022860
         DC        X'402F394219248446'   7                              00022870
         DC        X'406DF37F675EF6EA'   8                              00022880
         DC        X'40FFFFFFFFFFFFFF'   9                              00022890
         DC        X'403B9AC9FFFFFFFE'  10                              00022900
         DC        X'408AC7230489E800'  11                              00022910
         DC        X'40204FCE5E3E2502'  12                              00022920
         DC        X'404B3B4CA85A86C4'  13                              00022930
         DC        X'40AF298D050E4395'  14                              00022940
         DC        X'4028C87CB5C89A25'  15                              00022950
         DC        X'405EF4A74721E864'  16                              00022960
DTRB     DC        X'40B877AA3236A4B4'  1                               00022970
         DC        X'40734ACA5F6226F0'  2                               00022980
         DC        X'40480EBE7B9D5856'  3                               00022990
         DC        X'402D09370D425736'  4                               00023000
         DC        X'401C25C268497681'  5                               00023010
         DC        X'40AFEBFF0BCB24AA'  6                               00023020
         DC        X'406DF37F675EF6EA'  7                               00023030
         DC        X'4044B82FA09B5A52'  8                               00023040
         DC        X'402AF31DC4611873'  9                               00023050
DTRBH    DC        H'-17,-16,-15,-14,-13,-11,-10,-9,-8'                 00023060
PCK1     PACK  CHARATA+4(8),EXPA+4(1)                                   00023070
PCK2     PACK  CHARATA+4(8),DIGATA+4(1)                                 00023080
PCK3     PACK      CHARATA+12(8),0(1,14)                                00023090
PCK      PACK      DIGATA+12(8),DIGATA+4(1)                             00023100
PCKK     PACK      DIGATA+12(8),EXPA+4(1)                               00023110
CTBL     DC        D'1.,.1,1.E-2,1.E-3,1.E-4,1.E-5,1.E-6,1.E-7,1.E-8'   00023120
         DC        D'1.E-9,1.E-10,1.E-11,1.E-12,1.E-13,1.E-14,1.E-15'   00023130
XEXPLIT  EQU       CTBL                                                 00023140
DTBL     DC        D'1.E64,1.E48,1.E32,1.E16,1.,1.E-16,1.E-32,1.E-48'   00023150
         DC        D'1.E-64'                                            00023160
ADBASE4  DC        A(BASE4)                                             00023170
CHKPCHK  DC    C'5313'            MDDY 
         DC    CL4'CHKP'                                                00023190
CHKREG   DC    2F'0'                                                    00023200
TABL1    DC        X'FAFBFCFDFEFF'     TRANSLATE TABLE FOR LOGINP       00023210
CHZERO   DC    16C'0'             CONSTANT USED IN FLOATINP             00023220
         CNOP      0,8                                                  00023230
ZERO     DC        4F'0'                                                00023240
PATCH    DS    10F                PATCH AREA 
         CNOP  4,8 
CHARATA  DC    H'0',Y(ATMSZ),CL(ATMSZ+4)' '  CHAR ATOM SCAN AREA 
CARDOUT  DC        80CL1' '                                             00023270
*********************************************************************** 00023280
*  ======  END OF BASE 12 SECTION  ==================================== 00023290
*  ==================================================================== 00023300
         EJECT                                                          00023310
*  ==================================================================== 00023320
*  ======  BEGINNING OF BASEREGISTER 3 SECTION. INSIDE THIS  ========== 00023330
*  ======      SECTION REGISTER 3 MAY NEVER BE USED.  ================= 00023340
*  ======      NO ROUTINES USING REGISTER 3 AS A WORK REGISTER  ======= 00023350
*  ======      MAY CALL ROUTINES INSIDE THIS SECTION.  ================ 00023360
*********************************************************************** 00023370
**********   REMFLAG(X,Y)   ******************************************* 00023380
*********************************************************************** 00023390
****   REMOVE ALL OCCURANCES OF FLAG Y FROM ATOMS ON LIST X             00023400
REMFLAG  CR    A,NILR                  NIL LIST OR FINISHED ?           00023410
BASE3    EQU   REMFLAG                                                  00023420
         BE    0(2)                    BRANCH IF YES                    00023430
         L     15,CDR(A)               15 MOVES THROUGH LIST            00023440
         L     M,CAR(A)                M MOVES THROUGH ATOM             00023450
REMFNXF  L     14,CDR(M)               POINT 14 TO NEXT ELEMENT         00023460
         CR    14,NILR                 AT END OF ATOM ?                 00023470
         BE    REMFNXE                 GET NEXT LIST ELEMENT IF YES     00023480
         L     14,CAR(14)              POINT 14 TO FLAG                 00023490
         CR    14,Q                    DOES FLAG = Q ?                  00023500
         BE    REMFND                  BRANCH IF YES                    00023510
         L     M,CDR(M)                MOVE M FORWARD IN ATOM           00023520
         B     REMFNXF                 GO BACK, LOOK AT NEXT FLAG       00023530
REMFND   L     14,CDR(M)               MOVE 14 TO POINT TO              00023540
         L     14,CDR(14)                 ELEMENT AFTER MATCH           00023550
         IC    1,4(M)                  *  = CALL RPLACD(M,14)        *  00023560
         ST    14,CDR(M)               *  I.E. REMOVE FLAG FROM      *  00023570
         STC   1,4(M)                  *  THE ATOM                   *  00023580
         B     REMFNXF                 GO BACK, LOOK AT NEXT FLAG       00023590
REMFNXE  LR    A,15                    MOVE TO NEXT LIST ELEMENT        00023600
         B     REMFLAG                 GO BACK AND START OVER           00023610
         EJECT                                                          00023620
*********************************************************************** 00023630
*******************  DEBUG(IND)   NON REC    *************************  00023640
**********************************************************************  00023650
*        IND IS T OR NIL FOR DEBUG OUTPUT                               00023660
DEBUG    MVI       DBIND,X'00'         SET OFF                          00023670
         CR        A,NILR                                               00023680
         BE        0(2)                                                 00023690
         OI        DBIND,X'01'         SET ON                           00023700
         BR        2                                                    00023710
*********************************************************************** 00023720
*******************         TRACE(X)   NON REC     ******************** 00023730
*********************************************************************** 00023740
TRACEE   MVI       TRACEIND,X'01'                                       00023750
TRACE1   L         Q,CAR(A)                                             00023760
         OI        0(Q),X'01'                                           00023770
         L         A,CDR(A)                                             00023780
         CR        A,NILR                                               00023790
         BNE       TRACE1                                               00023800
         BR        2                                                    00023810
*********************************************************************** 00023820
*******************       UNTRACE(X)   NON REC     ******************** 00023830
*********************************************************************** 00023840
UNTRACE  L         Q,CAR(A)                                             00023850
         NI        0(Q),X'FE'                                           00023860
         L         A,CDR(A)                                             00023870
         CR        A,NILR                                               00023880
         BNE       UNTRACE                                              00023890
         BR        2                                                    00023900
         EJECT                                                          00023910
*********************************************************************** 00023920
**********  MAX AND MIN  *********************************************  00023930
**********************************************************************  00023940
MAX      SR        M,M                                                  00023950
         B         MAXMNTR                                              00023960
MIN      LR        M,K4                                                 00023970
MAXMNTR  SAVE      2                                                    00023980
         SAVE      M                                                    00023990
         BAL       2,EVLIS                                              00024000
         UNSAVE    Q                                                    00024010
         L         15,CAR(A)                                            00024020
         TM    0(15),FIX          IS IT A NUMBER  ?                     00024030
         BNO   ARITHER            NP, ERROR                             00024040
         TM    0(15),FLOAT        IS IT FLOATING  ?                     00024050
         BNO   MAXFX              NO, DO FIXED ARITHEMETIC              00024060
         L     15,CAR(15)         YES,  GET ADDR. OF NO.                00024070
         LE    2,CAR(15)          PUT NO. IN FLT. PT. REG. 2            00024080
         B     MAXFLT             GO DO FLOAT ARITHMETIC                00024090
MAXFX    L     15,CAR(15)         PUT NO. IN REG. 15                    00024100
         L     15,CAR(15)                                               00024110
MAXAGN   L     A,CDR(A)           GET NEXT ELEMENT                      00024120
         CR    A,NILR             AT END OF LIST ?                      00024130
         BNE   MAXFXTS            NO, TEST NUMBER                       00024140
         LR    A,15               YES, PUT RESULT IN A                  00024150
         UNSAVE 14                RESTORE RETURN ADDR. TO 14            00024160
         B     MKFXAT             GO MAKE A FIXED PT. ATOM              00024170
MAXFXTS  L     M,CAR(A)           GET ELEMENT                           00024180
         TM    0(M),FIX           IS IT A NUMBER  ?                     00024190
         BNO   ARITHER            NO, ERROR                             00024200
         TM    0(M),FLOAT         IS IT FLOATING PT.  ?                 00024210
         BNO   MAXSTAY            NO, CONTINUE FIXED                    00024220
         LR    1,15               PUT CURRENT VALUE IN REG. 1           00024230
         BAL   2,FLOAT1           CONVERT TO FLOATING PT.               00024240
         LER   2,0                PUT IN FLT. PT. REG. 2                00024250
         L     M,CAR(M)                                                 00024260
         LE    0,CAR(M)           PUT NO. IN FLT. PT. REG. 0            00024270
         B     MAXSKIP1           GO INTO FLOAT PART                    00024280
MAXSTAY  L     M,CAR(M)           PUT NUMBER IN M                       00024290
         L     M,CAR(M)                                                 00024300
         CR    M,15               COMPARE                               00024310
         EX    0,MAXMIN1(Q)       BNL,BNH TO MAXAGN FOR MAX,MIN RESP.   00024320
         LR    15,M               CHANGE CURRENT VALUE                  00024330
         B     MAXAGN             GO TRY NEXT ELEMENT                   00024340
MAXFLT   L     A,CDR(A)           GET NEXT ELEMENT                      00024350
         CR    A,NILR             FINISHED  ?                           00024360
         BNE   MAXFSTAY           NO, CONTINUE                          00024370
         LER   0,2                YES, PUT RESULT IN FLT. PT. REG. 2    00024380
         UNSAVE 14                RESTORE RETURN ADDR. TO 14            00024390
         B     MKFLAT             GO MAKE A FLT. PT. ATOM               00024400
MAXFSTAY L     M,CAR(A)           GET ELEMENT                           00024410
         TM    0(M),FIX           IS IT A NUMBER  ?                     00024420
         BNO   ARITHER            NO, ERROR                             00024430
         TM    0(M),FLOAT         IS IT FLT. PT.  ?                     00024440
         BO    MAXFYES            YES, CONTINUE                         00024450
         L     1,CAR(M)           NO, CONVERT TO FLT. PT.               00024460
         L     1,CAR(1)                                                 00024470
         BAL   2,FLOAT1                                                 00024480
         B     MAXSKIP1                                                 00024490
MAXFYES  L     M,CAR(M)                                                 00024500
         LE    0,CAR(M)                                                 00024510
MAXSKIP1 CER   0,2                COMPARE                               00024520
         EX    0,MAXMIN2(Q)       BNL,BNH TO MAXFLT FOR MAX,MIN RESP.   00024530
         LER   2,0                CHANGE CURRENT VALUE                  00024540
         B     MAXFLT             GO BACK FOR MORE                      00024550
MAXMIN1  BNH   MAXAGN             - EXECUTED INSTRUCTIONS -             00024560
         BNL   MAXAGN                                                   00024570
MAXMIN2  BNH   MAXFLT                                                   00024580
         BNL   MAXFLT                                                   00024590
         EJECT                                                          00024600
*********************************************************************** 00024610
********** PLANT,PLANT1,PLANTDC *************************************** 00024620
*********************************************************************** 00024630
PLANT1   LR    0,NILR             SET INITIAL ENTRY FLAG                00024640
         B     PLANTT                                                   00024650
PLANTB   NOPR  1                  DUMMY                                 00024660
PLANTDC  LA    0,0                SET DC ENTRY FLAG                     00024670
         B     PLANTT                                                   00024680
PLANTSQ  SR    A,NILR                                                   00024690
         ST    A,PLANTCON+4                                             00024700
         LA    1,PLANTCON+4                                             00024710
         LA    0,0                                                      00024720
         L     M,0(Q)                                                   00024730
         L     M,0(M)                                                   00024740
         B     PLANTSK                                                  00024750
PLANT    LA    0,1                SET NORMAL ENTRY FLAG                 00024760
PLANTT   L     M,0(Q)             SAVE THE LENGTH IN M                  00024770
         L     M,0(M)                                                   00024780
         L     1,CAR(A)           SAVE INSTR.                           00024790
PLANTSK  ST    2,PVARG            SAVE RETURN ADDR.                     00024800
         LA    Q,APVAL            GET(BPS,APVAL)                        00024810
         LA    A,BPS                                                    00024820
         BAL   2,GET                                                    00024830
         L     A,CAR(A)                                                 00024840
         LM    14,15,0(A)         GET NEXT AND LAST AVAIL. BPS          00024850
         CR    14,15              OUT OF BPS ?                          00024860
         BNL   PLE1               YES, BRANCH                           00024870
         LTR   0,0                TEST DC FLAG                          00024880
         BNZ   PLANTI             NO, BRANCH                            00024890
         TM    3(A),X'03'         ON FULL WORD BOUNDARY ?               00024900
         BZ    PLANTI             YRS, BRANCH                           00024910
         MVC   0(2,14),PLANTB     INSERT NOPR IN BPS                    00024920
         LA    14,2(0,14)         UPDATE NEXT AVAIL.                    00024930
PLANTI   MVC   0(4,14),0(1)       STORE INST. IN BPS                    00024940
         CR    0,NILR             TEST INITIAL ENTRY FLAG               00024950
         BNE   PLANTN             NO, BRANCH                            00024960
         LA    15,4090(0,14)                                            00024970
         ST    15,PLANTCON        SAVE IT                               00024980
PLANTN   LA    14,0(M,14)         UPDATE NEXT AVAIL.                    00024990
         C     14,PLANTCON        END OF BASE COVERAGE  ?               00025000
         BH    PLE2               YES, BRANCH                           00025010
         ST    14,0(A)            STORE NEXT AVAIL.                     00025020
         L     2,PVARG            RESTORE 2                             00025030
         BR    2                  RETURN                                00025040
PLANTCON DC    2F'0'                                                    00025050
PLE1     ERROR ' *** L8-BPS FULL'                                       00025060
PLE2     ERROR ' *** L9-EXCEEDED MAX. LAP ROUTINE SIZE'                 00025070
         EJECT                                                          00025080
*********************************************************************** 00025090
*******************   ATOM(X)      NON REC    ************************  00025100
**********************************************************************  00025110
*        RETURN TRUE IF X IS AN ATOM                                    00025120
ATOMP    TM        CAR(A),ATOM         IS IT AN ATOM                    00025130
         B         LTST                                                 00025140
LOGP     TM        CAR(A),LOGIC        LOGICAL ATOM                     00025150
         B         LTST                                                 00025160
FLOATP   TM        CAR(A),FLOAT                                         00025170
         B         LTST                                                 00025180
*        RETURN TRUE IF X IS A NUMERIC ATOM                             00025190
NUMBERP  TM        CAR(A),FIX                                           00025200
LTST     LR        A,NILR              NO MAYBE                         00025210
         BNO       0(2)                DEFINITLY                        00025220
         LA        A,T                 IS AN ATOM                       00025230
         BR        2                                                    00025240
FIXP     LR        Q,A                                                  00025250
         LR        A,NILR              NO MAYBE                         00025260
         TM        CAR(Q),FIX          IS IT NUMERIC                    00025270
         BNO       0(2)                NO                               00025280
         TM        CAR(Q),X'30'        NOT FLOAT OR BOOL                00025290
         BM        0(2)                                                 00025300
         LA        A,T                 ITS FIX                          00025310
         BR        2                                                    00025320
EVENP    TM        CAR(A),FIX                                           00025330
         BNO       ARITHER                                              00025340
         TM        CAR(A),FLOAT                                         00025350
         BO        ARITHER                                              00025360
         L         A,CAR(A)                                             00025370
         TM    3(A),X'01'                                               00025380
         LR    A,NILR                                                   00025390
         BCR   1,2                                                      00025400
         LA    A,T                                                      00025410
         BR    2                                                        00025420
         EJECT                                                          00025430
*********************************************************************** 00025440
*******************    EQUAL(X,Y)   NON REC   ************************* 00025450
*********************************************************************** 00025460
*        RETURNS TRUE IF LIST X EQUALS LIST Y                           00025470
EQUAL    SAVE      2                   SAVE RET                         00025480
         LR        M,A                 USE Q, M                         00025490
         LA        A,T                 SET TRUE RET                     00025500
EQTST    CR        M,Q                 ALL ALPHA EQ                     00025510
         BE        RETURN              TRUE YET                         00025520
         TM        CAR(M),ATOM                                          00025530
         BO        TSTY                YES                              00025540
         TM        CAR(Q),ATOM                                          00025550
         BO        RETNIL                                               00025560
         LM        14,15,CAR(M)                                         00025570
         SAVE      15                                                   00025580
         LR        A,14                                                 00025590
         LM        14,15,CAR(Q)                                         00025600
         SAVE      15                                                   00025610
         LR        Q,14                                                 00025620
         BAL       2,EQUAL             RECURSIVE ENTRY                  00025630
         UNSAVE    Q                                                    00025640
         UNSAVE    M                                                    00025650
         CR        A,NILR                                               00025660
         BE        RETURN                                               00025670
         B         EQTST                                                00025680
RETNIL   LR        A,NILR                                               00025690
         B         RETURN                                               00025700
TSTY     TM        CAR(Q),FIX                                           00025710
         BNO       RETNIL                                               00025720
         TM        CAR(M),FIX                                           00025730
         BNO       RETNIL                                               00025740
*         X, Y ARE ATOMS, PROBABLY NUMERIC                              00025750
         LR        A,M                                                  00025760
         SR        M,M                 SET DIFF SW                      00025770
         BAL       2,GLIP                                               00025780
         B         EQFX                FIXED RESULT                     00025790
         LPER      0,0                                                  00025800
         SE        0,FTOL                                               00025810
         BNM       RETNIL                                               00025820
         LA        A,T                                                  00025830
         B         RETURN                                               00025840
EQFX     LTR       A,A                                                  00025850
         BNZ       RETNIL                                               00025860
         LA        A,T                                                  00025870
         B         RETURN                                               00025880
FTOL     DC        E'1.E-6'            TOLERANCE                        00025890
         EJECT                                                          00025900
*********************************************************************** 00025910
*******************  LOGOR * LOGAND * LOGXOR  ***  FSUBRS  *********    00025920
********************************************************************    00025930
LOGOR    SR        M,M                 SET SW                           00025940
         B         LOGS                                                 00025950
LOGAND   LR        M,K4                                                 00025960
         B         LOGS                                                 00025970
LOGXOR   LA        M,8                                                  00025980
LOGS     SAVE      2                                                    00025990
         SAVE      M                                                    00026000
         BAL       2,EVLIS                                              00026010
         UNSAVE    M                                                    00026020
         UNSAVE    14                                                   00026030
         LM        A,Q,CAR(A)                                           00026040
         L         A,CAR(A)                                             00026050
         L         1,CAR(A)                                             00026060
LOGLP    CR        Q,NILR                                               00026070
         BE        LEND                                                 00026080
         LM        A,Q,CAR(Q)                                           00026090
         L         A,CAR(A)                                             00026100
         EX        0,LGFN(M)                                            00026110
         B         LOGLP                                                00026120
LGFN     O         1,CAR(A)                                             00026130
         N         1,CAR(A)                                             00026140
         X         1,CAR(A)                                             00026150
LEND     LR        A,1                                                  00026160
MKLGAT   LR        Q,NILR                                               00026170
         BAL       2,CONS                                               00026180
         MVI       CDR(A),FWD                                           00026190
         BAL       2,CONS                                               00026200
         MVI       CAR(A),LOGIC                                         00026210
         BR        14                                                   00026220
*********************************************************************** 00026230
*******************   LEFTSHIFT(X,N) *****  SUBR  ******************    00026240
********************************************************************    00026250
LEFTSHIF LR        14,2                                                 00026260
         TM        CAR(Q),FIX                                           00026290
         BNO       ARITHER                                              00026300
         L         A,CAR(A)                                             00026310
         L         A,CAR(A)                                             00026320
         L         Q,CAR(Q)                                             00026330
         L         Q,CAR(Q)                                             00026340
         LTR       Q,Q                 NEG                              00026350
         BM        SHIFTRT                                              00026360
         SLL       A,0(Q)                                               00026370
         B         MKLGAT                                               00026380
SHIFTRT  LCR       Q,Q                                                  00026390
         SRL       A,0(Q)                                               00026400
         B         MKLGAT                                               00026410
         EJECT                                                          00026420
*********************************************************************** 00026430
*******************    AND  ***  OR    *    FSUBRS     ************     00026440
*******************************************************************     00026450
AND      SR        M,M                 SET -AND- SWITCH                 00026460
         B         ANDOR                                                00026470
OR       LR        M,K4                                                 00026480
ANDOR    SAVE      2                                                    00026490
ATST     CR        A,NILR              END OF LIST                      00026500
         BE        OREXIT(M)                                            00026510
         SAVE      Q                   ALIST                            00026520
         LM        0,1,CAR(A)                                           00026530
         SAVE      1                   REST OF LIST                     00026540
         SAVE      M                   THE SWITCH                       00026550
         LR        A,0                 FUNCTION                         00026560
         BAL       2,EVAL              EVALUATE IT                      00026570
         LR        0,A                 HOLD A                           00026580
         UNSAVE    M                   AND-OR SW                        00026590
         UNSAVE    A                   REST OF LIST                     00026600
         UNSAVE    Q                   ALIST                            00026610
         LR        1,NILR                                               00026620
         CR        0,1                                                  00026630
         BE        ANDORCNT(M)                                          00026640
         B         ANDORCNT+4(M)                                        00026650
ANDEXIT  LR        A,NILR                                               00026660
         B         ANDE                                                 00026670
OREXIT   LA        A,T                                                  00026680
ANDE     UNSAVE    2                                                    00026690
         BR        2                                                    00026700
ANDORCNT B         ANDEXIT                                              00026710
         B         ATST                                                 00026720
         B         OREXIT                                               00026730
*********************************************************************** 00026740
*******************    MEMBER(X,Y)    NON REC   **********************  00026750
**********************************************************************  00026760
*        TEST IF X IS A MEMBER OF LIST Y                                00026770
MEMBER   ST        2,PVARG                                              00026780
MEMM     STM       A,Q,GARBT                                            00026790
         CR        Q,NILR                                               00026800
         BNE       MEM                                                  00026810
         LR        A,NILR                                               00026820
MEMBEXIT L         2,PVARG                                              00026830
         BR        2                                                    00026840
MEM      L         Q,CAR(Q)                                             00026850
         BAL       2,EQUAL                                              00026860
         CR        A,NILR                                               00026870
         BNE       MEMBEXIT                                             00026880
         LM        A,Q,GARBT                                            00026890
         L         Q,CDR(Q)                                             00026900
         B         MEMM                                                 00026910
         EJECT                                                          00026920
*********************************************************************** 00026930
*********  MAPCAR  SUBR  ********************************************** 00026940
*********************************************************************** 00026950
MAPCAR   STC       K4,ALIST                                             00026960
         B         MAP                                                  00026970
*********************************************************************** 00026980
**********   MAPLIST     *********** RECURSIVE   ********************** 00026990
*********************************************************************** 00027000
****   MAPLIST(X FN)                                                    00027010
MAPLIST  SR        M,M                                                  00027020
         STC       M,ALIST                                              00027030
MAP      CR        A,NILR                                               00027040
         BCR       8,2                                                  00027050
         SAVE      2                   SAVE RETURNADDRESS               00027060
         ST        NILR,GARBT          NEW LIST                         00027070
         ST        Q,GARBT+4           SET ASIDE FN                     00027080
         L         M,ALIST                                              00027090
MAPNEXT  SAVE      A                   SAVE ARGUMENT TO FN              00027100
         ST        M,ARGS                                               00027110
         SAVE      M                   SAVE ALIST                       00027120
         SAVE      Q                   SAVE FUNCTION                    00027130
         LR        Q,NILR                                               00027140
         SRL       M,24                FIND EXECUTE INDEX               00027150
         EX        0,MAPINSTR(M)                                        00027160
         BAL       2,CONS              MAKE LIST OF FN'S ARGUMENTS      00027170
         LR        Q,A                                                  00027180
         L         A,GARBT             PICK UP NEW LIST                 00027190
         SAVE      A                   AND SAVE IT                      00027200
         L         A,GARBT+4           PICK UP FN                       00027210
         BAL       2,APPLY             APPLY FUNCTION TO ARGUMENT       00027220
         LR        Q,A                                                  00027230
         UNSAVE    A                                                    00027240
         BAL       2,APPEND1           INCREASE NEW LIST                00027250
         ST        A,GARBT                                              00027260
         UNSAVE    Q                                                    00027270
         ST        Q,GARBT+4                                            00027280
         UNSAVE    M                                                    00027290
         UNSAVE    A                                                    00027300
         L         A,CDR(A)            END OF ARGUMENTS ?               00027310
         CR        A,NILR                                               00027320
         BNE       MAPNEXT             NO                               00027330
         L         A,GARBT             YES PICK UP NEW LIST             00027340
         UNSAVE    2                                                    00027350
         BR        2                                                    00027360
MAPINSTR NOP       *                                                    00027370
         L         A,CAR(A)                                             00027380
         EJECT                                                          00027390
*********************************************************************** 00027400
**********  FLAG(X,Y)      ******************************************** 00027410
*********************************************************************** 00027420
****   INSERT FLAG Y ON ALL ATOMS OF LIST X                             00027430
FLAG     ST    2,PSV                   SAVE 2                           00027440
         LR    M,A                     M MOVES THROUGH LIST             00027450
FLAGBK   CR    A,NILR                  NIL LIST OR FINISHED ?           00027460
         BE    FLAGOUT                 YES, DONE                        00027470
         LR    A,Q                ARG.1  CONS - POINTS TO NEW  FLAG     00027480
         L     Q,CAR(M)      SAVE CAR(M) IN Q TO HELP COMPLETE LINKING  00027490
         L     M,CDR(M)                MOVE M FORWARD                   00027500
         STM   A,M,GARBT               SAVE  A (=OLD Q) , Q , M         00027510
         L     Q,CDR(Q)           ARG.2  CONS - POINTS TO NEXT FLAG     00027520
         BAL   2,CONS                  CALL CONS                        00027530
         LM    Q,M,GARBT+4               RESTORE Q , M                  00027540
         ST    A,CDR(Q)                COMPLETES LINKING IN NEW FLAG    00027550
         L     Q,GARBT                 RESTORE ORIGINAL Q               00027560
         LR    A,M                     PUT POINTER IN A                 00027570
         B     FLAGBK                  GO TRY NEXT ELEMENT              00027580
FLAGOUT  L     2,PSV                   RESTORE 2                        00027590
         BR    2                                                        00027600
         EJECT                                                          00027610
*********************************************************************** 00027620
**********   FLAGP(X,Y)    ******************************************** 00027630
*********************************************************************** 00027640
****   IF FLAG Y ON ATOM X RETURN TRUE ELSE RETURN NIL                  00027650
FLAGP    L     A,CDR(A)                MOVE FORWARD IN ATOM             00027660
         CR    A,NILR                  ANY FLAGS ?                      00027670
         BE    0(2)                    NO, THEN RETURN NIL              00027680
         L     M,CAR(A)                PICK UP FLAG                     00027690
         CR    M,Q                     FLAGS EQUAL ?                    00027700
         BNE   FLAGP                   NO, THEN GET NEXT FLAG           00027710
         BR    2                       DONE                             00027720
*********************************************************************** 00027730
*********   DIGP   SUBR  NON RECURS  ********************************** 00027740
*********************************************************************** 00027750
*   DIGP DECIDES WHETHER A CHARACTEROBJECT IS DIGIT OR NOT              00027760
DIGP     LR    Q,A                                                      00027770
         LR    A,NILR                                                   00027780
         CLI   8(Q),C'0'               WITHIN RANGE                     00027790
         BL    0(2)          NO                                         00027800
         CLI   8(Q),C'9'                                                00027810
         BH    0(2)          NO                                         00027820
         LA    A,T           YES                                        00027830
         BR    2                                                        00027840
*********************************************************************** 00027850
**********   LITP  SUBR  NON RECURS *********************************** 00027860
*********************************************************************** 00027870
*         LITP(CH)= NOT(OR(BREAKP(CH),DIGP(CH)))                        00027880
LITP     ST    2,PVARG+4                                                00027890
         ST    A,PVARG                                                  00027900
         BAL   2,BREAKP                                                 00027910
         CR    A,NILR                                                   00027920
         BE    LITP1                   CHAR WAS BREAKCHAR               00027930
LITPF    LR    A,NILR                                                   00027940
LITPEXIT L     2,PVARG+4                                                00027950
         BR    2                                                        00027960
LITP1    L     A,PVARG                                                  00027970
         BAL   2,DIGP                                                   00027980
         CR    A,NILR                                                   00027990
         BNE   LITPF         CHAR WAS A DIGIT                           00028000
         LA    A,T                                                      00028010
         B     LITPEXIT                                                 00028020
*********************************************************************** 00028030
*********   BREAKP  SUBR  NON RECURS ********************************** 00028040
*********************************************************************** 00028050
*    BREAKP DECIDES WHETHER CHARACTEROBJECT IS BREAKP                   00028060
BREAKP   LR    Q,A                                                      00028070
         LA    A,T                                                      00028080
         TM        8(Q),X'C0'                                      UOM 
         BO    BREAKPF                                                  00028100
         CLI   8(Q),C' '                                                00028110
         BCR       8,2                                                  00028120
         CLI   8(Q),C'('                                                00028130
         BCR       8,2                                                  00028140
         CLI   8(Q),C')'                                                00028150
         BCR       8,2                                                  00028160
         CLI   8(Q),C','                                                00028170
         BCR       8,2                                                  00028180
         CLI   8(Q),C'.'                                                00028190
         BCR       8,2                                                  00028200
BREAKPF  LR    A,NILR                                                   00028210
         BR    2                                                        00028220
*********************************************************************** 00028230
**********   LAST  **************************************************** 00028240
*********************************************************************** 00028250
LAST     L     Q,CDR(A)           CHECK CDR                             00028260
         CR    Q,NILR             IS IT NIL ?                           00028270
         BE    0(2)               YES, RETURN CELL                      00028280
         LR    A,Q                NO, MOVE TO NEW CELL                  00028290
         B     LAST               BRANCH BACK                           00028300
*********************************************************************** 00028310
**********   RECLAIM  ************************************************* 00028320
*********************************************************************** 00028330
RESAV    DC    F'0'                                                     00028340
RECLAIM  LA        FREE,1         SET FREE TO 1 TO CAUSE GARB. COL.     00028350
         LR    A,NILR             SET FOR A DUMMY CALL TO CONS          00028360
         LR    Q,NILR                                                   00028370
         ST    2,RESAV                                                  00028380
         BAL   2,CONS                                                   00028390
         LR    A,NILR                                                   00028400
         L     2,RESAV                                                  00028410
         BR    2                                                        00028420
*********************************************************************** 00028430
**********   REMOB  *************************************************** 00028440
*********************************************************************** 00028450
REMOB    L     M,OBJECTA          PUT OBLIST ADDR. IN M                 00028460
REMOBAK  LR    Q,M                NOW M INTO Q                          00028470
         L     M,CDR(Q)           MOVE M FORWARD                        00028480
         C     A,CAR(M)           TEST IF OB EQUALS ARG                 00028490
         BE    REMOEQ             YES, GO REMOVE IT                     00028500
         C         NILR,CDR(M)    ARE WE DONE                           00028510
         BNE   REMOBAK            NO, GO BACK FOR NEXT OB               00028520
         LR    A,NILR             YES, RETURN NIL                       00028530
         BR    2                  RETURN                                00028540
REMOEQ   L     M,CDR(M)           NO, DELETE OBJECT                     00028550
         ST    M,CDR(Q)                                                 00028560
         C     K4,HASHTBL         IS THERE A HASH TABLE? 
         BH    REMO2              NO 
         L     A,CAR(0,A)         REMOVE THIS ATOM FROM IT 
         LH    M,0(0,A)           GET HASH CODE 
         AH    M,2(0,A) 
         MH    M,=X'7A3C' 
         N     M,=X'00003FE0' 
         A     M,HASHTBL 
         SR    Q,Q 
         ST    Q,0(0,M) 
REMO2    DS    0H 
         LR    A,NILR             RETURN NIL                            00028570
         BR    2                  RETURN                                00028580
**********************************************************************  00028590
*********  RECIP  ****  1.0/X  **************************************** 00028600
*********************************************************************** 00028610
RECIP    TM    0(A),FIX           IS IT A NUMBER                        00028620
         BNO   ARITHER            NO, CALL ERROR                        00028630
         TM    0(A),FLOAT         IS IT FLOATING POINT                  00028640
         BO    RECIPOK            YES, CONTINUE                         00028650
         LA    A,ZEERO            RETURN ZERO AS RESULT                 00028660
         BR    2                                                        00028670
RECIPOK  L     A,CAR(A)           GET ADDR. OF NO.                      00028680
         LE    2,CAR(A)           PUT NO. IN FLT. PT. REG. 2            00028690
         LE    0,=E'1.'           PUT 1.0 IN FLT. PT. REG. 0            00028700
         DER   0,2                COMPUTE 1/X                           00028710
         LR    14,2                                                     00028720
         B     MKFLAT             MAKE AN ATOM OF THE RESULT            00028730
         EJECT                                                          00028740
*********************************************************************** 00028750
*********   BPSZ   **************************************************** 00028760
*********************************************************************** 00028770
BPSZ     L     A,BPSSTART+4                                             00028780
         SR    A,K4                                                     00028790
         SRL   A,3                                                      00028800
         SLL   A,3                                                      00028810
         ST    A,BOTTOM                                                 00028820
         LA    Q,1                                                      00028830
         ST    Q,4(A)                                                   00028840
         LA    A,8(0,A)                                                 00028850
         ST    A,BPSSTART                                               00028860
         ST    A,BPSSTART+4                                             00028870
         LR    A,NILR                                                   00028880
         BR    2                                                        00028890
*********************************************************************** 00028900
*********   RDS  READSELECT  ****************************************** 00028910
*********************************************************************** 00028920
RDSS     ST        2,RESAV                                              00028930
         LR    M,A                                                      00028940
         L     1,INDCBADR         GET CURRENT INPUT DCB. 
         LTR   1,1                IS THERE ONE? 
         BZ    RDS1               NO -- SKIP. 
         USING DCBDS,1 
         L     0,LASTCHAR         YES; SAVE CHAR PTR. 
         ST    0,NXTCHR# 
RDS1     LA    0,LISPIN           GET LISPIN ATOM. 
         CR A,0                                                         00028960
         BNE   RDS2                                                     00028970
         LA        1,CARDIN                                        UOM 
         B         RDSEND                                               00029020
RDS2     LA    Q,APVAL                 ADR=CAAR(GET(DDNAME APVAL)'      00029030
         BAL   2,GET                                                    00029040
         CR    A,NILR             IF FILE NOT OPENED - ERROR            00029050
         BE    RDSERR                                                   00029060
         L     A,CAR(A)                                                 00029070
         L     1,CAR(,A) 
RDSEND   LR    A,M 
         ST    1,INDCBADR 
         L         0,TXTLEN#           SET INNL                    UOM 
         ST        0,CARDLNTH                                      UOM 
         AL    0,BFR$             SET CARDEND. 
         ST    0,CARDEND 
         L     0,NXTCHR#          SET CHAR. PTR. 
         ST    0,LASTCHAR         (MAY BE ZERO) 
         DROP      1                                               UOM 
         MVI   EOFIND,0           CLEAR EOF FLAG. 
         L         2,RESAV                                              00029140
         BR        2                                                    00029150
RDSERR   LR    A,M                                                      00029160
         SR        Q,Q                                                  00029170
         ERROR ' *** D3-RDS FILE NOT OPENED'                            00029180
*********************************************************************** 00029190
*********  WRS  WRITESELECT  ****************************************** 00029200
*********************************************************************** 00029210
WRS      LA    0,LISPOUT          IS IT LISPOUT                         00029220
         CR    A,0                                                      00029230
         BNE   WRS2                                                     00029240
         LA    0,PRINTCB          YES                                   00029250
         ST    0,OTDCBADR        CHANGE DCB                             00029260
         LA        14,MSGBUFFR                                          00029270
         ST        14,MARGIN2                                           00029280
         LA        14,LINE                                              00029290
         ST        14,MARGIN1                                           00029300
         LA    14,20              FOR MARGIN1. 
         B         CINDY                                           UOM 
WRS2     LA    0,LISPUNCH         IS IT LISPUNCH                        00029360
         CR    A,0                                                      00029370
         BNE   WRS3                                                     00029380
         L     0,PUNCHOPN         IS IT OPEN ?                          00029390
         LTR       0,0                                                  00029400
         BNZ   WRS2A                                                    00029410
         ST    2,WRSAVE                NO THEN OPEN IT                  00029420
         L         14,ADOPEN                                            00029430
         BALR      2,14                                                 00029440
         L         2,WRSAVE                                             00029450
         L         0,PUNCHOPN                                           00029460
WRS2A    ST        0,OTDCBADR                                           00029470
         LA        14,SNPA                                              00029480
         ST        14,MARGIN2                                           00029490
         LA        14,LINE+5                                            00029500
         ST    14,MARGIN1 
         LA    14,1 
         B         CINDY                                           UOM 
WRS3     LR    1,2                INDCBADR=CAAR(GET(DDNAME APVAL))      00029570
         LR    M,A                                                      00029580
         LA    Q,APVAL                                                  00029590
         BAL   2,GET                                                    00029600
         CR    A,NILR             IF FILE NOT OPENED - ERROR            00029610
         BE    WRSERR                                                   00029620
         L     A,CAR(A)                                                 00029630
         L         0,CAR(A)                                        UOM 
         ST        0,OTDCBADR                                      UOM 
         LR        A,M                                             UOM 
         LR        2,1                                             UOM 
         LA    14,20 
CINDY    LR        1,0                 DCB ADDRESS                 UOM 
         USING     DCBDS,1                                         UOM 
         L         0,TXTLEN#           INPUT TEXT LENGTH           UOM 
         A         0,MARGIN1                                       UOM 
         ST        0,SUPMAX                                        UOM 
         SR    0,14 
         ST        0,LINEMAX                                       UOM 
         BR        2                                               UOM 
         DROP      1                                               UOM 
WRSERR   LR    A,M                                                      00029680
        SR        Q,Q                                                   00029690
         ERROR ' *** D4-WRS FILE NOT OPENED'                            00029700
WRSAVE   DC    F'0'                                                     00029710
ADOPEN   DC        A(OPEN)                                              00029720
         EJECT                                                          00029730
*********************************************************************** 00029740
*********  INLL  INLINELENGTH  **************************************** 00029750
*********************************************************************** 00029760
INLL     L     A,CAR(A)                                                 00029770
         L         A,CAR(A)                                             00029780
         ST        A,CARDLNTH                                           00029790
         LR    A,NILR                                                   00029800
         BR    2                                                        00029810
*********************************************************************** 00029820
*********  OTLL  OUTLINELENGTH  *************************************** 00029830
*********************************************************************** 00029840
OTLL     L     A,CAR(A)                                                 00029850
         L     A,CAR(A)                                                 00029860
         A         A,MARGIN1                                            00029870
         ST        A,SUPMAX                                             00029880
         BCTR      A,0                                                  00029890
         ST        A,LINEMAX                                            00029900
         LR    A,NILR                                                   00029910
         BR    2                                                        00029920
*********************************************************************** 
*********  OTLLNG   GET CURRENT OUTLINE LENGTH   ********************** 
*********************************************************************** 
OTLLNG   LR    14,2 
         L     A,SUPMAX 
         S     A,MARGIN1 
         B     MKFXAT             MAKE IT A FIXED ATOM. 
*********************************************************************** 00029930
*********  LETP  ****************************************************** 00029940
*********************************************************************** 00029950
LETP     CLI   8(A),C'A'                                                00029960
         BL    LETPF                                                    00029970
         CLI   8(A),C'Z'                                                00029980
         BH        LETPF                                                00029990
         LA    A,T                                                      00030000
         BR    2                                                        00030010
LETPF    LR    A,NILR                                                   00030020
         BR    2                                                        00030030
*********************************************************************** 00030040
*********  LENGTH  **************************************************** 00030050
*********************************************************************** 00030060
LENGTH   LR    Q,A                                                      00030070
         LR        14,2                                                 00030080
         LA    A,0                                                      00030090
LENG2    CR    Q,NILR                                                   00030100
         BE        MKFXAT                                               00030110
         LA    A,1(0,A)                                                 00030120
         L     Q,CDR(Q)                                                 00030130
         B     LENG2                                                    00030140
*********************************************************************** 00030150
*********  EOF IS REACHED ON AN END OF FILE  FROM A USER DATA FILE  *** 00030160
*********  IN WHICH CASE  WE GO BACK TO READ FROM LISPIN  ************* 00030170
*********  IF EOF IS REACHED WHILE IN READCH, THE ATOM EOF IS GIVEN *** 00030180
*********    AS VALUE OF READCH  ************************************** 00030190
         DROP      3                                                    00030200
EOF      LA        3,BASE3                                              00030210
         USING     BASE3,3                                              00030220
         MVI   EOFIND,X'FF'       SET END OF FILE FLAG FOR READCH 
         CLI   READCHID,X'01'     IS IT READCH? 
         BNE   EOF1               NO 
         SR    CHAR,CHAR          CLEAR CHAR PTR 
         B     READCH3 
EOF1     TM        ERRIND,X'10'                                         00030280
         BZ    OKEOF1                                                   00030290
         L     A,EVLSV                                                  00030300
         L     A,CAR(A)                                                 00030310
         PUTMSG    ' *** R3-BAD BRACKET COUNT ON USER FILE'             00030320
T7       BC    0,STOP                                                   00030330
         BAL   2,PRINT                                                  00030340
OKEOF1   LA    A,LISPIN                                                 00030350
         BAL   2,RDSS                                                   00030360
         B     AGN                                                      00030370
*********************************************************************** 00030380
*********  ASA  NON  RECURS  ****************************************** 00030390
*********  ASA  OMITS THE CONTROLCHARACTER IN THE OUTPUTBUFFER  ******* 00030400
*********************************************************************** 00030410
ASA      CR    A,NILR                                                   00030420
         LA    1,5                ROBERT I. BERNS                       00030430
         BE    ASAF                                                     00030440
         LA    Q,LINE                                                   00030450
         ST    Q,MARGIN1          ROBERT I BERNS                        00030460
         LA    Q,MSGBUFFR                                               00030470
         ST    Q,MARGIN2                                                00030480
         L     Q,LINEMAX                                                00030490
         SR    Q,1                ROBERT I BERNS                        00030500
         ST    Q,LINEMAX                                                00030510
         L     Q,SUPMAX                                                 00030520
         SR    Q,1                                                      00030530
         ST    Q,SUPMAX           ROBERT I BERNS                        00030540
         BR    2                                                        00030550
ASAF     LA    Q,LINE+5                                                 00030560
         ST    Q,MARGIN1                                                00030570
         LA    Q,SNPA                                                   00030580
         ST    Q,MARGIN2                                                00030590
         L     Q,LINEMAX          AND LEAST YOU FORGET ...              00030600
         AR    Q,1                                                      00030610
         ST    Q,LINEMAX                                                00030620
         L     Q,SUPMAX                                                 00030630
         AR    Q,1                                                      00030640
         ST    Q,SUPMAX           ROBERT I BERNS                        00030650
         BR    2                  (JUST SO YOU REMEMBER)                00030660
*********************************************************************** 00030670
*********  CHKPOINT  ************************************************** 00030680
*********************************************************************** 00030690
CHKPOINT ST        2,PUNCHOPN+8                                         00030700
         ST        A,PUNCHOPN+4                                         00030710
         L     2,STORBLKS         CHECK FOR DYNAMIC CELL STORAGE. 
         LTR   2,2                DO WE HAVE ANY ? 
         BNZ   ERRA2              YES --> 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
</pre>
</body>
</html>
« May 2024 »
Su Mo Tu We Th Fr Sa
1 2 3 4
5 6 7 8 9 10 11
12 13 14 15 16 17 18
19 20 21 22 23 24 25
26 27 28 29 30 31
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: