TITLE RPGCOM for RPGII %1 SUBTTL Subroutines used by all phases of RPGII ;Copyright (C) 1975, 1976 Bob Currier and Cerritos College LOC 137 XWD VERSION,EDIT TWOSEG RELOC 400000 ENTRY LSTMES ;PUT AN ASCII STRING ONTO LISTING FILE ENTRY DEVERA ;DEVICE TRANSMISSION ERROR ENTRY DEVDED ;WRITE ERROR ON SCRATCH FILE ENTRY EOTAPE ;PUT OUT MAG-TAPE EOT MESSAGE ENTRY SIXOUT ;TYPE OUT A SIXBIT WORD ENTRY OCTOUT ;OUTPUT AN OCTAL NUMBER ENTRY LNKSET ;CREATE A TABLE ADDRESS FROM TABLE-LINK ENTRY GETFAZ ;GET NEXT MACHINE LOAD OF INSTRUCTIONS ENTRY RESTRT ;RESTART COMPILATION (REENTER) ENTRY REDO ;RESTART COMPILATION (START) ENTRY KILL ;KILL COMPILATION, DUMP CORE AND FILES ENTRY KILLF ;KILL COMPILATION, DUMP FILES ONLY ENTRY UUOCAL ;UUO TRAP ENTRY FILOUT ;TYPE OUT DEV:FILE.EXT[P,P] ENTRY ERATYP ;TYPE OUT ENTER/LOOKUP FAIL MESSAGE ; Uniquely RPGII routines ; ENTRY TABSCN ;UNIVERSAL TABLE SCAN ENTRY GETENT ;GET A TABLE ENTRY ENTRY FNDLNK ;FIND NAMTAB LINK ENTRY BLNKCK ;CHECK CARD COLUMNS FOR BLANKS ENTRY GETIND ;Get an INDTAB entry ENTRY GETVAL ;GET A VALTAB ENTRY ENTRY IDNTYP ; IDENTIFY CARD TYPE ENTRY DATCLR ; CLEAR OUT DATAB ENTRY ENTRY GETFTB ; GET AN FTBTAB ENTRY ENTRY NMVRFY ; [244] verify a field name EXTERNAL REGO, GETLOD, PUTLST ;PRINT ASCII TEXT ;ENTER WITH A BYTE POINTER TO THE TEXT STRING IN "TE". PUSHJ PP,PUTLST LSTMES: ILDB CH,TE JUMPN CH,LSTMES-1 POPJ PP, ;DEVICE TRANSMISSION ERROR ;THIS ROUTINE IS ENTERED WITH RH OF "CH" POINTING TO A TABLE ; CONSISTING OF: ; WORD1: DEVICE NAME IN SIXBIT ; WORD2: FILE-NAME IN SIXBIT ; WORD3: FILE-NAME EXTENSION IN LH, IN SIXBIT ; LH OF CH CONTAINS GETSTS FLAGS WHEN DEVERA CALLED. ;A MESSAGE IS TYPED OUT ;DEVERA WAITS FOR THE OPERATOR TO TYPE "CONTINUE". ;WHEN HE DOES, THE ROUTINE RETURNS TO: ; CALL+1 IF DEVICE IS MTA ; CALL+2 IF DEVICE IS DSK OR DTA ; CALL+3 IF DEVICE IS CDR OR LPT ;IF THE DEVICE IS NOT DTA,DSK,MTA,CDR OR LPT, THIS ROUTINE DOES ; A CALL [SIXBIT /EXIT/] ;DEVDED ALWAYS CALLS [SIXBIT /EXIT/] DEVERA: PUSH PP,TE MOVE TE,(CH) ;IS IT MTA? DEVCHR TE, TLNE TE,$MTA TLNN CH,$EOT ;YES--END OF TAPE? JRST .+3 ;NO POP PP,TE ;YES--RETURN POPJ PP, POP PP,TE PUSHJ PP,DEVERB JRST DEVERC DEVDED: PUSHJ PP,DEVERB JRST DEVER2 ;TYPE OUT ERROR MESSAGE DEVERB: TTCALL 3,[ASCIZ "TRANSMISSION ERROR FOR "] DVERB1: PUSH PP,TA PUSH PP,TE MOVE TA,(CH) PUSHJ PP,SIXOUT MOVEI TD,":" TTCALL 1,TD SKIPE TA,1(CH) PUSHJ PP,SIXOUT HLLZ TA,2(CH) JUMPE TA,DVERB2 MOVEI TD,"." TTCALL 1,TD PUSHJ PP,SIXOUT DVERB2: POP PP,TE POP PP,TA TTCALL 3,[ASCIZ " "] POPJ PP, ;END OF MAG-TAPE EOTAPE: TTCALL 3,[ASCIZ "Mount another reel on "] JRST DVERB1 ;GET CHARACTERISTICS OF DEVICE DEVERC: MOVE CH,(CH) DEVCHR CH, TLNN CH,OKDEVS ;IS IT POSSIBLE TO CONTINUE? JRST DEVER2 ;NO TTCALL 3,[ASCIZ "To retry, type CONTinue "] EXIT 1, TLNN CH,$MTA ;IS IT MAG-TAPE? JRST DEVER1 ;YES--EXIT TO CALL+1 TLNN CH,$DSK!$DTA ;NO--IS IT DISK OR DEC-TAPE? AOS (PP) ;NO--EXIT TO CALL+3 AOS (PP) ;YES--EXIT TO CALL+2 DEVER1: POPJ PP, ;CANNOT CONTINUE--EXIT DEVER2: TTCALL 3,[ASCIZ "?Cannot continue "] JRST RESTRT OKDEVS=$MTA!$DTA!$LPT!$CDR!$DSK ERATYP: PUSHJ PP,FILOUT ;TYPE 'DEV:FILE.EXT[PROJ,PROG]' TTCALL 3,[ASCIZ "("] HRRZ TA,I2 PUSHJ PP,OCTOUT MOVE TA,ERAPTR ERAT1: HLRZ TB,(TA) CAIE TB,(I2) AOBJN TA,ERAT1 HRRZ TA,(TA) TTCALL 3,(TA) TSWT FDSKC; SWOFF FECOM; JRST RESTRT ERAT2: XWD 0,[ASCIZ ") No file name"] XWD 1,[ASCIZ ") Incorrect Proj-Prog no."] XWD 2,[ASCIZ ") Protection failure"] XWD 3,[ASCIZ ") File being modified"] XWD 6,[ASCIZ ") Bab UFD or bad RIB"] XWD 14,[ASCIZ ") No room, or quota exceeded"] XWD 15,[ASCIZ ") Write lock"] XWD 16,[ASCIZ ") Not enough table space in monitor"] XWD 0,[ASCIZ ") Unknown error"] ERAPTR: XWD ERAT2-.+1,ERAT2 ;TYPE OUT "DEV:FILE.EXT[PROJ,PROG]"" FILOUT: MOVE TA,DEVDEV(DA) ;TYPE OUT DEVICE NAME PUSHJ PP,SIXOUT MOVEI CH,":" TTCALL 1,CH SKIPE TA,DEVFIL(DA) ;ANY FILE NAME? PUSHJ PP,SIXOUT ;YES--TYPE IT OUT SKIPN TA,DEVEXT(DA) ;ANY EXTENSION? JRST FILO1 ;NO MOVEI CH,"." ;YES--TYPE IT OUT TTCALL 1,CH PUSHJ PP,SIXOUT FILO1: SKIPN TA,DEVPP(DA) ;ANY PROJ-PROG #? JRST FILO2 ;NO MOVEI CH,"[" ;YES--TYPE IT OUT TTCALL 1,CH HLRZ TA,DEVPP(DA) PUSHJ PP,OCTOUT MOVEI CH,"," TTCALL 1,CH HRRZ TA,DEVPP(DA) PUSHJ PP,OCTOUT MOVEI CH,"]" TTCALL 1,CH FILO2: TTCALL 3,[ASCIZ " "] POPJ PP, ;TYPE OUT THE OCTAL NUMBER IN RH OF "TA" OCTOUT: MOVE TB,[POINT 3,TA,17] ILDB CH,TB TLNE TB,770000 JUMPE CH,.-2 OCTO1: ADDI CH,"0" TTCALL 1,CH TLNN TB,770000 POPJ PP, ILDB CH,TB JRST OCTO1 ;PUT OUT A SIXBIT WORD ONTO TTY SIXOUT: MOVE TE,[POINT 6,TA] SIXO1: ILDB TD,TE JUMPE TD,SIXEND ADDI TD,40 TTCALL 1,TD TLNE TE,770000 JRST SIXO1 SIXEND: POPJ PP, ;PUT MESSAGE ONTO THE LISTING ENTRY DBMESS DBMESS: MOVEI CH,440700 HRLM CH,(PP) JRST DBMES2 DBMES1: PUSHJ PP,PUTLST DBMES2: ILDB CH,(PP) JUMPN CH,DBMES1 AOS (PP) POPJ PP, ;SET UP A TABLE ADDRESS ;ENTER WITH TABLE-LINK IN "TA" ; BITS 18-20 = TABLE TYPE, BITS 21-35 = RELATIVE ADDRESS ;EXIT WITH ADDRESS IN "TA" LNKSET: LDB TE,[POINT 3,TA,20] ANDI TA,77777 ; JUMPE TA,BADLNK ADD TA,@LNKTAB(TE) MOVE TE,LNKTAB(TE) HRRZ TE,1(TE) CAIL TE,-1(TA) POPJ PP, ;IMPROPER LINK TYPE BADLNK: TTCALL 3,[ASCIZ "Bad table-link at "] SOS (PP) MOVE TE,[POINT 3,(PP),17] BADL1: ILDB CH,TE ADDI CH,"0" TTCALL 1,CH TLNE TE,770000 JRST BADL1 TTCALL 3,[ASCIZ " "] JRST KILL ;TABLE OF ADDRESSES OF POINTERS LNKTAB: EXP FILLOC EXP DATLOC EXP LITLOC EXP VALLOC EXP PROLOC EXP EXTLOC EXP ICHLOC EXP INDLOC ;RESTART DUE TO "START" CONSOLE COMMAND REDO: MOVEI SW,0 ;RESTART DUE TO "REENTER" CONSOLE COMMAND RESTRT: TSWF FECOM; ;ANY MORE COMMANDS? EXIT ;NO - QUIT MOVEI TA,REGO+2 AND SW,[EXP FDSKC] ;TURN OFF ALL FLAGS EXCEPT FDSKC IFE ONESEG,< MOVE TB,PHASEN ;ARE WE IN FIRST MACHINE LOAD? CAIG TB,MLOAD1 JRST (TA) ;YES--NO NEED TO LOAD IT MOVE TB,[SIXBIT "RPGII "] MOVEM TB,GETFNM+1 JRST GETFZ1 GETFAZ: MOVEM TA,GETFNM+1 MOVEI TA,REGO GETFZ1: MOVEM TA,GETFST JRST GETLOD > IFN ONESEG,< JRST RPGIIA##+2 GETFAZ: MSG JRST KILL > ;IF THIS ROUTINE IS ENTERED AT "KILL", THE FOLLOWING OCCURS: ; 1) AC'S SAVED ; 2) ALL DEVICES RELEASED ; 3) CORE DUMP OF THE IMPURE AREA TAKEN ; 4) ALL SCRATCH FILES DUMPED ;IF THIS ROUTINE IS ENTERED AT "KILLF", THE FOLLOWING OCCURS ; 1) ALL DEVICES RELEASED ; 2) ALL SCRATCH FILES DUMPED KILL: MOVEM 17,KILLAC+17 ;SAVE AC'S MOVEI 17,KILLAC BLT 17,KILLAC+16 JSP TB,SETUP IFE ONESEG,< ; [264] MOVEI TE,REGO > ; [264] IFN ONESEG,< ; [264] MOVEI TE,RPGIIK## ; [264] > ; [264] JRST KILLCALL KILLF: JSP TB,SETUP IFE ONESEG,< ; [264] MOVEI TE,REGO+2 > ; [264] IFN ONESEG,< ; [264] MOVEI TE,RPGIIK+2 ; [264] > ; [264] KILLCALL: IFE ONESEG,< MOVE TB,[SIXBIT "RPGIIK"] MOVEM TB,GETFNM+1 MOVEM TE,GETFST JRST GETLOD > IFN ONESEG,< JRST (TE) > SETUP: SKIPE TA,TOPLOC MOVEM TA,.JBFF## MOVSI TA,71000 ;RELEASE ALL DEVICES KILL1: XCT TA ADD TA,[1B12] CAME TA,[XWD 71740,0] JRST KILL1 MOVE 0,PHASEN ;SAVE PHASE NUMBER FOR RPGIIK JRST (TB) ;HANDLE UUO TRAPS UUOCAL: MOVEM TE,KILLAC+1 ;SAVE TE LDB TE,[POINT 9,.JBUUO##,8]; GET OP-CODE OF UUO CAILE TE,HIUUO ;ONE WE RECOGNIZE? JRST UUOC1 ;NO--ERROR PUSHJ PP,@UUOTAB(TE) ;YES--EXECUTE A ROUTINE MOVE TE,KILLAC+1 ;RESTORE TE POPJ PP, UUOC1: MOVEM CH,KILLAC ;SAVE CH TTCALL 3,[ASCIZ "Illegal UUO at location "] SOS (PP) MOVE TE,[POINT 3,(PP),17] UUOC2: ILDB CH,TE ADDI CH,"0" TTCALL 1,CH TLNE TE,770000 JRST UUOC2 TTCALL 3,[ASCIZ " "] MOVE TE,KILLAC+1 MOVE CH,KILLAC JRST KILL UUOTAB: EXP UUOC1 ;0 EXP UUO1 ;1 - WARNING DIAG HIUUO==.-UUOTAB-1 ;HIGHEST LEGAL UUO UUO1: HRRZ DW,.JBUUO JRST WARNW ;UNIVERSAL TABLE SCAN ; ;ENTER WITH ADDRESS OF TABLE IN TC, ITEM TO BE SEARCHED FOR IN CH. ;EXIT WITH TABLE INDEX IN TB. ; ;CALL: PUSHJ 17,TABSCN ; (ITEM NOT FOUND) ; (ITEM FOUND) ; TABSCN: SETZ TB, ; ZAP INDEX TBSCN1: MOVE TD,(TC) JUMPE TD,TBSCN2 AOJ TC, ; BUMP POINTER CAME CH,TD ; DID WE FIND IT? AOJA TB,TBSCN1 ; NO - BUMP INDEX AND LOOP AOS (PP) ; INCREMENT RETURN TBSCN2: POPJ PP, ; RETURN ;GET A TABLE ENTRY ; ;THIS ROUTINE IS USED WHEN A NEW ENTRY IN A TABLE IS NEEDED. ; ;ENTER WITH TABLE CODE IN LH OF TA, TABLE SIZE IN RH ;RETURN WITH POINTER TO TABLE ENTRY IN TA. ; GETENT: HLRZ TB,TA ; EXTRACT TABLE CODE CAIL TB,HINXT ; COMPARE TO SEE IF VALID JRST GETEN3 ; IT'S NOT - TELL SOMEONE GETEN1: HRRZ TC,TA ; EXTRACT SIZE OF TABLE HRL TC,TC ; AND LOAD INTO BOTH HALVES ADD TC,@GENTB1(TB) ; SEE IF WE HAVE ENOUGH ROOM HLRE TD,TC ; GET LEFT HALF OF TC JUMPGE TD,GETEN2 ; JUMP IF WE RAN OUT OF ROOM HRRZ TA,@GENTB1(TB) ; GET LOC FOR RETURN MOVEM TC,@GENTB1(TB) ; RESTORE xxxNXT POPJ PP, GETEN2: PUSHJ PP,@GENTB2(TB) ; EXPAND APPROPRIATE TABLE JRST GETEN1 ; TRY AGAIN GETEN3: OUTSTR [ASCIZ "BAD INDEX IN GETENT AT "] JRST BADLNK+1 ; TYPE OUT TOP OF PPLIST ;TABLE OF POINTERS TO FIRST FREE TABLE LOC GENTB1: EXP FILNXT EXP DATNXT EXP LITNXT EXP VALNXT EXP PRONXT EXP EXTNXT EXP ICHNXT EXP INDNXT EXP OTFNXT EXP OCHNXT HINXT=.-GENTB1 ;TABLE OF POINTERS TO EXPANSION ROUTINES GENTB2: EXP XPNFIL EXP XPNDAT EXP XPNLIT EXP XPNVAL EXP XPNPRO EXP XPNEXT EXP XPNICH EXP XPNIND EXP XPNOTF EXP XPNOCH ;Get an INDTAB entry ; ;This routine get a one word entry from INDTAB. ; ;Pointer is left in TA. ; GETIND: MOVE TA,INDNXT## AOBJP TA,GETIN0 ; INCREMENT BOTH HALVES MOVEM TA,INDNXT ; RESTORE INDNXT ANDI TA,777777 ; GET THE GOOD PART MOVEM TA,CURIND## ; STORE CURRENT POINTER FOR OTHER FOLKS POPJ PP, ; AND EXIT GETIN0: PUSHJ PP,XPNIND## ; EXPAND INDtab JRST GETIND ;GET AN VALTAB ENTRY ; ;THIS ROUTINE GET A ONE WORD ENTRY FROM INDTAB ; ;POINTER IS LEFT IN TA, CURVAL IS UPDATED ; GETVAL: MOVE TA,VALNXT## ; GET VALUE OF NEXT ENTRY AOBJP TA,GETVL0 ; INCREMENT, GO EXPAND TABLE IF NECESSARY MOVEM TA,VALNXT ; REPLACE VALUE ANDI TA,777777 ; GIVE A MORE USEABLE VALUE MOVEM TA,CURVAL## ; STORE FOR LATER GENERATIONS POPJ PP, ; RETURN GETVL0: PUSHJ PP,XPNVAL## ; EXPAND TABLE JRST GETVAL ; GO TRY AGAIN ;GET AN FTBTAB ENTRY ; ;THIS ROUTINE GETS ONE FTBTAB ENTRY AND RETURNS THE POINTER IN TA ; ; GETFTB: MOVE TC,[XWD SZ.FTB,SZ.FTB] ; GET THAT SIZE ADD TC,FTBNXT## ; ADD TO BOTH HALVES HLRE TD,TC ; GET LEFT HALF JUMPGE TD,GETFT1 ; JUMP IF NO ROOM HRRZ TA,FTBNXT ; ELSE GET POINTER MOVEM TC,FTBNXT ; UPDATE POINTER POPJ PP, ; AND EXIT GETFT1: PUSHJ PP,XPNFTB## ; EXPAND THAT TABLE JRST GETFTB ; AND TRY AGAIN ; ;IDNTYP IDENTIFY CARD TYPE ; ;EXPECTS FRMTYP TO BE IN TB, DESTROYS CH,TC ; ;RET+2 IF NOT IDENTIFIABLE ; IDNTYP: MOVE CH,TB ; SET UP FOR TABLE SEARCH PUSH PP,TB ; SAVE TB FOR LATER MOVEI TC,TYPTAB ; GET TABLE ADDR PUSHJ PP,TABSCN ; SCAN THE TABLE TRNA ; NOT FOUND JRST IDN.01 ; POP THEN EXIT LDB CH,[POINT 14,CRDBUF,13] ; get first 2 characters CAIN CH,"**" ; double star? JRST IDN.01 ; yes - ok POP PP,TB ; RESTORE TB AOS (PP) ; [012] INCREMENT RETURN AT PROPER TIME SOSE BADCNT## ; WE HIT JACKPOT YET? POPJ PP, ; NO - KEEP ON TRYING OUTSTR [ASCIZ " %Over 100 unrecognizable cards found %Are you sure you have an RPGII program? "] POPJ PP, ; YES - GIVE ERROR RETURN IDN.01: POP PP,TB ; RESTORE TB POPJ PP, ; AND EXIT TYPTAB: "H" ; HEADER "F" ; FILE SPECIFICATIONS "E" ; EXTENSION SPECS "L" ; LINE COUNTER SPECS "I" ; INPUT SPECS "C" ; CALCULATION SPECS "O" ; OUTPUT SPECS Z ; END OF TABLE ;DATCLR CLEAR OUT A DATAB ENTRY ; ; ;THIS ROUTINE IS CALLED WHEN DATAB HAS BEEN EXPANDED AND THEREFORE ;HAS GARBAGE THAT NEEDS TAKING OUT ; DATCLR: MOVEM TE,SAVEAC ; SAVE AN AC HRLZ TE,TA ; GET SOURCE POINTER HRRI TE,1(TA) ; GET DESTINATION SETZM (TA) ; ZAP THE FIRST WORD BLT TE,SZ.DAT(TA) ; AND BLIT AWAY THAT NAGGING GARBAGE MOVE TE,SAVEAC ; RESTORE TE POPJ PP, ; AND LEAVE NO FORWARDING ADDRESS ;CHECK CARD COLUMNS FOR SPACES (BLANKS) ; ;ENTER WITH BYTE POINTER TO FIRST COLUMN - 1 IN TB, COLUMN COUNT IN TB. ;RETURN IS +1 IF ALL COLUMNS SCANNED ARE BLANK. ; BLNKCK: ILDB CH,TB ; GET A COLUMN CAIE CH," " ; IS IT A BLANK? POPJ PP, ; NO - SOJN TC,BLNKCK ; NO - DECREMENT COUNT AND LOOP IF NOT ZERO AOS (PP) ; ALL DONE - INCREMENT RETURN POPJ PP, ; AND RETURN ;FIND A NAMTAB LINK ; ;THIS ROUTINE SEARCHES THE APPROPRIATE TABLE FOR A NAMTAB LINK. ; ;ENTER WITH TABLE CODE IN TB, NAMTAB LINK IN TA. EXIT WITH NAMTAB LINK ;IN TA, AND APPROPRIATE TABLE POINTER IN TB. NORMAL EXIT+1, ELSE JUST EXIT ;IF NAMTAB ENTRY NOT FOUND. ; FNDLNK: MOVE TE,TA ; STORE NAMTAB LINK HRRZ TC,TA ; STORE HALF WE WANT CAIL TB,HINXT ; SEE IF TABLE CODE IS VALID JRST FNDLK2 ; IT'S NOT HRRZ TA,@LNKTAB(TB) ; GET START OF TABLE FNDLK0: LDB TD,@LNKTB2(TB) ; GET NAMTAB LINK CAMN TD,TC ; COMPARE TO ONE WE ARE SEARCHING FOR JRST FNDLK1 ; FOUND IT! ADD TA,LNKTB3(TB) ; NO - GET ANOTHER ENTRY HRRZ TD,@GENTB1(TB) ; GET END OF TABLE CAMGE TA,TD ; [054] SEE IF WE HAVE HIT IT YET JRST FNDLK0 ; NO HAVEN'T GOT THERE YET - LOOP MOVE TA,TE ; [070] RESTORE NAMTAB POINTER POPJ PP, ; ENTRY NO FOUND FNDLK1: MOVE TB,TA ; SET TB TO LINK MOVE TA,TE ; RESTORE TA AOS (PP) ; INCREMENT RETURN POPJ PP, ; AND RETURN FNDLK2: OUTSTR [ASCIZ /Bad table index in FNDLNK at /] JRST BADLNK+1 ;TABLE OF NAMTAB LINKS LNKTB2: FI.NAM DA.NAM Z Z PR.NAM## EX.NAM Z Z Z Z ;TABLE OF TABLE ENTRY SIZES LNKTB3: SZ.FIL SZ.DAT SZ.LIT SZ.VAL SZ.PRO SZ.EXT SZ.ICH SZ.IND SZ.OTF SZ.OCH ;NMVRFY Routine to verify the validity of a field name ; ;Valid fields are defined as any combination of six or less letters and ;digits, starting with a letter, and having no imbedded blanks. One ;special case exists in the form of a comma; this character usually means ;that we are handleing an array entry. When a comma is found, checking is ;terminated, and the successfull (+1) return is taken. It is up to other ;routines to verify the index. ; ;This routine added as part of edit [244] ; NMVRFY: LDB CH,[POINT 6,NAMWRD##,5] ; get first character CAIL CH,'A' ; check for valid letter CAILE CH,'Z' ; POPJ PP, ; error return - not letter MOVE TB,[POINT 6,NAMWRD,5] ; check rest of word NMVR.1: ILDB CH,TB ; get next character JUMPE CH,NMVR.2 ; jump if blank CAIN CH,',' ; special case? JRST CPOPJ1 ; yes - take valid return CAIG CH,'Z' ; check for between 0 and Z CAIGE CH,'0' ; POPJ PP, ; isn't - take error return CAILE CH,'9' ; between 9 and A? CAIL CH,'A' ; TRNA ; no - OK CPOPJ:: POPJ PP, ; yes - take error return TLNE TB,770000 ; all done? JRST NMVR.1 ; no - CPOPJ1::AOS (PP) ; yes - take valid return POPJ PP, ; and exit NMVR.2: TLNN TB,770000 ; all done? JRST CPOPJ1 ; yes - take valid return ILDB CH,TB ; No - get another character JUMPE CH,NMVR.2 ; loop if space POPJ PP, ; else take error return ;HANDLE WARNING DIAGNOSTICS ; ;THIS ROUTINE DOES NOT DISTURB AC's TA,TB,TC,TD,LN ;IT DOES DISTURB CH,DW,TE ; WARNW: MOVEM TC,SAVEAC## MOVE TC,PHASEN## SUBI TC,"A"-1 DPB TC,[POINT 7,DW,25] MOVE TC,SAVELN ; GET LINE NUMBER SUBI TC,2 ; MAKE POINT TO CORRECT LINE DPB TC,[POINT 12,DW,14] ; STORE IN ERROR WORD PUSHJ PP,PUTERA## IFN DEBUG,< OUTSTR [ASCIZ /Diagnostic generated at /] POP PP,TC SOS (PP) MOVE TE,[POINT 3,(PP),17] WARN2: ILDB CH,TE ADDI CH,"0" OUTCHR CH TLNE TE,770000 JRST WARN2 OUTSTR [ASCIZ / /] AOS (PP) PUSH PP,TC > MOVE TC,SAVEAC POPJ PP, $LF==12 ;LINE-FEED $CR==15 ;CARRIAGE-RETURN $EOF==32;END OF FILE EXTERNAL KILLAC,INDLOC EXTERNAL DEVDEV,DEVFIL,DEVEXT,DEVPP EXTERNAL LITLOC,FILLOC,DATLOC,EXTLOC,VALLOC,OCHLOC,ICHLOC,PROLOC EXTERNAL LITNXT,FILNXT,DATNXT,EXTNXT,VALNXT,OCHNXT,ICHNXT,PRONXT EXTERNAL OTFNXT,PRONXT,XPNOTF,XPNPRO EXTERNAL XPNLIT,XPNFIL,XPNDAT,XPNEXT,XPNVAL,XPNOCH,XPNICH EXTERNAL FI.NAM,DA.NAM,EX.NAM EXTERNAL GETFNM, PHASEN, GETFST, MLOAD1,TOPLOC,SAVELN,CRDBUF IFN DEBUG,< PATCH:: BLOCK 200 ;PATCHING AREA > END