*	$Id: wrapper.sno,v 1.6 2013-11-10 01:32:18 phil Exp $
*
*	wrapper.sno -- create C code to wrap a C function for LOAD()'ing
*	Phil Budne, December, 2001
*
* TODO:
*	malloc string buffers to right size???
*	add 'HANDLE' type???
*
*	function to invoke C compiler, loader (libtool?) to create so/dl/shl/..
*	overall wrapper; take prototype, create file, executable, and load it!!

****************
*	constants for wrapper.proto

	wpmaxstr = 1024
	wpstrtype = 'STRING'
	wpinttype = 'INTEGER'
	wpint32type = 'INT32'
	wpint64type = 'INT64'
	wprealtype = 'REAL'
	wphdltype = 'HANDLE'
	wppredtype = 'PREDICATE'
	wpspredtype = 'SYSPRED'
	wptypes = wpinttype | wprealtype | wpstrtype |
+		wpint64type | wpint32type
*		 | wphdltype
	wprtypes = wptypes | wpredtype | wpspredtype | ''
	wpname = ANY(&UCASE &LCASE '_') SPAN(&UCASE &LCASE '0123456789_')
	wpend = ANY(',)')
	wp4sp = '    '
	wp8sp = '	'

****************
*	wrapper.startfile(output_name)
*
*	output_name:	the NAME (STRING) of output variable for C file
*
*	XXX take filename arg?, return generated name variable??
*	keep unit in a table, do endfile when endwrapperfile() called?

	define("wrapper.startfile(fn)")			:(e.wrapper.startfile)
wrapper.startfile
*	XXX wrap in '#ifdef HAVE_CONFIG_H'??
	$fn = '/* this file generated by wrapper.sno on ' DATE() ' */'
	$fn =
	$fn = '#include "config.h"'
	$fn = '#include "h.h"'
	$fn = '#include "snotypes.h"'
	$fn = '#include "macros.h"'
	$fn = '#include "load.h"'
	$fn = '#include "equ.h"'
* XXX include handle.h?
* XXX output handle list?
							:(return)
e.wrapper.startfile

****************
*	wrapper.proto(prototype,output_name)
*
*	prototype:	a prototype, as passed to SNOBOL LOAD() function
*			C function to call is the lowercase version
*			of the function name.
*	output_name:	the NAME (STRING) of output variable for C file

	define("wrapper.proto(proto,fn)types,i,n,c,call")	:(e.wrapper.proto)
wrapper.proto

	$fn =
	$fn = '/* ' proto ' */'

*	get function name
	proto POS(0) wpname . name '(' =		:f(wperr)

****************
*	loop for each argument, saving types in array
	n = 0
	wpcopy = 0

*	sigh; max 30 arguments! keep as linked list?
	types = ARRAY('0:29')
	proto POS(0) ')' =				:s(wpepars)
wploop	proto wptypes . type wpend . c =		:f(wperr)
	types[n] = type					:f(wperr)
*	terminal = 'types[' n '] = ' type
	n = n + 1

*	count string/handle typed variables to save time later
	wpcopy = IDENT(type, wpstrtype) wpcopy + 1
	wpcopy = IDENT(type, wphdltype) wpcopy + 1

*	was terminator a close paren? if so we're done with args, else loop
	IDENT(c, ')')					:s(wpepars)f(wploop)

wperr	TERMINAL = 'error in prototype: >' proto '<'	:(FRETURN)

*	proto should now have return type (or be empty)
wpepars
*	TERMINAL = 'return type: ' proto
	proto POS(0) wprtypes RPOS(0)			:f(wperr)

*	output C function declaration
	i = 0
	$fn = name '( LA_ALIST ) LA_DCL'
	$fn = '{'

****************
*	loop declaring variables
	eq(wpcopy,0)					:s(wpnostrs)
wploop2
* XXX branch based on type?
	IDENT(types[i],wpstrtype)			:f(wpnext2)
	$fn = wp4sp 'char arg' i '[' wpmaxstr '];'
wpnext2	i = i + 1
	LT(i,n)						:s(wploop2)

****************
*	loop copying string variables
	i = 0
wpcopy
*	dispatch based on type
		:($('wpcpy_' types[i]))
wpcpy_STRING
	$fn = wp4sp 'getstring(LA_PTR(' i '), arg' i ', sizeof(arg' i '));'
							:(wpncopy)
wpcpy_HANDLE
*	XXXX handle HANDLE here!!
wpcpy_INTEGER
wpcpy_INT64
wpcpy_INT32
wpcpy_REAL
wpcpy_
wpncopy	i = i + 1
	LT(i,n)						:s(wpcopy)

****************
*	construct function call
wpnostrs
	call = REPLACE(name,&UCASE,&LCASE) '('

	i = 0
wpcall	GE(i,n)						:s(wpecall)
	call = GT(i,0) call ','

* dispatch based on type
		:($('wparg_' types[i]))

wparg_INTEGER
wparg_INT32
	call = call '(int)LA_INT(' i ')'		:s(wpncall)
wparg_INT64
	call = call '(long long)LA_INT(' i ')'		:s(wpncall)
wparg_REAL
	call = call '(double)LA_REAL(' i ')'		:s(wpncall)
wparg_STRING
wparg_HANDLE
	call = call 'arg' i
wpncall	i = i + 1					:(wpcall)

wpecall	call = call ')'

*	here with complete invocation in "call"; output w/ proper return

*	dispatch based on type
		:($('wpret_' proto))

wpret_STRING
	$fn = wp4sp 'RETSTR((char *)' call ');'		:s(wpdone)
wpret_INT32
wpret_INT64
wpret_INTEGER
	$fn = wp4sp 'RETINT(' call ');'			:s(wpdone)
wpret_REAL
	$fn = wp4sp 'RETREAL(' call ');'		:s(wpdone)
wpret_PREDICATE
	$fn = wp4sp 'if (' call ')'
	$fn = wp8sp 'RETNULL;'
	$fn = wp4sp 'RETFAIL;'				:s(wpdone)
* system call (< 0 for failure)
wpret_SYSPRED
	$fn = wp4sp 'if (' call ' >= 0)'
	$fn = wp8sp 'RETNULL;'
	$fn = wp4sp 'RETFAIL;'				:s(wpdone)
wpret_
	$fn = wp4sp call ';'
	$fn = wp4sp 'RETNULL;'

*	end of function
wpdone	$fn = '}'					:(return)

e.wrapper.proto

**************** test;
*	wrapper.startfile(.OUTPUT)
*	wrapper.proto('FOO(INTEGER,STRING,REAL)STRING', .OUTPUT)
*	wrapper.proto('BAR(INTEGER,REAL)INTEGER', .OUTPUT)
*	wrapper.proto('BAZ(INTEGER,INTEGER,REAL,STRING)', .OUTPUT)
*	wrapper.proto('MUMBLE(STRING,STRING,STRING)REAL', .OUTPUT)
*
*end