370 lines
12 KiB
Plaintext
370 lines
12 KiB
Plaintext
|
*******************************************************************************
|
||
|
|
*
|
||
|
|
* uniVerse port of PI/open ENTRO.AS.IBAS subroutine
|
||
|
|
*
|
||
|
|
* Module %M% Version %I% Date %H%
|
||
|
|
*
|
||
|
|
* (c) Copyright 1998 Ardent Software Inc. - All Rights Reserved
|
||
|
|
* This is unpublished proprietary source code of Ardent Software Inc.
|
||
|
|
* The copyright notice above does not evidence any actual or intended
|
||
|
|
* publication of such source code.
|
||
|
|
*
|
||
|
|
*******************************************************************************
|
||
|
|
*
|
||
|
|
* Maintenance log - insert most recent change descriptions at top
|
||
|
|
*
|
||
|
|
* Date.... GTAR# WHO Description.........................................
|
||
|
|
* 10/14/98 23801 SAP Change copyrights.
|
||
|
|
* 02/24/93 11038 PVW Check for '@' being phrase instead of '@ID'.
|
||
|
|
* 12/07/92 10213 DPB Misc. Fixes
|
||
|
|
* 12/02/92 10213 PVW Further changes
|
||
|
|
* 12/02/92 10213 PVW Change UVPRINTMSG to *UVPRINTMSG
|
||
|
|
* 11/12/92 10213 PVW Port PI/open ENTRO to replace uniVerse REVISE.
|
||
|
|
*
|
||
|
|
*******************************************************************************
|
||
|
|
|
||
|
|
$OPTIONS INFORMATION
|
||
|
|
|
||
|
|
SUBROUTINE REVISE.ASSOC (MAT SYMBOLS, MAT MACRO,
|
||
|
|
SENT, NOUN, MAT D.D, PROCESS.ITEM, MAT VERIFY,
|
||
|
|
STRIPSTRINGS, EXPAND, DICT.DATA.FILE, FNAME,
|
||
|
|
ORIGINAL.SENTENCE, NUMBER.OF.PROMPTS, MAXIMUM.PROMPTS)
|
||
|
|
|
||
|
|
$INCLUDE UNIVERSE.INCLUDE REVISE.H
|
||
|
|
$INCLUDE UNIVERSE.INCLUDE VERBINSERT.H
|
||
|
|
|
||
|
|
@SYSTEM.SET = 0
|
||
|
|
ERROR.CODE = 0
|
||
|
|
|
||
|
|
DIM SYMBOLS(20)
|
||
|
|
DIM MACRO(20)
|
||
|
|
DIM D.D(20)
|
||
|
|
DIM VERIFY(20)
|
||
|
|
|
||
|
|
GROUPS = ''
|
||
|
|
NO.GROUPS = ''
|
||
|
|
GROUP.XREF = ''
|
||
|
|
AT.REVISE.REC = ''
|
||
|
|
|
||
|
|
MACRO.ID = RV$AT.REVISE
|
||
|
|
READ AT.REVISE.REC FROM DICT.DATA.FILE, MACRO.ID THEN
|
||
|
|
IF AT.REVISE.REC<2> = '' THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
|
||
|
|
CALL *UVPRINTMSG(001596,"") ;* insufficient privileges
|
||
|
|
STOP
|
||
|
|
END
|
||
|
|
END
|
||
|
|
|
||
|
|
IF SYMBOLS(NOUN) = '' THEN
|
||
|
|
GOSUB PROCESS.MACRO
|
||
|
|
END
|
||
|
|
|
||
|
|
NUMBER.OF.PROMPTS = 0
|
||
|
|
HadId = 0
|
||
|
|
SINGLE.VALUES.ONLY = TRUE
|
||
|
|
GOSUB PROCESS.NOUNS
|
||
|
|
SINGLE.VALUES.ONLY = FALSE
|
||
|
|
GOSUB PROCESS.NOUNS
|
||
|
|
*
|
||
|
|
* Verify that file id has been mentioned once and only once.
|
||
|
|
*
|
||
|
|
MAT VERIFY = ''
|
||
|
|
ID.FOUND = FALSE
|
||
|
|
FOR I = 1 TO NUMBER.OF.PROMPTS
|
||
|
|
IF D.D(I)<1,RV$PRO.FLD.LOCATION> = 0 THEN
|
||
|
|
ID.FOUND = TRUE
|
||
|
|
IF I # 1 THEN
|
||
|
|
TEMP.D.D = D.D(I)
|
||
|
|
D.D(I) = D.D(1)
|
||
|
|
D.D(1) = TEMP.D.D
|
||
|
|
END
|
||
|
|
END
|
||
|
|
NEXT I
|
||
|
|
|
||
|
|
IF NOT(ID.FOUND) THEN
|
||
|
|
PROCESS.AT.ID:
|
||
|
|
READ AT.ID.REC FROM DICT.DATA.FILE,RV$AT.ID ELSE
|
||
|
|
AT.ID.REC = @FM:0:@FM:@FM:'RECORD ID':@FM:'25L'
|
||
|
|
END
|
||
|
|
IF AT.ID.REC<4> EQ '' THEN AT.ID.REC<4> = 'RECORD ID'
|
||
|
|
|
||
|
|
FOR I = NUMBER.OF.PROMPTS TO 1 STEP -1
|
||
|
|
D.D(I+1) = D.D(I)
|
||
|
|
NEXT I
|
||
|
|
|
||
|
|
D.D(1) = FNAME
|
||
|
|
D.D(1)<1,RV$PRO.FLD.LOCATION> = AT.ID.REC<2>
|
||
|
|
D.D(1)<1,RV$PRO.FLD.CONVERSION> = AT.ID.REC<3>
|
||
|
|
D.D(1)<1,RV$PRO.FLD.DISPLAY> = AT.ID.REC<4>
|
||
|
|
D.D(1)<1,RV$PRO.FLD.FORMAT> = AT.ID.REC<5>
|
||
|
|
|
||
|
|
NUMBER.OF.PROMPTS += 1
|
||
|
|
|
||
|
|
IF NUMBER.OF.PROMPTS >= MAXIMUM.PROMPTS THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
STOP 'The Maximum number of prompt fields (':MAXIMUM.PROMPTS:') allowed in REVISE has been exceeded'
|
||
|
|
END
|
||
|
|
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
***** subroutines follow ******************************************************
|
||
|
|
*
|
||
|
|
* The following subroutine processes the list of nouns in
|
||
|
|
* the symbol table. 'I' types are handled under SYMBOLS(ITYPE).
|
||
|
|
*
|
||
|
|
PROCESS.NOUNS:
|
||
|
|
I = 1
|
||
|
|
LOOP Q = SYMBOLS(NOUN)<I> UNTIL Q = '' DO
|
||
|
|
|
||
|
|
ID = Q<1,1>
|
||
|
|
WORD.NO = Q<1,2>
|
||
|
|
DICT.REC = SYMBOLS(WORD.NO)
|
||
|
|
|
||
|
|
IF NOT(NUM(DICT.REC<2>)) THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
PRINT "The location (":DICT.REC<2>:") for token '":ID:"' is not valid."
|
||
|
|
STOP
|
||
|
|
END
|
||
|
|
|
||
|
|
GRP.NAME = ""
|
||
|
|
IF DICT.REC[1,1] = 'D' THEN
|
||
|
|
SINGLE.VALUE = TRUE
|
||
|
|
IF DICT.REC<6>[1,1] = 'M' THEN
|
||
|
|
SINGLE.VALUE = FALSE
|
||
|
|
GRP.NAME = DICT.REC<7>
|
||
|
|
END
|
||
|
|
END ELSE
|
||
|
|
SINGLE.VALUE = FALSE
|
||
|
|
BEGIN CASE
|
||
|
|
CASE DICT.REC<4>[1,2] = 'C;' OR DICT.REC<8>[1,3] = 'D1;'
|
||
|
|
GRP.NAME = 'DC':DICT.REC<2>
|
||
|
|
CASE DICT.REC<4>[1,2] = 'D;' OR DICT.REC<8>[1,3] = 'D2;'
|
||
|
|
GRP.NAME = 'DC':FIELD(DICT.REC<4>,';',2)
|
||
|
|
CASE 1
|
||
|
|
GRP.NAME = ''
|
||
|
|
END CASE
|
||
|
|
END
|
||
|
|
|
||
|
|
BEGIN CASE
|
||
|
|
CASE SINGLE.VALUES.ONLY AND NOT(SINGLE.VALUE)
|
||
|
|
NULL
|
||
|
|
CASE NOT(SINGLE.VALUES.ONLY) AND SINGLE.VALUE
|
||
|
|
NULL
|
||
|
|
CASE GRP.NAME NE ''
|
||
|
|
IF INDEX(GROUPS:@FM,@FM:GRP.NAME:@FM,1) THEN
|
||
|
|
* group already done *
|
||
|
|
NULL
|
||
|
|
END ELSE
|
||
|
|
GOSUB PROCESS.GROUP
|
||
|
|
END
|
||
|
|
CASE 1
|
||
|
|
IF DICT.REC<2,1> = 0 AND HadId = 1 THEN GOTO SKIPTO
|
||
|
|
HadId = 1
|
||
|
|
NUMBER.OF.PROMPTS += 1
|
||
|
|
IF NUMBER.OF.PROMPTS >= MAXIMUM.PROMPTS THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
PRINT 'The Maximum number of prompt fields (':MAXIMUM.PROMPTS:') allowed in REVISE has been exceeded'
|
||
|
|
STOP
|
||
|
|
END
|
||
|
|
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.LOCATION> = DICT.REC<2,1>
|
||
|
|
IF DICT.REC<1> = 'D' THEN
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.CONVERSION> = DICT.REC<3,1>
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.FORMAT> = DICT.REC<5,1>
|
||
|
|
NAME = DICT.REC<4>
|
||
|
|
END ELSE
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.CONVERSION> = DICT.REC<8>
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.FORMAT> = DICT.REC<10,1>:DICT.REC<9,1>
|
||
|
|
NAME = DICT.REC<3>
|
||
|
|
END
|
||
|
|
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.BRIEFHELP> = ID
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.NAME> = ID
|
||
|
|
|
||
|
|
GOSUB GET.DISPLAY.NAME
|
||
|
|
|
||
|
|
IF NOT(SINGLE.VALUE) THEN
|
||
|
|
GOSUB FORMAT.DISPLAY.NAME
|
||
|
|
NO.GROUPS += 1
|
||
|
|
IF NO.GROUPS EQ 1 THEN
|
||
|
|
PROCESS.ITEM<RV$PRO.SCREEN.HEADING,1> = UVREADMSG(010269,"")
|
||
|
|
END
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.SCREEN.NO> = NO.GROUPS + 1
|
||
|
|
GRP.NAME = Q<1,1>
|
||
|
|
PROCESS.ITEM<RV$PRO.SCREEN.HEADING,NO.GROUPS + 1> = GRP.NAME
|
||
|
|
GROUPS := @FM:GRP.NAME
|
||
|
|
END
|
||
|
|
END CASE
|
||
|
|
SKIPTO:
|
||
|
|
I += 1
|
||
|
|
REPEAT
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
* The following subroutine processes associations.
|
||
|
|
*
|
||
|
|
PROCESS.GROUP:
|
||
|
|
READ GRP FROM DICT.DATA.FILE,GRP.NAME ELSE
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
PRINT "The Association name in field ",Q<1,1>,"is not defined on the "
|
||
|
|
PRINT "Dictionary of",FNAME
|
||
|
|
STOP
|
||
|
|
END
|
||
|
|
* GET THE ASSOCIATION PHRASE
|
||
|
|
FMC=2
|
||
|
|
X=''
|
||
|
|
MORE.GRP:
|
||
|
|
X := GRP<FMC>
|
||
|
|
IF X[LEN(X),1]='_' THEN
|
||
|
|
X=X[1,LEN(X)-1]:' '
|
||
|
|
FMC+=1
|
||
|
|
GO MORE.GRP
|
||
|
|
END
|
||
|
|
GRP=TRIM(X)
|
||
|
|
NO.GROUPS+=1 ;* NEW ASSOCIATION
|
||
|
|
IF NO.GROUPS EQ 1 THEN
|
||
|
|
PROCESS.ITEM<RV$PRO.SCREEN.HEADING,1> = UVREADMSG(010269,"")
|
||
|
|
END
|
||
|
|
GROUPS := @FM:GRP.NAME
|
||
|
|
PROCESS.ITEM<RV$PRO.SCREEN.HEADING,NO.GROUPS + 1> = GRP
|
||
|
|
|
||
|
|
J=1
|
||
|
|
LOOP ID = FIELD(GRP,' ',J) UNTIL ID='' DO
|
||
|
|
READ DICT.REC FROM DICT.DATA.FILE,ID ELSE
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
PRINT "Member",ID,"in Association",GRP.NAME,"is not defined on the Dictionary of",FNAME
|
||
|
|
STOP
|
||
|
|
END
|
||
|
|
|
||
|
|
IF DICT.REC[1,1] = 'D' OR DICT.REC[1,1] = 'A' OR DICT.REC[1,1] = 'S' THEN
|
||
|
|
|
||
|
|
NUMBER.OF.PROMPTS += 1
|
||
|
|
IF NUMBER.OF.PROMPTS >= MAXIMUM.PROMPTS THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
STOP 'The Maximum number of prompt fields (':MAXIMUM.PROMPTS:') allowed in REVISE has been exceeded'
|
||
|
|
END
|
||
|
|
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.LOCATION> = DICT.REC<2,1>
|
||
|
|
IF DICT.REC[1,1] = 'D' THEN
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.CONVERSION> = DICT.REC<3,1>
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.FORMAT> = DICT.REC<5,1>
|
||
|
|
NAME = DICT.REC<4>
|
||
|
|
END ELSE
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.CONVERSION> = DICT.REC<7,1>
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.FORMAT> = DICT.REC<10,1>:DICT.REC<9,1>
|
||
|
|
NAME = DICT.REC<3>
|
||
|
|
END
|
||
|
|
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.BRIEFHELP> = ID
|
||
|
|
|
||
|
|
GOSUB GET.DISPLAY.NAME
|
||
|
|
|
||
|
|
IF NOT(INDEX(@FM:SYMBOLS(NOUN),@FM:ID:@VM,1)) THEN
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.DISPLAYONLY> = 1
|
||
|
|
END
|
||
|
|
IF D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.DISPLAY> = '' THEN
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.DISPLAY> = ID
|
||
|
|
END
|
||
|
|
|
||
|
|
IF D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.LOCATION> = 0
|
||
|
|
THEN
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.NAME> = "RECORD ID"
|
||
|
|
END
|
||
|
|
ELSE
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.NAME> = ID
|
||
|
|
END
|
||
|
|
|
||
|
|
GOSUB FORMAT.DISPLAY.NAME
|
||
|
|
|
||
|
|
GROUP.XREF<NO.GROUPS,-1> = NUMBER.OF.PROMPTS
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.SCREEN.NO> = NO.GROUPS + 1
|
||
|
|
END
|
||
|
|
J += 1
|
||
|
|
REPEAT
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
* The following subroutine formats the display name
|
||
|
|
*
|
||
|
|
GET.DISPLAY.NAME:
|
||
|
|
IF NAME = '' THEN
|
||
|
|
IF D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.LOCATION> = 0 THEN
|
||
|
|
NAME = "RECORD ID"
|
||
|
|
END
|
||
|
|
ELSE
|
||
|
|
NAME = ID
|
||
|
|
END
|
||
|
|
END ELSE
|
||
|
|
IF INDEX(NAME,@VM,1) THEN CONVERT @VM TO ' ' IN NAME
|
||
|
|
END
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.DISPLAY> = NAME
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
* The following subroutine ensures the field is wide enough to
|
||
|
|
* display the column header.
|
||
|
|
*
|
||
|
|
FORMAT.DISPLAY.NAME:
|
||
|
|
FORMAT=D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.FORMAT>
|
||
|
|
FOR Y=1 TO 10 UNTIL NUM(FORMAT[Y,1]) ; NEXT Y
|
||
|
|
FOR X=Y TO 10 WHILE NUM(FORMAT[X,1]) ; NEXT X
|
||
|
|
WIDE=FORMAT[Y,X-Y]
|
||
|
|
|
||
|
|
COLUMN.HEADER.WIDTH = LEN(D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.NAME>)
|
||
|
|
|
||
|
|
IF WIDE < COLUMN.HEADER.WIDTH THEN
|
||
|
|
COLUMN.HEADER.WIDTH = LEN(D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.DISPLAY>)
|
||
|
|
FORMAT=FORMAT[1,Y-1]:COLUMN.HEADER.WIDTH:FORMAT[X,10]
|
||
|
|
D.D(NUMBER.OF.PROMPTS)<1,RV$PRO.FLD.FORMAT> = FORMAT
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
* The following subroutine processes the macro.
|
||
|
|
*
|
||
|
|
PROCESS.MACRO:
|
||
|
|
IF AT.REVISE.REC NE '' THEN
|
||
|
|
MATPARSE MACRO FROM AT.REVISE.REC,@FM
|
||
|
|
END ELSE
|
||
|
|
MACRO.ID = '@'
|
||
|
|
MATREAD MACRO FROM DICT.DATA.FILE,MACRO.ID ELSE
|
||
|
|
CALL @REVISE.PHRASE(DICT.DATA.FILE,X)
|
||
|
|
IF X = '' THEN RETURN TO PROCESS.AT.ID
|
||
|
|
MATPARSE MACRO FROM X, @FM
|
||
|
|
END
|
||
|
|
END
|
||
|
|
IF MACRO(1)[1,2] = 'PH' THEN
|
||
|
|
MORE.MACRO:
|
||
|
|
IF MACRO(2)[LEN(MACRO(2)),1] = '_' THEN
|
||
|
|
MACRO(2) = TRIM(MACRO(2)[1,LEN(MACRO(2))-1])
|
||
|
|
MORE.FLAG = TRUE
|
||
|
|
END ELSE
|
||
|
|
MORE.FLAG = FALSE
|
||
|
|
END
|
||
|
|
SENT := ' ':MACRO(2)
|
||
|
|
|
||
|
|
IF MORE.FLAG THEN
|
||
|
|
MACRO(2) = MACRO(0)<1>
|
||
|
|
IF MACRO(2) NE '' THEN
|
||
|
|
MACRO(0) = DELETE(MACRO(0),1,0,0)
|
||
|
|
GO MORE.MACRO
|
||
|
|
END
|
||
|
|
END
|
||
|
|
|
||
|
|
OUTBUF=''
|
||
|
|
CALL @STRIPSTRINGS(SENT,MAT SYMBOLS)
|
||
|
|
CALL @EXPAND(SENT,OUTBUF,MAT SYMBOLS, ERROR.CODE)
|
||
|
|
|
||
|
|
IF ERROR.CODE THEN
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
STOP
|
||
|
|
END
|
||
|
|
|
||
|
|
SENT=OUTBUF
|
||
|
|
END ELSE
|
||
|
|
@SYSTEM.SET = -1
|
||
|
|
CALL *UVPRINTMSG(001600,MACRO.ID) ;* record not PHrase
|
||
|
|
STOP
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
END
|