johnblood/tldm-universe
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
main
tldm-universe/Ardent/UV/APP.PROGS/GCI.MAINT

962 lines
31 KiB
Plaintext
Raw Permalink Normal View History

first push of universe files
2024-09-09 21:51:08 +00:00
*****************************************************************************
*
* Maintain GGI File
*
* 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.
*
*******************************************************************************
*
* Maintenence log - insert most recent change descriptions at top
*
* Date.... GTAR# WHO Description.........................................
* 10/14/98 23801 SAP Change copyrights.
* 03/25/96 18026 PGW For MS Win, allow GCI file name on command line
* 03/21/96 17935 JC Added new wchar_t varients.
* 04/22/94 12300 LA Added new fields for PI/open data types + extra
* validation.
* 02/18/90 6841 DTW comment out prompts to update DATA.TYPES file
* 10/15/89 6314 DTW add module prompt
* 07/25/88 - - Maintenence log purged at 5.2.1, see release 5.1.10.
*
*******************************************************************************
*
* This program was produced in part by SCREENGEN, a proprietary program of
* Infocel, Inc., P.O. Box 18305, Raleigh, N.C. 27609
*
*****************************************************************************
*
*
*
*
$OPTIONS A
CLEAR COMMON
COMMON CLR, CL, CL.ERR, PROMPT, ERR, HELP, HELP3, STD.HELP, MV.HELP,
ERR.MSG, MSG1, MSG2, MSG3, MSG4, MSG5, MSG6,
ID, Q, NEW.ITEM, REC(12)
*
$INCLUDE UNIVERSE.INCLUDE MACHINE.NAME
*
CLR = @(-1)
CL = @(-4)
CL.ERR = @(0,23):CL
EQU BELL TO CHAR(7)
PROMPT=@(0,22):CL:@(0,21):CL ; PROMPT ""
*
EQU TRUE TO 1, FALSE TO 0
*
ERR = CL.ERR:BELL
HELP = CL.ERR
HELP3 = CL.ERR:PROMPT
*
STD.HELP=HELP3
STD.HELP=STD.HELP:'Enter "?" for help, "^" to back up to previous prompt, "XX" to cancel input,'
STD.HELP=STD.HELP:@(0,22):' or data value requested by prompt. Data will be edited and an error'
STD.HELP=STD.HELP:@(0,23):' will appear if data are invalid. --- Enter <CR>'
MV.HELP=HELP3
MV.HELP=MV.HELP:'Enter "?" for help, "^" to back up to previous prompt, "XX" to cancel input,'
MV.HELP=MV.HELP:@(0,22):' "+" to display next value group, "DE" to delete value, "I" to insert value,'
MV.HELP=MV.HELP:@(0,23):' "/" to end value input, or data value requested. --- Enter <CR>'
SUB.HELP=HELP3:'Name used in BASIC program to call C/F77 subroutine. '
SUB.HELP=SUB.HELP:@(0,22):'If it is called as a BASIC subroutine or is defined using a "DEFFUN" statement, the'
SUB.HELP=SUB.HELP:@(0,23):'the first character of this name must one of the characters *,-,$, or !.'
LANG.HELP=HELP3:'Languages supported are "c" (default) and "f77".'
EXT.HELP=HELP3:'Name of the c/f77 routine defined in the source file.'
EXT.HELP=EXT.HELP:@(0,22):'By default, this is the same as the subroutine name.'
MOD.HELP=HELP3:'Name of the module containing the c/f77 subroutine, without the ".c" or ".f"'
MOD.HELP=MOD.HELP:@(0,22):'suffix. By default, this is the same as the subroutine name.'
DESC.HELP=HELP3:'A short description of the subroutine (optional).'
ARGS.HELP=HELP3:'The number of arguments to the c/f77 routine.'
RET.HELP=HELP3:'Return value of the c/f77 routine.'
RET.HELP=RET.HELP:@(0,22):'For "c" routines, this can be a valid data type or "void".'
RET.HELP=RET.HELP:@(0,23):'For "f77" routines, it can only be "void".'
DIR.HELP=HELP3:'Argument direction: Input (I), Ouput (O) or Input/Output (I/O or B).'
TYP.HELP=HELP3:'Data type of argument.'
TYP.HELP=TYP.HELP:@(0,22):'For supported data types see the DATA.TYPES file or the GCI manual.'
LEN.HELP=HELP3:'Length of character string.'
LEN.HELP=LEN.HELP:@(0,22):'This is only used for character types which require the GCI to allocate space'
LEN.HELP=LEN.HELP:@(0,23):'("c" types "lchar*" and "charvar*", "f77" type "character").'
ROW.HELP=HELP3:'Enter number of rows for numeric array, or <CR> if this is not an array'
ROW.HELP=ROW.HELP:@(0,22):'argument.'
COL.HELP=HELP3:'Enter number of columns for a two-dimensional array, or <CR> if this is only'
COL.HELP=COL.HELP:@(0,22):'a single-dimensional array.'
ARGDESC.HELP=HELP3:'A short description of the argument (optional).'
ERR.MSG=ERR:"Your response does not pass the edits. Enter a new response."
MSG1=ERR:'Unable to open the file - '
MSG2=ERR:'A response is required.'
MSG3=ERR:'Response is too long.'
MSG4=ERR:'Numeric input required.'
MSG5=ERR:'Invalid data type specified.'
MSG6=ERR:'Number of arguments does not match the number of data types'
MSG7=ERR:'This data type does not have an input conversion'
MSG8=ERR:'This data type does not have an output conversion'
MSG9=ERR:'Number of arguments does no match the number of argument types'
MSG10=ERR:PROD.NAMEU:' General Calling Interface is not installed.'
MSG11=ERR:'Invalid language specified.'
MSG12=ERR:'Negative values are invalid'
*
*
EQU AM TO CHAR(254)
EQU VM TO CHAR(253)
EQU SVM TO CHAR(252)
EQU NO.DATA TO CHAR(0)
*
*
MV5=1 ;* IO.ARGS
COL5=2:AM:2:AM:2:AM:2:AM:2
LIN5=13:AM:14:AM:15:AM:16:AM:17
*
COL6=18:AM:18:AM:18:AM:18:AM:18
LIN6=13:AM:14:AM:15:AM:16:AM:17
*
COL9=30:AM:30:AM:30:AM:30:AM:30
LIN9=13:AM:14:AM:15:AM:16:AM:17
*
COL10=39:AM:39:AM:39:AM:39:AM:39
LIN10=13:AM:14:AM:15:AM:16:AM:17
*
COL11=46:AM:46:AM:46:AM:46:AM:46
LIN11=13:AM:14:AM:15:AM:16:AM:17
*
COL12=53:AM:53:AM:53:AM:53:AM:53
LIN12=13:AM:14:AM:15:AM:16:AM:17
*
*
*
dim SAVE.REC( 12 )
*
EQU LANGUAGE TO REC(1)
EQU EXT.NAME TO REC(2), SAVE.EXT.NAME to SAVE.REC( 2 )
EQU MOD.NAME TO REC(7), SAVE.MOD.NAME to SAVE.REC( 7 )
EQU RET.VAL TO REC(3)
EQU NO.ARGS TO REC(4), SAVE.NO.ARGS to SAVE.REC( 4 )
EQU DATA.TYPES TO REC(5)
EQU IO.ARGS TO REC(6)
EQU SUB.DESC TO REC(8)
EQU LENGTHS TO REC(9)
EQU ROWS TO REC(10)
EQU COLS TO REC(11)
EQU ARG.DESCS TO REC(12)
*
IF OS.TYPE = "UNIX" THEN
DEF.FILE.NAME = 'GCI'
END ELSE
* Windows NT:
* You can specify the definition file by putting its name on the
* command line, otherwise it defaults to 'GCI'
CMD = CONVERT(" ", @FM, TRIM(@SENTENCE))
DEF.FILE.NAME = CMD<4>
IF DEF.FILE.NAME = "" THEN DEF.FILE.NAME = 'GCI'
END
SSA11=CLR ;* Maintain GCI
SSA11=SSA11:@(0,0):"General Calling Interface Administration":SPACE(28):" GCI.MAINT"
IF OS.TYPE = "UNIX" THEN
SSA11=SSA11:@(22,1):"Maintain ":PROD.NAMEU:" GCI File"
END ELSE
SSA11=SSA11:@(12,1):"Maintain GCI Definition File ":DEF.FILE.NAME
END
SSA11=SSA11:@(0,2):STR("-",79)
SSA11=SSA11:@(7,4):"Subroutine name:"
SSA11=SSA11:@(0,6):"1. Language:"
SSA11=SSA11:@(0,7):"2. External Name:"
SSA11=SSA11:@(0,8):"3. Module Name:"
SSA11=SSA11:@(0,9):"4. Description:"
SSA11=SSA11:@(0,10):"5. Number of Arguments:"
SSA11=SSA11:@(39,10):"6. Return Value:"
SSA11=SSA11:@(0,12):"7. Direction"
SSA11=SSA11:@(18,12):"Data Type"
SSA11=SSA11:@(30,12):"Length"
SSA11=SSA11:@(39,12):"Rows"
SSA11=SSA11:@(46,12):"Cols"
SSA11=SSA11:@(53,12):"Description"
SSA11=SSA11:@(0,13):"7.1"
SSA11=SSA11:@(0,14):"7.2"
SSA11=SSA11:@(0,15):"7.3"
SSA11=SSA11:@(0,16):"7.4"
SSA11=SSA11:@(0,17):"7.5"
SSA11=SSA11:@(0,19):STR("-",79)
*
CLR.SSA11=@(0,0):@(25,6):CL:@(25,7):CL:@(25,8):CL:@(25,9):CL:@(25,10):SPACE(5):@(57,10):CL
CLR.SSA11=CLR.SSA11:@(2,13):1:CL:@(2,14):2"L#70":@(2,15):3"L#70":@(2,16):4"L#70":@(1,17):".":5"L#70":@(25,4):CL
*
H.ROWS = ""
H.COLS = ""
1 OPEN '','DATA.TYPES' TO FVDATA.TYPES ELSE
PRINT MSG10:
INPUT Q: ; PRINT CL.ERR: ; STOP
END
2 OPEN '',DEF.FILE.NAME TO FVGCI ELSE
PRINT MSG1:DEF.FILE.NAME:
INPUT Q: ; PRINT CL.ERR: ; STOP
END
*
************* ENTER RECORD KEY ***************
*
30 PRINT SSA11: ;* Maintain GCI
LOOP
EXECUTE "PTERM CASE NOINVERT"
40 PRINT PROMPT:"Enter subroutine name: ":
INPUT ID,32: ; PRINT CL.ERR:PROMPT:
EXECUTE "PTERM CASE INVERT"
IF ID = "?" THEN
PRINT SUB.HELP: ; INPUT Q: ; PRINT HELP3
GOTO 40
END
IF LEN(ID)>32 THEN
PRINT MSG3:
GOTO 40
END
UNTIL ID='' OR ID='^' OR ID='XX' or ID="xx" DO
NEW.ITEM=FALSE
MATREAD REC FROM FVGCI,ID ELSE
*
*
MAT REC=''; NEW.ITEM=TRUE
END
mat SAVE.REC = mat REC
PRINT @(25,4):CL:ID:
GOSUB 50 ;*** UPDATE RECORD
REPEAT
STOP
50***** UPDATE SUBROUTINE *****
IF NEW.ITEM THEN ;***** PROMPT FOR INPUT OF NEW REC
MV=0
FOR Z = 1 TO 7
Q=NO.DATA
ON Z GOSUB 100,200,700,800,300,400,500
IF Q="^" THEN IF MV>1 THEN MV=MV-2 ; Z=Z-1 ELSE IF Z<=1 THEN GOTO 9999 ELSE Z=Z-2
IF Q="XX" or Q="xx" THEN GOTO 9999
NEXT Z
NEW.ITEM=FALSE
END ELSE
MV=0 ; Q=""; GOSUB 88 ;*** PRINT SCREEN AND DATA
END
*
*######################### PRIMARY CONTROL LOOP #########################
60*
LOOP
* PRINT PROMPT:"Enter save(S), cancel(XX), delete(DE), or field # to change: ":
PRINT PROMPT:"Enter save(S), cancel(XX), delete(DE), or field # to change: ":
INPUT Q ; PRINT CL.ERR:PROMPT:
Q = upcase( Q )
UNTIL Q="S" OR Q="s" OR Q="." DO
if Q = "+" then Q = "7,+"
Z=FIELD(Q,",",1)
BEGIN CASE
CASE Z>=1 AND Z<8 AND NUM(Z)
Q=Q[COL2()+1,999]
IF Q="" THEN Q=NO.DATA
ON Z GOSUB 100,200,700,800,300,400,500
MV=0
CASE Q="XX"
GOTO 9999
CASE Q="xx"
GOTO 9999
CASE Q="DE"OR Q="de"
PRINT PROMPT:"Are you sure you want to delete this record (Y/N)? ":
INPUT Z ; IF Z="Y" OR Z="y" THEN DELETE FVGCI,ID
print SSA11:
RETURN
CASE Q="R" OR Q="^^"; PRINT SSA11: ; GOSUB 88 ;* REFRESH SCREEN
CASE 1 ; PRINT ERR:'Enter one of the requested commands.':
END CASE
REPEAT
*
IF NO.ARGS#DCOUNT(DATA.TYPES,@VM) THEN
PRINT MSG6:
GOTO 60
END
IF NO.ARGS#DCOUNT(IO.ARGS,@VM) THEN
PRINT MSG9:
GOTO 60
END
MATWRITE REC ON FVGCI,ID
*
*
*
*
*
line.no = 0
eof = FALSE
found = 0
*
9999 PRINT CLR.SSA11:PROMPT:
RETURN ;********** EXIT UPDATE ROUTINE
*
88*** REFRESH DATA
PRINT @(25,4):CL:ID:
PRINT @(25,6):LANGUAGE "L#30"
PRINT @(25,7):EXT.NAME "L#32"
PRINT @(25,8):MOD.NAME "L#55"
PRINT @(25,9):SUB.DESC "L#50"
PRINT @(25,10):NO.ARGS "L#2"
PRINT @(57,10):RET.VAL "L#30"
GOSUB 560 ; MV=0 ;* DISPLAY IO.ARGS
Q=NO.DATA
RETURN
*
*##########################################################################
*
100*** ########## LANGUAGE
EXECUTE "PTERM CASE NOINVERT"
IF Q=NO.DATA THEN
110 PRINT PROMPT:"Enter subroutine language: ":STR(".",30):@(27,21):
INPUT Q,30: ; PRINT CL.ERR:PROMPT:
END
Q = DOWNCASE(Q)
IF Q="" THEN
Q="c"
END
IF Q="?" THEN
PRINT LANG.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 110
END
IF Q="^" OR Q="XX" or Q="xx" THEN
PRINT @(25,6):"" "L#30"
RETURN
END
130*** EDITS FOR LANGUAGE
IF Q # "c" THEN
PRINT MSG11:
GOTO 110
END
140*** DISPLAY LANGUAGE
LANGUAGE=Q
PRINT @(25,6):Q "L#30"
EXECUTE "PTERM CASE INVERT"
RETURN
*
200*** ########## EXT.NAME
EXECUTE "PTERM CASE NOINVERT"
IF Q=NO.DATA THEN
210 PRINT PROMPT:"Enter subroutine external name: ":STR(".",32):@(32,21):
INPUT Q,32: ; PRINT CL.ERR:PROMPT:
END
IF Q="" THEN
Q=ID
END
IF Q="?" THEN
PRINT EXT.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 210
END
IF Q="^" OR Q="XX" or Q="xx" THEN
PRINT @(25,7):"" "L#32"
RETURN
END
230*** EDITS FOR EXT.NAME
IF LEN(Q)>32 THEN
PRINT MSG3:
GOTO 210
END
240*** DISPLAY EXT.NAME
EXT.NAME=Q
PRINT @(25,7):Q "L#32"
EXECUTE "PTERM CASE INVERT"
RETURN
*
300*** ########## NO.ARGS
IF Q=NO.DATA THEN
310 PRINT PROMPT:"Enter the number of arguments: ":STR(".",2):@(31,21):
INPUT Q,2: ; PRINT CL.ERR:PROMPT:
END
IF Q="" THEN
PRINT MSG2:
GOTO 310
END
IF Q="?" THEN
PRINT ARGS.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 310
END
IF Q="^" OR Q="XX" or Q="xx" THEN
PRINT @(25,10):"" "L#2"
RETURN
END
330*** EDITS FOR NO.ARGS
ICONV.TEMP=ICONV(Q,"MD0")
IF STATUS()#0 THEN
PRINT MSG4:
GOTO 310
END
IF LEN(Q)>2 THEN
PRINT MSG3:
GOTO 310
END
IF Q < 0 THEN
PRINT MSG12:
GOTO 310
END
340*** DISPLAY NO.ARGS
NO.ARGS=Q
PRINT @(25,10):Q "L#2"
RETURN
*
400*** ########## RET.VAL
EXECUTE "PTERM CASE NOINVERT"
IF Q=NO.DATA THEN
410 PRINT PROMPT:"Enter the return value: ":str(".",30):@(24,21):
INPUT Q,30: ; PRINT CL.ERR:PROMPT:
END
Q = DOWNCASE(Q)
IF Q="" THEN
PRINT MSG2:
GOTO 410
END
IF Q="?" THEN
PRINT RET.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 410
END
IF Q="^" OR Q="xx" THEN
PRINT @(57,10):"" "L#30"
RETURN
END
*** EDITS FOR RET.VAL
IF LEN(Q)>30 THEN
PRINT MSG3:
GOTO 410
END
IF LANGUAGE = "f77" THEN
IF Q#'void' THEN
PRINT MSG5:
GOTO 410
END
END ELSE ;* 'c' - any valid data type
IF Q#'void' THEN
TYPES.ID = LANGUAGE:".":Q
READ DUMMY FROM FVDATA.TYPES,TYPES.ID ELSE
PRINT MSG5:
GOTO 410
END
IF DUMMY<2> = "" THEN
PRINT MSG8:
GOTO 410
END
END
END
440*** DISPLAY RET.VAL
RET.VAL = Q
PRINT @(57,10):Q "L#30"
EXECUTE "PTERM CASE INVERT"
RETURN
*
500*** ########## IO.ARGS
* MULTIVALUE
H.IO.ARGS=IO.ARGS
* EXECUTE "PTERM CASE NOINVERT"
VALUE.INSERTED=FALSE
IF NEW.ITEM THEN MV=MV+1 ELSE
MV=FIELD(Z,".",2) ; Z=INT(Z)
IF MV<1 THEN
IF Q="DE" OR Q="de" THEN
DATA.TYPES=""; IO.ARGS=""; MV=1 ; GOSUB 560 ;* DELETE FIELD
END ELSE IF Q="+" THEN MV=1 ELSE
FOR MV=1 TO 99 UNTIL IO.ARGS<1,MV>=""; NEXT MV
IF MV>MV5+5 THEN GOSUB 560 ;* DISPLAY FIELD
END
END ELSE IF IO.ARGS<1,MV>='' AND (Q#'DE' AND Q#'de') THEN GOTO 500
END
IF NO.ARGS<=0 THEN RETURN
IF Q=NO.DATA THEN
510 PRINT PROMPT:"Enter argument " : MV"R#2" : " direction (I/O/B): ":STR(".",4):@(37,21):
INPUT Q,4: ; PRINT CL.ERR:PROMPT:
IF ( Q="" or Q="/" ) AND NOT(VALUE.INSERTED) THEN
PRINT @(COL5<MOD(MV-1,5)+1>,LIN5<MOD(MV-1,5)+1>):MV:CL
MV=0 ;
* EXECUTE "PTERM CASE INVERT"
RETURN
END
END
IF Q="" AND NOT(NEW.ITEM) AND IO.ARGS<1,MV>#"" THEN GOTO 550 ;*DO NOT CHANGE VALUE
IF Q="" THEN
PRINT MSG2:
GOTO 510
END
IF Q="INS" OR Q="INSERT" THEN
VALUE.INSERTED=TRUE ; DATA.TYPES=INSERT(DATA.TYPES,1,MV,0,"")
IO.ARGS=INSERT(IO.ARGS,1,MV,0,"")
GOSUB 560 ; Q=NO.DATA ; GOTO 510 ;* INSERT MV
END
IF Q="+" THEN ;* DISPLAY ONLY
MV=MV5+5
GOSUB 560
* EXECUTE "PTERM CASE INVERT"
RETURN
END
IF Q="DE" OR Q="de" THEN ;* DELETE MV
DATA.TYPES=DELETE(DATA.TYPES,1,MV,0)
IO.ARGS=DELETE(IO.ARGS,1,MV,0)
GOSUB 560
* EXECUTE "PTERM CASE INVERT"
RETURN
END
IF Q="?" THEN
PRINT DIR.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 510
END
IF Q="^" OR Q="XX" or Q="xx" OR Q="/" THEN
* if Q="^" then Z -= 1
* EXECUTE "PTERM CASE INVERT"
IF NOT(VALUE.INSERTED) THEN
MV=0
return
END ELSE
DATA.TYPES=DELETE(DATA.TYPES,1,MV,0)
IO.ARGS=DELETE(IO.ARGS,1,MV,0)
GOSUB 560 ; MV=0
RETURN
END
END
530*** EDITS FOR IO.ARGS
Q=UPCASE(Q)
IF Q="I/O" THEN Q="B"
IF Q#"I" AND Q#"O" AND Q#"B" THEN
PRINT ERR:"Response must be Input(I), Output(O) or Both(B).":
GOTO 510
END
540*** DISPLAY IO.ARGS
H.IO.ARGS<1,MV>=Q
IF MV<MV5 OR MV>MV5+4 THEN GOSUB 560
PRINT @(COL5<MOD(MV-1,5)+1>,LIN5<MOD(MV-1,5)+1>):MV"L#3":Q "L#4"
550 FOR J = 1 TO 5
Q=NO.DATA ; ON J GOSUB 600, 900, 1000, 1100, 1200
IF (Q="XX" OR Q="xx") AND NEW.ITEM THEN RETURN
IF Q="^" OR Q="XX" or Q="xx" THEN IF J<=1 THEN GOTO 510 ELSE J=J-2 ; Q.PREV = Q
NEXT J
DATA.TYPES<1,MV>=H.DATA.TYPES<1,MV>
IO.ARGS<1,MV>=H.IO.ARGS<1,MV>
LENGTHS<1,MV>=H.LENGTHS<1,MV>
ROWS<1,MV>=H.ROWS<1,MV>
COLS<1,MV>=H.COLS<1,MV>
ARG.DESCS<1,MV>=H.ARG.DESCS<1,MV>
IF NEW.ITEM THEN MV=MV+1 ; GOTO 510 ELSE MV=0
RETURN
560 MV5=5*INT((MV-1)/5)+1 ;* DISPLAY FIELD
IF IO.ARGS<1,MV5>="" AND Q="+" THEN MV5=1
FOR K=MV5 TO MV5+4
PRINT @(COL5<MOD(K-1,5)+1>,LIN5<MOD(K-1,5)+1>):K"L#3":
IF IO.ARGS<1,K>="" THEN PRINT CL: ELSE
PRINT IO.ARGS<1,K> "L#4":
GOSUB 660 ;*DISPLAY ASSOCIATED VALUES
GOSUB 960
GOSUB 1060
GOSUB 1160
GOSUB 1260
END
NEXT K
PRINT @(COL5<5>-1,LIN5<5>):
IF IO.ARGS<1,K>#"" THEN PRINT "+" ELSE PRINT "."
RETURN
*
*
600*** ######### DATA.TYPES
* ASSOCIATED MULTIVALUE
Q.PREV = NO.DATA
EXECUTE "PTERM CASE NOINVERT"
H.DATA.TYPES=DATA.TYPES
IF Q=NO.DATA THEN
610 PRINT PROMPT:"Enter data type " : MV"R#2" :": ":STR(".",30):@(20,21):
INPUT Q,30: ; PRINT CL.ERR:PROMPT:
END
IF Q="" AND NOT(NEW.ITEM) AND DATA.TYPES<1,MV>#"" THEN
EXECUTE "PTERM CASE INVERT"
RETURN ;* DO NOT CHANGE VALUE
END
IF Q="" THEN
PRINT MSG2:
GOTO 610
END
IF Q="?" THEN
PRINT TYP.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 610
END
IF Q="^" OR Q="XX" OR Q="xx" THEN
* PRINT @(COL6<MOD(MV-1,5)+1>,LIN6<MOD(MV-1,5)+1>):"" "L#30"
PRINT @(COL6<MOD(MV-1,5)+1>,LIN6<MOD(MV-1,5)+1>):CL
EXECUTE "PTERM CASE INVERT"
RETURN
END
630*** EDITS FOR DATA.TYPES
IF LEN(Q)>30 THEN
PRINT MSG3:
GOTO 610
END
TYPES.ID=LANGUAGE:".":Q
READ DUMMY FROM FVDATA.TYPES,TYPES.ID ELSE
PRINT MSG5:
***
*** Can't modify DATA.TYPES file
***
* PRINT PROMPT:"Do you wish to add new data types (Y/N) ":
* INPUT ANS
* IF ANS="Y" OR ANS ="y" THEN
* PA=''
* PA<1>='RUN APP.PROGS TYPES.MAINT'
* PA<2>='DATA ':LANGUAGE
* PA<3>='DATA ':Q
* EXECUTE PA
* SAVE.Q=Q ; SAVE.MV=MV
* PRINT SSA11
* GOSUB 88
* Q=SAVE.Q ; MV=SAVE.MV
* PRINT @(COL5<MOD(MV-1,5)+1>,LIN5<MOD(MV-1,5)+1>):MV"L#3":H.IO.ARGS<1,MV> "L#3"
* EXECUTE "PTERM CASE NOINVERT"
* GOTO 630
* END ELSE
GOTO 610
* END
END
IF H.IO.ARGS<1,MV>="I" OR H.IO.ARGS<1,MV>="B" THEN
IF DUMMY<1>="" THEN
PRINT MSG7:
* PRINT PROMPT:"Do you wish to update the data types file (Y/N) ":
* INPUT ANS
* IF ANS="Y" OR ANS ="y" THEN
* PA=''
* PA<1>='RUN APP.PROGS TYPES.MAINT'
* PA<2>='DATA ':LANGUAGE
* PA<3>='DATA ':Q
* PA<4>='DATA 2'
* EXECUTE PA
* SAVE.Q=Q ; SAVE.MV=MV
* PRINT SSA11
* GOSUB 88
* Q=SAVE.Q ; MV=SAVE.MV
* PRINT @(COL5<MOD(MV-1,5)+1>,LIN5<MOD(MV-1,5)+1>):MV"L#3":H.IO.ARGS<1,MV> "L#3"
* EXECUTE "PTERM CASE NOINVERT"
* GOTO 630
* END ELSE
GOTO 610
* END
END
END
IF H.IO.ARGS<1,MV>="O" OR H.IO.ARGS<1,MV>="B" THEN
IF DUMMY<2>="" THEN
PRINT MSG8:
* PRINT PROMPT:"Do you wish to update the DATA.TYPES file (Y/N) ":
* INPUT ANS
* IF ANS="Y" OR ANS ="y" THEN
* PA=''
* PA<1>='RUN APP.PROGS TYPES.MAINT'
* PA<2>='DATA ':LANGUAGE
* PA<3>='DATA ':Q
* PA<4>='DATA 3'
* EXECUTE PA
* SAVE.Q=Q ; SAVE.MV=MV
* PRINT SSA11
* GOSUB 88
* Q=SAVE.Q ; MV=SAVE.MV
* PRINT @(COL5<MOD(MV-1,5)+1>,LIN5<MOD(MV-1,5)+1>):MV"L#3":H.IO.ARGS<1,MV> "L#3"
* EXECUTE "PTERM CASE NOINVERT"
* GOTO 630
* END ELSE
GOTO 610
* END
END
END
640*** DISPLAY DATA.TYPES
H.DATA.TYPES<1,MV>=Q
PRINT @(COL6<MOD(MV-1,5)+1>,LIN6<MOD(MV-1,5)+1>):Q "L#30"
RETURN
660*** DISPLAY MULTIVALUE
PRINT @(COL6<MOD(K-1,5)+1>,LIN6<MOD(K-1,5)+1>):DATA.TYPES<1,K> "L#30":
RETURN
*
700*** ########## MOD.NAME
EXECUTE "PTERM CASE NOINVERT"
IF Q=NO.DATA THEN
710 PRINT PROMPT:"Enter file name (without the '.c'): ":STR(".",55):@(36,21):
INPUT Q,55: ; PRINT CL.ERR:PROMPT:
END
IF Q="" THEN
Q=ID
END
IF Q="?" THEN
PRINT MOD.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 710
END
IF Q="^" OR Q="XX" or Q="xx" THEN
PRINT @(25,8):"" "L#55"
RETURN
END
730*** EDITS FOR MOD.NAME
IF LEN(Q)>55 THEN
PRINT MSG3:
GOTO 710
END
740*** DISPLAY MOD.NAME
MOD.NAME=Q
PRINT @(25,8):Q "L#55"
EXECUTE "PTERM CASE INVERT"
RETURN
*
800*** ########## SUB.DESC
EXECUTE "PTERM CASE NOINVERT"
IF Q=NO.DATA THEN
810 PRINT PROMPT:"Enter subroutine description: ":STR(".",50):@(30,21):
INPUT Q,50: ; PRINT CL.ERR:PROMPT:
END
IF Q="?" THEN
PRINT DESC.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 810
END
IF Q="^" OR Q="XX" or Q="xx" THEN
PRINT @(25,9):"" "L#50"
RETURN
END
830*** EDITS FOR SUB.DESC
IF LEN(Q)>50 THEN
PRINT MSG3:
GOTO 810
END
840*** DISPLAY SUB.DESC
SUB.DESC=Q
PRINT @(25,9):Q "L#50"
EXECUTE "PTERM CASE INVERT"
RETURN
*
900*** ######### LENGTHS
* ASSOCIATED MULTIVALUE
H.LENGTHS=LENGTHS
IF H.DATA.TYPES<1,MV> # "lchar*" AND H.DATA.TYPES<1,MV> # "charvar*" AND H.DATA.TYPES<1,MV> # "character" AND H.DATA.TYPES<1,MV> # "lwchar_t*" AND H.DATA.TYPES<1,MV> # "wchar_tvar*" THEN
IF Q.PREV = "^" THEN Q = Q.PREV
RETURN
END
Q.PREV = NO.DATA
IF Q=NO.DATA THEN
910 PRINT PROMPT:"Enter string length " : MV"R#2" :": ":STR(".",6):@(24,21):
INPUT Q,6: ; PRINT CL.ERR:PROMPT:
END
IF Q="" AND NOT(NEW.ITEM) AND LENGTHS<1,MV>#"" THEN
RETURN ;* DO NOT CHANGE VALUE
END
IF Q="" THEN
PRINT MSG2:
GOTO 910
END
IF Q="?" THEN
PRINT LEN.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 910
END
IF Q="^" OR Q="XX" OR Q="xx" THEN
* PRINT @(COL9<MOD(MV-1,5)+1>,LIN9<MOD(MV-1,5)+1>):"" "L#6"
PRINT @(COL9<MOD(MV-1,5)+1>,LIN9<MOD(MV-1,5)+1>):CL
RETURN
END
930*** EDITS FOR LENGTHS
IF Q THEN
ICONV.TEMP=ICONV(Q,"MD0")
IF STATUS()#0 THEN
PRINT MSG4:
GOTO 910
END
IF LEN(Q)>6 THEN
PRINT MSG3:
GOTO 910
END
IF Q < 0 THEN
PRINT MSG12:
GOTO 910
END
IF H.IO.ARGS<1,MV>="I" OR H.IO.ARGS<1,MV>="B" THEN
IF DUMMY<1>="" THEN
PRINT MSG7:
GOTO 910
END
END
IF H.IO.ARGS<1,MV>="O" OR H.IO.ARGS<1,MV>="B" THEN
IF DUMMY<2>="" THEN
PRINT MSG8:
GOTO 910
END
END
END
940*** DISPLAY LENGTHS
H.LENGTHS<1,MV>=Q
PRINT @(COL9<MOD(MV-1,5)+1>,LIN9<MOD(MV-1,5)+1>):Q "L#6"
RETURN
960*** DISPLAY MULTIVALUE
PRINT @(COL9<MOD(K-1,5)+1>,LIN9<MOD(K-1,5)+1>):LENGTHS<1,K> "L#6":
RETURN
*
1000*** ######### ROWS
* ASSOCIATED MULTIVALUE
POS = INDEX(H.DATA.TYPES<1,MV>, "char", 1)
IF POS THEN
IF Q.PREV = "^" THEN Q = Q.PREV
RETURN
END
Q.PREV = NO.DATA
H.ROWS=ROWS
IF Q=NO.DATA THEN
1010 PRINT PROMPT:"Enter number of rows " : MV"R#2" :": ":STR(".",5):@(25,21):
INPUT Q,5: ; PRINT CL.ERR:PROMPT:
END
IF Q="" AND NOT(NEW.ITEM) AND ROWS<1,MV>#"" THEN
RETURN ;* DO NOT CHANGE VALUE
END
IF Q="?" THEN
PRINT ROW.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 1010
END
IF Q="^" OR Q="XX" OR Q="xx" THEN
* PRINT @(COL10<MOD(MV-1,5)+1>,LIN10<MOD(MV-1,5)+1>):"" "L#5"
PRINT @(COL10<MOD(MV-1,5)+1>,LIN10<MOD(MV-1,5)+1>):CL
RETURN
END
1030*** EDITS FOR ROWS
IF Q THEN
ICONV.TEMP=ICONV(Q,"MD0")
IF STATUS()#0 THEN
PRINT MSG4:
GOTO 1010
END
IF LEN(Q)>5 THEN
PRINT MSG3:
GOTO 1010
END
IF Q < 0 THEN
PRINT MSG12:
GOTO 1010
END
IF H.IO.ARGS<1,MV>="I" OR H.IO.ARGS<1,MV>="B" THEN
IF DUMMY<1>="" THEN
PRINT MSG7:
GOTO 1010
END
END
IF H.IO.ARGS<1,MV>="O" OR H.IO.ARGS<1,MV>="B" THEN
IF DUMMY<2>="" THEN
PRINT MSG8:
GOTO 1010
END
END
END
1040*** DISPLAY ROWS
H.ROWS<1,MV>=Q
PRINT @(COL10<MOD(MV-1,5)+1>,LIN10<MOD(MV-1,5)+1>):Q "L#5"
RETURN
1060*** DISPLAY MULTIVALUE
PRINT @(COL10<MOD(K-1,5)+1>,LIN10<MOD(K-1,5)+1>):ROWS<1,K> "L#5":
RETURN
*
1100*** ######### COLS
* ASSOCIATED MULTIVALUE
POS = INDEX(H.DATA.TYPES<1,MV>, "char", 1)
IF POS OR NOT(H.ROWS<1,MV>) THEN
IF Q.PREV = "^" THEN Q = Q.PREV
RETURN
END
Q.PREV = NO.DATA
H.COLS=COLS
IF Q=NO.DATA THEN
1110 PRINT PROMPT:"Enter number of columns " : MV"R#2" :": ":STR(".",6):@(28,21):
INPUT Q,6: ; PRINT CL.ERR:PROMPT:
END
IF Q="" AND NOT(NEW.ITEM) AND COLS<1,MV>#"" THEN
RETURN ;* DO NOT CHANGE VALUE
END
IF Q="?" THEN
PRINT COL.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 1110
END
IF Q="^" OR Q="XX" OR Q="xx" THEN
* PRINT @(COL11<MOD(MV-1,5)+1>,LIN11<MOD(MV-1,5)+1>):"" "L#6"
PRINT @(COL11<MOD(MV-1,5)+1>,LIN11<MOD(MV-1,5)+1>):CL
RETURN
END
1130*** EDITS FOR COLS
IF Q THEN
ICONV.TEMP=ICONV(Q,"MD0")
IF STATUS()#0 THEN
PRINT MSG4:
GOTO 1110
END
IF LEN(Q)>6 THEN
PRINT MSG3:
GOTO 1110
END
IF Q < 0 THEN
PRINT MSG12:
GOTO 1110
END
IF H.IO.ARGS<1,MV>="I" OR H.IO.ARGS<1,MV>="B" THEN
IF DUMMY<1>="" THEN
PRINT MSG7:
GOTO 1110
END
END
IF H.IO.ARGS<1,MV>="O" OR H.IO.ARGS<1,MV>="B" THEN
IF DUMMY<2>="" THEN
PRINT MSG8:
GOTO 1110
END
END
END
1140*** DISPLAY COLS
H.COLS<1,MV>=Q
PRINT @(COL11<MOD(MV-1,5)+1>,LIN11<MOD(MV-1,5)+1>):Q "L#6"
RETURN
1160*** DISPLAY MULTIVALUE
PRINT @(COL11<MOD(K-1,5)+1>,LIN11<MOD(K-1,5)+1>):COLS<1,K> "L#6":
RETURN
*
1200*** ######### ARG.DESC
* ASSOCIATED MULTIVALUE
H.ARG.DESCS=ARG.DESCS
Q.PREV = NO.DATA
IF Q=NO.DATA THEN
1210 PRINT PROMPT:"Enter argument description " : MV"R#2" :": ":STR(".",15):@(31,21):
INPUT Q,15: ; PRINT CL.ERR:PROMPT:
END
IF Q="" AND NOT(NEW.ITEM) AND ARG.DESCS<1,MV>#"" THEN
RETURN ;* DO NOT CHANGE VALUE
END
IF Q="?" THEN
PRINT ARGDESC.HELP: ; INPUT Q: ; PRINT HELP3:
GOTO 1210
END
IF Q="^" OR Q="XX" OR Q="xx" THEN
* PRINT @(COL12<MOD(MV-1,5)+1>,LIN12<MOD(MV-1,5)+1>):"" "L#15"
PRINT @(COL12<MOD(MV-1,5)+1>,LIN12<MOD(MV-1,5)+1>):CL
RETURN
END
1230*** EDITS FOR COLS
IF LEN(Q)>15 THEN
PRINT MSG3:
GOTO 1210
END
IF H.IO.ARGS<1,MV>="I" OR H.IO.ARGS<1,MV>="B" THEN
IF DUMMY<1>="" THEN
PRINT MSG7:
GOTO 1210
END
END
IF H.IO.ARGS<1,MV>="O" OR H.IO.ARGS<1,MV>="B" THEN
IF DUMMY<2>="" THEN
PRINT MSG8:
GOTO 1210
END
END
1240*** DISPLAY ARG.DESCS
H.ARG.DESCS<1,MV>=Q
PRINT @(COL12<MOD(MV-1,5)+1>,LIN12<MOD(MV-1,5)+1>):Q "L#15"
RETURN
1260*** DISPLAY MULTIVALUE
PRINT @(COL12<MOD(K-1,5)+1>,LIN12<MOD(K-1,5)+1>):ARG.DESCS<1,K> "L#15":
RETURN
*
END
Reference in New Issue Copy Permalink