[svn:parrot] r44188 - in trunk: . config/gen/makefiles src src/nci t/codingstd tools/build tools/dev
plobsing at svn.parrot.org
plobsing at svn.parrot.org
Fri Feb 19 17:49:39 UTC 2010
Author: plobsing
Date: Fri Feb 19 17:49:37 2010
New Revision: 44188
URL: https://trac.parrot.org/parrot/changeset/44188
Log:
revert r44185 and r44161
This should fix the build for everyone else. Sorry.
Added:
trunk/tools/build/nativecall.pir
- copied unchanged from r44160, trunk/tools/build/nativecall.pir
Deleted:
trunk/tools/dev/nci_thunk_gen.pir
Modified:
trunk/ (props changed)
trunk/MANIFEST
trunk/MANIFEST.SKIP
trunk/MANIFEST.generated
trunk/config/gen/makefiles/root.in
trunk/src/ (props changed)
trunk/src/global_setup.c
trunk/src/nci/api.c
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 Fri Feb 19 16:51:52 2010 (r44187)
+++ trunk/MANIFEST Fri Feb 19 17:49:37 2010 (r44188)
@@ -2135,6 +2135,7 @@
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 []
@@ -2169,7 +2170,6 @@
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/MANIFEST.SKIP
==============================================================================
--- trunk/MANIFEST.SKIP Fri Feb 19 16:51:52 2010 (r44187)
+++ trunk/MANIFEST.SKIP Fri Feb 19 17:49:37 2010 (r44188)
@@ -1,6 +1,6 @@
# ex: set ro:
# $Id$
-# generated by tools/dev/mk_manifest_and_skip.pl Fri Feb 19 16:09:15 2010 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Fri Feb 19 01:11:00 2010 UT
#
# This file should contain a transcript of the svn:ignore properties
# of the directories in the Parrot subversion repository. (Needed for
@@ -105,12 +105,6 @@
^parrot_config\.pbc/
^parrot_debugger$
^parrot_debugger/
-^parrot_nci_thunk_gen$
-^parrot_nci_thunk_gen/
-^parrot_nci_thunk_gen\.c$
-^parrot_nci_thunk_gen\.c/
-^parrot_nci_thunk_gen\.pbc$
-^parrot_nci_thunk_gen\.pbc/
^parrot_test_run\.tar\.gz$
^parrot_test_run\.tar\.gz/
^pbc_disassemble$
@@ -645,8 +639,6 @@
^src/exec_dep\.h/
^src/extend_vtable\.c$
^src/extend_vtable\.c/
-^src/extra_nci_thunks\.c$
-^src/extra_nci_thunks\.c/
^src/fingerprint\.c$
^src/fingerprint\.c/
^src/glut_callbacks\.c$
Modified: trunk/MANIFEST.generated
==============================================================================
--- trunk/MANIFEST.generated Fri Feb 19 16:51:52 2010 (r44187)
+++ trunk/MANIFEST.generated Fri Feb 19 17:49:37 2010 (r44188)
@@ -64,7 +64,6 @@
installable_pbc_merge [main]bin
installable_pbc_to_exe.exe [main]bin
installable_pbc_to_exe [main]bin
-installable_parrot_nci_thunk_gen [main]bin
installable_parrot-nqp.exe [main]bin
installable_parrot-nqp [main]bin
lib/Parrot/Config/Generated.pm [devel]lib
Modified: trunk/config/gen/makefiles/root.in
==============================================================================
--- trunk/config/gen/makefiles/root.in Fri Feb 19 16:51:52 2010 (r44187)
+++ trunk/config/gen/makefiles/root.in Fri Feb 19 17:49:37 2010 (r44188)
@@ -526,7 +526,6 @@
PARROT_CONFIG = ./parrot_config$(EXE)
PIRC = ./pirc$(EXE)
NQP_RX = ./parrot-nqp$(EXE)
-PARROT_NCI_THUNK_GEN = ./parrot_nci_thunk_gen$(EXE)
# Installable executables
INSTALLABLEPARROT = ./installable_parrot$(EXE)
@@ -537,7 +536,6 @@
INSTALLABLEPDB = ./installable_parrot_debugger$(EXE)
INSTALLABLECONFIG = ./installable_parrot_config$(EXE)
INSTALLABLENQP = ./installable_parrot-nqp$(EXE)
-INSTALLABLENCITHUNKGEN = ./installable_parrot_nci_thunk_gen$(EXE)
# Libraries
LIBPARROT_STATIC = @blib_dir@/@libparrot_static@
@@ -557,7 +555,6 @@
DYNEXT_DIR = runtime/parrot/dynext
LIBNCI_TEST_SO = $(DYNEXT_DIR)/libnci_test$(LOAD_EXT)
LIBGLUTCB_SO = $(DYNEXT_DIR)/libglutcb$(LOAD_EXT)
-EXTRANCITHUNKS_SO = $(DYNEXT_DIR)/extra_nci_thunks$(LOAD_EXT)
###############################################################################
#
@@ -605,7 +602,6 @@
corevm \
docs \
#IF(has_glut): $(LIBGLUTCB_SO) \
- $(EXTRANCITHUNKS_SO) \
$(DIS) \
$(PARROT_CONFIG) \
$(PBC_TO_EXE) \
@@ -808,7 +804,7 @@
parrot_utils : $(PDUMP) $(DIS) $(PDB) $(PBC_MERGE) $(PBC_TO_EXE) $(PARROT_CONFIG) src/install_config$(O)
-installable: all $(INSTALLABLEPARROT) $(INSTALLABLEPDUMP) $(INSTALLABLEDIS) $(INSTALLABLEPDB) $(INSTALLABLEPBC_MERGE) $(INSTALLABLEPBCTOEXE) $(INSTALLABLECONFIG) $(INSTALLABLENQP) $(INSTALLABLENCITHUNKGEN)
+installable: all $(INSTALLABLEPARROT) $(INSTALLABLEPDUMP) $(INSTALLABLEDIS) $(INSTALLABLEPDB) $(INSTALLABLEPBC_MERGE) $(INSTALLABLEPBCTOEXE) $(INSTALLABLECONFIG) $(INSTALLABLENQP)
flags_dummy :
@@ -833,12 +829,6 @@
$(PARROT) -o pbc_to_exe.pbc tools/dev/pbc_to_exe.pir
$(PARROT) pbc_to_exe.pbc pbc_to_exe.pbc
-parrot_nci_thunk_gen.pbc : tools/dev/nci_thunk_gen.pir $(LIBRARY_DIR)/data_json.pbc $(PARROT)
- $(PARROT) -o parrot_nci_thunk_gen.pbc tools/dev/nci_thunk_gen.pir
-
-$(PARROT_NCI_THUNK_GEN) : parrot_nci_thunk_gen.pbc $(PBC_TO_EXE)
- $(PBC_TO_EXE) parrot_nci_thunk_gen.pbc
-
$(PARROT_CONFIG) : tools/util/parrot-config.pir $(PARROT) $(PBC_TO_EXE)
$(PARROT) -o parrot_config.pbc tools/util/parrot-config.pir
$(PARROT) pbc_to_exe.pbc parrot_config.pbc
@@ -951,9 +941,6 @@
$(INSTALLABLEPBCTOEXE) : $(PBC_TO_EXE) src/install_config$(O)
$(PBC_TO_EXE) pbc_to_exe.pbc --install
-$(INSTALLABLENCITHUNKGEN) : parrot_nci_thunk_gen.pbc $(PBC_TO_EXE) src/install_config$(O)
- $(PBC_TO_EXE) parrot_nci_thunk_gen.pbc --install
-
#
# Parrot Debugger
#
@@ -1846,11 +1833,8 @@
$(INSTALLABLEPDB) \
$(INSTALLABLECONFIG) \
$(INSTALLABLENQP) \
- $(INSTALLABLENCITHUNKGEN) \
pbc_to_exe.pbc pbc_to_exe.c pbc_to_exe$(O) pbc_to_exe$(EXE) \
parrot_config$(EXE) parrot_config.c parrot_config$(O) parrot_config.pbc \
- parrot_nci_thunk_gen$(EXE) parrot_nci_thunk_gen.c \
- parrot_nci_thunk_gen$(O) parrot_nci_thunk_gen.pbc \
compilers/imcc/main$(O) \
$(PDUMP) src/pbc_dump$(O) src/packdump$(O) \
$(PDB) src/parrot_debugger$(O) \
@@ -1866,8 +1850,6 @@
src/glut_callbacks$(O) \
src/glut_nci_thunks$(O) \
$(LIBGLUTCB_SO) \
- src/extra_nci_thunks$(O) \
- $(EXTRANCITHUNKS_SO) \
install_config.fpmc
$(PERL) $(BUILD_TOOLS_DIR)/c2str.pl --init
$(RM_F) \
@@ -1889,7 +1871,6 @@
$(INSTALLABLEPDB) \
$(INSTALLABLECONFIG) \
$(INSTALLABLENQP) \
- $(INSTALLABLENCITHUNKGEN) \
compilers/imcc/main$(O) \
$(PDUMP) src/pbc_dump$(O) src/packdump$(O) \
$(PDB) src/parrot_debugger$(O) \
@@ -1906,8 +1887,6 @@
$(LIBNCI_TEST_SO) \
src/glut_callbacks$(O) \
$(LIBGLUTCB_SO) \
- src/extra_nci_thunks$(O) \
- $(EXTRA_NCI_THUNKS) \
$(LIBPARROT_STATIC) \
$(LIBPARROT_SHARED)
@@ -2435,8 +2414,8 @@
# for use by runtime/parrot/library/OpenGL.pir
src/glut_callbacks$(O): $(GENERAL_H_FILES)
-src/glut_nci_thunks.c: $(PARROT_NCI_THUNK_GEN)
- $(PARROT_NCI_THUNK_GEN) \
+src/glut_nci_thunks.c: $(PARROT) runtime/parrot/library/data_json.pbc tools/build/nativecall.pir
+ $(PARROT) tools/build/nativecall.pir \
--loader-name=Parrot_glut_nci_loader \
--loader-storage-class=PARROT_DYNEXT_EXPORT \
--output=src/glut_nci_thunks.c \
@@ -2449,16 +2428,6 @@
@ld_out@$@ src/glut_callbacks$(O) src/glut_nci_thunks$(O) \
$(ALL_PARROT_LIBS) @opengl_lib@
-src/extra_nci_thunks.c : src/nci/extra_thunks.nci $(PARROT_NCI_THUNK_GEN)
- $(PARROT_NCI_THUNK_GEN) --dynext --output=src/extra_nci_thunks.c <src/nci/extra_thunks.nci
-
-src/extra_nci_thunks$(O): $(GENERAL_H_FILES)
-
-$(EXTRANCITHUNKS_SO) : $(LIBPARROT) src/extra_nci_thunks$(O)
- $(LD) $(LD_LOAD_FLAGS) $(LDFLAGS) \
- @ld_out@$@ src/extra_nci_thunks$(O) \
- $(ALL_PARROT_LIBS)
-
# emacs etags
# this needs exuberant-ctags
Modified: trunk/src/global_setup.c
==============================================================================
--- trunk/src/global_setup.c Fri Feb 19 16:51:52 2010 (r44187)
+++ trunk/src/global_setup.c Fri Feb 19 17:49:37 2010 (r44188)
@@ -190,11 +190,6 @@
pmc = pmc_new(interp, enum_class_Hash);
VTABLE_set_pmc_keyed_int(interp, iglobals, IGLOBALS_DYN_LIBS, pmc);
-
- pmc = pmc_new(interp, enum_class_Hash);
- VTABLE_set_pmc_keyed_int(interp, iglobals, IGLOBALS_NCI_FUNCS, pmc);
- Parrot_nci_load_core_thunks(interp);
- Parrot_nci_load_extra_thunks(interp);
}
/*
Modified: trunk/src/nci/api.c
==============================================================================
--- trunk/src/nci/api.c Fri Feb 19 16:51:52 2010 (r44187)
+++ trunk/src/nci/api.c Fri Feb 19 17:49:37 2010 (r44188)
@@ -18,6 +18,14 @@
/* HEADERIZER HFILE: include/parrot/nci.h */
/* HEADERIZER STOP */
+static void
+init_nci_funcs(PARROT_INTERP) {
+ VTABLE_set_pmc_keyed_int(interp, interp->iglobals, IGLOBALS_NCI_FUNCS,
+ pmc_new(interp, enum_class_Hash));
+ Parrot_nci_load_core_thunks(interp);
+ Parrot_nci_load_extra_thunks(interp);
+}
+
/* 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. */
@@ -37,8 +45,10 @@
PANIC(interp, "iglobals isn't created yet");
nci_funcs = VTABLE_get_pmc_keyed_int(interp, iglobals, IGLOBALS_NCI_FUNCS);
- if (PMC_IS_NULL(nci_funcs))
- PANIC(interp, "iglobals.nci_funcs isn't created yet");
+ if (PMC_IS_NULL(nci_funcs)) {
+ init_nci_funcs(interp);
+ nci_funcs = VTABLE_get_pmc_keyed_int(interp, iglobals, IGLOBALS_NCI_FUNCS);
+ }
thunk = VTABLE_get_pmc_keyed_str(interp, nci_funcs, signature);
Modified: trunk/src/nci/core_thunks.c
==============================================================================
--- trunk/src/nci/core_thunks.c Fri Feb 19 16:51:52 2010 (r44187)
+++ trunk/src/nci/core_thunks.c Fri Feb 19 17:49:37 2010 (r44188)
@@ -1,7 +1,7 @@
/* ex: set ro ft=c:
* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
*
- * This file is generated automatically by parrot_nci_thunk_gen
+ * This file is generated automatically by tools/build/nativecall.pir
*
* Any changes made here will be lost!
*
@@ -1050,11 +1050,13 @@
PMC *HashPointer = NULL;
iglobals = interp->iglobals;
- PARROT_ASSERT(!PMC_IS_NULL(iglobals));
+ if (PMC_IS_NULL(iglobals))
+ PANIC(interp, "iglobals isn't created yet");
HashPointer = VTABLE_get_pmc_keyed_int(interp, iglobals,
IGLOBALS_NCI_FUNCS);
- PARROT_ASSERT(!PMC_IS_NULL(HashPointer));
+ if (PMC_IS_NULL(HashPointer))
+ PANIC(interp, "iglobals.nci_funcs isn't created yet");
temp_pmc = pmc_new(interp, enum_class_UnManagedStruct);
VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_d_JOd);
Modified: trunk/src/nci/extra_thunks.c
==============================================================================
--- trunk/src/nci/extra_thunks.c Fri Feb 19 16:51:52 2010 (r44187)
+++ trunk/src/nci/extra_thunks.c Fri Feb 19 17:49:37 2010 (r44188)
@@ -1,7 +1,7 @@
/* ex: set ro ft=c:
* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
*
- * This file is generated automatically by parrot_nci_thunk_gen
+ * This file is generated automatically by tools/build/nativecall.pir
*
* Any changes made here will be lost!
*
@@ -6202,11 +6202,13 @@
PMC *HashPointer = NULL;
iglobals = interp->iglobals;
- PARROT_ASSERT(!PMC_IS_NULL(iglobals));
+ if (PMC_IS_NULL(iglobals))
+ PANIC(interp, "iglobals isn't created yet");
HashPointer = VTABLE_get_pmc_keyed_int(interp, iglobals,
IGLOBALS_NCI_FUNCS);
- PARROT_ASSERT(!PMC_IS_NULL(HashPointer));
+ if (PMC_IS_NULL(HashPointer))
+ PANIC(interp, "iglobals.nci_funcs isn't created yet");
temp_pmc = pmc_new(interp, enum_class_UnManagedStruct);
VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_v_J);
Modified: trunk/t/codingstd/linelength.t
==============================================================================
--- trunk/t/codingstd/linelength.t Fri Feb 19 16:51:52 2010 (r44187)
+++ trunk/t/codingstd/linelength.t Fri Feb 19 17:49:37 2010 (r44188)
@@ -125,7 +125,7 @@
compilers/pirc/macro/macroparser.h
compilers/pirc/src/hdocprep.l
compilers/pirc/src/hdocprep.c
-# generated by tools/dev/nci_thunk_gen.pir
+# generated by tools/build/nativecall.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 Fri Feb 19 16:51:52 2010 (r44187)
+++ trunk/t/codingstd/trailing_space.t Fri Feb 19 17:49:37 2010 (r44188)
@@ -70,7 +70,7 @@
# vim: expandtab shiftwidth=4:
__DATA__
-# generated by tools/dev/nci_thunk_gen.pir
+# generated by tools/build/nativecall.pir
src/nci/core_thunks.c
src/nci/extra_thunks.c
Copied: trunk/tools/build/nativecall.pir (from r44160, trunk/tools/build/nativecall.pir)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/tools/build/nativecall.pir Fri Feb 19 17:49:37 2010 (r44188, copy of r44160, trunk/tools/build/nativecall.pir)
@@ -0,0 +1,1017 @@
+# 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 = 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 = 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 Fri Feb 19 16:51:52 2010 (r44187)
+++ trunk/tools/dev/mk_nci_thunks.pl Fri Feb 19 17:49:37 2010 (r44188)
@@ -25,7 +25,7 @@
my $nci_file = "src/nci/$_.nci";
my $loader_name = "Parrot_nci_load_$_";
print "$nci_file > $c_file\n";
- system("./parrot_nci_thunk_gen " .
+ system("./parrot tools/build/nativecall.pir " .
"--core " .
"--loader-name=$loader_name " .
"--output=$c_file " .
Deleted: trunk/tools/dev/nci_thunk_gen.pir
==============================================================================
--- trunk/tools/dev/nci_thunk_gen.pir Fri Feb 19 17:49:37 2010 (r44187)
+++ /dev/null 00:00:00 1970 (deleted)
@@ -1,1128 +0,0 @@
-# Copyright (C) 2010, Parrot Foundation.
-# $Id$
-
-=head1 NAME
-
-tools/dev/nci_thunk_gen.pir - Build up native call routine thunks
-
-=head1 SYNOPSIS
-
- % parrot_nci_thunk_gen -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 OPTS_GLOBAL_NAME 'options'
-
-.sub 'main' :main
- .param pmc argv
-
- # initialize global variables
- '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 == 'dynext-loader' goto get_dynext_loader
- if targ == 'coda' goto get_targ
- if targ == 'all' goto all
- if targ == 'all-dynext' goto all_dynext
- 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
-
- all_dynext:
- $S0 = 'get_head'(sigs)
- say $S0
- $S0 = 'get_thunks'(sigs)
- say $S0
- $S0 = 'get_dynext_loader'(sigs)
- say $S0
- $S0 = 'get_coda'(sigs)
- say $S0
- exit 0
-
- get_dynext_loader:
- $S0 = 'get_dynext_loader'(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, 'dynext'
- 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_nci_thunk_gen [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['dynext']
- if $I0 goto is_dynext
- opts['dynext'] = ''
- goto end_dynext
- is_dynext:
- $I0 = defined opts['target']
- if $I0 goto end_dynext_target
- opts['target'] = 'all-dynext'
- end_dynext_target:
-
- $I0 = defined opts['loader-storage-class']
- if $I0 goto end_dynext_loader_storage_class
- opts['loader-storage-class'] = 'PARROT_DYNEXT_EXPORT'
- end_dynext_loader_storage_class:
-
- $I0 = defined opts['loader-name']
- if $I0 goto end_dynext_loader_name
- $S0 = opts['output']
- ($S0, $S1, $S2) = 'file_basename'($S0, '.c')
- $S0 = 'sprintf'('Parrot_lib_%s_init', $S1)
- opts['loader-name'] = $S0
- end_dynext_loader_name:
- end_dynext:
-
- $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,dynext_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
- ($S0, str_file, $S1) = 'file_basename'(c_file, '.c')
- str_file = concat str_file, '.str'
-
- .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 parrot_nci_thunk_gen
- *
- * 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;
- PARROT_ASSERT(!PMC_IS_NULL(iglobals));
-
- HashPointer = VTABLE_get_pmc_keyed_int(interp, iglobals,
- IGLOBALS_NCI_FUNCS);
- PARROT_ASSERT(!PMC_IS_NULL(HashPointer));
-
-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 = 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_dynext_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, SHIM(PMC *lib))
-{
- PMC *iglobals;
- PMC *temp_pmc;
-
- PMC *HashPointer = NULL;
-
- iglobals = interp->iglobals;
- PARROT_ASSERT(!PMC_IS_NULL(iglobals));
-
- HashPointer = VTABLE_get_pmc_keyed_int(interp, iglobals,
- IGLOBALS_NCI_FUNCS);
- PARROT_ASSERT(!PMC_IS_NULL(HashPointer));
-
-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 = 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
- .const 'Sub' sig_table = 'get_sigtable'
-
- $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
-
-#}}}
-
-# get_sigtable {{{
-
-.sub 'get_sigtable' :anon :immediate
- .const string json_table = <<'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
-
- # decode table
- .local pmc compiler
- load_bytecode 'data_json.pbc'
- compiler = compreg 'data_json'
-
- .local pmc table
- $P0 = compiler.'compile'(json_table)
- table = $P0()
-
- # fixup_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 (table)
-.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
-
-.sub 'file_basename'
- .param string full_path
- .param pmc extns :slurpy
-
- .local string dir, file, extn
-
- file = clone full_path
-
- extn_loop:
- unless extns goto end_extn_loop
- $S0 = shift extns
- $I0 = length $S0
- $I1 = -$I0
- $S1 = substr file, $I1, $I0
- unless $S1 == $S0 goto extn_loop
- extn = $S1
- substr file, $I1, $I0, ''
- end_extn_loop:
-
- # TODO: make this portable
- .const string file_sep = '/'
-
- strip_dir_loop:
- $I0 = index file, file_sep
- if $I0 < 0 goto end_strip_dir_loop
- inc $I0
- $S0 = substr file, 0, $I0
- dir = concat dir, $S0
- file = substr file, $I0
- goto strip_dir_loop
- end_strip_dir_loop:
-
- .return (dir, file, extn)
-.end
-
-# }}}
-
-# Local Variables:
-# mode: pir
-# fill-column: 100
-# End:
-# vim: expandtab shiftwidth=4 ft=pir:
-
More information about the parrot-commits
mailing list