summaryrefslogtreecommitdiff
path: root/agen5/snarf.tpl
diff options
context:
space:
mode:
Diffstat (limited to 'agen5/snarf.tpl')
-rw-r--r--agen5/snarf.tpl316
1 files changed, 316 insertions, 0 deletions
diff --git a/agen5/snarf.tpl b/agen5/snarf.tpl
new file mode 100644
index 0000000..e485628
--- /dev/null
+++ b/agen5/snarf.tpl
@@ -0,0 +1,316 @@
+[= AutoGen5 template -*- Mode: Text -*-
+
+# Time-stamp: "2011-01-31 14:16:48 bkorb"
+
+##
+## This file is part of AutoGen.
+## AutoGen Copyright (c) 1992-2012 by Bruce Korb - all rights reserved
+##
+## AutoGen is free software: you can redistribute it and/or modify it
+## under the terms of the GNU General Public License as published by the
+## Free Software Foundation, either version 3 of the License, or
+## (at your option) any later version.
+##
+## AutoGen is distributed in the hope that it will be useful, but
+## WITHOUT ANY WARRANTY; without even the implied warranty of
+## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+## See the GNU General Public License for more details.
+##
+## You should have received a copy of the GNU General Public License along
+## with this program. If not, see <http://www.gnu.org/licenses/>.
+##
+
+(setenv "SHELL" "/bin/sh")
+
+ini =]
+[=#
+
+This template will emit the code necessary for registering callout routines
+for Guile/Scheme. The name of the output file will be ``basename.ini''
+where ``basename'' may be of your choosing.
+
+The following definitions are used:
+
+group A module prefix that preceeds the "scm_" prefix to all symbols
+init the name of the created initialization routine. This defaults
+ to "scm_init" or "group_init", if "group" is specified.
+ You must specify this for shared libraries.
+init-code code to put at the start of the init routine
+fini-code code to put at the end of the init routine
+
+gfunc this is a compound definition containing the following definitions
+ name the name of the function. The Scheme string name will normally be
+ derived from this name, but it may be over-ridden with the "string"
+ attribute. The transforming sed expression is:
+
+ sed -e's/_p$/?/;s/_x$/!/;s/_/-/g;s/-to-/->/'
+
+ string the Scheme name for the function, if not derivable from the name.
+ static If defined, then the function will not be exported.
+
+ exparg "EXPression ARGument" for each argument your routine handles,
+ you must specify one of these. This is a compound definition
+ with the following "attributes" that may be defined:
+
+ arg-name The name of the argument. required
+ arg-desc A very brief description of the argument. required
+ arg-optional Specify this if the argument is only optional
+ arg-list Specify this for the last argument if the last argument
+ may be an SCM list (i.e. an SCM-flavor of var args).
+
+syntax This defines a Guile syntax element. Read the Guile doc for
+ descriptions of the following attributes:
+ name the name of the C variable to hold the value
+ type
+ cfn
+ string the Scheme name for the syntax element, if not derivable.
+
+symbol This defines a Guile symbol.
+ name the name of the C variable to hold the value
+ init-val initial scm value for object
+ const-val initial integer value for object (signed long)
+ string the Scheme name for the symbol, if not derivable.
+
+If you are using a definitions file, these are defined in the normal
+way. If you are extracting them from `getdefs(1AG)' comments, then:
+
+1. `group' and `init' should be defined on the command line thus:
+ getdefs assign=group=XX assign=init=init_proc_name
+
+2. `init-code' and `fini-code' should be defined in a traditional
+ definitions file and be incorporated from a command line option:
+ getdefs copy=file-name.def
+
+3. `gfunc', `syntax', and `symbol' are getdefs' entry types.
+ The `name' attributes come from the getdefs entry name.
+ The remaining attributes are specified in the comment, per
+ the getdefs documentation.
+
+=][=
+
+(define ix 0)
+(define scm-prefix
+ (if (exist? "group")
+ (string-append (get "group") "_scm_")
+ "scm_" ))
+(out-push-new (string-append (base-name) ".h"))
+(dne " * " "/* ")=]
+ *
+ * copyright (c) 1992-2012 Bruce Korb - all rights reserved
+ *
+[=(gpl "AutoGen" " * ")=]
+ *
+ * Guile Implementation Routines[=% group " - for the %s group" =]
+ */
+[=(make-header-guard "GUILE_PROCS")=]
+#if GUILE_VERSION >= 108000
+# include <libguile.h>
+#else
+# include <guile/gh.h>
+#endif
+
+typedef enum {
+ GH_TYPE_UNDEFINED = 0,
+ GH_TYPE_BOOLEAN,
+ GH_TYPE_SYMBOL,
+ GH_TYPE_CHAR,
+ GH_TYPE_VECTOR,
+ GH_TYPE_PAIR,
+ GH_TYPE_NUMBER,
+ GH_TYPE_STRING,
+ GH_TYPE_PROCEDURE,
+ GH_TYPE_LIST,
+ GH_TYPE_INEXACT,
+ GH_TYPE_EXACT
+} teGuileType;
+[=
+FOR gfunc =]
+extern SCM [= (string-append scm-prefix (get "name") "(") =][=
+ IF (exist? "exparg") =][=
+ FOR exparg ", " =]SCM[=
+ ENDFOR =][=
+ ELSE =]void[=
+ ENDIF =]);[=
+ENDFOR gfunc =][=
+
+FOR symbol =][=
+ IF (exist? "global") =]
+extern SCM [= (string-append scm-prefix "sym_" (get "name") ";") =][=
+ ENDIF =][=
+ENDFOR symbol =]
+
+#endif /* [=(. header-guard)=] */
+[=
+
+(out-pop)
+(dne " * " "/* ")
+
+=]
+ *
+ * copyright (c) 1992-2012 Bruce Korb - all rights reserved
+ *
+[=
+(string-table-new "g_nm")
+
+(define add-to-g_nm (lambda ()
+ (string-table-add "g_nm"
+ (if (exist? "string")
+ (get "string")
+ (shellf
+ "echo '%s'|sed -e's/_p$/?/' -e's/_x$/!/' -e's/_/-/g' -e's/-to-/->/'"
+ (get "name") ) ) ) ))
+
+(gpl "AutoGen" " * ")=]
+ *
+ * Guile Initializations - [=% group (string-capitalize! "%s ")
+ =]Global Variables
+ */
+#include "[= (. header-file) =]"
+typedef SCM (*scm_callback_t)(void);
+void [=
+(define init-proc
+ (if (exist? "init")
+ (get "init")
+ (if (exist? "group")
+ (string-append (get "group") "_init")
+ "scm_init")))
+
+ init-proc =](void);
+[=
+
+ FOR symbol =][=
+ (sprintf "\n%s SCM %ssym_%-18s = SCM_BOOL_F;"
+ (if (exist? "global") "extern" "static")
+ scm-prefix (get "name") ) =][=
+ ENDFOR symbol
+
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */=][=
+
+IF (exist? "debug-enabled") =]
+#ifdef DEBUG_ENABLED[=
+
+ FOR gfunc
+
+=]
+static SCM
+agrelay_scm_[= (get "name") =]([=
+ IF (not (exist? "exparg")) =]void[=
+ (define pass-list "") =][=
+ ELSE =][=
+ (out-push-new) =][=
+ FOR exparg ", " =]SCM scm[= (for-index) =][= ENDFOR =][=
+ (define call-list (out-pop #t))
+ (define pass-list (shellf "echo '%s' | sed 's/SCM s/s/g'" call-list))
+ call-list =][=
+ ENDIF exparg exists/not =])
+{
+ if (OPT_VALUE_TRACE >= TRACE_EVERYTHING) {
+ static char const proc_z[] =
+ "Called ag_scm_[= name =]()\n";
+ fwrite(proc_z, sizeof(proc_z) - 1, 1, trace_fp);
+ }
+ return ag_scm_[= name =]([= (. pass-list) =]);
+}
+[= ENDFOR gfunc =]
+#if GUILE_VERSION >= 108000
+#define NEW_PROC(_As, _Ar, _Ao, _Ax, _An) \
+ scm_c_define_gsubr((char*)(_As), \
+ _Ar, _Ao, _Ax, (scm_callback_t)(void*)agrelay_scm_ ## _An)
+#else
+#define NEW_PROC(_As, _Ar, _Ao, _Ax, _An) \
+ gh_new_procedure((char*)(_As), (scm_callback_t)(void*)agrelay_scm_ ## _An, \
+ _Ar, _Ao, _Ax)
+#endif
+
+#else /* DEBUG_ENABLED *not* */[=
+
+ENDIF debug-enabled exists
+
+=]
+#if GUILE_VERSION >= 108000
+#define NEW_PROC(_As, _Ar, _Ao, _Ax, _An) \
+ scm_c_define_gsubr((char*)(_As), \
+ _Ar, _Ao, _Ax, (scm_callback_t)(void*)ag_scm_ ## _An)
+#else
+#define NEW_PROC(_As, _Ar, _Ao, _Ax, _An) \
+ gh_new_procedure((char*)(_As), (scm_callback_t)(void*)ag_scm_ ## _An, \
+ _Ar, _Ao, _Ax)
+#endif
+[= (if (exist? "debug-enabled") "#endif /* DEBUG_ENABLED */\n") =]
+/*
+ * [=group=] Initialization procedure.
+ */
+void
+[=(. init-proc)=](void)
+{[=
+
+ (out-push-new)
+
+ (if (exist? "init-code")
+ (prefix " " (get "init-code")) "") =][=
+
+ FOR gfunc =][=
+ INVOKE mk-new-proc =][=
+ ENDFOR gfunc =][=
+
+ FOR syntax =]
+ scm_make_synt(g_nm+[= (add-to-g_nm) =], [=type=], [=cfn=]);[=
+ ENDFOR syntax =][=
+
+ FOR symbol =]
+ [=(. scm-prefix)=]sym_[=name=] = scm_permanent_object[=
+ IF (not (and (exist? "init_val") (exist? "const_val")))
+ =](SCM_CAR (scm_intern0 (g_nm+[= (add-to-g_nm) =])));[=
+
+ ELSE =](scm_intern0 (g_nm+[= (add-to-g_nm) =]));
+ SCM_SETCDR ([=(. scm-prefix)=]sym_[=name=], [=
+ ?% init_val "%s" (sprintf "scm_long2num(%s)" (get "const_val"))=]);[=
+ ENDIF =][=
+ ENDFOR symbol =][=
+
+ (out-suspend "main")
+ (emit-string-table "g_nm")
+ (out-resume "main")
+ (out-pop #t) =][=
+ (if (exist? "fini-code")
+ (prefix " " (get "fini-code")) "") =]
+}
+#undef NEW_PROC
+/* end of [= (out-name) =] */
+[= #
+
+# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+=][=
+
+DEFINE mk-new-proc =][=
+
+ (set! ix (add-to-g_nm))
+
+ (ag-fprintf 0 "\n NEW_PROC(g_nm +%4d, " ix) =][=
+
+ IF (not (exist? "exparg"))
+
+ =]0, 0, 0[=
+
+ # Count of all the arguments: (count "exparg")
+ Of these, some may be optional: (count "exparg.arg_optional")
+ Of the optional, one may be an arg_list.
+ The sum of the three numbers must be: (count "exparg") =][=
+
+ ELIF (not (exist? "exparg.arg_list")) =][=
+ (- (count "exparg") (count "exparg.arg_optional")) =], [=
+ (count "exparg.arg_optional" ) =], 0[=
+
+ ELIF (not (exist? "exparg.arg_optional")) =][=
+ (- (count "exparg") 1) =], 0, 1[=
+
+ ELSE =][=
+ (- (count "exparg") (count "exparg.arg_optional")) =], [=
+ (- (count "exparg.arg_optional" ) 1) =], 1[=
+ ENDIF =], [=
+
+ name =]);[=
+
+ENDDEF =][=
+
+end of snarf.tpl \=]
View Lorry Controller Status