***************************************************************************** * * 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, .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:'' 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:'' 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:'' 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:'' 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:'.':REC 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#'' DO TYPES.REC=TRIM(TYPES.REC) EXT.VAL=''; INC.VAL='' IF INDEX(TYPES.REC,' ',1)=0 THEN * include file values does not have a space - assume its an include file pathname only INC.VAL='#include "':TYPES.REC:'"' END ELSE IF TYPES.REC[1,6]='extern' THEN * check for include file name or an external definition EXT.VAL=TYPES.REC END ELSE * assume its an include file or define statement INC.VAL=TYPES.REC 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 FOR X = 1 TO NUM.ARGS TYPES.KEY=REC:'.':REC READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP IF REC='I' OR REC='B' THEN IF TYPES.REC='' THEN PRINT 'Data type ':TYPES.KEY:' does not have an input conversion in the DATA.TYPES file.'; STOP TYPES.REC=TRIM(TYPES.REC) IF INDEX(TYPES.REC,' ',1)=0 AND TYPES.REC#'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:' ':TYPES.REC:'();' 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#'' DO TYPES.REC=TRIM(TYPES.REC) EXT.VAL=''; INC.VAL='' IF INDEX(TYPES.REC,' ',1)=0 THEN * include file values does not have a space - assume its an include file pathname only INC.VAL='#include "':TYPES.REC:'"' END ELSE IF TYPES.REC[1,6]='extern' THEN * check for include file name or an external definition EXT.VAL=TYPES.REC END ELSE * assume its an include file or define statement INC.VAL=TYPES.REC 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=TRIM(REC) REC=TRIM(REC) * For Windows NT, suppress the 'extern' if it's a Win32 API IF OS.TYPE = "UNIX" OR REC # "Win32" THEN EXT.VAL='extern ':REC:' ':REC:'();' 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#'' DO LINE=INC.FILES 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#'' DO LINE=EXT.DEFS 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#'' DO FUNCT.NAME=GCI.FUNCTS 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 * 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:'.':REC 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#'' THEN ARG.VAL=CHANGE(TYPES.REC,'$','arg':X) ARG.VAL=CHANGE(ARG.VAL, '@',REC) 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 THEN LINE = TAB3:REC:TAB1:'*arg':X:';' END ELSE LINE=TAB3:REC: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 THEN LINE = TAB3:'int arg':X:'rows = ':REC:';' WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP IF REC THEN LINE = TAB3:'int arg':X:'cols = ':REC:';' 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 = "short" or REC = "integer2" or REC = "logical" LINE := '1;':TAB2:'/* array type is short */' CASE REC = "long" or REC = "integer4" LINE := '2;':TAB2:'/* array type is long */' CASE REC = "int" LINE := '3;':TAB2:'/* array type is int */' CASE REC = "float" or REC = "real4" LINE := '4;':TAB2:'/* array type is float */' CASE REC = "double" or REC = "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 NE 'I' AND TYPES.REC = '' AND NOT(REC) THEN * set up temporary variable to hold input pointer for cleanup after output IF TYPES.REC#'' THEN ARG.VAL=CHANGE(TYPES.REC,'$','tmparg':X) ARG.VAL=CHANGE(ARG.VAL, '@',REC) LINE=TAB3:ARG.VAL END ELSE LINE=TAB3:REC: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)) 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: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:'.':REC READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP IF REC='I' OR REC='B' THEN IF REC THEN ;* Processing an array LINE=TAB3:'arg':X:' = (':REC:' *)array_load(var':X:', arg':X:'rows, arg':X:'cols, arg':X:'type);' END ELSE IF TYPES.REC='' THEN PRINT 'Data type ':TYPES.KEY:' does not have an input conversion in the DATA.TYPES file.'; STOP IF INDEX(TYPES.REC,'$',1) THEN * input conversion value has a $ - must perform substitutions NEW.VAL=CHANGE(TYPES.REC,'$','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:'(var':X:');' END ELSE * Windows NT - num_load needs a cast LINE = TAB3:'arg':X:' = ' IF TYPES.REC = "num_load" THEN LINE := '(':REC:')' END LINE := TYPES.REC:'(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 THEN ;* Processing an array LINE=TAB3:'arg':X:' = (':REC:' *)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 NE '' THEN IF INDEX(TYPES.REC,'$',1) THEN * initialisation value has a $ - must perform substitutions NEW.VAL=CHANGE(TYPES.REC,'$','arg':X) NEW.VAL=CHANGE(NEW.VAL,'@','var':X) LINE=TAB3:NEW.VAL END ELSE LINE=TAB3:'arg':X:' = ':TYPES.REC:'(var':X:');' END WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP END END END IF REC NE 'I' AND TYPES.REC = '' AND NOT(REC) 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:'(' FOR X=1 TO NUM.ARGS TYPES.KEY=REC:'.':REC READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP IF REC THEN * If array, don't pass the address of it as it is already a pointer ARGVAL='arg':X END ELSE IF REC = "f77" THEN IF REC = "character" THEN ARGVAL='arg':X END ELSE ARGVAL='&arg':X END END ELSE IF (REC='O' OR REC='B') AND TYPES.REC = '' THEN ARGVAL='&arg':X END ELSE ARGVAL='arg':X END END END LINE=LINE:ARGVAL IF X = "f77" THEN FOR X = 1 TO NUM.ARGS IF REC THEN ARGVAL='arg':X:'rows * arg':X:'cols' LINE=LINE:',':ARGVAL END ELSE IF REC = "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:'.':REC READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP IF REC='O' OR REC='B' THEN IF REC 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='' 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,'$',1) THEN * output conversion value has a $ - must perform substitutions NEW.VAL=CHANGE(TYPES.REC,'$','arg':X) NEW.VAL=CHANGE(NEW.VAL,'@','var':X) LINE=TAB3:NEW.VAL END ELSE LINE=TAB3:TYPES.REC:'(arg':X:',var':X:');' END END WRITESEQ LINE ON FILE.GCIPATH ELSE PRINT 'Unable to write to ':GCIPATH ; STOP IF TYPES.REC = '' AND NOT(REC) 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:'.':REC READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP IF TYPES.REC='' 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,'$',1) THEN * output conversion value has a $ - must perform substitutions NEW.VAL=CHANGE(TYPES.REC,'$','result') NEW.VAL=CHANGE(NEW.VAL,'@','res_var') LINE=TAB3:NEW.VAL END ELSE LINE=TAB3:TYPES.REC:'(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:'.':REC READ TYPES.REC FROM FILE.DATA.TYPES,TYPES.KEY ELSE PRINT 'Unable to read ':TYPES.KEY:' from DATA.TYPES file.'; STOP IF REC 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 = 'I' OR REC='B' OR TYPES.REC THEN IF TYPES.REC#'' THEN IF INDEX(TYPES.REC,'$',1) THEN * cleanup routine value has a $ - must perform substitutions NEW.VAL=CHANGE(TYPES.REC,'$','arg':X) NEW.VAL=CHANGE(NEW.VAL,'@','var':X) LINE=TAB3:NEW.VAL END ELSE LINE=TAB3:TYPES.REC:'(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