Trailing-Edge
-
PDP-10 Archives
-
decuslib10-10
-
43,50517/rpgcom.mac
There is 1 other file named rpgcom.mac in the archive. Click here to see a list.
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 <?Entered GETFAZ in a one-segment compiler
>
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