diff --git a/README.md b/README.md index d7fc193..4671d97 100644 --- a/README.md +++ b/README.md @@ -21,18 +21,23 @@ invoked directly, bypassing the Tcl interpreter. TSP is written entirely in Tcl, with support libraries written in C and Java. +Changes to original TSP +* limited Namespace support for proc names and variables (see [Features](./docs/tsp-lang-features.md)) +* package support with ::tsp::init_package // ::tsp::finalize_package (see [Features](./docs/tsp-lang-features.md)) +* #tsp::inlinec and #tsp::altTCL directives to include native c-code and alternative tcl-code (see [Compiler Usage](./docs/compiler-usage.md)) +* some bugfixes I ran into # Docs - 1. [Introduction](https://github.com/tpoindex/tsp/blob/master/docs/introduction.md) - 2. [Features](https://github.com/tpoindex/tsp/blob/master/docs/tsp-lang-features.md) - 3. [Type System](https://github.com/tpoindex/tsp/blob/master/docs/type-system.md) - 4. [Compiled Commands](https://github.com/tpoindex/tsp/blob/master/docs/compiled-commands.md) - 5. [Runtime](https://github.com/tpoindex/tsp/blob/master/docs/runtime.md) - 6. [Compiler Usage](https://github.com/tpoindex/tsp/blob/master/docs/compiler-usage.md) - 7. [Future Improvements](https://github.com/tpoindex/tsp/blob/master/docs/future-improvements.md) - 8. [Install](https://github.com/tpoindex/tsp/blob/master/docs/install.md) - 9. [Misc.](https://github.com/tpoindex/tsp/blob/master/docs/misc.md) + 1. [Introduction](./docs/introduction.md) + 2. [Features](./docs/tsp-lang-features.md) + 3. [Type System](./docs/type-system.md) + 4. [Compiled Commands](./docs/compiled-commands.md) + 5. [Runtime](./docs/runtime.md) + 6. [Compiler Usage](./docs/compiler-usage.md) + 7. [Future Improvements](./docs/future-improvements.md) + 8. [Install](./docs/install.md) + 9. [Misc.](./docs/misc.md) Wiki (Q & A, discussion, other): http://wiki.tcl.tk/Tcl%20Static%20Prime diff --git a/docs/compiled-commands.md b/docs/compiled-commands.md old mode 100644 new mode 100755 diff --git a/docs/compiler-usage.md b/docs/compiler-usage.md old mode 100644 new mode 100755 index ea40115..c4f17ac --- a/docs/compiler-usage.md +++ b/docs/compiler-usage.md @@ -42,12 +42,14 @@ proc can also be specified with a single underscore **('_')**. a convenience for `tsp::log _` -### `tsp::printLog` *?outfd? ?proc?* +### `tsp::printLog` *?outfd? ?proc? ?breakeval?* `tsp::printLog` prints the compiler log. Optional outfd specifies a writable file handle, stderr is the default. Optional proc is specified, only that log is returned. The most recent compiled proc can also be specified with a single underscore **('_')**. +**breakeval** defaults to 1, so that TSP returns with an error, if there are any errors in transpilation. + ## Annotations @@ -100,7 +102,37 @@ vwait, etc.) include tracing on variables and the return values. This can be useful to isolate variable that may cause conversion errors. See the Tracing section below. - +### `#tsp::inlinec` +`#tsp::inlinec` defines a pure c line, that will be put into the source code directly without changes, so it is possible to e.g. call other c-procs directly (given you know the calling conventions) etc. + +### `#tsp::altTCL` +`#tsp::altTCL` is put into the generated tcl code (use if compilation/loading fails), so you can give alternate TCL versions of inlineC parts + +``` + +#example +package require tsp + +set handle $::tsp::TCC_HANDLE +$handle cproc t1 {int i} double {;#define a simple c procedure here -- it will be compile as c_t1 later + return i*0.5; +} +tsp::proc test {} { + #tsp::procdef double + #tsp::int i + #tsp::double l k + set k 1.0 + for {set i 0} {$i<100000} {incr i} {;# $i will be decorated as __i in TSP, $l as __l and so on + #tsp::inlinec __l = c_t1(__i); + #tsp::altTCL set l [t1 $i] + #tsp::inlinec __k = __k+sqrt(__l*__l*0.33); + #tsp::altTCL set k [expr {$k+sqrt($l*$l*0.33)}] + } + return $k +} + + +``` ## Trace compile type diff --git a/docs/future-improvements.md b/docs/future-improvements.md old mode 100644 new mode 100755 diff --git a/docs/install.md b/docs/install.md old mode 100644 new mode 100755 diff --git a/docs/introduction.md b/docs/introduction.md old mode 100644 new mode 100755 diff --git a/docs/misc.md b/docs/misc.md old mode 100644 new mode 100755 diff --git a/docs/outline.md b/docs/outline.md old mode 100644 new mode 100755 diff --git a/docs/runtime.md b/docs/runtime.md old mode 100644 new mode 100755 diff --git a/docs/tsp-lang-features.md b/docs/tsp-lang-features.md old mode 100644 new mode 100755 index 2a46429..7f4603c --- a/docs/tsp-lang-features.md +++ b/docs/tsp-lang-features.md @@ -50,16 +50,93 @@ a level of additional runtime interpretation. lappend foo {*}$s ;# invalid: expansion syntax not allows ``` -## Namespace not supported for proc names +## limited Namespace support for proc names and variables -Currently, procedures can only be defined in the global namespace. +Procedures can be defined in the global namespace. Namespace qualifiers in the proc name are invalid ``` - tsp::proc ::pkg::foo {} { ;# invalid: namespace procname not allowed + tsp::proc ::pkg::foo {} { ;# invalid: #tsp::procdef void } ``` +But you can define a project namespace with the variable tsp::PACKAGE_NAMESPACE; if defined, ALL procs will be rewritten to this namespace + +``` +set tsp::PACKAGE_NAMESPACE pkg + tsp::proc foo {} { ;# will be rewritten pkg::foo + #tsp::procdef void + #tsp::var v + variable v ;# will be connected to $pkg::v + } + +``` +## Package support +Package support depends on the package tcc4tcl_helper to work, someday it will be integrated here, meanwhile find it here https://github.com/MichaelMiR01/tccide/tree/main/subpackages + +Package support (tsp_packagehelper.tcl) introduces two commands +* ::tsp::init_package {packagename {packagenamespace ""} {packageversion 1.0} {tclversion TCL_VERSION}} +* ::tsp::finalize_package {{packagedir ""} {compiler none}} + +TSP will generate package code in the given packagedir (packagedir defaults to packagename). +It writes out + +* packagename.c +* packagename.tclprocs.tcl +* packagename.puretcl.tcl +* pkgIndex.tcl +* packagename.dll + +compiler can be **intern/memory** or **export**. + + **intern** (eq memory) will compile to memory and immediatly install the compiled procs + + **export** will build a shared lib (.so//.dll) an write it into the package dir as **packagename.dll // packagename.so** + +* packagename.tclprocs.tcl contains all TSP procs defined as tcl-only and will be sourced, if loading the dll fails +* packagename.puretcl.tcl TSP collects all proc definitions between init_package and finalize_package and spits them here. This will be sourced from pkgIndex, so not only tsp and tcc proc are loaded, but tcl procs can also be defined as helpers + +``` +#example +package require tsp + +::tsp::init_package tnop + +set handle $tsp::TCC_HANDLE +$handle cproc cnop {Tcl_Interp* interp } char* { + // this is a pure c-function + return "cnop"; +} +::tsp::proc tspnop {} { + #this is a transpiled function, its tcl code will go to tnop.tclprocs.tcl + #tsp::procdef void + puts "tspnop" +} +proc tclnop {} { + # this is a pure tcl function. its code will go to tnop.puretcl.tcl + puts "tclnop " +} +::tsp::printLog +::tsp::finalize_package tnop export +``` + +The exported package can now be loaded with package require packagename. + +Furthermore, TSP will try to spit out some compiler directives for tcc/gcc you can use as boilerplate to recompile the sourcecode with an optimizing compiler. + +Packages can be enriched with external libraries with the following directives: +``` +proc ::tsp::add_tclinclude {fname} + # load tcls for additional sources, issues a source (fname) command into pkgIndex + +proc ::tsp::add_bininclude {fname} + # load_dlls for dlls wich should be loaded into interp, issues a load (fname) command into pkgIndex + +proc ::tsp::add_dllinclude {fname} + # external dlls wich are dependencies and do not get loaded into interp but linked to your c-code (like jpeg.dll) + # tries to copy fname.dll into [pwd], so tcl can find it and dload +``` + ## Limitation on proc name and variable names Procedure names and variable names inside of procedures must follow strict naming conventions. diff --git a/docs/tutorial.md b/docs/tutorial.md old mode 100644 new mode 100755 diff --git a/docs/type-system.md b/docs/type-system.md old mode 100644 new mode 100755 diff --git a/lib/README.md b/lib/README.md index 2522fde..01dabb0 100644 --- a/lib/README.md +++ b/lib/README.md @@ -6,13 +6,20 @@ The following packages are required for use with C/Tcl. JTcl does not require any external packages, as the required packages 'hyde' and 'parser' are included in the JTcl distribution. -critcl-3.1.15 - https://github.com/andreas-kupries/critcl/releases +critcl-3.1.15 is no longer needed for tsp4tcc uses tcc4tcl (tcc 0.9.27) + +tcc4tcl (tcc 0.9.27) can be found here https://github.com/MichaelMiR01/tcc4tcl/releases + +Precompiled binaries for tcc4tcl can be found here https://github.com/MichaelMiR01/tccide/ + +crtitcl can be found here, just in case https://github.com/andreas-kupries/critcl/releases tclparser-1.4.1 Tclparser provides the 'parser' package. This package is extracted from the TclPro open source project. +Precompiled binaries for win32 and linux64 are store in the subdir parser together with a pkgIndex.tcl + Original source: http://tclpro.cvs.sourceforge.net/viewvc/tclpro/tclparser/ License: BSD, see tclparser-1.4.1/license.terms diff --git a/native/clang/TSP_cmd.c b/native/clang/TSP_cmd.c old mode 100644 new mode 100755 index 8331765..e587ea3 --- a/native/clang/TSP_cmd.c +++ b/native/clang/TSP_cmd.c @@ -35,10 +35,16 @@ TSP_Cmd_getCmdInfo(Tcl_Interp* interp, char* cmd) { return &cmdInfo; } +/* define TSP_REMOVABLE as static inline to enable tcc dead code elimination */ +#ifdef __TINYC__ +#define TSP_REMOVABLE static inline +#else +#define TSP_REMOVABLE static +#endif /* builtins command - a function that calls the builtin and fills in command obj name */ -int +TSP_REMOVABLE int TSP_Cmd_builtin_after (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -56,7 +62,7 @@ TSP_Cmd_builtin_after (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_append (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -74,7 +80,7 @@ TSP_Cmd_builtin_append (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_apply (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -92,7 +98,7 @@ TSP_Cmd_builtin_apply (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_array (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -110,7 +116,7 @@ TSP_Cmd_builtin_array (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_binary (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -128,7 +134,7 @@ TSP_Cmd_builtin_binary (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_break (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -146,7 +152,7 @@ TSP_Cmd_builtin_break (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_case (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -164,7 +170,7 @@ TSP_Cmd_builtin_case (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_catch (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -182,7 +188,7 @@ TSP_Cmd_builtin_catch (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_cd (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -200,7 +206,7 @@ TSP_Cmd_builtin_cd (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_O return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_chan (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -218,11 +224,12 @@ TSP_Cmd_builtin_chan (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_clock (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; static ClientData clientData = NULL; + static int result; if (cmdProc == NULL) { Tcl_CmdInfo* cmdInfo; cmdInfo = TSP_Cmd_getCmdInfo(interp, "::clock"); @@ -233,10 +240,13 @@ TSP_Cmd_builtin_clock (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc Tcl_IncrRefCount(cmdName); /* from altercation */ } objv[0] = cmdName; - return (cmdProc)(clientData, interp, objc, objv); + // somehow we have to reset the proc, or this risks to crash + result= (cmdProc)(clientData, interp, objc, objv); + cmdProc = NULL; + return result; } -int +TSP_REMOVABLE int TSP_Cmd_builtin_close (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -254,7 +264,7 @@ TSP_Cmd_builtin_close (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_concat (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -272,7 +282,7 @@ TSP_Cmd_builtin_concat (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_continue (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -290,7 +300,7 @@ TSP_Cmd_builtin_continue (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_dict (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -308,7 +318,7 @@ TSP_Cmd_builtin_dict (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_encoding (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -326,7 +336,7 @@ TSP_Cmd_builtin_encoding (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_eof (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -344,7 +354,7 @@ TSP_Cmd_builtin_eof (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_ return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_error (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -362,7 +372,7 @@ TSP_Cmd_builtin_error (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_eval (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -380,7 +390,7 @@ TSP_Cmd_builtin_eval (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_exec (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -398,7 +408,7 @@ TSP_Cmd_builtin_exec (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_exit (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -416,7 +426,7 @@ TSP_Cmd_builtin_exit (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_expr (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -434,7 +444,7 @@ TSP_Cmd_builtin_expr (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_fblocked (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -452,7 +462,7 @@ TSP_Cmd_builtin_fblocked (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_fconfigure (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -470,7 +480,7 @@ TSP_Cmd_builtin_fconfigure (ClientData dummy, Tcl_Interp* interp, int objc, stru return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_fcopy (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -488,7 +498,7 @@ TSP_Cmd_builtin_fcopy (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_file (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -506,7 +516,7 @@ TSP_Cmd_builtin_file (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_fileevent (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -524,7 +534,7 @@ TSP_Cmd_builtin_fileevent (ClientData dummy, Tcl_Interp* interp, int objc, struc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_flush (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -542,7 +552,7 @@ TSP_Cmd_builtin_flush (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_for (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -560,7 +570,7 @@ TSP_Cmd_builtin_for (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_ return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_foreach (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -578,7 +588,7 @@ TSP_Cmd_builtin_foreach (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_format (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -596,7 +606,7 @@ TSP_Cmd_builtin_format (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_gets (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -614,7 +624,7 @@ TSP_Cmd_builtin_gets (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_glob (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -632,7 +642,7 @@ TSP_Cmd_builtin_glob (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_global (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -650,7 +660,7 @@ TSP_Cmd_builtin_global (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_if (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -668,7 +678,7 @@ TSP_Cmd_builtin_if (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_O return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_incr (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -686,7 +696,7 @@ TSP_Cmd_builtin_incr (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_info (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -704,7 +714,7 @@ TSP_Cmd_builtin_info (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_interp (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -722,7 +732,7 @@ TSP_Cmd_builtin_interp (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_join (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -740,7 +750,7 @@ TSP_Cmd_builtin_join (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_lappend (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -758,7 +768,7 @@ TSP_Cmd_builtin_lappend (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_lassign (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -776,7 +786,7 @@ TSP_Cmd_builtin_lassign (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_lindex (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -794,7 +804,7 @@ TSP_Cmd_builtin_lindex (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_linsert (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -812,7 +822,7 @@ TSP_Cmd_builtin_linsert (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_list (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -830,7 +840,7 @@ TSP_Cmd_builtin_list (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_llength (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -848,7 +858,7 @@ TSP_Cmd_builtin_llength (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_lmap (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -866,7 +876,7 @@ TSP_Cmd_builtin_lmap (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_load (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -884,7 +894,7 @@ TSP_Cmd_builtin_load (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_lrange (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -902,7 +912,7 @@ TSP_Cmd_builtin_lrange (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_lrepeat (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -920,7 +930,7 @@ TSP_Cmd_builtin_lrepeat (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_lreplace (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -938,7 +948,7 @@ TSP_Cmd_builtin_lreplace (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_lreverse (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -956,7 +966,7 @@ TSP_Cmd_builtin_lreverse (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_lsearch (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -974,7 +984,7 @@ TSP_Cmd_builtin_lsearch (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_lset (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -992,7 +1002,7 @@ TSP_Cmd_builtin_lset (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_lsort (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1010,7 +1020,7 @@ TSP_Cmd_builtin_lsort (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_namespace (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1028,7 +1038,7 @@ TSP_Cmd_builtin_namespace (ClientData dummy, Tcl_Interp* interp, int objc, struc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_open (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1046,7 +1056,7 @@ TSP_Cmd_builtin_open (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_package (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1064,7 +1074,7 @@ TSP_Cmd_builtin_package (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_pid (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1082,7 +1092,7 @@ TSP_Cmd_builtin_pid (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_ return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_proc (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1100,7 +1110,7 @@ TSP_Cmd_builtin_proc (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_puts (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1118,7 +1128,7 @@ TSP_Cmd_builtin_puts (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_pwd (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1136,7 +1146,7 @@ TSP_Cmd_builtin_pwd (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_ return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_read (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1154,7 +1164,7 @@ TSP_Cmd_builtin_read (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_regexp (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1172,7 +1182,7 @@ TSP_Cmd_builtin_regexp (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_regsub (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1190,7 +1200,7 @@ TSP_Cmd_builtin_regsub (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_rename (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1208,7 +1218,7 @@ TSP_Cmd_builtin_rename (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_return (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1226,7 +1236,7 @@ TSP_Cmd_builtin_return (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_scan (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1244,7 +1254,7 @@ TSP_Cmd_builtin_scan (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_seek (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1262,7 +1272,7 @@ TSP_Cmd_builtin_seek (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_set (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1280,7 +1290,7 @@ TSP_Cmd_builtin_set (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_ return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_socket (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1298,7 +1308,7 @@ TSP_Cmd_builtin_socket (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_source (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1316,7 +1326,7 @@ TSP_Cmd_builtin_source (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_split (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1334,7 +1344,7 @@ TSP_Cmd_builtin_split (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_string (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1352,7 +1362,7 @@ TSP_Cmd_builtin_string (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_subst (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1370,7 +1380,7 @@ TSP_Cmd_builtin_subst (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_switch (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1388,7 +1398,7 @@ TSP_Cmd_builtin_switch (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_tailcall (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1406,7 +1416,7 @@ TSP_Cmd_builtin_tailcall (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_tell (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1424,7 +1434,7 @@ TSP_Cmd_builtin_tell (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_time (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1442,7 +1452,7 @@ TSP_Cmd_builtin_time (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_trace (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1460,7 +1470,7 @@ TSP_Cmd_builtin_trace (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_try (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1478,7 +1488,7 @@ TSP_Cmd_builtin_try (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_ return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_unload (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1496,7 +1506,7 @@ TSP_Cmd_builtin_unload (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_unset (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1514,7 +1524,7 @@ TSP_Cmd_builtin_unset (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_update (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1532,7 +1542,7 @@ TSP_Cmd_builtin_update (ClientData dummy, Tcl_Interp* interp, int objc, struct T return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_uplevel (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1550,7 +1560,7 @@ TSP_Cmd_builtin_uplevel (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_upvar (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1568,7 +1578,7 @@ TSP_Cmd_builtin_upvar (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_variable (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1586,7 +1596,7 @@ TSP_Cmd_builtin_variable (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_vwait (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1604,7 +1614,7 @@ TSP_Cmd_builtin_vwait (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_while (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1622,7 +1632,7 @@ TSP_Cmd_builtin_while (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_yield (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1640,7 +1650,7 @@ TSP_Cmd_builtin_yield (ClientData dummy, Tcl_Interp* interp, int objc, struct Tc return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_yieldto (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; @@ -1658,7 +1668,7 @@ TSP_Cmd_builtin_yieldto (ClientData dummy, Tcl_Interp* interp, int objc, struct return (cmdProc)(clientData, interp, objc, objv); } -int +TSP_REMOVABLE int TSP_Cmd_builtin_zlib (ClientData dummy, Tcl_Interp* interp, int objc, struct Tcl_Obj *objv[]) { static Tcl_ObjCmdProc* cmdProc = NULL; static Tcl_Obj* cmdName = NULL; diff --git a/native/clang/TSP_func.c b/native/clang/TSP_func.c old mode 100644 new mode 100755 index fcbd2ba..fc9366c --- a/native/clang/TSP_func.c +++ b/native/clang/TSP_func.c @@ -5,6 +5,7 @@ #ifndef _MATH_H #include #endif +#include #ifndef _LIBC_LIMITS_H_ #include @@ -24,7 +25,7 @@ /* functions that can raise errors have macros to add rc and exprErrMsg parameters */ #define TSP_func_int_div(a,b) _TSP_func_int_div(rc, &exprErrMsg, (a), (b)) -Tcl_WideInt +TSP_REMOVABLE Tcl_WideInt _TSP_func_int_div(int* rc, char** exprErrMsg, Tcl_WideInt dividend, Tcl_WideInt divisor) { Tcl_WideInt quotient; @@ -49,7 +50,7 @@ _TSP_func_int_div(int* rc, char** exprErrMsg, Tcl_WideInt dividend, Tcl_WideInt #define TSP_func_int_mod(a,b) _TSP_func_int_mod(rc, &exprErrMsg, (a), (b)) -Tcl_WideInt +TSP_REMOVABLE Tcl_WideInt _TSP_func_int_mod(int* rc, char** exprErrMsg, Tcl_WideInt dividend, Tcl_WideInt divisor) { Tcl_WideInt remainder = 0; int neg_divisor = 0; @@ -81,7 +82,7 @@ _TSP_func_int_mod(int* rc, char** exprErrMsg, Tcl_WideInt dividend, Tcl_WideInt #define TSP_func_double_div(a,b) _TSP_func_double_div(rc, &exprErrMsg, (a), (b)) -double +TSP_REMOVABLE double _TSP_func_double_div(int* rc, char** exprErrMsg, double x, double y) { CHECK_NAN(x); CHECK_NAN(y); @@ -92,7 +93,7 @@ _TSP_func_double_div(int* rc, char** exprErrMsg, double x, double y) { } } -int +TSP_REMOVABLE int TSP_func_util_strcmp(Tcl_DString* s1, Tcl_DString* s2) { int match; int length1 = Tcl_DStringLength(s1); @@ -107,37 +108,38 @@ TSP_func_util_strcmp(Tcl_DString* s1, Tcl_DString* s2) { } } -int +TSP_REMOVABLE int TSP_func_str_lt(Tcl_DString* s1, Tcl_DString* s2) { return (TSP_func_util_strcmp(s1, s2) < 0) ? TRUE : FALSE; } -int +TSP_REMOVABLE int TSP_func_str_gt(Tcl_DString* s1, Tcl_DString* s2) { return (TSP_func_util_strcmp(s1, s2) > 0) ? TRUE : FALSE; } -int +TSP_REMOVABLE int TSP_func_str_le(Tcl_DString* s1, Tcl_DString* s2) { return (TSP_func_util_strcmp(s1, s2) <= 0) ? TRUE : FALSE; } -int +TSP_REMOVABLE int TSP_func_str_ge(Tcl_DString* s1, Tcl_DString* s2) { return (TSP_func_util_strcmp(s1, s2) >= 0) ? TRUE : FALSE; } -int +TSP_REMOVABLE int TSP_func_str_eq(Tcl_DString* s1, Tcl_DString* s2) { return (TSP_func_util_strcmp(s1, s2) == 0) ? TRUE : FALSE; } -int +TSP_REMOVABLE int TSP_func_str_ne(Tcl_DString* s1, Tcl_DString* s2) { return (TSP_func_util_strcmp(s1, s2) != 0) ? TRUE : FALSE; } -Tcl_WideInt + +TSP_REMOVABLE Tcl_WideInt TSP_func_int_abs(Tcl_WideInt i) { if (i < 0) { if (i == LLONG_MIN) { @@ -150,7 +152,7 @@ TSP_func_int_abs(Tcl_WideInt i) { } } -double +TSP_REMOVABLE double TSP_func_double_abs(double x) { CHECK_NAN(x); if (x < 0) { @@ -161,7 +163,7 @@ TSP_func_double_abs(double x) { } #define TSP_func_acos(a) _TSP_func_acos(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_acos(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -173,7 +175,7 @@ _TSP_func_acos(int* rc, char** exprErrMsg, double x) { } #define TSP_func_asin(a) _TSP_func_asin(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_asin(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -185,7 +187,7 @@ _TSP_func_asin(int* rc, char** exprErrMsg, double x) { } #define TSP_func_atan(a) _TSP_func_atan(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_atan(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -197,7 +199,7 @@ _TSP_func_atan(int* rc, char** exprErrMsg, double x) { } #define TSP_func_atan2(a,b) _TSP_func_atan2(rc, &exprErrMsg, (a), (b)) -double +TSP_REMOVABLE double _TSP_func_atan2(int* rc, char** exprErrMsg, double x, double y) { double z; CHECK_NAN(x); @@ -210,7 +212,7 @@ _TSP_func_atan2(int* rc, char** exprErrMsg, double x, double y) { } #define TSP_func_ceil(a) _TSP_func_ceil(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_ceil(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -222,7 +224,7 @@ _TSP_func_ceil(int* rc, char** exprErrMsg, double x) { } #define TSP_func_cos(a) _TSP_func_cos(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_cos(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -234,7 +236,7 @@ _TSP_func_cos(int* rc, char** exprErrMsg, double x) { } #define TSP_func_cosh(a) _TSP_func_cosh(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_cosh(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -246,7 +248,7 @@ _TSP_func_cosh(int* rc, char** exprErrMsg, double x) { } #define TSP_func_exp(a) _TSP_func_exp(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_exp(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -258,7 +260,7 @@ _TSP_func_exp(int* rc, char** exprErrMsg, double x) { } #define TSP_func_floor(a) _TSP_func_floor(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_floor(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -270,7 +272,7 @@ _TSP_func_floor(int* rc, char** exprErrMsg, double x) { } #define TSP_func_fmod(a) _TSP_func_fmod(rc, &exprErrMsg, (a), (b)) -double +TSP_REMOVABLE double _TSP_func_fmod(int* rc, char** exprErrMsg, double x, double y) { double z; CHECK_NAN(x); @@ -283,7 +285,7 @@ _TSP_func_fmod(int* rc, char** exprErrMsg, double x, double y) { } #define TSP_func_hypot(a,b) _TSP_func_hypot(rc, &exprErrMsg, (a), (b)) -double +TSP_REMOVABLE double _TSP_func_hypot(int* rc, char** exprErrMsg, double x, double y) { double z; CHECK_NAN(x); @@ -296,7 +298,7 @@ _TSP_func_hypot(int* rc, char** exprErrMsg, double x, double y) { } #define TSP_func_log(a) _TSP_func_log(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_log(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -308,7 +310,7 @@ _TSP_func_log(int* rc, char** exprErrMsg, double x) { } #define TSP_func_log10(a) _TSP_func_log10(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_log10(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -318,9 +320,46 @@ _TSP_func_log10(int* rc, char** exprErrMsg, double x) { } return z; } +#ifndef max +#define max(a,b) \ + ({ __typeof__ (a) _a = (a); \ + __typeof__ (b) _b = (b); \ + _a > _b ? _a : _b; }) +#endif +#define TSP_func_max(a,b) _TSP_func_max(rc, &exprErrMsg, (a), (b)) +TSP_REMOVABLE double +_TSP_func_max(int* rc, char** exprErrMsg, double x, double y) { + double z; + CHECK_NAN(x); + CHECK_NAN(y); + z = max(x,y); + if (isnan(z)) { + RAISE_ERROR(TSP_DOMAIN_ERROR " max()"); + } + return z; +} +#ifndef min +#define min(a,b) \ + ({ __typeof__ (a) _a = (a); \ + __typeof__ (b) _b = (b); \ + _a <= _b ? _a : _b; }) +#endif +#define TSP_func_min(a,b) _TSP_func_min(rc, &exprErrMsg, (a), (b)) +TSP_REMOVABLE double +_TSP_func_min(int* rc, char** exprErrMsg, double x, double y) { + double z; + CHECK_NAN(x); + CHECK_NAN(y); + z = min(x,y); + if (isnan(z)) { + RAISE_ERROR(TSP_DOMAIN_ERROR " min()"); + } + return z; +} -#define TSP_func_pow(a,b) _TSP_func_pow(rc, &exprErrMsg, (a), (b)) -double +#define TSP_func_pow(a,b) _TSP_func_double_pow(rc, &exprErrMsg, (a), (b)) +#define TSP_func_double_pow(a,b) _TSP_func_double_pow(rc, &exprErrMsg, (a), (b)) +TSP_REMOVABLE double _TSP_func_double_pow(int* rc, char** exprErrMsg, double x, double y) { double z; CHECK_NAN(x); @@ -332,8 +371,8 @@ _TSP_func_double_pow(int* rc, char** exprErrMsg, double x, double y) { return z; } -#define TSP_func_int_pow(a,b) _TSP_func_int_pow(rc, &exprErrMsg, (a), (b)) -double +#define TSP_func_int_pow(a,b) _TSP_func_double_int_pow(rc, &exprErrMsg, (a), (b)) +TSP_REMOVABLE double _TSP_func_double_int_pow(int* rc, char** exprErrMsg, double x, Tcl_WideInt y) { double z; CHECK_NAN(x); @@ -345,18 +384,18 @@ _TSP_func_double_int_pow(int* rc, char** exprErrMsg, double x, Tcl_WideInt y) { } -double +TSP_REMOVABLE double TSP_func_rand() { - return drand48(); + return rand(); } -double +TSP_REMOVABLE double TSP_func_round(double x) { return round(x); } #define TSP_func_sin(a) _TSP_func_sin(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_sin(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -368,7 +407,7 @@ _TSP_func_sin(int* rc, char** exprErrMsg, double x) { } #define TSP_func_sinh(a) _TSP_func_sinh(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_sinh(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -380,7 +419,7 @@ _TSP_func_sinh(int* rc, char** exprErrMsg, double x) { } #define TSP_func_sqrt(a) _TSP_func_sqrt(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_sqrt(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -391,14 +430,14 @@ _TSP_func_sqrt(int* rc, char** exprErrMsg, double x) { return z; } -double +TSP_REMOVABLE double TSP_func_int_srand(Tcl_WideInt i) { - srand48((long) i); - return drand48(); + srand((long) i); + return rand(); } #define TSP_func_tan(a) _TSP_func_tan(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_tan(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); @@ -410,7 +449,7 @@ _TSP_func_tan(int* rc, char** exprErrMsg, double x) { } #define TSP_func_tanh(a) _TSP_func_tanh(rc, &exprErrMsg, (a)) -double +TSP_REMOVABLE double _TSP_func_tanh(int* rc, char** exprErrMsg, double x) { double z; CHECK_NAN(x); diff --git a/native/clang/TSP_util.c b/native/clang/TSP_util.c old mode 100644 new mode 100755 index 3d81eda..60769bc --- a/native/clang/TSP_util.c +++ b/native/clang/TSP_util.c @@ -1,11 +1,42 @@ #ifndef _TCL #include #endif - +int TSP_debug(Tcl_Interp* interp, char const *format, ...) { + /* Helper for Debugging*/ + char __buf [4096]; + va_list aptr; + int ret; + va_start(aptr, format); + ret = vsnprintf(__buf, 4096, format, aptr); + va_end(aptr); + // compensate for surplus linebreaks, sincs puts will already write one + if(ret<0) return EOF; + if(ret>4096) ret=4096; + if(__buf[ret-1]=='\n') __buf[ret-1]=0; + Tcl_Interp* ip = interp; + if (ip==NULL) Tcl_Panic("No interp found to call tcl routine!"); + mod_Tcl_errorCode=0; + Tcl_Obj* argObjvArray [2]; + Tcl_Obj* funcname = Tcl_NewStringObj("puts",-1); + Tcl_IncrRefCount(funcname); + argObjvArray[0] = funcname; + Tcl_Obj* target_1 = Tcl_NewStringObj(__buf,-1); + Tcl_IncrRefCount(target_1); + argObjvArray[1] = target_1; + int rs = Tcl_EvalObjv(ip, 2, argObjvArray, 0); + if(funcname!=NULL) Tcl_DecrRefCount(funcname); + if(target_1 != NULL) Tcl_DecrRefCount(target_1); + if(rs !=TCL_OK) { + Tcl_Eval (ip, "puts {Error evaluating TCL-Function puts}; puts $errorInfo; flush stdout;"); + return EOF; + } + Tcl_DoOneEvent(TCL_DONT_WAIT|TCL_ALL_EVENTS); + return 1; +} /*********************************************************************************************/ /* convert to an int from a string */ -int +TSP_REMOVABLE int TSP_Util_lang_convert_int_string(Tcl_Interp* interp, Tcl_DString* sourceVarName, Tcl_WideInt* targetVarName) { int rc; Tcl_Obj* obj = Tcl_NewStringObj(Tcl_DStringValue(sourceVarName), Tcl_DStringLength(sourceVarName)); @@ -18,7 +49,7 @@ TSP_Util_lang_convert_int_string(Tcl_Interp* interp, Tcl_DString* sourceVarName, /*********************************************************************************************/ /* convert to an int from a string const */ -int +TSP_REMOVABLE int TSP_Util_lang_convert_int_string_const(Tcl_Interp* interp, char* sourceVarName, Tcl_WideInt* targetVarName) { int rc; Tcl_Obj* obj = Tcl_NewStringObj(sourceVarName, -1); @@ -31,7 +62,7 @@ TSP_Util_lang_convert_int_string_const(Tcl_Interp* interp, char* sourceVarName, /*********************************************************************************************/ /* convert to a string from an int */ -Tcl_DString* +TSP_REMOVABLE Tcl_DString* TSP_Util_lang_convert_string_int(Tcl_Interp* interp, Tcl_DString* targetVarName, Tcl_WideInt sourceVarName) { char str[500]; char *format = "%" TCL_LL_MODIFIER "d"; @@ -50,7 +81,7 @@ TSP_Util_lang_convert_string_int(Tcl_Interp* interp, Tcl_DString* targetVarName, /*********************************************************************************************/ /* convert to a string from a double */ -Tcl_DString* +TSP_REMOVABLE Tcl_DString* TSP_Util_lang_convert_string_double(Tcl_Interp* interp, Tcl_DString* targetVarName, double sourceVarName) { char str[500]; if (targetVarName != NULL) { @@ -67,7 +98,7 @@ TSP_Util_lang_convert_string_double(Tcl_Interp* interp, Tcl_DString* targetVarNa /*********************************************************************************************/ /* convert to a string from a var */ -Tcl_DString* +TSP_REMOVABLE Tcl_DString* TSP_Util_lang_convert_string_var(Tcl_DString* targetVarName, Tcl_Obj* sourceVarName) { char* str; int len; @@ -86,7 +117,7 @@ TSP_Util_lang_convert_string_var(Tcl_DString* targetVarName, Tcl_Obj* sourceVarN /*********************************************************************************************/ /* get a string from an int */ /* string must be used immediately */ -Tcl_DString* +TSP_REMOVABLE Tcl_DString* TSP_Util_lang_get_string_int(Tcl_WideInt sourceVarName) { static int doInit = 1; static Tcl_DString ds; @@ -106,7 +137,7 @@ TSP_Util_lang_get_string_int(Tcl_WideInt sourceVarName) { /*********************************************************************************************/ /* get a string from an double */ /* string must be used immediately */ -Tcl_DString* +TSP_REMOVABLE Tcl_DString* TSP_Util_lang_get_string_double(double sourceVarName) { static int doInit = 1; static Tcl_DString ds; @@ -123,7 +154,7 @@ TSP_Util_lang_get_string_double(double sourceVarName) { /*********************************************************************************************/ /* get a string from a var */ /* string must be used immediately */ -Tcl_DString* +TSP_REMOVABLE Tcl_DString* TSP_Util_lang_get_string_var(Tcl_Obj* sourceVarName) { static int doInit = 1; static Tcl_DString ds; @@ -143,7 +174,7 @@ TSP_Util_lang_get_string_var(Tcl_Obj* sourceVarName) { /*********************************************************************************************/ /* assign a var from a boolean */ -Tcl_Obj* +TSP_REMOVABLE Tcl_Obj* TSP_Util_lang_assign_var_boolean(Tcl_Obj* targetVarName, int sourceVarName) { if (targetVarName != NULL) { Tcl_DecrRefCount(targetVarName); @@ -156,7 +187,7 @@ TSP_Util_lang_assign_var_boolean(Tcl_Obj* targetVarName, int sourceVarName) { /*********************************************************************************************/ /* assign a var from an int */ -Tcl_Obj* +TSP_REMOVABLE Tcl_Obj* TSP_Util_lang_assign_var_int(Tcl_Obj* targetVarName, Tcl_WideInt sourceVarName) { if (targetVarName != NULL) { Tcl_DecrRefCount(targetVarName); @@ -169,7 +200,7 @@ TSP_Util_lang_assign_var_int(Tcl_Obj* targetVarName, Tcl_WideInt sourceVarName) /*********************************************************************************************/ /* assign a var from an double */ -Tcl_Obj* +TSP_REMOVABLE Tcl_Obj* TSP_Util_lang_assign_var_double(Tcl_Obj* targetVarName, double sourceVarName) { if (targetVarName != NULL) { Tcl_DecrRefCount(targetVarName); @@ -182,7 +213,7 @@ TSP_Util_lang_assign_var_double(Tcl_Obj* targetVarName, double sourceVarName) { /*********************************************************************************************/ /* assign a var from an string */ -Tcl_Obj* +TSP_REMOVABLE Tcl_Obj* TSP_Util_lang_assign_var_string(Tcl_Obj* targetVarName, Tcl_DString* sourceVarName) { if (targetVarName != NULL) { Tcl_DecrRefCount(targetVarName); @@ -195,7 +226,7 @@ TSP_Util_lang_assign_var_string(Tcl_Obj* targetVarName, Tcl_DString* sourceVarNa /*********************************************************************************************/ /* assign a var from an string const */ -Tcl_Obj* +TSP_REMOVABLE Tcl_Obj* TSP_Util_lang_assign_var_string_const(Tcl_Obj* targetVarName, char* sourceVarName) { if (targetVarName != NULL) { Tcl_DecrRefCount(targetVarName); @@ -208,14 +239,14 @@ TSP_Util_lang_assign_var_string_const(Tcl_Obj* targetVarName, char* sourceVarNam /*********************************************************************************************/ /* assign a var from a var */ -Tcl_Obj* +TSP_REMOVABLE Tcl_Obj* TSP_Util_lang_assign_var_var(Tcl_Obj* targetVarName, Tcl_Obj* sourceVarName) { if (targetVarName != NULL) { Tcl_DecrRefCount(targetVarName); } - /* targetVarName = Tcl_DuplicateObj(sourceVarName); */ - targetVarName = sourceVarName; + targetVarName = Tcl_DuplicateObj(sourceVarName); + //targetVarName = sourceVarName; Tcl_IncrRefCount(targetVarName); return targetVarName; @@ -224,9 +255,12 @@ TSP_Util_lang_assign_var_var(Tcl_Obj* targetVarName, Tcl_Obj* sourceVarName) { /*********************************************************************************************/ /* assign an array & element from a var */ -int + +TSP_REMOVABLE int TSP_Util_lang_assign_array_var(Tcl_Interp* interp, Tcl_Obj* targetArrayVar, Tcl_Obj* targetIdxVar, Tcl_Obj* var) { Tcl_Obj* obj; + if (var==NULL) {return TCL_ERROR;}; + //debug(interp,"TSP_Util_lang_assign_array_var %p %p %p\n",targetArrayVar,targetIdxVar,var); obj = Tcl_ObjSetVar2(interp, targetArrayVar, targetIdxVar, var, TCL_LEAVE_ERR_MSG); if (obj == NULL) { return TCL_ERROR; @@ -235,20 +269,9 @@ TSP_Util_lang_assign_array_var(Tcl_Interp* interp, Tcl_Obj* targetArrayVar, Tcl_ } } - -/*********************************************************************************************/ -/* compare two Tcl_DStrings */ -int -TSP_Util_string_compare(Tcl_DString* s1, Tcl_DString* s2) { - char* string2; - int length2; - - return TSP_Util_string_compare_const(s1, Tcl_DStringValue(s2), Tcl_DStringLength(s2)); -} - /*********************************************************************************************/ /* compare a Tcl_DString to a const string. use negative length to find first null in string2 */ -int +TSP_REMOVABLE int TSP_Util_string_compare_const(Tcl_DString* s1, char* string2, int length2) { char* string1; int length1; @@ -270,9 +293,29 @@ TSP_Util_string_compare_const(Tcl_DString* s1, char* string2, int length2) { } +/*********************************************************************************************/ +/* compare two Tcl_DStrings */ +TSP_REMOVABLE int +TSP_Util_string_compare(Tcl_DString* s1, Tcl_DString* s2) { + char* string2; + int length2; + + return TSP_Util_string_compare_const(s1, Tcl_DStringValue(s2), Tcl_DStringLength(s2)); +} + + +/* create Dstring from Char in tmpVar */ +Tcl_DString* TSP_UTIL_dstring_from_char (char* str, Tcl_DString* tmpvar) { + Tcl_DStringSetLength(tmpvar, 0); + Tcl_DStringAppend(tmpvar, str, -1); + return tmpvar; +} + + + /*********************************************************************************************/ /* create a constant string obj */ -Tcl_Obj* +TSP_REMOVABLE Tcl_Obj* TSP_Util_const_string(char* str) { Tcl_Obj* constObj; constObj = Tcl_NewStringObj(str, -1); @@ -282,7 +325,7 @@ TSP_Util_const_string(char* str) { /*********************************************************************************************/ /* create a constant wide int obj */ -Tcl_Obj* +TSP_REMOVABLE Tcl_Obj* TSP_Util_const_int(Tcl_WideInt i) { Tcl_Obj* constObj; constObj = Tcl_NewWideIntObj(i); @@ -292,7 +335,7 @@ TSP_Util_const_int(Tcl_WideInt i) { /*********************************************************************************************/ /* create a constant double obj */ -Tcl_Obj* +TSP_REMOVABLE Tcl_Obj* TSP_Util_const_double(double d) { Tcl_Obj* constObj; constObj = Tcl_NewDoubleObj(d); diff --git a/parser/pkgIndex.tcl b/parser/pkgIndex.tcl new file mode 100755 index 0000000..9082eba --- /dev/null +++ b/parser/pkgIndex.tcl @@ -0,0 +1 @@ +package ifneeded parser 1.001 [list load [file join $dir tclparser[info sharedlibextension]]] diff --git a/parser/readme.md b/parser/readme.md new file mode 100644 index 0000000..a04ac2f --- /dev/null +++ b/parser/readme.md @@ -0,0 +1 @@ +This are precompiled binaries of the tclParser for win32 and linux64 diff --git a/parser/tclParser.c b/parser/tclParser.c new file mode 100755 index 0000000..a39b903 --- /dev/null +++ b/parser/tclParser.c @@ -0,0 +1,971 @@ +/* + * tclParser.c -- + * + * This is a Tcl language parser as a Tcl dynamically loadable + * extension. + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * Copyright (c) 2000 Ajuba Solutions + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclParser.c,v 1.7 2007/07/08 19:53:05 kennykb Exp $ + */ + +/* + * tclInt.h is used for TclFindElement + */ + + /* i686-w64-mingw32-gcc -shared -s -m32 -D_WIN32 -Iincludetcl -Iincludetcl/win -Iinclude/xlib ./tclParser.c -Llib -ltclstub86 -Llib -otclparser.dll */ + +#define USE_TCL_STUBS +#include + +/* + * TCL_TOKEN_EXPAND_WORD is new in 8.5, but it's safe to define it + * when building in earlier releases, and a version of tclparser + * built that way continues to work in 8.5. + */ + +#ifndef TCL_TOKEN_EXPAND_WORD +#define TCL_TOKEN_EXPAND_WORD 256 +#endif + +/* + * The max number of characters needed to sprintf + * an integer, a space and a double. + */ + +#define MAX_RANGE_SIZE 100 + +/* + * name and version of this package + */ + +static char packageName[] = "parser"; +static char packageVersion[] = "1.001"; + +/* + * Declarations for functions defined in this file. + */ + +#ifdef BUILD_tclparser +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT +#endif + +EXTERN int Tclparser_Init _ANSI_ARGS_((Tcl_Interp *interp)); + +static int ParseMakeTokenList _ANSI_ARGS_((char *script, + Tcl_Parse *parsePtr, int index, Tcl_Obj **resultPtr)); +static Tcl_Obj *ParseMakeRange _ANSI_ARGS_((char *script, CONST char *start, + int end)); +static int ParseObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static void ParseSetErrorCode _ANSI_ARGS_((Tcl_Interp *interp, + char *script, Tcl_Parse *parsePtr)); +static int ParseCommand _ANSI_ARGS_((Tcl_Interp *interp, char *script, + int index, int length)); +static int ParseExpr _ANSI_ARGS_((Tcl_Interp *interp, char *script, + int index, int length)); +static int ParseList _ANSI_ARGS_((Tcl_Interp *interp, char *script, + int index, int length)); +static int ParseVarName _ANSI_ARGS_((Tcl_Interp *interp, char *script, + int index, int length)); +static int ParseGetString _ANSI_ARGS_((Tcl_Interp *interp, char *script, + int index, int length)); +static int ParseCharIndex _ANSI_ARGS_((Tcl_Interp *interp, char *script, + int index, int length)); +static int ParseCharLength _ANSI_ARGS_((Tcl_Interp *interp, char *script, + int index, int length)); +static int ParseCountNewline _ANSI_ARGS_((Tcl_Interp *interp, + char *script, int scriptLength, Tcl_Obj *rangePtr1, + Tcl_Obj *rangePtr2)); +static int ParseGetIndexAndLength _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *rangePtr, int scriptLen, int *index, + int *length)); + +/* + *---------------------------------------------------------------------- + * + * Tclparser_Init -- + * + * This procedure initializes the parse command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tclparser_Init(interp) + Tcl_Interp *interp; +{ + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } + Tcl_CreateObjCommand(interp, "parse", ParseObjCmd, NULL, NULL); + return Tcl_PkgProvide(interp, packageName, packageVersion); +} + +/* + *---------------------------------------------------------------------- + * + * ParseObjCmd -- + * + * This function implements the Tcl "parse" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParseObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int option, index, length, scriptLength; + char *script; + + static const char *options[] = { + "command", "expr", "varname", "list", + "getrange", "getstring", "charindex", "charlength", + "countnewline", NULL + }; + enum options { + PARSE_COMMAND, PARSE_EXPR, PARSE_VARNAME, PARSE_LIST, + PARSE_GET_RANGE, PARSE_GET_STR, PARSE_CHAR_INDEX, PARSE_CHAR_LEN, + PARSE_COUNT_NWLNE + }; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * Check the number arguments passed to the command and + * extract information (script, index, length) depending + * upon the option selected. + */ + + script = Tcl_GetStringFromObj(objv[2], &scriptLength); + switch ((enum options) option) { + case PARSE_GET_RANGE: + if (objc == 3) { + index = 0; + length = scriptLength; + } else if (objc == 5) { + if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) { + return TCL_ERROR; + } + if (index < 0) { + index = 0; + } else if (index >= scriptLength) { + index = scriptLength - 1; + } + if (length < 0) { + length = 0; + } else if (length > (scriptLength - index)) { + length = scriptLength - index; + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "string ?index length?"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, ParseMakeRange(script, script + index, + length)); + return TCL_OK; + + case PARSE_COMMAND: + case PARSE_EXPR: + case PARSE_VARNAME: + case PARSE_LIST: + case PARSE_GET_STR: + case PARSE_CHAR_INDEX: + case PARSE_CHAR_LEN: { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string range"); + return TCL_ERROR; + } + if (ParseGetIndexAndLength(interp, objv[3], scriptLength, + &index, &length) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) option) { + case PARSE_COMMAND: + return ParseCommand(interp, script, index, length); + case PARSE_EXPR: + return ParseExpr(interp, script, index, length); + case PARSE_VARNAME: + return ParseVarName(interp, script, index, length); + case PARSE_LIST: + return ParseList(interp, script, index, length); + case PARSE_GET_STR: + return ParseGetString(interp, script, index, length); + case PARSE_CHAR_INDEX: + return ParseCharIndex(interp, script, index, length); + case PARSE_CHAR_LEN: + return ParseCharLength(interp, script, index, length); + case PARSE_GET_RANGE: + case PARSE_COUNT_NWLNE: + /* No Op - This will suppress compiler warnings */ + break; + } + break; + } + case PARSE_COUNT_NWLNE: { + Tcl_Obj *range2; + if (objc == 5) { + range2 = objv[4]; + } else if (objc == 4) { + range2 = NULL; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "string range ?range?"); + return TCL_ERROR; + } + return ParseCountNewline(interp, script, scriptLength, + objv[3], range2); + } + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ParseCommand -- + * + * This function parses a script into Tcl commands by calling the + * Tcl_ParseCommand function. This routine returns a list of the + * following form: + * The first range refers to any leading comments before the command. + * The second range refers to the command itself. The third range + * contains the remainder of the original range that appears after + * the command range. The parseTree is a list representation + * of the parse tree where each node is a list in the form: + * . + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParseCommand(interp, script, index, length) + Tcl_Interp *interp; /* Current interpreter. */ + char *script; /* Script to parse. */ + int index; /* Index to the starting point of the + * script. */ + int length; /* Byte length of script be parsed. */ +{ + Tcl_Obj *resultPtr, *listPtr, *tokenPtr; + Tcl_Parse parse; + int i; + CONST char *start, *end; + + start = script + index; + + if (Tcl_ParseCommand(interp, start, length, 0, &parse) + != TCL_OK) { + ParseSetErrorCode(interp, script, &parse); + return TCL_ERROR; + } + + resultPtr = Tcl_GetObjResult(interp); + i = 0; + if (parse.commentStart) { + Tcl_ListObjAppendElement(interp, resultPtr, + ParseMakeRange(script, parse.commentStart, parse.commentSize)); + } else { + Tcl_ListObjAppendElement(interp, resultPtr, + ParseMakeRange(script, script, 0)); + } + Tcl_ListObjAppendElement(interp, resultPtr, + ParseMakeRange(script, parse.commandStart, parse.commandSize)); + end = parse.commandStart + parse.commandSize; + Tcl_ListObjAppendElement(interp, resultPtr, + ParseMakeRange(script, end, length - (int) (end - start))); + listPtr = Tcl_NewListObj(0, NULL); + while (i < parse.numTokens) { + i = ParseMakeTokenList(script, &parse, i, &tokenPtr); + Tcl_ListObjAppendElement(NULL, listPtr, tokenPtr); + } + Tcl_ListObjAppendElement(interp, resultPtr, listPtr); + Tcl_SetObjResult(interp, resultPtr); + Tcl_FreeParse(&parse); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseExpr -- + * + * This function parses a Tcl expression into a tree representation. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParseExpr(interp, script, index, length) + Tcl_Interp *interp; /* Current interpreter. */ + char *script; /* Script to parse. */ + int index; /* Index to the starting point of the + * script. */ + int length; /* Byte length of script be parsed. */ +{ + Tcl_Obj *resultPtr; + Tcl_Parse parse; + + resultPtr = Tcl_GetObjResult(interp); + + if (Tcl_ParseExpr(interp, script + index, length, &parse) + != TCL_OK) { + ParseSetErrorCode(interp, script, &parse); + return TCL_ERROR; + } + + /* + * There is only one top level token, so just return it. + */ + + ParseMakeTokenList(script, &parse, 0, &resultPtr); + Tcl_SetObjResult(interp, resultPtr); + Tcl_FreeParse(&parse); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseList -- + * + * This function parses a Tcl list into a list of ranges. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParseList(interp, script, index, length) + Tcl_Interp *interp; /* Current interpreter. */ + char *script; /* Script to parse. */ + int index; /* Index to the starting point of the + * script. */ + int length; /* Byte length of script be parsed. */ +{ + Tcl_Obj *resultPtr; + int size; + char c; + CONST char *list, *element, *prevList, *last; + + resultPtr = Tcl_NewListObj(0, NULL); + list = script + index; + last = list + length; + + for (;;) { + prevList = list; + if (TclFindElement(interp, list, length, &element, &list, + &size, NULL) != TCL_OK) { + Tcl_Obj *objv[4]; + Tcl_DecrRefCount(resultPtr); + objv[0] = Tcl_NewStringObj("PARSE", 5); + objv[1] = Tcl_NewStringObj("list", -1); + objv[2] = Tcl_NewIntObj(list - script); + objv[3] = Tcl_GetObjResult(interp); + Tcl_SetObjErrorCode(interp, Tcl_NewListObj(4, objv)); + return TCL_ERROR; + } + length -= (list - prevList); + if (element >= last) { + break; + } + + /* + * Check to see if this element was in quotes or braces. + * If it is, ensure that the range includes the quotes/braces + * so the parser can make decisions based on this fact. + */ + + if (element > script) { + c = *(element - 1); + } else { + c = 0; + } + if (c == '{' || c == '"') { + element--; + size += 2; + } + Tcl_ListObjAppendElement(interp, resultPtr, + ParseMakeRange(script, (char *)element, size)); + } + + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseVarName -- + * + * This function parses a Tcl braced word into a tree representation. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParseVarName(interp, script, index, length) + Tcl_Interp *interp; /* Current interpreter. */ + char *script; /* Script to parse. */ + int index; /* Index to the starting point of the + * script. */ + int length; /* Byte length of script be parsed. */ +{ + Tcl_Obj *resultPtr; + Tcl_Parse parse; + + resultPtr = Tcl_GetObjResult(interp); + + if (Tcl_ParseVarName(interp, script + index, length, &parse, 0) + != TCL_OK) { + ParseSetErrorCode(interp, script, &parse); + return TCL_ERROR; + } + + /* + * There is only one top level token, so just return it. + */ + + ParseMakeTokenList(script, &parse, 0, &resultPtr); + Tcl_SetObjResult(interp, resultPtr); + Tcl_FreeParse(&parse); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseSetErrorCode -- + * + * Set the errorCode variable the standard parser error form. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +ParseSetErrorCode(interp, script, parsePtr) + Tcl_Interp *interp; /* Current interpreter. */ + char *script; /* Script to parse. */ + Tcl_Parse *parsePtr; /* Parse state. */ +{ + Tcl_Obj *objv[4]; + char *type; + + switch (parsePtr->errorType) { + case TCL_PARSE_QUOTE_EXTRA: + type = "quoteExtra"; + break; + case TCL_PARSE_BRACE_EXTRA: + type = "braceExtra"; + break; + case TCL_PARSE_MISSING_BRACE: + type = "missingBrace"; + break; + case TCL_PARSE_MISSING_BRACKET: + type = "missingBracket"; + break; + case TCL_PARSE_MISSING_PAREN: + type = "missingParen"; + break; + case TCL_PARSE_MISSING_QUOTE: + type = "missingQuote"; + break; + case TCL_PARSE_MISSING_VAR_BRACE: + type = "missingVarBrace"; + break; + case TCL_PARSE_SYNTAX: + type = "syntax"; + break; + case TCL_PARSE_BAD_NUMBER: + type = "badNumber"; + break; + default: + type = "unknown"; + break; + } + objv[0] = Tcl_NewStringObj("PARSE", 5); + objv[1] = Tcl_NewStringObj(type, -1); + if (parsePtr->term) { + objv[2] = Tcl_NewIntObj(parsePtr->term - script); + } else { + objv[2] = Tcl_NewIntObj(0); + } + objv[3] = Tcl_GetObjResult(interp); + Tcl_SetObjErrorCode(interp, Tcl_NewListObj(4, objv)); +} + +/* + *---------------------------------------------------------------------- + * + * ParseMakeTokenList -- + * + * Make the list representation of a token. Each token is represented + * as a list where the first element is a token type, the second + * element is a range, and the third element is a list of + * subtokens. + * + * Results: + * Returns the next token offset and stores a newly allocated + * list object in the location referred to by resultPtrPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParseMakeTokenList(script, parsePtr, index, resultPtrPtr) + char *script; /* Pointer to start of script being parsed. */ + Tcl_Parse *parsePtr; /* Parse information. */ + int index; /* Index of token to append. */ + Tcl_Obj **resultPtrPtr; /* Pointer to location where resulting list + * object is to be stored. */ +{ + Tcl_Token *tokenPtr = parsePtr->tokenPtr + index; + Tcl_Obj *objv[3]; + int start; + char *type; + + switch (tokenPtr->type) { + case TCL_TOKEN_WORD: + type = "word"; + break; + case TCL_TOKEN_EXPAND_WORD: + type = "expand"; + break; + case TCL_TOKEN_SIMPLE_WORD: + type = "simple"; + break; + case TCL_TOKEN_TEXT: + type = "text"; + break; + case TCL_TOKEN_BS: + type = "backslash"; + break; + case TCL_TOKEN_COMMAND: + type = "command"; + break; + case TCL_TOKEN_VARIABLE: + type = "variable"; + break; + case TCL_TOKEN_SUB_EXPR: + type = "subexpr"; + break; + case TCL_TOKEN_OPERATOR: + type = "operator"; + break; + default: + type = "unknown"; + break; + } + objv[0] = Tcl_NewStringObj(type, -1); + objv[1] = ParseMakeRange(script, tokenPtr->start, tokenPtr->size); + objv[2] = Tcl_NewListObj(0, NULL); + start = index; + index++; + while (index <= start + tokenPtr->numComponents) { + index = ParseMakeTokenList(script, parsePtr, index, resultPtrPtr); + Tcl_ListObjAppendElement(NULL, objv[2], *resultPtrPtr); + } + + *resultPtrPtr = Tcl_NewListObj(3, objv); + return index; +} + +/* + *---------------------------------------------------------------------- + * + * ParseMakeRange -- + * + * Construct a new range object. + * + * Results: + * Returns a newly allocated Tcl object. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +ParseMakeRange(script, start, length) + char *script; /* Pointer to the first byte of the script. */ + CONST char *start; /* Pointer to the start of the range. */ + int length; /* The length of the range. */ +{ + Tcl_Obj *objv[2]; + + objv[0] = Tcl_NewIntObj(start-script); + objv[1] = Tcl_NewIntObj(length); + return Tcl_NewListObj(2, objv); +} + +/* + *---------------------------------------------------------------------- + * + * ParseGetString -- + * + * Extract the string fron the script within the boundaries of + * byte oriented index and length. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The interp's result is set. + * + *---------------------------------------------------------------------- + */ + +static int +ParseGetString(interp, script, index, length) + Tcl_Interp *interp; /* Current interpreter. */ + char *script; /* Script to parse. */ + int index; /* Index to the starting point of the + * script. */ + int length; /* Byte length of script be parsed. */ +{ + Tcl_Obj *resultPtr; + + resultPtr = Tcl_GetObjResult(interp); + Tcl_SetStringObj(resultPtr, script + index, length); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseCharIndex -- + * + * Converts byte oriented index values into character oriented + * index values. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The interp's result is set. + * + *---------------------------------------------------------------------- + */ + +static int +ParseCharIndex(interp, script, index, length) + Tcl_Interp *interp; /* Current interpreter. */ + char *script; /* Script to parse. */ + int index; /* Index to the starting point of the + * script. */ + int length; /* Byte length of script be parsed. */ +{ + Tcl_Obj *resultPtr; + + resultPtr = Tcl_GetObjResult(interp); + resultPtr = Tcl_NewLongObj(Tcl_NumUtfChars(script, index)); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseCharLength -- + * + * Converts the given byte length into a character count. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The interp's result is set. + * + *---------------------------------------------------------------------- + */ + +static int +ParseCharLength(interp, script, index, length) + Tcl_Interp *interp; /* Current interpreter. */ + char *script; /* Script to parse. */ + int index; /* Index to the starting point of the + * script. */ + int length; /* Byte length of script be parsed. */ +{ + Tcl_Obj *resultPtr; + + resultPtr = Tcl_GetObjResult(interp); + resultPtr = Tcl_NewLongObj(Tcl_NumUtfChars(script+index, length)); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +;} + +/* + *---------------------------------------------------------------------- + * + * ParseCountNewline -- + * + * Count the number of newlines between a range of characters + * in a script. If two ranges are passed to this function, + * calculate the number of newlines from the beginning index of + * the first range up to, but not including, the beginning of + * the second range. If one range is passed in, count the + * number of newlines from the beginning of the first range + * through the last character in the range. + * + * It is assumed that the indices and lengths are within the + * boundaries of the script. No error checking is done to + * verify this. Use the ParseGetIndexAndRange to validate + * the data. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The interp's result is set to the number of newlines counted. + * + *---------------------------------------------------------------------- + */ + +static int +ParseCountNewline(interp, script, scriptLength, rangePtr1, rangePtr2) + Tcl_Interp *interp; /* Current interpreter. */ + char *script; /* Script to parse. */ + int scriptLength; + Tcl_Obj *rangePtr1; /* Begin counting newlines with this range. */ + Tcl_Obj *rangePtr2; /* Possibly NULL, otherwise used to terminate + * newline counting */ +{ + Tcl_Obj *resultPtr; + char *subStr; + char *endStr; + int offset, index1, index2; + int length, length1, length2; + int listLen1, listLen2; + int numNewline; + + if (Tcl_ListObjLength(interp, rangePtr1, &listLen1) != TCL_OK) { + return TCL_ERROR; + } + if (ParseGetIndexAndLength(interp, rangePtr1, scriptLength, + &index1, &length1) != TCL_OK) { + return TCL_ERROR; + } + if (rangePtr2 != NULL) { + if (Tcl_ListObjLength(interp, rangePtr2, &listLen2) != TCL_OK) { + return TCL_ERROR; + } + if (ParseGetIndexAndLength(interp, rangePtr2, scriptLength, + &index2, &length2) != TCL_OK) { + return TCL_ERROR; + } + } else { + listLen2 = 0; + } + + if ((listLen1 == 0) && (listLen2 == 2)) { + /* + * Counting from the beginning of the file to + * the beginning of the second range. + * + * example: parse count script {} r2 + */ + + offset = 0; + length = index2; + } else if ((listLen1 == 2) && (listLen2 == 2)) { + /* + * Counting from the beginning of the first + * range to the beginning of the second range. + * + * example: parse count script r1 r2 + */ + + offset = index1; + length = (index2 - offset); + } else { + /* + * Counting from the beginning of the first + * range to the end of the first range. If + * the arg passed was an empty string it + * will count the whole script. + * + * example: parse count script {} + * parse count script r1 + */ + + offset = index1; + length = length1; + } + + subStr = (script + offset); + endStr = (subStr + length); + numNewline = 0; + while (subStr < endStr) { + if (*subStr == '\n') { + numNewline++; + } + subStr++; + } + + resultPtr = Tcl_GetObjResult(interp); + resultPtr = Tcl_NewIntObj(numNewline); + Tcl_SetObjResult(interp, resultPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseGetIndexAndLength -- + * + * Extract the index and length from a Tcl Object. If the + * Tcl Object does not contain data, return the beginning + * of the script as the index and the length of the script + * for the length. If the data in the script is out of the + * scripts range (e.g. < 0 or > scriptLength,) and scriptLen + * is >= 0, set the value to the closest point. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The values are written to the index and length arguments. + * If scriptLen is >= 0, the values will be normalized based + * on the length of the script. + * + *---------------------------------------------------------------------- + */ + +static int +ParseGetIndexAndLength(interp, rangePtr, scriptLen, indexPtr, lengthPtr) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Obj *rangePtr; + int scriptLen; /* Length of script. If >= 0, then try + * to normalize index and length based + * on the length of the script. */ + int *indexPtr; /* Index to the starting point of the + * script. */ + int *lengthPtr; /* Byte length of script be parsed. */ +{ + Tcl_Obj *itemPtr; + int listLen; + + if (Tcl_ListObjLength(interp, rangePtr, &listLen) != TCL_OK) { + return TCL_ERROR; + } + if ((listLen != 0) && (listLen != 2)) { + Tcl_SetResult(interp, "invalid range input: incorrect list size", TCL_STATIC); + return TCL_ERROR; + } + if ((listLen == 0) && (scriptLen < 0)) { + Tcl_SetResult(interp, "empty range: no index or length values", + TCL_STATIC); + return TCL_ERROR; + } + + /* + * If the range argument is null, then set 'index' to zero + * and 'length' to the string length of the script. Otherwise + * extract 'index' and 'length' from the list. If index or length + * is < 0 then set it to 0, if index or length is > then the scripts + * length, set it to the end of the script. + */ + + if (listLen == 0) { + *indexPtr = 0; + *lengthPtr = scriptLen; + } else { + int len; + char *bytes; + if (Tcl_ListObjIndex(interp, rangePtr, 0, &itemPtr) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, itemPtr, indexPtr) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_ListObjIndex(interp, rangePtr, 1, &itemPtr) != TCL_OK) { + return TCL_ERROR; + } + bytes = Tcl_GetStringFromObj(itemPtr, &len); + if ((*bytes == 'e') + && (strncmp(bytes, "end", (unsigned) len) == 0)) { + *lengthPtr = scriptLen; + } else if (Tcl_GetIntFromObj(interp, itemPtr, lengthPtr) != TCL_OK) { + return TCL_ERROR; + } + if (scriptLen >= 0) { + if (*indexPtr < 0) { + *indexPtr = 0; + } + if (*lengthPtr < 0) { + *lengthPtr = 0; + } + if (*indexPtr >= scriptLen) { + *indexPtr = scriptLen; + } + if (*indexPtr + *lengthPtr >= scriptLen) { + *lengthPtr = scriptLen - *indexPtr; + } + } + } + return TCL_OK; +} diff --git a/parser/tclparser.dll b/parser/tclparser.dll new file mode 100755 index 0000000..31f8eb3 Binary files /dev/null and b/parser/tclparser.dll differ diff --git a/parser/tclparser.so b/parser/tclparser.so new file mode 100755 index 0000000..e0c0e99 Binary files /dev/null and b/parser/tclparser.so differ diff --git a/pkgIndex.tcl b/pkgIndex.tcl old mode 100644 new mode 100755 diff --git a/tcc4tcl_helper.tcl b/tcc4tcl_helper.tcl new file mode 100644 index 0000000..0ad38ad --- /dev/null +++ b/tcc4tcl_helper.tcl @@ -0,0 +1,590 @@ +package provide tcc4tcl_helper 0.1 + +namespace eval ::tccenv { + # some common envelope vars for our ide + # this tries to analyze the surrounding dirs + # to find a suitable external compiler + # on windows this would be tcc.exe + # or gcc.exe + # someday this should be moved into tccide, since it's nothing to do with tcc4tcl + + variable localdir [pwd] + variable pathprefix [file dirname [file dirname [file dirname [info script]]]] + variable tccexecutabledir $localdir + variable tccexecutable tcc.exe + variable tccmaindir ${tccexecutabledir} + variable tccincludedir ${tccexecutabledir}/include + variable tcclibdir ${tccexecutabledir}/lib + + variable gccexecutabledir $localdir + variable gccexecutable gcc.exe + variable gccmaindir ${gccexecutabledir} + variable gccincludedir ${gccexecutabledir}/include + variable gcclibdir ${gccexecutabledir}/lib + + variable projectdir ${tccexecutabledir}/project + variable projectincludedir ${projectdir}/include + variable projectlibdir ${projectdir}/lib + + variable compiletime "" + + variable includes_missing "" + + variable EXTERNAL_COMPILERS "" + variable CC_DIRECTIVES "" + variable DLEXPORTMAKRO " +/***************** DLL EXPORT MAKRO FOR TCC AND GCC ************/ +#if (defined(_WIN32) && (defined(_MSC_VER)|| defined(__TINYC__) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) +#undef DLLIMPORT +#undef DLLEXPORT +# define DLLIMPORT __declspec(dllimport) +# define DLLEXPORT __declspec(dllexport) +#else +# define DLLIMPORT +# if defined(__GNUC__) && __GNUC__ > 3 +# define DLLEXPORT __attribute__ ((visibility(\"default\"))) +# else +# define DLLEXPORT +# endif +#endif +/***************************************************************/ +" + + # the following routines try to find tcc.exe and gcc.exe under win32 and set the tccenv vars accordingly + + proc setprojectdir {pdir} { + variable projectdir + variable projectincludedir + variable projectlibdir + set projectdir $pdir + set projectincludedir ${projectdir}/include + set projectlibdir ${projectdir}/lib + } + proc settccexedir {pdir {searchpathin ""}} { + variable tccexecutabledir + variable tccexecutable + variable tccmaindir + variable tccincludedir + variable tcclibdir + set searchpath {""} + foreach path $searchpathin { + lappend searchpath "$path" + } + set tccexecutabledir [findfiledir $pdir $searchpath "tcc.exe"] + set tccmaindir [file normalize ${tccexecutabledir}/] + set tccincludedir ${tccexecutabledir}/include + set tcclibdir ${tccexecutabledir}/lib + } + proc setgccexedir {pdir {searchpathin ""}} { + variable gccexecutabledir + variable gccexecutable + variable gccmaindir + variable gccincludedir + variable gcclibdir + set searchpath {"" "gcc/bin"} + foreach path $searchpathin { + lappend searchpath "$path" "$path/gcc/bin" + } + set gccexecutabledir [findfiledir $pdir $searchpath "gcc.exe"] + set gccmaindir [file normalize ${gccexecutabledir}/../../] + set gccincludedir ${gccmaindir}/include + set gcclibdir ${gccmaindir}/lib + } + + proc findfiledir {pdir searchpath filetofind} { + # + foreach p $searchpath { + set founddir [file join $pdir $p] + + if {![file exists [file join ${founddir} $filetofind]]} { + # try finding gcc + puts "not found $filetofind in $founddir" + } else { + puts "!found $filetofind in $founddir" + return [file join $founddir ""] + } + } + return "" + } +} + +proc ::tcc4tcl::getsubdirs {includepath} { + set retpath {} + foreach path $includepath { + if {![file isdir $path]} { + #try guessing in current subdirs + if {[file isdir [::tcc4tcl::shortenpath $path]]} { + set path [::tcc4tcl::shortenpath $path]; lappend retpath $path + } else { + if {[file isdir [file tail $path]]} {set path [file tail $path]; lappend retpath $path} + } + } + update + set subdirs "" + catch { + set subdirs [glob -nocomplain -directory $path -types d *] + } + foreach sub $subdirs { + set sub [file tail $sub] + lappend retpath [file join $path $sub] + append retpath " [::tcc4tcl::getsubdirs [file join $path $sub]]" + } + } + return $retpath +} + +proc ::tcc4tcl::searchDir {dir inDir} { + set subdirs "" + if {$dir==$inDir} { + return $inDir + } + catch { + set subdirs [glob -nocomplain -directory $inDir -types d *] + } + foreach sub $subdirs { + if {[file tail $sub]==$dir} { + return $sub + } + } + foreach sub $subdirs { + set d [::tcc4tcl::searchDir $dir $sub] + if {$d!=""} { + return $d + } + } + return "" +} + +proc ::tcc4tcl::shortenpath {path {prefix ""}} { + set shortincludepath "" + if {$prefix==""} { + set prefix $::tccenv::pathprefix/ + } + set prefix1 ${prefix}lib/ + set prefix2 ${prefix}lib/tcc4tcl-0.30/ + + set shortresult "" + set shortpath [string map [list $prefix ""] $path] + set shortpath1 [string map [list $prefix1 ""] $path] + set shortpath2 [string map [list $prefix2 ""] $path] + if {$shortpath2!=$path} { set shortresult $shortpath2; } + if {$shortpath1!=$path} { set shortresult $shortpath1; } + if {$shortpath!=$path} { set shortresult $shortpath; } + return shortresult +} + +proc ::tcc4tcl::analyse_includes {handle {prefix ""}} { + variable includes_missing + set includes_missing "" + set usedpath [$handle add_include_path] + set shortincludepath "" + if {$prefix==""} { + set prefix $::tccenv::pathprefix/ + } + set prefix1 ${prefix}lib/ + set prefix2 ${prefix}lib/tcc4tcl/ + + foreach path $usedpath { + set shortpath [string map [list $prefix ""] $path] + set shortpath1 [string map [list $prefix1 ""] $path] + set shortpath2 [string map [list $prefix2 ""] $path] + if {$shortpath2!=$path} { lappend shortincludepath $shortpath2; continue} + if {$shortpath1!=$path} { lappend shortincludepath $shortpath1; continue} + if {$shortpath!=$path} { lappend shortincludepath $shortpath; continue} + lappend shortincludepath $shortpath; + } + return $shortincludepath +} + +proc ::tcc4tcl::addExternalCompiler {compiler ccOptions exeDir exeFile {compilertype gccwin32}} { + # add external compiler to list EXTERNAL_COMPILERS + # $compiler: compilername cc + # $ccOptions additional options to use with cc + # $exeDir directory to execute cc in + # $exeFile cc to execute + # compilertype can be gccwin32/gcclin64/tccwin32/tcclin64/user and defines prebuilt ccOptions to use; set to user to have no predefined options + dict set ::tccenv::EXTERNAL_COMPILERS $compiler [list $compiler $ccOptions $exeDir $exeFile $compilertype] +} + +proc ::tcc4tcl::prepare_compilerdirectives {filepath handle} { + proc relTo {targetfile currentpath } { + # Get relative path to target file from current path + # First argument is a file name, second a directory name (not checked) + set result "" + set cc [file split [file normalize $currentpath]] + set tt [file split [file normalize $targetfile]] + set shorthandpath [file join [file normalize [pwd]] $targetfile] + if {![file exists $shorthandpath]} { + set shorthandpath [file join [file normalize $currentpath] $targetfile] + if {[file exists $shorthandpath]} { + # seems to be a direct hit + return $targetfile + } + } + + if {![string equal [lindex $cc 0] [lindex $tt 0]]} { + # not on *n*x then + return -code error "$targetfile not on same volume as $currentpath" + } + while {[string equal [lindex $cc 0] [lindex $tt 0]] && [llength $cc] > 0} { + # discard matching components from the front + set cc [lreplace $cc 0 0] + set tt [lreplace $tt 0 0] + } + set prefix {} + if {[llength $cc] == 0} { + # just the file name, so targetfile is lower down (or in same place) + set prefix . + } + # step up the tree + for {set i 0} {$i < [llength $cc]} {incr i} { + append prefix { ..} + } + # stick it all together + set result [file join {*}$prefix {*}$tt] + return $result + + } + proc eol {} { + switch -- $::tcl_platform(platform) { + windows {return \r\n} + unix {return \n} + macintosh {return \r} + default {\n} + } + } + + # This proc tries to guess the shell commands to invoke an external compiler + # therefor it uses $::tccenv::tccmaindir as a base directory + # ideally, tccide gets executed from $::tccenv::tccmaindir + # usually, your directory struct should look like this + # + # ::tccenv::tccmaindir/ + # tcc.exe executable for external compiler (tcc) + # include/... standard include dir for tcc, holding also tcl.h etc in include/generic + # win32/... standard win32 includes for tcc + # lib/... here go libtclstub86.a etc, tcc win32 defs libtcc1.a etc + # tsp-package/native/clang the include files for TSP go here + # + # when using gcc win32, all gcc stuff goes into + # ::tccenv::tccmaindir/gcc + # the binaries gcc.exe etc now are under + # ::tccenv::tccmaindir/gcc/bin + # + # under linux, gcc oder xgcc should be installed and bring there own includes etc. + # + # other compilers may need different treatment + # so be shure to set tccmaindir accordingly beforehand + + # add external compiler to list EXTERNAL_COMPILERS + # $compiler: compilername cc + # $ccOptions additional options to use with cc + # $exeDir directory to execute cc in + # $exeFile cc to execute + # $compilertype can be gccwin32/gcclin64/tccwin32/tcclin64/user and defines prebuilt ccOptions to use; set to user to have no predefined options + puts "Making Directives for $filepath ($::tccenv::tccmaindir)" + set pathway "" + catch {set pathway [::tcc4tcl::analyse_includes $handle]} + set includestccwin32 "-Iinclude -Iinclude/stdinc -Iinclude/generic -Iinclude/generic/win -Iinclude/xlib -Iwin32 -Iwin32/winapi " + set includesgccwin32 "-Iinclude -Iinclude/generic -Iinclude/generic/win -Iinclude/xlib" + set includestcclin64 "-Iinclude -Iinclude/stdinc -Iinclude/generic -Iinclude/generic/unix -Iinclude/xlib " + set includesgcclin64 "-Iinclude -Iinclude/generic -Iinclude/generic/unix -Iinclude/xlib" + set includesuser "" + + set librariestccwin32 "-ltclstub86elf -ltkstub86elf" + set librariestcclin64 "-ltclstub86_64 -ltkstub86_64" + set librariesgccwin32 "-Llib -ltclstub86 -ltkstub86" + set librariesgcclin64 "-Llib -ltclstub86_64 -ltkstub86_64" + set librariesuser "" + + set ccoptionstccwin32 "-m32 -D_WIN32 " + set ccoptionsgccwin32 "-s -m32 -D_WIN32 -static-libgcc " + set ccoptionstcclin64 {-Wl,-rpath=.} + set ccoptionsgcclin64 {-s -fPIC -D_GNU_SOURCE -Wl,-rpath=. } + + set ccoptionstccuser "" + + set includes_generic "" + + foreach incpath $pathway { + if {[string first include/ [string tolower $incpath]]<0} { + if {[string first win32 [string tolower $incpath]]<0} { + lappend includes_generic "-I[relTo $incpath $::tccenv::tccmaindir]" + } + } + } + + set libraries_addon "" + lappend libraries_addon "-Llib" + set libps "" + set libs "" + set opts "" + catch { + set libps [$handle add_library_path] + set libs [$handle add_library] + set opts [$handle add_options] + } + foreach inclib $libs { + lappend libraries_addon "-l$inclib" + } + foreach incpath $libps { + lappend libraries_addon "-L[relTo $incpath $::tccenv::tccmaindir]" + } + + set packagename [file rootname [file tail $filepath]] + set filepath [file dirname $filepath] + + if {[string first $::tccenv::tccmaindir $::tccenv::localdir]<0} { + set absfilepath [file normalize $filepath] + } else { + set absfilepath $filepath + } + + set relfilepath [relTo $filepath $::tccenv::tccmaindir] + set ccdirectives "" + foreach {compiler ccdetails} $::tccenv::EXTERNAL_COMPILERS { + # ok, spit out all directives and put it into dict CC_DIRECTIVES + set cc "" + lassign $ccdetails cc ccOptions exeDir exeFile compilertype + if {$cc eq ""} { + puts "ERROR: Unknown compiler $compiler or given none..." + continue; + } + + set includes [set [subst includes[set compilertype]]] + set libraries [set [subst libraries[set compilertype]]] + set ccoptions [set [subst ccoptions[set compilertype]]] + append libraries " $libraries_addon" + append inlcudes " $includes_generic" + + set dlext "dll" + if {[string first "lin64" $compilertype]>-1} { + set dlext "so" + } + + set cfile [file join $relfilepath "$packagename.c"] + set ofile [file join $relfilepath "$packagename.$dlext"] + + set ccpath [file join $exeDir $exeFile] + append ccoptions " -shared -DUSE_TCL_STUBS -O2" + append ccOptions " $ccoptions" + append ccOptions " [join $opts { }]" + + #puts "Directive for $compiler" + #puts "$ccpath $ccOptions $includes $includes_generic $cfile -o$ofile $libraries" + lappend ccdirectives $compiler "$ccpath $ccOptions $includes $includes_generic $cfile -o$ofile $libraries" + } + return $ccdirectives +} + +proc lstride {L n} { + set t [list]; set res [list] + foreach i $L { + lappend t $i + if {[llength $t]==$n} { + lappend res $t + set t [list] + } + } + if [llength $t] {lappend res $t} ;# maybe keep the rest + set res +} + +proc ::tcc4tcl::dlexport_procdefs {procdefs proclist} { + # + ### experimental insert### + # + ########################## + # + set exportcode "" + foreach {procname cname_obj} $procdefs { + # [list $tclname $rtype $adefs] + lassign $cname_obj cname rtype adefs + if {[string range $procname 0 1]!="__"} {;#rmoeve special procs + # + set adefs [lstride $adefs 2] + set adefs [join $adefs ,] + set dlcode "DLLEXPORT $rtype $cname ($adefs);\n" + puts "$procname -> obj $cname_obj cname $cname rtype $rtype adefs $adefs" + puts $dlcode + append exportcode $dlcode + } + } + return $exportcode +} + +proc ::tcc4tcl::prepare_packagecode {handle} { + # + set DLEXPORTMAKRO $::tccenv::DLEXPORTMAKRO + upvar #0 $handle state + #modify code with dlexportmakro + set oldcode $state(code) + set newcode $DLEXPORTMAKRO + append newcode $oldcode + #append newcode [::tcc4tcl::dlexport_procdefs $state(procdefs) ""] + set state(code) $newcode + +} + +proc ::tcc4tcl::write_packagecode {handle packagename {filepath ""} {packageversion 1.0} {tclversion TCL_VERSION}} { + proc relTo {targetfile currentpath } { + # Get relative path to target file from current path + # First argument is a file name, second a directory name (not checked) + set result "" + set cc [file split [file normalize $currentpath]] + set tt [file split [file normalize $targetfile]] + set shorthandpath [file join [file normalize [pwd]] $targetfile] + if {![file exists $shorthandpath]} { + set shorthandpath [file join [file normalize $currentpath] $targetfile] + if {[file exists $shorthandpath]} { + # seems to be a direct hit + return $targetfile + } + } + + if {![string equal [lindex $cc 0] [lindex $tt 0]]} { + # not on *n*x then + return -code error "$targetfile not on same volume as $currentpath" + } + while {[string equal [lindex $cc 0] [lindex $tt 0]] && [llength $cc] > 0} { + # discard matching components from the front + set cc [lreplace $cc 0 0] + set tt [lreplace $tt 0 0] + } + set prefix {} + if {[llength $cc] == 0} { + # just the file name, so targetfile is lower down (or in same place) + set prefix . + } + # step up the tree + for {set i 0} {$i < [llength $cc]} {incr i} { + append prefix { ..} + } + # stick it all together + set result [file join {*}$prefix {*}$tt] + return $result + + } + proc eol {} { + switch -- $::tcl_platform(platform) { + windows {return \r\n} + unix {return \n} + macintosh {return \r} + default {\n} + } + } + + upvar #0 $handle state + set oldtype "package" + if {$state(type)!="package"} { + set oldtype $state(type) + set state(package) [list $packagename $packageversion $tclversion] + set state(type) "package" + } + + set ::tccenv::compiletime [clock format [clock seconds]] +# + puts "Writing Package $packagename --> $filepath" + set mycode [$handle code] + + # beautify code + set mycode [::tcc4tcl::reformat [string map [list [eol] \n] $mycode] 4] + set $state(type) $oldtype + + set filename [file join $filepath "$packagename.c"] + set ccdirectives [::tcc4tcl::prepare_compilerdirectives $filename $handle] + set fp [open $filename w] + puts $fp "/***************** $::tccenv::compiletime Automatically Created with TCC4TCL Helper and maybe TSP **********************************/" + puts $fp "/* Compiler directives are raw estimates, please adapt to given pathstructure */\n" + foreach {compiler ccdirective} $ccdirectives { + puts $fp "/* for $compiler use */" + puts $fp "/* $ccdirective */\n" + } + puts $fp "/***************** $::tccenv::compiletime Automatically Created with TCC4TCL Helper and maybe TSP **********************************/" + puts $fp $mycode + close $fp + return $ccdirectives +} + +proc ::tcc4tcl::reformat {tclcode {pad 4}} { + proc count {string char} { + set count 0 + while {[set idx [string first $char $string]]>=0} { + set backslashes 0 + set nidx $idx + while {[string equal [string index $string [incr nidx -1]] \\]} { + incr backslashes + } + if {$backslashes % 2 == 0} { + incr count + } + set string [string range $string [incr idx] end] + } + return $count + } + + set lines [split $tclcode \n] + set out "" + set continued no + set oddquotes 0 + set line [lindex $lines 0] + set indent [expr {([string length $line]-[string length [string trimleft $line \ \t]])/$pad}] + set pad [string repeat " " $pad] + + foreach orig $lines { + set newline [string trim $orig \ \t] + if {$newline eq ""} { + if {$continued} { + set line "" + set continued no + incr indent -2 + } else { + continue + } + } else { + set line $orig + } + if {[string index $line end] eq "\\"} { + if {(!$continued)&&(!([string index $line end-1] eq "\*"))} { + incr indent 2 + set continued yes + } + } elseif {$continued} { + incr indent -2 + set continued no + } + + if {(0)&&(![regexp {^[ \t]*\#} $line])&&(![regexp {^[ \t]*\\\*} $line]) } { + # oddquotes contains : 0 when quotes are balanced + # and 1 when they are not + set oddquotes [expr {([count $line \"] + $oddquotes) % 2}] + if {! $oddquotes} { + set nbbraces [count $line \{] + incr nbbraces -[count $line \}] + set brace [string equal [string index $newline end] \{] + set unbrace [string equal [string index $newline 0] \}] + if {$nbbraces>0 || $brace} { + incr indent $nbbraces ;# [GWM] 010409 multiple open braces + } + if {$nbbraces<0 || $unbrace} { + incr indent $nbbraces ;# [GWM] 010409 multiple close braces + if {$indent<0} { + error "unbalanced braces" + } + ## was: set line [string range $line [string length $pad] end] + # 010409 remove multiple brace indentations. Including case + # where "\} else \{" needs to unindent this line but not later lines. + set np [expr {$unbrace? [string length $pad]:-$nbbraces*[string length $pad]}] + set line [string range $line $np end] + } + } else { + # unbalanced quotes, preserve original indentation + set line $orig + } + } + append out $line\n + } + return $out +} + +#----------------------------------- remove this code in future versions ----------------------- diff --git a/tests/test_tsp.tcl b/tests/test_tsp.tcl new file mode 100644 index 0000000..431c145 --- /dev/null +++ b/tests/test_tsp.tcl @@ -0,0 +1,101 @@ +package require tsp +#tsp::debug ./dbg + +#::tsp::init_package testpkg +tsp::proc fib0 {n} { + #tsp::procdef int -args int + #tsp::int fib_2 fib_1 + if {$n < 2} {return 1} + #tsp::volatile fib_2 + set fib_2 [fib [expr {$n -2}]] + set fib_1 [fib [expr {$n -1}]] + set result [expr {$fib_2 + $fib_1}] + return $result +} +tsp::proc fib {n} { + #tsp::procdef int -args int + #tsp::int fib_2 fib_1 + if {$n < 2} {return 1} + set fib_2 [fib [expr {$n -2}]] + set fib_1 [fib [expr {$n -1}]] + set result [expr {$fib_2 + $fib_1}] + return $result +} + +tsp::proc wordsplit {str} { + #tsp::procdef var -args string + #tsp::var list char + #tsp::string word + #tsp::boolean is_space + #tsp::int strlen len i + set list {} + set word {} + set strlen [string length $str] + for {set i 0} {$i < $strlen} {incr i} { + set char [string index $str $i] + set is_space [string is space $char] + if {$is_space} { + set len [string length $word] + if {$len > 0} { + lappend list $word + } + set word {} + } else { + append word $char + } + } + set len [string length $word] + if {$len > 0} { + lappend list $word + } + return $list +} + + +tsp::proc foo {} { + #tsp::procdef var + #tsp::var ll ll2 + set ll {} + set ll2 {} + puts "ok"; + set a "test" + puts "ok for $a" + set ll [list 0 8 7 1 2 3] + set ll2 [lsort $ll] + #set ll $ll2; # this will crash in execution, due to DecrRef/incrRef error... + foreach buf $ll2 { + puts $buf + } + puts "ok $ll2" + return "ok" +} +# ::tsp::printLog +#::tsp::finalize_package + +proc run_fib {} { + set i 0 + while {$i <= 30} { + puts "n=$i => [fib $i]" + incr i + } +} + +proc fib2 {n} { + if {$n < 2} {return 1} + set fib_2 [fib2 [expr {$n -2}]] + set fib_1 [fib2 [expr {$n -1}]] + set result [expr {$fib_2 + $fib_1}] + return $result +} + +proc run_fib2 {} { + set i 0 + while {$i <= 30} { + puts "n=$i => [fib2 $i]" + incr i + } +} +# + + + diff --git a/tests/tsp_fib.tcl b/tests/tsp_fib.tcl index da8d88a..72cee3a 100644 --- a/tests/tsp_fib.tcl +++ b/tests/tsp_fib.tcl @@ -1,6 +1,9 @@ package require tsp + +if {$::tcl_platform(platform) eq "java"} { hyde::configure -compiler javac +} tsp::proc tsp_fib {n} { #tsp::procdef int -args int diff --git a/tsp-clang.tcl b/tsp-clang.tcl old mode 100644 new mode 100755 index da489a0..9f1af37 --- a/tsp-clang.tcl +++ b/tsp-clang.tcl @@ -1,25 +1,12 @@ ################################################################## # language specific procs - c -#package require tcc4tcl -package require critcl +package require tcc4tcl # FIXME - strings and string command impls should use Tcl_UniChar arrays, not # UTF-8 strings. -# FIXME -# for testing, set cache dir and clear cache once -# this is ordinarily in ::tsp::lang_compile -::critcl::cache ./.critcl -::critcl::clean_cache - - -# force critcl to load so we can capture the original PkgInit bodhy -catch {::critcl::cproc} -variable ::tsp::critcl_pkginit [info body ::critcl::PkgInit] - - # BUILTIN_TCL_COMMANDS # interpreter builtin commands that we can call directly # note: this is all compiled commands, since some tsp_compiled @@ -32,7 +19,7 @@ variable ::tsp::critcl_pkginit [info body ::critcl::PkgInit] # SPILL_LOAD_COMMANDS # commands that specify variables by name, requiring spill/load # each element is a list of: command subcommand-or-option start end vartype spill-load-type. -# if variable naem is not previously defined, it will be defined as the first type +# if variable name is not previously defined, it will be defined as the first type # listed in vartype. # note: this list only for commands not otherwise compiled, and also not for array # variable names, since they are always kept in the interp ("file stat"), @@ -64,7 +51,7 @@ namespace eval ::tsp { ] variable SPILL_LOAD_COMMANDS [list \ - [list binary scan 4 end var load] \ + [list binary scan 4 end var load] \ [list dict append 2 2 var spill/load] \ [list dict incr 2 2 var spill/load] \ [list dict lappend 2 2 var spill/load] \ @@ -147,6 +134,7 @@ proc ::tsp::lang_type_null {} { # declare a native boolean # proc ::tsp::lang_decl_native_boolean {varName} { + return "int $varName;\n" return "int $varName = 0;\n" } @@ -154,6 +142,7 @@ proc ::tsp::lang_decl_native_boolean {varName} { # declare a native int # proc ::tsp::lang_decl_native_int {varName} { + return "Tcl_WideInt $varName;\n" return "Tcl_WideInt $varName = 0;\n" } @@ -161,6 +150,7 @@ proc ::tsp::lang_decl_native_int {varName} { # declare a native double # proc ::tsp::lang_decl_native_double {varName} { + return "double $varName;\n" return "double $varName = 0;\n" } @@ -276,7 +266,8 @@ proc ::tsp::lang_convert_int_string {targetVarName sourceVarName errMsg} { append result "if ((*rc = TSP_Util_lang_convert_int_string(interp, $sourceVarName, &$targetVarName)) != TCL_OK) \{\n" } #FIXME: see Tcl_GetInt() but convert use Tcl_GetWideIntFromObj instead. - append result " Tcl_AppendResult(interp, [::tsp::lang_quote_string $errMsg], Tcl_GetString($sourceVarName), (char *) NULL);\n" +# append result " Tcl_AppendResult(interp, [::tsp::lang_quote_string $errMsg], Tcl_GetString($sourceVarName), (char *) NULL);\n" + append result " Tcl_AppendResult(interp, [::tsp::lang_quote_string $errMsg], $sourceVarName, (char *) NULL);\n" append result " ERROR_EXIT;\n" append result "\}\n" return $result @@ -353,7 +344,7 @@ proc ::tsp::lang_convert_double_var {targetVarName sourceVarName errMsg} { proc ::tsp::lang_convert_string_boolean {targetVarName sourceVarName {errMsg ""}} { append result "/* ::tsp::lang_convert_string_boolean */\n" append result "Tcl_DStringSetLength($targetVarName,0);\n" - append result "Tcl_DStringAppend($targetVarName, ($sourceVarName ? : \"1\" : \"0\"), -1);\n" + append result "Tcl_DStringAppend($targetVarName, ($sourceVarName ? \"1\" : \"0\"), -1);\n" return $result } @@ -415,7 +406,7 @@ proc ::tsp::lang_convert_var_var {targetVarName sourceVarName {errMsg ""}} { # NOTE - return value must be used immediately # proc ::tsp::lang_get_string_boolean {sourceVarName} { - return "$sourceVarName ? : \"1\" : \"0\"" + return "$sourceVarName ? \"1\" : \"0\"" } ############################################## @@ -450,6 +441,15 @@ proc ::tsp::lang_get_string_var {sourceVarName} { return "TSP_Util_lang_get_string_var($sourceVarName)" } +############################################## +# get a tcl_dstring from a char value +# NOTE - value is place into a tcl_dstring from ::tsp::get_tmpvar +# +proc ::tsp::lang_get_string_char {char strVar} { + return "TSP_UTIL_dstring_from_char(\"$char\",$strVar)" +} + + ############################################## # preserve / incrRefCount a TclObject variable @@ -525,7 +525,7 @@ proc ::tsp::lang_int_const {n} { # appends double designation for java proc ::tsp::lang_double_const {n} { if {[string is wideinteger $n] || [string is double $n]} { - append n d + #append n d } return $n } @@ -571,13 +571,14 @@ proc ::tsp::lang_assign_empty_zero {var type} { # proc ::tsp::lang_assign_var_array_idxvar {targetObj arrVar idxVar errMsg} { append result "/* ::tsp::lang_assign_var_array_idxvar */\n" - + append result "[::tsp::lang_safe_release $targetObj]" append result "$targetObj = Tcl_ObjGetVar2(interp, $arrVar, $idxVar, TCL_LEAVE_ERR_MSG);\n" append result "if ($targetObj == NULL) \{\n" append result " /* Tcl_AppendResult(interp, [::tsp::lang_quote_string $errMsg], (char *) NULL);*/\n" append result " *rc = TCL_ERROR;\n" append result " ERROR_EXIT;\n" append result "\}\n" + append result "[::tsp::lang_preserve $targetObj]" return $result } @@ -588,15 +589,14 @@ proc ::tsp::lang_assign_var_array_idxvar {targetObj arrVar idxVar errMsg} { # proc ::tsp::lang_assign_var_array_idxtext {targetObj arrVar idxTxtVar errMsg} { append result "/* ::tsp::lang_array_get_array_idxtext */\n" - + append result "[::tsp::lang_safe_release $targetObj]" append result "$targetObj = Tcl_ObjGetVar2(interp, $arrVar, $idxTxtVar, TCL_LEAVE_ERR_MSG);\n" append result "if ($targetObj == NULL) \{\n" append result " /* Tcl_AppendResult(interp, [::tsp::lang_quote_string $errMsg], (char *) NULL);*/\n" append result " *rc = TCL_ERROR;\n" append result " ERROR_EXIT;\n" append result "\}\n" - return $result - + append result "[::tsp::lang_preserve $targetObj]" return $result } @@ -675,8 +675,7 @@ proc ::tsp::lang_assign_var_var {targetVarName sourceVarName {preserve 1}} { # which is preserved and released # proc ::tsp::lang_assign_array_var {targetArrayVar targetIdxVar var} { - append result "/* ::tsp::lang_assign_array_var */\n" - + append result "/* ::tsp::lang_assign_array_var $targetArrayVar $targetIdxVar $var */\n" append result "TSP_Util_lang_assign_array_var(interp, $targetArrayVar, $targetIdxVar, $var);\n" return $result } @@ -897,6 +896,10 @@ proc ::tsp::lang_create_compilable {compUnitDict code} { # create a list of proc argument names, prepended with __ set procArgs "" foreach arg [dict get $compUnit args] { + if {[lsearch $tsp::LOCKED_WINVARS $arg]>-1} { + ::tsp::addWarning compUnit " $arg is protected, rewriting to _$arg" + set arg _$arg + } lappend procArgs __$arg } @@ -909,7 +912,6 @@ proc ::tsp::lang_create_compilable {compUnitDict code} { set nativeArgs ", $nativeArgs" } - set nativeTypedArgs "" set intfProcArgs "" set intfProcInit "" @@ -1027,7 +1029,16 @@ proc ::tsp::lang_create_compilable {compUnitDict code} { set returnInit "" set returnCleanup $missing_return } - void - + void { + set returnVar "" + set returnValueCmd "" + set returnVarDecl "" + set returnVarAssignment "" + set intfReturnSetResult "" + set returnAlloc "" + set returnInit "" + set returnCleanup " goto normal_exit;" + } default { set returnVar "" set returnValueCmd "" @@ -1043,6 +1054,10 @@ proc ::tsp::lang_create_compilable {compUnitDict code} { # create proc function vars and cleanup code (for vars and string) foreach {var} [lsort [dict keys [dict get $compUnit vars]]] { set type [::tsp::getVarType compUnit $var] + if {[lsearch $tsp::LOCKED_WINVARS $var]>-1} { + ::tsp::addWarning compUnit " $var is protected, rewriting to _$var" + set var _$var + } if {[lsearch $procArgs __$var] >= 0} { continue } @@ -1084,7 +1099,9 @@ proc ::tsp::lang_create_compilable {compUnitDict code} { append argObjvArrays "Tcl_Obj** foreachObjv_0 = NULL;\n" } - append cleanup_defs "#define CLEANUP " \ \n + + set cleanup_defs "" + append cleanup_defs "#define CLEANUP " \ \n append cleanup_defs [::tsp::indent compUnit [::tsp::lang_spill_vars compUnit [dict get $compUnit finalSpill]] 1 \n] append cleanup_defs [::tsp::indent compUnit [::tsp::lang_safe_release _tmpVar_cmdResultObj] 1 \n] append cleanup_defs [::tsp::indent compUnit $procVarsCleanup 1 \n] @@ -1092,7 +1109,7 @@ proc ::tsp::lang_create_compilable {compUnitDict code} { set arg_cleanup_defs "" if {[string length $declStringsCleanup]} { - append arg_cleanup_defs "#define CLEANUP " \ \n + append arg_cleanup_defs "#define CLEANUP " \ \n append arg_cleanup_defs [::tsp::indent compUnit $declStringsCleanup 1 \n] } else { append arg_cleanup_defs "#define CLEANUP \n" @@ -1101,8 +1118,24 @@ proc ::tsp::lang_create_compilable {compUnitDict code} { regsub "^\[ \n\]*" $cleanup_defs {} cleanup_defs regsub -all {\n *$} $cleanup_defs "\n" cleanup_defs regsub -all {\n} $cleanup_defs "\\\n" cleanup_defs - append cleanup_defs " Tcl_PopCallFrame(interp); \\\n" - append cleanup_defs " ckfree((char*) frame) \n" + + # patch for native compiled routines, that don't need pushcallframe/popcallframe + # /* Tcl_CallFrame is dangerous since it is buried deep in the tcl_internals stubs table */ + # /* could easily break in future TCL_VERSION versions */ + # /* Functional against 8.6.6 with no guarantee */ + + set popcf "" + set pushcf "/* Native proc, no external variables used, dropping PushCallframe/PopCallframe */" + + if {[dict get $compUnit isNative]==0} { + set pushcf { + frame = (Tcl_CallFrame*) ckalloc(sizeof(Tcl_CallFrame)); + Tcl_PushCallFrame(interp, frame, Tcl_GetGlobalNamespace(interp), 1); + } + set popcf " Tcl_PopCallFrame(interp); \\\n ckfree((char*) frame) \n" + } + + append cleanup_defs $popcf regsub "^\[ \n\]*" $arg_cleanup_defs {} arg_cleanup_defs regsub -all {\n *$} $arg_cleanup_defs "\n" arg_cleanup_defs @@ -1123,20 +1156,25 @@ proc ::tsp::lang_create_compilable {compUnitDict code} { set direct_tsp_decls "" set direct_tsp_init "" foreach cmdName [lsort [dict get $compUnit direct]] { - if {$cmdName eq [dict get $compUnit name]} { set proc_info [list [dict get $compUnit returns] [dict get $compUnit argTypes] {} ] } else { set proc_info [dict get $::tsp::COMPILED_PROCS $cmdName] } lassign $proc_info procType procArgTypes procRef - if {$procType ne "void"} { - set procNativeType "" + + if {$procType eq "void"} { + set procNativeType "void" } else { set procNativeType "[::tsp::lang_xlate_native_type $procType] " } + if {$::tsp::PACKAGE_NAMESPACE ne ""} { + set nscmdName "::${::tsp::PACKAGE_NAMESPACE}::$cmdName" + } else { + set nscmdName $cmdName + } append direct_tsp_decls "static ${procNativeType}(* TSP_UserDirect_${cmdName})();\n " - append direct_tsp_init "TSP_UserDirect_${cmdName} = TSP_User_getCmd(interp, \"${cmdName}\");\n" + append direct_tsp_init "TSP_UserDirect_${cmdName} = TSP_User_getCmd(interp, \"${nscmdName}\");\n" } # create decls and init code for constants @@ -1151,27 +1189,37 @@ proc ::tsp::lang_create_compilable {compUnitDict code} { } elseif {[::tsp::typeIsDouble $constTypes]} { append procConstInit "$constvar = TSP_Util_const_double((double) $const);\n" } else { - append procConstInit "$constvar = TSP_Util_const_string([::tsp::lang_quote_string $const]);\n" + append procConstInit "$constvar = TSP_Util_const_string([::tsp::lang_quote_string $const]);/*from create_compilable*/\n" } } # class template +# $::tsp::HOME_DIR/native/clang/ is moved to $handle add_include_path +# include tcl.h should be present from tcc4tcl headers +if {$::tsp::PACKAGE_HEADER eq ""} { + # $::tsp::PACKAGE_HEADER gets included from tcc4tcl handle later + set ::tsp::PACKAGE_HEADER \ + { + /* don't forget to declare includedir tsp-package/native/clang/ in the right way */ + #include + #include + #include "TSP_cmd.c" + #include "TSP_func.c" + #include "TSP_util.c" + } +} - set cfileTemplate1 \ -{ - -#include - -#include "$::tsp::HOME_DIR/native/clang/TSP_cmd.c" -#include "$::tsp::HOME_DIR/native/clang/TSP_func.c" -#include "$::tsp::HOME_DIR/native/clang/TSP_util.c" +set cfileTemplate1 \ +{ +#undef CLEANUP +#undef RETURN_VALUE_CLEANUP +#undef RETURN_VALUE +#undef ERROR_EXIT #define ERROR_EXIT goto error_exit $cleanup_defs - $return_cleanup_def - $return_var_def /* @@ -1187,9 +1235,12 @@ TSP_UserDirect_${name}(Tcl_Interp* interp, int* rc $nativeTypedArgs ) { int idx2; char* str1; char* str2; - char* exprErrMsg = NULL; + char* exprErrMsg ; + Tcl_Obj* _tmpVar_cmdResultObj = NULL; - Tcl_CallFrame* frame = NULL; + + Tcl_CallFrame* frame; + $returnVarDecl [::tsp::indent compUnit $argObjvArrays 1 \n] [::tsp::indent compUnit $direct_tsp_decls 1 \n] @@ -1223,8 +1274,7 @@ TSP_UserDirect_${name}(Tcl_Interp* interp, int* rc $nativeTypedArgs ) { [::tsp::indent compUnit $procConstInit 2 \n] } - frame = (Tcl_CallFrame*) ckalloc(sizeof(Tcl_CallFrame)); - Tcl_PushCallFrame(interp, frame, Tcl_GetGlobalNamespace(interp), 1); + $pushcf *rc = TCL_OK; @@ -1257,6 +1307,7 @@ TSP_UserDirect_${name}(Tcl_Interp* interp, int* rc $nativeTypedArgs ) { #undef RETURN_VALUE #undef ERROR_EXIT + $arg_cleanup_defs #define RETURN_VALUE_CLEANUP #define RETURN_VALUE @@ -1271,13 +1322,6 @@ $arg_cleanup_defs } # end of cfileTemplate1 - - - - # defined by critcl::ccomand - # int TSP_UserCmd_${name}(ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj *const objv\[\]) - - set cfileTemplate2 \ { @@ -1323,11 +1367,6 @@ $arg_cleanup_defs } # end of cfileTemplate2 - # critcl needs two pieces, one for ccode and another form ccommand, so return as a list - - #puts [subst $cfileTemplate1] - #puts [subst $cfileTemplate2] - return [list [subst $cfileTemplate1] [subst $cfileTemplate2]] } @@ -1346,48 +1385,33 @@ proc ::tsp::lang_compile {compUnitDict code} { set name [dict get $compUnit name] variable ::tsp::cc_output set ::tsp::cc_output "" - set results "" + set __result "" set rc [catch { - # debugging critcl - ::critcl::config lines 0 - ::critcl::config keepsrc 1 - ::critcl::cache ./.critcl - -# for testing, this is executed on startup, -# uncomment for non-dev - #::critcl::clean_cache - - # redefine internal critcl print to capture error messages - ::proc ::critcl::print {args} { - append ::tsp::cc_output [lindex $args end] + if {$::tsp::COMPILE_PACKAGE==0} { + set handle [tcc4tcl::new] + $handle add_include_path "$::tsp::HOME_DIR/native/clang/" + $handle ccode "$::tsp::PACKAGE_HEADER" + } else { + set handle $::tsp::TCC_HANDLE } - - # redefine internal critcl PkgInit to return a custom package name, becomes - # the package init - ::proc ::critcl::PkgInit {file} [list return Tsp_user_[string tolower $name]] - - # tcl 8.5 has wide ints, make that the min version - ::critcl::tcl 8.5 - - # cause compile to fail if return is not coded in execution branch - if {[regexp gcc [::critcl::targetconfig]]} { - ::critcl::cflags -Werror=return-type -O3 + $handle ccode [lindex $code 0] + set myns "" + if {$::tsp::PACKAGE_NAMESPACE ne ""} { + set myns "::[string trim $::tsp::PACKAGE_NAMESPACE :]" } + $handle ccommand "${myns}::$name" {clientData interp objc objv} [lindex $code 1] - # create the code, first is the proc (ccode), second is the tcl interface (ccommand) - ::critcl::ccode [lindex $code 0] - ::critcl::ccommand ::$name {clientData interp objc objv} [lindex $code 1] - - # cause critcl to compile the code and load the resulting .so lib - ::critcl::load - - dict set compUnit compiledReference tsp.cmd.${name}Cmd - format "done" - } result ] - set critcl_results_dict [critcl::cresults] + if {$::tsp::COMPILE_PACKAGE==0} { + set compResult [$handle go] + ::tsp::addWarning compUnit "TCC: $compResult" + dict set compUnit compiledReference tsp.cmd.${name}Cmd + } + unset handle + } __result ] + if {$__result ne ""} { + puts "Transpile Result:\n$__result" + } set errors "" -#FIXME: use exl key for new critcl version - catch {set errors [dict get [critcl::cresults] log]} set cc_errors "" foreach line [split $::tsp::cc_output \n] { if {[regexp -nocase error $line]} { @@ -1397,11 +1421,7 @@ proc ::tsp::lang_compile {compUnitDict code} { if {$rc || [string length $cc_errors] > 0} { ::tsp::addError compUnit "error compiling $name:\n$result\n$errors\n$cc_errors" } -#FIXME: remove reset for new critcl version - catch {critcl::reset} - # reset the PkgInit proc for other critcl usage - ::proc ::critcl::PkgInit {file} $::tsp::critcl_pkginit return $rc } @@ -1410,7 +1430,6 @@ proc ::tsp::lang_compile {compUnitDict code} { # define a compiledReference in the interp # proc ::tsp::lang_interp_define {compUnitDict} { - # this is handled by critcl return } @@ -1514,13 +1533,15 @@ proc ::tsp::lang_expr {compUnitDict exprAssignment} { } + ############################################## -# spill vars into interp, used for ::tsp::volatile, -# compiled commands that use varName arguments, and -# spilling final var values for upvar/global/variable. +# spill vars from interp, used for ::tsp::volatile, +# compiled commands that use varName arguments, +# and final spill for variables after upvar/global/variable # returns code # NOTE: Tcl error raised if variable is already defined as an array in the interp # + proc ::tsp::lang_spill_vars {compUnitDict varList} { upvar $compUnitDict compUnit @@ -1528,7 +1549,11 @@ proc ::tsp::lang_spill_vars {compUnitDict varList} { return "" } - set buf "/* ::tsp::::tsp::lang_spill_vars $varList */\n" + set buf "/* ::tsp::lang_spill_vars $varList */\n" + ::tsp::addWarning compUnit "Spilling Vars |$varList| into global namespace" + ::tsp::addWarning compUnit "::tsp::spill: Function not native" + dict set compUnit isNative 0 + foreach var $varList { set type [::tsp::getVarType compUnit $var] if {$type eq "undefined"} { @@ -1553,7 +1578,10 @@ proc ::tsp::lang_spill_vars {compUnitDict varList} { set pre [::tsp::var_prefix $var] set varnameConst [::tsp::get_constvar [::tsp::getConstant compUnit $var]] - + if {[lsearch $::tsp::NAMESPACE_VARS $var]>-1} { + # rewrite varname to nas + append buf "$varnameConst = TSP_Util_const_string([::tsp::lang_quote_string ::${::tsp::PACKAGE_NAMESPACE}::$var]);\n" + } append buf "/* interp.setVar $var */\n" if {$type eq "var"} { append buf "if ($pre$var == NULL) \{\n" @@ -1589,7 +1617,7 @@ proc ::tsp::lang_spill_vars {compUnitDict varList} { # NOTE: TclException throw if variable is unset or can't convert to native type # returns code # -proc ::tsp::lang_load_vars {compUnitDict varList setEmptyWhenNotExists} { +proc ::tsp::lang_load_vars {compUnitDict varList setEmptyWhenNotExists {fromNamespace ""}} { upvar $compUnitDict compUnit set buf "" @@ -1624,8 +1652,12 @@ proc ::tsp::lang_load_vars {compUnitDict varList setEmptyWhenNotExists} { set interpVar [::tsp::get_tmpvar compUnit var $var] set isvar 0 } - - set varnameConst [::tsp::get_constvar [::tsp::getConstant compUnit $var]] + + if {$fromNamespace ne ""} { + set varnameConst [::tsp::get_constvar [::tsp::getConstant compUnit "${fromNamespace}::$var"]] + } else { + set varnameConst [::tsp::get_constvar [::tsp::getConstant compUnit $var]] + } if {$setEmptyWhenNotExists} { append buf "/* ::tsp::lang_load_vars interp.getVar $var */\n" @@ -2029,6 +2061,7 @@ proc ::tsp::lang_return {compUnitDict argVar} { switch $returnType { string {append code "Tcl_DStringAppend(returnValue, Tcl_DStringValue($argVar), Tcl_DStringLength($argVar));\n"} var {append code "returnValue = $argVar;\nTcl_IncrRefCount(returnValue);\n"} + void {return "CLEANUP;\n return;\n"} default {append code "returnValue = $argVar;\n"} } append code "*rc = TCL_OK;\n" diff --git a/tsp-compile.tcl b/tsp-compile.tcl old mode 100644 new mode 100755 index 404249a..c254621 --- a/tsp-compile.tcl +++ b/tsp-compile.tcl @@ -33,7 +33,6 @@ # compileType - normal = compile if able, none = don't compile, assert = Tcl error if not compilable, trace = enable Tcl tracing # compiledReference - the Java class name or C function - proc ::tsp::init_compunit {file name procargs body} { return [dict create \ file $file \ @@ -72,11 +71,13 @@ proc ::tsp::init_compunit {file name procargs body} { # compile a proc proc ::tsp::compile_proc {file name procargs body} { - set compUnit [::tsp::init_compunit $file $name $procargs $body] - + set ::tsp::tempspillvars {} + set procValid [::tsp::validProcName $name] + if {$procValid ne ""} { + puts "procValid Error in compUnit" ::tsp::addError compUnit $procValid ::tsp::logErrorsWarnings compUnit uplevel #0 [list ::proc $name $procargs $body] @@ -85,19 +86,43 @@ proc ::tsp::compile_proc {file name procargs body} { set code "" set errInf "" - - set rc [ catch {set compileResult [::tsp::parse_body compUnit {0 end}] } errInf] + if {$rc != 0} { + catch {puts [join [dict get $compUnit errors] \n]} + error "tsp internal error parsing $name: parse_body error: $errInf" + } + set returnType [dict get $compUnit returns] + + set compUnit [::tsp::init_compunit $file $name $procargs $body] + + if {$returnType eq ""} { + # try setting it to void + set pargs "" + foreach parg $procargs { + lappend pargs var + } + set compUnit [::tsp::init_compunit $file $name $procargs $body] + set procdef_pargs "tsp::procdef void -args [join $pargs { }]" + ::tsp::addWarning compUnit "Missing procdef definition, replacing with tsp::procdef void -args $pargs" + ::tsp::parse_procDefs compUnit "tsp::procdef void -args [join $pargs { }]" + } + + # reparse + set rc [ catch {set compileResult [::tsp::parse_body compUnit {0 end}] } errInf] if {$rc != 0} { - error "tsp internal error: parse_body error: $errInf" + catch {puts [join [dict get $compUnit errors] \n]} + error "tsp internal error w parsing $name: parse_body error: $errInf" } lassign $compileResult bodyType bodyRhs code - + + set ::tsp::lastcompunit $compUnit + set errors [::tsp::getErrors compUnit] set numErrors [llength $errors] set returnType [dict get $compUnit returns] + set compileType [dict get $compUnit compileType] if {$compileType eq "none"} { @@ -120,7 +145,6 @@ proc ::tsp::compile_proc {file name procargs body} { return } - if {$numErrors > 0 } { if {$compileType eq "assert" || $compileType eq "trace"} { error "compile type: $compileType, proc $name, but resulted in errors:\n[join $errors \n]" @@ -141,7 +165,7 @@ proc ::tsp::compile_proc {file name procargs body} { } else { # parse_body ok, let's see if we can compile it set compilable [::tsp::lang_create_compilable compUnit $code] - ::tsp::logCompilable compUnit $compilable + ::tsp::logCompilable compUnit [join $compilable ""] set rc [::tsp::lang_compile compUnit $compilable] if {$rc == 0} { ::tsp::lang_interp_define compUnit @@ -157,7 +181,6 @@ proc ::tsp::compile_proc {file name procargs body} { } - ######################################################### # check if name is a legal identifier for compilation # return "" if valid, other return error condition @@ -167,7 +190,8 @@ proc ::tsp::validProcName {name} { return "invalid proc name: \"$name\" is not a valid identifier" } if {[lsearch [::tsp::getCompiledProcs] $name] >= 0} { - return "invalid proc name: \"$name\" has been previously defined and compiled" + puts "warning: proc name: \"$name\" has been previously defined and compiled" + return "" } if {[lsearch ::tsp::BUILTIN_TCL_COMMANDS $name] >= 0} { return "invalid proc name: \"$name\" is builtin Tcl command" @@ -176,7 +200,6 @@ proc ::tsp::validProcName {name} { } - ######################################################### # main tsp proc interface # @@ -186,6 +209,12 @@ proc ::tsp::proc {name argList body} { if {$scriptfile eq ""} { set scriptfile _ } + if {[string trim [namespace qualifiers $name] : ] eq $::tsp::PACKAGE_NAMESPACE} { + set name [namespace tail $name] + } + if {$::tsp::COMPILE_PACKAGE>0} { + dict set ::tsp::PACKAGE_PROCS $name [list $name $argList $body] + } ::tsp::compile_proc $scriptfile $name $argList $body return "" } diff --git a/tsp-expr.tcl b/tsp-expr.tcl old mode 100644 new mode 100755 index 7d985c0..03e8626 --- a/tsp-expr.tcl +++ b/tsp-expr.tcl @@ -86,6 +86,10 @@ namespace eval ::tsp { variable tclfunc_tan TSP_func_tan variable tclfunc_tanh TSP_func_tanh + variable tclfunc_max TSP_func_max + variable tclfunc_min TSP_func_min + + variable VALUE_TRUE 1 variable VALUE_FALSE 0 @@ -111,12 +115,12 @@ namespace eval ::tsp { variable FUNC_0ARGS [list rand ] variable FUNC_1ARG [list abs acos asin atan ceil cos cosh double exp floor int log log10 round sin sinh sqrt srand tan tanh wide ] - variable FUNC_2ARGS [list atan2 fmod hypot pow ] + variable FUNC_2ARGS [list atan2 fmod hypot pow max min] variable ALL_FUNCS [concat $FUNC_0ARGS $FUNC_1ARG $FUNC_2ARGS] variable FUNC_INT_RESULT [list int round wide ] - variable FUNC_DOUBLE_RESULT [list acos asin atan atan2 ceil cos cosh double exp floor fmod hypot log log10 pow rand sin sinh sqrt srand tan tanh ] + variable FUNC_DOUBLE_RESULT [list acos asin atan atan2 ceil cos cosh double exp floor fmod hypot log log10 pow rand sin sinh sqrt srand tan tanh max min] variable FUNC_SAME_RESULT [list abs ] # note: special handling for abs(int) vs abs(double) @@ -131,7 +135,7 @@ namespace eval ::tsp { exp $tclfunc_exp floor $tclfunc_floor fmod $tclfunc_fmod hypot $tclfunc_hypot \ log $tclfunc_log log10 $tclfunc_log10 rand $tclfunc_rand round $tclfunc_round \ sin $tclfunc_sin sinh $tclfunc_sinh sqrt $tclfunc_sqrt tan $tclfunc_tan \ - tanh $tclfunc_tanh ] + tanh $tclfunc_tanh max $tclfunc_max min $tclfunc_min ] } @@ -264,10 +268,12 @@ proc ::tsp::produce_binary_op {compUnitDict op expr tree} { # turn string comparison into function call set func $::tsp::OP_STRING_XLATE($op) if {$firstType eq "stringliteral"} { - set firstOperand \"${firstOperand}\" + set strVar [::tsp::get_tmpvar compUnit string] + set firstOperand [::tsp::lang_get_string_char $firstOperand $strVar] } if {$secondType eq "stringliteral"} { - set secondOperand \"${secondOperand}\" + set strVar [::tsp::get_tmpvar compUnit string] + set secondOperand [::tsp::lang_get_string_char $secondOperand $strVar] } return [list boolean "${func}($firstOperand, $secondOperand)"] } else { @@ -437,6 +443,7 @@ proc ::tsp::produce_func {compUnitDict op expr tree} { } elseif {[llength $tree] == 1 && [lsearch -exact $::tsp::FUNC_1ARG $op] >= 0} { lassign [::tsp::produce_subexpr compUnit $expr [lindex $tree 0]] firstType firstOperand if {[string match string* $firstType]} { + #::tsp::lang_convert_int_string {targetVarName $firstType errMsg} error "arg type cannot be string for function: $op" } if {[::tsp::typeIsBoolean $firstType]} { @@ -581,7 +588,7 @@ proc ::tsp::produce_subexpr {compUnitDict expr tree} { set type [::tsp::getVarType compUnit $thingtext] set idx [lsearch -exact $::tsp::EXPR_TYPES $type] if {$idx == -1} { - error "variable \"$thingtext\" not type of boolean, int, double, or string: \"$type\" in expression: $nodeexpr" + error "subex variable \"$thingtext\" not type of boolean, int, double, or string: \"$type\" in expression: $nodeexpr" } # NOTE that we change the variable for native compilation by prefixing with "__" set pre [::tsp::var_prefix $thingtext] diff --git a/tsp-generate-control.tcl b/tsp-generate-control.tcl old mode 100644 new mode 100755 index 77a8149..0f723ca --- a/tsp-generate-control.tcl +++ b/tsp-generate-control.tcl @@ -19,14 +19,14 @@ proc ::tsp::gen_command_for {compUnitDict tree} { set rawtext [::tsp::parse_getstring compUnit [lindex $tree 1]] if {[string range $rawtext 0 0] ne "\{"} { - ::tsp::addError compUnit "start code argument not a braced word" + ::tsp::addError compUnit "start code argument not a braced word $rawtext" return [list void "" ""] } set pretext [lindex $rawtext 0] set rawtext [::tsp::parse_getstring compUnit [lindex $tree 2]] if {[string range $rawtext 0 0] ne "\{"} { - ::tsp::addError compUnit "test expr argument not a braced expression" + ::tsp::addError compUnit "test expr argument not a braced expression $rawtext" return [list void "" ""] } set exprtext [lindex $rawtext 0] @@ -112,7 +112,7 @@ proc ::tsp::gen_command_while {compUnitDict tree} { # get expr component, make sure it is braced set rawtext [::tsp::parse_getstring compUnit [lindex $tree 1]] if {[string range $rawtext 0 0] ne "\{"} { - ::tsp::addError compUnit "expr argument not a braced expression" + ::tsp::addError compUnit "expr argument not a braced expression $rawtext" return [list void "" ""] } set exprtext [lindex $rawtext 0] @@ -353,15 +353,16 @@ proc ::tsp::gen_command_return {compUnitDict tree} { ::tsp::addError compUnit "wrong # args: proc return type declared as \"$returnType\", but \"return\" has arguments" return [list void "" ""] } - return [list void "" "\nreturn;\n"] - } - + #return [list void "" "\n/*return deffered*/;\n"] + set result "\n/***** ::tsp::gen_command_return void */\n" + append result [::tsp::lang_return compUnit "void"] \n + return [list void "" $result] + } if {[llength $tree] != 2} { ::tsp::addError compUnit "wrong # args: proc return type declared as \"$returnType\", \"return\" requires exactly one argument" return [list void "" ""] } - # generate assignment to a tmp var that will be the return type # FIXME: probably should just return the return argument when it's the same type set argVar [::tsp::get_tmpvar compUnit $returnType] diff --git a/tsp-generate-list.tcl b/tsp-generate-list.tcl old mode 100644 new mode 100755 diff --git a/tsp-generate-math.tcl b/tsp-generate-math.tcl old mode 100644 new mode 100755 index 4f50a85..491acfd --- a/tsp-generate-math.tcl +++ b/tsp-generate-math.tcl @@ -16,7 +16,6 @@ proc ::tsp::gen_command_expr {compUnitDict tree} { # just get raw text from body set rawtext [::tsp::parse_getstring compUnit [lindex $tree 1]] - if { [string range $rawtext 0 0] ne "\{"} { ::tsp::addError compUnit "expr argument not a braced expression" return [list void "" ""] diff --git a/tsp-generate-set.tcl b/tsp-generate-set.tcl old mode 100644 new mode 100755 index 80e1e2b..67adbf4 --- a/tsp-generate-set.tcl +++ b/tsp-generate-set.tcl @@ -53,11 +53,10 @@ proc ::tsp::gen_check_target_var {compUnitDict targetVarName targetType sourceTy # # NOTE that anywhere a tcl var is used, it is prefixed with "__" for native compilation, except # for "array" variables, which are only accessed in the interp. This is done anytime we -# call a lang specific proc (::tsp::lang_*], or generate lang indepedent code. +# call a lang specific proc [::tsp::lang_*], or generate lang indepedent code. # proc ::tsp::gen_command_set {compUnitDict tree} { upvar $compUnitDict compUnit - set errors 0 set body [dict get $compUnit body] @@ -68,7 +67,7 @@ proc ::tsp::gen_command_set {compUnitDict tree} { } set targetStr [parse getstring $body [lindex [lindex $tree 1] 1]] set sourceStr [parse getstring $body [lindex [lindex $tree 2] 1]] - + #puts "set $targetStr $sourceStr " # check target, should be a single text, text_array_idxtext, or text_array_idxvar set targetComponents [::tsp::parse_word compUnit [lindex $tree 1]] set firstType [lindex [lindex $targetComponents 0] 0] @@ -85,7 +84,6 @@ proc ::tsp::gen_command_set {compUnitDict tree} { ::tsp::addError compUnit "set arg 2 invalid: \"$sourceStr\"" } - if {$errors} { return [list void "" ""] } @@ -144,6 +142,7 @@ proc ::tsp::produce_set {compUnitDict tree targetComponents sourceComponents} { # variable parsed as an array, but some other type set errors 1 ::tsp::addError compUnit "set arg 1 \"$targetVarName\" previously defined as type: \"$targetType\", now referenced as array" + #puts "set arg 1 \"$targetVarName\" previously defined as type: \"$targetType\", now referenced as array" } # is index a string or variable? @@ -178,7 +177,6 @@ proc ::tsp::produce_set {compUnitDict tree targetComponents sourceComponents} { set sourceArrayIdxtext "" set sourceArrayIdxvar "" set sourceCode "" - # is source an interpolated string? if {[llength $sourceComponents] > 1} { if {$targetType eq "array"} { @@ -393,7 +391,7 @@ proc ::tsp::produce_set {compUnitDict tree targetComponents sourceComponents} { # generate assignment # mostly same as a scalar from scalar assignment set sourceVarName $sourceRhsVar - append result "\n/***** ::tsp::generate_set assign from command */\n" + append result "\n/***** ::tsp::generate_set assign from command (set $targetVarName = $sourceVarName) */\n" append code $sourceCode set targetType [::tsp::gen_check_target_var compUnit $targetVarName $targetType $sourceType] if {$targetType eq "ERROR"} { @@ -499,7 +497,7 @@ proc ::tsp::gen_assign_scalar_text {compUnitDict targetVarName targetType source double { switch $sourceType { int { - append result "$targetPre$targetVarName = (::tsp::lang_type_double) [::tsp::lang_int_const $sourceText];\n" + append result "$targetPre$targetVarName = ([::tsp::lang_type_double]) [::tsp::lang_int_const $sourceText];\n" return $result } double { @@ -550,6 +548,7 @@ proc ::tsp::gen_assign_scalar_scalar {compUnitDict targetVarName targetType sour upvar $compUnitDict compUnit + # set the target as dirty # puts "gen_assign_scalar_scalar- ::tsp::setDirty compUnit $targetVarName" ::tsp::setDirty compUnit $targetVarName @@ -639,10 +638,29 @@ proc ::tsp::gen_assign_var_string_interpolated_string {compUnitDict targetVarNam # puts "gen_assign_var_string_interpolated_string- ::tsp::setDirty compUnit $targetVarName" ::tsp::setDirty compUnit $targetVarName - set targetPre [::tsp::var_prefix $targetVarName] - - append result "\n/***** ::tsp::gen_assign_var_string_interpolated_string */\n" + set recursiveSet "" + set oldTarget $targetVarName + + foreach component $sourceComponents { + # preanalyse, if recursive set occurs + set compType [lindex $component 0] + set sourceVarName [lindex $component 1] + if {$sourceVarName==$targetVarName} { + if {$compType=="scalar"} { + append code "// DEBUG: recursive set $sourceVarName \n" + set recursiveSet [::tsp::get_tmpvar compUnit string] + set targetVarName $recursiveSet + append code [::tsp::lang_assign_empty_zero $recursiveSet string] + } else { + ::tsp::addError compUnit "recursive assignment to \"$targetVarName\"" + return ERROR + } + } + } + set targetPre [::tsp::var_prefix $targetVarName] + append result "\n/***** ::tsp::gen_assign_var_string_interpolated_string targetType $targetType */\n" + set tmp [::tsp::get_tmpvar compUnit string] set tmp2 "" set arrVar "" @@ -650,6 +668,14 @@ proc ::tsp::gen_assign_var_string_interpolated_string {compUnitDict targetVarNam set tmp2 [::tsp::get_tmpvar compUnit string] append result [::tsp::lang_assign_empty_zero $tmp2 string] } + # fix: why is this not reset? + if {$targetType eq "string"} { + if {$targetPre!=""} { + append result [::tsp::lang_assign_empty_zero $targetPre$targetVarName string] + #append result "/* DEBUG Tcl_DStringSetLength($targetPre$targetVarName,0);*/\n" + } + } + foreach component $sourceComponents { set compType [lindex $component 0] switch $compType { @@ -662,6 +688,10 @@ proc ::tsp::gen_assign_var_string_interpolated_string {compUnitDict targetVarNam scalar { # assignment from native variable or var, possible type coersion set sourceVarName [lindex $component 1] + if {$sourceVarName==$targetVarName} { + # create another tempvar + append code "// DEBUG: sourceVarName=targetVarName=$targetVarName \n" + } set sourceType [::tsp::getVarType compUnit $sourceVarName] if {$sourceType eq "undefined"} { ::tsp::addError compUnit "set command arg 2 interpolated string variable not defined: \"$sourceVarName\"" @@ -673,29 +703,137 @@ proc ::tsp::gen_assign_var_string_interpolated_string {compUnitDict targetVarNam set sourceCmdRange [lindex $component 2] lassign [::tsp::parse_nestedbody compUnit $sourceCmdRange] sourceType sourceRhsVar sourceCode - if {$sourceCode eq ""} { - ::tsp::addError compUnit "assignment from nested command: no code generated: target \"$targetVarName\" " - return [list void "" ""] + if {$sourceCode eq ""} { + ::tsp::addError compUnit "assignment from nested command: no code generated: target \"$targetVarName\" " + return [list void "" ""] + } + + if {$sourceType eq "void"} { + ::tsp::addError compUnit "void assignment from nested command: target \"$targetVarName\"" + return [list void "" ""] } - - if {$sourceType eq "void"} { - ::tsp::addError compUnit "void assignment from nested command: target \"$targetVarName\"" - return [list void "" ""] - } append code $sourceCode append code [::tsp::gen_assign_scalar_scalar compUnit $tmp string $sourceRhsVar $sourceType ] } + text_array_idxvar - array_idxvar { + append code "//Parsing Array $compType in $component of $sourceComponents\n" + puts "//Parsing Array $compType in $component of $sourceComponents\n" + #::tsp::addWarning compUnit "$compType not implemented $component $sourceComponents" + #append code "//Parsing $component in $sourceComponents\n" + set tmp_s [::tsp::get_tmpvar compUnit string] + set doreturn 0 + + # assignment from native variable or var, possible type coersion + set sourceVarName [lindex $component 2] + set sourceType [::tsp::getVarType compUnit $sourceVarName] + #append code "// assignment |$sourceVarName|$sourceType| to $tmp_s\n" + if {$sourceType eq "undefined"} { + ::tsp::addError compUnit "set command arg 2 interpolated string variable not defined: \"$sourceVarName\"" + return [list ""] + } + append code [::tsp::gen_assign_scalar_scalar compUnit $tmp_s string $sourceVarName $sourceType] + + if {($compType=="array_idxvar")} { + #::tsp::addWarning compUnit "set arg 2 interpolated string cannot contain $compType as $component in $sourceComponents, only commands, text, backslash, or scalar variables" + set tmp_a [::tsp::get_tmpvar compUnit var tmp_array] + set tmp_v [::tsp::get_tmpvar compUnit var tmp_idx] + append code [::tsp::lang_assign_var_string $tmp_v $tmp_s] + #append code "// Convert array |$tmp_a| to $tmp\n" + append code [::tsp::lang_assign_var_array_idxvar $tmp_a [::tsp::get_constvar [::tsp::getConstant compUnit [lindex $component 1]]] $tmp_v "Error loading Array Text"] + append code "//DEBUG1: lang_convert_string_var after array \n" + append code [::tsp::lang_convert_string_var $tmp $tmp_a] + } else { + set sourceText [lindex $sourceComponents 3] + if {$sourceText eq ""} { + append code "//Missing source in $sourceComponents\n" + continue + } else { + error "DEBUG here, this is an unknown testcase??? 2025-04-18" + #::tsp::addWarning compUnit "set arg 2 interpolated string should not contain $compType as $sourceText in $sourceComponents, only commands, text, backslash, or scalar variables\n" + set newsource "[lindex $sourceComponents 1](" + #append code "// Convert |$newsource| to $tmp via $tmp_s\n" + append code [::tsp::lang_assign_string_const $tmp $newsource] + append code [::tsp::lang_append_string $tmp $tmp_s] + append code [::tsp::lang_append_string $tmp "\")\""] + append code "// DEBUG Tcl_DStringAppend($tmp,\")\",-1);\n//DEBUG Appended additional braces\n" + set doreturn 1 + } + } + if {$targetType eq "string"} { + append code "// Append string 727 dropped |$tmp|\n" + #append code [::tsp::lang_append_string $targetPre$targetVarName $tmp] + } elseif {$targetType eq "var"} { + append code "// Append var 740 dropped |$tmp|\n" + #append code [::tsp::lang_assign_var_string $targetVarName $tmp] + } + #append code [::tsp::lang_assign_empty_zero $tmp string] + if {$doreturn>0} { + #append code "// exiting\n" + return $code + } + } + text_array_idxtext - array_idxtext { + append code "//Parsing Array $compType in $component of $sourceComponents\n" + set tmp_s [::tsp::get_tmpvar compUnit string] + set sourceVarName [lindex $component 1] + set sourceType [::tsp::getVarType compUnit $sourceVarName] + #append code "// assignment |$sourceVarName|$sourceType| to $tmp_s\n" + if {($sourceVarName ne "") && ($sourceType ne "array")} { + ::tsp::addError compUnit "set command argument not defined as array but as $sourceType: \"$sourceVarName\"" + return [list ""] + } + set doreturn 0 + if {($compType=="array_idxtext")} { + #::tsp::addWarning compUnit "set arg 2 interpolated string cannot contain $compType as $component in $sourceComponents, only commands, text, backslash, or scalar variables" + set tmp_a [::tsp::get_tmpvar compUnit var tmp_array] + #append code "// Convert array |$tmp_a| to $tmp\n" + append code [::tsp::lang_assign_var_array_idxvar $tmp_a [::tsp::get_constvar [::tsp::getConstant compUnit [lindex $component 1]]] [::tsp::get_constvar [::tsp::getConstant compUnit [lindex $component 2]]] "Error loading Array Text"] + append code [::tsp::lang_convert_string_var $tmp $tmp_a] + } else { + set sourceText [lindex $sourceComponents 3] + if {$sourceText eq ""} { + append code "//Missing source in $sourceComponents\n" + continue + } else { + #::tsp::addWarning compUnit "set arg 2 interpolated string should not contain $compType as $sourceText in $sourceComponents, only commands, text, backslash, or scalar variables\n" + #append code "// Convert |$sourceText| to $tmp\n" + append code [::tsp::lang_assign_string_const $tmp $sourceText] + set doreturn 1 + } + } + if {$targetType eq "string"} { + #append code "// Append string 763 |$tmp|\n" + ##???append code [::tsp::lang_append_string $targetPre$targetVarName $tmp] + ### deleted this output 23-Oct 20, since it produced continuosly double output with + ### Line 781 string case + #append code "// ok;\n" + } elseif {$targetType eq "var"} { + append code "// Append var 778 |$tmp|\n" + append code [::tsp::lang_assign_var_string $targetVarName $tmp] + } + #append code [::tsp::lang_assign_empty_zero $tmp string] + if {$doreturn>0} { + append code "// exiting\n" + return $code + } + } default { ::tsp::addError compUnit "set arg 2 interpolated string cannot contain $compType, only commands, text, backslash, or scalar variables" return "" } } if {$targetType eq "string"} { + append code "// Append string 781 |$tmp|\n" append code [::tsp::lang_append_string $targetPre$targetVarName $tmp] } elseif {$targetType eq "var"} { append code [::tsp::lang_append_string $tmp2 $tmp] } } + if {$recursiveSet!=""} { + append code "// DEBUG: had recursive set\n" + append code [::tsp::lang_convert_string_string [::tsp::var_prefix $oldTarget]$oldTarget $targetPre$targetVarName] + set targetVarName $oldTarget + } if {$targetType eq "var"} { append code [::tsp::gen_assign_scalar_scalar compUnit $targetVarName var $tmp2 string] } @@ -765,6 +903,7 @@ proc ::tsp::gen_assign_array_scalar {compUnitDict targetVarName targetArrayIdxte append code [::tsp::lang_assign_var_$sourceType $value $pre$sourceVarName] } else { # it's a native var, use a shadow var + ::tsp::setDirty compUnit $sourceVarName lassign [::tsp::getCleanShadowVar compUnit $sourceVarName] value shadowCode append code $shadowCode } diff --git a/tsp-generate-string.tcl b/tsp-generate-string.tcl old mode 100644 new mode 100755 diff --git a/tsp-generate-var.tcl b/tsp-generate-var.tcl old mode 100644 new mode 100755 index 1c10143..c22cbd2 --- a/tsp-generate-var.tcl +++ b/tsp-generate-var.tcl @@ -10,7 +10,7 @@ # proc ::tsp::gen_command_unset {compUnitDict tree} { upvar $compUnitDict compUnit - ::tsp::addError compUnit "unset command currently not supported" + ::tsp::addError compUnit "unset command currently not supported use ::unset" return [list void "" ""] } @@ -186,7 +186,6 @@ proc ::tsp::gen_command_variable {compUnitDict tree} { append code [lindex $directResult 2] set upvared [list] - # check that local variables are defined, if not define them as var # generate code to get vars from interp after the real variable command code @@ -196,6 +195,7 @@ proc ::tsp::gen_command_variable {compUnitDict tree} { ::tsp::addError compUnit "variable local \"$rawLocal\" not a text var name" return [list void "" ""] } + set type [::tsp::getVarType compUnit $localVar] if {$type eq "undefined"} { if {[::tsp::isProcArg compUnit $localVar]} { @@ -215,7 +215,7 @@ proc ::tsp::gen_command_variable {compUnitDict tree} { if {[llength $upvared] > 0} { append code "\n/**** load variable: $upvared */\n" - append code [::tsp::lang_load_vars compUnit $upvared 1] + append code [::tsp::lang_load_vars compUnit $upvared 1 $::tsp::PACKAGE_NAMESPACE] } # add upvared variables to the finalSpill @@ -223,6 +223,7 @@ proc ::tsp::gen_command_variable {compUnitDict tree} { foreach var $upvared { if {[lsearch $existing $var] == -1} { dict lappend compUnit finalSpill $var + lappend ::tsp::NAMESPACE_VARS $var } } diff --git a/tsp-generate.tcl b/tsp-generate.tcl old mode 100644 new mode 100755 index 7af27d5..311fbea --- a/tsp-generate.tcl +++ b/tsp-generate.tcl @@ -70,6 +70,7 @@ proc ::tsp::addArgsPerLevel {compUnitDict level argc} { # proc ::tsp::getConstant {compUnitDict value} { upvar $compUnitDict compUnit + if {[dict exists $compUnit constVar $value]} { return [dict get $compUnit constVar $value] } else { @@ -173,7 +174,9 @@ proc ::tsp::gen_command {compUnitDict tree} { # a call to a previously tsp compiled proc, bypass interp # a call to a known tcl core command, bypass interp # a call to tcl interp - + if {($tsp::PACKAGE_NAMESPACE ne "")&&([string trim [namespace qualifiers $word] : ] eq $::tsp::PACKAGE_NAMESPACE)} { + set word [namespace tail $word] + } if {$type eq "text" && [info procs ::tsp::gen_command_$word] eq "::tsp::gen_command_$word"} { # command is compilable (set, if, while, string, lindex, etc.) return [::tsp::gen_command_$word compUnit $tree] @@ -277,6 +280,9 @@ proc ::tsp::gen_direct_tsp_compiled {compUnitDict tree} { set result "" set cmdComponent [lindex [::tsp::parse_word compUnit [lindex $tree 0]] 0] set cmdName [lindex $cmdComponent 1] + if {($tsp::PACKAGE_NAMESPACE ne "")&&([string trim [namespace qualifiers $cmdName] : ] eq $::tsp::PACKAGE_NAMESPACE)} { + set cmdName [namespace tail $cmdName] + } if {$cmdName eq [dict get $compUnit name]} { set proc_info [list [dict get $compUnit returns] [dict get $compUnit argTypes] {} ] @@ -311,7 +317,7 @@ proc ::tsp::gen_direct_tsp_compiled {compUnitDict tree} { return [list $procType $returnVar $result] } - + ######################################################### # generate a tcl invocation @@ -701,6 +707,7 @@ proc ::tsp::check_varname_args {compUnitDict tree} { } foreach node [lrange $tree $start $end] { set varname [::tsp::nodeText compUnit $node] + if {$varname ne "" && [::tsp::getVarType compUnit $varname] eq "undefined"} { ::tsp::addWarning compUnit "\"$varname\" implicitly defined as type \"$vartype\" by command \"$cmd\"" ::tsp::setVarType compUnit $varname $vartype @@ -729,6 +736,7 @@ proc ::tsp::check_varname_args {compUnitDict tree} { } foreach node [lrange $tree $start $end] { set varname [::tsp::nodeText compUnit $node] + if {$varname ne "" && [::tsp::getVarType compUnit $varname] eq "undefined"} { ::tsp::addWarning compUnit "\"$varname\" implicitly defined as type \"$vartype\" by command \"$cmd\"" ::tsp::setVarType compUnit $varname $vartype @@ -792,22 +800,33 @@ proc ::tsp::mkComment {text {len 40} {rawOnly 0}} { # get a clean shadow var for a native variable # generates code to set the shadow var if native variable is currently dirty # returns list of {var code} +# BUG FIXME This does not really work, if the shadow var gets set clean in a different code-path! +# HACK At least inserted a test if shadowVar is NULL +# to avoid crashing fron NULL Pointer Deref proc ::tsp::getCleanShadowVar {compUnitDict nativeVar} { upvar $compUnitDict compUnit set shadowVar [::tsp::get_tmpvar compUnit var $nativeVar] + set argVarComponents [list [list text $shadowVar $shadowVar]] + set sourceComponents [list [list scalar $nativeVar]] + set setTree "" if {[lsearch [::tsp::getCleanList compUnit] $nativeVar] == -1} { # var is not clean or not present, generate an assignment - set argVarComponents [list [list text $shadowVar $shadowVar]] - set sourceComponents [list [list scalar $nativeVar]] - set setTree "" set result "\n/* set shadow variable $nativeVar */" append result [lindex [::tsp::produce_set compUnit $setTree $argVarComponents $sourceComponents] 2] # mark the native variable clean - ::tsp::setDirty compUnit $nativeVar 0 +# BUG FIXME This does not really work, if the shadow var gets set clean in a different code-path! +# REMOVED, since it broke in case of multiple loops +# heapsort failed dramatically + # ::tsp::setDirty compUnit $nativeVar 0 } else { # var is clean no need to re-assign set result "/* shadow variable $nativeVar marked as clean */\n" + # prevent, that it's null + append result "if($shadowVar==NULL) {\n" + append result [lindex [::tsp::produce_set compUnit $setTree $argVarComponents $sourceComponents] 2] + append result "}\n" + } return [list $shadowVar $result] diff --git a/tsp-logging.tcl b/tsp-logging.tcl old mode 100644 new mode 100755 index 83737cf..ae0f9ba --- a/tsp-logging.tcl +++ b/tsp-logging.tcl @@ -160,8 +160,11 @@ proc ::tsp::logCompilable {compUnitDict compilable} { # optional filehandle, defaults to stderr # optional proc name pattern, defaults to * # -proc ::tsp::printLog {{fd stderr} {patt *}} { - puts $fd [::tsp::log $patt] +proc ::tsp::printLog {{fd stdout} {patt *} {breakeval 1}} { + if {$fd != "stdout"} { + puts [::tsp::log $patt] + } + puts $fd [::tsp::log $patt $breakeval] } @@ -170,8 +173,9 @@ proc ::tsp::printLog {{fd stderr} {patt *}} { # optional filehandle, defaults to stderr # optional proc name pattern, defaults to * # -proc ::tsp::log {{patt *}} { +proc ::tsp::log {{patt *} {breakeval 0}} { set result "" + set numerrors 0 set keys [lsort [dict keys $::tsp::COMPILER_LOG]] foreach key $keys { if {[string match $patt $key]} { @@ -184,9 +188,17 @@ proc ::tsp::log {{patt *}} { foreach warn [dict get $::tsp::COMPILER_LOG $key warnings] { append result " $warn" \n } + incr numerrors [llength [dict get $::tsp::COMPILER_LOG $key errors]] } } - return $result + if {$numerrors==0} { + return $result + } + if {$breakeval>0} { + return -code error "$result\n $numerrors errors in transpiling unit, execution halted\n " + } else { + return "$result\n $numerrors errors in transpiling unit\n " + } } diff --git a/tsp-packagehelper.tcl b/tsp-packagehelper.tcl new file mode 100755 index 0000000..f9298e3 --- /dev/null +++ b/tsp-packagehelper.tcl @@ -0,0 +1,930 @@ +############################################################################## +#tsp package helper commands for tccide +# +# package building process +# +# package structure +# PACKAGENAME_tsp_YYYY-MM-DD-hh-mm-ss.tcl (with tsp directives to create package) +# pkgIndex.tcl +# PACKAGENAME.puretcl.tcl (Untouched, pure TCL procs) +# PACKAGENAME.tclprocs.tcl (TCL Replacment procs) +# PACKAGENAME.c (sourcecode, final) +# PACKAGENAME.dll (binary file) +# +############################################################################## + +package require tcc4tcl +source [file join [file dirname [info script]] tcc4tcl_helper.tcl] + +namespace eval ::tsp { + # added for code package making MiR, also defined and used in tsp.tcl + variable COMPILE_PACKAGE 0 + variable PACKAGE_NAMESPACE "" + variable PACKAGE_HEADER "" + variable PACKAGE_PROCS "" + variable NAMESPACE_VARS "" + variable TCC_HANDLE + + variable TSP_VERSION "-unknown-" + + # these variables are NOT to be used elsewhere in tsp + variable PACKAGE_NAME "" + variable PACKAGE_VERSION "1.0" + variable PACKAGE_DIR "" + variable writepkg 1 ;# controls if any code is written out + variable TEST_PROC "" + #variable TSPPACKAGE_SPACE [file normalize [file dirname [info script]]] + variable TCL_VERSION "TCL_VERSION" + variable TCL_PROCS "" + # load tcls for additional sources + variable LOAD_TCLS "" + # load_dlls for dlls wich should be loaded into interp + variable LOAD_DLLS "" + # external dlls wich are dependencies and do not get loaded into interp + variable EXTERNAL_DLLS "" + variable COMPILE_DIRECTIVES "" + + # give name of save tcl source here, otherwise we use __lastsaved__.tcl + variable ACTSOURCE "" + + variable _HOOK_LEVEL 0 +} + +proc ::tsp::hook_proc {level} { + # we hook the proc construct to get information about package defined procs + variable _HOOK_LEVEL + set _HOOK_LEVEL $level + #puts "Hooking proc $level" + if {[info command ::__proc] eq ""} { + rename ::proc ::__proc + ::__proc ::proc {procName procargs procbody} { + #puts "Hook hit $procName in -[info script]- lv [info level]==$::tsp::_HOOK_LEVEL ?" + set nsprocname $procName + if {(([info script] eq "")||([info script] eq $::tsp::ACTSOURCE))&&([info level]==$::tsp::_HOOK_LEVEL)} { + #puts "lappend ::tsp::TCL_PROCS [list $procName $procargs $procbody]" + if {$::tsp::PACKAGE_NAMESPACE ne ""} { + set nsprocname ::${::tsp::PACKAGE_NAMESPACE}::$procName + puts "Namespace rewriting $procName to $nsprocname" + # check if namespace exists or create it + if {[namespace exists ::${::tsp::PACKAGE_NAMESPACE}]==0} { + namespace eval ::${::tsp::PACKAGE_NAMESPACE} {} + } + } + lappend ::tsp::TCL_PROCS [list $nsprocname $procargs $procbody] + } + if {[catch {uplevel 0 ::__proc [list $nsprocname $procargs $procbody]} err]} { + rename ::proc "" + rename ::__proc ::proc + return -code error "Error in proc $err" + } + } + } + +} + +proc ::tsp::unhook_proc {} { + # release the hooked proc construct + # if you eval external code, don't forget to handle errors in eval and call unhook_proc, just in case + if {[info command ::__proc] eq "::__proc"} { + rename ::proc "" + rename ::__proc ::proc + } +} + +proc ::tsp::init_package {packagename {packagenamespace ""} {packageversion 1.0} {tclversion TCL_VERSION}} { + if {$packagename eq ""} { + puts "Err: No package name given: use init_package packagename {packagenamespace ""} {packageversion 1.0} {tclversion TCL_VERSION}" + set ::tsp::COMPILE_PACKAGE 0 + return + } + set ::tsp::COMPILE_PACKAGE 1 + set ::tsp::PACKAGE_NAME $packagename + set ::tsp::PACKAGE_NAMESPACE [string trim $packagenamespace :]; # remove prepending/trailing :: + set ::tsp::PACKAGE_VERSION $packageversion + set ::tsp::TCL_VERSION $tclversion + + #which version of tsp did create the source? + if {$::tsp::TSP_VERSION eq "-unknown-"} { + # try taking it from application + catch {set ::tsp::TSP_VERSION $::_version} + } + # reset system in case + set ::tsp::COMPILER_LOG [dict create] + set ::tsp::COMPILED_PROCS [dict create] + set ::tsp::TRACE_PROC "" + set ::tsp::PACKAGE_PROCS "" + + catch { unset ::tsp::TCC_HANDLE} + set ::tsp::TCC_HANDLE [tcc4tcl::new] + + set ::tsp::NAMESPACE_VARS "" + set ::tsp::PACKAGE_INIT_PROC 0 + set ::tsp::TCL_PROCS "" + set ::tsp::PACKAGE_HEADER " +/* START OF PACKAGE_HEADER TSP (Version $::tsp::TSP_VERSION) */ +/* don't forget to declare includedir tsp-package/native/clang/ in the right way */ +#include +#include +#include \"TSP_cmd.c\" +#include \"TSP_func.c\" +#include \"TSP_util.c\" +/* END OF PACKAGE_HEADER */ + " + + $::tsp::TCC_HANDLE add_include_path "$::tsp::HOME_DIR/native/clang/" + $::tsp::TCC_HANDLE add_include_path $packagename + $::tsp::TCC_HANDLE add_library_path $packagename + + $::tsp::TCC_HANDLE ccode $::tsp::PACKAGE_HEADER + + set ::tsp::LOAD_TCLS "" + set ::tsp::LOAD_DLLS "" + set ::tsp::EXTERNAL_DLLS "" + + ::tsp::hook_proc [info level] +} +proc ::tsp::package_export {exportprocnames} { + # +} +proc ::tsp::finalize_package {{packagedir ""} {compiler none}} { + ::tsp::unhook_proc + + if {$::tsp::PACKAGE_NAME eq ""} { + puts "Err: No package name given: use init_package packagename" + set ::tsp::COMPILE_PACKAGE 0 + } + if {$::tsp::COMPILE_PACKAGE==0} { + puts "Err: No package building started: use init_package" + return + } + + set ::tsp::PACKAGE_DIR $packagedir + if {![file isdir $::tsp::PACKAGE_DIR]} { + file mkdir $::tsp::PACKAGE_DIR + } + + ::tsp::rewrite_procnamespace + ::tcc4tcl::prepare_packagecode $::tsp::TCC_HANDLE + + if {$compiler eq ""} { + set compiler "intern" + } + if {$compiler ni "intern memory"} { + if {[info commands "::tcc4tcl::write_packagecode"] ne "::tcc4tcl::write_packagecode"} { + set ::tsp::COMPILE_DIRECTIVES "" + puts "failed crafting compiledirectives... use package require tcc4tcc-helper" + } else { + set ::tsp::COMPILE_DIRECTIVES [::tcc4tcl::write_packagecode $::tsp::TCC_HANDLE $::tsp::PACKAGE_NAME $::tsp::PACKAGE_DIR $::tsp::PACKAGE_VERSION $::tsp::TCL_VERSION] + } + } + + # add a little help function + if {$::tsp::PACKAGE_NAMESPACE eq ""} { + set help_proc ::${::tsp::PACKAGE_NAME}_help + } else { + set help_proc ::${::tsp::PACKAGE_NAMESPACE}::help + } + # add help-index + set help_body " puts {\n" + append help_body [::tsp::getProcIndex $::tsp::PACKAGE_NAME] + append help_body "\n}\n" + set help_procdef [list $help_proc "" $help_body] + set cmd "::$help_proc {} $help_body" + ::proc ::$help_proc {} $help_body + lappend ::tsp::TCL_PROCS $help_procdef + if {$::tsp::writepkg>0} { + puts "writing pkg $::tsp::PACKAGE_NAME from -$::tsp::ACTSOURCE-" + ::tsp::write_pkgAltTcl $::tsp::PACKAGE_NAME + ::tsp::write_pkgIndex $::tsp::PACKAGE_NAME + } + # if a source file is given + # copy source to packagedir... if already in place, rename + if {($::tsp::ACTSOURCE ne "")&&[file exist $::tsp::ACTSOURCE]} { + set t [clock format [clock seconds] -format "%Y-%m-%d_%H-%M-%S"] + set srcname "${::tsp::PACKAGE_NAME}_tsp_${t}.tcl" + set srcname [file join $::tsp::PACKAGE_DIR $srcname] + set vdiff 1 + catch { + set lastsrcname [file join $::tsp::PACKAGE_DIR "${::tsp::PACKAGE_NAME}_tsp_*.tcl"] + set lastsrcname [lindex [lsort -decreasing [glob $lastsrcname]] 0] + set vdiff [version:filediff $::tsp::ACTSOURCE $lastsrcname] + } + if {$vdiff >0} { + puts "Copy src $::tsp::ACTSOURCE to $srcname" + file copy "$::tsp::ACTSOURCE" "$srcname" + } + } + + ::tsp::compile_package $::tsp::PACKAGE_NAME $compiler + + # pkginit? + if {$::tsp::PACKAGE_INIT_PROC>0} { + if {$compiler in "intern memory"} { + if {[catch {${::tsp::PACKAGE_NAME}_pkgInit} e]} { + puts "error ${::tsp::PACKAGE_NAME}_pkgInit: $e" + } + } + } + set ::tsp::COMPILE_PACKAGE 0 + set ::tsp::PACKAGE_NAME "" + +} + +proc ::tsp::tclwrap {name {adefs {}} {rtype void} {cname ""}} { + # this is a trampoline for tcc4tcls tclwrap routine adding the namespace + if {[namespace exists ::${::tsp::PACKAGE_NAMESPACE}]>0} { + # prepend package_namespace to name + # first clean up the nampespace_identifeier + set vname "::${::tsp::PACKAGE_NAMESPACE}::${name}" + if {[info command $vname]==$vname} { + set name $vname + } + } + $::tsp::TCC_HANDLE tclwrap $name $adefs $rtype $cname +} +proc ::tsp::tclwrap_eval {name {adefs {}} {rtype void} {cname ""}} { + # this is a trampoline for tcc4tcls tclwrap routine adding the namespace + if {[namespace exists ::${::tsp::PACKAGE_NAMESPACE}]>0} { + # prepend package_namespace to name + set vname "::${::tsp::PACKAGE_NAMESPACE}::${name}" + if {[info command $vname]==$vname} { + set name $vname + } + } + $::tsp::TCC_HANDLE tclwrap_eval $name $adefs $rtype $cname +} + + +proc ::tsp::addExternalCompiler {compiler ccOptions exeDir exeFile {compilertype gccwin32}} { + # add external compiler to list EXTERNAL_COMPILERS + # $compiler: compilername cc + # $ccOptions additional options to use with cc + # $exeDir directory to execute cc in + # $exeFile cc to execute + # compilertype can be gccwin32/gcclin64/tccwin32/tcclin64/user and defines prebuilt ccOptions to use; set to user to have no predefined options + tcc4tcl::addExternalCompiler $compiler $ccOptions $exeDir $exeFile $compilertype +} + +proc ::tsp::safeEval {cmd} { + # eval string cmd in global namespace, catch errors and eventually reset proc handler + if {[catch { + set r [namespace eval :: "$cmd"] + puts "Result: $r" + } err]} { + interp delete sl + ::tsp::unhook_proc + puts "Eval Error: $err" + } +} + +proc ::tsp::add_tclinclude {fname} { + # load tcls for additional sources + lappend ::tsp::LOAD_TCLS $fname +} +proc ::tsp::add_bininclude {fname} { + # load_dlls for dlls wich should be loaded into interp + lappend ::tsp::LOAD_DLLS $fname +} +proc ::tsp::add_dllinclude {fname} { + # external dlls wich are dependencies and do not get loaded into interp + lappend ::tsp::EXTERNAL_DLLS $fname +} + +proc ::tsp::test_packageX {packagename {callcmd ""} {shell "tclkit_8.6.12.exe"}} { + # ok, now things really get difficult, if the directory structure doesn't work "./tclkit_866_3.upx.exe" + # this actually only works under windows, you need a tclkit named $shell in the current working dir + set result "failed testloading package $packagename in [pwd]" + set callresult "" + set packagedir [file dir $packagename] + set packagename [file tail $packagename] + puts "Testing package $packagename in [pwd]" + if {[catch { + puts "Creating new exec" + set res_name [file normalize resrc.tcl] + set fd [open $res_name w] + fconfigure $fd -translation lf + puts $fd "#!/usr/bin/tclsh" + puts $fd "catch {console show}" + puts ">>> appending auto_path with [file normalize [file dir $::tsp::PACKAGE_DIR]]" + puts $fd "lappend auto_path ." + puts $fd "lappend auto_path [file normalize [file dir $::tsp::PACKAGE_DIR]]" + #puts "Testing for [file dir $::tsp::PACKAGE_DIR] ne $packagedir" + if {[file dir $::tsp::PACKAGE_DIR] ne $packagedir} { + puts ">>> appending auto_path with $packagedir" + puts $fd "lappend auto_path $packagedir" + } + #puts "Appending $::tsp::TSPPACKAGE_SPACE" + #puts $fd "lappend auto_path $::tsp::TSPPACKAGE_SPACE" + puts ">>> Load package... $packagename" + puts $fd "package require $packagename" + + if {$callcmd ne ""} { + puts ">>> Call $callcmd" + puts $fd $callcmd + } + } err]} { + puts "Error while preparing package $packagename\n$err" + } + close $fd + puts ">>> Go" + + # shell actually hardcoded... todo implement some clever routine to find nearest kit + # and to run under linux + if {$::tcl_platform(platform)=="unix"} { + puts "Seems to be a native linux, calling tclsh $res_name" + #exec >@stdout tclsh resrc.tcl + # solution: + set runcmd "exec tclsh \"$res_name\" 2>@stderr" + #" + puts "running $runcmd" + if {[catch $runcmd res]} { + error "Failed to run command $runcmd: $res" + } + + puts $res + } else { + if {[catch { + if {![file exists $shell]} { + puts "Shell not found $shell... searching" + # mark your shells as tclkit-8.6.6.exe to get found 866 8-6-6 all will do + # this will search for 8.6.6 shell + # or at least any 8.6 shell + set flist [glob -nocomplain tclkit*.exe] + if {[llength $flist]==0} { + puts "Shell not found in ./ ... searching $::tccenv::tclexedir" + set flist [glob -nocomplain [file join $::tccenv::tclexedir tclkit*.exe]] + puts $flist + } + set cand "" + foreach kit $flist { + set vnum [join [regexp -all -inline "\[0-9\]" [file tail $kit]]] + set vstring2 [join [lrange $vnum 0 1] "."] + set vstring3 [join [lrange $vnum 0 2] "."] + if {$vstring2 eq "8.6"} { + lappend cand $kit $vstring3 + } + if {$vstring3 eq "8.6.6"} { + # found an 866, use it + set shell $kit + puts "found $shell" + break; + } + } + if {[llength $cand]==0} { + puts "Error: Shell not found" + return + } + set cand [lsort -decreasing -stride 2 $cand] + puts "Candidates $cand" + set shell [lindex $cand 0] + puts "using $shell" + + } + exec $shell $res_name & + } err]} { + puts "Error while preparing package $packagename\n$err" + } + } + return +} + +proc ::tsp::test_package {packagename {callcmd ""}} { + # ok, now things really get difficult, if the directory structure doesn't work + # careful, loading a dll into the interp leads to a lock on the dll file, so recompiling it will fail due to writelock + set result "failed testloading package $packagename" + set callresult "" + puts "Testing package $packagename" + if {[catch { + puts "Creating new interp" + set ip [interp create] + puts "appending auto_path with [file dir $::tsp::PACKAGE_DIR]" + $ip eval lappend auto_path [file dir $::tsp::PACKAGE_DIR] + puts "Loading package... $packagename" + set result [$ip eval package require $packagename] + if {$callcmd ne ""} { + puts "Calling $callcmd" + catch { + set callresult [$ip eval $callcmd] + } errcall + puts "...result:" + puts $callresult + if {$errcall ne ""} { + puts $errcall + } + } + } err]} { + puts "Error while testing package $packagename\n$err" + } + puts "Got Result: $result" + puts "deleting interp" + interp delete $ip + return $result +} + +proc ::tsp::test_altpackage {packagename {callcmd ""}} { + # ok, now things really get difficult, if the directory structure doesn't work + set result "failed testloading package $packagename" + set callresult "" + puts "Testing package $packagename" + if {[catch { + puts "Creating new interp" + set ip [interp create] + puts "Loading TCL package... $packagename.tclprocs.tcl" + set result [$ip eval source [file join $::tsp::PACKAGE_DIR "${packagename}.tclprocs.tcl"]] + puts "Loading TCL package... $packagename.puretcl.tcl" + set result [$ip eval source [file join $::tsp::PACKAGE_DIR "${packagename}.puretcl.tcl"]] + if {$callcmd ne ""} { + puts "Calling $callcmd" + catch { + set callresult [$ip eval $callcmd] + } errcall + puts "...result:" + puts $callresult + if {$errcall ne ""} { + puts $errcall + } + } + } err]} { + puts "Error while testing package $packagename\n$err" + } + puts "Got Result: $result" + puts "deleting interp" + interp delete $ip + return $result +} + +############################################################################## +# internal routines +############################################################################## + +proc ::tsp::rewrite_procnamespace {} { + if {$::tsp::PACKAGE_NAMESPACE eq ""} { + #return 0 + } + set handle $::tsp::TCC_HANDLE + upvar #0 $handle state + if {![array exists state]} { return} + if {[catch { set p $state(procs)} e]} {return} + set nsprocs "" + foreach {procname cprocname} $state(procs) { + if {[lsearch $::tsp::PACKAGE_PROCS [namespace tail $procname]]<0} { + # pure c implemented... there will be no valid TCL representation + ##set procdef [list $procname "args" [list puts "Not implemented \"$procname\""]] + ##lappend ::tsp::PACKAGE_PROCS $procname $procdef + catch { + set cdef [dict get $state(procdefs) $procname] + lassign $cdef cprocname rtype cprocargs + set procargs "" + set procargsfull "" + foreach {ctype vname} $cprocargs { + lappend procargs $ctype + if {$vname!= "interp"} { + lappend procargsfull $vname + } + } + set procdef [list $procname "$procargsfull" [list puts "Not implemented \"$procname\""]] + lappend ::tsp::PACKAGE_PROCS $procname $procdef + } + #lappend ::tsp::COMPILED_PROCS $procname [list $rtype $procargs $cprocname] + } + } + if {$::tsp::PACKAGE_NAMESPACE eq ""} { + return 0 + } + foreach {procname cprocname} $state(procs) { + if {[namespace qualifier $procname] eq ""} { + set nsprocname "::${::tsp::PACKAGE_NAMESPACE}::$procname" + puts "Namespace rewriting $procname to $nsprocname" + } else { + set nsprocname $procname + } + lappend nsprocs $nsprocname $cprocname + } + set state(procs) $nsprocs +} + +proc ::tsp::getProcIndex {packagename} { + # + set helpindex "" + lappend helpindex "# Help Index:" + lappend helpindex "# Generated at [set t [clock format [clock seconds] -format "%Y-%m-%d_%H-%M-%S"]]" + lappend helpindex "# Package Index/Loader for $packagename generated by TSP//TCCIDE Version $::_version" + lappend helpindex "" + lappend helpindex "# Compiled Procs " + lappend helpindex "" + set cpr {} + catch {set cpr $::tsp::PACKAGE_PROCS} + foreach {procname procdef} $cpr { + if {[string range $procname 0 1]!="__"} { + lassign $procdef cproc cvars cbody + lappend helpindex "# ${::tsp::PACKAGE_NAMESPACE}::$cproc $cvars" + } + if {$procname eq "${packagename}_pkgInit"} { + set ::tsp::PACKAGE_INIT_PROC 1 + puts "Init via $procname" + } + } + + lappend helpindex "" + lappend helpindex "# TCL Procs " + lappend helpindex "" + set tclpr {} + catch {set tclpr $::tsp::TCL_PROCS} + foreach tcldef $tclpr { + lassign $tcldef cproc cvars cbody + lappend helpindex [string map {\n "."} "# $cproc $cvars"] + if {$cproc eq "${packagename}_pkgInit"} { + set ::tsp::PACKAGE_INIT_PROC 1 + puts "Init via $cproc" + } + } + return [join $helpindex \n] +} + +proc ::tsp::write_pkgIndex {packagename} { + # write a pkgindex.tcl file to load package + if {$::tsp::PACKAGE_DIR eq ""} { + set filename [file join $::tsp::PACKAGE_DIR "$packagename.pkgIndex.tcl"] + set loadername [file join $::tsp::PACKAGE_DIR "$packagename.${packagename}.loader.tcl"] + } else { + set filename [file join $::tsp::PACKAGE_DIR "pkgIndex.tcl"] + set loadername [file join $::tsp::PACKAGE_DIR "${packagename}.loader.tcl"] + } + + set fd [open $loadername w] + + puts $fd [::tsp::getProcIndex $packagename] + + set handle $::tsp::TCC_HANDLE + set loadextlibs "proc ${packagename}_loadextdlls {dir} {\ncatch {\n" + append loadextlibs { + switch -- $::tcl_platform(platform) { + windows {set appdir [file dir [info nameofexecutable]]} + unix { + set appdir [file dir [info script]] + if {$appdir==$dir} { + set appdir [pwd] + } + } + } + } + append loadextlibs "\n" + + set libs [$handle add_library] + set ::tsp::EXTERNAL_DLLS [lsort -unique $::tsp::EXTERNAL_DLLS] + if {$::tsp::EXTERNAL_DLLS ne ""} { + lappend libs {*}$::tsp::EXTERNAL_DLLS + } + foreach incpath $libs { + if {![file exists [file join $::tsp::PACKAGE_DIR $incpath[info sharedlibextension]]]} { + set incpath lib$incpath + } + append loadextlibs "\nset incdll \[file join \$dir $incpath\[info sharedlibextension\]\]\n" + append loadextlibs "set appdll \[file join \$appdir $incpath\[info sharedlibextension\]\]\n" + append loadextlibs "if {!\[file exists \$appdll\]} {\n" + append loadextlibs " puts \"Copy \$incdll --> \$appdll\"\n" + append loadextlibs " file copy \$incdll \$appdll\n" + append loadextlibs "}\n" + } + append loadextlibs "}\n}\n" + if {[llength $libs] ==0} { + set loadextlibs "" + } + + set pkgloadlib "proc ${packagename}_loadlib {dir packagename} {\n" + if {($loadextlibs ne "")||($::tsp::LOAD_DLLS ne "")} { + append pkgloadlib " ${packagename}_loadextdlls \$dir\n" + } + if {($loadextlibs ne "")||($::tsp::LOAD_TCLS ne "")} { + append pkgloadlib " ${packagename}_loadext \$dir\n" + } + if {$::tsp::PACKAGE_PROCS ne ""} { + append pkgloadlib " if {\[catch {load \[file join \$dir \$packagename\[info sharedlibextension\]\] \$packagename} err\]} {\n" + append pkgloadlib " source \[file join \$dir \${packagename}.tclprocs.tcl\]\n" + append pkgloadlib " }\n" + } + + if {$::tsp::TCL_PROCS ne ""} { + # load puretcl proc also + append pkgloadlib " source \[file join \$dir \${packagename}.puretcl.tcl\]\n" + if {$::tsp::PACKAGE_INIT_PROC>0} { + append pkgloadlib " # call pkgInit procedure to initialise pkg if given\n" + append pkgloadlib " return \[ catch {\${packagename}_pkgInit} e\] \n" + } + } + append pkgloadlib "}\n" + + set pkgloadext "proc ${packagename}_loadext {dir} {\n" + foreach extdll [lsort -unique $::tsp::LOAD_DLLS] { + append pkgloadext " if {\[catch {load \[file join \$dir $extdll\[info sharedlibextension\]\]} err\]} {\n" + append pkgloadext " puts \"Error loading $extdll \$err\"\n" + append pkgloadext " }\n" + } + foreach exttcl [lsort -unique $::tsp::LOAD_TCLS] { + append pkgloadext " if {\[catch {source \[file join \$dir ${exttcl}.tcl\]} err\]} {\n" + append pkgloadext " puts \"Error loading $exttcl \$err\"\n" + append pkgloadext " }\n" + } + append pkgloadext "}\n" + + set pkgrun "#run loader here\n${packagename}_loadlib \[file dir \[info script\]\] {$packagename}\n" + + puts $fd $loadextlibs + puts $fd $pkgloadlib + puts $fd $pkgloadext + puts $fd $pkgrun + close $fd + + set fd [open $filename w] + + set pkgrun "package ifneeded $packagename $::tsp::PACKAGE_VERSION \[list source \[file join \$dir [file tail $loadername]\]\]" + puts $fd $pkgrun + close $fd +} + +proc ::tsp::write_pkgAltTcl {packagename} { + # write an tcl file to keep all procs as alternate to compiled procs (can't load) + # and those procs, that we didn't compile + + # add a little help function + if {$::tsp::PACKAGE_NAMESPACE eq ""} { + set help_proc ::${packagename}_help + } else { + set help_proc ::${::tsp::PACKAGE_NAMESPACE}::help + } + + set help_body " puts {...\n" + append help_body [::tsp::getProcIndex $packagename] + append help_body "\n}\n" + set help_procdef [list $help_proc "" $help_body] + + if {[lsearch -index 0 $::tsp::TCL_PROCS $help_proc]==-1} { + lappend ::tsp::TCL_PROCS $help_procdef + } + + set filename [file join $::tsp::PACKAGE_DIR "$packagename.tclprocs.tcl"] + set fd [open $filename w] + puts $fd "# TSP Pure TCL procs for loadlib failure management" + puts $fd "# package $packagename" + puts $fd "package provide $packagename $::tsp::PACKAGE_VERSION" + if {$::tsp::PACKAGE_NAMESPACE ne ""} { + set nsvars [lsort -unique $::tsp::NAMESPACE_VARS] + puts $fd "namespace eval $::tsp::PACKAGE_NAMESPACE {" + foreach nsvar $nsvars { + puts $fd "variable $nsvar" + } + puts $fd "}" + } + foreach {procname procdef} $::tsp::PACKAGE_PROCS { + lassign $procdef procname procargs procbody + if {$procname eq "${packagename}_pkgInit"} { + set ::tsp::PACKAGE_INIT_PROC 1 + puts "Init via $procname" + } + if {$::tsp::PACKAGE_NAMESPACE ne ""} { + set procname "::${::tsp::PACKAGE_NAMESPACE}::$procname" + } + # replace #tsp::altTCL makro + set procbody [string map -nocase {"#tsp::altTCL " ""} $procbody] + puts $fd "proc $procname {$procargs} {$procbody}\n" + } + close $fd + + set filename [file join $::tsp::PACKAGE_DIR "${packagename}.puretcl.tcl"] + set fd [open $filename w] + puts $fd "# TSP Pure TCL procs for loadlib complemenary procs" + puts $fd "# package $packagename" + puts $fd "# " + if {$::tsp::COMPILED_PROCS eq ""} { + puts $fd "package provide $packagename $::tsp::PACKAGE_VERSION" + } + if {$::tsp::PACKAGE_NAMESPACE ne ""} { + set nsvars [lsort -unique $::tsp::NAMESPACE_VARS] + puts $fd "namespace eval $::tsp::PACKAGE_NAMESPACE {" + foreach nsvar $nsvars { + puts $fd "variable $nsvar" + } + puts $fd "}" + } + + foreach procdef $::tsp::TCL_PROCS { + lassign $procdef procname procargs procbody + if {$procname eq "${packagename}_pkgInit"} { + set ::tsp::PACKAGE_INIT_PROC 1 + puts "Init via $procname" + } + puts $fd "proc ${procname} {$procargs} {$procbody}\n" + } + + close $fd +} + +proc ::tsp::compile_package {packagename {compiler tccwin32}} { + # evtl compile c-source + # compile directives come from tcc4tcl_helper + # since tccide is mainly developed for windows + # it tries to find tcc.exe and gcc.exe in adjacent dirs to pwd + # so, trying to compile the code on external compiler relies on this mechanism + # so tcc and gcc options use win32 tcc.exe gcc.exe acoordingly + # lin64 tries to call gcc on a linux bash + # cross tries calling i686-w64-mingw32-gcc + # if this fails, you can still use the generated compiler directives + # as a boilerplate for manually compiling the source + # compile to memory (intern or memory) and + # compile to dynlib (export) + # with the integrated tcc4tcl should however work + + set EXTERNAL_COMPILERS $::tccenv::EXTERNAL_COMPILERS + + set ctype -1 + catch { + set ctype [dict get "none -1 intern 9 memory 9 export 9 debug 99" $compiler] + } + if {$ctype<0} { + # call plugin compiler here + set cc "" + if {[dict exists $EXTERNAL_COMPILERS $compiler]} { + set ccl [dict get $EXTERNAL_COMPILERS $compiler] + lassign $ccl cc ccOptions exeDir exeFile compilertype + } + if {$cc ne ""} { + # call compiler + } else { + # error not found + puts "ERROR: Unknown compiler $compiler or given none..." + return -1 + } + } + if {$ctype==9} { + puts "Compiling in Memory" + $::tsp::TCC_HANDLE go + return 1 + } + if {$ctype==99} { + puts "Debug Source" + puts [$::tsp::TCC_HANDLE code] + return 1 + } + + if {$::tsp::COMPILE_DIRECTIVES eq ""} { + puts "ERROR: No compiler directives found" + return -1 + } + if {$::tsp::PACKAGE_DIR eq ""} { + puts "No packagedir given, searching in $packagename/$packagename.c" + set filename [file join $::tsp::PACKAGE_DIR "$packagename.c"] + if {![file exists $filename]} { + set ::tsp::PACKAGE_DIR $packagename + } + } + + set filename [file join $::tsp::PACKAGE_DIR "$packagename.c"] + set dllname [file join $::tsp::PACKAGE_DIR "$packagename.dll"] + if {![file exists $filename]} { + puts "ERROR: $filename source not found" + return -1 + } + + set wd [pwd] + if {$::tccenv::tccexecutabledir ne ""} { + cd $::tccenv::tccexecutabledir + } + + set cdirect [dict get $::tsp::COMPILE_DIRECTIVES $compiler] + + puts "Compiling external $cdirect" + set ::errorCode "" + catch { + exec {*}$cdirect + } err + cd $wd + puts "Result:\n$err\n" + if {[llength $::errorCode]>1} { + puts "Compiling seems to have errors, execution halted" + puts "errorCode $::errorCode" + return -code error $err + } + return 1 +} + +proc version:filediff {file1 file2 {cmdEqual {version:cmdEqual}} {cmdAdd {version:cmdAdd}} {cmdDel {version:cmdDel}}} { + set sourcefid1 [open $file1 r] + set sourcefid2 [open $file2 r] + set ::afilediffs 0 + + set ::actdiff "#------------------------------------------------\n# Src: $file1\n# Trg $file2\n" + set diffminor 0;# if this is set to 0, lines will be trimmed befor comparison, empty lines will be dropped + set found 1 + set srcline 0 + set trgline 0 + while {![eof $sourcefid1] && ![eof $sourcefid2]} { + set lastmark [tell $sourcefid2] ;# Position in before reading the next line + gets $sourcefid1 line1 + gets $sourcefid2 line2 + if {$diffminor==0} { + set line1 [string trim $line1] + set line2 [string trim $line2] + } + incr srcline + incr trgline + if {$line1 eq $line2} { + $cmdEqual $line1 $srcline + continue + } + + # Lines with only whitespace are also equal + if {[regexp -- {^\s*$} $line1] && [regexp -- {^\s*$} $line2]} { + $cmdEqual {} $srcline + continue + } + + # From here both lines are unequal + + set state 0 + while {[regexp -- {^\s*$} $line1]} { + # If unequal then directly state empty lines in as deleted. + $cmdDel $line1 $srcline + if {![eof $sourcefid1]} { + gets $sourcefid1 line1 + if {$line1 eq $line2} { + $cmdEqual $line1 $srcline + set state 1 + break + } + } else { + break + } + } + if {$state} { + continue + } + + # Remember position in and look forward + set mark2 [tell $sourcefid2] + set mark2a $lastmark + set found 0 + while {![eof $sourcefid2]} { + gets $sourcefid2 line2 + if {$line1 ne $line2} { + set mark2a $mark2 + set mark2 [tell $sourcefid2] + } else { + # Found a matching line. Everything up to the line before are new lines + seek $sourcefid2 $lastmark + while {[tell $sourcefid2] <= $mark2a} { + gets $sourcefid2 line2 + $cmdAdd $line2 $srcline + } + gets $sourcefid2 line2 + $cmdEqual $line2 $srcline + set found 1 + break + } + } + if {!$found} { + # No matching line found in . Line must be deleted + $cmdDel $line1 $srcline + seek $sourcefid2 $lastmark + } + } + # Output the rest of as deleted + while {![eof $sourcefid1]} { + gets $sourcefid1 line1 + $cmdDel $line1 $srcline + } + + # Output the rest of as added + while {![eof $sourcefid2]} { + gets $sourcefid2 line2 + $cmdAdd $line2 $srcline + } + close $sourcefid2 + close $sourcefid1 + if {$::afilediffs>0} { + lappend ::lfilediffs $file1 $file2 + append ::tfilediffs $::actdiff + incr ::cfilediffs $::afilediffs + } + return $::afilediffs +} +proc version:cmdEqual {txt line} { +} +proc version:cmdAdd {txt line} { + if {[string trim $txt]!=""} { + append ::actdiff "$line: +$txt\n";update + incr ::afilediffs + } +} +proc version:cmdDel {txt line} { + if {[string trim $txt]!=""} { + append ::actdiff "$line: -$txt\n";update + incr ::afilediffs + } +} +proc version:clear {} { + set ::lfilediffs "" + set ::tfilediffs "" + set ::cfilediffs 0 +} +#----------------------------------- Code to remove ----------------------------------------- + diff --git a/tsp-parse.tcl b/tsp-parse.tcl old mode 100644 new mode 100755 index 19552d5..2c82546 --- a/tsp-parse.tcl +++ b/tsp-parse.tcl @@ -14,7 +14,6 @@ proc ::tsp::parse_body {compUnitDict range} { set cmdRhsVar "" set cmdCode "" - lassign $range firstIdx lastIdx if {$lastIdx eq "end"} { set lastIdx [string length $body] @@ -51,7 +50,6 @@ proc ::tsp::parse_body {compUnitDict range} { # added below for loading after the command is executed } - # process comments for tsp pragmas lassign $commentRange commentFirst commentLast if {$commentLast > 0} { @@ -62,6 +60,12 @@ proc ::tsp::parse_body {compUnitDict range} { set comment [parse getstring $body $commentRange] ::tsp::parse_pragma compUnit $comment + if {[dict exists $compUnit "immediateCode"]&&([set imcode [dict get $compUnit "immediateCode"]] ne "")} { + set imcode [join $imcode \n] + append gencode $imcode + dict unset compUnit "immediateCode" + } + } # process the command @@ -127,7 +131,7 @@ proc ::tsp::parse_body {compUnitDict range} { # continue parsing set range $restRange - lassign $range firstIdx lastIdx + lassign $range firstIdx lastIdx } # if any errors, return null string, else return the generated code @@ -199,6 +203,7 @@ proc ::tsp::parse_word {compUnitDict subtree {check_array 1}} { if {$type eq "simple"} { set textIdx [lindex [lindex $subtree 0] 1] set unquotedStr [parse getstring $body $textIdx] + if {$check_array} { return [::tsp::isArrayText [list [list text $wordStr $unquotedStr]] $unquotedStr] } else { @@ -210,6 +215,7 @@ proc ::tsp::parse_word {compUnitDict subtree {check_array 1}} { incr endIdx -2 set range [list $startIdx $endIdx] return [list command [::tsp::trimCommand $wordStr] $range] + } elseif {$type ne "word"} { return [list invalid "unknown node $type"] } @@ -248,7 +254,6 @@ proc ::tsp::parse_word {compUnitDict subtree {check_array 1}} { } } - ######################################################### # trim [ and ] from a command string proc ::tsp::trimCommand {str} { diff --git a/tsp-trace.tcl b/tsp-trace.tcl old mode 100644 new mode 100755 diff --git a/tsp-types.tcl b/tsp-types.tcl old mode 100644 new mode 100755 index b15e080..bcb5b74 --- a/tsp-types.tcl +++ b/tsp-types.tcl @@ -148,6 +148,11 @@ proc ::tsp::parse_pragma {compUnitDict comments} { } } + "tsp::inlinec*" { + set inlinec [string map {"tsp::inlinec " ""} $prag] + dict lappend compUnit "immediateCode" "/* $prag */" $inlinec + } + } dict incr compUnit lineNum @@ -161,7 +166,6 @@ proc ::tsp::parse_pragma {compUnitDict comments} { proc ::tsp::parse_procDefs {compUnitDict def} { upvar $compUnitDict compUnit - if {[dict get $compUnit returns] ne ""} { ::tsp::addError compUnit "::tsp::procdef: attempt to redefine proc: $def" return @@ -169,7 +173,11 @@ proc ::tsp::parse_procDefs {compUnitDict def} { set validReturnTypes $::tsp::RETURN_TYPES set validArgTypes $::tsp::VAR_TYPES - + + # patch for native proc without pushcallframe/popcallframe + dict set compUnit isNative 1 + set unsupportedTypes [list "array"] + set len [llength $def] if {$len < 2} { ::tsp::addError compUnit "::tsp::procdef: invalid proc definition, missing return type" @@ -181,9 +189,18 @@ proc ::tsp::parse_procDefs {compUnitDict def} { } set found [lsearch $validReturnTypes $type] if {$found < 0} { - ::tsp::addError compUnit "::tsp::procdef: invalid return type: $type" + ::tsp::addError compUnit "::tsp::procdef: invalid return type: $type $def" + dict set compUnit returns $type + return + } + set unsupported [lsearch $unsupportedTypes $type] + if {$unsupported>-1} { + ::tsp::addError compUnit "::tsp::procdef: invalid return type: $type $def" + dict set compUnit returns $type + dict set compUnit isNative 0 return } + dict set compUnit returns $type set argTypesList [list] set procArgs [dict get $compUnit args] @@ -229,6 +246,12 @@ proc ::tsp::parse_procDefs {compUnitDict def} { ::tsp::addError compUnit "::tsp::procdef: proc arg is not valid identifier: $arg" } set type [lindex $defArgs $i] + set unsupported [lsearch $unsupportedTypes $type] + if {$unsupported>-1} { + ::tsp::addError compUnit "::tsp::procdef: invalid argument type $type $def" + dict set compUnit isNative 0 + #return + } set found [lsearch $validArgTypes $type] if {$found < 0} { ::tsp::addError compUnit "::tsp::procdef: invalid proc definition: arg $arg type \"$type\" is invalid" @@ -240,7 +263,7 @@ proc ::tsp::parse_procDefs {compUnitDict def} { ::tsp::addError compUnit "::tsp::procdef: var already defined: arg \"$arg\" as type \"$previous\"" } } else { - ::tsp::setVarType compUnit $arg $type + ::tsp::setVarType compUnit $arg $type lappend argTypesList $type } } @@ -271,6 +294,13 @@ proc ::tsp::parse_varDefs {compUnitDict def} { ::tsp::addError compUnit "::tsp::def: invalid var type: \"$type\"" return } + set unsupported [lsearch "array" $type] + #set unsupported -1 + if {$unsupported>-1} { + #::tsp::addWarning compUnit "::tsp::procdef: not a native type $type $def" + dict set compUnit isNative 0 + #return + } set var_list [lrange $def 1 end] foreach var $var_list { @@ -298,7 +328,6 @@ proc ::tsp::parse_varDefs {compUnitDict def} { proc ::tsp::parse_volatileDefs {compUnitDict def} { upvar $compUnitDict compUnit - set vars [lrange $def 1 end] foreach var $vars { set isValid [::tsp::isValidIdent $var] @@ -364,8 +393,16 @@ proc ::tsp::isProcArg {compUnitDict var} { # proc ::tsp::isValidIdent {id} { #tsp::proc returns: bool args: string id - - return [regexp {^[a-zA-Z_][a-zA-Z0-9_]*$} $id] + set ns [string trim [namespace qualifiers $id] ":"] + set vn [namespace tail $id] + set r [regexp {^[a-zA-Z_][a-zA-Z0-9_]*$} $vn] + if {$ns eq $::tsp::PACKAGE_NAMESPACE} { + return $r + } + if {$ns eq ""} { + return $r + } + return 0 } @@ -458,7 +495,8 @@ proc ::tsp::reset_tmpvarsUsed {compUnitDict} { proc ::tsp::get_tmpvar {compUnitDict type {varName ""}} { upvar $compUnitDict compUnit - + #set callerlevel [expr [info level]-1] + #puts "tempvar $type requested from $callerlevel: [info level $callerlevel]" if {[lsearch $::tsp::VAR_TYPES $type] < 0 || $type eq "array"} { error "::tsp::get_tmpvar - invalid var type $type\n[::tsp::currentLine compUnit]\n[::tsp::error_stacktrace]" } @@ -550,6 +588,9 @@ proc ::tsp::is_prefixedvar {name} { # user variables proc ::tsp::var_prefix {name} { + if {[lsearch $tsp::LOCKED_WINVARS $name]>-1} { + return ___ + } if {[::tsp::is_tmpvar $name] || [::tsp::is_prefixedvar $name]} { return "" } else { diff --git a/tsp.tcl b/tsp.tcl old mode 100644 new mode 100755 index 8863582..5a20b28 --- a/tsp.tcl +++ b/tsp.tcl @@ -7,7 +7,25 @@ namespace eval ::tsp { variable VAR_TYPES [list boolean int double string array var] variable NATIVE_TYPES [list boolean int double string] variable RETURN_TYPES [list void boolean int double string var] - + + # added for code package making MiR see also tsp-packagehelper.tcl + variable COMPILE_PACKAGE 0 + variable PACKAGE_NAMESPACE "" + variable NAMESPACE_VARS "" + variable PACKAGE_HEADER "" + variable TCC_HANDLE + variable PACKAGE_PROCS "" + + # Locked global vars from stdlib in WIN32 and MINGW ... this is rather annoying MiR + # TSP rewrites variable/argmunetnames with __ + # this interfers with some #defines from stdlib.h at least + # if compiled code crashes for no obvious reason + # maybe we found another reserved extern defined global variable + # That's what I hate C for :-) lots of included headers and getting a pointer conversion warning at best if you redefine those (tcc won't even warn on this) + # so did a quick search for every __ prefixed symbol and locked it up... lets see how far we get + + variable LOCKED_WINVARS {argc argv targv wargv mb_cur_max mb_cur_max_dll argc_dll argv_dll imp__environ_dll imp__sys_nerr imp__sys_nerr_dll imp__sys_errlist CRT_INLINE CRT_STRINGIZE CRT_UNALIGNED CRT_WIDE DEFINE_CPP_OVERLOAD_SECURE_FUNC_0_0 DEFINE_CPP_OVERLOAD_SECURE_FUNC_0_1 DEFINE_CPP_OVERLOAD_SECURE_FUNC_0_1_ARGLIST DEFINE_CPP_OVERLOAD_SECURE_FUNC_0_2 DEFINE_CPP_OVERLOAD_SECURE_FUNC_0_2_ARGLIST DEFINE_CPP_OVERLOAD_SECURE_FUNC_0_3 DEFINE_CPP_OVERLOAD_SECURE_FUNC_0_4 DEFINE_CPP_OVERLOAD_SECURE_FUNC_1_1 DEFINE_CPP_OVERLOAD_SECURE_FUNC_1_2 DEFINE_CPP_OVERLOAD_SECURE_FUNC_1_3 DEFINE_CPP_OVERLOAD_SECURE_FUNC_2_0 DEFINE_CPP_OVERLOAD_SECURE_FUNC_SPLITPATH EMPTY_DECLSPEC ERRCODE_DEFINED_MS GNUC_VA_LIST MINGW_ATTRIB_CONST MINGW_ATTRIB_DEPRECATED MINGW_ATTRIB_MALLOC MINGW_ATTRIB_NONNULL MINGW_ATTRIB_NORETURN MINGW_ATTRIB_PURE MINGW_FPCLASS_DEFINED MINGW_H MINGW_IMPORT MINGW_NOTHROW MSVCRT__ RETURN_POLICY_DST RETURN_POLICY_SAME RETURN_POLICY_VOID TRY__ WIN32__ _mb_cur_max_func argc argv attribute__ builtin_alloca builtin_isgreater builtin_isgreaterequal builtin_isless builtin_islessequal builtin_islessgreater builtin_isunordered crt_typefix declspec dst fastcall finddata64_t fpclassifyf i386__ inline__ int16 int32 int64 int8 int8_t_defined intptr_t_defined iob_func mb_cur_max mbcur_max mingw_access mingw_snprintf mingw_vsnprintf signbitf stat64 static_assert_t stdcall swprintf_l try__ uintptr_t_defined unaligned va_copy va_end va_start vswprintf_l wargv x86_64} + # compiler log for all procs, keys are "filename,procname" errors|warnings, entries are list of: errors/warnings # most recent compilation has key of _ variable COMPILER_LOG [dict create] @@ -33,7 +51,7 @@ namespace eval ::tsp { # other ::tsp namespace variables are set in language specific files, # e.g., tsp-java.tcl, tsp-clang.tcl -} +} set ::tsp::HOME_DIR [file normalize [file dirname [info script]]] @@ -51,6 +69,8 @@ source [file join [file dirname [info script]] tsp-generate-var.tcl] source [file join [file dirname [info script]] tsp-generate-list.tcl] source [file join [file dirname [info script]] tsp-generate-string.tcl] +source [file join [file dirname [info script]] tsp-packagehelper.tcl] + # source the language specific module if {$::tcl_platform(platform) eq "java"} { source [file join [file dirname [info script]] tsp-java.tcl]