931 lines
40 KiB
Plaintext
Executable File
931 lines
40 KiB
Plaintext
Executable File
*****************************************************************************
|
|
*
|
|
* Generate gci.c program
|
|
*
|
|
* 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/27/96 18026 PGW Added MS Windows changes, & file name on cmd line
|
|
* 03/17/94 12300 LA Added support for missing PI/open types.
|
|
* 02/25/94 12300 LA Changes for PI/open GCI support
|
|
* 09/09/93 12299 LA Added setting of gcierrno variable.
|
|
* 06/17/91 7938 MAA Prevented redefinition of getpid() on ptx.
|
|
* 05/09/91 8254 GMH add section to check return value
|
|
* 03/21/91 8134 JWT fix type cast errors in gci.c
|
|
* 12/13/90 7784 JWT define NONETCALLS in gci.c
|
|
* 06/19/90 6417 JWT add message for subr called as function
|
|
* 05/23/90 6933 DTW move include stuff
|
|
* 01/30/90 6842 DTW use tmp variables to store pointers
|
|
* 01/26/90 6832 DTW move include file stuff, clean up comments
|
|
* 10/20/89 6315 DTW add gci.h
|
|
* 04/04/89 5895 JSM Add sccs identifiers
|
|
* 07/25/88 - - Maintenence log purged at 5.2.1, see release 5.1.10.
|
|
*
|
|
*******************************************************************************
|
|
*
|
|
$OPTIONS DEFAULT
|
|
|
|
PROGRAM GEN.GCI
|
|
|
|
ID = "@(#)%M% %I%"
|
|
|
|
$INCLUDE UNIVERSE.INCLUDE FILENAMES.H
|
|
*
|
|
$INCLUDE UNIVERSE.INCLUDE MACHINE.NAME
|
|
*
|
|
* Set up equate tokens for those fields in DATA.TYPES which are used in this
|
|
* program
|
|
*
|
|
EQUATE INCONV TO 1
|
|
EQUATE OUTCONV TO 2
|
|
EQUATE CLEANUP TO 3
|
|
EQUATE INC.EXT TO 4
|
|
EQUATE DECL TO 5
|
|
EQUATE INIT TO 7
|
|
*
|
|
* ...and the same for the fields in GCI
|
|
*
|
|
EQUATE LANG TO 1
|
|
EQUATE EXTNAME TO 2
|
|
EQUATE RETVAL TO 3
|
|
EQUATE NUMARGS TO 4
|
|
EQUATE TYPE TO 5
|
|
EQUATE DIR TO 6
|
|
EQUATE MODNAME TO 7
|
|
EQUATE LENGTH TO 9
|
|
EQUATE ROWS TO 10
|
|
EQUATE COLS TO 11
|
|
|
|
prompt ""
|
|
CL = @(-4)
|
|
CL.ERR = @(0,23):CL
|
|
EQU BELL TO CHAR(7)
|
|
ERR = CL.ERR:BELL
|
|
MSG10=ERR:PROD.NAMEU:' General Calling Interface is not installed.'
|
|
@SYSTEM.SET = -1
|
|
|
|
IF OS.TYPE = "UNIX" THEN
|
|
* Unix: this program can only be run in uvhome
|
|
OPEN '','DATA.TYPES' TO FILE.DATA.TYPES ELSE
|
|
PRINT MSG10:
|
|
INPUT Q: ; PRINT CL.ERR: ; STOP
|
|
END
|
|
DEF.FILE.NAME = 'GCI'
|
|
SCCSID = 'gci'
|
|
MODULE.NAME = 'gci.c'
|
|
GCIPATH = UV.GCI : '/gci.c'
|
|
END ELSE
|
|
* Windows NT: this program can be run in any account
|
|
OPENPATH UV.ROOT:'\DATA.TYPES' TO FILE.DATA.TYPES ELSE
|
|
PRINT MSG10:
|
|
INPUT Q: ; PRINT CL.ERR: ; STOP
|
|
END
|
|
* 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'
|
|
SCCSID = DOWNCASE(DEF.FILE.NAME)
|
|
MODULE.NAME = SCCSID : '.c'
|
|
GCIPATH = UV.GCI : '\' : MODULE.NAME
|
|
END
|
|
|
|
print @( -1 )
|
|
print @( 0, 0 ):"General Calling Interface Administration" : @( 72, 0 ) : "GEN.GCI":
|
|
print @( 23, 1): 'Generate a new "':GCIPATH:'"':
|
|
print @( 0, 2 ): str( "-", 79 ):
|
|
print @( 0, 4 ):
|
|
PRINTER RESET
|
|
**************************************************************************
|
|
*
|
|
* This program generates an interface module: gci.c on Unix, <filename>.c
|
|
* on Windows NT. The interface module is the interface between the BASIC
|
|
* run machine and a user's C or F77 subroutines. It is based on
|
|
* information contained in the GCI definition file ('GCI' on Unix, user's
|
|
* choice of name on Windows NT). The definition file contains information
|
|
* for each of the user's subroutines, such as the number of arguments,
|
|
* the input and output data types for each argument and the return value
|
|
* of the subroutine. Based on this information, the interface between the
|
|
* BASIC run machine and the user's routines can be set up to convert data
|
|
* to and from a data type recognized by the run machine to the data type
|
|
* required by the subroutine.
|
|
*
|
|
**************************************************************************
|
|
*
|
|
EQU TAB1 TO CHAR(9)
|
|
EQU TAB2 TO CHAR(9):CHAR(9)
|
|
EQU TAB3 TO CHAR(9):CHAR(9):CHAR(9)
|
|
EQU TAB4 TO CHAR(9):CHAR(9):CHAR(9):CHAR(9)
|
|
*
|
|
OPEN '',DEF.FILE.NAME TO FILE.GCI ELSE
|
|
PRINT 'Cannot open file "':DEF.FILE.NAME:'".'
|
|
@SYSTEM.SET = -1
|
|
STOP
|
|
END
|
|
OPENSEQ GCIPATH TO FILE.GCIPATH THEN
|
|
WEOFSEQ FILE.GCIPATH
|
|
END ELSE
|
|
WRITESEQ '' ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
**************************************************************************
|
|
*
|
|
* Set up interface module header
|
|
*
|
|
*************************************************************************
|
|
LINE='/':STR('*',79)
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='*'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='*':TAB1:'General Calling Interface'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='*'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='*':TAB1:'Module':TAB1:'%M%'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='*':TAB1:'Version':TAB1:'%I%'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='*':TAB1:'Date':TAB1:'%H%'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='*'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='*':TAB1:'(c) Copyright 1998 Ardent Software, Inc.'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='*':TAB1:'All rights reserved.'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='*'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=STR('*',79):'/'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
**************************************************************************
|
|
*
|
|
* Setup include files and external definitions
|
|
*
|
|
*************************************************************************
|
|
LINE='#define __MODULE__ "' : MODULE.NAME : '"'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='#define __SCCSID__ "' : SCCSID : '"'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='#define':TAB1:'NONETCALLS'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
IF OS.TYPE # "UNIX" THEN
|
|
* Windows NT or 95: UV globals are exported as pointers
|
|
LINE='#define':TAB1:'gcierrno':TAB1:'(*gcierrno)'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='#define':TAB1:'ATvar':TAB2:'(*ATvar)'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
LINE='#include':TAB1:'<gci.h>'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
IF PTX THEN
|
|
LINE='#define':TAB1:'INKERNEL'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='#include':TAB1:'<sys/unistd.h>'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='#undef':TAB1:'INKERNEL'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
LINE='#include':TAB1:'<execute.h>'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='#include':TAB1:'ERRNO_H'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='#include':TAB1:'<atvars.h>'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='extern int gcierrno;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
*
|
|
SSELECT FILE.GCI TO 1
|
|
NO.GCIS=@SELECTED
|
|
GCI.FUNCTS=''
|
|
EXT.DEFS=''
|
|
INC.FILES=''
|
|
I=1
|
|
*************************************************************************
|
|
*
|
|
* Must make a preliminary pass thru the GCI file, to eliminate duplicate
|
|
* definitions of function definitions and include files.
|
|
*
|
|
*************************************************************************
|
|
10*
|
|
READNEXT FUNCT FROM 1 ELSE GOTO 90
|
|
READ REC FROM FILE.GCI,FUNCT ELSE
|
|
PRINT 'Unable to read ':FUNCT:' from GCI definition file.'
|
|
STOP
|
|
END
|
|
* check field 3 for includes/defines/externs
|
|
TYPES.KEY=REC<LANG>:'.':REC<RETVAL>
|
|
READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE
|
|
PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'
|
|
STOP
|
|
END
|
|
*
|
|
* add specific #include file, #define statements for each routine
|
|
*
|
|
Y=1
|
|
LOOP
|
|
WHILE TYPES.REC<INC.EXT,Y>#'' DO
|
|
TYPES.REC<INC.EXT,Y>=TRIM(TYPES.REC<INC.EXT,Y>)
|
|
EXT.VAL=''; INC.VAL=''
|
|
IF INDEX(TYPES.REC<INC.EXT,Y>,' ',1)=0 THEN
|
|
* include file values does not have a space - assume its an include file pathname only
|
|
INC.VAL='#include "':TYPES.REC<INC.EXT,Y>:'"'
|
|
END ELSE
|
|
IF TYPES.REC<INC.EXT,Y>[1,6]='extern' THEN
|
|
* check for include file name or an external definition
|
|
EXT.VAL=TYPES.REC<INC.EXT,Y>
|
|
END ELSE
|
|
* assume its an include file or define statement
|
|
INC.VAL=TYPES.REC<INC.EXT,Y>
|
|
END
|
|
END
|
|
IF INC.VAL#'' THEN
|
|
LOCATE INC.VAL IN INC.FILES<1> SETTING VAL ELSE
|
|
INC.FILES<-1>=INC.VAL
|
|
END
|
|
END
|
|
IF EXT.VAL#'' THEN
|
|
LOCATE EXT.VAL IN EXT.DEFS<1> SETTING VAL ELSE
|
|
EXT.DEFS<-1>=EXT.VAL
|
|
END
|
|
END
|
|
Y+=1
|
|
REPEAT
|
|
* input arguments to subroutine must be defined as externs
|
|
NUM.ARGS=REC<NUMARGS>
|
|
FOR X = 1 TO NUM.ARGS
|
|
TYPES.KEY=REC<LANG>:'.':REC<TYPE,X>
|
|
READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP
|
|
IF REC<DIR,X>='I' OR REC<DIR,X>='B' THEN
|
|
IF TYPES.REC<INCONV>='' THEN PRINT 'Data type ':TYPES.KEY:' does not have an input conversion in the DATA.TYPES file.'; STOP
|
|
TYPES.REC<INCONV>=TRIM(TYPES.REC<INCONV>)
|
|
IF INDEX(TYPES.REC<INCONV>,' ',1)=0 AND TYPES.REC<INCONV>#'num_load' THEN
|
|
* input conversion value does not have a space - assume its not a simple function name
|
|
* also - don't duplicate num_load
|
|
EXT.VAL = 'extern ':REC<TYPE,X>:' ':TYPES.REC<INCONV>:'();'
|
|
LOCATE EXT.VAL IN EXT.DEFS SETTING VAL ELSE
|
|
EXT.DEFS<-1>=EXT.VAL
|
|
END
|
|
END
|
|
END
|
|
*
|
|
* add specific #include file, #define statements for each routine
|
|
*
|
|
Y=1
|
|
LOOP
|
|
WHILE TYPES.REC<INC.EXT,Y>#'' DO
|
|
TYPES.REC<INC.EXT,Y>=TRIM(TYPES.REC<INC.EXT,Y>)
|
|
EXT.VAL=''; INC.VAL=''
|
|
IF INDEX(TYPES.REC<INC.EXT,Y>,' ',1)=0 THEN
|
|
* include file values does not have a space - assume its an include file pathname only
|
|
INC.VAL='#include "':TYPES.REC<INC.EXT,Y>:'"'
|
|
END ELSE
|
|
IF TYPES.REC<INC.EXT,Y>[1,6]='extern' THEN
|
|
* check for include file name or an external definition
|
|
EXT.VAL=TYPES.REC<INC.EXT,Y>
|
|
END ELSE
|
|
* assume its an include file or define statement
|
|
INC.VAL=TYPES.REC<INC.EXT,Y>
|
|
END
|
|
END
|
|
IF INC.VAL#'' THEN
|
|
LOCATE INC.VAL IN INC.FILES<1> SETTING VAL ELSE
|
|
INC.FILES<-1>=INC.VAL
|
|
END
|
|
END
|
|
IF EXT.VAL#'' THEN
|
|
LOCATE EXT.VAL IN EXT.DEFS<1> SETTING VAL ELSE
|
|
EXT.DEFS<-1>=EXT.VAL
|
|
END
|
|
END
|
|
Y+=1
|
|
REPEAT
|
|
NEXT X
|
|
* save function name for gcinames table
|
|
LOCATE FUNCT IN GCI.FUNCTS<1> SETTING VAL ELSE
|
|
GCI.FUNCTS<-1>=FUNCT
|
|
END
|
|
* actual unix name of function must be defined as an extern
|
|
REC<EXTNAME>=TRIM(REC<EXTNAME>)
|
|
REC<RETVAL>=TRIM(REC<RETVAL>)
|
|
* For Windows NT, suppress the 'extern' if it's a Win32 API
|
|
IF OS.TYPE = "UNIX" OR REC<MODNAME> # "Win32" THEN
|
|
EXT.VAL='extern ':REC<RETVAL>:' ':REC<EXTNAME>:'();'
|
|
LOCATE EXT.VAL IN EXT.DEFS<1> SETTING VAL ELSE
|
|
EXT.DEFS<-1>=EXT.VAL
|
|
END
|
|
END
|
|
GOTO 10
|
|
90*
|
|
**************************************************************************
|
|
*
|
|
* Setup user's include files
|
|
*
|
|
*************************************************************************
|
|
X=1
|
|
LOOP
|
|
WHILE INC.FILES<X>#'' DO
|
|
LINE=INC.FILES<X>
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH;STOP
|
|
X+=1
|
|
REPEAT
|
|
*************************************************************************
|
|
*
|
|
* Setup external function definitions
|
|
*
|
|
*************************************************************************
|
|
IF EXT.DEFS#'' THEN
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
X=1
|
|
LOOP
|
|
WHILE EXT.DEFS<X>#'' DO
|
|
LINE=EXT.DEFS<X>
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
X+=1
|
|
REPEAT
|
|
**************************************************************************
|
|
*
|
|
* Setup gcinames table and maxgcis
|
|
*
|
|
**************************************************************************
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='STRING':TAB1:'gcinames[] = {'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
X=1
|
|
LOOP
|
|
WHILE GCI.FUNCTS<X>#'' DO
|
|
FUNCT.NAME=GCI.FUNCTS<X>
|
|
LINE=TAB3:' { ':LEN(FUNCT.NAME):', (uchar*) "':FUNCT.NAME:'"}, '
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
X+=1
|
|
REPEAT
|
|
LINE=TAB2:' };'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
*
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='int':TAB1:'maxgcis = ':NO.GCIS:';'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='#undef':TAB1:'G_DATUM'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='#define':TAB1:'G_DATUM(dest, addres) dest = indata[addres]'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
*************************************************************************
|
|
*
|
|
* Setup beginning of the actual interface functions
|
|
*
|
|
*************************************************************************
|
|
IF OS.TYPE # "UNIX" THEN
|
|
* Windows NT uses an extra function
|
|
LINE='void':TAB1:'InitGCI(max_ptr, names_ptr)'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='int':TAB1:'*max_ptr;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='STRING':TAB1:'**names_ptr;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='{'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB1:'*max_ptr = maxgcis;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB1:'*names_ptr = gcinames;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='}'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
|
|
* Each OS uses a slightly different function header
|
|
IF OS.TYPE = "UNIX" THEN
|
|
LINE = 'gci'
|
|
END ELSE
|
|
LINE = 'void':TAB1:'CallGCI'
|
|
END
|
|
LINE := '(functnum,flag,indata,no_args)'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='int':TAB1:'functnum;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='int':TAB1:'flag;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='DATUM':TAB1:'**indata;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='int':TAB1:'no_args;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='{'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB1:'int':TAB1:'p = 0;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB1:'/* Set @SYSTEM.RETURN.CODE to 0 */'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB1:'rel_var(&at_SYSTEM_RETURN_CODE);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB1:'num_store(0.0, &at_SYSTEM_RETURN_CODE);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB1:'switch(functnum)'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB1:'{'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
*
|
|
SSELECT FILE.GCI TO 1
|
|
NO.GCIS=@SELECTED
|
|
100*
|
|
READNEXT FUNCT FROM 1 ELSE GOTO 9000
|
|
READ REC FROM FILE.GCI,FUNCT ELSE PRINT 'Unable to read ':FUNCT:' from GCI file.'; STOP
|
|
**************************************************************************
|
|
*
|
|
* Setup beginning of each function interface
|
|
*
|
|
**************************************************************************
|
|
LINE=TAB2:'case ':I:':':TAB2:'/*':TAB1:FUNCT:' */'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB2:'{'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
**************************************************************************
|
|
*
|
|
* Setup variable definitions
|
|
*
|
|
**************************************************************************
|
|
NUM.ARGS=REC<NUMARGS>
|
|
|
|
* Now process arguments
|
|
|
|
FOR X=1 TO NUM.ARGS
|
|
|
|
LINE=TAB3:'DATUM':TAB1:'*var':X:';'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
TYPES.KEY=REC<LANG>:'.':REC<TYPE,X>
|
|
READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP
|
|
* data type has a declaration - must perform substitution for this argument
|
|
IF TYPES.REC<DECL>#'' THEN
|
|
ARG.VAL=CHANGE(TYPES.REC<DECL>,'$','arg':X)
|
|
ARG.VAL=CHANGE(ARG.VAL, '@',REC<LENGTH,X>)
|
|
LINE=TAB3:ARG.VAL
|
|
END ELSE
|
|
* check for array - if it is an array, we only need to declare a pointer as
|
|
* the memory for the array is allocated by the load routine
|
|
IF REC<ROWS,X> THEN
|
|
LINE = TAB3:REC<TYPE,X>:TAB1:'*arg':X:';'
|
|
END ELSE
|
|
LINE=TAB3:REC<TYPE,X>:TAB1:'arg':X:';'
|
|
END
|
|
END
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
* declare variables to hold rows & cols if appropriate and also a type variable
|
|
* for the array
|
|
IF REC<ROWS,X> THEN
|
|
LINE = TAB3:'int arg':X:'rows = ':REC<ROWS,X>:';'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
IF REC<COLS,X> THEN
|
|
LINE = TAB3:'int arg':X:'cols = ':REC<COLS,X>:';'
|
|
END ELSE
|
|
LINE = TAB3:'int arg':X:'cols = 1;'
|
|
END
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE = TAB3:'int arg':X:'type = '
|
|
BEGIN CASE
|
|
CASE REC<TYPE,X> = "short" or REC<TYPE,X> = "integer2" or REC<TYPE,X> = "logical"
|
|
LINE := '1;':TAB2:'/* array type is short */'
|
|
CASE REC<TYPE,X> = "long" or REC<TYPE,X> = "integer4"
|
|
LINE := '2;':TAB2:'/* array type is long */'
|
|
CASE REC<TYPE,X> = "int"
|
|
LINE := '3;':TAB2:'/* array type is int */'
|
|
CASE REC<TYPE,X> = "float" or REC<TYPE,X> = "real4"
|
|
LINE := '4;':TAB2:'/* array type is float */'
|
|
CASE REC<TYPE,X> = "double" or REC<TYPE,X> = "real8"
|
|
LINE := '5;':TAB2:'/* array type is double */'
|
|
END CASE
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
|
|
IF REC<DIR,X> NE 'I' AND TYPES.REC<INIT> = '' AND NOT(REC<ROWS,X>) THEN
|
|
* set up temporary variable to hold input pointer for cleanup after output
|
|
IF TYPES.REC<DECL>#'' THEN
|
|
ARG.VAL=CHANGE(TYPES.REC<DECL>,'$','tmparg':X)
|
|
ARG.VAL=CHANGE(ARG.VAL, '@',REC<LENGTH,X>)
|
|
LINE=TAB3:ARG.VAL
|
|
END ELSE
|
|
LINE=TAB3:REC<TYPE,X>:TAB1:'tmparg':X:';'
|
|
END
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
NEXT X
|
|
RET.VAL=TRIM(UPCASE(REC<RETVAL>))
|
|
IF RET.VAL='VOID' THEN
|
|
|
|
* If defined as a subroutine in the GCI (ie. return value of 'void'), then
|
|
* can either be called as a subroutine eg.
|
|
*
|
|
* CALL @FRED(ARG1, ARG2, ARG3)
|
|
*
|
|
* or, for PI/open compatibility, it can also be called as a function eg.
|
|
*
|
|
* DEFFUN FRED.FUNC(A,B) CALLING "$FRED"
|
|
* ARG1 = FRED(ARG2, ARG3)
|
|
*
|
|
* To do this, check if flag is set (ie. called as a function) and treat the
|
|
* return value as the first argument to the subroutine call
|
|
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
IF NUM.ARGS > 0 THEN
|
|
LINE=TAB3:'if(flag)':TAB1:'/* Subroutine called as a function */'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB3:'{':TAB1:'if(no_args != ':NUM.ARGS-1:') fatal(46018);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
|
|
* Note: For the case where it is being called as a function, the return value
|
|
* (ie. argument #1) will be last on the stack, not first
|
|
|
|
FOR X=2 TO NUM.ARGS
|
|
LINE=TAB4:'DATUM_GET(var':X:',p++);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
NEXT X
|
|
LINE=TAB4:'DATUM_GET(var1,p++);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB3:'} else':TAB2:'/* Subroutine called as a subroutine */'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB3:'{':TAB1:'if(no_args != ':NUM.ARGS:') fatal(46018);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
|
|
* For the case where it is being called as a subroutine, order of arguments
|
|
* is as expected.
|
|
|
|
FOR X=1 TO NUM.ARGS
|
|
LINE=TAB4:'DATUM_GET(var':X:',p++);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
NEXT X
|
|
LINE=TAB3:'}'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END ELSE
|
|
LINE=TAB3:'if(no_args != ':NUM.ARGS:') fatal(46018);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
END ELSE
|
|
|
|
* Function
|
|
|
|
LINE=TAB3:'DATUM':TAB1:'*res_var;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB3:REC<RETVAL>:TAB1:'result;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
|
|
* If defined as a CATALOGED function in the GCI (ie. return value not 'void'),
|
|
* then can either be called as a function eg.
|
|
*
|
|
* DEFFUN FRED.FUNC(A,B) CALLING "$FRED"
|
|
* RET.VAL = FRED(ARG1, ARG2)
|
|
*
|
|
* or, for PI/open compatibility, it can also be called as a subroutine eg.
|
|
*
|
|
* CALL @FRED(RET.VAL, ARG2, ARG3)
|
|
*
|
|
* To do this, check if flag is not set (ie. called as a subroutine) and
|
|
* treat first argument of the subroutine as the return value.
|
|
*
|
|
* NOTE: This does not apply to non-cataloged functions (those which must
|
|
* be called using DECLARE GCI)
|
|
|
|
PREFIX = FUNCT[1,1]
|
|
IF PREFIX = "$" OR PREFIX = "!" OR PREFIX = "*" OR PREFIX = "-" THEN
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE = TAB3:'if (flag)':TAB1:'/* Function called as a function */'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE = TAB3:'{':TAB1:'if(no_args != ':NUM.ARGS:') fatal(46018);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
FOR X=1 TO NUM.ARGS
|
|
LINE=TAB4:'DATUM_GET(var':X:',p++);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
NEXT X
|
|
LINE=TAB4:'DATUM_GET(res_var,p++);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB3:'} else':TAB2:'/* Function called as a subroutine */'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB3:'{':TAB1:'if(no_args != ':NUM.ARGS + 1:') fatal(46018);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB4:'DATUM_GET(res_var,p++);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
FOR X=1 TO NUM.ARGS
|
|
LINE=TAB4:'DATUM_GET(var':X:',p++);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
NEXT X
|
|
LINE=TAB3:'}'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END ELSE
|
|
|
|
* Not cataloged
|
|
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB3:'if(no_args != ':NUM.ARGS:')'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB3:'{':TAB1:'fatal(46018);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB3:'}'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
**************************************************************************
|
|
*
|
|
* Setup DATUM_GETS for each argument
|
|
*
|
|
**************************************************************************
|
|
IF NUM.ARGS THEN
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
FOR X=1 TO NUM.ARGS
|
|
LINE=TAB3:'DATUM_GET(var':X:',p++);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
NEXT X
|
|
LINE=TAB3:'DATUM_GET(res_var,p++);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
END
|
|
**************************************************************************
|
|
*
|
|
* Setup input conversions (ie - convert from DATUM to proper data type)
|
|
*
|
|
**************************************************************************
|
|
IF NUM.ARGS THEN
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
FOR X = 1 TO NUM.ARGS
|
|
TYPES.KEY=REC<LANG>:'.':REC<TYPE,X>
|
|
READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP
|
|
|
|
IF REC<DIR,X>='I' OR REC<DIR,X>='B' THEN
|
|
IF REC<ROWS,X> THEN ;* Processing an array
|
|
LINE=TAB3:'arg':X:' = (':REC<TYPE,X>:' *)array_load(var':X:', arg':X:'rows, arg':X:'cols, arg':X:'type);'
|
|
END ELSE
|
|
IF TYPES.REC<INCONV>='' THEN PRINT 'Data type ':TYPES.KEY:' does not have an input conversion in the DATA.TYPES file.'; STOP
|
|
IF INDEX(TYPES.REC<INCONV>,'$',1) THEN
|
|
* input conversion value has a $ - must perform substitutions
|
|
NEW.VAL=CHANGE(TYPES.REC<INCONV>,'$','arg':X)
|
|
NEW.VAL=CHANGE(NEW.VAL,'@','var':X)
|
|
LINE=TAB3:NEW.VAL
|
|
END ELSE
|
|
IF OS.TYPE = "UNIX" THEN
|
|
LINE=TAB3:'arg':X:' = ':TYPES.REC<INCONV>:'(var':X:');'
|
|
END ELSE
|
|
* Windows NT - num_load needs a cast
|
|
LINE = TAB3:'arg':X:' = '
|
|
IF TYPES.REC<INCONV> = "num_load" THEN
|
|
LINE := '(':REC<TYPE,X>:')'
|
|
END
|
|
LINE := TYPES.REC<INCONV>:'(var':X:');'
|
|
END
|
|
END
|
|
END
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END ELSE
|
|
|
|
* Some types need memory allocating by the gci, so call the initialisation
|
|
* routine to do this if they are output only (if they have an init routine)
|
|
|
|
IF REC<ROWS,X> THEN ;* Processing an array
|
|
LINE=TAB3:'arg':X:' = (':REC<TYPE,X>:' *)array_init(var':X:', arg':X:'rows, arg':X:'cols, arg':X:'type);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END ELSE
|
|
IF TYPES.REC<INIT> NE '' THEN
|
|
IF INDEX(TYPES.REC<INIT>,'$',1) THEN
|
|
* initialisation value has a $ - must perform substitutions
|
|
NEW.VAL=CHANGE(TYPES.REC<INIT>,'$','arg':X)
|
|
NEW.VAL=CHANGE(NEW.VAL,'@','var':X)
|
|
LINE=TAB3:NEW.VAL
|
|
END ELSE
|
|
LINE=TAB3:'arg':X:' = ':TYPES.REC<INIT>:'(var':X:');'
|
|
END
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
END
|
|
END
|
|
IF REC<DIR,X> NE 'I' AND TYPES.REC<INIT> = '' AND NOT(REC<ROWS,X>) THEN
|
|
LINE=TAB3:'tmparg':X:' = ':'arg':X:';'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
NEXT X
|
|
**************************************************************************
|
|
*
|
|
* Setup call to user function
|
|
*
|
|
**************************************************************************
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
IF RET.VAL='VOID' THEN
|
|
LINE=TAB3:'(void)'
|
|
END ELSE
|
|
LINE=TAB3:'result = '
|
|
END
|
|
LINE=LINE:REC<EXTNAME>:'('
|
|
FOR X=1 TO NUM.ARGS
|
|
TYPES.KEY=REC<LANG>:'.':REC<TYPE,X>
|
|
READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP
|
|
IF REC<ROWS,X> THEN
|
|
* If array, don't pass the address of it as it is already a pointer
|
|
ARGVAL='arg':X
|
|
END ELSE
|
|
IF REC<LANG> = "f77" THEN
|
|
IF REC<TYPE,X> = "character" THEN
|
|
ARGVAL='arg':X
|
|
END ELSE
|
|
ARGVAL='&arg':X
|
|
END
|
|
END ELSE
|
|
IF (REC<DIR,X>='O' OR REC<DIR,X>='B') AND TYPES.REC<INIT> = '' THEN
|
|
ARGVAL='&arg':X
|
|
END ELSE
|
|
ARGVAL='arg':X
|
|
END
|
|
END
|
|
END
|
|
LINE=LINE:ARGVAL
|
|
IF X<NUM.ARGS THEN LINE=LINE:','
|
|
NEXT X
|
|
|
|
* For Fortran, need to add dope vectors for arrays and strings as arguments
|
|
|
|
IF REC<LANG> = "f77" THEN
|
|
FOR X = 1 TO NUM.ARGS
|
|
IF REC<ROWS,X> THEN
|
|
ARGVAL='arg':X:'rows * arg':X:'cols'
|
|
LINE=LINE:',':ARGVAL
|
|
END ELSE
|
|
IF REC<TYPE,X> = "character" THEN
|
|
ARGVAL='len_arg':X
|
|
LINE=LINE:',':ARGVAL
|
|
END
|
|
END
|
|
NEXT X
|
|
END
|
|
LINE=LINE:');'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
**************************************************************************
|
|
*
|
|
* Setup storing gcierrno
|
|
*
|
|
**************************************************************************
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB3:'gcierrno = errno;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
**************************************************************************
|
|
*
|
|
* Setup output conversions (ie - convert from other data type to DATUM)
|
|
*
|
|
**************************************************************************
|
|
IF NUM.ARGS THEN
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
FOR X=1 TO NUM.ARGS
|
|
TYPES.KEY=REC<LANG>:'.':REC<TYPE,X>
|
|
READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP
|
|
IF REC<DIR,X>='O' OR REC<DIR,X>='B' THEN
|
|
IF REC<ROWS,X> THEN ;* Array - don't release DATUMs
|
|
LINE=TAB3:'array_store(arg':X:',var':X:',arg':X:'rows,arg':X:'cols, arg':X:'type);'
|
|
END ELSE
|
|
IF TYPES.REC<OUTCONV>='' THEN PRINT 'Data type ':TYPES.KEY:' does not have an output conversion in the DATA.TYPES file.'; STOP
|
|
LINE=TAB3:'rel_var(var':X:');'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
IF INDEX(TYPES.REC<OUTCONV>,'$',1) THEN
|
|
* output conversion value has a $ - must perform substitutions
|
|
NEW.VAL=CHANGE(TYPES.REC<OUTCONV>,'$','arg':X)
|
|
NEW.VAL=CHANGE(NEW.VAL,'@','var':X)
|
|
LINE=TAB3:NEW.VAL
|
|
END ELSE
|
|
LINE=TAB3:TYPES.REC<OUTCONV>:'(arg':X:',var':X:');'
|
|
END
|
|
END
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
IF TYPES.REC<INIT> = '' AND NOT(REC<ROWS,X>) THEN
|
|
LINE=TAB3:'arg':X:' = ':'tmparg':X:';'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
END
|
|
**************************************************************************
|
|
*
|
|
* Setup return value
|
|
*
|
|
**************************************************************************
|
|
NEXT X
|
|
IF RET.VAL#'VOID' THEN
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
TYPES.KEY=REC<LANG>:'.':REC<RETVAL>
|
|
READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP
|
|
IF TYPES.REC<OUTCONV>='' THEN PRINT 'Data type ':TYPES.KEY:' does not have an output conversion in the DATA.TYPES file.'; STOP
|
|
LINE=TAB3:'rel_var(res_var);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
IF INDEX(TYPES.REC<OUTCONV>,'$',1) THEN
|
|
* output conversion value has a $ - must perform substitutions
|
|
NEW.VAL=CHANGE(TYPES.REC<OUTCONV>,'$','result')
|
|
NEW.VAL=CHANGE(NEW.VAL,'@','res_var')
|
|
LINE=TAB3:NEW.VAL
|
|
END ELSE
|
|
LINE=TAB3:TYPES.REC<OUTCONV>:'(result,res_var);'
|
|
END
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
**************************************************************************
|
|
*
|
|
* Setup cleanup routines
|
|
*
|
|
**************************************************************************
|
|
IF NUM.ARGS THEN
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
FOR X = 1 TO NUM.ARGS
|
|
TYPES.KEY=REC<LANG>:'.':REC<TYPE,X>
|
|
READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP
|
|
IF REC<ROWS,X> THEN ;* Free array memory
|
|
LINE=TAB3:'free(arg':X:');'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END ELSE
|
|
IF REC<DIR,X> = 'I' OR REC<DIR,X>='B' OR TYPES.REC<INIT> THEN
|
|
IF TYPES.REC<CLEANUP>#'' THEN
|
|
IF INDEX(TYPES.REC<CLEANUP>,'$',1) THEN
|
|
* cleanup routine value has a $ - must perform substitutions
|
|
NEW.VAL=CHANGE(TYPES.REC<CLEANUP>,'$','arg':X)
|
|
NEW.VAL=CHANGE(NEW.VAL,'@','var':X)
|
|
LINE=TAB3:NEW.VAL
|
|
END ELSE
|
|
LINE=TAB3:TYPES.REC<CLEANUP>:'(arg':X:');'
|
|
END
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
END
|
|
END
|
|
END
|
|
NEXT X
|
|
**************************************************************************
|
|
*
|
|
* Setup end of function interface
|
|
*
|
|
**************************************************************************
|
|
LINE=''
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB3:'break;'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB2:'}'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
**************************************************************************
|
|
*
|
|
* End of each function interface
|
|
*
|
|
**************************************************************************
|
|
I+=1
|
|
GOTO 100
|
|
9000*
|
|
**************************************************************************
|
|
*
|
|
* Setup default case
|
|
*
|
|
**************************************************************************
|
|
LINE=TAB2:'default:':TAB1:'/* error condition */'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB2:'fatal(46019);'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE=TAB1:'}'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
LINE='}'
|
|
WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP
|
|
CLOSESEQ FILE.GCIPATH
|
|
PRINT
|
|
PRINT "New ":MODULE.NAME:" has been generated"
|
|
PRINT
|
|
**************************************************************************
|
|
*
|
|
* End of gci function
|
|
*
|
|
**************************************************************************
|
|
@SYSTEM.SET = 0
|
|
STOP
|
|
END
|