Compare commits

...
19 Commits
Author SHA1 Message Date
Miguel Sofer 8b2ef13748 updated some comments 2001-07-13 21:25:00 +00:00
Miguel Sofer 55c98da018 small changes in tclExecute.c 2001-07-13 17:03:46 +00:00
Miguel Sofer 9bd2cc3643 change from HEAD 2001-06-02 19:53:10 +00:00
Miguel Sofer 3f8b4fb44a removed Tcl_DuplicateObj from INST_DUP 2001-05-22 15:54:35 +00:00
Miguel Sofer 9ed609da84 regrouping instructions 2001-05-19 22:05:45 +00:00
Miguel Sofer c079c44510 new files 2001-05-19 16:25:55 +00:00
Miguel Sofer a23f08c532 Update to head -> S4-0-2 2001-05-19 16:11:56 +00:00
Miguel Sofer 13281fb2bd Insure that [::unknown] is always called [Patch #421166, Bug #420507] 2001-05-03 22:41:47 +00:00
Miguel Sofer ddf1a09ec0 better comments 2001-04-30 22:10:29 +00:00
Miguel Sofer f00b95258a revert stupid mistake in tclExecute.c 2001-04-30 20:55:23 +00:00
Miguel Sofer fc58d0a30b cleanup of tclExecute.h 2001-04-30 20:52:33 +00:00
Miguel Sofer 8956d1eeed Small bugfixes in the MSVC version 2001-04-27 23:04:40 +00:00
Miguel Sofer 1649a2a2db Improved comments/instructions 2001-04-11 22:51:19 +00:00
Miguel Sofer 131c2d00fe First CVS version of the new engine 2001-04-11 20:14:16 +00:00
Miguel Sofer 20461078ca First CVS version of the S4 engine (slight updates & bugfixes from
original)
2001-04-11 20:03:37 +00:00
Miguel Sofer 3465162865 minor changes to fix [set tcl_traceExec 3] possibility 2001-04-11 19:57:29 +00:00
Miguel Sofer 09008eebf1 Added compilation flag TCL_BYTECODE_OPCODES_OK for use in the new
engine in branch msofer-bcEngine
2001-04-11 12:55:25 +00:00
Miguel Sofer 8ded5cc66e Slight modifications for the new engine in branch msofer-bcEngine;
mainly, to convert the addressing mode of the tcl-stack
2001-04-11 12:31:57 +00:00
Miguel Sofer 1960287bd6 Added for the branch msofer-bcEngine; contains compiler-dependent
macros to vary the code to jump to the NEXT instruction
2001-04-11 12:09:18 +00:00
77 changed files with 15804 additions and 3997 deletions
+259 -1
View File
@@ -1,3 +1,262 @@
2001-05-16 Jeff Hobbs <jeffh@ActiveState.com>
* library/history.tcl (tcl::HistAdd): prevent empty calls from
being added to the history (arndt)
* tests/error.test: updated error-1.3 message to account for
string index being compiled at toplevel.
* tests/appendComp.test:
* tests/stringComp.test: new files for extended bytecode testing
* generic/tclBasic.c: added new CompileProc invocations to basic
command initialization.
* generic/tclCompCmds.c: added new compile commands for append,
lappend, lindex and llength. Refactored set and incr compile
commands to use new TclPushVarName function for handling the
varname component during compilation (also used by append and
lappend). Changed string compile command to compile toplevel code
as well (when possible).
* generic/tclCompile.c: added new instruction enums
* generic/tclCompile.h: added debug info for new instructions
* generic/tclExecute.c (TclExecuteByteCode): moved elemPtr to
toplevel var (oft-used). Added definitions for new bytecode
instructions INST_LIST_INDEX, INST_LIST_LENGTH, INST_APPEND_SCALAR1,
INST_APPEND_SCALAR4, INST_APPEND_ARRAY1, INST_APPEND_ARRAY4,
INST_APPEND_ARRAY_STK, INST_APPEND_STK, INST_LAPPEND_SCALAR1,
INST_LAPPEND_SCALAR4, INST_LAPPEND_ARRAY1, INST_LAPPEND_ARRAY4,
INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK.
Refactored repititious code for reuse with INST_LOAD_STK (same as
INST_LOAD_SCALAR_STK), INST_STORE_STK (same as
INST_STORE_SCALAR_STK).
Updated INST_STR_CMP with style of fix of 2001-04-06 Fellows
[Bug #219201] as that fix only affected the runtime eval'ed
"string" (string compare is normally byte-compiled now). We
may want to back these out for speed in the future, noting the
problems with \x00 comparisons in the docs.
* generic/tclInt.h: declarations for new compile commands.
* generic/tclVar.c: change TclGetIndexedScalar,
TclGetElementOfIndexedArray, TclSetElementOfIndexedArray and
TclSetIndexedScalar to use flags. The Set functions now support
TCL_APPEND_ELEMENT and TCL_LIST_ELEMENT as well.
* generic/tclInt.decls:
* generic/tclIntDecls.h: minor signature changes for above.
* generic/tclCmdMZ.c: made use of new Tcl_GetUnicodeFromObj.
2001-05-16 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/console.n: Deleted. Put it in the wrong source tree! D'oh!
2001-05-15 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tcl.decls:
* generic/tclDecls.h:
* generic/tclStubInit.c:
* generic/tclStringObj.c (Tcl_GetUnicodeFromObj): new function to
parallel Tcl_GetStringFromObj (fix of an API oversight).
* unix/tclUnixPipe.c: updated pipeChannelType to
TCL_CHANNEL_VERSION_2 type specification.
* tests/fileName.test: corrected tests not to fail on win when a
C:/test dir exists.
* generic/tclFileName.c (ExtractWinRoot): corrected ABR error
2001-05-15 Miguel Sofer <msofer@users.sourceforge.net>
* tests/lindex.test: added test for nested braces [Patch: 423617]
2001-05-15 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclInt.h
* generic/tclNamesp.c: invalidate all bytecodes in a namespace if
a new command shadows a bytecoded command.
* tests/namespace.test
Patched from [Bug: 231259]
2001-05-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/console.n: Created. It seems very odd to me that the
console implementation is part of the Tcl distribution and not
part of Tk, but given the location of the source, the
documentation must obviously match up...
2001-05-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclCmdMZ.c (Tcl_StringObjCmd):
* tests/string.test (string-4.14): Negative string indices should
not be added as offsets to the result of [string first] but
instead be treated as referring to the start of the string.
[Bug: 423581]
2001-05-11 Mo DeJong <mdejong@redhat.com>
* unix/Makefile.in: Add a LDFLAGS variable to the
Makefile instead of directly substing @LDFLAGS@.
* unix/configure: Regen.
* unix/tcl.m4: Fix CFLAGS_DEFAULT so that the name
of a Makefile variable is passed as @CFLAGS@.
* win/Makefile.in: Move the setting of CFLAGS
higher up in the Makefile.
* win/configure: Regen.
* win/configure.in: Use dnl to comment out macros
so that they are not accidently expanded.
* win/tcl.m4: Fix CFLAGS_DEFAULT so that the name
of a Makefile variable is passed as @CFLAGS@.
2001-05-07 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: insure different rand() seeds in different
threads [Bug 416643]
2001-05-03 Jeff Hobbs <jeffh@ActiveState.com>
* tests/tcltest.test: removed extraneous 'c' (doh!) [Bug: 414031]
* tools/tcltk-man2html.tcl: removed use of 'exec' for portability
and fixed up code.
2001-05-03 Don Porter <dgp@users.sourceforge.net>
* doc/library.n:
* library/init.tcl:
* tests/autoMkindex.test: Modified [auto_import] to apply
pattern matching in the [namespace import] style. [Bug 420186]
***POTENTIAL INCOMPATIBILITY*** for any callers of [auto_import]
from outside Tcl that expect the pattern matching to be like that
of [string match].
2001-05-03 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclParse.c:
* tests/namespace.test: Insure consistent behaviour of the
[unknown] command: when a command is unknown, it is always
processed by [::unknown], ignoring any namespace proc which
happens to be called "unknown" [Patch #421166, Bug #420507]
2001-05-02 Don Porter <dgp@users.sourceforge.net>
* tools/genStubs.tcl: Add a package require of Tcl 8
at the beginning of the script so that the script
will print a descriptive error message when run
in an old Tcl 7 shell.
2000-04-27 Kevin Kenny <kennykb@crd.ge.com>
* generic/tclInt.decls:
* generic/tclInt.h:
* generic/tclCmdIL.c:
* generic/tclProc.c:
* generic/tclVar.c: Added another collection of missing CONSTs
related to TclGetNamespaceForQualName.
* generic/tclIntDecls.h: Regenerated.
2000-04-25 Mo DeJong <mdejong@redhat.com>
* unix/configure: Regen.
* unix/tcl.m4: Subst TCL_THREADS into tclConfig.sh.
* unix/tclConfig.sh.in: Add TCL_THREADS variable.
* win/configure: Regen.
* win/tcl.m4: Subst TCL_THREADS into tclConfig.sh.
* win/tclConfig.sh.in: Add TCL_THREADS variable.
2000-04-25 Mo DeJong <mdejong@redhat.com>
* unix/configure: Regen.
* unix/configure.in: Use $@ in MAKE_LIB and MAKE_STUB_LIB
commands instead of using a delayed subst variable. Replace
instances of STUB_LIB_FILE with TCL_STUB_LIB_FILE.
2000-04-25 Mo DeJong <mdejong@redhat.com>
* unix/Makefile.in: Use TCL_STUB_LIB_FILE instead of STUB_LIB_FILE.
* unix/configure: Regen.
* unix/configure.in: Don't subst STUB_LIB_FILE, use TCL_STUB_LIB_FILE
instead.
2001-04-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tools/encoding/iso8859-15.txt:
* library/encoding/iso8859-15.enc: Oops! Got the full encoding
wrong. Should be fixed now...
* tools/encoding/iso8859-15.txt:
* library/encoding/iso8859-15.enc:
* tools/tcl.wse.in: Added ISO 8859-15 (a.k.a. Latin-1 + Euro
currency symbol) support.
* generic/tclNamesp.c:
* generic/tclBasic.c (TclRenameCommand): Missing CONST from
several declarations relating to use of TclGetNamespaceForQualName
2001-04-24 Kevin B. Kenny <kennykb@acm.org>
* doc/AssocData.3:
* doc/CrtCommand.3:
* doc/CrtMathFnc.3:
* doc/CrtObjCmd.3:
* doc/ExprLong.3:
* generic/tclBasic.c:
* generic/tclCmdMZ.c:
* doc/CrtSlave.3:
* generic/tclNamesp.c:
* generic/tcl.decls:
* generic/tcl.h:
* generic/tclInt.decls:
* generic/tclInt.h: (TIP #27) Another round of CONST changes, this
time adding CONST to the API's exported from tclBasic.c.
[Patch #415179]
***POTENTIAL INCOMPATIBILITY*** from 8.4a2, in which Vince
Darley's changes to command tracing were added. A const has been
added to the type signature of one of the parameters to
Tcl_CommandTraceProc.
2001-04-10 Kevin B. Kenny <kennykb@acm.org>
* unix/tclUnixTime.c: Altered code to use memcpy instead of
structure assigments in an effort to achieve better K&R
compatibility.
2001-04-10 Kevin B. Kenny <kennykb@acm.org>
* unix/tclUnixTime.c: Fixed silly typo in calls to 'gmtime' and
'localtime' that broke the Linux build.
2001-04-09 Kevin B. Kenny <kennykb@acm.org>
* unix/tclLoadShl.c: Added DYNAMIC_PATH to the load flags so that
the SHLIB_PATH will be searched for other libraries. [Bug #219140]
2001-04-09 Kevin B. Kenny <kennykb@acm.org>
* unix/tcl.m4: Added _REENTRANT to Solaris build so that thread
safe library routines are included.
* unix/configure: Re-ran 'autoconf' with changed tcl.m4
* tclUnixTime.c: Modified for thread safety of 'gmtime' and
'localtime' system calls [Bugs #219136 and #232558]
2001-04-09 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/expr.test (expr-21.*): Tests to check below fix.
* generic/tclParseExpr.c (GetLexeme): Now recognises the
non-numeric boolean literals for what they are. It no longer makes
sense for anyone to create functions with the same name as one of
them, but this was true in 7.* as well [Bug #217777; finally!]
2001-04-07 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: Avoid panic when there are extra items in
the tcl stack [Bug #406709, Patch #414470]
* tests/foreach.test: test to exercise the patch
2001-04-07 Miguel Sofer <msofer@users.sourceforge.net>
* doc/namespace.n: document correct functionality
* generic/tclNamesp.c: corrected behaviour of [namespace code]
(Bug #219385, Patch #403530)
* library/init.tcl:
* tests/namespace-old.test: test correct functionality
* tests/namespace.test: test correct functionality
2001-04-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* unix/Makefile.in (checkdoc): New target, checking the
@@ -2964,7 +3223,6 @@
Fixed "clock scan <number>" to scan the number as an hour for the
current day, rather than a minute after 00:00 for the current day
(bug #2732).
2000-01-07 Eric Melski <ericm@scriptics.com>
+57
View File
@@ -0,0 +1,57 @@
2001-07-13 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: small changes; brought the version in this
directory back in synch with the one in generic ...
2001-06-02 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: (TclExecuteByteCode): Added two casts to
INST_STR_CMP implementation to get rid of a couple warnings from
the SUNWspro C compiler. (change of 2001-05-30 in HEAD)
2001-05-22 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: removed Tcl_Duplicate_Obj from INST_DUP
2001-05-19 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: refactor/regroup some instructions
2001-05-19 Miguel Sofer <msofer@users.sourceforge.net>
* S4-0-2: added directory with differences to HEAD
* generic/tclExecute.c:
* generic/tclExecute.h: added append, lappend instructions
Many other files updated, brought up to date with HEAD
2001-05-03 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclParse.c:
* tests/namespace.test: Insure consistent behaviour of the
[unknown] command: when a command is unknown, it is always
processed by [::unknown], ignoring any namespace proc which
happens to be called "unknown" [Patch #421166, Bug #420507]
2001-04-30 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: better comments
* generic/tclExecute.h: better comments
2001-04-30 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.h: cleanup, modif of MSVC code
2001-04-27 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: small bugfix
* generic/tclExecute.h: small bugfix in MSVC code
2001-04-11 Miguel Sofer <msofer@users.sourceforge.net>
** First CVS version of the S4 engine **
* generic/tclCompile.h: Added compilation flag
TCL_BYTECODE_OPCODES_OK
* generic/tclExecute.c: First CVS version of the engine
* generic/tclExecute.h: Compiler dependent macros (new file)
* generic/tclInt.h: slight modifs, mainly for the new addressing
mode for the tcl stack
+135
View File
@@ -0,0 +1,135 @@
* INFO valid on 19-may-2001 *
*****************************************************************
THIS IS EXPERIMENTAL CODE
... but seems to perform quite well!
Purpose: speed increase in the tcl VM, with minimal impact on
functionality.
Please report bugs/suggestions to <mig@utdt.edu>
*****************************************************************
The differences to the head are described in this directory.
Note that, due to my lack of expertise, if you diff this to the HEAD
you will get *a lot more* differences: the revision numbers for plenty
of files!
The differences to the head are all in the generic directory:
* tclCompile.h: minor differences (one #define)
* tclExecute.c: major modifications
* tclExecute.h: new file
* tclInt.h: minor differences
*****************************************************************
* Restrictions: as it is now, the external behaviour is identical to
the original, with one exception: you cannot trace bytecode
execution (set tcl_traceExec is broken).
If you need the functionality, uncomment line 663 in tclExecute.c
*****************************************************************
* Description of contents, easy ones first:
** tclCompile.h
Define a flag TCL_BYTECODE_OPCODES_OK used by JUMP_version=1
** tclInt.h
Modifies the execution environment to use pointers to the stack
items instead of stack counts (absolute instead of relative
addressing). Add a couple of smallish macros.
** tclExecute.h
Compiler-dependent definition of the macros for flow control in
function TclExecuteByteCode. Currently three versions are
implemented:
- SWITCH the standard 'switch (*pc)', as in the HEAD version
- GCC (gcc only) direct jump from the end of one
instruction to the start of the next one
- MSVC (msvc only) 'switch (*pc)', but without the runtime
check that *pc is within bounds
** tclExecute.c
I will try to (remember and) describe the modifications done to
the original file
(a) Almost all changes are in the function TclExecuteByteCode. Some
others have suffered minor modifications, all related to the new
structure of the execution environment. The main example of this
are in TclCreateExecEnv and GrowEvaluationStack.
(b) removed all debugging code in TclExecuteByteCode. This allowed
the recognition and grouping of code common to several
instructions. *This still requires rethinking/rebuilding of
debugging messages*
(c) removed the possibility of tracing each bytecode (at the top
of the original execution loop). This does not seem necessary
except as debugging code; it has a very small impact on the
standard threading model, but much larger on the new (gcc only)
model included here too.
(d) abstracted the flow-control code in six small macros. These
are set in tclExecute.h
(e) reorganised the instructions to exploit common code; redefined
all auxiliary variables in blocks as small as possible. The idea
is that each instruction is actually a subroutine, and that it is
better to avoid global variables anyway. Helps some programmers
(me!) to analyse the code, may or may not help the optimiser.
(f) a few instructions where reprogrammed; the aim was mainly to
avoid testing more than once for the same condition, and to reuse
auxiliary values already calculated instead of recalculating
them. An example: when an object is shared, we now decrease its
refCount but do not test again to see if it can be freed ... we
KNOW it can't.
(g) defined a couple of macros to avoid calling very small
functions. INLINE_GET_BYTE_ARRAY/INLINE_GET_BYTE_ARRAY_LENGTH
replace calls to Tcl_GetByteArrayFromObj.
(h) avoided many POP/PUSH pairs: many instructions that POP an
object and then PUSH another now avoid decreasing/increasing the
stack top pointer (tosPtr) - just leave it where it is ...
(i) created a small stack for objects to be DecrRef'd. The
instructions that may put something in empty it before continuing;
all other instructions do not. Allows for simpler code in some
cases ('implicit ifs')
(j) inlined code from tclVar to access scalar indexed vars. The
inlined functions perform a few small chores and, in the normal
case, return a simple value: THIS was inlined; if the case is 'not
normal' (traced variables, error conditions), we fall back to the
original code. Maybe we should inline the whole function (and
remove it from tclVar.c?); it would require removing the 'static'
from a couple of functions in tclVar.c
[Find the spots searching for INLINE]
+329
View File
@@ -0,0 +1,329 @@
**
** Run on a Thinkpad TP560E (P166), 80MB
** runbench.tcl -iters 500
**
TCL_INTERP: 1:8.4a3 2:8.4a3
STARTED 2001-05-19 10:42:45
Benchmark 1:8.4a3 /CVS/tcl_SF_clean/unix/tclsh
MIDPOINT 2001-05-19 11:06:35
Benchmark 2:8.4a3 /CVS/tcl_SF_S4_new/unix/tclsh
MIDPOINT 2001-05-19 11:30:50
000 VERSIONS: 1:8.4a3 2:8.4a3
001 CATCH return ok 13 14
002 CATCH return error 165 150
003 CATCH no catch used 13 12
004 IF if true numeric 26 20
005 IF elseif true numeric 33 23
006 IF else true numeric 30 24
007 IF if true num/num 26 19
008 IF if false num/num 28 21
009 IF if false al/num 46 34
010 IF if true al/num 57 44
011 IF if false al/num 54 45
012 IF if true al/al 53 43
013 IF elseif true al/al 85 111
014 IF else true al/al 84 69
015 SWITCH first true 83 77
016 SWITCH second true 85 81
017 SWITCH ninth true 103 96
018 SWITCH default true 86 83
019 DATA create in a list 4588 2709
020 DATA create in an array 12177 8949
021 DATA access in a list 6145 4436
022 DATA access in an array 8963 7967
023 EVAL cmd eval in list obj var 44 40
024 EVAL cmd eval as list 39 38
025 EVAL cmd eval as string 104 98
026 EVAL cmd and mixed lists 7830 7895
027 EVAL list cmd and mixed lists 7866 7930
028 EVAL list cmd and pure lists 1238 1192
029 EXPR unbraced 376 347
030 EXPR braced 51 41
031 EXPR inline 58 59
032 EXPR one operand 13 12
033 EXPR ten operands 30 23
034 EXPR fifty operands 92 68
035 EXPR incr with incr 20 14
036 EXPR incr with expr 14 12
037 HEAPSORT size 10 2350 1984
038 HEAPSORT size 50 16510 13773
039 HEAPSORT size 100 37516 31309
040 KLIST shuffle0 llength 1 207 193
041 KLIST shuffle0 llength 10 577 547
042 KLIST shuffle0 llength 100 4934 4717
043 KLIST shuffle0 llength 1000 58638 59244
044 KLIST shuffle0 llength 10000 804393 742057
045 KLIST shuffle1-s llength 1 154 124
046 KLIST shuffle1-s llength 10 617 481
047 KLIST shuffle1-s llength 100 13439 7552
048 KLIST shuffle1-s llength 1000 1650896 1964249
049 KLIST shuffle1a llength 1 184 148
050 KLIST shuffle1a llength 10 768 578
051 KLIST shuffle1a llength 100 7215 5395
052 KLIST shuffle1a llength 1000 73048 55111
053 KLIST shuffle1a llength 10000 748935 556800
054 KLIST shuffle2 llength 1 176 152
055 KLIST shuffle2 llength 10 736 590
056 KLIST shuffle2 llength 100 6870 5564
057 KLIST shuffle2 llength 1000 72602 59582
058 KLIST shuffle2 llength 10000 829927 701050
059 KLIST shuffle3 llength 1 146 122
060 KLIST shuffle3 llength 10 541 426
061 KLIST shuffle3 llength 100 4905 3820
062 KLIST shuffle3 llength 1000 58468 48424
063 KLIST shuffle3 llength 10000 1888493 1816547
064 KLIST shuffle4 llength 1 153 129
065 KLIST shuffle4 llength 10 577 451
066 KLIST shuffle4 llength 100 5215 3904
067 KLIST shuffle4 llength 1000 51756 39315
068 KLIST shuffle4 llength 10000 536057 407722
069 KLIST shuffle5-s llength 1 72 55
070 KLIST shuffle5-s llength 10 403 330
071 KLIST shuffle5-s llength 100 5052 3691
072 KLIST shuffle5-s llength 1000 418503 513137
073 KLIST shuffle5a llength 1 86 69
074 KLIST shuffle5a llength 10 479 431
075 KLIST shuffle5a llength 100 4356 4006
076 KLIST shuffle5a llength 1000 53378 50004
077 KLIST shuffle5a llength 10000 1843622 1767409
078 STR/LIST length, obj shimmer 5867 5906
079 LIST length, pure list 22 21
080 STR length of a LIST 19 20
081 LIST exact search, first item 29 25
082 LIST exact search, middle item 89 88
083 LIST exact search, last item 175 171
084 LIST exact search, non-item 452 443
085 LIST sorted search, first item 34 32
086 LIST sorted search, middle item 34 32
087 LIST sorted search, last item 34 32
088 LIST sorted search, non-item 33 30
089 LIST exact search, untyped item 175 174
090 LIST exact search, typed item 161 155
091 LIST sorted search, typed item 33 31
092 LIST sort 7883 8117
093 LIST typed sort 6418 6600
094 LIST remove first element 643 690
095 LIST remove middle element 640 693
096 LIST remove last element 635 689
097 LIST replace first element 598 643
098 LIST replace middle element 595 643
099 LIST replace last element 598 643
100 LIST replace first el with multiple 659 702
101 LIST replace middle el with multiple 633 682
102 LIST replace last el with multiple 602 650
103 LIST replace range 601 649
104 LIST remove in mixed list 707 759
105 LIST replace in mixed list 650 742
106 LIST index first element 22 19
107 LIST index middle element 20 21
108 LIST index last element 22 20
109 LIST insert an item at start 648 707
110 LIST insert an item at middle 647 711
111 LIST insert an item at "end" 602 606
112 LIST small, early range 38 39
113 LIST small, late range 38 39
114 LIST large, early range 60 60
115 LIST large, late range 61 64
116 LIST append to list 1497 1498
117 LIST join list 2787 2790
118 LIST iterate list 9072 5473
119 LOOP for, iterate list 8213 4807
120 LOOP foreach, iterate list 4868 3624
121 LOOP for (to 1000) 6011 3299
122 LOOP while (to 1000) 6009 3288
123 LOOP for, iterate string 12192 8311
124 LOOP foreach, iterate string 5948 4727
125 MAP string 1 val 1716 1759
126 MAP string 2 val 4358 4393
127 MAP string 3 val 5426 5462
128 MAP string 4 val 6670 6682
129 MAP string 1 val -nocase 8680 8724
130 MAP string 2 val -nocase 15488 15578
131 MAP string 3 val -nocase 20885 20986
132 MAP string 4 val -nocase 25308 25423
133 MAP regsub 1 val 11326 11354
134 MAP regsub 2 val 50910 51169
135 MAP regsub 3 val 68324 68392
136 MAP regsub 4 val 85399 85878
137 MAP regsub 1 val -nocase 11333 11379
138 MAP regsub 2 val -nocase 50928 51228
139 MAP regsub 3 val -nocase 68223 68315
140 MAP regsub 4 val -nocase 85376 85150
141 MAP string, no match 2964 3579
142 MAP string -nocase, no match 16691 17733
143 MAP regsub, no match 3364 3491
144 MAP regsub -nocase, no match 3345 3508
145 MAP string short 77 68
146 MAP regsub short 480 490
147 MATRIX transposition-0 17473 14704
148 MATRIX transposition-1 12468 8843
149 MATRIX mult 5x5 1991 1542
150 MATRIX mult 10x10 12912 9967
151 MATRIX mult 15x15 41277 32008
152 MTHD direct ns proc call 13 12
153 MTHD imported ns proc call 14 15
154 MTHD interp alias proc call 41 43
155 MTHD indirect proc eval 55 55
156 MTHD indirect proc eval #2 109 99
157 MTHD array stored proc call 20 19
158 MTHD switch method call 87 85
159 MTHD ns lookup call 195 178
160 MTHD inline call 7 7
161 PROC explicit return 12 13
162 PROC implicit return 16 12
163 PROC explicit return (2) 12 11
164 PROC implicit return (2) 13 14
165 PROC explicit return (3) 14 11
166 PROC implicit return (3) 12 11
167 PROC heavily commented 14 11
168 PROC do-nothing, no args 11 10
169 PROC do-nothing, one arg 12 13
170 PROC local links with global 3990 3414
171 PROC local links with upvar 2851 2703
172 PROC local links with variable 2736 2593
173 READ 595K, gets 767395 724788
174 READ 595K, read 213648 211423
175 READ 595K, read & size 213510 211556
176 READ 3050b, gets 4187 3940
177 READ 3050b, read 1247 1224
178 READ 3050b, read & size 1328 1298
179 BREAD 595K, gets 778877 753880
180 BREAD 595K, read 119753 121253
181 BREAD 595K, read & size 119788 121200
182 BREAD 3050b, gets 4466 4392
183 BREAD 3050b, read 603 550
184 BREAD 3050b, read & size 690 673
185 RE literal regexp 97 99
186 RE var-based regexp 101 104
187 RE count all matches 455 454
188 RE extract all matches 536 543
189 RE 1-char short 62 67
190 RE 1-char long-start 63 62
191 RE 1-char long-middle 142 143
192 RE 1-char long-end 220 221
193 RE n-char short 65 65
194 RE n-char long-start 65 67
195 RE n-char long-middle 144 149
196 RE n-char long-end 227 227
197 RE basic 56 56
198 RE c-comment simple 153 152
199 RE c-comment nomatch 94 93
200 RE c-comment long 289 289
201 RE c-comment long pmatch 445 455
202 RE c-comment long nomatch 409 412
203 RE c-comment many *s 460 470
204 RE 1-char short catching 247 264
205 RE 1-char long-start catching 247 261
206 RE 1-char long-middle catching 333 346
207 RE 1-char long-end catching 411 426
208 RE n-char short catching 278 298
209 RE n-char long-start catching 286 305
210 RE n-char long-middle catching 364 386
211 RE n-char long-end catching 453 469
212 RE basic catching 280 288
213 RE c-comment simple catching 584 621
214 RE c-comment nomatch catching 90 100
215 RE c-comment long catching 819 859
216 RE c-comment long pmatch catching 449 462
217 RE c-comment long nomatch catching 406 411
218 RE c-comment many *s catching 1323 1402
219 STARTUP time to launch tclsh 47389 93217
220 STR string compare 46 42
221 STR string compare long 1714 1717
222 STR string compare mixed long 2944 2963
223 STR string compare uni long 5277 5329
224 STR string compare "" 35 26
225 STR string equal "" 30 22
226 STR str $a equal "" 28 19
227 STR str num == "" 31 21
228 STR str $a eq $b 40 33
229 STR str $a ne $b 41 33
230 STR str $a eq $b (same obj) 39 33
231 STR str $a ne $b (same obj) 39 32
232 STR length (==4010) 21 19
233 STR length static str 13 14
234 STR index 0 34 34
235 STR index 100 34 32
236 STR index 500 34 35
237 STR first (success) 30 30
238 STR first (failure) 367 368
239 STR first (total failure) 343 338
240 STR last (success) 29 28
241 STR last (failure) 251 250
242 STR last (total failure) 229 233
243 STR match, simple (success early) 27 26
244 STR match, simple (success late) 27 24
245 STR match, simple (failure) 27 27
246 STR match, simple (total failure) 25 26
247 STR match, complex (success early) 32 27
248 STR match, complex (success late) 381 379
249 STR match, complex (failure) 304 308
250 STR match, complex (total failure) 232 234
251 STR range, index 100..200 of 4010 41 41
252 STR replace, no replacement 152 163
253 STR replace, equal replacement 162 167
254 STR replace, longer replacement 171 176
255 STR repeat, abcdefghij * 10 28 26
256 STR repeat, abcdefghij * 100 83 80
257 STR repeat, abcdefghij * 1000 604 609
258 STR repeat, 4010 chars * 10 515 522
259 STR repeat, 4010 chars * 100 24627 24803
260 STR reverse iter/append, 10 c 184 157
261 STR reverse iter/append, 10 uc 185 158
262 STR reverse iter/set, 10 c 222 159
263 STR reverse iter/set, 10 uc 213 168
264 STR reverse recursive, 10 c 495 455
265 STR reverse recursive, 10 uc 469 440
266 STR reverse iter/append, 100 c 1186 920
267 STR reverse iter/append, 100 uc 1178 910
268 STR reverse iter/set, 100 c 1655 1230
269 STR reverse iter/set, 100 uc 1657 1236
270 STR reverse recursive, 100 c 5335 5223
271 STR reverse recursive, 100 uc 5144 5105
272 STR reverse iter/append, 400 c 4470 3456
273 STR reverse iter/append, 400 uc 4454 3407
274 STR reverse iter/set, 400 c 6722 4924
275 STR reverse iter/set, 400 uc 6750 4970
276 STR reverse recursive, 400 c 25668 24564
277 STR reverse recursive, 400 uc 27643 40254
278 STR split, 4010 chars 6366 6446
279 STR split, 12100 uchars 18520 18734
280 STR split iter, 4010 chars 25154 20244
281 STR split iter, 12100 uchars 74926 60378
282 STR append 242 263
283 STR append (1KB + 1KB) 104 106
284 STR append (10KB + 1KB) 386 247
285 STR append (1MB + 2b * 1000) 85110 82703
286 STR append (1MB + 1KB) 77400 77567
287 STR append (1MB + 1KB * 20) 78823 78932
288 STR append (1MB + 1KB * 1000) 147600 145619
289 STR append (1MB + 1MB * 3) 306243 305241
290 STR append (1MB + 1MB * 5) 383499 381346
291 STR append (1MB + (1b + 1K + 1b) * 100) 86053 85554
292 STR info locals match 2042 1747
293 TRACE no trace set 67 57
294 TRACE read 67 59
295 TRACE write 65 57
296 TRACE unset 66 59
297 TRACE all set (rwu) 66 57
298 UNSET var exists 20 18
299 UNSET catch var exists 22 19
300 UNSET catch var !exist 167 153
301 UNSET info check var exists 30 26
302 UNSET info check var !exist 22 19
303 UNSET nocomplain var exists 21 19
304 UNSET nocomplain var !exist 20 17
305 VAR access locally set 20 16
306 VAR access local proc arg 20 16
307 VAR access global 60 61
308 VAR access upvar 75 70
309 VAR set scalar 16 14
310 VAR set array element 29 25
311 VAR 100 'set's in array 362 298
312 VAR 'array set' of 100 elems 726 713
313 WORDCOUNT wc1 12944 12928
314 WORDCOUNT wc2 3489 3764
315 WORDCOUNT wc3 3216 3614
END VERSIONS: 1:8.4a3 2:8.4a3
FINISHED 2001-05-19 11:30:50
+1013
View File
File diff suppressed because it is too large Load Diff
+5350
View File
File diff suppressed because it is too large Load Diff
+224
View File
@@ -0,0 +1,224 @@
/*
* tclExecute.h --
*
* This file contains the compiler-dependent macros that determine the
* instruction-threading method used by tclExecute.c
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclExecute.h,v 1.1.2.2 2001/07/13 21:25:00 msofer Exp $
*/
/*
* An instruction-threading method has to define the following macros:
*
* . _CASE_DECLS declarations of special variables required
* . CHECK_OPCODES 0/1, if the opcodes have to be checked before RT
* . _CASE_START start of the block containing instructions
* . _CASE(instruction) the labelling method for instruction start
* . NEXT_INSTR the jump to the next instruction
* . _CASE_END end of the block containing instructions
*
*
* Currently three different methods are implemented:
*
* 1. SWITCH produces standard C code valid for any compiler;
* jumps from the end of an instruction to the switch
* statement, from there to the next instruction after
* performing a bounds check
* 2. GCC uses a gcc extension to jump directly from the end
* of an instruction to the start of the next one, using
* a jump table and the "labels as values" extension
* 3. MSVC directs msvc to omit checking the bounds of the switch
*/
#define SWITCH 0
#define GCC 1
#define MSVC 2
/*
* Choose the threading method according to the compiler being used; if
* TCL_BYTECODE_DEBUG is set, fallback to SWITCH for any compiler
*/
#ifdef __GNUC__
#define JUMP_version GCC
#elif defined( _MSC_VER ) && ( _MSC_VER >= 1200 ) && defined( _MSC_EXTENSIONS )
/* msvc with extensions */
#define JUMP_version MSVC
#else /* standard C output */
#define JUMP_version SWITCH
#endif /* choice of method */
#ifdef TCL_BYTECODE_DEBUG
# undef JUMP_version
# define JUMP_version SWITCH
# define INIT_TRACE_CHECK \
if (tclTraceExec == 3) {\
fprintf(stdout, "%2d: %2d ", iPtr->numLevels, tosPtr - eePtr->stackPtr);\
TclPrintInstruction(codePtr, pc);\
fflush(stdout);\
}
#else /* not debugging */
# define INIT_TRACE_CHECK
#endif /* debugging code */
/*
* Define the macros for the different threading methods
*/
/**** SWITCH ****/
#if JUMP_version == SWITCH
#define _CASE_DECLS
#define CHECK_OPCODES 0
# define _CASE_START \
instructions_start: \
INIT_TRACE_CHECK \
switch (*pc) {
#define _CASE(instruction) case instruction
#define NEXT_INSTR goto instructions_start
#define _CASE_END \
default: \
panic("TclExecuteByteCode: unrecognized opCode %u", *pc);\
} /* end of switch on opCode */
#endif /* SWITCH methods */
/**** MSVC ****/
#if JUMP_version == MSVC
#define _CASE_DECLS
#define CHECK_OPCODES 1
#define _CASE_START \
instructions_start: \
switch (*pc) {
#define _CASE(instruction) case instruction
#define NEXT_INSTR goto instructions_start
#define _CASE_END \
default: \
__assume(0); /* do not check bounds of switch! */ \
} /* end of switch on opCode */
#endif /* MSVC methods */
/**** GCC ****/
#if JUMP_version == GCC
#define _CASE_DECLS \
static const void *jumpTable[] = _JUMP_TABLE;
#define CHECK_OPCODES 1
#define _CASE_START NEXT_INSTR;
#define _CASE(instruction) _CASE_ ## instruction
#define NEXT_INSTR goto *jumpTable[*pc]
#define _CASE_END /* end of switch on opCode */
/* _CASE_DECLS uses the following jump table
* IT HAS TO BE IN THE CORRECT ORDER, of course */
#define _JUMP_TABLE {\
&&_CASE(INST_DONE),\
&&_CASE(INST_PUSH1),\
&&_CASE(INST_PUSH4),\
&&_CASE(INST_POP),\
&&_CASE(INST_DUP),\
&&_CASE(INST_CONCAT1),\
&&_CASE(INST_INVOKE_STK1),\
&&_CASE(INST_INVOKE_STK4),\
&&_CASE(INST_EVAL_STK),\
&&_CASE(INST_EXPR_STK),\
&&_CASE(INST_LOAD_SCALAR1),\
&&_CASE(INST_LOAD_SCALAR4),\
&&_CASE(INST_LOAD_SCALAR_STK),\
&&_CASE(INST_LOAD_ARRAY1),\
&&_CASE(INST_LOAD_ARRAY4),\
&&_CASE(INST_LOAD_ARRAY_STK),\
&&_CASE(INST_LOAD_STK),\
&&_CASE(INST_STORE_SCALAR1),\
&&_CASE(INST_STORE_SCALAR4),\
&&_CASE(INST_STORE_SCALAR_STK),\
&&_CASE(INST_STORE_ARRAY1),\
&&_CASE(INST_STORE_ARRAY4),\
&&_CASE(INST_STORE_ARRAY_STK),\
&&_CASE(INST_STORE_STK),\
&&_CASE(INST_INCR_SCALAR1),\
&&_CASE(INST_INCR_SCALAR_STK),\
&&_CASE(INST_INCR_ARRAY1),\
&&_CASE(INST_INCR_ARRAY_STK),\
&&_CASE(INST_INCR_STK),\
&&_CASE(INST_INCR_SCALAR1_IMM),\
&&_CASE(INST_INCR_SCALAR_STK_IMM),\
&&_CASE(INST_INCR_ARRAY1_IMM),\
&&_CASE(INST_INCR_ARRAY_STK_IMM),\
&&_CASE(INST_INCR_STK_IMM),\
&&_CASE(INST_JUMP1),\
&&_CASE(INST_JUMP4),\
&&_CASE(INST_JUMP_TRUE1),\
&&_CASE(INST_JUMP_TRUE4),\
&&_CASE(INST_JUMP_FALSE1),\
&&_CASE(INST_JUMP_FALSE4),\
&&_CASE(INST_LOR),\
&&_CASE(INST_LAND),\
&&_CASE(INST_BITOR),\
&&_CASE(INST_BITXOR),\
&&_CASE(INST_BITAND),\
&&_CASE(INST_EQ),\
&&_CASE(INST_NEQ),\
&&_CASE(INST_LT),\
&&_CASE(INST_GT),\
&&_CASE(INST_LE),\
&&_CASE(INST_GE),\
&&_CASE(INST_LSHIFT),\
&&_CASE(INST_RSHIFT),\
&&_CASE(INST_ADD),\
&&_CASE(INST_SUB),\
&&_CASE(INST_MULT),\
&&_CASE(INST_DIV),\
&&_CASE(INST_MOD),\
&&_CASE(INST_UPLUS),\
&&_CASE(INST_UMINUS),\
&&_CASE(INST_BITNOT),\
&&_CASE(INST_LNOT),\
&&_CASE(INST_CALL_BUILTIN_FUNC1),\
&&_CASE(INST_CALL_FUNC1),\
&&_CASE(INST_TRY_CVT_TO_NUMERIC),\
&&_CASE(INST_BREAK),\
&&_CASE(INST_CONTINUE),\
&&_CASE(INST_FOREACH_START4),\
&&_CASE(INST_FOREACH_STEP4),\
&&_CASE(INST_BEGIN_CATCH4),\
&&_CASE(INST_END_CATCH),\
&&_CASE(INST_PUSH_RESULT),\
&&_CASE(INST_PUSH_RETURN_CODE),\
&&_CASE(INST_STR_EQ),\
&&_CASE(INST_STR_NEQ),\
&&_CASE(INST_STR_CMP),\
&&_CASE(INST_STR_LEN),\
&&_CASE(INST_STR_INDEX),\
&&_CASE(INST_STR_MATCH),\
&&_CASE(INST_LIST),\
&&_CASE(INST_LIST_INDEX),\
&&_CASE(INST_LIST_LENGTH),\
&&_CASE(INST_APPEND_SCALAR1),\
&&_CASE(INST_APPEND_SCALAR4),\
&&_CASE(INST_APPEND_ARRAY1),\
&&_CASE(INST_APPEND_ARRAY4),\
&&_CASE(INST_APPEND_ARRAY_STK),\
&&_CASE(INST_APPEND_STK),\
&&_CASE(INST_LAPPEND_SCALAR1),\
&&_CASE(INST_LAPPEND_SCALAR4),\
&&_CASE(INST_LAPPEND_ARRAY1),\
&&_CASE(INST_LAPPEND_ARRAY4),\
&&_CASE(INST_LAPPEND_ARRAY_STK),\
&&_CASE(INST_LAPPEND_STK)\
}
#endif /* GCC methods */
/* End of method definitions */
#undef SWITCH
#undef GCC
#undef MSVC
#undef JUMP_version
+2325
View File
File diff suppressed because it is too large Load Diff
+1 -1
View File
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: Alloc.3,v 1.5 2001/04/06 23:14:08 andreas_kupries Exp $
'\" RCS: @(#) $Id: Alloc.3,v 1.4.2.1 2001/05/19 16:11:56 msofer Exp $
'\"
.so man.macros
.TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures"
+4 -2
View File
@@ -5,7 +5,7 @@
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\"
'\" RCS: @(#) $Id: AssocData.3,v 1.3 1999/04/16 00:46:30 stanton Exp $
'\" RCS: @(#) $Id: AssocData.3,v 1.3.16.1 2001/05/19 16:11:56 msofer Exp $
.so man.macros
.TH Tcl_SetAssocData 3 7.5 Tcl "Tcl Library Procedures"
.BS
@@ -27,7 +27,9 @@ ClientData
.AS Tcl_InterpDeleteProc *delProcPtr
.AP Tcl_Interp *interp in
Interpreter in which to execute the specified command.
.AP char *key in
.VS 8.4
.AP "CONST char" *key in
.VE
Key for association with which to store data or from which to delete or
retrieve data. Typically the module prefix for a package.
.AP Tcl_InterpDeleteProc *delProc in
+4 -2
View File
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: CrtCommand.3,v 1.3 1998/10/05 17:35:53 stanton Exp $
'\" RCS: @(#) $Id: CrtCommand.3,v 1.3.22.1 2001/05/19 16:11:56 msofer Exp $
'\"
.so man.macros
.TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures"
@@ -22,7 +22,9 @@ Tcl_Command
.AS Tcl_CmdDeleteProc **deleteProcPtr
.AP Tcl_Interp *interp in
Interpreter in which to create new command.
.AP char *cmdName in
.VS 8.4
.AP "CONST char" *cmdName in
.VE
Name of command.
.AP Tcl_CmdProc *proc in
Implementation of new command: \fIproc\fR will be called whenever
+4 -2
View File
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: CrtMathFnc.3,v 1.3 2000/04/14 23:01:49 hobbs Exp $
'\" RCS: @(#) $Id: CrtMathFnc.3,v 1.3.6.1 2001/05/19 16:11:56 msofer Exp $
'\"
.so man.macros
.TH Tcl_CreateMathFunc 3 7.0 Tcl "Tcl Library Procedures"
@@ -21,7 +21,9 @@ Tcl_CreateMathFunc \- Define a new math function for expressions
.AS Tcl_ValueType clientData
.AP Tcl_Interp *interp in
Interpreter in which new function will be defined.
.AP char *name in
.VS 8.4
.AP "CONST char" *name in
.VE
Name for new function.
.AP int numArgs in
Number of arguments to new function; also gives size of \fIargTypes\fR array.
+6 -2
View File
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: CrtObjCmd.3,v 1.4 2000/07/24 00:03:02 jenglish Exp $
'\" RCS: @(#) $Id: CrtObjCmd.3,v 1.4.2.1 2001/05/19 16:11:56 msofer Exp $
'\"
.so man.macros
.TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures"
@@ -30,13 +30,17 @@ int
int
\fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR)
.sp
char *
.VS 8.4
CONST char *
.VE
\fBTcl_GetCommandName\fR(\fIinterp, token\fR)
.SH ARGUMENTS
.AS Tcl_ObjCmdProc *deleteProc in/out
.AP Tcl_Interp *interp in
Interpreter in which to create a new command or that contains a command.
.VS 8.4
.AP char *cmdName in
.VE
Name of command.
.AP Tcl_ObjCmdProc *proc in
Implementation of the new command: \fIproc\fR will be called whenever
+7 -3
View File
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: CrtSlave.3,v 1.4 2000/07/24 00:03:02 jenglish Exp $
'\" RCS: @(#) $Id: CrtSlave.3,v 1.4.2.1 2001/05/19 16:11:56 msofer Exp $
'\"
.so man.macros
.TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures"
@@ -104,9 +104,13 @@ arguments to pass to an object alias command. The location is in storage
owned by the caller, the vector of Tcl_Obj structures is owned by the
called function.
.VS
.AP char *cmdName in
.VS 8.4
.AP "CONST char" *cmdName in
.VE
Name of an exposed command to hide or create.
.AP char *hiddenCmdName in
.VS 8.4
.AP "CONST char" *hiddenCmdName in
.VE
Name under which a hidden command is stored and with which it can be
exposed or invoked.
.VE
+2 -2
View File
@@ -3,7 +3,7 @@
'\" Copyright (c) 2000 by Scriptics Corporation.
'\" All rights reserved.
'\"
'\" RCS: @(#) $Id: DumpActiveMemory.3,v 1.3 2001/04/04 16:07:20 kennykb Exp $
'\" RCS: @(#) $Id: DumpActiveMemory.3,v 1.3.2.1 2001/05/19 16:11:56 msofer Exp $
'\"
.so man.macros
.TH "Tcl_DumpActiveMemory" 3 8.1 Tcl "Tcl Library Procedures"
@@ -26,7 +26,7 @@ void
.SH ARGUMENTS
.AP Tcl_Interp *interp in
Tcl interpreter in which to add commands.
.AP "CONST char"v *fileName in
.AP "CONST char" *fileName in
For \fBTcl_DumpActiveMemory\fR, name of the file to which memory
information will be written. For \fBTcl_ValidateAllMemory\fR, name of
the file from which the call is being made (normally \fB__FILE__\fR).
+4 -2
View File
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: ExprLong.3,v 1.3 2000/04/14 23:01:50 hobbs Exp $
'\" RCS: @(#) $Id: ExprLong.3,v 1.3.6.1 2001/05/19 16:11:56 msofer Exp $
'\"
.so man.macros
.TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures"
@@ -31,7 +31,9 @@ int
.AS Tcl_Interp *booleanPtr
.AP Tcl_Interp *interp in
Interpreter in whose context to evaluate \fIstring\fR or \fIobjPtr\fR.
.AP char *string in
.VS 8.4
.AP "CONST char" *string in
.VE
Expression to be evaluated. Must be in writable memory (the expression
parser makes temporary modifications to the string during parsing, which
it undoes before returning).
+3 -3
View File
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: Macintosh.3,v 1.2 2001/04/05 15:14:59 andreas_kupries Exp $
'\" RCS: @(#) $Id: Macintosh.3,v 1.2.2.1 2001/05/19 16:11:56 msofer Exp $
'\"
.so man.macros
.TH Tcl_MacSetEventProc 3 "8.1" Tcl "Tcl Library Procedures"
@@ -78,8 +78,8 @@ Currently only sources the resource by name, file IDs may be supported
at a later date.
.PP
\fBTcl_MacConvertTextResource\fR converts a TEXT resource into a Tcl
suitable string. It mallocs the returned memory, converts '\r' to
'\n', and appends a NULL. The caller has the responsibility for
suitable string. It mallocs the returned memory, converts ``\\r'' to
``\\n'', and appends a NULL. The caller has the responsibility for
freeing the memory.
.PP
\fBTcl_MacFindResource\fR provides a higher level interface for
+1 -1
View File
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: StringObj.3,v 1.8 2001/04/06 23:14:08 andreas_kupries Exp $
'\" RCS: @(#) $Id: StringObj.3,v 1.7.2.1 2001/05/19 16:11:56 msofer Exp $
'\"
.so man.macros
.TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures"
+4 -4
View File
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: UniCharIsAlpha.3,v 1.1 2001/04/06 23:29:17 andreas_kupries Exp $
'\" RCS: @(#) $Id: UniCharIsAlpha.3,v 1.2.4.1 2001/05/19 16:11:56 msofer Exp $
'\"
.so man.macros
.TH Tcl_UniCharIsAlpha 3 "8.1" Tcl "Tcl Library Procedures"
@@ -31,13 +31,13 @@ int
\fBTcl_UniCharIsGraph\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsLower\fR(\fch\fR)
\fBTcl_UniCharIsLower\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsPrint\fR(\fch\fR)
\fBTcl_UniCharIsPrint\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsPunct\fR(\fch\fR)
\fBTcl_UniCharIsPunct\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsSpace\fR(\fIch\fR)
+1 -1
View File
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: Utf.3,v 1.9 2001/04/06 23:14:08 andreas_kupries Exp $
'\" RCS: @(#) $Id: Utf.3,v 1.8.2.1 2001/05/19 16:11:56 msofer Exp $
'\"
.so man.macros
.TH Utf 3 "8.1" Tcl "Tcl Library Procedures"
+3 -2
View File
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: library.n,v 1.14 2000/09/07 14:27:49 poenitz Exp $
'\" RCS: @(#) $Id: library.n,v 1.14.2.1 2001/05/19 16:11:56 msofer Exp $
.so man.macros
.TH library n "8.0" Tcl "Tcl Built-In Commands"
.BS
@@ -81,7 +81,8 @@ the imported commands specified by \fIpattern\fR reside in an
autoloaded library. If so, the commands are loaded so that they will
be available to the interpreter for creating the import links. If the
commands do not reside in an autoloaded library, \fBauto_import\fR
does nothing.
does nothing. The pattern matching is performed according to the
matching rules of \fBnamespace importer\fR.
.TP
\fBauto_load \fIcmd\fR
This command attempts to load the definition for a Tcl command named
+28 -20
View File
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tcl.decls,v 1.45 2001/04/04 16:07:20 kennykb Exp $
# RCS: @(#) $Id: tcl.decls,v 1.45.2.1 2001/05/19 16:11:56 msofer Exp $
library tcl
@@ -337,7 +337,7 @@ declare 90 generic {
ClientData clientData)
}
declare 91 generic {
Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, char *cmdName, \
Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, CONST char *cmdName, \
Tcl_CmdProc *proc, ClientData clientData, \
Tcl_CmdDeleteProc *deleteProc)
}
@@ -352,11 +352,13 @@ declare 94 generic {
Tcl_Interp * Tcl_CreateInterp(void)
}
declare 95 generic {
void Tcl_CreateMathFunc(Tcl_Interp *interp, char *name, int numArgs, \
Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData)
void Tcl_CreateMathFunc(Tcl_Interp *interp, CONST char *name, \
int numArgs, Tcl_ValueType *argTypes,
Tcl_MathProc *proc, ClientData clientData)
}
declare 96 generic {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, char *cmdName, \
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, \
CONST char *cmdName, \
Tcl_ObjCmdProc *proc, ClientData clientData, \
Tcl_CmdDeleteProc *deleteProc)
}
@@ -373,7 +375,7 @@ declare 99 generic {
Tcl_CmdTraceProc *proc, ClientData clientData)
}
declare 100 generic {
void Tcl_DeleteAssocData(Tcl_Interp *interp, char *name)
void Tcl_DeleteAssocData(Tcl_Interp *interp, CONST char *name)
}
declare 101 generic {
void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc, \
@@ -384,7 +386,7 @@ declare 102 generic {
ClientData clientData)
}
declare 103 generic {
int Tcl_DeleteCommand(Tcl_Interp *interp, char *cmdName)
int Tcl_DeleteCommand(Tcl_Interp *interp, CONST char *cmdName)
}
declare 104 generic {
int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command)
@@ -479,23 +481,23 @@ declare 133 generic {
void Tcl_Exit(int status)
}
declare 134 generic {
int Tcl_ExposeCommand(Tcl_Interp *interp, char *hiddenCmdToken, \
char *cmdName)
int Tcl_ExposeCommand(Tcl_Interp *interp, CONST char *hiddenCmdToken, \
CONST char *cmdName)
}
declare 135 generic {
int Tcl_ExprBoolean(Tcl_Interp *interp, char *str, int *ptr)
int Tcl_ExprBoolean(Tcl_Interp *interp, CONST char *str, int *ptr)
}
declare 136 generic {
int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr)
}
declare 137 generic {
int Tcl_ExprDouble(Tcl_Interp *interp, char *str, double *ptr)
int Tcl_ExprDouble(Tcl_Interp *interp, CONST char *str, double *ptr)
}
declare 138 generic {
int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr)
}
declare 139 generic {
int Tcl_ExprLong(Tcl_Interp *interp, char *str, long *ptr)
int Tcl_ExprLong(Tcl_Interp *interp, CONST char *str, long *ptr)
}
declare 140 generic {
int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr)
@@ -505,7 +507,7 @@ declare 141 generic {
Tcl_Obj **resultPtrPtr)
}
declare 142 generic {
int Tcl_ExprString(Tcl_Interp *interp, char *string)
int Tcl_ExprString(Tcl_Interp *interp, CONST char *string)
}
declare 143 generic {
void Tcl_Finalize(void)
@@ -534,7 +536,7 @@ declare 149 generic {
Tcl_Obj ***objv)
}
declare 150 generic {
ClientData Tcl_GetAssocData(Tcl_Interp *interp, char *name, \
ClientData Tcl_GetAssocData(Tcl_Interp *interp, CONST char *name, \
Tcl_InterpDeleteProc **procPtr)
}
declare 151 generic {
@@ -565,11 +567,11 @@ declare 158 generic {
Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan)
}
declare 159 generic {
int Tcl_GetCommandInfo(Tcl_Interp *interp, char *cmdName, \
int Tcl_GetCommandInfo(Tcl_Interp *interp, CONST char *cmdName, \
Tcl_CmdInfo *infoPtr)
}
declare 160 generic {
char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command)
CONST char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command)
}
declare 161 generic {
int Tcl_GetErrno(void)
@@ -632,8 +634,8 @@ declare 178 generic {
int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 179 generic {
int Tcl_HideCommand(Tcl_Interp *interp, char *cmdName, \
char *hiddenCmdToken)
int Tcl_HideCommand(Tcl_Interp *interp, CONST char *cmdName, \
CONST char *hiddenCmdToken)
}
declare 180 generic {
int Tcl_Init(Tcl_Interp *interp)
@@ -776,7 +778,7 @@ declare 222 generic {
int Tcl_ServiceEvent(int flags)
}
declare 223 generic {
void Tcl_SetAssocData(Tcl_Interp *interp, char *name, \
void Tcl_SetAssocData(Tcl_Interp *interp, CONST char *name, \
Tcl_InterpDeleteProc *proc, ClientData clientData)
}
declare 224 generic {
@@ -787,7 +789,7 @@ declare 225 generic {
char *optionName, char *newValue)
}
declare 226 generic {
int Tcl_SetCommandInfo(Tcl_Interp *interp, char *cmdName, \
int Tcl_SetCommandInfo(Tcl_Interp *interp, CONST char *cmdName, \
Tcl_CmdInfo *infoPtr)
}
declare 227 generic {
@@ -1513,6 +1515,12 @@ declare 433 generic {
Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel)
}
# introduced in 8.4a3
declare 434 generic {
Tcl_UniChar * Tcl_GetUnicodeFromObj (Tcl_Obj *objPtr, int *lengthPtr)
}
##############################################################################
# Define the platform specific public Tcl interface. These functions are
+3 -2
View File
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tcl.h,v 1.88 2001/04/04 16:07:20 kennykb Exp $
* RCS: @(#) $Id: tcl.h,v 1.88.2.1 2001/05/19 16:11:56 msofer Exp $
*/
#ifndef _TCL
@@ -607,7 +607,8 @@ typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, char *part1, char *part2, int flags));
typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, char *oldName, char *newName, int flags));
Tcl_Interp *interp, CONST char *oldName, CONST char *newName,
int flags));
typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask,
Tcl_FileProc *proc, ClientData clientData));
typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd));
+32 -31
View File
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclBasic.c,v 1.29 2000/08/25 02:04:28 ericm Exp $
* RCS: @(#) $Id: tclBasic.c,v 1.29.2.1 2001/05/19 16:12:18 msofer Exp $
*/
#include "tclInt.h"
@@ -26,8 +26,8 @@
*/
static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr,
Command *cmdPtr, char *oldName,
char* newName, int flags));
Command *cmdPtr, CONST char *oldName,
CONST char* newName, int flags));
static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
static void ProcessUnexpectedResult _ANSI_ARGS_((
Tcl_Interp *interp, int returnCode));
@@ -65,7 +65,7 @@ static CmdInfo builtInCmds[] = {
*/
{"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd,
(CompileProc *) NULL, 1},
TclCompileAppendCmd, 1},
{"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd,
(CompileProc *) NULL, 1},
{"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd,
@@ -113,15 +113,15 @@ static CmdInfo builtInCmds[] = {
{"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd,
(CompileProc *) NULL, 1},
{"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd,
(CompileProc *) NULL, 1},
TclCompileLappendCmd, 1},
{"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd,
(CompileProc *) NULL, 1},
TclCompileLindexCmd, 1},
{"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd,
(CompileProc *) NULL, 1},
{"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd,
(CompileProc *) NULL, 1},
{"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd,
(CompileProc *) NULL, 1},
TclCompileLlengthCmd, 1},
{"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd,
(CompileProc *) NULL, 0},
{"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd,
@@ -720,7 +720,7 @@ Tcl_DontCallWhenDeleted(interp, proc, clientData)
void
Tcl_SetAssocData(interp, name, proc, clientData)
Tcl_Interp *interp; /* Interpreter to associate with. */
char *name; /* Name for association. */
CONST char *name; /* Name for association. */
Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
* about to be deleted. */
ClientData clientData; /* One-word value to pass to proc. */
@@ -766,7 +766,7 @@ Tcl_SetAssocData(interp, name, proc, clientData)
void
Tcl_DeleteAssocData(interp, name)
Tcl_Interp *interp; /* Interpreter to associate with. */
char *name; /* Name of association. */
CONST char *name; /* Name of association. */
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
@@ -808,7 +808,7 @@ Tcl_DeleteAssocData(interp, name)
ClientData
Tcl_GetAssocData(interp, name, procPtr)
Tcl_Interp *interp; /* Interpreter associated with. */
char *name; /* Name of association. */
CONST char *name; /* Name of association. */
Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address
* of current deletion callback. */
{
@@ -1103,8 +1103,8 @@ DeleteInterpProc(interp)
int
Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
Tcl_Interp *interp; /* Interpreter in which to hide command. */
char *cmdName; /* Name of command to hide. */
char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
CONST char *cmdName; /* Name of command to hide. */
CONST char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Command cmd;
@@ -1266,8 +1266,8 @@ int
Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
Tcl_Interp *interp; /* Interpreter in which to make command
* callable. */
char *hiddenCmdToken; /* Name of hidden command. */
char *cmdName; /* Name of to-be-exposed command. */
CONST char *hiddenCmdToken; /* Name of hidden command. */
CONST char *cmdName; /* Name of to-be-exposed command. */
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr;
@@ -1420,7 +1420,7 @@ Tcl_Command
Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
Tcl_Interp *interp; /* Token for command interpreter returned by
* a previous call to Tcl_CreateInterp. */
char *cmdName; /* Name of command. If it contains namespace
CONST char *cmdName; /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put
* in the global namespace. */
@@ -1435,7 +1435,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
Namespace *nsPtr, *dummy1, *dummy2;
Command *cmdPtr, *refCmdPtr;
Tcl_HashEntry *hPtr;
char *tail;
CONST char *tail;
int new;
ImportedCmdData *dataPtr;
@@ -1565,7 +1565,7 @@ Tcl_Command
Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
Tcl_Interp *interp; /* Token for command interpreter (returned
* by previous call to Tcl_CreateInterp). */
char *cmdName; /* Name of command. If it contains namespace
CONST char *cmdName; /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put
* in the global namespace. */
@@ -1582,7 +1582,7 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
Namespace *nsPtr, *dummy1, *dummy2;
Command *cmdPtr, *refCmdPtr;
Tcl_HashEntry *hPtr;
char *tail;
CONST char *tail;
int new;
ImportedCmdData *dataPtr;
@@ -1893,7 +1893,7 @@ TclRenameCommand(interp, oldName, newName)
char *newName; /* New command name. */
{
Interp *iPtr = (Interp *) interp;
char *newTail;
CONST char *newTail;
Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
Tcl_Command cmd;
Command *cmdPtr;
@@ -2033,7 +2033,7 @@ int
Tcl_SetCommandInfo(interp, cmdName, infoPtr)
Tcl_Interp *interp; /* Interpreter in which to look
* for command. */
char *cmdName; /* Name of desired command. */
CONST char *cmdName; /* Name of desired command. */
Tcl_CmdInfo *infoPtr; /* Where to find information
* to store in the command. */
{
@@ -2088,7 +2088,7 @@ int
Tcl_GetCommandInfo(interp, cmdName, infoPtr)
Tcl_Interp *interp; /* Interpreter in which to look
* for command. */
char *cmdName; /* Name of desired command. */
CONST char *cmdName; /* Name of desired command. */
Tcl_CmdInfo *infoPtr; /* Where to store information about
* command. */
{
@@ -2137,7 +2137,7 @@ Tcl_GetCommandInfo(interp, cmdName, infoPtr)
*----------------------------------------------------------------------
*/
char *
CONST char *
Tcl_GetCommandName(interp, command)
Tcl_Interp *interp; /* Interpreter containing the command. */
Tcl_Command command; /* Token for command returned by a previous
@@ -2234,7 +2234,7 @@ int
Tcl_DeleteCommand(interp, cmdName)
Tcl_Interp *interp; /* Token for command interpreter (returned
* by a previous Tcl_CreateInterp call). */
char *cmdName; /* Name of command to remove. */
CONST char *cmdName; /* Name of command to remove. */
{
Tcl_Command cmd;
@@ -2421,9 +2421,9 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
Interp *iPtr; /* Interpreter containing variable. */
Command *cmdPtr; /* Variable whose traces are to be
* invoked. */
char *oldName; /* Command's old name, or NULL if we
CONST char *oldName; /* Command's old name, or NULL if we
* must get the name from cmdPtr */
char *newName; /* Command's new name, or NULL if
CONST char *newName; /* Command's new name, or NULL if
* the command is not being renamed */
int flags; /* Flags passed to trace procedures:
* indicates what's happening to variable,
@@ -2545,7 +2545,7 @@ void
Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which function is
* to be available. */
char *name; /* Name of function (e.g. "sin"). */
CONST char *name; /* Name of function (e.g. "sin"). */
int numArgs; /* Nnumber of arguments required by
* function. */
Tcl_ValueType *argTypes; /* Array of types acceptable for
@@ -3018,7 +3018,7 @@ int
Tcl_ExprLong(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
char *string; /* Expression to evaluate. */
CONST char *string; /* Expression to evaluate. */
long *ptr; /* Where to store result. */
{
register Tcl_Obj *exprPtr;
@@ -3069,7 +3069,7 @@ int
Tcl_ExprDouble(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
char *string; /* Expression to evaluate. */
CONST char *string; /* Expression to evaluate. */
double *ptr; /* Where to store result. */
{
register Tcl_Obj *exprPtr;
@@ -3120,7 +3120,7 @@ int
Tcl_ExprBoolean(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
char *string; /* Expression to evaluate. */
CONST char *string; /* Expression to evaluate. */
int *ptr; /* Where to store 0/1 result. */
{
register Tcl_Obj *exprPtr;
@@ -3641,7 +3641,7 @@ int
Tcl_ExprString(interp, string)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
char *string; /* Expression to evaluate. */
CONST char *string; /* Expression to evaluate. */
{
register Tcl_Obj *exprPtr;
Tcl_Obj *resultPtr;
@@ -4336,7 +4336,8 @@ Tcl_AllowExceptions(interp)
*----------------------------------------------------------------------
*/
void Tcl_GetVersion(majorV, minorV, patchLevelV, type)
void
Tcl_GetVersion(majorV, minorV, patchLevelV, type)
int *majorV;
int *minorV;
int *patchLevelV;
+9 -6
View File
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclCmdIL.c,v 1.29 2000/11/23 15:53:26 dkf Exp $
* RCS: @(#) $Id: tclCmdIL.c,v 1.29.2.1 2001/05/19 16:12:18 msofer Exp $
*/
#include "tclInt.h"
@@ -77,7 +77,7 @@ typedef struct SortInfo {
*/
static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *listPtr, char *pattern,
Tcl_Obj *listPtr, CONST char *pattern,
int includeLinks));
static int DictionaryCompare _ANSI_ARGS_((char *left,
char *right));
@@ -654,7 +654,8 @@ InfoCommandsCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *cmdName, *pattern, *simplePattern;
char *cmdName, *pattern;
CONST char *simplePattern;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Namespace *nsPtr;
@@ -1276,7 +1277,7 @@ static void
AppendLocals(interp, listPtr, pattern, includeLinks)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Obj *listPtr; /* List object to append names to. */
char *pattern; /* Pattern to match against. */
CONST char *pattern; /* Pattern to match against. */
int includeLinks; /* 1 if upvars should be included, else 0. */
{
Interp *iPtr = (Interp *) interp;
@@ -1445,7 +1446,8 @@ InfoProcsCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *cmdName, *pattern, *simplePattern;
char *cmdName, *pattern;
CONST char *simplePattern;
Namespace *nsPtr;
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
@@ -1736,7 +1738,8 @@ InfoVarsCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
char *varName, *pattern, *simplePattern;
char *varName, *pattern;
CONST char *simplePattern;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Var *varPtr;
+79 -75
View File
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclCmdMZ.c,v 1.35 2001/04/06 10:50:00 dkf Exp $
* RCS: @(#) $Id: tclCmdMZ.c,v 1.35.2.1 2001/05/19 16:12:18 msofer Exp $
*/
#include "tclInt.h"
@@ -89,8 +89,8 @@ static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, char *name1, char *name2,
int flags));
static void TraceCommandProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, char *oldName, char *newName,
int flags));
Tcl_Interp *interp, CONST char *oldName,
CONST char *newName, int flags));
/*
@@ -568,10 +568,8 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv)
}
objPtr = objv[1];
wstring = Tcl_GetUnicode(objPtr);
wlen = Tcl_GetCharLength(objPtr);
wsubspec = Tcl_GetUnicode(objv[2]);
wsublen = Tcl_GetCharLength(objv[2]);
wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
varPtr = objv[3];
result = TCL_OK;
@@ -1060,6 +1058,12 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
switch ((enum options) index) {
case STR_EQUAL:
case STR_COMPARE: {
/*
* Remember to keep code here in some sync with the
* byte-compiled versions in tclExecute.c (INST_STR_EQ,
* INST_STR_NEQ and INST_STR_CMP as well as the expr string
* comparison in INST_EQ/INST_NEQ/INST_LT/...).
*/
int i, match, length, nocase = 0, reqlength = -1;
if (objc < 4 || objc > 7) {
@@ -1106,52 +1110,6 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
*/
objv += objc-2;
/*
* Use UNICODE versions of string comparisons since that
* won't cause undue type conversions and we can work with
* characters all of a fixed size (much faster.) Also use
* this code for untyped objects, since like that we'll
* pick up many things that are used for comparison in
* scripts and convert them (efficiently) to UNICODE
* strings for comparison, but exclude case where both are
* untyped as that is a little bit aggressive.
*/
if ((objv[0]->typePtr == &tclStringType ||
objv[0]->typePtr == NULL) &&
(objv[1]->typePtr == &tclStringType ||
objv[1]->typePtr == NULL) &&
!(objv[0]->typePtr == NULL && objv[1]->typePtr == NULL)) {
Tcl_UniChar *uni1, *uni2;
length1 = Tcl_GetCharLength(objv[0]);
length2 = Tcl_GetCharLength(objv[1]);
length = (length1 < length2) ? length1 : length2;
uni1 = Tcl_GetUnicode(objv[0]);
uni2 = Tcl_GetUnicode(objv[1]);
if (reqlength > 0 && reqlength < length) {
length = reqlength;
} else if (reqlength < 0) {
/*
* The requested length is negative, so we ignore it by
* setting it to the longer of the two lengths.
*/
reqlength = (length1 < length2) ? length2 : length1;
}
if (nocase) {
match = Tcl_UniCharNcasecmp(uni1, uni2, (unsigned)length);
} else {
match = Tcl_UniCharNcmp(uni1, uni2, (unsigned)length);
}
if ((match == 0) && (reqlength > length)) {
match = length1 - length2;
}
goto stringComparisonDone;
}
/*
* Use binary versions of comparisons since that won't
* cause undue type conversions and it is much faster.
@@ -1159,8 +1117,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
* that really makes sense with byte arrays anyway, and
* we have no memcasecmp() for some reason... :^)
*/
if (objv[0]->typePtr == &tclByteArrayType &&
objv[1]->typePtr == &tclByteArrayType && !nocase) {
if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
objv[1]->typePtr == &tclByteArrayType) {
unsigned char *bytes1, *bytes2;
bytes1 = Tcl_GetByteArrayFromObj(objv[0], &length1);
@@ -1185,6 +1143,50 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
goto stringComparisonDone;
}
/*
* Use UNICODE versions of string comparisons since that
* won't cause undue type conversions and we can work with
* characters all of a fixed size (much faster.) Also use
* this code for untyped objects, since like that we'll
* pick up many things that are used for comparison in
* scripts and convert them (efficiently) to UNICODE
* strings for comparison, but exclude case where both are
* untyped as that is a little bit aggressive.
*/
if ((objv[0]->typePtr == &tclStringType ||
objv[0]->typePtr == NULL) &&
(objv[1]->typePtr == &tclStringType ||
objv[1]->typePtr == NULL) &&
!(objv[0]->typePtr == NULL && objv[1]->typePtr == NULL)) {
Tcl_UniChar *uni1, *uni2;
uni1 = Tcl_GetUnicodeFromObj(objv[0], &length1);
uni2 = Tcl_GetUnicodeFromObj(objv[1], &length2);
length = (length1 < length2) ? length1 : length2;
if (reqlength > 0 && reqlength < length) {
length = reqlength;
} else if (reqlength < 0) {
/*
* The requested length is negative, so we ignore it by
* setting it to the longer of the two lengths.
*/
reqlength = (length1 < length2) ? length2 : length1;
}
if (nocase) {
match = Tcl_UniCharNcasecmp(uni1, uni2, (unsigned)length);
} else {
match = Tcl_UniCharNcmp(uni1, uni2, (unsigned)length);
}
if ((match == 0) && (reqlength > length)) {
match = length1 - length2;
}
goto stringComparisonDone;
}
/*
* Strings to be compared are not both UNICODE or byte
* arrays, so we will need to convert to UTF-8 and work
@@ -1247,10 +1249,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
start = 0;
length2 = -1;
ustring1 = Tcl_GetUnicode(objv[2]);
length1 = Tcl_GetCharLength(objv[2]);
ustring2 = Tcl_GetUnicode(objv[3]);
length2 = Tcl_GetCharLength(objv[3]);
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
/*
@@ -1267,6 +1267,12 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
} else if (start > 0) {
ustring2 += start;
length2 -= start;
} else if (start < 0) {
/*
* Invalid start index mapped to string start;
* Bug #423581
*/
start = 0;
}
}
@@ -1637,10 +1643,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
start = 0;
length2 = -1;
ustring1 = Tcl_GetUnicode(objv[2]);
length1 = Tcl_GetCharLength(objv[2]);
ustring2 = Tcl_GetUnicode(objv[3]);
length2 = Tcl_GetCharLength(objv[3]);
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
/*
@@ -1750,8 +1754,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
}
objc--;
ustring1 = Tcl_GetUnicode(objv[objc]);
length1 = Tcl_GetCharLength(objv[objc]);
ustring1 = Tcl_GetUnicodeFromObj(objv[objc], &length1);
if (length1 == 0) {
/*
* Empty input string, just stop now
@@ -1774,10 +1777,11 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
* algorithm is otherwise identical to the multi-pair case.
* This will be >30% faster on larger strings.
*/
Tcl_UniChar *mapString = Tcl_GetUnicode(mapElemv[1]);
int mapLen = Tcl_GetCharLength(mapElemv[1]);
ustring2 = Tcl_GetUnicode(mapElemv[0]);
length2 = Tcl_GetCharLength(mapElemv[0]);
int mapLen;
Tcl_UniChar *mapString;
ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
for (p = ustring1; ustring1 < end; ustring1++) {
if ((length2 > 0) &&
(nocase || (*ustring1 == *ustring2)) &&
@@ -1807,8 +1811,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
* significantly speeding up the algorithm.
*/
for (index = 0; index < mapElemc; index++) {
mapStrings[index] = Tcl_GetUnicode(mapElemv[index]);
mapLens[index] = Tcl_GetCharLength(mapElemv[index]);
mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
&(mapLens[index]));
}
for (p = ustring1; ustring1 < end; ustring1++) {
for (index = 0; index < mapElemc; index += 2) {
@@ -1967,8 +1971,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
ustring1 = Tcl_GetUnicode(objv[2]);
length1 = Tcl_GetCharLength(objv[2]) - 1;
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
length1--;
if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
|| (TclGetIntForIndex(interp, objv[4], length1,
@@ -3432,8 +3436,8 @@ static void
TraceCommandProc(clientData, interp, oldName, newName, flags)
ClientData clientData; /* Information about the command trace. */
Tcl_Interp *interp; /* Interpreter containing command. */
char *oldName; /* Name of command being changed. */
char *newName; /* New name of command. Empty string
CONST char *oldName; /* Name of command being changed. */
CONST char *newName; /* New name of command. Empty string
* or NULL means command is being deleted
* (renamed to ""). */
int flags; /* OR-ed bits giving operation and other
+696 -307
View File
File diff suppressed because it is too large Load Diff
+31 -1
View File
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclCompile.c,v 1.21 2000/05/26 08:53:41 hobbs Exp $
* RCS: @(#) $Id: tclCompile.c,v 1.21.2.1 2001/05/19 16:12:18 msofer Exp $
*/
#include "tclInt.h"
@@ -222,6 +222,36 @@ InstructionDesc instructionTable[] = {
/* Str Index: push (strindex stknext stktop) */
{"strmatch", 1, 0, {OPERAND_NONE}},
/* Str Match: push (strmatch stkforenext stknext stktop) */
{"list", 1, 0, {OPERAND_NONE}},
/* List: push (stk1 stk2 ... stktop) */
{"listindex", 1, 0, {OPERAND_NONE}},
/* List Index: push (listindex stknext stktop) */
{"listlength", 1, 0, {OPERAND_NONE}},
/* List Len: push (listlength stktop) */
{"appendScalar1", 2, 1, {OPERAND_UINT1}},
/* Append scalar variable at op1<=255 in frame; value is stktop */
{"appendScalar4", 5, 1, {OPERAND_UINT4}},
/* Append scalar variable at op1 > 255 in frame; value is stktop */
{"appendArray1", 2, 1, {OPERAND_UINT1}},
/* Append array element; array at op1<=255, value is top then elem */
{"appendArray4", 5, 1, {OPERAND_UINT4}},
/* Append array element; array at op1>=256, value is top then elem */
{"appendArrayStk", 1, 0, {OPERAND_NONE}},
/* Append array element; value is stktop, then elem, array names */
{"appendStk", 1, 0, {OPERAND_NONE}},
/* Append general variable; value is stktop, then unparsed name */
{"lappendScalar1", 2, 1, {OPERAND_UINT1}},
/* Lappend scalar variable at op1<=255 in frame; value is stktop */
{"lappendScalar4", 5, 1, {OPERAND_UINT4}},
/* Lappend scalar variable at op1 > 255 in frame; value is stktop */
{"lappendArray1", 2, 1, {OPERAND_UINT1}},
/* Lappend array element; array at op1<=255, value is top then elem */
{"lappendArray4", 5, 1, {OPERAND_UINT4}},
/* Lappend array element; array at op1>=256, value is top then elem */
{"lappendArrayStk", 1, 0, {OPERAND_NONE}},
/* Lappend array element; value is stktop, then elem, array names */
{"lappendStk", 1, 0, {OPERAND_NONE}},
/* Lappend general variable; value is stktop, then unparsed name */
{0}
};
+27 -3
View File
@@ -7,7 +7,9 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclCompile.h,v 1.14 2000/05/26 08:53:42 hobbs Exp $
* Up-to-date with 1.15
*
* RCS: @(#) $Id: tclCompile.h,v 1.14.2.3 2001/07/13 21:25:00 msofer Exp $
*/
#ifndef _TCLCOMPILATION
@@ -294,6 +296,9 @@ typedef struct CompileEnv {
*/
#define TCL_BYTECODE_PRECOMPILED 0x0001
#define TCL_BYTECODE_OPCODES_OK 0x0002
typedef struct ByteCode {
TclHandle interpHandle; /* Handle for interpreter containing the
* compiled code. Commands and their compile
@@ -494,7 +499,7 @@ typedef struct ByteCode {
#define INST_PUSH_RESULT 71
#define INST_PUSH_RETURN_CODE 72
/* Opcodes 73 to 74 */
/* Opcodes 73 to 78 */
#define INST_STR_EQ 73
#define INST_STR_NEQ 74
#define INST_STR_CMP 75
@@ -502,8 +507,27 @@ typedef struct ByteCode {
#define INST_STR_INDEX 77
#define INST_STR_MATCH 78
/* Opcodes 78 to 81 */
#define INST_LIST 79
#define INST_LIST_INDEX 80
#define INST_LIST_LENGTH 81
#define INST_APPEND_SCALAR1 82
#define INST_APPEND_SCALAR4 83
#define INST_APPEND_ARRAY1 84
#define INST_APPEND_ARRAY4 85
#define INST_APPEND_ARRAY_STK 86
#define INST_APPEND_STK 87
#define INST_LAPPEND_SCALAR1 88
#define INST_LAPPEND_SCALAR4 89
#define INST_LAPPEND_ARRAY1 90
#define INST_LAPPEND_ARRAY4 91
#define INST_LAPPEND_ARRAY_STK 92
#define INST_LAPPEND_STK 93
/* The last opcode */
#define LAST_INST_OPCODE 78
#define LAST_INST_OPCODE 93
/*
* Table describing the Tcl bytecode instructions: their name (for
+45 -33
View File
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclDecls.h,v 1.47 2001/04/04 16:07:20 kennykb Exp $
* RCS: @(#) $Id: tclDecls.h,v 1.47.2.1 2001/05/19 16:12:18 msofer Exp $
*/
#ifndef _TCLDECLS
@@ -304,7 +304,7 @@ EXTERN void Tcl_CreateCloseHandler _ANSI_ARGS_((Tcl_Channel chan,
Tcl_CloseProc * proc, ClientData clientData));
/* 91 */
EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp * interp,
char * cmdName, Tcl_CmdProc * proc,
CONST char * cmdName, Tcl_CmdProc * proc,
ClientData clientData,
Tcl_CmdDeleteProc * deleteProc));
/* 92 */
@@ -319,12 +319,12 @@ EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_((
EXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void));
/* 95 */
EXTERN void Tcl_CreateMathFunc _ANSI_ARGS_((Tcl_Interp * interp,
char * name, int numArgs,
CONST char * name, int numArgs,
Tcl_ValueType * argTypes,
Tcl_MathProc * proc, ClientData clientData));
/* 96 */
EXTERN Tcl_Command Tcl_CreateObjCommand _ANSI_ARGS_((
Tcl_Interp * interp, char * cmdName,
Tcl_Interp * interp, CONST char * cmdName,
Tcl_ObjCmdProc * proc, ClientData clientData,
Tcl_CmdDeleteProc * deleteProc));
/* 97 */
@@ -339,7 +339,7 @@ EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp * interp,
ClientData clientData));
/* 100 */
EXTERN void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp * interp,
char * name));
CONST char * name));
/* 101 */
EXTERN void Tcl_DeleteChannelHandler _ANSI_ARGS_((
Tcl_Channel chan, Tcl_ChannelProc * proc,
@@ -349,7 +349,7 @@ EXTERN void Tcl_DeleteCloseHandler _ANSI_ARGS_((Tcl_Channel chan,
Tcl_CloseProc * proc, ClientData clientData));
/* 103 */
EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp * interp,
char * cmdName));
CONST char * cmdName));
/* 104 */
EXTERN int Tcl_DeleteCommandFromToken _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Command command));
@@ -447,22 +447,23 @@ EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((
EXTERN void Tcl_Exit _ANSI_ARGS_((int status));
/* 134 */
EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp * interp,
char * hiddenCmdToken, char * cmdName));
CONST char * hiddenCmdToken,
CONST char * cmdName));
/* 135 */
EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp,
char * str, int * ptr));
CONST char * str, int * ptr));
/* 136 */
EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, int * ptr));
/* 137 */
EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp * interp,
char * str, double * ptr));
CONST char * str, double * ptr));
/* 138 */
EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, double * ptr));
/* 139 */
EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp * interp,
char * str, long * ptr));
CONST char * str, long * ptr));
/* 140 */
EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, long * ptr));
@@ -471,7 +472,7 @@ EXTERN int Tcl_ExprObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr));
/* 142 */
EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp * interp,
char * string));
CONST char * string));
/* 143 */
EXTERN void Tcl_Finalize _ANSI_ARGS_((void));
/* 144 */
@@ -498,7 +499,8 @@ EXTERN int Tcl_GetAliasObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj *** objv));
/* 150 */
EXTERN ClientData Tcl_GetAssocData _ANSI_ARGS_((Tcl_Interp * interp,
char * name, Tcl_InterpDeleteProc ** procPtr));
CONST char * name,
Tcl_InterpDeleteProc ** procPtr));
/* 151 */
EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp * interp,
char * chanName, int * modePtr));
@@ -523,9 +525,9 @@ EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((
EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan));
/* 159 */
EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp,
char * cmdName, Tcl_CmdInfo * infoPtr));
CONST char * cmdName, Tcl_CmdInfo * infoPtr));
/* 160 */
EXTERN char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp * interp,
EXTERN CONST char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Command command));
/* 161 */
EXTERN int Tcl_GetErrno _ANSI_ARGS_((void));
@@ -578,7 +580,8 @@ EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr));
/* 179 */
EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp * interp,
char * cmdName, char * hiddenCmdToken));
CONST char * cmdName,
CONST char * hiddenCmdToken));
/* 180 */
EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp * interp));
/* 181 */
@@ -716,7 +719,8 @@ EXTERN int Tcl_ServiceAll _ANSI_ARGS_((void));
EXTERN int Tcl_ServiceEvent _ANSI_ARGS_((int flags));
/* 223 */
EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp * interp,
char * name, Tcl_InterpDeleteProc * proc,
CONST char * name,
Tcl_InterpDeleteProc * proc,
ClientData clientData));
/* 224 */
EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_((
@@ -727,7 +731,7 @@ EXTERN int Tcl_SetChannelOption _ANSI_ARGS_((
char * optionName, char * newValue));
/* 226 */
EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp,
char * cmdName, Tcl_CmdInfo * infoPtr));
CONST char * cmdName, Tcl_CmdInfo * infoPtr));
/* 227 */
EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err));
/* 228 */
@@ -1359,6 +1363,9 @@ EXTERN int Tcl_AttemptSetObjLength _ANSI_ARGS_((
/* 433 */
EXTERN Tcl_ThreadId Tcl_GetChannelThread _ANSI_ARGS_((
Tcl_Channel channel));
/* 434 */
EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj _ANSI_ARGS_((Tcl_Obj * objPtr,
int * lengthPtr));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -1477,19 +1484,19 @@ typedef struct TclStubs {
Tcl_Channel (*tcl_CreateChannel) _ANSI_ARGS_((Tcl_ChannelType * typePtr, char * chanName, ClientData instanceData, int mask)); /* 88 */
void (*tcl_CreateChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, int mask, Tcl_ChannelProc * proc, ClientData clientData)); /* 89 */
void (*tcl_CreateCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 90 */
Tcl_Command (*tcl_CreateCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 91 */
Tcl_Command (*tcl_CreateCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 91 */
void (*tcl_CreateEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 92 */
void (*tcl_CreateExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 93 */
Tcl_Interp * (*tcl_CreateInterp) _ANSI_ARGS_((void)); /* 94 */
void (*tcl_CreateMathFunc) _ANSI_ARGS_((Tcl_Interp * interp, char * name, int numArgs, Tcl_ValueType * argTypes, Tcl_MathProc * proc, ClientData clientData)); /* 95 */
Tcl_Command (*tcl_CreateObjCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 96 */
void (*tcl_CreateMathFunc) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int numArgs, Tcl_ValueType * argTypes, Tcl_MathProc * proc, ClientData clientData)); /* 95 */
Tcl_Command (*tcl_CreateObjCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 96 */
Tcl_Interp * (*tcl_CreateSlave) _ANSI_ARGS_((Tcl_Interp * interp, char * slaveName, int isSafe)); /* 97 */
Tcl_TimerToken (*tcl_CreateTimerHandler) _ANSI_ARGS_((int milliseconds, Tcl_TimerProc * proc, ClientData clientData)); /* 98 */
Tcl_Trace (*tcl_CreateTrace) _ANSI_ARGS_((Tcl_Interp * interp, int level, Tcl_CmdTraceProc * proc, ClientData clientData)); /* 99 */
void (*tcl_DeleteAssocData) _ANSI_ARGS_((Tcl_Interp * interp, char * name)); /* 100 */
void (*tcl_DeleteAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 100 */
void (*tcl_DeleteChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_ChannelProc * proc, ClientData clientData)); /* 101 */
void (*tcl_DeleteCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 102 */
int (*tcl_DeleteCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName)); /* 103 */
int (*tcl_DeleteCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName)); /* 103 */
int (*tcl_DeleteCommandFromToken) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 104 */
void (*tcl_DeleteEvents) _ANSI_ARGS_((Tcl_EventDeleteProc * proc, ClientData clientData)); /* 105 */
void (*tcl_DeleteEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 106 */
@@ -1528,15 +1535,15 @@ typedef struct TclStubs {
int (*tcl_EvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 131 */
void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */
void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */
int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * hiddenCmdToken, char * cmdName)); /* 134 */
int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * ptr)); /* 135 */
int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * hiddenCmdToken, CONST char * cmdName)); /* 134 */
int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * ptr)); /* 135 */
int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */
int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * str, double * ptr)); /* 137 */
int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * ptr)); /* 137 */
int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */
int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * ptr)); /* 139 */
int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * ptr)); /* 139 */
int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */
int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */
int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 142 */
int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 142 */
void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */
void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */
Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */
@@ -1544,7 +1551,7 @@ typedef struct TclStubs {
void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */
int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp * interp, char * slaveCmd, Tcl_Interp ** targetInterpPtr, char ** targetCmdPtr, int * argcPtr, char *** argvPtr)); /* 148 */
int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp * interp, char * slaveCmd, Tcl_Interp ** targetInterpPtr, char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 149 */
ClientData (*tcl_GetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_InterpDeleteProc ** procPtr)); /* 150 */
ClientData (*tcl_GetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc ** procPtr)); /* 150 */
Tcl_Channel (*tcl_GetChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * chanName, int * modePtr)); /* 151 */
int (*tcl_GetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan)); /* 152 */
int (*tcl_GetChannelHandle) _ANSI_ARGS_((Tcl_Channel chan, int direction, ClientData * handlePtr)); /* 153 */
@@ -1553,8 +1560,8 @@ typedef struct TclStubs {
char * (*tcl_GetChannelName) _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */
int (*tcl_GetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, char * optionName, Tcl_DString * dsPtr)); /* 157 */
Tcl_ChannelType * (*tcl_GetChannelType) _ANSI_ARGS_((Tcl_Channel chan)); /* 158 */
int (*tcl_GetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_CmdInfo * infoPtr)); /* 159 */
char * (*tcl_GetCommandName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 160 */
int (*tcl_GetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 159 */
CONST char * (*tcl_GetCommandName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 160 */
int (*tcl_GetErrno) _ANSI_ARGS_((void)); /* 161 */
char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */
int (*tcl_GetInterpPath) _ANSI_ARGS_((Tcl_Interp * askInterp, Tcl_Interp * slaveInterp)); /* 163 */
@@ -1581,7 +1588,7 @@ typedef struct TclStubs {
char * (*tcl_GetVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags)); /* 176 */
int (*tcl_GlobalEval) _ANSI_ARGS_((Tcl_Interp * interp, char * command)); /* 177 */
int (*tcl_GlobalEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 178 */
int (*tcl_HideCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, char * hiddenCmdToken)); /* 179 */
int (*tcl_HideCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST char * hiddenCmdToken)); /* 179 */
int (*tcl_Init) _ANSI_ARGS_((Tcl_Interp * interp)); /* 180 */
void (*tcl_InitHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType)); /* 181 */
int (*tcl_InputBlocked) _ANSI_ARGS_((Tcl_Channel chan)); /* 182 */
@@ -1641,10 +1648,10 @@ typedef struct TclStubs {
int (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */
int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */
int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */
void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */
int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, char * optionName, char * newValue)); /* 225 */
int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_CmdInfo * infoPtr)); /* 226 */
int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 226 */
void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */
void (*tcl_SetErrorCode) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 228 */
void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */
@@ -1860,6 +1867,7 @@ typedef struct TclStubs {
char * (*tcl_AttemptDbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, char * file, int line)); /* 431 */
int (*tcl_AttemptSetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 432 */
Tcl_ThreadId (*tcl_GetChannelThread) _ANSI_ARGS_((Tcl_Channel channel)); /* 433 */
Tcl_UniChar * (*tcl_GetUnicodeFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 434 */
} TclStubs;
#ifdef __cplusplus
@@ -3644,6 +3652,10 @@ extern TclStubs *tclStubsPtr;
#define Tcl_GetChannelThread \
(tclStubsPtr->tcl_GetChannelThread) /* 433 */
#endif
#ifndef Tcl_GetUnicodeFromObj
#define Tcl_GetUnicodeFromObj \
(tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */
#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
+2562 -2571
View File
File diff suppressed because it is too large Load Diff
+224
View File
@@ -0,0 +1,224 @@
/*
* tclExecute.h --
*
* This file contains the compiler-dependent macros that determine the
* instruction-threading method used by tclExecute.c
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclExecute.h,v 1.1.2.7 2001/05/19 16:12:18 msofer Exp $
*/
/*
* An instruction-threading method has to define the following macros:
*
* . _CASE_DECLS declarations of special variables required
* . CHECK_OPCODES 0/1, if the opcodes have to be checked before RT
* . _CASE_START start of the block containing instructions
* . _CASE(instruction) the labelling method for instruction start
* . NEXT_INSTR the jump to the next instruction
* . _CASE_END end of the block containing instructions
*
*
* Currently three different methods are implemented:
*
* 1. SWITCH produces standard C code valid for any compiler;
* jumps from the end of an instruction to the switch
* statement, from there to the next instruction after
* performing a bounds check
* 2. GCC uses a gcc extension to jump directly from the end
* of an instruction to the start of the next one, using
* a jump table and the "labels as values" extension
* 3. MSVC directs msvc to omit checking the bounds of the switch
*/
#define SWITCH 0
#define GCC 1
#define MSVC 2
/*
* Choose the threading method according to the compiler being used; if
* TCL_BYTECODE_DEBUG is set, fallback to SWITCH for any compiler
*/
#ifdef __GNUC__
#define JUMP_version GCC
#elif defined( _MSC_VER ) && ( _MSC_VER >= 1200 ) && defined( _MSC_EXTENSIONS )
/* msvc with extensions */
#define JUMP_version MSVC
#else /* standard C output */
#define JUMP_version SWITCH
#endif /* choice of method */
#ifdef TCL_BYTECODE_DEBUG
# undef JUMP_version
# define JUMP_version SWITCH
# define INIT_TRACE_CHECK \
if (tclTraceExec == 3) {\
fprintf(stdout, "%2d: %2d ", iPtr->numLevels, tosPtr - eePtr->stackPtr);\
TclPrintInstruction(codePtr, pc);\
fflush(stdout);\
}
#else /* not debugging */
# define INIT_TRACE_CHECK
#endif /* debugging code */
/*
* Define the macros for the different threading methods
*/
/**** SWITCH ****/
#if JUMP_version == SWITCH
#define _CASE_DECLS
#define CHECK_OPCODES 0
# define _CASE_START \
instructions_start: \
INIT_TRACE_CHECK \
switch (*pc) {
#define _CASE(instruction) case instruction
#define NEXT_INSTR goto instructions_start
#define _CASE_END \
default: \
panic("TclExecuteByteCode: unrecognized opCode %u", *pc);\
} /* end of switch on opCode */
#endif /* SWITCH methods */
/**** MSVC ****/
#if JUMP_version == MSVC
#define _CASE_DECLS
#define CHECK_OPCODES 1
#define _CASE_START \
instructions_start: \
switch (*pc) {
#define _CASE(instruction) case instruction
#define NEXT_INSTR goto instructions_start
#define _CASE_END \
default: \
__assume(0); /* do not check bounds of switch! */ \
} /* end of switch on opCode */
#endif /* MSVC methods */
/**** GCC ****/
#if JUMP_version == GCC
#define _CASE_DECLS \
static const void *jumpTable[] = _JUMP_TABLE;
#define CHECK_OPCODES 1
#define _CASE_START NEXT_INSTR;
#define _CASE(instruction) _CASE_ ## instruction
#define NEXT_INSTR goto *jumpTable[*pc]
#define _CASE_END /* end of switch on opCode */
/* _CASE_DECLS uses the following jump table
* IT HAS TO BE IN THE CORRECT ORDER, of course */
#define _JUMP_TABLE {\
&&_CASE(INST_DONE),\
&&_CASE(INST_PUSH1),\
&&_CASE(INST_PUSH4),\
&&_CASE(INST_POP),\
&&_CASE(INST_DUP),\
&&_CASE(INST_CONCAT1),\
&&_CASE(INST_INVOKE_STK1),\
&&_CASE(INST_INVOKE_STK4),\
&&_CASE(INST_EVAL_STK),\
&&_CASE(INST_EXPR_STK),\
&&_CASE(INST_LOAD_SCALAR1),\
&&_CASE(INST_LOAD_SCALAR4),\
&&_CASE(INST_LOAD_SCALAR_STK),\
&&_CASE(INST_LOAD_ARRAY1),\
&&_CASE(INST_LOAD_ARRAY4),\
&&_CASE(INST_LOAD_ARRAY_STK),\
&&_CASE(INST_LOAD_STK),\
&&_CASE(INST_STORE_SCALAR1),\
&&_CASE(INST_STORE_SCALAR4),\
&&_CASE(INST_STORE_SCALAR_STK),\
&&_CASE(INST_STORE_ARRAY1),\
&&_CASE(INST_STORE_ARRAY4),\
&&_CASE(INST_STORE_ARRAY_STK),\
&&_CASE(INST_STORE_STK),\
&&_CASE(INST_INCR_SCALAR1),\
&&_CASE(INST_INCR_SCALAR_STK),\
&&_CASE(INST_INCR_ARRAY1),\
&&_CASE(INST_INCR_ARRAY_STK),\
&&_CASE(INST_INCR_STK),\
&&_CASE(INST_INCR_SCALAR1_IMM),\
&&_CASE(INST_INCR_SCALAR_STK_IMM),\
&&_CASE(INST_INCR_ARRAY1_IMM),\
&&_CASE(INST_INCR_ARRAY_STK_IMM),\
&&_CASE(INST_INCR_STK_IMM),\
&&_CASE(INST_JUMP1),\
&&_CASE(INST_JUMP4),\
&&_CASE(INST_JUMP_TRUE1),\
&&_CASE(INST_JUMP_TRUE4),\
&&_CASE(INST_JUMP_FALSE1),\
&&_CASE(INST_JUMP_FALSE4),\
&&_CASE(INST_LOR),\
&&_CASE(INST_LAND),\
&&_CASE(INST_BITOR),\
&&_CASE(INST_BITXOR),\
&&_CASE(INST_BITAND),\
&&_CASE(INST_EQ),\
&&_CASE(INST_NEQ),\
&&_CASE(INST_LT),\
&&_CASE(INST_GT),\
&&_CASE(INST_LE),\
&&_CASE(INST_GE),\
&&_CASE(INST_LSHIFT),\
&&_CASE(INST_RSHIFT),\
&&_CASE(INST_ADD),\
&&_CASE(INST_SUB),\
&&_CASE(INST_MULT),\
&&_CASE(INST_DIV),\
&&_CASE(INST_MOD),\
&&_CASE(INST_UPLUS),\
&&_CASE(INST_UMINUS),\
&&_CASE(INST_BITNOT),\
&&_CASE(INST_LNOT),\
&&_CASE(INST_CALL_BUILTIN_FUNC1),\
&&_CASE(INST_CALL_FUNC1),\
&&_CASE(INST_TRY_CVT_TO_NUMERIC),\
&&_CASE(INST_BREAK),\
&&_CASE(INST_CONTINUE),\
&&_CASE(INST_FOREACH_START4),\
&&_CASE(INST_FOREACH_STEP4),\
&&_CASE(INST_BEGIN_CATCH4),\
&&_CASE(INST_END_CATCH),\
&&_CASE(INST_PUSH_RESULT),\
&&_CASE(INST_PUSH_RETURN_CODE),\
&&_CASE(INST_STR_EQ),\
&&_CASE(INST_STR_NEQ),\
&&_CASE(INST_STR_CMP),\
&&_CASE(INST_STR_LEN),\
&&_CASE(INST_STR_INDEX),\
&&_CASE(INST_STR_MATCH),\
&&_CASE(INST_LIST),\
&&_CASE(INST_LIST_INDEX),\
&&_CASE(INST_LIST_LENGTH),\
&&_CASE(INST_APPEND_SCALAR1),\
&&_CASE(INST_APPEND_SCALAR4),\
&&_CASE(INST_APPEND_ARRAY1),\
&&_CASE(INST_APPEND_ARRAY4),\
&&_CASE(INST_APPEND_ARRAY_STK),\
&&_CASE(INST_APPEND_STK),\
&&_CASE(INST_LAPPEND_SCALAR1),\
&&_CASE(INST_LAPPEND_SCALAR4),\
&&_CASE(INST_LAPPEND_ARRAY1),\
&&_CASE(INST_LAPPEND_ARRAY4),\
&&_CASE(INST_LAPPEND_ARRAY_STK),\
&&_CASE(INST_LAPPEND_STK)\
}
#endif /* GCC methods */
/* End of method definitions */
#undef SWITCH
#undef GCC
#undef MSVC
#undef JUMP_version
+11 -12
View File
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclFileName.c,v 1.13 2000/04/19 23:24:52 hobbs Exp $
* RCS: @(#) $Id: tclFileName.c,v 1.13.6.1 2001/05/19 16:12:18 msofer Exp $
*/
#include "tclInt.h"
@@ -163,7 +163,6 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)
{
FileNameInit();
if (path[0] == '/' || path[0] == '\\') {
/* Might be a UNC or Vol-Relative path */
char *host, *share, *tail;
@@ -173,10 +172,10 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)
*typePtr = TCL_PATH_VOLUME_RELATIVE;
Tcl_DStringAppend(resultPtr, "/", 1);
return &path[1];
}
}
host = (char *)&path[2];
/* Skip seperators */
/* Skip separators */
while (host[0] == '/' || host[0] == '\\') host++;
for (hlen = 0; host[hlen];hlen++) {
@@ -191,7 +190,7 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)
Tcl_DStringSetLength(resultPtr, offset);
share = &host[hlen];
/* Skip seperators */
/* Skip separators */
while (share[0] == '/' || share[0] == '\\') share++;
for (slen = 0; share[slen];slen++) {
@@ -205,12 +204,12 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)
tail = &share[slen];
/* Skip seperators */
/* Skip separators */
while (tail[0] == '/' || tail[0] == '\\') tail++;
*typePtr = TCL_PATH_ABSOLUTE;
return tail;
} else if (path[1] == ':') {
} else if (*path && path[1] == ':') {
/* Might be a drive sep */
Tcl_DStringSetLength(resultPtr, offset);
@@ -218,17 +217,17 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)
*typePtr = TCL_PATH_VOLUME_RELATIVE;
Tcl_DStringAppend(resultPtr, path, 2);
return &path[2];
} else {
} else {
char *tail = (char*)&path[3];
/* Skip seperators */
while (tail[0] == '/' || tail[0] == '\\') tail++;
/* Skip separators */
while (*tail && (tail[0] == '/' || tail[0] == '\\')) tail++;
*typePtr = TCL_PATH_ABSOLUTE;
Tcl_DStringAppend(resultPtr, path, 2);
Tcl_DStringAppend(resultPtr, "/", 1);
Tcl_DStringAppend(resultPtr, "/", 1);
return tail;
return tail;
}
} else {
*typePtr = TCL_PATH_RELATIVE;
+11 -10
View File
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tclInt.decls,v 1.23 2000/09/28 06:38:21 hobbs Exp $
# RCS: @(#) $Id: tclInt.decls,v 1.23.2.1 2001/05/19 16:12:18 msofer Exp $
library tcl
@@ -62,7 +62,8 @@ declare 9 {unix win} {
TclFile *errFilePtr)
}
declare 10 generic {
int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr, char *procName, \
int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr,
CONST char *procName,
Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr)
}
declare 11 generic {
@@ -127,7 +128,7 @@ declare 28 generic {
}
declare 29 generic {
Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, \
int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg)
int localIndex, Tcl_Obj *elemPtr, int flags)
}
# Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1:
# declare 30 generic {
@@ -148,7 +149,7 @@ declare 34 generic {
}
declare 35 generic {
Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, \
int leaveErrorMsg)
int flags)
}
declare 36 generic {
int TclGetLong(Tcl_Interp *interp, char *str, long *longPtr)
@@ -157,10 +158,10 @@ declare 37 generic {
int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName)
}
declare 38 generic {
int TclGetNamespaceForQualName(Tcl_Interp *interp, char *qualName, \
int TclGetNamespaceForQualName(Tcl_Interp *interp, CONST char *qualName, \
Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, \
Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, \
char **simpleNamePtr)
CONST char **simpleNamePtr)
}
declare 39 generic {
TclObjCmdProcType TclGetObjInterpProc(void)
@@ -373,11 +374,11 @@ declare 98 generic {
}
declare 99 generic {
Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, \
int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int leaveErrorMsg)
int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
}
declare 100 generic {
Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, \
Tcl_Obj *objPtr, int leaveErrorMsg)
Tcl_Obj *objPtr, int flags)
}
declare 101 {unix win} {
char * TclSetPreInitScript(char *string)
@@ -425,7 +426,7 @@ declare 112 generic {
Tcl_Obj *objPtr)
}
declare 113 generic {
Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, char *name, \
Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, CONST char *name, \
ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 114 generic {
@@ -436,7 +437,7 @@ declare 115 generic {
int resetListFirst)
}
declare 116 generic {
Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, char *name, \
Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, CONST char *name, \
Tcl_Namespace *contextNsPtr, int flags)
}
declare 117 generic {
+83 -19
View File
@@ -11,7 +11,9 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclInt.h,v 1.50 2000/08/25 02:04:29 ericm Exp $
* Up-to-date with 1.57
*
* RCS: @(#) $Id: tclInt.h,v 1.50.2.3 2001/07/13 21:25:00 msofer Exp $
*/
#ifndef _TCLINT
@@ -98,7 +100,7 @@ typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
int flags, Tcl_Var *rPtr));
typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp,
char* name, Tcl_Namespace *context, int flags,
CONST char* name, Tcl_Namespace *context, int flags,
Tcl_Command *rPtr));
typedef struct Tcl_ResolverInfo {
@@ -184,11 +186,13 @@ typedef struct Namespace {
* namespace has already cached a Command *
* pointer; this causes all its cached
* Command* pointers to be invalidated. */
int resolverEpoch; /* Incremented whenever the name resolution
* rules change for this namespace; this
* invalidates all byte codes compiled in
* the namespace, causing the code to be
* recompiled under the new rules. */
int resolverEpoch; /* Incremented whenever (a) the name resolution
* rules change for this namespace or (b) a
* newly added command shadows a command that
* is compiled to bytecodes.
* This invalidates all byte codes compiled
* in the namespace, causing the code to be
* recompiled under the new rules.*/
Tcl_ResolveCmdProc *cmdResProc;
/* If non-null, this procedure overrides
* the usual command resolution mechanism
@@ -504,6 +508,10 @@ typedef struct Var {
#define TclClearVarUndefined(varPtr) \
(varPtr)->flags &= ~VAR_UNDEFINED
/* A slighly faster combination for (SetVarScalar/ClearVarUndefined) */
#define TclSetVarScalarDefined(varPtr) \
((varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK|VAR_UNDEFINED)) | VAR_SCALAR)
/*
* Macros to read various flag bits of variables.
* The ANSI C "prototypes" for these macros are:
@@ -542,6 +550,19 @@ typedef struct Var {
#define TclIsVarResolved(varPtr) \
((varPtr)->flags & VAR_RESOLVED)
/* A slighly faster combination for
* (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr))
* (1) XOR (^) reverses the VAR_UNDEFINED bit
* (2) AND (&) keeps both bits and zeroes everything else
* (3) == looks if both bits are set
* This is 3 ops instead of 4, single register instead of two
*/
#define _CONTAINS_(A,B) (((A) & (B)) == (B))
#define TclIsVarScalarDefined(varPtr) \
_CONTAINS_(((varPtr)->flags ^ VAR_UNDEFINED), (VAR_UNDEFINED | VAR_SCALAR))
#define TclIsVarArrayDefined(varPtr) \
_CONTAINS_(((varPtr)->flags ^ VAR_UNDEFINED), (VAR_UNDEFINED | VAR_ARRAY))
/*
*----------------------------------------------------------------
* Data structures related to procedures. These are used primarily
@@ -878,9 +899,9 @@ typedef int (CompileHookProc) _ANSI_ARGS_((Tcl_Interp *interp,
typedef struct ExecEnv {
Tcl_Obj **stackPtr; /* Points to the first item in the
* evaluation stack on the heap. */
int stackTop; /* Index of current top of stack; -1 when
* the stack is empty. */
int stackEnd; /* Index of last usable item in stack. */
Tcl_Obj **tosPtr; /* Pointer to current top of stack;
*(stackPtr-1) when stack is empty */
Tcl_Obj **stackEndPtr; /* Pointer to last usable item in stack. */
} ExecEnv;
/*
@@ -1590,6 +1611,9 @@ extern Tcl_ObjType tclIntType;
extern Tcl_ObjType tclListType;
extern Tcl_ObjType tclProcBodyType;
extern Tcl_ObjType tclStringType;
extern Tcl_ObjType tclArraySearchType;
extern Tcl_ObjType tclIndexType;
extern Tcl_ObjType tclNsNameType;
/*
* Variables denoting the hash key types defined in the core.
@@ -1653,7 +1677,7 @@ EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp,
TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr));
EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp *interp,
Namespace *nsPtr, char *procName,
Namespace *nsPtr, CONST char *procName,
Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr,
Proc **procPtrPtr));
EXTERN void TclDeleteCompiledLocalVars _ANSI_ARGS_((
@@ -1700,7 +1724,7 @@ EXTERN int TclGetDate _ANSI_ARGS_((char *p,
unsigned long *timePtr));
EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_((
Tcl_Interp *interp, int localIndex,
Tcl_Obj *elemPtr, int leaveErrorMsg));
Tcl_Obj *elemPtr, int flags));
EXTERN char * TclGetExtension _ANSI_ARGS_((char *name));
EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp,
char *string, CallFrame **framePtrPtr));
@@ -1708,17 +1732,17 @@ EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void));
EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, int endValue, int *indexPtr));
EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp,
int localIndex, int leaveErrorMsg));
int localIndex, int flags));
EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp *interp,
char *string, long *longPtr));
EXTERN int TclGetLoadedPackages _ANSI_ARGS_((
Tcl_Interp *interp, char *targetName));
EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_((
Tcl_Interp *interp, char *qualName,
Tcl_Interp *interp, CONST char *qualName,
Namespace *cxtNsPtr, int flags,
Namespace **nsPtrPtr, Namespace **altNsPtrPtr,
Namespace **actualCxtPtrPtr,
char **simpleNamePtr));
CONST char **simpleNamePtr));
EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void));
EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int *seekFlagPtr));
@@ -1830,6 +1854,7 @@ EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
char *fileName, char *modeString,
int permissions));
EXTERN void TclpPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *, format));
EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName,
Tcl_DString *linkPtr));
EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr,
@@ -1876,11 +1901,9 @@ EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_((
EXTERN int TclServiceIdle _ANSI_ARGS_((void));
EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_((
Tcl_Interp *interp, int localIndex,
Tcl_Obj *elemPtr, Tcl_Obj *objPtr,
int leaveErrorMsg));
Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags));
EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp,
int localIndex, Tcl_Obj *objPtr,
int leaveErrorMsg));
int localIndex, Tcl_Obj *objPtr, int flags));
EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char *string));
EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
@@ -2082,6 +2105,8 @@ EXTERN int Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData,
*----------------------------------------------------------------
*/
EXTERN int TclCompileAppendCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp,
@@ -2098,6 +2123,12 @@ EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileLappendCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileLindexCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileLlengthCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileReturnCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp,
@@ -2170,6 +2201,39 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp,
TclIncrObjsFreed(); \
}
#elif defined(PURIFY)
/*
* The PURIFY mode is like the regular mode, but instead of doing block
* Tcl_Obj allocation and keeping a freed list for efficiency, it always
* allocates and frees a single Tcl_Obj so that tools like Purify can
* better track memory leaks
*/
# define TclNewObj(objPtr) \
(objPtr) = (Tcl_Obj *) Tcl_Ckalloc(sizeof(Tcl_Obj)); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TclIncrObjsAllocated();
# define TclDecrRefCount(objPtr) \
if (--(objPtr)->refCount <= 0) { \
if (((objPtr)->bytes != NULL) \
&& ((objPtr)->bytes != tclEmptyStringRep)) { \
ckfree((char *) (objPtr)->bytes); \
} \
if (((objPtr)->typePtr != NULL) \
&& ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
(objPtr)->typePtr->freeIntRepProc(objPtr); \
} \
ckfree((char *) (objPtr)); \
TclIncrObjsFreed(); \
}
#else /* not TCL_MEM_DEBUG */
#ifdef TCL_THREADS
+19 -20
View File
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclIntDecls.h,v 1.21 2000/09/28 06:38:21 hobbs Exp $
* RCS: @(#) $Id: tclIntDecls.h,v 1.21.2.1 2001/05/19 16:12:18 msofer Exp $
*/
#ifndef _TCLINTDECLS
@@ -77,7 +77,7 @@ EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp * interp,
#endif /* __WIN32__ */
/* 10 */
EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp * interp,
Namespace * nsPtr, char * procName,
Namespace * nsPtr, CONST char * procName,
Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr,
Proc ** procPtrPtr));
/* 11 */
@@ -133,7 +133,7 @@ EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
/* 29 */
EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_((
Tcl_Interp * interp, int localIndex,
Tcl_Obj * elemPtr, int leaveErrorMsg));
Tcl_Obj * elemPtr, int flags));
/* Slot 30 is reserved */
/* 31 */
EXTERN char * TclGetExtension _ANSI_ARGS_((char * name));
@@ -148,7 +148,7 @@ EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp * interp,
int * indexPtr));
/* 35 */
EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp,
int localIndex, int leaveErrorMsg));
int localIndex, int flags));
/* 36 */
EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp * interp,
char * str, long * longPtr));
@@ -157,12 +157,12 @@ EXTERN int TclGetLoadedPackages _ANSI_ARGS_((
Tcl_Interp * interp, char * targetName));
/* 38 */
EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_((
Tcl_Interp * interp, char * qualName,
Tcl_Interp * interp, CONST char * qualName,
Namespace * cxtNsPtr, int flags,
Namespace ** nsPtrPtr,
Namespace ** altNsPtrPtr,
Namespace ** actualCxtPtrPtr,
char ** simpleNamePtr));
CONST char ** simpleNamePtr));
/* 39 */
EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void));
/* 40 */
@@ -327,11 +327,10 @@ EXTERN int TclServiceIdle _ANSI_ARGS_((void));
EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_((
Tcl_Interp * interp, int localIndex,
Tcl_Obj * elemPtr, Tcl_Obj * objPtr,
int leaveErrorMsg));
int flags));
/* 100 */
EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp,
int localIndex, Tcl_Obj * objPtr,
int leaveErrorMsg));
int localIndex, Tcl_Obj * objPtr, int flags));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 101 */
EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string));
@@ -379,7 +378,7 @@ EXTERN int Tcl_AppendExportList _ANSI_ARGS_((
Tcl_Obj * objPtr));
/* 113 */
EXTERN Tcl_Namespace * Tcl_CreateNamespace _ANSI_ARGS_((Tcl_Interp * interp,
char * name, ClientData clientData,
CONST char * name, ClientData clientData,
Tcl_NamespaceDeleteProc * deleteProc));
/* 114 */
EXTERN void Tcl_DeleteNamespace _ANSI_ARGS_((
@@ -390,8 +389,8 @@ EXTERN int Tcl_Export _ANSI_ARGS_((Tcl_Interp * interp,
int resetListFirst));
/* 116 */
EXTERN Tcl_Command Tcl_FindCommand _ANSI_ARGS_((Tcl_Interp * interp,
char * name, Tcl_Namespace * contextNsPtr,
int flags));
CONST char * name,
Tcl_Namespace * contextNsPtr, int flags));
/* 117 */
EXTERN Tcl_Namespace * Tcl_FindNamespace _ANSI_ARGS_((Tcl_Interp * interp,
char * name, Tcl_Namespace * contextNsPtr,
@@ -561,7 +560,7 @@ typedef struct TclIntStubs {
#ifdef MAC_TCL
void *reserved9;
#endif /* MAC_TCL */
int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */
int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, CONST char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */
void (*tclDeleteCompiledLocalVars) _ANSI_ARGS_((Interp * iPtr, CallFrame * framePtr)); /* 11 */
void (*tclDeleteVars) _ANSI_ARGS_((Interp * iPtr, Tcl_HashTable * tablePtr)); /* 12 */
int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, GlobTypeData * types)); /* 13 */
@@ -580,16 +579,16 @@ typedef struct TclIntStubs {
void *reserved26;
int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */
Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int leaveErrorMsg)); /* 29 */
Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int flags)); /* 29 */
void *reserved30;
char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */
int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, char * str, CallFrame ** framePtrPtr)); /* 32 */
TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */
int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */
Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int leaveErrorMsg)); /* 35 */
Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int flags)); /* 35 */
int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * longPtr)); /* 36 */
int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */
int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, char ** simpleNamePtr)); /* 38 */
int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, CONST char ** simpleNamePtr)); /* 38 */
TclObjCmdProcType (*tclGetObjInterpProc) _ANSI_ARGS_((void)); /* 39 */
int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * seekFlagPtr)); /* 40 */
Tcl_Command (*tclGetOriginalCommand) _ANSI_ARGS_((Tcl_Command command)); /* 41 */
@@ -650,8 +649,8 @@ typedef struct TclIntStubs {
int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */
void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */
int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */
Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 99 */
Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 100 */
Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int flags)); /* 99 */
Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int flags)); /* 100 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
#endif /* UNIX */
@@ -680,10 +679,10 @@ typedef struct TclIntStubs {
void *reserved110;
void (*tcl_AddInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 111 */
int (*tcl_AppendExportList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, Tcl_Obj * objPtr)); /* 112 */
Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */
Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */
void (*tcl_DeleteNamespace) _ANSI_ARGS_((Tcl_Namespace * nsPtr)); /* 114 */
int (*tcl_Export) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, char * pattern, int resetListFirst)); /* 115 */
Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 116 */
Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 116 */
Tcl_Namespace * (*tcl_FindNamespace) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 117 */
int (*tcl_GetInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_ResolverInfo * resInfo)); /* 118 */
int (*tcl_GetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolverInfo * resInfo)); /* 119 */
+30 -15
View File
@@ -19,7 +19,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclNamesp.c,v 1.20 2001/04/07 02:09:18 msofer Exp $
* RCS: @(#) $Id: tclNamesp.c,v 1.20.2.1 2001/05/19 16:12:18 msofer Exp $
*/
#include "tclInt.h"
@@ -430,7 +430,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
Tcl_Interp *interp; /* Interpreter in which a new namespace
* is being created. Also used for
* error reporting. */
char *name; /* Name for the new namespace. May be a
CONST char *name; /* Name for the new namespace. May be a
* qualified name with names of ancestor
* namespaces separated by "::"s. */
ClientData clientData; /* One-word value to store with
@@ -445,7 +445,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
register Namespace *nsPtr, *ancestorPtr;
Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
char *simpleName;
CONST char *simpleName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer1, buffer2;
int newEntry;
@@ -912,7 +912,8 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
#define INIT_EXPORT_PATTERNS 5
Namespace *nsPtr, *exportNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
char *simplePattern, *patternCpy;
CONST char *simplePattern;
char *patternCpy;
int neededElems, len, i;
/*
@@ -1111,7 +1112,8 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
Interp *iPtr = (Interp *) interp;
Namespace *nsPtr, *importNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
char *simplePattern, *cmdName;
CONST char *simplePattern;
char *cmdName;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Command *cmdPtr, *realCmdPtr;
@@ -1340,7 +1342,8 @@ Tcl_ForgetImport(interp, namespacePtr, pattern)
* imported. */
{
Namespace *nsPtr, *importNsPtr, *dummyPtr, *actualCtxPtr;
char *simplePattern, *cmdName;
CONST char *simplePattern;
char *cmdName;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Command *cmdPtr;
@@ -1610,7 +1613,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr)
Tcl_Interp *interp; /* Interpreter in which to find the
* namespace containing qualName. */
register char *qualName; /* A namespace-qualified name of an
CONST char *qualName; /* A namespace-qualified name of an
* command, variable, or namespace. */
Namespace *cxtNsPtr; /* The namespace in which to start the
* search for qualName's namespace. If NULL
@@ -1642,7 +1645,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
* the :: namespace if TCL_GLOBAL_ONLY was
* specified, or the current namespace if
* cxtNsPtr was NULL. */
char **simpleNamePtr; /* Address where procedure stores the
CONST char **simpleNamePtr; /* Address where procedure stores the
* simple name at end of the qualName, or
* NULL if qualName is "::" or the flag
* FIND_ONLY_NS was specified. */
@@ -1651,8 +1654,8 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
Namespace *nsPtr = cxtNsPtr;
Namespace *altNsPtr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
register char *start, *end;
char *nsName;
CONST char *start, *end;
CONST char *nsName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer;
int len;
@@ -1890,7 +1893,7 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags)
* TCL_LEAVE_ERR_MSG flags. */
{
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
char *dummy;
CONST char *dummy;
/*
* Find the namespace(s) that contain the specified namespace name.
@@ -1934,7 +1937,7 @@ Tcl_Command
Tcl_FindCommand(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* command and to report errors. */
char *name; /* Command's name. If it starts with "::",
CONST char *name; /* Command's name. If it starts with "::",
* will be looked up in global namespace.
* Else, looked up first in contextNsPtr
* (current namespace if contextNsPtr is
@@ -1957,7 +1960,7 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags)
ResolverScheme *resPtr;
Namespace *nsPtr[2], *cxtNsPtr;
char *simpleName;
CONST char *simpleName;
register Tcl_HashEntry *entryPtr;
register Command *cmdPtr;
register int search;
@@ -2088,7 +2091,7 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
Interp *iPtr = (Interp*)interp;
ResolverScheme *resPtr;
Namespace *nsPtr[2], *cxtNsPtr;
char *simpleName;
CONST char *simpleName;
Tcl_HashEntry *entryPtr;
Var *varPtr;
register int search;
@@ -2280,6 +2283,17 @@ TclResetShadowedCmdRefs(interp, newCmdPtr)
hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
if (hPtr != NULL) {
nsPtr->cmdRefEpoch++;
/*
* If the shadowed command was compiled to bytecodes, we
* invalidate all the bytecodes in nsPtr, to force a new
* compilation. We use the resolverEpoch to signal the need
* for a fresh compilation of every bytecode.
*/
if ((((Command *) hPtr)->compileProc) != NULL) {
nsPtr->resolverEpoch++;
}
}
}
@@ -3829,7 +3843,8 @@ SetNsNameFromAny(interp, objPtr)
register Tcl_Obj *objPtr; /* The object to convert. */
{
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
char *name, *dummy;
char *name;
CONST char *dummy;
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
register ResolvedNsName *resNamePtr;
+2 -2
View File
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclParse.c,v 1.14 2000/11/01 22:13:39 hobbs Exp $
* RCS: @(#) $Id: tclParse.c,v 1.14.2.2 2001/05/19 16:12:18 msofer Exp $
*/
#include "tclInt.h"
@@ -860,7 +860,7 @@ EvalObjv(interp, objc, objv, command, length, flags)
for (i = objc-1; i >= 0; i--) {
newObjv[i+1] = objv[i];
}
newObjv[0] = Tcl_NewStringObj("unknown", -1);
newObjv[0] = Tcl_NewStringObj("::unknown", -1);
Tcl_IncrRefCount(newObjv[0]);
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
if (cmdPtr == NULL) {
+47 -3
View File
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclParseExpr.c,v 1.7 2000/05/09 00:00:35 hobbs Exp $
* RCS: @(#) $Id: tclParseExpr.c,v 1.7.2.1 2001/05/19 16:12:18 msofer Exp $
*/
#include "tclInt.h"
@@ -1199,7 +1199,7 @@ ParsePrimaryExpr(infoPtr)
exprTokenPtr->size = infoPtr->size;
exprTokenPtr->numComponents = 1;
break;
case DOLLAR:
/*
* $var variable reference.
@@ -1406,7 +1406,7 @@ ParsePrimaryExpr(infoPtr)
exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start);
exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
break;
default:
goto syntaxError;
}
@@ -1778,6 +1778,50 @@ GetLexeme(infoPtr)
infoPtr->size = (src - infoPtr->start);
infoPtr->next = src;
parsePtr->term = infoPtr->next;
/*
* Check for boolean literals (true, false, yes, no, on, off)
*/
switch (infoPtr->start[0]) {
case 'f':
if (infoPtr->size == 5 &&
strncmp("false", infoPtr->start, 5) == 0) {
infoPtr->lexeme = LITERAL;
return TCL_OK;
}
break;
case 'n':
if (infoPtr->size == 2 &&
strncmp("no", infoPtr->start, 2) == 0) {
infoPtr->lexeme = LITERAL;
return TCL_OK;
}
break;
case 'o':
if (infoPtr->size == 3 &&
strncmp("off", infoPtr->start, 3) == 0) {
infoPtr->lexeme = LITERAL;
return TCL_OK;
} else if (infoPtr->size == 2 &&
strncmp("on", infoPtr->start, 2) == 0) {
infoPtr->lexeme = LITERAL;
return TCL_OK;
}
break;
case 't':
if (infoPtr->size == 4 &&
strncmp("true", infoPtr->start, 4) == 0) {
infoPtr->lexeme = LITERAL;
return TCL_OK;
}
break;
case 'y':
if (infoPtr->size == 3 &&
strncmp("yes", infoPtr->start, 3) == 0) {
infoPtr->lexeme = LITERAL;
return TCL_OK;
}
break;
}
return TCL_OK;
}
infoPtr->lexeme = UNKNOWN;
+4 -3
View File
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclProc.c,v 1.24 2000/05/03 00:14:35 hobbs Exp $
* RCS: @(#) $Id: tclProc.c,v 1.24.2.1 2001/05/19 16:12:18 msofer Exp $
*/
#include "tclInt.h"
@@ -67,7 +67,8 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
{
register Interp *iPtr = (Interp *) interp;
Proc *procPtr;
char *fullName, *procName;
char *fullName;
CONST char *procName;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
Tcl_DString ds;
@@ -175,7 +176,7 @@ int
TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
Tcl_Interp *interp; /* interpreter containing proc */
Namespace *nsPtr; /* namespace containing this proc */
char *procName; /* unqualified name of this proc */
CONST char *procName; /* unqualified name of this proc */
Tcl_Obj *argsPtr; /* description of arguments */
Tcl_Obj *bodyPtr; /* command body */
Proc **procPtrPtr; /* returns: pointer to proc data */
+58 -1
View File
@@ -33,7 +33,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclStringObj.c,v 1.20 2001/04/04 16:07:21 kennykb Exp $ */
* RCS: @(#) $Id: tclStringObj.c,v 1.20.2.1 2001/05/19 16:12:18 msofer Exp $ */
#include "tclInt.h"
@@ -517,6 +517,63 @@ Tcl_GetUnicode(objPtr)
return stringPtr->unicode;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetUnicodeFromObj --
*
* Get the Unicode form of the String object with length. If
* the object is not already a String object, it will be converted
* to one. If the String object does not have a Unicode rep, then
* one is create from the UTF string format.
*
* Results:
* Returns a pointer to the object's internal Unicode string.
*
* Side effects:
* Converts the object to have the String internal rep.
*
*----------------------------------------------------------------------
*/
Tcl_UniChar *
Tcl_GetUnicodeFromObj(objPtr, lengthPtr)
Tcl_Obj *objPtr; /* The object to find the unicode string for. */
int *lengthPtr; /* If non-NULL, the location where the
* string rep's unichar length should be
* stored. If NULL, no length is stored. */
{
String *stringPtr;
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if ((stringPtr->numChars == -1) || (stringPtr->uallocated == 0)) {
/*
* We haven't yet calculated the length, or all of the characters
* in the Utf string are 1 byte chars (so we didn't store the
* unicode str). Since this function must return a unicode string,
* and one has not yet been stored, force the Unicode to be
* calculated and stored now.
*/
FillUnicodeRep(objPtr);
/*
* We need to fetch the pointer again because we have just
* reallocated the structure to make room for the Unicode data.
*/
stringPtr = GET_STRING(objPtr);
}
if (lengthPtr != NULL) {
*lengthPtr = stringPtr->numChars;
}
return stringPtr->unicode;
}
/*
*----------------------------------------------------------------------
*
+2 -1
View File
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclStubInit.c,v 1.48 2001/03/30 23:06:40 andreas_kupries Exp $
* RCS: @(#) $Id: tclStubInit.c,v 1.48.2.1 2001/05/19 16:12:18 msofer Exp $
*/
#include "tclInt.h"
@@ -837,6 +837,7 @@ TclStubs tclStubs = {
Tcl_AttemptDbCkrealloc, /* 431 */
Tcl_AttemptSetObjLength, /* 432 */
Tcl_GetChannelThread, /* 433 */
Tcl_GetUnicodeFromObj, /* 434 */
};
/* !END!: Do not edit above this line. */
+147 -84
View File
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclVar.c,v 1.30 2001/03/24 01:14:11 hobbs Exp $
* RCS: @(#) $Id: tclVar.c,v 1.30.2.1 2001/05/19 16:12:18 msofer Exp $
*/
#include "tclInt.h"
@@ -248,7 +248,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
|| (varFramePtr == NULL)
|| !varFramePtr->isProcCallFrame
|| (strstr(part1, "::") != NULL)) {
char *tail;
CONST char *tail;
/*
* Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable,
@@ -665,7 +665,7 @@ Tcl_GetVar2Ex(interp, part1, part2, flags)
* given by localIndex. If the specified variable doesn't exist, or
* there is a clash in array usage, or an error occurs while executing
* variable traces, then NULL is returned and a message will be left in
* the interpreter's result if leaveErrorMsg is 1.
* the interpreter's result if TCL_LEAVE_ERR_MSG is set in flags.
*
* Side effects:
* The ref count for the returned object is _not_ incremented to
@@ -676,13 +676,13 @@ Tcl_GetVar2Ex(interp, part1, part2, flags)
*/
Tcl_Obj *
TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
TclGetIndexedScalar(interp, localIndex, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
register int localIndex; /* Index of variable in procedure's array
* of local variables. */
int leaveErrorMsg; /* 1 if to leave an error message in
* interpreter's result on an error.
int flags; /* TCL_LEAVE_ERR_MSG if to leave an error
* message in interpreter's result on an error.
* Otherwise no error message is left. */
{
Interp *iPtr = (Interp *) interp;
@@ -736,7 +736,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL,
TCL_TRACE_READS);
if (msg != NULL) {
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, varName, NULL, "read", msg);
}
return NULL;
@@ -749,7 +749,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
*/
if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) {
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarArray(varPtr)) {
msg = isArray;
} else {
@@ -778,7 +778,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
* element. If the specified array or element doesn't exist, or there
* is a clash in array usage, or an error occurs while executing
* variable traces, then NULL is returned and a message will be left in
* the interpreter's result if leaveErrorMsg is 1.
* the interpreter's result if TCL_LEAVE_ERR_MSG is set in flags.
*
* Side effects:
* The ref count for the returned object is _not_ incremented to
@@ -789,15 +789,15 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
*/
Tcl_Obj *
TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
TclGetElementOfIndexedArray(interp, localIndex, elemPtr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
int localIndex; /* Index of array variable in procedure's
* array of local variables. */
Tcl_Obj *elemPtr; /* Points to an object holding the name of
* an element to get in the array. */
int leaveErrorMsg; /* 1 if to leave an error message in
* the interpreter's result on an error.
int flags; /* TCL_LEAVE_ERR_MSG if to leave an error
* message in interpreter's result on an error.
* Otherwise no error message is left. */
{
Interp *iPtr = (Interp *) interp;
@@ -856,7 +856,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
*/
if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) {
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elem, "read", noSuchVar);
}
goto errorReturn;
@@ -894,7 +894,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
TCL_TRACE_READS);
if (msg != NULL) {
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elem, "read", msg);
}
goto errorReturn;
@@ -909,7 +909,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
return varPtr->value.objPtr;
}
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarArray(varPtr)) {
msg = isArray;
} else {
@@ -1190,8 +1190,7 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
Var *arrayPtr;
Tcl_Obj *oldValuePtr;
Tcl_Obj *resultPtr = NULL;
char *bytes;
int length, result;
int result;
varPtr = TclLookupVar(interp, part1, part2, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
@@ -1272,10 +1271,9 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
* We append newValuePtr's bytes but don't change its ref count.
*/
bytes = Tcl_GetStringFromObj(newValuePtr, &length);
if (oldValuePtr == NULL) {
varPtr->value.objPtr = Tcl_NewStringObj(bytes, length);
Tcl_IncrRefCount(varPtr->value.objPtr);
varPtr->value.objPtr = newValuePtr;
Tcl_IncrRefCount(newValuePtr);
} else {
if (Tcl_IsShared(oldValuePtr)) { /* append to copy */
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
@@ -1286,34 +1284,16 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
}
}
} else {
if (flags & TCL_LIST_ELEMENT) { /* set var to list element */
int neededBytes, listFlags;
} else if (newValuePtr != oldValuePtr) {
/*
* In this case we are replacing the value, so we don't need to
* do more than swap the objects.
*/
/*
* We set the variable to the result of converting newValuePtr's
* string rep to a list element. We do not change newValuePtr's
* ref count.
*/
if (oldValuePtr != NULL) {
Tcl_DecrRefCount(oldValuePtr); /* discard old value */
}
bytes = Tcl_GetStringFromObj(newValuePtr, &length);
neededBytes = Tcl_ScanElement(bytes, &listFlags);
oldValuePtr = Tcl_NewObj();
oldValuePtr->bytes = (char *)
ckalloc((unsigned) (neededBytes + 1));
oldValuePtr->length = Tcl_ConvertElement(bytes,
oldValuePtr->bytes, listFlags);
varPtr->value.objPtr = oldValuePtr;
Tcl_IncrRefCount(varPtr->value.objPtr);
} else if (newValuePtr != oldValuePtr) {
varPtr->value.objPtr = newValuePtr;
Tcl_IncrRefCount(newValuePtr); /* var is another ref */
if (oldValuePtr != NULL) {
TclDecrRefCount(oldValuePtr); /* discard old value */
}
varPtr->value.objPtr = newValuePtr;
Tcl_IncrRefCount(newValuePtr); /* var is another ref */
if (oldValuePtr != NULL) {
TclDecrRefCount(oldValuePtr); /* discard old value */
}
}
TclSetVarScalar(varPtr);
@@ -1381,8 +1361,8 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
* variable given by localIndex. If the specified variable doesn't
* exist, or there is a clash in array usage, or an error occurs while
* executing variable traces, then NULL is returned and a message will
* be left in the interpreter's result if leaveErrorMsg is 1. Note
* that the returned object may not be the same one referenced by
* be left in the interpreter's result if flags has TCL_LEAVE_ERR_MSG.
* Note that the returned object may not be the same one referenced by
* newValuePtr; this is because variable traces may modify the
* variable's value.
*
@@ -1401,15 +1381,15 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
*/
Tcl_Obj *
TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
TclSetIndexedScalar(interp, localIndex, newValuePtr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
int localIndex; /* Index of variable in procedure's array
* of local variables. */
Tcl_Obj *newValuePtr; /* New value for variable. */
int leaveErrorMsg; /* 1 if to leave an error message in
* the interpreter's result on an error.
* Otherwise no error message is left. */
int flags; /* Various flags that tell how to set value:
* any of TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
@@ -1465,7 +1445,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
*/
if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarArrayElement(varPtr)) {
VarErrMsg(interp, varName, NULL, "set", danglingElement);
} else {
@@ -1480,19 +1460,62 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
*/
if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, varName, NULL, "set", isArray);
}
return NULL;
}
/*
* Set the variable's new value and discard its old value. We don't
* append with this "set" procedure so the old value isn't needed.
* Set the variable's new value and discard its old value.
*/
oldValuePtr = varPtr->value.objPtr;
if (newValuePtr != oldValuePtr) { /* set new value */
if (flags & TCL_APPEND_VALUE) {
if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
Tcl_DecrRefCount(oldValuePtr); /* discard old value */
varPtr->value.objPtr = NULL;
oldValuePtr = NULL;
}
if (flags & TCL_LIST_ELEMENT) { /* append list element */
if (oldValuePtr == NULL) {
TclNewObj(oldValuePtr);
varPtr->value.objPtr = oldValuePtr;
Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
} else if (Tcl_IsShared(oldValuePtr)) {
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
Tcl_DecrRefCount(oldValuePtr);
oldValuePtr = varPtr->value.objPtr;
Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
}
if (Tcl_ListObjAppendElement(interp, oldValuePtr,
newValuePtr) != TCL_OK) {
return NULL;
}
} else { /* append string */
/*
* We append newValuePtr's bytes but don't change its ref count.
*/
if (oldValuePtr == NULL) {
varPtr->value.objPtr = newValuePtr;
Tcl_IncrRefCount(newValuePtr);
} else {
if (Tcl_IsShared(oldValuePtr)) { /* append to copy */
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
TclDecrRefCount(oldValuePtr);
oldValuePtr = varPtr->value.objPtr;
Tcl_IncrRefCount(oldValuePtr); /* since var is ref */
}
Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
}
}
} else if (newValuePtr != oldValuePtr) { /* set new value */
/*
* In this case we are replacing the value, so we don't need to
* do more than swap the objects.
*/
varPtr->value.objPtr = newValuePtr;
Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */
if (oldValuePtr != NULL) {
@@ -1510,7 +1533,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr,
varName, (char *) NULL, TCL_TRACE_WRITES);
if (msg != NULL) {
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, varName, NULL, "set", msg);
}
goto cleanup;
@@ -1557,7 +1580,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
* element. If the specified array or element doesn't exist, or there
* is a clash in array usage, or an error occurs while executing
* variable traces, then NULL is returned and a message will be left in
* the interpreter's result if leaveErrorMsg is 1. Note that the
* the interpreter's result if flags has TCL_LEAVE_ERR_MSG. Note that the
* returned object may not be the same one referenced by newValuePtr;
* this is because variable traces may modify the variable's value.
*
@@ -1578,8 +1601,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
*/
Tcl_Obj *
TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
leaveErrorMsg)
TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, flags)
Tcl_Interp *interp; /* Command interpreter in which the array is
* to be found. */
int localIndex; /* Index of array variable in procedure's
@@ -1587,9 +1609,9 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
Tcl_Obj *elemPtr; /* Points to an object holding the name of
* an element to set in the array. */
Tcl_Obj *newValuePtr; /* New value for variable. */
int leaveErrorMsg; /* 1 if to leave an error message in
* the interpreter's result on an error.
* Otherwise no error message is left. */
int flags; /* Various flags that tell how to set value:
* any of TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
@@ -1620,7 +1642,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
(unsigned int) varFramePtr);
}
if ((localIndex < 0) || (localIndex >= localCt)) {
fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n",
fprintf(stderr, "\nTclSetIndexedScalar: can't set element of local %i in frame 0x%x with %i locals\n",
localIndex, (unsigned int) varFramePtr, localCt);
panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x",
localIndex, (unsigned int) varFramePtr);
@@ -1637,7 +1659,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
* reference to a variable in an enclosing namespace. Traverse through
* any links until we find the referenced variable.
*/
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
@@ -1651,7 +1673,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
*/
if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarArrayElement(arrayPtr)) {
VarErrMsg(interp, arrayName, elem, "set", danglingElement);
} else {
@@ -1672,11 +1694,11 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
TclClearVarUndefined(arrayPtr);
} else if (!TclIsVarArray(arrayPtr)) {
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elem, "set", needArray);
}
goto errorReturn;
}
}
/*
* Look up the element.
@@ -1700,23 +1722,66 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
*/
if (TclIsVarArray(varPtr)) {
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elem, "set", isArray);
}
goto errorReturn;
}
/*
* Set the variable's new value and discard the old one. We don't
* append with this "set" procedure so the old value isn't needed.
* Set the variable's new value and discard the old one.
*/
oldValuePtr = varPtr->value.objPtr;
if (newValuePtr != oldValuePtr) { /* set new value */
if (flags & TCL_APPEND_VALUE) {
if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
Tcl_DecrRefCount(oldValuePtr); /* discard old value */
varPtr->value.objPtr = NULL;
oldValuePtr = NULL;
}
if (flags & TCL_LIST_ELEMENT) { /* append list element */
if (oldValuePtr == NULL) {
TclNewObj(oldValuePtr);
varPtr->value.objPtr = oldValuePtr;
Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
} else if (Tcl_IsShared(oldValuePtr)) {
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
Tcl_DecrRefCount(oldValuePtr);
oldValuePtr = varPtr->value.objPtr;
Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
}
if (Tcl_ListObjAppendElement(interp, oldValuePtr,
newValuePtr) != TCL_OK) {
return NULL;
}
} else { /* append string */
/*
* We append newValuePtr's bytes but don't change its ref count.
*/
if (oldValuePtr == NULL) {
varPtr->value.objPtr = newValuePtr;
Tcl_IncrRefCount(newValuePtr);
} else {
if (Tcl_IsShared(oldValuePtr)) { /* append to copy */
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
TclDecrRefCount(oldValuePtr);
oldValuePtr = varPtr->value.objPtr;
Tcl_IncrRefCount(oldValuePtr); /* since var is ref */
}
Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
}
}
} else if (newValuePtr != oldValuePtr) { /* set new value */
/*
* In this case we are replacing the value, so we don't need to
* do more than swap the objects.
*/
varPtr->value.objPtr = newValuePtr;
Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */
Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */
if (oldValuePtr != NULL) {
TclDecrRefCount(oldValuePtr); /* discard old value */
TclDecrRefCount(oldValuePtr); /* discard old value */
}
}
TclSetVarScalar(varPtr);
@@ -1731,7 +1796,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
TCL_TRACE_WRITES);
if (msg != NULL) {
if (leaveErrorMsg) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elem, "set", msg);
}
goto errorReturn;
@@ -1894,8 +1959,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount)
long i;
int result;
varValuePtr = TclGetIndexedScalar(interp, localIndex,
/*leaveErrorMsg*/ 1);
varValuePtr = TclGetIndexedScalar(interp, localIndex, TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
@@ -1929,7 +1993,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount)
*/
resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr,
/*leaveErrorMsg*/ 1);
TCL_LEAVE_ERR_MSG);
if (resultPtr == NULL) {
return NULL;
}
@@ -1982,7 +2046,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount)
int result;
varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr,
/*leaveErrorMsg*/ 1);
TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
@@ -2016,8 +2080,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount)
*/
resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr,
varValuePtr,
/*leaveErrorMsg*/ 1);
varValuePtr, TCL_LEAVE_ERR_MSG);
if (resultPtr == NULL) {
return NULL;
}
@@ -3489,7 +3552,7 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags)
CallFrame *savedFramePtr = NULL; /* Init. to avoid compiler warning. */
Tcl_HashTable *tablePtr;
Namespace *nsPtr, *altNsPtr, *dummyNsPtr;
char *tail;
CONST char *tail;
int new;
/*
+20
View File
@@ -0,0 +1,20 @@
# Encoding file: iso8859-15, single-byte
S
003F 0 1
00
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
0030003100320033003400350036003700380039003A003B003C003D003E003F
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
0080008100820083008400850086008700880089008A008B008C008D008E008F
0090009100920093009400950096009700980099009A009B009C009D009E009F
00A000A100A200A320AC00A5016000A7016100A900AA00AB00AC00AD00AE00AF
00B000B100B200B3017D00B500B600B7017E00B900BA00BB01520153017800BF
00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF
00D000D100D200D300D400D500D600D700D800D900DA00DB00DC00DD00DE00DF
00E000E100E200E300E400E500E600E700E800E900EA00EB00EC00ED00EE00EF
00F000F100F200F300F400F500F600F700F800F900FA00FB00FC00FD00FE00FF
+7 -1
View File
@@ -2,7 +2,7 @@
#
# Implementation of the history command.
#
# RCS: @(#) $Id: history.tcl,v 1.4 2000/05/15 21:48:44 ericm Exp $
# RCS: @(#) $Id: history.tcl,v 1.4.2.1 2001/05/19 16:12:19 msofer Exp $
#
# Copyright (c) 1997 Sun Microsystems, Inc.
#
@@ -166,6 +166,12 @@ proc history {args} {
proc tcl::HistAdd {command {exec {}}} {
variable history
# Do not add empty commands to the history
if {[string trim $command] == ""} {
return ""
}
set i [incr history(nextid)]
set history($i) $command
set j [incr history(oldest)]
+5 -4
View File
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.46 2001/04/07 02:10:17 msofer Exp $
# RCS: @(#) $Id: init.tcl,v 1.46.2.1 2001/05/19 16:12:19 msofer Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -501,9 +501,10 @@ proc auto_import {pattern} {
auto_load_index
foreach pattern $patternList {
foreach name [array names auto_index] {
if {[string match $pattern $name] && \
[string equal "" [info commands $name]]} {
foreach name [array names auto_index $pattern] {
if {[string equal "" [info commands $name]]
&& [string equal [namespace qualifiers $pattern] \
[namespace qualifiers $name]]} {
uplevel #0 $auto_index($name)
}
}
+1 -13
View File
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: append.test,v 1.5 2000/04/10 17:18:56 ericm Exp $
# RCS: @(#) $Id: append.test,v 1.5.6.1 2001/05/19 16:12:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -181,15 +181,3 @@ catch {rename check ""}
# cleanup
::tcltest::cleanupTests
return
+258
View File
@@ -0,0 +1,258 @@
# Commands covered: append lappend
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: appendComp.test,v 1.2.2.1 2001/05/19 16:12:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset x}
test append-1.1 {append command} {
catch {unset x}
proc foo {} {append ::x 1 2 abc "long string"}
list [foo] $x
} {{12abclong string} {12abclong string}}
test append-1.2 {append command} {
proc foo {} {
set x ""
list [append x first] [append x second] [append x third] $x
}
foo
} {first firstsecond firstsecondthird firstsecondthird}
test append-1.3 {append command} {
proc foo {} {
set x "abcd"
append x
}
foo
} abcd
test append-2.1 {long appends} {
proc foo {} {
set x ""
for {set i 0} {$i < 1000} {set i [expr $i+1]} {
append x "foobar "
}
set y "foobar"
set y "$y $y $y $y $y $y $y $y $y $y"
set y "$y $y $y $y $y $y $y $y $y $y"
set y "$y $y $y $y $y $y $y $y $y $y "
expr {$x == $y}
}
foo
} 1
test append-3.1 {append errors} {
proc foo {} {append}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "append varName ?value value ...?"}}
test append-3.2 {append errors} {
proc foo {} {
set x ""
append x(0) 44
}
list [catch {foo} msg] $msg
} {1 {can't set "x(0)": variable isn't array}}
test append-3.3 {append errors} {
proc foo {} {
catch {unset x}
append x
}
list [catch {foo} msg] $msg
} {1 {can't read "x": no such variable}}
test append-4.1 {lappend command} {
proc foo {} {
global x
catch {unset x}
lappend x 1 2 abc "long string"
}
list [foo] $x
} {{1 2 abc {long string}} {1 2 abc {long string}}}
test append-4.2 {lappend command} {
proc foo {} {
set x ""
list [lappend x first] [lappend x second] [lappend x third] $x
}
foo
} {first {first second} {first second third} {first second third}}
test append-4.3 {lappend command} {
proc foo {} {
global x
set x old
unset x
lappend x new
}
set result [foo]
rename foo {}
set result
} {new}
test append-4.4 {lappend command} {
proc foo {} {
set x {}
lappend x \{\ abc
}
foo
} {\{\ abc}
test append-4.5 {lappend command} {
proc foo {} {
set x {}
lappend x \{ abc
}
foo
} {\{ abc}
test append-4.6 {lappend command} {
proc foo {} {
set x {1 2 3}
lappend x
}
foo
} {1 2 3}
test append-4.7 {lappend command} {
proc foo {} {
set x "a\{"
lappend x abc
}
foo
} "a\\\{ abc"
test append-4.8 {lappend command} {
proc foo {} {
set x "\\\{"
lappend x abc
}
foo
} "\\{ abc"
test append-4.9 {lappend command} {
proc foo {} {
set x " \{"
list [catch {lappend x abc} msg] $msg
}
foo
} {1 {unmatched open brace in list}}
test append-4.10 {lappend command} {
proc foo {} {
set x " \{"
list [catch {lappend x abc} msg] $msg
}
foo
} {1 {unmatched open brace in list}}
test append-4.11 {lappend command} {
proc foo {} {
set x "\{\{\{"
list [catch {lappend x abc} msg] $msg
}
foo
} {1 {unmatched open brace in list}}
test append-4.12 {lappend command} {
proc foo {} {
set x "x \{\{\{"
list [catch {lappend x abc} msg] $msg
}
foo
} {1 {unmatched open brace in list}}
test append-4.13 {lappend command} {
proc foo {} {
set x "x\{\{\{"
lappend x abc
}
foo
} "x\\\{\\\{\\\{ abc"
test append-4.14 {lappend command} {
proc foo {} {
set x " "
lappend x abc
}
foo
} "abc"
test append-4.15 {lappend command} {
proc foo {} {
set x "\\ "
lappend x abc
}
foo
} "{ } abc"
test append-4.16 {lappend command} {
proc foo {} {
set x "x "
lappend x abc
}
foo
} "x abc"
test append-4.17 {lappend command} {
proc foo {} { lappend x }
foo
} {}
test append-4.18 {lappend command} {
proc foo {} { lappend x {} }
foo
} {{}}
proc check {var size} {
set l [llength $var]
if {$l != $size} {
return "length mismatch: should have been $size, was $l"
}
for {set i 0} {$i < $size} {set i [expr $i+1]} {
set j [lindex $var $i]
if {$j != "item $i"} {
return "element $i should have been \"item $i\", was \"$j\""
}
}
return ok
}
test append-5.1 {long lappends} {
set x ""
for {set i 0} {$i < 300} {set i [expr $i+1]} {
lappend x "item $i"
}
check $x 300
} ok
test append-6.1 {lappend errors} {
proc foo {} {lappend}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "lappend varName ?value value ...?"}}
test append-6.2 {lappend errors} {
proc foo {} {
set x ""
lappend x(0) 44
}
list [catch {foo} msg] $msg
} {1 {can't set "x(0)": variable isn't array}}
test append-7.1 {lappend-created var and error in trace on that var} {
proc bar {} {
global x
catch {rename foo ""}
catch {unset x}
trace variable x w foo
proc foo {} {global x; unset x}
catch {lappend x 1}
proc foo {args} {global x; unset x}
info exists x
set x
lappend x 1
list [info exists x] [catch {set x} msg] $msg
}
bar
} {0 1 {can't read "x": no such variable}}
catch {unset i x result y}
catch {rename foo ""}
catch {rename check ""}
# cleanup
::tcltest::cleanupTests
return
+9
View File
@@ -71,3 +71,12 @@ namespace eval ::buried {
{my proc} mycmd5 args {return "mycmd"}
}
{::buried::my proc} mycmd6 args {return "another"}
# A correctly functioning [auto_import] won't choke when a child
# namespace [namespace import]s from its parent.
#
namespace eval ::parent::child {
namespace import ::parent::*
}
proc ::parent::child::test {} {}
+3 -3
View File
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: autoMkindex.test,v 1.11 2000/04/10 17:18:57 ericm Exp $
# RCS: @(#) $Id: autoMkindex.test,v 1.11.6.1 2001/05/19 16:12:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -70,7 +70,7 @@ test autoMkindex-1.3 {examine tclIndex} {
}
namespace delete tcl_autoMkindex_tmp
set ::result
} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {indented $element} {normal $element} {top $element}"
} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}"
test autoMkindex-2.1 {commands on the autoload path can be imported} {
@@ -138,7 +138,7 @@ test autoMkindex-3.2 {auto_mkindex_parser::command} {
AutoMkindexTestReset
set ::result
} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}"
} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}"
test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} {
+7 -3
View File
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: error.test,v 1.7 2000/04/10 17:18:58 ericm Exp $
# RCS: @(#) $Id: error.test,v 1.7.6.1 2001/05/19 16:12:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -44,9 +44,13 @@ test error-1.2 {simple errors from commands} {
test error-1.3 {simple errors from commands} {
catch {format [string index]} b
set errorInfo
# this used to return '... while executing ...', but
# string index is fully compiled as of 8.4a3
} {wrong # args: should be "string index string charIndex"
while executing
"string index"}
while compiling
"string index"
while compiling
"format [string index]"}
test error-1.4 {simple errors from commands} {
catch {error glorp} b
+2 -2
View File
@@ -2,7 +2,7 @@
#
# This file contains the original set of tests for Tcl's expr command.
# Since the expr command is now compiled, a new set of tests covering
# the new implementation are in the files "parseExpr.test and
# the new implementation are in the files "parseExpr.test" and
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr-old.test,v 1.10 2000/12/14 22:24:48 dgp Exp $
# RCS: @(#) $Id: expr-old.test,v 1.10.2.1 2001/05/19 16:12:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
+15 -1
View File
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr.test,v 1.11 2000/11/24 15:14:01 dkf Exp $
# RCS: @(#) $Id: expr.test,v 1.11.2.1 2001/05/19 16:12:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -753,6 +753,20 @@ test expr-20.7 {handling of compile error in runtime case} {
list [catch {expr + {[error foo]}} msg] $msg
} {1 foo}
# Test for non-numeric boolean literal handling
test expr-21.1 {non-numeric boolean literals} {expr false } false
test expr-21.2 {non-numeric boolean literals} {expr true } true
test expr-21.3 {non-numeric boolean literals} {expr off } off
test expr-21.4 {non-numeric boolean literals} {expr on } on
test expr-21.5 {non-numeric boolean literals} {expr no } no
test expr-21.6 {non-numeric boolean literals} {expr yes } yes
test expr-21.7 {non-numeric boolean literals} {expr !false} 1
test expr-21.8 {non-numeric boolean literals} {expr !true } 0
test expr-21.9 {non-numeric boolean literals} {expr !off } 1
test expr-21.10 {non-numeric boolean literals} {expr !on } 0
test expr-21.11 {non-numeric boolean literals} {expr !no } 1
test expr-21.12 {non-numeric boolean literals} {expr !yes } 0
# cleanup
if {[info exists a]} {
unset a
+4 -4
View File
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fileName.test,v 1.9 2000/09/29 01:12:15 hobbs Exp $
# RCS: @(#) $Id: fileName.test,v 1.9.2.1 2001/05/19 16:12:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1475,13 +1475,13 @@ test filename-16.4 {windows specific globbing} {pcOnly} {
glob c:/
} c:/
test filename-16.5 {windows specific globbing} {pcOnly} {
glob c:*Test
glob c:*bTest
} c:globTest
test filename-16.6 {windows specific globbing} {pcOnly} {
glob c:\\\\*Test
glob c:\\\\*bTest
} c:/globTest
test filename-16.7 {windows specific globbing} {pcOnly} {
glob c:/*Test
glob c:/*bTest
} c:/globTest
test filename-16.8 {windows specific globbing} {pcOnly} {
lsort [glob c:globTest/*.bat]
-243
View File
@@ -1,243 +0,0 @@
# Commands covered: foreach, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: foreach.test,v 1.6 2000/04/10 17:18:59 ericm Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset a}
catch {unset x}
# Basic "foreach" operation.
test foreach-1.1 {basic foreach tests} {
set a {}
foreach i {a b c d} {
set a [concat $a $i]
}
set a
} {a b c d}
test foreach-1.2 {basic foreach tests} {
set a {}
foreach i {a b {{c d} e} {123 {{x}}}} {
set a [concat $a $i]
}
set a
} {a b {c d} e 123 {{x}}}
test foreach-1.3 {basic foreach tests} {catch {foreach} msg} 1
test foreach-1.4 {basic foreach tests} {
catch {foreach} msg
set msg
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
test foreach-1.5 {basic foreach tests} {catch {foreach i} msg} 1
test foreach-1.6 {basic foreach tests} {
catch {foreach i} msg
set msg
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
test foreach-1.7 {basic foreach tests} {catch {foreach i j} msg} 1
test foreach-1.8 {basic foreach tests} {
catch {foreach i j} msg
set msg
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
test foreach-1.9 {basic foreach tests} {catch {foreach i j k l} msg} 1
test foreach-1.10 {basic foreach tests} {
catch {foreach i j k l} msg
set msg
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
test foreach-1.11 {basic foreach tests} {
set a {}
foreach i {} {
set a [concat $a $i]
}
set a
} {}
test foreach-1.12 {foreach errors} {
list [catch {foreach {{a}{b}} {1 2 3} {}} msg] $msg
} {1 {list element in braces followed by "{b}" instead of space}}
test foreach-1.13 {foreach errors} {
list [catch {foreach a {{1 2}3} {}} msg] $msg
} {1 {list element in braces followed by "3" instead of space}}
catch {unset a}
test foreach-1.14 {foreach errors} {
catch {unset a}
set a(0) 44
list [catch {foreach a {1 2 3} {}} msg] $msg
} {1 {couldn't set loop variable: "a"}}
test foreach-1.15 {foreach errors} {
list [catch {foreach {} {} {}} msg] $msg
} {1 {foreach varlist is empty}}
catch {unset a}
test foreach-2.1 {parallel foreach tests} {
set x {}
foreach {a b} {1 2 3 4} {
append x $b $a
}
set x
} {2143}
test foreach-2.2 {parallel foreach tests} {
set x {}
foreach {a b} {1 2 3 4 5} {
append x $b $a
}
set x
} {21435}
test foreach-2.3 {parallel foreach tests} {
set x {}
foreach a {1 2 3} b {4 5 6} {
append x $b $a
}
set x
} {415263}
test foreach-2.4 {parallel foreach tests} {
set x {}
foreach a {1 2 3} b {4 5 6 7 8} {
append x $b $a
}
set x
} {41526378}
test foreach-2.5 {parallel foreach tests} {
set x {}
foreach {a b} {a b A B aa bb} c {c C cc CC} {
append x $a $b $c
}
set x
} {abcABCaabbccCC}
test foreach-2.6 {parallel foreach tests} {
set x {}
foreach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} {
append x $a $b $c $d $e
}
set x
} {111112222233333}
test foreach-2.7 {parallel foreach tests} {
set x {}
foreach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
append x $a $b $c $d $e
}
set x
} {1111 2222334}
test foreach-2.8 {foreach only sets vars if repeating loop} {
proc foo {} {
set rgb {65535 0 0}
foreach {r g b} [set rgb] {}
return "r=$r, g=$g, b=$b"
}
foo
} {r=65535, g=0, b=0}
test foreach-2.9 {foreach only supports local scalar variables} {
proc foo {} {
set x {}
foreach {a(3)} {1 2 3 4} {lappend x [set {a(3)}]}
set x
}
foo
} {1 2 3 4}
test foreach-3.1 {compiled foreach backward jump works correctly} {
catch {unset x}
proc foo {arrayName} {
upvar 1 $arrayName a
set l {}
foreach member [array names a] {
lappend l [list $member [set a($member)]]
}
return $l
}
array set x {0 zero 1 one 2 two 3 three}
lsort [foo x]
} [lsort {{0 zero} {1 one} {2 two} {3 three}}]
test foreach-4.1 {noncompiled foreach and shared variable or value list objects that are converted to another type} {
catch {unset x}
foreach {12.0} {a b c} {
set x 12.0
set x [expr $x + 1]
}
set x
} 13.0
# Check "continue".
test foreach-4.1 {continue tests} {catch continue} 4
test foreach-4.2 {continue tests} {
set a {}
foreach i {a b c d} {
if {[string compare $i "b"] == 0} continue
set a [concat $a $i]
}
set a
} {a c d}
test foreach-4.3 {continue tests} {
set a {}
foreach i {a b c d} {
if {[string compare $i "b"] != 0} continue
set a [concat $a $i]
}
set a
} {b}
test foreach-4.4 {continue tests} {catch {continue foo} msg} 1
test foreach-4.5 {continue tests} {
catch {continue foo} msg
set msg
} {wrong # args: should be "continue"}
# Check "break".
test foreach-5.1 {break tests} {catch break} 3
test foreach-5.2 {break tests} {
set a {}
foreach i {a b c d} {
if {[string compare $i "c"] == 0} break
set a [concat $a $i]
}
set a
} {a b}
test foreach-5.3 {break tests} {catch {break foo} msg} 1
test foreach-5.4 {break tests} {
catch {break foo} msg
set msg
} {wrong # args: should be "break"}
# Test for incorrect "double evaluation" semantics
test foreach-6.1 {delayed substitution of body} {knownBug} {
proc foo {} {
set a 0
foreach a [list 1 2 3] "
set x $a
"
set x
}
foo
} {0}
# cleanup
catch {unset a}
catch {unset x}
::tcltest::cleanupTests
return
+4 -1
View File
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lindex.test,v 1.7 2000/04/10 17:19:01 ericm Exp $
# RCS: @(#) $Id: lindex.test,v 1.7.6.1 2001/05/19 16:12:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -44,6 +44,9 @@ test lindex-1.9 {basic tests} {
test lindex-1.10 {basic tests} {
lindex {a b c d} 3
} d
test lindex-1.11 {Nested list with a backslashed brace} {
lindex {{a \{}} 0
} {a \{}
test lindex-2.1 {error conditions} {
list [catch {lindex msg} msg] $msg
+26 -1
View File
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: namespace.test,v 1.14 2001/04/07 02:12:30 msofer Exp $
# RCS: @(#) $Id: namespace.test,v 1.14.2.2 2001/05/19 16:12:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1125,6 +1125,31 @@ test namespace-39.3 {NamespaceExistsCmd error} {
list [catch {namespace exists a b} msg] $msg
} {1 {wrong # args: should be "namespace exists name"}}
test namespace-40.1 {Ignoring namespace proc "unknown"} {
rename unknown _unknown
proc unknown args {return global}
namespace eval ns {proc unknown args {return local}}
set l [list [namespace eval ns aaa bbb] [namespace eval ns aaa]]
rename unknown {}
rename _unknown unknown
namespace delete ns
set l
} {global global}
test namespace-41.1 {Shadowing byte-compiled commands} {
namespace eval ns {
proc test {} {
set ::g 0
}
lappend ::res [test]
proc set {a b} {
::set a [incr b]
}
lappend ::res [test]
}
set res
} {0 1}
# cleanup
catch {rename cmd1 {}}
catch {unset l}
+4 -1
View File
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: string.test,v 1.28 2001/04/06 10:50:00 dkf Exp $
# RCS: @(#) $Id: string.test,v 1.28.2.1 2001/05/19 16:12:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -197,6 +197,9 @@ test string-4.12 {string first, start index} {
test string-4.13 {string first, start index} {
string first \u7266 abc\u7266x end-2
} 3
test string-4.14 {string first, negative start index} {
string first b abc -1
} 1
test string-5.1 {string index} {
list [catch {string index} msg] $msg
+651
View File
@@ -0,0 +1,651 @@
# Commands covered: string
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# This differs from the original string tests in that the tests call
# things in procs, which uses the compiled string code instead of
# the runtime parse string code. The tests of import should match
# their equivalent number in string.test.
#
# Copyright (c) 2001 by ActiveState Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: stringComp.test,v 1.2.2.1 2001/05/19 16:12:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Some tests require the testobj command
set ::tcltest::testConstraints(testobj) \
[expr {[info commands testobj] != {}}]
test string-1.1 {error conditions} {
proc foo {} {string gorp a b}
list [catch {foo} msg] $msg
} {1 {bad option "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2 {error conditions} {
proc foo {} {string}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}
test string-2.1 {string compare, too few args} {
proc foo {} {string compare a}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.2 {string compare, bad args} {
proc foo {} {string compare a b c}
list [catch {foo} msg] $msg
} {1 {bad option "a": must be -nocase or -length}}
test string-2.3 {string compare, bad args} {
list [catch {string compare -length -nocase str1 str2} msg] $msg
} {1 {expected integer but got "-nocase"}}
test string-2.4 {string compare, too many args} {
list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.5 {string compare with length unspecified} {
list [catch {string compare -length 10 10} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.6 {string compare} {
proc foo {} {string compare abcde abdef}
foo
} -1
test string-2.7 {string compare, shortest method name} {
proc foo {} {string c abcde ABCDE}
foo
} 1
test string-2.8 {string compare} {
proc foo {} {string compare abcde abcde}
foo
} 0
test string-2.9 {string compare with length} {
proc foo {} {string compare -length 2 abcde abxyz}
foo
} 0
test string-2.10 {string compare with special index} {
proc foo {} {string compare -length end-3 abcde abxyz}
list [catch {foo} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-2.11 {string compare, unicode} {
proc foo {} {string compare ab\u7266 ab\u7267}
foo
} -1
test string-2.12 {string compare, high bit} {
# This test will fail if the underlying comparaison
# is using signed chars instead of unsigned chars.
# (like SunOS's default memcmp thus the compat/memcmp.c)
proc foo {} {string compare "\x80" "@"}
foo
# Nb this tests works also in utf8 space because \x80 is
# translated into a 2 or more bytelength but whose first byte has
# the high bit set.
} 1
test string-2.13 {string compare -nocase} {
proc foo {} {string compare -nocase abcde abdef}
foo
} -1
test string-2.14 {string compare -nocase} {
proc foo {} {string c -nocase abcde ABCDE}
foo
} 0
test string-2.15 {string compare -nocase} {
proc foo {} {string compare -nocase abcde abcde}
foo
} 0
test string-2.16 {string compare -nocase with length} {
proc foo {} {string compare -length 2 -nocase abcde Abxyz}
foo
} 0
test string-2.17 {string compare -nocase with length} {
proc foo {} {string compare -nocase -length 3 abcde Abxyz}
foo
} -1
test string-2.18 {string compare -nocase with length <= 0} {
proc foo {} {string compare -nocase -length -1 abcde AbCdEf}
foo
} -1
test string-2.19 {string compare -nocase with excessive length} {
proc foo {} {string compare -nocase -length 50 AbCdEf abcde}
foo
} 1
test string-2.20 {string compare -len unicode} {
# These are strings that are 6 BYTELENGTH long, but the length
# shouldn't make a different because there are actually 3 CHARS long
proc foo {} {string compare -len 5 \334\334\334 \334\334\374}
foo
} -1
test string-2.21 {string compare -nocase with special index} {
proc foo {} {string compare -nocase -length end-3 Abcde abxyz}
list [catch {foo} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-2.22 {string compare, null strings} {
proc foo {} {string compare "" ""}
foo
} 0
test string-2.23 {string compare, null strings} {
proc foo {} {string compare "" foo}
foo
} -1
test string-2.24 {string compare, null strings} {
proc foo {} {string compare foo ""}
foo
} 1
test string-2.25 {string compare -nocase, null strings} {
proc foo {} {string compare -nocase "" ""}
foo
} 0
test string-2.26 {string compare -nocase, null strings} {
proc foo {} {string compare -nocase "" foo}
foo
} -1
test string-2.27 {string compare -nocase, null strings} {
proc foo {} {string compare -nocase foo ""}
foo
} 1
test string-2.28 {string compare with length, unequal strings} {
proc foo {} {string compare -length 2 abc abde}
foo
} 0
test string-2.29 {string compare with length, unequal strings} {
proc foo {} {string compare -length 2 ab abde}
foo
} 0
test string-2.30 {string compare with NUL character vs. other ASCII} {
# Be careful here, since UTF-8 rep comparison with memcmp() of
# these puts chars in the wrong order
proc foo {} {string compare \x00 \x01}
foo
} -1
# only need a few tests on equal, since it uses the same code as
# string compare, but just modifies the return output
test string-3.1 {string equal} {
proc foo {} {string equal abcde abdef}
foo
} 0
test string-3.2 {string equal} {
proc foo {} {string eq abcde ABCDE}
foo
} 0
test string-3.3 {string equal} {
proc foo {} {string equal abcde abcde}
foo
} 1
test string-3.4 {string equal -nocase} {
proc foo {} {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334}
foo
} 1
test string-3.5 {string equal -nocase} {
proc foo {} {string equal -nocase abcde abdef}
foo
} 0
test string-3.6 {string equal -nocase} {
proc foo {} {string eq -nocase abcde ABCDE}
foo
} 1
test string-3.7 {string equal -nocase} {
proc foo {} {string equal -nocase abcde abcde}
foo
} 1
test string-3.8 {string equal with length, unequal strings} {
proc foo {} {string equal -length 2 abc abde}
foo
} 1
test string-4.1 {string first, too few args} {
proc foo {} {string first a}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test string-4.2 {string first, bad args} {
proc foo {} {string first a b c}
list [catch {foo} msg] $msg
} {1 {bad index "c": must be integer or end?-integer?}}
test string-4.3 {string first, too many args} {
proc foo {} {string first a b 5 d}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test string-4.4 {string first} {
proc foo {} {string first bq abcdefgbcefgbqrs}
foo
} 12
test string-4.5 {string first} {
proc foo {} {string fir bcd abcdefgbcefgbqrs}
foo
} 1
test string-4.6 {string first} {
proc foo {} {string f b abcdefgbcefgbqrs}
foo
} 1
test string-4.7 {string first} {
proc foo {} {string first xxx x123xx345xxx789xxx012}
foo
} 9
test string-4.8 {string first} {
proc foo {} {string first "" x123xx345xxx789xxx012}
foo
} -1
test string-4.9 {string first, unicode} {
proc foo {} {string first x abc\u7266x}
foo
} 4
test string-4.10 {string first, unicode} {
proc foo {} {string first \u7266 abc\u7266x}
foo
} 3
test string-4.11 {string first, start index} {
proc foo {} {string first \u7266 abc\u7266x 3}
foo
} 3
test string-4.12 {string first, start index} {
proc foo {} {string first \u7266 abc\u7266x 4}
foo
} -1
test string-4.13 {string first, start index} {
proc foo {} {string first \u7266 abc\u7266x end-2}
foo
} 3
test string-4.14 {string first, negative start index} {
proc foo {} {string first b abc -1}
foo
} 1
test string-5.1 {string index} {
proc foo {} {string index}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.2 {string index} {
proc foo {} {string index a b c}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.3 {string index} {
proc foo {} {string index abcde 0}
foo
} a
test string-5.4 {string index} {
proc foo {} {string in abcde 4}
foo
} e
test string-5.5 {string index} {
proc foo {} {string index abcde 5}
foo
} {}
test string-5.6 {string index} {
proc foo {} {string index abcde -10}
list [catch {foo} msg] $msg
} {0 {}}
test string-5.7 {string index} {
proc foo {} {string index a xyz}
list [catch {foo} msg] $msg
} {1 {bad index "xyz": must be integer or end?-integer?}}
test string-5.8 {string index} {
proc foo {} {string index abc end}
foo
} c
test string-5.9 {string index} {
proc foo {} {string index abc end-1}
foo
} b
test string-5.10 {string index, unicode} {
proc foo {} {string index abc\u7266d 4}
foo
} d
test string-5.11 {string index, unicode} {
proc foo {} {string index abc\u7266d 3}
foo
} \u7266
test string-5.12 {string index, unicode over char length, under byte length} {
proc foo {} {string index \334\374\334\374 6}
foo
} {}
test string-5.13 {string index, bytearray object} {
proc foo {} {string index [binary format a5 fuz] 0}
foo
} f
test string-5.14 {string index, bytearray object} {
proc foo {} {string index [binary format I* {0x50515253 0x52}] 3}
foo
} S
test string-5.15 {string index, bytearray object} {
proc foo {} {
set b [binary format I* {0x50515253 0x52}]
set i1 [string index $b end-6]
set i2 [string index $b 1]
string compare $i1 $i2
}
foo
} 0
test string-5.16 {string index, bytearray object with string obj shimmering} {
proc foo {} {
set str "0123456789\x00 abcdedfghi"
binary scan $str H* dump
string compare [string index $str 10] \x00
}
foo
} 0
test string-5.17 {string index, bad integer} {
proc foo {} {string index "abc" 08}
list [catch {foo} msg] $msg
} {1 {bad index "08": must be integer or end?-integer? (looks like invalid octal number)}}
test string-5.18 {string index, bad integer} {
proc foo {} {string index "abc" end-00289}
list [catch {foo} msg] $msg
} {1 {expected integer but got "-00289" (looks like invalid octal number)}}
test string-5.19 {string index, bytearray object out of bounds} {
proc foo {} {string index [binary format I* {0x50515253 0x52}] -1}
foo
} {}
test string-5.20 {string index, bytearray object out of bounds} {
proc foo {} {string index [binary format I* {0x50515253 0x52}] 20}
foo
} {}
proc largest_int {} {
# This will give us what the largest valid int on this machine is,
# so we can test for overflow properly below on >32 bit systems
set int 1
set exp 7; # assume we get at least 8 bits
while {$int > 0} { set int [expr {1 << [incr exp]}] }
return [expr {$int-1}]
}
## string is
## not yet bc
catch {rename largest_int {}}
## string last
## not yet bc
## string length
## not yet bc
test string-8.1 {string bytelength} {
proc foo {} {string bytelength}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.2 {string bytelength} {
proc foo {} {string bytelength a b}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.3 {string bytelength} {
proc foo {} {string bytelength "\u00c7"}
foo
} 2
test string-8.4 {string bytelength} {
proc foo {} {string b ""}
foo
} 0
## string length
##
test string-9.1 {string length} {
proc foo {} {string length}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string length string"}}
test string-9.2 {string length} {
proc foo {} {string length a b}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string length string"}}
test string-9.3 {string length} {
proc foo {} {string length "a little string"}
foo
} 15
test string-9.4 {string length} {
proc foo {} {string le ""}
foo
} 0
test string-9.5 {string length, unicode} {
proc foo {} {string le "abcd\u7266"}
foo
} 5
test string-9.6 {string length, bytearray object} {
proc foo {} {string length [binary format a5 foo]}
foo
} 5
test string-9.7 {string length, bytearray object} {
proc foo {} {string length [binary format I* {0x50515253 0x52}]}
foo
} 8
## string map
## not yet bc
## string match
##
test string-11.1 {string match, too few args} {
proc foo {} {string match a}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test string-11.2 {string match, too many args} {
proc foo {} {string match a b c d}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test string-11.3 {string match} {
proc foo {} {string match abc abc}
foo
} 1
test string-11.4 {string match} {
proc foo {} {string mat abc abd}
foo
} 0
test string-11.5 {string match} {
proc foo {} {string match ab*c abc}
foo
} 1
test string-11.6 {string match} {
proc foo {} {string match ab**c abc}
foo
} 1
test string-11.7 {string match} {
proc foo {} {string match ab* abcdef}
foo
} 1
test string-11.8 {string match} {
proc foo {} {string match *c abc}
foo
} 1
test string-11.9 {string match} {
proc foo {} {string match *3*6*9 0123456789}
foo
} 1
test string-11.10 {string match} {
proc foo {} {string match *3*6*9 01234567890}
foo
} 0
test string-11.11 {string match} {
proc foo {} {string match a?c abc}
foo
} 1
test string-11.12 {string match} {
proc foo {} {string match a??c abc}
foo
} 0
test string-11.13 {string match} {
proc foo {} {string match ?1??4???8? 0123456789}
foo
} 1
test string-11.14 {string match} {
proc foo {} {string match {[abc]bc} abc}
foo
} 1
test string-11.15 {string match} {
proc foo {} {string match {a[abc]c} abc}
foo
} 1
test string-11.16 {string match} {
proc foo {} {string match {a[xyz]c} abc}
foo
} 0
test string-11.17 {string match} {
proc foo {} {string match {12[2-7]45} 12345}
foo
} 1
test string-11.18 {string match} {
proc foo {} {string match {12[ab2-4cd]45} 12345}
foo
} 1
test string-11.19 {string match} {
proc foo {} {string match {12[ab2-4cd]45} 12b45}
foo
} 1
test string-11.20 {string match} {
proc foo {} {string match {12[ab2-4cd]45} 12d45}
foo
} 1
test string-11.21 {string match} {
proc foo {} {string match {12[ab2-4cd]45} 12145}
foo
} 0
test string-11.22 {string match} {
proc foo {} {string match {12[ab2-4cd]45} 12545}
foo
} 0
test string-11.23 {string match} {
proc foo {} {string match {a\*b} a*b}
foo
} 1
test string-11.24 {string match} {
proc foo {} {string match {a\*b} ab}
foo
} 0
test string-11.25 {string match} {
proc foo {} {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"}
foo
} 1
test string-11.26 {string match} {
proc foo {} {string match ** ""}
foo
} 1
test string-11.27 {string match} {
proc foo {} {string match *. ""}
foo
} 0
test string-11.28 {string match} {
proc foo {} {string match "" ""}
foo
} 1
test string-11.29 {string match} {
proc foo {} {string match \[a a}
foo
} 1
test string-11.30 {string match, bad args} {
proc foo {} {string match - b c}
list [catch {foo} msg] $msg
} {1 {bad option "-": must be -nocase}}
test string-11.31 {string match case} {
proc foo {} {string match a A}
foo
} 0
test string-11.32 {string match nocase} {
proc foo {} {string match -n a A}
foo
} 1
test string-11.33 {string match nocase} {
proc foo {} {string match -nocase a\334 A\374}
foo
} 1
test string-11.34 {string match nocase} {
proc foo {} {string match -nocase a*f ABCDEf}
foo
} 1
test string-11.35 {string match case, false hope} {
# This is true because '_' lies between the A-Z and a-z ranges
proc foo {} {string match {[A-z]} _}
foo
} 1
test string-11.36 {string match nocase range} {
# This is false because although '_' lies between the A-Z and a-z ranges,
# we lower case the end points before checking the ranges.
proc foo {} {string match -nocase {[A-z]} _}
foo
} 0
test string-11.37 {string match nocase} {
proc foo {} {string match -nocase {[A-fh-Z]} g}
foo
} 0
test string-11.38 {string match case, reverse range} {
proc foo {} {string match {[A-fh-Z]} g}
foo
} 1
test string-11.39 {string match, *\ case} {
proc foo {} {string match {*\abc} abc}
foo
} 1
test string-11.40 {string match, *special case} {
proc foo {} {string match {*[ab]} abc}
foo
} 0
test string-11.41 {string match, *special case} {
proc foo {} {string match {*[ab]*} abc}
foo
} 1
test string-11.42 {string match, *special case} {
proc foo {} {string match "*\\" "\\"}
foo
} 0
test string-11.43 {string match, *special case} {
proc foo {} {string match "*\\\\" "\\"}
foo
} 1
test string-11.44 {string match, *special case} {
proc foo {} {string match "*???" "12345"}
foo
} 1
test string-11.45 {string match, *special case} {
proc foo {} {string match "*???" "12"}
foo
} 0
test string-11.46 {string match, *special case} {
proc foo {} {string match "*\\*" "abc*"}
foo
} 1
test string-11.47 {string match, *special case} {
proc foo {} {string match "*\\*" "*"}
foo
} 1
test string-11.48 {string match, *special case} {
proc foo {} {string match "*\\*" "*abc"}
foo
} 0
test string-11.49 {string match, *special case} {
proc foo {} {string match "?\\*" "a*"}
foo
} 1
test string-11.50 {string match, *special case} {
proc foo {} {string match "\\" "\\"}
foo
} 0
## string range
## not yet bc
## string repeat
## not yet bc
## string replace
## not yet bc
## string tolower
## not yet bc
## string toupper
## not yet bc
## string totitle
## not yet bc
## string trim*
## not yet bc
## string word*
## not yet bc
# cleanup
::tcltest::cleanupTests
return
+2 -2
View File
@@ -6,7 +6,7 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.test,v 1.12 2000/10/24 22:30:35 jenn Exp $
# RCS: @(#) $Id: tcltest.test,v 1.12.2.1 2001/05/19 16:12:19 msofer Exp $
set tcltestVersion [package require tcltest]
namespace import -force ::tcltest::*
@@ -982,7 +982,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} {
if {[info exists ::env(TCLTEST_OPTIONS)]} {
set oldoptions $::env(TCLTEST_OPTIONS)
unset ::env(TCLTEST_OPTIONS)
c } else {
} else {
set oldoptions none
}
set ::env(TCLTEST_OPTIONS) {}
+200
View File
@@ -0,0 +1,200 @@
# ISO 8859-15 to Unicode mapping
# (Based on ISO 8859-1 to Unicode mapping in iso8859-1.txt)
#
# Alteration made by Donal K. Fellows <fellowsd@cs.man.ac.uk>
#
# Mappings which are different from ISO 8859-1 have "#8859-1" at the
# end of the line for informative purposes. (Differs for eight
# characters; 0xA4, 0xA6, 0xA8, 0xB4, 0xB8, 0xBC, 0xBD, 0xBE.)
#
0x20 0x0020 # SPACE
0x21 0x0021 # EXCLAMATION MARK
0x22 0x0022 # QUOTATION MARK
0x23 0x0023 # NUMBER SIGN
0x24 0x0024 # DOLLAR SIGN
0x25 0x0025 # PERCENT SIGN
0x26 0x0026 # AMPERSAND
0x27 0x0027 # APOSTROPHE
0x28 0x0028 # LEFT PARENTHESIS
0x29 0x0029 # RIGHT PARENTHESIS
0x2A 0x002A # ASTERISK
0x2B 0x002B # PLUS SIGN
0x2C 0x002C # COMMA
0x2D 0x002D # HYPHEN-MINUS
0x2E 0x002E # FULL STOP
0x2F 0x002F # SOLIDUS
0x30 0x0030 # DIGIT ZERO
0x31 0x0031 # DIGIT ONE
0x32 0x0032 # DIGIT TWO
0x33 0x0033 # DIGIT THREE
0x34 0x0034 # DIGIT FOUR
0x35 0x0035 # DIGIT FIVE
0x36 0x0036 # DIGIT SIX
0x37 0x0037 # DIGIT SEVEN
0x38 0x0038 # DIGIT EIGHT
0x39 0x0039 # DIGIT NINE
0x3A 0x003A # COLON
0x3B 0x003B # SEMICOLON
0x3C 0x003C # LESS-THAN SIGN
0x3D 0x003D # EQUALS SIGN
0x3E 0x003E # GREATER-THAN SIGN
0x3F 0x003F # QUESTION MARK
0x40 0x0040 # COMMERCIAL AT
0x41 0x0041 # LATIN CAPITAL LETTER A
0x42 0x0042 # LATIN CAPITAL LETTER B
0x43 0x0043 # LATIN CAPITAL LETTER C
0x44 0x0044 # LATIN CAPITAL LETTER D
0x45 0x0045 # LATIN CAPITAL LETTER E
0x46 0x0046 # LATIN CAPITAL LETTER F
0x47 0x0047 # LATIN CAPITAL LETTER G
0x48 0x0048 # LATIN CAPITAL LETTER H
0x49 0x0049 # LATIN CAPITAL LETTER I
0x4A 0x004A # LATIN CAPITAL LETTER J
0x4B 0x004B # LATIN CAPITAL LETTER K
0x4C 0x004C # LATIN CAPITAL LETTER L
0x4D 0x004D # LATIN CAPITAL LETTER M
0x4E 0x004E # LATIN CAPITAL LETTER N
0x4F 0x004F # LATIN CAPITAL LETTER O
0x50 0x0050 # LATIN CAPITAL LETTER P
0x51 0x0051 # LATIN CAPITAL LETTER Q
0x52 0x0052 # LATIN CAPITAL LETTER R
0x53 0x0053 # LATIN CAPITAL LETTER S
0x54 0x0054 # LATIN CAPITAL LETTER T
0x55 0x0055 # LATIN CAPITAL LETTER U
0x56 0x0056 # LATIN CAPITAL LETTER V
0x57 0x0057 # LATIN CAPITAL LETTER W
0x58 0x0058 # LATIN CAPITAL LETTER X
0x59 0x0059 # LATIN CAPITAL LETTER Y
0x5A 0x005A # LATIN CAPITAL LETTER Z
0x5B 0x005B # LEFT SQUARE BRACKET
0x5C 0x005C # REVERSE SOLIDUS
0x5D 0x005D # RIGHT SQUARE BRACKET
0x5E 0x005E # CIRCUMFLEX ACCENT
0x5F 0x005F # LOW LINE
0x60 0x0060 # GRAVE ACCENT
0x61 0x0061 # LATIN SMALL LETTER A
0x62 0x0062 # LATIN SMALL LETTER B
0x63 0x0063 # LATIN SMALL LETTER C
0x64 0x0064 # LATIN SMALL LETTER D
0x65 0x0065 # LATIN SMALL LETTER E
0x66 0x0066 # LATIN SMALL LETTER F
0x67 0x0067 # LATIN SMALL LETTER G
0x68 0x0068 # LATIN SMALL LETTER H
0x69 0x0069 # LATIN SMALL LETTER I
0x6A 0x006A # LATIN SMALL LETTER J
0x6B 0x006B # LATIN SMALL LETTER K
0x6C 0x006C # LATIN SMALL LETTER L
0x6D 0x006D # LATIN SMALL LETTER M
0x6E 0x006E # LATIN SMALL LETTER N
0x6F 0x006F # LATIN SMALL LETTER O
0x70 0x0070 # LATIN SMALL LETTER P
0x71 0x0071 # LATIN SMALL LETTER Q
0x72 0x0072 # LATIN SMALL LETTER R
0x73 0x0073 # LATIN SMALL LETTER S
0x74 0x0074 # LATIN SMALL LETTER T
0x75 0x0075 # LATIN SMALL LETTER U
0x76 0x0076 # LATIN SMALL LETTER V
0x77 0x0077 # LATIN SMALL LETTER W
0x78 0x0078 # LATIN SMALL LETTER X
0x79 0x0079 # LATIN SMALL LETTER Y
0x7A 0x007A # LATIN SMALL LETTER Z
0x7B 0x007B # LEFT CURLY BRACKET
0x7C 0x007C # VERTICAL LINE
0x7D 0x007D # RIGHT CURLY BRACKET
0x7E 0x007E # TILDE
0xA0 0x00A0 # NO-BREAK SPACE
0xA1 0x00A1 # INVERTED EXCLAMATION MARK
0xA2 0x00A2 # CENT SIGN
0xA3 0x00A3 # POUND SIGN
0xA4 0x20AC # EURO SIGN #8859-1
0xA5 0x00A5 # YEN SIGN
0xA6 0x0160 # LATIN CAPITAL LETTER S WITH CARON #8859-1
0xA7 0x00A7 # SECTION SIGN
0xA8 0x0161 # LATIN SMALL LETTER S WITH CARON #8859-1
0xA9 0x00A9 # COPYRIGHT SIGN
0xAA 0x00AA # FEMININE ORDINAL INDICATOR
0xAB 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
0xAC 0x00AC # NOT SIGN
0xAD 0x00AD # SOFT HYPHEN
0xAE 0x00AE # REGISTERED SIGN
0xAF 0x00AF # MACRON
0xB0 0x00B0 # DEGREE SIGN
0xB1 0x00B1 # PLUS-MINUS SIGN
0xB2 0x00B2 # SUPERSCRIPT TWO
0xB3 0x00B3 # SUPERSCRIPT THREE
0xB4 0x017D # LATIN CAPITAL LETTER Z WITH CARON #8859-1
0xB5 0x00B5 # MICRO SIGN
0xB6 0x00B6 # PILCROW SIGN
0xB7 0x00B7 # MIDDLE DOT
0xB8 0x017E # LATIN SMALL LETTER Z WITH CARON #8859-1
0xB9 0x00B9 # SUPERSCRIPT ONE
0xBA 0x00BA # MASCULINE ORDINAL INDICATOR
0xBB 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
0xBC 0x0152 # LATIN CAPITAL LIGATURE OE #8859-1
0xBD 0x0153 # LATIN SMALL LIGATURE OE #8859-1
0xBE 0x0178 # LATIN CAPITAL LETTER Y WITH DIAERESIS #8859-1
0xBF 0x00BF # INVERTED QUESTION MARK
0xC0 0x00C0 # LATIN CAPITAL LETTER A WITH GRAVE
0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
0xC3 0x00C3 # LATIN CAPITAL LETTER A WITH TILDE
0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
0xC5 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE
0xC6 0x00C6 # LATIN CAPITAL LETTER AE
0xC7 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA
0xC8 0x00C8 # LATIN CAPITAL LETTER E WITH GRAVE
0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
0xCA 0x00CA # LATIN CAPITAL LETTER E WITH CIRCUMFLEX
0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
0xCC 0x00CC # LATIN CAPITAL LETTER I WITH GRAVE
0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
0xCF 0x00CF # LATIN CAPITAL LETTER I WITH DIAERESIS
0xD0 0x00D0 # LATIN CAPITAL LETTER ETH (Icelandic)
0xD1 0x00D1 # LATIN CAPITAL LETTER N WITH TILDE
0xD2 0x00D2 # LATIN CAPITAL LETTER O WITH GRAVE
0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
0xD5 0x00D5 # LATIN CAPITAL LETTER O WITH TILDE
0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
0xD7 0x00D7 # MULTIPLICATION SIGN
0xD8 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE
0xD9 0x00D9 # LATIN CAPITAL LETTER U WITH GRAVE
0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
0xDB 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
0xDD 0x00DD # LATIN CAPITAL LETTER Y WITH ACUTE
0xDE 0x00DE # LATIN CAPITAL LETTER THORN (Icelandic)
0xDF 0x00DF # LATIN SMALL LETTER SHARP S (German)
0xE0 0x00E0 # LATIN SMALL LETTER A WITH GRAVE
0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
0xE3 0x00E3 # LATIN SMALL LETTER A WITH TILDE
0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
0xE5 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE
0xE6 0x00E6 # LATIN SMALL LETTER AE
0xE7 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA
0xE8 0x00E8 # LATIN SMALL LETTER E WITH GRAVE
0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
0xEA 0x00EA # LATIN SMALL LETTER E WITH CIRCUMFLEX
0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
0xEC 0x00EC # LATIN SMALL LETTER I WITH GRAVE
0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
0xEF 0x00EF # LATIN SMALL LETTER I WITH DIAERESIS
0xF0 0x00F0 # LATIN SMALL LETTER ETH (Icelandic)
0xF1 0x00F1 # LATIN SMALL LETTER N WITH TILDE
0xF2 0x00F2 # LATIN SMALL LETTER O WITH GRAVE
0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
0xF5 0x00F5 # LATIN SMALL LETTER O WITH TILDE
0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
0xF7 0x00F7 # DIVISION SIGN
0xF8 0x00F8 # LATIN SMALL LETTER O WITH STROKE
0xF9 0x00F9 # LATIN SMALL LETTER U WITH GRAVE
0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
0xFB 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
0xFD 0x00FD # LATIN SMALL LETTER Y WITH ACUTE
0xFE 0x00FE # LATIN SMALL LETTER THORN (Icelandic)
0xFF 0x00FF # LATIN SMALL LETTER Y WITH DIAERESIS
+3 -1
View File
@@ -8,7 +8,9 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: genStubs.tcl,v 1.7 1999/06/10 04:29:01 stanton Exp $
# RCS: @(#) $Id: genStubs.tcl,v 1.7.14.1 2001/05/19 16:12:19 msofer Exp $
package require Tcl 8
namespace eval genStubs {
# libraryName --
+5
View File
@@ -1176,6 +1176,11 @@ item: Install File
Destination=%MAINDIR%\lib\tcl%VER%\encoding\jis0201.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-15.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-15.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-9.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-9.enc
+122 -108
View File
@@ -65,7 +65,7 @@ package require Tcl 8.2
# Oct 24, 1997 - moved from 8.0b1 to 8.0 release
#
set Version "0.20"
set Version "0.30"
proc parse_command_line {} {
global argv Version
@@ -223,27 +223,35 @@ proc process-text {text} {
regsub -all {\\-\\\|\\-} $text -- text; # two hyphens
regsub -all -- {\\-\\\^\\-} $text -- text; # two hyphens
regsub -all {\\-} $text - text; # a hyphen
regsub -all "\\\\\n" $text "\\&\#92;\n" text; # backslashed newline
while {[regexp {\\} $text]} {
regsub -all "\\\\\n" $text "\\&#92;\n" text; # backslashed newline
while {[string first "\\" $text] >= 0} {
# C R
if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text {\1<TT>\2</TT>\3} text]} continue
if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text \
{\1<TT>\2</TT>\3} text]} continue
# B R
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text {\1<B>\2</B>\3} text]} continue
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \
{\1<B>\2</B>\3} text]} continue
# B I
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text {\1<B>\2</B>\\fI\3} text]} continue
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \
{\1<B>\2</B>\\fI\3} text]} continue
# I R
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text {\1<I>\2</I>\3} text]} continue
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \
{\1<I>\2</I>\3} text]} continue
# I B
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text {\1<I>\2</I>\\fB\3} text]} continue
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \
{\1<I>\2</I>\\fB\3} text]} continue
# B B, I I, R R
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text {\1\\fB\2\3} ntext]
|| [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text {\1\\fI\2\3} ntext]
|| [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text {\1\\fR\2\3} ntext]} {
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text \
{\1\\fB\2\3} ntext]
|| [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text \
{\1\\fI\2\3} ntext]
|| [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text \
{\1\\fR\2\3} ntext]} {
manerror "process-text: impotent font change: $text"
set text $ntext
continue
}
# unrecognized
# unrecognized
manerror "process-text: uncaught backslash: $text"
set text [string map [list "\\" "#92;"] $text]
}
@@ -272,7 +280,7 @@ proc next-text {} {
error "fatal"
}
proc is-a-directive {line} {
return [expr {[string first . $line] == 0}]
return [string match .* $line]
}
proc split-directive {line opname restname} {
upvar $opname op $restname rest
@@ -317,14 +325,14 @@ proc match-text args {
incr manual(text-pointer)
continue
}
if {[regexp {^@([_a-zA-Z0-9]+)$} $arg all name]} {
if {[regexp {^@(\w+)$} $arg all name]} {
upvar $name var
set var $targ
incr nback
incr manual(text-pointer)
continue
}
if {[regexp {^(\.[a-zA-Z][a-zA-Z])@([_a-zA-Z0-9]+)$} $arg all op name]\
if {[regexp -nocase {^(\.[A-Z][A-Z])@(\w+)$} $arg all op name]\
&& [string equal $op [lindex $targ 0]]} {
upvar $name var
set var [lrange $targ 1 end]
@@ -357,7 +365,8 @@ proc long-toc {text} {
global manual
set here M[incr manual(section-toc-n)]
set there L[incr manual(long-toc-n)]
lappend manual(section-toc) "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$text</A>"
lappend manual(section-toc) \
"<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$text</A>"
return "<A NAME=\"$here\">$text</A>"
}
proc option-toc {name class switch} {
@@ -406,11 +415,7 @@ proc output-widget-options {rest} {
set para {}
while {[next-op-is .OP rest]} {
switch -exact [llength $rest] {
3 {
set switch [lindex $rest 0]
set name [lindex $rest 1]
set class [lindex $rest 2]
}
3 { foreach {switch name class} $rest { break } }
5 {
set switch [lrange $rest 0 2]
set name [lindex $rest 3]
@@ -420,17 +425,17 @@ proc output-widget-options {rest} {
fatal "bad .OP $rest"
}
}
if {![regexp {^(<.>)([-a-zA-Z0-9 ]+)(</.>)$} $switch all oswitch switch cswitch]} {
if {![regexp {^(<.>)([-a-zA-Z0-9 ]+) or ([-a-zA-Z0-9 ]+)(</.>)$} $switch all oswitch switch1 switch2 cswitch]} {
if {![regexp {^(<.>)([-\w ]+)(</.>)$} $switch all oswitch switch cswitch]} {
if {![regexp {^(<.>)([-\w ]+) or ([-\w ]+)(</.>)$} $switch all oswitch switch1 switch2 cswitch]} {
error "not Switch: $switch"
} else {
set switch "$switch1$cswitch or $oswitch$switch2"
}
}
if {![regexp {^(<.>)([a-zA-Z0-9]*)(</.>)$} $name all oname name cname]} {
if {![regexp {^(<.>)([\w]*)(</.>)$} $name all oname name cname]} {
error "not Name: $name"
}
if {![regexp {^(<.>)([a-zA-Z0-9]*)(</.>)$} $class all oclass class cclass]} {
if {![regexp {^(<.>)([\w]*)(</.>)$} $class all oclass class cclass]} {
error "not Class: $class"
}
man-puts "$para<DT>Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch"
@@ -493,7 +498,7 @@ proc output-RS-list {} {
##
proc output-IP-list {context code rest} {
global manual
if {[string equal $rest {}]} {
if {![string length $rest]} {
# blank label, plain indent, no contents entry
man-puts <DL><P><DD>
while {[more-text]} {
@@ -535,7 +540,7 @@ proc output-IP-list {context code rest} {
continue
}
if {[string equal $manual(section) "ARGUMENTS"] || \
[regexp {^\[[0-9]+\]$} $rest]} {
[regexp {^\[\d+\]$} $rest]} {
man-puts "<P><DT>$rest<DD>"
} else {
man-puts "<P><DT>[long-toc $rest]<DD>"
@@ -578,7 +583,7 @@ proc output-IP-list {context code rest} {
incr accept_RE 1
} elseif {[match-text @rest .RE]} {
# gad, this is getting ridiculous
if { ! $accept_RE} {
if {!$accept_RE} {
man-puts "</DL><P>$rest<DL>"
backup-text 1
break
@@ -594,7 +599,7 @@ proc output-IP-list {context code rest} {
}
}
.RE {
if { ! $accept_RE} {
if {!$accept_RE} {
backup-text 1
break
}
@@ -657,7 +662,7 @@ proc cross-reference {ref} {
##
## nothing to reference
##
if { ! [info exists manual(name-$lref)]} {
if {![info exists manual(name-$lref)]} {
foreach name {array file history info interp string trace
after clipboard grab image option pack place selection tk tkwait update winfo wm} {
if {[regexp "^$name \[a-z0-9]*\$" $lref] && \
@@ -688,10 +693,12 @@ proc cross-reference {ref} {
set tcl_ref [lindex $manual(name-$lref) $tcl_i]
set tk_i [lsearch -glob $manual(name-$lref) *TkCmd*]
set tk_ref [lindex $manual(name-$lref) $tk_i]
if {$tcl_i >= 0 && "$manual(wing-file)" == {TclCmd} || "$manual(wing-file)" == {TclLib}} {
if {$tcl_i >= 0 && "$manual(wing-file)" == {TclCmd} \
|| "$manual(wing-file)" == {TclLib}} {
return "<A HREF=\"../$tcl_ref.htm\">$ref</A>"
}
if {$tk_i >= 0 && "$manual(wing-file)" == {TkCmd} || "$manual(wing-file)" == {TkLib}} {
if {$tk_i >= 0 && "$manual(wing-file)" == {TkCmd} \
|| "$manual(wing-file)" == {TkLib}} {
return "<A HREF=\"../$tk_ref.htm\">$ref</A>"
}
if {"$lref" == {exit} && "$manual(tail)" == {tclsh.1} && $tcl_i >= 0} {
@@ -812,7 +819,7 @@ proc insert-cross-references {text} {
##
## if nothing, then we're done.
##
if { ! [info exists offsets]} {
if {![info exists offsets]} {
return $text
}
##
@@ -824,68 +831,92 @@ proc insert-cross-references {text} {
##
switch -exact $invert([lindex $offsets 0]) {
anchor {
if {$offset(end-anchor) < 0} { return [reference-error {Missing end anchor} $text]; }
if {$offset(end-anchor) < 0} {
return [reference-error {Missing end anchor} $text]
}
set head [string range $text 0 $offset(end-anchor)]
set tail [string range $text [expr $offset(end-anchor)+1] end]
set tail [string range $text [expr {$offset(end-anchor)+1}] end]
return $head[insert-cross-references $tail]
}
quote {
if {$offset(end-quote) < 0} { return [reference-error {Missing end quote} $text]; }
if {"$invert([lindex $offsets 1])" == {tk}} { set offsets [lreplace $offsets 1 1]; }
if {"$invert([lindex $offsets 1])" == {tcl}} { set offsets [lreplace $offsets 1 1]; }
if {$offset(end-quote) < 0} {
return [reference-error "Missing end quote" $text]
}
if {$invert([lindex $offsets 1]) == "tk"} {
set offsets [lreplace $offsets 1 1]
}
if {$invert([lindex $offsets 1]) == "tcl"} {
set offsets [lreplace $offsets 1 1]
}
switch -exact $invert([lindex $offsets 1]) {
end-quote {
set head [string range $text 0 [expr $offset(quote)-1]]
set body [string range $text [expr $offset(quote)+2] [expr $offset(end-quote)-1]]
set tail [string range $text [expr $offset(end-quote)+2] end]
return $head``[cross-reference $body]''[insert-cross-references $tail]
set head [string range $text 0 [expr {$offset(quote)-1}]]
set body [string range $text [expr {$offset(quote)+2}] \
[expr {$offset(end-quote)-1}]]
set tail [string range $text \
[expr {$offset(end-quote)+2}] end]
return "$head``[cross-reference $body]''[insert-cross-references $tail]"
}
bold -
anchor {
set head [string range $text 0 [expr $offset(end-quote)+1]]
set tail [string range $text [expr $offset(end-quote)+2] end]
return $head[insert-cross-references $tail]
set head [string range $text \
0 [expr {$offset(end-quote)+1}]]
set tail [string range $text \
[expr {$offset(end-quote)+2}] end]
return "$head[insert-cross-references $tail]"
}
}
return [reference-error {Uncaught quote case} $text]
return [reference-error "Uncaught quote case" $text]
}
bold {
if {$offset(end-bold) < 0} { return $text; }
if {"$invert([lindex $offsets 1])" == {tk}} { set offsets [lreplace $offsets 1 1]; }
if {"$invert([lindex $offsets 1])" == {tcl}} { set offsets [lreplace $offsets 1 1]; }
if {$offset(end-bold) < 0} { return $text }
if {$invert([lindex $offsets 1]) == "tk"} {
set offsets [lreplace $offsets 1 1]
}
if {$invert([lindex $offsets 1]) == "tcl"} {
set offsets [lreplace $offsets 1 1]
}
switch -exact $invert([lindex $offsets 1]) {
end-bold {
set head [string range $text 0 [expr $offset(bold)-1]]
set body [string range $text [expr $offset(bold)+3] [expr $offset(end-bold)-1]]
set tail [string range $text [expr $offset(end-bold)+4] end]
return $head<B>[cross-reference $body]</B>[insert-cross-references $tail]
set head [string range $text 0 [expr {$offset(bold)-1}]]
set body [string range $text [expr {$offset(bold)+3}] \
[expr {$offset(end-bold)-1}]]
set tail [string range $text \
[expr {$offset(end-bold)+4}] end]
return "$head<B>[cross-reference $body]</B>[insert-cross-references $tail]"
}
anchor {
set head [string range $text 0 [expr $offset(end-bold)+3]]
set tail [string range $text [expr $offset(end-bold)+4] end]
return $head[insert-cross-references $tail]
set head [string range $text \
0 [expr {$offset(end-bold)+3}]]
set tail [string range $text \
[expr {$offset(end-bold)+4}] end]
return "$head[insert-cross-references $tail]"
}
}
return [reference-error {Uncaught bold case} $text]
return [reference-error "Uncaught bold case" $text]
}
tk {
set head [string range $text 0 [expr $offset(tk)-1]]
set head [string range $text 0 [expr {$offset(tk)-1}]]
set tail [string range $text $offset(tk) end]
if { ! [regexp {^(Tk_[a-zA-Z0-9_]+)(.*)$} $tail all body tail]} { return [reference-error {Tk regexp failed} $text]; }
if {![regexp {^(Tk_\w+)(.*)$} $tail all body tail]} {
return [reference-error "Tk regexp failed" $text]
}
return $head[cross-reference $body][insert-cross-references $tail]
}
tcl {
set head [string range $text 0 [expr $offset(tcl)-1]]
set head [string range $text 0 [expr {$offset(tcl)-1}]]
set tail [string range $text $offset(tcl) end]
if { ! [regexp {^(Tcl_[a-zA-Z0-9_]+)(.*)$} $tail all body tail]} { return [reference-error {Tcl regexp failed} $text]; }
if {![regexp {^(Tcl_\w+)(.*)$} $tail all body tail]} {
return [reference-error {Tcl regexp failed} $text]
}
return $head[cross-reference $body][insert-cross-references $tail]
}
Tcl1 -
Tcl2 {
set off [lindex $offsets 0]
set head [string range $text 0 [expr $off-1]]
set head [string range $text 0 [expr {$off-1}]]
set body Tcl
set tail [string range $text [expr $off+3] end]
set tail [string range $text [expr {$off+3}] end]
return $head[cross-reference $body][insert-cross-references $tail]
}
end-anchor -
@@ -988,7 +1019,7 @@ proc output-directive {line} {
set nmore {}
foreach cr [split $more ,] {
set cr [string trim $cr]
if { ! [regexp {^<B>.*</B>$} $cr]} {
if {![regexp {^<B>.*</B>$} $cr]} {
set cr <B>$cr</B>
}
if {[regexp {^<B>(.*)\([13n]\)</B>$} $cr all name]} {
@@ -1204,17 +1235,17 @@ proc output-directive {line} {
##
proc merge-copyrights {l1 l2} {
foreach copyright [concat $l1 $l2] {
if {[regexp {^Copyright +\(c\) +([0-9]+) +(by +)?([A-Za-z].*)$} $copyright all date by who]} {
if {[regexp {^Copyright +\(c\) +(\d+) +(by +)?(\w.*)$} $copyright all date by who]} {
lappend dates($who) $date
continue
}
if {[regexp {^Copyright +\(c\) +([0-9]+)-([0-9]+) +(by +)?([A-Za-z].*)$} $copyright all from to by who]} {
if {[regexp {^Copyright +\(c\) +(\d+)-(\d+) +(by +)?(\w.*)$} $copyright all from to by who]} {
for {set date $from} {$date <= $to} {incr date} {
lappend dates($who) $date
}
continue
}
if {[regexp {^Copyright +\(c\) +([0-9]+), *([0-9]+) +(by +)?([A-Za-z].*)$} $copyright all date1 date2 by who]} {
if {[regexp {^Copyright +\(c\) +(\d+), *(\d+) +(by +)?(\w.*)$} $copyright all date1 date2 by who]} {
lappend dates($who) $date1 $date2
continue
}
@@ -1230,18 +1261,14 @@ proc merge-copyrights {l1 l2} {
}
return [lsort $merge]
}
proc makedirhier {dir} {
if { ! [file isdirectory $dir]} {
makedirhier [file dirname $dir]
if { ! [file isdirectory $dir]} {
if {[catch {exec mkdir $dir} error]} {
error "cannot create directory $dir: $error"
}
}
if {![file isdirectory $dir] && \
[catch {file mkdir $dir} error]} {
return -code error "cannot create directory $dir: $error"
}
}
##
## foreach of the man directories specified by args
## convert manpages into hypertext in the directory
@@ -1250,9 +1277,6 @@ proc makedirhier {dir} {
proc make-man-pages {html args} {
global env manual overall_title
makedirhier $html
if { ! [file isdirectory $html]} {
exec mkdir $html
}
set manual(short-toc-n) 1
set manual(short-toc-fp) [open $html/contents.htm w]
puts $manual(short-toc-fp) "<HTML><HEAD><TITLE>$overall_title</TITLE></HEAD>"
@@ -1297,7 +1321,7 @@ proc make-man-pages {html args} {
manerror "discarding $manual(name)"
continue
}
set manual(infp) [open "$manual(page)"]
set manual(infp) [open $manual(page)]
set manual(text) {}
set manual(partial-text) {}
foreach p {.RS .DS .CS .SO} {
@@ -1309,7 +1333,7 @@ proc make-man-pages {html args} {
set manual(section-toc-n) 1
set manual(copyrights) {}
lappend manual(all-pages) $manual(wing-file)/$manual(tail)
manreport 100 "$manual(name)"
manreport 100 $manual(name)
while {[gets $manual(infp) line] >= 0} {
manreport 100 $line
if {[regexp {^[`'][/\\]} $line]} {
@@ -1325,13 +1349,7 @@ proc make-man-pages {html args} {
}
if {[parse-directive $line code rest]} {
switch -exact $code {
.ad -
.na -
.so -
.ne -
.AS -
.VE -
.VS -
.ad - .na - .so - .ne - .AS - .VE - .VS -
. {
# ignore
continue
@@ -1351,16 +1369,11 @@ proc make-man-pages {html args} {
.TH {
lappend manual(text) "$code [unquote $rest]"
}
.HS -
.UL -
.HS - .UL -
.ta {
lappend manual(text) "$code [unquote $rest]"
}
.BS -
.BE -
.br -
.fi -
.sp -
.BS - .BE - .br - .fi - .sp -
.nf {
if {"$rest" != {}} {
manerror "unexpected argument: $line"
@@ -1371,7 +1384,7 @@ proc make-man-pages {html args} {
lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]]
}
.IP {
regexp {^(.*) +[0-9]+$} $rest all rest
regexp {^(.*) +\d+$} $rest all rest
lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]"
}
.TP {
@@ -1382,7 +1395,7 @@ proc make-man-pages {html args} {
}
.OP {
lappend manual(text) [concat .OP [process-text \
"\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]]
"\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]]
}
.PP -
.LP {
@@ -1422,7 +1435,7 @@ proc make-man-pages {html args} {
}
.de {
while {[gets $manual(infp) line] >= 0} {
if {[regexp {^\.\.} $line]} {
if {[string match "..*" $line]} {
break
}
}
@@ -1435,20 +1448,20 @@ proc make-man-pages {html args} {
}
}
} else {
if {"$manual(partial-text)" == {}} {
if {$manual(partial-text) == ""} {
set manual(partial-text) $line
} else {
append manual(partial-text) \n$line
}
}
}
if {"$manual(partial-text)" != {}} {
if {$manual(partial-text) != ""} {
lappend manual(text) [process-text $manual(partial-text)]
}
close $manual(infp)
# fixups
if {$manual(.RS) != 0} {
if {"$manual(name)" != {selection}} {
if {$manual(name) != "selection"} {
puts "unbalanced .RS .RE"
}
}
@@ -1464,7 +1477,8 @@ proc make-man-pages {html args} {
# output conversion
open-text
if {[next-op-is .HS rest]} {
set manual($manual(name)-title) "[lrange $rest 1 end] [lindex $rest 0] manual page"
set manual($manual(name)-title) \
"[lrange $rest 1 end] [lindex $rest 0] manual page"
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
@@ -1513,18 +1527,19 @@ proc make-man-pages {html args} {
set width [string length $name]
}
}
set perline [expr 120 / $width]
set nrows [expr ([llength $manual(wing-toc)]+$perline)/$perline]
set perline [expr {120 / $width}]
set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}]
set n 0
catch {unset rows}
foreach name [lsort $manual(wing-toc)] {
set tail $manual(name-$name)
if {[llength $tail] > 1} {
manerror "$name is defined in more than one file: $tail"
set tail [lindex $tail [expr [llength $tail]-1]]
set tail [lindex $tail [expr {[llength $tail]-1}]]
}
set tail [file tail $tail]
append rows([expr $n%$nrows]) "<td> <a href=\"$tail.htm\">$name</a>"
append rows([expr {$n%$nrows}]) \
"<td> <a href=\"$tail.htm\">$name</a>"
incr n
}
puts $manual(wing-toc-fp) <table>
@@ -1552,7 +1567,7 @@ proc make-man-pages {html args} {
proc strcasecmp {a b} { return [string compare -nocase $a $b] }
set keys [lsort -command strcasecmp [array names manual keyword-*]]
makedirhier $html/Keywords
catch {eval exec rm -f [glob $html/Keywords/*]}
catch {eval file delete -- [glob $html/Keywords/*]}
puts $manual(short-toc-fp) {<DT><A HREF="Keywords/contents.htm">Keywords</A><DD>The keywords from the Tcl/Tk man pages.}
set keyfp [open $html/Keywords/contents.htm w]
puts $keyfp "<HTML><HEAD><TITLE>Tcl/Tk Keywords</TITLE></HEAD>"
@@ -1672,4 +1687,3 @@ if {1} {
puts $error\n$errorInfo
}
}
+7 -4
View File
@@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.73 2001/04/06 23:29:17 andreas_kupries Exp $
# RCS: @(#) $Id: Makefile.in,v 1.72.2.1 2001/05/19 16:12:19 msofer Exp $
VERSION = @TCL_VERSION@
@@ -89,6 +89,9 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
CFLAGS = @CFLAGS@
# Flags to pass to the linker
LDFLAGS = @LDFLAGS@
# To disable ANSI-C procedure prototypes reverse the comment characters
# on the following lines:
PROTO_FLAGS =
@@ -133,7 +136,7 @@ MEM_DEBUG_FLAGS =
#MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG
# To enable support for stubs in Tcl.
STUB_LIB_FILE = @STUB_LIB_FILE@
STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
#TCL_STUB_LIB_FILE = libtclstub.a
@@ -429,11 +432,11 @@ objs: ${OBJS}
tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE}
${CC} @LDFLAGS@ ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
${CC} ${LDFLAGS} ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
@TCL_LD_SEARCH_FLAGS@ -o tclsh
tcltest: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${BUILD_DLTEST}
${CC} @LDFLAGS@ ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
${CC} ${LDFLAGS} ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
@TCL_LD_SEARCH_FLAGS@ -o tcltest
+343 -271
View File
File diff suppressed because it is too large Load Diff
+7 -11
View File
@@ -3,7 +3,7 @@ dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
AC_INIT(../generic/tcl.h)
# RCS: @(#) $Id: configure.in,v 1.64 2001/04/02 01:59:26 hobbs Exp $
# RCS: @(#) $Id: configure.in,v 1.64.2.1 2001/05/19 16:12:20 msofer Exp $
TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
@@ -377,9 +377,9 @@ if test "${SHARED_BUILD}" = "1" -a "${SHLIB_SUFFIX}" != "" ; then
TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}"
eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}"
if test "x$DL_OBJS" = "xtclLoadAout.o"; then
MAKE_LIB="ar cr \${TCL_LIB_FILE} \${OBJS}"
MAKE_LIB="ar cr \[$]@ \${OBJS}"
else
MAKE_LIB="\${SHLIB_LD} -o \${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}"
MAKE_LIB="\${SHLIB_LD} -o \[$]@ \${OBJS} ${SHLIB_LD_LIBS}"
RANLIB=":"
fi
else
@@ -397,7 +397,7 @@ else
TCL_SHLIB_CFLAGS=""
TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}"
eval "TCL_LIB_FILE=libtcl${TCL_UNSHARED_LIB_SUFFIX}"
MAKE_LIB="ar cr \${TCL_LIB_FILE} \${OBJS}"
MAKE_LIB="ar cr \[$]@ \${OBJS}"
fi
# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
@@ -460,13 +460,11 @@ fi
#--------------------------------------------------------------------
# Replace ${VERSION} with contents of ${TCL_VERSION}
eval "STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
# Replace DBGX with TCL_DBGX
eval "STUB_LIB_FILE=\"${STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
MAKE_STUB_LIB="ar cr \${STUB_LIB_FILE} \${STUB_LIB_OBJS}"
TCL_STUB_LIB_FILE=${STUB_LIB_FILE}
MAKE_STUB_LIB="ar cr \[$]@ \${STUB_LIB_OBJS}"
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}"
@@ -485,8 +483,6 @@ TCL_STUB_LIB_PATH="${exec_prefix}/lib/${TCL_STUB_LIB_FILE}"
TCL_SHARED_BUILD=${SHARED_BUILD}
AC_SUBST(STUB_LIB_FILE)
AC_SUBST(TCL_STUB_LIB_FILE)
AC_SUBST(TCL_STUB_LIB_FLAG)
AC_SUBST(TCL_BUILD_STUB_LIB_SPEC)
+20 -4
View File
@@ -369,6 +369,7 @@ AC_DEFUN(SC_ENABLE_THREADS, [
TCL_THREADS=0
AC_MSG_RESULT([no (default)])
fi
AC_SUBST(TCL_THREADS)
])
#------------------------------------------------------------------------
@@ -391,8 +392,8 @@ AC_DEFUN(SC_ENABLE_THREADS, [
# --enable-symbols
#
# Defines the following vars:
# CFLAGS_DEFAULT Sets to CFLAGS_DEBUG if true
# Sets to CFLAGS_OPTIMIZE if false
# CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true
# Sets to $(CFLAGS_OPTIMIZE) if false
# LDFLAGS_DEFAULT Sets to LDFLAGS_DEBUG if true
# Sets to LDFLAGS_OPTIMIZE if false
# DBGX Debug library extension
@@ -402,13 +403,14 @@ AC_DEFUN(SC_ENABLE_THREADS, [
AC_DEFUN(SC_ENABLE_SYMBOLS, [
AC_MSG_CHECKING([for build with symbols])
AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no])
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "yes"; then
CFLAGS_DEFAULT="${CFLAGS_DEBUG}"
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}"
DBGX=g
AC_MSG_RESULT([yes])
else
CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE}"
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}"
DBGX=""
AC_MSG_RESULT([no])
@@ -986,6 +988,12 @@ AC_DEFUN(SC_CONFIG_CFLAGS, [
TCL_LIB_VERSIONS_OK=nodots
;;
SunOS-5.[[0-6]]*)
# Note: If _REENTRANT isn't defined, then Solaris
# won't define thread-safe library routines.
AC_DEFINE(_REENTRANT)
SHLIB_CFLAGS="-KPIC"
SHLIB_LD="/usr/ccs/bin/ld -G -z text"
@@ -1000,6 +1008,12 @@ AC_DEFUN(SC_CONFIG_CFLAGS, [
LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
;;
SunOS-5*)
# Note: If _REENTRANT isn't defined, then Solaris
# won't define thread-safe library routines.
AC_DEFINE(_REENTRANT)
SHLIB_CFLAGS="-KPIC"
SHLIB_LD="/usr/ccs/bin/ld -G -z text"
LDFLAGS=""
@@ -1623,6 +1637,8 @@ AC_DEFUN(SC_TIME_HANDLER, [
AC_HEADER_TIME
AC_STRUCT_TIMEZONE
AC_CHECK_FUNCS(gmtime_r localtime_r)
AC_MSG_CHECKING([tm_tzadj in struct tm])
AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_tzadj;],
[AC_DEFINE(HAVE_TM_TZADJ)
+4 -1
View File
@@ -9,7 +9,7 @@
#
# The information in this file is specific to a single platform.
#
# RCS: @(#) $Id: tclConfig.sh.in,v 1.14 2000/06/20 21:30:34 ericm Exp $
# RCS: @(#) $Id: tclConfig.sh.in,v 1.14.2.1 2001/05/19 16:12:20 msofer Exp $
# Tcl's version number.
TCL_VERSION='@TCL_VERSION@'
@@ -170,3 +170,6 @@ TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@'
# Path to the Tcl stub library in the install directory.
TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@'
# Flag, 1: we built Tcl with threads enables, 0 we didn't
TCL_THREADS=@TCL_THREADS@
+4 -2
View File
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclLoadShl.c,v 1.3 1999/04/16 00:48:04 stanton Exp $
* RCS: @(#) $Id: tclLoadShl.c,v 1.3.16.1 2001/05/19 16:12:20 msofer Exp $
*/
#include <dl.h>
@@ -73,7 +73,9 @@ TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
* when they are build."
*/
handle = shl_load(fileName, BIND_DEFERRED|BIND_VERBOSE, 0L);
handle = shl_load(fileName,
BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH,
0L);
if (handle == NULL) {
Tcl_AppendResult(interp, "couldn't load file \"", fileName,
"\": ", Tcl_PosixError(interp), (char *) NULL);
+15 -11
View File
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclUnixPipe.c,v 1.11 2001/03/29 19:45:20 hobbs Exp $
* RCS: @(#) $Id: tclUnixPipe.c,v 1.11.2.1 2001/05/19 16:12:20 msofer Exp $
*/
#include "tclInt.h"
@@ -67,16 +67,20 @@ static int SetupStdFile _ANSI_ARGS_((TclFile file, int type));
*/
static Tcl_ChannelType pipeChannelType = {
"pipe", /* Type name. */
PipeBlockModeProc, /* Set blocking/nonblocking mode.*/
PipeCloseProc, /* Close proc. */
PipeInputProc, /* Input proc. */
PipeOutputProc, /* Output proc. */
NULL, /* Seek proc. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
PipeWatchProc, /* Initialize notifier. */
PipeGetHandleProc, /* Get OS handles out of channel. */
"pipe", /* Type name. */
TCL_CHANNEL_VERSION_2, /* v2 channel */
PipeCloseProc, /* Close proc. */
PipeInputProc, /* Input proc. */
PipeOutputProc, /* Output proc. */
NULL, /* Seek proc. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
PipeWatchProc, /* Initialize notifier. */
PipeGetHandleProc, /* Get OS handles out of channel. */
NULL, /* close2proc. */
PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
};
/*
+114 -6
View File
@@ -9,13 +9,37 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclUnixTime.c,v 1.7 2000/01/14 22:15:52 ericm Exp $
* RCS: @(#) $Id: tclUnixTime.c,v 1.7.6.1 2001/05/19 16:12:20 msofer Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#define TM_YEAR_BASE 1900
#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0))
/*
* TclpGetDate is coded to return a pointer to a 'struct tm'. For
* thread safety, this structure must be in thread-specific data.
* The 'tmKey' variable is the key to this buffer.
*/
Tcl_ThreadDataKey tmKey;
/*
* If we fall back on the thread-unsafe versions of gmtime and localtime,
* use this mutex to try to protect them.
*/
#if !defined(HAVE_GMTIME_R) || !defined(HAVE_LOCALTIME_R)
TCL_DECLARE_MUTEX( tmMutex )
#endif
/*
* Forward declarations for procedures defined later in this file.
*/
static struct tm *ThreadSafeGMTime _ANSI_ARGS_(( CONST time_t* ));
static struct tm *ThreadSafeLocalTime _ANSI_ARGS_(( CONST time_t* ));
/*
*-----------------------------------------------------------------------------
@@ -115,7 +139,7 @@ TclpGetTimeZone (currentTime)
#if defined(HAVE_TM_TZADJ)
# define TCL_GOT_TIMEZONE
time_t curTime = (time_t) currentTime;
struct tm *timeDataPtr = localtime(&curTime);
struct tm *timeDataPtr = ThreadSafeLocalTime(&curTime);
int timeZone;
timeZone = timeDataPtr->tm_tzadj / 60;
@@ -129,7 +153,7 @@ TclpGetTimeZone (currentTime)
#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE)
# define TCL_GOT_TIMEZONE
time_t curTime = (time_t) currentTime;
struct tm *timeDataPtr = localtime(&curTime);
struct tm *timeDataPtr = ThreadSafeLocalTime(&curTime);
int timeZone;
timeZone = -(timeDataPtr->tm_gmtoff / 60);
@@ -152,7 +176,7 @@ TclpGetTimeZone (currentTime)
time_t tt;
struct tm *stm;
tt = 849268800L; /* 1996-11-29 12:00:00 GMT */
stm = localtime(&tt); /* eg 1996-11-29 6:00:00 CST6CDT */
stm = ThreadSafeLocalTime(&tt); /* eg 1996-11-29 6:00:00 CST6CDT */
/* The calculation below assumes a max of +12 or -12 hours from GMT */
timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min);
return timeZone; /* eg +360 for CST6CDT */
@@ -268,9 +292,9 @@ TclpGetDate(time, useGMT)
CONST time_t *tp = (CONST time_t *)time;
if (useGMT) {
return gmtime(tp);
return ThreadSafeGMTime(tp);
} else {
return localtime(tp);
return ThreadSafeLocalTime(tp);
}
}
@@ -308,3 +332,87 @@ TclpStrftime(s, maxsize, format, t)
}
return strftime(s, maxsize, format, t);
}
/*
*----------------------------------------------------------------------
*
* ThreadSafeGMTime --
*
* Wrapper around the 'gmtime' library function to make it thread
* safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
*
* Side effects:
* Invokes gmtime or gmtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
static struct tm *
ThreadSafeGMTime( timePtr )
CONST time_t *timePtr; /* Pointer to the number of seconds
* since the local system's epoch
*/
{
/*
* Get a thread-local buffer to hold the returned time.
*/
struct tm * tmPtr = (struct tm*) Tcl_GetThreadData( &tmKey,
sizeof( struct tm ) );
#ifdef HAVE_GMTIME_R
gmtime_r( timePtr, tmPtr );
#else
Tcl_MutexLock( & tmMutex );
memcpy( (VOID *) tmPtr, (VOID *) gmtime( timePtr ), sizeof ( struct tm ) );
Tcl_MutexUnlock( &tmMutex );
#endif
return tmPtr;
}
/*
*----------------------------------------------------------------------
*
* ThreadSafeLocalTime --
*
* Wrapper around the 'localtime' library function to make it thread
* safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
*
* Side effects:
* Invokes localtime or localtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
static struct tm *
ThreadSafeLocalTime( timePtr )
CONST time_t *timePtr; /* Pointer to the number of seconds
* since the local system's epoch
*/
{
/*
* Get a thread-local buffer to hold the returned time.
*/
struct tm * tmPtr = (struct tm*) Tcl_GetThreadData( &tmKey,
sizeof( struct tm ) );
#ifdef HAVE_LOCALTIME_R
localtime_r( timePtr, tmPtr );
#else
Tcl_MutexLock( & tmMutex );
memcpy( (VOID *) (tmPtr),
(VOID *) ( localtime( timePtr ) ),
sizeof (struct tm) );
Tcl_MutexUnlock( &tmMutex );
#endif
return tmPtr;
}
+8 -8
View File
@@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.43 2001/03/30 23:45:59 hobbs Exp $
# RCS: @(#) $Id: Makefile.in,v 1.43.2.1 2001/05/19 16:12:20 msofer Exp $
VERSION = @TCL_VERSION@
@@ -80,6 +80,13 @@ CFLAGS_WARNING = @CFLAGS_WARNING@
CFLAGS_DEBUG = @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
# To change the compiler switches, for example to change from optimization to
# debugging symbols, change the following line:
#CFLAGS = $(CFLAGS_DEBUG)
#CFLAGS = $(CFLAGS_OPTIMIZE)
#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
CFLAGS = @CFLAGS@
# To enable compilation debugging reverse the comment characters on
# one of the following lines.
COMPILE_DEBUG_FLAGS =
@@ -90,13 +97,6 @@ COMPILE_DEBUG_FLAGS =
LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
# To change the compiler switches, for example to change from optimization to
# debugging symbols, change the following line:
#CFLAGS = $(CFLAGS_DEBUG)
#CFLAGS = $(CFLAGS_OPTIMIZE)
#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
CFLAGS = @CFLAGS@
# Special compiler flags to use when building man2tcl on Windows.
MAN2TCLFLAGS = @MAN2TCLFLAGS@
+34 -35
View File
@@ -776,15 +776,12 @@ fi
# autoconf 2.50. You can also just set
# the CC, AR, RANLIB, and RC environment
# variables if you want to cross compile.
#AC_CHECK_TOOL(AR, ar, :)
#AC_CHECK_TOOL(RANLIB, ranlib, :)
#AC_CHECK_TOOL(RC, windres, :)
if test "${GCC}" = "yes" ; then
# Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:788: checking for $ac_word" >&5
echo "configure:785: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_AR'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -813,7 +810,7 @@ fi
# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:817: checking for $ac_word" >&5
echo "configure:814: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -842,7 +839,7 @@ fi
# Extract the first word of "windres", so it can be a program name with args.
set dummy windres; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:846: checking for $ac_word" >&5
echo "configure:843: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -875,7 +872,7 @@ fi
#--------------------------------------------------------------------
echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
echo "configure:879: checking whether ${MAKE-make} sets \${MAKE}" >&5
echo "configure:876: checking whether ${MAKE-make} sets \${MAKE}" >&5
set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@@ -907,12 +904,12 @@ fi
#--------------------------------------------------------------------
echo $ac_n "checking for Cygwin environment""... $ac_c" 1>&6
echo "configure:911: checking for Cygwin environment" >&5
echo "configure:908: checking for Cygwin environment" >&5
if eval "test \"`echo '$''{'ac_cv_cygwin'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 916 "configure"
#line 913 "configure"
#include "confdefs.h"
int main() {
@@ -923,7 +920,7 @@ int main() {
return __CYGWIN__;
; return 0; }
EOF
if { (eval echo configure:927: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
if { (eval echo configure:924: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_cygwin=yes
else
@@ -945,13 +942,13 @@ test "$ac_cv_cygwin" = yes && CYGWIN=yes
#--------------------------------------------------------------------
echo $ac_n "checking for object suffix""... $ac_c" 1>&6
echo "configure:949: checking for object suffix" >&5
echo "configure:946: checking for object suffix" >&5
if eval "test \"`echo '$''{'ac_cv_objext'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
rm -f conftest*
echo 'int i = 1;' > conftest.$ac_ext
if { (eval echo configure:955: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
if { (eval echo configure:952: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
for ac_file in conftest.*; do
case $ac_file in
*.c) ;;
@@ -969,19 +966,19 @@ OBJEXT=$ac_cv_objext
ac_objext=$ac_cv_objext
echo $ac_n "checking for mingw32 environment""... $ac_c" 1>&6
echo "configure:973: checking for mingw32 environment" >&5
echo "configure:970: checking for mingw32 environment" >&5
if eval "test \"`echo '$''{'ac_cv_mingw32'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 978 "configure"
#line 975 "configure"
#include "confdefs.h"
int main() {
return __MINGW32__;
; return 0; }
EOF
if { (eval echo configure:985: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
if { (eval echo configure:982: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_mingw32=yes
else
@@ -1000,7 +997,7 @@ test "$ac_cv_mingw32" = yes && MINGW32=yes
echo $ac_n "checking for executable suffix""... $ac_c" 1>&6
echo "configure:1004: checking for executable suffix" >&5
echo "configure:1001: checking for executable suffix" >&5
if eval "test \"`echo '$''{'ac_cv_exeext'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@@ -1010,7 +1007,7 @@ else
rm -f conftest*
echo 'int main () { return 0; }' > conftest.$ac_ext
ac_cv_exeext=
if { (eval echo configure:1014: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
if { (eval echo configure:1011: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
for file in conftest.*; do
case $file in
*.c | *.o | *.obj) ;;
@@ -1037,7 +1034,7 @@ ac_exeext=$EXEEXT
echo $ac_n "checking for building with threads""... $ac_c" 1>&6
echo "configure:1041: checking for building with threads" >&5
echo "configure:1038: checking for building with threads" >&5
# Check whether --enable-threads or --disable-threads was given.
if test "${enable_threads+set}" = set; then
enableval="$enable_threads"
@@ -1058,6 +1055,7 @@ EOF
TCL_THREADS=0
echo "$ac_t""no (default)" 1>&6
fi
#--------------------------------------------------------------------
@@ -1067,7 +1065,7 @@ EOF
echo $ac_n "checking how to build libraries""... $ac_c" 1>&6
echo "configure:1071: checking how to build libraries" >&5
echo "configure:1069: checking how to build libraries" >&5
# Check whether --enable-shared or --disable-shared was given.
if test "${enable_shared+set}" = set; then
enableval="$enable_shared"
@@ -1108,7 +1106,7 @@ EOF
# Step 0: Enable 64 bit support?
echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
echo "configure:1112: checking if 64bit support is requested" >&5
echo "configure:1110: checking if 64bit support is requested" >&5
# Check whether --enable-64bit or --disable-64bit was given.
if test "${enable_64bit+set}" = set; then
enableval="$enable_64bit"
@@ -1120,7 +1118,7 @@ fi
echo "$ac_t""$do64bit" 1>&6
echo $ac_n "checking compiler flags""... $ac_c" 1>&6
echo "configure:1124: checking compiler flags" >&5
echo "configure:1122: checking compiler flags" >&5
# Set some defaults (may get changed below)
EXTRA_CFLAGS=""
@@ -1191,7 +1189,7 @@ echo "configure:1124: checking compiler flags" >&5
fi
echo $ac_n "checking whether $ld_prog supports -shared option""... $ac_c" 1>&6
echo "configure:1195: checking whether $ld_prog supports -shared option" >&5
echo "configure:1193: checking whether $ld_prog supports -shared option" >&5
# now the ad-hoc check to see if GNU ld supports --shared.
if "$LD" --shared 2>&1 | egrep ': -shared not supported' >/dev/null; then
@@ -1302,7 +1300,7 @@ echo "configure:1195: checking whether $ld_prog supports -shared option" >&5
echo $ac_n "checking for build with symbols""... $ac_c" 1>&6
echo "configure:1306: checking for build with symbols" >&5
echo "configure:1304: checking for build with symbols" >&5
# Check whether --enable-symbols or --disable-symbols was given.
if test "${enable_symbols+set}" = set; then
enableval="$enable_symbols"
@@ -1313,12 +1311,12 @@ fi
if test "$tcl_ok" = "yes"; then
CFLAGS_DEFAULT="${CFLAGS_DEBUG}"
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}"
DBGX=d
echo "$ac_t""yes" 1>&6
else
CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE}"
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}"
DBGX=""
echo "$ac_t""no" 1>&6
@@ -1334,7 +1332,7 @@ TCL_DBGX=${DBGX}
#--------------------------------------------------------------------
echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
echo "configure:1338: checking how to run the C preprocessor" >&5
echo "configure:1336: checking how to run the C preprocessor" >&5
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
CPP=
@@ -1349,13 +1347,13 @@ else
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp.
cat > conftest.$ac_ext <<EOF
#line 1353 "configure"
#line 1351 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1359: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
{ (eval echo configure:1357: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
@@ -1366,13 +1364,13 @@ else
rm -rf conftest*
CPP="${CC-cc} -E -traditional-cpp"
cat > conftest.$ac_ext <<EOF
#line 1370 "configure"
#line 1368 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1376: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
{ (eval echo configure:1374: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
@@ -1383,13 +1381,13 @@ else
rm -rf conftest*
CPP="${CC-cc} -nologo -E"
cat > conftest.$ac_ext <<EOF
#line 1387 "configure"
#line 1385 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1393: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
{ (eval echo configure:1391: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
@@ -1415,17 +1413,17 @@ echo "$ac_t""$CPP" 1>&6
ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for errno.h""... $ac_c" 1>&6
echo "configure:1419: checking for errno.h" >&5
echo "configure:1417: checking for errno.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1424 "configure"
#line 1422 "configure"
#include "confdefs.h"
#include <errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1429: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
{ (eval echo configure:1427: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -1721,6 +1719,7 @@ s%@RC@%$RC%g
s%@SET_MAKE@%$SET_MAKE%g
s%@OBJEXT@%$OBJEXT%g
s%@EXEEXT@%$EXEEXT%g
s%@TCL_THREADS@%$TCL_THREADS%g
s%@CPP@%$CPP%g
s%@MAN2TCLFLAGS@%$MAN2TCLFLAGS%g
s%@TCL_VERSION@%$TCL_VERSION%g
+4 -4
View File
@@ -2,7 +2,7 @@
# generate the file "configure", which is run during Tcl installation
# to configure the system for the local environment.
#
# RCS: @(#) $Id: configure.in,v 1.30 2001/04/02 01:59:26 hobbs Exp $
# RCS: @(#) $Id: configure.in,v 1.30.2.1 2001/05/19 16:12:20 msofer Exp $
AC_INIT(../generic/tcl.h)
@@ -31,9 +31,9 @@ AC_PROG_CC
# autoconf 2.50. You can also just set
# the CC, AR, RANLIB, and RC environment
# variables if you want to cross compile.
#AC_CHECK_TOOL(AR, ar, :)
#AC_CHECK_TOOL(RANLIB, ranlib, :)
#AC_CHECK_TOOL(RC, windres, :)
dnl AC_CHECK_TOOL(AR, ar, :)
dnl AC_CHECK_TOOL(RANLIB, ranlib, :)
dnl AC_CHECK_TOOL(RC, windres, :)
if test "${GCC}" = "yes" ; then
AC_CHECK_PROG(AR, ar, ar)
+5 -4
View File
@@ -224,6 +224,7 @@ AC_DEFUN(SC_ENABLE_THREADS, [
TCL_THREADS=0
AC_MSG_RESULT([no (default)])
fi
AC_SUBST(TCL_THREADS)
])
#------------------------------------------------------------------------
@@ -244,8 +245,8 @@ AC_DEFUN(SC_ENABLE_THREADS, [
# --enable-symbols
#
# Defines the following vars:
# CFLAGS_DEFAULT Sets to CFLAGS_DEBUG if true
# Sets to CFLAGS_OPTIMIZE if false
# CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true
# Sets to $(CFLAGS_OPTIMIZE) if false
# LDFLAGS_DEFAULT Sets to LDFLAGS_DEBUG if true
# Sets to LDFLAGS_OPTIMIZE if false
# DBGX Debug library extension
@@ -257,12 +258,12 @@ AC_DEFUN(SC_ENABLE_SYMBOLS, [
AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no])
if test "$tcl_ok" = "yes"; then
CFLAGS_DEFAULT="${CFLAGS_DEBUG}"
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}"
DBGX=d
AC_MSG_RESULT([yes])
else
CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE}"
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}"
DBGX=""
AC_MSG_RESULT([no])
+5 -1
View File
@@ -9,7 +9,7 @@
#
# The information in this file is specific to a single platform.
#
# RCS: @(#) $Id: tclConfig.sh.in,v 1.6 2000/09/28 06:33:18 hobbs Exp $
# RCS: @(#) $Id: tclConfig.sh.in,v 1.6.2.1 2001/05/19 16:12:20 msofer Exp $
TCL_DLL_FILE="@TCL_DLL_FILE@"
@@ -172,3 +172,7 @@ TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@'
# Path to the Tcl stub library in the install directory.
TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@'
# Flag, 1: we built Tcl with threads enables, 0 we didn't
TCL_THREADS=@TCL_THREADS@