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

931 lines
40 KiB
Plaintext
Raw Normal View History

first push of universe files
2024-09-09 21:51:08 +00:00
*****************************************************************************
*
* 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
Reference in New Issue Copy Permalink