Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-06 - decus/20-153/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