Trailing-Edge
-
PDP-10 Archives
-
ap-c800d-sb
-
cobold.mac
There are 14 other files named cobold.mac in the archive. Click here to see a list.
; UPD ID= 2013 on 8/22/79 at 1:25 PM by W:<WRIGHT>
TITLE COBOLD FOR COBOL V12
SUBTTL PROCEDURE DIV. SYNTAX SCAN W.NEELY/CAM/SEB
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1974, 1979 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
STRING==:STRING
ISAM==:ISAM
RPW==:RPW
SERCH==:SERCH
DBMS6==:DBMS6
DBMS4==:DBMS4
DBMS==:DBMS
DEBUG==:DEBUG
MCS==:MCS
TCS==:TCS
;EDITS
;NAME DATE COMMENTS
;V12*****************
;DAW 7-MAY-79 [707] FIX EDIT 670 - IT BROKE NESTED IF'S.
;DMN 4-APR-79 [675] CHECK FIND RSE 3 SYNTAX THAT COULD LOOK LIKE FIND RSE 5
;JSM 28-MAR-79 [670] FIX NESTED IF . ELSE PROBLEM
;DMN 20-MAR-79 [665] RECOVER CORRECTLY FROM PROCEDURE DIVISION MIS-SPELLED
;DAW 28-FEB-79 [645] FIX ERROR RECOVERY IN SORT STATEMENT; ALSO
;;; ADD RESTRICTION TO "MERGE" STATEMENT TO NOT ALLOW SUBSCRIPTING
;DMN 28-JAN-79 [631] DON'T USE ARG2 AT PA258. THUS PREVENTING CATASTROPHIE IN PHASE D
;DMN 12-DEC-78 [612] INITIALIZE FNOSUB AT THE START OF PHASE D (THIS WAS IN THE BWR FILE)
;DAW 11-OCT-78 [574] DON'T SET BIT 1 FOR USER-NAME EXTERNAL ENTRY (BIT WENT AWAY)
;EHM 17-SEP-78 [552] GIVE ERROR IF DECLAR. & NO END DECLARITIVES
;EHM 04-MAY-78 [535] FIX EDIT [273] FOR IF SET NOT EMPTY
;EHM 29-MAR-78 [532] FIX [511] TO PROCESS ERRORS CORRECTLY
;V11*****************
;SSC 28-SEPT-77 ADDED ACTIONS TO SUPPORT DBMS-V6 ENHANCEMENTS (AFTER PA321.)
;EHM 19-SEP-77 [511] MAKE NESTED SEARCH STATMENTS WORK
;VR 19-APR-77 [467] SET LN, CP AND RIGHT DIAG. MESSAGE FOR
; STATEMENT: GO TO -(NUMBER)
;EHM 28-JAN-77 [461] FIX TALLY FOR RECORD-NAME IN WRITE CAUSES CRASH
;EHM 17-JAN-77 [460] FIX THIS STATEMENT CANNOT BE REACHED AFTER SEARCH ALL
;VR 17-DEC-76 [455] FLAG SORT KEYS NOT DEFINED IN SD STATEMENT
; AS FATAL ERROR
;SSC 2-AUG-76 ADD DBMS S. U. ACTIONS
; 8-AUG-76 [435] FIX DECLARITIVES IN DBMS PROG SO THAT DBMS SECTION GOES AROUND IT
; 6-APR-76 [420] FIX FOR MISSING PERIOD ON OPEN STATEMENT
; 24-MAR-76 [413] FIX SEARCH MIXED WITH IF
; 30-JAN-76 [405] FIX QUALIFICATION OF SUBSCRIPTS
;GPS MAR-12-75 ADDED CODE TO COMPUTE LENGTH OF SU TABLES
;DBT MAR-7-75 REMOVE CANCEL ERROR MESSAGE WHICH CREPT BACK IN
;SSC MAR-5-75 PLACED 6A EDIT %316 DIRECTLY INTO V10
;GPS 12/23/74 ADD SIMULTANEOUS UPDATE
;DBT 12/1/74 CHANGE DA96. TO DA96.D TO AVOID ONESEG PROBLEM
;********************
; EDIT 363 FIX RECOVERY IF TOO MANY LEVELS OF SUBSCRIPTING.
; EDIT 362 RECOVER FROM ERROR IN SEARCH STATEMENT.
; EDIT 353 FIX DBMS IF STATEMENT WITH UNDEFINED VARIABLE TO FLAG CORRECT PLACE.
; EDIT 336 FIX FIND5 FROM GENERATING BAD ARG BLOCK FOR RECORD NAMES
; LONGER THAN 12 CHARS WHEN OPTIONAL WORD 'RECORD' NOT USED
; EDIT 333 ALLOW TALLY AS A SUBSCRIPT TO BE ADDED TO SUBTRACTED FROM
; EDIT 327 PUT IN GENERATED AFTER DECLARATIVES.
; EDIT 324 SET DECLARATIVE SWITCH IF PROGRAM HAS DECLARATIVES.
; EDIT 314 FIX RECOVERY IN A COMPUTE STATEMENT HAVING AN UNDEFINED VARIBLE.
; EDIT 313 DBMS- FIX IF STATEMENT ERROR MESSSAGE OHAVING UNDEFINED VARIABLE IN WORD FOLLOWING THE "IF ".
; EDIT 312 FIXSTATEMENTS FOLLOWING A GO TO PARAGRAPH.
; EDIT 307 FIX CANCEL
; EDIT 276 CHECK FOR RECORD NAME FOR WRITE, DELETE, REWRITE AND RELASE VERBS
; EDIT 273 DBMS FIX. ROUNED UP FOR ASCII WORD SIZE IS WRONG
; EDIT 271 FIX CATASTROPHIE IN PHASE D IF NO PARA NAME IMMEDIATELY AFTER SECTION NAME
; EDIT 265 ALLOW FIG CONSTANT "ZERO" FOR PERFORM LITERALS
; EDIT 262 FIXES HANLDING OF UNDEFINED SUBSCRIPT
; EDIT 261 FIXES CHECKING OF NAMTAB TABLE WHEN ITS END IS REACHED [261]
; EDIT FIX RELEASE AND RETURN SO THAT PARMS ARE ONLY IN SORT FILE [257]
;**; EDIT 250 ALLOW TALLY TO BE A SUBSCRIPT
;*:; EDIT 246 FIX MULTIPLE CALL "SUB".
;**; EDIT 244 FLAGS AS ERROR AN ELSE FOLLWING A PERIOD.
;**; EDIT 242 ALLOWS SUBCRIPTING FOR ITEMS WITH FILE NAME QUALIFIERS.
;**; EDIT 240 FIXES QUALIFICATION PROBLEM OF DATA NAMES
; USUALLY IN SEARCHES
;[222] /ACK FIX NULL TABLE LINK PROBLEM FOR CORRESPONDING OPTION
; AND FOR PERFORM VARYING'S.
;214 CHANGE FATAL TO WARNING IF MORE THAN 6 CHARS IN SUBPROGRAM NAME
;**; EDIT 172 FIXES 151 UNBALL PAREN CHECK DONE TOO SOON (AT SUB EXPRESSION LEVEL).
;**; EDIT 171 MAKES ENTER COBOL EQUIVALENT TO CALL.
;**; EDIT 137 GIVE ERROR MESSAGE IF SUBSCRIPT IS IN LINKAGE
; SECTION OR IF SUBSCRIPT IS SUBSCRIPTED.
;**; EDIT 165 FIXES COMPILER LOOP IF RIGHT PAREN MISSING FOR SUBSCRIPTED DATA-NAME.
;**; EDIT 155 FIXES "ADDRESS CHECK..." WHEN SORT FILE SHARES SAME BUFFER AREA
;**; EDIT 151 FIXES UNBALL PARENTHESIS PROBLEM IN COMPUTE STATEMENT
;**; EDIT 111 FIXES COMPILER LOOP FOR SEARCH ALL.. AT END STOP RUN-- STATEMENT
;**; EDIT110 OPEN STATEMENT DOES NOT GIVE PERIOD ASSUMED MESSAGE IF A
;**; PERIOD IS MISSING AND STATEMENT IS LAST ONE IN A PARA.
TWOSEG
SALL
RELOC 400000
ENTRY COBOLD
INTERN PASU8.,PASU9.,PASU6.,PASU66,PASU60,PASU61
INTERN PASU64,PASU63,PASU62,PASU4.,PASU7.,PASU41
INTERN PASU45,PASU40,PASU44,PASU42,PASU5.,PASU2.
INTERN PASU21,PASU20,PASU3.,PASU39,PASU38,PASU36
INTERN PASU34,PASU31,PASU37,PASU35,PASU30,PASU33
INTERN PASU1.,PASU19,PASU18,PASU17,PASU14,PASU10
INTERN PASU16,PASU12,PASU15,PASU13,PASU11
EXTERN FI.ACC, FI.RTC, FI.SKY,FI.NXT,FILLOC,FILNXT,CURFIL,LNKSET,DA.USG,DA.INS
EXTERN DTREE
EXTERN SURRTM,SURRT.,SUEQTM,SUEQT.,SUFBTM,SUFBT.
EXTERN BUFFER,BUFCTR,CPOPJ,CPOPJ1
EXTERN PASU4T,SU30F1,SU30F2,SU30FG,SU8CNT,SU8FLG
EXTERN SU8SVA,SU8SVB,SU8SVC
EXTERN DWLNCP,WORDLN,WORDCP
COBOLD: JRST 1,.+1 ;ENABLE CONCEALED MODE
SETFAZ D;
MOVE NODPTR,INDPTR##
IFN DEBUG,<
MOVE TE,CORESW##
SWOFF FNDTRC;
TRNE TE,TRACEP## ;TRACE PD NODES?
SWON FNDTRC; ;YES
>
SETZM PROGST## ;CLR FIRST PARA ADDR
SETZM DECLR.## ; [324] CLR DELCARITIVES IN PROG SWTICH
HRRZI TA,STRTD.## ;FIRST PD NODE
PUSH NODPTR,TA
PUSHJ PP,SQURL.## ;BEGIN
TTCALL 3,[ASCIZ "COBOLD--LOST; TOO MANY POPJ'S
"]
JRST KILL
SUBTTL PROCEDURE DIVISION ACTIONS
INTER. PA0.
PA0.: POP NODPTR,NODE ;POP UP CURRENT NODE
IFN DEBUG,<PUSHJ PP,PTPOP.##> ;IF TRACING, LIST NODE POPING UP TO
POPJ PP,
INTER. PA1.
PA1.: MOVE SAVPTR,ISVPTR## ;INITIALIZE PD POINTER
SWOFF FNOTF!UNCONT!INDECL!FARITH!FEXPR!FNOSUB ;[612]
SETZM OPRTR##
MOVE TA,[OPRTR,,OPRTR+1]
BLT TA,ARG3##+1
SETZM NSBSC1##
MOVE TA,[XWD NSBSC1,SBSCR1##]
BLT TA,5+SBSCR3##
SETZM CURSEC
SETZM LSTPRI##
SETZM PRIOR##
SETZM IFLVL##
SETZM SPFLVL##
SETZM NQUAL##
SETZM ELEVEL##
SETZM CLEVEL##
SETZM TOPLVL##
SETZM NXTSNT##
SETZM IMPLOP##
SETZM IMPLOP+1
SETZM TBLOCK
MOVE TA,[XWD TBLOCK,TBLOCK+1]
BLT TA,TBLOCK+24
SETZM VARBLK##
MOVE TA,[XWD VARBLK,VARBLK+1]
BLT TA,VARBLK+^D134 ;[222] WAS ^D80.
HRRZ TA,SECLOC##
SETZM 1(TA)
HRLZI TB,1(TA)
HRRI TB,2(TA)
BLT TB,^D200(TA)
SETZM USES##
MOVE TA,[XWD USES,USES+1]
BLT TA,USES+USES.L##-1
MOVE TA,VALLOC##
MOVEM TA,VALNXT##
SETZM 1(TA)
SETZM ARGLST##
MOVE TA,[XWD ARGLST,ARGL2##]
BLT TA,ARGL2+13
JRST PA219.
INTER. PA2.
PA2.: TLNE W1,GWLIT ;IS ITEM A LITERAL?
JRST PA2.L ;YES
TLZN W1,GWNOT ;IS ITEM IN NAMTAB?
JRST PA2.S ;YES
PUSHJ PP,BLDNAM## ;NO--PUT IT IN
HLRS TA
DPB TA,[POINT 15,W2,15]
PA2.S: TLZ W1,004000 ;'ROUNDED' BIT
MOVEM W1,ARG1## ;SAVE ITEM
MOVEM W2,ARG1+1
POPJ PP,
PA2.L: HLRZ TB,W1
ANDI TB,177 ;NO. OF CHARACTERS
JUMPN TB,PA2.L1 ;NULL LITERAL?
EWARNW E.183 ;YES
MOVE TA,[BYTE (7)7,7,7,7]
MOVEM TA,LITVAL## ;CREATE A DUMMY
HRRZI TB,4
PA2.L1: MOVE TC,[POINT 7,LITVAL]
MOVEM TC,TBLOCK+1 ;STORE POINTER TO LITERAL
MOVEM TB,TBLOCK##
HRRZI TB,5(TB)
IDIVI TB,5 ;NO. OF WORDS REQUIRED
HRRZI TA,(TB)
HRLI TA,CD.VAL ;VALTAB CODE
PUSHJ PP,GETENT## ;GET VALTAB ENTRY
HLR W1,TA ;UPDATE ITEM
MOVE TB,TBLOCK+1 ;'GET' POINTER
MOVE TC,[POINT 7,0(TA),6] ;'PUT' POINTER
HRRZ TD,TBLOCK ;COUNTER
DPB TD,TC
PA2.Q: SOJL TD,PA2.S
ILDB TE,TB ;GET CHARACTER
IDPB TE,TC ;SAVE
JRST PA2.Q
INTER. PA3.
PA3.: TSWTZ UNCONT;
JRST PA3.A
HLRZ TA,CURPAR##
JUMPE TA,PA3.A
PUSHJ PP,LNKSET
SETO TB,
DPB TB,PR.TUT##
HLRZ TA,CURSEC##
JUMPE TA,PA3.A
PUSHJ PP,LNKSET
SETO TB,
DPB TB,PR.TUT
PA3.A: MOVE TA,ARG1+1
SETZM OPRTR
DPB TA,OP.LNC## ;LN, CP
HRRZI TA,100 ;OP CODE FOR SECTION OPERATOR
PUSHJ PP,SETOP3
LDB TA,[POINT 15,ARG1+1,15]
HRRZI TB,CD.PRO ;PROTAB CODE
PUSHJ PP,FNDLNK## ;LOOK FOR PROTAB LINK
JRST PA3.P ;NONE FOUND
PA3.L: LDB TC,PR.SEC## ;PARAGRAPH/SECTION FLAG FROM PROTAB
JUMPE TC,PA3.E ;DUPLICATE SECTION NAME
PUSHJ PP,FNDNXT## ;NO--TRY AGAIN
JRST PA3.P ;NO MORE
JRST PA3.L ;TEST THIS ENTRY
PA3.P: TLO W2,GWDEF ;PUT DEFINING REFERENCE IN CREF FILE
LDB TA,[POINT 20,ARG1+1,35] ;USE LN&CP FOR THE NAME --
DPB TA,[POINT 20,W2,35] ; NOT THE PERIOD AFTER IT
MOVE TA,[NAMWRD,,NAMWRD+1] ;MOVE SECTION NAME BACK TO NAMWRD
SETZM NAMWRD##
BLT TA,NAMWRD+4
LDB TA,[POINT 15,ARG1+1,15]
HRRZ TB,NAMLOC##
ADDI TA,1(TB)
HRLI TA,(POINT 6,0)
MOVE TB,[POINT 6,NAMWRD]
PA3.X: HRRZ TC,.JBREL## ;SEE IF LAST ENTRY ENDED ON A K BOUNDARY
CAIG TC,(TA) ;IF SO, THATS THE END OF NAMTAB
JRST PA3.Y ;YES
ILDB TC,TA
TRNN TC,60 ;FINISHED YET?
JRST PA3.Y ;YES
IDPB TC,TB
JRST PA3.X
PA3.Y: PUSHJ PP,PUTCRF## ;INDICATE THAT SECT-NAME IS HERE DEFINED
MOVE TA,[XWD CD.PRO,SZ.PRO]
PUSHJ PP,GETENT ;GET AN ENTRY IN PROTAB
PUSHJ PP,PA4SUB ;STORE PTR TO PROTAB ENTRY
MOVE TC,LSTPRI ;PRIORITY OF LAST SECTION
MOVE TD,PRIOR ;PRIORITY OF NEW SECTION
CAMGE TC,SEGLIM## ;LAST SECTION NON-RESIDENT?
CAML TD,SEGLIM ;NO --- IS NEW ONE?
CAIN TC,(TD) ;ONE OR BOTH NON-RESIDENT
JRST PA3.P1 ;BOTH RESIDENT OR IN SAME SEGMENT
MOVE TE,ARG1
MOVEM TE,TBLOCK+21
MOVE TE,ARG1+1
MOVEM TE,TBLOCK+22 ;SAVE ARG1
MOVE TE,OPRTR
MOVEM TE,TBLOCK+23
MOVE TE,OPRTR+1
MOVEM TE,TBLOCK+24 ;AND OPERATOR
MOVEM TA,TBLOCK+20 ;PROTAB POINTER FOR NEW SECTION
SETZM OPRTR
SETZM OPRTR+1
SKIPN TA,CURSEC
JRST PA3.P0
LDB TB,PR.TUT ;IF SECTION ENDED WITH UNCONDITIONAL
JUMPN TB,PA3.P0 ;TRANSFER, SPECIAL GO NOT NEEDED
PUSHJ PP,PA25. ;CREATE 'GO TO' OPERATOR
HLRZ TA,TBLOCK+20 ;NEW SECTION PROTAB POINTER
HRRZM TA,ARG1 ;PUT IN OPERAND
SETO TB,
DPB TB,OP.CLN## ;SET SPECIAL FLAG SO THAT EXITS WILL
;BE GENERATED BEFORE THIS GO
PUSHJ PP,PA21. ;OUTPUT OPERAND
PUSHJ PP,PA22. ;AND OPERATOR
PA3.P0: MOVSI TA,104000
DPB W2,[POINT 20,TA,35]
HRRZI TB,104 ;SEGMENT BREAK OPERATOR
PUSHJ PP,PUTGEN
MOVE TE,TBLOCK+21
MOVEM TE,ARG1
MOVE TE,TBLOCK+22
MOVEM TE,ARG1+1
MOVE TE,TBLOCK+23
MOVEM TE,OPRTR
MOVE TE,TBLOCK+24
MOVEM TE,OPRTR+1
MOVE TA,TBLOCK+20
PA3.P1: MOVEM TA,CURSEC ;CURRENT SECTION
SETZM CURPAR ;NO CURRENT PARAGRAPH YET
HRRZ TE,SECLOC
HRRZI TE,1(TE)
HRLI TE,TD
MOVEM TE,PNTR
MOVE TD,PRIOR
CAMGE TD,SEGLIM ;IS CURRENT SECTION RESIDENT?
SETZ TD, ;YES
ASH TD,1 ;PRIORITY*2
SKIPE TA,@PNTR##
JRST PA3.P2 ;THIS SEGMENT WAS SEEN BEFORE
HLLZ TA,CURSEC
HLRS TA ;PROTAB POINTER FOR CURRENT SECTION
MOVEM TA,@PNTR ;SET UP AS BOTH FIRST AND LAST SECTION OF
;THIS PRIORITY
MOVE TB,GENWRD##
HRRZI TD,1(TD)
MOVEM TB,@PNTR ;INITIAL BLOCK OF THIS PRIORITY
MOVE TA,CURSEC
JRST PA3.Q
PA3.P2: MOVEM TD,TBLOCK+15
PUSHJ PP,LNKSET
MOVE TB,GENWRD
DPB TB,PR.GNW##
HLRZ TB,CURSEC
MOVE TD,TBLOCK+15
HRRM TB,@PNTR
MOVE TA,CURSEC
PA3.Q: HLRZM TA,ARG1 ;SET UP OPERAND TABLE LINK
LDB TB,[POINT 15,ARG1+1,15]
IORI TB,CD.PRO*1B20 ;TABLE TYPE CODE
MOVSM TB,(TA)
SETO TB,
DPB TB,PR.DEF## ;SET DEFINED BIT
TSWF INDECL;
DPB TB,PR.DFD## ;DEFINED IN DECLARATIVES
HRRZ TC,PRIOR
DPB TC,PR.PRI## ;PRIORITY
HLRZ TB,(TA) ;NAMTAB REL. ADDR.
ANDI TB,077777
HRRI TA,(TB)
MOVEM TA,TBLOCK ;SAVE PUTLNK PARAMETER
PUSHJ PP,PUTLNK## ;PUT ENTRY IN CHAIN
MOVE TA,[XWD CD.FLO,SZ.FLO]
PUSHJ PP,GETENT
SETO TB,
DPB TB,FL.PND## ;PROCEDURE-NAME DEFINITION FLAG IN FLOTAB
TSWF INDECL;
DPB TB,FL.RDC## ;REFERENCED IN DECLARATIVES
HLRZ TB,TBLOCK ;PROTAB ENTRY REL. ADDR.
DPB TB,FL.PRO## ;PUT PROTAB LINK IN FLOTAB
DPB W2,FL.LNC## ;PUT NAMTAB POINTER, LN, CP IN FLOTAB
MOVEM TA,CURFLO##
HLRZ TA,TBLOCK
PUSHJ PP,LNKSET## ;GET ADDRESS OF PROTAB ENTRY
HLRZ TB,CURFLO
DPB TB,PR.FLO## ;LINK PROTAB TO FLOTAB
POPJ PP,
PA3.E: SETO TC,
DPB TC,PR.MDF## ;MULTIPLY DEFINED
EWARNW E.171
JRST PA3.P
INTER. PA4.
PA4.: TSWTZ UNCONT;
JRST PA4.B
HLRZ TA,CURPAR
JUMPE TA,PA4.B
PUSHJ PP,LNKSET
SETO TB,
DPB TB,PR.TUT
PA4.B: LDB TA,[POINT 15,ARG1+1,15]
HRRZI TB,CD.PRO
PUSHJ PP,FNDLNK
JRST PA4.P ;NONE FOUND
PA4.L: LDB TD,PR.LSC## ;SECTION LINK
LDB TC,PR.SEC ;PARAGRAPH/SECTION FLAG
JUMPE TC,PA4.C ;THIS IS A SECTION
HLRZ TC,CURSEC ;PARAGRAPH
CAIN TC,(TD) ;IN CURRENT SECTION?
JRST PA4.E ;YES--ERROR
PA4.A: PUSHJ PP,FNDNXT ;MORE PROTAB ENTRIES FOR THIS NAME?
JRST PA4.P ;NO
JRST PA4.L
PA4.C: HRRZ TC,CURSEC ;CHECK TO SEE WHETHER
HLRZ TC,(TC) ;CURRENT SECTION HAS THE
HLRZ TB,(TA) ;SAME NAME AS THIS PARAGRAPH
ANDI TB,077777 ;NAMTAB POINTER OF THIS ENTRY
ANDI TC,077777 ;NAMTAB POINTER OF CURRENT SECTION
CAIN TB,(TC) ;SAME NAME AS THIS PARAGRAPH.
EWARNJ E.7 ;IT HAS--ERROR.
JRST PA4.A ;LOOK FOR MORE
PA4.P: TLO W2,GWDEF ;PUT DEFINING REFERENCE IN CREF FILE
LDB TA,[POINT 20,ARG1+1,35] ;USE LN&CP FOR THE NAME --
DPB TA,[POINT 20,W2,35] ; NOT THE PERIOD AFTER IT
PUSHJ PP,PUTCRF
MOVE TA,[XWD CD.PRO,SZ.PRO]
PUSHJ PP,GETENT ;GET ENTRY
PUSHJ PP,PA4SUB ;SAVE PTR TO PROTAB ENTRY
MOVEM TA,TBLOCK+1 ;SAVE ADDRESS
PUSHJ PP,PA3.Q ;SET IT UP
MOVE TA,TBLOCK+1
HLRZ TB,CURSEC ;REL. ADDR. OF CURRENT SECTION PROTAB ENTRY
DPB TB,PR.LSC ;SECTION LINK
SETO TB,
DPB TB,PR.SEC ;SET PARAGRAPH BIT
MOVEM TA,CURPAR ;SET UP CURRENT PARAGRAPH POINTER
POPJ PP,
PA4.E: SETO TC,
DPB TC,PR.MDF
EWARNW E.172
JRST PA4.P
;SAVE PTR TO PROTAB ENTRY
; AND SAVE INITIAL SECTION OR PARA NAME FOR START CODE
PA4SUB: MOVEM TA,CURPRO## ;SAVE PROTAB PTR
TSWT INDECL ;IN DECLARATIVES?
SKIPE PROGST ;INITIAL PARA NAME SAVED ALREADY?
POPJ PP, ;YES
HLRZ TB,TA ;GET THE PROTAB LINK
XORI TB,600000 ;CONVERT D-E TABLE CODE TO F-G CODE (4 BECOMES 2)
HRRM TB,PROGST ;SAVE ADDR OF INITIAL PROC NAME
POPJ PP,
INTER. PA5.
PA5.: SETZ TA,
EXCH TA,PRIOR ;PRIOR_0
MOVEM TA,LSTPRI
POPJ PP,
INTER. PA6.
PA6.: TLNN W1,GWLIT ;IS ITEM A LITERAL?
JRST PA6.E ;NO
TLNN W1,GWNLIT ;IS ITEM A NUM. LIT.?
JRST PA6.E ;NO
TLNE W1,GWDP ;IS IT INTEGER?
JRST PA6.E ;NO
HLRZ TB,W1
ANDI TB,177
MOVEM TB,CTR## ;LENGTH
HRRZI TA,LITVAL ;LOCATION
PUSHJ PP,GETVAL##
JUMPL TC,PA6.E ;NEGATIVE
CAILE TC,143 ;99. IS MAXIMUM
HRRZI TC,143
CAMGE TC,SEGLIM ;IS THIS RESIDENT?
TDZA TC,TC ;YES
SETOM NRESSN## ;NO, SIGNAL NON-RESIDENT SECTION SEEN
MOVEM TC,PRIOR
POPJ PP,
PA6.E: MOVE TC,LSTPRI
MOVEM TC,PRIOR
EWARNJ E.25
INTER. PA7.
PA7.: HLRZ TA,CURSEC
JUMPE TA,CPOPJ ;NO SECTION LINK
PUSHJ PP,LNKSET
HRRZ TC,PRIOR
DPB TC,PR.PRI ;PUT PRIORITY IN PROTAB ENTRY
POPJ PP,
INTER. PA8.
PA8.: HRRZI TA,66 ;USE OP CODE (NEVER OUTPUT)
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.USE##
POPJ PP,
INTER. PA9.
PA9.: SETO TA,
DPB TA,OP.AFT## ;SET AFTER BIT
POPJ PP,
INTER. PA10.
PA10.: SETZ TA,
DPB TA,OP.AFT ;SET BEFORE BIT
POPJ PP,
INTER. PA11.
PA11.: HRRZI TA,75 ;ERROR USE
JRST SETOP3
IFN ANS68,<
INTER. PA12.
PA12.: SETO TA,
DPB TA,OP.BEG## ;SET 'BEGINNING' BIT IN OPERATOR
POPJ PP,
INTER. PA13.
PA13.: SETO TA,
DPB TA,OP.END## ;SET 'ENDING' FLAG IN OPERATOR
POPJ PP,
>
INTER. PA14.
PA14.: SETO TA, ;SET ERROR-PROCEDURE-ON-OPEN BIT
DPB TA,OP.OPN##
POPJ PP,
IFN ANS68,<
INTER. PA15.
PA15.: SETO TA,
DPB TA,OP.FIL## ;SET 'FILE' FLAG IN OPERATOR
POPJ PP,
INTER. PA16.
PA16.: SETO TA,
DPB TA,OP.UNT## ;SET 'REEL' ('UNIT') FLAG IN OPERATOR
POPJ PP,
INTER. PA17.
PA17.: POPJ PP,
>
INTER. PA18.
PA18.: HRRZI TA,2
DPB TA,OP.USE ;I-O USE
POPJ PP,
INTER. PA19.
PA19.: HRRZI TA,0
DPB TA,OP.USE ;INPUT USE
POPJ PP,
INTER. PA20.
PA20.: HRRZI TA,1 ;OUTPUT USE
DPB TA,OP.USE
POPJ PP,
IFN ANS74,<
INTER. PA20X.
PA20X.: SETO TA, ;EXTEND USE
DPB TA,OP.XTD##
POPJ PP,
>
INTER. PA21.
PA21.: SETZM TBLOCK+7 ;FLAG SAYS THIS IS NOT A SUBSCRIPT
PA21.0: HRRZ TB,ARG1 ;R. H. OF GETSRC W1
MOVE TA,ARG1+1 ;GETSRC W2
MOVE TE,TA ;W2
MOVE TD,ARG1 ;W1
AND TA,[XWD 3,777777] ;LN, CP
TLO TA,400000 ;SET OPERAND BIT
TLNN TD,GWLIT ;IS ITEM A LITERAL?
JRST PA21.A ;NO
SETZM NSBSC1
TLO TA,GNLIT ;YES--SET LITERAL BIT
TLNE TD,GWASCI ;IS ITEM 'PURE' ASCII?
TLO TA,020000 ;YES -- SET BIT
TLNE TD,GWNLIT ;IS ITEM A NUMERIC LITERAL?
TLO TA,GNNUM ;YES--SET NUMERIC LITERAL BIT
JUMPE TB,PA21.E
PA21.B: TLNE TD,GWALL ;'ALL' ITEM?
TLO TA,GNALL ;YES--SET ALL BIT
SETZM ARG1
SETZM ARG1+1
IFN ANS74,<
JRST PUTGEN ;OUTPUT ARG1
>
IFN ANS68,<
CAIN TC,TALLY ; [333] TALLY
SKIPN TBLOCK+7 ; [333] TALLY- IS IT A SUBSCRIPT?
JRST PUTGEN ; [333] NO PUT LITERAL IN GENFIL
MOVE TD,TBLOCK+6 ; [333] GET INDEX TO SUBSCRIPT TABLE
ASH TD,2 ; [333] 4 WORDS EACH
SKIPN SBSCR1+2(TD) ; [333] DOES TALLY HAVE AN ADDITIVE?
JRST PUTGEN ; [333] NO PUT INTO GENFIL
MOVEI TC,1 ; [333] ASSUME +
SKIPGE SBSCR1(TD) ; [333] UNLESS IT WAS -
MOVEI TC,2 ; [333]
DPB TC,[POINT 2,TB,11] ; [333] STORE ADDITIVE OPERATOR
JRST PUTGEN ; [333] NO PUT TALLY OPERAND INTO GENFIL
>
PA21.A: TLNN TD,GWFIGC ;IS ITEM A FIGURATIVE CONSTANT?
JRST PA21.C ;NO
SETZM NSBSC1
TLO TA,GNLIT!GNFIGC ;YES---SET FIGURATIVE CONSTANT BIT
HLRZ TC,TD
ANDI TC,777 ;YES--GET VALUE
SETZ TE,
CAIN TC,HIVAL.
HRLZI TE,GNFCHV ;HIGH-VALUE(S)
CAIN TC,LOVAL.
HRLZI TE,GNFCLV ;LOW-VALUE(S)
CAIN TC,QUOTE.
HRLZI TE,GNFCQ ;QUOTE(S)
CAIN TC,ZERO.
HRLZI TE,GNFCZ ;ZER0((E)S)
CAIN TC,SPACE.
HRLZI TE,GNFCS ;SPACE(S)
IFN ANS68,<
CAIN TC,TALLY
HRLZI TE,GNTALY ;TALLY
>
CAIN TC,TODAY
HRLZI TE,GNTODY ;TODAY
IOR TA,TE ;SET APPROPRIATE BITS
JRST PA21.B
PA21.C: TLNE TD,004000 ;ROUNDED?
TLO TB,200000 ;YES
TLNN TE,400000 ;FLOTAB ENTRY?
JRST PA21.D ;NO
SETZM NSBSC1
TLO TB,100000 ;YES--SET BIT IN OPERAND WORD
JRST PUTFT
PA21.D: HRRZI TC,(TD) ;TABLE LINK
JUMPE TC,PA21.E ;NULL
LSH TC,-17 ;TABLE TYPE CODE
CAIN TC,CD.CON ;CONTAB?
JRST PUTFT ;YES, DON'T CLR NSBSC1
CAIN TC,CD.DAT ;DATAB?
JRST .+3
SETZM NSBSC1
JRST PUTFT ;NO--OUTPUT AS IS
MOVEM TA,TBLOCK
MOVEM TB,TBLOCK+1
MOVEM TD,TBLOCK+2
MOVEM TE,TBLOCK+3
HRRZ TA,TB ;LINK
PUSHJ PP,LNKSET ;ABS. ADDR. OF DATAB ENTRY
MOVE TC,TA ;ENTRY ADDRESS
MOVE TA,TBLOCK
MOVE TB,TBLOCK+1
MOVE TD,4(TC) ;WORD 5 OF DATAB ENTRY
TRNE TD,100 ;LINKAGE SECTION
TLO TA,(LKSFLG) ;YES
TLNE TD,100000 ;SYNC LEFT?
TLO TA,010000 ;YES
TLNE TD,040000 ;SYNC RIGHT?
TLO TA,004000 ;YES
TLNE TD,000010 ;JUST RIGHT?
TLO TA,001000 ;YES
TLO TA,002000 ;SET NUMERIC BIT
TLNE TD,400000 ;NOT NUMERIC
TLNE TD,200000 ;SKIP IF NUMERIC
TLZ TA,002000 ;TURN OFF NUMERIC BIT
TRNE TD,400000 ;DD ERROR?
TLO TB,400000 ;YES
EXCH TA, TC ;PUT DATAB OFFSET IN TA & SAVE TC.
LDB TD, DA.USG## ;PICK UP THE ITEM'S USAGE.
EXCH TA, TC ;PUT THINGS BACK THE WAY THEY WERE.
DPB TD, [POINT 4,TA,13] ;PUT THE USAGE IN THE FIRST GENFIL WORD.
PUTFT: SKIPN TBLOCK+7 ;DOING A SUBSCRIPT?
JRST PUTFT0 ;NO
MOVE TD,TBLOCK+6 ;GET INDEX TO SUBSCRIPT TABLE
ASH TD,2 ;4 WORDS EACH
SKIPN SBSCR1+2(TD) ;DOES IT HAVE AN ADDITIVE?
JRST PUTFT0 ;NO
MOVEI TC,1 ;ASSUME +
SKIPGE SBSCR1(TD)
MOVEI TC,2 ;NO, -
DPB TC,[POINT 2,TB,11] ;STORE ADDITIVE OPERATOR
PUTFT0: SETZM ARG1
SETZM ARG1+1
HRRZI TC,(TB)
JUMPE TC,PA21.E
SKIPN TD,NSBSC1 ;NUMBER OF SUBSCRIPTS
JRST PUTGEN
HRRZM TD,TBLOCK+6
MOVNI TC,MAXSUB## ;ALSO COUNT ADDITIONS TO SUBSCRIPTS
MOVSI TC,(TC)
PUTFT3: SKIPE SBSCR1+2(TC) ;THIS SUBSCRIPT HAVE AN ADDITIVE?
AOJ TD, ;YES
ADDI TC,3 ;AIM AT NEXT SUBSCRIPT
AOBJN TC,PUTFT3
DPB TD,[POINT 6,TB,17]
PUSHJ PP,PUTGEN
PUTFT1: SOSGE TD,TBLOCK+6
JRST PUTFT2
ASH TD,2
HRLZI TC,SBSCR1(TD)
HRRI TC,ARG1
BLT TC,ARG1+1
SETZM NSBSC1
AOS TBLOCK+7 ;TELL PA21. WE ARE DOING A SUBSCRIPT
PUSHJ PP,PA21.0
MOVE TD,TBLOCK+6 ;GET INDEX TO SUBSCRIPT TABLE
ASH TD,2
SKIPN TA,SBSCR1+2(TD) ;IS THERE AN ADDITIVE?
JRST PUTFT1 ;NO
MOVE TB,SBSCR1+3(TD) ;YES, GET 2ND WORD OF ADDITIVE
MOVEM TA,ARG1
MOVEM TB,ARG1+1
PUSHJ PP,PA21.
JRST PUTFT1
PUTFT2: MOVE TA,[XWD NSBSC1,SBSCR1]
MOVEI TB,MAXSUB*4-1
BLT TA,SBSCR1(TB)
POPJ PP,
PA21.E: TTCALL 3,[ASCIZ /PA21.--NULL TABLE LINK
/]
HRRZI TA,105 ;'YECCH' OP CODE
PUSHJ PP,SETOP3
EWARNJ E.263
; THIS ROUTINE OUTPUTS THE OPERATOR. IT ALSO CHECKS
;FOR STATEMENTS THAT CAN'T BE REACHED
INTER. PA22.
PA22.: LDB TC,OP.OP2## ;OP CODE
CAIN TC,105 ;YECCH?
JRST PA22.A ;YES
CAIE TC,26 ;ENDIF OPERATOR?
JRST PA22.Z
PA22.A: SWOFF UNCONT;
JRST PA22.C
PA22.Z: TSWT UNCONT;
JRST PA22.B
CAIN TC,20 ;IF <, ETC.
JRST PA22.C
CAIG TC,50 ;COMPUTE ARITHMETIC OPERATOR?
JRST PA22.Q ;NO
CAIG TC,57
JRST PA22.C ;YES
; /DAW 8-MAR-79: IF A DISPLAY (OP CODE 61) FOLLOWS A STOP RUN
;IT DOESN'T GET FLAGGED. OPEN,CLOSE, AND SEVERAL MORE ALSO WOULDN'T
;GET FLAGGED. THE TEST FOR TYPE=PERIOD IS MADE AT THE END OF PARSING
;THESE STATEMENTS, THEREFORE IT SUCCEEDS!.
; SINCE IT IS DIFFICULT TO FIGURE OUT WHERE COMMENTING
;OUT THE CHECKING OF AC "TYPE" MIGHT CAUSE PROBLEMS, I LEFT THE TEST FOR
;"WHEN" IN.. HOPEFULLY NOTHING WILL BREAK!!
; CAIE TYPE,PRIOD. ;PERIOD OK
CAIN TYPE,WHEN. ;ARE WE LOOKING AT A "WHEN"?
JRST PA22.C ;YES - ITS LEGAL
CAIL TC,70 ;COMPUTE OPERATOR?
CAILE TC,73
JRST PA22.Q ;NO
JRST PA22.C
PA22.Q: LDB LN,OP.LN##
LDB CP,OP.CP##
HRRZI DW,E.188 ; % THIS STATEMENT CANNOT BE REACHED
PUSHJ PP,WARN##
LDB TC,OP.OP2
PA22.B: CAIE TC,30 ;IS IT 'GO'?
JRST PA22.D ;NO
LDB TC,OP.CLN ;SPECIAL TYPE?
JUMPN TC,PA22.C ;YES
SWON UNCONT;
PA22.C: MOVE TA,OPRTR ;OUTPUT
MOVE TB,OPRTR+1 ;OP
SETZM OPRTR
SETZM OPRTR+1
JRST PUTGEN
PA22.D: CAIE TC,40 ;'STOP'?
JRST PA22.C ;NO
LDB TB,OP.RUN## ;'RUN'?
JUMPE TB,PA22.C ;NO
SWON UNCONT;
JRST PA22.C
INTER. PA23.
PA23.: SWON FARITH;
PA23.1: PUSHJ PP,SKPSRC##
TSWF FEOF;
JRST PA23.X
CAIE CP,7
JRST PA23.1
PA23.2: PUSHJ PP,SKPSRC
TSWF FEOF;
JRST PA23.X
CAIL CP,^D12
JRST PA23.1
CAIN CH," "
JRST PA23.2
PA23.X: SWOFF FARITH;
SWON FREGCH;
SKPNAM
INTER. PA23.Z
PA23.Z: SWOFF FREGWD ; [312] MAKE SURE WE DON'T REGET BAD WORD
PUSHJ PP,GETITM##
SKPNAM
INTER. PA24.
PA24.: SWON FREGWD;
POPJ PP,
INTER. PA25.
PA25.: HRRZI TA,30 ;'GO TO' OP CODE
JRST SETOP
INTER. PA26.
PA26.: SKIPN ARG1
SKIPE ARG1+1
PUSHJ PP,PA21. ;PUT OUT ARG1 IF NOT NULL
PUSHJ PP,PA22. ;PUT OUT OP
HLRZ TA,CURPAR
JUMPE TA,PA26.E
PUSHJ PP,LNKSET ;PROTAB ENTRY OF CURRENT PARAGRAPH
SETO TB,
DPB TB,PR.ALT## ;SET ALTERABLE FLAG IN PROTAB
POPJ PP,
PA26.E: TTCALL 3,[ASCIZ /PA26.--NO PROTAB LINK FOR PARAGRAPH NAME
/]
EWARNW E.262
JRST KILL
INTER. PA27.
PA27.: PUSHJ PP,PA21.
PUSHJ PP,PA24.
HRRZI NODE,PD153.##
MOVEM NODE,(NODPTR)
HRRZI NODE,PD157.##
PUSH NODPTR,NODE
HRRZI NODE,PD395F##
PUSH NODPTR,NODE
POPJ PP,
;SEE IF WE WERE PROCESSING A CONDITIONAL FOR 'IF' OR WHETHER WE WERE
; JUST DOING AN ORDINARY DATA NAME.
INTER. PA28.
PA28.: MOVE TB, [XWD PD643A##,PD669.##]
JRST PA28.1+1 ;GET TRACE RIGHT
INTER. PA28.1
PA28.1: MOVE TB, [XWD PD643A##,PD714.##]
HRRZ TA, ARG1 ;GET THE TABLE LINK.
LSH TA, -17 ;ISOLATE THE TABLE CODE.
CAIN TA, CD.CON ;IS IT CONTAB?
JRST PA0. ;YES, POP UP TO THE NODE WE
; PUSHED DOWN FROM.
; IT WASN'T A CONDITIONAL - TRY TO FAKE OUT SQUIRL.
HLRZM TB, (NODPTR) ;PRETEND WE WERE AT PD643A
HRRZM TB, -1(NODPTR) ; AND HAD PUSHED DOWN FROM
; PD669 OR PD714.
PJRST PA111. ;GO PUT OUT INITIAL GENFIL CODE
; FOR "EXPR" OPERATOR.
;PREVENT ERROR MESSAGE "PERIOD ASSUMED" WHEN "NOTE MUMBLE." IS THE
; LAST THING IN THE PROGRAM.
INTER. PA29.
PA29.: TSWT FEOF; ;WAS THAT THE END?
SWONS FREGWD; ;NO, REGET THE TOKEN.
PUSHJ PP, PA0. ;IF IT WAS THE END, POP UP TWO
JRST PA0. ; LEVELS IN THE TREE OTHERWISE
; ONLY POP UP ONE LEVEL.
INTER. PA30.
PA30.: HRRZI TA,3 ;'ADD TO' OP CODE
JRST SETOP
INTER. PA33.
PA33.: HRRZI TA,2 ;'ADD' OP CODE
JRST SETOP3
INTER. PA34.
PA34.: HRRZI TA,11 ;'RESULT' OP CODE
JRST SETOP1
INTER. PA35.
PA35.: MOVE TA,ARG1
TLO TA,004000 ;SET 'ROUNDED' BIT
MOVEM TA,ARG1
POPJ PP,
INTER. PA36.
PA36.: SETO TA,
DPB TA,OP.SZE##
PUSHJ PP,PA22.
HRRZI TA,23 ;'SPECIAL IF' OP CODE
PUSHJ PP,SETOP2
SETO TA,
DPB TA,OP.SZE
JRST PA90.A
INTER. PA37.
PA37.: IFN MCS!TCS,<
SKIPN IFMSGF## ;ARE WE IN AN "IF MSG"
JRST .+4
PUSHJ PP,PA139. ;GENERATE TAGNAM AND END-SPIF
SOS IFMSGF## ;DECREMENT IF-MSG LEVEL
JRST .+5 ;JUMP OVER GARBAGE
>
HRLZI TA,026000 ;ENDIF
HRRZI TB,26
DPB W2,[POINT 20,TA,35]
PUSHJ PP,PUTGEN
HRRZ TA,IFLVL
ADD TA,SPFLVL
HRRZ TC,ARGL2-1(TA) ;F-TARGET FOR CURRENT LEVEL
HLRM TC,ARGL2-1(TA) ;CLEAR ENTRY
PUSHJ PP,P127.A ;DEFINE TAG
SOS IFLVL
SWOFF UNCONT;
POPJ PP,
INTER. PA38.
PA38.: SETO TA,
DPB TA,OP.UPO## ;SET 'UPON' BIT
POPJ PP,
INTER. PA43.
PA43.: HRRZI TA,60 ;'ACCEPT' OP CODE
JRST SETOP
INTER. PA45.
PA45.: HRRZI TA,34 ;'ALTER' OP CODE
JRST SETOP
INTER. PA47.
PA47.: MOVE TA,ARG1
EXCH TA,ARG2##
MOVEM TA,ARG1
MOVE TA,ARG1+1
EXCH TA,ARG2+1
MOVEM TA,ARG1+1
MOVE TA,[XWD NSBSC1,TBLOCK]
BLT TA,TBLOCK+^D12 ;[222] WAS ^D6.
MOVE TA,[XWD NSBSC2,NSBSC1]
BLT TA,SBSCR1+^D11 ;[222] WAS ^D5.
MOVE TA,[XWD TBLOCK,NSBSC2##]
BLT TA,SBSCR2##+^D11 ;[222] WAS ^D5.
POPJ PP,
INTER. PA49.
PA49.: HRRZI TA,62 ;'OPEN' OP CODE
JRST SETOP1
INTER. PA50.
PA50.: HRRZI TA,63 ;'CLOSE' OP CODE
JRST SETOP1
INTER. PA51.
PA51.: SETO TA,
DPB TA,OP.REE## ;SET 'REEL' BIT
POPJ PP,
INTER. PA52.
PA52.: SETO TA,
DPB TA,OP.LCK## ;SET 'LOCK' BIT
POPJ PP,
IFN ANS74,<
INTER. PA52A.
PA52A.: SETO TA,
DPB TA,OP.REM## ;SET 'FOR REMOVAL' BIT
POPJ PP,
>
INTER. PA53.
PA53.: SETO TA,
DPB TA,OP.NRW## ;SET 'NO REWIND' BIT
POPJ PP,
INTER. PA54.
PA54.: HRRZI TA,57 ;'CEND' OP CODE
SWOFF FARITH;
JRST SETOP1
INTER. PA54A
PA54A: SKIPG CLEVEL ; ARE ALL PARENTHESIS CLOSED? [172]
JRST PA54A1 ; YES OK [172]
PA54A2: EWARNW E.261 ; NO [172]
SOSLE CLEVEL ; [172]
JRST PA54A2 ; TELL HIM ABOUT ALL UNBALANCED ONES [172]
PA54A1: SETZM CLEVEL ; CLEAR PAREN COUNT [172]
SETZM ELEVEL ; CLEAR BALANCE COUNT [172]
JRST PA54. ; FINISH UP [172]
INTER. PA55.
PA55.: HRRZI TA,61 ;'DISPLAY' OP CODE
JRST SETOP
INTER. PA57.
PA57.: HRRZI TA,13 ;'DIVBY' OP CODE
JRST SETOP
INTER. PA58.
PA58.: HRRZI TA,10 ;'DIVIDE' OP CODE
JRST SETOP3
IFN ANS74,<
INTER. PA59.
PA59.: HRRZI TA,106 ;NO-OP OP CODE
JRST SETOP
>
INTER. PA61.
PA61.: HRRZI TA,42 ;'EXAMINE' OP CODE
JRST SETOP
INTER. PA62.
PA62.: SETO TA,
DPB TA,OP.TAL## ;SET 'TALLYING' FLAG
IFN ANS74,<
HRRZI TA,156 ;GET "TALLYING" OPERATOR
MOVEM TA,SVINSO## ; SAVE NEXT OPERATOR
>
POPJ PP,
INTER. PA64.
PA64.: SETO TA,
DPB TA,OP.LEA##
POPJ PP,
IFN ANS68,<
INTER. PA65.
PA65.: SETO TA,
DPB TA,OP.UFR##
POPJ PP,
>
IFN ANS74,<
INTER. PA65.
PA65.: SETO TA,
DPB TA,OP.CHR##
POPJ PP,
INTER. PA65A.
PA65A.: JSP TB,PREBA ;ONLY 1 BEFORE/AFTER CLAUSE ALLOWED
SETO TA,
DPB TA,OP.IAF##
POPJ PP,
INTER. PA65B.
PA65B.: JSP TB,PREBA ;ONLY 1 BEFORE/AFTER CLAUSE ALLOWED
SETO TA,
DPB TA,OP.IBF##
POPJ PP,
PREBA: LDB TA,OP.IBF## ;ANY PREVIOUS "BEFORE" CLAUSE
JUMPN TA,PREBAE ; FOR THIS ARGUMENT?
LDB TA,OP.IAF## ;OR "AFTER" CLAUSE?
JUMPN TA,PREBAE
JRST (TB) ;NO, OK
PREBAE: EWARNJ E.724 ;"Only one 'BEFORE' or 'AFTER' clause allowed"
>
INTER. PA66.
PA66.: SETO TA,
DPB TA,OP.RPL##
IFN ANS68,<
POPJ PP,
>
IFN ANS74,<
SKPNAM
INTER. PA66A.
PA66A.: HRRZI TA,157 ;"REPLACING" OPERATOR
MOVEM TA,SVINSO## ;SAVE IT
POPJ PP,
>
INTER. PA67.
PA67.: SETO TA,
DPB TA,OP.FIR##
POPJ PP,
INTER. PA68.
PA68.: HRRZI TA,31 ;'GO DEPENDING' OP CODE
;HERE TO SET UP OPERATOR WORDS
SETOP: SETZM ARG1
SETZM ARG1+1
SETOP1: SETZM OPRTR
SETOP2: DPB W2,OP.LNC
SETOP3: DPB TA,OP.OPC##
DPB TA,OP.OP2
POPJ PP,
INTER. PA70.
PA70.: HRRZI TA,1 ;'MOVE' OP CODE
JRST SETOP
INTER. PA72.
PA72.: HRRZI TA,7 ;'MULTIPLY BY' OP CODE
JRST SETOP
INTER. PA73.
PA73.: HRRZI TA,6 ;'MULTIPLY GIVING' OP CODE
JRST SETOP3
INTER. PA74.
PA74.: MOVE TB,OP.INP##
PA74.A: HRRZI TA,62 ;'OPEN' OP CODE
LDB TC,OP.LNC
SETZM OPRTR
DPB TC,OP.LNC
PUSHJ PP,SETOP3
SETO TA,
DPB TA,TB
POPJ PP,
INTER. PA75.
PA75.: MOVE TB,OP.OUT##
JRST PA74.A
INTER. PA76.
PA76.: MOVE TB,OP.INO##
JRST PA74.A
INTER. PA77.
PA77.: HRRZ TA,ARG1
JUMPE TA,CPOPJ
PUSHJ PP,LNKSET
LDB TB,OP.INO
SETO TC,
XCT [POPJ PP,
DPB TC,FI.INO## ;OPEN INPUT
DPB TC,FI.OUO## ;OPEN OUTPUT
DPB TC,FI.IOO##](TB) ;OPEN I-O
POPJ PP,
INTER. PA78.
PA78.: SETZ TA,
DPB TA,OP.NRW ;CLEAR NO REWIND BIT
POPJ PP,
INTER. PA79.
PA79.: SETO TA,
DPB TA,OP.NRW ;SET NO REWIND BIT
POPJ PP,
INTER. PA79E.
PA79E.: SETO TA,
DPB TA,OP.EXT## ;SET EXTEND BIT
POPJ PP,
IFN ANS74,<
INTER. PA79R.
PA79R.: SETO TA,
DPB TA,OP.REV## ;SET REVERSED BIT
POPJ PP,
>
INTER. PA80.
PA80.: HRRZI TA,64 ;'READ' OP CODE
SETZM REINTO## ;CLR READ INTO FLAG
JRST SETOP1
INTER. PA81.
PA81.: HRRZI TA,23 ;'SPECIAL IF'
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.ATE## ;'AT END'
JRST PA90.A
IFN ANS74,<
INTER. PA81P.
PA81P.: HRRZI TA,23 ;'SPECIAL IF'
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.EOP## ;'AT END OF PAGE'
JRST PA90.A
>
INTER. PA82.
PA82.: HRRZI TA,43 ;'SET TO' OP CODE
JRST SETOP
INTER. PA83.
PA83.: HRRZI TA,45 ;'SET UP BY' OP CODE
JRST SETOP3
INTER. PA84.
PA84.: HRRZI TA,44 ;'SET DOWN BY' OP CODE
JRST SETOP3
;SET UP WRITE OP-CODE
INTER. PA85.
PA85.: HRRZI TA,65 ;'WRITE' OP CODE
JRST SETOP1
;SET UP DELETE OP-CODE
INTER. PA85D.
PA85D.:
IFN ISAM,<
HRRZI TA,122 ;DELETE OP-CODE
JRST SETOP1
>
IFE ISAM,<EWARNJ DE91.> ;?NOT IMPLEMENTED
;SET UP REWRITE OP-CODE
INTER. PA85R.
PA85R.:
IFN ISAM,<
HRRZI TA,66 ;REWRITE OP-CODE
JRST SETOP1
>
IFE ISAM,<EWARNJ DE91.> ;?NOT IMPLEMENTED
INTER. PA86.
PA86.: SETO TA,
DPB TA,OP.BAD## ;'BEFORE ADVANCING'
POPJ PP,
INTER. PA87.
PA87.: SETO TA,
DPB TA,OP.AAD## ;'AFTER ADVANCING'
POPJ PP,
INTER. PA88.
PA88.: SETZI TA, ;WHOPS, MAKE THAT POSITIONING INSTEAD OF ADVANCING.
DPB TA, OP.ADV## ;CLEAR ADVANCING.
SETOI TA,
DPB TA, OP.PSG## ;SET POSITIONING.
POPJ PP,
INTER. PA90.
PA90.: HRRZI TA,23 ;'SPECIAL IF'
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.INK## ;'INVALID KEY'
PA90.A: PUSHJ PP,GETTAG##
ANDI CH,077777
JUMPE CH,PA90.A ;%0 NOT ALLOWED
DPB CH,OP.TRG##
AOS TA,SPFLVL
ADD TA,IFLVL
CAILE TA,IF.DEP ;ARGL2 OVERFLOW?
JRST PA90.B ;YES
HRLZM CH,ARGL2-1(TA)
JRST PA22.
PA90.B: EWARNW E.323
JRST PA133. ;GIVE UP
INTER. PA91.
PA91.: HRRZI TA,5 ;'SUBTRACT FROM' OP CODE
JRST SETOP
INTER. PA94.
PA94.: HRRZI TA,32 ;'PERFORM' OP CODE
JRST SETOP1
INTER. PA95.
PA95.: HRRZI TA,33 ;'PERFORM TIMES' OP CODE
JRST SETOP3
INTER. PA96.
PA96.: SKIPN ARG2
SKIPE ARG2+1
JRST PA96.A
PUSHJ PP,PA159.
JRST .+2
PA96.A: PUSHJ PP,PA47.
SETZM NVARY##
SETZM VARBLK
MOVE TA,[XWD VARBLK,VARBLK+1]
BLT TA,VARBLK+^D134 ;[222] WAS ^D80.
SETZM VARTAG##
MOVE TA,[XWD VARTAG,VARTAG+1]
BLT TA,VARTAG+6
PUSHJ PP,GETTAG
ANDI CH,077777
JUMPE CH,.-2
HRRZM CH,VARTAG ;%S
HRLZI TB,(CH)
HRRI TB,74 ;'JUMPTO' OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN##
MOVE TA,[XWD OPRTR,SAVPRF##]
BLT TA,SAVPRF+5
POPJ PP,
INTER. PA97.
PA97.: AOS TA,NVARY
CAIG TA,3
POPJ PP,
EWARNJ E.156 ;ONLY THREE VARYINGS ALLOWED
INTER. PA98.
PA98.: HRRZ TA,NVARY ;WE HAD SEEN 'VARYING'. NOW WE SAW 'FROM'
; SO WE SAVE WHAT TO VARY IN VARBLK.
CAILE TA,3
POPJ PP, ;IGNORE FURTHER VARYINGS
HRRZI TA,-1(TA)
IMULI TA,^D45 ;[222] WAS ^D27.
MOVE TB,ARG1 ;INDEX
MOVEM TB,VARBLK(TA)
MOVE TB,ARG1+1
MOVEM TB,VARBLK+1(TA)
HRRZI TB,VARBLK+2(TA)
HRLI TB,NSBSC1
BLT TB,VARBLK+^D14(TA) ;[222] WAS ^D8.
PA98.X: SETZM NSBSC1 ;CLR SUBSCRIPT STORE
MOVE TB,[XWD NSBSC1,NSBSC1+1]
BLT TB,NSBSC1+^D12 ;[222] WAS ^D6.
POPJ PP,
INTER. PA99.
PA99.: HRRZ TA,NVARY ;WE HAD SEEN 'FROM'. NOW WE SAW 'BY'
; SO SAVE THE INITIAL VALUE IN VARBLK.
CAILE TA,3
POPJ PP, ;IGNORE FURTHER VARYINGS
HRRZI TA,-1(TA)
IMULI TA,^D45 ;[222] WAS ^D27.
MOVE TB,ARG1 ;ORIGINAL VALUE OF INDEX
MOVEM TB,VARBLK+^D15(TA) ;[222] WAS ^D9.
MOVE TB,ARG1+1
MOVEM TB,VARBLK+^D16(TA) ;[222] WAS ^D10.
HRRZI TB,VARBLK+^D17(TA) ;[222] WAS ^D11.
HRLI TB,NSBSC1
BLT TB,VARBLK+^D29(TA) ;[222] WAS ^D17.
JRST PA98.X ;CLR SUBSCRIPT STORE & RETURN
INTER. PA100.
PA100.: HRRZ TA,NVARY ;HAD SEEN A 'BY'. NOW WE SAW AN 'UNTIL'
; SO SAVE THE INCREMENT IN VARBLK.
CAILE TA,3
POPJ PP,
HRRZI TA,-1(TA)
IMULI TA,^D45 ;[222] WAS ^D27.
MOVE TB,ARG1
MOVEM TB,VARBLK+^D30(TA) ;INCREMENT ;[222] WAS ^D18.
MOVE TB,ARG1+1
MOVEM TB,VARBLK+^D31(TA) ;[222] WAS ^D19.
HRRZI TB,VARBLK+^D32(TA) ;[222] WAS ^D20.
HRLI TB,NSBSC1
BLT TB,VARBLK+^D44(TA) ;[222] WAS ^D26.
PUSHJ PP,GETTAG
ANDI CH,077777
HRLZI TB,(CH)
HRRI TB,102 ;'TAGNAM' OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
HRRZ TC,NVARY
LSH TC,1
HRRZM CH,VARTAG(TC)
JRST PUTGEN
INTER. PA101.
PA101.: HRRZ TA,NVARY
CAILE TA,3
JRST PA37.
PUSHJ PP,GETTAG
ANDI CH,077777
HRRZ TA,NVARY
LSH TA,1
HRRZM CH,VARTAG-1(TA)
HRLZI TB,(CH)
HRRI TB,74 ;'JUMPTO' OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
JRST PA37.
INTER. PA102.
PA102.: SETZM OPRTR+1
HRRZI TA,20 ;'IF' OP CODE
JRST SETOP1
INTER. PA103.
PA103.: SWOFF UNCONT;
SKIPN CH,NXTSNT
PUSHJ PP,GETTAG
ANDI CH,077777
JUMPE CH,.-2
HRRZM CH,NXTSNT
HRLZI TB,(CH)
HRRI TB,74 ;JUMPTO OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
JRST PUTGEN
INTER. PA104.
PA104.: SWOFF FNOTF;
SETZM ARGLST##
MOVE TA,[XWD ARGLST,ARGLST+1]
BLT TA,ARGLST+IF.DEP-1
SETZM TOPLVL
SETZM TRMLVL##
AOS TA,IFLVL
ADD TA,SPFLVL ;ARGL2 OVERFLOW?
CAIG TA,IF.DEP
POPJ PP,
JRST PA90.B ;YES
INTER. PA107.
PA107.: TSWC FNOTF;
SETZM TOPLVL
POPJ PP,
INTER. PA111.
PA111.: MOVE TA,TOPLVL
MOVEM TA,ELEVEL
MOVE TB,CLEVEL
SUB TB,TA
MOVEM TB,CLEVEL
SWON FEXPR+FARITH
HRRZI TA,72 ;'EXPRESSION' OP CODE
PUSHJ PP,SETOP0
HRLZI TA,070000
DPB W2,[POINT 20,TA,35]
HRRZI TB,70 ;'(' OP CODE
CAIA
PUSHJ PP,PUTGEN
SOSL TOPLVL
JRST .-2
SETZM TOPLVL
POPJ PP,
;OUTPUT CODES FOR "AND"
INTER. PA118.
PA118.: PUSHJ PP,SETCTR ;# OF LEVELS FROM HERE UP
P118.2: ADD TB,CLEVEL ;(TB STILL CONTAINS VALUE OF CTR)
HRRZ TB,ARGLST(TB) ;ANY TAG THERE?
JUMPN TB,P118.1 ;YES
SOSLE TB,CTR ;NO, FINISHED ALL ENTRIES ABOVE THIS LEVEL?
JRST P118.2 ;NOT YET
PUSHJ PP,PA129. ;NONE FOUND. NORMAL "AND".
JRST SETCTR ;RETURN WITH CTR SET UP
P118.1: AOS CLEVEL
PUSHJ PP,PA130. ;INVERTED "AND". GOIF-TRUE ONE LEVEL UP.
SOS CLEVEL
PUSHJ PP,SETCTR
P118.3: PUSHJ PP,PA127. ;OUTPUT ALL FALSE TAGS
SOSL CTR
JRST P118.3
MOVE TB,CLEVEL ;DEFINE F-TARGET AT THIS LEVEL
HRLZ TB,ARGLST(TB) ;ONE THERE ALREADY?
JUMPN TB,P118.4 ;YES
P118.5: PUSHJ PP,GETTAG ;NO, GET ONE
ANDI CH,077777
JUMPE CH,P118.5
MOVE TB,CLEVEL
HRRM CH,ARGLST(TB)
P118.6: HRLZ TB,CH
P118.4: HRRI TB,74 ;OUTPUT JUMPTO
HRLI TA,074000
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
JRST SETCTR ;RETURN WITH CTR SET UP
;OUTPUT CODES FOR "OR"
INTER. PA119.
PA119.: PUSHJ PP,SETCTR ;# OF LEVELS FROM HERE UP
P119.2: ADD TB,CLEVEL ;(TB STILL CONTAINS VALUE OF CTR)
HLRZ TB,ARGLST(TB) ;ANY TAG THERE?
ANDI TB,077777
JUMPN TB,P119.1 ;YES
SOSLE TB,CTR ;NO, FINISHED ALL ENTRIES ABOVE THIS LEVEL?
JRST P119.2 ;NOT YET
PUSHJ PP,PA130. ;NONE FOUND. NORMAL "OR".
JRST SETCTR ;RETURN WITH CTR SET UP
P119.1: PUSHJ PP,PA129. ;INVERTED "OR".
PUSHJ PP,SETCTR
P119.3: PUSHJ PP,PA131. ;OUTPUT ALL TRUE TAGS
SOSL CTR
JRST P119.3
MOVE TB,CLEVEL ;DEFINE T-TARGET AT THIS LEVEL
HLLZ TB,ARGLST(TB) ;ONE THERE ALREADY?
JUMPN TB,P118.4 ;YES
P119.5: PUSHJ PP,GETTAG ;NO, GET ONE
ANDI CH,077777
JUMPE CH,P119.5
MOVE TB,CLEVEL
HRLM CH,ARGLST(TB)
JRST P118.6
; "AND" IN IF-STATEMENT
;DEFINE FALSE-TARGET AT THIS LEVEL,
;OUTPUT GOIF-FALSE,
;AND OUTPUT TRUE-TARGET TAGS AT HIGHER LEVELS.
INTER. PA120.
PA120.: HRRZ TA,CLEVEL
SKIPGE TA,ARGLST(TA) ;NOT FLAG ON?
JRST P121.0 ;YES
P120.0: PUSHJ PP,PA118. ;OUTPUT AND CODES
P120.1: PUSHJ PP,PA131. ;OUTPUT T-TAGS AT HIGHER LEVELS
SOSLE CTR
JRST P120.1
P120.2: SKIPN TA,TRMLVL ;COMING DOWN FROM HIGHER LEVEL?
POPJ PP, ;NO
P120.3: ADD TA,CLEVEL ;YES
MOVE TB,ARGLST(TA) ;CLEAR NOT BIT AT ALL UPPER LEVELS
TLZ TB,400000
MOVEM TB,ARGLST(TA)
SOSE TA,TRMLVL
JRST P120.3
POPJ PP,
; "OR" IN IF-STATEMENT
;DEFINE TRUE-TARGET AT THIS LEVEL (FALSE-TARGET IF NOT FLAG IS ON),
;OUTPUT GOIF-TRUE
;AND OUTPUT FALSE-TARGET TAGS AT THIS AND HIGHER LEVELS
INTER. PA121.
PA121.: HRRZ TA,CLEVEL
SKIPGE TA,ARGLST(TA) ;NOT FLAG ON?
JRST P120.0 ;YES
P121.0: PUSHJ PP,PA119. ;OUTPUT OR CODES
P121.1: PUSHJ PP,PA127. ;OUTPUT F-TAGS
SOSL CTR
JRST P121.1
JRST P120.2
INTER. PA122.
PA122.: SOSGE CLEVEL
EWARNJ E.261 ;UNBALANCED PARINS
AOS TRMLVL
POPJ PP,
INTER. PA123.
PA123.: SKIPG CLEVEL ;ALL PARINS CLOSED?
JRST P123.3 ;YES
P123.4: EWARNW E.261 ;NO
SOSLE CLEVEL
JRST P123.4 ;TELL HIM ABOUT ALL OF THEM
P123.3: PUSHJ PP,PA118. ;OUTPUT AND CODES
P123.1: PUSHJ PP,PA131. ;OUTPUT ALL TRUE-TAGS
SOSL CTR
JRST P123.1
HRRZ TA,ARGLST
HRRZ TB,IFLVL
ADD TB,SPFLVL
HRRZM TA,ARGL2-1(TB)
SETZM CLEVEL
SETZM TOPLVL
SETZM ARGLST
MOVE TA,[XWD ARGLST,ARGLST+1]
BLT TA,ARGLST+13
HRLZI TA,076000 ;END-CONDITION OP CODE
HRRZI TB,76
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
JRST PA0.
SETCTR: MOVEI TB,IF.DEP-1 ;MAX LENGTH OF ARGLST - 1
SUB TB,CLEVEL ;LESS WHERE WE ARE NOW
MOVEM TB,CTR ;EQUALS PART OF LIST TO CHECK
POPJ PP,
INTER. PA125.
PA125.: HRRZI TA,52 ;'CSUB' OP CODE
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.UNM## ;UNARY MINUS
JRST PA22.
INTER. PA126.
PA126.: TSWF FEXPR;
JRST P126.A
AOS TA,CLEVEL
CAILE TA,IF.DEP ;ARGLST OVERFLOW?
JRST P126.B ;YES
AOS TOPLVL
SETZ TB,
TSWFZ FNOTF;
HRLZI TB,4B20
HLLZ TC,ARGLST-1(TA) ;NOT ON AT LOWEL LEVEL?
TLZ TC,377777
XOR TB,TC ;IF SO, COMPLEMENT NOT AT CURRENT LEVEL
MOVEM TB,ARGLST(TA)
POPJ PP,
P126.A: AOS ELEVEL
HRRZI TA,70 ;'(' OP CODE
SETOP0: PUSHJ PP,SETOP1
JRST PA22.
P126.B: EWARNW E.324
JRST PA133.
;OUTPUT FALSE-TARGET TAG AT LEVEL=CLEVEL+CTR
INTER. PA127.
PA127.: HRRZ TA,CLEVEL ;DESIRED LEVEL
ADD TA,CTR
HRRZ TC,ARGLST(TA) ;F-TARGET
HLRM TC,ARGLST(TA) ;CLEAR ENTRY
P127.A: ANDI TC,077777 ;GET TARGET TAG
JUMPE TC,CPOPJ ;NONE THERE
HRLZ TB,TC
HRRI TB,102 ;TAGNAM OP CODE
HRLZI TA,102000
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
JRST PUTGEN
INTER. PA128.
PA128.: SOSGE ELEVEL
JRST P128.A
P128.Q: HRRZI TA,71 ;')' OP CODE
JRST SETOP0
P128.A: SETZM ELEVEL
PUSHJ PP,PA24.
PUSHJ PP,PA132.
JRST PA0.
;DEFINE FALSE-TARGET
INTER. PA129.
PA129.: HRRZ TA,CLEVEL ;TAG THERE ALREADY?
HRRZ TC,ARGLST(TA)
ANDI TC,077777
JUMPN TC,P129.A ;YES
PUSHJ PP,GETTAG ;NO, GET A NEW ONE
ANDI CH,077777
JUMPE CH,.-2
HRRZ TA,CLEVEL ;OUTPUT GOIF-FALSE
HRRZ TC,ARGLST(TA)
IOR TC,CH
HRRM TC,ARGLST(TA)
P129.A: MOVE TA,[XWD IMPLOP,OPRTR]
BLT TA,OPRTR+1
SETO TA,
DPB TA,OP.FLS## ;'GO TO IF FALSE' FLAG
JRST P130.B
;DEFINE TRUE-TARGET
INTER. PA130.
PA130.: HRRZ TA,CLEVEL ;TAG THERE ALREADY?
HLRZ TC,ARGLST(TA)
ANDI TC,077777
JUMPN TC,P130.A ;YES
PUSHJ PP,GETTAG ;NO, GET A NEW ONE
ANDI CH,077777
JUMPE CH,.-2
HRRZ TA,CLEVEL ;PUT IT ON THE LIST AT THIS LEVEL
HLRZ TC,ARGLST(TA)
IOR TC,CH
HRLM TC,ARGLST(TA)
P130.A: MOVE TA,[XWD IMPLOP,OPRTR]
BLT TA,OPRTR+1
SETZ TA,
DPB TA,OP.FLS ;'GO TO IF TRUE' FLAG
P130.B: DPB TC,OP.TRG ;TARGET TAG
IFN ANS68,<
JRST PA22.
>
IFN ANS74,<
MOVSI TA,OPM.IF## ;GET COMPLEMENT MASK
TSWFZ FNOTF ;NOT SEEN ALSO
XORM TA,OPRTR ;YES, SWAP TEST
PUSHJ PP,PA22. ;OUTPUT OPCODE
MOVE TC,CLEVEL
SKIPGE ARGLST(TC) ;IF NOT ON AT THIS LEVEL
POPJ PP, ;LEAVE IT ALONE
MOVSI TC,4 ;ELSE
ANDCAM TC,IMPLOP ;TURN NOT OFF FOR ABREV. LIST
POPJ PP,
>
;OUTPUT TRUE-TARGET TAG AT LEVEL=CLEVEL+CTR
INTER. PA131.
PA131.: HRRZ TA,CLEVEL ;AIM AT DESIRED LEVEL
ADD TA,CTR
HLRZ TC,ARGLST(TA) ;T-TARGET
HRRZI TB,(TC) ;CLR TAG FROM ENTRY
ANDI TB,7B20
HRLM TB,ARGLST(TA)
JRST P127.A ;OUTPUT TAG
INTER. PA132.
PA132.: MOVE TA,ELEVEL
ADDM TA,CLEVEL
SOSGE ELEVEL
JRST .+3
PUSHJ PP,P128.Q
JRST .-3
SETZM ELEVEL
HRRZI TA,73 ;'END EXPRESSION' OP CODE
SWOFF FEXPR+FARITH
HRRZ TB,CLEVEL
SKIPGE TC,ARGLST+1(TB)
SWON FNOTF;
JRST SETOP0
INTER. PA133.
PA133.: HRRZI DW,E.306
PUSHJ PP,PA133S
HRRZI DW,E.307
P133EX: SWOFF FREGWD;
PUSHJ PP,GETITM
TSWF FEOF;
JRST PA24.
JRST PA148.
;22-AUG-79 /DAW HOPEFULLY THE NEXT TWO LINES OF CODE WILL
; IMPROVE ERROR RECOVERY SO IF PERIOD IS SEEN AT THE WRONG
; TIME, THE NEXT TOKEN WILL BE PARSED AS IF IT WERE THE START
; OF A STATEMENT.. THE COMPILER USED TO SKIP THE PARSING OF THE
; NEXT STATEMENT.
PA133S: CAIN TYPE,PRIOD. ;IF ALREADY AT PERIOD, DON'T DO ANYTHING
JRST P133.X
SWON FARITH;
P133.1: PUSHJ PP,SKPSRC
TSWF FEOF;
JRST P133.X
CAIN CP,7
JRST P133.3 ;START OF NON-CONTINUATION LINE
P133.2: CAIN CH,"."
JRST P133.5 ;PERIOD IN B-MARGIN
CAIE CH," "
JRST P133.1 ;JUST A CHARACTER
MOVE TA,SAVBLN##
JUMPE TA,P133.4 ;IF 0, SAVBLN NOT IN USE
MOVEM TA,BLNKLN##
MOVE TA,SAVBCP##
MOVEM TA,BLNKCP##
P133.4: PUSHJ PP,SKPSRC
CAIN CP,7
JRST P133.3 ;A-MARGIN
CAIE CH," "
JRST P133.2
JRST P133.4 ;ANOTHER IN A STRING OF BLANKS
P133.3: PUSHJ PP,SKPSRC ;GET CHARACTER IN THE A-MARGIN
TSWF FEOF;
JRST P133.X
CAIL CP,^D12
JRST P133.2 ;NOW IN B-MARGIN
CAIN CH," "
JRST P133.3 ;A SPACE
CAIL CH,"0"
CAILE CH,"9"
SKIPA ;NOT A DIGIT
JRST P133.E ;POSSIBLY A PROCEDURE-NAME
CAIL CH,"A"
CAILE CH,"Z"
JRST P133.2 ;SOME GARBAGE IN A-MARGIN--TREAT AS B-MARGIN
P133.E: PUSHJ PP,DE125.
SWON FREGCH;
P133.X: SWOFF FARITH;
POPJ PP,
P133.5: PUSHJ PP,SKPSRC
CAIE CH," "
JRST P133.1
SWOFF FNEEDS;
JRST P133.X ;PERIOD FOLLOWED BY SPACE
IFN ANS68,<
;SKIP TO END OF NOTE IN MIDST OF PARAGRAPH
INTER. PA133N
PA133N: PUSHJ PP,PA133S
JRST P133EX
>
INTER. PA134.
PA134.: HRRZI TA,40 ;'STOP' OP CODE
JRST SETOP1
INTER. PA135.
PA135.: SETO TA,
DPB TA,OP.RUN ;SET 'RUN' BIT IN OPERATOR
POPJ PP,
INTER. PA137.
PA137.: MOVE TA,ARG1+1
DPB TA,OP.LNC ;PUT LN, CP IN OPERATOR
HRRZI TA,101 ;OP CODE FOR PARAGRAPH OPERATOR
JRST SETOP3
IFN ANS74,<
INTER. PA136A
PA136A: POPJ PP,
>
INTER. PA138.
PA138.: TSWF UNCONT;
JRST A831AP
PUSHJ PP,PA25.
MOVE TA,OPRTR
MOVE TB,OPRTR+1
TLO TA,200
PUSHJ PP,PUTGEN
A831AP: SKIPN CURSEC ;ANY SECTIONS?
JRST PA138A ;NO --- THEN NO SEGMENT BREAK, ALL RESIDENT
MOVSI TA,104000
DPB W2,[POINT 20,TA,35]
HRRZI TB,104 ;SEGMENT BREAK
PUSHJ PP,PUTGEN
PA138A: MOVE TA,GENWRD ;SAVE WORD NUMBER OF
MOVEM TA,ARG2 ;ENDIT OPERATOR
MOVE TA,[XWD 377003,777607]
HRRZI TB,377 ;ENDIT OPERATOR
PUSHJ PP,PUTGEN
CLOSE GEN,2 ;CLOSE OUTPUT SIDE
SETZM CURPAR
SETZM CURSEC
HRRZ TA,FLOLOC## ;BEGINNING OF FLOTAB
AOJA TA,P138Z1 ;NOW POINTS TO ENTRY PROPERLY
;ENTER ROUTINE TO CLEAR UP
P138FZ: HRRZ TA,CURFLO
ADDI TA,SZ.FLO ;NEXT ENTRY
P138Z1: HRRZ TB,FLONXT## ;FIRST UNUSED PROTAB ENTRY
CAILE TA,(TB)
JRST FLODN
HRRZM TA,CURFLO
LDB TB,FL.PND ;PROCEDURE-NAME DEFINITION FLAG
JUMPE TB,P138F2 ;NOT PROCEDURE-NAME DEFINITION
LDB TA,FL.PRO ;PROTAB LINK
PUSHJ PP,LNKSET ;GET ABS. ADDR.
HRRZ TB,CURFLO ;FLOTAB ENTRY ABS. ADDR.
HRL TA,(TB) ;PUT PROTAB REL. ADDR. IN TA L. H.
LDB TC,PR.SEC ;PARAGRAPH/SECTION FLAG
JUMPE TC,P138F1 ;JUMP IF SECTION
MOVEM TA,CURPAR ;SAVE LINK OF CURRENT PARAGRAPH
JRST P138FZ ;GET NEXT ENTRY
P138F1: SETZM CURPAR ;THIS ENTRY IS A SECTION
MOVEM TA,CURSEC ;SAVE LINK OF CURRENT SECTION
JRST P138FY
P138F2: LDB TB,FL.QUA## ;QUALIFIED ENTRY?
JUMPN TB,PF2Q ;YES
PUSHJ PP,RESLVU ;NO --- RESOLVE
JRST PF2
PF2Q: PUSHJ PP,RESLVQ ;RESOLVE QUALIFIED ENTRY
PF2: MOVEM TA,SAVETA##
LDB TA,FL.PRO
JUMPE TA,PF2.1
PUSHJ PP,LNKSET
LDB TB,PR.MDF
JUMPN TB,MDF138
LDB TB,PR.DEF
JUMPE TB,P138FY ;NOT DEFINED
PF2.1: MOVE TA,SAVETA
LDB TB,FL.SAL## ;SUBJECT OF ALTER?
JUMPE TB,PF3 ;NO
MOVEM TA,SAVETA ;SAVE FLOTAB ENTRY ADDRESS
LDB TA,FL.PRO ;PROTAB LINK
MOVEM TA,TBLOCK+17 ;SAVE IT
JUMPE TA,P138FZ ;ENTRY WAS NOT RESOLVED
PUSHJ PP,LNKSET
LDB TB,PR.ALT ;ALTERABLE?
JUMPN TB,P138FZ ;YES --- CONTINUE
HRRZI DW,E.113 ;DIAGNOSTIC 113.
E138: MOVE TA,SAVETA
LDB LN,FL.LN## ;LINE NUMBER
LDB CP,FL.CP## ;CHARACTER POSITION
IFN DEBUG,<
PUSHJ PP,WARN
>
IFE DEBUG,<
EXTERN FATAL
PUSHJ PP,FATAL
>
P138FY: SETZM TBLOCK+17
JRST P138FZ
MDF138: HRRZI DW,E.187 ;DIAGNOSTIC 187.
JRST E138
PF3: LDB TB,FL.OAL## ;OBJECT OF ALTER?
JUMPE TB,PF6 ;NO
LDB TA,FL.PRO
JUMPE TA,PF3E ;ENTRY WAS NOT RESOLVED
PUSHJ PP,LNKSET ;ADDRESS OF OBJECT'S PROTAB ENTRY
LDB TB,PR.PRI ;PRIORITY OF OBJECT
MOVEM TB,TBLOCK+16 ;SAVE
MOVE TA,TBLOCK+17
JUMPE TA,P138FZ ;NO SUBJECT SAVED
PUSHJ PP,LNKSET ;ADDRESS OF SUBJECT'S PROTAB ENTRY
SETO TD,
HRRZ TC,TBLOCK+16 ;PRIORITY OF OBJECT
LDB TB,PR.PRI ;PRIORITY OF SUBJECT
CAME TB,TC ;SAME AS THAT OF OBJECT?
JRST PF5 ;NO
DPB TD,PR.ARS## ;ALTERED TO SAME SEGMENT
JRST P138FY
PF5: DPB TD,PR.ANR## ;ALTERED TO DIFFERENT SEGMENT
JRST P138FY
PF6: LDB TB,FL.OPF## ;OBJECT OF PERFORM?
JUMPE TB,P138FY ;NO
LDB TA,FL.PRO
JUMPE TA,P138FY ;ENTRY WAS NOT RESOLVED
PUSHJ PP,LNKSET
SETO TB,
DPB TB,PR.EXR## ;SET EXIT REQUIRED BIT
JRST P138FY
PF3E: PUSHJ PP,P138FE
JRST P138FY
RESLVU: LDB TA,FL.NAM## ;NAMTAB POINTER
HRRZI TB,CD.PRO
PUSHJ PP,FNDLNK ;IS THERE A PROTAB LINK FOR THIS NAME?
JRST P138FE ;N0--UNDEFINED
SETZM TBLOCK+2 ;PTR TO PARAGRAPH IN THIS SECTION
SETZM TBLOCK+3 ;PTR TO PARAGRAPH IN ANOTHER SECTION
SETZM TBLOCK+4 ;PTR TO SECTION OF THIS NAME
SETZM TBLOCK+5 ;0 UNLESS MORE THAN ONE PARAGRAPH OF
;THIS NAME IN OTHER SECTIONS
P138F8: MOVEM TB,CURPRO ;SAVE LINK FOUND
HRRZ TA,TB
LDB TC,PR.SEC ;SECTION/PARAGRAPH FLAG
JUMPN TC,P138F3 ;JUMP IF PARAGRAPH
SKIPE TBLOCK+4 ;HAVE WE SEEN A SECTION BEFORE?
JRST P138E1 ;YES---ERROR
MOVEM TB,TBLOCK+4 ;NO, SAVE THIS LINK
JRST P138F5
P138F3: LDB TD,PR.LSC ;SECTION LINK FROM PROTAB ENTRY
HRLS TD ;PUT LINK ALSO IN LEFT HALF
XOR TD,CURSEC
TLNE TD,777777 ;IS IT THE CURRENT SECTION?
JRST P138F4 ;NO
SKIPE TBLOCK+2 ;IS THERE A PARAGRAPH OF THIS NAME
;IN THE CURRENT SECTION?
JRST P138E2 ;YES---ERROR
MOVEM TB,TBLOCK+2 ;NO, SAVE LINK
JRST P138F5
P138F4: SKIPE TBLOCK+3 ;PARAGRAPHS OF THIS NAME IN OTHER SECTS?
SETOM TBLOCK+5 ;YES--SET FLAG WORD
MOVEM TB,TBLOCK+3 ;SAVE LINK
P138F5: PUSHJ PP,FNDNXT ;FIND ANOTHER PROTAB LINK
JRST .+2 ;NO--NOW EVALUATE
JRST P138F8 ;YES---PROCESS
HRRZ TA,CURFLO ;FLOTAB ENTRY ABS. ADDR.
SKIPN TC,TBLOCK+2 ;PARAGRAPH IN CURRENT SECTION?
JRST P138F6 ;NO
SKIPE TBLOCK+4 ;YES--WAS THERE A SECTION OF THIS NAME?
JRST P138E3 ;YES---ERROR
P138F7: HLRS TC ;GET LINK IN RIGHT HALF
DPB TC,FL.PRO ;AND PUT IN FLOTAB
POPJ PP,
P138F6: SKIPE TC,TBLOCK+4 ;ANY SECTION OF THIS NAME?
JRST P138F7 ;YES---PUT IN FLOTAB
SKIPN TC,TBLOCK+3 ;NO--ANY PARAGRAPHS IN OTHER SECTIONS?
JRST P138E4 ;NO---ERROR
SKIPE TBLOCK+5 ;MORE THAN 1 PARAGRAPH OF THIS NAME?
JRST P138E2 ;YES---ERROR
JRST P138F7 ;NO--PUT IN FLOTAB
P138E1: HRRZI DW,E.178
P138EE: HLRS TC
DPB TC,FL.PRO ;ASSUMED MEANING
P138EF: LDB LN,FL.LN ;GET LINE NUMBER AND
LDB CP,FL.CP ;CHARACTER POSITION FROM FLOTAB
IFN DEBUG,<
PUSHJ PP,WARN
>
IFE DEBUG,<
PUSHJ PP,FATAL
>
MOVE TA,CURFLO
POPJ PP,
P138E2: HRRZI DW,E.179
JRST P138EE
P138E3: HRRZI DW,E.180
JRST P138EE
P138E4: HRRZI DW,E.181
JRST P138EE
P138FE: MOVE TA,[SIXBIT /UNDEF;/]
MOVEM TA,NAMWRD
SETZM NAMWRD+1
SETZM NAMWRD+2
SETZM NAMWRD+3
SETZM NAMWRD+4
PUSHJ PP,TRYNAM##
JRST FE1381
MOVEM TA,CURNAM##
HLRZS TA
HRRZI TB,CD.PRO
PUSHJ PP,FNDLNK
JRST FE1382
HRRZ TA,CURFLO
HLRS TB
DPB TB,FL.PRO
HRRZI DW,E.181
JRST P138EF
FE1381: PUSHJ PP,BLDNAM
MOVEM TA,CURNAM
FE1382: MOVE TA,[XWD CD.PRO,SZ.PRO]
PUSHJ PP,GETENT
HLRM TA,CURNAM
HLRZ TB,CURNAM ;NAMTAB POINTER
ANDI TB,077777
IORI TB,CD.PRO*1B20
HRLZM TB,(TA)
HLRZ TB,TA
HRRZ TA,CURFLO
DPB TB,FL.PRO
MOVS TA,CURNAM
PUSHJ PP,PUTLNK
MOVE TA,CURFLO
HRRZI DW,E.181
JRST P138EF
FLODN: HRRZ TC,SECLOC
ADDI TC,1
HRLI TC,TD
MOVEM TC,PNTR
SETZB TD,TBLOCK ;WILL HOLD WORD NUMBER OF LOWEST SEGMENT
SETZM TBLOCK+1 ;R. H. POINTS TO LAST SECTION OF MOST RECENT SEGMENT
P138S1: MOVE TA,@PNTR ;GET SEGTAB ENTRY
JUMPE TA,P138S9 ;NOTHING FOR THIS SEGMENT
SKIPE TBLOCK ;ANYTHING AT ALL SEEN BEFORE?
JRST P138S2 ;YES
ADDI TD,1
MOVE TB,@PNTR ;GENFIL BLOCK FOR THIS SEGMENT
MOVEM TB,TBLOCK
MOVEM TA,TBLOCK+1
AOJA TD,P138S3
P138S2: MOVEM TD,TBLOCK+2
EXCH TA,TBLOCK+1 ;NEW 'LAST SEGMENT SEEN' POINTER
PUSHJ PP,LNKSET
MOVE TD,TBLOCK+2
ADDI TD,1
MOVE TB,@PNTR ;GENFIL WORD NUMBER FOR NEW SEGMENT
DPB TB,PR.GNW ;INTO OLD SECTION PROTAB ENTRY
AOJA TD,P138S3
P138S9: ADDI TD,2
P138S3: CAIG TD,306 ;198.
JRST P138S1
SKIPE TBLOCK ;SKIP IF NO SEGMENTS
JRST P138S4
MOVEI TA,100
HRLM TA,PROGST##
JRST PRODN
P138S4: HRRZ TB,TBLOCK
JUMPN TB,.+2
HRRZI TB,100
HRLM TB,PROGST ;BLOCK NUMBER OF LOWEST SEGMENT IN PROGST L.H.
MOVE TA,TBLOCK+1
JUMPE TA,PRODN
PUSHJ PP,LNKSET
MOVE TB,ARG2 ;ENDIT WORD NUMBER
DPB TB,PR.GNW ;PUT IN LAST SECTION OF LAST SEGMENT
PRODN: PUSHJ PP,CLEAND## ;CLEAN UP AFTER THE PHASE
PUSHJ PP,CLENTA## ;CLEAN UP TABLES
ENDFAZ D
RESLVQ: HRRZ TA,CURFLO
ADDI TA,SZ.FLO ;QUALIFICATION ENTRY ADDRESS
LDB TA,FL.NAM ;NAMTAB POINTER OF QUALIFIER
HRRZI TB,CD.PRO
PUSHJ PP,FNDLNK ;FIND PROTAB LINK
JRST P138QE ;THERE IS NONE
P138Q2: LDB TC,PR.SEC ;PARAGRAPH/SECTION FLAG
JUMPE TC,P138Q3 ;JUMP IF THIS IS A SECTION
PUSHJ PP,FNDNXT ;FIND NEXT ENTRY
JRST P138QE ;NO MORE
JRST P138Q2
P138Q3: MOVEM TB,TBLOCK+6 ;SAVE LINK TO SECTION PROTAB ENTRY
HRRZ TA,CURFLO
LDB TA,FL.NAM ;NAMTAB POINTER FOR QUALIFIED ITEM
HRRZI TB,CD.PRO
PUSHJ PP,FNDLNK ;FIND A PROTAB ENTRY FOR IT
JRST P138QE ;NONE
P138Q4: LDB TC,PR.SEC ;PARAGRAPH/SECTION FLAG
JUMPN TC,P138Q6 ;JUMP IF PARAGRAPH
P138Q5: PUSHJ PP,FNDNXT ;ANY MORE ENTRIES?
JRST P138QE ;NO--COULD NOT RESOLVE IT
JRST P138Q4 ;YES--TEST IT
P138Q6: LDB TD,PR.LSC ;GET SECTION LINK FOR THIS PARAGRAPH
HLRZ TC,TBLOCK+6 ;GET LINK TO QUALIFIER ENTRY
CAME TC,TD ;ARE THEY THE SAME?
JRST P138Q5 ;NO--TRY FURTHER
HLRS TB
HRRZ TA,CURFLO ;SET UP TA
DPB TB,FL.PRO ;RESOLVED IT
P138Q7: MOVE TA,CURFLO
MOVE TB,CURFLO
ADD TB,[XWD SZ.FLO,SZ.FLO]
MOVEM TB,CURFLO ;SET UP CURFLO TO IGNORE QUALIFIER ENTRY
POPJ PP,
P138QE: PUSHJ PP,P138FE
JRST P138Q7
INTER. PA139.
PA139.: SKIPG SPFLVL
POPJ PP, ;NO SPIF ACTIVE
SKIPN REINTO ;'INTO' SEEN?
JRST PA139A ;NO
PUSHJ PP,GETTAG ;GET A TAG SO 'AT END' SKIPS 'INTO' CODE
ANDI CH,077777
JUMPE CH,.-2
PUSH PP,CH ;SAVE IT FOR A MINUTE
HRLZI TB,(CH) ;OUTPUT A JUMP TO THIS TAG
HRRI TB,74
HRLI TA,074000
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
PA139A: MOVE TA,SPFLVL
ADD TA,IFLVL
HLLZ TB,ARGL2-1(TA) ;TARGET FOR SPIF
JUMPE TB,P139.E
HRLM TB,ARGL2-1(TA) ;REMOVE ENTRY
HRLZI TA,102000 ;TAGNAM OP CODE
HRRI TB,102
PUSHJ PP,PUTGEN
P139.X: SOS SPFLVL
SWOFF UNCONT;
HRRZI TA,26 ;'ENDIF' OP CODE
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.SPI## ;SPECIAL IF
SKIPN REINTO ;'INTO' SEEN?
JRST PA22. ;NO
PUSHJ PP,PA22. ;OUTPUT THE ENDIF
POP PP,CH ;GET BACK THAT TAG
PA139X: HRLZI TB,(CH) ;OUTPUT TAGNAM
HRRI TB,102
HRLI TA,102000
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
JRST PUTGEN
P139.E:
IFN MCS!TCS,<
SKIPE IFMSGF## ;ARE WE IN "IF MESSAGE"
JRST P139.X ;YES, EVERYTHING IS OK
>
SKIPN ARGL2-1(TA)
JRST P139.F
TTCALL 3,[ASCIZ /ENDSPIF ENCOUNTERED, BUT ENDIF EXPECTED--PA139.
/]
TRNA
P139.F: TTCALL 3,[ASCIZ /ENDSPIF ENCOUNTERED, BUT ARGL2 ENTRY NULL--PA139.
/]
EWARNW E.260
JRST KILL
INTER. PA141.
PA141.: SETO TA,
DPB TA,OP.MAC## ;SET 'MACRO' BIT
POPJ PP,
IFN ANS68,<
INTER. PA142.
PA142.: SETO TA,
DPB TA,OP.FOR## ;SET 'FORTRAN-IV' BIT
POPJ PP,
>
INTER. PA143.
PA143.: SETZ TA,
DPB TA,OP.COB## ;SET 'COBOL' FLAG
POPJ PP,
INTER. PA143A
PA143A: PUSHJ PP,PA143. ; SET UP COBOL FLAG [171]
JRST PA248A ; GO SET UP CALL OPERAND [171]
INTER. PA145A
PA145A:
IFN DBMS,<
SKIPN SCHSEC## ;IS THIS A DBMS PROGRAM?
EWARNW E.431 ;NO, DECL IS IN WRONG PLACE
HRRZI TA,14 ;[435] SET DECLARITIVES START OP CODE
PUSHJ PP,SETOP ;[435] SET UP OPERAND
PUSHJ PP,PA22. ;[435] PUT INTO GENFIL
>
SKPNAM ;PROCEED AS NORMAL
INTER. PA145.
PA145.: SETOM DECLR. ; [324] SET DECLARATIVES IN PROGRAM
DPB LN,[POINT 13,DECLR.,28] ;[552] SAVE LINE NUMBER
DPB CP,[POINT 7,DECLR.,35] ;[552] AND CHAR. POS.
SWON INDECL;
POPJ PP,
INTER. PA147.
PA147.: SWOFF INDECL;
IFN DBMS,<
SKIPN SCHSEC ;[435] IS THIS A DBMS PROG?
POPJ PP, ;[435] NO, NO SPECIAL CODE FOR DECLARITIVES NEEDED
HRRZI TA,15 ;[435] END DECLARITIVES OP CODE
PUSHJ PP,SETOP ;[435] SET UP OPERAND
PJRST PA22. ;[435] PUT INTO GENFIL AND RETURN
>
IFE DBMS,<
POPJ PP,
>
INTER. PA148.
PA148.: SWON FPERWD!FREGWD ;RETURN PERIOD
POPJ PP,
INTER. PA149.
PA149.: SWOFF FREGWD;
POPJ PP,
INTER. PA150.
PA150.: MOVE TA,FL.OGO## ;OBJECT OF GO
FLENT.: MOVEM TA,PNTR
MOVE TA,[XWD CD.FLO,SZ.FLO]
PUSHJ PP,GETENT ;GET A FLOTAB ENTRY
MOVEM TA,CURFLO
SETO TB,
DPB TB,PNTR ;SET TYPE OF ENTRY FLAG
TSWF INDECL;
DPB TB,FL.RDC ;REFERENCED IN DECLARATIVES
MOVE TB,ARG1+1 ;GETSRC W2
DPB TB,FL.NLC## ;NAMTAB POINTER, LN, CP
TLO TB,400000 ;SET FLOTAB REFERENCE BIT
MOVEM TB,ARG1+1 ;IN OPERAND
HLRM TA,ARG1 ;PUT FLOTAB POINTER IN OPERAND
POPJ PP,
INTER. PA151.
PA151.: MOVE TA,ARG1
MOVEM TA,TBLOCK+23
MOVE TA,ARG1+1
MOVEM TA,TBLOCK+24
SETZM ARG1
SETZM ARG1+1
POPJ PP,
INTER. PA152.
PA152.: MOVE TA,TBLOCK+23
MOVEM TA,ARG1
MOVE TA,TBLOCK+24
MOVEM TA,ARG1+1
POPJ PP,
INTER. PA153.
PA153.: HRRZ TA,CURFLO
SETO TB,
DPB TB,FL.QUA##
POPJ PP,
INTER. PA154.
PA154.: MOVE TA,FL.SAL ;'SUBJECT OF ALTER'
JRST FLENT.
INTER. PA155.
PA155.: MOVE TA,FL.OAL## ;'OBJECT OF ALTER'
JRST FLENT.
INTER. PA156.
PA156.: MOVE TA,FL.SPF## ;'SUBJECT OF PERFORM'
JRST FLENT.
INTER. PA157.
PA157.: MOVE TA,FL.OPF## ;'OBJECT OF PERFORM'
JRST FLENT.
INTER. PA159.
PA159.: MOVE TA,ARG1+1
TLNN TA,400000 ;FLOTAB ENTRY?
POPJ PP, ;NO
HRRZ TA,ARG1
ANDI TA,077777
HRRZ TB,FLOLOC
ADDI TA,(TB) ;POINTS TO FLOTAB ENTRY FOR ARG1
SETO TB,
DPB TB,FL.OPF ;'OBJECT OF PERFORM' FLAG
POPJ PP,
INTER. PA160.
PA160.: MOVE TA,OPRTR
MOVEM TA,TBLOCK
MOVE TA,OPRTR+1
MOVEM TA,TBLOCK+1
PUSHJ PP,PA22.
MOVE TA,TBLOCK
MOVEM TA,OPRTR
MOVE TA,TBLOCK+1
MOVEM TA,OPRTR+1
POPJ PP,
INTER. PA163.
PA163.: TLNE W1,40000 ;SIGNED?
EWARNW E.25 ;[467] YES
HLRZ TE,W1
ANDI TE,777 ;SIZE
MOVE TA,[XWD NAMWRD,NAMWRD+1]
SETZM NAMWRD
BLT TA,NAMWRD+4
MOVE TA,[POINT 7,LITVAL]
MOVE TB,[POINT 6,NAMWRD]
PA163A: ILDB TC,TA
SUBI TC,40 ;CONVERT TO SIXBIT
IDPB TC,TB
SOJG TE,PA163A
TLZ W2,GWDEF ;ENTER REF. TO NUMERIC PARA. NAME
PUSHJ PP,PUTCRF ; IN CREF TABLE
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM ;NOT FOUND
HRRZ W1,(TA)
HLRZS TA
DPB TA,[POINT 15,W2,15]
MOVEM W1,ARG1
MOVEM W2,ARG1+1
POPJ PP,
INTER. PA164.
PA164.: MOVE TA,ARG1
TLO TA,GWALL ;SET 'ALL' BIT IN ARG1
MOVEM TA,ARG1
POPJ PP,
INTER. PA165.
PA165.: HRRZI TA,105 ;'YECCH!' OPERATOR
PUSHJ PP,SETOP3
PUSHJ PP,PA22.
SETZM ARG1
SETZM ARG1+1
SETZM NQUAL
POPJ PP,
INTER. PAYECC
PAYECC: HRRZI TA,105 ;SET OPERATOR TO 'YECCH'
JRST SETOP3 ; AND RETURN
INTER. PA166.
PA166.: HRRZI TA,4 ;'SUBTRACT' OP CODE
JRST SETOP3
INTER. PA168.
PA168.: HRRZI TA,12 ;'REMAIN' OP CODE
JRST SETOP
INTER. PA169.
PA169.: HRRZI TA,47 ;'ENTER' OP CODE
JRST SETOP1
INTER. PA170.
PA170.: SETZM GOTQUA##
SKIPN TA,NQUAL
JRST P170.1
CAIE TA,1
JRST P170.5
MOVE TA,QUALT##
TLNN TA,GWFIGC
JRST P170.5
LDB TB,[POINT 9,TA,17]
IFN ANS68,<
CAIN TB,TALLY
JRST PA170O
>
P170.5: LDB TA,[POINT 15,QUALT+1,15] ;ITEM'S NAMTAB POINTER
HRRZI TB,CD.DAT
PUSHJ PP,FNDLNK
JRST P170.0 ;MAY BE CONDITION-NAME
PA170A: HLRM TB,QUALT
PUSHJ PP,DOQUAL
JRST PA170B
SKIPE GOTQUA
JRST P170.2 ;INSUFFICIENT QUALIFICATION
HRRZM TA,GOTQUA ;TA CONTAINS QUALT ON RETURN
PA170B: PUSHJ PP,LNKSET
PUSHJ PP,FNDNXT## ;FIND THE NEXT ITEM WITH THE SAME
; NAME IN THE CURRENT TABLE.
SKIPA TB,SAVE1## ;NO MORE IN THIS TABLE.
JRST PA170A ;GO SEE IF THIS NAME WORKS.
CAIE TB,CD.CON ;IF IT WAS CONTAB, WE'RE THROUGH.
JRST P170.0 ;GO LOOK AT CONTAB.
PA170C: SKIPN TA,GOTQUA ;ANY FOUND?
JRST P170.1 ;NO
PA170O: HLL TA,QUALT
MOVEM TA,ARG1
MOVE TA,QUALT+1
MOVEM TA,ARG1+1
SETZM NQUAL
POPJ PP,
P170.0: LDB TA,[POINT 15,QUALT+1,15] ;ITEM'S NAMTAB POINTER
HRRZI TB,CD.CON
PUSHJ PP,FNDLNK
JRST PA170C ;NO CONTAB LINK
JRST PA170A
P170.1: HRRZI DW,E.104 ;NOT DEFINED
JRST PA170E
P170.2: HRRZI DW,E.60
PA170E: LDB LN,[POINT 13,QUALT+1,28]
LDB CP,[POINT 7,QUALT+1,35]
IFN DEBUG,<
PUSHJ PP,WARN
>
IFE DEBUG,<
PUSHJ PP,FATAL
>
MOVEI TA,<CD.DAT>B20+1 ;ASSUME DUMMY DATAB ENTRY
MOVEM TA,QUALT
JRST PA170O
DOQUAL: HRRZI TA,1
HRRZM TA,CURQUA## ;CURRENT ENTRY NUMBER-1
HRRZ TA,QUALT
JUMPE TA,NOPOP
HRLZM TA,CURDAT##
PUSHJ PP,LNKSET
HRRM TA,CURDAT
HRRZ TC,CURQUA
DQULUP: CAML TC,NQUAL
JRST DOOUT
NXTPOP: PUSHJ PP,GETPOP ;FIND FATHER OF CURDAT ITEM
JRST NOPOP ;FOUND NONE
MOVEM TA,CURDAT ;SAVE FATHER LINK
LDB TB,DA.NAM## ;FATHER'S NAMTAB LINK
HRRZ TC,CURQUA
LSH TC,1
LDB TD,[POINT 15,QUALT+1(TC),15] ;NAMTAB LINK OF ITEM SOUGHT
CAME TB,TD ;ARE THEY THE SAME?
JRST NXTPOP ;NO --- TRY HIGHER
HLRM TA,QUALT(TC) ;PUT LINK IN QUALT ENTRY
AOS TC,CURQUA
JRST DQULUP ;CHECK FOR MORE QUALIFIERS
DOOUT: MOVE TA,QUALT
POP PP,TE
JRST 1(TE)
NOPOP: MOVE TA,QUALT
POPJ PP, ;FAILURE EXIT
GETPOP: MOVE TA,CURDAT
JUMPE TA,CPOPJ
LDB TB,[POINT 3,CURDAT,2]
CAIN TB,CD.DAT
JRST NXTTRY ;DATAB ITEM
CAIE TB,CD.CON
POPJ PP,
LDB TA,CO.DAT## ;CONTAB ITEM FATHER LINK
JUMPN TA,GOTFA ;NOT NULL
POPJ PP,
NXTTRY: LDB TB,DA.FAL## ;FATHER/BROTHER FLAG
JUMPN TB,ISFAL ;FATHER
LDB TA,DA.BRO## ;GET BROTHER LINK
JUMPE TA,CPOPJ ;NULL
PUSHJ PP,LNKSET
JRST NXTTRY
ISFAL: LDB TA,DA.POP## ;GET FATHER LINK
JUMPE TA,CPOPJ ;NULL
GOTFA: HRRZM TA,TBLOCK
LDB TB,[POINT 3,TA,20] ;COULD BE AN RPW LINK
JUMPE TB,GOTRPW ;MAYBE
GOTFA1: PUSHJ PP,LNKSET
GOTFA2: HRL TA,TBLOCK
POP PP,TE
JRST 1(TE)
GOTRPW: HRRZI TC,(TA)
HRRZ TA,CURDAT ;SEE IF LINE- OR PAGE-COUNTER BIT ON
LDB TB,DA.LPC##
JUMPE TB,GOTRP1 ;NO, MUST BE A FILTAB LINK
HRRZ TA,RPWLOC ;YES, GET RPWTAB ADDRESS
ADDI TA,(TC)
JRST GOTFA2
GOTRP1: HRRZI TA,(TC) ;RESTORE TA
JRST GOTFA1
INTER. PA171.
PA171.: HRRZ TC,NQUAL
LSH TC,1
CAIL TC,144 ;SIZE OF TABLE
EWARNJ E.190 ;TOO MANY QUALIFIERS
MOVE TA,ARG1
MOVEM TA,QUALT(TC)
MOVE TA,ARG1+1
MOVEM TA,QUALT+1(TC)
SETZM ARG1
SETZM ARG1+1
AOS NQUAL
POPJ PP,
INTER. PA172.
PA172.: HRRZI TB,CD.EXT
LDB TA,[POINT 15,W2,15]
PUSHJ PP,FNDLNK
JRST P172.A ;NOT FOUND
HLRM TB,W1
HLRM TB,ARG1
SKIPN PRIOR
POPJ PP,
HRRZ TA,W1
PUSHJ PP,LNKSET
MOVE TB,1(TA)
TLO TB,NR.EXT ;[574]
MOVEM TB,1(TA)
POPJ PP,
P172.A: MOVE TA,[XWD CD.EXT,SZ.EXT]
PUSHJ PP,GETENT
HLRM TA,W1
HLRM TA,ARG1
LDB TB,[POINT 15,W2,15]
IORI TB,500000
MOVSM TB,(TA)
SKIPN PRIOR ;[574] SKIP IF SECTION PRIORITY NOT ZERO
TDZA TB,TB ;[574] NOT EXTERNAL--GET 0 AND SKIP
MOVSI TB,NR.EXT ;[574] SET EXTERNAL BIT
MOVEM TB,1(TA)
LDB TB,[POINT 15,W2,15]
HRR TA,TB
JRST PUTLNK
INTER. PA173.
PA173.: SETZ TC,
LDB TA,OP.USE
LDB TB,OP.OPC
IFN ANS74,<
MOVE TE,OPRTR
>
IFN ANS68,<
CAIN TB,66 ;USE
JRST P173.0 ;NOT ERROR USE
>
CAIN TB,75
JRST P173.B ;ERROR USE
JRST P173.X
IFN ANS68,<
P173.0: MOVE TE,OPRTR
TLNN TE,40 ;BEGINNING?
JRST P173.A ;NO
HRRZI TC,3
TLNE TE,10 ;REEL/UNIT?
PUSHJ PP,CHK173 ;YES
HRRZI TC,6
TLNE TE,4 ;FILE?
PUSHJ PP,CHK173 ;YES
P173.A: TLNN TE,20 ;ENDING?
JRST P173.X ;NO
HRRZI TC,17
TLNE TE,10 ;REEL/UNIT?
PUSHJ PP,CHK173 ;YES
HRRZI TC,22
TLNE TE,4 ;FILE?
PUSHJ PP,CHK173 ;YES
JRST P173.X
CHK173: TLNE TE,100 ;BEFORE?
ADDI TC,6 ;NO
>
P173.B: CAIN TA,3
IFN ANS74,<
TLNE TE,10 ;USE ... EXTEND (IT ALSO HAS VALUE OF 3)
SKIPA TC,TA ;LOAD TC WITH 0 THRU 3
>
JRST P173.C ;SPECIFIC FILE
IFN ANS68,<
ADD TC,TA
>
SKIPE TB,USES(TC)
JRST P173.E ;CONFLICTS WITH PREVIOUS USE
HLRZ TD,CURSEC
HRRZM TD,USES(TC)
P173.X: SETZM ARG1
SETZM ARG1+1
POPJ PP,
P173.C: MOVEM TC,TBLOCK
HRRZ TA,ARG1
JUMPE TA,P173.X
PUSHJ PP,LNKSET
MOVE TC,TBLOCK
IDIVI TC,3
SETZ TB,
LSHC TC,-1
MOVE TD,FI.ERR##
ADD TD,TC
SKIPE TB
IBP TD
LDB TB,TD
JUMPN TB,P173.E ;PREVIOUS USE OF THIS TYPE
HLRZ TB,CURSEC
DPB TB,TD
LDB TB,[POINT 1,OPRTR,15] ;GET ERROR-ON-OPEN BIT
DPB TB,FI.ENT## ;IF ON, SET IT IN FILTAB
POPJ PP,
P173.E: MOVEM TB,TBLOCK
MOVEM TE,TBLOCK+1
MOVEM TA,TBLOCK+2
MOVE TA,CURSEC
LDB TA,PR.FLO
ADD TA,FLOLOC
LDB LN,FL.LN
LDB CP,FL.CP
HRRZI DW,E.505
PUSHJ PP,FATAL
MOVE DW,TBLOCK
PUSHJ PP,PUTERA##
MOVE TE,TBLOCK+1
MOVE TA,TBLOCK+2
POPJ PP,
INTER. PA174.
PA174.: SETO TA,
DPB TA,OP.IN2## ;'INTO'
SETOM REINTO ;REMEMBER 'INTO' SEEN FOR 'AT END'
POPJ PP,
IFN ANS74,<
INTER. PA174N
PA174N: SETO TA,
DPB TA,OP.NXT## ;'NEXT'
POPJ PP,
INTER. PA174K
PA174K: POPJ PP, ;'KEY' IS DATA-NAME
>
INTER. PA175.
PA175.: SKIPN TA,CURFIL##
POPJ PP,
LDB TB, OP.ADV## ;ADVANCING ON?
TRNE TB, 1
SKIPA TB, FI.ADV## ;YES.
MOVE TB, FI.PSN## ;NO, MUST BE POSITIONING THEN.
SETOI TC,
DPB TC, TB ;SET THE APPROPRIATE FLAG.
POPJ PP,
INTER. PA176.
PA176.: SETO TA,
DPB TA,OP.FRM## ;'FROM'
POPJ PP,
INTER. PA177.
;22-AUG-79 /DAW DIAGNOSE COMMON ERROR OF "START" USED
; AS A PARAGRAPH NAME AND GIVE A CLEARER ERROR MESSAGE.
PA177.: HRLM LN,DWLNCP ;SAVE LN
HRRM CP,DWLNCP ;,,CP
HRRZI TA,67 ;[68] 'SEEK' OR [74] 'START' OP CODE
JRST SETOP1
IFN ANS74,<
;HERE IF "START <PRIOD.>" SEEN
INTER. PA177A
PA177A: HLRZ LN,DWLNCP ;GET SAVED "LN"
MOVEM LN,WORDLN
HRRZ CP,DWLNCP ;GET SAVED "CP"
MOVEM CP,WORDCP ;SAVE FOR "WARN"
EWARNJ E.730 ;"RESERVED WORD.. MAY NOT BE USED AS PARA. NAME"
>
INTER. PA178.
PA178.: HRRZI TA,51 ;'CADD' OP CODE
JRST SETOP0
INTER. PA179.
PA179.: HRRZI TA,52 ;'CSUB' OP CODE
JRST SETOP0
INTER. PA180.
PA180.: HRRZI TA,53 ;'CMUL' OP CODE
JRST SETOP0
INTER. PA181.
PA181.: HRRZI TA,54 ;'CDIV' OP CODE
JRST SETOP0
INTER. PA182.
PA182.: HRRZI TA,55 ;'CEXP' OP CODE
JRST SETOP0
INTER. PA183.
PA183.: MOVE TE,OP.ALF##
P183.A: SETZM OPRTR+1
HRRZI TA,22 ;'IFT' OP CODE
P183.C: PUSHJ PP,SETOP1
P183.B: SETO TA,
DPB TA,TE
JRST P189.A
INTER. PA184.
PA184.: MOVE TE,OP.NUM##
JRST P183.A
INTER. PA185.
PA185.: MOVE TE,OP.POS##
JRST P183.A
INTER. PA186.
PA186.: MOVE TE,OP.NEG##
JRST P183.A
INTER. PA187.
PA187.: TLNN W1,GWRESV
JRST P187.E
LDB TA,[POINT 9,W1,17]
CAIE TA,ZERO.
JRST P187.E
MOVE TE,OP.ZER##
JRST P183.A
P187.E: PUSHJ PP,PA165. ;"YECCH"
SOS IFLVL ;COME DOWN ONE LEVEL OF IF
EWARNW E.86
JRST PA0. ;POP UP ONE BRANCH IN TREE
INTER. PA188.
PA188.: HRRZI TA,20 ;'IF' OP CODE
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.GRT## ;'GREATER' FLAG
JRST P189.A
INTER. PA189.
PA189.: HRRZI TA,20
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.LES## ;'LESS' OP CODE
P189.A: TSWTZ FNOTF;
TDZA TA,TA
SETO TA,
HRRZ TB,CLEVEL
HLRZ TC,ARGLST(TB)
TRNE TC,400000
TRC TA,1
DPB TA,OP.NOT##
MOVE TA,[XWD OPRTR,IMPLOP]
BLT TA,IMPLOP+1
POPJ PP,
INTER. PA190.
PA190.: HRRZI TA,20
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.EQU## ;'EQUALS' OP CODE
JRST P189.A
IFN ANS74,<
;HERE FOR NOT GREATER, NOT LESS, NOT EQUALS
INTER. PA188N
PA188N: TSWC FNOTF ;COMPLEMENT NOT FLAG
HRRZI TA,20 ;'IF' OP CODE
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.LES ;NOT 'GREATER' OP CODE
DPB TA,OP.EQU ;...
JRST P189.A
INTER. PA189N
PA189N: TSWC FNOTF ;COMPLEMENT NOT FLAG
HRRZI TA,20
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.GRT ;NOT 'LESS' OP CODE
DPB TA,OP.EQU ;...
JRST P189.A
INTER. PA190N
PA190N: TSWC FNOTF ;COMPLEMENT NOT FLAG
HRRZI TA,20
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.GRT ;NOT 'EQUALS' OP CODE
DPB TA,OP.LES ;...
JRST P189.A
>
INTER. PA191.
PA191.: HRRZI TA,50 ;'COMPUTE' OP CODE
SWON FARITH;
JRST SETOP1
INTER. PA192.
PA192.: PUSHJ PP,PA103.
IFN MCS!TCS,<
SKIPN IFMSGF##
JRST P192.A
MOVE TA,SPFLVL
ADD TA,IFLVL
HLLZ TB,ARGL2-1(TA)
HRLM TB,ARGL2-1(TA)
HRLZI TA,102000
HRRI TB,102
PUSHJ PP,PUTGEN
>
P192.A: HRRZ TA,IFLVL
ADD TA,SPFLVL
HRRZ TC,ARGL2-1(TA) ;F-TARGET
HLRM TC,ARGL2-1(TA) ;CLEAR IT
JRST P127.A ;DEFINE IT
INTER. PA193.
PA193.: HRLZ TB,NXTSNT
SETZM NXTSNT
JUMPE TB,CPOPJ
HRRI TB,102 ;TAGNAM OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
JRST PUTGEN ;DEFINE SENTENCE TAG
INTER. PA194.
PA194.: SETZM OPRTR+1
HRRZI TA,21 ;'IFC' OP CODE
PUSHJ PP,SETOP1
JRST P189.A
INTER. PA195.
PA195.: MOVE TE,OP.ON##
P195.A: SETZM OPRTR+1
HRRZI TA,21
PUSHJ PP,SETOP1
MOVE TB,TBLOCK
DPB TB,OP.SWT##
JRST P183.B
INTER. PA196.
PA196.: MOVE TE,OP.OFF##
JRST P195.A
INTER. PA197.
PA197.: SETZM TBLOCK
SETZM OPRTR+1
HRRZI TA,76 ;CLREOP
PUSHJ PP,SETOP0
TLNE W1,GWNLIT
TLNE W1,GWDP
EWARNJ E.25
HLRZ TB,W1
ANDI TB,177
HRRZM TB,CTR
HRRZI TA,LITVAL
PUSHJ PP,GETVAL
CAIL TC,0
CAILE TC,43
EWARNJ E.243
MOVEM TC,TBLOCK
POPJ PP,
INTER. PA198.
PA198.: SKIPN ARG2
SKIPE ARG2+1
JRST P198.A ;PERFORM ... THRU ...
PUSHJ PP,PA159. ;PERFORM ...
P198.A: PUSHJ PP,GETTAG
ANDI CH,077777
JUMPE CH,.-2
HRRZM CH,UNTTAG##
HRLZI TB,(CH)
HRRI TB,74 ;'JUMPTO' OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
PUSHJ PP,GETTAG
ANDI CH,077777
JUMPE CH,.-2
HRLZI TB,(CH)
HRRZM CH,UNTTAG+1
HRRI TB,102 ;'TAGNAM' OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
SKIPN ARG2
SKIPE ARG2+1
JRST P198.B ;PERFORM ... THRU ...
PUSHJ PP,PCA25.
JRST P198.C
P198.B: PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA22.
P198.C: HRLZ TB,UNTTAG
HRRI TB,102 ;'TAGNAM' OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
JRST PUTGEN
INTER. PA199.
PA199.: PUSHJ PP,GETTAG
ANDI CH,077777
HRRZM CH,UNTTAG
HRLZI TB,(CH)
HRRI TB,74 ;'JUMPTO' OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
PUSHJ PP,P192.A ;IMPLICIT 'ELSE'
HRLZ TB,UNTTAG+1
HRRI TB,74 ;'JUMPTO' OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
PUSHJ PP,PA37.
HRLZ TB,UNTTAG
HRRI TB,102
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
JRST PUTGEN
INTER. PA200.
PA200.: MOVE TA,NVARY
CAILE TA,3
HRRZI TA,3
MOVEM TA,MVARY##
MOVE TA,[XWD SAVPRF,OPRTR]
BLT TA,ARG2+1
PUSHJ PP,PA21.
PUSHJ PP,PA47.
SKIPN ARG1
SKIPE ARG1+1
PUSHJ PP,PA21.
PUSHJ PP,PA22.
P200.A: SOSGE TA,NVARY
POPJ PP,
CAILE TA,2
JRST P200.A ;MORE THAN 3 SEEN
IMULI TA,^D45 ;[222] WAS ^D27.
MOVSI TB,VARBLK(TA)
HRRI TB,ARG1
BLT TB,ARG1+1
MOVSI TB,VARBLK+2(TA)
HRRI TB,NSBSC1
BLT TB,NSBSC1+^D12 ;[222] WAS ^D6.
MOVSI TB,VARBLK+^D30(TA) ;[222] WAS ^D18.
HRRI TB,ARG2
BLT TB,ARG2+1
MOVSI TB,VARBLK+^D32(TA) ;[222] WAS ^D20.
HRRI TB,NSBSC2
BLT TB,NSBSC2+^D12 ;[222] WAS ^D6.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA30. ;'ADDTO' OPERATOR
PUSHJ PP,PA22.
PUSHJ PP,PA34. ;'RESULT' OPERATOR
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA22.
HRRZ TA,NVARY
LSH TA,1
HRLZ TB,VARTAG+2(TA)
HRRI TB,74 ;'JUMPTO' OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
SKIPG TA,NVARY
JRST P200.B
LSH TA,1
HRLZ TB,VARTAG+1(TA)
HRRI TB,102 ;'TAGNAM' OP CODE
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
PUSHJ PP,PA70. ;'MOVE' OPERATOR
HRRZ TA,NVARY
IMULI TA,^D45 ;[222] WAS ^D27.
MOVSI TB,VARBLK(TA)
HRRI TB,ARG1
BLT TB,ARG1+1
MOVSI TB,VARBLK+2(TA)
HRRI TB,NSBSC1
BLT TB,NSBSC1+^D12 ;[222] WAS ^D6.
MOVSI TB,VARBLK+^D15(TA) ;[222] WAS ^D9.
HRRI TB,ARG2
BLT TB,ARG2+1
MOVSI TB,VARBLK+^D17(TA) ;[222] WAS ^D11.
HRRI TB,NSBSC2
BLT TB,NSBSC2+^D12 ;[222] WAS ^D6.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA22.
JRST P200.A
P200.B: HRLZ TB,VARTAG ;%S
HRRI TB,102 ;'TAGNAM' OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
SETZB TA,NVARY
P200.C: CAML TA,MVARY
JRST P200.D
PUSHJ PP,PA70. ;'MOVE' OPERATOR
HRRZ TA,NVARY
IMULI TA,^D45 ;[222] WAS ^D27.
MOVSI TB,VARBLK(TA)
HRRI TB,ARG1
BLT TB,ARG1+1
MOVSI TB,VARBLK+2(TA)
HRRI TB,NSBSC1
BLT TB,NSBSC1+^D12 ;[222] WAS ^D6.
MOVSI TB,VARBLK+^D15(TA) ;[222] WAS ^D9.
HRRI TB,ARG2
BLT TB,ARG2+1
MOVSI TB,VARBLK+^D17(TA) ;[222] WAS ^D11.
HRRI TB,NSBSC2
BLT TB,NSBSC2+^D12 ;[222] WAS ^D6.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA22.
AOS TA,NVARY
JRST P200.C
P200.D: HRLZ TB,VARTAG+2 ;%C1
HRRI TB,74 ;'JUMPTO' OP CODE
SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
HRLZ TB,VARTAG+1 ;%Z
HRRI TB,102
DPB TB,[POINT 9,TA,8]
JRST PUTGEN
INTER. PA201.
PA201.: MOVE TA,ARG2 ;SAVE
MOVEM TA,HROUND## ; "ROUND" FLAG
SETZM CORRSP+12
SETO TA,
DPB TA,OP.COR##
MOVE TA,[XWD OPRTR,CORRSP+10]
BLT TA,CORRSP+11
MOVE TA,[XWD CORRSP+6,OPRTR]
BLT TA,OPRTR+1
HRRZ TA,ARG1
JUMPE TA,P201.X
LDB TB,[POINT 3,TA,20]
CAIE TB,CD.DAT
JRST P201.X
HRLZM TA,CORRSP##
PUSHJ PP,LNKSET
HRRM TA,CORRSP
LDB TB,DA.SON
JUMPE TB,P201E1 ;CANNOT BE ELEMENTARY
HRRZ TA,ARG2
JUMPE TA,P201.X
LDB TB,[POINT 3,TA,20]
CAIE TB,CD.DAT
JRST P201.X
HRLZM TA,CORRSP+1
PUSHJ PP,LNKSET
HRRM TA,CORRSP+1
LDB TB,DA.SON
JUMPE TB,P201E1
MOVE TB,ARG1+1
MOVEM TB,CORRSP+4
MOVE TB,ARG2+1
MOVEM TB,CORRSP+5
MOVE TA,CORRSP
MOVEM TA,CORRSP+2 ;'LEFT' OPERAND
MOVE TA,CORRSP+1
MOVEM TA,CORRSP+3 ;'RIGHT' OPERAND
MOVE TA,[XWD NSBSC1,CORRSP+13]
BLT TA,CORRSP+21
MOVE TA,[XWD NSBSC2,CORRSP+22]
BLT TA,CORRSP+30
P201.1: MOVE TA,CORRSP+2
LDB TA,DA.SON
JUMPE TA,P201E2 ;SHOULDN'T BE POSSIBLE
HRLZM TA,CORRSP+2
PUSHJ PP,LNKSET
HRRM TA,CORRSP+2 ;'LEFT'_SON('LEFT')
P201.3: LDB TB,DA.LVL##
CAIN TB,76
JRST P201.2 ;IGNORE 66 LEVEL ITEMS
LDB TB,DA.OCC##
JUMPN TB,P201.2 ;IGNORE ITEMS WITH OCCURS CLAUSES
LDB TB,DA.RDF##
JUMPN TB,P201.2
LDB TB,DA.NAM
ADD TB,NAMLOC
HLRZ TC,(TB) ;L. H. OF NAMTAB ENTRY HEADER
ANDI TC,07777
CAIN TC,FILLE.
JRST P201.2 ;IGNORE FILLER
MOVE TA,CORRSP+3
LDB TA,DA.SON##
JUMPE TA,P201.2
HRLZM TA,CORRSP+3
PUSHJ PP,LNKSET
HRRM TA,CORRSP+3
P201.5: LDB TB,DA.LVL
CAIN TB,76
JRST P201.4
LDB TB,DA.OCC
JUMPN TB,P201.4
LDB TB,DA.RDF
JUMPN TB,P201.4
LDB TB,DA.NAM
HRRZI TD,(TB)
ADD TB,NAMLOC
HLRZ TC,(TB)
ANDI TC,077777
CAIN TC,FILLE.
JRST P201.4
HRRZ TA,CORRSP+2
LDB TB,DA.NAM
CAIE TB,(TD)
JRST P201.4 ;NOT THE SAME NAME
LDB TB,DA.SON ;SON OF 'LEFT'
HRRZ TA,CORRSP+3
LDB TC,DA.SON ;SON OF 'RIGHT'
JUMPE TB,.+2 ;'LEFT' IS ELEMENTARY
JUMPN TC,P201.1 ;NEITHER IS ELEMENTARY
IORI TB,(TC)
JUMPE TB,P201.O ;BOTH ELEMENTARY
LDB TC,OP.OPC
CAIE TC,1
JRST P201.2 ;NOT 'MOVE' --- BOTH MUST BE ELEMENTARY
P201.O: MOVE TA,CORRSP+2
HLRZM TA,ARG1
MOVE TC,CORRSP+4
MOVEM TC,ARG1+1
MOVE TA,CORRSP+3
HLR TA,HROUND ;GET POSSIBLE "ROUND" FLAG
MOVSM TA,ARG2
MOVEM TC,ARG2+1
MOVE TA,[XWD CORRSP+13,NSBSC1]
BLT TA,NSBSC1+6
MOVE TA,[XWD CORRSP+22,NSBSC2]
BLT TA,NSBSC2+6
PUSHJ PP,PA21. ;'LEFT'
LDB TB,OP.OPC
CAIE TB,1
JRST P201O1 ;NOT 'MOVE'
PUSHJ PP,PA47.
PUSHJ PP,PA21.
MOVE TA,[XWD OPRTR,CORRSP+6]
BLT TA,CORRSP+7 ;SAVE OPERATOR
P201O2: PUSHJ PP,PA22.
MOVS TA,[XWD OPRTR,CORRSP+6]
BLT TA,OPRTR+1
AOS CORRSP+12
JRST P201.4
P201O1: MOVE TA,[XWD OPRTR,CORRSP+6]
BLT TA,CORRSP+7
PUSHJ PP,PA22.
PUSHJ PP,PA47.
MOVE TB,CORRSP+5 ;GET CORRECT LINE & CHAR POS. OF 2ND
MOVEM TB,ARG1+1 ; GROUP ARG IN CASE OF ERROR
PUSHJ PP,PA21.
MOVE TA,[XWD CORRSP+10,OPRTR]
BLT TA,OPRTR+1
JRST P201O2 ;OUTPUT 'RESULT'
P201.4: HLRZ TB,CORRSP+3 ;'RIGHT'
HLRZ TC,CORRSP+1
CAIN TB,(TC)
JRST P201.X ;FINISHED
PUSHJ PP,FNDBRO
JRST P201.6 ;NO BROTHER
HRLZM TB,CORRSP+3
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,CORRSP+3
JRST P201.5
P201.6: HLRZ TB,CORRSP+3
HLRZ TC,CORRSP+1
CAIN TB,(TC)
JRST P201.X
PUSHJ PP,FNDPOP
JRST P201.X
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.DAT
JRST P201.X
HRLZM TB,CORRSP+3
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,CORRSP+3
P201.2: HLRZ TB,CORRSP+2 ;'LEFT'
HLRZ TC,CORRSP
CAIN TB,(TC)
JRST P201.X
PUSHJ PP,FNDBRO
JRST P20121
HRLZM TB,CORRSP+2
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,CORRSP+2
JRST P201.3
P20121: HLRZ TB,CORRSP+2
HLRZ TC,CORRSP
CAIN TB,(TC)
JRST P201.X
PUSHJ PP,FNDPOP
JRST P201.X
HLRZ TC,CORRSP
CAIN TB,(TC)
JRST P201.X
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.DAT
JRST P201.X
HRRZI TA,(TB)
HRLZM TB,CORRSP+2
PUSHJ PP,LNKSET
HRRM TA,CORRSP+2
JRST P201.6
P201.X: SKIPE CORRSP+12
JRST P201X1
LDB LN,OP.LN
LDB CP,OP.CP
HRRZI DW,E.105 ;NO CORRESPONDING ELEMENTS
PUSHJ PP,WARN
P201X1: SETZM OPRTR
MOVE TA,[XWD OPRTR,OPRTR+1]
BLT TA,ARG2+1
POPJ PP,
P201E1: LDB LN,OP.LN
LDB CP,OP.CP
HRRZI DW,E.265
JRST FATAL
P201E2: TTCALL 3,[ASCIZ /PA201.--INTERNAL COMPILER ERROR
/]
JRST KILL
FNDPOP: JUMPE TB,CPOPJ
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.DAT
POPJ PP,
HRRZI TA,(TB)
POP.1: HRRZM TA,TBLOCK
PUSHJ PP,LNKSET
LDB TB,DA.FAL
JUMPE TB,POP.2 ;BROTHER LINK
LDB TB,DA.POP
POP PP,TE
JRST 1(TE)
POP.2: LDB TA,DA.BRO
JUMPN TA,POP.1
POPJ PP,
FNDBRO: JUMPE TB,CPOPJ
LDB TC,[POINT 3,TC,20]
CAIE TC,CD.DAT
POPJ PP,
HRRZI TA,(TB)
PUSHJ PP,LNKSET
LDB TB,DA.FAL
JUMPN TB,CPOPJ
LDB TB,DA.BRO
JUMPE TB,CPOPJ
POP PP,TE
JRST 1(TE)
; THIS ROUTINE FINDS THE FILE WHICH CONTAINS THE GIVEN RECORD NAME [257]
FNDFIL: SETZM CURFIL ; [275] CLEAR FILENAME
HRRZ TB,ARG1 ; [275] GET ITEM
JUMPE TB,CPOPJ ; [275] NONE - ERROR
LDB TC,[POINT 3,TB,20]; [275] GET TYPE OF ITEM
CAIN TC,CD.FIL ; [275] IS IT A FILE-NAME?
JRST FIL.F ; [275] YES GO IT
CAIN TC,CD.DAT ; [275] IS ITEM A DATA-NAME?
FIL.A: PUSHJ PP,FNDPOP ; [275] GET FATHER OF DATA-ITEM
POPJ PP, ; [275] NONE- DATA ITEM NOT IN A FILE-ERROR RETURN
LDB TC,[POINT 3,TB,20]; [275] GET TYPE OF FATHER
CAIN TC,CD.DAT ; [275] IF FATHER IS A DATA NAME
JRST FIL.A ; [275] THEN LOOP TO GET NEXT FATHER
CAIE TC,CD.FIL ; [275] IS FATHER A FILE-NAME
POPJ PP, ; [275] NO NOT A FILE OR DATA NAME- ERROR EXIT
FIL.F: HRLZM TB,CURFIL ; [275] STORE THE FILE NAME RELATIVE ADDRESS
HRRZI TA,(TB) ; [275] NOW GET ITS REAL
PUSHJ PP,LNKSET ; [275] ADDRESS
HRRM TA,CURFIL ; [275] STORE FILENAME ADDRESS
JRST CPOPJ1 ; [257] FOUND --SKIP RETURN
INTER. PA202.
PA202.: MOVE TA,[XWD OPRTR,CORRSP+6]
BLT TA,CORRSP+7
POPJ PP,
INTER. PA203.
PA203.: PUSHJ PP,PA34.
SETO TA,
DPB TA,OP.SZE
POPJ PP,
INTER. PA204.
PA204.: SETZM OPRTR
DPB LN,OP.LN
DPB CP,OP.CP
HRRZI TA,23 ;'SPIF' OPERATOR
PUSHJ PP,SETOP3
SETO TA,
DPB TA,OP.SZE
DPB TA,OP.COR
JRST PA90.A
INTER. PA205.
PA205.: TSWF FNOSUB ;IF SUBSCRIPTING NO ALLOWED
EWARNW E.275 ;GIVE ERROR
SETZM NSBSC1
MOVE TA,[XWD NSBSC1,SBSCR1]
MOVEI TB,MAXSUB*4-1
BLT TA,SBSCR1(TB)
PUSHJ PP,PA170.
MOVE TA,[XWD ARG1,ARG3]
BLT TA,ARG3+1
POPJ PP,
INTER. PA206A
PA206A:
IFN ANS68,<
HLRZ TA,ARG1 ; GET SUBCRIPT [250]
CAIN TA,GWRESV!GWFIGC!TALLY ; IS IT TALLY?
JRST PA206. ; YES GO ON [205]
>
HRRZ TA,ARG1 ; [405] GET SUBSCRIPT RELATIVE DATAB ADDRESS
PUSHJ PP,LNKSET ; [405] GET IS REAL ADDRESS
MOVEM TA,CURDAT ; [405] NOW STORE IT
LDB TB,DA.SUB## ; IS SUBSCRIPTED ITEM SUBSCRIPTED ? [137]
SKIPE TB ; ERROR IF SO [137]
EWARNW E.495 ; ERROR MESSAGE [137]
SKPNAM ; OK GO ON [137]
INTER. PA206.
PA206.: AOS TA,NSBSC1
CAILE TA,MAXSUB
JRST [MOVEI TA,MAXSUB ; [363] RESTORE TO MAXIMUM
MOVEM TA,NSBSC1 ; [363] LIMIT
EWARNJ E.277] ; [363] TOO MANY SUBSCRIPTS.
ASH TA,2
HRRZI TA,SBSCR1-4(TA)
HRRZI TB,1(TA)
HRLI TA,ARG1
BLT TA,(TB)
POPJ PP,
INTER. PA207.
PA207.: HRRZI TA,110 ;'SORT'
SWON FNOSUB ;SUBSCRIPTING NOT ALLOWED
JRST SETOP1
INTER. PA207A
PA207A: SWON FNOSUB; ;[645] SUBSCRIPTING NOT ALLOWED
HRRZI TA,117 ;'MERGE'
JRST SETOP1
IFN ANS74,<
INTER. PA207C
PA207C: MOVEI TA,107 ;COLLATING SEQUENCE
JRST SETOP1
>
INTER. PA208.
PA208.: HRRZI TA,111 ;'KEY'
JRST SETOP1
INTER. PA209.
PA209.: PUSHJ PP,PA208.
SETO TA,
DPB TA,OP.ASC## ;'ASCENDING KEY'
POPJ PP,
INTER. PA210.
PA210.: MOVEI TA,112 ;'INPUT PROCEDURE' OP CODE
JRST SETOP1
INTER. PA211.
PA211.: MOVEI TA,113 ;'OUTPUT PROCEDURE' OP CODE
JRST SETOP1
INTER. PA212.
PA212.: HRRZI TA,115 ;'USING'
JRST SETOP1
INTER. PA213.
PA213.: HRRZI TA,114 ;'GIVING'
JRST SETOP1
INTER. PA214.
PA214.: HRRZI TA,116 ;'ENDSRT'
SWOFF FNOSUB ;TURN SUBSCRIPTING BACK ON
JRST SETOP0
INTER. PA215.
PA215.: HRRZ TA,ARG1
JUMPE TA,CPOPJ
LDB TB,[POINT 3,TA,20]
CAIE TB,CD.FIL
POPJ PP,
PUSHJ PP,LNKSET
LDB TB,OP.OPC
CAIE TB,115 ;'USING'
JRST P215.A
SETO TB,
DPB TB,FI.INO
JRST P215.B
P215.A: CAIE TB,114 ;'GIVING'
POPJ PP,
SETO TB,
DPB TB,FI.OUO
P215.B: LDB TB,FI.DSD##
JUMPE TB,CPOPJ
LDB CP,[POINT 7,ARG1+1,35]
LDB LN,[POINT 13,ARG1+1,28]
HRRZI DW,E.291
JRST FATAL
INTER. PA216.
PA216.: PUSHJ PP,PCA83. ; [257] CHECK THAT RECORD IS 01 OR 77 LEVEL
PUSHJ PP,FNDFIL ; GO GET ASSOC FILE [257]
JFCL ; WILL CATCH ERROR IN IOGEN PHASE E [257]
JRST PA21. ; STORE OPERANDS [257]
INTER. PA217.
PA217.: SETO TB,
DPB TB,OP.USI##
PUSHJ PP,PA21.
PUSHJ PP,PA22.
SETZM OPRTR+1
HRRZI TA,46 ;'USING'
JRST SETOP1
INTER. PA218.
PA218.: LDB TE,[POINT 13,W2,28]
MOVE TA,[POINT 7,TBLOCK+1]
SETZM TBLOCK+1
HRRZI TC,^D1000
P218.A: IDIVI TE,(TC)
ADDI TE,"0"
IDPB TE,TA
IDIVI TC,^D10
HRRZI TE,(TD)
JUMPG TC,P218.A
MOVE TB,[ASCII /LINE /]
MOVEM TB,TBLOCK
MOVE TA,[XWD CD.VAL,2]
PUSHJ PP,GETENT
MOVE TB,[POINT 7,(TA)]
HRRZI TD,^D9
MOVE TC,[POINT 7,TBLOCK]
IDPB TD,TB
ILDB TD,TC
JUMPN TD,.-2
HLRZ W1,TA
HRLI W1,^D9
TLO W1,GWLIT
MOVEM W1,ARG1
MOVEM W2,ARG1+1
JRST PA21.
INTER. PA219.
PA219.: MOVE TA,[XWD NAMWRD,NAMWRD+1]
SETZM NAMWRD
BLT TA,NAMWRD+4
MOVE TA,[XWD [SIXBIT /:GENERATED:SECTION:NAME:/],NAMWRD]
BLT TA,NAMWRD+3
SETZM PRIOR
MOVSI W1,GWNOT
PUSHJ PP,PA2.
PUSHJ PP,PCA3A ; [271] SET UP SECTION NAME
MOVE TA,CURPRO ;GET PTR TO PROTAB ENTRY
SETZ TB, ;CLEAR DEFINED FLAG SO THIS WONT BE
DPB TB,PR.DEF ; ON LISTING
PA219X: MOVE TA,[XWD NAMWRD,NAMWRD+1] ; [271] NEW LABEL
SETZM NAMWRD
BLT TA,NAMWRD+4
MOVE TA,[XWD [SIXBIT /:GENERATED:PARAGRAPH:NAME:/],NAMWRD]
BLT TA,NAMWRD+4
MOVSI W1,GWNOT
PUSHJ PP,PA2.
PUSHJ PP,PCA2.
MOVE TA,CURPRO ;GET PTR TO PROTAB ENTRY
SETZB TB,PROGST ;CLEAR DEFINED FLAG ANDDON'T COUNT AS REAL PRO NAMES
DPB TB,PR.DEF
POPJ PP,
;THIS ACTION IS SO THAT THE STARTING ADDRESS "PROGST" DOESN'T GET
;RESET IN A DBMS PROGRAM, AFTER THE DECLARATIVES.
INTER. PA219A
PA219A: MOVE TA,PROGST ;SAVE STARTING ADDRESS
PUSH PP,TA ;SAVE ON STACK
PUSHJ PP,PA219. ;DO THE NORMAL STUFF
POP PP,TA
MOVEM TA,PROGST ;RESET IT (MAY BE ZERO)
HRRZ TA,CURPRO ; [327] GET GENERATED PARA PROTAB POINER
SETO TB, ; [327] TURN ON THE
DPB TB,PR.MDF ; [327] MULTI-DEFINED BIT- NOTE DEFINED BIT OFF
; [327] THIS TELLS PARGEN IN XFRGEN IN PHASE E THIS IS A GENERATED PARA
POPJ PP,
INTER. PA220.
PA220.: MOVE TA,[XWD ARG3,ARG1]
BLT TA,ARG1+1
POPJ PP,
INTER. PA222.
PA222.: MOVEI TA,120 ;'RELEASE' OP CODE
JRST SETOP1
INTER. PA223.
PA223.: MOVEI TA,121 ;'RETURN' OP CODE
JRST SETOP1
INTER. PA224.
PA224.: MOVE TA,FL.OEN## ;'OBJECT OF ENTER'
JRST FLENT.
SUBTTL REPORT WRITER SYNTAX
IFN RPW,<
;"GENERATE"
INTER. PA225.
PA225.: HRRZI TA,124 ;GENERATE OP CODE
JRST SETOP1
;"GENERATE <REPORT-ITEM-NAME>"
INTER. PA226.
PA226.: MOVEM W1,ARG1 ;GET READY TO PUTGEN THIS ITEM
MOVEM W2,ARG1+1 ; . .
PUSHJ PP,DA96.D ;CONVERT QUALIFIERS TO A DATAB LINK
HRRZI TA,(TE) ;CONVERT DATAB LINK TO RPWTAB LINK
HRRZI TB,(TE)
TRZ TB,077777
CAIE TB,100000
JRST PA226E
PUSHJ PP,LNKSET
LDB TB,DA.RPW##
HRRZ TA,RPWLOC##
ADDI TA,(TB)
LDB TC,RW.TYP##
CAIE TC,%RG.DE
JRST PA226E
HRRM TB,ARG1 ;OK, STORE REAL DATAB LINK
MOVE W1,ARG1
MOVE W2,ARG1+1 ;READY TO CALL PA2.
SKPNAM
;"GENERATE <REPORT-NAME>"
INTER. PA227.
PA227.: PUSHJ PP,PA2.
PUSHJ PP,PA21.
PUSHJ PP,PA22.
JRST PA0.
PA226E: EWARNW E.361 ;NOT A TYPE DETAIL ITEM
JRST PA0. ;POP UP TO HIGHER NODE
;STILL IN RPW
;"INITIATE"
INTER. PA228.
PA228.: HRRZI TA,123 ;INITIATE OP CODE
JRST SETOP1
;"INITIATE/TERMINATE <REPORT-NAME>"
INTER. PA229.
PA229.: PUSHJ PP,PA2.
PUSHJ PP,PA21.
JRST PA160.
;"TERMINATE"
INTER. PA230.
PA230.: HRRZI TA,125 ;TERMINATE OP CODE
JRST SETOP1
>;END IFN RPW
;"WITH NO ADVANCING" CLAUSE FOR "DISPLAY" VERB
INTER. PA231.
PA231.: SETO TA,
DPB TA,OP.DNA## ;SET NO ADVANCING BIT
POPJ PP,
;"WITH DELETE" CLAUSE FOR CLOSE
INTER. PA232.
PA232.: SETO TA,
DPB TA,OP.WDL## ;SET "DELETE" BIT
POPJ PP,
;"USE BEFORE REPORTING" STATEMENT
IFN RPW,<
INTER. PA233.
PA233.: PUSHJ PP,DA96.D ;GET REPORT GROUP NAME WITH QUALIFIER
HRRZ TA,DATLOC## ;MAKE PTR TO ITEM
ADDI TA,(TE)
SUBI TA,<CD.DAT>B20
LDB TB,DA.RPW ;GET CORRESP. RPWTAB LINK
JUMPE TB,JCE267 ;?MUST BE A REPORT GROUP
LDB TC,DA.LVL
SOJN TC,JCE267
HRRZ TA,RPWLOC ;MAKE PTR TO RPWTAB ENTRY
ADDI TA,(TB)
MOVEM TA,CURRPW## ;SAVE IT
PUSHJ PP,GETTAG ;GET TAG FOR USE PROCEDURE
HRRZ TA,CURRPW ;STORE TAG IN RPWTAB
DPB CH,RW.USE##
JRST PRFSUB## ;OUTPUT PRF. UUO TO AS2FILE
JCE267: EWARNJ E.267
>
;PLUS SIGN FOLLOWS SUBSCRIPT IDENTIFIER
INTER. PA234.
PA234.: MOVE TA,NSBSC1 ;MAKE INDEX TO SUBSCRIPT TABLE
ASH TA,2
MOVSI TB,400000 ;CLR BIT 0 OF 1ST WORD OF ENTRY
ANDCAM TB,SBSCR1-4(TA) ; TO INDICATE PLUS
POPJ PP,
;MINUS SIGN FOLLOWS SUBSCRIPT IDENTIFIER
INTER. PA235.
PA235.: MOVE TA,NSBSC1
ASH TA,2
MOVSI TB,400000 ;SET BIT 0 OF 1ST WORD OF ENTRY
IORM TB,SBSCR1-4(TA) ; TO INDICATE MINUS
POPJ PP,
;INTEGER TO BE ADDED TO SUBSCRIPT
INTER. PA236.
PA236.: PUSHJ PP,PA2. ;PROCESS LITERAL
MOVE TA,NSBSC1 ;MAKE INDEX TO SUBSCRIPT TABLE
ASH TA,2
MOVE TB,ARG1 ;STORE WORDS FOR ADDITIVE
MOVEM TB,SBSCR1-2(TA)
MOVE TB,ARG1+1
MOVEM TB,SBSCR1-1(TA)
POPJ PP,
;SET UP TRACE OPERATOR
INTER. PA237.
PA237.: HRRZI TA,126 ;"TRACE" OP CODE
SKIPE PRODSW## ;/P ON?
HRRZI TA,105 ;YES, GENERATE A YECCH INSTEAD
JRST SETOP1
INTER. PA238.
PA238.:
IFN DEBUG,<SETOM TRACFL##> ;TURN ON SYNTAX SCAN TRACE (PROVIDED /TP ON)
SKIPE PRODSW ;/P ON?
POPJ PP, ;YES
SETO TA, ;'ON' FLAG
PA238A: DPB TA,OP.TRC##
POPJ PP,
INTER. PA239.
PA239.:
IFN DEBUG,<SETZM TRACFL> ;TURN OFF SYNTAX SCAN TRACE
SKIPE PRODSW ;/P ON?
POPJ PP, ;YES
SETZ TA, ;'OFF' FLAG
JRST PA238A
IFN SERCH,<
;SET UP SEARCH OPERATOR
INTER. PA240.
PA240.: PUSHJ PP,GETTAG ;GET TAG FOR END OF WHENS
ANDI CH,077777
JUMPE CH,PA240. ;[511] %0 NOT ALLOWED
AOS TA,SPFLVL ;[511] GET NESTED LEVEL
ADD TA,IFLVL ;[511] ADD IF NESTED LEVEL
CAILE TA,IF.DEP ;[511] MORE THAN LIMIT?
JRST PA240A ;[511] YES OVERFLOW
HRLZM CH,ARGL2-1(TA) ;[511] SAVE THE TAG FOR LATER
HRLZM CH,CURTAG## ; & SAVE IT (USING CURTAG(LH) FOR SCRATCH)
SETOM SWHEN## ;DIDN'T SEE "." BEFORE "WHEN"
HRRZI TA,OPSEAR## ;SEARCH OP CODE
JRST SETOP
PA240A: EWARNW E.323 ;[511] MORE THAN 12 NESTED IF/SEARCH
JRST PA133. ;[511] GET OUT
;DATA NAME FOR SEARCH & INDEX FOR SEARCH
INTER. PA241.
PA241.: MOVEM W1,ARG1 ;STORE ITEM WORDS
MOVEM W2,ARG1+1
PUSHJ PP,DA96.D ;GET ALL QUALIFIERS
HRRM TE,ARG1
JRST PA21.
;SET SEARCH 'ALL' FLAG
INTER. PA242.
PA242.: SETO TB,
DPB TB,OP.ALL##
POPJ PP,
;SINCR OPERATOR AFTER ALL WHENS DONE
INTER. PA244.
PA244.: HRRZI TA,(TYPE)
ANDI TA,777 ;TYPE LESS A-MARGIN BIT
CAIE TA,PRIOD. ;IF NOT A PERIOD, TURN OFF FLAG THAT PA245.
SWOFF FPERWD ; [413] TURNED ON, BECAUSE WE ARE COMING UP FROM
;AN 'ELSE'
PUSHJ PP,PA37.
PUSHJ PP,PA246. ;OUTPUT SINCR
JRST PA247. ;OUTPUT %ENDWHN TAG
;OUTPUT JUMPTO TAG-FOLLOWING-ALL-WHENS
INTER. PA245.
PA245.: HRRZI TA,(TYPE)
ANDI TA,777 ;TYPE LESS A-MARGIN BIT
CAIN TA,PRIOD. ;IF AT END OF SEARCH STATEMENT
SWON FPERWD ; [413] REGET THE PERIOD
CAIN TA,WHEN. ;DID WE COME HERE ON "WHEN"?
JRST PA245A ;YES--MAKE SURE NO PERIOD FOLLOWED LAST SENTENCE
PA245B: HRRZI TA,OPJUMP##
PUSHJ PP,SETOP
HLLZ TB,CURTAG
HLLM TB,OPRTR+1
SWOFF UNCONT; ;INCASE "GOTO" OR "STOP RUN" IN SEARCH
JRST PA22. ;GO OUTPUT JUMP OPERATOR
PA245A: SKIPE SWHEN## ;SKIP IF SOMETHING OTHER THAN 'WHEN' ENDED
; LAST SENTENCE
JRST PA245B ;NO, ALL OK
MOVE LN,PERLN ;GET LN & CP
MOVE CP,PERCP ; OF LAST PERIOD
MOVEI DW,E.621 ;"PERIOD IGNORED"
PUSHJ PP,WARN
JRST PA245B ;RESUME PROCESSING
;OUTPUT SINCR
INTER. PA246.
PA246.: HRRZI TA,OPSINC##
PUSHJ PP,SETOP
JRST PA22.
;OUTPUT %ENDWHN TAG
INTER. PA247.
PA247.: MOVE TA,SPFLVL ;[511] GET SEARCH LEVEL
ADD TA,IFLVL ;[511] ADD IF LEVEL FOR INDEX
HLRZ CH,ARGL2-1(TA) ;[511] RETRIEVE TAG
HLLM CH,ARGL2-1(TA) ;[511] REMOVE ENTRY
SOS SPFLVL ;[511] SUBTRACT 1 LEVEL
SWOFF UNCONT ;[460] SEARCH IS NOT UNCOND. GO TO
JRST PA139X
>
;CALL
INTER. PA248.
PA248.: PUSHJ PP,PA169. ;SET 'ENTER' OP CODE
;**; AT PA248.+1
PA248A: ; NEW LABEL FOR ENTRY FROM PA143A FOR ENTER COBOL [171]
SETO TA,
DPB TA,OP.CAL## ;SET 'CALL' BIT
POPJ PP,
;ENTER FORTRAN
INTER. PA249.
PA249.: SETO TA, ;SET 'FORTRAN' BIT
DPB TA,OP.F10##
POPJ PP,
;CANCEL
INTER. PA250.
PA250.: HRRZI TA,130 ;'CANCEL' OP CODE
JRST SETOP1
;OPERANDS FOR CANCEL
INTER. PA251.
PA251.: PUSHJ PP,PA2. ;SET UP OPERAND
PUSHJ PP,PA172. ;PUT IN EXTAB
HRRZ TA,W1 ;GET EXTAB LINK
PUSHJ PP,LNKSET
PUSHJ PP,PA251S ;PUT OPERAND NAME IN HLDTAB
JRST PA21.
;PUT A NAME IN HLDTAB FOR USE BY PHASE E
PA251S: HRRZM TA,CUREXT## ;SAVE ABS PTR
LDB TB,EX.NAM ;MAKE PTR TO NAME
HRRZ TA,NAMLOC
ADDI TB,1(TA)
HLRZ TD,NAMLOC ; GET SIZE OF NAMTAB TABLE [261]
TRC TD,-1 ; MAKE IT POSITIVE [261]
ADDI TA,(TD) ; GET LAST NAMTAB TABLE ADDRESS [261]
PA251A: CAIGE TA,(TB) ; ARE WE STILL IN NAMTAB [261]
JRST PA251T ; NO- DONE [261]
MOVE TC,(TB) ;GET NAMTAB WORD [261]
TLNE TC,600000 ;BEGINNING OF NEXT ENTRY?
AOBJP TB,PA251A ;NO, COUNT IT
PA251T: ; NEW LABEL [261]
HLRZ TB,TB ;GET NAMWRD COUNT
PUSH PP,TB ;SAVE COUNT
ADDI TB,2 ;SIZE OF HLDTAB ENTRY WANTED
MOVSI TA,CD.HLD ;GET SPACE FOR ENTRY
HRRI TA,(TB)
PUSHJ PP,GETENT
MOVEI TB,100 ;ENTRY TYPE CODE
DPB TB,HL.COD##
POP PP,TB ;COUNT OF EXTRA WORDS
DPB TB,HL.QAL##
PUSH PP,TA ;SAVE HLDTAB LINK
HRRZ TA,CUREXT ;SET UP 'FROM' PTR
LDB TB,EX.NAM##
HRRZ TA,NAMLOC
ADDI TB,(TA)
HRLI TB,(POINT 6,0,35)
HRRZ TA,(PP) ;SET UP 'TO' PTR
ADDI TA,2
HRLI TA,(POINT 6,)
PA251B: ILDB TD,TB
TRNN TD,60 ;2 HI ORDER BITS ZERO?
JRST PA251C ;YES, END OF NAME
CAIN TD,':' ;CONVERT : TO -
MOVEI TD,'-'
IDPB TD,TA
JRST PA251B
PA251C: POP PP,TA ;PUT HLDTAB LINK IN EXTAB
HLRZ TB,TA
HRRZ TA,CUREXT ;GET BACK EXTAB PTR
DPB TB,EX.HLD##
POPJ PP,
;GOBACK
INTER. PA252.
PA252.: SETOM SUBPRG## ;INDICATE THIS IS A SUBPROGRAM
HRRZI TA,37 ;'GOBACK' OP CODE
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.GOB## ;'GOBACK' BIT
POPJ PP,
;EXIT PROGRAM
INTER. PA253.
PA253.: SETOM SUBPRG ;INDICATE THIS IS A SUBPROGRAM
HRRZI TA,37 ;'GOBACK' OP CODE
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.PGM## ;'EXIT PROGRAM' BIT
JRST PA22. ;OUTPUT OPERATOR
;LITERAL FOR SUBPROGRAM NAME - CONVERT TO NORMAL NAME
INTER. PA254.
PA254.: HLRZ TB,W1 ;GET CHAR COUNT
ANDI TB,177
CAILE TB,^D30 ;RESTRICT TO 30 CHARS
MOVEI TB,^D30
MOVE TC,[POINT 7,LITVAL]
MOVE TD,[POINT 6,NAMWRD]
PA254A: SOJL TB,PA254B ;LOOP TO MOVE CHARS
ILDB TE,TC
CAIL TE,141 ;CONVERT LC TO UC
TRZ TE,40
CAIG TE,"Z" ;CK FOR ILLEGAL CHARS
CAIGE TE,"A"
CAIG TE,"9"
CAIGE TE,"0"
CAIN TE,"-"
CAIA
EWARNJ E.57 ;?ILLEGAL CHAR
SUBI TE,40 ;CONVERT TO SIXBIT
IDPB TE,TD
JRST PA254A
PA254B: HRLZI W1,GWNOT
PUSHJ PP,TRYNAM
POPJ PP, ;NOT FOUND
HLRZ TB,(TA) ;WAS IT A RESERVED WORD?
TRNE TB,GWRESV
EWARNJ E.315 ;YES
SETZ W1,
HLRS TA ; GET NAMTAB RELATIVE LOCATION [246]
DPB TA,[POINT 15,W2,15] ; STORE FOR LATER CHECK AT PA260. [246]
POPJ PP, ;RESUME NORMAL PROCESSING
;OVERFLOW OPTION FOR CALL/ENTER
INTER. PA255.
PA255.: LDB TA,OP.OPC ;USING OPERATOR WAITING?
CAIN TA,46
PUSHJ PP,PA22. ;YES, PUT IT OUT
HRRZI TA,23 ;'SPECIAL IF'
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.OVR## ;'ON OVERFLOW'
PA255A: PUSHJ PP,GETTAG##
ANDI CH,077777
JUMPE CH,PA255A ;%0 NOT ALLOWED
DPB CH,OP.TRG##
AOS TA,SPFLVL
ADD TA,IFLVL
CAILE TA,^D12 ;ARGL2 OVERFLOW?
JRST PA255B ;YES
HRLZM CH,ARGL2-1(TA)
JRST PA22.
PA255B: EWARNW E.323
JRST PA133. ;GIVE UP
;ENTRY
INTER. PA256.
PA256.: SETOM SUBPRG ;INDICATE THIS IS A SUBPROGRAM
PA256A: SWOFF UNCONT ;MAY FOLLOW UNCONDIT GOTO
HRRZI TA,77 ;'ENTRY' OP CODE
JRST SETOP1
;ENTRY-NAME
INTER. PA257.
PA257.: PUSHJ PP,PA2. ;PUT SYMBOL IN NAMTAB
PUSHJ PP,CHKEXT ;CHECK LENGTH
PUSHJ PP,PA172. ;PUT IN EXTAB
HRRZ TA,W1 ;GET LINK TO EXTAB ENTRY
PUSHJ PP,LNKSET
PA257A: SETO TB, ;SET ENTRY BIT
DPB TB,EX.ENT##
PJRST PA251S ;PUT ENTRY NAME IN HLDTAB
;CHECK LENGTH OF EXTERNAL NAME
CHKEXT: SKIPN NAMWRD+1 ;MORE THAN 6 CHARS?
POPJ PP, ;NO
HRRZI DW,E.410 ;[214]
JRST WARN ;YES, ERROR
;SET UP PROCEDURE DIVISION ENTRY
INTER. PA258.
PA258.: PUSHJ PP,PA256A ;'ENTRY' OP CODE
SETO TB, ;SET PROC DIV ENTRY FLAG
DPB TB,OP.PD##
HRR W1,PIDLNK## ;GET LINK TO PROGRAM-ID
MOVEM W1,ARG1 ;SET UP ARGS
MOVEM W2,ARG1+1 ;[631]
HRRZI TA,(W1) ;PUT PROGRAM-NAME IN HLDTAB
PUSHJ PP,LNKSET
PJRST PA251S
;USING CLAUSE FOR PROCEDURE DIVISION HEADER
INTER. PA259.
PA259.: SETOM SUBPRG ;SET SUBPROGRAM FLAG
POPJ PP,
;PROGRAM-NAME FOR CALL & ENTER
INTER. PA260.
PA260.: PUSHJ PP,CHKEXT ;CHECK SIZE OF NAME
PUSHJ PP,PA172. ;SET UP EXTAB ENTRY
LDB TE,OP.CAL ;IS THIS A CALL?
JUMPE TE,CPOPJ ;NO
HRRZ TA,W1 ;YES, GET EXTAB LINK
PUSHJ PP,LNKSET
SETO TE, ;SET "REFERENCED-BY-CALL" BIT
DPB TE,EX.CAL##
POPJ PP,
;OUTPUT TAG IF NO INITIAL SECTION OR PARA NAME
INTER. PA261.
PA261.: SKIPE PROGST## ;STORED ALREADY?
JRST PA24. ;YES
PUSHJ PP,GETTAG ;NO, GET A TAG FOR IT
HRRM CH,PROGST ;REMEMBER FOR START CODE IN COBOLG
HRRZ TA,CH
PUSHJ PP,REFTAG## ;IT WILL BE REFERENCED IN PHASE G
ANDI CH,077777 ;OUTPUT TAG
HRLI TB,(CH)
HRRI TB,102 ;TAG OP CODE
HRLZI TA,102000
PUSHJ PP,PUTGEN
JRST PA24.
;ENTRY IS ALREADY IN EXTAB
INTER. PA262.
PA262.: PUSHJ PP,PA2.
HRRZ TA,W1 ;GET LINK TO EXTAB ENTRY
PUSHJ PP,LNKSET
LDB TB,EX.ENT ;GET ENTRY DEFN BITS
JUMPE TB,PA257A ;REF'D BY A CALL -- LET PHASE E FLAG IT
EWARNW E.397 ;?DUPLICATE ENTRY DEFN
HRRZI TA,105 ;"YECCH" OP CODE
JRST SETOP1
;IMPROPER SUBSCRIPT ERROR
INTER. PA263.
PA263.: MOVEI W1,<CD.DAT>B20+1 ;USE DUMMY DATA ITEM FOR SUBSCRIPT
TLZ W2,777770
MOVEM W1,ARG1 ;NO NEED TO GIVE DIAGNOSTIC BECAUSE
MOVEM W2,ARG1+1 ; PHASE E DOES IT ALREADY
SWOFF FREGWD ;GO ON TO NEXT SOURCE ITEM
HRRZI TA,(W1) ; SET UP DUMMY RELATIVE ADDRESS [262]
PUSHJ PP,LNKSET ; GET DATAB ADR FOR DUMMY [262]
HRRM TA,CURDAT ; STORE IT [262]
HRLM W1,CURDAT ; PUT BACK DATAB RELATIVE ADR [262]
POPJ PP,
;SET DECLARED BY ENTRY OR PD USING CLAUSE BIT IN DATAB
INTER. PA264.
PA264.: HRRZI TA,(W1) ;GET DATAB LINK
PUSHJ PP,LNKSET
PA264A: SETO TB, ;[***]
DPB TB,DA.RBE##
LDB TB,DA.LVL ;[***] GET LEVEL
SOJN TB,CPOPJ ;[***] GIVE UP UNLESS LEVEL 1
LDB TA,DA.BRO## ;[***] DOES IT HAVE A BROTHER
JUMPE TA,CPOPJ ;[***] NO, GIVE UP
PUSHJ PP,LNKSET ;[***] YES, POINT TO IT
LDB TB,DA.RDF ;[***] IS IT A REDEFINES
JUMPN TB,PA264A ;[***] YES, SET BIT IN HERE ALSO
POPJ PP, ;[***]
IFN DBMS,<
;SAVE SET-NAME AS A LITERAL FOR 'IF SET-NAME SET [NOT] EMPTY' CONDITION
; OR 'IF RECORD [NOT] [MEMBER/OWNER] OF SET-NAME/ANY SET' CONDITION
INTER. PA265.
PA265.: MOVEI TC,^D30 ;CHAR CTR
MOVE TB,[POINT 6,NAMWRD]
PA265A: ILDB TD,TB
SKIPE TD ;END OF WORD?
SOJG TC,PA265A ;LOOKED AT ALL 30 CHARS?
MOVEI TB,^D30 ;GET POS CHAR COUNT
SUBI TB,(TC)
PUSH PP,TB ;SAVE CHAR COUNT
HRRZI TB,5(TB) ;[273][535]CONVERT TO ASCII WORDS
IDIVI TB,5
HRRZI TA,(TB) ;GET VALTAB ENTRY OF THAT SIZE
HRLI TA,CD.VAL
PUSHJ PP,GETENT
HLR W1,TA ;SAVE OPERAND
TLO W1,GWLIT ;SET LITERAL FLAG
;[353] HRRZS W2 ;CLR LEFT HALF OF W2
TLZ W2,777774 ;[353] CLEAR ALL BUT LINE AND CHAR POSITION.
MOVEM W1,ARG1
MOVEM W2,ARG1+1
MOVE TC,[POINT 6,NAMWRD] ;FROM PTR
MOVE TD,[POINT 7,(TA),6] ;TO PTR
POP PP,TB ;PUT BYTE COUNT IN ENTRY
DPB TB,TD
PA265B: ILDB TE,TC
ADDI TE,40 ;MAKE ASCII
CAIN TE,":" ;CONVERT GETITM'S COLON TO DASH
MOVEI TE,"-"
IDPB TE,TD
SOJG TB,PA265B ;DONE ALL YET?
POPJ PP,
;STILL IN IFN DBMS
;SET UP IFDB OPERATOR FOR 'IF SET-NAME SET [NOT] EMPTY'
INTER. PA266.
PA266.: PUSHJ PP,PA21. ;SET UP OPERAND
MOVE TE,OP.EMP## ;GET SET EMPTY CONDITION FLAG
PA266A: SETZM OPRTR+1
HRRZI TA,131 ;IFDB OPERATOR
JRST P183.C
;ERROR: 'IF <USER-NAME>' NOT FOLLOWED BY 'SET'
INTER. PA267.
PA267.: LDB LN,[POINT 13,ARG1+1,28]
LDB CP,[POINT 7,ARG1+1,35]
HRRZI DW,E.104 ; [314] UNDEFINED
JRST FATAL
;STILL IN IFN DBMS
;SAVE OPRTR FLAG FOR 'IF RECORD *MEMBER* OF SET-NAME SET'
INTER. PA268.
PA268.: MOVE TE,OP.MEM##
PA268A: MOVEM TE,TBLOCK
POPJ PP,
;SAVE OPRTR FLAG FOR 'IF RECORD *OWNER* OF SET-NAME/ANY SET'
INTER. PA269.
PA269.: MOVE TE,OP.OWN##
JRST PA268A
;SAVE OPRTR FLAG FOR 'IF RECORD <<OWNER OR MEMBER>> OF SET-NAME/ANY SET'
INTER. PA270.
PA270.: MOVE TE,OP.MOO##
JRST PA268A
;SET UP OPERATOR FOR 'IF RECORD [MEMBER/OWNER] OF SET-NAME/ANY SET'
INTER. PA271.
PA271.: PUSHJ PP,PA21. ;SET UP OPERAND
MOVE TE,TBLOCK ;GET PTR TO FLAG BIT
JRST PA266A
;STILL IN IFN DBMS
;SET UP USETAB ENTRY FOR 'USE IF ERROR-STATUS'
INTER. PA272.
PA272.: MOVE TB,['ERROR:'] ;CK FOR ERROR-STATUS DATA-NAME
CAME TB,NAMWRD
JRST PA272E ;NO
MOVE TB,['STATUS']
CAME TB,NAMWRD+1
JRST PA272E ;NO
SKIPE NAMWRD+2
JRST PA272E ;NO
MOVE TA,[CD.USE,,SZ.USE] ;GET ROOM FOR NEW ENTRY
PUSHJ PP,GETENT
MOVEI TB,%UT.ES ;SET ERROR-STATUS FLAG
DPB TB,US.TYP##
HLRZ TB,CURPRO ;LINK USE TO CURRENT SECTION
DPB TB,US.PRO##
HLRZM TA,CURUSE## ;REMEMBER REL ADDR OF USETAB ENTRY
POPJ PP,
INTER. PA272E
PA272E: EWARNW E.405 ;?ERROR-STATUS EXPECTED
SWOFF FREGWD ;SKIP TO NEXT SOURCE ITEM
HRRZI NODE,PD1127## ;RETURN TO ERROR NODE IN TREE
HRRZM NODE,(NODPTR)
POPJ PP,
;STILL IN IFN DBMS
;SCAN USETAB FOR ERROR-STATUS ENTRIES WITH SELECTED CODES
; WHICH WOULD MEAN AN ILLEGAL COMBINATION OR ERROR-STATUS USE-PROCS
;
;CTR=0 IMPLIES ANY OTHER ERROR-STATUS ENTRY IS AN ERROR
;CTR NOT = 0 IMPLIES ANY ENTRY WITH CODE=CTR IS AN ERROR
; AND ANY ENTRY WITH CODE -1 (GENERAL PURPOSE ENTRY) IS AN ERROR
;SKIP RETURN IF NO ERROR
PA272S: HRRZ TA,USELOC## ;INIT SCAN OF USETAB ERROR-STATUS ENTRIES
ADDI TA,1
HRRZ TB,USELOC ;STOP WHEN ENTRY BEFORE CURRENT HAS BEEN CHECKED
ADD TB,CURUSE
PA272A: CAIL TA,(TB) ;CHECKED ALL?
JRST CPOPJ1 ;YES, NO ERRORS
LDB TC,US.TYP## ;THIS AN ERROR-STATUS ENTRY?
CAIE TC,%UT.ES
JRST PA272B ;NO
LDB TC,US.XTR## ;EXTRA WORDS ALLOCATED FOR THIS ENTRY?
JUMPE TC,PA272B ;NO (MUST HAVE BEEN LEFT BY AN ERROR)
SKIPN CTR ;WHICH TYPE OF CHECK ARE WE DOING?
EWARNJ E.406 ;ANY OTHER ENTRY IS AN ERROR
LDB TC,US.CNT ;GET EXTRA WORDS COUNT
MOVE TD,[POINT 18,1(TA),17] ;SET PTR TO GET ERROR CODES
PA272D: ILDB TE,TD ;GET NEXT ERROR CODE FROM ENTRY
JUMPE TE,PA272B ;NO MORE
CAIE TE,-1 ;-1 OR CTR IS AN ERROR
CAMN TE,CTR
EWARNJ E.406
SOJG TC,PA272D ;CK WORD COUNT
PA272B: LDB TC,US.XTR ;ADVANCE TO NEXT ENTRY
JUMPE TC,PA272C ;NO EXTRA WORDS IN THIS ENTRY
LDB TC,US.CNT## ;GET # OF EXTRA WORDS
ADDI TA,(TC)
PA272C: AOJA TA,PA272A ;TRY NEXT ENTRY
;STILL IN IFN DBMS
;STORE GIVEN ERROR-STATUS CODE IN USETAB ENTRY
INTER. PA273.
PA273.: HLRZ TB,W1 ;GET THE VALUE OF THE INTEGER
ANDI TB,177
MOVEM TB,CTR
HRRZI TA,LITVAL
PUSHJ PP,GETVAL
MOVEM TC,CTR ;SAVE VALUE FOR LATER STORAGE
PUSHJ PP,PA272S ;SCAN USETAB FOR SAME CODE OR GEN-PURP CODE
POPJ PP, ;ERROR RETURN
PA273A: HRRZ TA,USELOC ;GET PTR TO CURRENT USETAB ENTRY
ADD TA,CURUSE
LDB TB,US.XTR ;ANY EXTRA WORDS ALREADY ALLOCATED?
JUMPN TB,PA273F ;YES
MOVE TA,[CD.USE,,SZ.USE] ;GET ROOM FOR 1ST EXTRA WORD
PUSHJ PP,GETENT
HRRZ TA,USELOC ;GET BACK PTR TO CURRENT USETAB ENTRY
ADD TA,CURUSE
SETO TB, ;SET EXTRA WORD FLAG
DPB TB,US.XTR
MOVEI TB,1 ;SET EXTRA WORD COUNT IN ENTRY
DPB TB,US.CNT
AOJA TA,PA273H ;BUMP PTR UP TO EXTRA WORD
PA273F: LDB TC,US.CNT ;GET # OF EXTRA WORDS
MOVEI TC,1(TC) ;BUMP WORD COUNT IN ENTRY
DPB TC,US.CNT
TRNE TC,1 ;HOW MANY CODES STORED ALREADY?
JRST PA273G ;ODD #
MOVE TA,[CD.USE,,SZ.USE] ;GET ANOTHER WORD
PUSHJ PP,GETENT
MOVE TC,CTR ;STORE NEW CODE IN LEFT HALF OF NEW WORD
HRLZM TC,(TA)
POPJ PP,
PA273G: LSH TC,-1 ;MAKE PTR TO LAST EXTRA WORD
ADDI TA,1(TC)
PA273H: MOVE TC,CTR ;STORE NEW WORD IN RIGHT HF OF WORD
HRRM TC,(TA)
POPJ PP,
;STILL IN IFN DBMS
;STORE CODE FOR GENERAL PURPOSE 'USE IF ERROR-STATUS' ENTRY
INTER. PA274.
PA274.:
;;; JUST FORBID A PRIOR "USE" OF SAME FORM
MOVEI TC,-1 ;STORE GENERAL PURPOSE CODE IN ENTRY
MOVEM TC,CTR
PUSHJ PP,PA272S ;SCAN USETAB FOR OTHER E-S ENTRIES
POPJ PP, ;ERROR RETURN
JRST PA273A
;PROCESS "CLOSE ALL" DBMS COMMAND
INTER. PA275.
PA275.: PUSHJ PP,PA276.
SKPNAM
INTER. PA277.
PA277.:
IFN DBMS4,<MOVSI W1,5!GWLIT!GWNLIT>
PA277A:
MOVE TA,[POINT 6,NAMWRD] ;GET PTR TO USER-NAME
PUSHJ PP,FIXLIT ;FIX IT LIKE A LITERAL
PUSHJ PP,PA2. ;SET UP OPERAND
JRST PA21. ;OUTPUT OPERAND
FIXLIT: MOVE TB,[POINT 7,LITVAL]
SETZ TD, ;CLEAR CHAR COUNT
FIX2: ILDB TC,TA ;GET CHAR
CAIL TD,^D30 ;WOULD THIS CHAR BE OUT-OF-BOUNDS?
SETZM TC ;YES, SO FAKE TERM-CHAR
CAIN TC,':' ;CONVERT ALL ":" BACK TO "-"
MOVEI TC,'-'
SKIPE TC ;DON'T CONVERT IF ZERO
ADDI TC,40 ;CONVERT TO ASCII
IDPB TC,TB ;DEPOSIT IT IN LITVAL
JUMPE TC,FIX3
AOJA TD,FIX2 ;BUMP COUNTER
FIX3:
IFN DBMS4,<JUMPN W1,FIXNMID>
HRLZ W1,TD ;MOVE COUNT IN W1
TLO W1,1B19 ;SET BIT 1
POPJ PP,
IFN DBMS4,<
FIXNMID:
SM.NMID==SM.USR##+1
MOVEI TA,[-2,,0
SYMTAB##
17B12+LITVAL]+1
;;; 0/1 USED BY SUBROUT
SKIPN SYMTAB ;INVOKE STAT MESSED UP?
JRST FIXNM1 ;YES
PUSH PP,0
PUSH PP,1
PUSHJ PP,FNDSYM##
MOVE TA,0 ;FIND A SYMBOL
POP PP,1
POP PP,0
JUMPN TA,FIXNM2
FIXNM1: EWARNW E.588 ;NO BAD
SKIPA TB,[ASCII/00000/] ;FUDGE IT
FIXNM2: MOVE TB,SM.NMID(TA)
MOVEM TB,LITVAL
POPJ PP,
> ;END IFN DBMS4
INTER. PA276.
PA276.: MOVEI W1,%CLOSE## ;SET UP "CLOSD" ADDRESS
SKPNAM
INTER. PA278.
PA278.: PUSHJ PP,PA169. ;SET UP ENTER OPRTR
PUSHJ PP,PA141. ;...AND MACRO BIT
PUSHJ PP,PA2. ;CONSTRUCT ARG1,ARG1+1
JRST PA217. ;OUTPUT THEM
INTER. PA279.
PA279.: MOVEI W1,%STORE## ;GET STORE EXTAB OFFSET
PUSHJ PP,PA278.
JRST PA277.
;SET UP "INSERT" REFERENCE.
INTER. PA280.
PA280.: MOVEI W1,%INSRT##
JRST PA278.
;MODIFY <REC-NAME>.
INTER. PA281.
PA281.: MOVEI W1,%MODIF##
JRST PA278.
;SET UP REFERENCE TO "GETS"
INTER. PA282.
PA282.: MOVEI W1,%GETS##
JRST PA278.
;OUTPUT OPERAND REFERENCE TO DBMS-NULL.
INTER. PA283.
PA283.:
IFE DBMS4,<
MOVE TA,[SIXBIT /DBMS:N/]
MOVEM TA,NAMWRD
MOVSI TA,'ULL'
MOVEM TA,NAMWRD+1
SETZM NAMWRD+2 ;[%336] CLEAR FOR PROPER MATCH
SETZM NAMWRD+3 ;[%336] GET IT ALL
SETZM NAMWRD+4 ;[%336]
PUSHJ PP,TRYNAM ;GET NAMTAB ADDRESS
PUSHJ PP,BLDNAM ;PUT IN TABLE IF NOT THERE
HLRZ TA,TA ;SWITCH HALVES
DPB TA,[POINT 15,W2,15]
SETZM TBLOCK
SETZM TBLOCK+1
SETZM TBLOCK+2
SETZM TBLOCK+3
SETZM TBLOCK+5
SETZM TBLOCK+6
MOVEM W2,TBLOCK+4 ;SET UP ARGS
PUSHJ PP,FINDAT ;GET DATAB ADDRESS
SKIPE DW ;SKIP IF IN DATAB
MOVEI TE,1 ;USE NULL DATAB ENTRY
HRRZ W1,TE ;PUT TABLE LINK IN W1
TRO W1,1B20 ;SET BIT TO INDICATE DATAB
>
IFN DBMS4,<
MOVE TB,[ASCII/00000/] ;PASS 0 CAUSE SIMPLER & NO ARG PASSING PROB
MOVEM TB,LITVAL
MOVSI W1,5!GWLIT!GWNLIT
>
PUSHJ PP,PA2. ;SET UP ARG1
JRST PA21. ;OUTPUT OPERAND
;REMOVE VERB
INTER. PA284.
PA284.: MOVEI W1,%REMOV##
JRST PA278.
;STILL IN IFN DBMS
;ACTIONS FOR "DELETE" VERB.
SAVEPP: POP PP,TE ;GET RETURN ADDRESS
PUSH PP,W1
PUSH PP,W2
PUSH PP,CT
PUSH PP,NAMWRD
PUSH PP,NAMWRD+1
PUSH PP,NAMWRD+2
PUSH PP,NAMWRD+3
PUSH PP,NAMWRD+4
JRST (TE)
GETPP: POP PP,TE
POP PP,NAMWRD+4
POP PP,NAMWRD+3
POP PP,NAMWRD+2
POP PP,NAMWRD+1
POP PP,NAMWRD
POP PP,CT
POP PP,W2
POP PP,W1
JRST (TE)
INTER. PA285.
PA285.: PUSHJ PP,SAVEPP
MOVEI W1,%DELET##
PUSHJ PP,PA278.
PUSHJ PP,PA283. ;OUTPUT DBMS-NULL
PUSHJ PP,GETPP
JRST PA277.
;PROCESS THE STATEMENT: DELETE.
INTER. PA285A
PA285A: MOVEI W1,%DELET
PUSHJ PP,PA278.
PUSHJ PP,PA283.
JRST PA283.
INTER. PA286.
PA286.: PUSHJ PP,SAVEPP
PUSHJ PP,GETEM. ;GET <REC-NAME> BACK AGAIN
PUSHJ PP,PA2. ;OUTPUT IT
PUSHJ PP,PA171.
PUSHJ PP,GETPP
PUSHJ PP,PA170. ;NOW, WE ARE LOOKING AT "INVALID"
PUSHJ PP,PA216.
PUSHJ PP,PA22.
JRST PA90.
INTER. PA287.
PA287.: MOVEI W1,%DELET
PUSHJ PP,PA278.
PUSHJ PP,GETEM. ;GET <REC-NAME> BACK
PUSHJ PP,PA277. ;OUTPUT AS LITERAL
JRST PA283. ;OUTPUT DBMS-NULL.
INTER. PA288.
PA288.: PUSHJ PP,SAVEPP
MOVEI W1,%DELET
PUSHJ PP,PA278.
PUSHJ PP,GETEM. ;GET <REC-NAME>
PUSHJ PP,PA277.
PUSHJ PP,GETPP
JRST PA277.
INTER. PA288A; ;'DELETE <REC-NAME> OF ...'
PA288A: PUSHJ PP, SAVEPP
PUSHJ PP, GETEM.
PUSHJ PP, PA2.
PUSHJ PP, PA171.
PUSHJ PP, GETPP
POPJ PP,
;STILL IN IFN DBMS
;THESE SUBROUTINES ARE DESIGNED TO PRESERVE THE VITAL
;INFORMATION ABOUT THE CURRENT ITEM BEING SCANNED. THIS INFO CAN
;THEN BE RESTORED LATER AS IF THE SCANNER WAS RETURNING TO THE
;PREVIOUS WORD.
INTER. SAVEM.
SAVEM.: PUSH SAVPTR,W1
PUSH SAVPTR,W2
PUSH SAVPTR,CT
PUSH SAVPTR,NAMWRD
PUSH SAVPTR,NAMWRD+1
PUSH SAVPTR,NAMWRD+2
PUSH SAVPTR,NAMWRD+3
PUSH SAVPTR,NAMWRD+4
POPJ PP,
INTER. GETEM.
GETEM.: POP SAVPTR,NAMWRD+4
POP SAVPTR,NAMWRD+3
POP SAVPTR,NAMWRD+2
POP SAVPTR,NAMWRD+1
POP SAVPTR,NAMWRD
POP SAVPTR,CT
POP SAVPTR,W2
POP SAVPTR,W1
POPJ PP,
;STILL IN IFN DBMS
;SET UP "MOVE" EXTERNAL REFERENCE.
INTER. PA289.
PA289.: MOVEI W1,%MOVEC##
JRST PA278.
;OUTPUT DBMS-NULL, AND "RUN-UNIT".
INTER. PA290.
PA290.: PUSHJ PP,SAVEM. ;SAVE "RUN-UNIT"
PUSHJ PP,PA283. ;OUTPUT DBMS-NULL
PUSHJ PP,GETEM.
MOVEI TA,15 ;15=SIXBIT /-/
DPB TA,[POINT 6,NAMWRD,23]
JRST PA277. ;NOW, PUT OUT "RUN-UNIT".
;STILL IN IFN DBMS
;ACTIONS FOR "FIND" VERB AND RSE.
INTER. PA291.
PA291.: PUSHJ PP,PA292.
JRST PA283.
INTER. PA292.
PA292.: MOVEI W1,%FIND2##
JRST PA278.
INTER. PA293.
PA293.: MOVEI W1,%FIND4##
JRST PA278.
INTER. PA294.
PA294.: PUSHJ PP,PA292.
PUSHJ PP,GETEM. ;GET <REC-NAME> BACK AGAIN
JRST PA277. ;PUT IT OUT.
;FIND OWNER <SET-NAME>.
INTER. PA295.
PA295.: PUSHJ PP,PA293.
PUSHJ PP,GETEM.
JRST PA277.
INTER. PA296.
PA296.: PUSHJ PP,SAVEM.
PUSHJ PP,PA297.
PUSHJ PP,GETEM.
JRST PA277.
INTER. PA297.
PA297.: MOVEI W1,%FIND3##
JRST PA278.
IFN DBMS4,< ;NOT TRULY NECES SINCE REF ONLY BY NEW CODE
INTER. PA297A
PA297A: MOVEI W1,%FINDO## ;FIND OFFSET GETS SPECIAL PATH FOR V4
JRST PA278.
> ;END IFN DBMS4
INTER. PA298.
PA298.: PUSHJ PP,SAVEM.
IFE DBMS4,<PUSHJ PP,PA297.>
IFN DBMS4,<PUSHJ PP,PA297A>
PUSHJ PP,GETEM.
JRST PCA5. ;OUTPUT INTEGER
INTER. PA299.
PA299.: PUSHJ PP,SAVEM. ;COME HERE ON "DUPLICATE"
PUSHJ PP,PA300.
PUSHJ PP,GETEM.
SETZ TA,
DPB TA,[POINT 6,NAMWRD,23] ;TRUNCATE TO "DUP"
JRST PA277.
INTER. PA300.
PA300.: MOVEI W1,%FIND5##
JRST PA278.
INTER. PA301.
PA301.: MOVEI W1,%FIND1##
JRST PA278.
INTER. PA302.
PA302.: PUSHJ PP,PA301.
PUSHJ PP,GETEM.
JRST PA277.
INTER. PA303.
PA303.: PUSHJ PP,PA300.
PUSHJ PP,PA283.
PUSHJ PP,GETEM.
JRST PA277.
INTER. PA304.
PA304.:
IFE DBMS4,<PUSHJ PP,PA297.>
IFN DBMS4,<PUSHJ PP,PA297A>
PUSHJ PP,GETEM.
PUSHJ PP,PA2. ;[675] MAKE SURE ITS IN NAMTAB
HRRZ TA,ARG1 ;[675] GET TABLE ENTRY
JUMPE TA,PA304A ;[675] INCASE OF ERROR
PUSHJ PP,LNKSET ;[675] SET UP POINTER TO DATAB
LDB TD,DA.CLA## ;[675] GET CLASS OF DATAB
LDB TE,DA.NDP## ;[675] GET NUMBER OF DECIMAL PLACES
CAIN TD,%CL.NU ;[675] MUST BE NUMERIC
JUMPE TE,PA304A ;[675] AND HAVE NO DECIMAL PLACES
HRRZI DW,E.264 ;[675] NO, ERROR
LDB CP,[POINT 7,ARG1+1,35] ;[675]
LDB LN,[POINT 13,ARG1+1,28] ;[675]
PUSHJ PP,FATAL ;[675]
PA304A: PUSHJ PP,PA21. ;[675]
JRST PA283.
INTER. PA305.
PA305.: PUSHJ PP,SAVEPP
PUSHJ PP,PA304. ;OUTPUT <REC>, NULL.
PUSHJ PP,GETPP
JRST PA277.
INTER. PA306.
PA306.: PUSHJ PP,SAVEPP
IFE DBMS4,<PUSHJ PP,PA297.>
IFN DBMS4,<PUSHJ PP,PA297A>
PUSHJ PP,GETEM.
PUSHJ PP,PCA5.
PUSHJ PP,GETPP
JRST PA277.
INTER. PA307.
PA307.: PUSHJ PP,SAVEPP
PUSHJ PP,PA297.
PUSHJ PP,GETEM.
PUSHJ PP,PA277.
PUSHJ PP,GETPP
JRST PA277.
INTER. PA308.
PA308.: PUSHJ PP,PA297.
PUSHJ PP,GETEM.
PUSHJ PP,PA277.
JRST PA283.
INTER. PA309.
PA309.: PUSHJ PP,PA299. ;OUTPUT "DUP"
JRST GETEM. ;POP GARBAGE OFF STACK
INTER. PA310.
PA310.: PUSHJ PP,PA301.
JRST PA283.
;STILL IN IFN DBMS
;ACTIONS FOR "OPEN" VERB.
INTER. PA311.
PA311.: SETZM BUFCTR##
MOVEI W1,%OPEND##
JRST PA278.
INTER. PA312.
PA312.: MOVE TA,BUFCTR ;GFET # OF ENTRIES
CAIL TA,^D10 ;IS TABLE FULL?
EWARNJ E.428 ;YES, GIVE ERROR AND IGNORE NEW ENTRY.
LSH TA,3 ;MULTIPLY BY 8
ADDI TA,BUFFER##-1 ;GET ADDRESS OF NEW ENTRY
PUSH TA,W1
PUSH TA,W2 ;PUSH ALL GOOD STUFF INTO TABLE
PUSH TA,CT
PUSH TA,NAMWRD
PUSH TA,NAMWRD+1
PUSH TA,NAMWRD+2
PUSH TA,NAMWRD+3
PUSH TA,NAMWRD+4
AOS BUFCTR ;BUMP COUNT
POPJ PP,
INTER. PA313.
PA313.: SETZ TA,
DPB TA,[POINT 6,NAMWRD,29]
JRST SAVEM. ;SAVE "EXCLUSIVE"
; *** OPEN VERB NOW COMES HERE IF BOTH ACCESS &SHARE-LEVEL SPEC
INTER. PA314.
PA314.: PUSHJ PP,PA277.
PUSHJ PP,GETEM. ;GET TYPE OF UPDATE
JRST PA277. ;OUTPUT IT
INTER. PA315.
PA315.:
IFE DBMS4,<PUSHJ PP,PA277.>
IFN DBMS4,<
SETZM W1 ;SO FIXLIT WILL KNOW TRUE LIT...I.E. NOT PRESENT
PUSHJ PP,PA277A ;SKIP THE PRESET
>
SKPNAM
INTER. PA316.
PA316.: SETZ TB, ;OUTPUT ALL OPERANDS STORED IN BUFFER
P3161.: MOVE TA,TB ;GET TEMP COUNTER
LSH TA,3 ;MULTIPLY BY 8
ADDI TA,BUFFER-1+^D8 ;POINT TO END OF NEXT ENTRY
HRLI TA,^D10 ;SET UP FAKE PUSH-DOWN COUNT
POP TA,NAMWRD+4
POP TA,NAMWRD+3 ;GET GOOD STUFF
POP TA,NAMWRD+2
POP TA,NAMWRD+1
POP TA,NAMWRD
POP TA,CT
POP TA,W2
POP TA,W1
PUSH PP,TB ;SAVE COUNTER FOR NOW
PUSHJ PP,PA277. ;OUTPUT OPERAND
POP PP,TB
AOS TB ;BUMP COUNTER
CAME TB,BUFCTR ;HAVE WE GOTTEN ALL ENTRIES?
JRST P3161. ;NO
POPJ PP,
; *** OPEN VERB COMES HERE IF JUST ACCESS SPEC
INTER. PA317.
PA317.: PUSHJ PP,PA277.
JRST PA283.
INTER. PA318.
PA318.: MOVE TA,[SIXBIT /RETR/] ;OUTPUT "RETR"
MOVEM TA,NAMWRD
JRST PA277.
INTER. PA319.
PA319.: PUSHJ PP,SAVEM. ;SAVE "ALL"
PUSHJ PP,PA311. ;OUTPUT EXTERNAL REFERENCE
PUSHJ PP,GETEM.
JRST PA312.
INTER. PA320.
PA320.: PUSHJ PP,PA318.
PUSHJ PP,PA283.
PUSHJ PP,PA283.
JRST PA316.
INTER. PA321.
PA321.: PUSHJ PP,PA283. ;OUTPUT NULL
JRST PA22. ;OUTPUT BAD OPERAND
IFN DBMS6,<
INTER. PAOT01
PAOT01: MOVEI W1,%OPENT## ;OPEN A TRANSACTION
JRST PA278.
INTER. PACT01
PACT01: MOVEI W1,%CLOTR## ;CLOSE A TRANSACTION
JRST PA278.
INTER. PADT01
PADT01: MOVEI W1,%DELTR## ;DELETE A TRANSACTION
JRST PA278.
INTER. PAFIN6
PAFIN6: MOVEI W1,%FIND6## ;FIND RSE6
PUSHJ PP,PA278.
PUSHJ PP,GETEM. ;GET BACK THE RECNAME THAT HAS ALREADY BEEN EATEN
JRST PA277. ;PUT IT OUT IN ADDITION TO THE CALL & GO BACK TO PARSE
> ;END IFN DBMS6
>;END IFN DBMS
;COME HERE BEFORE DECLARATIVES TO SEE IF THERE IS
;A DBMS FILE TO BE PROCESSED.
INTER. PA322.
PA322.: SKIPN FINVD## ;IS OUR FLAG SET?
POPJ PP, ;NO, EXIT
IFE DBMS,<
TTCALL 3,[ASCIZ /?FATAL--"FINVD" FLAG IS SET---PA322.
/]
JRST KILL##
>
IFN DBMS,<
SETZM FINVD ;THIS TELLS GETITM TO DELETE FILES
;[%316] DELETE BUMP OF DBCNTC SINCE RCLAIM NO MORE
JRST DBGTF.## ;GO PROCESS 1ST FILE (###DB1.TMP)
>
SUBTTL MCS/TCS SYNTAX
;DISABLE/ENABLE ACTIONS
IFN MCS!TCS,<
INTER. PA323.
PA323.: HRRZI TA,132 ;DISABLE OPERATOR
JRST SETOP
INTER. PA324.
PA324.: PUSHJ PP,PA323. ;SET UP OP CODE
SETO TA,
DPB TA,OP.ENA## ;SET ENABLE BIT
POPJ PP,
INTER. PA325.
PA325.: HRRZ TA,W1 ;CHECK TO MAKE SURE IT'S AN...
ADD TA,CDLOC## ;...INPUT CD!
SKIPGE 1(TA) ;INPUT CD?
EWARNW E.458 ;NO
JRST PA328. ;GO ON
INTER. PA326.
PA326.: SETO TA,
DPB TA,OP.TRM## ;SETE TERMINAL BIT
POPJ PP,
INTER. PA327.
PA327.: SETO TA,
DPB TA,OP.OT2## ;SET OUTPUT
POPJ PP,
INTER. PA329.
PA329.: HRRZI TA,133
PUSHJ PP,SETOP ;SET OP CODE
SKPNAM
INTER. PA328.
PA328.: PUSHJ PP,PA2. ;OUTPUT OPERAND
JRST PA21.
INTER. PA330.
PA330.: HRRZI TA,134 ;SEND OP CODE
JRST SETOP
INTER. PA330A
PA330A: HRRZ TA,W1 ;CHECK FOR OUTPUT CD
ADD TA,CDLOC##
SKIPL 1(TA)
EWARNW E.453 ;ERROR IF INPUT CD
JRST PA328. ;NO, OUTPUT OPERAND
INTER. PA331.
PA331.: MOVSI TA,(ASCIZ /0/) ;OUTPUT "0"
;SUBROUTINE TO OUTPUT A LITERAL NUMERIC
OUTLIT: MOVEM TA,LITVAL
MOVSI W1,1B19+1B23+1 ;SET "LITERAL","NUMERIC LITERAL",LENGTH (ALWAYS 1)
JRST PA328. ;OUTPUT IT
INTER. PA332.
PA332.: HRRZ TA,W1 ;CHECK FOR ALPHANUMERIC
PUSHJ PP,LNKSET ;FIND DATAB ENTRY
LDB TB,DA.CLA ;GET DATA TYPE
IFN TCS,<
CAIE TB,%CL.NU ;TCS WANTS TO ALLOW INTEGERS HERE
JRST PA332A ;NOT NUMERIC, CONTINUE TESTING
LDB TB,DA.USG ;GET USAGE
CAIE TB,%US.1C ;1-WORD COMP?
CAIN TB,%US.IN ;OR INDEX?
JRST PA2. ;YES
TRNA ;NO, GIVE ERROR
PA332A:>
CAIE TB,%CL.AN
EWARNW E.454 ;NOT ALPHANUMERIC
JRST PA2.
INTER. PA333.
PA333.: MOVSI TA,(ASCIZ /1/) ;ESI
JRST OUTLIT
INTER. PA334.
PA334.: MOVSI TA,(ASCIZ /2/) ;EMI
JRST OUTLIT
INTER. PA335.
PA335.: MOVSI TA,(ASCIZ /3/) ;EGI
JRST OUTLIT
IFN MCS,<
INTER. PA336.
PA336.: MOVSI TA,(ASCIZ /4/) ;EPI
JRST OUTLIT
>
INTER. PA337.
PA337.: SETO TA,
DPB TA,OP.AF2## ;SET "AFTER" BIT
POPJ PP,
INTER. PA338.
PA338.: SETO TA,
DPB TA,OP.PAG## ;SET PAGE BIT
JRST PA331.
INTER. PA339.
PA339.: HRRZI TA,135 ;'RECEIV' OP CODE
JRST SETOP
INTER. PA340.
PA340.: SETO TA,
DPB TA,OP.SEG## ;SET SEGMENT BIT
POPJ PP,
INTER. PA341.
PA341.: SETO TA,
DPB TA,OP.NDP## ;SET 'NO DATA PHRASE' BIT
PUSHJ PP,PA22. ;OUTPUT RECEIV OPERATOR
P341A: HRRZI TA,23 ;SPIF OP CODE
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.ATE## ;SET 'AT END' BIT
JRST PA90.A ;OUTPUT SPIF
INTER. PA342.
PA342.: AOS IFMSGF## ;MAKE NEW LEVEL FOR "IF MSG"
HRRZI TA,133 ;'ACCNT' OP CODE
PUSHJ PP,SETOP
SETO TA,
DPB TA,OP.IFM## ;IF MSG BIT
POPJ PP,
INTER. PA343.
PA343.: PUSHJ PP,PA325. ;OUTPUT CD-NAME
PUSHJ PP,PA22. ;AND OPERAND
JRST P341A
>;END OF MCS/TCS ACTIONS
;STRING ACTIONS
IFN STRING,<
;OUTPUT DUMMY DATAB ENTRY FOR MISSING DATA ITEM
INTER. PA360.
PA360.: PUSHJ PP,DE111. ;?IDENTIFIER EXPECTED
PUSHJ PP,PA263. ;SUBSTITUTE DUMMY DATAB ENTRY
JRST PA21.
;SET UP SDELIM OPERATOR
INTER. PA361.
PA361.: HRRZI TA,SDELIM
JRST SETOP
;MISSING DELIMITED BY CLAUSE
INTER. PA363.
PA363.: EWARNW E.462 ;?'DELIMITED BY' CLAUSE REQUIRED
PUSHJ PP,PA361. ;SET UP SDELIM OPERATOR WITH SIZE FLAG
SKPNAM
;SET 'DELIMITED BY SIZE' FLAG
INTER. PA362.
PA362.: SETO TA,
DPB TA,OP.DSZ##
POPJ PP,
;SET UP STRING OPERATOR
INTER. PA364.
PA364.: HRRZI TA,STRNG
JRST SETOP
;SET 'WITH POINTER' FLAG
INTER. PA365.
PA365.: SETO TA,
DPB TA,OP.PTR##
POPJ PP,
;SET 'ON OVERFLOW' FLAG
INTER. PA366.
PA366.: SETO TA,
DPB TA,OP.OVF##
POPJ PP,
;CONVERT FIG CONSTANT TO A SINGLE CHARACTER LITERAL
IFN ANS68,<
INTER. PA367.
PA367.: LDB TB,[POINT 9,W1,17] ;GET FIG CON CODE
SUBI TB,HIVAL. ;MAKE INDEX TO TABLE
XCT %HV(TB) ;GET EQUIVALENT SINGLE LETTER LITERAL
MOVEM TB,LITVAL
MOVSI W1,GWLIT!1 ;SAY ITS A 1-CHAR LITERAL
JRST PCA5. ;CONTINUE AS IF NOTHING HAPPENED
%HV: EWARNJ E.184 ;ILLEGAL FIG CON
%LV: EWARNJ E.184
%QUO: MOVSI TB,(ASCII /"/)
%SPA: MOVSI TB,(ASCII / /)
%TL: EWARNJ E.184
%ZER: MOVSI TB,(ASCII /0/)
>
>
;UNSTRING ACTIONS
IFN STRING,<
INTER. PA370.
PA370.: HRLZI TA,ARG1 ;SAVE SOME THINGS ABOUT SOURCE-ITEM
HRRI TA,STRSAV## ;ADDR OF SAVE AREA
BLT TA,STRSAV+2 ;THIS BLT'S 1 MORE LOC THAN NECESSARY
MOVE TB,NSBSC1
MOVEM TB,STRSAV+2 ;SAVE # OF SUBSCRIPTS
HRLI TA,SBSCR1
HRRI TA,STRSAV+3
BLT TA,STRSAV+6 ;SAVE SBSCR1
SETZM NSBSC1## ;RESET SUBSCRIPT COUNT FOR NEXT ITEM.
POPJ PP,
INTER. PA372.
PA372.: HRRZI TA,UDELIM ;SET UP UDELIM OPERATOR
JRST SETOP
INTER. PA373.
PA373.: SETO TA, ;SET THE 'ALL' FLAG
DPB TA,OP.ALL##
POPJ PP,
INTER. PA374.
PA374.: PUSHJ PP,PA22. ;OUTPUT PREVIOUS UDELIM
JRST PA372. ;SET UP NEW UDELIM OP
INTER. PA375.
PA375.: HRRZI TA,UNSDES ;SET UP UNSDES OPERATOR
JRST SETOP
INTER. PA376.
PA376.: SETO TA, ;SET 'DELIMITER IN' FLAG
DPB TA,OP.DEL##
POPJ PP,
INTER. PA377.
PA377.: SETO TA, ;SET 'COUNT IN' FLAG
DPB TA,OP.COU##
POPJ PP,
INTER. PA378.
PA378.: PUSHJ PP,PA22. ;OUTPUT LAST UNSDES OP
HRLZI TA,STRSAV ;SET UP TO RESTORE SOURCE-ITEM
HRRI TA,ARG1
BLT TA,ARG1+1
MOVE TB,STRSAV+2
MOVEM TB,NSBSC1 ;GET # OF SUBSCRIPTS
HRLI TA,STRSAV+3
HRRI TA,SBSCR1 ;RESTORE SUBSCRIPT INFO
BLT TA,SBSCR1+3
PUSHJ PP,PA21. ;OUTPUT IT
HRRZI TA,UNSTR ;SET UP UNSTR OPERATOR
JRST SETOP
INTER. PA379.
PA379.: SETO TA, ;SET 'TALLYING IN' FLAG
DPB TA,OP.TLG##
POPJ PP,
INTER. PA380.
PA380.: PUSHJ PP,PA22. ;OUTPUT PREVIOUS UNSDES OPERATOR
JRST PA375. ;SET UP NEW UNSDES OP
>
; CHECK FIG CONSTANT- ONLY ZERO IS LEGAL.
INTER. PA400.
PA400.: LDB TA,[POINT 9,W1,17] ;GET WHICH FIG CONSTANT [265]
CAIN TA,ZERO. ; IS IT ZERO? [265]
JRST PA2. ; YES-OK [265]
EWARNW E.131 ; NO- ILLEGAL [265]
MOVEI TA,ZERO. ; MAKE ZERO [265]
DPB TA,[POINT 9,W1,17] ; TO PREVENT MORE ERRORS [265]
JRST PA2. ; [265]
;SET WITH SEQUENCE CHECK FOR MERGE VERB
INTER. PA401.
PA401.: SETO TA,
DPB TA,OP.WSC##
IFN ANS74,<
SKIPE FLGSW## ;NEED TO FLAG EXTENSIONS?
EWARNJ E.722
>
POPJ PP,
IFN CSTATS,<
;METER--JSYS
INTER. PA402.
PA402.: HRRZI TA,155 ;OPCODE
SKIPE METRSW## ;DID HE SPECIFY "WITH METER--ING"?
JRST SETOP1 ;YES--OK
EWARNW E.599 ;? WITH METER--ING MUST BE SPECIFIED IN ENVIRON.
HRRZI TA,105 ;"YECCH"
JRST SETOP1
INTER. PA403.
PA403.: HLRZ TB,W1
ANDI TB,177
MOVEM TB,CTR## ;LENGTH
HRRZI TA,LITVAL
PUSHJ PP,GETVAL##
JUMPL TC,JDE25. ;?POSITIVE INTEGER REQUIRED
CAILE TC,^D2500 ;MUST BE LE 2500
EWARNJ E.600 ;?MUST BE...
MOVSI TA,(1B0) ;SET OPERAND BIT
MOVE TB,TC ; 2ND WORD = NUMBER
PJRST PUTGEN ;SEND IT OUT
JDE25.: EWARNJ E.25
>;END IFN CSTATS
IFN ANS74,<
;START FILE-NAME KEY ARITHMETIC-CONDITION
INTER. PA500.
PA500.: SETO TA,
DPB TA,OP.EQU
POPJ PP,
INTER. PA501.
PA501.: SETO TA,
DPB TA,OP.GRT
POPJ PP,
INTER. PA502.
PA502.: SETO TA,
DPB TA,OP.LES
POPJ PP,
;USE FOR DEBUGGING ...
INTER. PA510.
PA510.: SKIPE DEBSW## ;IF USER EXPECTED THIS TO WORK
EWARNW E.717 ;TELL USER ITS NOT IMPLEMENTED
SKPNAM
INTER. PA511.
PA511.: PUSHJ PP,SKPPGF## ;SKIP REST OF PARAGRAPH.
POPJ PP,
;WRITE RECORD ADVANCING PAGE.
INTER. PA631.
PA631.: PUSHJ PP,PA2.
HRRZ TB,ARG1 ;R. H. OF GETSRC W1
MOVE TA,ARG1+1 ;GETSRC W2
MOVE TE,TA ;W2
MOVE TD,ARG1 ;W1
AND TA,[XWD 3,-1] ;LN, CP
TLO TA,400000 ;SET OPERAND BIT
SETZM NSBSC1
SETZM ARG1
SETZM ARG1+1
HLRZ TB,TD
ANDI TB,777 ;GET VALUE
JRST PUTGEN ;OUTPUT ARG1
;WRITE ADVANCING ZERO
>
;READ & FIND A DEFINED DATA-NAME WITH ALL QUALIFIERS
;RETURNS TE=DATAB LINK
INTER. DA96.D
DA96.D: SETZM TBLOCK ;CLR TBLOCK
MOVE TA,[TBLOCK,,TBLOCK+1]
BLT TA,TBLOCK+24
MOVEM W2,TBLOCK+4 ;FACTS ABOUT DATA-NAME TO TBLOCK SETUP
DA96.1: PUSHJ PP,GETITM ;READ NEXT SOURCE WORD
CAIE TYPE,OF. ;IS IT "OF" OR "IN"?
JRST DA96.2 ;NO, TIME TO EXIT
PUSHJ PP,GETITM ;YES, QUALIFIER SHOULD FOLLOW
CAILE TYPE,ENDIT. ;IS IT A RESERVED WORD?
JRST DA96.0 ;NO, IT'S OK
SWON FREGWD ;YES, PREPARE TO REGET THAT ITEM
EWARNJ E.101 ;& FLAG THIS AS ILLEGAL QUALIFIER
DA96.0: AOS TA,TBLOCK+1 ;COUNT THE QUALIFIER
LDB TB,[POINT 15,W2,15] ;GET NAMTAB LINK
JUMPL W1,JDE104 ;QUALIFIER MUST BE DEFINED [240]
MOVEM TB,TBLOCK+4(TA) ;STORE NAMTAB LINK OF QUAL IN TBLOCK
JRST DA96.1 ;ANY MORE QUALS?
DA96.2: SWON FREGWD ;REGET THIS LAST WORD THAT WASN'T "OF"
PUSHJ PP,FINDAT## ;FIND A DATAB MATCH FOR THE ITEM
JUMPN DW,DA96.3 ;SKIP IF ERROR
POPJ PP, ;RETURN WITH DATAB LINK IN TE
JDE104: MOVEI DW,E.104 ;NAME IS UNDEFINED [240]
DA96.3: PUSHJ PP,FATAL## ;GIVE MESSAGE
MOVEI TE,<CD.DAT>B20+1 ;AIM AT DUMMY ENTRY
POPJ PP,
SUBTTL SIMULTANEOUS UPDATE SYNTAX
; ACTIONS PASU1 THROUGH PASU21 ARE USED TO SCAN THE OPEN STATEMENT,
; AS MODIFIED TO SUPPORT SIMULTANEOUS UPDATE. NO GEN FILE OUTPUT IS
; PRODUCED UNTIL THE OPEN STATEMENT IS COMPLETELY SCANNED.
;
;
; EACH FILENAME SCANNED DURING THE SCANNNING OF AN OPEN
; STATEMENT RESULTS IN THE CREATION OF A TABLE ENTRY IN THE TABLE CALLED
; BUFFER. THERE MAY BE UP TO EIGHT SUCH TABLE ENTRIES. EACH TABLE ENTRY
; HAS THE FOLLOWING FORMAT:
;
; WORD 0:
;
; BIT 0: INPUT
; BIT 1: OUTPUT
; BIT 2: INPUT-OUTPUT
; BIT 3: NO REWIND
; BIT 4: FOR READ
; BIT 5: FOR REWRITE
; BIT 6: FOR WRITE
; BIT 7: FOR DELETE
; BIT 8: FOR ALL
; BIT 9: OTHERS NONE
; BIT 10: OTHERS READ
; BIT 11: OTHERS REWRITE
; BIT 12: OTHERS WRITE
; BIT 13: OTHERS DELETE
; BIT 14: OTHERS ALL
; BIT 15: USER SUPPLIED UNAVAILABLE STATEMENT (1ST FILENAME ONLY)
; BIT 16: [74] EXTENDED
; BIT 17: [74] REVERSED
;
; WORD 1: SAVE W1
;
; WORD 2: SAVE W2
;
; WORD 3: SAVE CT
;
; WORD 4: SAVE NAMWRD
;
; WORD 5: SAVE NAMWRD + 1
;
; WORD 6: SAVE NAMWRD + 2
;
; WORD 7: SAVE NAMWRD + 3
;
; WORD 8: SAVE NAMWRD + 4
; THE GENFIL GENERATED FOR AN OPEN STATEMENT INCLUDING SIMULTANEOUS
; UPDATE LOOKS LIKE THIS:
;
; FILE-NAME-1
; FENQ (OP CODE 143) WITH FLAGS INDICATING USAGE
; .
; .
; .
; FILE-NAME-N
; FENQ, AS ABOVE
; EFENQ (OP CODE 146) WITH FLAG INDICATING IF USER SUPPLIED
; AN UNAVAILABLE STATEMENT
; FILE-NAME-1
; OPEN
; .
; .
; .
; FILE-NAME-M M>=N
; OPEN
; FUNAV (OP CODE 144) IF USER SUPPLIED UNAVAILABLE STATEMENT
; [GENFIL FOR UNAVAILABLE STATEMENT]
; EFUNAV (OP CODE 145) IF USER SUPPLIED UNAVAILABLE STATEMENT
INTER. PASU1.
PASU1.: SETZM BUFCTR; INITIALIZE BUFFER TABLE
SETZM BUFFER; INITIALIZE WORD 0 OF THE 1ST ENTRY
JRST PA49.; EXECUTE PA49 IN CASE THIS IS A DBMS OPEN
INTER. PASU2.
PASU2.: MOVEI TD,400000; SET INPUT BIT
MOVEI TC,300002; CLEAR OUTPUT AND INPUT-OUTPUT BITS
PASU2A: PUSHJ PP,PASU2B; SET UP TA
MOVE TB,BUFFER(TA)
TLZ TB,0(TC); ZERO BITS INDICATED BY TC
TLO TB,0(TD); SET BITS INDICATED BY TD
MOVEM TB,BUFFER(TA)
POPJ PP,
PASU2B: MOVE TA,BUFCTR; THIS SUBROUTINE PREPARES IN TA A
CAIGE TA,^D16; RELATIVE POINTER TO THE CURRENT ENTRY
JRST PASUYY
EWARNW E.573; IN THE BUFFER TABLE, AFTER CHECKING
SETZB TA,BUFCTR
PASUYY: LSH TA,3; THAT THE NUMBER OF FILE NAMES HAS NOT
ADD TA,BUFCTR; EXCEEDED 16.
POPJ PP,
INTER. PASU3.
PASU3.: MOVEI TD,200000; SET OUTPUT BIT
MOVEI TC,500002; CLEAR INPUT AND INPUT-OUTPUT BITS
JRST PASU2A
INTER. PASUE.
PASUE.: MOVEI TD,240002; SET OUTPUT, NO REWIND & EXTEND BITS
MOVEI TC,500000; CLEAR INPUT AND INPUT-OUTPUT BITS
JRST PASU2A
IFN ANS74,<
INTER. PASUR.
PASUR.: MOVEI TD,1 ;SET REVERSED BIT
JRST PASU6A
>
INTER. PASU4.
PASU4.: MOVEI TD,100000; SET INPUT-OUTPUT BIT
MOVEI TC,640000; CLEAR INPUT AND OUTPUT BITS
JRST PASU2A
INTER. PASU5.
PASU5.: PUSHJ PP,PASU2B; SET UP TA
ADDI TA,BUFFER
PUSH TA,W1; SAVE EVERYTHING NECESSARY TO
PUSH TA,W2; LATER PRETEND WE HAVE JUST
PUSH TA,CT; SEEN THE FILENAME
PUSH TA,NAMWRD
PUSH TA,NAMWRD+1
PUSH TA,NAMWRD+2
PUSH TA,NAMWRD+3
PUSH TA,NAMWRD+4
POPJ PP,
INTER. PASU6.
PASU6.: MOVEI TD,040000; SET NO REWIND BIT
PASU6A: SETZ TC,; CLEAR NO BITS
JRST PASU2A
INTER. PASU7.
PASU7.: PUSHJ PP,PASU2B; SET UP TA
MOVE TB,BUFFER(TA)
TLZ TB,077777; INITIALIZE 1ST WORD OF NEXT ENTRY
MOVEM TB,BUFFER+^D9(TA)
AOS BUFCTR; PUSH BUFFER TABLE
POPJ PP,
INTER. PASU9.
PASU9.: MOVEI TD,020000; SET FOR READ BIT
JRST PASU6A
INTER. PASU10
PASU10: MOVEI TD,010000; SET FOR REWRITE BIT
JRST PASU6A
INTER. PASU11
PASU11: MOVEI TD,004000; SET FOR WRITE BIT
JRST PASU6A
INTER. PASU12
PASU12: MOVEI TD,002000; SET FOR DELETE BIT
JRST PASU6A
INTER. PASU13
PASU13: MOVEI TD,036000; SET FOR ALL BIT
JRST PASU6A
INTER. PASU14
PASU14: MOVEI TD,000400; SET OTHERS NONE BIT
JRST PASU6A
INTER. PASU15
PASU15: MOVEI TD,000200; SET OTHERS READ BIT
JRST PASU6A
INTER. PASU16
PASU16: MOVEI TD,000100; SET OTHERS REWRITE BI
JRST PASU6A
INTER. PASU17
PASU17: MOVEI TD,000040; SET OTHERS WRITE BIT
JRST PASU6A
INTER. PASU18
PASU18: MOVEI TD,000020; SET OTHERS DELETE BIT
JRST PASU6A
INTER. PASU19
PASU19: MOVEI TD,000360; SET OTHERS ALL BIT
JRST PASU6A
INTER. PASU8.
PASU8.: SKIPN BUFCTR
POPJ PP,
MOVE TA,[XWD NAMWRD,HLDNAM##] ; [420] SAVE CURRENT
BLT TA,HLDNAM+4 ; [420] SOURCE ITEM
MOVEM W1,HLDSRC## ; [420] STORE FIRST WORD OF SOURCE PARAMS
MOVEM W2,HLDSRC+1 ; [420] 2ND SOURCE WORD PARAMS
MOVEM CT,HLDSRC+2 ; [420] 3RD SOURCE PARAMS
SETZM SU8FLG
MOVE TA,BUFCTR ;ADJUST SPACE REQUIRED FOR ENQ/DEQ BUFFERING
LSH TA,1
ADD TA,BUFCTR
ADDI TA,2
CAMLE TA,SUEQT.
MOVEM TA,SUEQT.
SETZM SU8CNT; GET READY FOR FIRST PASS OF BUFFER TABLE
PASU8A: MOVE TC,SU8CNT; DURING THE 1ST PASS,DETERMINE
CAML TC,BUFCTR; WHICH FILES, IF ANY, ARE TO BE OPENED
JRST PASU8B; WITH SIMULTANEOUS UPDATE, AND FOR THOSE
LSH TC,3; FILES WHICH ARE, GENERATE APPROPRIATE
ADD TC,SU8CNT; CODE.
MOVE TD,BUFFER(TC)
TLNN TD,000770
JRST PASU8R; JUMP IF NO SIMULTANEOUS UPDATE
TLNN TD,100000
EWARNW E.574 ;INDICATE ERROR IF FILE NOT OPEN FOR I-O
MOVE TA,BUFFER+2(TC); SET UP LINE NUMBER AND CHARACTER POSITION
TLZ TA,777774; ZERO IRRELEVANT FIELDS
TLO TA,400000; SET OPERAND BIT
MOVE TB,BUFFER+1(TC); SET UP FILE NAME TABLE ADDRESS
HRLI TB,0; ZERO IRRELEVANT BITS
TRZ TB,700000
MOVEM TC,SU8SVC
PUSHJ PP,PUTGEN; GENERATE FILE NAME OPERAND
MOVE TC,SU8SVC
MOVE TD,BUFFER(TC)
LSH TD,-4; GET R, W, D BITS IN POSITION
TLZ TD,777077; ZERO EVERYTHING ELSE
MOVE TA,BUFFER(TC)
LSH TA,-2; GET OR, OR, OW, OD BITS IN POSITION
TLZ TA,777703; ZERO EVERYTHING ELSE
OR TA,TD
TLO TA,143000; COMBINE AND ADD OP CODE
HRRI TA,0
TLZ W2,777774
OR TA,W2; ADD LINE AND CHARACTER POSITION
HRRZI TB,000143; SET UP WORD 2
PUSHJ PP,PUTGEN; GENERATE OPERATOR
SETOM SU8FLG
PASU8C: AOS SU8CNT
JRST PASU8A
PASU8B: SKIPN SU8FLG
JRST PASU8F; JUMP IF NO FILES OPENED FOR SIMULTANEOUS UPDATE
MOVE TA,BUFFER
LSH TA,6; GET FLAG INDICATING IF USER SUPPLIED
TLZ TA,777377; AN UNAVAILABLE STATEMENT AND MOVE
TLO TA,146000; TO BIT 9 OF OPERATOR FLAG FIELD
TRZ TA,777777
TLZ W2,777774
OR TA,W2
HRRZI TB,000146
PUSHJ PP,PUTGEN; GENERATE EFENQ OPERATOR
PASU8F: SETZM SU8CNT; PREPARE TO MAKE SECOND PASS OF BUFFER TABLE
PASU8D: MOVE TA,SU8CNT; THIS TIME, GENERATE REGULAR OPEN CODE
;FOR FILES NOT OPEN FOR SIMULTANEOUS UPDATE
CAML TA,BUFCTR
JRST PASU8E
LSH TA,3
ADD TA,SU8CNT
MOVE TB,BUFFER(TA)
TLNE TB,000770
JRST PASU8Z ;JUMP IF OPEN FOR SIMULTANEOUS UPDATE
MOVEM TA,SU8SVA
PUSHJ PP,PA49.; EXECUTE OLD ACTION PA49 OF NODE PD491A
MOVE TA,SU8SVA
MOVE TB,BUFFER(TA)
MOVEM TB,SU8SVB
TLNE TB,400000
PUSHJ PP,PA74.; EXECUTE OLD ACTION PA74 OF NODE PD491
MOVE TB,SU8SVB
TLNE TB,200000
PUSHJ PP,PA75.; EXECUTE OLD ACTION OF NODE PD492
MOVE TB,SU8SVB
TLNE TB,100000
PUSHJ PP,PA76.; EXECUTE OLD ACTION PA76 OF NODE PD493
MOVE TA,SU8SVA
ADDI TA,BUFFER+^D8
HRLI TA,20
POP TA,NAMWRD+4
POP TA,NAMWRD+3
POP TA,NAMWRD+2
POP TA,NAMWRD+1
POP TA,NAMWRD
POP TA,CT
POP TA,W2
POP TA,W1
PUSHJ PP,PA2.; EXECUTE OLD ACTION PCA48 OF NODE PD496
PUSHJ PP,PA77.
PUSHJ PP,PA78.
MOVE TB,SU8SVB
TLNE TB,040000
PUSHJ PP,PA79.; EXECUTE OLD ACTION PA79 OF NODE PD504
TLNE TB,(1B16) ;EXTENDED?
PUSHJ PP,PA79E. ;YES
IFN ANS74,<
TLNE TB,(1B17) ;REVERSED?
PUSHJ PP,PA79R. ;YES
>
PUSHJ PP,PA21. ;EXECUTE OLD ACTION PCA49 OF NODE PD507
PUSHJ PP,PA160.
AOS SU8CNT
JRST PASU8D
PASU8E: MOVE TB,BUFFER
TLNN TB,000004; TEST IF USER SUPPLIED UNAVAILABLE STATEMENT
JRST PASU8M ;[420] DO OLD ACTION
MOVE TA,W2
TLZ TA,777774
TLO TA,144000; GENERATE FUNAV OPERATOR
HRRZI TB,000144
PUSHJ PP,PUTGEN
MOVE TA,[XWD HLDNAM,NAMWRD] ; [420] RESTORE CURRENT
BLT TA,NAMWRD+4 ; [420] SOURCE ITEM
MOVE W1,HLDSRC## ; [420] RESTORE FIRST WORD OF SOURCE PARAMS
MOVE W2,HLDSRC+1 ; [420] 2ND SOURCE WORD PARAMS
MOVE CT,HLDSRC+2 ; [420] 3RD SOURCE PARAMS
POPJ PP,
PASU8M: MOVE TA,[XWD HLDNAM,NAMWRD] ; [420] RESTORE CURRENT
BLT TA,NAMWRD+4 ; [420] SOURCE ITEM
MOVE W1,HLDSRC## ; [420] RESTORE FIRST WORD OF SOURCE PARAMS
MOVE W2,HLDSRC+1 ; [420] 2ND SOURCE WORD PARAMS
MOVE CT,HLDSRC+2 ; [420] 3RD SOURCE PARAMS
JRST PA0.; EXECUTE OLD ACTION PA0. OF NODE PD508
PASU8R: TLNE TD,037000
EWARNW E.575
JRST PASU8C ;WARN IF FOR BUT NO OTHERS
INTER. PASU20
PASU20: MOVE TA,BUFFER; SET BIT INDICATING USER SUPPLIED UNAVAILABLE STATEMENT
TLO TA,000004
MOVEM TA,BUFFER
JRST PASU8.
INTER. PASU21
PASU21: HRLZI TA,145000
TLZ W2,777774
OR TA,W2
HRRZI TB,000145
PUSHJ PP,PUTGEN; GENERATE EFUNAV OPERATOR
PUSHJ PP,PA24.
SWOFF UNCONT; SET SWITCH TO INDICATE IT'S OK FOR AN UNLABELED STATEMENT TO FOLLOW
JRST PA0.
PASU8Z: HRRZ TA,BUFFER+1(TA)
HRLZM TA,CURFIL
PUSHJ PP,LNKSET ;GET ADDRESS OF FILE TABLE
HRRM TA,CURFIL
SETO TB,
DPB TB,FI.IOO ;SET BIT INDICATING I-0 OPEN SEEN
AOS SU8CNT
JRST PASU8D
;ACTIONS PASU30 THROUGH PASU45 GENERATE GENFIL FOR THE RETAIN
;STATEMENT. THE GENFIL FOR A RETAIN STATEMENT LOOKS LIKE THIS:
;
; FILE-NAME-1
; [DATA-NAME-1 OR LITERAL-1]
; RENQ (OP CODE 147) WITH FLAGS INDICATING USAGE
; .
; .
; .
; FILE-NAME-N
; [DATA-NAME-N OR LITERAL-N]
; RENQ, AS ABOVE
; ERENQ (OP CODE 150) WITH FLAG INDICATING IF USER SUPPLIED
; AN UNAVAILABLE STATEMENT
; [CODE FOR THE UNAVAILABLE STATEMENT]
; ERUNAV (OP CODE 151) IF USER SUPPLIED UNAVAILABLE STATEMENT
INTER. PASU30
PASU30: MOVE TA,W2; CREATE FILENAME OPERAND
TLZ TA,777774; AND SAVE IN SU30F1, SU30F2
TLO TA,400000
HRRZ TB,W1
TRZ TB,700000
MOVEM TA,SU30F1
MOVEM TB,SU30F2
SETZM SU30FG; ZERO FLAGS
POPJ PP,
INTER. PASU31
PASU31: HRLZI TA,000010; SET FLAG INDICATING DATA NAME OR
ORM TA,SU30FG; LITERAL SUPPLIED
JRST PA2.; GO TO PA2. TO SAVE SAME
INTER. PASU33
PASU33: HRLZI TA,000400; SET READ FLAG
PASU3X: ORM TA,SU30FG
POPJ PP,
INTER. PASU34
PASU34: HRLZI TA,000600; SET READ, REWRITE FLAGS
JRST PASU3X
INTER. PASU35
PASU35: HRLZI TA,000500; SET READ, WRITE FLAGS
JRST PASU3X
INTER. PASU36
PASU36: HRLZI TA,000040; SET DELETE FLAG
JRST PASU3X
INTER. PASU37
PASU37: HRLZI TA,000100; SET WRITE FLAG
JRST PASU3X
INTER. PASU38
PASU38: HRLZI TA,000200; SET REWRITE FLAG
JRST PASU3X
INTER. PASU39
PASU39: HRLZI TA,000740; SET ALL FLAGS
JRST PASU3X
INTER. PASU40
PASU40: HRLZI TA,000020; SET UNTIL FREED FLAG
JRST PASU3X
IFN ANS74,<
INTER. PASU90
PASU90: HRLZI TA,(1B15) ;SET "NEXT RECORD" FLAG
JRST PASU3X
>;END IFN ANS74
INTER. PASU44
PASU44: AOS SUFBTM ;INCREMENT SPACE REQUIRED IN THE
;FILL FLUSH BUFFER TABLE
MOVEI TA,3
ADDM TA,SUEQTM ;INCREMENT SPACE REQUIRED IN EACH
;OF THE ENQ/DEQ TABLES.
HRRZ TA,SU30F2 ;MOVE ADDRESS OF FILE TABLE TO TA
HRLZM TA,CURFIL
PUSHJ PP,LNKSET
HRRM TA,CURFIL
MOVEI TC,1
LDB TB,FI.ACC
CAIE TB,%ACC.I
JRST SUCS1 ;SIZE OF SPACE REQUIRED TO SAVE KEY
;IS ONE WORD IF FILE IS NOT INDEXED
LDB TA,FI.SKY ;MOVE ADDRESS OF DATAB ENTRY FOR
;SYMBOLIC KEY TO TA
JUMPE TA,SUCS1 ;SYMBOLIC KEY NOT DEFINED
HRLZM TA,CURDAT
PUSHJ PP,LNKSET
HRRM TA,CURDAT
LDB TB,DA.USG
CAIE TB,%US.1C
CAIN TB,%US.C1
JRST SUCS1 ;JUMP IF KEY 1 WORD COMP OR COMP-1
CAIN TB,%US.IN
JRST SUCS1 ;JUMP IF KEY INDEX
MOVEI TC,2
CAIN TB,%US.2C
JRST SUCS1 ;JUMP IF KEY 2 WORD COMP
CAIN TB,%US.D6
MOVEI TC,6 ;SET DIVISOR TO 6 IF KEY DISPLAY-6
CAIN TB,%US.D7
MOVEI TC,5 ;SET DIVISOR TO 5 IF KEY DISPLAY-7
CAIN TB,%US.EB
MOVEI TC,4 ;SET DIVISOR TO 4 IF KEY DISPLAY-9
CAIN TB,%US.C3
MOVEI TC,4 ;SET DIVISOR TO 4 IF KEY COMP-3
MOVE TD,16
MOVE TE,17
LDB 17,DA.INS ;GET INTERNAL SIZE FROM DATAB ENTRY
SETZ 16,
DIV 16,TC
MOVE TC,16
SKIPE 17
ADDI TC,1
MOVE 16,TD
MOVE 17,TE
; AT THIS POINT TC CONTAINS THE NUMBER OF WORDS REQUIRED TO
; STORE A KEY OF THE FILE
SUCS1: ADDI TC,2 ;ADD 1 WORD FOR THE MISCELLANEOUS
;WORD, 1 WORD FOR THE BLOCK NUMBER.
;TC NOW CONTAINS THE LENGTH OF A
;RETAINED RECORDS TABLE ENTRY AT
;RUN TIME.
ADDM TC,SURRTM
MOVE TA,CURFIL
LDB TB,FI.ACC ;GET ACCESS MODE FROM FILE TABLE
CAIE TB,2
JRST PASUAA ;JUMP IF FILE NOT INDEXED
LDB TB,FI.RTC
JUMPN TB,PASUAA ;JUMP IF A PRIOR ELEMENT IN THIS
;RETAIN STATEMENT REFERENCES THE SAME
;FILE
SUBI TC,1 ;OTHERWISE, ADD TO THE SPACE REQUIRED
;IN THE RETAINED RECORDS TABLE, ROOM
;TO TEMPORARILY SAVE THE KEY OF THE FILE
;WHEN DOING FAKE LOW-VALUES READS AT
;RUN TIME.
ADDM TC,SURRTM
DPB TC,FI.RTC ;SET FI.RTC TO NON-ZERO TO INDICATE WE
;PROCESSED AN ELEMENT OF THIS RETAIN
;STATEMENT NAMING THIS FILE.
MOVEI TC,3
ADDM TC,SUEQTM ;INCREMENT THE SPACE REQUIRED IN EACH
;OF THE ENQ/DEQ TABLE BY 3 (FOR THE
;FILE INDEX)
PASUAA: HRLZI TA,147000
PASU4Z: MOVEM TA,PASU4T
MOVE TA,SU30F1
MOVE TB,SU30F2
PUSHJ PP,PUTGEN; GENERATE FILE NAME
MOVE TA,SU30FG
TLNE TA,000010
PUSHJ PP,PA21.; GENERATE DATA NAME OR LITERAL, IF ANY
MOVE TA,SU30F1
TLZ TA,777774
OR TA,SU30FG
OR TA,PASU4T
HLRZ TB,PASU4T
LSH TB,-9
JRST PUTGEN; GENERATE RENQ OPERATOR AND RETURN
INTER. PASU41
PASU41: HRLZI TC,150400
PASU4Y: MOVEM TC,SU41TP##
MOVE TC,SURRTM ;SET SURRT., SUEQT., SUFBT. TO THE
;LARGEST REQUIREMENT OF ANY RETAIN
;STATEMENT PROCESSED SO FAR.
CAMLE TC,SURRT.
MOVEM TC,SURRT.
MOVE TC,SUEQTM
ADDI TC,2
CAMLE TC,SUEQT.
MOVEM TC,SUEQT.
MOVE TC,SUFBTM
CAMLE TC,SUFBT.
MOVEM TC,SUFBT.
PUSHJ PP,SUZRTC ;ZERO FI.RTC IN ALL FILE TABLES
MOVE TA,SU30F1
TLZ TA,777774
OR TA,SU41TP##
HRRZI TB,000150
PJRST PUTGEN; GENERATE ERENQ OPERATOR AND RETURN
SUZRTC: MOVE TA,FILLOC ;ZERO FI.RTC IN ALL FILE TABLES
;AND RETURN
CAMN TA,FILNXT
POPJ PP,
HRRZI TA,CD.FIL*1B20+1
SUZRT1: HRLZM TA,CURFIL
PUSHJ PP,LNKSET
HRRM TA,CURFIL
SETZ TB,
DPB TB,FI.RTC
SUZRT2: HRRZ TA,CURFIL
LDB TA,FI.NXT
JUMPE TA,CPOPJ
JRST SUZRT1
INTER. PASU42
PASU42: HRLZI TC,150000
PUSHJ PP,PASU4Y
JRST PA0.; POP UP
INTER. PASU45
PASU45: MOVE TA,SU30F1; GENERATE ERUNAV OPERATOR
TLZ TA,777774; AND POP UP
TLO TA,151000
HRRZI TB,000151
PUSHJ PP,PUTGEN
PUSHJ PP,PA24.
SWOFF UNCONT; 0K FOR GO TO OR STOP TO PRECEDE NEXT STATEMENT
JRST PA0.
INTER. PASU64
PASU64: HRLZI TA,000200; SET FILENAME EVERY FLAG
JRST PASU3X
IFN ANS74,<
INTER. PASU92
PASU92: HRLZI TA,(1B15) ;SET "FILENAME NEXT" FLAG
JRST PASU3X
>;END IFN ANS74
;ACTIONS PASU60 THROUGH PASU81 GENERATE GENFIL FOR THE FREE STATEMENT.
;THE GENFIL FOR THE FREE STATEMENT LOOKS LIKE THIS:
;
; FILE-NAME-1
; [DATA-NAME-1 OR LITERAL-1]
; RDEQ (OP CODE 152)
; .
; .
; .
; FILE-NAME-N
; [DATA-NAME-N OR LITERAL-N]
; RDEQ, AS ABOVE
; ERDEQ (OP CODE 153) WITH FLAG INDICATING IF USER SUPPLIED
; A NOT RETAINED STATEMENT
; [CODE FOR THE NOT RETAINED STATEMENT]
; ENR (OP CODE 154) IF USER SUPPLIED NOT RETAINED STATEMENT
;
INTER. PASU60
PASU60: MOVE TA,W2; GET LINE NUMBER AND CHARACTER POSITION
TLZ TA,777774
TLO TA,152400; SET RDEQ AND EVERY FLAG
HRRZI TB,000152
JRST PUTGEN
INTER. PASU61
PASU61: HRLZI TC,153400; SET NOT RETAINED FLAG
PASU6Y: MOVE TA,W2
TLZ TA,777774
OR TA,TC
HRRZI TB,000153; GENERATE ERDEQ
PJRST PUTGEN
INTER. PASU63
PASU63: HRLZI TC,153000
PUSHJ PP,PASU6Y; GENERATE ERDEQ
JRST PA0.; POP UP
INTER. PASU62
PASU62: MOVE TA,W2; GENERATE ENR AND POP UP
TLZ TA,777774
TLO TA,154000
HRRZI TB,000154
PUSHJ PP,PUTGEN
PUSHJ PP,PA24.
SWOFF UNCONT; OK FOR GO OR STOP TO PRECEDE NEXT STATEMENT
JRST PA0.
INTER. PASU66
PASU66: HRLZI TA,152000; GENERATE RDEQ
JRST PASU4Z
SUBTTL COMPOUND ACTIONS
INTER. PCA1.
PCA1.: PUSHJ PP,PA3.
PUSHJ PP,PA21.
JRST PA22.
INTER. PCA2.
PCA2.: PUSHJ PP,PA4.
PUSHJ PP,PA137.
SKPNAM
INTER. PCA25.
PCA25.: PUSHJ PP,PA21.
JRST PA22.
INTER. PCA3.
PCA3.: PUSHJ PP,PCA3A ; [271] SET UP SECTION
MOVE TB,PROGST ; [271] SAVE START OF PROG
PUSH PP,TB ; [271]
PUSHJ PP,PA219X ; [271] MAKE GENERATED PARA NAME FOR NEW SECTION
POP PP,TB ; [271] RESTORE
MOVEM TB,PROGST ; [271] START OF PROG
SETO TB, ; [271] SET MULTI-DEFINED BIT ON
DPB TB,PR.MDF ; [271] DEFINED BIT OFF-MEANS GENERATED PARA IN COBOLE (XFRGEN)
POPJ PP, ; [271]
PCA3A: PUSHJ PP,PA3. ; [271] ADD LABEL
PUSHJ PP,PA7.
JRST PCA25.
IFN ANS74,<
INTER. PCA5A.
PCA5A.: TLNE W1,GWSIGN!GWDP
EWARNW E.702
SKPNAM
>;END IFN ANS74
INTER. PCA5.
PCA5.: PUSHJ PP,PA2.
JRST PA21.
IFN ANS74,<
INTER. PCA6A.
PCA6A.: PUSHJ PP,PA22.
PUSHJ PP,PA59.
SKPNAM
>
INTER. PCA6.
PCA6.: PUSHJ PP,PA22.
JRST PA0.
INTER. PCA7.
PCA7.: PUSHJ PP,PA24.
JRST PA0.
;IN A SEARCH STATEMENT.. SET FLAG THAT SAYS "WHEN" SEEN TO DELIMIT
; STATEMENT, NOT "."
INTER. PCA7A.
PCA7A.: SETOM SWHEN##
JRST PCA7. ;REGET THE "WHEN" AND POP UP A NODE
;IN SEARCH STATEMENT, SET FLAG THAT SAYS "." SEEN TO DELIMIT
; STATEMENT. IF THE NEXT TOKEN IS A "WHEN", WE WILL ASSUME
; THAT THE "." IS A MISTAKE
; AND IGNORE IT.
INTER. PCA7B.
PCA7B.: SETZM SWHEN## ;CLEAR FLAG
MOVEM LN,PERLN## ;STORE LN AND CP
MOVEM CP,PERCP## ;;OF THE "." INCASE AFTER PARSING THE
;NEXT TOKEN WE DECIDE THIS PERIOD IS EXTRANEOUS
JRST PA0. ;POP UP A NODE
INTER. PCA11.
PCA11.: PUSHJ PP,PCA10.
JRST PA24.
INTER. PCA12.
PCA12.: SWOFF FNOSUB; ;[645] CLEAR "SUBSCRIPTING NOT ALLOWED" FLAG
PUSHJ PP,PA165. ;OUTPUT "YECCH"
PUSHJ PP,PA133. ;SKIP TO NEXT PERIOD
JRST PA0. ;GO POP UP A LEVEL
INTER. PCA13.
PCA13.: PUSHJ PP,PA148.
JRST PA0.
INTER. PCA14.
PCA14.: PUSHJ PP,PA135.
JRST PA22.
INTER. PCA15.
PCA15.: PUSHJ PP,PCA5.
HRRZ TA,W1 ;GET FILTAB LINK
PUSHJ PP,LNKSET
LDB TB,FI.DSD ;LOOK FOR SORT FLAG
JUMPN TB,PA22. ;OK
EWARNW E.44 ;NOT A SORT FILE
JRST PA22.
INTER. PCA16.
PCA16.: PUSHJ PP,PA148.
JRST PA0.
INTER. PCA17.
PCA17.: PUSHJ PP,PA2.
JRST PA150.
INTER. PCA18.
PCA18.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA150.
JRST PA152.
INTER. PCA19.
PCA19.: PUSHJ PP,PA2.
SKPNAM
INTER. PCA10.
PCA10.: PUSHJ PP,PA21.
PUSHJ PP,PA22.
JRST PA0.
IFN ANS74,<
INTER. PCA19A
PCA19A: PUSHJ PP,PA2.
MOVE TA,ARG1 ;GETSRC W1
TLNE TA,GWSIGN!GWDP ;TEST FOR SIGN AND POINT
EWARNW E.702 ;TOO BAD
PUSHJ PP,PA21.
PUSHJ PP,PA22.
JRST PA0.
>
INTER. PCA21.
PCA21.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA154.
JRST PA152.
INTER. PCA22.
PCA22.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA155.
JRST PA152.
INTER. PCA23.
PCA23.: PUSHJ PP,PA47.
PUSHJ PP,PA2.
JRST PA155.
INTER. PCA26.
PCA26.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA156.
JRST PA152.
INTER. PCA27.
PCA27.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA157.
JRST PA152.
INTER. PCA28.
PCA28.: PUSHJ PP,PA47.
PUSHJ PP,PA2.
JRST PA157.
INTER. PCA29.
PCA29.: PUSHJ PP,PA159.
JRST PA21.
INTER. PCA30.
PCA30.: PUSHJ PP,PA163.
JRST PA150.
INTER. PCA31.
PCA31.: PUSHJ PP,PA47.
PUSHJ PP,PA163.
JRST PA155.
INTER. PCA32.
PCA32.: PUSHJ PP,PA47.
PUSHJ PP,PA163.
JRST PA157.
INTER. PCA33.
PCA33.: PUSHJ PP,PA2.
JRST PA164.
INTER. PCA34.
PCA34.: PUSHJ PP,PA2.
PUSHJ PP,PA21.
JRST PA38.
INTER. PCA36.
PCA36.: PUSHJ PP,PA24.
PUSHJ PP,PA139.
JRST PA0.
INTER. PCA37.
PCA37.: PUSHJ PP,PA22.
JRST PA34.
INTER. PCA38.
PCA38.: PUSHJ PP,PA21.
JRST PA166.
INTER. PCA39.
PCA39.: PUSHJ PP,PA73.
JRST PA22.
INTER. PCA40.
PCA40.: PUSHJ PP,PA34.
JRST PA36.
INTER. PCA41.
PCA41.: PUSHJ PP,PA34.
PUSHJ PP,PA22.
JRST PA0.
INTER. PCA42.
PCA42.: PUSHJ PP,PA2.
JRST PA171.
INTER. PCA44.
PCA44.: PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA47.
JRST PA21.
INTER. PCA45.
PCA45.: PUSHJ PP,PA95.
JRST PA21.
INTER. PCA46.
PCA46.: PUSHJ PP,PA24.
PUSHJ PP,PA26.
PUSHJ PP,DE125.
JRST PA0.
INTER. PCA47.
PCA47.: PUSHJ PP,PA50.
JRST PA2.
INTER. PCA51.
PCA51.: PUSHJ PP,PA173.
JRST PA0.
IFN ANS68,<
INTER. PCA52.
PCA52.: PUSHJ PP,PA12.
JRST PA13.
INTER. PCA53.
PCA53.: PUSHJ PP,PA16.
JRST PA15.
>
INTER. PCA54.
PCA54.: PUSHJ PP,PA22.
JRST PA81.
INTER. PCA55.
PCA55.: PUSHJ PP,PA175.
JRST PA22.
INTER. PCA56.
PCA56.: PUSHJ PP,PA22.
JRST PA90.
INTER. PCA59.
PCA59.: PUSHJ PP,PA132.
JRST PA0.
INTER. PCA60.
PCA60.: PUSHJ PP,PA37.
PUSHJ PP,PA148.
JRST PA0.
INTER. PCA61.
PCA61.: PUSHJ PP,PA37.
PUSHJ PP,PA24.
PUSH PP,TD ;[670] GET AN AC
MOVEI TD,PRIOD. ;[670] LOAD TOKEN FLAG FOR PERIOD (.)
CAME TD,PRVTOK## ;[670] WAS PREV TOKEN A PERIOD?
JRST PCA61M ;[670] NO
MOVE TD,IFLVL ;[670] LOAD CURR NO OF LEVELS OF "IF"
JUMPLE TD,PCA61M ;[670] JUMP IF NO LEVELS OUTSTANDING
PCA61J: POP NODPTR,NODE ;[670] UNWIND TWO LEVELS OF NODES FOR
POP NODPTR,NODE ;[670] FOR EACH LEVEL OF "IF"
PUSHJ PP,PA37. ;[707] MAYBE OUTPUT FALSE-TAG
SKIPLE IFLVL ;[707] REACHED THE BOTTOM YET?
JRST PCA61J ;[670] NO
PCA61M: POP PP,TD ;[670] YES, RESTORE AC
JRST PA0.
INTER. PCA62.
PCA62.: PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
JRST PA160.
INTER. PCA63.
PCA63.: PUSHJ PP,PA73.
PUSHJ PP,PA21.
JRST PA22.
INTER. PCA64.
PCA64.: PUSHJ PP,PA22.
PUSHJ PP,PA21.
JRST PA34.
INTER. PCA65.
PCA65.: PUSHJ PP,PA21.
PUSHJ PP,PA22.
JRST PA34.
INTER. PCA66.
PCA66.: PUSHJ PP,PA22.
JRST PA168.
INTER. PCA67.
PCA67.: PUSHJ PP,PA47.
JRST PA202.
INTER. PCA68.
PCA68.: PUSHJ PP,PA2.
PUSHJ PP,PA215.
PUSHJ PP,PA21.
JRST PA22.
INTER. PCA69.
PCA69.: SWOFF FGTPER!FREGWD ;
PUSHJ PP,PA1. ;[665] INITIALIZE
PUSHJ PP,PA258. ;[665] SET UP PROCEDURE DIVISION ENTRY
JRST PCA25. ;[665] OUTPUT THE OPERATOR
INTER. PCA70.
PCA70.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA224.
JRST PA152.
INTER. PCA71.
PCA71.: PUSHJ PP,PA2.
JRST PA224.
IFN SERCH,<
INTER. PCA72.
PCA72.: HRRZI TA,72 ;EXPR OP CODE
PUSHJ PP,SETOP
PUSHJ PP,PA22.
JRST PA2.
INTER. PCA73.
PCA73.: PUSHJ PP,PA21.
HRRZI TA,73 ;ENDEXP OP CODE
PUSHJ PP,SETOP
JRST PA22.
>
;ITEM DECLARED IN ENTRY OR PD USING CLAUSE
INTER. PCA74.
PCA74.: PUSHJ PP,PA2.
JRST PA264.
INTER. PCA75.
PCA75.: PUSHJ PP,PA21. ;OUTPUT OPERAND
JRST PA0. ;POP TO PREVIOUS NODE
; CHECK TO SEE IF RECORD IS IN A SORT FILE [257]
; AND INSERT RECORD OPERANDS INTO GENFIL , EVEN IF ERROR
INTERN. PCA80.
PCA80.: PUSHJ PP,PCA83. ; [276] SEE IF RECORD LEVEL
MOVEI DW,E.206 ; [257] SET UP NOT RECORD ERROR CODE
PUSHJ PP,FNDFIL ; [257] GET CORR FILE FOR THIS RECORD
JRST PCA80B ; [257] NOT A RECORD ERROR
LDB TB,FI.DSD ; [257] IS RECORD IN SORT FILE
PCA80A: MOVEI DW,E.488 ; [257] NOT IN SORT FILE ERROR CODE
SKIPN TB ; [257]
PUSHJ PP,FATAL ; [257] GIVE ERROR
JRST PA21. ; [257] PUT OUT OPERANDS-EVEN IF ERROR ONES
PCA80B: PUSHJ PP,FATAL ; [257] GIVE ERROR
SETZ TB, ; [257] WILL FORCE NOT IN SORT FILE ERROR
JRST PCA80A ; [257] CONTINUE
; [257] SEE IF FILE IS SORT FILE
INTER. PCA81.
PCA81.: PUSHJ PP,PCA5. ; [257] SET UP ARG1 AND OPERAND
HRRZ TA,W1 ; [257] GET FILTAB LINK
PUSHJ PP,LNKSET ; [257]
LDB TB,FI.DSD ; [257] IS IT A SORT FILE
JUMPN TB,CPOPJ ; [257] YES OKAY
EWARNJ E.44 ; [257] NO ILLEGAL
INTER. PCA82.
PCA82.: SETZM CLEVEL ; [313] CLEAR THE PAREN
SETZM ELEVEL ; [313] COUNTS- BECAUSE WE LOSE COUNT
JRST DE111. ; [313] GIVE ERROR MESSAGE AND RETURN
; CHECK THAT DATA NAME IS RECORD ( 01 OR 77 LEVEL).
INTER. PCA83.
PCA83.: HRRZ TA,ARG1 ; [276] GET DATAB REL LOCACTION
JUMPE TA,PCA83A ;[461] IF ARG IS ZERO TROUBLE
PUSHJ PP,LNKSET ; [276] GET REAL ADDRESS
MOVE TC,ARG1+1 ; [276] GET LINE AND CHAR POSITION
LDB LN,[POINT 13,TC,28] ; [276] EXTRACT OUT LINE
LDB CP,[POINT 7,TC,35] ; [276] EXTRACT OUT CHAR POS.
LDB TB,DA.LVL ; [276] GET LEVEL OF DATA ITEM
CAIE TB,1 ; [276] RECORD NAME IF 01
CAIN TB,^D77 ; [276] 0R 77 LEVEL
POPJ PP, ; [276] OK
MOVEI DW,E.159 ; [276] NOT AT RECORD LEVEL
JRST FATAL ; [276] FLAG ERROR AND RETURN
PCA83A: MOVEI TA,<CD.DAT>B20+1 ;[461] USE DUMMY DATA ITEM
MOVEM TA,ARG1 ;[461] SO PHASE E DOESN'T CRASH
JRST FATAL ;[461] AND GET OUT
INTER. PCA84.; ; [362]
PCA84.: SOS SPFLVL ;[532] [511] COUNT DOWN ONE MORE ADDED BY
SOSGE SPFLVL ; [362] COUNT DOWN "IF" LEVEL IN
; [362]"SEARCH" STATEMENTS
SETZM SPFLVL ; [362] ZERO MINIMUM
EWARNJ E.390 ; [362] "WHEN" EXPECTED ERROR MSG
INTER. PCA88.
PCA88.: PUSHJ PP,FNDFIL ; [455] GET FILE FOR THIS RECORD
JRST [SETZ TB, ; [455] FORCE NOT IN SORT FILE ERROR
JRST PCA88A] ; [455] CONTINUE
MOVE TC,ARG1+1 ; [455] GET LINE AND CHAR POSITION
LDB LN,[POINT 13,TC,28] ; [455] EXTRACT LINE
LDB CP,[POINT 7,TC,35] ; [455] EXTRACT CHAR POS
LDB TB,FI.DSD ; [455] IS RECORD IN SORT FILE
PCA88A: MOVEI DW,E.488 ; [455] NOT IN SORT FILE ERROR CODE
SKIPN TB ; [455]
PUSHJ PP,FATAL ; [455] GIVE ERROR
PUSHJ PP,PA21. ; [455] PUT OUT OPERANDS
JRST PA160. ; [455] CONTINUE
SUBTTL ANS-74 PROCEDURE DIVISION ACTIONS
IFN ANS74,<
;ACCEPT XXX FROM DATE.
INTER. PCA90.
PCA90.: PUSHJ PP,PA2.
HRRZ TB,ARG1 ;R. H. OF GETSRC W1
MOVE TA,ARG1+1 ;GETSRC W2
MOVE TE,TA ;W2
MOVE TD,ARG1 ;W1
TLZ TA,777774 ;LN, CP
SETZM NSBSC1
TLO TA,400000!GNLIT!GNFIGC ;SET OPERAND AND FIGURATIVE CONSTANT BITS
HLRZ TC,TD
ANDI TC,777 ;YES--GET VALUE
SETZ TE,
CAIN TC,DATE..
HRLZI TE,GNTODY!GNDATE
CAIN TC,DAY..
HRLZI TE,GNTODY!GNDAY
CAIN TC,TIME..
HRLZI TE,GNTODY!GNTIME
IOR TA,TE ;SET APPROPRIATE BITS
SETZM ARG1
SETZM ARG1+1
JRST PUTGEN ;OUTPUT ARG1
;SAVE DATA ITEM IN CASE TYPE 3 INSPECT
INTER. PCA91.
PCA91.: PUSHJ PP,PA2.
MOVEM W1,SVINSP##
MOVEM W2,SVINSP+1
POPJ PP,
;RESTORE DATA ITEM AND OP-CODE FOR INSPECT
INTER. PCA92.
PCA92.: PUSHJ PP,PA22. ;OUTPUT LAST OPERATOR
MOVE TA,SVINSO## ;EITHER "TALLYING" OR "REPLACING" ARG
PJRST SETOP ; SETUP FRESH OPERATOR
INTER. PCA92T
PCA92T: PUSHJ PP,PA22. ;OUTPUT PREVIOUS "TALLYING" OPERAND
MOVE TA,SVINSO ; GET "TALLYING" AGAIN
PUSHJ PP,SETOP ;SETUP FRESH OPERATOR
JRST PA2. ;READ DATAN
INTER. PCA92L
PCA92L: PUSHJ PP,PCA92.
JRST PA64. ;LEADING
INTER. PCA92F
PCA92F: PUSHJ PP,PCA92.
JRST PA67. ;FIRST
INTER. PCA92C
PCA92C: PUSHJ PP,PCA92.
JRST PA65. ;CHARACTER
INTER. PCA92R
PCA92R: PUSHJ PP,PCA92.
JRST PCA5. ;READ DATAN
INTER. PCA92S
PCA92S: PUSHJ PP,PCA92.
JRST PA2. ;READ DATAN
INTER. PCA92E
PCA92E: SETO TA,
DPB TA,OP.EIN## ;"LAST ARGUMENT" FOR INSPECT
JRST PCA6.
;COMPUTE SERIES
INTER. PCA93.
PCA93.: PUSHJ PP,PA191. ;COMPUTE OP-CODE
JRST PA2. ;DATAN.
;DIVIDE SERIES
INTER. PCA94.
PCA94.: PUSHJ PP,PA2.
MOVEM W1,SVDIV##
MOVEM W2,SVDIV+1
POPJ PP,
;DIVIDE INTO SERIES
INTER. PCA94I
PCA94I: PUSH PP,W1
PUSH PP,W2
PUSHJ PP,PCA64.
PUSHJ PP,PA22.
PUSHJ PP,PA57.
MOVE W1,SVDIV
MOVE W2,SVDIV+1
PUSHJ PP,PCA5.
PUSHJ PP,PA174.
POP PP,W2
POP PP,W1
JRST PA2.
>
SUBTTL ERRORS USED BY PD SYNTAX SCAN
INTER. DE111.
DE111.: TLNE W1,GWLIT!GWFIGC ;LITERAL OR FIG. CONST?
EWARNJ E.101 ;? IDENTIFIER EXPECTED
TLNN W1,GWRESV ;SKIP IF RESERVED WORD
EWARNJ E.104 ;NO, SAY "?NOT DEFINED"
SKPNAM ;ELSE "CAN NOT BE A DATA-NAME"
INTER. DE103.
DE103.: HRRZI DW,E.103 ;DIAGNOSTIC 103
LDB TA,[POINT 9,W1,17]
TLNE W1,GWRESV
CAIE TA,FILLE.
JRST WARNW##
EWARNJ E.289
INTER. DE125.
DE125.: MOVE CP,BLNKCP
MOVE LN,BLNKLN
HRRZI DW,E.125 ;DIAGNOSTIC 125
JRST WARN ;WARNING ONLY
IFE ONESEG,< END COBOLD>
IFN ONESEG,< END >