Forgot your password?
Document Actions
lisp.mts_master.sa.1.html
Click here to get the file
File contents
<html>
<head>
<title>LISP/360 interpreter source code</title>
</head>
<body>
<pre>
LISP TITLE 'LISP360' UOM
****** 00000010
MACRO 00000020
&NAME ERROR &MSG 00000030
LCLA &L 00000040
&L SETA K'&MSG
LISPMSG CSECT
MSG&SYSNDX DC Y(&L-3),C&MSG
&SYSECT CSECT
&NAME LA 14,MSG&SYSNDX-LISPMSG
B ERROR
MEND 00000090
****** 00000100
MACRO 00000110
&NAME SNAPS &IDENT,&FROM,&TO 00000120
CNOP 0,4 00000130
&NAME STM 13,3,SNPPSER 00000140
BAL 14,SNAPROUT 00000150
DC CL8'&IDENT',A(&FROM,&TO),PL2'0' 00000160
LM 13,3,SNPPSER 00000170
MEND 00000180
****** 00000190
MACRO 00000200
&NAME PUTMSG &DATA 00000210
LCLA &L 00000220
&NAME STM 13,1,WRSV 00000230
AIF (T'&DATA EQ 'U').A 00000240
LA 14,&DATA 00000250
BAL 2,PUTMSG 00000260
MEXIT 00000270
.A ANOP
&L SETA K'&DATA
LISPMSG CSECT
MSG&SYSNDX DC Y(&L-3),C&DATA
&SYSECT CSECT
LA 14,MSG&SYSNDX-LISPMSG
BAL 2,PUTMSG
MEND 00000330
****** 00000340
MACRO 00000350
&LABEL ECHO &NAME,&PROP,&RTN,&ACNT 00000360
LCLA &LNGTH,&K,&KK,&ARGS 00000370
LCLC &P,&PP,&N,&NN,&PPP,&NNN 00000380
&ARGS SETA 0 00000390
&LNGTH SETA K'&NAME 00000400
&K SETA 20 00000410
&KK SETA 12 00000420
&P SETC 'NIL' 00000430
&PP SETC 'NIL' 00000440
&PPP SETC 'NIL' 00000450
&N SETC '&NAME'(1,4).' ' 00000460
AIF (&LNGTH LT 5).A 00000470
&KK SETA &KK+8 00000480
&K SETA &K+8 00000490
&PP SETC '*+3' 00000500
&NN SETC '&NAME'(5,4).' ' 00000510
.A AIF (&LNGTH LT 9).G 00000520
&KK SETA &KK+8 00000530
&K SETA &K+8 00000540
&PPP SETC '*+3' 00000550
&NNN SETC '&NAME'(9,4).' ' 00000560
.G AIF (T'&PROP EQ 'O').B 00000570
AIF (T'&ACNT EQ 'O').F 00000580
&ARGS SETA &ARGS+&ACNT 00000590
.F ANOP 00000600
&P SETC '*+'.'&KK' 00000610
&K SETA &K+24 00000620
.B DC A(*+8,*+&K) 00000630
&LABEL DC XL1'80' 00000640
DC AL3(*+7) 00000650
DC A(&P) 00000660
DC CL4'&N' 00000670
DC XL1'60' 00000680
DC AL3(&PP) 00000690
AIF (&LNGTH LT 5).C 00000700
DC CL4'&NN' 00000710
DC XL1'60' 00000720
DC AL3(&PPP) 00000730
.C AIF (&LNGTH LT 9).E 00000740
DC CL4'&NNN',XL1'60',AL3(NIL) 00000750
.E AIF (T'&PROP EQ 'O').D 00000760
DC A(&PROP,*+4),A(*+8,NIL) 00000770
DC AL1(&ARGS),AL3(&RTN),XL1'40',AL3(NIL) 00000780
.D MEXIT 00000790
MEND 00000800
****** 00000810
MACRO 00000820
&NAME SAVE &R 00000830
&NAME ST &R,0(,PDS)
BXH PDS,K4,ERG2 00000850
MEND 00000860
****** 00000870
MACRO 00000880
&NAME UNSAVE &R 00000890
&NAME SR PDS,K4 00000900
L &R,0(,PDS)
MEND 00000920
MACRO UOM
&LABEL TTIMER &XXX UOM
&LABEL SVC 38 UOM
AR 0,1 UOM
LCR 0,0 UOM
MEND UOM
SPACE 1 UOM
MACRO UOM
&LABEL OPEN &XXX UOM
&LABEL L 15,=A(MAROPEN) UOM
BALR 14,15 UOM
MEND UOM
SPACE 1 UOM
MACRO UOM
&LABEL CLOSE &DCB UOM
AIF (T'&DCB EQ 'O').NOD UOM
&LABEL LA 1,&DCB UOM
.CON1 L 15,=A(MARCLOSE) UOM
BALR 14,15 UOM
MEXIT UOM
.NOD ANOP UOM
&LABEL L 15,=A(MARCLOSE) UOM
BALR 14,15 UOM
MEND UOM
SPACE 1 UOM
MACRO UOM
&NAME GET &DCB,&AREA UOM
AIF ('&DCB' EQ '').E1 UOM
&NAME IHBINNRA &DCB,&AREA UOM
L 15,=A(GETPRO) LOAD GET ROUTINE ADDR. UOM
BALR 14,15 LINK TO GET ROUTINE UOM
MEXIT UOM
.E1 IHBERMAC 06 UOM
MEND UOM
SPACE 2 UOM
MACRO UOM
&NAME PUT &DCB,&AREA UOM
AIF ('&DCB' EQ '').ERR UOM
&NAME IHBINNRA &DCB,&AREA UOM
USING DCBDS,1 UOM
ST 0,BFR$ UOM
L 15,IORTN$ UOM
DROP 1 UOM
BASR 14,15 UOM
MEXIT UOM
.ERR IHBERMAC 6 UOM
MEND
SPACE 1 UOM
MACRO UOM
&LABEL DCB &IOR,&BFR,&EOD,&IOCODE,&LEN,&MOD,&TXTLEN UOM
&LABEL DC A(&BFR) I/O BUFFER UOM
DS A LENGTH LOC UOM
DS A MODIFIERS LOC UOM
DS A LINE NUMBER LOC UOM
DS A FDUB PTR LOC UOM
AIF (T'&IOR EQ 'O').NOR UOM
DC V(&IOR) I/O ROUTINE UOM
AGO .CON1 UOM
.NOR DC A(0) I/O ROUTINE UOM
.CON1 ANOP UOM
DC Y(&LEN) LRECL UOM
DC Y(&LEN) TEXT LENGTH UOM
DS F LINE NUMBER UOM
AIF (T'&MOD EQ 'O').NOMOD UOM
DC XL4&MOD MODIFIERS UOM
AGO .CON2 UOM
.NOMOD DC XL4'0' MODIFIERS UOM
.CON2 DC A(0) FDUB PTR OR LOG. UNIT NO. UOM
DC A(&EOD) EOD ADDRESS UOM
DC A(&IOCODE) I/O CODE 0->INPUT 1->OUTPUT UOM
DS A FDUB PTR UOM
DS A GDINFO VECTOR UOM
DS F INPUT BUFFER SIZE UOM
AIF (T'&TXTLEN EQ 'O').NT UOM
DC A(&TXTLEN) TEXT LENGTH UOM
AGO .CON3 UOM
.NT DC A(0) TEXT LENGTH UOM
.CON3 DC A(0) NEXT-CHARACTER ADRS
MEND
EJECT 00000930
* INTERPRETER DESIGNED AND CODED BY- 00000940
* J.G.KENT, J.F.BOLCE & R.I.BERNS 00000950
*********************************************************************** 00000960
********* REGISTER ASSIGNMENTS ************** 00000970
*********************************************************** 00000980
********* 0 LOCAL WORK REGISTER 00000990
********* 1 LOCAL WORK REGISTER 00001000
********* 2 LINKAGE REGISTER 00001010
********* 3 BASE & WORK REGISTER - RESTORE PLEASE 00001020
********* DO NOT USE 3 INSIDE BASE 3 SECTION 00001030
********* 4 K4 CONSTANT F'4'-FOR UNSAVE ETC 00001040
********* 5 NILR ADDR OF NIL 00001050
********* 6 FREE FWS POINTER 00001060
********* 7 PDS STACK POINTER 00001070
********* 8 A FIRST ARGUMENT 00001080
********* 9 Q SECOND ARGUMENT 00001090
********* 10 M TEMP LIST SAVE- GARBAGE COLLECTED 00001100
********* 11 BASE REGISTER 00001110
********* 12 BASE REGISTER 00001120
********* 13 SAVE AREA AND BASE REGISTER 00001130
********* 14 LOCAL WORK REGISTER 00001140
********* 15 LOCAL WORK REGISTER 00001150
*********************************************************** 00001160
LISP START 00001170
******************* ASSEMBLY OPTIONS ***************** 00001180
STACKSIZ EQU 8000 WORDS FOR PUSHDOWN STACK UOM
BPSSIZE EQU 43550 BINARY PROGRAM SPACE UOM
STORESIZ EQU 24000 STATIC LISP CELLS
SBLKSIZ EQU 4*4096 DYNAMIC CELL BLOCK SIZE
ATMSZ EQU 80 SIZE OF PNAME MAX 00001220
CDEND EQU 72 MAX CD COL FOR S-EXPR 00001230
* 00001240
******************* REGISTER DEFINITIONS ************** 00001250
K4 EQU 4 00001260
FREE EQU 6 00001270
NILR EQU 5 00001280
PDS EQU 7 00001290
PDL EQU 15 00001300
A EQU 8 REGISTER DEFINITION 00001310
Q EQU 9 00001320
M EQU 10 00001330
F0 EQU 0 00001340
F2 EQU 2 00001350
F4 EQU 4 00001360
F6 EQU 6 00001370
R0 EQU 0 00001380
R1 EQU 1 00001390
R2 EQU 2 00001400
R3 EQU 3 00001410
R14 EQU 14 00001420
* 00001430
CAR EQU 0 00001440
CDR EQU 4 00001450
LOGIC EQU X'D0' NOTE.. FLOAT & BOOL ARE ALSO FIX 00001460
FLOAT EQU X'E0' 00001470
FIX EQU X'C0' 00001480
ATOM EQU X'80' 00001490
FWD EQU X'60' 00001500
EJECT 00001520
* ==================================================================== 00001530
* ====== THE BEGINNING OF THE INTERPRETER IS COVERED BY BASE- ======== 00001540
* ====== REGISTER 4 ============================================ 00001550
*********************************************************************** 00001560
******************* MAIN PROGRAM ********************************** 00001570
*********************************************************************** 00001580
MAIN STM 14,12,12(13) 00001590
LR K4,15 00001600
USING MAIN,K4 00001610
L 11,ADOFAGN 00001620
USING AGN,11 00001630
LA 12,BASE12 00001640
USING BASE12,12 00001650
LA 3,REMFLAG 00001660
USING REMFLAG,3 00001670
ST 13,SAVEBLK+4 00001680
LA 13,SAVEBLK 00001690
USING SAVEBLK,13 00001700
L NILR,NILA 00001710
USING NIL,NILR NOTE USE OF NILR AS A BASE 00001720
* REGISTER TO COVER OBJECT LIST 00001730
L 1,0(1) LOAD PARM POINTER 00001740
LH 2,0(1) COUNT 00001750
LTR 2,2 00001760
BZ NOPARM 00001770
CLC 2(3,1),=C'BCD' 00001780
BE RDBCD 00001790
PUTMSG ' *** INVALID PARM' 00001800
B NOPARM 00001810
RDBCD MVI NOTDOT+1,C'<' 00001820
MVI CKLP+1,C'%' 00001830
MVI NOTMIN+1,X'50' + 00001840
MVI TRYRPAR+1,C'<' 00001850
NOPARM EQU * 00001860
SPIE TRAPS,((1,13),15) 00001870
SR 0,0 INPUT CODE UOM
LA 1,=CL8'SCARDS' LISPIN UOM
LA 2,CARDIN INPUT DCB UOM
OPEN , UOM
LA 0,1 OUTPUT CODE UOM
LA 1,=CL8'SPRINT' LISPOUT UOM
LA 2,PRINTCB OUTPUT DCB UOM
OPEN , UOM
LA A,LISPIN RDS(LISPIN) UOM
BAL 2,RDSS UOM
LA A,LISPOUT WRS(LISPOUT) UOM
BAL 2,WRS UOM
L 15,=V(CANREPLY) BATCH MODE? UOM
BALR 14,15 UOM
B *+4(15) UOM
B BATCH2 NO UOM
OI BUFFPR,X'01' YES - ECHO INPUT UOM
MVI BATCHF,X'FF' SET "BATCH" FLAG UOM
BATCH2 LA 0,ATNPRO ATN INT PROCESSOR UOM
LA 1,ATNSA ATN SAVE AREA UOM
MVI 0(1),X'00' UOM
L 15,=V(ATTNTRP) UOM
BALR 14,15
L FREE,ADOFTOP INITIALIZE STATIC
LR 2,FREE LISP CELL STORAGE.
LA A,8
L Q,BOTTOM
SR 0,0
LA 1,8(,2)
INITL STM 0,1,0(2)
LR 2,1
BXLE 1,A,INITL
LA 1,1
STM 0,1,0(2)
L 0,=A(STORESIZ)
ST 0,CELLCNT
L PDS,PUSHA SET UP STACK POINTER.
LA K4,4 00002040
BR 11 00002050
ADOFAGN DC A(AGN) 00002060
ADOFTOP DC A(TOP1) 00002070
DROP K4 00002080
* ====== END OF THIS BASE 4 SECTION ================================ 00002090
* =================================================================== 00002100
EJECT 00002110
* =================================================================== 00002120
* ====== BEGINNING OF SPECIAL BASE 4 SECTION ======================= 00002130
* ====== ONLY OPEN IS IN THIS SECTION ============================== 00002140
USING BASE4,K4 00002150
*********************************************************************** 00002160
********* OPEN ****************************************************** 00002170
*********************************************************************** 00002180
OPEN BALR K4,0 00002190
BASE4 ST 2,OPENTEMP 00002200
ST A,OPENTEMP+4 00002210
* IS OPEN GIVEN ON SYSTEM DATASETS? 00002220
LA 0,LISPIN 00002230
CR A,0 00002240
BE USEREXIT YES, LISPIN 00002250
LA 0,LISPOUT 00002260
CR A,0 00002270
BE USEREXIT YES, LISPOUT 00002280
LA 0,LISPUNCH 00002290
CR A,0 00002300
BNE USERFILE 00002310
L 0,PUNCHOPN YES, LISPUNCH 00002320
LTR 0,0 00002330
BNZ USEREXIT LISPUNCH WAS ALREADY OPENED 00002340
BAL M,GETSTOR OPEN LISPUNCH. PUNCOPN WILL 00002350
ST 2,PUNCHOPN BE 0 IF LISPUNCH IS UNOPENED. 00002360
MVC 0(LDCB,R2),OTMDLDCB OUTPUT BCD UOM
MVC DDAREA(8),LUPCH MAKE IT USE SCARDS.
B USEREX1 00002390
USERFILE LR M,Q 00002400
LA Q,APVAL 00002410
BAL 2,GET 00002420
CR A,NILR 00002430
BNE USEREXIT 00002440
L A,OPENTEMP+4 00002450
LR Q,M 00002460
LA 0,SYSIN 00002470
CR Q,0 OWN DDNAME. IS THE DCB 00002480
BNE USERFIL2 DESCRIPTOR A SYSTEMDESCRIPTOR? 00002490
BAL M,GETSTOR YES, SYSIN 00002500
MVC 0(LDCB,R2),INMDLDCB INPUT DCB UOM
USING DCBDS,2 UOM
MVC LRECL#,LRECL2 UOM
B USEREX4 00002540
USERFIL2 LA 0,SYSOUT 00002550
CR Q,0 00002560
BNE USERFIL3 00002570
BAL M,GETSTOR YES, SYSOUT 00002580
MVC 0(LDCB,R2),OTMDLDCB OUTPUT DCB UOM
MVC LRECL#,LRECL3 UOM
B USEREX5 00002630
USERFIL3 LA 0,SYSPUNCH 00002640
CR Q,0 00002650
BNE USERFIL4 00002660
BAL M,GETSTOR YES, SYSPUNCH 00002670
MVC 0(LDCB,R2),OTMDLDCB OUTPUT DCB UOM
BAL 1,DDNAMSET 00002690
B USEREX1 00002700
USERFIL4 LA 0,SYSFILE 00002710
CR Q,0 00002720
BNE USERFIL6 00002730
BAL M,GETSTOR YES, SYSFILE WHICH IS 00002740
* USED FOR CHKPOINT OR 00002750
LA 0,OUTPUT RESTORE 00002760
C 0,ARGS REQUIRED FOR INPUT OR OUTPUT? 00002770
BNE USERFIL5 (DEFAULT: INPUT) 00002780
MVC 0(LDCB,R2),OTMDLDCB OUTPUT DCB UOM
MVC LRECL#,LRECL2 UOM
B USEREX5 00002820
USERFIL5 MVC 0(LDCB,R2),INMDLDCB INPUT DCB UOM
MVC LRECL#,LRECL2 UOM
B USEREX4 00002860
USERFIL6 LA 0,OUTPUT THE USER HAS SPECIFIED 00002870
C 0,ARGS HIS OWN DDNAME AND DCB 00002880
BNE USERFIL7 DESCRIPTOR LIST. 00002890
BAL M,GETSTOR DCB REQUIRED FOR OUTPUT OR 00002900
MVC 0(LDCB,R2),OTMDLDCB OUTPUT DCB UOM
TM CAR(Q),ATOM UOM
BNZ USEREX5 00002930
BAL 1,SETPARAM 00002940
B USEREX5 00002950
USERFIL7 BAL M,GETSTOR 00002960
MVC 0(LDCB,R2),INMDLDCB INPUT DCB UOM
TM CAR(Q),ATOM UOM
BNZ USEREX4 00002990
BAL 1,SETPARAM 00003000
B USEREX4 00003010
USEREX5 BAL 1,DDNAMSET 00003020
USEREX3 LA 0,1 OUTPUT CODE UOM
LA 1,DDAREA UNIT NAME UOM
OPEN , UOM
USEREXIT L 2,OPENTEMP 00003040
L A,OPENTEMP+4 00003050
LA K4,4 00003060
BR 2 00003070
USEREX4 BAL 1,DDNAMSET 00003080
USEREX2 SR 0,0 INPUT CODE UOM
LA 1,DDAREA UNIT NAME UOM
OPEN , UOM
B USEREXIT 00003100
USEREX1 MVC LRECL#,LRECL1 UOM
B USEREX3 00003130
GETSTOR GETSPACE LDCB,T=2 SPACE FOR A DCB UOM
LTR 15,15 00003150
BZ GETSTOR1 00003160
SR Q,Q 00003170
ERROR ' *** D2-FILE CANNOT BE OPENED - NO STORAGE AVLBL.' 00003180
GETSTOR1 LR 2,1 UOM
BR M 00003200
DDNAMSET LR 14,2 00003210
ST 2,SAVE2A SAVE R2 UOM
LR 15,A 00003220
LR A,2 00003230
LR Q,NILR 00003240
A Q,=X'60000000' 00003250
LA K4,4 00003260
BAL 2,CONS 00003270
LR Q,A 00003280
LR A,15 00003290
LR 0,1 00003300
BAL 2,CSET 00003310
LR 1,0 00003320
L K4,ADBASE4 00003330
MVC DDAREA,BLANKS BLANK UNIT NAME AREA.
L 15,CAR(15) 00003350
LM Q,M,0(15) 00003360
CLI 0(15),X'00' NAME OR INTEGER? UOM
BNE SHHV NAME UOM
ST Q,DDAREA NUMBER UOM
B DDNAMX2 UOM
SHHV SR 15,15 UOM
LA 14,DDAREA POINT TO UNIT NAME AREA UOM
NAMAGAIN SLDL A,8 00003380
STC A,0(15,14) UOM
LTR Q,Q 00003400
LA 15,1(0,15) 00003410
BZ NAMTEST 00003420
B NAMAGAIN 00003430
NAMTEST LA M,0(0,M) 00003440
CR M,NILR 00003450
BE DDNAMX2 UOM
L Q,CAR(M) 00003470
NAMAGN SLDL A,8 00003480
STC A,0(15,14) UOM
LTR Q,Q 00003500
LA 15,1(,15) UOM
BZ DDNAMX UOM
B NAMAGN 00003530
DDNAMX L M,CDR(M) NEXT BCD CELL UOM
B NAMTEST UOM
DDNAMX2 L 2,SAVE2A UOM
BR 1 00003550
SETPARAM ST 1,PARTEMP 00003560
PARMAGN LA M,LRECL 00003570
CR Q,NILR 00003580
BE PARMEXIT 00003590
LM A,Q,0(Q) 00003600
BAL 1,FINDPARM 00003610
STH 15,LRECL# BUFFER SIZE UOM
LA M,TXTLEN UOM
BAL 1,FINDPARM 00003640
ST 15,TXTLEN# UOM
LA M,AA 00003660
BAL 1,FINDPARM 00003670
NOP 0 UOM
B PARMAGN 00003690
FINDPARM LM 14,15,0(A) 00003700
CR 14,M 00003710
BNE 4(1) 00003720
L 15,CAR(15) 00003730
L 15,CAR(15) 00003740
BR 1 00003750
PARMEXIT L A,OPENTEMP+4 00003760
L 1,PARTEMP 00003770
BR 1 00003780
OPENTEMP DC 2F'0' 00003790
PARTEMP DC F'0' 00003800
STORADDR DC 2F'0' 00003810
PUNCHDDN DC CL8'LISPUNCH' 00003830
LRECL2 DC AL2(80) 00003840
LRECL1 EQU LRECL2 00003850
LRECL3 DC AL2(132) UOM
OTMDLDCB DCB ,0,0,1,0 OUTPUT DCB UOM
INMDLDCB DCB ,0,EOF,0,0,'80000000' UOM
SAVE2A DS A SAVE R2 UOM
DDAREA DS CL84 BUILD UNIT NAME UOM
DROP 2 UOM
DROP K4 00003920
* ====== END OF THIS SPECIAL BASE 4 SECTION ======================== 00003930
* =================================================================== 00003940
EJECT 00003950
* UOM
* ENTER WITH GR0 CONTAINING I/O CODE (0->INPUT, 1->OUTPUT) UOM
* GR1 POINTS TO LOGICAL UNIT NAME OR FDNAME UOM
* GR2 POINTS TO DCB UOM
* UOM
USING MAROPEN,15 UOM
MAROPEN STM 0,15,GETSA SHARE SAVE AREA WITH GETPRO UOM
LR 8,15 UOM
LR 10,0 I/O CODE UOM
LR 11,1 UNIT NAME UOM
LR 12,2 DCB LOC UOM
DROP 15 UOM
USING MAROPEN,8 UOM
USING DCBDS,12 UOM
CLI 0(11),X'00' A UNIT NUMBER? UOM
BNE LUNLU NO UOM
OI INOUT#,X'80' INDICATE LOGICAL UNIT UOM
MVC FDUB#,0(1) YES - MOVE TO PARM LIST UOM
MVC BCDUN(1),0(1) BUILD BCD UNIT NAME UOM
LM 0,1,BCDUN SET FOR CALL TO GDINFO UOM
B CGDIN UOM
SPACE 1 UOM
* UOM
* LOOK UP NAME IN LOGICAL UNIT TABLE UOM
* UOM
SPACE 1 UOM
LUNLU LA 5,LUNAM POINT TO UNIT TABLE UOM
LA 6,LUCNT NO. OF ENTRIES UOM
LULUL CLC 0(8,5),0(11) NAMES MATCH? UOM
BE GOTUN YES UOM
LA 5,12(,5) POINT TO NEXT ENTRY UOM
BCT 6,LULUL UOM
FDNAME L 15,=V(GETFD) MIGHT BE AN FDNAME UOM
BASR 14,15 UOM
ST 0,FDUB# SAVE FDUB UOM
SR 1,1 CALL GDINFO WITH FDUB UOM
CGDIN L 15,=V(GDINFO) UOM
BALR 14,15 UOM
ST 1,GDIV# SAVE PTR TO VECTOR UOM
MVC FDUB2#,0(1) SAVE FDUB UOM
LRHBS LTR 10,10 INPUT OR OUTPUT UOM
BZ INLGL INPUT UOM
OI INOUT#,X'01' SET "OUTPUT" BIT.
LH 0,LRECL# USER-LENGTH UOM
LTR 0,0 SPECIFIED? UOM
BZ LA120 NO - ASSUME 120 UOM
C 0,=F'120' UOM
BNH *+8 UOM
LA120 LA 0,120 UOM
LH 6,10(,1) GDINFO LENGTH UOM
CR 0,6 UOM
BNH *+6 UOM
LR 0,6 UOM
ST 0,TXTLEN# UOM
STH 0,LEN# UOM
CLC IORTN$,=F'0' IS THERE AN I/O ROUTINE? UOM
BNE RISU YES UOM
MVC IORTN$,=V(WRITE) NO - USE WRITE UOM
B RISU UOM
SPACE 1 UOM
* UOM
* PROCESS "INPUT" TYPE UOM
* UOM
SPACE 1 UOM
INLGL LH 6,8(,1) INPUT LENGTH UOM
LH 0,LRECL# USER-SPECIFIED REC LEN UOM
CR 0,6 CHOOSE MAX UOM
BNH *+6 UOM
LR 6,0 UOM
ST 6,BUFSIZ# THIS IS INPUT BUFFER SIZE UOM
LTR 0,0 DID USER GIVE LRECL?
BP *+10 YES -- SKIP.
STH 6,LRECL# NO; USE GDINFO LENGTH.
LR 0,6
L 6,TXTLEN# GET TXTLEN.
LTR 6,6 DID USER SPECIFY IT?
BNP OPENO NO -- USE LRECL.
CR 6,0 YES; LIMIT TXTLEN TO LRECL.
BNH *+6
OPENO LR 6,0
ST 6,TXTLEN#
LA 0,3 NOW GET BUFFER.
L 1,BUFSIZ# UOM
L 15,=V(GETSPACE) UOM
BALR 14,15 UOM
ST 1,BFR$ UOM
CLC IORTN$,=F'0' IS THERE AN I/O ROUTINE? UOM
BNE RISU YES UOM
MVC IORTN$,=V(READ) NO - USE READ UOM
* UOM
RISU LA 0,LEN# UOM
ST 0,LEN$ UOM
LA 0,LIN# UOM
ST 0,LIN$ UOM
LA 0,MOD# UOM
ST 0,MDF$ UOM
LA 0,FDUB# UOM
ST 0,FDUB$ UOM
LM 0,15,GETSA RESTORE EVERYBODY UOM
BR 14 UOM
* UOM
GOTUN MVC IORTN$,8(5) MOVE I/O ROUTINE UOM
OI INOUT#,X'80' UOM
LM 0,1,0(5) GET BCD UNIT NAME UOM
B CGDIN UOM
* UOM
DROP 8 UOM
USING BASE12,12 UOM
DS 0F UOM
BCDUN DC CL8' ' BUILD 8-BYTE UNIT NAME UOM
* UOM
* TABLE OF NON-NUMERIC LOGICAL UNIT NAMES UOM
* UOM
LUNAM DC CL8'SCARDS',V(SCARDS) UOM
DC CL8'SPRINT',V(SPRINT) UOM
LUPCH DC CL8'SPUNCH',V(SPUNCH)
DC CL8'GUSER',V(GUSER) UOM
DC CL8'SERCOM',V(SERCOM) UOM
LUCNT EQU (*-LUNAM)/12
EJECT UOM
* UOM
* SUPPORT FOR "CLOSE" MACRO UOM
* UOM
SPACE 1 UOM
USING MARCLOSE,15 UOM
MARCLOSE STM 0,15,GETSA UOM
LR Q,15 UOM
LR M,1 COPY DCB PTR UOM
USING MARCLOSE,Q UOM
USING DCBDS,M UOM
DROP 15 UOM
L 0,FDUB2# GET FDUB UOM
TM INOUT#,X'80' LOGICAL UNIT? UOM
BO NOFREEFD YES - DON'T FREE UOM
LTR 0,0 WAS THERE EVER AN FDUB? UOM
BZ NOFREEFD NO - DON'T FREE UOM
L 15,=V(FREEFD) FREE IT UOM
BALR 14,15 UOM
NOFREEFD TM INOUT#,X'01' INPUT DEVICE? UOM
BO NOFREEB NO - DON'T FREE BUFFER UOM
L 1,BFR$ POINT TO BUFFER UOM
LTR 1,1 A BUFFER TO FREE? UOM
BZ NOFREEB UOM
SR 0,0 FREE IT ALL UOM
L 15,=V(FREESPAC) UOM
BASR 14,15 UOM
NOFREEB L 1,GDIV# FREE THE FDINFO INFO
LTR 1,1 IF ANY
BZ NOFREEG
L 15,=V(FREESPAC)
SR 0,0
BASR 14,15
NOFREEG LR 1,M FREE THE DCB UOM
LA 0,CARDIN IGNORE LISPIN & LISPOUT UOM
CR 0,1 UOM
BE NOFREED UOM
LA 0,PRINTCB UOM
CR 0,1 UOM
BE NOFREED UOM
SR 0,0 UOM
L 15,=V(FREESPAC) UOM
BASR 14,15 UOM
NOFREED LM 0,15,GETSA UOM
BR 14 UOM
DROP M,Q UOM
EJECT UOM
* UOM
* PROCESS "ATTN" UOM
* UOM
SPACE 1 UOM
ATTN BALR 1,0 UOM
USING *,1 UOM
L 15,=V(ATTNTRP) UOM
LR 14,2 COPY RETURN ADDRESS UOM
SR 0,0 ASSUME ATN OFF UOM
CR A,NILR ATTN OFF? UOM
BE ATNOFF YES UOM
LA 0,ATNPRO ATN ON UOM
ATNOFF LA 1,ATNSA UOM
DROP 1 UOM
MVI 0(1),X'00' UOM
BR 15 UOM
SPACE 2 UOM
* UOM
* ATTENTION INTERRUPT PROCESSOR UOM
* UOM
SPACE 1 UOM
ATNPRO LR 10,15 UOM
USING ATNPRO,10 UOM
LM 11,13,=A(AGN,BASE12,SAVEBLK) UOM
LM 2,9,16(1) UOM
CR FREE,K4 IN GARBAGE COLLECTION?
BL ATNOTNOW YES.
L 2,INDCBADR LOOK AT INPUT DCB UOM
USING DCBDS,2 UOM
L 0,LASTCHAR SAVE CHARACTER PTR.
ST 0,NXTCHR#
L 1,GDIV# POINT TO GDINFO VECTOR UOM
CLI 12(1),X'01' *MSOURCE*? UOM
BE ATNP3 YES -- LOOK AT *SINK*.
TM MSFLOC,X'01' *MSOURCE* OPENED? UOM
BO MSNP YES UOM
OI MSFLOC,X'01' SET SWITCH UOM
LA 2,MSRCDCB POINT TO *MSOURCE* DCB UOM
LA 1,=C'*MSOURCE* ' UOM
SR 0,0 INPUT CODE UOM
OPEN , OPEN *MSOURCE* UOM
MSNP L 0,MSRCDCB+TXTLEN#-DCBDS FAKE RDS(*MSOURCE*).
ST 0,CARDLNTH UOM
LA 0,MSRCDCB UOM
ST 0,INDCBADR UOM
ATNP3 SR 0,0 FORCE NEW INPUT LINE.
ST 0,LASTCHAR UOM
L 2,OTDCBADR LOOK AT OUTPUT DCB.
L 1,GDIV# UOM
CLI 12(1),X'02' *MSINK*? UOM
BE NOMO *MSINK* OPEN? UOM
TM MSFLOC,X'02' *MSINK* OPEN? UOM
BO WHATTN YES UOM
OI MSFLOC,X'02' SET BIT UOM
LA 2,MSNKDCB POINT TO *MSINK* DCB UOM
LA 1,=C'*MSINK* ' UOM
LA 0,1 OUTPUT CODE UOM
OPEN , UOM
WHATTN LA 14,MSGBUFFR FAKE WRS(*MSINK*)
ST 14,MARGIN2 UOM
LA 0,MSNKDCB UOM
ST 0,OTDCBADR UOM
LA 14,LINE UOM
ST 14,MARGIN1 UOM
LA 14,100(,14) UOM
ST 14,LINEMAX UOM
LA 14,20(,14) UOM
ST 14,SUPMAX UOM
DROP 2 UOM
NOMO MVC MSGBUFFR,BLANKS CLEAR MESSAGE BUFFER.
PUTMSG ' LISP ATTN' UOM
SR 0,0
ATNCALL LA 1,ATNSA
STC 0,0(,1)
ST NILR,ERRARG
LR 0,10 ATN TRAP PROCESSOR UOM
L 15,=V(ATTNTRP)
BALR 14,15 UOM
B ERRPU UOM
ATNOTNOW LA 0,255
B ATNCALL
DROP 10 UOM
EJECT UOM
* UOM
* PROCESS "BATCH" UOM
* UOM
SPACE 1 UOM
BATCH BALR 1,0 UOM
USING *,1 UOM
LR A,NILR ASSUME CONVERSATIONAL UOM
CLI BATCHF,X'00' TRUE? UOM
BER 2 YES UOM
LA A,T NO - CONVERSATIONAL UOM
BR 2 UOM
SPACE 1 UOM
* UOM
* PROCESS "MTS" UOM
* UOM
SPACE 1 UOM
MTS BALR 1,0 UOM
USING *,1 UOM
STM 0,15,GETSA UOM
L 15,=V(MTS) UOM
BALR 14,15 UOM
USING *,14 UOM
LM 0,15,GETSA UOM
LR A,NILR UOM
BR 2 UOM
DROP 1,14 UOM
EJECT UOM
* UOM
* PROCESS "GET" MACRO UOM
* GR1 POINTS TO DCB UOM
* UOM
SPACE 1 UOM
USING GETPRO,15 UOM
USING DCBDS,8 UOM
GETPRO STM 0,15,GETSA UOM
LR 10,15 UOM
LR 8,1 UOM
DROP 15 UOM
USING GETPRO,10 UOM
CRING2 L 15,IORTN$ I/O ROUTINE ADDRESS UOM
BALR 14,15 UOM
LTR 15,15 EOF UOM
BNZ GETEOF YES UOM
LTR 0,0 READ OK? UOM
BZ LROK NO - NEW FDUB OPENED UOM
L 1,GDIV# FREE OLD GDINFO INFO
SR 0,0
L 15,=V(FREESPAC)
LTR 1,1 IF ANY
BZ *+6
BASR 14,15
L 0,FDUB2# POINT TO IT UOM
SR 1,1 UOM
L 15,=V(GDINFO) GET NEW INFO UOM
BALR 14,15 UOM
ST 1,GDIV# SAVE VECTOR PTR UOM
LTR 15,15 UOM
BNZ CRING UOM
CLC =C'NONE',4(1) UOM
BE CRING UOM
LH 6,8(,1) MAX. INPUT LENGTH
C 6,BUFSIZ# IS BUFFER BIG ENOUGH?
BNH CRING YES -- SKIP.
SR 0,0 NO - FREE OLD BUFFER UOM
L 1,BFR$ POINT TO BUFFER UOM
L 15,=V(FREESPAC) UOM
BALR 14,15 UOM
LR 1,6 GET NEW BUFFER UOM
LA 0,3 UOM
L 15,=V(GETSPACE) UOM
BALR 14,15 UOM
ST 1,BFR$ UOM
ST 6,BUFSIZ# STORE NEW BUFFER SIZE.
CRING LR 1,8 POINT TO DCB UOM
B CRING2 UOM
LROK L 1,BFR$ POINT TO INPUT BUFFER
LH 2,LEN# INPUT LENGTH UOM
L 3,BUFSIZ# BUFFER SIZE UOM
CR 2,3 OVERFLOW? UOM
BH GETABORT YES UOM
BE GETEQ ON THE NOSE UOM
LA 4,0(1,2) POINT TO END OF TEXT.
LA 5,X'07' MAKE 3-BIT MASK.
NR 5,4 GET POS'N IN DOUBLEWORD.
LA 5,BLANKS(5) ADD TO ADRS. OF BLANKS.
SR 3,2 COMPUTE NBR BLANKS NEEDED.
LA 0,128 MOVE UP TO 128 AT A TIME.
GETM CR 3,0
BNH GETN
MVC 0(128,4),0(5)
AR 4,0
SR 3,0
B GETM
GETN BCTR 3,0
EX 3,GETMVC
GETEQ LM 2,15,GETSA+8 UOM
BR 14 UOM
GETMVC MVC 0(0,4),0(5)
GETEOF L 15,EODAD# EOF EXIT UOM
LM 0,14,GETSA UOM
BR 15 UOM
GETABORT LM 0,15,GETSA UOM
DROP 8,10 UOM
MVI ERRORIND,X'03' ERROR ON UOM
ERROR ' *** RECORD LENGTH EXCEEDS BUFFER SIZE' UOM
GETSA DS 18F UOM
ATNSA DS 18F ATNTTRP SAVE AREA UOM
MSRCDCB DCB READ,0,LASTCARD,0,0,'80000000' *MSOURCE* DCB UOM
MSNKDCB DCB WRITE,0,0,1,132 *MSINK* DCB UOM
MSFLOC DC X'00' *MSOURCE*/*MSINK* OPEN UOM
LTORG UOM
EJECT
* SPECIAL BASE 4 SECTION TO INITIALIZE THE HASH TABEL FOR ATOMS
*
HASHINIT LR K4,15
USING HASHINIT,K4
GETSPACE 4*4096,T=3 GET A HASH TABLE
ST 1,HASHTBL SAVE IT
A 1,=A(4*4096-1) FIND END
ST 1,ENDHASH
L 1,HASHTBL BEGINNING AGAIN
SR 0,0 LEAR IT
ST 0,0(0,1)
LA 1,4(0,1)
C 1,ENDHASH
BL *-12
L 1,OBJECTA OBJECT LIST
HSHI1 L 14,CAR(0,1) POINT TO ATOM
L 14,CAR(0,14) POINT TO FULL WORD
LH 15,0(0,14) COMPUT HASH
AH 15,2(0,14)
MH 15,=X'7A3C'
N 15,=X'00003FE0'
A 15,HASHTBL
HSHI2 MVI LPSW,0 NO LOOP YET
C 0,0(0,15) EMPTY ENTRY?
BE HSHI3 YES
LA 15,4(0,15) NEXT
C 15,ENDHASH END?
BL HSHI2 NO
L 15,HASHTBL WRAP AROUND
XI LPSW,1 AVOID INFINITE LOOPS
BNZ HSHI2 NOPE
B TMNYATM TOO MANY ATOMES
HSHI3 L 14,CAR(0,1) POINT TO ATOM
ST 14,0(0,15) INTO HSH TBL
L 1,CDR(0,1) NEXT ATOM
CR 1,NILR END?
BNE HSHI1 NOPE
LA K4,4 RESTORE 4
DROP K4
B SCH1
LTORG
EJECT
* ===================================================================== 00003960
* ===== BEGINNING OF ANOTHER SPECIAL BASE 4 SECTION ================== 00003970
* ===== ONLY EXITERR IN THIS SECTION ================================ 00003980
USING BASE4A,K4 00003990
*********************************************************************** 00004000
***** EXITERR ***************************************************** 00004010
*********************************************************************** 00004020
EXITERR BALR K4,0 00004030
BASE4A CR A,NILR 00004040
BE EXOFF RESET TO NORMAL 00004050
MVI T1+1,X'F0' SET FOR EXITS 00004060
MVI T2+1,X'F0' 00004070
MVI T3+1,X'F0' 00004080
MVI T4+1,X'F0' 00004090
MVI T5+1,X'F0' 00004100
MVI T6+1,X'F0' 00004110
MVI T7+1,X'F0' 00004120
MVI T8+1,X'F0' 00004130
MVI T9+1,X'F0' 00004140
B EXOUT 00004160
EXOFF MVI T1+1,X'00' 00004170
MVI T2+1,X'00' 00004180
MVI T3+1,X'10' UOM
MVI T4+1,X'00' 00004200
MVI T5+1,X'00' 00004210
MVI T6+1,X'00' 00004220
MVI T7+1,X'00' 00004230
MVI T8+1,X'00' 00004240
MVI T9+1,X'00' 00004250
EXOUT LA K4,4 00004270
BR 2 00004280
DROP K4 00004290
* ===== END OF THIS SPECIAL BASE 4 SECTION ========================== 00004300
* ===================================================================== 00004310
BATCHF DC X'00' BATCH FLAG 00 -> CONV UOM
EJECT 00004320
* ==================================================================== 00004330
* ====== BEGINNING OF BASEREGISTER 11 SECTION. THIS SECTION IS FULL = 00004340
AGN DS 0H UOM
NI MAININD,X'00' 00004360
BAL 2,READ READ THE FUNCTION 00004370
ST A,GARBT HOLD IT 00004380
BAL 2,READ READ ARGUMENTS 00004390
ST A,GARBT+4 HOLD THEM 00004400
TM MAININD,X'05' 00004410
BZ NOBUG 00004420
PUTMSG READERR 00004430
L A,GARBT 00004440
BAL 2,PRINT 00004450
L A,GARBT+4 00004460
BAL 2,PRINT 00004470
NI MAININD,X'00' 00004480
B AGN 00004490
* TM DBIND,X'01' DEBUG MODE 00004500
* BZ NOBUG NO 00004510
NOBUG TM GARBSW,X'01' IGNORE TITLES? UOM
BZ SEQM1 YES UOM
PUTMSG MA UOM
L A,GARBT 00004530
BAL 2,PRINT 00004540
L A,GARBT+4 00004550
BAL 2,PRINT 00004560
SEQM1 L Q,GARBT+4 UOM
L A,GARBT 00004580
TTIMER 00004590
ST 0,STIM DONT COUNT READ TIME 00004600
BAL 2,EVALQUOT 00004610
TTIMER 00004620
L 1,STIM 00004630
ST 0,STIM 00004640
SR 1,0 00004650
M 0,=F'5' UOM
D 0,=F'384' UOM
CVD 1,TEA INTO DECIMAL 00004680
MVC MB+9(8),MASK 00004690
ED MB+9(8),TEA+4 00004700
TM GARBSW,X'01' UOM
BZ SEQM2 UOM
PUTMSG MB 00004710
SEQM2 BAL 2,PRINT UOM
B AGN 00004730
* SNAPS BPS,BPSST,BPSST+4*BPSSIZE 00004740
* SNAPS STACK,PUSH,PUSH+4*STACKSIZ 00004750
* SNAPS OBJLIST,OBJECT,OBJECT+8*STORESIZ 00004760
STOP EQU * 00004770
CLOSE (PRINTCB) 00004780
L 13,SAVEBLK+4 00004790
RETURN (14,12) 00004800
MA DC AL2(29),C'0 ARGUMENTS FOR EVALQUOTE ...' 00004810
STIM DC F'2000000000' 20 00004820
TEA DC D'0' DP WORK AREA 00004830
MASK DC X'40',5X'20',X'2120' 00004840
MB DC AL2(31),C'0 TIME MS, VALUE IS ...' 00004850
READERR DC AL2(66),C' *** ERRORS ENCOUNTERED WHILE READING.' 00004860
DC C' CONTINUING WITH NEXT DOUBLET' 00004870
MAININD DC X'00' 00004880
EJECT 00004890
*********************************************************************** 00004900
******************* TRAP SUPERVISOR ******************************* 00004910
*********************************************************************** 00004920
TRAPS CR FREE,K4 A GARBCOLL TRAP 00004930
BL GARBCOLL 00004940
CLI 7(1),X'08' 00004950
BL TRAPS1 00004960
MVC OFLOW(1),7(1) 00004970
UNPK OFLOWTP(3),OFLOW(2) 00004980
TR OFLOWTP(2),SNPTR-240 00004990
PUTMSG OFLOWMSG 00005000
T1 BC 0,STOP 00005010
BR 14 00005020
TRAPS1 MVC SAVEBLK+12(8),4(1) MOVE PSW 00005030
SNAPS TRAP_PSW,SAVEBLK+12,SAVEBLK+19 00005040
MVC SAVEBLK+12(12),20(1) 00005050
STM 3,7,SAVEBLK+24 00005060
SNAPS REGS0-7,SAVEBLK+12,SAVEBLK+43 00005070
STM 8,13,SAVEBLK+12 00005080
MVC SAVEBLK+36(8),12(1) 00005090
SNAPS REGS8-15,SAVEBLK+12,SAVEBLK+43 00005100
MVC 9(3,1),=AL3(SYSER) 00005110
T2 BC 0,STOP 00005120
BR 14 00005130
CONS1 ST A,CAR(FREE) 00005140
BR 14 00005150
SYSER ERROR '0*** ERROR: CAR TAKEN OF FULLCELL' 00005160
OFLOWMSG DC AL2(33),C' *** OVER-OR UNDERFLOW OF TYPE ' 00005170
OFLOWTP DC X'00000000' 00005180
OFLOW DC H'0' 00005190
EJECT 00005200
CARDIN DCB SCARDS,0,LASTCARD,0,0,'80000000' UOM
PRINTCB DCB SPRINT,0,0,1,132 UOM
SNAPROUT ST 14,SNPSV 00005250
L 2,8(14) LOWER BOUND 00005260
MVC SNPA(8),0(14) 00005270
AP 16(2,14),SNP1 00005280
UNPK SNPA+9(3),16(2,14) 00005290
OI SNPA+11,X'F0' 00005300
SNPLN ST 2,SNPA+31 00005310
UNPK SNPA+13(7),SNPA+31(5) 00005320
TR SNPA+13(6),SNPTR-240 00005330
MVC SNPA+19(100),BLANKS+4
LA 1,SNPA+22 00005360
LA 3,8 00005370
SNPAL C 2,12(14) 00005380
BH SNPOUT 00005390
UNPK 0(9,1),0(5,2) 00005400
TR 0(8,1),SNPTR-240 00005410
MVI 8(1),C' ' 00005420
LA 1,09(,1) 00005430
LA 2,4(,2) 00005440
BCT 3,SNPAL 00005450
SNPOUT L R1,OTDCBADR 00005460
L 0,MARGIN2 00005470
PUT (R1),(0) 00005480
L 14,SNPSV 00005490
C 2,12(14) UPPER 00005500
BNH SNPLN 00005510
MVC MSGBUFFR,BLANKS
BH 18(14) 00005540
SNP1 DC PL1'1' 00005550
SNPSV DC F'0' 00005560
SNPPSER DC 7F'0' 00005570
DS 0D
MSGBUFFR DC CL129' ' FOR MESSAGES AND DUMPS
SNPA EQU MSGBUFFR+1
SNPPP DC CL13' ' 00005600
SNPTR DC C'0123456789ABCDEF' 00005610
DTRAH DC H'-78,-68,-58,-49,-39,-29,-20,-10,0,9,19,28,38' 00005620
DC H'48,57,67' 00005630
DS 0D
BLANKS DC CL(128+8)' '
LINE DC CL124' ',CL14' '
EJECT 00005640
*********************************************************************** 00005650
******************* EVALQUOTE(FN,ARGS) NON REC ******************* 00005660
*********************************************************************** 00005670
EVS DC 3F'0' 00005680
EVALQUOT STM A,Q,EVS+4 00005690
ST 2,EVS 00005700
LA Q,FEXPR TRY FEXPR 00005710
BAL 2,GET 00005720
CR A,NILR IS IT 00005730
BNE EVL ITS EXPR 00005740
L A,EVS+4 00005750
LA Q,FSUBR TRY FSUBR 00005760
BAL 2,GET 00005770
CR A,NILR IS IT 00005780
BNE EVL IT IS FSUBR 00005790
* APPLY(FN,ARGS,NIL) 00005800
ST NILR,ARGS 00005810
LM A,Q,EVS+4 00005820
BAL 2,APPLY 00005830
B EVQS UOM
* EVAL(CONS(FN,ARGS),NIL) 00005860
EVL LM A,Q,EVS+4 00005870
BAL 2,CONS 00005880
LR Q,NILR 00005890
BAL 2,EVAL 00005900
EVQS ST A,ER## SAVE FOR RES# UOM
L 2,EVS 00005910
BR 2 00005920
EJECT 00005930
*********************************************************************** 00005940
******************* EVAL(FORM,A) RECURSIVE ********************* 00005950
*********************************************************************** 00005960
TRACEIND DC X'0000' 00005970
EVAL SAVE 2 SAVE RET 00005980
EVALL CR A,NILR 00005990
BE RETURN RET NIL 00006000
TM CAR(A),FIX A NUMBER 00006010
BO RETURN YES 00006020
STM A,Q,EVLSV SAVE PARAMS 00006030
TM CAR(A),ATOM 00006040
BZ EVALST NO 00006050
LA Q,APVAL IS IT APVAL 00006060
BAL 2,GET 00006070
CR A,NILR 00006080
BE EVNAP NO 00006090
L A,CAR(,A) YES -- RETURN VALUE.
B RETURN 00006110
EVNAP LM A,Q,EVLSV AN ATOM AND NOT APVAL 00006120
LA 1,ERRA8 00006130
BAL 2,SASSOC 00006140
L A,CDR(,A)
B RETURN 00006160
ERRA8 ERROR ' *** A8-UNDEFINED VARIABLE' 00006170
ERRA9 ERROR ' *** A9-FUNCTION NOT DEFINED' 00006180
EVALST EQU * 00006190
NTEV EQU * 00006200
L A,CAR(,A) FORM NOT AN ATOM; TRY QUOTE.
LA 1,QUOTE 00006220
CR A,1 00006230
BNE EVNQ NOT QUOTE 00006240
L A,EVLSV 00006250
L A,CDR(A) 00006260
L A,CAR(A) CADR(FORM) 00006270
B RETURN 00006280
EVNQ LA 1,COND TRY COND 00006290
CR A,1 00006300
BNE EVNC NOT COND 00006310
L A,EVLSV IT IS COND 00006320
L A,CDR(A) 00006330
BAL 2,EVCON 00006340
B RETURN 00006350
EVNC TM CAR(A),ATOM 00006360
BZ EVNA NO 00006370
ST A,EVLSV+8 00006380
LA Q,EXPR 00006390
BAL 2,GET 00006400
CR A,NILR 00006410
BE EVNXP NOT EXPR 00006420
* APPLY(---,EVLIS(CDR(FORM),A),A 00006430
TM TRACEIND,X'01' TEST FOR TRACING 00006440
BNO NOTRACE NO TRACE 00006450
SAVE A SAVE EXPR DEFN. 00006460
L A,EVLSV+8 RESTORE FUNCTION 00006470
SAVE A SAVE IT 00006480
LM A,Q,EVLSV RESTORE EVALARGS 00006490
SAVE Q SAVE ASSOC.LIST 00006500
L A,CDR(A) FIND ARGS. 00006510
BAL 2,EVLIS 00006520
ST A,EVLSV STORE RESULTS IN 00006530
ST A,PVARG LOCAL & I/O STORE. 00006540
UNSAVE Q UNSAVE ASSOC. LIST 00006550
ST Q,ARGS STORE IT 00006560
UNSAVE A UNSAVE AND STORE 00006570
ST A,EVLSV+8 THE FUNCTION 00006580
TM 0(A),X'01' SHOULD IT BE TRACED 00006590
BNO NOTRA NO 00006600
BAL 2,PRARG YES, PRINT FUNCTION + ARGS. 00006610
NOTRA L Q,EVLSV RESTORE ARGS TO Q 00006620
UNSAVE A UNSAVE EXPR POINTER 00006630
L 2,EVLSV+8 RESTORE FUNCTION 00006640
SAVE 2 SAVE IT 00006650
BAL 2,APPLY APPLY FUNCTION 00006660
ST A,EVLSV STORE VALUE IN 00006670
ST A,PVARG LOCAL + I/O STORE 00006680
UNSAVE A UNSAVE FUNCTION 00006690
TM 0(A),X'01' SHOULD IT BE TRACED 00006700
BNO NOTRB NO 00006710
BAL 2,PRVAL PRINT FUNTION + VALUE 00006720
NOTRB L A,EVLSV RESTORE VALUE 00006730
B RETURN RETURN 00006740
NOTRACE SAVE A 00006750
LM A,Q,EVLSV 00006760
SAVE Q 00006770
L A,CDR(A) 00006780
BAL 2,EVLIS 00006790
UNSAVE Q 00006800
ST Q,ARGS ASSOC LIST 00006810
LR Q,A 00006820
UNSAVE A 00006830
BAL 2,APPLY 00006840
B RETURN 00006850
EVNXP L A,EVLSV+8 CAR(FORM) 00006860
LA Q,FEXPR 00006870
BAL 2,GET IS IT FEXPR 00006880
CR A,NILR 00006890
BE EVNFXP 00006900
* APPLY(---,LIST(CDR(FORM)A)A) 00006910
LR M,A 00006920
L A,EVLSV+4 ALIST 00006930
ST A,ARGS 00006940
LR Q,NILR 00006950
BAL 2,CONS 00006960
LR Q,A 00006970
L A,EVLSV 00006980
L A,CDR(A) 00006990
BAL 2,CONS 00007000
TM TRACEIND,X'01' TEST FOR TRACING 00007010
BNO NOTRACE2 NO 00007020
LR Q,A PUT ARGS IN Q 00007030
L A,EVLSV+8 GET FUNCTION 00007040
SAVE A SAVE FUNCTION 00007050
TM 0(A),X'01' SHOULD IT BE TRACED 00007060
BNO NOTR2A NO 00007070
ST M,EVLSV+4 STORE ADDR OF FEXPR 00007080
ST Q,EVLSV STORE ARGS 00007090
ST Q,PVARG ALSO IN I/O ROUTINE 00007100
BAL 2,PRARG PRINT FUNCTION AND ARGS. 00007110
LM Q,M,EVLSV PUT ARGS IN Q, ADDR OF FEXPR IN M 00007120
NOTR2A LR A,M PUT ADDR. OF FEXPR IN A 00007130
BAL 2,APPLY CALL APPLY 00007140
UNSAVE M GET THE FUNCTION 00007150
TM 0(M),X'01' SHOULD IT BE TRACED 00007160
BNO RETURN NO, RETURN 00007170
ST A,EVLSV STORE VALUE 00007180
ST A,PVARG ALSO IN I/O ROUTINE 00007190
LR A,M PUT FUNCTION IN A 00007200
BAL 2,PRVAL PRINT FUNCTION AND VALUE 00007210
L A,EVLSV RESTORE VALUE 00007220
B RETURN RETURN 00007230
NOTRACE2 LR Q,A 00007240
LR A,M 00007250
B APPLYY 00007260
EVNFXP L A,EVLSV+8 00007270
LA Q,SUBR TRY SUBR 00007280
BAL 2,GET 00007290
CR A,NILR 00007300
BE EVNS NOT SUBR 00007310
L Q,ALIST 00007320
SAVE Q 00007330
SAVE A SUBR ADDR. 00007340
LM A,M,EVLSV 00007350
SAVE Q ALIST 00007360
SAVE M FUNCTION 00007370
L A,CDR(A) 00007380
BAL 2,EVLIS 00007390
UNSAVE Q UNSAVE FUNCTION 00007400
TM TRACEIND,X'01' TEST FOR TRACING 00007410
BNO NOTRACE3 NO 00007420
ST Q,EVLSV+8 STORE FUNCTION 00007430
TM 0(Q),X'01' SHOULD FUNCTION BE TRACED 00007440
BNO NOTR3A NO 00007450
ST A,EVLSV SAVE ARGS 00007460
ST A,PVARG ALSO IN I/O ROUTINE 00007470
LR A,Q PUT FUNCTION IN A 00007480
BAL 2,PRARG PRINT FUNCTION AND ARGS. 00007490
L A,EVLSV RESTORE ARGS. 00007500
L Q,EVLSV+8 RESTORE FUNCTION 00007510
NOTR3A STM A,Q,TAPPL IN CASE OF ARG. CT. ERROR 00007520
UNSAVE Q GET ASSOC LIST 00007530
ST Q,ALIST PUT IN ALIST 00007540
BAL 2,SPREAD RETURNS ARG CT. IN REG 1 00007550
UNSAVE 14 SUBR ADDR. 00007560
L M,EVLSV+8 RESTORE FUNCTION 00007570
SAVE M SAVE IT 00007580
STC 1,*+5 CHECK ARG CT. 00007590
CLI 0(14),X'00' 00007600
BE EVNOERR 00007610
LM A,Q,TAPPL 00007620
BL SUBRER TO MANY ARGS. 00007630
B SUBRERO TO FEW 00007640
EVNOERR L 14,0(14) SUBR ADR. 00007650
BALR 2,14 CALL SUBR 00007660
UNSAVE M RESTORE FUNCTION 00007670
UNSAVE Q 00007680
ST Q,ALIST 00007690
TM 0(M),X'01' SHOULD IT BE TRACED 00007700
BNO RETURN NO, RETURN 00007710
ST A,EVLSV STORE VALUE 00007720
ST A,PVARG ALSO IN I/O ROUTINE 00007730
LR A,M PUT FUNCTION IN A 00007740
BAL 2,PRVAL PRINT FUNCTION AND VALUE 00007750
L A,EVLSV RESTORE VALUE 00007760
B RETURN RETURN 00007770
NOTRACE3 STM A,Q,TAPPL 00007780
UNSAVE Q ALIST 00007790
ST Q,ALIST 00007800
BAL 2,SPREAD 00007810
UNSAVE 14 SUBR ADR. 00007820
B EXSUBR EXECUTE SUBR. COUNT ARGS 00007830
EVNS L A,EVLSV+8 00007840
LA Q,FSUBR 00007850
BAL 2,GET 00007860
CR A,NILR 00007870
BE EVNFS 00007880
LR 14,A ADR OF FSUBR IN 14 00007890
L Q,ALIST 00007900
SAVE Q 00007910
LM A,Q,EVLSV PICK UP EVALARGS 00007920
ST Q,ALIST SET UP ALIST 00007930
L A,CDR(A) RESULT 00007940
TM TRACEIND,X'01' TEST FOR TRACING 00007950
BNO EXSUBRB NO, EXECUTE FSUBR 00007960
L M,EVLSV+8 RESTORE FUNCTION 00007970
SAVE M SAVE IT 00007980
TM 0(M),X'01' SHOULD IT BE TRACED 00007990
BNO NOTR4A NO 00008000
ST 14,EVLSV+8 STORE FSUBR ADR. 00008010
ST A,EVLSV STORE RESULT 00008020
ST A,PVARG ALSO IN I/O ROUTINE 00008030
LR A,M PUT FUNCTION IN A 00008040
BAL 2,PRARG PRINT FUNCTION AND ARGS. 00008050
LM A,M,EVLSV RESTORE RESULT,ALIST,FSUBR ADR. 00008060
LR 14,M FSUBR ADR. IN 14 00008070
NOTR4A L 14,CAR(14) FSUBR ADR. 00008080
BALR 2,14 CALL FSUBR 00008090
UNSAVE M UNSAVE FUNCTION 00008100
UNSAVE Q 00008120
ST Q,ALIST 00008130
TM 0(M),X'01' SHOULD IT BE TRACED
BNO RETURN NO, RETURN 00008140
ST A,EVLSV SAVE VALUE 00008150
ST A,PVARG ALSO IN I/O ROUTINE 00008160
LR A,M PUT FUNCTION IN A 00008170
BAL 2,PRVAL PRINT FUNCTION AND VALUE 00008180
L A,EVLSV RESTORE VALUE 00008190
B RETURN RETURN 00008200
* EVAL(CONS(CDR(SASSOC(CAR(FORM),A,U)),CDR(FORM)),A) 00008210
EVNFS L A,EVLSV+8 CAR(FORM) 00008220
L Q,EVLSV+4 00008230
LA 1,ERRA9 00008240
BAL 2,SASSOC 00008250
L A,CDR(A) 00008260
L Q,EVLSV 00008270
L Q,CDR(Q) 00008280
BAL 2,CONS 00008290
L Q,EVLSV+4 00008300
B EVALL 00008310
* APPLY(CAR(FORM),EVLIS(CDR(FORM),A),A) 00008320
EVNA SAVE A CAR(FORM) 00008330
L Q,EVLSV+4 00008340
SAVE Q ALIST 00008350
L A,EVLSV 00008360
L A,CDR(A) 00008370
BAL 2,EVLIS 00008380
UNSAVE Q 00008390
ST Q,ARGS 00008400
LR Q,A 00008410
UNSAVE A 00008420
BAL 2,APPLY 00008430
B RETURN 00008440
EJECT 00008450
*********************************************************************** 00008460
******************* APPLY(FN,ARGS,A) RECURSIVE ******************* 00008470
*********************************************************************** 00008480
APPLY SAVE 2 00008490
APPLYY CR A,NILR 00008500
BE RETURN IF FN=NIL RETURN NIL 00008510
NTAP EQU * 00008520
TM CAR(A),ATOM IS FN ATOM 00008530
BZ APPNATM NO 00008540
STM A,Q,TAPPL SAVE ARGS 00008550
LA Q,EXPR 00008560
BAL 2,GET 00008570
CR A,NILR 00008580
BE APNEXPR LIST WASNT AN EXPR 00008590
* APPLY(---,ARGS) 00008600
L Q,TAPPL+4 PUT ARGS IN Q 00008610
TM TRACEIND,X'01' TEST FOR TRACING 00008620
BNO APPLYY NO, CALL APPLY 00008630
ST A,EVLSV SAVE EXPR ADR. 00008640
L A,TAPPL GET FUNCTION 00008650
SAVE A SAVE IT 00008660
TM 0(A),X'01' SHOULD IT BE TRACED 00008670
BNO NOTR5A NO 00008680
ST Q,PVARG SAVE ARGS IN I/O ROUTINE 00008690
BAL 2,PRARG WRITE FUNCTIONS AND ARGS. 00008700
L Q,TAPPL+4 RESTORE ARGS. 00008710
NOTR5A L A,EVLSV RESTORE EXPR ADR 00008720
BAL 2,APPLY CALL APPLY 00008730
UNSAVE M UNSAVE FUNCTION 00008740
TM 0(M),X'01' SHOULD IT BE TRACED 00008750
BNO RETURN NO 00008760
ST A,TAPPL SAVE VALUE 00008770
ST A,PVARG ALSO IN I/O ROUTINES 00008780
LR A,M PUT FUNCTION IN A 00008790
BAL 2,PRVAL WRITE FUNCTION AND VALUES 00008800
L A,TAPPL RESTORE VALUE RETURN 00008810
B RETURN 00008820
APNEXPR LA Q,SUBR TRY SUBR 00008830
L A,TAPPL 00008840
BAL 2,GET 00008850
CR A,NILR 00008860
BE APNSUBR NOT A SUBR 00008870
L Q,ALIST 00008880
SAVE Q 00008890
L Q,ARGS ITS A SUBR 00008900
ST Q,ALIST SET UP ALIST 00008910
LR 14,A ADDR OF SUBR 00008920
L A,TAPPL+4 00008930
BAL 2,SPREAD RETURNS ARG CNT IN REG 1 00008940
TM TRACEIND,X'01' TEST FOR TRACING 00008950
BNO EXSUBR NO 00008960
L M,TAPPL GET FUNCTION 00008970
SAVE M SAVE IT 00008980
TM 0(M),X'01' SHOULD IT BE TRACED 00008990
BNO NOTR6A NO 00009000
ST 14,EVLSV SAVE SUBR. ADR. 00009010
ST 1,EVLSV+4 SAVE ARG. CT. 00009020
STM A,Q,GARBT 00009030
L A,TAPPL+4 00009040
ST A,TAPPL SAVE ARGS 00009050
ST A,PVARG ALSO IN I/O ROUTINE 00009060
LR A,M PUT FUNCTION IN A 00009070
BAL 2,PRARG WRITE FUNCTION AND ARGS. 00009080
L 14,EVLSV RESTORE SUBR ADR. 00009090
L 1,EVLSV+4 RESTORE ARG CNT. 00009100
LM A,Q,GARBT 00009110
NOTR6A STC 1,*+5 00009120
CLI 0(14),X'00' 00009130
BE APNOERR 00009140
LM A,Q,TAPPL 00009150
BL SUBRER 00009160
B SUBRERO 00009170
APNOERR L 14,0(14) ROUTINE ADR. 00009180
BALR 2,14 00009190
UNSAVE M UNSAVE FUNCTION 00009200
UNSAVE Q 00009210
ST Q,ALIST 00009220
TM 0(M),X'01' SHOULD IT BE TRACED 00009230
BNO RETURN NO 00009240
ST A,TAPPL STORE VALUE 00009250
ST A,PVARG ALSO IN I/O ROUTINE 00009260
LR A,M PUT FUNCTION IN A 00009270
BAL 2,PRVAL WRITE FUNCTION AND VALUE 00009280
L A,TAPPL RESTORE VALUE 00009290
B RETURN 00009300
EXSUBR STC 1,*+5 00009310
CLI 0(14),X'00' 00009320
BE EXSUBRB 00009330
LM A,Q,TAPPL 00009340
BL SUBRER 00009350
SUBRERO ERROR ' *** F3-TOO FEW ARGUMENTS-SUBR' 00009360
SUBRER ERROR ' *** F2-TOO MANY ARGUMENTS-SUBR' 00009370
EXSUBRB L 14,0(14) ROUTINE ADR. 00009380
BALR 2,14 00009390
UNSAVE Q 00009400
ST Q,ALIST 00009410
B RETURN 00009420
* APPLY(CDR(SASSOC(FN,A,U)),ARGS,A) 00009430
APNSUBR L Q,ARGS 00009440
L A,TAPPL 00009450
LA 1,ERRA2 00009460
BAL 2,SASSOC 00009470
L A,CDR(A) 00009480
L Q,TAPPL+4 00009490
B APPLYY 00009500
APPNATM L 14,CAR(A) 00009510
LA 15,LABEL TRY LABEL 00009520
CR 14,15 00009530
BE APLBL A LABEL 00009540
LA 15,FUNARG TRY FUNARG 00009550
CR 14,15 00009560
BE APFUN YES 00009570
LA 15,LAMBDA TRY LAMBDA 00009580
CR 14,15 00009590
BE APLAM ITS LAMBDA 00009600
* APPLY(EVAL(FN,A),ARGS,A) 00009610
SAVE Q 00009620
L Q,ARGS ASSOC LIST 00009630
SAVE Q 00009640
BAL 2,EVAL 00009650
UNSAVE Q 00009660
ST Q,ARGS 00009670
UNSAVE Q 00009680
B APPLYY 00009690
* APPLY(CADDR(FN),ARGS,CONS(CONS(CADR(FN),CADDR(FN)),A)) 00009700
APLBL SAVE Q PROCESS LABEL 00009710
L Q,CDR(A) 00009720
L A,CAR(Q) CADR 00009730
L Q,CDR(Q) CDDR 00009740
L Q,CAR(Q) CADDR 00009750
SAVE Q 00009760
BAL 2,CONS 00009770
L Q,ARGS 00009780
BAL 2,CONS 00009790
ST A,ARGS 00009800
UNSAVE A CADDR 00009810
UNSAVE Q ARGS 00009820
B APPLYY 00009830
* APPLY(CADR(FN),ARGS,CADDR(FN)) 00009840
APFUN L A,CDR(A) 00009850
L 14,CDR(A) CDDR 00009860
L 14,CAR(14) CADDR 00009870
ST 14,ARGS 00009880
L A,CAR(A) CADR 00009890
B APPLYY 00009900
* EVAL(CADDR(FN),NCONC(PAIR(CADR(FN),ARGS),A)) 00009910
APLAM L A,CDR(A) LAMBDA 00009920
ST A,TAPPL 00009930
L A,CAR(A) CADR 00009940
BAL 2,PAIR 00009950
L Q,ARGS 00009960
BAL 2,NCONC 00009970
LR Q,A 00009980
L A,TAPPL 00009990
L A,CDR(A) 00010000
L A,CAR(A) 00010010
MVI PROGIND,0 SET OFF FOR LAMBDA EXPR 00010020
BAL 2,EVAL 00010030
B RETURN 00010040
ERRA2 ERROR ' *** A2-FUNCTION NOT DEFINED' 00010050
EJECT 00010060
*********************************************************************** 00010070
******************* EVCON(C,A) RECURSIVE ************************ 00010080
*********************************************************************** 00010090
EVCON SAVE 2 00010100
SAVE A EXTRA SAVE IN CASE OF COND ERROR 00010110
EVCONN CR A,NILR 00010120
BE EVERA3 00010130
C NILR,CAR(,A)
BE EVNIL SKIP NIL
* EVAL(CAAR(C),A) 00010140
O A,PROGIND SAVE PROGIND ALSO 00010150
SAVE A 00010160
SAVE Q 00010170
L A,CAR(,A)
L A,CAR(,A) CAAR
BAL 2,EVAL 00010200
LR M,A 00010210
UNSAVE Q 00010220
UNSAVE A 00010230
LR 1,A 00010240
SRL 1,24 00010250
STC 1,PROGIND 00010260
CR M,NILR 00010270
BNE EVCE 00010280
* EVCON(CDR(C),A) 00010290
EVNIL L A,CDR(,A)
B EVCONN 00010310
* EVAL(CADAR(C),A) 00010320
EVCE L A,CAR(A) 00010330
L A,CDR(A) CADR 00010340
L A,CAR(A) CADAR 00010350
BAL 2,EVAL 00010360
UNSAVE 1 EXTRA SAVE WASNT NEEDED 00010370
B RETURN 00010380
EVERA3 UNSAVE A PRINT ORIGINAL LIST 00010390
TM PROGIND,X'01' IF PROG ITS OK 00010400
BO RETURN 00010410
CONDER ERROR ' *** A3-NO ARGS OF COND TRUE' 00010420
EJECT 00010430
*********************************************************************** 00010440
******************* EVLIS(M,A) RECURSIVE *********************** 00010450
*********************************************************************** 00010460
EVLIS CR A,NILR NIL LIST 00010470
BE 0(2) 00010480
SAVE 2 00010490
LR 1,NILR 00010500
EVLISS SAVE A 00010510
SAVE Q 00010520
SAVE 1 00010530
L A,CAR(A) 00010540
BAL 2,EVAL 00010550
LR Q,NILR 00010560
BAL 2,CONS 00010570
LR Q,A 00010580
UNSAVE A 00010590
BAL 2,NCONC 00010600
LR 1,A 00010610
UNSAVE Q 00010620
UNSAVE A 00010630
L A,CDR(A) 00010640
CR A,NILR 00010650
BNE EVLISS 00010660
LR A,1 00010670
B RETURN 00010680
EJECT 00010690
*********************************************************************** 00010700
******************* GET(X,Y) NON REC ************************ 00010710
********************************************************************** 00010720
* SEARCH LIST X FOR ITEM Y, RETURN CAR OF REST OF LIST, ELSE NIL 00010730
GET CR A,NILR IS X NIL 00010740
BCR 8,2 YES, EXIT 00010750
C Q,CAR(,A) COMPARE Y TO CAR(X).
L A,CDR(,A)
BNE GET
L A,CAR(,A)
BR 2 00010800
EJECT 00010810
*********************************************************************** 00010820
******************* SASSOC(X,Y,U) NON REC ************************ 00010830
*********************************************************************** 00010840
* SEARCHES LIST Y OF DOTTED PAIRS FOR X IN CAR, RET PTR TO PAIR 00010850
* INTERNAL ENTRY POINT SASSOC - R1 IS ERROR MACRO ADDRESS 00010860
* LISP ENTRY POINT SASSOCC - U IS ERROR FUNCTION 00010870
INER DC X'00' INTERNAL CALL TO SASSOC 00010880
DBIND DC X'00' ON IF DEBUG TRACING 00010890
SASSOC MVI INER,X'01' 00010900
STM A,Q,ERSV IN CASE OF SASSOC ERROR 00010910
B SASSOCC+4 00010920
SASSOCC MVI INER,X'00' 00010930
LR M,Q 00010940
SASSOCS CR M,NILR 00010950
BE SASSER 00010960
LM Q,M,CAR(M) 00010970
C A,CAR(,Q)
BNE SASSOCS 00010990
LR A,Q 00011000
BR 2 00011010
SASSER TM INER,X'01' 00011020
BO SINER INTRNAL CALL 00011030
L A,ARGS 00011040
L Q,ALIST 00011050
ST Q,ARGS 00011060
LR Q,NILR 00011070
B APPLY 00011080
SINER LM A,Q,ERSV 00011090
BR 1 00011100
EJECT 00011110
*********************************************************************** 00011120
******************* PAIR(X,Y) NON REC ************************ 00011130
*********************************************************************** 00011140
* PAIR FORMS LIST ((XN YN)...(X1 Y1)) FROM LISTS X AND Y 00011150
TA EQU 14 POINTS AT X LIST 00011160
TQ EQU 15 POINTS AT Y LIST 00011170
PAIR STM A,Q,GARBT+4 IN CASE OF GARB COLLN 00011180
ST 2,PSV 00011190
LR TA,A 00011200
LR TQ,Q 00011210
LR M,NILR LINK OF NEW LIST 00011220
PAIRR CR TA,NILR 00011230
BE PANIL END OF X LIST 00011240
CR TQ,NILR 00011250
BE PQNIL END OF Y LIST 00011260
L A,CAR(TA) 00011270
L Q,CAR(TQ) 00011280
BAL 2,CONS (XN.YN) 00011290
LR Q,M LAST LINK IN LIST 00011300
BAL 2,CONS ADD TO LIST 00011310
LR M,A 00011320
L TA,CDR(TA) 00011330
L TQ,CDR(TQ) 00011340
B PAIRR 00011350
PANIL L 2,PSV 00011360
CR TQ,NILR 00011370
BE 0(2) BOTH A AND Q NIL 00011380
LM A,Q,GARBT+4 00011390
ERROR ' *** F2-TOO MANY ARGUMENTS-EXPR' 00011400
PQNIL LM A,Q,GARBT+4 00011410
ERROR ' *** F3-TOO FEW ARGUMENTS-EXPR' 00011420
EJECT 00011430
*********************************************************************** 00011440
******************* APPEND(X,Y) NON REC ******************$$$ 00011450
********************************************************************** 00011460
* FORM LIST (X Y) FROM LISTS X AND Y 00011470
* NCONC(COPY(X),Y) 00011480
APT DC F'0' 00011490
APPEND ST 2,APT 00011500
APPEND2 EQU * 00011510
CR A,NILR A NIL 00011520
BE APXNIL YES 00011530
ST Q,GARBT HOLD Q 00011540
LM A,Q,CAR(A) MAKE NEW X LIST 00011550
BAL 2,CONS 00011560
LR M,A SAVE NEW LIST 00011570
APAGN CR Q,NILR AT END 00011580
BE APDN YES 00011590
LR 1,A HOLD A A SEC 00011600
LM A,Q,CAR(Q) NEXT CELL 00011610
BAL 2,CONS 00011620
ST A,CDR(1) LINK IT 00011630
B APAGN 00011640
APDN L Q,GARBT 00011650
ST Q,CDR(A) LINK ON Y 00011660
LR A,M 00011670
B EPX 00011680
APXNIL LR A,Q RETURN Y 00011690
EPX L 2,APT 00011700
BR 2 00011710
******************* APPEND1(X,Y) ** SUBR ************************* 00011720
* NCONC(X,CONS(Y,NIL)) 00011730
APPEND1 LR 1,2 00011740
LR M,A 00011750
LR A,Q 00011760
LR Q,NILR 00011770
BAL 2,CONS 00011780
LR Q,A 00011790
LR A,M 00011800
LR 2,1 00011810
B NCONC 00011820
EJECT 00011830
*********************************************************************** 00011840
******************* SPREAD(X) NON REC ***************** 00011850
********************************************************************** 00011860
* PUTS ELEMENTS OF LIST X INTO ARG CELLS. 00011870
* REG1 RETURNS NUMBER OF ARGUMENTS FOUND, MAX IS 22. 00011880
SPREAD SR 1,1 ZERO THE ARGUMENT COUNT.
CR A,NILR IS LIST EMPTY?
BER 2 YES -- RETURN NIL.
LR 0,A SAVE X, IN CASE OF ERROR.
LM A,Q,CAR(A) GET 1ST ARG.
LA 1,1(,1) COUNT IT.
CR Q,NILR JUST ONE ARG?
BER 2 YES -- RETURN.
LM Q,M,CAR(Q) NO; GET 2ND ARG.
LA 1,1(,1) COUNT IT.
CR M,NILR ANY MORE ARGS?
BER 2 NO -- RETURN.
SLA 1,2
SPRNXT C 1,=F'88' MORE THAN 22 ARGS?
BNL SPERR YES -- ERROR.
L 15,CAR(,M) GET NEXT ARG.
ST 15,ARGS-8(1) STORE IT.
L M,CDR(,M)
AR 1,K4 INCREMENT INDEX.
CR M,NILR ANY MORE ON LIST?
BNE SPRNXT YES.
SRA 1,2 NO; CONVERT INDEX TO COUNT.
BR 2 RETURN.
SPERR LR A,0 RESTORE X.
ERROR ' *** A7-MORE THAN 22 ARGS' 00012140
EJECT 00012150
*********************************************************************** 00012160
******************* NCONC(X,Y) NON REC ************************** 00012170
*********************************************************************** 00012180
* JOINS LIST X TO LIST Y 00012190
NCONC LR 1,A 00012200
CR A,NILR 00012210
BNE NCA 00012220
LR A,Q 00012230
BR 2 00012240
NCC L 1,CDR(,1)
NCA C NILR,CDR(,1)
BNE NCC 00012270
ST Q,CDR(1) 00012280
BR 2 00012290
*********************************************************************** 00012300
******************* ATTRIB(X,E) NON REC ************************* 00012310
*********************************************************************** 00012320
* PUTS LIST E ON END OF LIST X, RETURNS E 00012330
ATTRIB ST Q,GARBT 00012340
LR 15,2 00012350
BAL 2,NCONC 00012360
L A,GARBT 00012370
BR 15 00012380
EJECT 00012390
*********************************************************************** 00012400
******************* PROG((X1,X2,...),A) REC ********************* 00012410
*********************************************************************** 00012420
PROGIND DC F'0' PROG SWITCH 00012430
PROG SAVE 2 00012440
ST A,PROGT HOLD PRGM 00012450
SAVE A SAVE IT WHILE WE EVALUATE IT 00012460
ST NILR,GOLIST 00012470
* PUT PROG VARIABLES ON ALIST 00012480
ST Q,ALIST 00012490
L A,CAR(A) 00012500
PROGV CR A,NILR AT NIL 00012510
BE PROGA YES 00012520
LR M,A SAVE A 00012530
L A,CAR(A) VARIABLE 00012540
LR Q,NILR 00012550
BAL 2,CONS PAIR IT TO NIL 00012560
L Q,ALIST 00012570
BAL 2,CONS ADD TO ALIST 00012580
ST A,ALIST 00012590
L A,CDR(M) NEXT VAR 00012600
B PROGV 00012610
PROGA L A,PROGT 00012620
* BUILD GOLIST 00012630
PROGL L M,CDR(A) 00012640
CR M,NILR END OF PROG 00012650
BE PROGE YES 00012660
L A,CAR(M) TRY FOR LABEL 00012670
TM CAR(A),ATOM LABEL 00012680
BO PROGY YES 00012690
LR A,M RESET A 00012700
B PROGL TRY AGAIN 00012710
PROGY L Q,CDR(M) ADDR OF PGM STMT 00012720
BAL 2,CONS 00012730
L Q,GOLIST 00012740
BAL 2,CONS LINK INTO GOLIST 00012750
ST A,GOLIST 00012760
LR A,M RESET A 00012770
B PROGL FIND NEXT LABEL 00012780
* BEGIN EXECUTION OF PROG 00012790
PROGE L Q,PROGT START OF PROGM 00012800
PROGEX L Q,CDR(Q) FIRST STMT 00012810
CR Q,NILR AT END 00012820
LR A,NILR 00012830
BE PEX END OF PROG LIST 00012840
L A,CAR(Q) -A- HAS PTR TO STMT 00012850
TM CAR(A),ATOM IS NEXT PGM STMT A LABEL 00012860
BO PROGEX YES SKIP OVER IT 00012870
MVI PROGIND,X'01' SET IND ON 00012880
SAVE Q SAVE PTR TO REST OF PGM 00012890
L Q,GOLIST 00012900
SAVE Q SAVE GOLIST 00012910
L Q,ALIST 00012920
SAVE Q SAVE ALIST 00012930
BAL 2,EVAL EVAL STMT 00012940
* NOTE AT THIS POINT (PROGR) IS ADDR IN STACK- USED IN GO & RET 00012950
PROGR UNSAVE Q 00012960
ST Q,ALIST 00012970
UNSAVE Q 00012980
ST Q,GOLIST 00012990
UNSAVE Q REST OF PGM 00013000
B PROGEX NEXT STMT 00013010
EJECT 00013020
SPECBIND ST 3,PVARG 00013030
DROP 3 00013040
LA 3,BASE3 00013050
USING BASE3,3 00013060
B SPECBIN1 00013070
SPECRSTR ST 3,PVARG 00013080
DROP 3 00013090
LA 3,BASE3 00013100
USING BASE3,3 00013110
B SPECRST1 00013120
* ==================================================================== 00013130
* ====== END OF BASE 11 SECTION ==================================== 00013140
EJECT 00013150
* ==================================================================== 00013160
* ====== BEGINNING OF BASE 12 SECTION ============================== 00013170
* ====== THE INSTRUCTIONS AND CONSTANTS IN THE BEGINNING =========== 00013180
* ====== OF THIS SECTION ARE USED BY LAPASSEMBLED PROGRAMS ===== 00013190
* ====== THEIR POSITION RELATIVE TO THE BEGGINNING OF THIS ===== 00013200
* ====== SECTION IS FIXED AND MUST NOT BE CHANGED ============== 00013210
CNOP 0,4 00013220
BASE12 EQU * 00013230
B ERG2 0(12) 00013240
B CALL 4(12) 00013250
DC A(ARGS) 8(12) 00013260
DC A(BOTTOM) 12(12) 00013270
B LSTCMP 16(12) 00013280
B SPECBIND 20(12) 00013290
B SPECRSTR 24(12) 00013300
B CONDER 28(12) 00013310
B FUNCTIO2 32(12) 00013320
B EVAL 36(12) 00013330
B COMBIND 40(12) 00013340
B COMRSTR 44(12) 00013350
B RTRN 48(12) 00013360
B MOVIT 52(12) 00013370
B LINK 56(12) 00013380
EJECT 00013390
*********************************************************************** 00013400
********* CALL ******************************************************** 00013410
*********************************************************************** 00013420
CALL SAVE 3 00013430
DROP 3 00013440
LA 3,BASE3 RESET BASE 3 00013450
USING BASE3,3 00013460
SAVE 15 00013470
SAVE 2 00013480
L 1,0(0,2) 00013490
BAL 2,0(NILR,1) 00013500
CALLEXIT UNSAVE 2 00013510
UNSAVE 15 00013520
UNSAVE 3 00013530
B 8(2) 00013540
LINK SAVE 3 00013550
SAVE 15 00013560
SAVE 2 00013570
DROP 3 00013580
LA 3,BASE3 00013590
USING BASE3,3 00013600
B LINK1 00013610
MOVIT ST 3,PVARG 00013620
DROP 3 00013630
LA 3,BASE3 00013640
USING BASE3,3 00013650
B MOVIT1 00013660
FUNCTIO2 STM 2,3,PVARG 00013670
DROP 3 00013680
LA 3,BASE3 00013690
USING BASE3,3 00013700
BAL 2,FUNCTIO1 00013710
LM 2,3,PVARG 00013720
BR 2 00013730
COMBIND ST 3,PVARG 00013740
DROP 3 00013750
LA 3,BASE3 00013760
USING BASE3,3 00013770
B COMBIND1 00013780
COMRSTR ST 3,PVARG 00013790
DROP 3 00013800
LA 3,BASE3 00013810
USING BASE3,3 00013820
B COMRSTR1 00013830
LSTCMP ST 3,PVARG 00013840
DROP 3 00013850
LA 3,BASE3 00013860
USING BASE3,3 00013870
B LSTCMP1 00013880
EJECT 00013890
*********************************************************************** 00013900
******************* GO(X) FSUBR ******************************* 00013910
*********************************************************************** 00013920
ERA6 ERROR ' ***A6-UNDEF LABEL IN GO' 00013930
GO LA 1,PROGR 00013940
GOL UNSAVE 15 SCAN DOWN STACK FOR EVAL 00013950
LA 15,0(,15) STRIP OFF BITS FOR COMPARE 00013960
CR 15,1 00013970
BNE GOL R14 HAS RET ADDR -DONT LOSE IT 00013980
UNSAVE Q ALIST 00013990
ST Q,ALIST 00014000
UNSAVE Q 00014010
ST Q,GOLIST 00014020
UNSAVE M REST OF PGM, NOT NEEDED 00014030
L A,CAR(A) CAR(X) 00014040
LA 1,ERA6 00014050
BAL 2,SASSOC FIND ON ASSOC LIST 00014060
LR Q,A
B PROGEX
*********************************************************************** 00014200
******************* RETURN(X) ** SUBR ********************* 00014210
*********************************************************************** 00014220
GORET LA 1,PROGR 00014230
GORR UNSAVE Q 00014240
LA Q,0(,Q) STRIP BITS 00014250
CR 1,Q 00014260
BNE GORR 00014270
UNSAVE Q ALIST 00014280
UNSAVE Q GOLIST 00014290
UNSAVE Q PGM 00014300
PEX UNSAVE Q PROG 00014310
MVI PROGIND,0 00014320
B RETURN EXIT FROM PROG 00014330
EJECT 00014340
*********************************************************************** 00014350
********* READCH(X) SUBR ******************************************* 00014360
*********************************************************************** 00014370
* READCH GIVES CHROBJ READ IF ARGUMENT IS NIL, OTHERWISE 00014380
* READCH WILL BACKSPACE: BACKSPACE MUST BE DONE ONLY ONCE AT 00014390
* A TIME, AND ONLY AFTER READCH HAVE BEEN EXECUTED 00014400
BACKSPAC DC X'00' 00014410
READCHTP DC 2F'0' 00014420
LASTREAD DC A(BLANK,BLANK) 00014430
READCH CR A,NILR IF ARG IS TRUE READCH SHOULD 00014440
* BACKSPACE 00014450
BE READCH1 OTHERWISE PICK NEXT CAR 00014460
OI BACKSPAC,X'01' SET BACKSPACE MARKER 00014470
L A,LASTREAD VALUE IS CHR JUST IN FRONT 00014480
* OF CHAR JUST READ 00014490
BR 2 00014500
READCH1 L A,LASTREAD+4 PICK UP CHROBJ JUST READ 00014510
TM BACKSPAC,X'01' IS BACKSPACE MARKER SET 00014520
BO READCH2 YES 00014530
ST A,LASTREAD OTHERWISE REMEMBER CHROBJ 00014540
* JUST READ 00014550
TM EOFIND,X'FF' END-OF-FILE FLAG ON?
BZ *+14 NO.
LA A,ATEOF YES; GIVE EOF ATOM.
ST A,LASTREAD+4
BR 2
STM 2,3,READCHTP STORE R2 AND R3 = CHAR 00014560
L CHAR,LASTCHAR 00014570
OI READCHID,X'01' SAY IS READCH FOR EOF PROCESSOR
LTR CHAR,CHAR IS THERE A CHARACTER YET?
BNZ *+8 YES.
BAL 2,GETCD NO; START AN INPUT RECORD.
IC Q,0(CHAR) 00014580
N Q,=X'0000003F' 00014590
M A,=F'24' 00014600
LA A,CHROBJ(Q) 00014610
ST A,LASTREAD+4 00014620
BAL 2,GETCHAR PICK UP NEXT CHAR 00014640
READCH3 NI READCHID,X'00'
ST CHAR,LASTCHAR 00014660
LM 2,3,READCHTP 00014670
BR 2 00014680
READCH2 NI BACKSPAC,X'00' 00014690
BR 2 00014700
EJECT 00014710
*********************************************************************** 00014720
********* FIX SUBR NON RECURS ************************************* 00014730
*********************************************************************** 00014740
* FIX MAKES AN INTEGER OUT OF A FLOATING POINT NUMBER 00014750
* RETURNS INTEGER 0 IF ALL SIGNIFICANCE IS LOST 00014760
FIXIT SWR 0,0
L A,CAR(,A)
LE 0,CAR(,A) GET FLOATING-POINT VALUE.
AW 0,NZERO TAKE THE INTEGER PART.
STD 0,STORE STORE IT.
L A,STORE+4 TAKE THE LOW-ORDER PART.
BNM *+6 SKIP IF NOT NEGATIVE.
LCR A,A COMPLEMENT NEGATIVE VALUES.
LR 14,2
B MKFXAT MAKE A FIXED ATOM.
STORE DC D'0' 00015030
*********************************************************************** 00015040
********* EXPLODE SUBR NON RECURS ******************************* 00015050
*********************************************************************** 00015060
* EXPLODE MAKES A LIST OF CHAR IN ATOM'S PRINTNAME 00015070
EXPLODE ST 2,PVARG 00015080
ST NILR,GARBT 00015090
L 15,CAR(A) 00015100
EXPL2 SR 14,14 00015110
EXPL1 SR Q,Q 00015120
SR M,M 00015130
IC Q,CAR(14,15) 00015140
CR Q,M 00015150
BE EXPLEXIT 00015160
N Q,=X'0000003F' 00015170
M A,=F'24' 00015180
LA Q,CHROBJ(Q) 00015190
L A,GARBT 00015200
BAL 2,APPEND1 00015210
ST A,GARBT 00015220
LA 14,1(0,14) 00015230
CR 14,K4 00015240
BL EXPL1 00015250
EXPLODE1 L 15,CDR(15) 00015260
LA 15,0(0,15) 00015270
CR 15,NILR 00015280
BNE EXPL2 00015290
EXPLEXIT L 2,PVARG 00015300
L A,GARBT 00015310
BR 2 00015320
*********************************************************************** 00015330
********* GENSYM SUBR NON RECURS ********************************* 00015340
*********************************************************************** 00015350
GENSYMBL DC C'0000' 00015360
GENSYMSK DC XL6'21202020202020' 00015370
GENSYMNR DC F'0' 00015380
GENSYM ST 2,PVARG 00015390
L Q,GENSYMNR 00015400
AH Q,=H'1' 00015410
ST Q,GENSYMNR 00015420
CVD Q,GARBTM2 00015430
MVC NEWGENSM(8),GENSYMSK-3 00015440
ED NEWGENSM(8),GARBTM2+5 00015450
SR 1,1 00015460
SR M,M 00015470
SR Q,Q 00015480
MVC NEWGENSM(4),GENSYMBL 00015490
L A,CAR(A) 00015500
GENSYM2 IC Q,CAR(1,A) PICK UP CHAR 00015510
CR Q,M IS IT BLANK 00015520
BE GENSYM1 00015530
STC Q,NEWGENSM(1) 00015540
LA 1,1(0,1) 00015550
CR 1,K4 00015560
BL GENSYM2 00015570
GENSYM1 L A,NEWGENSM+4 00015580
LR Q,NILR 00015590
BAL 2,CONS 00015600
LR Q,A 00015610
MVI CDR(A),FWD 00015620
L A,NEWGENSM 00015630
BAL 2,CONS 00015640
MVI CDR(A),FWD 00015650
LR Q,NILR 00015660
BAL 2,CONS 00015670
MVI CAR(A),ATOM 00015680
L 2,PVARG 00015690
BR 2 00015700
EJECT 00015710
********************************************************************** 00015720
********* PRARG *** PRVAL ******************************************* 00015730
*********************************************************************** 00015740
PRARG STM 2,3,PVARG+4 STORE 2 AND 3 00015750
MVC LINE(18),TROUT1 SET UP TO WRITE FUNCTION 00015760
LA P,LINE+18 00015770
BAL 2,PUTATOM 00015780
BAL 2,WRLINE WRITE FUNCTION 00015790
L A,PVARG SET UP TO WRITE ARGUMENTS 00015800
BAL 2,PRINT WRITE ARGUMENTS 00015810
LM 2,3,PVARG+4 00015820
BR 2 RETURN 00015830
TROUT1 DC C'0*** ARGUMENTS OF ' 00015840
TROUT2 DC C'0*** VALUE OF ' 00015850
PVARG DC 3F'0' 00015860
PRVAL STM 2,3,PVARG+4 00015870
MVC LINE(14),TROUT2 00015880
LA P,LINE+14 00015890
BAL 2,PUTATOM 00015900
BAL 2,WRLINE 00015910
L A,PVARG 00015920
BAL 2,PRINT 00015930
LM 2,3,PVARG+4 RESTORE 2 AND 3 00015940
BR 2 00015950
*********************************************************************** 00015960
********** ORDERP ************************************************** 00015970
*********************************************************************** 00015980
ORDERP CR A,Q COMPARE ARG1 TO ARG2 00015990
BNH ORDERT 00016000
LR A,NILR ARG1<ARG2 THEN FALSE 00016010
BR 2 00016020
ORDERT LA A,T TRUE RETURN 00016030
BR 2 00016040
EJECT 00016050
*********************************************************************** 00016060
************ RLIT(CH) SUBR NON RECURS ***************************** 00016070
*********************************************************************** 00016080
RLIT TM ATOMIND,X'80' ATOMIND SET 00016090
BO RLIT1 YES 00016100
MVC CHARATA+4(16),ZERO 00016110
MVC CHARATA+20(ATMSZ-12),CHARATA+4
SR 0,0 00016130
STH 0,CHARATA 00016140
NI ATOMIND,X'00' 00016150
OI ATOMIND,X'82' 00016160
RLIT1 LA 1,CHARATA SCANAREA 00016170
STOLIT IC 0,8(,A) PICK UP CHAR 00016180
STOLITT LH 15,0(1) CURRENT LENGTH OF ATOM 00016190
CH 15,2(1) ATMAX 00016200
BL RLIT2 NO 00016210
OI ERRIND,X'04' ATOM IS TRUNCATED 00016220
BR 2 00016230
RLIT2 STC 0,4(1,15) STORE CHAR 00016240
LA 0,1(,15) INCREASE CHR COUNT 00016250
STH 0,0(1) 00016260
BR 2 00016270
*********************************************************************** 00016280
************ RNUMB(CH) SUBR NON RECURS ***************************** 00016290
*********************************************************************** 00016300
RNUMB TM ATOMIND,X'80' ATOMIND SET 00016310
BO RNUMB1 YES 00016320
NI ATOMIND,X'00' 00016330
OI ATOMIND,X'C0' NO NITIALIZE 00016340
SR 0,0 00016350
MVC DIGATA+4(16),CHZERO INITIALIZATION 00016360
STH 0,DIGATA 00016370
STH 0,EXPA 00016380
ST 0,EXPA+4 00016390
STH 0,EXP 00016400
RNUMB1 CLI 8(A),C'0' 00016410
BL CKNUMB 00016420
CLI 8(A),C'9' 00016430
BH RNUMBERR 00016440
TM ATOMIND,X'10' EXPIND SET 00016450
BZ RNUMB6 NO 00016460
LA 1,EXPA YES SET POINTER 00016470
B STOLIT 00016480
RNUMB6 TM ATOMIND,X'20' FLOATIND SET 00016490
BZ RNUMB7 NO 00016500
LH 1,EXP 00016510
BCTR 1,0 00016520
STH 1,EXP 00016530
RNUMB7 TM ATOMIND,X'10' 00016540
BZ RNUMB9 00016550
LA 1,EXPA 00016560
B STOLIT 00016570
RNUMB9 LA 1,DIGATA 00016580
B STOLIT 00016590
CKNUMB CLI 8(A),C'+' IS IT PLUS 00016600
BE 0(2) YES 00016610
CLI 8(A),C'-' IS IT MINUS 00016620
BNE RNUMB2 NO 00016630
TM ATOMIND,X'10' YES WAS EXPIND SET 00016640
BZ RNUMB3 NO 00016650
OI ATOMIND,X'08' YES SET NEGEXPONENT IND 00016660
BR 2 00016670
RNUMB3 OI ATOMIND,X'04' SET NEG NUMBER ON 00016680
BR 2 00016690
RNUMB2 CLI 8(A),C'.' IS IT DOT 00016700
BNE RNUMB4 NO 00016710
OI ATOMIND,X'20' SET FLOATIND 00016720
BR 2 00016730
RNUMB4 TM ATOMIND,X'20' 00016740
BO RNUMB8 00016750
CLI 8(A),C'A' 00016760
BL RNUMBERR 00016770
CLI 8(A),C'F' 00016780
BH CKLOGX 00016790
OI ATOMIND,X'02' 00016800
MVC NUMBFLD(1),8(A) 00016810
TR NUMBFLD(1),TABL1-193 00016820
LA 1,DIGATA 00016830
SR 0,0 00016840
IC 0,NUMBFLD 00016850
B STOLITT 00016860
RNUMB8 CLI 8(A),C'E' 00016870
BNE CKLOGX 00016880
OI ATOMIND,X'10' 00016890
BR 2 00016900
CKLOGX CLI 8(A),C'X' 00016910
BNE RNUMBERR 00016920
OI ATOMIND,X'12' 00016930
BR 2 00016940
RNUMBERR OI ERRIND,X'01' 00016950
NI ATOMIND,X'00' 00016960
BR 2 00016970
*********************************************************************** 00016980
************ MKATOM() SUBR NON RECURS ***************************** 00016990
*********************************************************************** 00017000
ATOMPOIN DC F'0' 00017010
MKATOM ST 2,RESAV 00017020
TM ERRIND,X'01' 00017030
BZ TRNCERR 00017040
PUTMSG SYNTAXMS 00017050
T5 BC 0,STOP 00017060
TRNCERR TM ERRIND,X'04' WAS ATOM TRUNCATED 00017070
BZ MKATOM1 NO 00017080
PUTMSG TRUNCMSG YES SAY SO 00017090
T6 BC 0,STOP 00017100
NI ERRIND,X'00' 00017110
MKATOM1 LA 2,MKATOM2 00017120
ST 2,ATMSV2 00017130
MVI LINKS+3,CAR 00017140
MVI ATOMEQ+3,CAR 00017150
LA A,ATOMPOIN 00017160
B ALLATOM 00017170
MKATOM2 L A,CAR(A) 00017180
NI ATOMIND,X'00' 00017190
L 2,RESAV 00017200
BR 2 00017210
TRUNCMSG DC AL2(30),C' *** R5-NAME OR NUMBER TOO LONG' 00017220
DC XL1'00' 00017230
SYNTAXMS DC AL2(19),C' *** R1-SYNTAX ERROR' 00017240
EJECT 00017250
*********************************************************************** 00017260
******************* SET(X,Y) NON REC *************************** 00017270
*********************************************************************** 00017280
* SETS X=Y ON ALIST 00017290
SETSV DC 2F'0' 00017300
SET ST 2,SETSV 00017310
ST Q,SETSV+4 00017320
LA 1,ERA5 00017330
L Q,ALIST 00017340
BAL 2,SASSOC 00017350
LM 1,2,SETSV 00017360
ST 2,CDR(A) 00017370
LR A,2 00017380
BR 1 00017390
ERA5 ERROR ' ***A5-SET VARIABLE UNDEF' 00017400
*********************************************************************** 00017410
******************* SETQ(X,A) REC ******************************** 00017420
*********************************************************************** 00017430
SETQ SAVE 2 00017440
LA 2,SET 00017450
SETC SAVE 2 COMMON FOR SETQ & CSETQ 00017460
SAVE A ARG LIST 00017470
SAVE Q ALIST 00017480
L A,CDR(A) 00017490
L A,CAR(A) 00017500
BAL 2,EVAL 00017510
UNSAVE Q 00017520
ST Q,ALIST 00017530
LR Q,A 00017540
UNSAVE A 00017550
L A,CAR(A) 00017560
UNSAVE 1 00017570
UNSAVE 2 00017580
BR 1 00017590
*********************************************************************** 00017600
******************* CSET(OB,VAL) NON REC ************************ 00017610
*********************************************************************** 00017620
* PUT VAL AS AN APVAL ON PROPERTY LIST OF OB 00017630
CSET TM CAR(A),ATOM SHOULD BE ATOM 00017640
BZ 0(2) ISNT 00017650
ST 2,PVARG 00017660
STM A,Q,GARBT 00017670
LA Q,APVAL 00017680
BAL 2,FLAGP 00017690
CR A,NILR 00017700
BE CSET1 00017710
L A,CDR(A) 00017720
L A,CAR(A) 00017730
L Q,GARBT+4 00017740
ST Q,CAR(A) 00017750
L A,GARBT 00017760
L 2,PVARG 00017770
BR 2 00017780
CSET1 LM A,Q,GARBT 00017790
L 1,PVARG 00017800
LR M,A HOLD A 00017810
LR A,Q 00017820
LR Q,NILR 00017830
BAL 2,CONS 00017840
L Q,CDR(M) 00017850
BAL 2,CONS 00017860
LR Q,A 00017870
LA A,APVAL SET IND 00017880
BAL 2,CONS 00017890
ST A,CDR(M) LINK TO ATOM 00017900
L A,GARBT 00017910
BR 1 EXIT 00017920
CSETQ SAVE 2 00017930
LA 2,CSET 00017940
B SETC 00017950
EJECT 00017960
*********************************************************************** 00017970
******************** REMPROP(X,IND) NON REC ********************* 00017980
*********************************************************************** 00017990
* SEARCH LIST X FOR INDICATOR IND, WHEN FOUND REMOVE IT AND 00018000
* FOLLOWING PROPERTY FROM LIST 00018010
REMPROP CR A,NILR NIL LIST 00018020
BE REX 00018030
L 1,CDR(A) 00018040
CR 1,NILR NO INDICATORS 00018050
BE REX 00018060
C Q,CAR(1) CHECK IND 00018070
BE RFND FOUND 00018080
L A,CDR(1) CONT SEARCH 00018090
B REMPROP 00018100
RFND L 1,CDR(1) FOUND IND 00018110
CR 1,NILR NO PROP 00018120
BE REX 00018130
L 1,CDR(1) EXISE IND & PROP 00018140
ST 1,CDR(A) 00018150
B REMPROP TRY FOR MORE 00018160
REX LR A,NILR 00018170
BR 2 EXIT 00018180
EJECT 00018190
*********************************************************************** 00018200
******************* DEFINE(X) NON REC **************************** 00018210
*********************************************************************** 00018220
DEFINE LA Q,EXPR 00018230
B DEFLIST 00018240
*********************************************************************** 00018250
******************* DEFLIST(X,IND) NON REC ********************* 00018260
*********************************************************************** 00018270
DEFLIST ST 2,PVARG 00018280
LR 0,Q 00018290
ST NILR,GARBT+4 DEFINE BEGINNING OF NEW LIST 00018300
DAGN ST A,GARBT 00018310
L A,CAR(A) NEXT DEFINITION ON LIST 00018320
L 14,CDR(A) FIND NEW PROPERTY 00018330
L 14,CAR(14) 00018340
L A,CAR(A) FIND ATOM NAME 00018350
LR 15,A AND PUT IT ASIDE 00018360
BAL 2,FLAGP IS IND. ALREADY ON PROPERTYLIST 00018370
CR A,NILR 00018380
BE DAGN1 NO GO TO DAGN1 00018390
L A,CDR(A) YES INSERT NEW PROPERTY 00018400
ST 14,CAR(A) 00018410
B DAGN2 00018420
DAGN1 L Q,CDR(15) SET UP PROPERTY ON PROPERTYLIST 00018430
LR A,14 00018440
BAL 2,CONS 00018450
LR Q,A 00018460
LR A,0 00018470
BAL 2,CONS 00018480
ST A,CDR(15) LINK INTO ATOM 00018490
DAGN2 L A,GARBT+4 CONSTRUCT LIST THAT IS 00018500
LR Q,15 IS VALUE OF DEFLIST 00018510
BAL 2,APPEND1 00018520
ST A,GARBT+4 00018530
L A,GARBT 00018540
L A,CDR(A) REST OF LIST 00018550
CR A,NILR AT END OF LIST ? 00018560
BNE DAGN NO 00018570
L A,GARBT+4 00018580
L 2,PVARG 00018590
BR 2 00018600
EJECT 00018610
*********************************************************************** 00018620
******************* ADD1 * SUB1 * MINUS SUBR ******************** 00018630
*********************************************************************** 00018640
ADD1 SR M,M SET ADD SWITCH 00018650
B ASM1 00018660
SUB1 LR M,K4 SET SUB1 SW 00018670
B ASM1 00018680
MINUS LA M,8 00018690
ASM1 LR 14,2 HOLD 2 00018700
TM CAR(A),FLOAT 00018710
BO ASMFL 00018720
TM CAR(A),FIX 00018730
BO ASMFX 00018740
ARITHER ERROR ' *** I3-BAD ARITH ARG' 00018750
ASMFX L A,CAR(A) 00018760
L A,CAR(A) 00018770
EX 0,ASMFXT(M) 00018780
MKFXAT LR Q,NILR 00018790
BAL 2,CONS 00018800
MVI CDR(A),FWD 00018810
BAL 2,CONS 00018820
MVI CAR(A),FIX SET ATOM TYPE 00018830
BR 14 00018840
ASMFXT AH A,=H'1' ADD1 00018850
SH A,=H'1' SUB1 00018860
LCR A,A -X 00018870
ASMFL L A,CAR(A) 00018880
LE 0,CAR(A) 00018890
EX 0,ASMFLT(M) 00018900
MKFLAT LR Q,NILR MAKE FLOAT ATOM 00018910
BAL 2,CONS 00018920
STE 0,CAR(A) 00018930
MVI CDR(A),FWD 00018940
BAL 2,CONS 00018950
MVI CAR(A),FLOAT 00018960
BR 14 00018970
ASMFLT AE 0,=E'1.' ADD1. 00018980
SE 0,=E'1.' SUB1. 00018990
LCER 0,0 -X 00019000
DPA DC D'0' 00019010
DPAA DC D'0' 00019020
NZERO DC X'4E',7X'00' NORMAL ZERO 00019030
*********************************************************************** 00019040
******************* PLUS * TIMES FSUBR ************************ 00019050
*********************************************************************** 00019060
PLUS SR M,M SET PLUS SW 00019070
B PLTI 00019080
TIMES LR M,K4 SET TIMES SW 00019090
PLTI SAVE 2 00019100
SAVE M 00019110
BAL 2,EVLIS EVAL ARGS 00019120
UNSAVE M 00019130
SR 15,15 SET FIXPT SW 00019140
LR 1,M 00019150
SRA 1,2 SET FOR MULT OR ADD 00019160
LR Q,A 00019170
PTLOOP CR Q,NILR END OF LIST 00019180
BE PTDONE YES 00019190
LM A,Q,CAR(Q) 00019200
LTR 15,15 TEST MODE 00019210
BNZ PTFLOAT FLOAT MODE 00019220
TM CAR(A),FLOAT 00019230
BO PTFL 00019240
TM CAR(A),FIX 00019250
BNO ARITHER BAD NUMBER 00019260
L A,CAR(A) 00019270
EX 0,INTI(M) 00019280
B PTLOOP 00019290
INTI A 1,CAR(A) 00019300
M 0,CAR(A) 00019310
PTFL BAL 2,FLOAT1 00019320
LR 15,K4 SET FLOAT SW 00019330
PTFFL L A,CAR(A) 00019340
MVC DPAA(4),CAR(A) MOVE INTO DP AREA 00019350
EX 0,FLTI(M) 00019360
B PTLOOP 00019370
FLTI AD 0,DPAA 00019380
MD 0,DPAA 00019390
PTFLOAT TM CAR(A),FLOAT 00019400
BO PTFFL FLOAT MODE & FLOAT NO. 00019410
TM CAR(A),FIX 00019420
BO PTFINT INTEGER ENCOUNTERED 00019430
B ARITHER 00019440
PTFINT L A,CAR(A) 00019450
L 1,CAR(A) 00019460
LDR 2,0 00019470
BAL 2,FLOAT1 00019480
EX 0,FLTII(M) 00019490
B PTLOOP 00019500
FLTII ADR 0,2 00019510
NOPR 0 00019520
MDR 0,2 00019530
PTDONE UNSAVE 14 00019540
LTR 15,15 00019550
BNZ MKFLAT 00019560
LR A,1 00019570
B MKFXAT 00019580
FLOAT1 MVI DPA,X'4E' SWITCH FIX REG1 TO FLOAT REG0 00019590
LTR 1,1 00019600
BNM *+10 00019610
LCR 1,1 00019620
MVI DPA,X'CE' NEG EXP 00019630
ST 1,DPA+4 00019640
LD 0,DPA 00019650
AD 0,ZERO 00019660
BR 2 00019670
*********************************************************************** 00019680
******************* DIFFERENCE * QUOTIENT SUBR ****************** 00019690
*********************************************************************** 00019700
DIFF SR M,M SET DIFF SW 00019710
B DIQ 00019720
QUOTIENT LR M,K4 SET QU SW 00019730
DIQ LR 14,2 HOLD 2 FOR MFXAT, MKFLAT 00019740
BAL 2,GLIP 00019750
B MKFXAT FIXED RESULT 00019760
B MKFLAT FLOAT 00019770
GLIP LR 15,2 COMPUTE DIFF OR QUOTIENT 00019780
TM CAR(A),FLOAT 00019790
BO XFLT 00019800
TM CAR(A),FIX X INTEGER 00019810
BNO ARITHER NO 00019820
TM CAR(Q),FLOAT 00019830
BO XYM 00019840
TM CAR(Q),FIX X INT, TRY Y 00019850
BNO ARITHER NO 00019860
L A,CAR(A) 00019870
L 1,CAR(Q) 00019880
L A,CAR(A) 00019890
SRDA A,32 00019900
EX 0,DQB(M) 00019910
LR A,Q 00019920
BR 15 FIX RET 00019930
DQB S Q,CAR(1) 00019940
D A,CAR(1) 00019950
XFLT TM CAR(Q),FLOAT Y FLOAT 00019960
BO XYFLT 00019970
TM CAR(Q),FIX X FLOAT, TRY Y 00019980
BNO ARITHER NO 00019990
LR 1,Q X FLOAT, Y INTEGER 00020000
LR Q,A SWITCH A&Q 00020010
LR A,1 00020020
LA M,8(,M) 00020030
LA 2,DPAA 00020040
B MIXED 00020050
XYFLT L A,CAR(A) X,Y FLOAT 00020060
L Q,CAR(Q) 00020070
LE 0,CAR(A) 00020080
EX 0,DQT(M) 00020090
B 4(15) FLOAT RET 00020100
DQT SE 0,CAR(Q) 00020110
DE 0,CAR(Q) 00020120
XYM LA 2,DPA X INT, Y FLOAT 00020130
MIXED L A,CAR(A) 00020140
L Q,CAR(Q) 00020150
L 1,CAR(A) 00020160
SRL M,1 00020170
L 1,CAR(A) 00020180
BAL 2,FLOAT1 00020190
LE 2,CAR(Q) 00020200
EX 0,MTA(M) 00020210
EX 0,MTA+8(M) 00020220
B 4(15) FLOAT RET 00020230
MTA SDR 0,2 00020240
DDR 0,2 00020250
SDR 2,0 00020260
DDR 2,0 00020270
NOPR 0 00020280
NOPR 0 00020290
LDR 0,2 00020300
LDR 0,2 00020310
*********************************************************************** 00020320
******************* REMAINDER(X Y) *** SUBR ********************** 00020330
*********************************************************************** 00020340
* FIXPT REM(X/Y) 00020350
* FLOAT X-INTEGER(X/Y)*Y 00020360
REMAIND LR 14,2 00020370
TM CAR(A),FIX 00020380
BNO ARITHER 00020390
TM CAR(Q),FIX 00020400
BNO ARITHER 00020410
TM CAR(A),FLOAT 00020420
BO REMXFL X FLOAT 00020430
TM CAR(Q),FLOAT 00020440
BO REMXY X FIX, Y FLOAT 00020450
L A,CAR(A) COMPUTE MOD 00020460
L Q,CAR(Q) 00020470
L 0,CAR(A) 00020480
SRDA 0,32 00020490
D 0,CAR(Q) 00020500
LR A,0 00020510
B MKFXAT 00020520
REMXFL TM CAR(Q),FLOAT 00020530
BO REMXYF X,Y FLOAT 00020540
L Q,CAR(Q) X FLOAT, Y FIX 00020550
L 1,CAR(Q) 00020560
BAL 2,FLOAT1 FLOATED INTO FR0 00020570
LDR F2,F0 00020580
L A,CAR(A) 00020590
LE F0,CAR(A) 00020600
B AMOD 00020610
REMXY L A,CAR(A) X FIX, Y FLOAT 00020620
L 1,CAR(A) 00020630
BAL 2,FLOAT1 FLOAT INTO F0 00020640
L Q,CAR(Q) 00020650
LE F2,CAR(Q) 00020660
B AMOD 00020670
REMXYF L A,CAR(A) X, Y FLOAT 00020680
LE F0,CAR(A) 00020690
L Q,CAR(Q) 00020700
LE F2,CAR(Q) 00020710
AMOD LER F4,F0 00020720
DER F0,F2 00020730
LD F6,ZERO 00020740
LER F6,F0 EXPAND TO DP 00020750
LDR F0,F6 00020760
AW F0,NZERO INTEGERIZE IT 00020770
AD F0,ZERO NORMALIZE 00020780
MER F0,F2 00020790
SER F4,F0 00020800
LER F0,F4 00020810
B MKFLAT 00020820
*********************************************************************** 00020830
******************* ZEROP *** MINUSP *** SUBRS ********** 00020840
******************************************************************* 00020850
*** ZEROP(X) T IF X.EQ.0 OR ABS(X).GT. 1.E-6 00020860
*** MINUSP(X) T IF X.LT.0 00020870
ZEROP LR M,K4 00020880
B ZMP 00020890
MINUSP SR M,M SET MINUSP 00020900
ZMP TM CAR(A),FLOAT 00020910
BO ZMFLT 00020920
TM CAR(A),FIX 00020930
BNO ARITHER 00020940
L A,CAR(A) 00020950
MFP L A,CAR(A) 00020960
LTR A,A 00020970
LR A,NILR 00020980
EX 0,ZMBR+6(M) 00020990
LA A,T 00021000
BR 2 00021010
ZMFLT L A,CAR(A) 00021020
LE 0,CAR(A) 00021030
EX 0,ZMBR(M) TEST SIGN 00021040
SE 0,FTOL 00021050
LR A,NILR 00021060
BNM 0(2) 00021070
LA A,T 00021080
BR 2 00021090
ZMBR B MFP 00021100
LPER 0,0 00021110
BNM 0(2) 00021120
BNZ 0(2) 00021130
*********************************************************************** 00021140
******************* LESSP *** GREATERP *** SUBRS *********** 00021150
******************************************************************* 00021160
**** LESSP(X,Y) T IF X-Y.LT.0 00021170
**** GREATERP(X,Y) T IF X-Y.GT.0 00021180
LESSP ST 2,ERSV 00021190
SR M,M DIFF SW 00021200
SR 14,14 LESSP SW 00021210
B TKDIF TAKE DIFFERENCE 00021220
GREATERP ST 2,ERSV 00021230
SR M,M 00021240
LR 14,K4 SET GP SW 00021250
TKDIF BAL 2,GLIP 00021260
B GLFX FIXED 00021270
GLFL LTER 0,0 00021280
L 2,ERSV 00021290
LR A,NILR 00021300
EX 0,GLFC(14) 00021310
LA A,T 00021320
BR 2 00021330
GLFX LTR A,A 00021340
B GLFL+2 00021350
GLFC BNM 0(2) 00021360
BNP 0(2) 00021370
EJECT 00021380
*********************************************************************** 00021390
********** EXPT ***************************************************** 00021400
*********************************************************************** 00021410
R4 EQU 15 00021420
EXPT STM 2,3,PVARG 00021430
TM 0(Q),FLOAT 00021440
BM EXPT1 00021450
ERROR ' *** I8-EXPT CANNOT TAKE REAL EXPONENT' 00021460
EXPT1 TM 0(A),FLOAT 00021470
BM EXPT2 00021480
LA R14,EXPTEXT1 00021490
SDR F4,F4 00021500
L A,CAR(A) 00021510
LE F4,0(A) 00021520
L Q,CAR(Q) 00021530
L R4,0(Q) 00021540
LD F0,XEXPLIT 00021550
MVI XEXPSW1,X'2C' 00021560
LTR R4,R4 00021570
BH XEXP21 00021580
BL XEXP69 00021590
LTER F4,F4 00021600
BCR 7,R14 00021610
B XERREX2 00021620
XEXP69 MVI XEXPSW1,X'2D' 00021630
LPR R4,R4 00021640
LTER F4,F4 00021650
BNZ XEXP21 00021660
B XERREX3 00021670
XEXP11 MDR F4,F4 00021680
XEXP21 EX R4,XEXPTM 00021690
BZ XEXP31 00021700
XEXPSW1 MDR F0,F4 00021710
XEXP31 SRA R4,1 00021720
BH XEXP11 00021730
BR 14 00021740
EXPT2 TM 0(A),FIX 00021750
BM ARITHER 00021760
TM 0(Q),FIX 00021770
BM ARITHER 00021780
LA R14,EXPTEXT2 00021790
L A,CAR(A) 00021800
L R2,0(A) 00021810
L Q,CAR(Q) 00021820
L R4,0(Q) 00021830
SRDA R2,32 00021840
LA R1,1 00021850
SR R0,R0 00021860
MVI XEXPSW+1,X'F0' 00021870
LTR R4,R4 00021880
BH XEXP2 00021890
BL XEXP6 00021900
LTR R3,R3 00021910
BCR 7,R14 00021920
XERREX2 ERROR ' *** I5-ATTEMPT TO RAISE 0 TO 0' 00021930
XEXP6 MVI XEXPSW+1,X'00' 00021940
LPR R4,R4 00021950
LTR R3,R3 00021960
BNZ XEXP2 00021970
XERREX3 ERROR ' *** I6-ATTEMPT TO RAISE 0 TO NEGATIVE POWER' 00021980
XEXP1 MR R2,R3 00021990
XEXP2 EX R4,XEXPTM 00022000
BZ XEXP3 00022010
MR R0,R3 00022020
XEXP3 SRA R4,1 00022030
BH XEXP1 00022040
XEXPSW BC 0,0(,R14) 00022050
BAL 2,FLOAT1 00022060
LE F2,=E'1.' 00022070
DER F2,F0 00022080
LER F0,F2 00022090
EXPTEXT1 BAL R14,MKFLAT 00022100
B EXPTEXIT 00022110
EXPTEXT2 LR A,R1 00022120
BAL R14,MKFXAT 00022130
EXPTEXIT LM 2,3,PVARG 00022140
LA K4,4 00022150
BR 2 00022160
XEXPTM TM XTEST,X'00' 00022170
XTEST DC X'01' 00022180
EJECT 00022190
*********************************************************************** 00022200
******************* ERROR ***************************** 00022210
********************************************************************** 00022220
ERRORR SR Q,Q PRINT A ONLY 00022230
ST A,ERRARG SAVE ERROR'S ARG.
CR A,NILR IS IT NIL?
BNE ERRPRNT NO -- PRINT
C NILR,ERRSET HAS ERRORSET BEEN CALLED?
BNE ERDAN YES -- NO PRINT.
C NILR,ERRSET+4 CHECK THE 2ND ARG.
BE ERDAN NIL -- NO PRINT.
ERRPRNT DS 0H
PUTMSG ' *** A1-CALL TO ERROR' 00022240
BAL 2,PRINT PRINT ERROR'S ARGUMENT 00022250
B ERDAN 00022260
ERRSET DC A(NIL,0) ARGS TO ERRORSET
ERRARG DC A(NIL) ARG TO ERROR
ERSV DC 2F'0' 00022270
ERRORIND DC 2X'00' 00022280
ERROR EQU * 00022290
STM 13,1,WRSV 00022300
ST NILR,ERRARG SET ARG TO NIL.
TM ERRORIND,2 IS IT FATAL ERROR?
BO *+12 YES -- PRINT.
C NILR,ERRSET+4 IS 2ND ARG NIL?
BE ERDAN YES -- NO PRINT.
BAL 2,PUTMSG PRINT THE ERROR 00022310
ST Q,ERSV 00022320
BAL 2,ERCK 00022330
L A,ERSV PRINT Q LIST 00022340
BAL 2,ERCK 00022350
TM ERRORIND,X'01' 00022360
BO ERDN NO PDS 00022370
PUTMSG '0*** TRACE-BACK FOLLOWS' 00022380
ERNXT CL PDS,PUSHA 00022390
BE ERDN 00022400
UNSAVE A 00022410
BAL 2,ERCK 00022420
B ERNXT 00022430
ERDN EQU * 00022440
TM ERRORIND,X'02' 00022450
T3 BO STOP 00022460
ERDAN MVI ERRORIND,X'00' SET OFF 00022470
T4 BC 0,STOP 00022480
DROP 3 00022500
ERRPU LA 3,BASE3
USING BASE3,3 00022520
LA K4,4 00022530
MVC LINE,BLANKS
L PDS,ERRSET RESTORE PDS.
L A,ERRARG GET RETURN VALUE.
CR PDS,NILR ERRORSET CALLED?
BNE ERRRET YES.
L PDS,PUSHA NO; RESET PDS.
B AGN 00022560
ERCK LR 0,A
BAS 14,CKADDR
BZR 2
ST 2,ERSV+4 00022640
MVI LINE+1,C'*' 00022650
BAL 2,PRINT 00022660
L 2,ERSV+4 00022670
BR 2 00022680
ERRORSET L M,ALIST
SAVE M SAVE ALIST.
LM 0,1,ERRSET
SAVE 0 SAVE OLD PDS.
SAVE 1 SAVE OLD SWITCH.
SAVE 2 SAVE RETURN.
ST PDS,ERRSET NEW PDS PTR.
ST Q,ERRSET+4 NEW SWITCH.
LR Q,M ALIST.
BAL 2,EVAL EVALUATE 1ST ARG.
LR Q,NILR MAKE IT A LIST.
BAL 2,CONS
ERRRET UNSAVE 2 RETURN ADRS.
UNSAVE 1 SWITCH.
UNSAVE 0 PDS.
STM 0,1,ERRSET RESTORE PDS AND SWITCH.
UNSAVE M ALIST.
ST M,ALIST
BR 2 RETURN
EJECT 00022690
*********************************************************************** 00022700
************** TABLES USED IN READ AND PRINT, THEY HAD TO BE 00022710
* MOVED BECAUSE THE SECTION COVERED BY BASEREGISTER 13 WAS FULL 00022720
* WHILE MORE HAD TO BE ADDED TO THAT VERY SECTION 00022730
GARBSW DC X'01' VERBOS SWITCH 00022740
BUFFPR DC X'00' 00022750
NUMBFLD DC X'00' 00022760
EOFIND DC X'00' 00022770
READCHID DC X'00' 00022780
CNOP 0,8 00022790
DOUBLCST DC XL8'4000000080000000' 00022800
DTRA DC X'401DA48CE468E7C7' 1 00022810
DC X'404504787C5F878A' 2 00022820
DC X'40A0B19D2AB70E6E' 3 00022830
DC X'40256A18DD89E626' 4 00022840
DC X'40571CBEC554B60D' 5 00022850
DC X'40CAD2F7F5359A3B' 6 00022860
DC X'402F394219248446' 7 00022870
DC X'406DF37F675EF6EA' 8 00022880
DC X'40FFFFFFFFFFFFFF' 9 00022890
DC X'403B9AC9FFFFFFFE' 10 00022900
DC X'408AC7230489E800' 11 00022910
DC X'40204FCE5E3E2502' 12 00022920
DC X'404B3B4CA85A86C4' 13 00022930
DC X'40AF298D050E4395' 14 00022940
DC X'4028C87CB5C89A25' 15 00022950
DC X'405EF4A74721E864' 16 00022960
DTRB DC X'40B877AA3236A4B4' 1 00022970
DC X'40734ACA5F6226F0' 2 00022980
DC X'40480EBE7B9D5856' 3 00022990
DC X'402D09370D425736' 4 00023000
DC X'401C25C268497681' 5 00023010
DC X'40AFEBFF0BCB24AA' 6 00023020
DC X'406DF37F675EF6EA' 7 00023030
DC X'4044B82FA09B5A52' 8 00023040
DC X'402AF31DC4611873' 9 00023050
DTRBH DC H'-17,-16,-15,-14,-13,-11,-10,-9,-8' 00023060
PCK1 PACK CHARATA+4(8),EXPA+4(1) 00023070
PCK2 PACK CHARATA+4(8),DIGATA+4(1) 00023080
PCK3 PACK CHARATA+12(8),0(1,14) 00023090
PCK PACK DIGATA+12(8),DIGATA+4(1) 00023100
PCKK PACK DIGATA+12(8),EXPA+4(1) 00023110
CTBL DC D'1.,.1,1.E-2,1.E-3,1.E-4,1.E-5,1.E-6,1.E-7,1.E-8' 00023120
DC D'1.E-9,1.E-10,1.E-11,1.E-12,1.E-13,1.E-14,1.E-15' 00023130
XEXPLIT EQU CTBL 00023140
DTBL DC D'1.E64,1.E48,1.E32,1.E16,1.,1.E-16,1.E-32,1.E-48' 00023150
DC D'1.E-64' 00023160
ADBASE4 DC A(BASE4) 00023170
CHKPCHK DC C'5313' MDDY
DC CL4'CHKP' 00023190
CHKREG DC 2F'0' 00023200
TABL1 DC X'FAFBFCFDFEFF' TRANSLATE TABLE FOR LOGINP 00023210
CHZERO DC 16C'0' CONSTANT USED IN FLOATINP 00023220
CNOP 0,8 00023230
ZERO DC 4F'0' 00023240
PATCH DS 10F PATCH AREA
CNOP 4,8
CHARATA DC H'0',Y(ATMSZ),CL(ATMSZ+4)' ' CHAR ATOM SCAN AREA
CARDOUT DC 80CL1' ' 00023270
*********************************************************************** 00023280
* ====== END OF BASE 12 SECTION ==================================== 00023290
* ==================================================================== 00023300
EJECT 00023310
* ==================================================================== 00023320
* ====== BEGINNING OF BASEREGISTER 3 SECTION. INSIDE THIS ========== 00023330
* ====== SECTION REGISTER 3 MAY NEVER BE USED. ================= 00023340
* ====== NO ROUTINES USING REGISTER 3 AS A WORK REGISTER ======= 00023350
* ====== MAY CALL ROUTINES INSIDE THIS SECTION. ================ 00023360
*********************************************************************** 00023370
********** REMFLAG(X,Y) ******************************************* 00023380
*********************************************************************** 00023390
**** REMOVE ALL OCCURANCES OF FLAG Y FROM ATOMS ON LIST X 00023400
REMFLAG CR A,NILR NIL LIST OR FINISHED ? 00023410
BASE3 EQU REMFLAG 00023420
BE 0(2) BRANCH IF YES 00023430
L 15,CDR(A) 15 MOVES THROUGH LIST 00023440
L M,CAR(A) M MOVES THROUGH ATOM 00023450
REMFNXF L 14,CDR(M) POINT 14 TO NEXT ELEMENT 00023460
CR 14,NILR AT END OF ATOM ? 00023470
BE REMFNXE GET NEXT LIST ELEMENT IF YES 00023480
L 14,CAR(14) POINT 14 TO FLAG 00023490
CR 14,Q DOES FLAG = Q ? 00023500
BE REMFND BRANCH IF YES 00023510
L M,CDR(M) MOVE M FORWARD IN ATOM 00023520
B REMFNXF GO BACK, LOOK AT NEXT FLAG 00023530
REMFND L 14,CDR(M) MOVE 14 TO POINT TO 00023540
L 14,CDR(14) ELEMENT AFTER MATCH 00023550
IC 1,4(M) * = CALL RPLACD(M,14) * 00023560
ST 14,CDR(M) * I.E. REMOVE FLAG FROM * 00023570
STC 1,4(M) * THE ATOM * 00023580
B REMFNXF GO BACK, LOOK AT NEXT FLAG 00023590
REMFNXE LR A,15 MOVE TO NEXT LIST ELEMENT 00023600
B REMFLAG GO BACK AND START OVER 00023610
EJECT 00023620
*********************************************************************** 00023630
******************* DEBUG(IND) NON REC ************************* 00023640
********************************************************************** 00023650
* IND IS T OR NIL FOR DEBUG OUTPUT 00023660
DEBUG MVI DBIND,X'00' SET OFF 00023670
CR A,NILR 00023680
BE 0(2) 00023690
OI DBIND,X'01' SET ON 00023700
BR 2 00023710
*********************************************************************** 00023720
******************* TRACE(X) NON REC ******************** 00023730
*********************************************************************** 00023740
TRACEE MVI TRACEIND,X'01' 00023750
TRACE1 L Q,CAR(A) 00023760
OI 0(Q),X'01' 00023770
L A,CDR(A) 00023780
CR A,NILR 00023790
BNE TRACE1 00023800
BR 2 00023810
*********************************************************************** 00023820
******************* UNTRACE(X) NON REC ******************** 00023830
*********************************************************************** 00023840
UNTRACE L Q,CAR(A) 00023850
NI 0(Q),X'FE' 00023860
L A,CDR(A) 00023870
CR A,NILR 00023880
BNE UNTRACE 00023890
BR 2 00023900
EJECT 00023910
*********************************************************************** 00023920
********** MAX AND MIN ********************************************* 00023930
********************************************************************** 00023940
MAX SR M,M 00023950
B MAXMNTR 00023960
MIN LR M,K4 00023970
MAXMNTR SAVE 2 00023980
SAVE M 00023990
BAL 2,EVLIS 00024000
UNSAVE Q 00024010
L 15,CAR(A) 00024020
TM 0(15),FIX IS IT A NUMBER ? 00024030
BNO ARITHER NP, ERROR 00024040
TM 0(15),FLOAT IS IT FLOATING ? 00024050
BNO MAXFX NO, DO FIXED ARITHEMETIC 00024060
L 15,CAR(15) YES, GET ADDR. OF NO. 00024070
LE 2,CAR(15) PUT NO. IN FLT. PT. REG. 2 00024080
B MAXFLT GO DO FLOAT ARITHMETIC 00024090
MAXFX L 15,CAR(15) PUT NO. IN REG. 15 00024100
L 15,CAR(15) 00024110
MAXAGN L A,CDR(A) GET NEXT ELEMENT 00024120
CR A,NILR AT END OF LIST ? 00024130
BNE MAXFXTS NO, TEST NUMBER 00024140
LR A,15 YES, PUT RESULT IN A 00024150
UNSAVE 14 RESTORE RETURN ADDR. TO 14 00024160
B MKFXAT GO MAKE A FIXED PT. ATOM 00024170
MAXFXTS L M,CAR(A) GET ELEMENT 00024180
TM 0(M),FIX IS IT A NUMBER ? 00024190
BNO ARITHER NO, ERROR 00024200
TM 0(M),FLOAT IS IT FLOATING PT. ? 00024210
BNO MAXSTAY NO, CONTINUE FIXED 00024220
LR 1,15 PUT CURRENT VALUE IN REG. 1 00024230
BAL 2,FLOAT1 CONVERT TO FLOATING PT. 00024240
LER 2,0 PUT IN FLT. PT. REG. 2 00024250
L M,CAR(M) 00024260
LE 0,CAR(M) PUT NO. IN FLT. PT. REG. 0 00024270
B MAXSKIP1 GO INTO FLOAT PART 00024280
MAXSTAY L M,CAR(M) PUT NUMBER IN M 00024290
L M,CAR(M) 00024300
CR M,15 COMPARE 00024310
EX 0,MAXMIN1(Q) BNL,BNH TO MAXAGN FOR MAX,MIN RESP. 00024320
LR 15,M CHANGE CURRENT VALUE 00024330
B MAXAGN GO TRY NEXT ELEMENT 00024340
MAXFLT L A,CDR(A) GET NEXT ELEMENT 00024350
CR A,NILR FINISHED ? 00024360
BNE MAXFSTAY NO, CONTINUE 00024370
LER 0,2 YES, PUT RESULT IN FLT. PT. REG. 2 00024380
UNSAVE 14 RESTORE RETURN ADDR. TO 14 00024390
B MKFLAT GO MAKE A FLT. PT. ATOM 00024400
MAXFSTAY L M,CAR(A) GET ELEMENT 00024410
TM 0(M),FIX IS IT A NUMBER ? 00024420
BNO ARITHER NO, ERROR 00024430
TM 0(M),FLOAT IS IT FLT. PT. ? 00024440
BO MAXFYES YES, CONTINUE 00024450
L 1,CAR(M) NO, CONVERT TO FLT. PT. 00024460
L 1,CAR(1) 00024470
BAL 2,FLOAT1 00024480
B MAXSKIP1 00024490
MAXFYES L M,CAR(M) 00024500
LE 0,CAR(M) 00024510
MAXSKIP1 CER 0,2 COMPARE 00024520
EX 0,MAXMIN2(Q) BNL,BNH TO MAXFLT FOR MAX,MIN RESP. 00024530
LER 2,0 CHANGE CURRENT VALUE 00024540
B MAXFLT GO BACK FOR MORE 00024550
MAXMIN1 BNH MAXAGN - EXECUTED INSTRUCTIONS - 00024560
BNL MAXAGN 00024570
MAXMIN2 BNH MAXFLT 00024580
BNL MAXFLT 00024590
EJECT 00024600
*********************************************************************** 00024610
********** PLANT,PLANT1,PLANTDC *************************************** 00024620
*********************************************************************** 00024630
PLANT1 LR 0,NILR SET INITIAL ENTRY FLAG 00024640
B PLANTT 00024650
PLANTB NOPR 1 DUMMY 00024660
PLANTDC LA 0,0 SET DC ENTRY FLAG 00024670
B PLANTT 00024680
PLANTSQ SR A,NILR 00024690
ST A,PLANTCON+4 00024700
LA 1,PLANTCON+4 00024710
LA 0,0 00024720
L M,0(Q) 00024730
L M,0(M) 00024740
B PLANTSK 00024750
PLANT LA 0,1 SET NORMAL ENTRY FLAG 00024760
PLANTT L M,0(Q) SAVE THE LENGTH IN M 00024770
L M,0(M) 00024780
L 1,CAR(A) SAVE INSTR. 00024790
PLANTSK ST 2,PVARG SAVE RETURN ADDR. 00024800
LA Q,APVAL GET(BPS,APVAL) 00024810
LA A,BPS 00024820
BAL 2,GET 00024830
L A,CAR(A) 00024840
LM 14,15,0(A) GET NEXT AND LAST AVAIL. BPS 00024850
CR 14,15 OUT OF BPS ? 00024860
BNL PLE1 YES, BRANCH 00024870
LTR 0,0 TEST DC FLAG 00024880
BNZ PLANTI NO, BRANCH 00024890
TM 3(A),X'03' ON FULL WORD BOUNDARY ? 00024900
BZ PLANTI YRS, BRANCH 00024910
MVC 0(2,14),PLANTB INSERT NOPR IN BPS 00024920
LA 14,2(0,14) UPDATE NEXT AVAIL. 00024930
PLANTI MVC 0(4,14),0(1) STORE INST. IN BPS 00024940
CR 0,NILR TEST INITIAL ENTRY FLAG 00024950
BNE PLANTN NO, BRANCH 00024960
LA 15,4090(0,14) 00024970
ST 15,PLANTCON SAVE IT 00024980
PLANTN LA 14,0(M,14) UPDATE NEXT AVAIL. 00024990
C 14,PLANTCON END OF BASE COVERAGE ? 00025000
BH PLE2 YES, BRANCH 00025010
ST 14,0(A) STORE NEXT AVAIL. 00025020
L 2,PVARG RESTORE 2 00025030
BR 2 RETURN 00025040
PLANTCON DC 2F'0' 00025050
PLE1 ERROR ' *** L8-BPS FULL' 00025060
PLE2 ERROR ' *** L9-EXCEEDED MAX. LAP ROUTINE SIZE' 00025070
EJECT 00025080
*********************************************************************** 00025090
******************* ATOM(X) NON REC ************************ 00025100
********************************************************************** 00025110
* RETURN TRUE IF X IS AN ATOM 00025120
ATOMP TM CAR(A),ATOM IS IT AN ATOM 00025130
B LTST 00025140
LOGP TM CAR(A),LOGIC LOGICAL ATOM 00025150
B LTST 00025160
FLOATP TM CAR(A),FLOAT 00025170
B LTST 00025180
* RETURN TRUE IF X IS A NUMERIC ATOM 00025190
NUMBERP TM CAR(A),FIX 00025200
LTST LR A,NILR NO MAYBE 00025210
BNO 0(2) DEFINITLY 00025220
LA A,T IS AN ATOM 00025230
BR 2 00025240
FIXP LR Q,A 00025250
LR A,NILR NO MAYBE 00025260
TM CAR(Q),FIX IS IT NUMERIC 00025270
BNO 0(2) NO 00025280
TM CAR(Q),X'30' NOT FLOAT OR BOOL 00025290
BM 0(2) 00025300
LA A,T ITS FIX 00025310
BR 2 00025320
EVENP TM CAR(A),FIX 00025330
BNO ARITHER 00025340
TM CAR(A),FLOAT 00025350
BO ARITHER 00025360
L A,CAR(A) 00025370
TM 3(A),X'01' 00025380
LR A,NILR 00025390
BCR 1,2 00025400
LA A,T 00025410
BR 2 00025420
EJECT 00025430
*********************************************************************** 00025440
******************* EQUAL(X,Y) NON REC ************************* 00025450
*********************************************************************** 00025460
* RETURNS TRUE IF LIST X EQUALS LIST Y 00025470
EQUAL SAVE 2 SAVE RET 00025480
LR M,A USE Q, M 00025490
LA A,T SET TRUE RET 00025500
EQTST CR M,Q ALL ALPHA EQ 00025510
BE RETURN TRUE YET 00025520
TM CAR(M),ATOM 00025530
BO TSTY YES 00025540
TM CAR(Q),ATOM 00025550
BO RETNIL 00025560
LM 14,15,CAR(M) 00025570
SAVE 15 00025580
LR A,14 00025590
LM 14,15,CAR(Q) 00025600
SAVE 15 00025610
LR Q,14 00025620
BAL 2,EQUAL RECURSIVE ENTRY 00025630
UNSAVE Q 00025640
UNSAVE M 00025650
CR A,NILR 00025660
BE RETURN 00025670
B EQTST 00025680
RETNIL LR A,NILR 00025690
B RETURN 00025700
TSTY TM CAR(Q),FIX 00025710
BNO RETNIL 00025720
TM CAR(M),FIX 00025730
BNO RETNIL 00025740
* X, Y ARE ATOMS, PROBABLY NUMERIC 00025750
LR A,M 00025760
SR M,M SET DIFF SW 00025770
BAL 2,GLIP 00025780
B EQFX FIXED RESULT 00025790
LPER 0,0 00025800
SE 0,FTOL 00025810
BNM RETNIL 00025820
LA A,T 00025830
B RETURN 00025840
EQFX LTR A,A 00025850
BNZ RETNIL 00025860
LA A,T 00025870
B RETURN 00025880
FTOL DC E'1.E-6' TOLERANCE 00025890
EJECT 00025900
*********************************************************************** 00025910
******************* LOGOR * LOGAND * LOGXOR *** FSUBRS ********* 00025920
******************************************************************** 00025930
LOGOR SR M,M SET SW 00025940
B LOGS 00025950
LOGAND LR M,K4 00025960
B LOGS 00025970
LOGXOR LA M,8 00025980
LOGS SAVE 2 00025990
SAVE M 00026000
BAL 2,EVLIS 00026010
UNSAVE M 00026020
UNSAVE 14 00026030
LM A,Q,CAR(A) 00026040
L A,CAR(A) 00026050
L 1,CAR(A) 00026060
LOGLP CR Q,NILR 00026070
BE LEND 00026080
LM A,Q,CAR(Q) 00026090
L A,CAR(A) 00026100
EX 0,LGFN(M) 00026110
B LOGLP 00026120
LGFN O 1,CAR(A) 00026130
N 1,CAR(A) 00026140
X 1,CAR(A) 00026150
LEND LR A,1 00026160
MKLGAT LR Q,NILR 00026170
BAL 2,CONS 00026180
MVI CDR(A),FWD 00026190
BAL 2,CONS 00026200
MVI CAR(A),LOGIC 00026210
BR 14 00026220
*********************************************************************** 00026230
******************* LEFTSHIFT(X,N) ***** SUBR ****************** 00026240
******************************************************************** 00026250
LEFTSHIF LR 14,2 00026260
TM CAR(Q),FIX 00026290
BNO ARITHER 00026300
L A,CAR(A) 00026310
L A,CAR(A) 00026320
L Q,CAR(Q) 00026330
L Q,CAR(Q) 00026340
LTR Q,Q NEG 00026350
BM SHIFTRT 00026360
SLL A,0(Q) 00026370
B MKLGAT 00026380
SHIFTRT LCR Q,Q 00026390
SRL A,0(Q) 00026400
B MKLGAT 00026410
EJECT 00026420
*********************************************************************** 00026430
******************* AND *** OR * FSUBRS ************ 00026440
******************************************************************* 00026450
AND SR M,M SET -AND- SWITCH 00026460
B ANDOR 00026470
OR LR M,K4 00026480
ANDOR SAVE 2 00026490
ATST CR A,NILR END OF LIST 00026500
BE OREXIT(M) 00026510
SAVE Q ALIST 00026520
LM 0,1,CAR(A) 00026530
SAVE 1 REST OF LIST 00026540
SAVE M THE SWITCH 00026550
LR A,0 FUNCTION 00026560
BAL 2,EVAL EVALUATE IT 00026570
LR 0,A HOLD A 00026580
UNSAVE M AND-OR SW 00026590
UNSAVE A REST OF LIST 00026600
UNSAVE Q ALIST 00026610
LR 1,NILR 00026620
CR 0,1 00026630
BE ANDORCNT(M) 00026640
B ANDORCNT+4(M) 00026650
ANDEXIT LR A,NILR 00026660
B ANDE 00026670
OREXIT LA A,T 00026680
ANDE UNSAVE 2 00026690
BR 2 00026700
ANDORCNT B ANDEXIT 00026710
B ATST 00026720
B OREXIT 00026730
*********************************************************************** 00026740
******************* MEMBER(X,Y) NON REC ********************** 00026750
********************************************************************** 00026760
* TEST IF X IS A MEMBER OF LIST Y 00026770
MEMBER ST 2,PVARG 00026780
MEMM STM A,Q,GARBT 00026790
CR Q,NILR 00026800
BNE MEM 00026810
LR A,NILR 00026820
MEMBEXIT L 2,PVARG 00026830
BR 2 00026840
MEM L Q,CAR(Q) 00026850
BAL 2,EQUAL 00026860
CR A,NILR 00026870
BNE MEMBEXIT 00026880
LM A,Q,GARBT 00026890
L Q,CDR(Q) 00026900
B MEMM 00026910
EJECT 00026920
*********************************************************************** 00026930
********* MAPCAR SUBR ********************************************** 00026940
*********************************************************************** 00026950
MAPCAR STC K4,ALIST 00026960
B MAP 00026970
*********************************************************************** 00026980
********** MAPLIST *********** RECURSIVE ********************** 00026990
*********************************************************************** 00027000
**** MAPLIST(X FN) 00027010
MAPLIST SR M,M 00027020
STC M,ALIST 00027030
MAP CR A,NILR 00027040
BCR 8,2 00027050
SAVE 2 SAVE RETURNADDRESS 00027060
ST NILR,GARBT NEW LIST 00027070
ST Q,GARBT+4 SET ASIDE FN 00027080
L M,ALIST 00027090
MAPNEXT SAVE A SAVE ARGUMENT TO FN 00027100
ST M,ARGS 00027110
SAVE M SAVE ALIST 00027120
SAVE Q SAVE FUNCTION 00027130
LR Q,NILR 00027140
SRL M,24 FIND EXECUTE INDEX 00027150
EX 0,MAPINSTR(M) 00027160
BAL 2,CONS MAKE LIST OF FN'S ARGUMENTS 00027170
LR Q,A 00027180
L A,GARBT PICK UP NEW LIST 00027190
SAVE A AND SAVE IT 00027200
L A,GARBT+4 PICK UP FN 00027210
BAL 2,APPLY APPLY FUNCTION TO ARGUMENT 00027220
LR Q,A 00027230
UNSAVE A 00027240
BAL 2,APPEND1 INCREASE NEW LIST 00027250
ST A,GARBT 00027260
UNSAVE Q 00027270
ST Q,GARBT+4 00027280
UNSAVE M 00027290
UNSAVE A 00027300
L A,CDR(A) END OF ARGUMENTS ? 00027310
CR A,NILR 00027320
BNE MAPNEXT NO 00027330
L A,GARBT YES PICK UP NEW LIST 00027340
UNSAVE 2 00027350
BR 2 00027360
MAPINSTR NOP * 00027370
L A,CAR(A) 00027380
EJECT 00027390
*********************************************************************** 00027400
********** FLAG(X,Y) ******************************************** 00027410
*********************************************************************** 00027420
**** INSERT FLAG Y ON ALL ATOMS OF LIST X 00027430
FLAG ST 2,PSV SAVE 2 00027440
LR M,A M MOVES THROUGH LIST 00027450
FLAGBK CR A,NILR NIL LIST OR FINISHED ? 00027460
BE FLAGOUT YES, DONE 00027470
LR A,Q ARG.1 CONS - POINTS TO NEW FLAG 00027480
L Q,CAR(M) SAVE CAR(M) IN Q TO HELP COMPLETE LINKING 00027490
L M,CDR(M) MOVE M FORWARD 00027500
STM A,M,GARBT SAVE A (=OLD Q) , Q , M 00027510
L Q,CDR(Q) ARG.2 CONS - POINTS TO NEXT FLAG 00027520
BAL 2,CONS CALL CONS 00027530
LM Q,M,GARBT+4 RESTORE Q , M 00027540
ST A,CDR(Q) COMPLETES LINKING IN NEW FLAG 00027550
L Q,GARBT RESTORE ORIGINAL Q 00027560
LR A,M PUT POINTER IN A 00027570
B FLAGBK GO TRY NEXT ELEMENT 00027580
FLAGOUT L 2,PSV RESTORE 2 00027590
BR 2 00027600
EJECT 00027610
*********************************************************************** 00027620
********** FLAGP(X,Y) ******************************************** 00027630
*********************************************************************** 00027640
**** IF FLAG Y ON ATOM X RETURN TRUE ELSE RETURN NIL 00027650
FLAGP L A,CDR(A) MOVE FORWARD IN ATOM 00027660
CR A,NILR ANY FLAGS ? 00027670
BE 0(2) NO, THEN RETURN NIL 00027680
L M,CAR(A) PICK UP FLAG 00027690
CR M,Q FLAGS EQUAL ? 00027700
BNE FLAGP NO, THEN GET NEXT FLAG 00027710
BR 2 DONE 00027720
*********************************************************************** 00027730
********* DIGP SUBR NON RECURS ********************************** 00027740
*********************************************************************** 00027750
* DIGP DECIDES WHETHER A CHARACTEROBJECT IS DIGIT OR NOT 00027760
DIGP LR Q,A 00027770
LR A,NILR 00027780
CLI 8(Q),C'0' WITHIN RANGE 00027790
BL 0(2) NO 00027800
CLI 8(Q),C'9' 00027810
BH 0(2) NO 00027820
LA A,T YES 00027830
BR 2 00027840
*********************************************************************** 00027850
********** LITP SUBR NON RECURS *********************************** 00027860
*********************************************************************** 00027870
* LITP(CH)= NOT(OR(BREAKP(CH),DIGP(CH))) 00027880
LITP ST 2,PVARG+4 00027890
ST A,PVARG 00027900
BAL 2,BREAKP 00027910
CR A,NILR 00027920
BE LITP1 CHAR WAS BREAKCHAR 00027930
LITPF LR A,NILR 00027940
LITPEXIT L 2,PVARG+4 00027950
BR 2 00027960
LITP1 L A,PVARG 00027970
BAL 2,DIGP 00027980
CR A,NILR 00027990
BNE LITPF CHAR WAS A DIGIT 00028000
LA A,T 00028010
B LITPEXIT 00028020
*********************************************************************** 00028030
********* BREAKP SUBR NON RECURS ********************************** 00028040
*********************************************************************** 00028050
* BREAKP DECIDES WHETHER CHARACTEROBJECT IS BREAKP 00028060
BREAKP LR Q,A 00028070
LA A,T 00028080
TM 8(Q),X'C0' UOM
BO BREAKPF 00028100
CLI 8(Q),C' ' 00028110
BCR 8,2 00028120
CLI 8(Q),C'(' 00028130
BCR 8,2 00028140
CLI 8(Q),C')' 00028150
BCR 8,2 00028160
CLI 8(Q),C',' 00028170
BCR 8,2 00028180
CLI 8(Q),C'.' 00028190
BCR 8,2 00028200
BREAKPF LR A,NILR 00028210
BR 2 00028220
*********************************************************************** 00028230
********** LAST **************************************************** 00028240
*********************************************************************** 00028250
LAST L Q,CDR(A) CHECK CDR 00028260
CR Q,NILR IS IT NIL ? 00028270
BE 0(2) YES, RETURN CELL 00028280
LR A,Q NO, MOVE TO NEW CELL 00028290
B LAST BRANCH BACK 00028300
*********************************************************************** 00028310
********** RECLAIM ************************************************* 00028320
*********************************************************************** 00028330
RESAV DC F'0' 00028340
RECLAIM LA FREE,1 SET FREE TO 1 TO CAUSE GARB. COL. 00028350
LR A,NILR SET FOR A DUMMY CALL TO CONS 00028360
LR Q,NILR 00028370
ST 2,RESAV 00028380
BAL 2,CONS 00028390
LR A,NILR 00028400
L 2,RESAV 00028410
BR 2 00028420
*********************************************************************** 00028430
********** REMOB *************************************************** 00028440
*********************************************************************** 00028450
REMOB L M,OBJECTA PUT OBLIST ADDR. IN M 00028460
REMOBAK LR Q,M NOW M INTO Q 00028470
L M,CDR(Q) MOVE M FORWARD 00028480
C A,CAR(M) TEST IF OB EQUALS ARG 00028490
BE REMOEQ YES, GO REMOVE IT 00028500
C NILR,CDR(M) ARE WE DONE 00028510
BNE REMOBAK NO, GO BACK FOR NEXT OB 00028520
LR A,NILR YES, RETURN NIL 00028530
BR 2 RETURN 00028540
REMOEQ L M,CDR(M) NO, DELETE OBJECT 00028550
ST M,CDR(Q) 00028560
C K4,HASHTBL IS THERE A HASH TABLE?
BH REMO2 NO
L A,CAR(0,A) REMOVE THIS ATOM FROM IT
LH M,0(0,A) GET HASH CODE
AH M,2(0,A)
MH M,=X'7A3C'
N M,=X'00003FE0'
A M,HASHTBL
SR Q,Q
ST Q,0(0,M)
REMO2 DS 0H
LR A,NILR RETURN NIL 00028570
BR 2 RETURN 00028580
********************************************************************** 00028590
********* RECIP **** 1.0/X **************************************** 00028600
*********************************************************************** 00028610
RECIP TM 0(A),FIX IS IT A NUMBER 00028620
BNO ARITHER NO, CALL ERROR 00028630
TM 0(A),FLOAT IS IT FLOATING POINT 00028640
BO RECIPOK YES, CONTINUE 00028650
LA A,ZEERO RETURN ZERO AS RESULT 00028660
BR 2 00028670
RECIPOK L A,CAR(A) GET ADDR. OF NO. 00028680
LE 2,CAR(A) PUT NO. IN FLT. PT. REG. 2 00028690
LE 0,=E'1.' PUT 1.0 IN FLT. PT. REG. 0 00028700
DER 0,2 COMPUTE 1/X 00028710
LR 14,2 00028720
B MKFLAT MAKE AN ATOM OF THE RESULT 00028730
EJECT 00028740
*********************************************************************** 00028750
********* BPSZ **************************************************** 00028760
*********************************************************************** 00028770
BPSZ L A,BPSSTART+4 00028780
SR A,K4 00028790
SRL A,3 00028800
SLL A,3 00028810
ST A,BOTTOM 00028820
LA Q,1 00028830
ST Q,4(A) 00028840
LA A,8(0,A) 00028850
ST A,BPSSTART 00028860
ST A,BPSSTART+4 00028870
LR A,NILR 00028880
BR 2 00028890
*********************************************************************** 00028900
********* RDS READSELECT ****************************************** 00028910
*********************************************************************** 00028920
RDSS ST 2,RESAV 00028930
LR M,A 00028940
L 1,INDCBADR GET CURRENT INPUT DCB.
LTR 1,1 IS THERE ONE?
BZ RDS1 NO -- SKIP.
USING DCBDS,1
L 0,LASTCHAR YES; SAVE CHAR PTR.
ST 0,NXTCHR#
RDS1 LA 0,LISPIN GET LISPIN ATOM.
CR A,0 00028960
BNE RDS2 00028970
LA 1,CARDIN UOM
B RDSEND 00029020
RDS2 LA Q,APVAL ADR=CAAR(GET(DDNAME APVAL)' 00029030
BAL 2,GET 00029040
CR A,NILR IF FILE NOT OPENED - ERROR 00029050
BE RDSERR 00029060
L A,CAR(A) 00029070
L 1,CAR(,A)
RDSEND LR A,M
ST 1,INDCBADR
L 0,TXTLEN# SET INNL UOM
ST 0,CARDLNTH UOM
AL 0,BFR$ SET CARDEND.
ST 0,CARDEND
L 0,NXTCHR# SET CHAR. PTR.
ST 0,LASTCHAR (MAY BE ZERO)
DROP 1 UOM
MVI EOFIND,0 CLEAR EOF FLAG.
L 2,RESAV 00029140
BR 2 00029150
RDSERR LR A,M 00029160
SR Q,Q 00029170
ERROR ' *** D3-RDS FILE NOT OPENED' 00029180
*********************************************************************** 00029190
********* WRS WRITESELECT ****************************************** 00029200
*********************************************************************** 00029210
WRS LA 0,LISPOUT IS IT LISPOUT 00029220
CR A,0 00029230
BNE WRS2 00029240
LA 0,PRINTCB YES 00029250
ST 0,OTDCBADR CHANGE DCB 00029260
LA 14,MSGBUFFR 00029270
ST 14,MARGIN2 00029280
LA 14,LINE 00029290
ST 14,MARGIN1 00029300
LA 14,20 FOR MARGIN1.
B CINDY UOM
WRS2 LA 0,LISPUNCH IS IT LISPUNCH 00029360
CR A,0 00029370
BNE WRS3 00029380
L 0,PUNCHOPN IS IT OPEN ? 00029390
LTR 0,0 00029400
BNZ WRS2A 00029410
ST 2,WRSAVE NO THEN OPEN IT 00029420
L 14,ADOPEN 00029430
BALR 2,14 00029440
L 2,WRSAVE 00029450
L 0,PUNCHOPN 00029460
WRS2A ST 0,OTDCBADR 00029470
LA 14,SNPA 00029480
ST 14,MARGIN2 00029490
LA 14,LINE+5 00029500
ST 14,MARGIN1
LA 14,1
B CINDY UOM
WRS3 LR 1,2 INDCBADR=CAAR(GET(DDNAME APVAL)) 00029570
LR M,A 00029580
LA Q,APVAL 00029590
BAL 2,GET 00029600
CR A,NILR IF FILE NOT OPENED - ERROR 00029610
BE WRSERR 00029620
L A,CAR(A) 00029630
L 0,CAR(A) UOM
ST 0,OTDCBADR UOM
LR A,M UOM
LR 2,1 UOM
LA 14,20
CINDY LR 1,0 DCB ADDRESS UOM
USING DCBDS,1 UOM
L 0,TXTLEN# INPUT TEXT LENGTH UOM
A 0,MARGIN1 UOM
ST 0,SUPMAX UOM
SR 0,14
ST 0,LINEMAX UOM
BR 2 UOM
DROP 1 UOM
WRSERR LR A,M 00029680
SR Q,Q 00029690
ERROR ' *** D4-WRS FILE NOT OPENED' 00029700
WRSAVE DC F'0' 00029710
ADOPEN DC A(OPEN) 00029720
EJECT 00029730
*********************************************************************** 00029740
********* INLL INLINELENGTH **************************************** 00029750
*********************************************************************** 00029760
INLL L A,CAR(A) 00029770
L A,CAR(A) 00029780
ST A,CARDLNTH 00029790
LR A,NILR 00029800
BR 2 00029810
*********************************************************************** 00029820
********* OTLL OUTLINELENGTH *************************************** 00029830
*********************************************************************** 00029840
OTLL L A,CAR(A) 00029850
L A,CAR(A) 00029860
A A,MARGIN1 00029870
ST A,SUPMAX 00029880
BCTR A,0 00029890
ST A,LINEMAX 00029900
LR A,NILR 00029910
BR 2 00029920
***********************************************************************
********* OTLLNG GET CURRENT OUTLINE LENGTH **********************
***********************************************************************
OTLLNG LR 14,2
L A,SUPMAX
S A,MARGIN1
B MKFXAT MAKE IT A FIXED ATOM.
*********************************************************************** 00029930
********* LETP ****************************************************** 00029940
*********************************************************************** 00029950
LETP CLI 8(A),C'A' 00029960
BL LETPF 00029970
CLI 8(A),C'Z' 00029980
BH LETPF 00029990
LA A,T 00030000
BR 2 00030010
LETPF LR A,NILR 00030020
BR 2 00030030
*********************************************************************** 00030040
********* LENGTH **************************************************** 00030050
*********************************************************************** 00030060
LENGTH LR Q,A 00030070
LR 14,2 00030080
LA A,0 00030090
LENG2 CR Q,NILR 00030100
BE MKFXAT 00030110
LA A,1(0,A) 00030120
L Q,CDR(Q) 00030130
B LENG2 00030140
*********************************************************************** 00030150
********* EOF IS REACHED ON AN END OF FILE FROM A USER DATA FILE *** 00030160
********* IN WHICH CASE WE GO BACK TO READ FROM LISPIN ************* 00030170
********* IF EOF IS REACHED WHILE IN READCH, THE ATOM EOF IS GIVEN *** 00030180
********* AS VALUE OF READCH ************************************** 00030190
DROP 3 00030200
EOF LA 3,BASE3 00030210
USING BASE3,3 00030220
MVI EOFIND,X'FF' SET END OF FILE FLAG FOR READCH
CLI READCHID,X'01' IS IT READCH?
BNE EOF1 NO
SR CHAR,CHAR CLEAR CHAR PTR
B READCH3
EOF1 TM ERRIND,X'10' 00030280
BZ OKEOF1 00030290
L A,EVLSV 00030300
L A,CAR(A) 00030310
PUTMSG ' *** R3-BAD BRACKET COUNT ON USER FILE' 00030320
T7 BC 0,STOP 00030330
BAL 2,PRINT 00030340
OKEOF1 LA A,LISPIN 00030350
BAL 2,RDSS 00030360
B AGN 00030370
*********************************************************************** 00030380
********* ASA NON RECURS ****************************************** 00030390
********* ASA OMITS THE CONTROLCHARACTER IN THE OUTPUTBUFFER ******* 00030400
*********************************************************************** 00030410
ASA CR A,NILR 00030420
LA 1,5 ROBERT I. BERNS 00030430
BE ASAF 00030440
LA Q,LINE 00030450
ST Q,MARGIN1 ROBERT I BERNS 00030460
LA Q,MSGBUFFR 00030470
ST Q,MARGIN2 00030480
L Q,LINEMAX 00030490
SR Q,1 ROBERT I BERNS 00030500
ST Q,LINEMAX 00030510
L Q,SUPMAX 00030520
SR Q,1 00030530
ST Q,SUPMAX ROBERT I BERNS 00030540
BR 2 00030550
ASAF LA Q,LINE+5 00030560
ST Q,MARGIN1 00030570
LA Q,SNPA 00030580
ST Q,MARGIN2 00030590
L Q,LINEMAX AND LEAST YOU FORGET ... 00030600
AR Q,1 00030610
ST Q,LINEMAX 00030620
L Q,SUPMAX 00030630
AR Q,1 00030640
ST Q,SUPMAX ROBERT I BERNS 00030650
BR 2 (JUST SO YOU REMEMBER) 00030660
*********************************************************************** 00030670
********* CHKPOINT ************************************************** 00030680
*********************************************************************** 00030690
CHKPOINT ST 2,PUNCHOPN+8 00030700
ST A,PUNCHOPN+4 00030710
L 2,STORBLKS CHECK FOR DYNAMIC CELL STORAGE.
LTR 2,2 DO WE HAVE ANY ?
BNZ ERRA2 YES --> CHKPOINT UNDEFINED.
LA Q,APVAL 00030720
BAL 2,GET 00030730
CR A,NILR 00030740
BNE RELOCATE 00030750
L A,PUNCHOPN+4 00030760
SR Q,Q 00030770
ERROR ' *** D5-CHKPOINT FILE NOT OPENED' 00030780
RELOCATE L A,CAR(A) 00030790
L M,CAR(A) M NOW CONTAINS DCB ADDRESS 00030800
L A,PUNCHOPN+4 00030810
BAL 2,REMPROP REMOVE APVAL FROM CHKPOINTDDNAME 00030820
LR A,M 00030830
L M,BPSSTART 00030840
SR M,NILR 00030850
ST M,CHKREG+4 00030860
LR M,FREE 00030870
SR M,NILR 00030880
ST M,CHKREG 00030890
PUT (A),CHKPCHK 00030900
STM 14,12,12(13)
BAL 15,MARK MARK A-L UNUSED CELLS
LM 14,12,12(13)
* NOW ALL THE USED CELLS WILL HAVE BIT 32 TURNED ON
LA Q,CARDOUT Q POINTS TO LOCATION ON THE CARD
LR M,NILR M POINTS TO LOCATION IN LISTS
CHOVER DS 0H
TM 4(M),X'80' IS THE ELEMENT MARKED
BO CHOK YES THEN HANDLE IT NORMALLY
LA 1,1 IF NOT THEN WE COUNT THE NUMBER
* OF CONTINGUOUS FREE ELEMENTS, SO
* THAT WE MAY COMPRESS THEN INTO ONE
CHINK C M,BOTTOM END OF THE LISTS?
BNL CHSTORE YES, THAT'S ALL
TM 12(M),X'80' IS THE NEXT ONE MARKES
BO CHSTORE IF SO, END IT
LA 1,1(,1) IF NOT, COUNT
LA M,8(,M) NEXT
B CHINK
CHSTORE SR 2,2
BCTR 2,0 PUT ALL 'F'S IN CDR
STM 1,2,0(Q) STORE THE COUNT
B CHQ
*
CHOK LM 14,15,0(M) GET CAR AND CDR
CLI 4(M),FWD+X'80' IS THE CSR RELOCATABLE
BE CHNOREL NO
SR 14,NILR RELOCATE CAR
CHNOREL SR 15,NILR RELOCATE CDR
STM 14,15,0(Q) STORE IN CARD
CHQ LA Q,8(,Q) INCREMENT CARD
C Q,=A(CARDOUT+80)
BL CHM
PUT (A),CARDOUT
LA Q,CARDOUT RESET Q
CHM LA M,8(,M) INCREMENT M
C M,BOTTOM
BNH CHOVER LOOP IF LOW
LA M,CARDOUT * WE WANT TO SEE IF WE NEED TO
CR Q,M * FLUSH THE BUFFER
BE CHOUT NO
PUT (A),CARDOUT YES
*
* NOW WE DUMP BPS
CHBL EQU 80
CHOUT L M,=A(BPSST)
C M,BPSSTART THIS HAS THE UPPER LIMIT OF BPS USED
BH CHALL
PUT (A),(M)
LA M,CHBL(,M)
B CHOUT+4
CHALL LA FREE,1 PRETEND WE HIT THE END
BAL 14,GARBCOLL COLLECT THE GARBAGE AND TURN BITS OF
LR M,A
B CLOSE2 DROP THE FILE
*********************************************************************** 00031190
********* RESTORE ************************************************** 00031200
*********************************************************************** 00031210
RESTORE ST 2,PUNCHOPN+8 00031220
ST A,PUNCHOPN+4 00031230
LA Q,APVAL 00031240
BAL 2,GET 00031250
CR A,NILR 00031260
BNE RELOC 00031270
L A,PUNCHOPN+4 00031280
SR Q,Q 00031290
ERROR ' *** D6-RESTORE FILE NOT OPENED' 00031300
RELOC L A,CAR(A) 00031310
L A,CAR(A) A NOW CONTAINS DCB ADDRESS 00031320
GET (A) 00031330
CLC CHKPCHK(8),0(1) 00031340
BE RELOCOK 00031350
L A,PUNCHOPN+4 00031360
SR Q,Q 00031370
ERROR ' *** D7-RESTORE GIVEN FILE INCOMPATIBLE WITH SYSTEMC00031380
SPECIFIED' 00031390
RELOCOK LR Q,1
L 1,STORBLKS RELEASE DYNAMIC BLOCKS.
L M,CELLCNT
RELST1 LTR 1,1 ANY MORE BLOCKS?
BZ RELST2 NO.
L 2,0(,1) YES; GET NEXT NOW.
SR 0,0 FREE ALL THIS ONE.
L 15,=V(FREESPAC)
BASR 14,15
S M,=A((SBLKSIZ-8)/8) REDUCE CELL COUNT.
LR 1,2 TRY THE NEXT.
B RELST1
RELST2 ST 1,STORBLKS RESET BLOCKS POINTER.
ST M,CELLCNT RESET CELL COUNT.
L 1,HASHTBL RELEASE THE HASH TBL
LTR 1,1 IF ANY
BZ RELST3 NONE
SR 0,0
ST 0,HASHTBL NONE NOW
L 15,=V(FREESPAC)
BASR 14,15
RELST3 LR 1,Q
L M,12(,1)
AR M,NILR 00031410
ST M,BPSSTART 00031420
LR M,NILR 00031430
L FREE,8(1) 00031440
AR FREE,NILR 00031450
LR Q,NILR POINT TO START OF LISTA
L M,=F'-1' -1 MEANS FREE STUFF
REGET GET (A) RETURNS ADDR IN REG 1
LA 2,80(0,1) POINTS TO END OF CARD
RELOOK LM 14,15,0(1) GET CAR AND CDR
CR 15,M IS IT FREE LIST
BNE REREL NO, GO RELOCATE IT
SLA 14,3 LEAVE THE SPACE (ELS X 8)
AR Q,14 ADD IT TO THE CORE POINTER
B RELOOP
REREL CLI 4(1),FWD+X'80' IS IT RELOCATABLE
BE RENOREL NO, GO
AR 14,NILR RELOCATE THE CAR
RENOREL AR 15,NILR REL. CDR
STM 14,15,0(Q) STORE INTO CORE
LA Q,8(,Q) NEXT PLEASE
RELOOP C Q,BOTTOM TEST FOR END
BH REOUT
LA 1,8(,1) INCREMENT POINTER TO THE CARD
CR 1,2 OFF THE END?
BL RELOOK
B REGET
*
REOUT L M,=A(BPSST) START OF BPS
RENEXT GET (A)
MVC 0(CHBL,M),0(1) MOVE PROGRAM INTO CORE
LA M,CHBL(,M) INCREMENT
C M,BPSSTART
BL RENEXT IF LOW DO IT AGAIN
*
RESTORX SR M,M 00031700
LA 2,GARBT
L 1,PUSHA
BCTR 1,0
LR 0,K4 00031730
ZEROTEMP ST M,0(2) 00031740
BXLE 2,0,ZEROTEMP 00031750
LA FREE,1 TURN OFF THE FUNNY BITS
BAL 14,GARBCOLL AND BUILD A FREE LIST
LR M,A 00031760
ST NILR,PUNCHOPN+4 00031770
B CLOSE2 00031780
*********************************************************************** 00031790
********* CLOSE ***************************************************** 00031800
*********************************************************************** 00031810
PUNCHOPN DC 3F'0' 00031820
CLOSE LA 0,LISPIN 00031830
CR A,0 00031840
BCR 8,2 00031850
LA 0,LISPOUT 00031860
CR A,0 00031870
BCR 8,2 00031880
ST A,PUNCHOPN+4 00031890
ST 2,PUNCHOPN+8 00031900
LA 0,LISPUNCH 00031910
CR A,0 00031920
BNE CLOSUSFL 00031930
L M,PUNCHOPN 00031940
LTR M,M 00031950
BZ CLOSEERR 00031960
SR 0,0 00031970
ST 0,PUNCHOPN 00031980
B CLOSE2 00031990
CLOSUSFL LA Q,APVAL 00032000
BAL 2,GET 00032010
CR A,NILR 00032020
BE CLOSEERR 00032030
CLOSE1 L M,CAR(A) 00032040
L M,CAR(M) 00032050
L A,PUNCHOPN+4 00032060
BAL 2,REMPROP 00032070
CLOSE2 LR 1,M UOM
CLOSE , CLOSE PRINTCB UOM
CLOSEERR LM A,Q,PUNCHOPN+4 00032160
BR Q 00032170
*********************************************************************** 00032180
********* VERBOS *************************************************** 00032190
*********************************************************************** 00032200
**** ARG=T PRINTS IN GARB. COL....ARG=NIL NO PRINT ON GARB. COL. 00032210
PRBUFFER LA 1,BUFFPR 00032220
B COMSECT 00032230
VERBOS LA 1,GARBSW 00032240
COMSECT NI 0(1),X'00' 00032250
CR A,NILR 00032260
BCR 8,2 00032270
OI 0(1),X'01' 00032280
BR 2 00032290
*********************************************************************** 00032300
********* FLOAT SUBR NON REC ************************************** 00032310
*********************************************************************** 00032320
* FLOAT CONVERTS INTEGER INTO FLOATING POINT *********************** 00032330
FLOATIT LR 14,2 00032340
L A,CAR(A) 00032350
L 1,CAR(A) NUMBER INTO R1 00032360
BAL 2,FLOAT1 FLOAT IT 00032370
B MKFLAT MAKE ATOM 00032380
*********************************************************************** 00032390
******************* EQ(X,Y) NON REC ************************ 00032400
********************************************************************** 00032410
* RETURN TRUE IF X=Y 00032420
EQ CR A,Q ARE THEY EQUAL 00032430
LR A,NILR NO MAYBE 00032440
BNE 0(2) THEY ARENT 00032450
LA A,T TRUE 00032460
BR 2 00032470
*********************************************************************** 00032480
******************* REPLACA(X,Y) NON REC *********************** 00032490
********************************************************************** 00032500
* REPLACE CAR OF X BY Y 00032510
RPLACA IC 1,CAR(A) 00032520
ST Q,CAR(A) 00032530
STC 1,CAR(A) 00032540
BR 2 00032550
*********************************************************************** 00032560
******************* REPLACD(X,Y) NON REC *********************** 00032570
********************************************************************** 00032580
* REPLACE CDR OF X BY Y 00032590
RPLACD IC 1,CDR(A) 00032600
ST Q,CDR(A) 00032610
STC 1,CDR(A) 00032620
BR 2 00032630
*********************************************************************** 00032640
******************* NULL(X) NON REC ************************* 00032650
********************************************************************** 00032660
* RETURN TRUE IF X IS NIL 00032670
NULL CR A,NILR IS IT NIL 00032680
LR A,NILR IS NOW 00032690
BNE 0(2) IT WASNT, FALSE RETURN 00032700
LA A,T IT WAS 00032710
BR 2 00032720
*********************************************************************** 00032730
******************* FUNCTION(X) NON REC FSUBR ****************** 00032740
*********************************************************************** 00032750
FUNCTIO1 ST A,RESAV 00032760
LA A,RESAV 00032770
FUNCTION LR 14,2 SAVE RET 00032780
LR M,A SAVE A 00032790
LR A,Q ALIST 00032800
LR Q,NILR 00032810
BAL 2,CONS 00032820
LR Q,A 00032830
L A,CAR(M) 00032840
BAL 2,CONS 00032850
LR Q,A 00032860
LA A,FUNARG 00032870
BAL 2,CONS 00032880
BR 14 EXIT 00032890
EJECT 00032900
*********************************************************************** 00032910
********* SPECBIND ENTRY FROM COMPILER *************************** 00032920
*********************************************************************** 00032930
SPECBIN1 L A,0(2) 00032940
AR A,NILR 00032950
L 14,CAR(A) 00032960
L M,4(2) 00032970
L Q,0(M,PDL) 00032980
ST 14,0(M,PDL) 00032990
ST Q,0(A) 00033000
LA 2,8(0,2) 00033010
BCT 1,SPECBIN1 00033020
L 3,PVARG 00033030
BR 2 00033040
*********************************************************************** 00033050
********* SPECRSTR ENTRY FROM COMPILER *************************** 00033060
*********************************************************************** 00033070
SPECRST1 L A,0(2) 00033080
AR A,NILR 00033090
L M,4(2) 00033100
L 14,0(M,PDL) 00033110
ST 14,0(A) 00033120
LA 2,8(0,2) 00033130
BCT 1,SPECRST1 00033140
L 3,PVARG 00033150
BR 2 00033160
*********************************************************************** 00033170
********* COMBIND ENTRY FROM COMPILER *************************** 00033180
*********************************************************************** 00033190
COMBIND1 ST 2,RESAV 00033200
LR 0,15 00033210
BAL 2,PAIR 00033220
LR 15,0 00033230
L Q,ALIST 00033240
BAL 2,NCONC 00033250
ST A,ALIST 00033260
L 2,RESAV 00033270
L 3,PVARG 00033280
BR 2 00033290
*********************************************************************** 00033300
********* COMBRSTR ENTRY FROM COMPILER *************************** 00033310
*********************************************************************** 00033320
COMRSTR1 L A,CAR(A) 00033330
L Q,CAR(A) 00033340
L A,ALIST 00033350
COMLOP L A,CDR(A) 00033360
BCT Q,COMLOP 00033370
ST A,ALIST 00033380
L 3,PVARG 00033390
BR 2 00033400
*********************************************************************** 00033410
*********MOVIT ENTERED FROM COMPILER ******************************* 00033420
*********************************************************************** 00033430
MOVIT1 CR PDS,NILR 00033440
BH ERG2 00033450
ST NILR,0(0,PDL) 00033460
ST A,4(0,PDL) 00033470
ST Q,8(0,PDL) 00033480
SR M,K4 00033490
CR M,K4 00033500
BNH MOVOUT 00033510
SR M,K4 00033520
BCTR M,0 00033530
STC M,MOVINST+1 00033540
MOVINST MVC 12(1,PDL),ARGS 00033550
MOVOUT L 3,PVARG 00033560
BR 2 00033570
*********************************************************************** 00033580
*********LSTCMP ENTERED FROM COMPILER ******************************* 00033590
*********************************************************************** 00033600
LSTCMP1 LR 14,0 00033610
BCTR 14,0 00033620
SLL 14,2 00033630
AR 14,2 00033640
LA 1,4(0,14) 00033650
LR Q,NILR 00033660
SR 2,2 00033670
LSTLOP SR A,A 00033680
SR M,M 00033690
L 3,PVARG 00033700
EX 0,0(14) 00033710
DROP 3 00033720
LA 3,BASE3 00033730
USING BASE3,3 00033740
LTR A,A 00033750
BNE LSTA 00033760
LTR M,M 00033770
BNE LSTASPEC 00033780
AR 2,NILR 00033790
LR A,2 00033800
B LSTA 00033810
LSTASPEC L A,0(M,NILR) 00033820
LSTA BAL 2,CONS 00033830
LR Q,A 00033840
SR 14,K4 00033850
BCT 0,LSTLOP 00033860
L 3,PVARG 00033870
BR 1 00033880
*********************************************************************** 00033890
********* LINK ****************************************************** 00033900
********* LINK ESTABLISHES LINKAGES FOR THE COMPILER **************** 00033910
********* LINK WILL ALSO MAKE A FAST CALL WHENEVER POSSIBLE ******** 00033920
********* BY CHANGING THE CODE IN THE FUNCTION THAT LINKED ***** 00033930
*********************************************************************** 00033940
LINKSAVE DC 2F'0' 00033950
ASUBR DC A(SUBR) 00033960
AFSUBR DC A(FSUBR) 00033970
AEXPR DC A(EXPR) 00033980
AFEXPR DC A(FEXPR) 00033990
LINK1 L 1,0(0,2) PICK UP FN NAME IN A 00034000
AR 1,NILR 00034010
LR 15,1 SET UP TO SEARCH PROPERTYLIST 00034020
LINKGET L 15,CDR(15) 00034030
CR 15,NILR 00034040
BE NOPROPRT FN IS NOT DEFINED BY PROPERTY 00034050
L 0,CAR(15) 00034060
C 0,ASUBR 00034070
BE SUBRLINK 00034080
C 0,AFSUBR 00034090
BE SUBRLINK 00034100
C 0,AEXPR 00034110
BE EXPRLINK 00034120
C 0,AFEXPR 00034130
BNE LINKGET 00034140
EXPRLINK L 15,CDR(15) PICK UP LAMBDA DEF. 00034150
L 15,CAR(15) OF EXPR OR FEXPR 00034160
FNALIST L 0,4(0,2) PICK UP NO. OF ARGS IN R0 00034170
BAL 2,LISTARG LIST ARGS 00034180
TM 0(1),X'01' SHOULD FN BE TRACED? 00034190
BO TRACEXPR YES, GO TRACE IT 00034200
L Q,ALIST NO, SET UP FOR APPLY 00034210
ST Q,ARGS 00034220
LR Q,A 00034230
LR A,15 00034240
BAL 2,APPLY CALL APPLY AND EXIT 00034250
B CALLEXIT 00034260
TRACEXPR ST A,PVARG 00034270
LR A,1 00034280
SAVE A 00034290
BAL 2,PRARG TRACE ARGS 00034300
LR Q,A ARGS TO Q 00034310
L A,ALIST 00034320
ST A,ARGS SET UP FOR APPLY 00034330
LR A,15 00034340
BAL 2,APPLY CALL APPLY 00034350
TRRET ST A,PVARG
UNSAVE 2
TM 0(2),X'01' SHOULD IT BE TRACED
BZ CALLEXIT NOPE
LR A,2 MOVE FOR PRVAL
BAL 2,PRVAL TRACE VALUE 00034380
B CALLEXIT 00034390
NOPROPRT LR 15,1 FUNCTION IS DEFINED ON ALIST 00034400
B FNALIST SO CALL APPLY 00034410
SUBRLINK L 15,CDR(15) PICK UP ADDR. OF FSUBR 00034420
L 15,CAR(15) OR SUBR 00034430
L 15,CAR(15) 00034440
TM TRACEIND,X'01' IS ANYTHING BEING TRACED
BO TRACSUBR YES - DON'T MAKE ANY FAST LINKS THEN
SR 2,K4 NO, SET UP TO MAKE FAST CALL 00034470
LR 1,15 00034480
SR 1,NILR MAKE SUBR ADDR. RELOCATABLE 00034490
STC K4,3(0,2) MODIFY BAL INST. 00034500
ST 1,4(0,2) STORE RELOC. SUBR ADDR. 00034510
BALR 2,15 GO TO FN 00034520
B CALLEXIT 00034530
TRACSUBR STM A,Q,GARBT+4 PROTECT ARG1 AND ARG2 00034540
L 0,4(0,2) PICK UP NO. OF ARGS IN R0 00034550
BAL 2,LISTARG LIST ARGS FOR TRACING 00034560
ST A,PVARG 00034570
LR A,1 00034580
SAVE A 00034590
TM 0(A),X'01' IS FN BEING TRACED
BZ *+8 NO
BAL 2,PRARG TRACE ARGS 00034600
LM A,Q,GARBT+4 00034610
BALR 2,15 CALL FN 00034620
B TRRET TRACE RETURNED VALUE
LISTARG LTR 0,0 00034670
BNE LISTARG1 00034680
LR A,NILR 00034690
BR 2 00034700
LISTARG1 ST 2,LINKSAVE+4 00034710
SR 0,K4 00034720
BNE LISTARG2 00034740
LR Q,NILR 00034750
BAL 2,CONS 00034760
L 2,LINKSAVE+4 00034770
BR 2 00034780
LISTARG2 ST A,GARBT 00034790
LR A,Q 00034800
LR Q,NILR 00034810
BAL 2,CONS 00034820
LR Q,A 00034830
L A,GARBT 00034840
BAL 2,CONS 00034850
SR 0,K4 00034860
BNE LISTARG3 00034880
L 2,LINKSAVE+4 00034890
BR 2 00034900
LISTARG3 ST 1,LINKSAVE 00034910
SR 14,14 00034920
LISTARG4 L Q,ARGS(14) 00034930
BAL 2,APPEND1 00034940
AR 14,K4 00034950
CR 14,0 00034960
BL LISTARG4 00034970
LM 1,2,LINKSAVE 00034980
BR 2 00034990
EJECT 00035000
*********************************************************************** 00035010
******************* CAR * CDR * CADR * ETC ***SUBRS ********** 00035020
********************************************************************** 00035030
CAAAR L A,CAR(,A)
CAAR L A,CAR(,A)
CARR L A,CAR(,A)
BR 2
CAADR L A,CDR(,A)
L A,CAR(,A)
L A,CAR(,A)
BR 2
CADAR L A,CAR(,A)
CADR L A,CDR(,A)
L A,CAR(,A)
BR 2
CADDR L A,CDR(,A)
L A,CDR(,A)
L A,CAR(,A)
BR 2
CDAAR L A,CAR(,A)
CDAR L A,CAR(,A)
CDRR L A,CDR(,A)
BR 2
CDADR L A,CDR(,A)
L A,CAR(,A)
L A,CDR(,A)
BR 2
CDDAR L A,CAR(,A)
CDDR L A,CDR(,A)
L A,CDR(,A)
BR 2
CDDDR L A,CDR(,A)
L A,CDR(,A)
L A,CDR(,A)
BR 2 00035350
PROG2 LR A,Q 00035360
BR 2 00035370
* ====== END OF BASE 3 SECTION ===================================== 00035380
* ==================================================================== 00035390
EJECT 00035400
* ==================================================================== 00035410
* ====== BEGINNING OF BASEREGISTER 13 SECTION. PLEASE NOTE THAT ==== 00035420
* ====== REGISTER 13 IS ALSO POINTING TO THE INTERPRETERS ====== 00035430
* ====== SAVEAREA ============================================== 00035440
SAVEBLK DC 18F'0' 00035450
*********************************************************************** 00035460
********* READ ROUTINE ******************** 00035470
*********************************************************** 00035480
* SYNTAX ERRORS 00035490
* ERRB A . AFTER A ( 00035500
* DOTERR1 THE SECOND S-EXPRESSION IN DOTTED PAIR IS NOT 00035510
* FOLLOWED BY ) 00035520
* DOTERR2 A , . OR ) FOLLOWS A . 00035530
* REG -CHAR- HAS POINTER TO CURRENT CHARACTER 00035540
CHAR EQU 3 POINTER TO CURRENT CHARACTER 00035550
WKU EQU 1 WORK REGISTER 00035560
ERRIND DC X'00' X'01' INDICATES SYNTAX ERROR 00035570
* X'04' LABEL OR NUMB TRUNC 00035580
LASTCHAR DC A(0)
RDSV2 DC 2F'0' NOT RECURSIVE 00035600
READ EQU * 00035610
STM 2,3,RDSV2 SAVE EM 00035620
L CHAR,LASTCHAR 00035630
MVI ERRIND,X'00' SET ERRIND OFF 00035640
LR A,NILR SET TO NIL LIST 00035650
LR Q,NILR 00035660
BAL 2,CONS START NEW LIST 00035670
MVI LINKS+3,X'00' SET FOR CAR ATOM 00035680
MVI ATOMEQ+3,X'00' SET FOR CAR ATOM 00035690
LTR CHAR,CHAR IS THERE A CHARACTER YET?
BNZ *+8 YES.
BAL 2,GETCD NO; START AN INPUT RECORD.
RDIG BAL 2,TRYATOM -A- IS ADDR OF CELL 00035700
B RDOUT GOT ATOM 00035710
B RDIG DOT OR RT PAR 00035720
OI ERRIND,X'10' STARTING READ 00035730
BAL 2,TRYRPAR 00035740
B RDOUT ATOM IS NIL 00035750
ST A,EVLSV 00035760
BAL 2,UPPER 00035770
RDOUT ST CHAR,LASTCHAR -A- HAS POINTER TO TOP OF LI 00035780
L A,CAR(A) 00035790
TM ERRIND,X'01' 00035800
BZ RT2 00035810
PUTMSG SYNTAXMS 00035820
T8 BC 0,STOP 00035830
RT2 TM ERRIND,X'04' 00035840
BZ RTOK 00035850
PUTMSG TRUNCMSG 00035860
T9 BC 0,STOP 00035870
RTOK LM 2,3,RDSV2 00035880
NI ATOMIND,X'00' 00035890
OC MAININD(1),ERRIND INDICATE ERROR TO MAIN PROGRAM 00035900
NI ERRIND,X'00' 00035910
BR 2 00035920
* 00035930
********* RECURSIVE ENTRY FOR UPPER BRANCH ********* 00035940
* 00035950
UPPER SAVE 2 00035960
SAVE A 00035970
LR WKU,A HOLD -A- 00035980
BAL 2,CONS GET A CELL 00035990
ST A,CAR(WKU) SET PTR DOWN 00036000
B RDS READ S EXPRESSION 00036010
* 00036020
********* RECURSIVE ENTRY FOR LOWER BRANCH ************ 00036030
* 00036040
LOWER SAVE 2 00036050
SAVE A 00036060
RDCNO LR WKU,A 00036070
LR A,NILR PREVENT A LOOP IN PRINT IF ABEND 00036080
BAL 2,CONS GET A CELL 00036090
ST A,CDR(WKU) SET PTR DOWN 00036100
RDS MVI LINKS+3,CAR SET FOR CAR ATOM 00036110
MVI ATOMEQ+3,CAR SET FOR CAR ATOM 00036120
BAL 2,TRYATOM 00036130
B RDBATM GOT ONE 00036140
B RDBERB 00036150
BAL 2,TRYRPAR 00036160
B RDBRP 00036170
BAL 2,UPPER 00036180
RDBATM BAL 2,TRYRPAR 00036190
B RDRET 00036200
B RDCDOT 00036210
RDRET UNSAVE A 00036220
B RETURN 00036230
RDBERB LA 1,ERRB LOAD ADDR OF ERRB 00036240
ST 1,CAR(A) 00036250
OI ERRIND,X'01' 00036260
B RDBATM 00036270
RDBRP ST NILR,CAR(A) SET CAR TO NIL 00036280
B RDBATM 00036290
RDCDOT BAL 2,TRYDOT 00036300
B RDCDOTT 00036310
B RDCNO 00036320
RDCDOTT MVI LINKS+3,CDR SET FOR CDR ATOM 00036330
MVI ATOMEQ+3,CDR SET FOR CDR ATOM 00036340
BAL 2,TRYATOM 00036350
B RDCATM 00036360
B RDCDTER 00036370
BAL 2,TRYRPAR 00036380
B RDRET 00036390
BAL 2,LOWER 00036400
RDCATM BAL 2,TRYRPAR 00036410
B RDRET 00036420
LA 1,DOTERR1 00036430
ST 1,CDR(A) SET CDR TO DOTERR1 00036440
OI ERRIND,X'01' 00036450
B RDRET 00036460
RDCDTER LA 1,DOTERR2 00036470
ST 1,CDR(A) SET CDR TO DOTERR2 00036480
OI ERRIND,X'01' 00036490
B RDCATM 00036500
EJECT 00036510
*********************************************************************** 00036520
********* TRYATOM ************************** 00036530
***************************************************************** 00036540
ATOMIND DC X'00' BIT SWITCHES 00036550
* BIT 8 ATOMIND 00036560
* 7 NUMIND 00036570
* 6 FLOATIND 00036580
* 5 EXPIND 00036590
* 4 NEGEXP 00036600
* 3 NEGINT 00036610
* 2 LOGICAL 00036620
ATMSV2 DC 1F'0' SAVE RETURN, NON RECURSIVE 00036630
NEWGENSM EQU CHARATA+4 00036660
CNOP 4,8 00036670
DIGATA DC H'0',H'10',4F'0' 00036680
EXPA DC H'0',H'2',F'0' EXP SCAN AREA 00036690
EXP DC H'0' 00036700
* SCAN AREA= CURR LENGTH,MAX LENGTH,DATA 00036710
* REG -A- CONTAINS CURRENT CELL IN LIST 00036720
TRYATOM EQU * 00036730
ST 2,ATMSV2 SAVE RETURN 00036740
NI ATOMIND,X'00' CLEAR BITS 00036750
CLI 0(CHAR),C' ' BLANK 00036760
BNE NOTBL 00036770
NEXTCHAR BAL 2,GETCHAR 00036780
ATLOK CLI 0(CHAR),C' ' BLANK 00036790
BNE NOTBL 00036800
TM ATOMIND,X'80' 00036810
BZ NEXTCHAR 00036820
B ALLATOM 00036830
NOTBL CLI 0(CHAR),C',' 00036840
BNE NOTCOM 00036850
TM ATOMIND,X'80' 00036860
BO ALLATOM 00036870
B NEXTCHAR IGNORE COMMA 00036880
NOTCOM CLI 0(CHAR),C'.' 00036890
BNE NOTDOT 00036900
TM ATOMIND,X'40' WAS IT A NUMBER COLLECTION 00036910
BZ CKATM NO 00036920
OI ATOMIND,X'20' SET FLOAT IND ON 00036930
B NEXTCHAR 00036940
CKATM TM ATOMIND,X'80' 00036950
BO ALLATOM 00036960
BAL 2,GETCHAR 00036970
L 2,ATMSV2 00036980
B 4(2) DOT & RT PAR RETURN 00036990
NOTDOT CLI 0(CHAR),C')' 00037000
BE CKATM 00037010
CKLP CLI 0(CHAR),C'(' 00037020
BNE NOTLP 00037030
TM ATOMIND,X'80' 00037040
BO ALLATOM 00037050
BAL 2,GETCHAR 00037060
L 2,ATMSV2 00037070
B 8(2) LEFT PAR RETURN 00037080
NOTLP CLI 0(CHAR),C'-' 00037090
BNE NOTMIN 00037100
LA 1,CHARATA 00037110
BAL 2,STOCHAR 00037120
BAL 2,GETCHAR 00037130
BAL 2,CKDIG IS IT DIGIT 00037140
B RDDASH NO 00037150
TM ATOMIND,X'10' IN EXPONENT 00037160
BZ NOEXP 00037170
OI ATOMIND,X'08' SET NEG EXPONENT 00037180
B NOTBL 00037190
NOEXP OI ATOMIND,X'04' SET NEG INTEGER 00037200
B NOTBL 00037210
NOTMIN CLI 0(CHAR),C'+' 00037220
BNE NOTPLUS 00037230
LA 1,CHARATA 00037240
BAL 2,STOCHAR 00037250
BAL 2,GETCHAR 00037260
BAL 2,CKDIG IS IT DIGIT 00037270
B RDPLUSS NO 00037280
B NOTBL YES 00037290
NOTPLUS BAL 2,CKDIG IS IT DIGIT 00037300
B NOTDIGIT NO 00037310
TM ATOMIND,X'40' 00037320
BO STNAT 00037330
TM ATOMIND,X'80' 00037340
BO CHARATM 00037350
OI ATOMIND,X'C0' ATOMIND & NUMBIND 00037360
LA 1,0 00037370
MVC DIGATA+4(16),CHZERO INITIALIZATION 00037380
STH 1,DIGATA ZEROING THE DIGIT AREAS 00037390
STH 1,EXPA 00037400
ST 1,EXPA+4 00037410
STH 1,EXP 00037420
STNAT TM ATOMIND,X'10' IN EXPONENT 00037430
BO ACEXP YES 00037440
STNATT LA 1,DIGATA SET PTR 00037450
BAL 2,STOCHAR 00037460
TM ATOMIND,X'20' FLOAT NUMBER 00037470
BNO NEXTCHAR 00037480
LH 1,EXP 00037490
BCTR 1,0 00037500
STH 1,EXP 00037510
B NEXTCHAR 00037520
ACEXP LA 1,EXPA EXPONENT AREA 00037530
BAL 2,STOCHAR STORE IT 00037540
B NEXTCHAR CONT 00037550
CKDIG CLI 0(CHAR),C'0' 00037560
BL 0(2) NOT DIGIT 00037570
CLI 0(CHAR),C'9' 00037580
BH 0(2) NOT DIGIT 00037590
B 4(2) DIGIT 00037600
NOTDIGIT TM ATOMIND,X'40' A NUMBER 00037610
BO CKEXP YES 00037620
CLI 0(CHAR),C'$' LITERAL 00037630
BE LITERAL 00037640
CHARATM TM ATOMIND,X'80' ATOM 00037650
BO ATOK YES 00037660
MVC CHARATA+4(16),ZERO 00037670
MVC CHARATA+20(ATMSZ-12),CHARATA+4
LA 1,0 00037690
STH 1,CHARATA 00037700
OI ATOMIND,X'80' ATOM & LETTER 00037710
ATOK LA 1,CHARATA SET PTR 00037720
BAL 2,STOCHAR 00037730
B NEXTCHAR 00037740
CKEXP TM ATOMIND,X'20' IS IT FLOATNUMBER ? 00037750
BO CKEXP1 YES SEE IF THIS IS EXPMARKER 00037760
CLI 0(CHAR),C'A' IS CHAR LESS THAN 'A' 00037770
BL NOTLOG NO 00037780
CLI 0(CHAR),C'F' IS CHAR GREATER THAN 'F' 00037790
BH NOTEXP YES 00037800
OI ATOMIND,X'02' 00037810
TR 0(1,CHAR),TABL1-193 00037820
B STNATT 00037830
CKEXP1 CLI 0(CHAR),C'E' IS CHAR EXP MARK ? 00037840
BNE NOTEXP 00037850
OI ATOMIND,X'10' SET EXP ON 00037860
B NEXTCHAR 00037870
NOTEXP CLI 0(CHAR),C'X' LOGICAL 00037880
BNE NOTLOG 00037890
OI ATOMIND,X'12' SET EXP, LOG ON 00037900
B NEXTCHAR 00037910
NOTLOG OI ERRIND,X'01' INVALID SYNTAX 00037920
NI ATOMIND,X'00' 00037930
B NEXTCHAR 00037940
RDDASH EQU * 00037950
TM ATOMIND,X'80' 00037960
BO ATLOK 00037970
LA 14,DASH 00037980
B ATOMEQ 00037990
RDPLUSS EQU * 00038000
TM ATOMIND,X'80' 00038010
BO ATLOK 00038020
LA 14,PLUSS 00038030
B ATOMEQ 00038040
STOCHAR LH 15,0(1) CURR LENGTH 00038050
CH 15,2(1) AT MAX 00038060
BL STOIT NO 00038070
OI ERRIND,X'04' LABEL OR NUMBER TRUNCATED 00038080
BR 2 DROP CHAR 00038090
STOIT IC 0,0(CHAR) PICK IT UP 00038100
STC 0,4(1,15) 00038110
LA 0,1(,15) ADD 1 00038120
STH 0,0(1) 00038130
BR 2 00038140
LITERAL TM ATOMIND,X'80' LITERAL=>$$D.. ...D 00038150
BO ATOK BUILDING ATOM 00038160
MVC CHARATA+4(16),ZERO 00038170
MVC CHARATA+20(ATMSZ-12),CHARATA+4
LA 0,0 00038190
STH 0,CHARATA 00038200
OI ATOMIND,X'80' ATOM & LETTER 00038210
LA 1,CHARATA 00038220
BAL 2,STOCHAR STO IT FOR NOW 00038230
BAL 2,GETCHAR GET NEXT CHAR 00038240
CLI 0(CHAR),C'$' 00038250
BNE ATLOK NOT A LITERAL 00038260
LH 15,CHARATA 00038270
BCTR 15,0 BACK UP ONE, IE TO $ 00038280
STH 15,CHARATA 00038290
LITOK BAL 2,GETCHAR GET DELIMETER 00038300
IC 0,0(CHAR) PICK IT UP 00038310
STC 0,DELM+1 STO IT 00038320
LITON BAL 2,GETCHAR NEXT CHAR 00038330
DELM CLI 0(CHAR),C'9' SCAN FOR DELIMETER 00038340
BE LITDN 00038350
LA 1,CHARATA SET PTR 00038360
BAL 2,STOCHAR 00038370
B LITON 00038380
LITDN BAL 2,GETCHAR 00038390
EJECT 00038410
* ALL REQUIRED CHARACTERS HAVE BEEN PICKED OFF THE CARD. 00038420
* AN ALPHABETIC OR NUMERIC ATOM MAY NOW BE CONSTRUCTED. 00038430
* REGISTERS 0,1,14,15 USED HERE- CONS MUST NOT ALTER THEM. 00038440
ALLATOM TM ATOMIND,X'40' NUMB ATOM 00038450
BO NUMAT YES 00038460
MVI ATMTYP+1,ATOM SET ATOM TYPE 00038470
STSCH L 1,HASHTBL LOOK IN HASH TABLE
LTR 1,1 NONE
BNZ SCH1 NOPE
L 15,=A(HASHINIT) BUILD ONE
BR 15
SCH1 LH 15,CHARATA+4 GET THE HASH KEY
AH 15,CHARATA+6
MH 15,=X'7A3C'
N 15,=X'00003FE0'
A 15,HASHTBL
MVI LPSW,0 USED TO LOOK FOR LOOPS
SCH2 L 14,0(0,15) FIND NEXT ATOM
LR 1,15 SAVE LOCN IN HASH TBL
LTR 14,14 HOLE?
BZ BUILDATM YES - NEW ATOM
L 1,CAR(0,14) FIND FULL WORD
L 0,CHARATA+4 NEW ATOM FULL WORD
C 0,CAR(0,1) COMPARE
BNE SCHAGN NOT IT
LR 2,1 SET UP FOR REST OF COMPARE
SR 1,1
B SCHEQ
SCHAGN LA 15,4(0,15) NEXT ATOM
C 15,ENDHASH END?
BL SCH2 NOPE
L 15,HASHTBL WRAP AROUND
XI LPSW,1 BUT ONLY ONCE
BNZ SCH2 OK
TMNYATM ERROR ' *** TOO MANY ATOMS (>4096)'
LPSW DC X'0'
*** FOUND ONE, SO COMPARE REST OF NAME 00038520
SCHEQ L 2,CDR(2) 00038550
LA 2,0(,2) ZERO EXTRA BITS 00038560
CR 2,NILR NIL YET 00038570
BE CKATEND CHECK END OF AREA 00038580
L 0,CAR(2) NEXT PART OF NAME 00038590
C 0,CHARATA+8(1) 00038600
BNE SCHAGN SEARCH REST OF OBJLIST 00038610
AR 1,K4 00038620
B SCHEQ TRY NEXT 4 BYTES 00038630
CKATEND SR 2,2
C 2,CHARATA+8(1) SHOULD BE ZERO 00038650
BNE SCHAGN CHECK REST OF LIST 00038660
ATOMEQ ST 14,CAR(A) SET PTR TO ATOM 00038670
ATEXIT L 2,ATMSV2 RESTORE 2 00038680
BR 2 FOUND ATOM 00038690
*** ATOM NOT ON OBJLIST SO WE ADD IT TO FRONT 00038810
BUILDATM LR 15,A SAVE-A- PNTS TO CURR CELL ABUILDING 00038820
LR Q,NILR Q=NIL 00038830
BAL 2,CONS ATOM HEAD 00038840
ST A,0(0,1) STORE INTO HASH TABLE
LINKS ST A,CAR(15) LINK CELL TO LIST 00038850
LR 14,A SAVE-A- PNTS TO ATOM HEAD 00038860
L 1,OBJECTA ADD ATOM TO FRONT OF OBJLIST 00038870
L Q,CDR(1) 00038880
BAL 2,CONS ADD TO OBJECT LIST 00038890
ST A,CDR(1) LINK IT 00038900
LR Q,NILR 00038910
BAL 2,CONS FIRST DATA CELL 00038920
ST A,CAR(14) LINK TO ATOM HEAD 00038930
ATMTYP MVI CAR(14),ATOM MARK ATOM HEAD 00038940
LA 1,0 00038950
MVI CDR(A),FWD MARK ALPHA CELL 00038960
L 0,CHARATA+4 PNAME 00038970
STNEXT ST 0,CAR(A) STORE NAME 00038980
L 0,CHARATA+8(1) GET NEXT PART OF NAM E 00038990
C 0,ZERO END OF ST R ING 00039000
BE BTEXIT YES 00039010
LR 14,A SAVE-A- 00039020
BAL 2,CONS ANOTHER CELL 00039030
MVI CDR(A),FWD MARK AS ALPHA 00039040
ST A,CDR(14) LINK INTO LIST 00039050
MVI CDR(14),FWD MARK AS ALPHA 00039060
AR 1,K4 00039070
B STNEXT 00039080
BTEXIT LR A,15 RESET A 00039090
B ATEXIT 00039100
*** DATA SCANNED WAS A NUMERIC ATOM -- CONVERT TO FIX OR FLOAT 00039110
NUMAT TM ATOMIND,X'20' FLOATIND 00039120
BO FLOATINP 00039130
TM ATOMIND,X'02' LOGICAL 00039140
BO LOGINP 00039150
LH 1,DIGATA CONST LENGTH 00039160
BCTR 1,0 LESS ONE 00039170
EX 1,PCK PACK IT 00039180
CVB 1,DIGATA+12 TO BIN 00039190
TM ATOMIND,X'04' NUMB NEG 00039200
BZ *+6 00039210
LCR 1,1 YES, COMPLEMENT IT 00039220
MVI ATMTYP+1,FIX SET CORRECT TYPE 00039230
NUMIT ST 1,CHARATA+4 00039240
MVC CHARATA+8(4),ZERO 00039250
B STSCH MAKE AN ATOM 00039260
LOGINP LH 2,DIGATA GET NUMBER OF LOGICAL DIGITS 00039270
LA 14,DIGATA+4 R14 = LOWER BOUNDARY OF FIELD 00039280
SR 0,0 STE R0 TO 0 00039290
LOGLOP IC 1,0(14) FIND FIRST DIGIT 00039300
SLL 1,28 AND PUT IT IN R0 00039310
SLDL 0,4 00039320
LA 14,1(0,14) HAVE ALL DIGITS BEEN PROCESSED 00039330
BCT 2,LOGLOP IF SO BRANCH TO LOGLOP 00039340
LH 2,EXPA GET NUMBER OF DIGITS IN EXPONENT 00039350
LTR 2,2 TEST FOR ZERO 00039360
BZ NUMITT NO EXPONENT 00039370
BCTR 2,0 00039380
EX 2,PCK1 CONVERT EXPONENT TO BINARY 00039390
CVB 2,CHARATA+4 00039400
SLL 2,2 MULTIPLY EXPONENT BY 4 00039410
SLL 0,0(2) SHIFT LOGICAL NUMBER 00039420
* CONSTRUCT A NONUNIQUE ATOM OUT OF THE LOGICAL NUMBER IN R0 00039430
NUMITT LR 15,A 00039440
LR Q,NILR 00039450
LR A,0 00039460
BAL 2,CONS 00039470
MVI CDR(A),FWD 00039480
BAL 2,CONS 00039490
MVI CAR(A),LOGIC 00039500
LR 14,A 00039510
LR A,15 00039520
B ATOMEQ 00039530
FLOATINP LH 0,EXP EXP HAD MINUS NO. OF FRAC. DIG.S 00039540
SR 2,2 UOM
TM ATOMIND,X'10' IS THERE AN EXP. FIELD ? 00039550
LH 1,DIGATA GET NO. OF NOS. 00039570
BZ NONEGXP NO EXP. 00039580
LH 2,EXPA GET EXP. DIG. COUNT 00039590
BCTR 2,0 SUBTRACT 1 FOR PACK 00039600
EX 2,PCK1 PACK 00039610
CVB 2,CHARATA+4 CONV. TO BIN. 00039620
TM ATOMIND,X'08' WAS EXP. NEG. 00039630
BZ NONEGXP NO 00039640
LCR 2,2 YES, COMPLIMENT 00039650
NONEGXP AR 0,2 REG 0 NOW CONTAINS NO. OF FRAC. DIGIT 00039660
* IN THE NUMBER RELATIVE TO THE END OF 00039670
* THE FIELD (ADJUSTED FOR EXPA) 00039680
AR 1,0 REG 1 NOW CONTAINS NO. OF WHOLE NO. 00039690
* DIGITS IN THE NUMBER RELATIVE TO THE 00039700
* START OF THE FIELD 00039710
LR 15,0 00039720
LA 14,DIGATA+4 00039730
LR 2,14 00039740
AR 14,1 GET ADDR. OF POS. OF D.P. 00039750
SR 2,14 TO SEE IF D.P. BELOW START OF FIELD 00039760
BC 11,LOWEQXP BRANCH ZERO OR POS. NOT INSIDE FIELD 00039770
LA 2,DIGATA+12 ADDR. OF END OF FIELD 00039780
SR 2,14 TO SEE IF ADDR. ABOVE END OF FIELD 00039790
BC 13,UPEQXP BRANCH IF ZER OR NEG. NOT IN FD 00039800
SR 2,2 UOM
LTR 15,15 CHECK FOR NO EXP. BUT IN FIELD 00039810
BC 11,NOXPATAL ZERO OR POS. THEN BRANCH 00039830
BCTR 1,0 REDUCE NO. COUNT FOR PACK 00039840
EX 1,PCK2 PACK 00039850
LCR 1,0 GET NO. OF FRAC. DIGITS 00039860
BCTR 1,0 SUBTRACT 1 FOR PACK 00039870
EX 1,PCK3 PACK FRAC. -THAT RHYMES- 00039880
CVB 2,CHARATA+4 CONV. NO. AND FRAC. TO FLT. PT. 00039890
MVI DPA,X'4E' 00039900
ST 2,DPA+4 00039910
LD 0,DPA 00039920
AD 0,ZERO NO. IN FLT. PT. REG. 0 00039930
CVB 2,CHARATA+12 00039940
MVI DPA,X'4E' 00039950
ST 2,DPA+4 00039960
LD 2,DPA 00039970
AD 2,ZERO FRAC. IN FLT. PT. REG. 2 00039980
SLL 1,3 ADJUST TO FIND N IN 10**N 00039990
MD 2,CTBL+8(1) COMPUTE FRAC.*10**(-N) 00040000
ADR 0,2 NO. + FRAC.*10**(-N) 00040010
B COMNPART 00040020
LOWEQXP LH 1,DIGATA GET LENGTH OF NO. 00040030
BCTR 1,0 SUBTRACT 1 FOR PACK 00040040
EX 1,PCK2 PACK 00040050
CVB 14,CHARATA+4 CONVERT TO BIN. 00040060
LA 0,1(1,2) 00040070
COMPNO MVI DPA,X'4E' CONVERT NO. TO FLT. PT. 00040080
ST 14,DPA+4 00040090
LD 0,DPA 00040100
AD 0,ZERO 00040110
SR 1,1 COMPUTE NO. 00040120
LCR 0,0 00040130
BZ COMNPART DONE IF NO EXP. 00040140
AH 0,=H'64' 00040150
BP PLEXP 00040160
DD 0,DTBL+16 REDUCE NO. 00040170
AH 0,=H'32' RAISE EXP 00040180
PLEXP SRDL 0,4 4 BITS 00040190
SRL 1,25 00040200
DD 0,CTBL(1) FIRST 4 BITS OF EXP 00040210
SRDL 0,3 NEXT 3 BITS 00040220
SRL 1,26 00040230
DD 0,DTBL(1) 00040240
B COMNPART 00040250
UPEQXP AH 2,=H'1' 00040260
LA 1,9 00040270
NOXPATAL BCTR 1,0 SUBTRACT 1 FOR PACK 00040280
EX 1,PCK2 PACK 00040290
CVB 14,CHARATA+4 CONVERT TO BIN. 00040300
LR 0,2 0 NOW CONTAINS POWER OF 10 00040310
B COMPNO 00040320
COMNPART LTER 0,0 IS THE NUMBER 0.0 ? 00040330
BZ BERNS YES 00040340
STE 0,PVARG ROUND RESULT IF NOT 00040350
L 14,PVARG 00040360
SRL 14,24 00040370
STC 14,DOUBLCST 00040380
AD 0,DOUBLCST 00040390
BERNS LR 15,A SAVE A 00040400
LR Q,NILR CREATE ATOM 00040410
BAL 2,CONS 00040420
STE 0,0(A) 00040430
TM ATOMIND,X'04' CHECK FOR NEG. NO. 00040440
BZ NUMBPOS NO. 00040450
OI 0(A),X'80' 00040460
NUMBPOS MVI CDR(A),FWD 00040470
BAL 2,CONS 00040480
MVI CAR(A),FLOAT 00040490
LR 14,A 00040500
LR A,15 00040510
B ATOMEQ 00040520
EJECT 00040530
*********************************************************************** 00040540
********* TRYDOT *** TRYRPAR ******************* 00040550
***************************************************************** 00040560
TRSV2 DC F'0' SAVE RETURN, NOT RECURSIVE 00040570
TRYDOT MVI TC+1,C'.' SET TEST CHAR TO . 00040580
B TRYBL 00040590
TRYRPAR MVI TC+1,C')' SET TEST CHAR TO ) 00040600
TRYBL CLI 0(CHAR),C' ' SCAN OUT BLANKS 00040610
BNE TC 00040620
ST 2,TRSV2 00040630
NXTBL BAL 2,GETCHAR 00040640
CLI 0(CHAR),C' ' 00040650
BE NXTBL 00040660
L 2,TRSV2 00040670
TC CLI 0(CHAR),C'.' 00040680
BNE 4(2) NOT . OR ) 00040690
ST 2,TRSV2 00040700
BAL 2,GETCHAR 00040710
L 2,TRSV2 00040720
BR 2 00040730
EJECT 00040740
*********************************************************************** 00040750
******************* PRINT *************************************** 00040760
*********************************************************************** 00040770
P EQU 3 POINTER TO LINE POSITION 00040780
PRARGMNT DC F'0' 00040790
PRSV DC 2F'0' SAVE 2,3 00040800
PSV DC F'0' 00040810
LINEMAX DC A(LINE+100) LIMIT WHEN OUTPUTING CHARS 00040820
SUPMAX DC A(LINE+120) LIMIT FOR ATOMS 00040830
PRINT STM 2,3,PRSV 00040840
ST A,PRARGMNT 00040850
L P,PRTAB 00040860
TM CDR(A),X'40' 00040870
BZ PGOES NO 00040880
PEXIT LM 2,3,PRSV 00040890
L A,PRARGMNT 00040900
BR 2 00040910
PGOES TM CAR(A),ATOM 00040920
BZ PUTLIST ITS A LIST 00040930
BAL 2,PUTATOM 00040940
PWRT BAL 2,WRLINE 00040950
B PEXIT 00040960
PUTLIST LR Q,A 00040970
LA A,0 00040980
********* Q POINTS TO LIST BEING CURRENTLY OUTPUT 00040990
********* A IS A SCRATCH REG USED FOR SAVING PTRS 00041000
SAVE A 00041010
PLFTP MVI 0(P),C'(' LEFT PAREN 00041020
BAL 2,PCKOVR CHECK BUFFER AREA 00041030
PRNXT L A,CAR(Q) 00041040
LR 0,A CHECK CAR.
BAL 14,CKADDR
BZ PRCDR INVALID -- SKIP.
TM CAR(A),ATOM 00041050
BO PATM YES 00041060
LM Q,M,CAR(Q) 00041070
SAVE M 00041080
B PLFTP 00041090
PATM BAL 2,PUTATOM 00041100
PRCDR L Q,CDR(,Q)
CR Q,NILR 00041120
BE FNDNIL 00041130
PRLIST LR 0,Q CHECK CDR.
BAL 14,CKADDR
BZ FNDNIL INVALID -- SKIP.
TM CAR(Q),ATOM
BO PRDOT YES 00041150
BAL 2,PCKOVR 00041160
B PRNXT 00041170
PRDOT MVC 0(3,P),SNPPP+1 00041180
MVI 1(P),C'.' 00041190
LA P,2(0,P) 00041200
BAL 2,PCKOVR 00041210
LR A,Q 00041220
BAL 2,PUTATOM 00041230
FNDNIL MVI 0(P),C')' 00041240
BAL 2,PCKOVR 00041250
UNSAVE Q 00041260
LTR Q,Q 00041270
BZ PWRT 00041280
CR Q,NILR 00041290
BE FNDNIL 00041300
B PRLIST 00041310
PCKOVR LA P,1(,P) UP BY ONE 00041320
C P,LINEMAX 00041330
BL 0(2) OK YET 00041340
ST 2,PSV BETTER PRINT 00041350
BAL 2,WRLINE 00041360
L 2,PSV RESTORE 2 00041370
BR 2 00041380
*** PUT ATOM -A- TO BUFFER, PRINT IF OVER, -P- POINTS TO BUFF 00041390
PUTATOM ST 2,PSV SAVE IT 00041400
TM CAR(A),FIX 00041410
BO PRNUMB 00041420
L A,CAR(A) 00041430
PUTNXT LR 0,Q 00041440
LR 1,P
LR 14,A
PUTOFLO LR M,14
NEXTFWD LM Q,M,CAR(M) 00041460
NEXTCHR SLDL A,8 00041470
STC A,0(P) 00041480
LA P,1(0,P) 00041490
C P,SUPMAX 00041500
BL COMPRQ 00041510
LTR 1,1
BZ *+10
SR P,1
EX P,SPLAT
BAL 2,WRLINE
LTR 1,1
BZ COMPRQ
SR 1,1
B PUTOFLO
SPLAT MVC 0(0,1),BLANKS
COMPRQ LTR Q,Q 00041530
BNZ NEXTCHR 00041540
LA M,0(0,M) 00041550
CR M,NILR 00041560
BNE NEXTFWD 00041570
LR Q,0 00041580
B PUTAX 00041590
PRNUMB TM CAR(A),FLOAT 00041600
BO PRFLT YES 00041610
TM CAR(A),LOGIC IS IT A LOGICAL NUMBER ? 00041620
BO PRLOGIC YES 00041630
L A,CAR(A) 00041640
L A,CAR(A) NUMBER 00041650
CVD A,TEA TO PACKED 00041660
MVC WKA(12),MSK EDIT MASK 00041670
LA 1,WKA+11 00041680
EDMK WKA(12),TEA+2 00041690
BNM PRNO NOT NEG 00041700
BCTR 1,0 ROOM FOR SIGN 00041710
MVI 0(1),C'-' SET SIGN 00041720
PRNO LA 2,WKA+11 END OF AREA 00041730
SR 2,1 LENGTH OF NUMB-1 00041740
LA 0,1(P,2)
C 0,SUPMAX
BNH *+12
BAL 2,WRLINE
B PRNO
STC 2,*+5 SET LENGTH 00041750
MVC 0(1,P),0(1) TO PRINT AREA 00041760
LA P,1(P,2) UP P 00041770
TSTOVR C P,LINEMAX 00041780
BL PUTAX 00041790
BAL 2,WRLINE 00041800
PUTAX L 2,PSV 00041810
LR A,NILR 00041820
BR 2 00041830
PRLOGIC L A,CAR(A) GET ADDRESS OF PRINTNAME 00041840
LA 0,10(,P)
C 0,SUPMAX
BNH *+8
BAL 2,WRLINE
MVC TEA(4),CAR(A) MOVE LOGICAL NUMBER TO PACK AREA 00041850
MVC TEA+4(1),ZERO 00041860
MVI 0(P),C'0' 00041870
UNPK 1(9,P),TEA(5) 00041880
TR 1(8,P),SNPTR-240 TRANSLATE THE LOGICAL NO. 00041890
MVI 9(P),C'X' 00041900
LA P,10(0,P) 00041910
B TSTOVR 00041920
PRFLT EQU * 00041930
L A,CAR(A) 00041940
L 0,CAR(A) 00041950
LTR 0,0 00041960
BZ FPA0 00041970
LA 2,13(,P)
C 2,SUPMAX
BNH *+8
BAL 2,WRLINE
MVC TEA(4),CAR(A) MOVE NUMBER 00041980
MVI TEA,X'40' SET EXP 00041990
LE 0,TEA LOAD FP REG 00042000
IC 1,CAR(A) EXPONENT 00042010
SLDL 0,29 ALL BUT 3 BITS 00042020
SRL 1,26 BACK TO ADDRESS DBL WORDS 00042030
LR 2,1 SAVE IT 00042040
SRDL 0,4 NEXT 4 00042050
SRL 1,25 TO ADDR DBL WD 00042060
DD 0,DTRA(1) 00042070
SRL 1,2 TO HALF 00042080
LH M,DTRAH(1) 00042090
CE 0,DPNCON 00042100
BL *+20 00042110
LA 2,8(,2) UP BY ONE DBL WD 00042120
STE 0,TEA 00042130
MVI TEA,X'40' 00042140
LE 0,TEA 00042150
DD 0,DTRB(2) 00042160
SRL 2,2 TO HALF 00042170
AH M,DTRBH(2) 00042180
STD 0,TEA 00042190
TM TEA,X'01' 00042200
MVI TEA,X'00' 00042210
LM 0,1,TEA 00042220
BZ *+8 00042230
SLDA 0,4 00042240
* AT THIS POINT 0 AND 1 CONTAIN A 14 DIGIT BINARY INTEGER 00042250
* M HAS DECIMAL EXPONENT 00042260
FPA EQU CHARATA+4 00042270
D 0,=F'1000000000' 10**9 00042280
CVD 0,TEA LT 10**9 00042290
UNPK FPA+10(9),TEA+3(5) 00042300
OI FPA+18,X'F0' SET ZONE 00042310
CVD 1,TEA 00042320
UNPK FPA(10),TEA+2(6) NOW A 19 DIGIT NUMBER AT FPA 00042330
OI FPA+9,X'F0' DECIMAL POINT AT RIGHT OF FPA+18 00042340
LA 1,FPA+3 SET UP TRT 00042350
TRT FPA(3),TRTBL-240 FIND FIRST NON ZERO 00042360
LA 2,FPA+18 00042370
SR 2,1 COMPUTE DECIMAL POINT 00042380
AR M,2 EXPONENT 00042390
TM CAR(A),X'80' WAS NUMB NEG 00042400
BZ *+12 00042410
MVI 0(P),C'-' YES 00042420
LA P,1(,P) 00042430
MVC 0(1,P),0(1) MOVE ONE DIGIT 00042440
MVI 1(P),C'.' 00042450
MVC 2(6,P),1(1) 6 MORE DIGITS 00042460
MVC 8(4,P),DMSK 00042470
CVD M,TEA 00042480
ED 8(4,P),TEA+6 EDIT EXP 00042490
MVI 9(P),C'+' SET PLUS 00042500
BP *+8 SHOULD IT BE 00042510
MVI 9(P),C'-' NO 00042520
LA P,13(,P) -N.NNNNNNE-NN 00042530
B TSTOVR 00042540
FPA0 LA 0,3(,P)
C 0,SUPMAX
BNH *+8
BAL 2,WRLINE
MVC 0(3,P),CHZERO
MVI 1(P),C'.' 00042560
LA P,3(0,P) 00042570
B TSTOVR 00042580
*** 00042590
PRTAB DC A(LINE+5) START VALUE 00042600
PRIN1 STM 2,3,PRSV 00042610
TM CAR(A),ATOM MUST BE AN ATOM
BZR 2 IGNORE IF NOT
L P,PRTAB LEFT OFF HERE
BAL 2,PUTATOM 00042650
BCTR P,0 00042660
BAL 2,PCKOVR 00042670
ST P,PRTAB 00042680
LM 2,3,PRSV 00042690
BR 2 00042700
*** 00042710
* MOVE OVER N POSNS 00042720
XTAB L Q,CAR(A) 00042730
L Q,CAR(Q) 00042740
LPR Q,Q MUST BE POSITIVE 00042750
A Q,PRTAB 00042760
LR A,NILR 00042770
C Q,LINEMAX 00042780
BH TERPRI PRINT IT 00042790
ST Q,PRTAB 00042800
BR 2 00042810
* MOVE TO N'TH POSITION 00042820
TTAB L Q,CAR(A) 00042830
L Q,CAR(Q) 00042840
LPR Q,Q MUST BE POS 00042850
LA M,LINE 00042860
AR Q,M 00042870
LR A,NILR 00042880
C Q,SUPMAX 00042890
BH 0(2) 00042900
ST Q,PRTAB 00042910
BR 2 00042920
*** 00042930
TERPRI STM 2,3,PRSV 00042940
BAL 2,WRLINE 00042950
LM 2,3,PRSV 00042960
BR 2 00042970
DMSK DC X'C5212020' 00042980
TRTBL DC X'00' MUST HAVE 8 NON ZERO DIGITS AFT 00042990
MSK DC X'402020202020202020202120' BDD,DDD,DDD,DSD 00043000
WKA DC 4F'0' 00043010
TEN8 DC F'100000000' 00043020
DPNCON DC X'41100000' 00043030
EJECT 00043040
*********************************************************************** 00043050
********* RTRN ENTERED FROM COMPILER ******************************* 00043060
*********************************************************************** 00043070
RTRN UNSAVE 3 00043080
*********************************************************************** 00043090
******* RETURN *************************************************** 00043100
********************************************************************** 00043110
RETURN UNSAVE 2 GET LINK ADDR 00043120
BR 2 00043130
*********************************************************************** 00043140
******* SAVE *************************************************** 00043150
********************************************************************** 00043160
CNOP 0,4 00043170
NILG DC X'80',AL3(NILF) 00043180
ERG2 L A,NILG 00043190
ST A,NIL 00043200
PUTMSG ' *** G2-PUSHDOWN STACK OVERFLOW' 00043210
CR FREE,K4 STACK OFLOW IN GARBAGECOLL? 00043220
BNL ERDAN NO.
MVI ERRORIND,X'03' YES, FATAL ERROR 00043240
ERROR ' WHILE GARBAGECOLLECTING' 00043250
EJECT 00043340
*********************************************************************** 00043350
******* CONS *************************************************** 00043360
********************************************************************** 00043370
* MUST NOT DESTROY ANY REGISTERS 00043380
* END OF FREE LIST IS MARKED BY FREE EQUAL TO 1. THIS GIVES A 00043390
* SPECIFICATION EXCEPTION TO CAUSE A GARBAGE COLLECTION 00043400
CONS ST A,CAR(,FREE)
LR A,FREE
L FREE,CDR(,FREE)
ST Q,CDR(,A)
BR 2 00043450
EJECT 00043460
*********************************************************************** 00043470
******* GETCHAR *************************************************** 00043480
********************************************************************** 00043490
CARDEND DC A(0)
CARDLNTH DC A(CDEND)
INDCBADR DC A(0)
GETCHAR LA CHAR,1(,CHAR) NEXT CHAR 00043540
C CHAR,CARDEND 00043550
BLR 2 UOM
GETCD EQU * 00043570
L R1,INDCBADR 00043580
GET (R1) 00043590
LR CHAR,1 LOCN OF CARD 00043600
ST CHAR,LASTCHAR
A 1,CARDLNTH 00043610
ST 1,CARDEND 00043620
TM BUFFPR,X'01' 00043630
BZR 2 UOM
LA 0,120 COMPUTE MIN(LRECL,120).
L 1,INDCBADR
USING DCBDS,1
LH 1,LRECL#
DROP 1
CR 1,0
BNH *+6
LR 1,0
BCTR 1,0
MVC MSGBUFFR(8),=C' => ' PUT IN PREFIX.
STC 1,*+5 NOT RE-ENTRANT !!
MVC MSGBUFFR+8(0),0(CHAR) COPY LINE FOR PRINTING.
L R1,OTDCBADR USE OUTPUT DCB.
STM 13,1,WRSV
B PUTMSG2 PRINT THE INPUT LINE.
LASTCARD TM ERRIND,X'10' WERE WE READING A LIST 00043700
BZ OKEOF NO 00043710
MVI ERRORIND,X'03' TERMINAL ERROR 00043720
L A,EVLSV 00043730
L A,CAR(A) 00043740
SR Q,Q 00043750
ERROR ' *** R2-BAD BRACKET COUNT' 00043760
OKEOF PUTMSG ' *** END OF DATA' 00043770
B STOP 00043780
EJECT 00043790
*********************************************************************** 00043800
******* WRLINE *************************************************** 00043810
********************************************************************** 00043820
MARGIN1 DC A(LINE) 00043830
MARGIN2 DC A(MSGBUFFR) 00043840
OTDCBADR DC A(PRINTCB) 00043850
WRSV DC 6F'0' 00043860
*** WRLINE IS USED TO OUTPUT DATA AREA 'LINE' AND RESET IT 00043870
* TO BLANKS 00043880
WRLINE STM 13,1,WRSV 00043910
L 0,MARGIN1 00043920
L R1,OTDCBADR 00043930
PUT (R1),(0) 00043940
MVC LINE,BLANKS
LA P,LINE+5 00043970
ST P,PRTAB 00043980
LM 13,1,WRSV 00043990
BR 2 00044000
*** PUTMSG IS USED TO OUTPUT A MESSAGE, A VARIABLE LENGTH RECO: 00044010
PUTMSG L R1,OTDCBADR 00044020
CL 14,=F'4095' TEST MESSAGE LOCATION.
BH *+8 ADDRESS -- SKIP.
AL 14,=A(LISPMSG) DISPLACEMENT; CONVERT TO ADDRESS.
LH 15,0(,14) GET MESSAGE LENGTH-1.
STC 15,MSGMOVE+1 00044040
MSGMOVE MVC MSGBUFFR(1),2(14) 00044050
PUTMSG2 L 0,MARGIN2
PUT (R1),(0) 00044070
MVC MSGBUFFR,BLANKS
LM 13,1,WRSV 00044100
BR 2 00044110
EJECT ST 2,RESAV 00044120
PUTMSG SKIP 00044130
L 2,RESAV 00044140
LR A,NILR 00044150
BR 2 00044160
SKIP DC AL2(2),C'1 ' 00044170
EJECT 00044180
*********************************************************************** 00044190
******************* GARBAGE COLLECTOR ***************************** 00044200
********************************************************************** 00044210
LISPMSG CSECT
CNOP 6,8
GARBMS DC AL2(73)
GARBMS1 DC C'XXXXXXXX CELLS TOTAL; '
GARBMS2 DC C'XXXXXXXX CELLS ACTIVE; '
GARBMS3 DC C'XXXXXXXX STACK UNITS LEFT.'
LISP CSECT
CELLCNT DC F'0' NUMBER OF LISP CELLS.
GARBTM2 DC D'0' SAVE COUNTS AND CONVERT.
GARBTEMP DC 6F'0' SAVE ALL NEEDED REGISTERS
GARBCOLL STM 14,3,GARBTEMP
SAVE A 00044290
SAVE Q 00044300
SAVE M 00044310
LA 15,GARBCNT5
MARK DS 0H ENTRY TO MARK CELLS AND NOT COLLECT
LR Q,NILR COMPUTE PDS LEFT 00044320
SR Q,PDS 00044330
SRL Q,2(0) 00044340
ST Q,GARBTM2+4 00044350
LR A,K4 00044360
LR Q,PDS TOP OF STACK 00044370
** TRACE ALL ACTIVE LISTS AND MARK CELLS.
LA M,TEMPORAR USE STACK AND MISC. POINTERS.
NXTPUSH L 2,0(,M) GET NEXT ADDRESS ON STACK.
LR 0,2
BAL 14,CKADDR IS IT A VALID CELL ADDRESS?
BZ GARBCONT NO -- SKIP.
SR 3,3 YES; STACK ZERO.
SAVE 3
GARB2 TM CDR(2),X'80' IS CELL (R2) ALREADY MARKED?
BO GARB4 YES.
TM CDR(2),X'40' NO; IS IT A FULLCELL?
BO GARB3 YES.
OI CDR(2),X'80' NO; SET ACTIVE MARK.
LM 2,3,CAR(2) GET ITS CAR AND CDR.
TM CDR(3),X'80' IS CDR CELL MARKED?
BO GARB2 YES -- TRACE CAR.
SAVE 3 NO; STACK ADDRESS.
B GARB2
GARB3 OI CDR(2),X'80' MARK FULLCELL ACTIVE.
L 2,CDR(,2) GO DOWN FULLCELL LIST.
TM CDR(2),X'80' MARKED?
BZ GARB3 NO.
GARB4 UNSAVE 2 UNSTACK AN ADDRESS.
LTR 2,2 MORE ON THIS LIST?
BNZ GARB2 YES.
GARBCONT BXLE M,A,NXTPUSH ADVANCE STACK POINTER.
BR 15 RETURN IF ENTERED AT MARK
** NOW SCAN STORAGE FOR INACTIVE CELLS, AND COLLECT THEM.
GARBCNT5 DS 0H
AR A,A CELL LENGTH.
LR 3,NILR START WITH STATIC BLOCK.
L Q,BOTTOM
SR M,M ZERO THE INACTIVE COUNT.
LA 1,1
GARB51 TM CDR(3),X'80' IS CELL ACTIVE?
BNZ GARB6 YES -- SKIP.
ST FREE,CDR(,3) NO; PUT IT ON FREE LIST.
LR FREE,3
AR M,1 KEEP COUNT OF INACTIVE CELLS.
GARB6 NI CDR(3),X'7F' SET COLLECTION BIT OFF.
BXLE 3,A,GARB51 REPEAT FOR WHOLE BLOCK.
CL Q,BOTTOM WAS THIS THE STATIC BLOCK?
BNE *+8 NO.
LA 2,STORBLKS YES -- START DYNAMIC BLOCKS.
L 2,0(,2) GET NEXT BLOCK.
LTR 2,2 ALL BLOCKS SCANNED?
BZ GARB7 YES.
LA 3,8(,2) NO; POINT TO 1ST CELL.
L Q,4(,2) POINT TO END OF BLOCK.
B GARB51 GO SCAN IT.
GARB7 C M,=F'400' DID WE COLLECT ENOUGH?
BNL GARB10 YES -- SKIP.
LA 0,2 NO; GET ANOTHER BLOCK.
L 1,=A(SBLKSIZ)
L 15,=V(GETSPACE)
BASR 14,15
LTR 15,15 DID WE GET IT?
BNZ GARB10 NO -- SETTLE FOR WHAT WE HAVE.
LR 3,1 YES; COPY BLOCK ADDRESS.
LR Q,1 COMPUTE END OF BLOCK.
AL Q,=A(SBLKSIZ)
BCTR Q,0
ST Q,4(,3) SAVE END IN BLOCK HEADER.
SR 0,0
LA 2,8(,3) POINT TO 1ST CELL.
LA 1,8(,2) INITIALIZE THE BLOCK.
GARB8 STM 0,1,0(2)
LR 2,1
BXLE 1,A,GARB8
LR 1,FREE LINK AT HEAD OF FREE LIST.
STM 0,1,0(2)
LA FREE,8(,3)
L 1,STORBLKS ADD BLOCK TO BLOCK LIST.
ST 1,0(,3)
ST 3,STORBLKS
L 3,=A((SBLKSIZ-8)/8) GET NBR CELLS IN BLOCK.
AR M,3 ADD TO INACTIVE COUNT.
A 3,CELLCNT ADD TO TOTAL COUNT.
ST 3,CELLCNT
GARB10 TM GARBSW,X'01' IS VERBOS SWITCH ON?
BZ GARBSWT NO -- SKIP PRINTOUT.
L 3,GARBTM2+4 YES; GET PDS SPACE.
L 2,CELLCNT GET NBR OF LISP CELLS.
CVD 2,GARBTM2 PLUG INTO MESSAGE.
L 1,=A(GARBMS) BASE FOR MESSAGE
USING GARBMS,1
MVC GARBMS1(8),MASK
ED GARBMS1(8),GARBTM2+4
SR 2,M COMPUTE NBR ACTIVE CELLS.
CVD 2,GARBTM2 PLUG IN.
MVC GARBMS2(8),MASK
ED GARBMS2(8),GARBTM2+4
CVD 3,GARBTM2 STACK UNITS LEFT.
MVC GARBMS3(8),MASK 00044800
ED GARBMS3(8),GARBTM2+4 00044810
PUTMSG GARBMS 00044820
DROP 1
GARBSWT UNSAVE M 00044830
UNSAVE Q 00044840
UNSAVE A 00044850
LM 14,3,GARBTEMP
CR FREE,K4 COLLECT ANY 00044870
BNL CONS1 00044880
OI ERRORIND,X'03' TERMINAL ERROR AND NO PDL PRINT 00044890
ERROR ' *** GC2-STORAGE EXHAUSTED' 00044900
EJECT
* CHECK CELL ADDRESS IN GR0.
*
CKADDR LR 1,0 CLEAR ANY FLAG BITS.
LA 0,0(,1)
N 1,=X'00000007' MUST BE DOUBLEWORD.
BNZ CKADNO
CLR 0,NILR IS IT IN THE STATIC BLOCK?
BL CKADB
CL 0,BOTTOM
BNH CKADOK YES.
CKADB LA 1,STORBLKS NO; SEARCH DYNAMIC BLOCKS.
CKADNXT L 1,0(,1)
LTR 1,1 END OF LIST?
BZ CKADNO YES.
CLR 0,1 CHECK BEGINNING.
BNH CKADNXT NOT HERE.
CL 0,4(,1) CHECK END.
BH CKADNXT NOT HERE.
CKADOK LTR 0,0 OK; SET CC ~= 0.
BR 14
CKADNO SR 1,1 NO GOOD; SET CC=0.
BR 14
EJECT 00044950
LTORG 00044960
PUSHA DC A(PUSH) 00044970
NILA DC A(NIL) 00044980
BOTTOM DC A(TOP1+8*STORESIZ-8) POINTER TO END OF FWS 00044990
STORBLKS DC A(0) HEAD OF STORAGE BLOCK LIST
BPSSTART DC A(BPSST) 00045010
DC A(BPSST+4*BPSSIZE) 00045020
HASHTBL DC A(0) HASH TABLE POINTER
ENDHASH DC A(0) END OF HASH TALE
TEMPORAR EQU * THIS IS THE START OF A 25 00045030
* WORD AREA FOR THE STORAGE OF PTRS THAT MAY BE NEEDED AT 00045040
* GARBAGE COLLECTION. 00045050
OBJECTA DC A(OBJECT) POINTER TO START OF OBJECTLIST 00045060
GARBT DC 3F'0' 00045080
PROGT EQU GARBT TEMP IN CASE OF GARB COLLN 00045090
GOLIST EQU GARBT+4 TEMP IN CASE OF GARB COLLN 00045100
EVLSV DC 3F'0' 00045110
TAPPL DC 2F'0' 00045120
ARGS DC 20A(0) FOR ARGS 3 TO 22
* ====== END OF BASE 13 SECTION ==================================== 00045130
* ==================================================================== 00045140
* ==================================================================== 00045150
* ====== REGISTER 7 IS ALWAYS POINTING TO THE LAST SAVED =========== 00045160
* ====== ELEMENT IN THE STACK. REGISTER 7 MUST THEREFORE NEVER BE 00045170
* ====== USED IN THE ASSEMBLER OR IN THE INTERPRETER =========== 00045180
PUSH DS (STACKSIZ)F 00045190
CNOP 0,8 00045200
EJECT 00045210
*********************************************************************** 00045220
****************** OBJECT LIST ********************************** 00045230
*********************************************************************** 00045240
* THE MACRO 'ECHO' IS USED TO DEFINE THE OBJECT LIST. 00045250
* THE MACRO IS LABELLED IF THE GENERATED ATOM IS TO BE 00045260
* REFERRED TO BY ANOTHER ATOM. 00045270
* THE PARAMETERS ARE AS FOLLOWS. 00045280
* 1 - PRINT NAME (1 TO 8 CHARS) REQD 00045290
* 2 - PROPERTY OPTIONAL 00045300
* 3 - INTERNAL SUBRTN NAME REQD WITH 2 00045310
* 4 - NUMBER OF ARGS FOR 3 ZERO ASSUMED 00045320
* 00045330
* ******************************************* 00045340
* ATOMHEAD *X'MM' A(P1)* A(P2)* 00045350
* ******************************************* 00045360
* 00045370
* ******************************************* 00045380
* P1 *'ABCD' *X'40' A(P3)* 00045390
* ******************************************* 00045400
* 00045410
* ******************************************* 00045420
* P3 *'EF00' *X'40' A(NIL)* 00045430
* ******************************************* 00045440
* 00045450
* ******************************************* 00045460
* P2 * A(PROPERTY)* A(P4)* 00045470
* ******************************************* 00045480
* 00045490
* ******************************************* 00045500
* P4 * A(P5)* A(NIL)* 00045510
* ******************************************* 00045520
* 00045530
* ******************************************* 00045540
* P5 *X'NN' A(SUBRTN)*X'40' A(NIL)* 00045550
* ******************************************* 00045560
* 00045570
* 00045580
* MM X'80' ALPHABETIC ATOM 00045590
* X'C0' FIXED POINT ATOM 00045600
* X'E0' FLOATING POINT ATOM 00045610
* X'D0' LOGICAL ATOM 00045620
* 00045630
* NN IS THE NUMBER OF ARGUMENTS REQUIRED BY SUBRTN 00045640
* P2 AND P3 MAY BE NIL 00045650
* ==================================================================== 00045660
* ====== REGISTER 5 WHICH IS ALWAYS POINTING TO THE ATOM NIL ======= 00045670
* ====== IS ALSO USED AS A BASEREGISTER FOR THE BEGINNING OF === 00045680
* ====== THE OBJECT LIST ======================================= 00045690
* ====== REGISTER 5 IS ALSO USED AS A POINTER TO THE END OF THE ==== 00045700
* ====== STACK. BECAUSE THE ATOMHEAD OF NIL OCCUPIES THE FIRST = 00045710
* ====== WORD BEHIND THE STACK ================================= 00045720
PRINT NOGEN UOM
NIL DC X'80',AL3(NILF),A(NILB) 00045730
OBJECT DC A(NIL,NILF+8) START OF OBJECT LIST 00045740
NILB DC A(APVAL,NILC) 00045750
NILC DC A(NILE,NIL) 00045760
NILE DC A(NIL,NIL) 00045770
NILF DC CL4'NIL ',XL1'60',AL3(NIL) 00045780
ECHO CAR,SUBR,CARR,1 00045790
ECHO CDR,SUBR,CDRR,1 00045800
QUOTE ECHO QUOTE 00045810
ECHO CONS,SUBR,CONS,2 00045820
ECHO EVAL,SUBR,EVAL,2 00045830
ECHO DEFINE,SUBR,DEFINE,1 00045840
ECHO EQ,SUBR,EQ,2 00045850
ECHO EQUAL,SUBR,EQUAL,2 00045860
ECHO ATOM,SUBR,ATOMP,1 00045870
APVAL ECHO APVAL 00045880
EXPR ECHO EXPR 00045890
SUBR ECHO SUBR 00045900
COND ECHO COND 00045910
LAMBDA ECHO LAMBDA 00045920
DC A(*+8,*+20) 00045930
CHROBJ EQU * 00045940
BLANK DC XL1'80' 00045950
DC AL3(*+7) 00045960
DC A(NIL) 00045970
DC CL4' ',XL1'60',AL3(NIL) 00045980
AA ECHO A 00045990
ECHO B 00046000
ECHO C 00046010
ECHO D 00046020
ECHO E 00046030
DC A(F,G-8) 00046040
F DC XL1'80',AL3(PRINF),A(PROPF) 00046050
PRINF DC CL4'F ',XL1'60',AL3(NIL) 00046060
G ECHO G 00046070
ECHO H 00046080
ECHO I 00046090
ECHO 00046100
PERIOD ECHO . 00046110
ECHO < 00046120
DC A(*+8,*+20) 00046130
LPAR DC XL1'80' 00046140
DC AL3(*+7) 00046150
DC A(NIL) 00046160
DC CL4'( ',XL1'60',AL3(NIL) 00046170
PLUSS ECHO + 00046180
ECHO | 00046190
DC A(*+8,*+20) 00046200
DC XL1'80' 00046210
DC AL3(*+7) 00046220
DC A(NIL) 00046230
DC CL4'&& ',XL1'60',AL3(NIL) 00046240
ECHO J 00046250
ECHO K 00046260
ECHO L 00046270
ECHO M 00046280
ECHO N 00046290
ECHO O 00046300
ECHO P 00046310
ECHO Q 00046320
ECHO R 00046330
ECHO ! 00046340
DOLLAR ECHO $ 00046350
STAR ECHO * 00046360
DC A(*+8,*+20) 00046370
RPAR DC XL1'80' 00046380
DC AL3(*+7) 00046390
DC A(NIL) 00046400
DC CL4') ',XL1'60',AL3(NIL) 00046410
ECHO ; 00046420
ECHO ~ 00046430
DASH ECHO - 00046440
SLASH ECHO / 00046450
ECHO S 00046460
DC A(T,U-8) 00046470
T DC XL1'80',AL3(PRINTT),A(PROPT) 00046480
PRINTT DC CL4'T ',XL1'60',AL3(NIL) 00046490
U ECHO U 00046500
ECHO V 00046510
ECHO W 00046520
ECHO X 00046530
ECHO Y 00046540
ECHO Z 00046550
ECHO 00046560
DC A(*+8,*+20) 00046570
COMMA DC XL1'80' 00046580
DC AL3(*+7) 00046590
DC A(NIL) 00046600
DC CL4', ',XL1'60',AL3(NIL) 00046610
ECHO % 00046620
ECHO _ 00046630
ECHO > 00046640
ECHO ? 00046650
ECHO 0 00046660
ECHO 1 00046670
ECHO 2 00046680
ECHO 3 00046690
ECHO 4 00046700
ECHO 5 00046710
ECHO 6 00046720
ECHO 7 00046730
ECHO 8 00046740
ECHO 9 00046750
ECHO : 00046760
ECHO # 00046770
ECHO @ 00046780
DC A(*+8,*+20) 00046790
DC XL1'80' 00046800
DC AL3(*+7) 00046810
DC A(NIL) 00046820
DC CL4''' ',XL1'60',AL3(NIL) 00046830
EQSIGN ECHO = 00046840
DC A(PP,FEXPR-8) 00046850
PP DC XL1'80',AL3(PRINTPP),A(NIL) 00046860
PRINTPP DC CL4'" ',XL1'60',AL3(NIL) 00046870
PROPT DC A(APVAL,PROPT1) 00046880
PROPT1 DC A(PROPT2,NIL) 00046890
PROPT2 DC A(T,NIL) 00046900
PROPF DC A(APVAL,PROPF1) 00046910
PROPF1 DC A(PROPF2,NIL) 00046920
PROPF2 DC A(NIL,NIL) 00046930
FEXPR ECHO FEXPR 00046940
FSUBR ECHO FSUBR 00046950
LABEL ECHO LABEL 00046960
FUNARG ECHO FUNARG 00046970
DC A(ZEERO,ZEEROPNM+8) 00046980
ZEERO DC XL1'C0',AL3(ZEEROPNM),A(NIL) 00046990
ZEEROPNM DC F'0',XL1'60',AL3(NIL) 00047000
BPS ECHO BPS,APVAL,BPSSTART 00047010
ERRB ECHO ERRB 00047020
DOTERR1 ECHO DOTERR1 00047030
DOTERR2 ECHO DOTERR2 00047040
SYSIN ECHO SYSIN 00047050
SYSOUT ECHO SYSOUT 00047060
SYSPUNCH ECHO SYSPUNCH 00047070
INPUT ECHO INPUT 00047080
OUTPUT ECHO OUTPUT 00047090
LISPIN ECHO LISPIN 00047100
LISPOUT ECHO LISPOUT 00047110
LISPUNCH ECHO LISPUNCH 00047120
SYSFILE ECHO SYSFILE 00047130
LRECL ECHO LRECL 00047140
BLKSIZE ECHO BLKSIZE 00047150
TXTLEN ECHO TXTLEN UOM
ATEOF ECHO EOF 00047160
DC A(*+8,EEVQR) UOM
DC X'80' UOM
DC AL3(*+7) UOM
DC A(PRPEVQR) UOM
DC CL4'RES#',X'60',AL3(NIL) UOM
PRPEVQR DC A(APVAL,PROPEVQR) UOM
PROPEVQR DC A(ER##,PROP2EVQ) UOM
PROP2EVQ DC A(SPECIAL,PROP3EVQ) UOM
PROP3EVQ DC A(ER##,NIL) UOM
ER## DC A(NIL,NIL) UOM
EEVQR DS 0F
DC A(*+8,SPECIAL-8) 00047170
DC XL1'80' 00047180
DC AL3(*+7) 00047190
DC A(PRPALIST) 00047200
DC CL4'ALIS',XL1'60',AL3(PRNTALIS) 00047210
PRNTALIS DC CL4'T ',XL1'60',AL3(NIL) 00047220
PRPALIST DC A(APVAL,PROPALIS) 00047230
PROPALIS DC A(ALIST,SPECPROP) 00047240
ALIST DC A(NIL,NIL) 00047250
SPECPROP DC A(SPECIAL,PROPSPEC) 00047260
PROPSPEC DC A(ALIST,NIL) 00047270
SPECIAL ECHO SPECIAL 00047280
COMMON ECHO COMMON 00047290
TRACE ECHO TRACE,SUBR,TRACEE,1 00047300
ECHO BLANK,APVAL,BLANK 00047310
ECHO PERIOD,APVAL,PERIOD 00047320
ECHO LPAR,APVAL,LPAR 00047330
ECHO PLUSS,APVAL,PLUSS 00047340
ECHO DOLLAR,APVAL,DOLLAR 00047350
ECHO STAR,APVAL,STAR 00047360
ECHO RPAR,APVAL,RPAR 00047370
ECHO DASH,APVAL,DASH 00047380
ECHO SLASH,APVAL,SLASH 00047390
ECHO COMMA,APVAL,COMMA 00047400
ECHO EQSIGN,APVAL,EQSIGN 00047410
ECHO REMFLAG,SUBR,REMFLAG,2 00047420
ECHO FLAGP,SUBR,FLAGP,2 00047430
ECHO FLAG,SUBR,FLAG,2 00047440
ECHO READCH,SUBR,READCH,1 00047450
ECHO MAPLIST,SUBR,MAPLIST,2 00047460
ECHO VERBOS,SUBR,VERBOS,1 00047470
ECHO LITP,SUBR,LITP,1 00047480
ECHO FLOAT,SUBR,FLOATIT,1 00047490
ECHO FIX,SUBR,FIXIT,1 00047500
ECHO DIGP,SUBR,DIGP,1 00047510
ECHO BREAKP,SUBR,BREAKP,1 00047520
ECHO PLANT,SUBR,PLANT,2 00047530
ECHO PLANT1,SUBR,PLANT1,2 00047540
ECHO PLANTDC,SUBR,PLANTDC,2 00047550
ECHO PLANTSQ,SUBR,PLANTSQ,2 00047560
ECHO EXPLODE,SUBR,EXPLODE,1 00047570
ECHO GENSYM1,SUBR,GENSYM,1 00047580
ECHO CAAAR,SUBR,CAAAR,1 00047590
ECHO CDAAR,SUBR,CDAAR,1 00047600
ECHO CDDAR,SUBR,CDDAR,1 00047610
ECHO CDDDR,SUBR,CDDDR,1 00047620
ECHO CDADR,SUBR,CDADR,1 00047630
ECHO LAST,SUBR,LAST,1 00047640
ECHO RECLAIM,SUBR,RECLAIM 00047650
ECHO REMOB,SUBR,REMOB,1 00047660
ECHO RECIP,SUBR,RECIP,1 00047670
ECHO MAX,FSUBR,MAX 00047680
ECHO MIN,FSUBR,MIN 00047690
ECHO CSETQ,FSUBR,CSETQ,2 00047700
ECHO OPEN,SUBR,OPEN,3 00047710
ECHO CHKPOINT,SUBR,CHKPOINT,1 00047720
ECHO RESTORE,SUBR,RESTORE,1 00047730
ECHO CLOSE,SUBR,CLOSE,1 00047740
ECHO RDS,SUBR,RDSS,1 00047750
ECHO WRS,SUBR,WRS,1 00047760
ECHO INLL,SUBR,INLL,1 00047770
ECHO OTLL,SUBR,OTLL,1 00047780
ECHO LETP,SUBR,LETP,1 00047790
ECHO LENGTH,SUBR,LENGTH,1 00047800
ECHO ASA,SUBR,ASA,1 00047810
PRINT GEN 00047820
ECHO BPSZ,SUBR,BPSZ,0 00047830
PRINT NOGEN 00047840
ECHO MTS,SUBR,MTS UOM
ECHO BATCH,SUBR,BATCH UOM
ECHO ATTN,SUBR,ATTN,1 UOM
ECHO OTLLNG,SUBR,OTLLNG,0
ECHO ERRORSET,SUBR,ERRORSET,2
ECHO EXITERR,SUBR,EXITERR,1 00047850
ECHO MAPCAR,SUBR,MAPCAR,2 00047860
ECHO RLIT,SUBR,RLIT,1 00047870
ECHO RNUMB,SUBR,RNUMB,1 00047880
ECHO MKATOM,SUBR,MKATOM 00047890
ECHO ORDERP,SUBR,ORDERP,2 00047900
ECHO PRBUFFER,SUBR,PRBUFFER,1 00047910
ECHO EXPT,SUBR,EXPT,2 00047920
ECHO CAADR,SUBR,CAADR,1 00047930
ECHO EVCON,SUBR,EVCON,2 00047940
ECHO LEFTSHIFT,SUBR,LEFTSHIF,2 00047950
ECHO DIFFERENCE,SUBR,DIFF,2 00047960
ECHO REMAINDER,SUBR,REMAIND,2 00047970
ECHO LOGOR,FSUBR,LOGOR 00047980
ECHO LOGAND,FSUBR,LOGAND 00047990
ECHO LOGXOR,FSUBR,LOGXOR 00048000
ECHO EVENP,SUBR,EVENP,1 00048010
ECHO XTAB,SUBR,XTAB,1 00048020
ECHO TTAB,SUBR,TTAB,1 00048030
ECHO QUOTIENT,SUBR,QUOTIENT,2 00048040
ECHO NULL,SUBR,NULL,1 00048050
ECHO ADD1,SUBR,ADD1,1 00048060
ECHO SUB1,SUBR,SUB1,1 00048070
ECHO MINUS,SUBR,MINUS,1 00048080
ECHO PLUS,FSUBR,PLUS 00048090
ECHO TIMES,FSUBR,TIMES 00048100
ECHO APPEND,SUBR,APPEND,2 00048110
ECHO PROG,FSUBR,PROG 00048120
ECHO GO,FSUBR,GO,1 00048130
ECHO RETURN,SUBR,GORET,1 00048140
ECHO SET,SUBR,SET,2 00048150
ECHO CSET,SUBR,CSET,2 00048160
ECHO SETQ,FSUBR,SETQ,2 00048170
ECHO OBLIST,APVAL,OBJECT 00048180
ECHO CADR,SUBR,CADR,1 00048190
ECHO CDDR,SUBR,CDDR,1 00048200
ECHO CAAR,SUBR,CAAR,1 00048210
ECHO CDAR,SUBR,CDAR,1 00048220
ECHO CADDR,SUBR,CADDR,1 00048230
ECHO CADAR,SUBR,CADAR,1 00048240
ECHO PRINT,SUBR,PRINT,1 00048250
ECHO READ,SUBR,READ 00048260
ECHO GET,SUBR,GET,2 00048270
ECHO MEMBER,SUBR,MEMBER,2 00048280
ECHO EVLIS,SUBR,EVLIS,2 00048290
ECHO NCONC,SUBR,NCONC,2 00048300
ECHO PAIR,SUBR,PAIR,2 00048310
ECHO APPLY,SUBR,APPLY,3 00048320
ECHO APPEND1,SUBR,APPEND1,2 00048330
ECHO UNTRACE,SUBR,UNTRACE,1 00048340
ECHO AND,FSUBR,AND 00048350
ECHO OR,FSUBR,OR 00048360
ECHO MINUSP,SUBR,MINUSP,1 00048370
ECHO ZEROP,SUBR,ZEROP,1 00048380
ECHO LESSP,SUBR,LESSP,2 00048390
ECHO GREATERP,SUBR,GREATERP,2 00048400
ECHO ERROR,SUBR,ERRORR,1 00048410
ECHO NOT,SUBR,NULL,1 00048420
ECHO FIXP,SUBR,FIXP,1 00048430
ECHO FLOATP,SUBR,FLOATP,1 00048440
ECHO LIST,FSUBR,EVLIS,2 00048450
ECHO LOGP,SUBR,LOGP,1 00048460
ECHO PRIN1,SUBR,PRIN1,1 00048470
ECHO TERPRI,SUBR,TERPRI,0 00048480
ECHO DEFLIST,SUBR,DEFLIST,2 00048490
ECHO REMPROP,SUBR,REMPROP,2 00048500
ECHO FUNCTION,FSUBR,FUNCTION,1 00048510
ECHO ATTRIB,SUBR,ATTRIB,2 00048520
ECHO PROG2,SUBR,PROG2,2 00048530
ECHO NUMBERP,SUBR,NUMBERP,1 00048540
ECHO RPLACA,SUBR,RPLACA,2 00048550
ECHO RPLACD,SUBR,RPLACD,2 00048560
ECHO EJECT,SUBR,EJECT 00048570
ECHO DEBUG,SUBR,DEBUG,1 00048580
DC A(*+16,NIL) MARK END OF LIST 00048590
ECHO SASSOC,SUBR,SASSOCC,3 00048600
TOP1 DS (STORESIZ)D 00048610
BPSST DS (BPSSIZE+1)F 00048620
DS CL80 BUFFER UOM
EJECT UOM
* UOM
* DSECT FOR A LISP DCB UOM
* UOM
SPACE 1 UOM
DCBDS DSECT UOM
BFR$ DS A BUFFER LOC UOM
LEN$ DS A LENGTH LOC UOM
MDF$ DS A MODIFIERS LOC UOM
LIN$ DS A LINE NUMBER LOC UOM
FDUB$ DS A FDUB PTR LOC UOM
IORTN$ DS A I/O ROUTINE UOM
LRECL# DS H RECORD LENGTH
LEN# DS H TEXT LENGTH UOM
LIN# DS F LINE NUMBER UOM
MOD# DS F MODIFIERS UOM
FDUB# DS A FDUB PTR UOM
EODAD# DS A EOD ADDRESS UOM
INOUT# DS F I/O CODE UOM
FDUB2# DS XL4 FDUB PTR UOM
GDIV# DS A GDINFO OUTPUT VECTOR UOM
BUFSIZ# DS F BUFFER SIZE UOM
TXTLEN# DS F TEXT LENGTH UOM
NXTCHR# DS F NEXT-CHARACTER ADRS
LDCB EQU *-DCBDS LENGTH OF A LISP DCB UOM
END MAIN 00048630
</pre>
</body>
</html>