[svn:parrot] r44243 - in trunk: . config/gen/makefiles src/nci t/codingstd tools/build tools/dev
plobsing at svn.parrot.org
plobsing at svn.parrot.org
Sat Feb 20 18:42:31 UTC 2010
Author: plobsing
Date: Sat Feb 20 18:42:28 2010
New Revision: 44243
URL: https://trac.parrot.org/parrot/changeset/44243
Log:
move tools/build/nativecall.pir to tools/dev/nci_thunk_gen.pir
Added:
trunk/tools/dev/nci_thunk_gen.pir
- copied, changed from r44242, trunk/tools/build/nativecall.pir
Deleted:
trunk/tools/build/nativecall.pir
Modified:
trunk/MANIFEST
trunk/config/gen/makefiles/root.in
trunk/src/nci/core_thunks.c
trunk/src/nci/extra_thunks.c
trunk/t/codingstd/linelength.t
trunk/t/codingstd/trailing_space.t
trunk/tools/dev/mk_nci_thunks.pl
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST Sat Feb 20 14:35:06 2010 (r44242)
+++ trunk/MANIFEST Sat Feb 20 18:42:28 2010 (r44243)
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Sat Feb 20 01:23:06 2010 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Sat Feb 20 18:21:54 2010 UT
#
# See below for documentation on the format of this file.
#
@@ -2139,7 +2139,6 @@
tools/build/fixup_gen_file.pl []
tools/build/h2inc.pl []
tools/build/headerizer.pl []
-tools/build/nativecall.pir []
tools/build/ops2c.pl [devel]
tools/build/ops2pm.pl []
tools/build/parrot_config_c.pl []
@@ -2174,6 +2173,7 @@
tools/dev/mk_nci_thunks.pl []
tools/dev/mk_rpm_manifests.pl []
tools/dev/nci_test_gen.pl []
+tools/dev/nci_thunk_gen.pir []
tools/dev/nm.pl []
tools/dev/nopaste.pl []
tools/dev/ops_not_tested.pl []
Modified: trunk/config/gen/makefiles/root.in
==============================================================================
--- trunk/config/gen/makefiles/root.in Sat Feb 20 14:35:06 2010 (r44242)
+++ trunk/config/gen/makefiles/root.in Sat Feb 20 18:42:28 2010 (r44243)
@@ -2414,8 +2414,8 @@
# for use by runtime/parrot/library/OpenGL.pir
src/glut_callbacks$(O): $(GENERAL_H_FILES)
-src/glut_nci_thunks.c: $(PARROT) runtime/parrot/library/data_json.pbc tools/build/nativecall.pir
- $(PARROT) tools/build/nativecall.pir \
+src/glut_nci_thunks.c: $(PARROT) runtime/parrot/library/data_json.pbc tools/dev/nci_thunk_gen.pir
+ $(PARROT) tools/dev/nci_thunk_gen.pir \
--loader-name=Parrot_glut_nci_loader \
--loader-storage-class=PARROT_DYNEXT_EXPORT \
--output=src/glut_nci_thunks.c \
Modified: trunk/src/nci/core_thunks.c
==============================================================================
--- trunk/src/nci/core_thunks.c Sat Feb 20 14:35:06 2010 (r44242)
+++ trunk/src/nci/core_thunks.c Sat Feb 20 18:42:28 2010 (r44243)
@@ -1,7 +1,7 @@
/* ex: set ro ft=c:
* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
*
- * This file is generated automatically by tools/build/nativecall.pir
+ * This file is generated automatically by tools/dev/nci_thunk_gen.pir
*
* Any changes made here will be lost!
*
Modified: trunk/src/nci/extra_thunks.c
==============================================================================
--- trunk/src/nci/extra_thunks.c Sat Feb 20 14:35:06 2010 (r44242)
+++ trunk/src/nci/extra_thunks.c Sat Feb 20 18:42:28 2010 (r44243)
@@ -1,7 +1,7 @@
/* ex: set ro ft=c:
* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
*
- * This file is generated automatically by tools/build/nativecall.pir
+ * This file is generated automatically by tools/dev/nci_thunk_gen.pir
*
* Any changes made here will be lost!
*
Modified: trunk/t/codingstd/linelength.t
==============================================================================
--- trunk/t/codingstd/linelength.t Sat Feb 20 14:35:06 2010 (r44242)
+++ trunk/t/codingstd/linelength.t Sat Feb 20 18:42:28 2010 (r44243)
@@ -125,7 +125,7 @@
compilers/pirc/macro/macroparser.h
compilers/pirc/src/hdocprep.l
compilers/pirc/src/hdocprep.c
-# generated by tools/build/nativecall.pir
+# generated by tools/dev/nci_thunk_gen.pir
src/nci/core_thunks.c
src/nci/extra_thunks.c
# these ones include long POD
Modified: trunk/t/codingstd/trailing_space.t
==============================================================================
--- trunk/t/codingstd/trailing_space.t Sat Feb 20 14:35:06 2010 (r44242)
+++ trunk/t/codingstd/trailing_space.t Sat Feb 20 18:42:28 2010 (r44243)
@@ -70,7 +70,7 @@
# vim: expandtab shiftwidth=4:
__DATA__
-# generated by tools/build/nativecall.pir
+# generated by tools/dev/nci_thunk_gen.pir
src/nci/core_thunks.c
src/nci/extra_thunks.c
Deleted: trunk/tools/build/nativecall.pir
==============================================================================
--- trunk/tools/build/nativecall.pir Sat Feb 20 18:42:28 2010 (r44242)
+++ /dev/null 00:00:00 1970 (deleted)
@@ -1,1017 +0,0 @@
-# Copyright (C) 2010, Parrot Foundation.
-# $Id$
-
-=head1 NAME
-
-tools/build/nativecall.pir - Build up the native call routines
-
-=head1 SYNOPSIS
-
- % ./parrot tools/build/nativecall.pir -o src/nci/extra_thunks.c <src/nci/extra_thunks.nci
-
-=head1 DESCRIPTION
-
-This script creates Native Call Interface files. It parses a file of function
-signatures of the form:
-
- <return-type-specifier><ws><parameter-type-specifiers>[<ws>][#<comment>]
- ...
-Empty lines and lines containing only whitespace or comment are ignored.
-The types specifiers are documented in F<src/nci/extra_thunks.nci>.
-
-=head1 SEE ALSO
-
-F<src/nci/extra_thunks.nci>.
-F<docs/pdds/pdd16_native_call.pod>.
-
-=cut
-
-.macro_const VERSION 0.01
-
-.macro_const SIG_TABLE_GLOBAL_NAME 'signature_table'
-.macro_const OPTS_GLOBAL_NAME 'options'
-
-.sub 'main' :main
- .param pmc argv
-
- # initialize global variables
- 'gen_sigtable'()
- 'get_options'(argv)
-
- .local string targ
- targ = 'read_from_opts'('target')
-
- .local pmc sigs
- sigs = 'read_sigs'()
-
- $S0 = 'read_from_opts'('output')
- $P0 = open $S0, 'w'
- setstdout $P0
-
- if targ == 'head' goto get_targ
- if targ == 'thunks' goto get_targ
- if targ == 'loader' goto get_targ
- if targ == 'coda' goto get_targ
- if targ == 'all' goto all
- if targ == 'names' goto names
- if targ == 'signatures' goto signatures
-
- # unknown target
- $S0 = 'sprintf'("Unknown target type '%s'", targ)
- die $S0
-
- all:
- $S0 = 'get_head'(sigs)
- say $S0
- $S0 = 'get_thunks'(sigs)
- say $S0
- $S0 = 'get_loader'(sigs)
- say $S0
- $S0 = 'get_coda'(sigs)
- say $S0
- exit 0
-
- get_targ:
- $S0 = concat 'get_', targ
- $P0 = get_global $S0
- $S1 = $P0(sigs)
- say $S1
- exit 0
-
- names:
- die "names not yet implemented"
- signatures:
- die "signatures not yet implemented"
-.end
-
-# getopt stuff {{{
-
-.macro_const OUTPUT 'output'
-.macro_const THUNK_STORAGE_CLASS 'thunk-storage-class'
-.macro_const THUNK_NAME_PROTO 'thunk-name-proto'
-.macro_const LOADER_STORAGE_CLASS 'loader-storage-class'
-.macro_const LOADER_NAME 'loader-name'
-.macro_const CORE 'core'
-
-.sub 'get_options'
- .param pmc argv
-
- load_bytecode 'Getopt/Obj.pbc'
-
- .local pmc getopt
- getopt = new ['Getopt';'Obj']
- push getopt, 'help|h'
- push getopt, 'version|v'
- push getopt, 'core'
- push getopt, 'output|o=s'
- push getopt, 'target=s'
- push getopt, 'thunk-storage-class=s'
- push getopt, 'thunk-name-proto=s'
- push getopt, 'loader-storage-class=s'
- push getopt, 'loader-name=s'
-
- .local string prog_name
- prog_name = shift argv
-
- .local pmc opt
- opt = getopt.'get_options'(argv)
-
- $I0 = opt['help']
- if $I0 goto print_help
-
- $I0 = opt['version']
- if $I0 goto print_version
-
- 'fixup_opts'(opt)
-
- set_global .OPTS_GLOBAL_NAME, opt
- .return()
-
- print_help:
- 'usage'(prog_name)
- print_version:
- 'version'(prog_name)
-.end
-
-.sub 'usage'
- .param string prog_name
- print prog_name
- say ' - Parrot NCI thunk library creation utility'
- say <<'USAGE'
-
-Creates a C file of routines suitable for use as Parrot NCI thunks.
-
-Usage ./parrot nativecall.pir [options] -o output_c_file.c <input_signature_list.nci
-
-Options
- --help print this message and exit
- --version print the version number of this utility
- --core output a thunks file suitable for inclusion in Parrot core. Default is no.
- -o --output <file> specify output file to use.
- --target <target> select what to output (valid options are 'head', 'thunks',
- 'loader', 'coda', 'all', 'names', and 'signatures'). Default value is 'all'
- --thunk-storage-class <storage class>
- set the storage class used for the thunks. Default value is 'static'.
- --thunk-name-proto <printf prototype>
- set the prototype used for the thunk function names. Must be a printf
- format with arity 1. Default value is 'pcf_%s'
- --loader-storage-class
- set the storage class used for the loader function. Default value is none.
- --loader-name set the name used for the loader function. Default value is 'Parrot_load_nci_thunks'.
-USAGE
- exit 0
-.end
-
-.sub 'version'
- .param string prog_name
- print prog_name
- print ' version '
- say .VERSION
- exit 0
-.end
-
-.sub 'fixup_opts'
- .param pmc opts
-
- $I0 = defined opts['core']
- if $I0 goto in_core
- opts['core'] = ''
- goto end_core
- in_core:
- opts['core'] = 'true'
- end_core:
-
- $I0 = defined opts['target']
- if $I0 goto end_target
- opts['target'] = 'all'
- end_target:
-
- $I0 = defined opts['thunk-storage-class']
- if $I0 goto end_thunk_storage_class
- opts['thunk-storage-class'] = 'static'
- end_thunk_storage_class:
-
- $I0 = defined opts['thunk-name-proto']
- if $I0 goto end_thunk_name_proto
- opts['thunk-name-proto'] = 'pcf_%s'
- end_thunk_name_proto:
-
- $S0 = opts['thunk-name-proto']
- $I0 = 'printf_arity'($S0)
- if $I0 == 1 goto end_thunk_name_proto_printf_arity
- 'sprintf'("Provided proto for 'thunk-name-proto' is of incorrect arity %i (expected 1)", $I0)
- die $S0
- end_thunk_name_proto_printf_arity:
-
- $I0 = defined opts['loader-storage-class']
- if $I0 goto end_loader_storage_class
- opts['loader-storage-class'] = ''
- end_loader_storage_class:
-
- $I0 = defined opts['loader-name']
- if $I0 goto end_loader_name
- opts['loader-name'] = 'Parrot_load_nci_thunks'
- end_loader_name:
-.end
-
-.sub 'read_from_opts'
- .param string key
-
- .local pmc opts
- opts = get_global .OPTS_GLOBAL_NAME
-
- $I0 = defined opts[key]
- unless $I0 goto not_present
-
- $S0 = opts[key]
- .return ($S0)
-
- not_present:
- $S0 = 'sprintf'("Parameter '%s' required but not provided", key)
- die $S0
-.end
-
-# }}}
-
-# get_{head,thunks,loader,coda} {{{
-
-.sub 'get_head'
- .param pmc ignored :slurpy
-
- .local string in_core
- in_core = 'read_from_opts'(.CORE)
-
- .local string ext_defn
- ext_defn = ''
- if in_core goto end_ext_defn
- ext_defn = '#define PARROT_IN_EXTENSION'
- end_ext_defn:
-
- .local string c_file
- c_file = 'read_from_opts'(.OUTPUT)
-
- .local string str_file
- str_file = clone c_file
- substr str_file, -2, 2, '.str'
- strip_str_file_loop:
- $I0 = index str_file, '/'
- if $I0 < 0 goto end_strip_str_file_loop
- $I0 += 1
- str_file = substr str_file, $I0
- goto strip_str_file_loop
- end_strip_str_file_loop:
-
- .local string head
- head = 'sprintf'(<<'HEAD', c_file, ext_defn, str_file)
-/* 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!
- *
- */
-
-/* %s
- * Copyright (C) 2010, 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:
- */
-
-%s
-#include "parrot/parrot.h"
-#include "pmc/pmc_nci.h"
-
-
-#ifdef PARROT_IN_EXTENSION
-/* external libraries can't have strings statically compiled into parrot */
-# define CONST_STRING(i, s) Parrot_str_new_constant((i), (s))
-#else
-# include "%s"
-#endif
-
-/* HEADERIZER HFILE: none */
-/* HEADERIZER STOP */
-
-/* All our static functions that call in various ways. Yes, terribly
- hackish, but that is just fine */
-
-HEAD
- .return (head)
-.end
-
-.sub 'get_thunks'
- .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 :flat)
- code = concat code, $S0
-
- inc i
- goto loop
- end_loop:
- .return (code)
-.end
-
-.sub 'get_loader'
- .param pmc sigs
-
- $S0 = 'read_from_opts'(.LOADER_STORAGE_CLASS)
- $S1 = 'read_from_opts'(.LOADER_NAME)
- .local string code
- code = 'sprintf'(<<'FN_HEADER', $S0, $S1)
-
-%s void
-%s(PARROT_INTERP)
-{
- PMC *iglobals;
- PMC *temp_pmc;
-
- PMC *HashPointer = NULL;
-
- 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 (PMC_IS_NULL(HashPointer))
- PANIC(interp, "iglobals.nci_funcs isn't created yet");
-
-FN_HEADER
-
- .local int i, n
- 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 :flat)
-
- .local string key
- key = join '', sig
-
- $S0 = 'sprintf'(<<'TEMPLATE', fn_name, key)
- temp_pmc = Parrot_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'
-}
-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 string ret
- .param string params
-
- .local string final_assign
- $P0 = 'map_from_sig_table'(ret, 'ret_assign')
- final_assign = $P0[0]
-
- .local string extra_postamble
- $P0 = 'map_from_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 string ret
- .param string params
-
- .local string return_assign
- $P0 = 'map_from_sig_table'(ret, 'func_call_assign')
- return_assign = $P0[0]
-
- .local string ret_cast
- $P0 = 'map_from_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'(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 string ret
- .param string params
-
- unless params goto return
-
- .local string sig
- $P0 = 'map_from_sig_table'(params, 'sig_char')
- sig = join "", $P0
-
- .local string fill_params
- $P0 = 'map_from_sig_table'(params, 'fill_params_tmpl')
- 'fill_tmpls_ascending_ints'($P0)
- fill_params = join "", $P0
-
- .local string extra_preamble
- $P0 = 'map_from_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 string ret
- .param string params
-
- .local string ret_csig
- $P0 = 'map_from_sig_table'(ret, 'as_return')
- ret_csig = $P0[0]
-
- .local string params_csig
- $P0 = 'map_from_sig_table'(params, 'as_proto')
- params_csig = join ', ', $P0
-
- .local string ret_tdecl
- ret_tdecl = ""
- $P0 = 'map_from_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'(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'(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 :slurpy
- .local string storage_class, fn_name, fn_decl
- storage_class = 'read_from_opts'(.THUNK_STORAGE_CLASS)
- fn_name = 'sig_to_fn_name'(sig :flat)
- fn_decl = 'sprintf'(<<'TEMPLATE', storage_class, fn_name)
-%s void
-%s(PARROT_INTERP, PMC *self)
-TEMPLATE
- .return (fn_decl)
-.end
-
-.sub 'sig_to_fn_name'
- .param string ret
- .param string params
-
- .local string fix_params
- $P0 = 'map_from_sig_table'(params, 'cname')
- fix_params = join '', $P0
-
-
- $S0 = 'sprintf'('%s_%s', ret, fix_params)
- $S1 = 'read_from_opts'(.THUNK_NAME_PROTO)
- $S2 = 'sprintf'($S1, $S0)
- .return ($S2)
-.end
-
-.sub 'map_from_sig_table'
- .param string sig
- .param string field_name
-
- .local pmc sig_table
- sig_table = get_global .SIG_TABLE_GLOBAL_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)
- set_global .SIG_TABLE_GLOBAL_NAME, $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 = Parrot_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:
-
Modified: trunk/tools/dev/mk_nci_thunks.pl
==============================================================================
--- trunk/tools/dev/mk_nci_thunks.pl Sat Feb 20 14:35:06 2010 (r44242)
+++ trunk/tools/dev/mk_nci_thunks.pl Sat Feb 20 18:42:28 2010 (r44243)
@@ -25,7 +25,7 @@
my $nci_file = "src/nci/$_.nci";
my $loader_name = "Parrot_nci_load_$_";
print "$nci_file > $c_file\n";
- system("./parrot tools/build/nativecall.pir " .
+ system("./parrot tools/dev/nci_thunk_gen.pir " .
"--core " .
"--loader-name=$loader_name " .
"--output=$c_file " .
Copied and modified: trunk/tools/dev/nci_thunk_gen.pir (from r44242, trunk/tools/build/nativecall.pir)
==============================================================================
--- trunk/tools/build/nativecall.pir Sat Feb 20 14:35:06 2010 (r44242, copy source)
+++ trunk/tools/dev/nci_thunk_gen.pir Sat Feb 20 18:42:28 2010 (r44243)
@@ -3,11 +3,11 @@
=head1 NAME
-tools/build/nativecall.pir - Build up the native call routines
+tools/dev/nci_thunk_gen.pir - Build up native call thunk routines
=head1 SYNOPSIS
- % ./parrot tools/build/nativecall.pir -o src/nci/extra_thunks.c <src/nci/extra_thunks.nci
+ % ./parrot tools/dev/nci_thunk_gen.pir -o src/nci/extra_thunks.c <src/nci/extra_thunks.nci
=head1 DESCRIPTION
@@ -141,7 +141,7 @@
Creates a C file of routines suitable for use as Parrot NCI thunks.
-Usage ./parrot nativecall.pir [options] -o output_c_file.c <input_signature_list.nci
+Usage ./parrot nci_thunk_gen.pir [options] -o output_c_file.c <input_signature_list.nci
Options
--help print this message and exit
@@ -266,7 +266,7 @@
/* ex: set ro ft=c:
* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
*
- * This file is generated automatically by tools/build/nativecall.pir
+ * This file is generated automatically by tools/dev/nci_thunk_gen.pir
*
* Any changes made here will be lost!
*
More information about the parrot-commits
mailing list