%INPUT LISP360 40 %OUTPUT NEWLISP.S LISP TITLE 'LISP360' UOM %DELETE '00000050' '00000080' &L SETA K'&MSG LISPMSG CSECT MSG&SYSNDX DC Y(&L-3),C&MSG &SYSECT CSECT &NAME LA 14,MSG&SYSNDX-LISPMSG B ERROR %DEL '00000280' '00000320' .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 %DEL '00000840' &NAME ST &R,0(,PDS) %DEL '00000910' L &R,0(,PDS) %AFT '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 %DEL '00001190' 3 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 %DEL '00001510' %DEL '00001880' '00002030' 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. %DEL '00002370' 2 MVC 0(LDCB,R2),OTMDLDCB OUTPUT BCD UOM MVC DDAREA(8),LUPCH MAKE IT USE SCARDS. %DEL '00002510' 3 MVC 0(LDCB,R2),INMDLDCB INPUT DCB UOM USING DCBDS,2 UOM MVC LRECL#,LRECL2 UOM %DEL '00002590' 4 MVC 0(LDCB,R2),OTMDLDCB OUTPUT DCB UOM MVC LRECL#,LRECL3 UOM %DEL '00002680' MVC 0(LDCB,R2),OTMDLDCB OUTPUT DCB UOM %DEL '00002790' 3 MVC 0(LDCB,R2),OTMDLDCB OUTPUT DCB UOM MVC LRECL#,LRECL2 UOM %DEL '00002830' 3 USERFIL5 MVC 0(LDCB,R2),INMDLDCB INPUT DCB UOM MVC LRECL#,LRECL2 UOM %DEL '00002910' MVC 0(LDCB,R2),OTMDLDCB OUTPUT DCB UOM %DEL '00002920' TM CAR(Q),ATOM UOM %DEL '00002970' MVC 0(LDCB,R2),INMDLDCB INPUT DCB UOM %DEL '00002980' TM CAR(Q),ATOM UOM %DEL '00003030' USEREX3 LA 0,1 OUTPUT CODE UOM LA 1,DDAREA UNIT NAME UOM OPEN , UOM %DEL '00003090' USEREX2 SR 0,0 INPUT CODE UOM LA 1,DDAREA UNIT NAME UOM OPEN , UOM %DEL '00003110' 2 USEREX1 MVC LRECL#,LRECL1 UOM %DEL '00003140' GETSTOR GETSPACE LDCB,T=2 SPACE FOR A DCB UOM %DEL '00003190' GETSTOR1 LR 2,1 UOM %AFT '00003210' ST 2,SAVE2A SAVE R2 UOM %DEL '00003340' MVC DDAREA,BLANKS BLANK UNIT NAME AREA. %DEL '00003370' 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 %DEL '00003390' STC A,0(15,14) UOM %DEL '00003460' BE DDNAMX2 UOM %DEL '00003490' STC A,0(15,14) UOM %DEL '00003510' 2 LA 15,1(,15) UOM BZ DDNAMX UOM %DEL '00003540' DDNAMX L M,CDR(M) NEXT BCD CELL UOM B NAMTEST UOM DDNAMX2 L 2,SAVE2A UOM %DEL '00003620' STH 15,LRECL# BUFFER SIZE UOM %DEL '00003630' LA M,TXTLEN UOM %DEL '00003650' ST 15,TXTLEN# UOM %DEL '00003680' NOP 0 UOM %DEL '00003820' %DELETE '00003860' '00003910' 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 %AFT '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 %DEL '00004150' %DEL '00004190' MVI T3+1,X'10' UOM %DEL '00004260' %AFT '00004310' BATCHF DC X'00' BATCH FLAG 00 -> CONV UOM %DEL '00004350' AGN DS 0H UOM %DEL '00004520' NOBUG TM GARBSW,X'01' IGNORE TITLES? UOM BZ SEQM1 YES UOM PUTMSG MA UOM %DEL '00004570' SEQM1 L Q,GARBT+4 UOM %DEL '00004660' 2 M 0,=F'5' UOM D 0,=F'384' UOM %AFT '00004700' TM GARBSW,X'01' UOM BZ SEQM2 UOM %DEL '00004720' SEQM2 BAL 2,PRINT UOM %DEL '00005210' 4 CARDIN DCB SCARDS,0,LASTCARD,0,0,'80000000' UOM PRINTCB DCB SPRINT,0,0,1,132 UOM %DEL '00005340' '00005350' MVC SNPA+19(100),BLANKS+4 %DEL '00005520' '00005530' MVC MSGBUFFR,BLANKS %DEL '00005580' '00005590' DS 0D MSGBUFFR DC CL129' ' FOR MESSAGES AND DUMPS SNPA EQU MSGBUFFR+1 %AFTER '00005630' DS 0D BLANKS DC CL(128+8)' ' LINE DC CL124' ',CL14' ' %DEL '00005840' 2 B EVQS UOM %AFT '00005900' EVQS ST A,ER## SAVE FOR RES# UOM %DEL '00006100' L A,CAR(,A) YES -- RETURN VALUE. %DEL '00006150' L A,CDR(,A) %DEL '00006210' L A,CAR(,A) FORM NOT AN ATOM; TRY QUOTE. %DELETE '00008110' %AFTER '00008130' TM 0(M),X'01' SHOULD IT BE TRACED %AFTER '00010130' C NILR,CAR(,A) BE EVNIL SKIP NIL %DEL '00010180' '00010190' L A,CAR(,A) L A,CAR(,A) CAAR %DELETE '00010300' EVNIL L A,CDR(,A) %DEL '00010760' '00010790' C Q,CAR(,A) COMPARE Y TO CAR(X). L A,CDR(,A) BNE GET L A,CAR(,A) %DEL '00010980' C A,CAR(,Q) %DEL '00011890' '00012130' 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. %DEL '00012250' '00012260' NCC L 1,CDR(,1) NCA C NILR,CDR(,1) %DELETE '00014070' '00014190' LR Q,A B PROGEX %AFTER '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 %AFTER '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. %DELETE '00014630' %DELETE '00014650' READCH3 NI READCHID,X'00' %DEL '00014770' '00015020' 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. %DELETE '00016120' MVC CHARATA+20(ATMSZ-12),CHARATA+4 %AFTER '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 %AFTER '00022260' ERRSET DC A(NIL,0) ARGS TO ERRORSET ERRARG DC A(NIL) ARG TO ERROR %AFTER '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. %DEL '00022490' %DEL '00022510' ERRPU LA 3,BASE3 %DEL '00022540' '00022550' 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. %DELETE '00022570','00022630' ERCK LR 0,A BAS 14,CKADDR BZR 2 %AFTER '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 %DELETE '00023180' CHKPCHK DC C'5313' MDDY %DEL '00023250' '00023260' PATCH DS 10F PATCH AREA CNOP 4,8 CHARATA DC H'0',Y(ATMSZ),CL(ATMSZ+4)' ' CHAR ATOM SCAN AREA %DELETE '00026270' '00026280' %DEL '00028090' TM 8(Q),X'C0' UOM %AFTER '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 %DELETE '00028950' 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. %DEL '00028980' '00029010' LA 1,CARDIN UOM %DEL '00029080' '00029130' 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. %DEL '00029310' '00029350' LA 14,20 FOR MARGIN1. B CINDY UOM %DEL '00029510' '00029560' ST 14,MARGIN1 LA 14,1 B CINDY UOM %DEL '00029640' '00029670' 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 %AFTER '00029920' *********************************************************************** ********* OTLLNG GET CURRENT OUTLINE LENGTH ********************** *********************************************************************** OTLLNG LR 14,2 L A,SUPMAX S A,MARGIN1 B MKFXAT MAKE IT A FIXED ATOM. %DELETE '00030230' '00030270' 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 %AFTER '00030710' L 2,STORBLKS CHECK FOR DYNAMIC CELL STORAGE. LTR 2,2 DO WE HAVE ANY ? BNZ ERRA2 YES --> CHKPOINT UNDEFINED. %DELETE '00030910' '00031180' 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 %DEL '00031400' 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) %DELETE '00031460' '00031690' 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 * %DELETE '00031710' '00031720' LA 2,GARBT L 1,PUSHA BCTR 1,0 %AFTER '00031750' LA FREE,1 TURN OFF THE FUNNY BITS BAL 14,GARBCOLL AND BUILD A FREE LIST %DEL '00032080' '00032150' CLOSE2 LR 1,M UOM CLOSE , CLOSE PRINTCB UOM %DELETE '00034360' TRRET ST A,PVARG %DELETE '00034370' UNSAVE 2 TM 0(2),X'01' SHOULD IT BE TRACED BZ CALLEXIT NOPE LR A,2 MOVE FOR PRVAL %DELETE '00034450' 2 TM TRACEIND,X'01' IS ANYTHING BEING TRACED BO TRACSUBR YES - DON'T MAKE ANY FAST LINKS THEN %AFTER '00034590' TM 0(A),X'01' IS FN BEING TRACED BZ *+8 NO %DELETE '00034630' '00034660' B TRRET TRACE RETURNED VALUE %DELETE '00034730' %DELETE '00034870' %DELETE '00035040' '00035340' 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) %DELETE '00035590' LASTCHAR DC A(0) %AFTER '00035690' LTR CHAR,CHAR IS THERE A CHARACTER YET? BNZ *+8 YES. BAL 2,GETCD NO; START AN INPUT RECORD. %DEL '00036640' '00036650' %DELETE '00037680' MVC CHARATA+20(ATMSZ-12),CHARATA+4 %DELETE '00038180' MVC CHARATA+20(ATMSZ-12),CHARATA+4 %DEL '00038400' %DELETE '00038480' '00038510' 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' %DELETE '00038530' '00038540' %DELETE '00038640' CKATEND SR 2,2 %DELETE '00038700' '00038800' %AFTER '00038840' ST A,0(0,1) STORE INTO HASH TABLE %AFT '00039540' SR 2,2 UOM %DEL '00039560' %AFT '00039800' SR 2,2 UOM %DEL '00039820' %AFTER '00041040' LR 0,A CHECK CAR. BAL 14,CKADDR BZ PRCDR INVALID -- SKIP. %DEL '00041110' PRCDR L Q,CDR(,Q) %DEL '00041140' PRLIST LR 0,Q CHECK CDR. BAL 14,CKADDR BZ FNDNIL INVALID -- SKIP. TM CAR(Q),ATOM %DEL '00041450' LR 1,P LR 14,A PUTOFLO LR M,14 %DEL '00041520' 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 %AFTER '00041740' LA 0,1(P,2) C 0,SUPMAX BNH *+12 BAL 2,WRLINE B PRNO %AFTER '00041840' LA 0,10(,P) C 0,SUPMAX BNH *+8 BAL 2,WRLINE %AFTER '00041970' LA 2,13(,P) C 2,SUPMAX BNH *+8 BAL 2,WRLINE %DEL '00042550' FPA0 LA 0,3(,P) C 0,SUPMAX BNH *+8 BAL 2,WRLINE MVC 0(3,P),CHZERO %DELETE '00042620' '00042640' TM CAR(A),ATOM MUST BE AN ATOM BZR 2 IGNORE IF NOT L P,PRTAB LEFT OFF HERE %DEL '00043230' BNL ERDAN NO. %DEL '00043260' '00043330' %DEL '00043410' '00043440' CONS ST A,CAR(,FREE) LR A,FREE L FREE,CDR(,FREE) ST Q,CDR(,A) %DEL '00043500' '00043530' CARDEND DC A(0) CARDLNTH DC A(CDEND) INDCBADR DC A(0) %DEL '00043560' BLR 2 UOM %AFTER '00043600' ST CHAR,LASTCHAR %DELETE '00043640' '00043690' 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. %DEL '00043890' '00043900' %DEL '00043950' '00043960' MVC LINE,BLANKS %DELETE '00044030' 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. %DEL '00044060' PUTMSG2 L 0,MARGIN2 %DEL '00044080' '00044090' MVC MSGBUFFR,BLANKS %DELETE '00044220' '00044280' 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 %AFTER '00044310' LA 15,GARBCNT5 MARK DS 0H ENTRY TO MARK CELLS AND NOT COLLECT %DELETE '00044380' '00044790' ** 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. %AFTER '00044820' DROP 1 %DELETE '00044860' LM 14,3,GARBTEMP %DELETE '00044910' '00044940' 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 %DEL '00045000' STORBLKS DC A(0) HEAD OF STORAGE BLOCK LIST %AFTER '00045020' HASHTBL DC A(0) HASH TABLE POINTER ENDHASH DC A(0) END OF HASH TALE %DEL '00045070' %AFTER '00045120' ARGS DC 20A(0) FOR ARGS 3 TO 22 %AFT '00045720' UOM PRINT NOGEN UOM %AFT '00047150' TXTLEN ECHO TXTLEN UOM %AFT '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 %AFT '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 %AFT '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 %AFTER FILEMARK %END