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