Google
 

Trailing-Edge - PDP-10 Archives - LCG_Integration_Tools_Clearinghouse_T20_v7_30Apr86 - tools/isacon/vag002.cbl
There are 5 other files named vag002.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
*=======================
 
Program-Id.	VAG002.
 
Author.	KATHY MCKENDRY
 
Date-Written.	October 12, 1984.
 
Date-Compiled.
 
Installation.	PAPER FREE SYSTEMS INC.
*-------------
*Program Title:
*-------------
*
*	System: ISACON	DEC to VAX Conversion System
*	Module: VAG002	Application Module (Program) Generator
*
*
*-------------------
*Program Description:
*-------------------
*
*	VAG002 is a macro expander for a finite state machine.

*	It uses the output of VAG001 to build an internal symbol table,

*	and then, using a skeleton file as a driver, produces much

*	of the COBOL source code.
*
*----------------------------
*Program Modification History:
*----------------------------
*	--Date--   Who	What
*
*----------------------------------------------------------------------
ENVIRONMENT DIVISION.
*====================

CONFIGURATION SECTION.
*---------------------

SOURCE-COMPUTER.	DECSYSTEM-10.

OBJECT-COMPUTER.	DECSYSTEM-10.


INPUT-OUTPUT SECTION.
*--------------------

FILE-CONTROL.

select			FILE-LANGUAGE-FILE
	assign to	DSK
	file status is	FL-FS-STATUS
			FL-FS-ERROR-NO
			FL-FS-ACTION-CODE
			FL-FS-FILE-SPEC
			FL-FS-BLOCK-NO
			FL-FS-RECORD-NO
			FL-FS-FILE-NAME
			FL-FS-TABLE-POINTER
	recording mode	ASCII.

Select			SKELETON-FILE
	assign to	DSK
	file status is	SKL-FS-STATUS
			SKL-FS-ERROR-NO
			SKL-FS-ACTION-CODE
			SKL-FS-FILE-SPEC
			SKL-FS-BLOCK-NO
			SKL-FS-RECORD-NO
			SKL-FS-FILE-NAME
			SKL-FS-TABLE-POINTER
	recording mode	ASCII.

select			RECURS-FILE
	assign to 	DSK
	recording mode	ASCII.

select			SOURCE-CODE-FILE
	assign to 	DSK
	recording mode	ASCII.
DATA DIVISION.
*=============

FILE SECTION.
*------------

fd			FILE-LANGUAGE-FILE
	value of id	FILE-LANGUAGE-FILE-ID.

01	FILE-LANGUAGE-RECORD		display-7.
	02  FLR-NUM-TEST		pic  X(005).
	02  filler			pic  X(001).
	02  FLR-BODY			pic  X(369).

01	FILE-LANGUAGE-WORK-REC	display-7.
	02  FILE-LANGUAGE-WORK	pic  X(001)	occurs 375.

fd			SKELETON-FILE
	value of id	SKELETON-FILE-ID.

01	SKELETON-RECORD			display-7.
	02  SKELETON-LINE-NUMBER.
	    04  FIRST-SKELETON-CHAR	pic  X(001).
		88 COMMAND-LINE			value '/'.
	    04  filler			pic  X(004).
	02  filler			pic  X(001).
	02  SKELETON-BODY		pic  X(099).
*
fd			SOURCE-CODE-FILE
	value of id	SOURCE-CODE-FILE-ID.

01	SOURCE-CODE-RECORD		display-7.
	02  SOURCE-CODE-CHAR		pic  X(001)	occurs 105.
01	SOURCE-CODE-2			DISPLAY-7.
	02  SOURCE-CODE-VAR		PIC X(001)	OCCURS 1 TO 105
					DEPENDING ON	VAR-IDX.

fd			RECURS-FILE
	value of id	'RECURSTMP'.

01	RECURS-RECORD			pic  X(105)	display-7.
WORKING-STORAGE SECTION.
*=======================

*=============================================================
*	S Y M B O L    T A B L E
*=============================================================

*-------------------
* Module Information
*-------------------

01	MODULE-DATA		display-7.
	02  FILNM		pic  X(10).
	02  MODTL		pic  X(40).
	02  ACCES		pic  X(10).
	02  filler		pic  X(05).
	02  ASIGN		PIC  X(30).
	02  ORG			PIC  X(10).
	02  MKEY		PIC  X(30).
	02  MMODE		PIC  X(10).
	02  MBLCK		PIC  X(04).
	02  MODNM		PIC  X(10).
	02  RECNM		PIC  X(30).

*------------------
* Image Information
*---------------

01	IMAGE-INFO		DISPLAY-7.
    02	IMAGE-DATA		OCCURS 15 TIMES
				indexed by IMAGE-DATA-INDEX.
	04  filler		pic  X(02).
	04  ITYPE		pic  X(10).
	04  NOITM		pic  X(04).
	04  filler		pic  X(01).
	04  IDATA		PIC X(105).

*------------------
* Field Information
*------------------

01	FIELD-INFO.
    02  FIELD-DATA		occurs 300 times
				indexed by FIELD-DATA-INDEX.
	04  FLDIX		PIC  9(03).
	04  FIELD		pic  X(30).
	04  PICT		pic  X(40).
	04  DPICT		pic  X(20).
	04  PPICT		pic  X(20).
	04  FLDNO		pic  X(02).
	04  filler		pic  X(02).
	04  REDEF		PIC  X(30).
	04  ISRDF		PIC  X(03).
	04  USIGE		PIC  X(15).
	04  FSIGN		PIC  X(10).
	04  FSEP		PIC  X(10).
	04  FOCUR		PIC  X(04).
	04  FTO			PIC  X(04).
	04  OLVL1		PIC  X(04).
	04  OLVL2		PIC  X(04).
	04  OLVL3		PIC  X(04).
	04  DEPND		PIC  X(30).
	04  ASCND		PIC  X(30).
	04  DSCND		PIC  X(30).
	04  INDXD		PIC  X(30).
	04  INDX1		PIC  X(30).
	04  INDX2		PIC  X(30).
	04  INDX3		PIC  X(30).
	04  FSYNC		PIC  X(05).
	04  FJUST		PIC  X(05).
	04  FBLNK		PIC  X(04).
	04  FVALU		PIC  X(30).
	04  FDLMT		PIC  X(01).
	04  FDATA		PIC X(105).
	04  FDTA2		PIC X(105).

*========== E N D    O F    S Y M B O L    T A B L E==========


*=============================================================
*	S Y M B O L    T A B L E    W S
*=============================================================

01	FL-MAX-INDICES.
	02  IMAGE-DATA-MAX-INDEX	usage index.
	02  FIELD-DATA-MAX-INDEX	usage index.

01	FL-KEY-WORD			pic  X(12).
	88  MODULE-KEY-WORD	value 'MODULE'.
	88  IMAGE-KEY-WORD	value 'IMAGE'.
	88  FIELD-KEY-WORD	value 'FIELD'.

01	FL-TOKEN			display-7
					pic X(105).
01	filler redefines FL-TOKEN	display-7.
	02  FL-TOKEN-1			pic  X(01).
	02  filler			pic X(104).
01	filler redefines FL-TOKEN	display-7.
	02  FL-TOKEN-2			pic  X(02).
	02  filler			pic X(103).
01	filler redefines FL-TOKEN	display-7.
	02  FL-TOKEN-3			pic  X(03).
	02  filler			pic X(102).
01	filler redefines FL-TOKEN	display-7.
	02  FL-TOKEN-4			pic  X(04).
	02  filler			pic X(101).
01	filler redefines FL-TOKEN	display-7.
	02  FL-TOKEN-5.
	    04	filler			pic  X(03).
	    04	FL-TOKEN-5-2		pic  X(02).
	02  filler			pic X(100).
01	filler redefines FL-TOKEN	display-7.
	02  FL-TOKEN-10			pic  X(10).
	02  filler			pic  X(95).
01	filler redefines FL-TOKEN	display-7.
	02  FL-TOKEN-15			pic  X(15).
	02  filler			pic  X(90).
01	filler redefines FL-TOKEN	display-7.
	02  FL-TOKEN-20			PIC  X(20).
	02  filler			pic  X(85).
01	filler redefines FL-TOKEN	display-7.
	02  FL-TOKEN-30			pic  X(30).
	02  filler			pic  X(75).
01	filler redefines FL-TOKEN	display-7.
	02  FL-TOKEN-40			pic  X(40).
	02  filler			pic  X(65).
01	FL-TOKEN-ARRAY redefines FL-TOKEN display-7
					occurs 105
					indexed by FL-TOKEN-INDEX
					pic  X(01).
01	FL-TOKEN-30-6			PIC  X(30).

01	FL-POINTERS.
	02  FILE-LANGUAGE-PTR		pic S9(03) comp.

01	FL-STATE-SWITCHES.
	02  FILE-LANGUAGE-END-SW	pic  S9(01) comp.
	    88 FILE-LANGUAGE-END value 1.

01	FILE-LANGUAGE-FILE-CONTROL	DISPLAY-6.
	02  FILE-LANGUAGE-FILE-ID.
	    04  FILE-LANGUAGE-FILE-NAME	pic  X(06).
	    04	FILLER			REDEFINES
		FILE-LANGUAGE-FILE-NAME.
		06  FILE-LANG-FIRST-5	PIC  X(05).
		06  FILLER		PIC  X(01).
	    04  FILE-LANGUAGE-FILE-EXT	pic  X(03).
	02  FL-FILE-STATUS.
	    04  FL-FS-STATUS			pic  9(02).
		88  FL-FS-STATUS-NORMAL			value 00.
		88  FL-FS-STATUS-EOF			value 10.
		88  FL-FS-STATUS-DUPLICATE-KEY		value 22.
		88  FL-FS-STATUS-NOT-FOUND		value 23.
		88  FL-FS-STATUS-OUT-OF-BOUNDS		value 24.
		88  FL-FS-STATUS-INVALID-KEY		value 22, 23, 24.
		88  FL-FS-STATUS-FATAL			value 30, 34.
	    04  FL-FS-ERROR-NO			pic  9(10).
	    04  filler redefines FL-FS-ERROR-NO.
		06  FL-FS-VERB-ERROR		pic  9(02).
		    88  FL-FS-OPEN-ERROR		value 01.
		    88  FL-FS-READ-ERROR		value 06.
		06  FL-FS-MONITOR-ERROR		pic  9(02).
		    88  FL-FS-LOOKUP-ERROR		value 03.
		06  filler			pic  9(06).
	    04  FL-FS-ACTION-CODE		usage index.
	    04  FL-FS-FILE-SPEC			pic  X(09).
	    04  FL-FS-BLOCK-NO			usage index.
	    04  FL-FS-RECORD-NO			usage index.
	    04  FL-FS-FILE-NAME			pic  X(30).
	    04  FL-FS-TABLE-POINTER		usage index.

01	FL-FILE-SWITCHES.
	02  FL-FILE-NUMBERED-FLAG	pic  9(01).
	88  FL-FILE-NUMBERED-NOT-SET		value 0.
	88  FL-FILE-NUMBERED-NO			value 1.
	88  FL-FILE-NUMBERED-YES		value 2.

01	FL-FILE-NAME-PROMPT		display-7
					pic  X(21)
	value 'File language file > '.

01	SKELETON-FILE-CONTROL		DISPLAY-6.
	02  SKL-FILE-STATUS.
	    04  SKL-FS-STATUS			pic  9(02).
		88  SKL-FS-STATUS-NORMAL			value 00.
		88  SKL-FS-STATUS-EOF			value 10.
		88  SKL-FS-STATUS-DUPLICATE-KEY		value 22.
		88  SKL-FS-STATUS-NOT-FOUND		value 23.
		88  SKL-FS-STATUS-OUT-OF-BOUNDS		value 24.
		88  SKL-FS-STATUS-INVALID-KEY		value 22, 23, 24.
		88  SKL-FS-STATUS-FATAL			value 30, 34.
	    04  SKL-FS-ERROR-NO			pic  9(10).
	    04  filler redefines SKL-FS-ERROR-NO.
		06  SKL-FS-VERB-ERROR		pic  9(02).
		    88  SKL-FS-OPEN-ERROR		value 01.
		    88  SKL-FS-READ-ERROR		value 06.
		06  SKL-FS-MONITOR-ERROR		pic  9(02).
		    88  SKL-FS-LOOKUP-ERROR		value 03.
		06  filler			pic  9(06).
	    04  SKL-FS-ACTION-CODE		usage index.
	    04  SKL-FS-FILE-SPEC			pic  X(09).
	    04  SKL-FS-BLOCK-NO			usage index.
	    04  SKL-FS-RECORD-NO			usage index.
	    04  SKL-FS-FILE-NAME			pic  X(30).
	    04  SKL-FS-TABLE-POINTER		usage index.
 
01	SKL-FILE-NAME-PROMPT		DISPLAY-7
					PIC  X(21)
	VALUE 'Skeleton           > '.
 
01	TEMP-INDEX			usage index.

01	WSS-REDEF-FIELD			PIC  X(30).
 
01	WSS-REDEF-LEVEL			PIC  9(02).
 
01	WSS-LEVELS.
	05  WSS-FOCUR-LEVEL		PIC  9(02)	VALUE 99.
	05  WSS-LEVEL1			PIC  9(02)	VALUE 99.
	05  WSS-LEVEL2			PIC  9(02)	VALUE 99.
	05  WSS-LEVEL3			PIC  9(02)	VALUE 99.
 
01	WSS-USAGE-FIELDS.
	05  WSS-USAGE-LEVEL		PIC  9(02).
	05  WSS-USAGE			PIC  X(15).
01	WSS-LEVEL-INDEXES.
	05  WSS-LEVEL1-IDX		PIC  X(04).
	05  WSS-LEVEL2-IDX		PIC  X(04).
	05  WSS-LEVEL3-IDX		PIC  X(04).
	05  WSS-LEVEL1-NAME		PIC  X(30).
	05  WSS-LEVEL2-NAME		PIC  X(30).
	05  WSS-LEVEL3-NAME		PIC  X(30).

01	VAR-IDX				USAGE INDEX.
*=============================================================
*	M A C R O    E X P A N S I O N    W S
*=============================================================

*----------------
* Command Data
*----------------

01	MACRO-COMMAND		pic  X(12).
	88  NO-COMMAND		value SPACE.
	88  EACH-FIELD-COMMAND	value 'EACH-FIELD'.
	88  EACH-IMAGE-COMMAND	value 'EACH-IMAGE'.
	88  ELSE-COMMAND	value 'ELSE'.
	88  END-COMMAND		value 'END'.
	88  END-FIELD-COMMAND	value 'END-FIELD'.
	88  END-IF-COMMAND	value 'END-IF'.
	88  END-IMAGE-COMMAND	value 'END-IMAGE'.
	88  END-NOTE-COMMAND	value 'END-NOTE'.
	88  IF-COMMAND		value 'IF'.
	88  IF-NOT-COMMAND	value 'IF-NOT'.
	88  NOTE-COMMAND	value 'NOTE'.
	88  PAGE-COMMAND	value 'PAGE'.
	88  SET-COMMAND		value 'SET'.
	88  START-COMMAND	value 'START'.
*
*	n.b.	The following table must be kept in alphabetical
*		order since it is searched binarily.
01	MACRO-COMMAND-TABLE.
	02  filler		pic  X(12) value 'EACH-FIELD'.
	02  filler		pic  X(12) value 'EACH-IMAGE'.
	02  filler		pic  X(12) value 'ELSE'.
	02  filler		pic  X(12) value 'END'.
	02  filler		pic  X(12) value 'END-FIELD'.
	02  filler		pic  X(12) value 'END-IF'.
	02  filler		pic  X(12) value 'END-IMAGE'.
	02  filler		pic  X(12) value 'END-NOTE'.
	02  filler		pic  X(12) value 'IF'.
	02  filler		pic  X(12) value 'IF-NOT'.
	02  filler		pic  X(12) value 'NOTE'.
	02  filler		pic  X(12) value 'PAGE'.
	02  filler		pic  X(12) value 'SET'.
	02  filler		pic  X(12) value 'START'.

01	MACRO-COMMAND-ARRAY	redefines MACRO-COMMAND-TABLE.
	02  MACRO-COMMAND-ENTRY	pic  X(12)
				occurs 14 times
				indexed by MACRO-COMMAND-INDEX
				ascending key MACRO-COMMAND-ENTRY.
*
01	MACRO-COMMAND-INFO.
	02  MACRO-COMMAND-STACK	pic  X(12)
				occurs 30 times
				indexed by MACRO-COMMAND-STACK-PTR.
*
01	LINE-POINTERS.
	02  SKELETON-PTR		pic S9(03) comp.
	02  SOURCE-CODE-PTR		pic S9(03) comp.
	02  MAX-SOURCE-CODE-PTR		pic S9(03) comp value 105.
	02  LAST-SOURCE-PTR		pic S9(03) comp.
	02  LAST-COL-NO			pic S9(03) comp.
	02  CURR-COL-NO			pic S9(03) comp.
	02  NEXT-COL-NO			pic S9(03) comp.
	02  NEXT-TAB-NO			pic S9(03) comp.
	02  FILL-COUNT			pic S9(02) comp.
	02  ERROR-LINE-PTR		pic S9(03) comp.
	02  SYMBOL-WORK-PTR		pic S9(03) comp.
*
01	SOURCE-CODE-WORK		display-7
					pic  X(105).
01	SOURCE-CODE-ARRAY redefines SOURCE-CODE-WORK display-7
					occurs 105
					indexed by SOURCE-CODE-INDEX
					pic  X(01).
*
01	COMMAND-SPECIAL-CHAR		display-7.
	02  CURRENT-DELIMITER		pic  X(01).
	02  BEGIN-DELIMITER		pic  X(01) value '{'.
	02  END-DELIMITER		pic  X(01) value '}'.
	02  filler			pic  X(02).

*
01	COMMAND-STATE-SWITCHES.
	02  COMMAND-VALID-SW		pic S9(01) comp.
	    88 COMMAND-VALID		value 1.
	02  SKELETON-FILE-END-SW	pic S9(01) comp.
	    88  COMMAND-STATE-END	value 1.
*
01	ERROR-HANDLING			display-7.
	02  ERROR-LINE			pic  X(105).
	02  ERROR-NUMBER		pic S9(10) comp.

01	filler				display-7.
	02  TEMP-SUBSTITUTE-NAME	pic  X(06).
	02  filler			pic  X(04).
*
01	filler				display-7.
	02  ASCII-SUBSTITUTE-NAME	pic  X(06).
	02  filler			pic  X(04).
*
01	SUBSTITUTE-NAME			display-6.
	88  FILNM-NAME		value 'FILNM'.
	88  MODTL-NAME		value 'MODTL'.
	88  ACCES-NAME		value 'ACCES'.
	88  ASIGN-NAME		VALUE 'ASIGN'.
	88  ORG-NAME		VALUE 'ORG'.
	88  MKEY-NAME		VALUE 'MKEY'.
	88  MMODE-NAME		VALUE 'MMODE'.
	88  MBLCK-NAME		VALUE 'MBLCK'.
	88  MODNM-NAME		VALUE 'MODNM'.
	88  RECNM-NAME		VALUE 'RECNM'.
	88  ITYPE-NAME		value 'ITYPE'.
	88  NOITM-NAME		value 'NOITM'.
	88  IDATA-NAME		VALUE 'IDATA'.
	88  FLDIX-NAME		VALUE 'FLDIX'.
	88  FIELD-NAME		value 'FIELD'.
	88  PICT-NAME		value 'PICT'.
	88  DPICT-NAME		value 'DPICT'.
	88  PPICT-NAME		value 'PPICT'.
	88  FLDNO-NAME		value 'FLDNO'.
	88  REDEF-NAME		VALUE 'REDEF'.
	88  ISRDF-NAME		VALUE 'ISRDF'.
	88  USIGE-NAME		VALUE 'USIGE'.
	88  FSIGN-NAME		VALUE 'FSIGN'.
	88  FSEP-NAME		VALUE 'FSEP'.
	88  FOCUR-NAME		VALUE 'FOCUR'.
	88  FTO-NAME		VALUE 'FTO'.
	88  OLVL1-NAME		VALUE 'OLVL1'.
	88  OLVL2-NAME		VALUE 'OLVL2'.
	88  OLVL3-NAME		VALUE 'OLVL3'.
	88  DEPND-NAME		VALUE 'DEPND'.
	88  ASCND-NAME		VALUE 'ASCND'.
	88  DSCND-NAME		VALUE 'DSCND'.
	88  INDXD-NAME		VALUE 'INDXD'.
	88  INDX1-NAME		VALUE 'INDX1'.
	88  INDX2-NAME		VALUE 'INDX2'.
	88  INDX3-NAME		VALUE 'INDX3'.
	88  FSYNC-NAME		VALUE 'FSYNC'.
	88  FJUST-NAME		VALUE 'FJUST'.
	88  FBLNK-NAME		VALUE 'FBLNK'.
	88  FVALU-NAME		VALUE 'FVALU'.
	88  FDLMT-NAME		VALUE 'FDLMT'.
	88  FDATA-NAME		VALUE 'FDATA'.
	88  FDTA2-NAME		VALUE 'FDTA2'.
	02  filler			pic  X(01).
	    88  RESERVED-VARIABLE	value '%'.
	02  RESERVED-NAME.
	    88  DATE-VARIABLE		value 'DATE'.
	    04  RESERVED-NAME-CHAR-1	pic  X(01).
	    04  filler			pic  X(04).

01	SKELETON-FILE-ID.
	02  SKELETON-FILE-NAME		pic  X(06).
	02  FILLER			REDEFINES
	    SKELETON-FILE-NAME.
	    04	SKELETON-FILE-FIRST	PIC X(01).
	    04  FILLER			PIC X(05).
	02  SKELETON-FILE-EXT		pic  X(03).

01	SKL-FILE-SWITCHES.
	02  SKL-FILE-NUMBERED-FLAG	pic  s9(01) comp.
	    88  SKL-FILE-NUMBERED-NOT-SET		value 2.
	    88  SKL-FILE-NOT-NUMBERED			value 0.
	    88  SKL-FILE-NUMBERED			value 1.

01	SOURCE-CODE-FILE-ID.
	02  SOURCE-CODE-FILE-NAME	pic  X(06).
	02  SOURCE-CODE-FILE-EXT	pic  X(03).

01	WS-FILE-NAME			DISPLAY-6
					PIC  X(12).

01	LINE-NUMBER			pic S9(05) comp.
01	LINE-NUMBER-PRT			pic  ZZZZ9.

01	PAGE-NUMBER			pic S9(05) comp.

01	SYMBOL-WORK			display-7
					pic  X(105).

01	SYMBOL-WORK-ARRAY redefines SYMBOL-WORK display-7
					occurs 105
					pic  X(01).

01	SIXBIT-SYMBOL-WORK		display-6
					pic  X(105).

01	INPUT-FLAG			pic S9(01) comp value 0.
	88  SKELETON-FILE-READ	value 0.
	88  RECURS-FILE-READ	value 1.
	88  FIELD-FILE-READ	value 2.

01	INPUT-FLAG-SAVE			pic S9(01) comp.
 
01	SKL-STATUS			PIC S9(01) COMP VALUE 0.
	88  SKL-FILE-CLOSED	VALUE 0.
	88  SKL-FILE-OPEN	VALUE 1.
 
01	SOURCE-FILE-STATUS		PIC S9(01) COMP VALUE 0.
	88  SOURCE-FILE-CLOSED	VALUE 0.
	88  SOURCE-FILE-OPEN	VALUE 1.
 
01	RECURS-FILE-STATUS		pic S9(01) comp value 0.
	88  RECURS-FILE-CLOSED	value 0.
	88  RECURS-FILE-WRITE	value 1.
	88  RECURS-FILE-INPUT	value 2.

01	FIELD-FILE-STATUS		pic S9(01) comp value 0.
	88  FIELD-FILE-CLOSED	value 0.
	88  FIELD-FILE-WRITE	value 1.
	88  FIELD-FILE-INPUT	value 2.

01	CONDITION-VALUE		pic S9(01) comp.
	88  CONDITION-FALSE	value 0.
	88  CONDITION-TRUE	value 1.

01	CONDITION-STACK		occurs 25
				indexed by CONDITION-INDEX
				pic S9(01) comp.

01	CONDITION-WORK		pic  X(12).
01	CONDITION-TEMP		pic  X(12).


01	SET-NAME		pic  X(12).
	88  IMAGE-SET-NAME	value 'IMAGE' 'IMAGE-INDEX'.

01	filler			display-7.
	02  SET-VALUE		pic  X(02).
	02  filler		pic  X(03).

01	FIELD-FILE-INFO			DISPLAY-7.
	02  FIELD-FILE-ARRAY		OCCURS 300
					indexed by FIELD-FILE-INDEX
					pic  X(105).
*=========================================================
*	S C R A T C H    P A D
*==========================================================

01	YES-NO-VALUES.
	02  YES-VALUE			pic S9(01) comp value 1.
	02  NO-VALUE			pic S9(01) comp value 0.
*
01	ERROR-TABLE			display-7.
	02  CURRENT-ERROR.
	    04  ERROR-LENGTH		pic  9(02).
	    04  ERROR-TEXT		pic  X(38).
	02  COMMAND-INTERP-ERROR	pic  X(40)
	    value '29 This is an unknown command. @'.
	02  END-DELIMITER-ERROR		pic  X(40)
	    value '36 Beginning but no ending delimiter. @'.
	02  SYMBOL-ERROR		pic  X(40)
	    value '22 Unrecognized symbol. @'.
	02  END-COMMAND-ERROR		pic  X(40)
	    value '20 Early END command. @'.
	02  DATA-TYPE-ERROR		pic  X(40)
	    value '33 Current data type is undefined. @'.
	02  RESERVED-VARIABLE-ERROR	pic  X(40)
	    value '30 Undefined reserved variable. @'.
	02  RECURS-FILE-ERROR		pic  X(40)
	    value '34 Image file end before END-IMAGE. @'.
	02  FIELD-FILE-ERROR		pic  X(40)
	    value '34 Field file end before END-FIELD. @'.
	02  END-IMAGE-ERROR		pic  X(40)
	    value '26 Early END-IMAGE command. @'.
	02  END-FIELD-ERROR		pic  X(40)
	    value '26 Early END-FIELD command. @'.
	02  IF-COMMAND-ERROR		pic  X(40)
	    value '21 IF statement error. @'.
	02  IF-SYNC-ERROR		pic  X(40)
	    value '17 END-IF missing. @'.

01	PROG-HEADING			display-7
					pic  X(55)
	value 'VAG002:  Application Module Generator -- Version 1'.

01	PROG-PROCESSING-FLAG		pic S9(01) comp value 0.
	88  CONTINUE-PROCESSING	value 0.
	88  PROG-PROCESSING-END		value 9.

01	TERMINAL-INPUT-SW		pic S9(01) comp.
	88  TERMINAL-INPUT	value 1.


01	TERMINAL-REPLY			pic  X(10).

01	WS-SPECIAL-CHARACTERS		pic S9(10) comp value 3090.
01	filler	redefines	WS-SPECIAL-CHARACTERS	display-7.
	02  filler			pic  X(03).
	02  WS-PAGE-EJECT		pic  X(01).
	02  WS-TAB			pic  X(01).
01	WS-TODAY			display-6.
	02  WS-DATE.
	    04  WS-DATE-YY		pic  X(02).
	    04	WS-DATE-MM		pic  X(02).
	    04	WS-DATE-DD		pic  X(02).

01	WS-TODAY-WORK			display-7.
	02  WS-DATE-WORK.
	    04  WS-DATE-MM-WORK		pic  X(02).
	    04  filler			pic  X(01) value '/'.
	    04  WS-DATE-DD-WORK		pic  X(02).
	    04  filler			pic  X(01) value '/'.
	    04	WS-DATE-YY-WORK		pic  X(02).

01	WS-SAVE-PTR			pic S9(03) comp.
01	WS-INDEX			pic S9(03) comp.

01	WS-NUMBER-6		pic  9(06).
01	filler redefines WS-NUMBER-6.
	02  filler		pic  9(03).
	02  WS-NUMBER-3		pic  9(03).
01	filler redefines WS-NUMBER-6.
	02  filler		pic  9(04).
	02  WS-NUMBER-2		pic  9(02).

01	TAB-WIDTH			pic S9(01) comp value 8.

01	NO-WARNING-COMP			display-6
					pic S9(06).

01	NO-WARNING-6 redefines NO-WARNING-COMP.
	02  filler			pic  X(01).
	02  NO-WARNING-5.
	    04  filler			pic  X(01).
	    04  NO-WARNING-4.
		06  filler		pic  X(01).
		06  NO-WARNING-3.
		    08  filler		pic  X(01).
		    08  NO-WARNING-2.
			10  filler	pic  X(01).
			10  NO-WARNING-1 
					pic  9(01).


01 TALLY				pic  9(10) COMP.
 
01	WSS-88-FIELDS.
	05  WSS-88-INDEX		USAGE INDEX.
	05  WSS-88-TOTAL		PIC 9(02).

01	WSS-HELP-CHECK			PIC  X(10).
	88  WSS-HELP		VALUE 'HELP', 'Help', 'help', 'H', 'h', '?'.
 
01	WSS-FIG-CONSTANTS.
	05  WSS-SPACE-5		PIC X(05)	VALUE '" "'.
	05  WSS-SPACE-6		PIC X(06)	VALUE '" "'.
	05  WSS-ZERO-4		PIC 9(04)	VALUE 0.
	05  WSS-ZERO-5		PIC 9(05)	VALUE 0.
	05  WSS-ZERO-6		PIC 9(06)	VALUE 0.
	05  WSS-QUOTE-5		PIC X(05)	VALUE '"'.
	05  WSS-QUOTE-6		PIC X(06)	VALUE '"'.
PROCEDURE DIVISION.
*==================

DECLARATIVES.
*------------

D100-INPUT-ERROR SECTION.	use after standard error procedure on FILE-LANGUAGE-FILE.

D110-INPUT-ERROR.
	If  FL-FS-OPEN-ERROR
	    If  FL-FS-LOOKUP-ERROR
		display space
		display '% File ['
		FILE-LANGUAGE-FILE-NAME '.' FILE-LANGUAGE-FILE-EXT
			'] not found.'
		display space
		set TERMINAL-INPUT-SW	TO YES-VALUE
		set FL-FS-ACTION-CODE	TO 1
	    else
		display space
		display '? Fatal error on file ['
			FILE-LANGUAGE-FILE-NAME '.' FILE-LANGUAGE-FILE-EXT
			'].'
		display '	(File Status / Error Number = '
			FL-FS-STATUS ' / ' FL-FS-ERROR-NO ')'.


D200-INPUT-ERROR SECTION.	use after standard error procedure on SKELETON-FILE.

D210-INPUT-ERROR.
	If  SKL-FS-OPEN-ERROR
	    SET SKL-STATUS		TO NO-VALUE
	    If  SKL-FS-LOOKUP-ERROR
		display space
		display '% File ['
		SKELETON-FILE-NAME '.' SKELETON-FILE-EXT
			'] not found.'
		display space
		set TERMINAL-INPUT-SW	TO YES-VALUE
		set SKL-FS-ACTION-CODE	TO 1
	    else
		display space
		display '? Fatal error on file ['
			SKELETON-FILE-NAME '.' SKELETON-FILE-EXT
			'].'
		display '	(File Status / Error Number = '
			SKL-FS-STATUS ' / ' SKL-FS-ERROR-NO ')'.


END DECLARATIVES.
*----------------

THE-PROGRAM SECTION.

0000-PROG-MAIN-LOGIC.
	perform				0100-INITIALIZE.
	PERFORM				0200-PROCESS-ALL
		UNTIL	NOT CONTINUE-PROCESSING.
	perform				0300-TERMINATE.
	STOP RUN.
 
0100-INITIALIZE.
	display SPACE.
	display PROG-HEADING.
	display SPACE.

	accept WS-DATE			from DATE.
	move WS-DATE-YY			to WS-DATE-YY-WORK.
	move WS-DATE-MM			to WS-DATE-MM-WORK.
	move WS-DATE-DD			to WS-DATE-DD-WORK.

0200-PROCESS-ALL.
	SET SKELETON-FILE-END-SW,
	    FILE-LANGUAGE-END-SW,
	    PROG-PROCESSING-FLAG	to 0.
	set TERMINAL-INPUT-SW		TO 1.
	PERFORM				0210-COLLECT-TERMINAL
		UNTIL	NOT TERMINAL-INPUT.
	If  CONTINUE-PROCESSING
	    PERFORM			0220-INIT-PROCESS
	    PERFORM			1000-BUILD-SYMBOL-TABLE
		UNTIL	FILE-LANGUAGE-END
	    CLOSE FILE-LANGUAGE-FILE
	    perform			2000-CREATE-SOURCE-FILE
		UNTIL	COMMAND-STATE-END.

0210-COLLECT-TERMINAL.
	display FL-FILE-NAME-PROMPT
		WITH NO ADVANCING.
	accept	TERMINAL-REPLY.
	If  TERMINAL-REPLY = SPACE
	    set PROG-PROCESSING-FLAG	to 9
	    set FILE-LANGUAGE-END-SW	to YES-VALUE
	    set SKELETON-FILE-END-SW	to YES-VALUE
	    set TERMINAL-INPUT-SW	to NO-VALUE
	else
	    MOVE TERMINAL-REPLY		TO WSS-HELP-CHECK
	    IF	WSS-HELP
		DISPLAY '  Enter the name of the .FL file to be used to create the source code'
	    ELSE
		perform			0215-OPEN-FL.

0215-OPEN-FL.
	unstring TERMINAL-REPLY
		delimited by		'.'
		into			FILE-LANGUAGE-FILE-NAME,
					FILE-LANGUAGE-FILE-EXT.
	If  FILE-LANGUAGE-FILE-EXT = SPACE
	    move 'FL'			to FILE-LANGUAGE-FILE-EXT.
	set TERMINAL-INPUT-SW		to NO-VALUE.
	open	INPUT			FILE-LANGUAGE-FILE.
	set FL-FILE-NUMBERED-FLAG	to 0.
 
0220-INIT-PROCESS.
	MOVE SPACE			TO ERROR-LINE,
					   SUBSTITUTE-NAME
					   MODULE-DATA
					   IMAGE-INFO
					   FIELD-INFO.
	set COMMAND-VALID-SW,
	    ERROR-NUMBER,
	    MACRO-COMMAND-STACK-PTR,
	    IMAGE-DATA-INDEX,
	    FIELD-DATA-INDEX		TO 0.
	SET SKELETON-PTR,
	    SOURCE-CODE-PTR,
	    ERROR-LINE-PTR		TO 1.
 
0300-TERMINATE.
	IF SKL-FILE-OPEN
	    close	SKELETON-FILE.
	IF  SOURCE-FILE-OPEN
	    CLOSE 	SOURCE-CODE-FILE.
*============================================================
*	S C R E E N    L A N G U A G E    S C A N
*=============================================================
1000-BUILD-SYMBOL-TABLE.
	perform				8000-READ-FL.
	If  not FILE-LANGUAGE-END
	    perform			1100-TEST-SYMBOL.

1100-TEST-SYMBOL.
	move SPACE			to FL-KEY-WORD.
	perform				1199-EAT-SPACES
		until	FILE-LANGUAGE-PTR > MAX-SOURCE-CODE-PTR
		   or	(FILE-LANGUAGE-WORK(FILE-LANGUAGE-PTR) not= SPACE
			and FILE-LANGUAGE-WORK(FILE-LANGUAGE-PTR) not= WS-TAB).
	unstring FILE-LANGUAGE-RECORD
		DELIMITED BY		','
		into			FL-KEY-WORD
		with pointer		FILE-LANGUAGE-PTR.

	If  FIELD-KEY-WORD
	    perform			1110-FIELD-SYMBOLS
	else If IMAGE-KEY-WORD
	    perform			1120-IMAGE-SYMBOLS
	else If MODULE-KEY-WORD
	    perform			1130-MODULE-SYMBOLS.

1110-FIELD-SYMBOLS.
	set FIELD-DATA-INDEX		up by 1.
	set FIELD-DATA-MAX-INDEX 	up by 1.
	move FIELD-DATA-INDEX		to WS-NUMBER-6.
	MOVE WS-NUMBER-3		TO FLDIX (FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-2			TO FLDNO(FIELD-DATA-INDEX).
	perform				1199-UNSTRING-TOKEN.
	move FL-TOKEN-30		to FIELD(FIELD-DATA-INDEX).
	IF FLDNO(FIELD-DATA-INDEX) = '01'
	    MOVE FIELD(FIELD-DATA-INDEX)	TO RECNM.
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-30		TO REDEF(FIELD-DATA-INDEX).
	IF FL-TOKEN-4 NOT = 'NONE'
	    MOVE REDEF(FIELD-DATA-INDEX) TO WSS-REDEF-FIELD
	    MOVE FLDNO(FIELD-DATA-INDEX) TO WSS-REDEF-LEVEL
	    MOVE FIELD-DATA-INDEX	TO TEMP-INDEX
	    SET FIELD-DATA-INDEX	TO 1
	    SEARCH FIELD-DATA VARYING FIELD-DATA-INDEX
		AT END MOVE TEMP-INDEX	TO FIELD-DATA-INDEX
		WHEN FIELD(FIELD-DATA-INDEX) = WSS-REDEF-FIELD
		    MOVE 'YES'		TO ISRDF(FIELD-DATA-INDEX)
		    MOVE TEMP-INDEX	TO FIELD-DATA-INDEX.
	IF  ISRDF(FIELD-DATA-INDEX) NOT = 'YES'
	    MOVE 'NO'			TO ISRDF(FIELD-DATA-INDEX).
	perform				1199-UNSTRING-TOKEN.
	move FL-TOKEN-40		to PICT(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-15		TO USIGE(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-10		TO FSIGN(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-10		TO FSEP(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-4			TO FOCUR(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-4			TO FTO(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-30		TO DEPND(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-30		TO ASCND(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-30		TO DSCND(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-30		TO INDXD(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-5			TO FSYNC(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-5			TO FJUST(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-4			TO FBLNK(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-30		TO FL-TOKEN-30-6.
	INSPECT FL-TOKEN-30-6
	    REPLACING 'SPACES'		BY WSS-SPACE-6
		      'SPACE'		BY WSS-SPACE-5
		      'ZEROES'		BY WSS-ZERO-6
		      'ZEROS'		BY WSS-ZERO-5
		      'ZERO'		BY WSS-ZERO-4
		      'QUOTES'		BY WSS-QUOTE-6
		      'QUOTE'		BY WSS-QUOTE-5.
	MOVE FL-TOKEN-30-6		TO FVALU(FIELD-DATA-INDEX).
	IF  FL-TOKEN-1 = "'"
	OR  FL-TOKEN-1 = '"'
	    MOVE FL-TOKEN-1		TO FDLMT(FIELD-DATA-INDEX)
	ELSE
	    MOVE 'N'			TO FDLMT(FIELD-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN			TO FDATA(FIELD-DATA-INDEX).
	IF  USIGE(FIELD-DATA-INDEX) = 'DISPLAY@'
	    INSPECT FL-TOKEN
		REPLACING WS-TAB	BY SPACE
	    INSPECT FL-TOKEN
		REPLACING ' DISPLAY-6.'	BY '.          '
			  ' DISPLAY-6 ' BY SPACES
			  ' DISPLAY-7.'	BY '.          '
			  ' DISPLAY-7 '	BY SPACES
	ELSE IF USIGE(FIELD-DATA-INDEX) = 'COMP@'
	    INSPECT FL-TOKEN
		REPLACING WS-TAB		BY SPACE
	    INSPECT FL-TOKEN
		REPLACING ' COMPUTATIONAL.'	BY '.              '
			  ' COMPUTATIONAL '	BY SPACES
			  ' COMP.'		BY '.     '
			  ' COMP '		BY SPACES
	ELSE IF USIGE(FIELD-DATA-INDEX) = 'COMP-1@'
	    INSPECT FL-TOKEN
		REPLACING WS-TAB		BY SPACE
	    INSPECT FL-TOKEN
		REPLACING ' COMPUTATIONAL-1.'	BY '.                '
			  ' COMPUTATIONAL-1 '	BY SPACES
			  ' COMP-1.'		BY '.       '
			  ' COMP-1 '		BY SPACES
	ELSE IF USIGE(FIELD-DATA-INDEX) = 'COMP-3@'
	    INSPECT FL-TOKEN
		REPLACING WS-TAB		BY SPACE
	    INSPECT FL-TOKEN
		REPLACING ' COMPUTATIONAL-3.'	BY '.                '
			  ' COMPUTATIONAL-3 '	BY SPACES
			  ' COMP-3.'		BY '.       '
			  ' COMP-3 '		BY SPACES.
	IF  FL-TOKEN = FDATA(FIELD-DATA-INDEX)
	    MOVE 'NONE@'		TO FDTA2(FIELD-DATA-INDEX)
	ELSE
	    MOVE FL-TOKEN		TO FDTA2(FIELD-DATA-INDEX).
	IF  FOCUR(FIELD-DATA-INDEX) NOT = 'NONE'
	    MOVE FLDNO(FIELD-DATA-INDEX)	TO WSS-FOCUR-LEVEL
	    IF WSS-FOCUR-LEVEL NOT > WSS-LEVEL1
		MOVE SPACES			TO WSS-LEVEL-INDEXES
		MOVE 99				TO WSS-LEVEL2
						   WSS-LEVEL3
		MOVE WSS-FOCUR-LEVEL		TO WSS-LEVEL1
		MOVE FOCUR(FIELD-DATA-INDEX)	TO WSS-LEVEL1-IDX
		MOVE INDXD(FIELD-DATA-INDEX)	TO WSS-LEVEL1-NAME
	    ELSE IF WSS-FOCUR-LEVEL NOT > WSS-LEVEL2
		MOVE SPACES			TO WSS-LEVEL3-IDX
						   WSS-LEVEL3-NAME
		MOVE 99				TO WSS-LEVEL3
		MOVE WSS-FOCUR-LEVEL		TO WSS-LEVEL2
		MOVE FOCUR(FIELD-DATA-INDEX)	TO WSS-LEVEL2-IDX
		MOVE INDXD(FIELD-DATA-INDEX)	TO WSS-LEVEL2-NAME
	    ELSE IF WSS-FOCUR-LEVEL NOT > WSS-LEVEL3
		MOVE WSS-FOCUR-LEVEL		TO WSS-LEVEL3
		MOVE FOCUR(FIELD-DATA-INDEX)	TO WSS-LEVEL3-IDX
		MOVE INDXD(FIELD-DATA-INDEX)	TO WSS-LEVEL3-NAME.
* FOR ELEMENTARY ITEMS WITH NO PICTURE CLAUSE (USAGE ONLY) MOVE 'YES'
* TO PICTURE FIELD...
	IF FIELD-DATA-INDEX > 1
	    IF PICT(FIELD-DATA-INDEX - 1) = 'NONE@'
	    AND	USIGE(FIELD-DATA-INDEX - 1) NOT = 'NONE@'
	    AND	FLDNO(FIELD-DATA-INDEX) NOT = '00'
	    AND	FLDNO(FIELD-DATA-INDEX) NOT > FLDNO(FIELD-DATA-INDEX - 1)
		MOVE 'YES'		TO PICT(FIELD-DATA-INDEX - 1).
	IF  WSS-REDEF-FIELD NOT = SPACES
	    IF	WSS-REDEF-FIELD = REDEF(FIELD-DATA-INDEX)
		NEXT SENTENCE
	    ELSE
	    IF FLDNO(FIELD-DATA-INDEX) > WSS-REDEF-LEVEL
		MOVE WSS-REDEF-FIELD	TO REDEF(FIELD-DATA-INDEX)
	    ELSE
		MOVE SPACES		TO WSS-REDEF-FIELD
		MOVE 0			TO WSS-REDEF-LEVEL.
	MOVE 'NONE'			TO OLVL1(FIELD-DATA-INDEX)
					   OLVL2(FIELD-DATA-INDEX)
					   OLVL3(FIELD-DATA-INDEX)
					   INDX1(FIELD-DATA-INDEX)
					   INDX2(FIELD-DATA-INDEX)
					   INDX3(FIELD-DATA-INDEX).
	IF WSS-LEVEL1 < FLDNO(FIELD-DATA-INDEX)
	OR  (WSS-LEVEL1 = FLDNO(FIELD-DATA-INDEX)
	AND FOCUR(FIELD-DATA-INDEX) NOT = 'NONE')
	    IF PICT(FIELD-DATA-INDEX) NOT = 'NONE@'
		MOVE WSS-LEVEL1-IDX	TO OLVL1(FIELD-DATA-INDEX)
		MOVE WSS-LEVEL1-NAME	TO INDX1(FIELD-DATA-INDEX)
		IF WSS-LEVEL2 < FLDNO(FIELD-DATA-INDEX)
		OR  (WSS-LEVEL2 = FLDNO(FIELD-DATA-INDEX)
		AND FOCUR(FIELD-DATA-INDEX) NOT = 'NONE')
		    MOVE WSS-LEVEL2-IDX	TO OLVL2(FIELD-DATA-INDEX)
		    MOVE WSS-LEVEL2-NAME	TO INDX2(FIELD-DATA-INDEX)
		    IF	WSS-LEVEL3 < FLDNO(FIELD-DATA-INDEX)
		    OR	(WSS-LEVEL3 = FLDNO(FIELD-DATA-INDEX)
		    AND	FOCUR(FIELD-DATA-INDEX) NOT = 'NONE')
			MOVE WSS-LEVEL3-IDX	TO OLVL3(FIELD-DATA-INDEX)
			MOVE WSS-LEVEL3-NAME	TO INDX3(FIELD-DATA-INDEX)
		    ELSE IF WSS-LEVEL3 = FLDNO(FIELD-DATA-INDEX)
			AND FOCUR(FIELD-DATA-INDEX) = 'NONE'
			MOVE SPACES		TO WSS-LEVEL3-IDX
						   WSS-LEVEL3-NAME
			MOVE 99			TO WSS-LEVEL3
		    ELSE
			NEXT SENTENCE
		ELSE IF WSS-LEVEL2 = FLDNO(FIELD-DATA-INDEX)
		AND FOCUR(FIELD-DATA-INDEX) = 'NONE'
		    MOVE SPACES			TO WSS-LEVEL2-IDX
						   WSS-LEVEL2-NAME
						   WSS-LEVEL3-IDX
						   WSS-LEVEL3-NAME
		    MOVE 99			TO WSS-LEVEL2
						   WSS-LEVEL3
		ELSE
		    NEXT SENTENCE
	    ELSE
		NEXT SENTENCE
	ELSE IF FLDNO(FIELD-DATA-INDEX) = '00'
	    NEXT SENTENCE
	ELSE
	    MOVE 99999999		TO WSS-LEVELS
	    MOVE SPACES			TO WSS-LEVEL-INDEXES.
	IF PICT(FIELD-DATA-INDEX) = 'NONE@'
	    MOVE FLDNO(FIELD-DATA-INDEX)	TO WSS-USAGE-LEVEL
	    IF	USIGE(FIELD-DATA-INDEX) = 'NONE@'
		MOVE 'DISPLAY@'			TO WSS-USAGE
	    ELSE
		MOVE USIGE(FIELD-DATA-INDEX)	TO WSS-USAGE
	ELSE IF FLDNO(FIELD-DATA-INDEX) > WSS-USAGE-LEVEL
	AND  USIGE(FIELD-DATA-INDEX) = 'NONE@'
	    MOVE WSS-USAGE		TO USIGE(FIELD-DATA-INDEX)
	ELSE IF USIGE(FIELD-DATA-INDEX) = 'NONE@'
	    MOVE 'DISPLAY@'		TO USIGE(FIELD-DATA-INDEX).
	IF FLDNO(FIELD-DATA-INDEX) = '88'
	    IF	WSS-88-TOTAL = 0
		MOVE FIELD-DATA-INDEX	TO WSS-88-INDEX
		SUBTRACT 1		FROM WSS-88-INDEX
		SET WSS-88-TOTAL UP	BY 1
	    ELSE
		SET WSS-88-TOTAL UP	BY 1
	ELSE
	IF  WSS-88-TOTAL > 0
	    MOVE SPACES			TO FVALU(WSS-88-INDEX)
	    STRING WSS-88-TOTAL		DELIMITED BY SIZE
		'@'			DELIMITED BY SIZE
		INTO			FVALU(WSS-88-INDEX)
	    MOVE 0			TO WSS-88-TOTAL
					   WSS-88-INDEX.
	IF  FIELD-DATA-INDEX < FIELD-DATA-MAX-INDEX
	    SET FIELD-DATA-INDEX UP	BY 1.
 
1120-IMAGE-SYMBOLS.
	set IMAGE-DATA-INDEX		up by 1.
	set FIELD-DATA-INDEX		to 0.
	set FIELD-DATA-MAX-INDEX	to 0.
	perform				1199-UNSTRING-TOKEN.
	move FL-TOKEN-10		to ITYPE(IMAGE-DATA-INDEX).
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN			TO IDATA(IMAGE-DATA-INDEX).

1130-MODULE-SYMBOLS.
	perform				1199-UNSTRING-TOKEN.
	move FL-TOKEN-10		to FILNM.
	perform				1199-UNSTRING-TOKEN.
	move FL-TOKEN-40		to MODTL.
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-30		TO ASIGN.
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-10		TO ORG.
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-10		TO ACCES.
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-30		TO MKEY.
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-10		TO MMODE.
	PERFORM				1199-UNSTRING-TOKEN.
	MOVE FL-TOKEN-4			TO MBLCK.

1199-UNSTRING-TOKEN.
	IF FILE-LANGUAGE-PTR > 375
	    perform			8000-READ-FL
	    perform			1199-EAT-SPACES
		until	FILE-LANGUAGE-PTR > MAX-SOURCE-CODE-PTR
		   or	(FILE-LANGUAGE-WORK(FILE-LANGUAGE-PTR) not= SPACE
			and FILE-LANGUAGE-WORK(FILE-LANGUAGE-PTR) not= WS-TAB).
	If  FILE-LANGUAGE-PTR < 375
	    IF FILE-LANGUAGE-WORK(FILE-LANGUAGE-PTR) = '<'
		set FILE-LANGUAGE-PTR	up by 1
		unstring FILE-LANGUAGE-RECORD
		    delimited by		'>,' or '>'
		    into			FL-TOKEN
		    with pointer		FILE-LANGUAGE-PTR
	    else
		unstring FILE-LANGUAGE-RECORD
		    delimited by		','
		    into			FL-TOKEN
		    with pointer		FILE-LANGUAGE-PTR.
	perform				9900-DO-NOTHING
		varying FL-TOKEN-INDEX	from 105 by -1
		until	FL-TOKEN-ARRAY(FL-TOKEN-INDEX) not= SPACE
		   or	FL-TOKEN-INDEX = 1.
	IF FL-TOKEN-INDEX < 105
	    set FL-TOKEN-INDEX		up by 1
	    move '@'			to FL-TOKEN-ARRAY (FL-TOKEN-INDEX).

1199-EAT-SPACES.

	Set FILE-LANGUAGE-PTR		up by 1.
2000-CREATE-SOURCE-FILE.
	SET TERMINAL-INPUT-SW		TO YES-VALUE.
	IF SKL-FILE-OPEN
	    SET SKL-STATUS		TO 0
	    CLOSE	SKELETON-FILE.
	perform				2100-COLLECT-SKELETON
	    UNTIL NOT TERMINAL-INPUT.
	IF  SOURCE-FILE-OPEN
	    SET SOURCE-FILE-STATUS	TO 0
	    CLOSE	SOURCE-CODE-FILE.
	IF CONTINUE-PROCESSING
	    PERFORM			2200-OPEN-CBL-FILE
	    MOVE SPACES			TO MACRO-COMMAND-INFO
					   MACRO-COMMAND
					   FIELD-FILE-INFO
	    MOVE 0			TO RECURS-FILE-STATUS
					   FIELD-FILE-STATUS
					   INPUT-FLAG
	    perform				3000-COMMAND-STATE-INIT
	    perform				4000-SOURCE-GENERATION
		until	COMMAND-STATE-END
	    IF	CONTINUE-PROCESSING
		SET SKELETON-FILE-END-SW	TO 0
	    ELSE
		NEXT SENTENCE
	ELSE
	    SET PROG-PROCESSING-FLAG		TO 0.

2100-COLLECT-SKELETON.
	display SKL-FILE-NAME-PROMPT
		WITH NO ADVANCING.
	Accept	TERMINAL-REPLY.
	If  TERMINAL-REPLY = SPACE
	    set PROG-PROCESSING-FLAG	to 9
	    set SKELETON-FILE-END-SW	to YES-VALUE
	    set TERMINAL-INPUT-SW	to NO-VALUE
	else
	    MOVE TERMINAL-REPLY		TO WSS-HELP-CHECK
	    IF	WSS-HELP
		DISPLAY '  Enter the name of the .SKL file to be used to create the source file'
		DISPLAY '  Choices are:'
		DISPLAY '         UNLOAD - Convert DEC ISAM file to SEQ file'
		DISPLAY '         LOADIT - Convert SEQ file to VAX IDX file'
		DISPLAY '         CDDICT - Create Common Data Dictionary DDL'
	    ELSE
		perform			2110-OPEN-SKL.
 
2110-OPEN-SKL.
	unstring TERMINAL-REPLY
		delimited by		'.'
		into			SKELETON-FILE-ID,
					SKELETON-FILE-EXT.
	If  SKELETON-FILE-EXT = SPACE
	    move 'SKL'			to SKELETON-FILE-EXT.
	SET TERMINAL-INPUT-SW		TO NO-VALUE.
	IF  SKL-FILE-OPEN
	    CLOSE SKELETON-FILE
	    OPEN INPUT SKELETON-FILE
	ELSE
	    SET SKL-STATUS		TO YES-VALUE
	    open	INPUT		SKELETON-FILE.
 
2200-OPEN-CBL-FILE.
	MOVE SPACES			TO SOURCE-CODE-FILE-NAME.
	STRING FILE-LANG-FIRST-5	DELIMITED BY SPACE
	       SKELETON-FILE-FIRST	DELIMITED BY SIZE
					INTO SOURCE-CODE-FILE-NAME.
	STRING SOURCE-CODE-FILE-NAME	DELIMITED BY SIZE
	       '@'			DELIMITED BY SIZE
					INTO MODNM.
	move 'CBL'			to SOURCE-CODE-FILE-EXT.
	SET SOURCE-FILE-STATUS		TO YES-VALUE.
	open	OUTPUT			SOURCE-CODE-FILE.
	MOVE SPACES			TO WS-FILE-NAME.
	string	SOURCE-CODE-FILE-NAME	delimited by space
		'.'			delimited by size
		SOURCE-CODE-FILE-EXT	delimited by space
		into			WS-FILE-NAME.
	display	space.
	display 'Creating ', WS-FILE-NAME.
	display space.
*
3000-COMMAND-STATE-INIT.
	set SKL-FILE-NUMBERED-FLAG	to 2.
	set PAGE-NUMBER			to 1.
	set LINE-NUMBER			to 0.
	set CONDITION-INDEX		to 0.
	set IMAGE-DATA-MAX-INDEX	to IMAGE-DATA-INDEX.
	set CONDITION-VALUE		to 1.
	If  IMAGE-DATA-INDEX > 0
	    set IMAGE-DATA-INDEX	to 1.
	If  FIELD-DATA-INDEX > 0
	    set FIELD-DATA-INDEX	to 1.
	perform				3100-NOITM
		varying TEMP-INDEX from 1 by 1
		until TEMP-INDEX > IMAGE-DATA-MAX-INDEX.
	
3100-NOITM.
	move FIELD-DATA-MAX-INDEX	to NO-WARNING-COMP.
	move NO-WARNING-4		to NOITM (TEMP-INDEX).
*===========================================================
*	S O U R C E    C O D E    G E N E R A T I O N
*============================================================
4000-SOURCE-GENERATION.
	perform				8100-READ.
	If  not COMMAND-STATE-END
	    If  COMMAND-LINE
		perform			5000-COMMAND-INTERPRETATION
			until END-COMMAND
		move SPACE		to MACRO-COMMAND
	    else
		move SKELETON-RECORD	to SOURCE-CODE-RECORD
		perform			8600-WRITE-SOURCE-LINE.

5000-COMMAND-INTERPRETATION.
	set SKELETON-PTR		to 2.
	unstring SKELETON-RECORD
		delimited by		ALL SPACE or ALL WS-TAB
		into			MACRO-COMMAND
		with pointer		SKELETON-PTR.
	set COMMAND-VALID-SW		to NO-VALUE.
	search all MACRO-COMMAND-ENTRY
		when MACRO-COMMAND = MACRO-COMMAND-ENTRY(MACRO-COMMAND-INDEX)
		     set COMMAND-VALID-SW to YES-VALUE.
	If  COMMAND-VALID
	    perform			5000-COMMAND-DISPATCH
	    perform			5000-COMMAND-DISPATCH
		until NO-COMMAND or END-COMMAND
	else
	    MOVE 'END'			TO MACRO-COMMAND
	    set SOURCE-CODE-PTR		to 2
	    move COMMAND-INTERP-ERROR	to CURRENT-ERROR
	    perform			9999-RECORD-ERROR.

5000-COMMAND-DISPATCH.
	If  EACH-FIELD-COMMAND
	    perform			5110-EACH-FIELD-COMMAND
	else If EACH-IMAGE-COMMAND
	    perform			5120-EACH-IMAGE-COMMAND
	else If ELSE-COMMAND
	    perform			5130-ELSE-COMMAND
		until not ELSE-COMMAND
	else If END-COMMAND
	    perform			5140-END-COMMAND
	else If END-FIELD-COMMAND
	    perform			5150-END-FIELD-COMMAND
		until not END-FIELD-COMMAND.

	If  END-IF-COMMAND
	    perform			5210-END-IF-COMMAND
		until not END-IF-COMMAND
	else If END-IMAGE-COMMAND
	    perform			5220-END-IMAGE-COMMAND
		until not END-IMAGE-COMMAND
	else If IF-COMMAND
	    perform			5230-IF-COMMAND
		until not IF-COMMAND
	else If IF-NOT-COMMAND
	    perform			5240-IF-NOT-COMMAND
		until not IF-NOT-COMMAND
	else If SET-COMMAND
	    perform			5250-SET-COMMAND.

	If  START-COMMAND
	    perform			9300-START-COMMAND
		until not START-COMMAND
	else If PAGE-COMMAND
	    perform			5310-PAGE-COMMAND
	else If NOTE-COMMAND
	    perform			9500-EAT
		until END-NOTE-COMMAND or END-COMMAND
	else If  END-NOTE-COMMAND
	    perform			5320-END-NOTE-COMMAND.
*===========================================================
*	M A C R O    C O M M A N D    R O U T I N E S
*============================================================

*-------------------
* Each-Field Command
*-------------------

5110-EACH-FIELD-COMMAND.
	If  FIELD-FILE-CLOSED
	    set FIELD-FILE-INDEX	to 0
	    set FIELD-FILE-STATUS	to 1.
	perform				9300-START-COMMAND
		until not EACH-FIELD-COMMAND.

*-------------------
* Each-Image Command
*-------------------

5120-EACH-IMAGE-COMMAND.
	If  RECURS-FILE-CLOSED
	    open	OUTPUT		RECURS-FILE
	    set RECURS-FILE-STATUS	to 1.
	perform				9300-START-COMMAND
		until not EACH-IMAGE-COMMAND.

*-------------
* Else Command
*-------------

5130-ELSE-COMMAND.
	If  CONDITION-STACK (CONDITION-INDEX) = 1
	    If  CONDITION-FALSE
		set CONDITION-VALUE	to 1
		perform			9400-POP-COMMAND
	    else
		set  CONDITION-VALUE	to 0
		perform			9500-EAT
		perform			9500-EAT
		until END-IF-COMMAND or IF-COMMAND or IF-NOT-COMMAND
			or END-COMMAND
	else
	    perform			9500-EAT
	    perform			9500-EAT
	    until END-IF-COMMAND or IF-COMMAND or IF-NOT-COMMAND
		or END-COMMAND.


*------------
* End Command
*------------

5140-END-COMMAND.
	perform				9400-POP-COMMAND.
	If  not START-COMMAND
	    set SOURCE-CODE-PTR		to 2
	    move END-COMMAND-ERROR	to CURRENT-ERROR
	    perform			9999-RECORD-ERROR.
	If  CONDITION-INDEX NOT ZERO
	    set SOURCE-CODE-PTR		to 2
	    move IF-SYNC-ERROR		to CURRENT-ERROR
	    perform			9999-RECORD-ERROR.
	move 'END'			to MACRO-COMMAND.

*------------------
* End-Field Command
*------------------

5150-END-FIELD-COMMAND.
	perform				9400-POP-COMMAND.
	If  not EACH-FIELD-COMMAND
	    move END-FIELD-ERROR	to CURRENT-ERROR
	    perform			9999-RECORD-ERROR.
	set FIELD-DATA-INDEX		up by 1.
	If  FIELD-DATA-INDEX > FIELD-DATA-MAX-INDEX
	    perform			5151-WRAPUP-FIELD
	else
	    perform			5152-REPEAT-FIELD.

5151-WRAPUP-FIELD.
	perform				9400-POP-COMMAND.
	set FIELD-DATA-INDEX		to 1.
	set FIELD-FILE-STATUS		to 0.
	If  RECURS-FILE-STATUS = 2
	    set INPUT-FLAG		to 1
	else
	    set INPUT-FLAG		to 0.
5152-REPEAT-FIELD.
	set FIELD-FILE-INDEX		to 0.
	set INPUT-FLAG			to 2.
	set FIELD-FILE-STATUS		to 2.
*---------------
* End-If Command
*---------------

5210-END-IF-COMMAND.
	perform				5211-POP-CONDITION.
	If  CONDITION-TRUE
	    perform			9400-POP-COMMAND
	else
	    perform			9500-EAT
	    perform			9500-EAT
		until	END-IF-COMMAND or ELSE-COMMAND or IF-COMMAND
			or IF-NOT-COMMAND or END-COMMAND.

5211-POP-CONDITION.
	IF  CONDITION-INDEX > 0
	    set CONDITION-VALUE		to CONDITION-STACK (CONDITION-INDEX)
	    set CONDITION-INDEX		down by 1
	ELSE
	    SET CONDITION-VALUE		TO 0.


*------------------
* End-Image Command
*------------------

5220-END-IMAGE-COMMAND.
	perform				9400-POP-COMMAND.
	If  not EACH-IMAGE-COMMAND
	    move END-IMAGE-ERROR	to CURRENT-ERROR
	    perform			9999-RECORD-ERROR.
	set IMAGE-DATA-INDEX		up by 1.
	If  IMAGE-DATA-INDEX > IMAGE-DATA-MAX-INDEX
	    perform			5221-WRAPUP-IMAGE
	else
	    perform			5222-REPEAT-IMAGE.

5221-WRAPUP-IMAGE.
	set IMAGE-DATA-INDEX		to 1.
	CLOSE	RECURS-FILE	DELETE.
	set RECURS-FILE-STATUS		to 0.
	set INPUT-FLAG			to 0.
	perform				9400-POP-COMMAND.

5222-REPEAT-IMAGE.
	CLOSE	RECURS-FILE.
	open	INPUT	RECURS-FILE.
	set INPUT-FLAG			to 1.
	set RECURS-FILE-STATUS		to 2.


*-----------
* If Command
*-----------

5230-IF-COMMAND.
	perform				9600-PUSH-CONDITION.
	IF  CONDITION-TRUE
	    perform			9700-TEST-CONDITION.
	IF CONDITION-TRUE
	    perform			9400-POP-COMMAND
	else
	    perform			9500-EAT
	    perform			9500-EAT
		until END-IF-COMMAND or ELSE-COMMAND or IF-NOT-COMMAND
		      or IF-COMMAND or END-COMMAND.


*---------------
* If-not Command
*---------------

*	False is true and true is false.
5240-IF-NOT-COMMAND.
	perform				9600-PUSH-CONDITION.
	IF  CONDITION-TRUE
	    perform			9700-TEST-CONDITION
	    If  CONDITION-TRUE
		set CONDITION-VALUE	to 0
	    else
		set CONDITION-VALUE	to 1.
	IF CONDITION-TRUE
	    perform			9400-POP-COMMAND
	else
	    perform			9500-EAT
	    perform			9500-EAT
		until END-IF-COMMAND or ELSE-COMMAND or IF-NOT-COMMAND
		      or IF-COMMAND or END-COMMAND.

*------------
* set Command
*------------
5250-SET-COMMAND.
	set SKELETON-PTR		to 6.
	unstring SKELETON-RECORD
		delimited by		ALL SPACE
		into			SET-NAME
		pointer			SKELETON-PTR.
	Set SKELETON-PTR		up by 3.
	Unstring SKELETON-RECORD
		delimited by 		ALL SPACE
		into			SET-VALUE
		pointer			SKELETON-PTR.
	If  IMAGE-SET-NAME
	    move SET-VALUE		to IMAGE-DATA-INDEX.
	If  MACRO-COMMAND-STACK-PTR > 0
	    perform			9400-POP-COMMAND
	ELSE
	    move 'END'			to MACRO-COMMAND.

*-------------
* Page command
*-------------

5310-PAGE-COMMAND.
	move WS-PAGE-EJECT		to SOURCE-CODE-RECORD.
	perform				8600-WRITE-SOURCE-LINE.
	If  MACRO-COMMAND-STACK-PTR > 0
	    perform			9400-POP-COMMAND
	else
	    move 'END'			to MACRO-COMMAND.

*------------------
* End-note Command
*-----------------

5320-END-NOTE-COMMAND.
	If  MACRO-COMMAND-STACK-PTR > 0
	    perform			9400-POP-COMMAND
	else
	    move 'END'			TO MACRO-COMMAND.
8000-READ-FL.
	set FILE-LANGUAGE-PTR		to 1.
	read FILE-LANGUAGE-FILE
		at end
		   set FILE-LANGUAGE-END-SW to YES-VALUE.
	If  not FILE-LANGUAGE-END
	    If  FL-FILE-NUMBERED-NO
		NEXT SENTENCE
	    else
	    If  FL-FILE-NUMBERED-YES
		set FILE-LANGUAGE-PTR		to 7
	    else
	    If  FLR-NUM-TEST IS NUMERIC
		set FL-FILE-NUMBERED-FLAG	to 2
		set FILE-LANGUAGE-PTR		to 7
	    else
		set FL-FILE-NUMBERED-FLAG	to 1.

8100-READ.
	set SKELETON-PTR		to 1.
	If  SKELETON-FILE-READ
	    perform			8200-READ-SKELETON
	else If RECURS-FILE-READ
	    perform			8300-READ-RECURS
	else If FIELD-FILE-READ
	    perform			9100-INPUT-FIELD.

8200-READ-SKELETON.
	read SKELETON-FILE
		at end
		   move 'END'		to MACRO-COMMAND
		   set SKELETON-FILE-END-SW to YES-VALUE
		   move SPACE		to SKELETON-RECORD.
	If  SKL-FILE-NUMBERED-NOT-SET
	    If  SKELETON-LINE-NUMBER NUMERIC
		set SKL-FILE-NUMBERED-FLAG to YES-VALUE
	    else
		set SKL-FILE-NUMBERED-FLAG to NO-VALUE.
	If  SKL-FILE-NUMBERED
	    move SKELETON-BODY		to SKELETON-RECORD.
	If  RECURS-FILE-WRITE
	    perform			8500-RECURS-WRITE.
	If  FIELD-FILE-WRITE
	    perform			9200-FIELD-OUTPUT.

8300-READ-RECURS.
	read RECURS-FILE
		at end
		   close RECURS-FILE DELETE
		   move RECURS-FILE-ERROR to CURRENT-ERROR
		   perform		9999-RECORD-ERROR.
	move RECURS-RECORD		to SKELETON-RECORD.
	If  FIELD-FILE-WRITE
	    perform			9200-FIELD-OUTPUT.
8500-RECURS-WRITE.
	move SKELETON-RECORD		to RECURS-RECORD.
	write				RECURS-RECORD.

8600-WRITE-SOURCE-LINE.
	If  SOURCE-CODE-CHAR (1) = WS-PAGE-EJECT
	    set LINE-NUMBER		TO 0
	    set PAGE-NUMBER		up by 1
	else
	    set LINE-NUMBER		up by 100.
	PERFORM				9900-DO-NOTHING
	    VARYING VAR-IDX		FROM 105 BY -1
	    UNTIL SOURCE-CODE-VAR(VAR-IDX) NOT = SPACE
	    OR VAR-IDX = 1.
	write SOURCE-CODE-2
	    BEFORE ADVANCING 1 LINE.
	set SOURCE-CODE-PTR		to 1.
	move SPACE			to SOURCE-CODE-RECORD.
	If  LINE-NUMBER > 99700
	    move WS-PAGE-EJECT		to SOURCE-CODE-CHAR (1)
	    perform			8600-WRITE-SOURCE-LINE.
9100-INPUT-FIELD.
	set FIELD-FILE-INDEX		up by 1.
	move FIELD-FILE-ARRAY (FIELD-FILE-INDEX) to SKELETON-RECORD.

9200-FIELD-OUTPUT.
	set FIELD-FILE-INDEX		up by 1.
	If  FIELD-FILE-INDEX > 300
	    Display "? Field file length exceeded.".
	move SKELETON-RECORD		to FIELD-FILE-ARRAY (FIELD-FILE-INDEX).


*--------------
* Start Command
*--------------

9300-START-COMMAND.
	perform				8100-READ.
	If  COMMAND-LINE
	    perform			9310-PUSH-COMMAND
	else
	    perform			9320-LINE-SCAN
		until SKELETON-PTR > MAX-SOURCE-CODE-PTR
	    perform			8600-WRITE-SOURCE-LINE.

9310-PUSH-COMMAND.
	set MACRO-COMMAND-STACK-PTR	up by 1.
	move MACRO-COMMAND		to MACRO-COMMAND-STACK(MACRO-COMMAND-STACK-PTR).
	move SPACE			to MACRO-COMMAND.

9320-LINE-SCAN.
	move SPACE			to CURRENT-DELIMITER.
	unstring SKELETON-RECORD
		delimited by		BEGIN-DELIMITER
		into			SOURCE-CODE-WORK
		DELIMITER IN		CURRENT-DELIMITER
		COUNT IN		SOURCE-CODE-INDEX
		pointer			SKELETON-PTR.
	set SOURCE-CODE-INDEX		up by 1.
	If  SKELETON-PTR not> MAX-SOURCE-CODE-PTR
	    move '@'			to SOURCE-CODE-ARRAY(SOURCE-CODE-INDEX).
	string	SOURCE-CODE-WORK	delimited by '@'
		into			SOURCE-CODE-RECORD
		pointer			SOURCE-CODE-PTR.
	If  CURRENT-DELIMITER = BEGIN-DELIMITER
	    perform			9710-SUBSTITUTE-NAME.

9400-POP-COMMAND.
	IF  MACRO-COMMAND-STACK-PTR > 0
	    move MACRO-COMMAND-STACK(MACRO-COMMAND-STACK-PTR) to MACRO-COMMAND
	    set MACRO-COMMAND-STACK-PTR	down by 1
	ELSE
	    MOVE SPACES			TO MACRO-COMMAND.
9500-EAT.
	move SPACE			to SKELETON-RECORD.
	perform				8100-READ
		until COMMAND-LINE.
	set SKELETON-PTR		to 2.
	unstring SKELETON-RECORD
		delimited by		ALL SPACE or ALL WS-TAB
		into			MACRO-COMMAND
		pointer			SKELETON-PTR.


9600-PUSH-CONDITION.
	set CONDITION-INDEX		up by 1.
	set CONDITION-STACK (CONDITION-INDEX) to CONDITION-VALUE.

9700-TEST-CONDITION.
	unstring SKELETON-RECORD
		delimited by		BEGIN-DELIMITER
		into			SUBSTITUTE-NAME
		pointer			SKELETON-PTR.
	unstring SKELETON-RECORD
		delimited by		END-DELIMITER
		into			SUBSTITUTE-NAME
		pointer			SKELETON-PTR.
	perform				9710-FIELD-DATA-NAMES.
	inspect SYMBOL-WORK
		replacing all		'@'
		by			space.
	set SKELETON-PTR		up by 3.
	unstring SKELETON-RECORD
		delimited by		ALL SPACE
		into			CONDITION-TEMP
		pointer			SKELETON-PTR.
	set CONDITION-VALUE		to NO-VALUE.
	set SYMBOL-WORK-PTR		to 1.
	perform				9720-SEARCH
		until SYMBOL-WORK-PTR > 105
		or	CONDITION-TRUE.

9710-SUBSTITUTE-NAME.
	unstring SKELETON-RECORD
		delimited by		END-DELIMITER
		into			ASCII-SUBSTITUTE-NAME
		delimiter in		CURRENT-DELIMITER
		pointer			SKELETON-PTR.
	move ASCII-SUBSTITUTE-NAME	to SUBSTITUTE-NAME.
	If  SKELETON-PTR > MAX-SOURCE-CODE-PTR
	    move END-DELIMITER-ERROR	to CURRENT-ERROR
	    perform			9999-RECORD-ERROR
	else If RESERVED-VARIABLE
	    perform			9710-RESERVED-VARIABLE
	else
	    perform			9710-FIELD-DATA-NAMES
	    string	SYMBOL-WORK		delimited by '@'
		into				SOURCE-CODE-RECORD
		pointer				SOURCE-CODE-PTR.

9710-RESERVED-VARIABLE.
	IF DATE-VARIABLE
	    string WS-DATE-WORK
		delimited by		SIZE
		into			SOURCE-CODE-RECORD
		pointer			SOURCE-CODE-PTR
	else If RESERVED-NAME-CHAR-1 is numeric
	    unstring RESERVED-NAME delimited by space  into NEXT-COL-NO
	    perform			9730-ADJUST-OUTPUT-COLUMN
*	else If condition
	else
	    move RESERVED-VARIABLE-ERROR to CURRENT-ERROR
	    perform			9999-RECORD-ERROR.

9710-FIELD-DATA-NAMES.
	If  FIELD-NAME
	    move FIELD (FIELD-DATA-INDEX) to SYMBOL-WORK
	ELSE IF FLDIX-NAME
	    MOVE FLDIX (FIELD-DATA-INDEX) TO SYMBOL-WORK
	    move '@'			to SYMBOL-WORK-ARRAY (4)
	else If FLDNO-NAME
	    move FLDNO (FIELD-DATA-INDEX) to SYMBOL-WORK
	    move '@'			to SYMBOL-WORK-ARRAY (3)
	ELSE IF REDEF-NAME
	    MOVE REDEF (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF ISRDF-NAME
	    MOVE ISRDF (FIELD-DATA-INDEX) TO SYMBOL-WORK
	else If PICT-NAME
	    move PICT (FIELD-DATA-INDEX) to SYMBOL-WORK
	ELSE IF USIGE-NAME
	    MOVE USIGE (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF FSIGN-NAME
	    MOVE FSIGN (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF FSEP-NAME
	    MOVE FSEP (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF FOCUR-NAME
	    MOVE FOCUR (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF OLVL1-NAME
	    MOVE OLVL1 (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF OLVL2-NAME
	    MOVE OLVL2 (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF OLVL3-NAME
	    MOVE OLVL3 (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF FTO-NAME
	    MOVE FTO (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF DEPND-NAME
	    MOVE DEPND (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF ASCND-NAME
	    MOVE ASCND (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF DSCND-NAME
	    MOVE DSCND (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF INDXD-NAME
	    MOVE INDXD (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF INDX1-NAME
	    MOVE INDX1 (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF INDX2-NAME
	    MOVE INDX2 (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF INDX3-NAME
	    MOVE INDX3 (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF FSYNC-NAME
	    MOVE FSYNC (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF FJUST-NAME
	    MOVE FJUST (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF FBLNK-NAME
	    MOVE FBLNK (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE
	    PERFORM 9710-A.
	MOVE substitute-name		TO temp-substitute-name.
	IF  temp-substitute-name = ascii-substitute-name
	    MOVE symbol-work		TO sixbit-symbol-work
	    MOVE sixbit-symbol-work	TO symbol-work.

9710-A.
*PARAGRAPH TO OVERCOME 24-LEVEL NESTING LIMIT ON 'IF-ELSE'.
	IF  FVALU-NAME
	    MOVE FVALU (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF FDLMT-NAME
	    MOVE FDLMT (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF FDATA-NAME
	    MOVE FDATA (FIELD-DATA-INDEX) TO SYMBOL-WORK
	ELSE IF FDTA2-NAME
	    MOVE FDTA2 (FIELD-DATA-INDEX) TO SYMBOL-WORK
	else
	    perform				9710-IMAGE-DATA-NAMES.
 
9710-IMAGE-DATA-NAMES.
	If ITYPE-NAME
	    move ITYPE (IMAGE-DATA-INDEX)	to SYMBOL-WORK
	ELSE IF IDATA-NAME
	    MOVE IDATA (IMAGE-DATA-INDEX)	TO SYMBOL-WORK
	else
	    perform				9710-MODULE-DATA-NAMES.

9710-MODULE-DATA-NAMES.
	If MODTL-NAME
	   move MODTL			to SYMBOL-WORK
	else If FILNM-NAME
	    move FILNM			to SYMBOL-WORK
	ELSE IF ASIGN-NAME
	    MOVE ASIGN			TO SYMBOL-WORK
	ELSE IF ORG-NAME
	    MOVE ORG			TO SYMBOL-WORK
	else If ACCES-NAME
	    move ACCES			to SYMBOL-WORK
	ELSE IF MKEY-NAME
	    MOVE MKEY			TO SYMBOL-WORK
	ELSE IF MMODE-NAME
	    MOVE MMODE			TO SYMBOL-WORK
	ELSE IF MBLCK-NAME
	    MOVE MBLCK			TO SYMBOL-WORK
	ELSE IF MODNM-NAME
	    MOVE MODNM			TO SYMBOL-WORK
	ELSE IF RECNM-NAME
	    MOVE RECNM			TO SYMBOL-WORK
	else
	    move SYMBOL-ERROR		to CURRENT-ERROR
	    perform			9999-RECORD-ERROR.

9720-SEARCH.
	unstring SYMBOL-WORK
		delimited by		all space or ','
		into			CONDITION-WORK
		pointer			SYMBOL-WORK-PTR.
	If  CONDITION-WORK = CONDITION-TEMP
	    set CONDITION-VALUE		to YES-VALUE.


9730-ADJUST-OUTPUT-COLUMN.
	set CURR-COL-NO,
	    LAST-COL-NO,
	    LAST-SOURCE-PTR		to 0.
	perform				9731-CALC-LAST-COL-NO
	    varying  WS-INDEX  from 1 by 1
	      until  WS-INDEX  =  SOURCE-CODE-PTR.
	compute SOURCE-CODE-PTR  =  LAST-SOURCE-PTR + 1.
	If  (LAST-COL-NO + 1)  >  NEXT-COL-NO
	    perform			9732-INSERT-SPACE
		varying  SOURCE-CODE-PTR  from SOURCE-CODE-PTR by 1
		  until  SOURCE-CODE-PTR  >  MAX-SOURCE-CODE-PTR
	    perform			8600-WRITE-SOURCE-LINE
	    set LAST-COL-NO		to 0
	    set SOURCE-CODE-PTR		to 1.
	If  (LAST-COL-NO + 1)  not>  NEXT-COL-NO
	    divide   NEXT-COL-NO by TAB-WIDTH	giving NEXT-TAB-NO
	    multiply NEXT-TAB-NO by TAB-WIDTH giving NO-WARNING-COMP
	    move NO-WARNING-3		TO NEXT-TAB-NO
	    perform			9733-INSERT-TAB
		varying  SOURCE-CODE-PTR  from SOURCE-CODE-PTR by 1
		  until  LAST-COL-NO  NOT<  NEXT-TAB-NO
	    perform			9732-INSERT-SPACE
		varying  SOURCE-CODE-PTR  from SOURCE-CODE-PTR by 1
		  until  LAST-COL-NO  NOT<  NEXT-COL-NO.
9731-CALC-LAST-COL-NO.
	set CURR-COL-NO			up by 1.
	If  SOURCE-CODE-CHAR (WS-INDEX)  =  WS-TAB
	    divide  CURR-COL-NO by 8	giving    TALLY
					REMAINDER FILL-COUNT
	    COMPUTE CURR-COL-NO  =  CURR-COL-NO + 8 - FILL-COUNT
	else
	If  SOURCE-CODE-CHAR (WS-INDEX)  =  SPACE
	    NEXT SENTENCE
	else
	    move WS-INDEX		to LAST-SOURCE-PTR
	    move CURR-COL-NO		to LAST-COL-NO.

9732-INSERT-SPACE.
	move SPACE			to SOURCE-CODE-CHAR (SOURCE-CODE-PTR).
	set  LAST-COL-NO		up by 1.

9733-INSERT-TAB.
	move WS-TAB			to SOURCE-CODE-CHAR (SOURCE-CODE-PTR).
	divide  LAST-COL-NO by 8	giving    TALLY
					REMAINDER FILL-COUNT
	COMPUTE LAST-COL-NO  =  LAST-COL-NO + 8 - FILL-COUNT.

9900-DO-NOTHING.
 
*---------------------
* Record Error Routine
*---------------------
*	1.  Make sure SOURCE-CODE-PTR is where you want '^'.
*	2.  move error-name-ERROR	to CURRENT-ERROR.
*	3.  perform			9999-RECORD-ERROR.
9999-RECORD-ERROR.
	set WS-SAVE-PTR			to SOURCE-CODE-PTR.
	move SKELETON-RECORD		to SOURCE-CODE-RECORD.
	perform				8600-WRITE-SOURCE-LINE.
	move SPACE			to SOURCE-CODE-RECORD.
	set SOURCE-CODE-PTR		to WS-SAVE-PTR.
	string	'^'			delimited by SIZE
		into			SOURCE-CODE-RECORD
		pointer			SOURCE-CODE-PTR.
	SUBTRACT ERROR-LENGTH
	    from MAX-SOURCE-CODE-PTR	giving ERROR-LINE-PTR.
	If  SOURCE-CODE-PTR > ERROR-LINE-PTR
	    subtract ERROR-LENGTH,1	from SOURCE-CODE-PTR.
	string	ERROR-TEXT		delimited by '@'
		into			SOURCE-CODE-RECORD
		pointer			SOURCE-CODE-PTR.
	perform				8600-WRITE-SOURCE-LINE.
	set  ERROR-NUMBER		up by 1.
	set SKELETON-PTR		to MAX-SOURCE-CODE-PTR.
	set SKELETON-PTR		up by 1.
	move LINE-NUMBER		to LINE-NUMBER-PRT.
	display 'Error # ' ERROR-NUMBER '	(line/page) '
		LINE-NUMBER-PRT '/' PAGE-NUMBER.