[svn:parrot] r43647 - trunk/tools/build
plobsing at svn.parrot.org
plobsing at svn.parrot.org
Sat Jan 30 05:26:25 UTC 2010
Author: plobsing
Date: Sat Jan 30 05:26:25 2010
New Revision: 43647
URL: https://trac.parrot.org/parrot/changeset/43647
Log:
rewrite nativecall.pl in PIR.
TODO: figure out how to work this into the build system
Added:
trunk/tools/build/nativecall.pir
Added: trunk/tools/build/nativecall.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/build/nativecall.pir Sat Jan 30 05:26:25 2010 (r43647)
@@ -0,0 +1,865 @@
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+.sub 'main' :main
+ $P0 = 'gen_sigtable'()
+ $P1 = 'read_sigs'()
+
+ $S0 = 'get_head'($P0, $P1)
+ say $S0
+ $S0 = 'get_thunks'($P0, $P1)
+ say $S0
+ $S0 = 'get_loader'($P0, $P1)
+ say $S0
+ $S0 = 'get_coda'($P0, $P1)
+ say $S0
+.end
+
+# get_{head,thunks,loader,coda} {{{
+
+.sub 'get_head'
+ .param pmc ignored :slurpy
+ .return (<<'HEAD')
+/* ex: set ro ft=c:
+ * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ *
+ * This file is generated automatically by tools/build/nativecall.pir
+ *
+ * Any changes made here will be lost!
+ *
+ */
+
+/* nci.c
+ * Copyright (C) 2001-2009, Parrot Foundation.
+ * SVN Info
+ * $Id$
+ * Overview:
+ * Native Call Interface routines. The code needed to build a
+ * parrot to C call frame is in here
+ * Data Structure and Algorithms:
+ * History:
+ * Notes:
+ * References:
+ */
+#include "parrot/parrot.h"
+#include "parrot/hash.h"
+#include "parrot/oplib/ops.h"
+#include "pmc/pmc_managedstruct.h"
+#include "pmc/pmc_nci.h"
+#include "pmc/pmc_pointer.h"
+#include "pmc/pmc_callcontext.h"
+#include "nci.str"
+
+/* HEADERIZER HFILE: none */
+/* HEADERIZER STOP */
+
+/*
+ * if the architecture can build some or all of these signatures
+ * enable the define below
+ * - the JITed function will be called first
+ * - if it returns NULL, the hardcoded version will do the job
+ */
+
+#include "frame_builder.h"
+
+/* All our static functions that call in various ways. Yes, terribly
+ hackish, but that is just fine */
+
+HEAD
+.end
+
+.sub 'get_thunks'
+ .param pmc sig_table
+ .param pmc sigs
+ .local string code
+ .local int i, n
+ code = ''
+ i = 0
+ n = sigs
+ loop:
+ if i >= n goto end_loop
+
+ .local pmc sig
+ sig = sigs[i]
+ $S0 = 'sig_to_fn_code'(sig_table, sig :flat)
+ code = concat code, $S0
+
+ inc i
+ goto loop
+ end_loop:
+ .return (code)
+.end
+
+.sub 'get_loader'
+ .param pmc sig_table
+ .param pmc sigs
+ .local string code
+ .local int i, n
+ code = <<'FN_HEADER'
+
+
+/* This function serves a single purpose. It takes the function
+ signature for a C function we want to call and returns a pointer
+ to a function that can call it. */
+void *
+build_call_func(PARROT_INTERP,
+#if defined(CAN_BUILD_CALL_FRAMES)
+PMC *pmc_nci, NOTNULL(STRING *signature), NOTNULL(int *jitted))
+#else
+SHIM(PMC *pmc_nci), NOTNULL(STRING *signature), SHIM(int *jitted))
+#endif
+{
+ char *c;
+ STRING *ns, *message;
+ PMC *b;
+ PMC *iglobals;
+ PMC *temp_pmc;
+
+ PMC *HashPointer = NULL;
+
+ /* And in here is the platform-independent way. Which is to say
+ "here there be hacks" */
+
+ /* fixup empty signatures */
+ if (STRING_IS_EMPTY(signature))
+ signature = CONST_STRING(interp, "v");
+
+ iglobals = interp->iglobals;
+
+ if (PMC_IS_NULL(iglobals))
+ PANIC(interp, "iglobals isn't created yet");
+ HashPointer = VTABLE_get_pmc_keyed_int(interp, iglobals,
+ IGLOBALS_NCI_FUNCS);
+
+ if (!HashPointer) {
+ HashPointer = pmc_new(interp, enum_class_Hash);
+ VTABLE_set_pmc_keyed_int(interp, iglobals, IGLOBALS_NCI_FUNCS,
+ HashPointer);
+ }
+
+#if defined(CAN_BUILD_CALL_FRAMES)
+ /* Try if JIT code can build that signature. If yes, we are done */
+ b = VTABLE_get_pmc_keyed_str(interp, HashPointer, signature);
+
+ PARROT_ASSERT(PMC_IS_NULL(b) || b->vtable);
+
+ if ((!PMC_IS_NULL(b)) && b->vtable->base_type == enum_class_ManagedStruct) {
+ *jitted = 1;
+ return F2DPTR(VTABLE_get_pointer(interp, b));
+ }
+ else {
+ int jit_size;
+ void * const result = Parrot_jit_build_call_func(interp, pmc_nci, signature, &jit_size);
+ if (result) {
+ struct jit_buffer_private_data *priv;
+ *jitted = 1;
+ temp_pmc = pmc_new(interp, enum_class_ManagedStruct);
+ VTABLE_set_pointer(interp, temp_pmc, (void *)result);
+#ifdef PARROT_HAS_EXEC_PROTECT
+ priv = (struct jit_buffer_private_data *)
+ mem_sys_allocate(sizeof(struct jit_buffer_private_data));
+ priv->size = jit_size;
+ SETATTR_ManagedStruct_custom_free_func(interp, temp_pmc, Parrot_jit_free_buffer);
+ SETATTR_ManagedStruct_custom_free_priv(interp, temp_pmc, priv);
+ SETATTR_ManagedStruct_custom_clone_func(interp, temp_pmc, Parrot_jit_clone_buffer);
+ SETATTR_ManagedStruct_custom_clone_priv(interp, temp_pmc, priv);
+#endif /* PARROT_HAS_EXEC_PROTECT */
+ VTABLE_set_pmc_keyed_str(interp, HashPointer, signature, temp_pmc);
+ return result;
+ }
+ }
+
+#endif
+
+ b = VTABLE_get_pmc_keyed_str(interp, HashPointer, signature);
+
+ if (PMC_IS_NULL(b)) {
+FN_HEADER
+
+ i = 0
+ n = sigs
+ loop:
+ if i >= n goto end_loop
+
+ .local pmc sig
+ sig = shift sigs
+
+ .local string fn_name
+ fn_name = 'sig_to_fn_name'(sig_table, sig :flat)
+
+ .local string key
+ key = join '', sig
+
+ $S0 = 'sprintf'(<<'TEMPLATE', fn_name, key)
+ temp_pmc = pmc_new(interp, enum_class_UnManagedStruct);
+ VTABLE_set_pointer(interp, temp_pmc, (void *)%s);
+ VTABLE_set_pmc_keyed_str(interp, HashPointer, CONST_STRING(interp, "%s"), temp_pmc);
+TEMPLATE
+ code = concat code, $S0
+
+ inc i
+ goto loop
+ end_loop:
+
+ code = concat code, <<'FN_FOOTER'
+
+ b = VTABLE_get_pmc_keyed_str(interp, HashPointer, signature);
+ }
+
+ PARROT_ASSERT(PMC_IS_NULL(b) || b->vtable);
+
+ if ((!PMC_IS_NULL(b)) && b->vtable->base_type == enum_class_UnManagedStruct)
+ return F2DPTR(VTABLE_get_pointer(interp, b));
+
+ /*
+ These three lines have been added to aid debugging. I want to be able to
+ see which signature has an unknown type. I am sure someone can come up
+ with a neater way to do this.
+ */
+ ns = string_make(interp, " is an unknown signature type", 29, "ascii", 0);
+ message = Parrot_str_concat(interp, signature, ns, 0);
+
+#if defined(CAN_BUILD_CALL_FRAMES)
+ ns = string_make(interp, ".\\nCAN_BUILD_CALL_FRAMES is enabled, this should not happen", 58, "ascii", 0);
+#else
+ ns = string_make(interp, ".\\nCAN_BUILD_CALL_FRAMES is disabled, add the signature to src/call_list.txt", 75, "ascii", 0);
+#endif
+ message = Parrot_str_concat(interp, message, ns, 0);
+
+ /*
+ * I think there may be memory issues with this but if we get to here we are
+ * aborting.
+ */
+ c = Parrot_str_to_cstring(interp, message);
+ PANIC(interp, c);
+}
+
+FN_FOOTER
+ .return (code)
+.end
+
+.sub 'get_coda'
+ .param pmc ignored :slurpy
+ .return (<<'CODA')
+
+/*
+ * Local variables:
+ * c-file-style: "parrot"
+ * End:
+ * vim: expandtab shiftwidth=4:
+ */
+CODA
+.end
+
+# }}}
+
+# sig_to_* {{{
+
+.sub 'sig_to_fn_code'
+ .param pmc args :slurpy
+
+ .local string fn_decl
+ fn_decl = 'sig_to_fn_decl'(args :flat)
+
+ .local string var_decls
+ var_decls = 'sig_to_var_decls'(args :flat)
+
+ .local string preamble
+ preamble = 'sig_to_preamble'(args :flat)
+
+ .local string call
+ call = 'sig_to_call'(args :flat)
+
+ .local string postamble
+ postamble = 'sig_to_postamble'(args :flat)
+
+ .local string fn_code
+ fn_code = 'sprintf'("%s{\n%s%s%s%s}\n", fn_decl, var_decls, preamble, call, postamble)
+ .return (fn_code)
+.end
+
+.sub 'sig_to_postamble'
+ .param pmc sig_table
+ .param string ret
+ .param string params
+
+ .local string final_assign
+ $P0 = 'map_from_sig_table'(sig_table, ret, 'ret_assign')
+ final_assign = $P0[0]
+
+ .local string extra_postamble
+ $P0 = 'map_from_sig_table'(sig_table, params, 'postamble_tmpl')
+ 'fill_tmpls_ascending_ints'($P0)
+ extra_postamble = join "\n", $P0
+
+ .local string postamble
+ postamble = 'sprintf'(<<'TEMPLATE', final_assign, extra_postamble)
+ %s
+ %s
+TEMPLATE
+ .return (postamble)
+.end
+
+.sub 'sig_to_call'
+ .param pmc sig_table
+ .param string ret
+ .param string params
+
+ .local string return_assign
+ $P0 = 'map_from_sig_table'(sig_table, ret, 'func_call_assign')
+ return_assign = $P0[0]
+
+ .local string ret_cast
+ $P0 = 'map_from_sig_table'(sig_table, ret, 'as_return')
+ ret_cast = $P0[0]
+ if ret_cast == 'void' goto void_fn
+ ret_cast = 'sprintf'('(%s)', ret_cast)
+ goto end_ret_cast
+ void_fn:
+ ret_cast = ''
+ end_ret_cast:
+
+ .local string call_params
+ $P0 = 'map_from_sig_table'(sig_table, params, 'call_param_tmpl')
+ 'fill_tmpls_ascending_ints'($P0)
+ call_params = join ', ', $P0
+
+ .local string call
+ call = 'sprintf'(<<'TEMPLATE', return_assign, ret_cast, call_params)
+ GETATTR_NCI_orig_func(interp, self, orig_func);
+ fn_pointer = (func_t)D2FPTR(orig_func);
+ %s %s(*fn_pointer)(%s);
+TEMPLATE
+ .return (call)
+.end
+
+.sub 'sig_to_preamble'
+ .param pmc sig_table
+ .param string ret
+ .param string params
+
+ unless params goto return
+
+ .local string sig
+ $P0 = 'map_from_sig_table'(sig_table, params, 'sig_char')
+ sig = join "", $P0
+
+ .local string fill_params
+ $P0 = 'map_from_sig_table'(sig_table, params, 'fill_params_tmpl')
+ 'fill_tmpls_ascending_ints'($P0)
+ fill_params = join "", $P0
+
+ .local string extra_preamble
+ $P0 = 'map_from_sig_table'(sig_table, params, 'preamble_tmpl')
+ 'fill_tmpls_ascending_ints'($P0)
+ extra_preamble = join "", $P0
+
+ .local string preamble
+ preamble = 'sprintf'(<<'TEMPLATE', sig, fill_params, extra_preamble)
+ Parrot_pcc_fill_params_from_c_args(interp, call_object, "%s" %s);
+ %s
+TEMPLATE
+
+ return:
+ .return (preamble)
+.end
+
+.sub 'sig_to_var_decls'
+ .param pmc sig_table
+ .param string ret
+ .param string params
+
+ .local string ret_csig
+ $P0 = 'map_from_sig_table'(sig_table, ret, 'as_return')
+ ret_csig = $P0[0]
+
+ .local string params_csig
+ $P0 = 'map_from_sig_table'(sig_table, params, 'as_proto')
+ params_csig = join ', ', $P0
+
+ .local string ret_tdecl
+ ret_tdecl = ""
+ $P0 = 'map_from_sig_table'(sig_table, ret, 'return_type')
+ $S0 = $P0[0]
+ unless $S0 goto end_ret_type
+ if $S0 == 'void' goto end_ret_type
+ $S0 = 'sprintf'("%s return_data;\n", $S0)
+ ret_tdecl = concat ret_tdecl, $S0
+ end_ret_type:
+ $P0 = 'map_from_sig_table'(sig_table, ret, 'final_dest')
+ $S0 = $P0[0]
+ unless $S0 goto end_final_dest
+ $S0 = concat $S0, "\n"
+ ret_tdecl = concat ret_tdecl, $S0
+ end_final_dest:
+
+ .local string params_tdecl
+ $P0 = 'map_from_sig_table'(sig_table, params, 'temp_tmpl')
+ 'fill_tmpls_ascending_ints'($P0)
+ $P0 = 'grep_for_true'($P0)
+ params_tdecl = join ";\n ", $P0
+
+ .local string var_decls
+ var_decls = 'sprintf'(<<'TEMPLATE', ret_csig, params_csig, ret_tdecl, params_tdecl)
+ typedef %s(* func_t)(%s);
+ func_t fn_pointer;
+ void *orig_func;
+ PMC *ctx = CURRENT_CONTEXT(interp);
+ PMC *call_object = Parrot_pcc_get_signature(interp, ctx);
+ %s
+ %s;
+TEMPLATE
+
+ .return (var_decls)
+.end
+
+.sub 'sig_to_fn_decl'
+ .param pmc sig_table
+ .param pmc sig :slurpy
+ .local string fn_name, fn_decl
+ fn_name = 'sig_to_fn_name'(sig_table, sig :flat)
+ fn_decl = 'sprintf'(<<'TEMPLATE', fn_name)
+static void
+%s(PARROT_INTERP, PMC *self)
+TEMPLATE
+ .return (fn_decl)
+.end
+
+.sub 'sig_to_fn_name'
+ .param pmc sig_table
+ .param string ret
+ .param string params
+
+ .local string fix_params
+ $P0 = 'map_from_sig_table'(sig_table, params, 'cname')
+ fix_params = join '', $P0
+
+ $S0 = 'sprintf'('pcf_%s_%s', ret, fix_params)
+ .return ($S0)
+.end
+
+.sub 'map_from_sig_table'
+ .param pmc sig_table
+ .param string sig
+ .param string field_name
+
+ $P0 = split '', sig
+
+ .local pmc result
+ result = new ['ResizableStringArray']
+ $I0 = $P0
+ result = $I0
+
+ $I0 = $P0
+ $I1 = 0
+ loop:
+ if $I1 >= $I0 goto end_loop
+ $S0 = $P0[$I1]
+ $S1 = sig_table[$S0; field_name]
+ result[$I1] = $S1
+ inc $I1
+ goto loop
+ end_loop:
+
+ .return (result)
+.end
+
+# }}}
+
+# read_sigs {{{
+
+.sub 'read_sigs'
+ .local pmc stdin, seen, sigs
+ stdin = getstdin
+ seen = new ['Hash']
+ sigs = new ['ResizablePMCArray']
+
+ .local int lineno
+ lineno = 0
+ read_loop:
+ unless stdin goto end_read_loop
+
+ .local string ret_sig, param_sig, full_sig
+ (ret_sig, param_sig) = 'read_one_sig'(stdin)
+ inc lineno
+ full_sig = concat ret_sig, param_sig
+
+ # filter out empty sigs (and empty lines)
+ unless full_sig goto read_loop
+
+ # de-dup sigs
+ $I0 = seen[full_sig]
+ unless $I0 goto unseen
+ $S0 = 'sprintf'("Ignored signature '%s' on line %d (previously seen on line %d)\n", full_sig, lineno, $I0)
+ printerr $S0
+ goto read_loop
+ unseen:
+ seen[full_sig] = lineno
+
+ .local pmc sig
+ sig = new ['ResizableStringArray']
+ sig = 2
+ sig[0] = ret_sig
+ sig[1] = param_sig
+ push sigs, sig
+
+ goto read_loop
+ end_read_loop:
+
+ .return (sigs)
+.end
+
+.sub 'read_one_sig'
+ .param pmc fh
+
+ .local string line
+ line = readline fh
+
+ # handle comments
+ $I0 = index line, '#'
+ if $I0 < 0 goto end_comment
+ line = substr line, 0, $I0
+ end_comment:
+
+ # convert whitespace into spaces
+ $S0 = '\t'
+ whitespace_loop:
+ $I0 = index line, $S0
+ if $I0 < 0 goto end_whitespace_loop
+ substr line, $I0, 1, ' '
+ goto whitespace_loop
+ end_whitespace_loop:
+
+ if $S0 == "\n" goto end_whitespace
+ $S0 = "\n"
+ goto whitespace_loop
+ end_whitespace:
+
+ # turn multiple spaces into a single space
+ multispace_loop:
+ $I0 = index line, ' '
+ if $I0 < 0 goto end_multispace_loop
+ $S0 = substr line, $I0, 2, ' '
+ goto multispace_loop
+ end_multispace_loop:
+
+ # remove leading whitespace
+ $S0 = substr line, 0, 1
+ unless $S0 == ' ' goto end_leading
+ $S0 = substr line, 0, 1, ''
+ end_leading:
+
+ # handle empty (or whitespace only) lines
+ if line == '' goto ret
+ if line == ' ' goto ret
+
+ # remove trailing whitespace
+ $S0 = substr line, -1, 1
+ unless $S0 == ' ' goto end_trailing
+ $S0 = substr line, -1, 1, ''
+ end_trailing:
+
+ # read the signature
+ .local string ret_sig, param_sig
+ $P0 = split ' ', line
+ ret_sig = $P0[0]
+ param_sig = $P0[1]
+
+ ret:
+ .return (ret_sig, param_sig)
+.end
+
+#}}}
+
+# gen_sigtable {{{
+
+.sub 'gen_sigtable'
+ $S0 = 'sigtable_json'()
+ $P0 = 'decode_table'($S0)
+ 'fixup_table'($P0)
+ .return ($P0)
+.end
+
+.sub 'decode_table'
+ .param string json
+
+ .local pmc compiler
+ load_bytecode 'data_json.pbc'
+ compiler = compreg 'data_json'
+
+ .local pmc table
+ $P0 = compiler.'compile'(json)
+ table = $P0()
+
+ .return (table)
+.end
+
+.sub 'fixup_table'
+ .param pmc table
+
+ .local pmc table_iter
+ table_iter = iter table
+ iter_loop:
+ unless table_iter goto iter_end
+
+ .local string k
+ .local pmc v
+ k = shift table_iter
+ v = table[k]
+
+ $I0 = exists v['cname']
+ if $I0 goto has_cname
+ v['cname'] = k
+ has_cname:
+
+ $I0 = exists v['as_return']
+ if $I0 goto has_as_return
+ $S0 = v['as_proto']
+ v['as_return'] = $S0
+ has_as_return:
+
+ $I0 = exists v['return_type']
+ if $I0 goto has_return_type
+ $S0 = v['as_proto']
+ v['return_type'] = $S0
+ has_return_type:
+
+ $I0 = exists v['ret_assign']
+ $I1 = exists v['sig_char']
+ $I1 = !$I1
+ $I0 = $I0 || $I1 # not (not exists v[ret_assign] and exists v[sig_char])
+ if $I0 goto has_ret_assign
+ $S0 = 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "'
+ $S1 = v['sig_char']
+ $S0 = concat $S0, $S1
+ $S0 = concat $S0, '", return_data);'
+ v['ret_assign'] = $S0
+ has_ret_assign:
+
+ $I0 = exists v['func_call_assign']
+ if $I0 goto has_func_call_assign
+ v['func_call_assign'] = 'return_data = '
+ has_func_call_assign:
+
+ $I0 = exists v['temp_tmpl']
+ if $I0 goto has_temp_tmpl
+ $S0 = v['return_type']
+ $S0 = concat $S0, " t_%i"
+ v['temp_tmpl'] = $S0
+ has_temp_tmpl:
+
+ $I0 = exists v['fill_params_tmpl']
+ if $I0 goto has_fill_params_tmpl
+ v['fill_params_tmpl'] = ', &t_%i'
+ has_fill_params_tmpl:
+
+ $I0 = exists v['call_param_tmpl']
+ if $I0 goto has_call_param_tmpl
+ v['call_param_tmpl'] = 't_%i'
+ has_call_param_tmpl:
+
+ goto iter_loop
+ iter_end:
+
+ .return ()
+.end
+
+.sub 'sigtable_json'
+ .const string retv = <<'JSON'
+{
+ "p": { "as_proto": "void *",
+ "final_dest": "PMC * final_destination = PMCNULL;",
+ "temp_tmpl": "PMC *t_%i",
+ "sig_char": "P",
+ "call_param_tmpl": "PMC_IS_NULL((PMC*)t_%i) ? (void *)NULL : VTABLE_get_pointer(interp, t_%i)",
+ "ret_assign": "if (return_data != NULL) {
+ final_destination = pmc_new(interp, enum_class_UnManagedStruct);
+ VTABLE_set_pointer(interp, final_destination, return_data);
+ }
+ Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"P\", final_destination);" },
+ "i": { "as_proto": "int", "sig_char": "I",
+ "return_type": "INTVAL" },
+ "l": { "as_proto": "long", "sig_char": "I", "return_type": "INTVAL" },
+ "c": { "as_proto": "char", "sig_char": "I", "return_type": "INTVAL" },
+ "s": { "as_proto": "short", "sig_char": "I", "return_type": "INTVAL" },
+ "f": { "as_proto": "float", "sig_char": "N", "return_type": "FLOATVAL" },
+ "d": { "as_proto": "double", "sig_char": "N", "return_type": "FLOATVAL" },
+ "t": { "as_proto": "char *",
+ "final_dest": "STRING *final_destination;",
+ "ret_assign": "final_destination = Parrot_str_new(interp, return_data, 0);
+ Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"S\", final_destination);",
+ "sig_char": "S",
+ "temp_tmpl": "char *t_%i; STRING *ts_%i",
+ "fill_params_tmpl": ", &ts_%i",
+ "preamble_tmpl": "t_%i = ts_%i ? Parrot_str_to_cstring(interp, ts_%i) : (char *)NULL;",
+ "postamble_tmpl": "if (t_%i) Parrot_str_free_cstring(t_%i);" },
+ "v": { "as_proto": "void",
+ "return_type": "void *",
+ "sig_char": "v",
+ "ret_assign": "",
+ "func_call_assign": "" },
+ "P": { "as_proto": "PMC *", "sig_char": "P" },
+ "O": { "as_proto": "PMC *", "returns": "", "sig_char": "Pi" },
+ "J": { "as_proto": "PARROT_INTERP",
+ "returns": "",
+ "fill_params_tmpl": "",
+ "call_param_tmpl": "interp",
+ "temp_tmpl": "",
+ "sig_char": "" },
+ "S": { "as_proto": "STRING *", "sig_char": "S" },
+ "I": { "as_proto": "INTVAL", "sig_char": "I" },
+ "N": { "as_proto": "FLOATVAL", "sig_char": "N" },
+ "b": { "as_proto": "void *",
+ "as_return": "",
+ "sig_char": "S",
+ "temp_tmpl":"STRING *t_%i",
+ "call_param_tmpl": "Buffer_bufstart(t_%i)" },
+ "B": { "as_proto": "char **",
+ "as_return": "",
+ "sig_char": "S",
+ "fill_params_tmpl": ", &ts_%i",
+ "temp_tmpl": "char *t_%i; STRING *ts_%i",
+ "preamble_tmpl": "t_%i = ts_%i ? Parrot_str_to_cstring(interp, ts_%i) : (char *) NULL;",
+ "call_param_tmpl": "&t_%i",
+ "postamble_tmpl": "if (t_%i) Parrot_str_free_cstring(t_%i);" },
+ "2": { "as_proto": "short *",
+ "sig_char": "P",
+ "return_type": "short",
+ "ret_assign": "Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"I\", return_data);",
+ "temp_tmpl": "PMC *t_%i; short i_%i",
+ "preamble_tmpl": "i_%i = VTABLE_get_integer(interp, t_%i);",
+ "call_param_tmpl": "&i_%i",
+ "postamble_tmpl": "VTABLE_set_integer_native(interp, t_%i, i_%i);" },
+ "3": { "as_proto": "int *",
+ "sig_char": "P",
+ "return_type": "int",
+ "ret_assign": "Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"I\", return_data);",
+ "temp_tmpl": "PMC *t_%i; int i_%i",
+ "preamble_tmpl": "i_%i = VTABLE_get_integer(interp, t_%i);",
+ "call_param_tmpl": "&i_%i",
+ "postamble_tmpl": "VTABLE_set_integer_native(interp, t_%i, i_%i);" },
+ "4": { "as_proto": "long *",
+ "sig_char": "P",
+ "return_type": "long",
+ "ret_assign": "Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"I\", return_data);",
+ "temp_tmpl": "PMC *t_%i; long i_%i",
+ "preamble_tmpl": "i_%i = VTABLE_get_integer(interp, t_%i);",
+ "call_param_tmpl": "&i_%i",
+ "postamble_tmpl": "VTABLE_set_integer_native(interp, t_%i, i_%i);" },
+ "L": { "as_proto": "long *", "as_return": "" },
+ "T": { "as_proto": "char **", "as_return": "" },
+ "V": { "as_proto": "void **",
+ "as_return": "",
+ "sig_char": "P",
+ "temp_tmpl": "PMC *t_%i; void *v_%i",
+ "preamble_tmpl": "v_%i = VTABLE_get_pointer(interp, t_%i);",
+ "call_param_tmpl": "&v_%i",
+ "postamble_tmpl": "VTABLE_set_pointer(interp, t_%i, v_%i);" },
+ "@": { "as_proto": "PMC *", "as_return": "", "cname": "xAT_", "sig_char": "Ps" }
+}
+JSON
+ .return (retv)
+.end
+
+# }}}
+
+# utility fn's {{{
+
+.sub 'sprintf'
+ .param string tmpl
+ .param pmc args :slurpy
+ $S0 = sprintf tmpl, args
+ .return ($S0)
+.end
+
+.sub 'fill_tmpls_ascending_ints'
+ .param pmc tmpls
+ .local int idx, n
+
+ idx = 0
+ n = tmpls
+ loop:
+ if idx >= n goto end_loop
+ $S0 = tmpls[idx]
+ $I0 = 'printf_arity'($S0)
+ $P0 = 'xtimes'(idx, $I0)
+ $S1 = sprintf $S0, $P0
+ tmpls[idx] = $S1
+ inc idx
+ goto loop
+ end_loop:
+.end
+
+.sub 'printf_arity'
+ .param string tmpl
+
+ .local int count, idx
+ idx = 0
+ count = 0
+
+ loop:
+ idx = index tmpl, '%', idx
+ if idx < 0 goto end_loop
+
+ # check against '%%' escapes
+ $I0 = idx + 1
+ $S0 = substr tmpl, $I0, 1
+ unless $S0 == '%' goto is_valid_placeholder
+ idx = idx + 2 # skip both '%'s
+ goto loop
+ is_valid_placeholder:
+
+ inc idx
+ inc count
+ goto loop
+ end_loop:
+
+ .return (count)
+.end
+
+.sub 'xtimes'
+ .param pmc what
+ .param int times
+
+ .local pmc retv
+ retv = new ['ResizablePMCArray']
+ retv = times
+
+ $I0 = 0
+ loop:
+ if $I0 >= times goto end_loop
+ retv[$I0] = what
+ inc $I0
+ goto loop
+ end_loop:
+
+ .return (retv)
+.end
+
+.sub 'grep_for_true'
+ .param pmc input
+ .local pmc output
+ .local int i, n
+ output = new ['ResizableStringArray']
+ i = 0
+ n = input
+ loop:
+ if i >= n goto end_loop
+ $S0 = input[i]
+ unless $S0 goto end_cond
+ push output, $S0
+ end_cond:
+ inc i
+ goto loop
+ end_loop:
+ .return (output)
+.end
+
+# }}}
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
+
More information about the parrot-commits
mailing list