summaryrefslogtreecommitdiffstats
path: root/imports
Commit message (Expand)AuthorAgeFilesLines
* Move gitignore to right level, update for Linux.Warwick Allison2010-03-312-2/+5
* Merge branch '4.7' of scm.dev.nokia.troll.no:qt/qt-s60-publicaxis2010-03-112-2/+0
|\
| * Fix build of importsTobias Hunger2010-03-023-3/+0
| * Move WebView to an extension plugin.Warwick Allison2010-03-021-0/+1
* | Added gitignore rules for Symbian plugins.axis2010-03-011-0/+2
|/
* Install the QML extensions.Roberto Raggi2010-02-242-0/+2
lProc.c | 185 +- generic/tclRegexp.c | 792 ++ generic/tclRegexp.h | 104 +- generic/tclResult.c | 1025 ++ generic/tclScan.c | 1032 ++ generic/tclStringObj.c | 51 +- generic/tclStubInit.c | 164 +- generic/tclStubs.c | 685 +- generic/tclTest.c | 1363 ++- generic/tclTestObj.c | 193 +- generic/tclThread.c | 563 + generic/tclThreadTest.c | 898 ++ generic/tclTimer.c | 388 +- generic/tclUniData.c | 621 ++ generic/tclUtf.c | 1287 +++ generic/tclUtil.c | 1725 +-- generic/tclVar.c | 715 +- library/auto.tcl | 553 + library/encoding/ascii.enc | 20 + library/encoding/big5.enc | 1516 +++ library/encoding/cp1250.enc | 20 + library/encoding/cp1251.enc | 20 + library/encoding/cp1252.enc | 20 + library/encoding/cp1253.enc | 20 + library/encoding/cp1254.enc | 20 + library/encoding/cp1255.enc | 20 + library/encoding/cp1256.enc | 20 + library/encoding/cp1257.enc | 20 + library/encoding/cp1258.enc | 20 + library/encoding/cp437.enc | 20 + library/encoding/cp737.enc | 20 + library/encoding/cp775.enc | 20 + library/encoding/cp850.enc | 20 + library/encoding/cp852.enc | 20 + library/encoding/cp855.enc | 20 + library/encoding/cp857.enc | 20 + library/encoding/cp860.enc | 20 + library/encoding/cp861.enc | 20 + library/encoding/cp862.enc | 20 + library/encoding/cp863.enc | 20 + library/encoding/cp864.enc | 20 + library/encoding/cp865.enc | 20 + library/encoding/cp866.enc | 20 + library/encoding/cp869.enc | 20 + library/encoding/cp874.enc | 20 + library/encoding/cp932.enc | 785 ++ library/encoding/cp936.enc | 2162 ++++ library/encoding/cp949.enc | 2128 ++++ library/encoding/cp950.enc | 1499 +++ library/encoding/dingbats.enc | 20 + library/encoding/euc-cn.enc | 1397 +++ library/encoding/euc-jp.enc | 1346 +++ library/encoding/euc-kr.enc | 1533 +++ library/encoding/gb12345.enc | 1414 +++ library/encoding/gb1988.enc | 20 + library/encoding/gb2312.enc | 1380 +++ library/encoding/iso2022-jp.enc | 12 + library/encoding/iso2022-kr.enc | 7 + library/encoding/iso2022.enc | 16 + library/encoding/iso8859-1.enc | 20 + library/encoding/iso8859-2.enc | 20 + library/encoding/iso8859-3.enc | 20 + library/encoding/iso8859-4.enc | 20 + library/encoding/iso8859-5.enc | 20 + library/encoding/iso8859-6.enc | 20 + library/encoding/iso8859-7.enc | 20 + library/encoding/iso8859-8.enc | 20 + library/encoding/iso8859-9.enc | 20 + library/encoding/jis0201.enc | 20 + library/encoding/jis0208.enc | 1312 +++ library/encoding/jis0212.enc | 1159 ++ library/encoding/ksc5601.enc | 1516 +++ library/encoding/macCentEuro.enc | 20 + library/encoding/macCroatian.enc | 20 + library/encoding/macCyrillic.enc | 20 + library/encoding/macDingbats.enc | 20 + library/encoding/macGreek.enc | 20 + library/encoding/macIceland.enc | 20 + library/encoding/macJapan.enc | 785 ++ library/encoding/macRoman.enc | 20 + library/encoding/macRomania.enc | 20 + library/encoding/macThai.enc | 20 + library/encoding/macTurkish.enc | 20 + library/encoding/macUkraine.enc | 20 + library/encoding/shiftjis.enc | 683 ++ library/encoding/symbol.enc | 20 + library/init.tcl | 1015 +- library/msgcat/msgcat.tcl | 177 + library/msgcat/pkgIndex.tcl | 1 + library/msgcat1.0/msgcat.tcl | 177 + library/msgcat1.0/pkgIndex.tcl | 1 + library/opt/optparse.tcl | 1097 ++ library/opt/pkgIndex.tcl | 11 + library/opt0.1/optparse.tcl | 1099 -- library/opt0.1/pkgIndex.tcl | 7 - library/opt0.4/optparse.tcl | 1097 ++ library/opt0.4/pkgIndex.tcl | 11 + library/package.tcl | 473 + library/safe.tcl | 48 +- library/tclIndex | 58 + library/word.tcl | 7 +- mac/MW_TclHeader.pch | 6 +- mac/README | 65 +- mac/tclMacAppInit.c | 4 +- mac/tclMacBOAAppInit.c | 4 +- mac/tclMacBOAMain.c | 27 +- mac/tclMacChan.c | 159 +- mac/tclMacExit.c | 4 +- mac/tclMacFCmd.c | 465 +- mac/tclMacFile.c | 660 +- mac/tclMacInit.c | 592 +- mac/tclMacInt.h | 13 +- mac/tclMacLibrary.r | 6 +- mac/tclMacLoad.c | 61 +- mac/tclMacNotify.c | 146 +- mac/tclMacOSA.c | 8 +- mac/tclMacPort.h | 236 +- mac/tclMacResource.c | 88 +- mac/tclMacResource.r | 6 +- mac/tclMacShLib.exp | 5 - mac/tclMacSock.c | 216 +- mac/tclMacTclCode.r | 36 + mac/tclMacThrd.c | 795 ++ mac/tclMacThrd.h | 20 + mac/tclMacUnix.c | 145 +- tests/README | 489 +- tests/all | 71 - tests/all.tcl | 76 + tests/append.test | 28 +- tests/assocd.test | 24 +- tests/async.test | 25 +- tests/autoMkindex.test | 64 +- tests/basic.test | 230 +- tests/binary.test | 25 +- tests/case.test | 23 +- tests/clock.test | 74 +- tests/cmdAH.test | 779 +- tests/cmdIL.test | 40 +- tests/cmdInfo.test | 26 +- tests/cmdMZ.test | 581 + tests/compExpr-old.test | 687 ++ tests/compExpr.test | 340 + tests/compile.test | 58 +- tests/concat.test | 23 +- tests/dcall.test | 26 +- tests/defs | 460 - tests/defs.tcl | 990 ++ tests/dstring.test | 25 +- tests/encoding.test | 316 + tests/env.test | 161 +- tests/error.test | 23 +- tests/eval.test | 23 +- tests/event.test | 606 +- tests/exec.test | 228 +- tests/execute.test | 450 +- tests/expr-old.test | 41 +- tests/expr.test | 75 +- tests/fCmd.test | 548 +- tests/fileName.test | 292 +- tests/for-old.test | 22 +- tests/for.test | 178 +- tests/foreach.test | 34 +- tests/format.test | 261 +- tests/get.test | 41 +- tests/history.test | 25 +- tests/http.test | 202 +- tests/httpd | 148 + tests/httpold.test | 52 +- tests/if-old.test | 23 +- tests/if.test | 602 +- tests/incr-old.test | 23 +- tests/incr.test | 273 +- tests/indexObj.test | 24 +- tests/info.test | 233 +- tests/init.test | 36 +- tests/interp.test | 179 +- tests/io.test | 2685 ++++- tests/ioCmd.test | 62 +- tests/ioUtil.test | 68 +- tests/join.test | 21 +- tests/lindex.test | 23 +- tests/link.test | 27 +- tests/linsert.test | 22 +- tests/list.test | 23 +- tests/listObj.test | 33 +- tests/llength.test | 23 +- tests/load.test | 110 +- tests/lrange.test | 23 +- tests/lreplace.test | 22 +- tests/lsearch.test | 25 +- tests/macFCmd.test | 158 +- tests/misc.test | 30 +- tests/msgcat.test | 318 + tests/namespace-old.test | 23 +- tests/namespace.test | 22 +- tests/obj.test | 176 +- tests/opt.test | 29 +- tests/osa.test | 41 +- tests/parse.test | 1257 ++- tests/parseExpr.test | 637 ++ tests/parseOld.test | 546 + tests/pid.test | 28 +- tests/pkg.test | 31 +- tests/pkg/import.tcl | 16 + tests/pkgMkIndex.test | 76 +- tests/platform.test | 25 +- tests/proc-old.test | 22 +- tests/proc.test | 23 +- tests/pwd.test | 23 +- tests/reg.test | 905 ++ tests/regexp.test | 82 +- tests/registry.test | 320 +- tests/remote.tcl | 13 +- tests/rename.test | 22 +- tests/resource.test | 142 +- tests/result.test | 102 + tests/safe.test | 107 +- tests/scan.test | 482 +- tests/security.test | 53 + tests/set-old.test | 25 +- tests/set.test | 274 +- tests/socket.test | 338 +- tests/source.test | 56 +- tests/split.test | 23 +- tests/stack.test | 24 +- tests/string.test | 29 +- tests/stringObj.test | 26 +- tests/subst.test | 25 +- tests/switch.test | 27 +- tests/thread.test | 240 + tests/timer.test | 103 +- tests/trace.test | 28 +- tests/unixFCmd.test | 168 +- tests/unixFile.test | 53 +- tests/unixInit.test | 205 + tests/unixNotfy.test | 73 +- tests/unknown.test | 23 +- tests/uplevel.test | 23 +- tests/upvar.test | 23 +- tests/utf.test | 276 + tests/util.test | 230 +- tests/var.test | 28 +- tests/while-old.test | 23 +- tests/while.test | 324 +- tests/winConsole.test | 51 + tests/winDde.test | 152 + tests/winFCmd.test | 419 +- tests/winFile.test | 64 + tests/winNotify.test | 56 +- tests/winPipe.test | 298 +- tests/winTime.test | 49 + tools/checkLibraryDoc.tcl | 242 + tools/configure.in | 7 +- tools/cvtEOL.tcl | 35 + tools/encoding/Makefile | 110 + tools/encoding/README | 5 + tools/encoding/ascii.txt | 95 + tools/encoding/big5.txt | 13906 +++++++++++++++++++++++ tools/encoding/cjk.inf | 4467 ++++++++ tools/encoding/cp1250.txt | 275 + tools/encoding/cp1251.txt | 275 + tools/encoding/cp1252.txt | 275 + tools/encoding/cp1253.txt | 275 + tools/encoding/cp1254.txt | 275 + tools/encoding/cp1255.txt | 275 + tools/encoding/cp1256.txt | 275 + tools/encoding/cp1257.txt | 275 + tools/encoding/cp1258.txt | 275 + tools/encoding/cp437.txt | 274 + tools/encoding/cp737.txt | 274 + tools/encoding/cp775.txt | 275 + tools/encoding/cp850.txt | 274 + tools/encoding/cp852.txt | 274 + tools/encoding/cp855.txt | 275 + tools/encoding/cp857.txt | 275 + tools/encoding/cp860.txt | 275 + tools/encoding/cp861.txt | 275 + tools/encoding/cp862.txt | 275 + tools/encoding/cp863.txt | 275 + tools/encoding/cp864.txt | 275 + tools/encoding/cp865.txt | 275 + tools/encoding/cp866.txt | 275 + tools/encoding/cp869.txt | 275 + tools/encoding/cp874.txt | 275 + tools/encoding/cp932.txt | 7999 ++++++++++++++ tools/encoding/cp936.txt | 22066 +++++++++++++++++++++++++++++++++++++ tools/encoding/cp949.txt | 17321 +++++++++++++++++++++++++++++ tools/encoding/cp950.txt | 13775 +++++++++++++++++++++++ tools/encoding/dingbats.txt | 250 + tools/encoding/gb12345.txt | 7604 +++++++++++++ tools/encoding/gb1988.txt | 158 + tools/encoding/gb2312.txt | 7515 +++++++++++++ tools/encoding/iso2022-jp.esc | 10 + tools/encoding/iso2022-kr.esc | 5 + tools/encoding/iso2022.esc | 14 + tools/encoding/iso8859-1.txt | 230 + tools/encoding/iso8859-2.txt | 230 + tools/encoding/iso8859-3.txt | 223 + tools/encoding/iso8859-4.txt | 230 + tools/encoding/iso8859-5.txt | 230 + tools/encoding/iso8859-6.txt | 185 + tools/encoding/iso8859-7.txt | 224 + tools/encoding/iso8859-8.txt | 192 + tools/encoding/iso8859-9.txt | 232 + tools/encoding/jis0201.txt | 202 + tools/encoding/jis0208.txt | 6940 ++++++++++++ tools/encoding/jis0212.txt | 6141 +++++++++++ tools/encoding/ksc5601.txt | 8262 ++++++++++++++ tools/encoding/macCentEuro.txt | 293 + tools/encoding/macCroatian.txt | 287 + tools/encoding/macCyrillic.txt | 287 + tools/encoding/macDingbats.txt | 260 + tools/encoding/macGreek.txt | 290 + tools/encoding/macIceland.txt | 285 + tools/encoding/macJapan.txt | 7598 +++++++++++++ tools/encoding/macRoman.txt | 301 + tools/encoding/macRomania.txt | 285 + tools/encoding/macThai.txt | 299 + tools/encoding/macTurkish.txt | 289 + tools/encoding/macUkraine.txt | 279 + tools/encoding/shiftjis.txt | 7096 ++++++++++++ tools/encoding/symbol.txt | 265 + tools/encoding/txt2enc.c | 244 + tools/genStubs.tcl | 10 +- tools/genWinImage.tcl | 120 + tools/man2html.tcl | 181 + tools/man2html1.tcl | 269 + tools/man2html2.tcl | 871 ++ tools/man2tcl.c | 4 +- tools/regexpTestLib.tcl | 266 + tools/str2c | 61 + tools/tcl.hpj.in | 6 +- tools/tcl.wse.in | 2330 ++++ tools/tcl8.1-tk8.1-man-html.tcl | 1662 +++ tools/tclSplash.bmp | Bin 0 -> 162030 bytes tools/tclmin.wse | 247 + tools/uniParse.tcl | 369 + tools/white.bmp | Bin 0 -> 20522 bytes unix/Makefile.in | 207 +- unix/README | 22 +- unix/configure.in | 140 +- unix/dltest/Makefile.in | 5 +- unix/dltest/configure.in | 4 +- unix/dltest/pkge.c | 6 +- unix/dltest/pkgf.c | 5 +- unix/mkLinks | 276 +- unix/porting.notes | 417 +- unix/tclAppInit.c | 29 +- unix/tclLoadAix.c | 6 +- unix/tclLoadAout.c | 69 +- unix/tclLoadDl.c | 82 +- unix/tclLoadDld.c | 47 +- unix/tclLoadNext.c | 41 +- unix/tclLoadOSF.c | 42 +- unix/tclLoadShl.c | 57 +- unix/tclMtherr.c | 13 +- unix/tclUnixChan.c | 558 +- unix/tclUnixEvent.c | 4 +- unix/tclUnixFCmd.c | 711 +- unix/tclUnixFile.c | 603 +- unix/tclUnixInit.c | 508 +- unix/tclUnixNotfy.c | 643 +- unix/tclUnixPipe.c | 103 +- unix/tclUnixPort.h | 136 +- unix/tclUnixSock.c | 38 +- unix/tclUnixTest.c | 114 +- unix/tclUnixThrd.c | 682 ++ unix/tclUnixThrd.h | 21 + unix/tclUnixTime.c | 17 +- unix/tclXtTest.c | 4 +- win/README | 57 +- win/README.binary | 905 +- win/makefile.bc | 388 - win/makefile.vc | 238 +- win/pkgIndex.tcl | 5 +- win/tcl.rc | 14 +- win/tclAppInit.c | 47 +- win/tclWin32Dll.c | 543 +- win/tclWinChan.c | 610 +- win/tclWinConsole.c | 1272 +++ win/tclWinDde.c | 1287 +++ win/tclWinError.c | 5 +- win/tclWinFCmd.c | 1036 +- win/tclWinFile.c | 991 +- win/tclWinInit.c | 652 +- win/tclWinInt.h | 68 +- win/tclWinLoad.c | 77 +- win/tclWinMtherr.c | 15 +- win/tclWinNotify.c | 355 +- win/tclWinPipe.c | 1602 ++- win/tclWinPort.h | 371 +- win/tclWinReg.c | 420 +- win/tclWinSerial.c | 1401 +++ win/tclWinSock.c | 671 +- win/tclWinTest.c | 5 +- win/tclWinThrd.c | 900 ++ win/tclWinThrd.h | 21 + win/tclWinTime.c | 122 +- win/tclsh.rc | 10 +- 532 files changed, 263785 insertions(+), 42531 deletions(-) create mode 100644 compat/memcmp.c delete mode 100644 doc/CrtVersion.3 create mode 100644 doc/Encoding.3 delete mode 100644 doc/EvalObj.3 create mode 100755 doc/GetCwd.3 create mode 100755 doc/GetVersion.3 delete mode 100644 doc/ObjSetVar.3 create mode 100644 doc/ParseCmd.3 create mode 100644 doc/SaveResult.3 create mode 100644 doc/Thread.3 create mode 100644 doc/ToUpper.3 create mode 100644 doc/Utf.3 create mode 100644 doc/dde.n create mode 100644 doc/encoding.n create mode 100644 doc/msgcat.n create mode 100644 generic/regc_color.c create mode 100644 generic/regc_cvec.c create mode 100644 generic/regc_lex.c create mode 100644 generic/regc_locale.c create mode 100644 generic/regc_nfa.c create mode 100644 generic/regcomp.c create mode 100644 generic/regcustom.h create mode 100644 generic/rege_dfa.c create mode 100644 generic/regerror.c create mode 100644 generic/regerrs.h create mode 100644 generic/regex.h create mode 100644 generic/regexec.c delete mode 100644 generic/regexp.c create mode 100644 generic/regfree.c create mode 100644 generic/regfronts.c create mode 100644 generic/regguts.h create mode 100644 generic/tclCompCmds.c create mode 100644 generic/tclEncoding.c delete mode 100644 generic/tclIntPlatStubs.c delete mode 100644 generic/tclIntStubs.c create mode 100644 generic/tclLiteral.c create mode 100644 generic/tclParseExpr.c delete mode 100644 generic/tclPlatStubs.c create mode 100644 generic/tclRegexp.c create mode 100644 generic/tclResult.c create mode 100644 generic/tclScan.c create mode 100644 generic/tclThread.c create mode 100644 generic/tclThreadTest.c create mode 100644 generic/tclUniData.c create mode 100644 generic/tclUtf.c create mode 100644 library/auto.tcl create mode 100644 library/encoding/ascii.enc create mode 100644 library/encoding/big5.enc create mode 100644 library/encoding/cp1250.enc create mode 100644 library/encoding/cp1251.enc create mode 100644 library/encoding/cp1252.enc create mode 100644 library/encoding/cp1253.enc create mode 100644 library/encoding/cp1254.enc create mode 100644 library/encoding/cp1255.enc create mode 100644 library/encoding/cp1256.enc create mode 100644 library/encoding/cp1257.enc create mode 100644 library/encoding/cp1258.enc create mode 100644 library/encoding/cp437.enc create mode 100644 library/encoding/cp737.enc create mode 100644 library/encoding/cp775.enc create mode 100644 library/encoding/cp850.enc create mode 100644 library/encoding/cp852.enc create mode 100644 library/encoding/cp855.enc create mode 100644 library/encoding/cp857.enc create mode 100644 library/encoding/cp860.enc create mode 100644 library/encoding/cp861.enc create mode 100644 library/encoding/cp862.enc create mode 100644 library/encoding/cp863.enc create mode 100644 library/encoding/cp864.enc create mode 100644 library/encoding/cp865.enc create mode 100644 library/encoding/cp866.enc create mode 100644 library/encoding/cp869.enc create mode 100644 library/encoding/cp874.enc create mode 100644 library/encoding/cp932.enc create mode 100644 library/encoding/cp936.enc create mode 100644 library/encoding/cp949.enc create mode 100644 library/encoding/cp950.enc create mode 100644 library/encoding/dingbats.enc create mode 100644 library/encoding/euc-cn.enc create mode 100644 library/encoding/euc-jp.enc create mode 100644 library/encoding/euc-kr.enc create mode 100644 library/encoding/gb12345.enc create mode 100644 library/encoding/gb1988.enc create mode 100644 library/encoding/gb2312.enc create mode 100644 library/encoding/iso2022-jp.enc create mode 100644 library/encoding/iso2022-kr.enc create mode 100644 library/encoding/iso2022.enc create mode 100644 library/encoding/iso8859-1.enc create mode 100644 library/encoding/iso8859-2.enc create mode 100644 library/encoding/iso8859-3.enc create mode 100644 library/encoding/iso8859-4.enc create mode 100644 library/encoding/iso8859-5.enc create mode 100644 library/encoding/iso8859-6.enc create mode 100644 library/encoding/iso8859-7.enc create mode 100644 library/encoding/iso8859-8.enc create mode 100644 library/encoding/iso8859-9.enc create mode 100644 library/encoding/jis0201.enc create mode 100644 library/encoding/jis0208.enc create mode 100644 library/encoding/jis0212.enc create mode 100644 library/encoding/ksc5601.enc create mode 100644 library/encoding/macCentEuro.enc create mode 100644 library/encoding/macCroatian.enc create mode 100644 library/encoding/macCyrillic.enc create mode 100644 library/encoding/macDingbats.enc create mode 100644 library/encoding/macGreek.enc create mode 100644 library/encoding/macIceland.enc create mode 100644 library/encoding/macJapan.enc create mode 100644 library/encoding/macRoman.enc create mode 100644 library/encoding/macRomania.enc create mode 100644 library/encoding/macThai.enc create mode 100644 library/encoding/macTurkish.enc create mode 100644 library/encoding/macUkraine.enc create mode 100644 library/encoding/shiftjis.enc create mode 100644 library/encoding/symbol.enc create mode 100644 library/msgcat/msgcat.tcl create mode 100644 library/msgcat/pkgIndex.tcl create mode 100644 library/msgcat1.0/msgcat.tcl create mode 100644 library/msgcat1.0/pkgIndex.tcl create mode 100644 library/opt/optparse.tcl create mode 100644 library/opt/pkgIndex.tcl delete mode 100644 library/opt0.1/optparse.tcl delete mode 100644 library/opt0.1/pkgIndex.tcl create mode 100644 library/opt0.4/optparse.tcl create mode 100644 library/opt0.4/pkgIndex.tcl create mode 100644 library/package.tcl create mode 100644 mac/tclMacTclCode.r create mode 100644 mac/tclMacThrd.c create mode 100644 mac/tclMacThrd.h delete mode 100644 tests/all create mode 100644 tests/all.tcl create mode 100644 tests/cmdMZ.test create mode 100644 tests/compExpr-old.test create mode 100644 tests/compExpr.test delete mode 100644 tests/defs create mode 100644 tests/defs.tcl create mode 100644 tests/encoding.test create mode 100644 tests/httpd create mode 100644 tests/msgcat.test create mode 100644 tests/parseExpr.test create mode 100644 tests/parseOld.test create mode 100644 tests/pkg/import.tcl create mode 100644 tests/reg.test create mode 100644 tests/result.test create mode 100644 tests/security.test create mode 100644 tests/thread.test create mode 100644 tests/unixInit.test create mode 100644 tests/utf.test create mode 100644 tests/winConsole.test create mode 100644 tests/winDde.test create mode 100644 tests/winFile.test create mode 100644 tests/winTime.test create mode 100755 tools/checkLibraryDoc.tcl create mode 100644 tools/cvtEOL.tcl create mode 100644 tools/encoding/Makefile create mode 100644 tools/encoding/README create mode 100644 tools/encoding/ascii.txt create mode 100644 tools/encoding/big5.txt create mode 100644 tools/encoding/cjk.inf create mode 100644 tools/encoding/cp1250.txt create mode 100644 tools/encoding/cp1251.txt create mode 100644 tools/encoding/cp1252.txt create mode 100644 tools/encoding/cp1253.txt create mode 100644 tools/encoding/cp1254.txt create mode 100644 tools/encoding/cp1255.txt create mode 100644 tools/encoding/cp1256.txt create mode 100644 tools/encoding/cp1257.txt create mode 100644 tools/encoding/cp1258.txt create mode 100644 tools/encoding/cp437.txt create mode 100644 tools/encoding/cp737.txt create mode 100644 tools/encoding/cp775.txt create mode 100644 tools/encoding/cp850.txt create mode 100644 tools/encoding/cp852.txt create mode 100644 tools/encoding/cp855.txt create mode 100644 tools/encoding/cp857.txt create mode 100644 tools/encoding/cp860.txt create mode 100644 tools/encoding/cp861.txt create mode 100644 tools/encoding/cp862.txt create mode 100644 tools/encoding/cp863.txt create mode 100644 tools/encoding/cp864.txt create mode 100644 tools/encoding/cp865.txt create mode 100644 tools/encoding/cp866.txt create mode 100644 tools/encoding/cp869.txt create mode 100644 tools/encoding/cp874.txt create mode 100644 tools/encoding/cp932.txt create mode 100644 tools/encoding/cp936.txt create mode 100644 tools/encoding/cp949.txt create mode 100644 tools/encoding/cp950.txt create mode 100644 tools/encoding/dingbats.txt create mode 100644 tools/encoding/gb12345.txt create mode 100644 tools/encoding/gb1988.txt create mode 100644 tools/encoding/gb2312.txt create mode 100644 tools/encoding/iso2022-jp.esc create mode 100644 tools/encoding/iso2022-kr.esc create mode 100644 tools/encoding/iso2022.esc create mode 100644 tools/encoding/iso8859-1.txt create mode 100644 tools/encoding/iso8859-2.txt create mode 100644 tools/encoding/iso8859-3.txt create mode 100644 tools/encoding/iso8859-4.txt create mode 100644 tools/encoding/iso8859-5.txt create mode 100644 tools/encoding/iso8859-6.txt create mode 100644 tools/encoding/iso8859-7.txt create mode 100644 tools/encoding/iso8859-8.txt create mode 100644 tools/encoding/iso8859-9.txt create mode 100644 tools/encoding/jis0201.txt create mode 100644 tools/encoding/jis0208.txt create mode 100644 tools/encoding/jis0212.txt create mode 100644 tools/encoding/ksc5601.txt create mode 100644 tools/encoding/macCentEuro.txt create mode 100644 tools/encoding/macCroatian.txt create mode 100644 tools/encoding/macCyrillic.txt create mode 100644 tools/encoding/macDingbats.txt create mode 100644 tools/encoding/macGreek.txt create mode 100644 tools/encoding/macIceland.txt create mode 100644 tools/encoding/macJapan.txt create mode 100644 tools/encoding/macRoman.txt create mode 100644 tools/encoding/macRomania.txt create mode 100644 tools/encoding/macThai.txt create mode 100644 tools/encoding/macTurkish.txt create mode 100644 tools/encoding/macUkraine.txt create mode 100644 tools/encoding/shiftjis.txt create mode 100644 tools/encoding/symbol.txt create mode 100644 tools/encoding/txt2enc.c create mode 100644 tools/genWinImage.tcl create mode 100644 tools/man2html.tcl create mode 100644 tools/man2html1.tcl create mode 100644 tools/man2html2.tcl create mode 100644 tools/regexpTestLib.tcl create mode 100644 tools/str2c create mode 100644 tools/tcl.wse.in create mode 100644 tools/tcl8.1-tk8.1-man-html.tcl create mode 100644 tools/tclSplash.bmp create mode 100644 tools/tclmin.wse create mode 100644 tools/uniParse.tcl create mode 100644 tools/white.bmp create mode 100644 unix/tclUnixThrd.c create mode 100644 unix/tclUnixThrd.h delete mode 100644 win/makefile.bc create mode 100644 win/tclWinConsole.c create mode 100644 win/tclWinDde.c create mode 100644 win/tclWinSerial.c create mode 100644 win/tclWinThrd.c create mode 100644 win/tclWinThrd.h diff --git a/ChangeLog b/ChangeLog index 1d3eaf2..b9d5dc4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,222 +1,560 @@ 1999-04-15 - * Merge 8.0.5 changes: - - Mac changes for final release - - Minor fixes to tools configure file - + * Merged 8.1 back into the main trunk + +1999-04-13 + + * library/encoding/gb2312.enc: + * library/encoding/euc-cn.enc: + * tools/encoding/gb2312.txt: + * tools/encoding/cp950.txt: + * tools/encoding/Makefile: Restored the double byte definition of + GB2312 and added the EUC-CN encoding. EUC-CN is a variant of + GB2312 that shifts the characters into bytes with the high bit set + and includes ASCII as a subset. [Bug: 632] + +1999-04-13 + * win/tclWinSock.c: Apply patch to allow write access to a socket if FD_WRITE is sent but FD_CONNECT is not. Some strange problem with either Win32 or a socket driver. [Bug: 1664 1776] -1999-03-12 +1999-04-09 - * generic/tcl.h: Changed magic number so it doesn't match the plus - patch, at Jan's request. + * unix/tclUnixNotfy.c: Fixed notifier deadlock situation when the + pipe used to talk back notifier thread is filled with data. When + calling the write() function to feed data down that pipe, unlock + the notifierMutex to allow the notifier to wake up again. Found + as a result of the focus.test for Tk hanging. [Bug: 1700] -1999-03-11 +1999-04-06 - * unix/tclConfig.sh.in: - * unix/dltest/Makefile.in: - * unix/dltest/configure.in: - * unix/dltest/pkga.c: - * unix/dltest/pkgb.c: - * unix/dltest/pkgc.c: - * unix/dltest/pkgd.c: - * unix/dltest/pkge.c: - * unix/dltest/pkgf.c: Changed package tests to build against the - stubs library. + * tests/unixNotfy.test: Fixed hang in tests when built with thread + support. -1999-03-10 + * tests/httpold.test: Fixed broken test that didn't wait long + enough for events to arrive. - * generic/tclAlloc.c: Changed TCL_NATIVE_MALLOC to USE_TCLALLOC so - it matches 8.1. + * tests/unixInit.test: Fixed race condition in test. - * generic/tclBasic.c: - * generic/tcl.h: - * generic/tcl.decls: Changed Tcl_ReleaseType from an enum to - macros so it can be used in .rc files. - Added Tcl_GetString. + * tests/unixInit.test: + * tests/fileName.test: Minor test nits. + + * unix/tclUnixInit.c (TclpSetInitialEncodings): Fixed bad initial + encoding string. + +1999-04-06 + + * generic/tclVar.c: + * generic/tclEnv.c: Moved the "array set" C level code into a + common routine (TclArraySet). The TclSetupEnv routine now uses + this API to create an env array w/ no elements. + + * generic/tclEnv.c: + * generic/tclWinInit.h: + * generic/tclUnixInit.h: + * generic/tclInt.h: Made the Env module I18N compliant. Changed the + FindVariable routine to TclpFindVariable, that now does a case + insensitive string comparison on Windows, and not on UNIX. [Bug: + 1299, 1500] + +1999-04-05 + + * tests/io.test: Minor test cleanup. - * unix/Makefile.in: Added compat binaries to the stub library. - Changed compat binaries to always compile with shared flags since - they need to be shared for the stub library. + * generic/tclEncoding.c (Tcl_CreateEncoding): Minor lint to make + it easier to compile on Digital-unix. [Bug: 1659] -1999-03-10 + * unix/configure.in: + * unix/tclUnixPort.h: Applied patch for OS/390 to handle lack of + sys/param.h. [Bug: 1725] + + * unix/configure.in: Fixed BSD/OS 4.* configuration to support + shared libraries properly. [Bug: 1730] + +1999-04-05 + * win/tclWinDde.c: decrease timeout value for DDE calls to 30k + [Bug: 1639] + + * generic/tcl.decls: * generic/tcl.h: - * generic/tclBasic.c: Add Tcl_GetVersion() to public C API to - allow checking of the Tcl library's version number at runtime. + * generic/tclDecls.h: + * generic/tclInt.decls: + * generic/tclInt.h: + * generic/tclIntDecls.h: + * generic/tclStubInit.c: + * generic/tclUtil.c: Added more functions to the Tcl stubs table, + including all Tcl_ functions not already in it (except Cmd + functions) and Tcl_GetCwd() and Tcl_Chdir() (new functions). -1999-03-09 + * tests/safe.test: + * doc/safe.n: + * generic/tclBasic.c: + * library/safe.tcl: The encoding command is not safe as-is, so + create a safe alias to mask out the "encoding system " but + allow all other uses including "encoding system". Added test cases + and updated the man page for Safe Tcl. - * generic/tcl.h: Changed TCL_STUB_MAGIC back to match plus patch - implementation. +1999-04-05 - * Regenerated stub interfaces. + * tests/winTime.test: + * win/tclWinTime.c: Fixed crash in clock command that occurred + when manipulating negative time values in timezones east of + GMT. [Bug: 1142, 1458] + + * tests/platform.test: + * tests/fileName.test: Fixed broken tests. - * tools/genStubs.tcl: Reorganized code to support mixed generic - and platform specific tables. + * generic/tclFileName.c: Moved global regexps into thread local + storage. + + * tests/socket.test: Changed so tests don't reuse sockets, + since Windows is slow to release sockets. + + * win/tclWinConsole.c: + * win/tclWinPipe.c: + * win/tclWinSerial.c: Fixed race condition where background + threads were terminated while they still held a lock in the + notifier. + +1999-04-02 + + * tests/http.test: Fixed bad test initialization code. + + * generic/tclThreadTest.c (ThreadExitProc): Fixed bug where static + memory was being returned instead of a dynamically allocated + result in error cases. + +1999-04-02 + + * doc/dde.n: + * tools/tcl.wse.in: + * win/makefile.vc: + * win/pkgIndex.tcl: + * win/tclWinDde.c: Add new DDE package, code removed from Tk now + separated into its own package. Changed DDE-based send code into + "dde eval" command. Can be loaded into tclsh (not just wish). + Windows only. + +1999-04-02 + + * tests/expr.test: + * tests/for-old.test: + * tests/for.test: + * tests/foreach.test: + * tests/format.test: + * tests/httpold.test: + * tests/if.test: + * tests/init.test: + * tests/interp.test: + * tests/while.test: Added some tests for known bugs (marked with + knownBug constraint), and cleaned up a few bad tests. + + * generic/regc_locale.c: + * generic/regcustom.h: + * generic/tcl.decls: + * generic/tclCmdIL.c: + * generic/tclCmdMZ.c: + * generic/tclInt.h: + * generic/tclRegexp.c: + * generic/tclScan.c: + * generic/tclTest.c: + * generic/tclUtf.c: + * win/tclWinFCmd.c: + * win/tclWinFile.c: Made various Unicode utility functions + public. The following functions were made public and added to the + stubs table: + Tcl_UtfToUniCharDString, Tcl_UniCharToUtfDString, + Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharIsAlnum, + Tcl_UniCharIsAlpha, Tcl_UniCharIsDigit, Tcl_UniCharIsLower, + Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsWordChar - * generic/tclInt.decls: Removed TclCompile*Cmd routines from the - table. +1999-04-01 - * generic/tcl.decls: Moved old Unix fd handler routines into - generic table and modified stubs ordering to match the plus patch. + * tests/registry.test: + * win/tclWinReg.c: Internationalized the registry code. It now + uses Unicode interfaces on NT. [Bug: 1197] - * win/tclWinChan.c (FileSeekProc): Fixed bug where errors during - seeking were not getting propagated. + * tests/parse.test: + * generic/tclParse.c: Fixed crash due to multiple frees in parser + during error cleanup when parsing commands with more tokens than + will fit in the static area of the parse structure. [Bug: 1681] -1999-03-08 + * generic/tclInt.h: Removed duplicate declarations. + + * generic/tclInt.decls: + * generic/tcl.decls: Added Tcl_WinUtfToTChar and Tcl_WinTCharToUtf + to the tclPlat table. +1999-04-01 + + * generic/tcl.decls: + * generic/tcl.h: + * generic/tclBasic.c: * generic/tclDecls.h: - * generic/tclStubs.c: - * generic/tclStubInit.c: - * generic/tcl.decls: Removed Tcl_InitMemory(). + * generic/StubInit.c: + * tools/genStubs.tcl: + * unix/Makefile.in: + * win/makefile.vc: Applied patch from Jan Nijtmans to fix Ultrix + multiple symbol definition problem. Now, even Tcl includes a copy + of the Tcl stub library. Also fixed TCL_MEM_DEBUG mode (for Tk). - * generic/tcl.h: Changed TCL_STUB_MAGIC to break binary - compatibility with plus patch version, since the tables don't - match. +1999-03-31 -1999-03-08 + * win/tclWinConsole.c: WinNT has a bug when reading a single + character from the console. Rewrote the code for the console to + read an entire line at a time using the reader thread. - * win/tclWinInt.h: - * generic/tclInt.h: - * generic/tclIntDecls.h: - * generic/tclIntPlatDecls.h: - * generic/tclIntPlatStubs.c: - * generic/tclIntStubs.c: - * generic/tclStubInit.c: - * generic/tclInt.decls: Removed initialization and finalization - routines from the stub table since these should never be called by - an extension. +1999-03-30 -1999-03-06 + * unix/Makefile.in: Removed trailing backslash that broke the + "depend" target. - * unix/Makefile.in: - * generic/tcl.decls: - * generic/tclCompile.h: - * generic/tclCompileDecls.h: - * generic/tclCompileStubs.c: + * unix/tclUnixInit.c (TclpSetInitialEncodings): Changed to avoid + calling setlocale(). We now look directly at env(LANG) and + env(LC_CTYPE) instead. [Bug: 1636] + + * generic/tclFileName.c: * generic/tclDecls.h: - * generic/tclInt.decls: + * generic/tcl.decls: Removed CONST from Tcl_JoinPath and + Tcl_TranslateFileName because it changes the signature of + Tcl_JoinPath in an incompatible manner. + * generic/tclInt.h: - * generic/tclStubInit.c: Removed tclCompile.h functions. Moved - TclGetAuxDataType to tclInt.h so it is available for use by - the TclPro Byte Compiler loader. - -1999-03-05 - - * unix/configure.in: Applied patch from Jan Nijtmans to fix the - following problems: - - There seems to be a HP-UX-11 already, which behaves - identical to HP-UX-10. - - For 64-bit IRIX, SHLIB_LD_LIBS should be set to - '${LIBS}'. This also has the side-effect that SHLIB_LD - doesn't need the -rpath option any more: it is already part - of ${LIBS} - - Fix Linux to use the -rpath option. - - On Solaris, LD_SEARCH_FLAGS can only be used with the - linker, not with the compiler, because the "-Wl," part is - missing. - - The TCL_LD_SEARCH_FLAGS should be used in static executables - as well as dynamically linked ones. Otherwise, static - executables have a different search strategy for dynamically - loadable stub-enabled extensions than executables using - shared libraries. This effects extensions which load other - libraries in turn. - - * generic/tclCompile.h: - * generic/tclStubInit.c: - * generic/tclCompileDecls.h: - * generic/tclCompileStubs.c: - * generic/tclInt.decls: Added functions from tclCompile.h into a - new tclCompile interface. + * generic/tclLoad.c (TclFinalizeLoad): + * generic/tclEvent.c (Tcl_Finalize): Defer unloading of loadable + modules until all exit handlers have been invoked. + [Bug: 998, 1273, 1573, 1593] - * generic/tclStubs.c: +1999-03-29 + + * generic/tclFileName.c: + * generic/tclDecls.h: + * generic/tcl.decls: Added CONST to Tcl_JoinPath and + Tcl_TranslateFileName. + +1999-03-29 + + * tools/genStubs.tcl: + * unix/configure.in: + * unix/Makefile.in: + * win/makefile.vc: + * generic/tcl.h: + * generic/tclBasic.c: * generic/tclDecls.h: - * generic/tcl.decls: Added Tcl_InitMemory. + * generic/tclIntDecls.h: + * generic/tclPlatDecls.h: + * generic/tclIntPlatDecls.h: Removed the stub functions and + changed the stub macros to just use the name without params. Pass + &tclStubs into the interp (don't use tclStubsPtr because of + collisions with the stubs on Solaris). + +1999-03-27 + + * win/makefile.bc: Removed makefile for Borland compiler, no + longer supported. + +1999-03-26 - * generic/tclStubLib.c: Changed to define USE_TCL_STUBS and - USE_TCL_STUB_PROCS automatically. + * win/tclWinSerial.c: + * win/tclWinConsole.c: + * win/tclWinPipe.c: Don't close the Win32 handle for a channel if + it's a stdio handle (GetStdHandle()) during shutdown of a thread + to prevent it from destroying the stdio of other threads. - * unix/Makefile.in: Changes to get stubs mechanism working. +1999-03-26 - * generic/tclGetDate.y: Updated to reflect tclDate.c changes. + * unix/configure.in + --nameble-shared is now the default and build Tcl as a shared + library; specify --disable-shared to build a static Tcl library + and shell. + +1999-03-25 + + * tests/interp.test: + * generic/tclInterp.c (AliasObjCmd): Changed so aliases are + invoked at current scope in the target interpreter instead of at + the global scope. This was an incompatibility introduced in 8.1 + that is being removed. [Bug: 1153, 1556] + + * library/encoding/big5.enc: + * library/encoding/gb2312.enc: + * tools/encoding/big5.enc: + * tools/encoding/gb2312.enc: Added ASCII to big5 and gb2312 + encodings. [Bug: 632] - * tools/genStubs.tcl: + * generic/tclPkg.c (Tcl_PkgRequireEx): Fixed broken clientData + initialization in package code. + + * unix/Makefile.in (dist): Added tcl.decls and tclInt.decls to + source distribution. [Bug: 1571] + + * doc/Thread.3: Updated documentation of Tcl_MutexLock to indicate + that the recursive locking behavior is undefined. On Windows, it + does not block, on Unix it deadlocks. [Bug: 1275] + +1999-03-24 + + * tests/execute.test: + * generic/tclExecute.c (TclExecuteByteCode): Fixed expression code + that incorrectly returned floating point values for integers if + the internal rep happened to be a double. Now we check to see if + the object has a string rep that looks like an integer before + using the double internal rep. [Bug: 1516] + +1999-03-24 + + * generic/tclAlloc.c: + * generic/tclEncoding.c: * generic/tclProc.c: + * unix/tclUnixTime.c: + * win/tclWinSerial.c: Fixed compilation warnings/errors for VC++ + 5.0 and 6.0 and HP-UX native compiler without -Aa or -Ae. + [Bug: 1323 1518 1324 1583 1585 1586] + + * win/tclWinSock.c: Make sockets thread-safe on Windows. The + current implementation uses windows to handle events on the + socket, one for each thread (thread local storage). Previously, + there was only one window shared between threads, which didn't + work. [Bug: 1326] + +1999-03-23 + + * tools/tcl.wse: Fixed file association to look in the right place + for the wish icon. [Bug: 1544] + + * tests/winNotify.test: + * tests/ioCmd.test: + * tests/event.test: Changed to use new style conditionals. + + * tests/encoding.test: Fixed nonportable test. + + * unix/dltest/configure.in: + * unix/dltest/Makefile.in: Added missing DBGX macros. [Bug: 1564] + + * tests/winNotify.test: + * mac/tclMacNotify.c: + * win/tclWinNotify.c: + * unix/tclUnixNotfy.c: + * generic/tclNotify.c: Added a new Tcl_ServiceModeHook interface + that is invoked whenever the service mode changes. This is needed + to allow the Windows notifier to create a communication window the + first time Tcl is about to enter an external modal event loop + instead of at startup time. This will avoid the various problems + that people have been seeing where the system hangs when tclsh + is running outside of the event loop. [Bug: 783] + + * generic/tclInt.h: + * generic/tcl.decls: Renamed TclpAlertNotifier back to + Tcl_AlertNotifier since it is part of the public notifier driver + API. + +1999-03-23 + + * win/tclWinSerial.c: Fixed problem with fileevent on the serial + port and nonblocking mode. Gets no longer hangs, fileevents fire + whenever there is any character data on the port. + + * tests/winConsole.test: + * win/tclWinConsole.c: Fixed problem with fileevents and gets from + a console stdin. Previously, fileevents were firing before an + entire line was available for reading, which meant that when you + did a gets or read, it blocked (even in nonblocking mode). Now, it + should work the same as Unix: fileevents fire when an entire line + is ready, and gets and read do not block in non-blocking mode. + Added an interactive test case to check for this. + +1999-03-22 + + * tests/reg.test: + * generic/regc_color.c: Applied regexp bug fix from Henry Spencer. + +1999-03-19 + + * generic/tclCmdIL.c: Fixed the initialization of an array so that + the Sun 5.0 C compiler wouldn't complain. + + * unix/configure.in: Added support for --enable-64bit. For now, + this is only supported on Solaris 7 64bit (SunOS 5.7) using the Sun + compiler (not gcc). + +1999-03-18 + + * win/tclWinChan.c (TclpOpenFileChannel, Tcl_MakeFileChannel): + Changed to only test for console or comm handles when the type is + FILE_TYPE_CHAR to avoid useless tests on simple files. Also + reordered tests so consoles are tested first as this is more + common. + + * win/makefile.vc: Regularized usage of mkd and rmd and rm. + + * library/encoding/shiftjis.enc: + * tools/encoding/shiftjis.txt: Missing/incorrect characters in + shift-jis table. [Bug: 1008, 1526] + + * generic/tclInt.decls: + * generic/tcl.decls: Eliminated use of "string" and "list" from + argument lists to avoid conflicts with C++ STL. [Bug: 1181] + + * win/tclWinFile.c (TclpMatchFiles): Changed to ignore the + FS_CASE_IS_PRESERVED bit and always return exactly what we get + from the system. + +1999-03-17 + + * win/README.binary: + * win/README: + * unix/configure.in: + * generic/tcl.h: + * README: Updated version to 8.1b3. + +1999-03-14 + + * win/tclWinConsole.c: + * win/tclWinPipe.c: + * win/tclWinSerial.c: Changed so channel drivers wait for the + reader/writer threads to exit before returning during a close + operation. This ensures that the main thread is the last thread + to exit, so the process return value is set properly. + + * generic/tclIntDecls.h: + * generic/tclIntPlatDecls.h: + * generic/tclIntPlatStubs.c: + * generic/tclIntStubs.c: + * generic/tclPlatDecls.h: + * generic/tclPlatStubs.c: * generic/tclStubInit.c: - * generic/tclTest.c: - * unix/tclUnixFile.c: - * unix/tclUnixPort.h: lint + * generic/tclStubs.c: Fixed bad eol characters. + + * generic/tclInt.decls: Changed "const" to "CONST" in + declarations for better portability. - * win/makefile.vc: - * generic/tclAlloc.c: Changed USE_NATIVEMALLOC to USE_NATIVE_MALLOC. + * generic/tcl.decls: Renamed panic and panicVA to Tcl_Panic and + Tcl_PanicVA in the stub files. -1999-03-03 + * generic/tclInterp.c (Tcl_MakeSafe): Remove tcl_platform(user) + from safe interps. - * unix/tclUnixTime.c: Added TclpGetDate and TclStrftime. +1999-03-11 - * unix/tclUnixSock.c: Added TclHasSockets. + * unix/Makefile.in: + * unix/configure.in: Include compat files in the stub library in + addition to the main library. Compat files are now built for + dynamic use in all cases. + + * generic/tcl.h: Changed magic number so it doesn't match the plus + patch, at Jan's request. + + * unix/tclConfig.sh.in: + * unix/dltest/Makefile.in: + * unix/dltest/configure.in: + * unix/dltest/pkga.c: + * unix/dltest/pkgb.c: + * unix/dltest/pkgc.c: + * unix/dltest/pkgd.c: + * unix/dltest/pkge.c: + * unix/dltest/pkgf.c: Changed package tests to build against the + stubs library. - * unix/tclUnixPort.h: Eliminated various Tclp* macros that have - been replaced with function defintions. +1999-03-10 - * win/tclWinInt.h: - * win/tclWin32Dll.c: - * unix/tclUnixInit.c: Added TclpCheckStackSpace. + * generic/tcl.h: + * generic/tcl.decls: Changed Tcl_ReleaseType from an enum to + macros so it can be used in .rc files. + Added Tcl_GetString. - * unix/tclUnixFile.c: - * mac/tclMacShLib.exp: - * mac/tclMacFile.c: - * generic/tclFileName.c: - * win/tclWinFile.c: Renamed TclpGetUserHome back to - TclGetUserHome for patch level compatibility. + * mac/tclMacNotify.c: + * generic/tclNotify.c: + * generic/tclInt.h: + * win/tclWinNotify.c: + * generic/tcl.h: Renamed Tcl_AlertNotifier to TclpAlertNotifier. - * unix/tclUnixFile.c: Added TclpAccess and TclpState. + * generic/tclInt.decls: Added TclWinAddProcess to make it possible + for expect to use Tcl_WaitForPid(). This patch is from Gordon + Chaffee. - * win/tclWinPort.h: * mac/tclMacPort.h: - * mac/tclMacInt.h: - * mac/tclMac.h: - * generic/tcl.decls: Added Mac specific declarations. + * win/tclWinInit.c: + * unix/tclUnixPort.h: + * generic/tclAsync.c: Added TclpAsyncMark to fix bug in async + handling on Windows where async events don't wake up the event + loop. This patch comes from Gordon Chaffee. + + * generic/tcl.decls: Fixed declarations of reserved slots. + +1999-03-10 - * mac/tclMacChan.c: Added stub implementation of - Tcl_MakeFileChannel that doesn't do anything. This could be - implemented at a later date. + * generic/tclCompile.h: Ensure that the ByteCode struct is binary + compatible with the version in 8.0.6. - * generic/tclStubLib.c: Added internal interface hooks. + * generic/tcl.h: + * generic/tclBasic.c: Add Tcl_GetVersion() function to the public + C API to allow programs to check the version number of the Tcl + library at runtime. Also added an enum to clarify the release + level (alpha, beta, final). + +1999-03-09 - * generic/tclStubs.c: - * generic/tclStubInit.c: Added undefs for all of the TCL_MEM_DEBUG - macros to avoid conflicts with the stub names. + * Integrated changes from Tcl 8.0 including: + stubs mechanism + configure patches from Jan Nijtmans + rename of panic to Tcl_Panic - * generic/tclStubInit.c: - * generic/tclInt.h: - * generic/tclInt.decls: Moved some declarations out of the generic - and into the platform specific sections. Added missing - declarations and Mac specific declarations. +1999-03-08 - * win/tclWinTime.c: - * unix/tclUnixTime.c: - * mac/tclMacTime.c: - * generic/tclInt.h: - * generic/tclDate.c: - * generic/tclClock.c: Created a new opaque TclpTime_t type so - generic functions that depend on the format of time_t can appear - in the generic header files. + * win/tclWin32Dll.c: Removed Dll instance from thread-local + storage. - * unix/Makefile.in: - * generic/tclAlloc.c: Changed so stub versions of TclpAlloc, - etc. are generated when TCL_MEM_DEBUG is not defined. +1999-03-08 + + * generic/tcl.h: Moved Tcl_Mutex, etc. macros above the inclusion + of tclDecls.h to avoid macro conflicts. - * generic/tclStubInit.c: - * generic/tclPanic.c: - * generic/tcl.h: - * generic/tcl.decls: renamed Tcl_Panic back to panic to avoid - incompatibilities in a patch release. + * generic/tclInt.h: + * generic/regc_color.c: + * generic/regcomp.c: + * generic/tclCmdIL.c: + * generic/tclCmdAH.c: + * generic/tclIOCmd.c: + * generic/tclParse.c: + * generic/tclStringObj.c: + * unix/tclUnixNotfy.c: Cleaned up various compiler warnings, + eliminated UCHAR bugs. + + * unix/tclUnixNotfy.c: + * unix/tclUnixThrd.c: + * generic/tclThreadTest.c: + * mac/tclMacThrd.c: Changed TclpCondition*() to Tcl_Condition*(). + + * INTEGRATED PATCHES FROM 8.0.6: -1999-03-02 + * generic/tcl.decls: + * generic/tcl.h: + * generic/tclBasic.c: + * generic/tclDecls.h: + * generic/tclInt.decls: + * generic/tclInt.h: + * generic/tclIntDecls.h: + * generic/tclIntPlatDecls.h: + * generic/tclIntPlatStubs.c: + * generic/tclIntStubs.c: + * generic/tclPlatDecls.h: + * generic/tclPlatStubs.c: + * generic/tclStubInit.c: + * generic/tclStubLib.c: + * generic/tclStubs.c: + * tools/genStubs.tcl: + * unix/configure.in: + * unix/Makefile.in: + * unix/tclConfig.sh.in: + * win/makefile.vc: + * win/tclWinPort.h: Added Tcl stubs implementation. There are + now two new macros USE_TCL_STUBS and USE_TCL_STUB_PROCS that + enable use of stubs and disable stub macros respectively. All of + the public and private function declarations from tcl.h and + tclInt.h have moved into the *.decls files and the *Stubs.c and + *Decls.h files are generated using the genStubs.tcl script. * unix/Makefile.in: * unix/configure.in: @@ -255,44 +593,399 @@ all platforms, even though it is currently a noop on mac and windows, and renamed it to TclpGetUserHome. - * generic/tclCkalloc.c: Added stub versions of memory checking - functions when compiling without TCL_MEM_DEBUG. + * generic/tclPanic.c: + * generic/panic.c: Renamed panic to Tcl_Panic. + +1999-02-25 - * doc/ByteArrObj.3: - * generic/tcl.h: - * generic/tclBinary.c: - * generic/tclObj.c: Ported the 8.1 ByteArray type back to 8.0. + * win/makefile.vc: Added tclWinConsole.c and tclWinSerial.c - * generic/tcl.decls: + * win/tclWinConsole.c: New code to properly deal with fileevents + and nonblocking mode on consoles. + + * win/tclWinSerial.c: New code to properly deal with fileevents + and nonblocking mode on serial ports. + + * win/tclWinPipe.c: + * win/tclWinPort.h: Exported functions to allow creation of pipe + channels from tclWinChan.c + + * win/tclWinChan.c: Check the type of a channel, including for the + standard (stdin/stdout/stderr), and use the correct channel type + to create the channel (file, serial, console, or pipe). + +1999-02-11 + + * README: + * generic/tcl.h: + * win/README.binary: + * win/README: + * unix/configure.in: + * mac/README: Updated version numbers to 8.1b2. + +1999-02-10 + + * library/auto.tcl: Fixed auto_mkindex so it handles .tbc files. + Did some general cleanup to handle bad eval statements that didn't + use "list". + + * unix/mkLinks: + * doc/SetVar.3: * generic/tcl.h: - * generic/tclBasic.c: - * generic/tclDecls.h: - * generic/tclInt.decls: + * generic/tclVar.c: Restored Tcl_ObjGetVar2 and Tcl_ObjSetVar2 + from 8.0. Renamed Tcl_Get/SetObjVar2 to Tcl_GetVar2Ex and + Tcl_SetVar2Ex. + +1999-02-10 + + INTEGRATED PATCHES FROM 8.0.5b2: + + * test/winPipe.test: Changed to remove echoArgs.tcl temporary file + when done. + + * tests/cmdAH.test: + * generic/tclFileName.c (TclGetExtension): Changed behavior so the + split happens at the last period in the name instead of the first + period of the last run of periods. So, "foo..o" is split into + "foo." and ".o" now. [Bug: 1126] + + * win/makefile.vc: Added better support for paths with spaces in + the name. Added .lib and support .dlls to the install-binaries + target. Added generate of a pkgIndex.tcl script to the + install-libraries target. + + * win/tclAppInit.c: + * unix/tclAppInit.c: + * mac/tclMacAppInit.c: + * generic/tclTest.c: Changed some EXTERN declarations to extern + since they are not defining exported interfaces. This avoids + generating useless declspec() attributes and makes the windows + makefile simpler. + + * generic/tcl.h: Moved Tcl_AppInit declaration to end and cleared + out TCL_STORAGE_CLASS so it is not declared with a declspec(). + + * tests/interp.test: + * generic/tclInterp.c (DeleteAlias): Changed to use + Tcl_DeleteCommandFromToken so we handle renames properly. This + avoids senseless panic. [Bug: 736] + + * unix/tclUnixChan.c: + * win/tclWinSock.c: + * doc/socket.n: Applied Gordon Chaffee's patch to handle failures + during asynchronous socket connection operations. This adds a new + "-error" fconfgure option to socket channels. [Bug: 893] + + * generic/tclProc.c: + * generic/tclNamesp.c: * generic/tclInt.h: - * generic/tclIntDecls.h: - * generic/tclIntPlatDecls.h: - * generic/tclIntPlatStubs.c: - * generic/tclIntStubs.c: - * generic/tclPlatDecls.h: - * generic/tclPlatStubs.c: - * generic/tclStubInit.c: - * generic/tclStubLib.c: - * generic/tclStubs.c: - * tools/genStubs.tcl: - * unix/configure.in: - * unix/Makefile.in: - * unix/tclConfig.sh.in: - * win/makefile.vc: - * win/tclWinPort.h: Added Tcl stubs implementation. There are - now two new macros USE_TCL_STUBS and USE_TCL_STUB_PROCS that - enable use of stubs and disable stub macros respectively. All of - the public and private function declarations from tcl.h and - tclInt.h have moved into the *.decls files and the *Stubs.c and - *Decls.h files are generated using the genStubs.tcl script. + * generic/tclCmdIL.c: + * generic/tclBasic.c: + * generic/tclVar.c: Applied patch from Viktor Dukhovni to + rationalize TCL_LEAVE_ERR_MSG behavior when creating variables. + + * generic/tclVar.c: Fixed bug in namespace tail computation. + Fixed bug where upvar could resurrect a namespace variable whose + namespace had been deleted. -1999-02-27 + * generic/tclCompile.c (TclCompileExprCmd): Eliminated yet another + bogus optimization in expression compilation. - * generic/tclPanic.c: - * generic/panic.c: renamed panic to Tcl_Panic, added macro for - backwards compatibility, renamed file to tclPanic.c + * unix/configure.in: Added branch for BSD/OS-4* to shared library + case statement. [Bug: 975] + Fixed to correctly handle IRIX 6.5 n32 library support. [Bug: 1117] + + * win/winDumpExts.c: Patched to be pickier about stripping + @'s. [Bug: 920] + + * library/http2.0/http.tcl: Added catch around eof test in + CopyDone since the user may have already called http::reset. + [Bug: 1108] + + * unix/configure.in: Changed Linux and IRIX to set SHLIB_LIBS to + LIBS so shared libraries are linked with the system + libraries. [Bug: 1018] + + * generic/tclCompile.c (CompileExprWord): Fixed exception stack + overflow bug caused by missing statement. [Bug: 928] + + * generic/tclIOCmd.c: + * generic/tclBasic.c: Objectified the "open" command. [Bug: 1113] + + * generic/tclPosixStr.c (Tcl_ErrnoId, Tcl_ErrnoMsg): When using + egcs, ENOTSUP and EOPNOTSUPP are the same, so now we handle that + case. [Bug: 1137] + + * library/init.tcl: Various small changes requested by Jan Nijtmans. + - If the variable $tcl_library contains the empty string, this + empty string will be put in $auto_path. This is not useful at all, + it only slows down later package processing. + - If the variable tcl_pkgPath is not set, the "unset __dir" + fails. Thich makes init.tcl totally unusable. Better put a "catch" + around it. + - In the function tcl_findLibraries, the "string match" function + only works correctly if $tcl_patchLevel is in one of the forms + "?.?a?", "?.?b?" or "?.?.?". Could a "regexp" be used instead, + then it allows anything to be appended to the patchLevel + string. And it is more efficient. + - The tclPkgSetup function assumes that if $type != "load" then + the type must be "source". This needn't be true. Some users want + to add their own setup types. + [RFE: 1138] [Bug: 978] + + * win/tclWinReg.c: + * doc/registry.n: Added support for HKEY_PERFORMANCE_DATA and + HKEY_DYN_DATA keys. [Bug: 1109] + + * win/tclWinInit.c (TclPlatformInit): Added code to ensure + tcl_pkgPath is set to "" when no registry entry is found. [Bug: 978] + +1999-02-01 + + * generic/tclBasic.c: + * generic/tclCmdAH.c: + * generic/tclCmdIL.c: + * generic/tclCmdMZ.c: + * generic/tclExecute.c: + * generic/tclHistory.c: + * generic/tclIO.c: + * generic/tclIOUtil.c: + * generic/tclInterp.c: + * generic/tclMain.c: + * generic/tclNamesp.c: + * generic/tclParse.c: + * generic/tclProc.c: + * generic/tclTest.c: + * generic/tclTimer.c: + * generic/tcl.h: Made eval interfaces compatible with 8.0 by + renaming Tcl_EvalObj to Tcl_EvalObjEx, renaming Tcl_Eval2 to + Tcl_EvalEx and restoring Tcl_EvalObj and Tcl_GlobalEvalObj + interfaces so they match Tcl 8.0. + +1999-01-28 + + * Merged Tcl 8.0.5b1 changes. + + * generic/tclUtil.c (Tcl_DStringSetLength): Changed so the buffer + overallocates in a manner similar to Tcl_DStringAppend. This + should improve performance for TclUniCharToUtfDString. + +1998-12-11 === Tcl 8.1b1 Release === + +1998-12-10 + + * Fixed lots of files that used TCL_THREAD instead of TCL_THREADS. + + * generic/tclEncoding.c (Tcl_FreeEncoding): Moved most of the code + into a static FreeEncoding routine that does not grab the + encodingMutex to avoid deadlocks/races when called from other + routines that already have the mutex. + +1998-12-09 + + * library/msgcat1.0/msgcat.tcl: Fixed bad export list, fixed so + all locale strings are converted to lower case, including file + names. + + * generic/regcomp.c (makescan): Fixed bug in longest match case + that caused anchored patterns to fail. [Bug: 897] + +1998-12-08 + + * library/msgcat1.0/msgcat.tcl: changed mc to invoke mcunknown in + the calling context, changed locale lookups to be case insensitive + +1998-12-07 + + * generic/tclAlloc.c (TclpRealloc): Fixed a memory allocation bug + where big blocks that were reallocated into a different heap + location were not being placed into the bigBlocks list. [Bug: 933] + + * tests/msgcat.test: Added message catalog test suite. + + * library/msgcat1.0/msgcat.tcl: minor bug fixes, integrated latest + changes from Mark Harrison. + +1998-12-04 + + * library/msgcat1.0/msgcat.tcl: Changed code to conform to Tcl + coding standards. Changed to use file join for portability. + + * library/msgcat1.0: Added initial implementaion of Tcl message + catalog package contributed by Mark Harrison. + +1998-12-03 + + * win/tclWinPipe.c (BuildCommandLine): Fixed bug that kept + arguments containing spaces from being properly quoted. + + * tests/defs: Changed so auto_path is set to only contain the Tcl + library directory. This keeps the tests from accidentally picking + up stuff in installed packages. + + * generic/tclUtil.c (Tcl_StringMatch): Changed to match 8.0 + behavior in corner case where there is no closing bracket. + +1998-12-02 + + * win/tclWinPipe.c (TclpCreateCommandChannel): Changed + reader/writer threads to have THREAD_PRIORITY_HIGHEST so they will + have a chance to run whenever there is something to do. + + * generic/tclIO.c (WriteBytes, WriteChars): Fixed so extraneous + flushes do not happen in line mode. + (TranslateOutputEOL): Made translation more efficient in line mode + and fixed a buffer overflow bug in CRLF translation. [Bug: 887] + +1998-12-02 + + * Updated patchlevel to 8.1b1 + +1998-12-02 + + * generic/regc_color.c (subcolor): Added check for error case to + avoid an out of bounds array reference. + + * generic/tclCmdAH.c (Tcl_EncodingObjCmd): Changed to avoid using + Tcl_DStringResult because it is not binary clean. + + * generic/tclParse.c (Tcl_ParseCommand): Fixed bug in comment + parsing where a trailing comment looked like an incomplete + command. + +1998-12-02 + + * Merged changes from 8.0.4, especially the new pkg_mkIndex + +1998-12-01 + + * generic/tclIO.c (Tcl_ReadChars): Added a call to UpdateInterest + so we don't block when there is data sitting in the buffers. + + * generic/tclTest.c (TestevalobjvObjCmd): Updated for EvalObjv + change. + + * tests/parse.test: Updated tests for EvalObjv change. + + * generic/tclParse.c (EvalObjv, Tcl_EvalObjv): Changed + Tcl_EvalObjv interface to remove string and length arguments, + preserved original interface as EvalObjv for internal use. + + * generic/tcl.h: Changed Tcl_EvalObjv interface to remove string + and length arguments. + + * doc/Eval.3: Updated documentation for Tcl_EvalObjv to remove + string and length arguments. + + * generic/tclCompCmds.c (TclCompileForeachCmd): Fixed code that + corrupted the exceptDepth value in the compile environment when + foreach failed to compile inline. [Bug: 884] + + * library/encoding/euc-kr.enc: + * library/encoding/ksc5601.enc: + * tools/encoding/ksc5601.txt: + * unix/tclUnixInit.c: Added support for Korean EUC. + + * win/tclWinChan.c (TclpGetDefaultStdChannel): added check for a + failure during Tcl_MakeFileChannel. + +1998-11-30 + + * unix/tclUnixNotfy.c (Tcl_WaitForEvent): Fixed hang that occurs + when trying to close a pipe that is currently being waited on by + the notifier thread. [Bug: 607] + + * unix/tclUnixFCmd.c (GetPermissionsAttribute): Increase size of + returnString buffer to avoid overflow. [Bug: 584] + + * generic/tclThreadTest.c (TclThreadSend): Fixed memory leak due + to use of TCL_VOLATILE instead of TCL_DYNAMIC. + + * generic/tclThread.c (TclRememberSyncObject): Fixed memory leak + caused by failure to reuse condition variables. + + * unix/tclUnixNotfy.c: (Tcl_AlertNotifier, Tcl_WaitForEvent, + NotifierThreadProc, Tcl_InitNotifier): Fixed race condition caused + by incorrect use of condition variables when sending messages + between threads.. [Bug: 607] + + * generic/tclTestObj.c (TeststringobjCmd): MAX_STRINGS was off by one + so the strings array was too small. + + * generic/tclCkalloc.c (Tcl_DbCkfree): Moved mutex lock so + ValidateMemory is done inside the mutex to avoid a race condition + when validate_memory is enabled. [Bug: 880] + +1998-11-23 + + * regexec.c: more performance tuning from Henry Spencer. + +1998-11-17 + + * tclScan.c: moved "scan" implementation out of tclCmdMZ.c and + added Unicode support. This required a complete reimplementation + of the command to avoid using scanf(), which isn't Unicode aware. + Two new features were added in the process: %n to return the + current number of characters consumed, and XPG3-style %n$ argument + order specifiers similar to those provided by the "format" + command. [Bug: 833] + + * tclAlloc.c: changed so allocated memory is always 8-byte aligned + to improve memory performance and to ensure that it will work on + systems that don't like accessing 4-byte aligned values + (e.g. Solaris and HP-UX). [Bug: 834] + +1998-11-06 + + * tclVar.c (TclGetIndexedScalar): Fixed bug 796, var name was + getting lost before being passed to CallTraces. + +1998-10-21 + + * added "encoding" command + + * Moved internal regexp declarations from tclInt.h to tclRegexp.h + + * integrated regexp updates from Henry Spencer + +1998-10-15 + + * tclUtf.c: added Unicode character table support + + * tclInt.h: added TclUniCharIsWordChar + + * tclCmdMZ.c (Tcl_StringObjCmd): added "totitle" subcommand, + changed "wordend" and "wordstart" to properly handle Unicode word + characters and connector punctuation + +1998-10-05 + + * auto.tcl, package.tcl: fixed SCCS strings + + * tclIndex: updated index to reflect 8.1 files + + * tclCompile.c (TclCompileScript): changed to avoid modifying the + input string in place because name lookup operations could have + arbitrary side effects + + * tclInterp.c: added guard against deleting current interpreter + + * tclMacFile.c, tclUnixFile.c, tclWinFile.c, tclFileName.c: added + warnings around code that modifies strings in place + + * tclExecute.c: fixed off-by-one copying error, fixed merge bugs + + * tclEvent.c: changed so USE_TCLALLOC is tested for value instead + of definition + + * tclCompCmds.c: replaced SCCS strings, added warnings around code + that modifies strings in place + + * interp.test: added test for interp deleting itself + +1998-09-30 + + * makefile.vc: fixed so TCL_LIBRARY is set before running tcltest + + * tclWin32Dll.c: removed TclpFinalize, cleanup of merges diff --git a/README b/README index ff54e6e..00e549d 100644 --- a/README +++ b/README @@ -3,14 +3,14 @@ README: Tcl Tcl is maintained, enhanced, and distributed freely as a service to the Tcl community by Scriptics Corporation. -RCS: @(#) $Id: README,v 1.15 1999/02/26 22:25:04 hershey Exp $ +RCS: @(#) $Id: README,v 1.16 1999/04/16 00:46:29 stanton Exp $ Contents -------- 1. Introduction 2. Documentation 3. Compiling and installing Tcl - 4. Summary of changes in Tcl 8.0 + 4. Summary of changes in Tcl 8.1 5. Development tools 6. Tcl newsgroup 7. Tcl contributed archive @@ -31,23 +31,23 @@ variety of web-related tasks and for creating powerful command languages for applications. This directory contains the sources and documentation for Tcl. The -information here corresponds to release 8.0.5, which is the fifth -patch update for Tcl 8.0. This patch provides bug fixes and -incorporates user-contributed patches. Please check the changes file -for details. - -Tcl 8.0 is a major release that replaces the core of the interpreter -with an on-the-fly bytecode compiler to improve execution speed. It -also includes several other new features such as namespaces and binary -I/O, plus many bug fixes. The compiler introduces a few -incompatibilities that may affect existing Tcl scripts; the -incompatibilities are relatively obscure but may require modifications -to some old scripts before they can run with this version. The -compiler introduces many new C-level APIs, but the old APIs are still -supported. See below for more details. +information here corresponds to release 8.1b3, which is the third +beta release for Tcl 8.1. This release is mostly feature complete but +may have bugs and be missing some minor features. This release is for +early adopters who are willing to help us find and fix problems. +Please let us know about any problems you uncover. + +Tcl 8.1 includes four major new features: Unicode support (all internal +strings are now stored in UTF-8 form), a new regular expression matcher +with most of the Perl features, support for multithreading, and a new +message catalog package. For details on features, incompatibilities, and +potential problems with this release, see the Tcl/Tk 8.1 Web page at +http://www.scriptics.com/software/8.1.html or refer to the "changes" file +in this directory, which contains a historical record of all changes to +Tcl. Tcl is a freely available open source package. You can do virtually -anything you like with it, such as modifying it, redistributing it , +anything you like with it, such as modifying it, redistributing it, and selling it either in whole or in part. See the file "license.terms" for complete information. @@ -143,138 +143,87 @@ compiling under UNIX, "win" if you're compiling under Windows, or in the README file in that directory for compiling Tcl, installing it, and running the test suite. -4. Summary of changes in Tcl 8.0 +4. Summary of changes in Tcl 8.1 -------------------------------- -Here are the most significant changes in Tcl 8.0. In addition to these +Here are the most significant changes in Tcl 8.1. In addition to these changes, there are several smaller changes and bug fixes. See the file "changes" for a complete list of all changes. - 1. Bytecode compiler. The core of the Tcl interpreter has been - replaced with an on-the-fly compiler that translates Tcl scripts to - byte codes; a new interpreter then executes the byte codes. In - earlier versions of Tcl, strings were used as a universal - representation; in Tcl 8.0 strings are replaced with Tcl_Obj - structures ("objects") that can hold both a string value and an - internal form such as a binary integer or compiled bytecodes. The - new objects make it possible to store information in efficient - internal forms and avoid the constant translations to and from - strings that occurred with the old interpreter. We have not yet - converted all of Tcl to take full advantage of the compiler and - objects and have not converted any of Tk yet, but even so you - should see speedups of 2-3x on many programs and you may see - speedups as much as 10-20x in some cases (such as code that - manipulates long lists). Future releases should achieve even - greater speedups. The compiler introduces only a few minor changes - at the level of Tcl scripts, but it introduces many new C APIs for - managing objects. See, for example, the manual entries doc/*Obj*.3. - - 2. Namespaces. There is a new namespace mechanism based on the - namespace implementation by Michael McLennan of Cadence. - This includes new "namespace" and "variable" commands. There are - many new C APIs associated with namespaces, but they will not be - exported until Tcl 8.1. Note: the syntax of the namespace command - has been changed slightly since the b1 release. See the changes - file for details. - - 3. Binary I/O. The new object system in Tcl 8.0 supports binary - strings (internally, strings are counted in addition to being null - terminated). There is a new "binary" command for inserting and - extracting data to/from binary strings. Commands such as "puts", - "gets", and "read" commands now operate correctly on binary data. - There is a new variable tcl_platform(byteOrder) to identify the - native byte order for the current host. - - 4. Random numbers. The "expr" command now contains a random number - generator, which can be accessed via the "rand()" and "srand()" math - functions. - - 5. Safe-Tcl enhancements. There is a new "hidden command" - mechanism, implemented with the Tcl commands "interp hide", "interp - expose", "interp invokehidden", and "interp hidden" and the C APIs - Tcl_HideCommand and Tcl_ExposeCommand. There is now support for - safe packages and extension loading, including new library - procedures such as safe::interpCreate (see the manual entry safe.n - for details). - - 6. There is a new package "registry" available under Windows for - accessing the Windows registry. - - 7. There is a new command "file attributes" for getting and setting - things like permissions and owner. There is also a new command - "file nativename" for getting back the platform-specific name for a - particular file. - - 8. There is a new "fcopy" command to copy data between channels. - This replaces and improves upon the not-so-secret unsupported old - command "unsupported0". - - 9. There is a new package "http" for doing GET, POST, and HEAD - requests via the HTTP/1.0 protocol. See the manual entry http.n - for details. - - 10. There are new library procedures for finding word breaks in - strings. See the manual entry library.n for details. - - 11. There are new C APIs Tcl_Finalize (for cleaning up before - unloading the Tcl DLL) and Tcl_Ungets for pushing bytes back into a - channel's input buffer. - - 12. Tcl now supports serial I/O devices on Windows and Unix, with a - new fconfigure -mode option. The Windows driver does not yet - support event-driven I/O. - - 13. The lsort command has new options -dictionary and -index. The - -index option allows for very rapid sorting based on an element - of a list. - - 14. The event notifier has been completely rewritten (again). It - should now allow Tcl to use an external event loop (like Motif's) - when it is embedded in other applications. No script-level - interfaces have changed, but many of the C APIs have. - -Tcl 8.0 introduces the following incompatibilities that may affect Tcl -scripts that worked under Tcl 7.6 and earlier releases: - - 1. Variable and command names may not include the character sequence - "::" anymore: this sequence is now used as a namespace separator. - - 2. The semantics of some Tcl commands have been changed slightly to - maximize performance under the compiler. These incompatibilities - are documented on the Web so that we can keep the list up-to-date. - See the following URL: - - http://www.scriptics.com/doc/compiler.html - - 3. 2-digit years are now parsed differently by the "clock" command - to handle year 2000 issues better (years 00-38 are treated as - 2000-2038 instead of 1900-1938). - - 4. The old Macintosh commands "cp", "mkdir", "mv", "rm", and "rmdir" - are no longer supported; all of these features are now available on - all platforms via the "file" command. - - 5. The variable tcl_precision is now shared between interpreters - and defaults to 12 digits instead of 6; safe interpreters cannot - modify tcl_precision. The new object system in Tcl 8.0 causes - floating-to-string conversions (and the associated rounding) to - occur much less often than in Tcl 7.6, which can sometimes cause - behavioral changes. - - 6. The C APIs associated with the notifier have changed substantially. - - 7. The procedures Tcl_CreateModalTimeout and Tcl_DeleteModalTimeout - have been removed. - - 8. Tcl_CreateFileHandler and Tcl_DeleteFileHandler now take Unix - fd's and are only supported on the Unix platform - - 9. The C APIs for creating channel drivers have changed as part of - the new notifier implementation. The Tcl_File interfaces have been - removed. Tcl_GetChannelFile has been replaced with - Tcl_GetChannelHandle. Tcl_MakeFileChannel now takes a platform- - specific file handle. Tcl_DriverGetOptionProc procedures now take - an additional interp argument. + 1. Internationalization. Tcl has undergone a major revision to + support international character sets: + + All strings in Tcl are now represented in UTF-8 instead of ASCII, + so that Tcl now supports the full Unicode character set. The + representation of ASCII characters is unchanged (in UTF-8 anything + that looks like an ASCII character is an ASCII character), but + characters with the high-order bit set, such as those in ISO-8859, + are represented with multi-byte sequences, as are all Unicode + characters with values greater than 127. This change does not + affect Tcl scripts but it does affect C code that parses strings. + Tcl automatically translates between UTF-8 and the normal encoding + for the platform during interactions with the system. + + In Tcl scripts the backslash sequence \u can be used to enter + 16-bit Unicode characters. \o and \x generate only 8-bit + characters as before. + + There is a new "encoding" command that allows scripts to determine + what encodings are available as well as to convert strings between + different encodings. The fconfigure command now supports a + -encoding option for specifying the encoding of an open file or + socket. Tcl will automatically translate between the specified + encoding and UTF-8 during I/O. + + There are several new C APIs that support UTF-8 and various + encodings. See the manual entry Utf.3 for procedures that + translate between Unicode and UTF-8 and manipulate UTF-8 strings. + See Encoding.3 for procedures that create new encodings and + translate between encodings. See ToUpper.3 for procedures that + perform case conversions on UTF-8 strings. + + 2. Binary data. Binary data is handled differently in Tcl 8.1 + than in Tcl 8.0. Tcl 8.1 uses the UTF-8 facilities to represent + binary data: the character value zero is represented with a + multi-byte sequence, so that (once again) strings in Tcl 8.1 never + contain null bytes. This means that binary data is now accepted + everywhere in Tcl and Tk (in Tcl 8.0 the support for binary data + was incomplete). If you have C code that needs to manipulate the + bytes of binary data (as opposed to just passing the data through) + you should use a new object type called "byte array". See the + manual entry ByteArrObj.3 for information about procedures such as + Tcl_GetByteArrayFromObj. + + 3. Regular expressions. Tcl 8.1 contains a brand new + implementation of regular expressions from Henry Spencer. The + regular expression syntax has been greatly expanded to include + most of the features in Perl. In addition, the regexp engine + supports Unicode and binary data. See the doc/regexp.n manual + entry for more details. + + 4. Threads. If configured with the --enable-threads flag, Tcl can + now be compiled for use in a multi-threaded application. + Individual threads are allowed to use one or more interpreters as + long as each interpreter (and any slave interpreters) is only + accessed by one thread. Each thread runs its own event loop, and + you can post events to other threads. There are new C APIs for + mutexes, condition variables, and thread local storage. See the + doc/Thread.3 manual entry for more details. Tk 8.1 is not yet + multi-thread safe. There is not yet support for tcl level use of + threading except for a test command. (Compile tcltest and try + testthread.) + + 5. Message catalog. There is a new message catalog package which makes + it easy to localize the strings in a script. See the doc/msgcat.n + manual entry for more details. + + 6. Stubbs library for building extensions. There is now a new + way to build extensions for Tcl. Instead of linking with the + tcl shared library you can now link to a stubs library that gets + built in this release. By linking with the stubs library it + is possible to use dynamically loaded extensions in staticlly + built applications. It will also be possible for some extensions + to work for both Tcl 8.0 & 8.1 with out having to recompile. 5. Development tools -------------------- diff --git a/changes b/changes index e46d87f..7ee8d72 100644 --- a/changes +++ b/changes @@ -1,6 +1,6 @@ Recent user-visible changes to Tcl: -RCS: @(#) $Id: changes,v 1.42 1999/04/15 22:40:33 stanton Exp $ +RCS: @(#) $Id: changes,v 1.43 1999/04/16 00:46:29 stanton Exp $ 1. No more [command1] [command2] construct for grouping multiple commands on a single command line. @@ -2547,7 +2547,7 @@ changes are to expressions and lists. incorrect programs that took advantage of behavior of the old implementation that was not documented in the man pages. Other changes to Tcl scripts are discussed in the web page at -http://www.sunlabs.com/research/tcl/compiler.html. (BL) +http://www.scriptics.com/doc/compiler.html. (BL) *** POTENTIAL INCOMPATIBILITY *** 10/21/96 (new feature) In earlier versions of Tcl, strings were used as a @@ -3115,7 +3115,7 @@ activity. A refcount bug triggered a panic in Tcl_ListObjAppendElement. (BW) 7/8/97 (bug fix) Relaxed the pattern matching on http_get so you do not need a trailing path component. You can now get away with just -http_get sunscript.sun.com (BW) +http_get www.scriptics.com (BW) 7/9/97 (bug fix) Creating anonymous interpreters no longer smashes existing commands with names similar to the generated name. Previously creating an @@ -3655,7 +3655,7 @@ to update them to n32 for them to work with Tcl. (RJ) pathnames it searched for the initialization script. tclInitScript.h was incorrectly adding the parent of tcl_library to tcl_pkgPath. This logic was moved into init.tcl, and the initialization of auto_path was -documented. Thanks to Donald Porter and Tom Silva for related +documented. Thanks to Donald Porter and Tom Silva for related patches. (BW) 10/29/98 (bug fix) Fixed Tcl_NotifyChannel to use Tcl_Preserve instead @@ -3668,18 +3668,18 @@ command. (BW) package requires and packages split among scripts and binary files. Also fixed ommision of global for errorInfo in tcl_findLibrary. (BW) -11/08/98 (bug fix) Fixed the resource command to always detect the -case where a file is opened a second time with the same permissions. -IM claims that this will always cause the same FileRef to be returned, -but in MacOS 8.1+, this is no longer the case, so we have to test for -this equality explicitly. (JI) +11/08/98 (bug fix) Fixed the resource command to always detect +the case where a file is opened a second time with the same +permissions. IM claims that this will always cause the same +FileRef to be returned, but in MacOS 8.1+, this is no longer the case, +so we have to test for this explicitly. (JI) 11/10/98 (feature change) When compiling with Metrowerk's MSL, use the exit function from MSL rather than ExitToShell. This allows MSL to clean up its temporary files. Thanks to Vince Darley for this improvement. (JI) ------------------ Released 8.0.4, 11/19/98 ----------------------- +----------------- Released 8.0.4, 11/19/98 ------------------------- 11/20/98 (bug fix) Handle possible NULL return in TclGetStdFiles. (RJ) @@ -3741,4 +3741,569 @@ extension" so that it splits at the last period. Now the extension of a file like "foo..o" is ".o" instead of "..o" as in previous versions. *** POTENTIAL INCOMPATIBILITY *** ------------------ Released 8.0.5, 3/9/99 ----------------------- +----------------- Released 8.0.5, 3/9/99 ------------------------- + +======== Changes for 8.0 go above this line ======== +======== Changes for 8.1 go below this line ======== + +6/18/97 (new feature) Tcl now supports international character sets: + - All C APIs now accept UTF-8 strings instead of iso8859-1 strings, + wherever you see "char *", unless explicitly noted otherwise. + - All Tcl strings represented in UTF-8, which is a convenient + multi-byte encoding of Unicode. Variable names, procedure names, + and all other values in Tcl may include arbitrary Unicode characters. + For example, the Tcl command "string length" returns how many + Unicode characters are in the argument string. + - For Java compatibility, embedded null bytes in C strings are + represented as \xC080 in UTF-8 strings, but the null byte at the end + of a UTF-8 string remains \0. Thus Tcl strings once again do not + contain null bytes, except for termination bytes. + - For Java compatibility, "\uXXXX" is used in Tcl to enter a Unicode + character. "\u0000" through "\uffff" are acceptable Unicode + characters. + - "\xXX" is used to enter a small Unicode character (between 0 and 255) + in Tcl. + - Tcl automatically translates between UTF-8 and the normal encoding for + the platform during interactions with the system. + - The fconfigure command now supports a -encoding option for specifying + the encoding of an open file or socket. Tcl will automatically + translate between the specified encoding and UTF-8 during I/O. + See the directory library/encoding to find out what encodings are + supported (eventually there will be an "encoding" command that + makes this information more accessible). + - There are several new C APIs that support UTF-8 and various encodings. + See Utf.3 for procedures that translate between Unicode and UTF-8 + and manipulate UTF-8 strings. See Encoding.3 for procedures that + create new encodings and translate between encodings. See + ToUpper.3 for procedures that perform case conversions on UTF-8 + strings. + +9/18/97 (enhancement) Literal objects are now shared by the ByteCode +structures created when compiled different scripts. This saves up to 45% +of the total memory needed for all literals. (BL) + +9/24/97 (bug fixes) Fixed Tcl_ParseCommand parsing of backslash-newline +sequences at start of command words. Suppressed Tcl_EvalDirect error logging +if non-TCL_OK result wasn't an error. (BL) + +10/17/97 (feature enhancement) "~username" now refers to the users' home +directory on Windows (previously always returned failure). (CCS) + +10/20/97 (implementation change) The Tcl parser has been completely rewritten +to make it more modular. It can now be used to parse a script without actually +executing it. The APIs for the new parser are not correctly exported, but +they will eventually be exported and augmented with Tcl commands so that +Tcl scripts can parse other Tcl scripts. (JO) + +10/21/97 (API change) Added "flags" argument to Tcl_EvalObj, removed +Tcl_GlobalEvalObj procedure. Added new procedures Tcl_Eval2 and +Tcl_EvalObjv. (JO) +*** POTENTIAL INCOMPATIBILITY *** + +10/22/97 (API change) Renamed Tcl_ObjSetVar2 and Tcl_ObjGetVar2 to +Tcl_SetObjVar2 and Tcl_GetObjVar2 (for consistency with other C APIs) +and changed the name arguments to be strings instead of objects. (JO) +*** POTENTIAL INCOMPATIBILITY *** + +10/27/97 (enhancement) Bytecode compiler rewritten to use the new Tcl +parser. (BL) + +11/3/97 (New routines) Added Tcl_AppendObjToObj, which appends the +string rep of one Tcl_Obj to another. Added Tcl_GetIndexFromObjStruct, +which is similar to Tcl_GetIndexFromObj, except that you can give an +offset between strings. This allows Tcl_GetIndexFromObjStruct to be +called with a table of records which have strings in them. (SRP) + +12/4/97 (enhancement) New Tcl expression parser added. Added new procedure +Tcl_ParseExpr and new token types TCL_TOKEN_SUB_EXPR and +TCL_TOKEN_OPERATOR. Expression compiler is reimplemented to use this +parser. (BL) + +12/9/97 (bug fix) Tcl_EvalObj() increments/decrements the refcount of the +script object to prevent the object from deleting itself while in the +middle of being evaluated. (CCS) + +12/9/97 (bug fix) Memory leak in Tcl_GetsObjCmd(). (CCS) + +12/11/97 (bug fix) Environment array leaked memory when compiled with +Visual C++. (SS) + +12/11/97 (bug fix) File events and non-blocking I/O did not work on +pipes under Windows. Changed to use threads to achieve non-blocking +behavior. (SS) + +12/18/97 (bug fixes) Fixed segfault in "namespace import"; importing a +procedure that causes a cycle now returns an error. Modified "info procs", +"info args", "info body", and "info default" to return information about +imported procedures as well as procedures defined in a namespace. (BL) + +12/19/97 (enhancement) Added new Tcl_GetString() procedure that can be used +in place of Tcl_GetStringFromObj() if the string representation's length +isn't needed. (BL) + +12/18/97 (bug fix) In the opt argument parsing package: if the description +had only flags, the "too many arguments" case was not detected. The default +value was not used for the special "args" ending argument. (DL) + +1/7/98 (clean up) Moved everything not absolutly necessary out of init.tcl +procs now in auto.tcl and package.tcl can be autoloaded if needed. (DL) + +1/7/98 (enhancement) tcltest made at install time will search for it's +init.tcl where it is, even when using virtual path compilation. (DL) + +1/8/98 (os bug workaround) when needed, using a replacement for memcmp so +string compare "char with high bit set" "char w/o high bit set" returns +the expected value on all platforms. (DL) + +1/8/98 (unix portability/configure) building from .../unix/targetName/ +subdirectories and simply using "../configure" should now work fine. (DL) + +1/14/98 (enhancement) Added new regular expression package that +supports AREs, EREs, and BREs. The new package includes new escape +characters, meta-syntax, and character classes inside brackets. +Regexps involving backslashes may behave differently. (MH) +*** POTENTIAL INCOMPATIBILITY *** + +1/16/98 (os workaround) Under windows, "file volume" was causing chatter +and/or several seconds of hanging when querying empty floppy drives. +Changed implementation to call an empirically-derived function that doesn't +cause this. (CCS) + +1/16/98 (enhancement) Converted regular expressions to a Tcl_Obj type so +their compiled form gets cached automatically. Reduced NSUBEXP from 100 +to 20. (BW) + +1/16/98 (documentation) Change unclear documentation and comments for +functions like Tcl_TranslateFileName() and Tcl_ExternalToUtfDString(). Now +it explicitly says they take an uninitialized or free DString. A DString +that is "empty" or "not holding anything" could have been interpreted as one +currently with a zero length, but with a large dynamically allocated buffer. +(CCS) + +----------------- Released 8.1a1, 1/22/98 ----------------------- + +1/28/98 (new feature) Added a "-direct" optional flag to pkg_mkIndex +to generate direct loading package indexes (such those you need +if you use namespaces and plan on using namespace import just after +package require). pkg_mkIndex still has limitations regarding +package dependencies but errors are now ignored and with -direct, correct +package indexes can be generated even if there are dependencies as long +as the "package provide" are done early enough in the files. (DL) + +1/28/98 (enhancement) Performance tuning of regexp and regsub. (CCS) + +1/28/98 (bug fix) regexp and regsub with "-indices" returned the byte-offsets +of the characters in the UTF-8 representation, not the character offsets +themselves. (CCS) + +1/28/98 (bug fix) "clock format 0 -format %Z -gmt 1" would return the local +timezone string instead of "GMT" on Solaris and Windows. + +1/28/98 (bug fix) Restore tty settings when closing serial device on Unix. +This is good behavior when closing real serial devices, essential when +closing the pseudo-device /dev/tty because the user's terminal settings +would be left useless, in raw mode, when tcl quit. (CCS) + +1/28/98 (bug fix) Tcl_OpenCommandChannel() was modifying the contents of the +argv array passed to it, causing problems for any caller that wanted to +continue to use the argv array after calling Tcl_OpenCommandChannel(). (CCS) + +2/1/98 (bug fix) More bugs with %Z in format string argument to strftime(): +1. Borland always returned empty string. +2. MSVC always returned the timezone string for the current time, not the + timezone string for the specified time. +3. With MSVC, "clock format 0 -format %Z -gmt 1" would return "GMT" the first + time it was called, but would return the current timezone string on all + subsequent calls. (CCS) + +2/1/98 (bug fix) "file stat" was broken on Windows. +1. "file stat" of a root directory (local or network) or a relative path that + resolved to a root directory (c:. when in pwd was c:/) was returning error. +2. "file stat" on a regular file (S_IFREG), the st_mode was sign extended to + a negative int if the platform-dependant type "mode_t" was declared as a + short instead of an unsigned short. +3. "file stat" of a network directory, the st_dev was incorrectly reported + as the id of the last accessed local drive rather than the id of the + network drive. (CCS) + +2/1/98 (bug fix) "file attributes" of a relative path that resolved to a +root directory was returning error. (CCS) + +2/1/98 (bug fix) Change error message when "file attribute" could not +determine the attributes for a file. Previously it would return different +error messages on Unix vs. Windows vs. Mac. (CCS) + +2/4/98 (bug fixes) Fixed several instances of bugs where the parser/compiler +would reach outside the range of allocated memory. Improved the array +lookup algorithm in set compilation. (DL) + +2/5/98 (change) The TCL_PARSE_PART1 flag for Set/Get(Obj)Var2 C APIs is now +deprecated and ignored. The part1 is always parsed when the part2 argument +is NULL. This is to avoid a pattern of errors for extension writers converting +from string based Tcl_SetVar() to new Tcl_SetObjVar2() and who could easily +forget to provide the flag and thus get code working for normal variables +but not for array elements. The performance hit is minimal. A side effect +of that change is that is is no longer possible to create scalar variables +that can't be accessed by tcl scripts because of their invalid name +(ending with parenthesis). Likewise it is also parsed and checked to +ensure that you don't create array elements of array whose name is a valid +array element because they would not be accessible from scripts anyway. +Note: There is still duplicate array elements parsing code. (DL) +*** POTENTIAL INCOMPATIBILITY *** + +2/11/98 (bug fix) Sharing objects between interps, such as by "interp +eval" or "send" could cause a crash later when dereferencing an interp +that had been deleted, given code such as: + set a {set x y} + interp create foo + interp eval foo $a + interp delete foo + unset a +Interp "foo" was gone, but "a" had a internal rep consisting of bytecodes +containing a dangling pointer to "foo". Unsetting "a" would attempt to +return resources back to "foo", causing a crash as random memory was +accessed. The lesson is that that if an object's internal rep depends on +an interp (or any other data structure) it must preserve that data in +some fashion. (CCS) + +2/11/98 (enhancement) The "interp" command was returning inconsistent error +messages when the specified slave interp could not be found. (CCS) + +2/11/98 (bug fix) Result codes like TCL_BREAK and TCL_CONTINUE were not +propagating through the master/slave interp boundaries, such as "interp +eval" and "interp alias". TCL_OK, TCL_ERROR, and non-standard codes like +teh integer 57 work. There is still a question as to whether TCL_RETURN +can/should propagate. (CCS) + +2/11/98 (bug fix) TclCompileScript() was derefering memory 1 byte before +start of the string to compile, looking for ']'. (CCS,DL) + +2/11/98 (bug fix) Tcl_Eval2() was derefering memory 1 byte before start +of the string to eval, looking for ']'. (CCS,DL) + +2/11/98 (bug fix) Compiling "set a(b" was running off end of string. (CCS,DL) + +2/11/98 (bug fix) Windows initialization code was dereferencing +uninitialized memory if TCL_LIBRARY environment didn't exist. (CCS) + +2/11/98 (bug fix) Windows "registry" command was dereferencing +uninitialized memory when constructing the $errorCode for a failed +registry call. (CCS) + +2/11/98 (enhancement) Eliminate the TCL_USE_TIMEZONE_VAR definition from +configure.in, because it was the same information as the already existing +HAVE_TM_ZONE definition. The lack of HAVE_TM_ZONE is used to work around a +Solaris and Windows bug where "clock format [clock sec] -format %Z -gmt 1" +produces the local timezone string instead of "GMT". (CCS) + +2/11/98 (bug fix) Memleaks and dereferencing of uninitialized memory in +regexp if an error occurred while compiling a regular expression. (CCS). + +2/18/98 (new feature) Added mutexes and thread local storage in order +to make Tcl thread safe. For testing purposes, there is a testthread +command that creates a new thread and an interpreter inside it. See +thread.test for examples, but this script-level interface is not fixed. +Each thread has its own notifier instance to manage its own events, +and threads can post messages to each other's message queue. +This uses pthreads on UNIX, and native thread support on other platforms. +You enable this by configuring with --enable-threads. Note that at +this time *Tk* is still not thread safe. Special thanks to +Richard Hipp: his earlier implementation inspired this work. (BW, SS, JI) + +2/18/98 (hidden feature change) The way the env() array is shared among +interpreters changed. Updates to env used to trigger write traces in +other interpreters. This undocumented feature is no longer implemented. +Instead, variable tracing is used to keep the C-level environ array in sync +with the Tcl-level env array. This required adding TCL_TRACE_ARRAY support +to Tcl_TraceVar2 so that array names works properly. (BW) +*** POTENTIAL INCOMPATIBILITY *** + +2/18/98 (enhancement) Conditional compilation for unix systems (e.g., +IRIX, SCO) that use f_bsize instead of st_blksize to determine disk block +size. (CCS) + +2/23/98 (bug fix) Fixed the emulation of polling selects in the threaded +version of the Unix notifier. The bug was showing up on a multiprocessor +as starvation of the notifier thread. (BW) + +----------------- Released 8.1a2, Feb 23 1998 ----------------------- + +9/22/98 (bug fix) Changed the value of TCL_TRACE_ARRAY so it no longer +conflicts with the deprecated TCL_PARSE_PART1 flag. This should +improve portability of C code. (stanton) + +10/6/98 (bug fix) The compile procedure for "if" incorrectly attempted +to match against the literal string "if", resulting in a stack +overflow when "::if" was compiled. It also would incorrectly accept +"if" instead of "elsif" in later clauses. (stanton) + +10/15/98 (new feature) Added a "totitle" subcommand to the "string" +command to convert strings to capitalize the first character of a string +and lowercase all of the other characters. (stanton) + +10/15/98 (bug fix) Changed regexp and string commands to properly +handle case folding according to the Unicode character +tables. (stanton) + +10/21/98 (new feature) Added an "encoding" command to facilitate +translations of strings between different character encodings. See +the encoding.n manual entry for more details. (stanton) + +11/3/98 (bug fix) The regular expression character classification +syntax now includes Unicode characters in the supported +classes. (stanton) + +11/6/98 (bug fix) Variable traces were causing crashes when upvar +variables went out of scope. [Bug: 796] (stanton) + +11/9/98 (bug fix) "format" now correctly handles multibyte characters +in %s format strings. (stanton) + +11/10/98 (new feature) "regexp" now accepts three new switches +("-line", "-lineanchor", and "-linestop") that control how regular +expressions treat line breaks. See the regexp manual entry for more +details. (stanton) + +11/17/98 (bug fix) "scan" now correctly handles Unicode +characters. (stanton) + +11/17/98 (new feature) "scan" now supports XPG3 position specifiers +and the "%n" conversion character. See the "scan" manual entry for +more details. (stanton) + +11/17/98 (bug fix) The Tcl memory allocator now returns 8-byte aligned +chunks of memory which improves performance on Windows and avoids +crashes on other platforms. [Bug: 834] (stanton) + +11/23/98 (bug fix) Applied various regular expression performance bug +fixes supplied by Henry Spencer. (stanton) + +11/30/98 (bug fix) Fixed various thread related race conditions. [Bug: +880 & 607] (stanton) + +11/30/98 (bug fix) Fixed a number of memory overflow and leak +bugs. [Bug: 584] (stanton) + +12/1/98 (new feaure) Added support for Korean encodings. (stanton) + +12/1/98 (feature change) Changed the Tcl_EvalObjv interface to remove +the string and length arguments. +*** POTENTIAL INCOMPATIBILITY with previous alpha releases *** + +12/2/98 (bug fix) Fixed various bugs related to line feed +translation. [Bug: 887] (stanton) + +12/4/98 (new feature) Added a message catalog facility to help with +localizing Tcl scripts. Thanks to Mark Harrison for contributing the +initial implementation of the "msgcat" package. (stanton) + +12/7/98 (bug fix) The memory allocator was failing to update the +block list for large memory blocks that were reallocated into a +different address. [Bug: 933] (stanton) + +----------------- Released 8.1b1, Dec 10 1998 ----------------------- + +12/22/98 (performance improvement) Improved the -command option of the +lsort command to better use the object system for improved +performance (about 5x speed up). Thanks to Syd Polk for suppling the +patch. [RFE: 726] (rjohnson) + +2/10/99 (bug fix) Restored the Tcl_ObjSetVar2/Tcl_ObjGetVar2 +interfaces from 8.0 and renamed the Tcl_GetObjVar2/Tcl_SetObjVar2 +interfaces to Tcl_GetVar2Ex and Tcl_SetVar2Ex. This should provide +better compatibility with 8.0. (stanton) +*** POTENTIAL INCOMPATIBILITY with previous alpha/beta releases *** + +2/10/99 (bug fix) Made the eval interfaces compatible with 8.0 by +renaming Tcl_EvalObj to Tcl_EvalObjEx, renaming Tcl_Eval2 to +Tcl_EvalEx and restoring Tcl_EvalObj and Tcl_GlobalEvalObj interfaces +so they match Tcl 8.0. (stanton) +*** POTENTIAL INCOMPATIBILITY with previous alpha/beta releases *** + +2/25/99 (bug fix/new feature) On Windows, the channel drivers for +consoles and serial ports now completely support file events. (redman) + +3/5/99 (bug fix) Integrated patches to fix various configure problems +that affected HP-UX-11, 64-bit IRIX, Linux, and Solaris. (stanton) + +3/9/99 (bug fix) Integrated various AIX related patches to improve +support for shared libraries. (stanton) + +3/9/99 (new feature) Added tcl_platform(user) to provide a portable +way to get the name of the current user. (welch) + +3/9/99 (new feature) Integrated the stub library mechanism contributed +by Jan Nijtmans, Paul Duffin, and Jean-Claude Wippler. This feature +should make it possible to write extensions that support multiple +versions of Tcl simultaneously. It also makes it possible to +dynamically load extensions into statically linked interpreters. This +patch includes the following changes: + - Added a Tcl_InitStubs() interface + - Added Tcl_PkgProvideEx, Tcl_PkgRequireEx, Tcl_PkgPresentEx, + and Tcl_PkgPresent. + - Added va_list versions of all VARARGS functions so they can be + invoked from wrapper functions. +See the manual for more information. (stanton) + + +3/10/99 (feature change) Replaced Tcl_AlertNotifier with +Tcl_ThreadAlert since the Tcl_AlertNotifier function relied on passing +internal data structures. (stanton) +*** POTENTIAL INCOMPATIBILITY with previous alpha/beta releases *** + +3/10/99 (new feature) Added a Tcl_GetVersion API to make it easier to +check the Tcl version and patch level from C. (redman) + +3/14/99 (feature change) Tried to unify the TclpInitLibrary path +routines to look in similar places from Windows to UNIX. The new +library search path is: TCL_LIBRARY, TCL_LIBRARY/../tcl8.1, relative +to DLL (Windows Only) relative to installed executable, relative to +develop executable, and relative to compiled-in in location (UNIX +Only.) This fix included: + - Defining a TclpFindExecutable + - Moving Tcl_FindExecutable to a common area in tclEncoding.c + - Modifying the TclpInitLibraryPath routines. +(surles) + +3/14/99 (feature change) Added hooks for TclPro Wrapper to initialize +the location of the encoding files and libraries. This fix included: + - Adding the TclSetPerInitScript routine. + - Modifying the Tcl_Init routines to evaluate the non-NULL + pre-init script. + - Adding the Tcl_SetdefaultEncodingDir and Tcl_GetDefaultEncodingDir + routines. + - Modifying the TclpInitLibrary routines to append the default + encoding dir. +(surles) + +3/14/99 (feature change) Test suite now uses "test" namespace to +define the test procedure and other auxiliary procedures as well as +global variables. + - Global array testConfige is now called ::test::testConfig. + - Global variable VERBOSE is now called ::test::verbose, and + ::test::verbose no longer works with numerical values. We've + switched to a bitwise character string. You can set + ::test::verbose by using the -verbose option on the Tcl command + line. + - Global variable TESTS is now called ::test::matchingTests, and + can be set on the Tcl command line via the -match option. + - There is now a ::test::skipTests variable (works similarly to + ::test::matchTests) that can be set on the Tcl command line via + the -match option. + - The test suite can now be run in any working directory. When + you run "make test", the working directory is nolonger switched + to ../tests. +(hirschl) +*** POTENTIAL INCOMPATIBILITY *** + +--------------- Released 8.1b2, March 16, 1999 ---------------------- + +3/18/99 (bug fix) Fixed missing/incorrect characters in shift-jis table +(stanton) + +3/18/99 (feature change) The glob command ignores the +FS_CASE_IS_PRESERVED bit on file systesm and always returns +exactly what it gets from the system. (stanton) +*** POTENTIAL INCOMPATIBILITY *** + +3/19/99 (new feature) Added support for --enable-64bit. For now, +this is only supported on Solaris 7 64bit (SunOS 5.7) using the Sun +compiler. (redman) + +3/23/99 (bug fix) Fixed fileevents and gets on Windows consoles and +serial devices so that non-blocking channels do not block on partial +input lines. (redman) + +3/23/99 (bug fix) Added a new Tcl_ServiceModeHook interface. +This is used on Windows to avoid the various problems that people +have been seeing where the system hangs when tclsh is running +outside of the event loop. As part of this, renamed +TclpAlertNotifier back to Tcl_AlertNotifier since it is public. +(stanton) + +3/23/99 (feature change) Test suite now uses "tcltest" namespace to +define the test procedure and other auxiliary procedures as well as +global variables. The previously chosen "test" namespace was thought +to be too generic and likely to create conflits. +(hirschl) +*** POTENTIAL INCOMPATIBILITY *** + +3/24/99 (bug fix) Make sockets thread safe on Windows. +(redman) + +3/24/99 (bug fix) Fix cases where expr would incorrect return +a floating point value instead of an integer. (stanton) + +3/25/99 (bug fix) Added ASCII to big5 and gb2312 encodings. +(stanton) + +3/25/99 (feature change) Changed so aliases are invoked at current +scope in the target interpreter instead of at the global scope. This +was an incompatibility introduced in 8.1 that is being removed. +(stanton) +*** POTENTIAL INCOMPATIBILITY with previous beta releases *** + +3/26/99 (feature change) --nameble-shared is now the default and build +Tcl as a shared library; specify --disable-shared to build a static Tcl +library and shell. +*** POTENTIAL INCOMPATIBILITY *** + +3/29/99 (bug fix) Removed the stub functions and changed the stub +macros to just use the name without params. Pass &tclStubs into the +interp (don't use tclStubsPtr because of collisions with the stubs on +Solaris). (redman) + +3/30/99 (bug fix) Loadable modules are now unloaded at the last +possible moment during Tcl_Finalize to fix various exit-time crashes. +(welch) + +3/30/99 (bug fix) Tcl no longer calls setlocale(). It looks at +env(LANG) and env(LC_TYPE) instead. (stanton) + +4/1/99 (bug fix) Fixed the Ultrix multiple symbol definition problem. +Now, even Tcl includes a copy of the Tcl stub library. (redman) + +4/1/99 (bug fix) Internationalized the registry package. + +4/1/99 (bug fix) Changed the implemenation of Tcl_ConditionWait and +Tcl_ConditionNotify on Windows. The new algorithm eliminates a race +condition and was suggested by Jim Davidson. (welch) + +4/2/99 (new apis) Made various Unicode utility functions public. +Tcl_UtfToUniCharDString, Tcl_UniCharToUtfDString, Tcl_UniCharLen, +Tcl_UniCharNcmp, Tcl_UniCharIsAlnum, Tcl_UniCharIsAlpha, +Tcl_UniCharIsDigit, Tcl_UniCharIsLower, Tcl_UniCharIsSpace, +Tcl_UniCharIsUpper, Tcl_UniCharIsWordChar, Tcl_WinUtfToTChar, +Tcl_WinTCharToUtf (stanton) + +4/2/99 (feature change) Add new DDE package and removed the Tk +send command from the Windows version. Changed DDE-based send +code into "dde eval" command. The DDE package can be loaded +into tclsh, not just wish. Windows only. (redman) + +4/5/99 (bug fix) Changed safe-tcl so that the encoding command +is an alias that masks out the "encoding system" subcommand. +(redman) + +4/5/99 (bug fix) Configure patches to improve support for +OS/390 and BSD/OS 4.*. (stanton) + +4/5/99 (bug fix) Fixed crash in the clock command that occurred +with negative time values in timezones east of GMT. (stanton) + +4/6/99 (bug fix) Moved the "array set" C level code into a common +routine (TclArraySet). The TclSetupEnv routine now uses this API to +create an env array w/ no elements. This fixes the bug caused when +every environ varaible is removed, and the Tcl env variable is +synched. If no environ vars existed, the Tcl env var would never be +created. (surles) + +4/6/99 (bug fix) Made the Env module I18N compliant. (surles) + +4/6/99 (bug fix) Changed the FindVariable routine to TclpFindVariable, +that now does a case insensitive string comparison on Windows, and not +on UNIX. (surles) + + +--------------- Released 8.1b3, April 6, 1999 ---------------------- + diff --git a/compat/memcmp.c b/compat/memcmp.c new file mode 100644 index 0000000..09a5724 --- /dev/null +++ b/compat/memcmp.c @@ -0,0 +1,61 @@ +/* + * memcmp.c -- + * + * Source code for the "memcmp" library routine. + * + * Copyright (c) 1998 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) memcmp.c 1.2 98/01/19 10:48:58 + */ + +#include "tcl.h" +#include "tclPort.h" + +/* + * Here is the prototype just in case it is not included + * in tclPort.h. + */ + +int memcmp _ANSI_ARGS_((CONST VOID *s1, + CONST VOID *s2, size_t n)); + +/* + *---------------------------------------------------------------------- + * + * memcmp -- + * + * Compares two bytes sequences. + * + * Results: + * compares its arguments, looking at the first n + * bytes (each interpreted as an unsigned char), and returns + * an integer less than, equal to, or greater than 0, accord- + * ing as s1 is less than, equal to, or + * greater than s2 when taken to be unsigned 8 bit numbers. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +memcmp(s1, s2, n) + CONST VOID *s1; /* First string. */ + CONST VOID *s2; /* Second string. */ + size_t n; /* Length to compare. */ +{ + unsigned char u1, u2; + + for ( ; n-- ; s1++, s2++) { + u1 = * (unsigned char *) s1; + u2 = * (unsigned char *) s2; + if ( u1 != u2) { + return (u1-u2); + } + } + return 0; +} diff --git a/compat/stdlib.h b/compat/stdlib.h index a9f30bc..6edeeae 100644 --- a/compat/stdlib.h +++ b/compat/stdlib.h @@ -9,12 +9,12 @@ * declare all the procedures needed here (such as strtod). * * Copyright (c) 1991 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 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: stdlib.h,v 1.2 1998/09/14 18:39:45 stanton Exp $ + * RCS: @(#) $Id: stdlib.h,v 1.3 1999/04/16 00:46:30 stanton Exp $ */ #ifndef _STDLIB diff --git a/compat/strftime.c b/compat/strftime.c index e99a046..d588433 100644 --- a/compat/strftime.c +++ b/compat/strftime.c @@ -8,7 +8,7 @@ * source. See the copyright notice below for details on redistribution * restrictions. The "license.terms" file does not apply to this file. * - * RCS: @(#) $Id: strftime.c,v 1.2 1998/09/14 18:39:45 stanton Exp $ + * RCS: @(#) $Id: strftime.c,v 1.3 1999/04/16 00:46:30 stanton Exp $ */ /* @@ -45,7 +45,7 @@ */ #if defined(LIBC_SCCS) -static char *rcsid = "$Id: strftime.c,v 1.2 1998/09/14 18:39:45 stanton Exp $"; +static char *rcsid = "$Id: strftime.c,v 1.3 1999/04/16 00:46:30 stanton Exp $"; #endif /* LIBC_SCCS */ #include @@ -105,7 +105,7 @@ static size_t _fmt _ANSI_ARGS_((const char *format, const struct tm *t)); size_t -TclStrftime(s, maxsize, format, t) +TclpStrftime(s, maxsize, format, t) char *s; size_t maxsize; const char *format; @@ -315,7 +315,7 @@ _fmt(format, t) continue; #ifndef MAC_TCL case 'Z': { - char *name = TclpGetTZName(); + char *name = TclpGetTZName(t->tm_isdst); if (name && !_add(name)) { return 0; } diff --git a/compat/string.h b/compat/string.h index a4df8ab..b7a0653 100644 --- a/compat/string.h +++ b/compat/string.h @@ -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: string.h,v 1.2 1998/09/14 18:39:45 stanton Exp $ + * RCS: @(#) $Id: string.h,v 1.3 1999/04/16 00:46:30 stanton Exp $ */ #ifndef _STRING @@ -32,8 +32,12 @@ extern char * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n)); extern int memcmp _ANSI_ARGS_((CONST VOID *s1, CONST VOID *s2, size_t n)); extern char * memcpy _ANSI_ARGS_((VOID *t, CONST VOID *f, size_t n)); +#ifdef NO_MEMMOVE +#define memmove(d, s, n) bcopy ((s), (d), (n)) +#else extern char * memmove _ANSI_ARGS_((VOID *t, CONST VOID *f, size_t n)); +#endif extern char * memset _ANSI_ARGS_((VOID *s, int c, size_t n)); extern int strcasecmp _ANSI_ARGS_((CONST char *s1, diff --git a/doc/AssocData.3 b/doc/AssocData.3 index 4ff36c8..9b68c43 100644 --- a/doc/AssocData.3 +++ b/doc/AssocData.3 @@ -5,7 +5,7 @@ '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" -'\" RCS: @(#) $Id: AssocData.3,v 1.2 1998/09/14 18:39:46 stanton Exp $ +'\" RCS: @(#) $Id: AssocData.3,v 1.3 1999/04/16 00:46:30 stanton Exp $ .so man.macros .TH Tcl_SetAssocData 3 7.5 Tcl "Tcl Library Procedures" .BS @@ -84,6 +84,6 @@ specified key exists in the given interpreter \fBTcl_GetAssocData\fR returns \fBNULL\fR. .PP \fBTcl_DeleteAssocData\fR deletes an association with a specified key in -the given interpreter. It does not call the deletion procedure. +the given interpreter. Then it calls the deletion procedure. .SH KEYWORDS association, data, deletion procedure, interpreter, key diff --git a/doc/Async.3 b/doc/Async.3 index 1c245cb..5086557 100644 --- a/doc/Async.3 +++ b/doc/Async.3 @@ -5,13 +5,13 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Async.3,v 1.2 1998/09/14 18:39:46 stanton Exp $ +'\" RCS: @(#) $Id: Async.3,v 1.3 1999/04/16 00:46:30 stanton Exp $ '\" .so man.macros .TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete \- handle asynchronous events +Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady \- handle asynchronous events .SH SYNOPSIS .nf \fB#include \fR diff --git a/doc/Backslash.3 b/doc/Backslash.3 index 382e8f2..95fc7e8 100644 --- a/doc/Backslash.3 +++ b/doc/Backslash.3 @@ -5,10 +5,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Backslash.3,v 1.2 1998/09/14 18:39:46 stanton Exp $ +'\" RCS: @(#) $Id: Backslash.3,v 1.3 1999/04/16 00:46:30 stanton Exp $ '\" .so man.macros -.TH Tcl_Backslash 3 "" Tcl "Tcl Library Procedures" +.TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Backslash \- parse a backslash sequence @@ -30,16 +30,24 @@ the backslash character. .SH DESCRIPTION .PP -This is a utility procedure used by several of the Tcl -commands. It parses a backslash sequence and returns -the single character corresponding to the sequence. -\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number -of characters in the backslash sequence. +.VS 8.1 +The use of \fBTcl_Backslash\fR is deprecated in favor of +\fBTcl_UtfBackslash\fR. .PP -See the Tcl manual entry for information on the valid -backslash sequences. -All of the sequences described in the Tcl -manual entry are supported by \fBTcl_Backslash\fR. +This is a utility procedure provided for backwards compatibilty with +non-internationalized Tcl extensions. It parses a backslash sequence and +returns the low byte of the Unicode character corresponding to the sequence. +.VE +\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of +characters in the backslash sequence. +.PP +See the Tcl manual entry for information on the valid backslash sequences. +All of the sequences described in the Tcl manual entry are supported by +\fBTcl_Backslash\fR. +.VS 8.1 br +.SH "SEE ALSO" +Tcl(n), Tcl_UtfBackslash(3) +.VE .SH KEYWORDS backslash, parse diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index daef201..dc0f91b 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -4,13 +4,13 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: CrtChannel.3,v 1.2 1998/09/14 18:39:46 stanton Exp $ +'\" RCS: @(#) $Id: CrtChannel.3,v 1.3 1999/04/16 00:46:30 stanton Exp $ .so man.macros .TH Tcl_CreateChannel 3 8.0 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetDefaultTranslation, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption \- procedures for creating and manipulating channels +Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption \- procedures for creating and manipulating channels .SH SYNOPSIS .nf \fB#include \fR @@ -33,11 +33,6 @@ int .VE .sp int -\fBTcl_GetChannelFlags\fR(\fIchannel\fR) -.sp -\fBTcl_SetDefaultTranslation\fR(\fIchannel, transMode\fR) -.sp -int \fBTcl_GetChannelBufferSize\fR(\fIchannel\fR) .sp \fBTcl_SetChannelBufferSize\fR(\fIchannel, size\fR) @@ -170,13 +165,7 @@ for each driver to determine what type of handle is returned. and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input and output. .PP -\fBTcl_SetDefaultTranslation\fR sets the default end of line translation -mode. This mode will be installed as the translation mode for the channel -if an attempt is made to output on the channel while it is still in -\fBTCL_TRANSLATE_AUTO\fR mode. For a description of end of line translation -modes, see the manual entry for \fBfconfigure\fR. -.PP -\fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers + \fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers allocated to store input or output in \fIchan\fR. If the value was not set by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then the default value of 4096 is returned. @@ -221,16 +210,19 @@ typedef struct Tcl_ChannelType { Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; Tcl_DriverWatchProc *\fIwatchProc\fR; Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; + Tcl_DriverClose2Proc *\fIclose2Proc\fR; } Tcl_ChannelType; .CE .VE .PP The driver must provide implementations for all functions except -\fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR, and -\fIgetOptionProc\fR, which may be specified as NULL to indicate that the -channel does not support seeking. Other functions that can not be -implemented for this type of device should return \fBEINVAL\fR when invoked -to indicate that they are not implemented. +\fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR, +.VS +\fIgetOptionProc\fR, and \fIclose2Proc\fR, which may be specified as +.VE +NULL. Other functions that can not be implemented for this type of +device should return \fBEINVAL\fR when invoked to indicate that they +are not implemented. .SH TYPENAME .PP @@ -264,7 +256,7 @@ For some device types, the blocking and nonblocking behavior can be implemented by the underlying operating system; for other device types, the behavior must be emulated in the channel driver. -.SH CLOSEPROC +.SH CLOSEPROC AND CLOSE2PROC .PP The \fIcloseProc\fR field contains the address of a function called by the generic layer to clean up driver-related information when the channel is @@ -286,6 +278,35 @@ calling the \fIcloseProc\fR. If the close operation is successful, the procedure should return zero; otherwise it should return a nonzero POSIX error code. In addition, if an error occurs and \fIinterp\fR is not NULL, the procedure should store an error message in \fIinterp->result\fR. +.PP +.VS +Alternatively, channels that support closing the read and write sides +independently may set \fIcloseProc\fR to \fBTCL_CLOSE2PROC\fR and set +\fIclose2Proc\fR to the address of a function that matches the +following prototype: +.PP +.CS +typedef int Tcl_DriverClose2Proc( + ClientData \fIinstanceData\fR, + Tcl_Interp *\fIinterp\fR, + int \fIflags\fR); +.CE +.PP +The \fIclose2Proc\fR will be called with \fIflags\fR set to an OR'ed +combination of \fBTCL_CLOSE_READ\fR or \fBTCL_CLOSE_WRITE\fR to +indicate that the driver should close the read and/or write side of +the channel. The channel driver may be invoked to perform +additional operations on the channel after \fIclose2Proc\fR is +called to close one or both sides of the channel. If \fIflags\fR is +\fB0\fR (zero), the driver should close the channel in the manner +described above for \fIcloseProc\fR. No further operations will be +invoked on this instance after \fIclose2Proc\fR is called with all +flags cleared. In all cases, the \fIclose2Proc\fR function should +return zero if the close operation was successful; otherwise it should +return a nonzero POSIX error code. In addition, if an error occurs and +\fIinterp\fR is not NULL, the procedure should store an error message +in \fIinterp->result\fR. +.VE .SH INPUTPROC .PP @@ -382,7 +403,7 @@ typedef int Tcl_DriverSeekProc( .PP The \fIinstanceData\fR argument is the same as the value given to \fBTcl_CreateChannel\fR when this channel was created. \fIOffset\fR and -\fIseekMode\fR have the same meaning as for the \fBTcl_SeekChannel\fR +\fIseekMode\fR have the same meaning as for the \fBTcl_Seek\fR procedure (described in the manual entry for \fBTcl_OpenFileChannel\fR). .PP The \fIerrorCodePtr\fR argument points to an integer variable provided by diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index 4390ef0..756b970 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -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.2 1998/09/14 18:39:47 stanton Exp $ +'\" RCS: @(#) $Id: CrtObjCmd.3,v 1.3 1999/04/16 00:46:30 stanton Exp $ '\" .so man.macros .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" @@ -62,8 +62,10 @@ such that whenever \fIname\fR is invoked as a Tcl command (e.g., via a call to \fBTcl_EvalObj\fR) the Tcl interpreter will call \fIproc\fR to process the command. .PP -\fBTcl_CreateObjCommand\fR will delete any command \fIname\fR -already associated with the interpreter. +\fBTcl_CreateObjCommand\fR deletes any existing command +\fIname\fR already associated with the interpreter +(however see below for an exception where the existing command +is not deleted). It returns a token that may be used to refer to the command in subsequent calls to \fBTcl_GetCommandName\fR. If \fIname\fR contains any \fB::\fR namespace qualifiers, @@ -101,7 +103,7 @@ cause memory to be lost and the runtime stack to be corrupted. The compilers to report any such attempted assignment as an error. However, it is acceptable to modify the internal representation of any individual object argument. For instance, the user may call -\fBTcl_GetIntFromObject\fR on \fIobjv\fR[\fB2\fR] to obtain the integer +\fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer representation of that object; that call may change the type of the object that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. @@ -128,6 +130,17 @@ not modify them. Call \fBTcl_SetObjResult\fR if you want to return something from the \fIobjv\fR array. .PP +Ordinarily, \fBTcl_CreateObjCommand\fR deletes any existing command +\fIname\fR already associated with the interpreter. +However, if the existing command was created by a previous call to +\fBTcl_CreateCommand\fR, +\fBTcl_CreateObjCommand\fR does not delete the command +but instead arranges for the Tcl interpreter to call the +\fBTcl_ObjCmdProc\fR \fIproc\fR in the future. +The old string-based \fBTcl_CmdProc\fR associated with the command +is retained and its address can be obtained by subsequent +\fBTcl_GetCommandInfo\fR calls. This is done for backwards compatibility. +.PP \fIDeleteProc\fR will be invoked when (if) \fIname\fR is deleted. This can occur through a call to \fBTcl_DeleteCommand\fR, \fBTcl_DeleteCommandFromToken\fR, or \fBTcl_DeleteInterp\fR, diff --git a/doc/CrtVersion.3 b/doc/CrtVersion.3 deleted file mode 100644 index 4333786..0000000 --- a/doc/CrtVersion.3 +++ /dev/null @@ -1,49 +0,0 @@ -'\" -'\" Copyright (c) 1999 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: CrtVersion.3,v 1.2 1999/03/11 19:29:34 redman Exp $ -'\" -.so man.macros -.TH Tcl_GetVersion 3 7.5 Tcl "Tcl Library Procedures" -.BS -.SH NAME -Tcl_GetVersion \- get the version of the library at runtime -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -\fBTcl_GetVersion\fR(\fmajor, minor, patchLevel, type\fR) -.SH ARGUMENTS -.AP int *major out -Major version number of the Tcl library. -.AP int *minor out -Minor version number of the Tcl library. -.AP int *patchLevel out -The patch level of the Tcl library (or alpha or beta number). -.AP Tcl_ReleaseType *type out -The type of release, also indicates the type of patch level. Can be -one of \fBTCL_ALPHA_RELEASE\fR, \fBTCL_BETA_RELEASE\fR, or -\fBTCL_FINAL_RELEASE\fR. -.BE - -.SH DESCRIPTION -.PP -\fBTcl_GetVersion\fR should be used to query the version number -of the Tcl library at runtime. This is useful when using a -dynamically loaded Tcl library or when writing a stubs-aware -extension. For instance, if you write an extension that is -linked against the Tcl stubs library, it could be loaded into -a program linked to an older version of Tcl than you expected. -Use \fBTcl_GetVersion\fR to verify that fact, and possibly to -change the behavior of your extension. -.PP -If may pass a NULL for any of the arguments. For instance if -you do not care about the \fIpatchLevel\fI of the library, pass -a NULL for the \fIpatchLevel\fI argument. - -.SH KEYWORDS -version, patchlevel, major, minor, alpha, beta, release - diff --git a/doc/Encoding.3 b/doc/Encoding.3 new file mode 100644 index 0000000..e9329dd --- /dev/null +++ b/doc/Encoding.3 @@ -0,0 +1,484 @@ +'\" +'\" Copyright (c) 1997-1998 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: Encoding.3,v 1.2 1999/04/16 00:46:31 stanton Exp $ +'\" +.so man.macros +.TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings. + + + + +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_Encoding +\fBTcl_GetEncoding\fR(\fIinterp, name\fR) +.sp +void +\fBTcl_FreeEncoding\fR(\fIencoding\fR) +.sp +void +\fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR) +.sp +int +\fBTcl_ExternalToUtf\fR(\fIinterp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, + dstCharsPtr\fR) +.sp +void +\fBTcl_UtfToExternalDString\fR(\fIencoding, src, srcLen, dstPtr\fR) +.sp +int +\fBTcl_UtfToExternal\fR(\fIinterp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, + dstCharsPtr\fR) +.sp +char * +\fBTcl_GetEncodingName\fR(\fIencoding\fR) +.sp +int +\fBTcl_SetSystemEncoding\fR(\fIinterp, name\fR) +.sp +void +\fBTcl_GetEncodingNames\fR(\fIinterp\fR) +.sp +Tcl_Encoding +\fBTcl_CreateEncoding\fR(\fItypePtr\fR) + +.sp +char * +\fBTcl_GetDefaultEncodingDir\fR(\fIvoid\fR) +.sp +void +\fBTcl_SetDefaultEncodingDir\fR(\fIpath\fR) + + +.SH ARGUMENTS +.AS Tcl_EncodingState *dstWrotePtr +.AP Tcl_Interp *interp in +Interpreter to use for error reporting, or NULL if no error reporting is +desired. +.AP "CONST char" *name in +Name of encoding to load. +.AP Tcl_Encoding encoding in +The encoding to query, free, or use for converting text. If \fIencoding\fR is +NULL, the current system encoding is used. +.AP "CONST char" *src in +For the \fBTcl_ExternalToUtf\fR functions, an array of bytes in the +specified encoding that are to be converted to UTF-8. For the +\fBTcl_UtfToExternal\fR functions, an array of UTF-8 characters to be +converted to the specified encoding. +.AP int srcLen in +Length of \fIsrc\fR in bytes. If the length is negative, the +encoding-specific length of the string is used. +.AP Tcl_DString *dstPtr out +Pointer to an uninitialized or free \fBTcl_DString\fR in which the converted +result will be stored. +.AP int flags in +Various flag bits OR-ed together. +TCL_ENCODING_START signifies that the +source buffer is the first block in a (potentially multi-block) input +stream, telling the conversion routine to reset to an initial state and +perform any initialization that needs to occur before the first byte is +converted. TCL_ENCODING_END signifies that the source buffer is the last +block in a (potentially multi-block) input stream, telling the conversion +routine to perform any finalization that needs to occur after the last +byte is converted and then to reset to an initial state. +TCL_ENCODING_STOPONERROR signifies that the conversion routine should +return immediately upon reading a source character that doesn't exist in +the target encoding; otherwise a default fallback character will +automatically be substituted. +.AP Tcl_EncodingState *statePtr in/out +Used when converting a (generally long or indefinite length) byte stream +in a piece by piece fashion. The conversion routine stores its current +state in \fI*statePtr\fR after \fIsrc\fR (the buffer containing the +current piece) has been converted; that state information must be passed +back when converting the next piece of the stream so the conversion +routine knows what state it was in when it left off at the end of the +last piece. May be NULL, in which case the value specified for \fIflags\fR +is ignored and the source buffer is assumed to contain the complete string to +convert. +.AP char *dst out +Buffer in which the converted result will be stored. No more than +\fIdstLen\fR bytes will be stored in \fIdst\fR. +.AP int dstLen in +The maximum length of the output buffer \fIdst\fR in bytes. +.AP int *srcReadPtr out +Filled with the number of bytes from \fIsrc\fR that were actually +converted. This may be less than the original source length if there was +a problem converting some source characters. May be NULL. +.AP int *dstWrotePtr out +Filled with the number of bytes that were actually stored in the output +buffer as a result of the conversion. May be NULL. +.AP int *dstCharsPtr out +Filled with the number of characters that correspond to the number of bytes +stored in the output buffer. May be NULL. +.AP Tcl_EncodingType *typePtr in +Structure that defines a new type of encoding. +.AP char *path in +A path to the location of the encoding file. +.BE +.SH INTRODUCTION +.PP +These routines convert between Tcl's internal character representation, +UTF-8, and character representations used by various operating systems or +file systems, such as Unicode, ASCII, or Shift-JIS. When operating on +strings, such as such as obtaining the names of files or displaying +characters using international fonts, the strings must be translated into +one or possibly multiple formats that the various system calls can use. For +instance, on a Japanese Unix workstation, a user might obtain a filename +represented in the EUC-JP file encoding and then translate the characters to +the jisx0208 font encoding in order to display the filename in a Tk widget. +The purpose of the encoding package is to help bridge the translation gap. +UTF-8 provides an intermediate staging ground for all the various +encodings. In the example above, text would be translated into UTF-8 from +whatever file encoding the operating system is using. Then it would be +translated from UTF-8 into whatever font encoding the display routines +require. +.PP +Some basic encodings are compiled into Tcl. Others can be defined by the +user or dynamically loaded from encoding files in a +platform-independent manner. +.SH DESCRIPTION +.PP +\fBTcl_GetEncoding\fR finds an encoding given its \fIname\fR. The name may +refer to a builtin Tcl encoding, a user-defined encoding registered by +calling \fBTcl_CreateEncoding\fR, or a dynamically-loadable encoding +file. The return value is a token that represents the encoding and can be +used in subsequent calls to procedures such as \fBTcl_GetEncodingName\fR, +\fBTcl_FreeEncoding\fR, and \fBTcl_UtfToExternal\fR. If the name did not +refer to any known or loadable encoding, NULL is returned and an error +message is returned in \fIinterp\fR. +.PP +The encoding package maintains a database of all encodings currently in use. +The first time \fIname\fR is seen, \fBTcl_GetEncoding\fR returns an +encoding with a reference count of 1. If the same \fIname\fR is requested +further times, then the reference count for that encoding is incremented +without the overhead of allocating a new encoding and all its associated +data structures. +.PP +When an \fIencoding\fR is no longer needed, \fBTcl_FreeEncoding\fR +should be called to release it. When an \fIencoding\fR is no longer in use +anywhere (i.e., it has been freed as many times as it has been gotten) +\fBTcl_FreeEncoding\fR will release all storage the encoding was using +and delete it from the database. +.PP +\fBTcl_ExternalToUtfDString\fR converts a source buffer \fIsrc\fR from the +specified \fIencoding\fR into UTF-8. The converted bytes are stored in +\fIdstPtr\fR, which is then NULL terminated. The caller should eventually +call \fBTcl_DStringFree\fR to free any information stored in \fIdstPtr\fR. +When converting, if any of the characters in the source buffer cannot be +represented in the target encoding, a default fallback character will be +used. +.PP +\fBTcl_ExternalToUtf\fR converts a source buffer \fIsrc\fR from the specified +\fIencoding\fR into UTF-8. Up to \fIsrcLen\fR bytes are converted from the +source buffer and up to \fIdstLen\fR converted bytes are stored in \fIdst\fR. +In all cases, \fI*srcReadPtr\fR is filled with the number of bytes that were +successfully converted from \fIsrc\fR and \fI*dstWrotePtr\fR is filled with +the corresponding number of bytes that were stored in \fIdst\fR. The return +value is one of the following: +.RS +.IP \fBTCL_OK\fR 29 +All bytes of \fIsrc\fR were converted. +.IP \fBTCL_CONVERT_NOSPACE\fR 29 +The destination buffer was not large enough for all of the converted data; as +many characters as could fit were converted though. +.IP \fBTCL_CONVERT_MULTIBYTE\fR 29 +The last fews bytes in the source buffer were the beginning of a multibyte +sequence, but more bytes were needed to complete this sequence. A +subsequent call to the conversion routine should pass a buffer containing +the unconverted bytes that remained in \fIsrc\fR plus some further bytes +from the source stream to properly convert the formerly split-up multibyte +sequence. +.IP \fBTCL_CONVERT_SYNTAX\fR 29 +The source buffer contained an invalid character sequence. This may occur +if the input stream has been damaged or if the input encoding method was +misidentified. +.IP \fBTCL_CONVERT_UNKNOWN\fR 29 +The source buffer contained a character that could not be represented in +the target encoding and TCL_ENCODING_STOPONERROR was specified. +.RE +.LP +\fBTcl_UtfToExternalDString\fR converts a source buffer \fIsrc\fR from UTF-8 +into the specified \fIencoding\fR. The converted bytes are stored in +\fIdstPtr\fR, which is then terminated with the appropriate encoding-specific +NULL. The caller should eventually call \fBTcl_DStringFree\fR to free any +information stored in \fIdstPtr\fR. When converting, if any of the +characters in the source buffer cannot be represented in the target +encoding, a default fallback character will be used. +.PP +\fBTcl_UtfToExternal\fR converts a source buffer \fIsrc\fR from UTF-8 into +the specified \fIencoding\fR. Up to \fIsrcLen\fR bytes are converted from +the source buffer and up to \fIdstLen\fR converted bytes are stored in +\fIdst\fR. In all cases, \fI*srcReadPtr\fR is filled with the number of +bytes that were successfully converted from \fIsrc\fR and \fI*dstWrotePtr\fR +is filled with the corresponding number of bytes that were stored in +\fIdst\fR. The return values are the same as the return values for +\fBTcl_ExternalToUtf\fR. +.PP +\fBTcl_GetEncodingName\fR is roughly the inverse of \fBTk_GetEncoding\fR. +Given an \fIencoding\fR, the return value is the \fIname\fR argument that +was used to create the encoding. The string returned by +\fBTcl_GetEncodingName\fR is only guaranteed to persist until the +\fIencoding\fR is deleted. The caller must not modify this string. +.PP +\fBTcl_SetSystemEncoding\fR sets the default encoding that should be used +whenever the user passes a NULL value for the \fIencoding\fR argument to +any of the other encoding functions. If \fIname\fR is NULL, the system +encoding is reset to the default system encoding, \fBbinary\fR. If the +name did not refer to any known or loadable encoding, TCL_ERROR is +returned and an error message is left in \fIinterp\fR. Otherwise, this +procedure increments the reference count of the new system encoding, +decrements the reference count of the old system encoding, and returns +TCL_OK. +.PP +\fBTcl_GetEncodingNames\fR sets the \fIinterp\fR result to a list +consisting of the names of all the encodings that are currently defined +or can be dynamically loaded, searching the encoding path specified by +\fBTcl_SetDefaultEncodingDir\fR. This procedure does not ensure that the +dynamically-loadable encoding files contain valid data, but merely that they +exist. +.PP +\fBTcl_CreateEncoding\fR defines a new encoding and registers the C +procedures that are called back to convert between the encoding and +UTF-8. Encodings created by \fBTcl_CreateEncoding\fR are thereafter +visible in the database used by \fBTcl_GetEncoding\fR. Just as with the +\fBTcl_GetEncoding\fR procedure, the return value is a token that +represents the encoding and can be used in subsequent calls to other +encoding functions. \fBTcl_CreateEncoding\fR returns an encoding with a +reference count of 1. If an encoding with the specified \fIname\fR +already exists, then its entry in the database is replaced with the new +encoding; the token for the old encoding will remain valid and continue +to behave as before, but users of the new token will now call the new +encoding procedures. +.PP +The \fItypePtr\fR argument to \fBTcl_CreateEncoding\fR contains information +about the name of the encoding and the procedures that will be called to +convert between this encoding and UTF-8. It is defined as follows: +.PP +.CS +typedef struct Tcl_EncodingType { + CONST char *\fIencodingName\fR; + Tcl_EncodingConvertProc *\fItoUtfProc\fR; + Tcl_EncodingConvertProc *\fIfromUtfProc\fR; + Tcl_EncodingFreeProc *\fIfreeProc\fR; + ClientData \fIclientData\fR; + int \fInullSize\fR; +} Tcl_EncodingType; +.CE +.PP +The \fIencodingName\fR provides a string name for the encoding, by +which it can be referred in other procedures such as +\fBTcl_GetEncoding\fR. The \fItoUtfProc\fR refers to a callback +procedure to invoke to convert text from this encoding into UTF-8. +The \fIfromUtfProc\fR refers to a callback procedure to invoke to +convert text from UTF-8 into this encoding. The \fIfreeProc\fR refers +to a callback procedure to invoke when this encoding is deleted. The +\fIfreeProc\fR field may be NULL. The \fIclientData\fR contains an +arbitrary one-word value passed to \fItoUtfProc\fR, \fIfromUtfProc\fR, +and \fIfreeProc\fR whenever they are called. Typically, this is a +pointer to a data structure containing encoding-specific information +that can be used by the callback procedures. For instance, two very +similar encodings such as \fBascii\fR and \fBmacRoman\fR may use the +same callback procedure, but use different values of \fIclientData\fR +to control its behavior. The \fInullSize\fR specifies the number of +zero bytes that signify end-of-string in this encoding. It must be +\fB1\fR (for single-byte or multi-byte encodings like ASCII or +Shift-JIS) or \fB2\fR (for double-byte encodings like Unicode). +Constant-sized encodings with 3 or more bytes per character (such as +CNS11643) are not accepted. +.PP +The callback procedures \fItoUtfProc\fR and \fIfromUtfProc\fR should match the +type \fBTcl_EncodingConvertProc\fR: +.PP +.CS +typedef int Tcl_EncodingConvertProc( + ClientData \fIclientData\fR, + CONST char *\fIsrc\fR, + int \fIsrcLen\fR, + int \fIflags\fR, + Tcl_Encoding *\fIstatePtr\fR, + char *\fIdst\fR, + int \fIdstLen\fR, + int *\fIsrcReadPtr\fR, + int *\fIdstWrotePtr\fR, + int *\fIdstCharsPtr\fR); +.CE +.PP +The \fItoUtfProc\fR and \fIfromUtfProc\fR procedures are called by the +\fBTcl_ExternalToUtf\fR or \fBTcl_UtfToExternal\fR family of functions to +perform the actual conversion. The \fIclientData\fR parameter to these +procedures is the same as the \fIclientData\fR field specified to +\fBTcl_CreateEncoding\fR when the encoding was created. The remaining +arguments to the callback procedures are the same as the arguments, +documented at the top, to \fBTcl_ExternalToUtf\fR or +\fBTcl_UtfToExternal\fR, with the following exceptions. If the +\fIsrcLen\fR argument to one of those high-level functions is negative, +the value passed to the callback procedure will be the appropriate +encoding-specific string length of \fIsrc\fR. If any of the \fIsrcReadPtr\fR, +\fIdstWrotePtr\fR, or \fIdstCharsPtr\fR arguments to one of the high-level +functions is NULL, the corresponding value passed to the callback +procedure will be a non-NULL location. +.PP +The callback procedure \fIfreeProc\fR, if non-NULL, should match the type +\fBTcl_EncodingFreeProc\fR: +.CS +typedef void Tcl_EncodingFreeProc( + ClientData \fIclientData\fR); +.CE +.PP +This \fIfreeProc\fR function is called when the encoding is deleted. The +\fIclientData\fR parameter is the same as the \fIclientData\fR field +specified to \fBTcl_CreateEncoding\fR when the encoding was created. +.PP + +\fBTcl_GetDefaultEncodingDir\fR and \fBTcl_SetDefaultEncodingDir\fR +access and set the directory to use when locating the default encoding +files. If this value is not NULL, the \fBTclpInitLibraryPath\fR routine +appends the path to the head of the search path, and uses this path as +the first place to look into when trying to locate the encoding file. + +.SH ENCODING FILES +Space would prohibit precompiling into Tcl every possible encoding +algorithm, so many encodings are stored on disk as dynamically-loadable +encoding files. This behavior also allows the user to create additional +encoding files that can be loaded using the same mechanism. These +encoding files contain information about the tables and/or escape +sequences used to map between an external encoding and Unicode. The +external encoding may consist of single-byte, multi-byte, or double-byte +characters. +.PP +Each dynamically-loadable encoding is represented as a text file. The +initial line of the file, beginning with a ``#'' symbol, is a comment +that provides a human-readable description of the file. The next line +identifies the type of encoding file. It can be one of the following +letters: +.IP "[1] \fBS\fR" +A single-byte encoding, where one character is always one byte long in the +encoding. An example is \fBiso8859-1\fR, used by many European languages. +.IP "[2] \fBD\fR" +A double-byte encoding, where one character is always two bytes long in the +encoding. An example is \fBbig5\fR, used for Chinese text. +.IP "[3] \fBM\fR" +A multi-byte encoding, where one character may be either one or two bytes long. +Certain bytes are a lead bytes, indicating that another byte must follow +and that together the two bytes represent one character. Other bytes are not +lead bytes and represent themselves. An example is \fBshiftjis\fR, used by +many Japanese computers. +.IP "[4] \fBE\fR" +An escape-sequence encoding, specifying that certain sequences of bytes +do not represent characters, but commands that describe how following bytes +should be interpreted. +.PP +The rest of the lines in the file depend on the type. +.PP +Cases [1], [2], and [3] are collectively referred to as table-based encoding +files. The lines in a table-based encoding file are in the same +format as this example taken from the \fBshiftjis\fR encoding (this is not +the complete file): +.CS +# Encoding file: shiftjis, multi-byte +M +003F 0 40 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D203E007F +0080000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F +FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F +FF80FF81FF82FF83FF84FF85FF86FF87FF88FF89FF8AFF8BFF8CFF8DFF8EFF8F +FF90FF91FF92FF93FF94FF95FF96FF97FF98FF99FF9AFF9BFF9CFF9DFF9EFF9F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +81 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +300030013002FF0CFF0E30FBFF1AFF1BFF1FFF01309B309C00B4FF4000A8FF3E +FFE3FF3F30FD30FE309D309E30034EDD30053006300730FC20152010FF0F005C +301C2016FF5C2026202520182019201C201DFF08FF0930143015FF3BFF3DFF5B +FF5D30083009300A300B300C300D300E300F30103011FF0B221200B100D70000 +00F7FF1D2260FF1CFF1E22662267221E22342642264000B0203220332103FFE5 +FF0400A200A3FF05FF03FF06FF0AFF2000A72606260525CB25CF25CE25C725C6 +25A125A025B325B225BD25BC203B301221922190219121933013000000000000 +000000000000000000000000000000002208220B2286228722822283222A2229 +000000000000000000000000000000002227222800AC21D221D4220022030000 +0000000000000000000000000000000000000000222022A52312220222072261 +2252226A226B221A223D221D2235222B222C0000000000000000000000000000 +212B2030266F266D266A2020202100B6000000000000000025EF000000000000 +.CE +.PP +The third line of the file is three numbers. The first number is the +fallback character (in base 16) to use when converting from UTF-8 to this +encoding. The second number is a \fB1\fR if this file represents the +encoding for a symbol font, or \fB0\fR otherwise. The last number (in base +10) is how many pages of data follow. +.PP +Subsequent lines in the example above are pages that describe how to map +from the encoding into 2-byte Unicode. The first line in a page identifies +the page number. Following it are 256 double-byte numbers, arranged as 16 +rows of 16 numbers. Given a character in the encoding, the high byte of +that character is used to select which page, and the low byte of that +character is used as an index to select one of the double-byte numbers in +that page \- the value obtained being the corresponding Unicode character. +By examination of the example above, one can see that the characters 0x7E +and 0x8163 in \fBshiftjis\fR map to 203E and 2026 in Unicode, respectively. +.PP +Following the first page will be all the other pages, each in the same +format as the first: one number identifying the page followed by 256 +double-byte Unicode characters. If a character in the encoding maps to the +Unicode character 0000, it means that the character doesn't actually exist. +If all characters on a page would map to 0000, that page can be omitted. +.PP +Case [4] is the escape-sequence encoding file. The lines in an this type of +file are in the same format as this example taken from the \fBiso2022-jp\fR +encoding: +.CS +.ta 1.5i +# Encoding file: iso2022-jp, escape-driven +E +init {} +final {} +iso8859-1 \\x1b(B +jis0201 \\x1b(J +jis0208 \\x1b$@ +jis0208 \\x1b$B +jis0212 \\x1b$(D +gb2312 \\x1b$A +ksc5601 \\x1b$(C +.CE +.PP +In the file, the first column represents an option and the second column +is the associated value. \fBinit\fR is a string to emit or expect before +the first character is converted, while \fBfinal\fR is a string to emit +or expect after the last character. All other options are names of +table-based encodings; the associated value is the escape-sequence that +marks that encoding. Tcl syntax is used for the values; in the above +example, for instance, ``\fB{}\fR'' represents the empty string and +``\fB\\x1b\fR'' represents character 27. +.PP +When \fBTcl_GetEncoding\fR encounters an encoding \fIname\fR that has not +been loaded, it attempts to load an encoding file called \fIname\fB.enc\fR +from the \fBencoding\fR subdirectory of each directory specified in the +library path \fB$tcl_libPath\fR. If the encoding file exists, but is +malformed, an error message will be left in \fIinterp\fR. +.SH KEYWORDS +utf, encoding, convert + + + diff --git a/doc/Eval.3 b/doc/Eval.3 index 42e77ae..bc0effc 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -5,97 +5,173 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Eval.3,v 1.3 1999/03/10 05:52:45 stanton Exp $ +'\" RCS: @(#) $Id: Eval.3,v 1.4 1999/04/16 00:46:31 stanton Exp $ '\" .so man.macros -.TH Tcl_Eval 3 7.0 Tcl "Tcl Library Procedures" +.TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_Eval, Tcl_VarEval, Tcl_VarEvalVA, Tcl_EvalFile, Tcl_GlobalEval \- execute Tcl commands +Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts .SH SYNOPSIS .nf \fB#include \fR .sp +.VS int -\fBTcl_Eval\fR(\fIinterp, cmd\fR) +\fBTcl_EvalObjEx\fR(\fIinterp, objPtr, flags\fR) .sp int -\fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR) +\fBTcl_EvalFile\fR(\fIinterp, fileName\fR) .sp int -\fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) +\fBTcl_EvalObjv\fR(\fIinterp, objc, objv, flags\fR) .sp int -\fBTcl_EvalFile\fR(\fIinterp, fileName\fR) +\fBTcl_Eval\fR(\fIinterp, script\fR) +.sp +int +\fBTcl_EvalEx\fR(\fIinterp, script, numBytes, flags\fR) +.sp +int +\fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int -\fBTcl_GlobalEval\fR(\fIinterp, cmd\fR) +\fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr, flags\fR) +.sp +int +\fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR) +.sp +int +\fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr; .AP Tcl_Interp *interp in -Interpreter in which to execute the command. -A string result will be stored in \fIinterp->result\fR. -.AP char *cmd in -Command (or sequence of commands) to execute. Must be in writable -memory (\fBTcl_Eval\fR makes temporary modifications to the command). +Interpreter in which to execute the script. The interpreter's result is +modified to hold the result or error message from the script. +.AP Tcl_Obj *objPtr in +A Tcl object containing the script to execute. +.AP int flags in +ORed combination of flag bits that specify additional options. +\fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported. +.AP char *fileName in +Name of a file containing a Tcl script. +.AP int *objc in +The number of objects in the array pointed to by \fIobjPtr\fR; +this is also the number of words in the command. +.AP Tcl_Obj **objv in +Points to an array of pointers to objects; each object holds the +value of a single word in the command to execute. +.AP int numBytes in +The number of bytes in \fIscript\fR, not including any +null terminating character. If \-1, then all characters up to the +first null byte are used. +.AP char *script in +Points to first byte of script to execute. This script must be in +writable memory: temporary modifications are made to it during +parsing. .AP char *string in -String forming part of Tcl command. +String forming part of a Tcl script. .AP va_list argList in An argument list which must have been initialised using \fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. -.AP char *fileName in -Name of file containing Tcl command string. .BE .SH DESCRIPTION .PP -All four of these procedures execute Tcl commands. -\fBTcl_Eval\fR is the core procedure and is used by all the others. -It executes the commands in the script held by \fIcmd\fR -until either an error occurs or it reaches the end of the script. +The procedures described here are invoked to execute Tcl scripts in +various forms. +\fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. +It executes the commands in the script stored in \fIobjPtr\fR +until either an error occurs or the end of the script is reached. +If this is the first time \fIobjPtr\fR has been executed, +its commands are compiled into bytecode instructions +which are then executed. The +bytecodes are saved in \fIobjPtr\fR so that the compilation step +can be skipped if the object is evaluated again in the future. +.PP +The return value from \fBTcl_EvalObjEx\fR (and all the other procedures +described here) is a Tcl completion code with +one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, +\fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. +In addition, a result value or error message is left in \fIinterp\fR's +result; it can be retrieved using \fBTcl_GetObjResult\fR. +.PP +\fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates +its contents as a Tcl script. It returns the same information as +\fBTcl_EvalObjEx\fR. +If the file couldn't be read then a Tcl error is returned to describe +why the file couldn't be read. +.PP +\fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a +script. The \fIobjc\fR and \fIobjv\fR arguments contain the values +of the words for the Tcl command, one word in each object in +\fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns +a completion code and result just like \fBTcl_EvalObjEx\fR. +.PP +\fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that +the script to be executed is supplied as a string instead of an +object and no compilation occurs. The string is parsed and executed +directly (using \fBTcl_EvalObjv\fR) instead of compiling it and +executing the bytecodes. In situations where it is known that the +script will never be executed again, \fBTcl_Eval\fR may be +faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion +code and result just like \fBTcl_EvalObjEx\fR. Note: for backward +compatibility with versions before Tcl 8.0, \fBTcl_Eval\fR +copies the object result in \fIinterp\fR to \fIinterp->result\fR +where it can be accessed directly. This makes \fBTcl_Eval\fR somewhat +slower than \fBTcl_EvalEx\fR, which doesn't do the copy. .PP -Note that \fBTcl_Eval\fR and \fBTcl_GlobalEval\fR -have been largely replaced by the -object-based procedures \fBTcl_EvalObj\fR and \fBTcl_GlobalEvalObj\fR. -Those object-based procedures evaluate a script held in a Tcl object -instead of a string. -The object argument can retain the bytecode instructions for the script -and so avoid reparsing the script each time it is executed. -\fBTcl_Eval\fR is implemented using \fBTcl_EvalObj\fR -but is slower because it must reparse the script each time -since there is no object to retain the bytecode instructions. +\fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes +additional arguments \fInumBytes\fR and \fIflags\fR. For the +efficiency reason given above, \fBTcl_EvalEx\fR is generally preferred +over \fBTcl_Eval\fR. .PP -The return value from \fBTcl_Eval\fR is one of the Tcl return codes -\fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or -\fBTCL_CONTINUE\fR, and \fIinterp->result\fR will point to -a string with additional information (a result value or error message). -If an error occurs during compilation, this return information -describes the error. -Otherwise, this return information corresponds to the last command -executed from \fIcmd\fR. +\fBTcl_GlobalEval\fR and \fBTcl_GlobalEvalObj\fR are older procedures +that are now deprecated. They are similar to \fBTcl_EvalEx\fR and +\fBTcl_EvalObjEx\fR except that the script is evaluated in the global +namespace and its variable context consists of global variables only +(it ignores any Tcl procedures that are active). These functions are +equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below). .PP \fBTcl_VarEval\fR takes any number of string arguments of any length, concatenates them into a single string, then calls \fBTcl_Eval\fR to execute that string as a Tcl command. It returns the result of the command and also modifies -\fIinterp->result\fR in the usual fashion for Tcl commands. +\fIinterp->result\fR in the same way as \fBTcl_Eval\fR. The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end -of arguments. +of arguments. \fBTcl_VarEval\fR is now deprecated. .PP \fBTcl_VarEvalVA\fR is the same as \fBTcl_VarEval\fR except that -instead of taking a variable number of arguments it takes an argument list. -.PP -\fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates -its contents as a Tcl command by calling \fBTcl_Eval\fR. It returns -a standard Tcl result that reflects the result of evaluating the file. -If the file couldn't be read then a Tcl error is returned to describe -why the file couldn't be read. +instead of taking a variable number of arguments it takes an argument +list. Like \fBTcl_VarEval\fR, \fBTcl_VarEvalVA\fR is deprecated. + +.SH "FLAG BITS" +Any ORed combination of the following values may be used for the +\fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR: +.TP 23 +\fBTCL_EVAL_DIRECT\fR +This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by +other procedures. If this flag bit is set, the script is not +compiled to bytecodes; instead it is executed directly +as is done by \fBTcl_EvalEx\fR. The +\fBTCL_EVAL_DIRECT\fR flag is useful in situations where the +contents of an object are going to change immediately, so the +bytecodes won't be reused in a future execution. In this case, +it's faster to execute the script directly. +.TP 23 +\fBTCL_EVAL_GLOBAL\fR +If this flag is set, the script is processed at global level. This +means that it is evaluated in the global namespace and its variable +context consists of global variables only (it ignores any Tcl +procedures at are active). + +.SH "MISCELLANEOUS DETAILS" .PP During the processing of a Tcl command it is legal to make nested calls to evaluate other commands (this is how procedures and some control structures are implemented). If a code other than \fBTCL_OK\fR is returned -from a nested \fBTcl_Eval\fR invocation, +from a nested \fBTcl_EvalObjEx\fR invocation, then the caller should normally return immediately, passing that same return code back to its caller, and so on until the top-level application is reached. @@ -103,21 +179,18 @@ A few commands, like \fBfor\fR, will check for certain return codes, like \fBTCL_BREAK\fR and \fBTCL_CONTINUE\fR, and process them specially without returning. .PP -\fBTcl_Eval\fR keeps track of how many nested \fBTcl_Eval\fR +\fBTcl_EvalObjEx\fR keeps track of how many nested \fBTcl_EvalObjEx\fR invocations are in progress for \fIinterp\fR. If a code of \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR is -about to be returned from the topmost \fBTcl_Eval\fR +about to be returned from the topmost \fBTcl_EvalObjEx\fR invocation for \fIinterp\fR, it converts the return code to \fBTCL_ERROR\fR -and sets \fIinterp->result\fR -to point to an error message indicating that +and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code -from \fBTcl_Eval\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. - -.SH "SEE ALSO" -Tcl_EvalObj, Tcl_GlobalEvalObj +from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. +.VE .SH KEYWORDS -command, execute, file, global, object, object result, variable +execute, file, global, object, result, script diff --git a/doc/EvalObj.3 b/doc/EvalObj.3 deleted file mode 100644 index 9948196..0000000 --- a/doc/EvalObj.3 +++ /dev/null @@ -1,91 +0,0 @@ -'\" -'\" Copyright (c) 1996-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: EvalObj.3,v 1.2 1998/09/14 18:39:48 stanton Exp $ -'\" -.so man.macros -.TH Tcl_EvalObj 3 8.0 Tcl "Tcl Library Procedures" -.BS -.SH NAME -Tcl_EvalObj, Tcl_GlobalEvalObj \- execute Tcl commands -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -int -\fBTcl_EvalObj\fR(\fIinterp, objPtr\fR) -.sp -int -\fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) -.SH ARGUMENTS -.AS Tcl_Interp **termPtr; -.AP Tcl_Interp *interp in -Interpreter in which to execute the command. -The command's result will be stored in the interpreter's result object -and can be retrieved using \fBTcl_GetObjResult\fR. -.AP Tcl_Obj *objPtr in -A Tcl object containing a command string -(or sequence of commands in a string) to execute. -.BE - -.SH DESCRIPTION -.PP -These two procedures execute Tcl commands. -\fBTcl_EvalObj\fR is the core procedure -and is used by \fBTcl_GlobalEvalObj\fR. -It executes the commands in the script held by \fIobjPtr\fR -until either an error occurs or it reaches the end of the script. -If this is the first time \fIobjPtr\fR has been executed, -its commands are compiled into bytecode instructions -that are then executed if there are no compilation errors. -.PP -The return value from \fBTcl_EvalObj\fR is one of the Tcl return codes -\fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or -\fBTCL_CONTINUE\fR, -and a result object containing additional information -(a result value or error message) -that can be retrieved using \fBTcl_GetObjResult\fR. -If an error occurs during compilation, this return information -describes the error. -Otherwise, this return information corresponds to the last command -executed from \fIobjPtr\fR. -.PP -\fBTcl_GlobalEvalObj\fR is similar to \fBTcl_EvalObj\fR except that it -processes the command at global level. -This means that the variable context for the command consists of -global variables only (it ignores any Tcl procedure that is active). -This produces an effect similar to the Tcl command ``\fBuplevel 0\fR''. -.PP -During the processing of a Tcl command it is legal to make nested -calls to evaluate other commands (this is how procedures and -some control structures are implemented). -If a code other than \fBTCL_OK\fR is returned -from a nested \fBTcl_EvalObj\fR invocation, -then the caller should normally return immediately, -passing that same return code back to its caller, -and so on until the top-level application is reached. -A few commands, like \fBfor\fR, will check for certain -return codes, like \fBTCL_BREAK\fR and \fBTCL_CONTINUE\fR, and process them -specially without returning. -.PP -\fBTcl_EvalObj\fR keeps track of how many nested \fBTcl_EvalObj\fR -invocations are in progress for \fIinterp\fR. -If a code of \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR is -about to be returned from the topmost \fBTcl_EvalObj\fR -invocation for \fIinterp\fR, -it converts the return code to \fBTCL_ERROR\fR -and sets the interpreter's result object -to point to an error message indicating that -the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was -invoked in an inappropriate place. -This means that top-level applications should never see a return code -from \fBTcl_EvalObj\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. - -.SH "SEE ALSO" -Tcl_GetObjResult, Tcl_SetObjResult - -.SH KEYWORDS -command, execute, file, global, object, object result, variable diff --git a/doc/Exit.3 b/doc/Exit.3 index b3f2ca6..c533efe 100644 --- a/doc/Exit.3 +++ b/doc/Exit.3 @@ -4,13 +4,13 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Exit.3,v 1.2 1998/09/14 18:39:48 stanton Exp $ +'\" RCS: @(#) $Id: Exit.3,v 1.3 1999/04/16 00:46:31 stanton Exp $ '\" .so man.macros -.TH Tcl_Exit 3 7.7 Tcl "Tcl Library Procedures" +.TH Tcl_Exit 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_Exit, Tcl_Finalize, Tcl_CreateExitHandler, Tcl_DeleteExitHandler \- end the application (and invoke exit handlers) +Tcl_Exit, Tcl_Finalize, Tcl_FinalizeThread, Tcl_CreateExitHandler, Tcl_DeleteExitHandler, Tcl_CreateThreadExitHandler, Tcl_DeleteThreadExitHandler \- end the application or thread (and invoke exit handlers) .SH SYNOPSIS .nf \fB#include \fR @@ -22,10 +22,19 @@ Tcl_Exit, Tcl_Finalize, Tcl_CreateExitHandler, Tcl_DeleteExitHandler \- end the \fBTcl_CreateExitHandler\fR(\fIproc, clientData\fR) .sp \fBTcl_DeleteExitHandler\fR(\fIproc, clientData\fR) +.sp +\fBTcl_ExitThread\fR(\fIstatus\fR) +.sp +\fBTcl_FinalizeThread\fR() +.sp +\fBTcl_CreateThreadExitHandler\fR(\fIproc, clientData\fR) +.sp +\fBTcl_DeleteThreadExitHandler\fR(\fIproc, clientData\fR) .SH ARGUMENTS .AS Tcl_ExitProc clientData .AP int status in -Provides information about why application exited. Exact meaning may +Provides information about why the application or thread exited. +Exact meaning may be platform-specific. 0 usually means a normal exit, any nonzero value usually means that an error occurred. .AP Tcl_ExitProc *proc in @@ -51,7 +60,6 @@ otherwise causes the application to terminate without calling \fBTcl_Exit\fR internally invokes the \fBexit\fR system call, thus it never returns control to its caller. .PP -.VS \fBTcl_Finalize\fR is similar to \fBTcl_Exit\fR except that it does not exit from the current process. It is useful for cleaning up when a process is finished using \fBTcl\fR but @@ -64,10 +72,20 @@ However, to ensure portability, your code should always invoke \fBTcl_Finalize\fR when \fBTcl\fR is being unloaded, to ensure that the code will work on all platforms. \fBTcl_Finalize\fR can be safely called more than once. +.PP +.VS +\fBTcl_ExitThread\fR is used to terminate the current thread and invoke +per-thread exit handlers. This finalization is done by +\fBTcl_FinalizeThread\fR, which you can call if you just want to clean +up per-thread state and invoke the thread exit handlers. +\fBTcl_Finalize\fR calls \fBTcl_FinalizeThread\fR for the current +thread automatically. .VE .PP \fBTcl_CreateExitHandler\fR arranges for \fIproc\fR to be invoked by \fBTcl_Finalize\fR and \fBTcl_Exit\fR. +\fBTcl_CreateThreadExitHandler\fR arranges for \fIproc\fR to be invoked +by \fBTcl_FinalizeThread\fR and \fBTcl_ExitThread\fR. This provides a hook for cleanup operations such as flushing buffers and freeing global memory. \fIProc\fR should match the type \fBTcl_ExitProc\fR: @@ -76,16 +94,18 @@ typedef void Tcl_ExitProc(ClientData \fIclientData\fR); .CE The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR argument given to -\fBTcl_CreateExitHandler\fR when the callback +\fBTcl_CreateExitHandler\fR or \fBTcl_CreateThreadExitHandler\fR when +the callback was created. Typically, \fIclientData\fR points to a data structure containing application-specific information about what to do in \fIproc\fR. .PP -\fBTcl_DeleteExitHandler\fR may be called to delete a +\fBTcl_DeleteExitHandler\fR and \fBTcl_DeleteThreadExitHandler\fR may be +called to delete a previously-created exit handler. It removes the handler indicated by \fIproc\fR and \fIclientData\fR so that no call to \fIproc\fR will be made. If no such handler exists then -\fBTcl_DeleteExitHandler\fR does nothing. +\fBTcl_DeleteExitHandler\fR or \fBTcl_DeleteThreadExitHandler\fR does nothing. .PP .VS .PP @@ -98,6 +118,14 @@ If extension \fBA\fR registers its exit handlers before loading extension \fBB\fR, this ensures that any exit handlers for \fBB\fR will be executed before the exit handlers for \fBA\fR. .VE +.VS +.PP +\fBTcl_Finalize\fR and \fBTcl_Exit\fR call \fBTcl_FinalizeThread\fR +and the thread exit handlers \fIafter\fR +the process-wide exit handlers. This is because thread finalization shuts +down the I/O channel system, so any attempt at I/O by the global exit +handlers will vanish into the bitbucket. +.VE .SH KEYWORDS -callback, cleanup, dynamic loading, end application, exit, unloading +callback, cleanup, dynamic loading, end application, exit, unloading, thread diff --git a/doc/GetCwd.3 b/doc/GetCwd.3 new file mode 100755 index 0000000..4c8d65d --- /dev/null +++ b/doc/GetCwd.3 @@ -0,0 +1,54 @@ +'\" +'\" Copyright (c) 1998-1999 Scriptics Corportation +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" RCS: @(#) $Id: GetCwd.3,v 1.2 1999/04/16 00:46:31 stanton Exp $ +'\" +.so man.macros +.TH Tcl_GetCwd 3 8.1 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_GetCwd, Tcl_Chdir \- manipulate the current working directory +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +char * +\fBTcl_GetCwd\fR(\fIinterp\fR, \fIbufferPtr\fR) +.sp +int +\fBTcl_Chdir\fR(\fIpath\fR) +.SH ARGUMENTS +.AS Tcl_DString *bufferPtr +.AP Tcl_Interp *interp in +Interpreter in which to report an error, if any. +.AP Tcl_DString *bufferPtr in/out +This dynamic string is used to store the current working directory. +At the time of the call it should be uninitialized or free. The +caller must eventually call \fBTcl_DStringFree\fR to free up +anything stored here. +.AP char *path in +File path in UTF\-8 format. +.BE + +.SH DESCRIPTION +.PP +These procedures may be used to manipulate the current working +directory for the application. They provide C\-level access to +the same functionality as the Tcl \fBpwd\fR command. +.PP +\fBTcl_GetCwd\fR returns a pointer to a string specifying the current +directory, or NULL if the current directory could not be determined. +If NULL is returned, an error message is left in the interp's result. +Storage for the result string is allocated in bufferPtr; the caller +must call \fBTcl_DStringFree()\fR when the result is no longer needed. +The format of the path is UTF\-8. +.PP +\fBTcl_Chdir\fR changes the applications current working directory to +the value specified in \fIpath\fR. The format of the passed in string +must be UTF\-8. The function returns -1 on error or 0 on success. + +.SH KEYWORDS +pwd diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index 4cacdb2..342069a 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -4,10 +4,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: GetIndex.3,v 1.2 1998/09/14 18:39:48 stanton Exp $ +'\" RCS: @(#) $Id: GetIndex.3,v 1.3 1999/04/16 00:46:31 stanton Exp $ '\" .so man.macros -.TH Tcl_GetIndexFromObj 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_GetIndexFromObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_GetIndexFromObj \- lookup string in table of keywords @@ -16,7 +16,14 @@ Tcl_GetIndexFromObj \- lookup string in table of keywords \fB#include \fR .sp int -\fBTcl_GetIndexFromObj\fR(\fIinterp, objPtr, tablePtr, msg, flags, indexPtr\fR) +\fBTcl_GetIndexFromObj\fR(\fIinterp, objPtr, tablePtr, msg, flags, +indexPtr\fR) +.VS +.sp +int +\fBTcl_GetIndexFromObjStruct\fR(\fIinterp, objPtr, tablePtr, offset, +msg, flags, indexPtr\fR) +.VE .SH ARGUMENTS .AS Tcl_Interp **tablePtr .AP Tcl_Interp *interp in @@ -29,6 +36,11 @@ table entry. .AP char **tablePtr in An array of null-terminated strings. The end of the array is marked by a NULL string pointer. +.VS +.AP int offset in +The offset to add to tablePtr to get to the next string in the +list. The end of the array is marked by a NULL string pointer. +.VE .AP char *msg in Null-terminated string describing what is being looked up, such as \fBoption\fR. This string is included in error messages. @@ -68,7 +80,18 @@ is invoked again with the same \fIobjPtr\fR and \fItablePtr\fR arguments (e.g. during a reinvocation of a Tcl command), it returns the matching index immediately without having to redo the lookup operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries -in \fItablePtr\fR are static: they must not change between invocations. +in \fItablePtr\fR are static: they must not change between +invocations. +.VS +.PP +\fBTcl_GetIndexFromObjStruct\fR works just like +\fBTcl_GetIndexFromObj\fR, except that instead of treating +\fItablePtr\fR as an array of string pointers, it treats it as the +first in a series of string ptrs that are spaced apart by \fIoffset\fR +bytes. This is particularly useful when processing things like +\fBTk_ConfigurationSpec\fR, whose string keys are in the same place in +each of several array elements. +.VE .SH "SEE ALSO" Tcl_WrongNumArgs diff --git a/doc/GetVersion.3 b/doc/GetVersion.3 new file mode 100755 index 0000000..0b88dc5 --- /dev/null +++ b/doc/GetVersion.3 @@ -0,0 +1,49 @@ +'\" +'\" Copyright (c) 1999 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: GetVersion.3,v 1.2 1999/04/16 00:46:32 stanton Exp $ +'\" +.so man.macros +.TH Tcl_GetVersion 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_GetVersion \- get the version of the library at runtime +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_GetVersion\fR(\fImajor, minor, patchLevel, type\fR) +.SH ARGUMENTS +.AP int *major out +Major version number of the Tcl library. +.AP int *minor out +Minor version number of the Tcl library. +.AP int *patchLevel out +The patch level of the Tcl library (or alpha or beta number). +.AP Tcl_ReleaseType *type out +The type of release, also indicates the type of patch level. Can be +one of \fBTCL_ALPHA_RELEASE\fR, \fBTCL_BETA_RELEASE\fR, or +\fBTCL_FINAL_RELEASE\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_GetVersion\fR should be used to query the version number +of the Tcl library at runtime. This is useful when using a +dynamically loaded Tcl library or when writing a stubs-aware +extension. For instance, if you write an extension that is +linked against the Tcl stubs library, it could be loaded into +a program linked to an older version of Tcl than you expected. +Use \fBTcl_GetVersion\fR to verify that fact, and possibly to +change the behavior of your extension. +.PP +If may pass a NULL for any of the arguments. For instance if +you do not care about the \fIpatchLevel\fR of the library, pass +a NULL for the \fIpatchLevel\fR argument. + +.SH KEYWORDS +version, patchlevel, major, minor, alpha, beta, release + diff --git a/doc/ObjSetVar.3 b/doc/ObjSetVar.3 deleted file mode 100644 index e34f9d3..0000000 --- a/doc/ObjSetVar.3 +++ /dev/null @@ -1,162 +0,0 @@ -'\" -'\" Copyright (c) 1996-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: ObjSetVar.3,v 1.2 1998/09/14 18:39:49 stanton Exp $ -'\" -.so man.macros -.TH Tcl_ObjSetVar2 3 8.0 Tcl "Tcl Library Procedures" -.BS -.SH NAME -Tcl_ObjSetVar2, Tcl_ObjGetVar2 \- manipulate Tcl variables -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -Tcl_Obj * -\fBTcl_ObjSetVar2\fR(\fIinterp, part1Ptr, part2Ptr, newValuePtr, flags\fR) -.sp -Tcl_Obj * -\fBTcl_ObjGetVar2\fR(\fIinterp, part1Ptr, part2Ptr, flags\fR) -.SH ARGUMENTS -.AS Tcl_Interp *newValuePtr -.AP Tcl_Interp *interp in -Interpreter containing variable. -.AP Tcl_Obj *part1Ptr in -Points to a Tcl object containing the variable's name. -The name may include a series of \fB::\fR namespace qualifiers -to specify a variable in a particular namespace. -May refer to a scalar variable or an element of an array variable. -.AP Tcl_Obj *part2Ptr in -If non-NULL, points to an object containing the name of an element -within an array and \fIpart1Ptr\fR must refer to an array variable. -.AP Tcl_Obj *newValuePtr in -Points to a Tcl object containing the new value for the variable. -.AP int flags in -OR-ed combination of bits providing additional information for -operation. See below for valid values. -.BE - -.SH DESCRIPTION -.PP -These two procedures may be used to read and modify -Tcl variables from C code. -\fBTcl_ObjSetVar2\fR will create a new variable or modify an existing one. -It sets the specified variable to -the object referenced by \fInewValuePtr\fR -and returns a pointer to the object which is the variable's new value. -The returned object may not be the same one -referenced by \fInewValuePtr\fR; -this might happen because variable traces may modify the variable's value. -The reference count for the variable's old value is decremented -and the reference count for its new value is incremented. -If the new value for the variable -is not the same one referenced by \fInewValuePtr\fR -(perhaps as a result of a variable trace), -then \fInewValuePtr\fR's reference count is left unchanged. -The reference count for the returned object is not incremented -to reflect the returned reference. -If the caller needs to keep a reference to the object, -say in a data structure, -it must increment its reference count using \fBTcl_IncrRefCount\fR. -If an error occurs in setting the variable -(e.g. an array variable is referenced -without giving an index into the array), -then NULL is returned. -.PP -The variable name specified to \fBTcl_ObjSetVar2\fR consists of two parts. -\fIpart1Ptr\fR contains the name of a scalar or array variable. -If \fIpart2Ptr\fR is NULL, the variable must be a scalar. -If \fIpart2Ptr\fR is not NULL, -it contains the name of an element in the array named by \fIpart2Ptr\fR. -As a special case, if the flag TCL_PARSE_PART1 is specified, -\fIpart1Ptr\fR may contain both an array and an element name: -if the name contains an open parenthesis and ends with a -close parenthesis, then the value between the parentheses is -treated as an element name (which can have any string value) and -the characters before the first open -parenthesis are treated as the name of an array variable. -If the flag TCL_PARSE_PART1 is given, -\fIpart2Ptr\fR should be NULL since the array and element names -are taken from \fIpart2Ptr\fR. -.PP -The \fIflags\fR argument may be used to specify any of several -options to the procedures. -It consists of an OR-ed combination of any of the following -bits: -.TP -\fBTCL_GLOBAL_ONLY\fR -Under normal circumstances the procedures look up variables as follows: -If a procedure call is active in \fIinterp\fR, -a variable is looked up at the current level of procedure call. -Otherwise, a variable is looked up first in the current namespace, -then in the global namespace. -However, if this bit is set in \fIflags\fR then the variable -is looked up only in the global namespace -even if there is a procedure call active. -If both \fBTCL_GLOBAL_ONLY\fR and \fBTCL_NAMESPACE_ONLY\fR are given, -\fBTCL_GLOBAL_ONLY\fR is ignored. -.TP -\fBTCL_NAMESPACE_ONLY\fR -Under normal circumstances the procedures look up variables as follows: -If a procedure call is active in \fIinterp\fR, -a variable is looked up at the current level of procedure call. -Otherwise, a variable is looked up first in the current namespace, -then in the global namespace. -However, if this bit is set in \fIflags\fR then the variable -is looked up only in the current namespace -even if there is a procedure call active. -.TP -\fBTCL_LEAVE_ERR_MSG\fR -If an error is returned and this bit is set in \fIflags\fR, then -an error message will be left in the interpreter's result, -where it can be retrieved with \fBTcl_GetObjResult\fR -or \fBTcl_GetStringResult\fR. -If this flag bit isn't set then no error message is left -and the interpreter's result will not be modified. -.TP -\fBTCL_APPEND_VALUE\fR -If this bit is set then \fInewValuePtr\fR is appended to the current -value, instead of replacing it. -If the variable is currently undefined, then this bit is ignored. -.TP -\fBTCL_LIST_ELEMENT\fR -If this bit is set, then \fInewValuePtr\fR is converted to a valid -Tcl list element before setting (or appending to) the variable. -A separator space is appended before the new list element unless -the list element is going to be the first element in a list or -sublist (i.e. the variable's current value is empty, or contains -the single character ``{'', or ends in `` }''). -.TP -\fBTCL_PARSE_PART1\fR -If this bit is set, -then \fBTcl_ObjGetVar2\fR and \fBTcl_ObjSetVar2\fR -will parse \fIpart1Ptr\fR -to obtain both an array name and an element name. -If the name in \fIpart1Ptr\fR contains an open parenthesis -and ends with a close parenthesis, -the name is treated as the name of an element of an array; -otherwise, the name in \fIpart1Ptr\fR -is interpreted as the name of a scalar variable. -When this bit is set, -\fIpart2Ptr\fR is ignored. -.PP -\fBTcl_ObjGetVar2\fR returns the value of the specified variable. -Its arguments are treated the same way as those for \fBTcl_ObjSetVar2\fR. -It returns a pointer to the object which is the variable's value. -The reference count for the returned object is not incremented. -If the caller needs to keep a reference to the object, -say in a data structure, -it must increment the reference count using \fBTcl_IncrRefCount\fR. -If an error occurs in setting the variable -(e.g. an array variable is referenced -without giving an index into the array), -then NULL is returned. - -.SH "SEE ALSO" -Tcl_GetObjResult, Tcl_GetStringResult, Tcl_GetVar, Tcl_GetVar2, Tcl_SetVar, Tcl_SetVar2, Tcl_TraceVar, Tcl_UnsetVar, Tcl_UnsetVar2 - -.SH KEYWORDS -array, interpreter, object, scalar, set, unset, variable diff --git a/doc/Object.3 b/doc/Object.3 index da9c3cd..214695f 100644 --- a/doc/Object.3 +++ b/doc/Object.3 @@ -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: Object.3,v 1.2 1998/09/14 18:39:49 stanton Exp $ +'\" RCS: @(#) $Id: Object.3,v 1.3 1999/04/16 00:46:32 stanton Exp $ '\" .so man.macros .TH Tcl_Obj 3 8.0 Tcl "Tcl Library Procedures" @@ -85,7 +85,7 @@ Because of this representation invalidation and regeneration, it is dangerous for extension writers to access \fBTcl_Obj\fR fields directly. It is better to access Tcl_Obj information using -procedures like \fBTcl_GetStringFromObj\fR. +procedures like \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR. .PP Objects are allocated on the heap and are referenced using a pointer to their \fBTcl_Obj\fR structure. @@ -138,7 +138,7 @@ The byte array must always have a null after the last byte, at offset \fIlength\fR; this allows string representations that do not contain nulls to be treated as conventional null-terminated C strings. -C programs use \fBTcl_GetStringFromObj\fR to get +C programs use \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR to get an object's string representation. If \fIbytes\fR is NULL, the string representation is invalid. @@ -177,7 +177,8 @@ An object typically starts out containing only a string representation: it is untyped and has a NULL \fItypePtr\fR. An object containing an empty string or a copy of a specified string is created using \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR respectively. -An object's string value is gotten with \fBTcl_GetStringFromObj\fR +An object's string value is gotten with +\fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR and changed with \fBTcl_SetStringObj\fR. If the object is later passed to a procedure like \fBTcl_GetIntFromObj\fR that requires a specific internal representation, @@ -187,7 +188,7 @@ An object's two representations are duals of each other: changes made to one are reflected in the other. For example, \fBTcl_ListObjReplace\fR will modify an object's internal representation and the next call to \fBTcl_GetStringFromObj\fR -will reflect that change. +or \fBTcl_GetString\fR will reflect that change. .PP Representations are recomputed lazily for efficiency. A change to one representation made by a procedure @@ -208,7 +209,7 @@ free any storage associated with the old string representation. Objects usually remain one type over their life, but occasionally an object must be converted from one type to another. For example, a C program might build up a string in an object -with repeated calls to \fBTcl_StringObjAppend\fR, +with repeated calls to \fBTcl_AppendToObj\fR, and then call \fBTcl_ListObjIndex\fR to extract a list element from the object. The same object holding the same string value diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index c0d121c..e9205e3 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -4,13 +4,13 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.2 1998/09/14 18:39:49 stanton Exp $ +'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.3 1999/04/16 00:46:32 stanton Exp $ .so man.macros -.TH Tcl_OpenFileChannel 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_OpenFileChannel 3 8.1 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_Close, Tcl_Read, Tcl_Gets, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_GetChannelOption, Tcl_SetChannelOption \- buffered I/O facilities using channels +Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, \- buffered I/O facilities using channels .SH SYNOPSIS .nf \fB#include \fR @@ -22,7 +22,7 @@ Tcl_Channel .sp Tcl_Channel \fBTcl_OpenCommandChannel\fR(\fIinterp, argc, argv, flags\fR) -.VS +.VS 8.0 .sp Tcl_Channel \fBTcl_MakeFileChannel\fR(\fIhandle, readOrWrite\fR) @@ -40,17 +40,28 @@ int int \fBTcl_Close\fR(\fIinterp, channel\fR) .sp +.VS 8.1 int -\fBTcl_Read\fR(\fIchannel, buf, toRead\fR) +\fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR) .sp int -\fBTcl_Gets\fR(\fIchannel, lineRead\fR) +\fBTcl_Read\fR(\fIchannel, byteBuf, bytesToRead\fR) .sp int \fBTcl_GetsObj\fR(\fIchannel, lineObjPtr\fR) .sp int -\fBTcl_Write\fR(\fIchannel, buf, toWrite\fR) +\fBTcl_Gets\fR(\fIchannel, lineRead\fR) +.sp +int +\fBTcl_WriteObj\fR(\fIchannel, writeObjPtr\fR) +.sp +int +\fBTcl_WriteChars\fR(\fIchannel, charBuf, bytesToWrite\fR) +.sp +int +\fBTcl_Write\fR(\fIchannel, byteBuf, bytesToWrite\fR) +.VE .sp int \fBTcl_Flush\fR(\fIchannel\fR) @@ -83,37 +94,36 @@ Used for error reporting and to look up a channel registered in it. .AP char *fileName in The name of a local or network file. .AP char *mode in -Specifies how the file is to be accessed. May have any of the -values allowed for the \fImode\fR argument to the Tcl -\fBopen\fR command. -For \fBTcl_OpenCommandChannel\fR, may be NULL. +Specifies how the file is to be accessed. May have any of the values +allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. For +\fBTcl_OpenCommandChannel\fR, may be NULL. .AP int permissions in -POSIX-style permission flags such as 0644. -If a new file is created, these permissions will be set on the -created file. +POSIX-style permission flags such as 0644. If a new file is created, these +permissions will be set on the created file. .AP int argc in The number of elements in \fIargv\fR. .AP char **argv in -Arguments for constructing a command pipeline. -These values have the same meaning as the non-switch arguments -to the Tcl \fBexec\fR command. +Arguments for constructing a command pipeline. These values have the same +meaning as the non-switch arguments to the Tcl \fBexec\fR command. .AP int flags in Specifies the disposition of the stdio handles in pipeline: OR-ed -combination of \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, \fBTCL_STDERR\fR, -and \fBTCL_ENFORCE_MODE\fR. If \fBTCL_STDIN\fR is set, stdin for -the first child in the pipe is the pipe channel, otherwise it is the same -as the standard input of the invoking process; likewise for -\fBTCL_STDOUT\fR and \fBTCL_STDERR\fR. If \fBTCL_ENFORCE_MODE\fR is not set, -then the pipe can redirect stdio handles to override the stdio handles for -which \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR have been set. -If it is set, then such redirections cause an error. -.VS +combination of \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, \fBTCL_STDERR\fR, and +\fBTCL_ENFORCE_MODE\fR. If \fBTCL_STDIN\fR is set, stdin for the first child +in the pipe is the pipe channel, otherwise it is the same as the standard +input of the invoking process; likewise for \fBTCL_STDOUT\fR and +\fBTCL_STDERR\fR. If \fBTCL_ENFORCE_MODE\fR is not set, then the pipe can +redirect stdio handles to override the stdio handles for which +\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR have been set. If it +is set, then such redirections cause an error. +.VS 8.0 .AP ClientData handle in Operating system specific handle for I/O to a file. For Unix this is a file descriptor, for Windows it is a HANDLE. .AP int readOrWrite in OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate what operations are valid on \fIhandle\fR. +.AP char *channelName in +The name of the channel. .VE .AP int *modePtr out Points at an integer variable that will receive an OR-ed combination of @@ -122,26 +132,40 @@ open for reading and writing. .AP Tcl_Channel channel in A Tcl channel for input or output. Must have been the return value from a procedure such as \fBTcl_OpenFileChannel\fR. -.AP char *buf in -An array of bytes in which to store channel input, or from which -to read channel output. -.AP int len in -The length of the input or output. -.AP int atEnd in -If nonzero, store the input at the end of the input queue, otherwise store -it at the head of the input queue. -.AP int toRead in -The number of bytes to read from the channel. -.AP Tcl_DString *lineRead in -A pointer to a Tcl dynamic string in which to store the line read from the -channel. Must have been initialized by the caller. The line read -will be appended to any data already in the dynamic string. -.AP Tcl_Obj *linePtrObj in +.VS 8.1 br +.AP Tcl_Obj *readObjPtr in/out +A pointer to a Tcl Object in which to store the characters read from the +channel. +.AP int charsToRead in +The number of characters to read from the channel. If the channel's encoding +is \fBbinary\fR, this is equivalent to the number of bytes to read from the +channel. +.AP int appendFlag in +If non-zero, data read from the channel will be appended to the object. +Otherwise, the data will replace the existing contents of the object. +.AP char *readBuf out +A buffer in which to store the bytes read from the channel. +.AP int bytesToRead in +The number of bytes to read from the channel. The buffer \fIreadBuf\fR must +be large enough to hold this many bytes. +.AP Tcl_Obj *lineObjPtr in/out A pointer to a Tcl object in which to store the line read from the channel. The line read will be appended to the current value of the object. -.AP int toWrite in -The number of bytes to read from \fIbuf\fR and output to the channel. +.AP Tcl_DString *lineRead in/out +A pointer to a Tcl dynamic string in which to store the line read from the +channel. Must have been initialized by the caller. The line read will be +appended to any data already in the dynamic string. +.AP Tcl_Obj *writeObjPtr in +A pointer to a Tcl Object whose contents will be output to the channel. +.AP "CONST char" *charBuf in +A buffer containing the characters to output to the channel. +.AP char *byteBuf in +A buffer containing the bytes to output to the channel. +.AP int bytesToWrite in +The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and +output to the channel. +.VE .AP int offset in How far to move the access point in the channel at which the next input or output operation will be applied, measured in bytes from the position @@ -169,7 +193,7 @@ types. The channel mechanism is extensible to new channel types, by providing a low level channel driver for the new type; the channel driver interface is described in the manual entry for \fBTcl_CreateChannel\fR. The -channel mechanism provides a buffering scheme modelled after +channel mechanism provides a buffering scheme modeled after Unix's standard I/O, and it also allows for nonblocking I/O on channels. .PP @@ -182,7 +206,7 @@ channels, see the manual entry for \fBTcl_CreateChannel\fR. .PP \fBTcl_OpenFileChannel\fR opens a file specified by \fIfileName\fR and returns a channel handle that can be used to perform input and output on -the file. This API is modelled after the \fBfopen\fR procedure of +the file. This API is modeled after the \fBfopen\fR procedure of the Unix standard I/O library. The syntax and meaning of all arguments is similar to those given in the Tcl \fBopen\fR command when opening a file. @@ -190,7 +214,7 @@ If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR -leaves an error message in \fIinterp->result\fR after any error. +leaves an error message in \fIinterp\fR's result after any error. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR, described below. @@ -310,93 +334,136 @@ left in \fIinterp->result\fR. .PP Note: it is not safe to call \fBTcl_Close\fR on a channel that has been registered using \fBTcl_RegisterChannel\fR; see the documentation for -\fBTcl_RegisterChannel\fR, above, for details. If the channel has ever been -given as the \fBchan\fR argument in a call to \fBTcl_RegisterChannel\fR, -you should instead use \fBTcl_UnregisterChannel\fR, which will internally -call \fBTcl_Close\fR when all calls to \fBTcl_RegisterChannel\fR have been -matched by corresponding calls to \fBTcl_UnregisterChannel\fR. +\fBTcl_RegisterChannel\fR, above, for details. If the channel has ever +been given as the \fBchan\fR argument in a call to +\fBTcl_RegisterChannel\fR, you should instead use +\fBTcl_UnregisterChannel\fR, which will internally call \fBTcl_Close\fR +when all calls to \fBTcl_RegisterChannel\fR have been matched by +corresponding calls to \fBTcl_UnregisterChannel\fR. -.SH TCL_READ -.PP -\fBTcl_Read\fR consumes up to \fItoRead\fR bytes of data from -\fIchannel\fR and stores it at \fIbuf\fR. -The return value of \fBTcl_Read\fR is the number of characters written -at \fIbuf\fR. -The buffer produced by \fBTcl_Read\fR is not NULL terminated. Its contents -are valid from the zeroth position up to and excluding the position -indicated by the return value. -If an error occurs, the return value is -1 and \fBTcl_Read\fR records -a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. -.PP -The return value may be smaller than the value of \fItoRead\fR, indicating -that less data than requested was available, also called a \fIshort -read\fR. -In blocking mode, this can only happen on an end-of-file. -In nonblocking mode, a short read can also occur if there is not -enough input currently available: \fBTcl_Read\fR returns a short -count rather than waiting for more data. -.PP -If the channel is in blocking mode, a return value of zero indicates an end -of file condition. If the channel is in nonblocking mode, a return value of -zero indicates either that no input is currently available or an end of -file condition. Use \fBTcl_Eof\fR and \fBTcl_InputBlocked\fR -to tell which of these conditions actually occurred. -.PP -\fBTcl_Read\fR translates platform-specific end-of-line representations -into the canonical \fB\en\fR internal representation according to the -current end-of-line recognition mode. End-of-line recognition and the -various platform-specific modes are described in the manual entry for the -Tcl \fBfconfigure\fR command. +.VS 8.1 br +.SH TCL_READCHARS AND TCL_READ +.PP +\fBTcl_ReadChars\fR consumes bytes from \fIchannel\fR, converting the bytes +to UTF-8 based on the channel's encoding and storing the produced data in +\fIreadObjPtr\fR's string representation. The return value of +\fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR, +that were stored in \fIobjPtr\fR. If an error occurs while reading, the +return value is \-1 and \fBTcl_ReadChars\fR records a POSIX error code that +can be retrieved with \fBTcl_GetErrno\fR. +.PP +The return value may be smaller than the value to read, indicating that less +data than requested was available. This is called a \fIshort read\fR. In +blocking mode, this can only happen on an end-of-file. In nonblocking mode, +a short read can also occur if there is not enough input currently +available: \fBTcl_ReadChars\fR returns a short count rather than waiting +for more data. +.PP +If the channel is in blocking mode, a return value of zero indicates an +end-of-file condition. If the channel is in nonblocking mode, a return +value of zero indicates either that no input is currently available or an +end-of-file condition. Use \fBTcl_Eof\fR and \fBTcl_InputBlocked\fR to tell +which of these conditions actually occurred. +.PP +\fBTcl_ReadChars\fR translates the various end-of-line representations into +the canonical \fB\en\fR internal representation according to the current +end-of-line recognition mode. End-of-line recognition and the various +platform-specific modes are described in the manual entry for the Tcl +\fBfconfigure\fR command. +.PP +As a performance optimization, when reading from a channel with the encoding +\fBbinary\fR, the bytes are not converted to UTF-8 as they are read. +Instead, they are stored in \fIreadObjPtr\fR's internal representation as a +byte-array object. The string representation of this object will only be +constructed if it is needed (e.g., because of a call to +\fBTcl_GetStringFromObj\fR). In this way, byte-oriented data can be read +from a channel, manipulated by calling \fBTcl_GetByteArrayFromObj\fR and +related functions, and then written to a channel without the expense of ever +converting to or from UTF-8. +.PP +\fBTcl_Read\fR is similar to \fBTcl_ReadChars\fR, except that it doesn't do +encoding conversions, regardless of the channel's encoding. It is deprecated +and exists for backwards compatibility with non-internationalized Tcl +extensions. It consumes bytes from \fIchannel\fR and stores them in +\fIbuf\fR, performing end-of-line translations on the way. The return value +of \fBTcl_Read\fR is the number of bytes, up to \fItoRead\fR, written in +\fIbuf\fR. The buffer produced by \fBTcl_Read\fR is not NULL terminated. +Its contents are valid from the zeroth position up to and excluding the +position indicated by the return value. -.SH TCL_GETS AND TCL_GETSOBJ -.PP -\fBTcl_Gets\fR reads a line of input from a channel and appends all of -the characters of the line except for the terminating end-of-line character(s) -to the dynamic string given by \fIdsPtr\fR. -The end-of-line character(s) are read and discarded. +.SH TCL_GETSOBJ AND TCL_GETS +.PP +\fBTcl_GetsObj\fR consumes bytes from \fIchannel\fR, converting the bytes to +UTF-8 based on the channel's encoding, until a full line of input has been +seen. If the channel's encoding is \fBbinary\fR, each byte read from the +channel is treated as an individual Unicode character. All of the +characters of the line except for the terminating end-of-line character(s) +are appended to \fIlineObjPtr\fR's string representation. The end-of-line +character(s) are read and discarded. +.PP +If a line was successfully read, the return value is greater than or equal +to zero and indicates the number of bytes stored in \fIlineObjPtr\fR. If an +error occurs, \fBTcl_GetsObj\fR returns \-1 and records a POSIX error code +that can be retrieved with \fBTcl_GetErrno\fR. \fBTcl_GetsObj\fR also +returns \-1 if the end of the file is reached; the \fBTcl_Eof\fR procedure +can be used to distinguish an error from an end-of-file condition. +.PP +If the channel is in nonblocking mode, the return value can also be \-1 if +no data was available or the data that was available did not contain an +end-of-line character. When \-1 is returned, the \fBTcl_InputBlocked\fR +procedure may be invoked to determine if the channel is blocked because +of input unavailability. +.PP +\fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting +characters are appended to the appended to the dynamic string given by +\fIdsPtr\fR rather than a Tcl object. + +.SH TCL_WRITECHARS, TCL_WRITEOBJ, AND TCL_WRITE .PP -If a line was successfully read, the return value is greater than or -equal to zero, and it indicates the number of characters stored -in the dynamic string. -If an error occurs, \fBTcl_Gets\fR returns -1 and records a POSIX error -code that can be retrieved with \fBTcl_GetErrno\fR. -\fBTcl_Gets\fR also returns -1 if the end of the file is reached; -the \fBTcl_Eof\fR procedure can be used to distinguish an error -from an end-of-file condition. -.PP -If the channel is in nonblocking mode, the return value can also -be -1 if no data was available or the data that was available -did not contain an end-of-line character. -When -1 is returned, the \fBTcl_InputBlocked\fR procedure may be -invoked to determine if the channel is blocked because of input -unavailability. -.PP -\fBTcl_GetsObj\fR is the same as \fBTcl_Gets\fR except the resulting -characters are appended to a Tcl object \fBlineObjPtr\fR rather than a -dynamic string. -.SH TCL_WRITE -.PP -\fBTcl_Write\fR accepts \fItoWrite\fR bytes of data at \fIbuf\fR for output -on \fIchannel\fR. This data may not appear on the output device -immediately. If the data should appear immediately, call \fBTcl_Flush\fR -after the call to \fBTcl_Write\fR, or set the \fB-buffering\fR option on -the channel to \fBnone\fR. If you wish the data to appear as soon as an end -of line is accepted for output, set the \fB\-buffering\fR option on the -channel to \fBline\fR mode. -.PP -The \fItoWrite\fR argument specifies how many bytes of data are provided in -the \fIbuf\fR argument. If it is negative, \fBTcl_Write\fR expects the data +\fBTcl_WriteChars\fR accepts \fIbytesToWrite\fR bytes of character data at +\fIcharBuf\fR. The UTF-8 characters in the buffer are converted to the +channel's encoding and queued for output to \fIchannel\fR. If +\fIbytesToWrite\fR is negative, \fBTcl_WriteChars\fR expects \fIcharBuf\fR to be NULL terminated and it outputs everything up to the NULL. .PP -The return value of \fBTcl_Write\fR is a count of how many -characters were accepted for output to the channel. This is either equal to -\fItoWrite\fR or -1 to indicate that an error occurred. -If an error occurs, \fBTcl_Write\fR also records a POSIX error code -that may be retrieved with \fBTcl_GetErrno\fR. +Data queued for output may not appear on the output device immediately, due +to internal buffering. If the data should appear immediately, call +\fBTcl_Flush\fR after the call to \fBTcl_WriteChars\fR, or set the +\fB\-buffering\fR option on the channel to \fBnone\fR. If you wish the data +to appear as soon as a complete line is accepted for output, set the +\fB\-buffering\fR option on the channel to \fBline\fR mode. +.PP +The return value of \fBTcl_WriteChars\fR is a count of how many bytes were +accepted for output to the channel. This is either greater than zero to +indicate success or \-1 to indicate that an error occurred. If an error +occurs, \fBTcl_WriteChars\fR records a POSIX error code that may be +retrieved with \fBTcl_GetErrno\fR. .PP Newline characters in the output data are translated to platform-specific -end-of-line sequences according to the \fB\-translation\fR option for -the channel. +end-of-line sequences according to the \fB\-translation\fR option for the +channel. This is done even if the channel has no encoding. +.PP +\fBTcl_WriteObj\fR is similar to \fBTcl_WriteChars\fR except it +accepts a Tcl object whose contents will be output to the channel. The +UTF-8 characters in \fIwriteObjPtr\fR's string representation are converted +to the channel's encoding and queued for output to \fIchannel\fR. +As a performance optimization, when writing to a channel with the encoding +\fBbinary\fR, UTF-8 characters are not converted as they are written. +Instead, the bytes in \fIwriteObjPtr\fR's internal representation as a +byte-array object are written to the channel. The byte-array representation +of the object will be constructed if it is needed. In this way, +byte-oriented data can be read from a channel, manipulated by calling +\fBTcl_GetByteArrayFromObj\fR and related functions, and then written to a +channel without the expense of ever converting to or from UTF-8. +.PP +\fBTcl_Write\fR is similar to \fBTcl_WriteChars\fR except that it doesn't do +encoding conversions, regardless of the channel's encoding. It is +deprecated and exists for backwards compatibility with non-internationalized +Tcl extensions. It accepts \fIbytesToWrite\fR bytes of data at +\fIbyteBuf\fR and queues them for output to \fIchannel\fR. If +\fIbytesToWrite\fR is negative, \fBTcl_Write\fR expects \fIbyteBuf\fR to be +NULL terminated and it outputs everything up to the NULL. +.VE .SH TCL_FLUSH .PP @@ -419,14 +486,14 @@ data will be read or written. Buffered output is flushed to the channel and buffered input is discarded, prior to the seek operation. .PP \fBTcl_Seek\fR normally returns the new access point. -If an error occurs, \fBTcl_Seek\fR returns -1 and records a POSIX error +If an error occurs, \fBTcl_Seek\fR returns \-1 and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. After an error, the access point may or may not have been moved. .SH TCL_TELL .PP \fBTcl_Tell\fR returns the current access point for a channel. The returned -value is -1 if the channel does not support seeking. +value is \-1 if the channel does not support seeking. .SH TCL_GETCHANNELOPTION .PP @@ -477,7 +544,7 @@ The call always returns zero if the channel is in blocking mode. buffered in the internal buffers for a channel. If the channel is not open for reading, this function always returns zero. -.VS +.VS 8.0 .SH "PLATFORM ISSUES" .PP The handles returned from \fBTcl_GetChannelHandle\fR depend on the diff --git a/doc/ParseCmd.3 b/doc/ParseCmd.3 new file mode 100644 index 0000000..2a180a6 --- /dev/null +++ b/doc/ParseCmd.3 @@ -0,0 +1,426 @@ +'\" +'\" Copyright (c) 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: ParseCmd.3,v 1.2 1999/04/16 00:46:32 stanton Exp $ +'\" +.so man.macros +.TH Tcl_ParseCommand 3 8.1 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_FreeParse, Tcl_EvalTokens \- parse Tcl scripts and expressions +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTcl_ParseCommand\fR(\fIinterp, string, numBytes, nested, parsePtr\fR) +.sp +int +\fBTcl_ParseExpr\fR(\fIinterp, string, numBytes, parsePtr\fR) +.sp +int +\fBTcl_ParseBraces\fR(\fIinterp, string, numBytes, parsePtr, append, termPtr\fR) +.sp +int +\fBTcl_ParseQuotedString\fR(\fIinterp, string, numBytes, parsePtr, append, termPtr\fR) +.sp +int +\fBTcl_ParseVarName\fR(\fIinterp, string, numBytes, parsePtr, append\fR) +.sp +\fBTcl_FreeParse\fR(\fIusedParsePtr\fR) +.sp +Tcl_Obj * +\fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR) +.SH ARGUMENTS +.AS Tcl_Interp *usedParsePtr +.AP Tcl_Interp *interp out +For procedures other than \fBTcl_FreeParse\fR and \fBTcl_EvalTokens\fR, +used only for error reporting; +if NULL, then no error messages are left after errors. +For \fBTcl_EvalTokens\fR, determines the context for evaluating the +script and also is used for error reporting; must not be NULL. +.AP char *string in +Pointer to first character in string to parse. +.AP int numBytes in +Number of bytes in \fIstring\fR, not including any terminating null +character. If less than 0 then the script consists of all characters +in \fIstring\fR up to the first null character. +.AP int nested in +Non-zero means that the script is part of a command substitution so an +unquoted close bracket should be treated as a command terminator. If zero, +close brackets have no special meaning. +.AP int append in +Non-zero means that \fI*parsePtr\fR already contains valid tokens; the new +tokens should be appended to those already present. Zero means that +\fI*parsePtr\fR is uninitialized; any information in it is ignored. +This argument is normally 0. +.AP Tcl_Parse *parsePtr out +Points to structure to fill in with information about the parsed +command, expression, variable name, etc. +Any previous information in this structure +is ignored, unless \fIappend\fR is non-zero in a call to +\fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, +or \fBTcl_ParseVarName\fR. +.AP char **termPtr out +If not NULL, points to a location where +\fBTcl_ParseBraces\fR and \fBTcl_ParseQuotedString\fR +will store a pointer to the character +just after the terminating close-brace or close-quote (respectively) +if the parse was successful. +.AP Tcl_Parse *usedParsePtr in +Points to structure that was filled in by a previous call to +\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseVarName\fR, etc. +.BE + +.SH DESCRIPTION +.PP +These procedures parse Tcl commands or portions of Tcl commands such as +expressions or references to variables. +Each procedure takes a pointer to a script (or portion thereof) +and fills in the structure pointed to by \fIparsePtr\fR +with a collection of tokens describing the information that was parsed. +The procedures normally return \fBTCL_OK\fR. +However, if an error occurs then they return \fBTCL_ERROR\fR, +leave an error message in \fIinterp's\fR result +(if \fIinterp\fR is not NULL), +and leave nothing in \fIparsePtr\fR. +.PP +\fBTcl_ParseCommand\fR is a procedure that parses Tcl +scripts. Given a pointer to a script, it +parses the first command from the script. If the command was parsed +successfully, \fBTcl_ParseCommand\fR returns \fBTCL_OK\fR and fills in the +structure pointed to by \fIparsePtr\fR with information about the +structure of the command (see below for details). +If an error occurred in parsing the command then +\fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's +result, and no information is left at \fI*parsePtr\fR. +.PP +\fBTcl_ParseExpr\fR parses Tcl expressions. +Given a pointer to a script containing an expression, +\fBTcl_ParseCommand\fR parses the expression. +If the expression was parsed successfully, +\fBTcl_ParseExpr\fR returns \fBTCL_OK\fR and fills in the +structure pointed to by \fIparsePtr\fR with information about the +structure of the expression (see below for details). +If an error occurred in parsing the command then +\fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's +result, and no information is left at \fI*parsePtr\fR. +.PP +\fBTcl_ParseBraces\fR parses a string or command argument +enclosed in braces such as +\fB{hello}\fR or \fB{string \\t with \\t tabs}\fR +from the beginning of its argument \fIstring\fR. +The first character of \fIstring\fR must be \fB{\fR. +If the braced string was parsed successfully, +\fBTcl_ParseBraces\fR returns \fBTCL_OK\fR, +fills in the structure pointed to by \fIparsePtr\fR +with information about the structure of the string +(see below for details), +and stores a pointer to the character just after the terminating \fB}\fR +in the location given by \fI*termPtr\fR. +If an error occurrs while parsing the string +then \fBTCL_ERROR\fR is returned, +an error message is left in \fIinterp\fR's result, +and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR. +.PP +\fBTcl_ParseQuotedString\fR parses a double-quoted string such as +\fB"sum is [expr $a+$b]"\fR +from the beginning of the argument \fIstring\fR. +The first character of \fIstring\fR must be \fB"\fR. +If the double-quoted string was parsed successfully, +\fBTcl_ParseQuotedString\fR returns \fBTCL_OK\fR, +fills in the structure pointed to by \fIparsePtr\fR +with information about the structure of the string +(see below for details), +and stores a pointer to the character just after the terminating \fB"\fR +in the location given by \fI*termPtr\fR. +If an error occurrs while parsing the string +then \fBTCL_ERROR\fR is returned, +an error message is left in \fIinterp\fR's result, +and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR. +.PP +\fBTcl_ParseVarName\fR parses a Tcl variable reference such as +\fB$abc\fR or \fB$x([expr $index + 1])\fR from the beginning of its +\fIstring\fR argument. +The first character of \fIstring\fR must be \fB$\fR. +If a variable name was parsed successfully, \fBTcl_ParseVarName\fR +returns \fBTCL_OK\fR and fills in the structure pointed to by +\fIparsePtr\fR with information about the structure of the variable name +(see below for details). If an error +occurrs while parsing the command then \fBTCL_ERROR\fR is returned, an +error message is left in \fIinterp\fR's result (if \fIinterp\fR isn't +NULL), and no information is left at \fI*parsePtr\fR. +.PP +The information left at \fI*parsePtr\fR +by \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, +\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR +may include dynamically allocated memory. +If these five parsing procedures return \fBTCL_OK\fR +then the caller must invoke \fBTcl_FreeParse\fR to release +the storage at \fI*parsePtr\fR. +These procedures ignore any existing information in +\fI*parsePtr\fR (unless \fIappend\fR is non-zero), +so if repeated calls are being made to any of them +then \fBTcl_FreeParse\fR must be invoked once after each call. +.PP +\fBTcl_EvalTokens\fR evaluates a sequence of parse tokens from a Tcl_Parse +structure. The tokens typically consist +of all the tokens in a word or all the tokens that make up the index for +a reference to an array variable. \fBTcl_EvalTokens\fR performs the +substitutions requested by the tokens, concatenates the +resulting values, and returns the result in a new Tcl_Obj. The +reference count of the object returned as result has been +incremented, so the caller must +invoke \fBTcl_DecrRefCount\fR when it is finished with the object. +If an error occurs while evaluating the tokens (such as a reference to +a non-existent variable) then the return value is NULL and an error +message is left in \fIinterp\fR's result. + +.SH TCL_PARSE STRUCTURE +.PP +\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, +\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR +return parse information in two data structures, Tcl_Parse and Tcl_Token: +.CS +typedef struct Tcl_Parse { + char *\fIcommentStart\fR; + int \fIcommentSize\fR; + char *\fIcommandStart\fR; + int \fIcommandSize\fR; + int \fInumWords\fR; + Tcl_Token *\fItokenPtr\fR; + int \fInumTokens\fR; + ... +} Tcl_Parse; + +typedef struct Tcl_Token { + int \fItype\fR; + char *\fIstart\fR; + int \fIsize\fR; + int \fInumComponents\fR; +} Tcl_Token; +.CE +.PP +The first five fields of a Tcl_Parse structure +are filled in only by \fBTcl_ParseCommand\fR. +These fields are not used by the other parsing procedures. +.PP +\fBTcl_ParseCommand\fR fills in a Tcl_Parse structure +with information that describes one Tcl command and any comments that +precede the command. +If there are comments, +the \fIcommentStart\fR field points to the \fB#\fR character that begins +the first comment and \fIcommentSize\fR indicates the number of bytes +in all of the comments preceding the command, including the newline +character that terminates the last comment. +If the command is not preceded by any comments, \fIcommentSize\fR is 0. +\fBTcl_ParseCommand\fR also sets the \fIcommandStart\fR field +to point to the first character of the first +word in the command (skipping any comments and leading space) and +\fIcommandSize\fR gives the total number of bytes in the command, +including the character pointed to by \fIcommandStart\fR up to and +including the newline, close bracket, or semicolon character that +terminates the command. The \fInumWords\fR field gives the +total number of words in the command. +.PP +All parsing procedures set the remaining fields, +\fItokenPtr\fR and \fInumTokens\fR. +The \fItokenPtr\fR field points to the first in an array of Tcl_Token +structures that describe the components of the entity being parsed. +The \fInumTokens\fR field gives the total number of tokens +present in the array. +Each token contains four fields. +The \fItype\fR field selects one of several token types +that are described below. The \fIstart\fR field +points to the first character in the token and the \fIsize\fR field +gives the total number of characters in the token. Some token types, +such as \fBTCL_TOKEN_WORD\fR and \fBTCL_TOKEN_VARIABLE\fR, consist of +several component tokens, which immediately follow the parent token; +the \fInumComponents\fR field describes how many of these there are. +The \fItype\fR field has one of the following values: +.TP 20 +\fBTCL_TOKEN_WORD\fR +This token ordinarily describes one word of a command +but it may also describe a quoted or braced string in an expression. +The token describes a component of the script that is +the result of concatenating together a sequence of subcomponents, +each described by a separate subtoken. +The token starts with the first non-blank +character of the component (which may be a double-quote or open brace) +and includes all characters in the component up to but not including the +space, semicolon, close bracket, close quote, or close brace that +terminates the component. The \fInumComponents\fR field counts the total +number of sub-tokens that make up the word, including sub-tokens +of \fBTCL_TOKEN_VARIABLE\fR and \fBTCL_TOKEN_BS\fR tokens. +.TP +\fBTCL_TOKEN_SIMPLE_WORD\fR +This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that +the word is guaranteed to consist of a single \fBTCL_TOKEN_TEXT\fR +sub-token. The \fInumComponents\fR field is always 1. +.TP +\fBTCL_TOKEN_TEXT\fR +The token describes a range of literal text that is part of a word. +The \fInumComponents\fR field is always 0. +.TP +\fBTCL_TOKEN_BS\fR +The token describes a backslash sequence such as \fB\en\fR or \fB\e0xa3\fR. +The \fInumComponents\fR field is always 0. +.TP +\fBTCL_TOKEN_COMMAND\fR +The token describes a command whose result result must be substituted into +the word. The token includes the square brackets that surround the +command. The \fInumComponents\fR field is always 0 (the nested command +is not parsed; call \fBTcl_ParseCommand\fR recursively if you want to +see its tokens). +.TP +\fBTCL_TOKEN_VARIABLE\fR +The token describes a variable substitution, including the +\fB$\fR, variable name, and array index (if there is one) up through the +close parenthesis that terminates the index. This token is followed +by one or more additional tokens that describe the variable name and +array index. If \fInumComponents\fR is 1 then the variable is a +scalar and the next token is a \fBTCL_TOKEN_TEXT\fR token that gives the +variable name. If \fInumComponents\fR is greater than 1 then the +variable is an array: the first sub-token is a \fBTCL_TOKEN_TEXT\fR +token giving the array name and the remaining sub-tokens are +\fBTCL_TOKEN_TEXT\fR, \fBTCL_TOKEN_BS\fR, \fBTCL_TOKEN_COMMAND\fR, and +\fBTCL_TOKEN_VARIABLE\fR tokens that must be concatenated to produce the +array index. The \fInumComponents\fR field includes nested sub-tokens +that are part of \fBTCL_TOKEN_VARIABLE\fR tokens in the array index. +.TP +\fBTCL_TOKEN_SUB_EXPR\fR +The token describes one subexpression of an expression +(or an entire expression). +A subexpression may consist of a value +such as an integer literal, variable substitution, +or parenthesized subexpression; +it may also consist of an operator and its operands. +The token starts with the first non-blank character of the subexpression +up to but not including the space, brace, close-paren, or bracket +that terminates the subexpression. +This token is followed by one or more additional tokens +that describe the subexpression. +If the first sub-token after the \fBTCL_TOKEN_SUB_EXPR\fR token +is a \fBTCL_TOKEN_OPERATOR\fR token, +the subexpression consists of an operator and its token operands. +If the operator has no operands, the subexpression consists of +just the \fBTCL_TOKEN_OPERATOR\fR token. +Each operand is described by a \fBTCL_TOKEN_SUB_EXPR\fR token. +Otherwise, the subexpression is a value described by +one of the token types \fBTCL_TOKEN_WORD\fR, \fBTCL_TOKEN_TEXT\fR, +\fBTCL_TOKEN_BS\fR, \fBTCL_TOKEN_COMMAND\fR, +\fBTCL_TOKEN_VARIABLE\fR, and \fBTCL_TOKEN_SUB_EXPR\fR. +The \fInumComponents\fR field +counts the total number of sub-tokens that make up the subexpression; +this includes the sub-tokens for any nested \fBTCL_TOKEN_SUB_EXPR\fR tokens. +.TP +\fBTCL_TOKEN_OPERATOR\fR +The token describes one operator of an expression +such as \fB&&\fR or \fBhypot\fR. +An \fBTCL_TOKEN_OPERATOR\fR token is always preceeded by a +\fBTCL_TOKEN_SUB_EXPR\fR token +that describes the operator and its operands; +the \fBTCL_TOKEN_SUB_EXPR\fR token's \fInumComponents\fR field +can be used to determine the number of operands. +A binary operator such as \fB*\fR +is followed by two \fBTCL_TOKEN_SUB_EXPR\fR tokens +that describe its operands. +A unary operator like \fB-\fR +is followed by a single \fBTCL_TOKEN_SUB_EXPR\fR token +for its operand. +If the operator is a math function such as \fBlog10\fR, +the \fBTCL_TOKEN_OPERATOR\fR token will give its name and +the following \fBTCL_TOKEN_SUB_EXPR\fR tokens will describe +its operands; +if there are no operands (as with \fBrand\fR), +no \fBTCL_TOKEN_SUB_EXPR\fR tokens follow. +There is one trinary operator, \fB?\fR, +that appears in if-then-else subexpressions +such as \fIx\fB?\fIy\fB:\fIz\fR; +in this case, the \fB?\fR \fBTCL_TOKEN_OPERATOR\fR token +is followed by three \fBTCL_TOKEN_SUB_EXPR\fR tokens for the operands +\fIx\fR, \fIy\fR, and \fIz\fR. +The \fInumComponents\fR field for a \fBTCL_TOKEN_OPERATOR\fR token +is always 0. +.PP +After \fBTcl_ParseCommand\fR returns, the first token pointed to by +the \fItokenPtr\fR field of the +Tcl_Parse structure always has type \fBTCL_TOKEN_WORD\fR or +\fBTCL_TOKEN_SIMPLE_WORD\fR. It is followed by the sub-tokens +that must be concatenated to produce the value of that word. +The next token is the \fBTCL_TOKEN_WORD\fR or \fBTCL_TOKEN_SIMPLE_WORD\fR +token for the second word, followed by sub-tokens for that +word, and so on until all \fInumWords\fR have been accounted +for. +.PP +After \fBTcl_ParseExpr\fR returns, the first token pointed to by +the \fItokenPtr\fR field of the +Tcl_Parse structure always has type \fBTCL_TOKEN_SUB_EXPR\fR. +It is followed by the sub-tokens that must be evaluated +to produce the value of the expression. +Only the token information in the Tcl_Parse structure +is modified: the \fIcommentStart\fR, \fIcommentSize\fR, +\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified +by \fBTcl_ParseExpr\fR. +.PP +After \fBTcl_ParseBraces\fR returns, +the array of tokens pointed to by the \fItokenPtr\fR field of the +Tcl_Parse structure will contain a single \fBTCL_TOKEN_TEXT\fR token +if the braced string does not contain any backslash-newlines. +If the string does contain backslash-newlines, +the array of tokens will contain one or more +\fBTCL_TOKEN_TEXT\fR or \fBTCL_TOKEN_BS\fR sub-tokens +that must be concatenated to produce the value of the string. +If the braced string was just \fB{}\fR +(that is, the string was empty), +the single \fBTCL_TOKEN_TEXT\fR token will have a \fIsize\fR field +containing zero; +this ensures that at least one token appears +to describe the braced string. +Only the token information in the Tcl_Parse structure +is modified: the \fIcommentStart\fR, \fIcommentSize\fR, +\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified +by \fBTcl_ParseBraces\fR. +.PP +After \fBTcl_ParseQuotedString\fR returns, +the array of tokens pointed to by the \fItokenPtr\fR field of the +Tcl_Parse structure depends on the contents of the quoted string. +It will consist of one or more \fBTCL_TOKEN_TEXT\fR, \fBTCL_TOKEN_BS\fR, +\fBTCL_TOKEN_COMMAND\fR, and \fBTCL_TOKEN_VARIABLE\fR sub-tokens. +The array always contains at least one token; +for example, if the argument \fIstring\fR is empty, +the array returned consists of a single \fBTCL_TOKEN_TEXT\fR token +with a zero \fIsize\fR field. +Only the token information in the Tcl_Parse structure +is modified: the \fIcommentStart\fR, \fIcommentSize\fR, +\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified. +.PP +After \fBTcl_ParseVarName\fR returns, the first token pointed to by +the \fItokenPtr\fR field of the +Tcl_Parse structure always has type \fBTCL_TOKEN_VARIABLE\fR. It +is followed by the sub-tokens that make up the variable name as +described above. The total length of the variable name is +contained in the \fIsize\fR field of the first token. +As in \fBTcl_ParseExpr\fR, +only the token information in the Tcl_Parse structure +is modified by \fBTcl_ParseVarName\fR: +the \fIcommentStart\fR, \fIcommentSize\fR, +\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified. +.PP +All of the character pointers in the +Tcl_Parse and Tcl_Token structures refer +to characters in the \fIstring\fR argument passed to +\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, +\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR. +.PP +There are additional fields in the Tcl_Parse structure after the +\fInumTokens\fR field, but these are for the private use of +\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, +\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR; they should not be +referenced by code outside of these procedures. + +.SH KEYWORDS +backslash substitution, braces, command, expression, parse, token, variable substitution diff --git a/doc/RegExp.3 b/doc/RegExp.3 index 61778cd..1f1064d 100644 --- a/doc/RegExp.3 +++ b/doc/RegExp.3 @@ -1,21 +1,25 @@ '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1998-1999 Scriptics Corportation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: RegExp.3,v 1.2 1998/09/14 18:39:50 stanton Exp $ +'\" RCS: @(#) $Id: RegExp.3,v 1.3 1999/04/16 00:46:32 stanton Exp $ '\" .so man.macros .TH Tcl_RegExpMatch 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange \- Pattern matching with regular expressions +Tcl_GetRegExpFromObj, Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange \- Pattern matching with regular expressions .SH SYNOPSIS .nf \fB#include \fR .sp +Tcl_RegExp +\fBTcl_GetRegExpFromObj\fR(\fIinterp\fR, \fIpatObj\fR, \fIflags\fR) +.sp int \fBTcl_RegExpMatch\fR(\fIinterp\fR, \fIstring\fR, \fIpattern\fR) .sp @@ -34,9 +38,13 @@ Tcl interpreter to use for error reporting. String to check for a match with a regular expression. .AP char *pattern in String in the form of a regular expression pattern. +.AP Tcl_Obj *patObj in +Refers to the object from which to get a compiled regular expression. +.AP int flags in +Various flags to control regular expression compile options. .AP Tcl_RegExp regexp in Compiled regular expression. Must have been returned previously -by \fBTcl_RegExpCompile\fR. +by \fBTcl_GetRegExpFromObj\fR. .AP char *start in If \fIstring\fR is just a portion of some other string, this argument identifies the beginning of the larger string. @@ -56,6 +64,13 @@ is stored here, or NULL if there is no such range. .SH DESCRIPTION .PP +\fBTcl_GetRegExpFromObj\fR attepts to return a compiled regular +expression from the Tcl obj \fIpatObj\fR. If the object does not +already contain a compiled regular expression it will attempt to +create one from the string in the Tcl obj and assign it to the +internal representation of the \fIpatObj\fR. The return value +of this function is of type \fBTcl_RegExp\fR. +.PP \fBTcl_RegExpMatch\fR determines whether its \fIpattern\fR argument matches \fIregexp\fR, where \fIregexp\fR is interpreted as a regular expression using the same rules as for the diff --git a/doc/SaveResult.3 b/doc/SaveResult.3 new file mode 100644 index 0000000..6a0a051 --- /dev/null +++ b/doc/SaveResult.3 @@ -0,0 +1,65 @@ +'\" +'\" Copyright (c) 1997 by 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: SaveResult.3,v 1.2 1999/04/16 00:46:33 stanton Exp $ +'\" +.so man.macros +.TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's result +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fBTcl_SaveResult(\fIinterp, statePtr\fB)\fR +.sp +\fBTcl_RestoreResult(\fIinterp, statePtr\fB)\fR +.sp +\fBTcl_DiscardResult(\fIstatePtr\fB)\fR +.SH ARGUMENTS +.AS Tcl_SavedResult statePtr +.AP Tcl_Interp *interp in +Interpreter for which state should be saved. +.AP Tcl_SavedResult *statePtr in +Pointer to location where interpreter result should be saved or restored. +.BE + +.SH DESCRIPTION +.PP +These routines allows a C procedure to take a snapshot of the current +interpreter result so that it can be restored after a call +to \fBTcl_Eval\fR or some other routine that modifies the interpreter +result. These routines are passed a pointer to a structure that is +used to store enough information to restore the interpreter result +state. This structure can be allocated on the stack of the calling +procedure. These routines do not save the state of any error +information in the interpreter (e.g. the \fBerrorCode\fR or +\fBerrorInfo\fR variables). +.PP +\fBTcl_SaveResult\fR moves the string and object results +of \fIinterp\fR into the location specified by \fIstatePtr\fR. +\fBTcl_SaveResult\fR clears the result for \fIinterp\fR and +leaves the result in its normal empty initialized state. +.PP +\fBTcl_RestoreResult\fR moves the string and object results from +\fIstatePtr\fR back into \fIinterp\fR. Any result or error that was +already in the interpreter will be cleared. The \fIstatePtr\fR is left +in an uninitialized state and cannot be used until another call to +\fBTcl_SaveResult\fR. +.PP +\fBTcl_DiscardResult\fR releases the saved interpreter state +stored at \fBstatePtr\fR. The state structure is left in an +uninitialized state and cannot be used until another call to +\fBTcl_SaveResult\fR. +.PP +Once \fBTcl_SaveResult\fR is called to save the interpreter +result, either \fBTcl_RestoreResult\fR or +\fBTcl_DiscardResult\fR must be called to properly clean up the +memory associated with the saved state. + +.SH KEYWORDS +result, state, interp diff --git a/doc/SetRecLmt.3 b/doc/SetRecLmt.3 index b41985b..599e46f 100644 --- a/doc/SetRecLmt.3 +++ b/doc/SetRecLmt.3 @@ -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: SetRecLmt.3,v 1.2 1998/09/14 18:39:50 stanton Exp $ +'\" RCS: @(#) $Id: SetRecLmt.3,v 1.3 1999/04/16 00:46:33 stanton Exp $ '\" .so man.macros .TH Tcl_SetRecursionLimit 3 7.0 Tcl "Tcl Library Procedures" @@ -41,7 +41,7 @@ allowable nesting depth for an interpreter. The \fIdepth\fR argument specifies a new limit for \fIinterp\fR, and \fBTcl_SetRecursionLimit\fR returns the old limit. To read out the old limit without modifying it, invoke -\fBTcl_SetRecursionDepth\fR with \fIdepth\fR equal to 0. +\fBTcl_SetRecursionLimit\fR with \fIdepth\fR equal to 0. .PP The \fBTcl_SetRecursionLimit\fR only sets the size of the Tcl call stack: it cannot by itself prevent stack overflows on the diff --git a/doc/SetVar.3 b/doc/SetVar.3 index 70100f4..bb07005 100644 --- a/doc/SetVar.3 +++ b/doc/SetVar.3 @@ -5,93 +5,158 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: SetVar.3,v 1.2 1998/09/14 18:39:50 stanton Exp $ +'\" RCS: @(#) $Id: SetVar.3,v 1.3 1999/04/16 00:46:33 stanton Exp $ '\" .so man.macros -.TH Tcl_SetVar 3 7.4 Tcl "Tcl Library Procedures" +.TH Tcl_SetVar 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_SetVar, Tcl_SetVar2, Tcl_GetVar, Tcl_GetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables +Tcl_SetVar2Ex, Tcl_SetVar, Tcl_SetVar2, Tcl_ObjSetVar2, Tcl_GetVar2Ex, Tcl_GetVar, Tcl_GetVar2, Tcl_ObjGetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables .SH SYNOPSIS .nf \fB#include \fR .sp +.VS 8.1 +Tcl_Obj * +\fBTcl_SetVar2Ex\fR(\fIinterp, name1, name2, newValuePtr, flags\fR) +.VE +.sp char * \fBTcl_SetVar\fR(\fIinterp, varName, newValue, flags\fR) .sp char * \fBTcl_SetVar2\fR(\fIinterp, name1, name2, newValue, flags\fR) .sp +Tcl_Obj * +\fBTcl_ObjSetVar2\fR(\fIinterp, part1Ptr, part2Ptr, newValuePtr, flags\fR) +.sp +.VS 8.1 +Tcl_Obj * +\fBTcl_GetVar2Ex\fR(\fIinterp, name1, name2, flags\fR) +.VE +.sp char * \fBTcl_GetVar\fR(\fIinterp, varName, flags\fR) .sp char * \fBTcl_GetVar2\fR(\fIinterp, name1, name2, flags\fR) .sp +Tcl_Obj * +\fBTcl_ObjGetVar2\fR(\fIinterp, part1Ptr, part2Ptr, flags\fR) +.sp int \fBTcl_UnsetVar\fR(\fIinterp, varName, flags\fR) .sp int \fBTcl_UnsetVar2\fR(\fIinterp, name1, name2, flags\fR) .SH ARGUMENTS -.AS Tcl_Interp *newValue +.AS Tcl_Interp *newValuePtr .AP Tcl_Interp *interp in Interpreter containing variable. +.AP char *name1 in +Contains the name of an array variable (if \fIname2\fR is non-NULL) +or (if \fIname2\fR is NULL) either the name of a scalar variable +or a complete name including both variable name and index. +May include \fB::\fR namespace qualifiers +to specify a variable in a particular namespace. +.AP char *name2 in +If non-NULL, gives name of element within array; in this +case \fIname1\fR must refer to an array variable. +.AP Tcl_Obj *newValuePtr in +.VS 8.1 +Points to a Tcl object containing the new value for the variable. +.VE +.AP int flags in +OR-ed combination of bits providing additional information. See below +for valid values. .AP char *varName in Name of variable. -May include a series of \fB::\fR namespace qualifiers +May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. May refer to a scalar variable or an element of -an array variable. -If the name references an element of an array, then it +an array. +If the name references an element of an array, then the name must be in writable memory: Tcl will make temporary modifications to it while looking up the name. .AP char *newValue in -New value for variable. -.AP int flags in -OR-ed combination of bits providing additional information for -operation. See below for valid values. -.AP char *name1 in -Name of scalar variable, or name of array variable if \fIname2\fR -is non-NULL. -May include a series of \fB::\fR namespace qualifiers +New value for variable, specified as a NULL-terminated string. +A copy of this value is stored in the variable. +.AP Tcl_Obj *part1Ptr in +Points to a Tcl object containing the variable's name. +The name may include a series of \fB::\fR namespace qualifiers to specify a variable in a particular namespace. -.AP char *name2 in -If non-NULL, gives name of element within array and \fIname1\fR -must refer to an array variable. +May refer to a scalar variable or an element of an array variable. +.AP Tcl_Obj *part2Ptr in +If non-NULL, points to an object containing the name of an element +within an array and \fIpart1Ptr\fR must refer to an array variable. .BE .SH DESCRIPTION .PP -These procedures may be used to create, modify, read, and delete +These procedures are used to create, modify, read, and delete Tcl variables from C code. .PP -Note that \fBTcl_GetVar\fR and \fBTcl_SetVar\fR -have been largely replaced by the -object-based procedures \fBTcl_ObjGetVar2\fR and \fBTcl_ObjSetVar2\fR. -Those object-based procedures read, modify, and create -a variable whose name is held in a Tcl object instead of a string. -They also return a pointer to the object -which is the variable's value instead of returning a string. -Operations on objects can be faster since objects -hold an internal representation that can be manipulated more efficiently. -.PP -\fBTcl_SetVar\fR and \fBTcl_SetVar2\fR +.VS 8.1 +\fBTcl_SetVar2Ex\fR, \fBTcl_SetVar\fR, \fBTcl_SetVar2\fR, and +\fBTcl_ObjSetVar2\fR will create a new variable or modify an existing one. -Both of these procedures set the given variable to the value -given by \fInewValue\fR, and they return a pointer to a -copy of the variable's new value, which is stored in Tcl's +These procedures set the given variable to the value +given by \fInewValuePtr\fR or \fInewValue\fR and return a +pointer to the variable's new value, which is stored in Tcl's variable structure. -Tcl keeps a private copy of the variable's value, so the caller -may change \fInewValue\fR after these procedures return without -affecting the value of the variable. +\fBTcl_SetVar2Ex\fR and \fBTcl_ObjSetVar2\fR take the new value as a +Tcl_Obj and return +a pointer to a Tcl_Obj. \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR +take the new value as a string and return a string; they are +usually less efficient than \fBTcl_ObjSetVar2\fR. Note that the +return value may be different than the \fInewValuePtr\fR or +.VE +\fInewValue\fR argument, due to modifications made by write traces. If an error occurs in setting the variable (e.g. an array -variable is referenced without giving an index into the array), -they return NULL. +variable is referenced without giving an index into the array) +NULL is returned and an error message is left in \fIinterp\fR's +result if the \fBTCL_LEAVE_ERR_MSG\fR \fIflag\fR bit is set. +.PP +.VS 8.1 +\fBTcl_GetVar2Ex\fR, \fBTcl_GetVar\fR, \fBTcl_GetVar2\fR, and +\fBTcl_ObjGetVar2\fR +return the current value of a variable. +The arguments to these procedures are treated in the same way +as the arguments to the procedures described above. +Under normal circumstances, the return value is a pointer +to the variable's value. For \fBTcl_GetVar2Ex\fR and +\fBTcl_ObjGetVar2\fR the value is +returned as a pointer to a Tcl_Obj. For \fBTcl_GetVar\fR and +\fBTcl_GetVar2\fR the value is returned as a string; this is +usually less efficient, so \fBTcl_GetVar2Ex\fR or \fBTcl_ObjGetVar2\fR +are preferred. +.VE +If an error occurs while reading the variable (e.g. the variable +doesn't exist or an array element is specified for a scalar +variable), then NULL is returned and an error message is left +in \fIinterp\fR's result if the \fBTCL_LEAVE_ERR_MSG\fR \fIflag\fR +bit is set. .PP -The name of the variable may be specified to -\fBTcl_SetVar\fR and \fBTcl_SetVar2\fR in either of two ways. -If \fBTcl_SetVar\fR is called, the variable name is given as +\fBTcl_UnsetVar\fR and \fBTcl_UnsetVar2\fR may be used to remove +a variable, so that future attempts to read the variable will return +an error. +The arguments to these procedures are treated in the same way +as the arguments to the procedures above. +If the variable is successfully removed then TCL_OK is returned. +If the variable cannot be removed because it doesn't exist then +TCL_ERROR is returned and an error message is left +in \fIinterp\fR's result if the \fBTCL_LEAVE_ERR_MSG\fR \fIflag\fR +bit is set. +If an array element is specified, the given element is removed +but the array remains. +If an array name is specified without an index, then the entire +array is removed. +.PP +The name of a variable may be specified to these procedures in +four ways: +.IP [1] +If \fBTcl_SetVar\fR, \fBTcl_GetVar\fR, or \fBTcl_UnsetVar\fR +is invoked, the variable name is given as a single string, \fIvarName\fR. If \fIvarName\fR contains an open parenthesis and ends with a close parenthesis, then the value between the parentheses is @@ -100,22 +165,31 @@ the characters before the first open parenthesis are treated as the name of an array variable. If \fIvarName\fR doesn't have parentheses as described above, then the entire string is treated as the name of a scalar variable. -If \fBTcl_SetVar2\fR is called, then the array name and index -have been separated by the caller into two separate strings, -\fIname1\fR and \fIname2\fR respectively; if \fIname2\fR is -zero it means that a scalar variable is being referenced. +.IP [2] +If the \fIname1\fR and \fIname2\fR arguments are provided and +\fIname2\fR is non-NULL, then an array element is specified and +the array name and index have +already been separated by the caller: \fIname1\fR contains the +name and \fIname2\fR contains the index. +.VS 8.1 +An error is generated +if \fIname1\fR contains an open parenthesis and ends with a +close parenthesis (array element) and \fIname2\fR is non-NULL. +.IP [3] +If \fIname2\fR is NULL, \fIname1\fR is treated just like +\fIvarName\fR in case [1] above (it can be either a scalar or an array +element variable name). +.VE .PP The \fIflags\fR argument may be used to specify any of several options to the procedures. It consists of an OR-ed combination of the following bits. -Note that the flag bit TCL_PARSE_PART1 is only meaningful -for the procedures Tcl_SetVar2 and Tcl_GetVar2. .TP \fBTCL_GLOBAL_ONLY\fR -Under normal circumstances the procedures look up variables as follows: +Under normal circumstances the procedures look up variables as follows. If a procedure call is active in \fIinterp\fR, -a variable is looked up at the current level of procedure call. -Otherwise, a variable is looked up first in the current namespace, +the variable is looked up at the current level of procedure call. +Otherwise, the variable is looked up first in the current namespace, then in the global namespace. However, if this bit is set in \fIflags\fR then the variable is looked up only in the global namespace @@ -124,14 +198,10 @@ If both \fBTCL_GLOBAL_ONLY\fR and \fBTCL_NAMESPACE_ONLY\fR are given, \fBTCL_GLOBAL_ONLY\fR is ignored. .TP \fBTCL_NAMESPACE_ONLY\fR -Under normal circumstances the procedures look up variables as follows: -If a procedure call is active in \fIinterp\fR, -a variable is looked up at the current level of procedure call. -Otherwise, a variable is looked up first in the current namespace, -then in the global namespace. -However, if this bit is set in \fIflags\fR then the variable -is looked up only in the current namespace -even if there is a procedure call active. +If this bit is set in \fIflags\fR then the variable +is looked up only in the current namespace; if a procedure is active +its variables are ignored, and the global namespace is also ignored unless +it is the current namespace. .TP \fBTCL_LEAVE_ERR_MSG\fR If an error is returned and this bit is set in \fIflags\fR, then @@ -142,9 +212,10 @@ If this flag bit isn't set then no error message is left and the interpreter's result will not be modified. .TP \fBTCL_APPEND_VALUE\fR -If this bit is set then \fInewValue\fR is appended to the current -value, instead of replacing it. -If the variable is currently undefined, then this bit is ignored. +If this bit is set then \fInewValuePtr\fR or \fInewValue\fR is +appended to the current value instead of replacing it. +If the variable is currently undefined, then the bit is ignored. +This bit is only used by the \fBTcl_Set*\fR procedures. .TP \fBTCL_LIST_ELEMENT\fR If this bit is set, then \fInewValue\fR is converted to a valid @@ -153,18 +224,6 @@ A separator space is appended before the new list element unless the list element is going to be the first element in a list or sublist (i.e. the variable's current value is empty, or contains the single character ``{'', or ends in `` }''). -.TP -\fBTCL_PARSE_PART1\fR -If this bit is set when calling \fITcl_SetVar2\fR and \fITcl_GetVar2\fR, -\fIname1\fR may contain both an array and an element name: -if the name contains an open parenthesis and ends with a -close parenthesis, then the value between the parentheses is -treated as an element name (which can have any string value) and -the characters before the first open -parenthesis are treated as the name of an array variable. -If the flag TCL_PARSE_PART1 is given, -\fIname2\fR should be NULL since the array and element names -are taken from \fIname1\fR. .PP \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR return the current value of a variable. @@ -178,8 +237,6 @@ or \fBTcl_SetVar2\fR). and TCL_LEAVE_ERR_MSG, both of which have the same meaning as for \fBTcl_SetVar\fR. -In addition, \fBTcl_GetVar2\fR uses the bit TCL_PARSE_PART1, -which has the same meaning as for \fBTcl_SetVar2\fR. If an error occurs in reading the variable (e.g. the variable doesn't exist or an array element is specified for a scalar variable), then NULL is returned. @@ -198,7 +255,7 @@ If an array name is specified without an index, then the entire array is removed. .SH "SEE ALSO" -Tcl_GetObjResult, Tcl_GetStringResult, Tcl_ObjGetVar2, Tcl_ObjSetVar2, Tcl_TraceVar +Tcl_GetObjResult, Tcl_GetStringResult, Tcl_TraceVar .SH KEYWORDS -array, interpreter, object, scalar, set, unset, variable +array, get variable, interpreter, object, scalar, set, unset, variable diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 94cd142..46fe959 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -4,13 +4,13 @@ '\" 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.3 1999/03/10 05:52:45 stanton Exp $ +'\" RCS: @(#) $Id: StringObj.3,v 1.4 1999/04/16 00:46:33 stanton Exp $ '\" .so man.macros -.TH Tcl_StringObj 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NewStringObj, Tcl_SetStringObj, Tcl_GetStringFromObj, Tcl_AppendToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_SetObjLength, TclConcatObj \- manipulate Tcl objects as strings +Tcl_NewStringObj, Tcl_SetStringObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_AppendToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj \- manipulate Tcl objects as strings .SH SYNOPSIS .nf \fB#include \fR @@ -23,7 +23,14 @@ Tcl_Obj * char * \fBTcl_GetStringFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp +char * +\fBTcl_GetString\fR(\fIobjPtr\fR) +.sp \fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR) +.VS +.sp +\fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) +.VE .sp \fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *) NULL\fR) .sp @@ -34,7 +41,7 @@ char * Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS -.AS Tcl_Interp *lengthPtr out +.AS Tcl_Interp *appendObjPtr in/out .AP char *bytes in Points to the first byte of an array of bytes used to set or append to a string object. @@ -46,6 +53,10 @@ initializing, setting, or appending to a string object. If negative, all bytes up to the first null are used. .AP Tcl_Obj *objPtr in/out Points to an object to manipulate. +.VS +.AP Tcl_Obj *appendObjPtr in +The object to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. +.VE .AP int *lengthPtr out If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store the the length of an object's string representation. @@ -81,21 +92,30 @@ Both procedures set the object to hold a copy of the specified string. \fBTcl_SetStringObj\fR frees any old string representation as well as any old internal representation of the object. .PP -\fBTcl_GetStringFromObj\fR returns an object's string representation. +\fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR +return an object's string representation. This is given by the returned byte pointer -and length, which is stored in \fIlengthPtr\fR if it is non-NULL. +and (for \fBTcl_GetStringFromObj\fR) length, +which is stored in \fIlengthPtr\fR if it is non-NULL. If the object's string representation is invalid (its byte pointer is NULL), the string representation is regenerated from the object's internal representation. The storage referenced by the returned byte pointer is owned by the object manager and should not be modified by the caller. +The procedure \fBTcl_GetString\fR is used in the common case +where the caller does not need the length of the string representation. .PP \fBTcl_AppendToObj\fR appends the data given by \fIbytes\fR and \fIlength\fR to the object specified by \fIobjPtr\fR. It does this in a way that handles repeated calls relatively efficiently (it overallocates the string space to avoid repeated reallocations and copies of object's string value). +.VS +.PP +\fBTcl_AppendObjToObj\fR is similar to \fBTcl_AppendToObj\fR, but it +appends the string value of \fIappendObjPtr\fR to \fIobjPtr\fR. +.VE .PP \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR except that it can be passed more than one value to append and diff --git a/doc/Tcl.n b/doc/Tcl.n index ee71cf5..6bd8511 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -5,10 +5,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Tcl.n,v 1.2 1998/09/14 18:39:50 stanton Exp $ -' +'\" RCS: @(#) $Id: Tcl.n,v 1.3 1999/04/16 00:46:33 stanton Exp $ +'\" .so man.macros -.TH Tcl n "" Tcl "Tcl Built-In Commands" +.TH Tcl n "8.1" Tcl "Tcl Built-In Commands" .BS .SH NAME Tcl \- Summary of Tcl language syntax. @@ -111,47 +111,61 @@ special processing. The following table lists the backslash sequences that are handled specially, along with the value that replaces each sequence. .RS -.TP 6 +.TP 7 \e\fBa\fR Audible alert (bell) (0x7). -.TP 6 +.TP 7 \e\fBb\fR Backspace (0x8). -.TP 6 +.TP 7 \e\fBf\fR Form feed (0xc). -.TP 6 +.TP 7 \e\fBn\fR Newline (0xa). -.TP 6 +.TP 7 \e\fBr\fR Carriage-return (0xd). -.TP 6 +.TP 7 \e\fBt\fR Tab (0x9). -.TP 6 +.TP 7 \e\fBv\fR Vertical tab (0xb). -.TP 6 +.TP 7 \e\fB\fIwhiteSpace\fR -A single space character replaces the backslash, newline, and all -spaces and tabs after the newline. -This backslash sequence is unique in that it is replaced in a separate -pre-pass before the command is actually parsed. -This means that it will be replaced even when it occurs between -braces, and the resulting space will be treated as a word separator -if it isn't in braces or quotes. -.TP 6 +. +A single space character replaces the backslash, newline, and all spaces +and tabs after the newline. This backslash sequence is unique in that it +is replaced in a separate pre-pass before the command is actually parsed. +This means that it will be replaced even when it occurs between braces, +and the resulting space will be treated as a word separator if it isn't +in braces or quotes. +.TP 7 \e\e Backslash (``\e''). -.TP 6 -\e\fIooo\fR -The digits \fIooo\fR (one, two, or three of them) give the octal value of -the character. -.TP 6 -\e\fBx\fIhh\fR -The hexadecimal digits \fIhh\fR give the hexadecimal value of -the character. Any number of digits may be present. +.VS 8.1 br +.TP 7 +\e\fIooo\fR +. +The digits \fIooo\fR (one, two, or three of them) give an eight-bit octal +value for the Unicode character that will be inserted. The upper bits of the +Unicode character will be 0. +.TP 7 +\e\fBx\fIhh\fR +. +The hexadecimal digits \fIhh\fR give an eight-bit hexadecimal value for the +Unicode character that will be inserted. Any number of hexadecimal digits +may be present; however, all but the last two are ignored (the result is +always a one-byte quantity). The upper bits of the Unicode character will +be 0. +.TP 7 +\e\fBu\fIhhhh\fR +. +The hexadecimal digits \fIhhhh\fR (one, two, three, or four of them) give a +sixteen-bit hexadecimal value for the Unicode character that will be +inserted. +.VE .LP Backslash substitution is not performed on words enclosed in braces, except for backslash-newline as described above. diff --git a/doc/Thread.3 b/doc/Thread.3 new file mode 100644 index 0000000..595fac3 --- /dev/null +++ b/doc/Thread.3 @@ -0,0 +1,100 @@ +'\" +'\" Copyright (c) 1998 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: Thread.3,v 1.2 1999/04/16 00:46:33 stanton Exp $ +'\" +.so man.macros +.TH Tcl_ConditionNotify 3 "8.1" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock \- thread synchronization support. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +void +\fBTcl_ConditionNotify\fR(\fIcondPtr\fR) +.sp +void +\fBTcl_ConditionWait\fR(\fIcondPtr, mutexPtr, timePtr\fR) +.sp +VOID * +\fBTcl_GetThreadData\fR(\fIkeyPtr, size\fR) +.sp +void +\fBTcl_MutexLock\fR(\fImutexPtr\fR) +.sp +void +\fBTcl_MutexUnlock\fR(\fImutexPtr\fR) +.SH ARGUMENTS +.AS Tcl_ThreadDataKey *keyPtr +.AP Tcl_Condition *condPtr in +A condition variable, which must be associated with a mutex lock. +.AP Tcl_Condition *mutexPtr in +A mutex lock. +.AP Tcl_Time *timePtr in +A time limit on the condition wait. NULL to wait forever. +Note that a polling value of 0 seconds doesn't make much sense. +.AP Tcl_ThreadDataKey *keyPtr in +This identifies a block of thread local storage. The key should be +static and process-wide, yet each thread will end up associating +a different block of storage with this key. +.AP int *size in +The size of the thread local storage block. This amount of data +is allocated and initialized to zero the first time each thread +calls \fBTcl_GetThreadData\fR. +.BE + +.SH DESCRIPTION +.PP +A mutex is a lock that is used to serialize all threads through a piece +of code by calling \fBTcl_MutexLock\fR and \fBTcl_MutexUnlock\fR. +If one thread holds a mutex, any other thread calling \fBTcl_MutexLock\fR will +block until \fBTcl_MutexUnlock\fR is called. +.VS +The result of locking a mutex twice from the same thread is undefined. +On some platforms it will result in a deadlock. +.VE +\fBTcl_MutexLock\fR and \fBTcl_MutexUnlock\fR +procedures are defined as empty macros if not compiling with threads enabled. +.PP +A condition variable is used as a signaling mechanism: +a thread can lock a mutex and then wait on a condition variable +with \fBTcl_ConditionWait\fR. This atomically releases the mutex lock +and blocks the waiting thread until another thread calls +\fBTcl_ConditionNotify\fR. The caller of \fBTcl_ConditionNotify\fR should +have the associated mutex held by previously calling \fBTcl_MutexLock\fR, +but this is not enforced. Notifying the +condition variable unblocks all threads waiting on the condition variable, +but they do not proceed until the mutex is released with \fBTcl_MutexUnlock\fR. +The implementation of \fBTcl_ConditionWait\fR automatically locks +the mutex before returning. +.PP +The caller of \fBTcl_ConditionWait\fR should be prepared for spurious +notifications by calling \fBTcl_ConditionWait\fR within a while loop +that tests some invariant. +.PP +The \fBTcl_GetThreadData\fR call returns a pointer to a block of +thread-private data. Its argument is a key that is shared by all threads +and a size for the block of storage. The storage is automatically +allocated and initialized to all zeros the first time each thread asks for it. +The storage is automatically deallocated by \fBTcl_FinalizeThread\fR +.SH INITIALIZATION +.PP +.PP +All of these synchronization objects are self initializing. +They are implemented as opaque pointers that should be NULL +upon first use. +The mutexes and condition variables are +cleaned up by process exit handlers. Thread local storage is +reclaimed during \fBTcl_FinalizeThread\fR. +.SH CREATING THREADS +The API to create threads is not finalized at this time. +There are private facilities to create threads that contain a new +Tcl interpreter, and to send scripts among threads. +Dive into tclThreadTest.c and tclThread.c for examples. +.SH KEYWORDS +thread, mutex, condition variable, thread local storage diff --git a/doc/ToUpper.3 b/doc/ToUpper.3 new file mode 100644 index 0000000..639dd61 --- /dev/null +++ b/doc/ToUpper.3 @@ -0,0 +1,90 @@ +'\" +'\" Copyright (c) 1997 by 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: ToUpper.3,v 1.2 1999/04/16 00:46:33 stanton Exp $ +'\" +.so man.macros +.TH Tcl_UtfToUpper 3 "8.1" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_UniCharToUpper, Tcl_UniCharToLower, Tcl_UniCharToTitle, Tcl_UtfToUpper, Tcl_UtfToLower, Tcl_UtfToTitle \- routines for manipulating the case of Unicode characters and UTF-8 strings. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_UniChar +\fBTcl_UniCharToUpper\fR(\fIch\fR) +.sp +Tcl_UniChar +\fBTcl_UniCharToLower\fR(\fIch\fR) +.sp +Tcl_UniChar +\fBTcl_UniCharToTitle\fR(\fIch\fR) +.sp +int +\fBTcl_UtfToUpper\fR(\fIstr\fR) +.sp +int +\fBTcl_UtfToLower\fR(\fIstr\fR) +.sp +int +\fBTcl_UtfToTitle\fR(\fIstr\fR) +.SH ARGUMENTS +.AS char *str in/out +.AP int ch in +The Tcl_UniChar to be converted. +.AP char *str in/out +Pointer to UTF-8 string to be converted in place. +.BE + +.SH DESCRIPTION +.PP +The first three routines convert the case of individual Unicode characters: +.PP +If \fIch\fR represents a lower-case character, +\fBTcl_UniCharToUpper\fR returns the corresponding upper-case +character. If no upper-case character is defined, it returns the +character unchanged. +.PP +If \fIch\fR represents an upper-case character, +\fBTcl_UniCharToLower\fR returns the corresponding lower-case +character. If no lower-case character is defined, it returns the +character unchanged. +.PP +If \fIch\fR represents a lower-case character, +\fBTcl_UniCharToTitle\fR returns the corresponding title-case +character. If no title-case character is defined, it returns the +corresponding upper-case character. If no upper-case character is +defined, it returns the character unchanged. Title-case is defined +for a small number of characters that have a different appearance when +they are at the beginning of a capitalized word. +.PP +The next three routines convert the case of UTF-8 strings in place in +memory: +.PP +\fBTcl_UtfToUpper\fR changes every UTF-8 character in \fIstr\fR to +upper-case. Because changing the case of a character may change its +size, the byte offset of each character in the resulting string may +differ from its original location. \fBTcl_UtfToUpper\fR writes a null +byte at the end of the converted string. \fBTcl_UtfToUpper\fR returns +the new length of the string in bytes. This new length is guaranteed +to be no longer than the original string length. +.PP +\fBTcl_UtfToLower\fR is the same as \fBTcl_UtfToUpper\fR except it +turns each character in the string into its lower-case equivalent. +.PP +\fBTcl_UtfToTitle\fR is the same as \fBTcl_UtfToUpper\fR except it +turns the first character in the string into its title-case equivalent +and all following characters into their lower-case equivalents. + +.SH BUGS +.PP +At this time, the case conversions are only defined for the ISO8859-1 +characters. Unicode characters above 0x00ff are not modified by these +routines. + +.SH KEYWORDS +utf, unicode, toupper, tolower, totitle, case diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index ac4891d..57a3350 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -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: TraceVar.3,v 1.2 1998/09/14 18:39:50 stanton Exp $ +'\" RCS: @(#) $Id: TraceVar.3,v 1.3 1999/04/16 00:46:33 stanton Exp $ '\" .so man.macros .TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures" @@ -44,7 +44,7 @@ must be in writable memory: Tcl will make temporary modifications to it while looking up the name. .AP int flags in OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, and -TCL_TRACE_UNSETS, TCL_PARSE_PART1, and TCL_GLOBAL_ONLY. +TCL_TRACE_UNSETS, TCL_TRACE_ARRAY, and TCL_GLOBAL_ONLY. Not all flags are used by all procedures. See below for more information. .AP Tcl_VarTraceProc *proc in @@ -96,6 +96,12 @@ A variable may be unset either explicitly by an \fBunset\fR command, or implicitly when a procedure returns (its local variables are automatically unset) or when the interpreter is deleted (all variables are automatically unset). +.TP +\fBTCL_TRACE_ARRAY\fR +Invoke \fIproc\fR whenever the array command is invoked. +This gives the trace procedure a chance to update the array before +array names or array get is called. Note that this is called +before an array set, but that will trigger write traces. .PP Whenever one of the specified operations occurs on the variable, \fIproc\fR will be invoked. @@ -120,7 +126,8 @@ in the normal two-part form (see the description of \fBTcl_TraceVar2\fR below for details). \fIFlags\fR is an OR-ed combination of bits providing several pieces of information. -One of the bits TCL_TRACE_READS, TCL_TRACE_WRITES, or TCL_TRACE_UNSETS +One of the bits TCL_TRACE_READS, TCL_TRACE_WRITES, TCL_TRACE_ARRAY, +or TCL_TRACE_UNSETS will be set in \fIflags\fR to indicate which operation is being performed on the variable. The bit TCL_GLOBAL_ONLY will be set whenever the variable being @@ -175,24 +182,26 @@ The procedures \fBTcl_TraceVar2\fR, \fBTcl_UntraceVar2\fR, and except that the name of the variable consists of two parts. \fIName1\fR gives the name of a scalar variable or array, and \fIname2\fR gives the name of an element within an array. -If \fIname2\fR is NULL it means that either the variable is -a scalar or the trace is to be set on the entire array rather -than an individual element (see WHOLE-ARRAY TRACES below for -more information). -As a special case, if the flag TCL_PARSE_PART1 is specified, +.VS 8.1 +When \fIname2\fR is NULL, \fIname1\fR may contain both an array and an element name: if the name contains an open parenthesis and ends with a close parenthesis, then the value between the parentheses is treated as an element name (which can have any string value) and the characters before the first open parenthesis are treated as the name of an array variable. -If the flag TCL_PARSE_PART1 is given, -\fIname2\fR should be NULL since the array and element names -are taken from \fIname1\fR. +If \fIname2\fR is NULL and \fIname1\fR does not refer +to an array element +.VE +it means that either the variable is +a scalar or the trace is to be set on the entire array rather +than an individual element (see WHOLE-ARRAY TRACES below for +more information). + .SH "ACCESSING VARIABLES DURING TRACES" .PP -During read and write traces, the +During read, write, and array traces, the trace procedure can read, write, or unset the traced variable using \fBTcl_GetVar2\fR, \fBTcl_SetVar2\fR, and other procedures. @@ -245,6 +254,12 @@ access. If it deletes the variable then the traced access will return an empty string. .PP +When array tracing has been specified, the trace procedure +will be invoked at the beginning of the array command implementation, +before any of the operations like get, set, or names have been invoked. +The trace procedure can modify the array elements with \fBTcl_SetVar\fR +and \fBTcl_SetVar2\fR. +.PP When unset tracing has been specified, the trace procedure will be invoked whenever the variable is destroyed. The traces will be called after the variable has been @@ -343,6 +358,9 @@ to clean up and free their own internal data structures. Tcl doesn't do any error checking to prevent trace procedures from misusing the interpreter during traces with TCL_INTERP_DESTROYED set. +.PP +Array traces are not yet integrated with the Tcl "info exists" command, +nor is there Tcl-level access to array traces. .SH KEYWORDS clientData, trace, variable diff --git a/doc/Translate.3 b/doc/Translate.3 index e57d7f3..5d0d598 100644 --- a/doc/Translate.3 +++ b/doc/Translate.3 @@ -1,14 +1,14 @@ '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1994-1998 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: Translate.3,v 1.2 1998/09/14 18:39:51 stanton Exp $ +'\" RCS: @(#) $Id: Translate.3,v 1.3 1999/04/16 00:46:33 stanton Exp $ '\" .so man.macros -.TH Tcl_TranslateFileName 3 7.5 Tcl "Tcl Library Procedures" +.TH Tcl_TranslateFileName 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_TranslateFileName \- convert file name to native form and replace tilde with home directory @@ -26,7 +26,7 @@ Interpreter in which to report an error, if any. File name, which may start with a ``~''. .AP Tcl_DString *bufferPtr in/out If needed, this dynamic string is used to store the new file name. -At the time of the call it should be uninitialized or empty. The +At the time of the call it should be uninitialized or free. The caller must eventually call \fBTcl_DStringFree\fR to free up anything stored here. .BE diff --git a/doc/Utf.3 b/doc/Utf.3 new file mode 100644 index 0000000..f68a6cb --- /dev/null +++ b/doc/Utf.3 @@ -0,0 +1,160 @@ +'\" +'\" Copyright (c) 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: Utf.3,v 1.2 1999/04/16 00:46:34 stanton Exp $ +'\" +.so man.macros +.TH Utf 3 "8.1" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +typedef ... Tcl_UniChar; +.sp +int +\fBTcl_UniCharToUtf\fR(\fIch, buf\fR) +.sp +int +\fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR) +.sp +int +\fBTcl_UtfCharComplete\fR(\fIsrc, len\fR) +.sp +int +\fBTcl_NumUtfChars\fR(\fIsrc, len\fR) +.sp +char * +\fBTcl_UtfFindFirst\fR(\fIsrc, ch\fR) +.sp +char * +\fBTcl_UtfFindLast\fR(\fIsrc, ch\fR) +.sp +char * +\fBTcl_UtfNext\fR(\fIsrc\fR) +.sp +char * +\fBTcl_UtfPrev\fR(\fIsrc, start\fR) +.sp +Tcl_UniChar +\fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR) +.sp +char * +\fBTcl_UtfAtIndex\fR(\fIsrc, index\fR) +.sp +int +\fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR) +.SH ARGUMENTS +.AS "CONST char" *chPtr out +.AP char *buf out +Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most +TCL_UTF_MAX bytes are stored in the buffer. +.AP int ch in +The Tcl_UniChar to be converted or examined. +.AP Tcl_UniChar *chPtr out +Filled with the Tcl_UniChar represented by the head of the UTF-8 string. +.AP "CONST char" *src in +Pointer to a UTF-8 string. +.AP int len in +The length of the UTF-8 string in bytes (not UTF-8 characters). If +negative, all bytes up to the first null byte are used. +.AP "CONST char" *start in +Pointer to the beginning of a UTF-8 string. +.AP int index in +The index of a character (not byte) in the UTF-8 string. +.AP int *readPtr out +If non-NULL, filled with the number of bytes in the backslash sequence, +including the backslash character. +.AP char *dst out +Buffer in which the bytes represented by the backslash sequence are stored. +At most TCL_UTF_MAX bytes are stored in the buffer. +.BE + +.SH DESCRIPTION +.PP +These routines convert between UTF-8 strings and Tcl_UniChars. A +Tcl_UniChar is a Unicode character represented as an unsigned, fixed-size +quantity. A UTF-8 character is a Unicode character represented as +a varying-length sequence of up to TCL_UTF_MAX bytes. A multibyte UTF-8 +sequence consists of a lead byte followed by some number of trail bytes. +.PP +\fBTCL_UTF_MAX\fR is the maximum number of bytes that it takes to +represent one Unicode character in the UTF-8 representation. +.PP +\fBTcl_UniCharToUtf\fR stores the Tcl_UniChar \fIch\fR as a UTF-8 string +in starting at \fIbuf\fR. The return value is the number of bytes stored +in \fIbuf\fR. +.PP +\fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR +and stores it as a Tcl_UniChar in \fI*chPtr\fR. The return value is the +number of bytes read from \fIsrc\fR.. The caller must ensure that the +source buffer is long enough such that this routine does not run off the +end and dereference non-existent or random memory; if the source buffer +is known to be null terminated, this will not happen. If the input is +not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first +byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and +0x00ff and return 1. +.PP +\fBTcl_UtfCharComplete\fR returns 1 if the source UTF-8 string \fIsrc\fR +of length \fIlen\fR bytes is long enough to be decoded by +\fBTcl_UtfToUniChar\fR, or 0 otherwise. This function does not guarantee +that the UTF-8 string is properly formed. This routine is used by +procedures that are operating on a byte at a time and need to know if a +full Tcl_UniChar has been seen. +.PP +\fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It +returns the number of Tcl_UniChars that are represented by the UTF-8 string +\fIsrc\fR. The length of the source string is \fIlen\fR bytes. If the +length is negative, all bytes up to the first NULL byte are used. +.PP +\fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings. It +returns a pointer to the first occurance of the Tcl_UniChar \fIch\fR +in the NULL-terminated UTF-8 string \fIsrc\fR. The NULL terminator is +considered part of the UTF-8 string. +.PP +\fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings. It +returns a pointer to the last occurance of the Tcl_UniChar \fIch\fR +in the NULL terminated UTF-8 string \fIsrc\fR. The NULL terminator is +considered part of the UTF-8 string. +.PP +Given \fIsrc\fR, a pointer to some location in a UTF-8 string, +\fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the +string. The caller must not ask for the next character after the last +character in the string. +.PP +Given \fIsrc\fR, a pointer to some location in a UTF-8 string, +\fBTcl_UtfPrev\fR returns a pointer to the previous UTF-8 character in the +string. This function will not back up to a position before \fIstart\fR, +the start of the UTF-8 string. If \fIsrc\fR was already at \fIstart\fR, the +return value will be \fIstart\fR. +.PP +\fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the +Pascal Ord() function. It returns the Tcl_UniChar represented at the +specified character (not byte) \fIindex\fR in the UTF-8 string +\fIsrc\fR. The source string must contain at least \fIindex\fR +characters. +.PP +\fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not +byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must +contain at least \fIindex\fR characters. This is equivalent to calling +\fBTcl_UtfNext\fR \fIindex\fR times. +.PP +\fBTcl_UtfBackslash\fR is a utility procedure used by several of the Tcl +commands. It parses a backslash sequence and stores the properly formed +UTF-8 character represented by the backslash sequence in the output +buffer \fIdst\fR. At most TCL_UTF_MAX bytes are stored in the buffer. +\fBTcl_UtfBackslash\fR modifies \fI*readPtr\fR to contain the number +of bytes in the backslash sequence, including the backslash character. +The return value is the number of bytes stored in the output buffer. +.PP +See the \fBTcl\fR manual entry for information on the valid backslash +sequences. All of the sequences described in the Tcl manual entry are +supported by \fBTcl_UtfBackslash\fR. + +.SH KEYWORDS +utf, unicode, backslash diff --git a/doc/binary.n b/doc/binary.n index 871182e..8b20259 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -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: binary.n,v 1.2 1998/09/14 18:39:51 stanton Exp $ +'\" RCS: @(#) $Id: binary.n,v 1.3 1999/04/16 00:46:34 stanton Exp $ '\" .so man.macros .TH binary n 8.0 Tcl "Tcl Built-In Commands" @@ -119,7 +119,7 @@ remaining bits of the last byte will be zeros. For example, .CS \fBbinary format h3h* AB def\fR .CE -will return a string equivalent to \fB\\xba\\xed\\x0f\fR. +will return a string equivalent to \fB\\xba\\x00\\xed\\x0f\fR. .RE .IP \fBH\fR 5 This form is the same as \fBh\fR except that the digits are stored in @@ -128,7 +128,7 @@ high-to-low order within each byte. For example, .CS \fBbinary format H3H* ab DEF\fR .CE -will return a string equivalent to \fB\\xab\\xde\\xf0\fR. +will return a string equivalent to \fB\\xab\\x00\\xde\\xf0\fR. .RE .IP \fBc\fR 5 Stores one or more 8-bit integer values in the output string. If no @@ -142,10 +142,10 @@ error is generated. If the number of elements in the list is greater than \fIcount\fR, then the extra elements are ignored. For example, .RS .CS -\fBbinary format c3cc* {3 -3 128 1} 257 {2 5}\fR +\fBbinary format c3cc* {3 -3 128 1} 260 {2 5}\fR .CE will return a string equivalent to -\fB\\x03\\xfd\\x80\\x01\\x02\\x05\fR, whereas +\fB\\x03\\xfd\\x80\\x04\\x02\\x05\fR, whereas .CS \fBbinary format c {2 5}\fR .CE @@ -186,7 +186,7 @@ example, \fBbinary format i3 {3 -3 65536 1}\fR .CE will return a string equivalent to -\fB\\x03\\x00\\x00\\x00\\xfd\\xff\\xff\\xff\\x00\\x00\\x10\\x00\fR. +\fB\\x03\\x00\\x00\\x00\\xfd\\xff\\xff\\xff\\x00\\x00\\x01\\x00\fR .RE .IP \fBI\fR 5 This form is the same as \fBi\fR except that it stores one or more one @@ -197,7 +197,7 @@ For example, \fBbinary format I3 {3 -3 65536 1}\fR .CE will return a string equivalent to -\fB\\x00\\x00\\x00\\x03\\xff\\xff\\xff\\xfd\\x00\\x10\\x00\\x00\fR. +\fB\\x00\\x00\\x00\\x03\\xff\\xff\\xff\\xfd\\x00\\x01\\x00\\x00\fR .RE .IP \fBf\fR 5 This form is the same as \fBc\fR except that it stores one or more one @@ -318,7 +318,7 @@ This form is the same as \fBa\fR, except trailing blanks and nulls are stripped the scanned value before it is stored in the variable. For example, .RS .CS -\fBbinary scan "abc efghi \\000" a* var1\fR +\fBbinary scan "abc efghi \\000" A* var1\fR .CE will return \fB1\fR with \fBabc efghi\fR stored in \fBvar1\fR. .RE @@ -338,11 +338,11 @@ will return \fB2\fR with \fB11100\fR stored in \fBvar1\fR and \fB1110000110100000\fR stored in \fBvar2\fR. .RE .IP \fBB\fR 5 -This form is the same as \fBB\fR, except the bits are taken in +This form is the same as \fBb\fR, except the bits are taken in high-to-low order within each byte. For example, .RS .CS -\fBbinary scan \\x70\\x87\\x05 b5b* var1 var2\fR +\fBbinary scan \\x70\\x87\\x05 B5B* var1 var2\fR .CE will return \fB2\fR with \fB01110\fR stored in \fBvar1\fR and \fB1000011100000101\fR stored in \fBvar2\fR. @@ -365,7 +365,7 @@ will return \fB2\fR with \fB706\fR stored in \fBvar1\fR and .RE .IP \fBH\fR 5 This form is the same as \fBh\fR, except the digits are taken in -low-to-high order within each byte. For example, +high-to-low order within each byte. For example, .RS .CS \fBbinary scan \\x07\\x86\\x05 H3H* var1 var2\fR diff --git a/doc/catch.n b/doc/catch.n index 17b5c1d..23771f9 100644 --- a/doc/catch.n +++ b/doc/catch.n @@ -5,10 +5,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: catch.n,v 1.2 1998/09/14 18:39:51 stanton Exp $ +'\" RCS: @(#) $Id: catch.n,v 1.3 1999/04/16 00:46:34 stanton Exp $ '\" .so man.macros -.TH catch n "" Tcl "Tcl Built-In Commands" +.TH catch n "8.0" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -19,22 +19,52 @@ catch \- Evaluate script and trap exceptional returns .SH DESCRIPTION .PP -The \fBcatch\fR command may be used to prevent errors from aborting -command interpretation. \fBCatch\fR calls the Tcl interpreter recursively -to execute \fIscript\fR, and always returns a TCL_OK code, regardless of -any errors that might occur while executing \fIscript\fR. The return -value from \fBcatch\fR is a decimal string giving the -code returned by the Tcl interpreter after executing \fIscript\fR. -This will be \fB0\fR (TCL_OK) if there were no errors in \fIscript\fR; -otherwise -it will have a non-zero value corresponding to one of the exceptional -return codes (see tcl.h for the definitions of code values). If the -\fIvarName\fR argument is given, then it gives the name of a variable; -\fBcatch\fR will set the variable to the string returned -from \fIscript\fR (either a result or an error message). +The \fBcatch\fR command may be used to prevent errors from aborting command +interpretation. \fBCatch\fR calls the Tcl interpreter recursively to +execute \fIscript\fR, and always returns without raising an error, +regardless of any errors that might occur while executing \fIscript\fR. +.PP +If \fIscript\fR raises an error, \fBcatch\fR will return a non-zero integer +value corresponding to one of the exceptional return codes (see tcl.h +for the definitions of code values). If the \fIvarName\fR argument is +given, then the variable it names is set to the error message from +interpreting \fIscript\fR. +.PP +If \fIscript\fR does not raise an error, \fBcatch\fR will return 0 +(TCL_OK) and set the variable to the value returned from \fIscript\fR. .PP Note that \fBcatch\fR catches all exceptions, including those -generated by \fBbreak\fR and \fBcontinue\fR as well as errors. +generated by \fBbreak\fR and \fBcontinue\fR as well as errors. The +only errors that are not caught are syntax errors found when the +script is compiled. This is because the catch command only catches +errors during runtime. When the catch statement is compiled, the +script is compiled as well and any syntax errors will generate a Tcl +error. + +.SH EXAMPLES + +The \fBcatch\fR command may be used in an \fBif\fR to branch based on +the success of a script. + +.DS +.CS +if { [catch {open $someFile w} fid] } { + puts stderr "Could not open $someFile for writing\\n$fid" + exit 1 +} +.CE +.DE +The \fBcatch\fR command will not catch compiled syntax errors. The +first time proc \fBfoo\fR is called, the body will be compiled and a +Tcl error will be generated. + +.DS +.CS +proc foo {} { + catch {expr {1 +- }} +} +.CE +.DE .SH KEYWORDS catch, error diff --git a/doc/dde.n b/doc/dde.n new file mode 100644 index 0000000..c9797a6 --- /dev/null +++ b/doc/dde.n @@ -0,0 +1,124 @@ +'\" +'\" Copyright (c) 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: dde.n,v 1.2 1999/04/16 00:46:34 stanton Exp $ +'\" +.so man.macros +.TH dde n 8.1 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +dde \- Execute a Dynamic Data Exchange command +.SH SYNOPSIS +.sp +\fBpackage require dde 1.0\fR +.sp +\fBdde \fIservername \fR?\fItopic\fR? +.sp +\fBdde ?\-async?\fR \fIcommand service topic \fR?\fIdata\fR? +.BE + +.SH DESCRIPTION +.PP +This command allows an application to send Dynamic Data Exchange (DDE) +command when running under Microsoft Windows. Dynamic Data Exchange is +a mechanism where applications can exchange raw data. Each DDE +transaction needs a \fIservice name\fR and a \fItopic\fR. Both the +\fIservice name\fR and \fItopic\fR are application defined; Tcl uses +the service name \fBTclEval\fR, while the topic name is the name of the +interpreter given by \fBdde servername\fR. Other applications have their +own \fIservice names\fR and \fItopics\fR. For instance, Microsoft Excel +has the service name \fBExcel\fR. +.PP +The only option to the \fBdde\fR command is: +.TP +\fB\-async\fR +Requests asynchronous invocation. This is valid only for the +\fBexecute\fR subcommand. Normally, the \fBdde execute\fR subcommand +waits until the command completes, returning appropriate error +messages. When the \fB\-async\fR option is used, the command returns +immediately, and no error information is available. +.SH "DDE COMMANDS" +.PP +The following commands are a subset of the full Dynamic Data Exchange +set of commands. +.TP +\fBdde servername \fR?\fItopic\fR? +\fBdde servername\fR registers the interpreter as a DDE server with +the service name TclEval and the topic name specified byt \fItopic\fR. +If no \fItopic\fR is given, \fBdde servername\fR returns the name +of the current topic or the empty string if it is not registered as a service. +.TP +\fBdde execute \fIservice topic data\fR +\fBdde execute\fR takes the \fIdata\fR and sends it to the server +indicated by \fIservice\fR with the topic indicated by +\fItopic\fR. Typically, \fIservice\fR is the name of an application, +and \fItopic\fR is a file to work on. The \fIdata\fR field is given +to the remote application. Typically, the application treats the +\fIdata\fR field as a script, and the script is run in the +application. The command returns an error if the script did not +run. If the \fB\-async\fR flag was used, the command +returns immediately with no error. +.TP +\fBdde request \fIservice topic item\fR +\fBdde request\fR is typically used to get the value of something; the +value of a cell in Microsoft Excel or the text of a selection in +Microsoft Word. \fIservice\fR is typically the name of an application, +\fItopic\fR is typically the name of the file, and \fIitem\fR is +application-specific. The command returns the value of \fIitem\fR as +defined in the application. +.TP +\fBdde services \fIservice topic\fR +\fBdde services\fR returns a list of service-topic pairs that +currently exist on the machine. If \fIservice\fR and \fItopic\fR are +both null strings ({}), then all service-topic pairs currently +available on the system are returned. If \fIservice\fR is null and +\fItopic\fR is not, then all services with the specified topic are +returned. If \fIservice\fR is not null and \fItopic\fR is, all topics +for a given service are returned. If both are not null, if that +service-topic pair currently exists, it is returned; otherwise, null +is returned. +.TP +\fBdde eval \fItopic cmd \fR?\fIarg arg ...\fR? +\fBdde eval\fR evaluates a command and its arguments using the +interpreter specified by \fItopic\fR. The DDE service must be the +"TclEval" service. This command can be used to replace send on Windows. +.SH "DDE AND TCL" +A Tcl interpreter always has a service name of "TclEval". Each +different interp of all running Tcl applications should a unique +name specified by \fBdde servername\fR. Each interp is available as a +DDE topic only if the \fBdde servername\fR command was used to set the +name of the topic for each interp. So a \fBdde services TclEval {}\fR +command will return a list of service-topic pairs, where each of the +currently running interps will be a topic. +.PP +When Tcl processes a \fBdde execute\fR command, the data for the +execute is run as a script in the interp named by the topic of the +\fBdde execute\fR command. +.PP +When Tcl processes a \fBdde request\fR command, it returns the value of +the variable given in the dde command in the context of the interp +named by the dde topic. Tcl reserves the variable "$TCLEVAL$EXECUTE$RESULT" +for internal use, and \fBdde request\fR commands for that variable +will give unpredictable results. +.PP +An external application which wishes to run a script in Tcl should have +that script store its result in a variable, run the \fBdde execute\fR +command, and the run \fBdde request\fR to get the value of the +variable. +.PP +When using DDE, be careful to ensure that the event queue is flushed +using either \fBupdate\fR or \fBvwait\fR. This happens by default +when using \fBwish\fR unless a blocking command is called (such as \fBexec\fR +without adding the \fB&\fR to place the process in the background). +If for any reason the event queue is not flushed, DDE commands may +hang until the event queue is flushed. This can create a deadlock +situation. +.SH KEYWORDS +application, dde, name, remote execution +.SH "SEE ALSO" +tk, winfo, send + diff --git a/doc/encoding.n b/doc/encoding.n new file mode 100644 index 0000000..fc6d4f7 --- /dev/null +++ b/doc/encoding.n @@ -0,0 +1,79 @@ +'\" +'\" Copyright (c) 1998 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: encoding.n,v 1.2 1999/04/16 00:46:34 stanton Exp $ +'\" +.so man.macros +.TH encoding n "8.1" Tcl "Tcl Built-In Commands" +.BS +.SH NAME +encoding \- Manipulate encodings +.SH SYNOPSIS +\fBencoding \fIoption\fR ?\fIarg arg ...\fR? +.BE + +.SH INTRODUCTION +.PP +Strings in Tcl are encoded using 16-bit Unicode characters. Different +operating system interfaces or applications may generate strings in +other encodings such as Shift-JIS. The \fBencoding\fR command helps +to bridge the gap between Unicode and these other formats. + +.SH DESCRIPTION +.PP +Performs one of several encoding related operations, depending on +\fIoption\fR. The legal \fIoption\fRs are: +.TP +\fBencoding convertfrom ?\fIencoding\fR? \fIdata\fR +Convert \fIdata\fR to Unicode from the specified \fIencoding\fR. The +characters in \fIdata\fR are treated as binary data where the lower +8-bits of each character is taken as a single byte. The resulting +sequence of bytes is treated as a string in the specified +\fIencoding\fR. If \fIencoding\fR is not specified, the current +system encoding is used. +.TP +\fBencoding convertto ?\fIencoding\fR? \fIstring\fR +Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. +The result is a sequence of bytes that represents the converted +string. Each byte is stored in the lower 8-bits of a Unicode +character. If \fIencoding\fR is not specified, the current +system encoding is used. +.TP +\fBencoding names\fR +Returns a list containing the names of all of the encodings that are +currently available. +.TP +\fBencoding system\fR ?\fIencoding\fR? +Set the system encoding to \fIencoding\fR. If \fIencoding\fR is +omitted then the command returns the current system encoding. The +system encoding is used whenever Tcl passes strings to system calls. + +.SH EXAMPLE +.PP +It is common practice to write script files using a text editor that +produces output in the euc-jp encoding, which represents the ASCII +characters as singe bytes and Japanese characters as two bytes. This +makes it easy to embed literal strings that correspond to non-ASCII +characters by simply typing the strings in place in the script. +However, because the \fBsource\fR command always reads files using the +ISO8859-1 encoding, Tcl will treat each byte in the file as a separate +character that maps to the 00 page in Unicode. The +resulting Tcl strings will not contain the expected Japanese +characters. Instead, they will contain a sequence of Latin-1 +characters that correspond to the bytes of the original string. The +\fBencoding\fR command can be used to convert this string to the +expected Japanese Unicode characters. For example, +.CS + set s [encoding convertfrom euc-jp "\\xA4\\xCF"] +.CE +would return the Unicode string "\\u306F", which is the Hiragana +letter HA. + +.SH "SEE ALSO" +Tcl_GetEncoding + +.SH KEYWORDS +encoding diff --git a/doc/exec.n b/doc/exec.n index 0d6db95..f30f6b0 100644 --- a/doc/exec.n +++ b/doc/exec.n @@ -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: exec.n,v 1.2 1998/09/14 18:39:52 stanton Exp $ +'\" RCS: @(#) $Id: exec.n,v 1.3 1999/04/16 00:46:34 stanton Exp $ '\" .so man.macros .TH exec n 7.6 Tcl "Tcl Built-In Commands" @@ -202,10 +202,11 @@ instead of ``applbakery.default''). Two or more forward or backward slashes in a row in a path refer to a network path. For example, a simple concatenation of the root directory \fBc:/\fR with a subdirectory \fB/windows/system\fR will yield -\fBc://windows/system\fR (two slashes together), which refers to the -directory \fB/system\fR on the machine \fBwindows\fR (and the \fBc:/\fR is -ignored), and is not equivalent to \fBc:/windows/system\fR, which describes -a directory on the current computer. +\fBc://windows/system\fR (two slashes together), which refers to the mount +point called \fBsystem\fR on the machine called \fBwindows\fR (and the +\fBc:/\fR is ignored), and is not equivalent to \fBc:/windows/system\fR, +which describes a directory on the current computer. The \fBfile join\fR +command should be used to concatenate path components. .TP \fBWindows NT\fR . @@ -264,7 +265,7 @@ the caller must prepend ``\fBcommand.com /c\0\fR'' to the desired command. Once a 16-bit DOS application has read standard input from a console and then quit, all subsequently run 16-bit DOS applications will see the standard input as already closed. 32-bit applications do not have this -problem and will run correctly even after a 16-bit DOS application thinks +problem and will run correctly, even after a 16-bit DOS application thinks that standard input is closed. There is no known workaround for this bug at this time. .sp @@ -282,8 +283,8 @@ other end of the pipe must be closed before the 16-bit DOS application begins executing. All standard output or error from a 16-bit DOS application to a pipe is collected into temporary files; the application must terminate before the temporary files are redirected to the next stage -of the pipeline. This is due to a workaround for a Windows 95 bug in the -implementation of pipes, and is how the Windows 95 command line interpreter +of the pipeline. This is due to a workaround for a Windows 95 bug in the +implementation of pipes, and is how the standard Windows 95 DOS shell handles pipes itself. .sp Certain applications, such as \fBcommand.com\fR, should not be executed diff --git a/doc/fconfigure.n b/doc/fconfigure.n index 720b206..e2479e8a 100644 --- a/doc/fconfigure.n +++ b/doc/fconfigure.n @@ -4,10 +4,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: fconfigure.n,v 1.2 1998/09/14 18:39:52 stanton Exp $ +'\" RCS: @(#) $Id: fconfigure.n,v 1.3 1999/04/16 00:46:34 stanton Exp $ '\" .so man.macros -.TH fconfigure n 7.5 Tcl "Tcl Built-In Commands" +.TH fconfigure n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -51,122 +51,143 @@ using the Tcl event loop (e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR command). .TP \fB\-buffering\fR \fInewValue\fR +. If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output until its internal buffer is full or until the \fBflush\fR command is invoked. If \fInewValue\fR is \fBline\fR, then the I/O system will automatically flush output for the channel whenever a newline character is output. If \fInewValue\fR is \fBnone\fR, the I/O system will flush -automatically after every output operation. -The default is for \fB\-buffering\fR to be set to \fBfull\fR except for -channels that connect to terminal-like devices; for these channels the -initial setting is \fBline\fR. +automatically after every output operation. The default is for +\fB\-buffering\fR to be set to \fBfull\fR except for channels that +connect to terminal-like devices; for these channels the initial setting +is \fBline\fR. .TP \fB\-buffersize\fR \fInewSize\fR +. \fINewvalue\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store input or output. \fINewvalue\fR must be between ten and one million, allowing buffers of ten to one million bytes in size. +.VS 8.1 br +.TP +\fB\-encoding\fR \fIname\fR +. +This option is used to specify the encoding of the channel, so that the data +can be converted to and from Unicode for use in Tcl. For instance, in +order for Tcl to read characters from a Japanese file in \fBshiftjis\fR +and properly process and display the contents, the encoding would be set +to \fBshiftjis\fR. Thereafter, when reading from the channel, the bytes in +the Japanese file would be converted to Unicode as they are read. +Writing is also supported \- as Tcl strings are written to the channel they +will automatically be converted to the specified encoding on output. +.RS +.PP +If a file contains pure binary data (for instance, a JPEG image), the +encoding for the channel should be configured to be \fBbinary\fR. Tcl +will then assign no interpretation to the data in the file and simply read or +write raw bytes. The Tcl \fBbinary\fR command can be used to manipulate this +byte-oriented data. +.PP +The default encoding for newly opened channels is the same platform- and +locale-dependent system encoding used for interfacing with the operating +system. +.RE +.VE .TP \fB\-eofchar\fR \fIchar\fR .TP \fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR -This option supports DOS file systems that use Control-z (\ex1a) as -an end of file marker. -If \fIchar\fR is not an empty string, then this character signals -end of file when it is encountered during input. -For output, the end of file character is output when -the channel is closed. -If \fIchar\fR is the empty string, then there is no special -end of file character marker. -For read-write channels, a two-element list specifies -the end of file marker for input and output, respectively. -As a convenience, when setting the end-of-file character -for a read-write channel -you can specify a single value that will apply to both reading and writing. -When querying the end-of-file character of a read-write channel, -a two-element list will always be returned. -The default value for \fB\-eofchar\fR is the empty string in all -cases except for files under Windows. In that case the \fB\-eofchar\fR -is Control-z (\ex1a) for reading and the empty string for writing. +. +This option supports DOS file systems that use Control-z (\ex1a) as an +end of file marker. If \fIchar\fR is not an empty string, then this +character signals end-of-file when it is encountered during input. For +output, the end-of-file character is output when the channel is closed. +If \fIchar\fR is the empty string, then there is no special end of file +character marker. For read-write channels, a two-element list specifies +the end of file marker for input and output, respectively. As a +convenience, when setting the end-of-file character for a read-write +channel you can specify a single value that will apply to both reading +and writing. When querying the end-of-file character of a read-write +channel, a two-element list will always be returned. The default value +for \fB\-eofchar\fR is the empty string in all cases except for files +under Windows. In that case the \fB\-eofchar\fR is Control-z (\ex1a) for +reading and the empty string for writing. .TP \fB\-translation\fR \fImode\fR .TP -\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR -In Tcl scripts the end of a line is always represented using a -single newline character (\en). -However, in actual files and devices the end of a line may be -represented differently on different platforms, or even for -different devices on the same platform. For example, under UNIX -newlines are used in files, whereas carriage-return-linefeed -sequences are normally used in network connections. -On input (i.e., with \fBgets\fP and \fBread\fP) -the Tcl I/O system automatically translates the external end-of-line -representation into newline characters. -Upon output (i.e., with \fBputs\fP), -the I/O system translates newlines to the external -end-of-line representation. -The default translation mode, \fBauto\fP, handles all the common -cases automatically, but the \fB\-translation\fR option provides -explicit control over the end of line translations. +\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR +. +In Tcl scripts the end of a line is always represented using a single +newline character (\en). However, in actual files and devices the end of +a line may be represented differently on different platforms, or even for +different devices on the same platform. For example, under UNIX newlines +are used in files, whereas carriage-return-linefeed sequences are +normally used in network connections. On input (i.e., with \fBgets\fP +and \fBread\fP) the Tcl I/O system automatically translates the external +end-of-line representation into newline characters. Upon output (i.e., +with \fBputs\fP), the I/O system translates newlines to the external +end-of-line representation. The default translation mode, \fBauto\fP, +handles all the common cases automatically, but the \fB\-translation\fR +option provides explicit control over the end of line translations. .RS .PP The value associated with \fB\-translation\fR is a single item for -read-only and write-only channels. -The value is a two-element list for read-write channels; -the read translation mode is the first element of the list, -and the write translation mode is the second element. -As a convenience, when setting the translation mode for a read-write channel -you can specify a single value that will apply to both reading and writing. -When querying the translation mode of a read-write channel, -a two-element list will always be returned. -The following values are currently supported: +read-only and write-only channels. The value is a two-element list for +read-write channels; the read translation mode is the first element of +the list, and the write translation mode is the second element. As a +convenience, when setting the translation mode for a read-write channel +you can specify a single value that will apply to both reading and +writing. When querying the translation mode of a read-write channel, a +two-element list will always be returned. The following values are +currently supported: .TP \fBauto\fR -As the input translation mode, \fBauto\fR treats any of newline (\fBlf\fP), -carriage return (\fBcr\fP), or carriage return followed by a newline (\fBcrlf\fP) -as the end of line representation. The end of line representation can -even change from line-to-line, and all cases are translated to a newline. -As the output translation mode, \fBauto\fR chooses a platform specific -representation; for sockets on all platforms Tcl -chooses \fBcrlf\fR, for all Unix flavors, it chooses \fBlf\fR, for the +. +As the input translation mode, \fBauto\fR treats any of newline +(\fBlf\fP), carriage return (\fBcr\fP), or carriage return followed by a +newline (\fBcrlf\fP) as the end of line representation. The end of line +representation can even change from line-to-line, and all cases are +translated to a newline. As the output translation mode, \fBauto\fR +chooses a platform specific representation; for sockets on all platforms +Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses \fBlf\fR, for the Macintosh platform it chooses \fBcr\fR and for the various flavors of -Windows it chooses \fBcrlf\fR. -The default setting for \fB\-translation\fR is \fBauto\fR for both -input and output. +Windows it chooses \fBcrlf\fR. The default setting for +\fB\-translation\fR is \fBauto\fR for both input and output. +.VS 8.1 br .TP -\fBbinary\fR +\fBbinary\fR +. No end-of-line translations are performed. This is nearly identical to \fBlf\fP mode, except that in addition \fBbinary\fP mode also sets the -end of file character to the empty string, which disables it. -See the description of -\fB\-eofchar\fP for more information. +end-of-file character to the empty string (which disables it) and sets the +encoding to \fBbinary\fR (which disables encoding filtering). See the +description of \fB\-eofchar\fR and \fB\-encoding\fR for more information. +.VE .TP \fBcr\fR -The end of a line in the underlying file or device is represented -by a single carriage return character. -As the input translation mode, \fBcr\fP mode converts carriage returns -to newline characters. -As the output translation mode, \fBcr\fP mode -translates newline characters to carriage returns. -This mode is typically used on Macintosh platforms. +. +The end of a line in the underlying file or device is represented by a +single carriage return character. As the input translation mode, +\fBcr\fP mode converts carriage returns to newline characters. As the +output translation mode, \fBcr\fP mode translates newline characters to +carriage returns. This mode is typically used on Macintosh platforms. .TP \fBcrlf\fR -The end of a line in the underlying file or device is represented -by a carriage return character followed by a linefeed character. -As the input translation mode, \fBcrlf\fP mode converts -carriage-return-linefeed sequences -to newline characters. -As the output translation mode, \fBcrlf\fP mode -translates newline characters to -carriage-return-linefeed sequences. -This mode is typically used on Windows platforms and for network -connections. +. +The end of a line in the underlying file or device is represented by a +carriage return character followed by a linefeed character. As the input +translation mode, \fBcrlf\fP mode converts carriage-return-linefeed +sequences to newline characters. As the output translation mode, +\fBcrlf\fP mode translates newline characters to carriage-return-linefeed +sequences. This mode is typically used on Windows platforms and for +network connections. .TP \fBlf\fR -The end of a line in the underlying file or device is represented -by a single newline (linefeed) character. -In this mode no translations occur during either input or output. -This mode is typically used on UNIX platforms. +. +The end of a line in the underlying file or device is represented by a +single newline (linefeed) character. In this mode no translations occur +during either input or output. This mode is typically used on UNIX +platforms. .RE .PP @@ -175,4 +196,5 @@ close(n), flush(n), gets(n), puts(n), read(n), socket(n) .SH KEYWORDS blocking, buffering, carriage return, end of line, flushing, linemode, -newline, nonblocking, platform, translation +newline, nonblocking, platform, translation, encoding, filter, byte array, +binary diff --git a/doc/format.n b/doc/format.n index 8161ee6..9f737e0 100644 --- a/doc/format.n +++ b/doc/format.n @@ -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: format.n,v 1.2 1998/09/14 18:39:52 stanton Exp $ +'\" RCS: @(#) $Id: format.n,v 1.3 1999/04/16 00:46:34 stanton Exp $ '\" .so man.macros .TH format n "" Tcl "Tcl Built-In Commands" @@ -154,9 +154,11 @@ Convert integer to unsigned octal string. \fBx\fR or \fBX\fR Convert integer to unsigned hexadecimal string, using digits ``0123456789abcdef'' for \fBx\fR and ``0123456789ABCDEF'' for \fBX\fR). +.VS .TP 10 \fBc\fR -Convert integer to the 8-bit character it represents. +Convert integer to the Unicode character it represents. +.VE .TP 10 \fBs\fR No conversion; just insert string. diff --git a/doc/glob.n b/doc/glob.n index 3bddcc8..47c4e50 100644 --- a/doc/glob.n +++ b/doc/glob.n @@ -5,10 +5,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: glob.n,v 1.2 1998/09/14 18:39:52 stanton Exp $ +'\" RCS: @(#) $Id: glob.n,v 1.3 1999/04/16 00:46:35 stanton Exp $ '\" .so man.macros -.TH glob n 7.5 Tcl "Tcl Built-In Commands" +.TH glob n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -76,9 +76,18 @@ contains a ?, *, or [] construct. Unlike other Tcl commands that will accept both network and native style names (see the \fBfilename\fR manual entry for details on how native and network names are specified), the \fBglob\fR command only -accepts native names. Also, for Windows UNC names, the servername and -sharename components of the path may not contain ?, *, or [] -constructs. +accepts native names. +.VS 8.1 +.TP +\fBWindows\fR +. +For Windows UNC names, the servername and sharename components of the path +may not contain ?, *, or [] constructs. On Windows NT, if \fIpattern\fR is +of the form ``\fB~\fIusername\fB@\fIdomain\fR'' it refers to the home +directory of the user whose account information resides on the specified NT +domain server. Otherwise, user account information is obtained from +the local computer. +.VE .SH KEYWORDS exist, file, glob, pattern diff --git a/doc/http.n b/doc/http.n index 79ff5e9..7fd61ce 100644 --- a/doc/http.n +++ b/doc/http.n @@ -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: http.n,v 1.2 1998/09/14 18:39:53 stanton Exp $ +'\" RCS: @(#) $Id: http.n,v 1.3 1999/04/16 00:46:35 stanton Exp $ '\" .so man.macros .TH "Http" n 8.0 Tcl "Tcl Built-In Commands" @@ -250,7 +250,9 @@ Use this construct to create an easy-to-use array variable: .CS upvar #0 $token state .CE -The following elements of the array are supported: +Once the data associated with the url is no longer needed, the state +array should be unset to free up storage. The following elements of +the array are supported: .RS .TP \fBbody\fR diff --git a/doc/library.n b/doc/library.n index a760c04..eb20351 100644 --- a/doc/library.n +++ b/doc/library.n @@ -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.5 1998/10/30 23:02:02 welch Exp $ +'\" RCS: @(#) $Id: library.n,v 1.6 1999/04/16 00:46:35 stanton Exp $ .so man.macros .TH library n "8.0" Tcl "Tcl Built-In Commands" .BS @@ -60,16 +60,18 @@ the auto-load mechanism defined below. The following procedures are provided in the Tcl library: .TP \fBauto_execok \fIcmd\fR -Determines whether there is an executable file by the name \fIcmd\fR. -This command examines the directories in the current search path -(given by the PATH environment variable) to see if there is an -executable file named \fIcmd\fR in any of those directories. -If so, it returns 1; if not it returns 0. \fBAuto_exec\fR -remembers information about previous searches in an array -named \fBauto_execs\fR; this avoids the path search in -future calls for the same \fIcmd\fR. The command \fBauto_reset\fR -may be used to force \fBauto_execok\fR to forget its cached -information. +Determines whether there is an executable file or shell builtin +by the name \fIcmd\fR. If so, it returns a list of arguments to be +passed to \fBexec\fR to execute the executable file or shell builtin +named by \fIcmd\fR. If not, it returns an empty string. This command +examines the directories in the current search path (given by the PATH +environment variable) in its search for an executable file named +\fIcmd\fR. On Windows platforms, the search is expanded with the same +directories and file extensions as used by \fBexec\fR. \fBAuto_exec\fR +remembers information about previous searches in an array named +\fBauto_execs\fR; this avoids the path search in future calls for the +same \fIcmd\fR. The command \fBauto_reset\fR may be used to force +\fBauto_execok\fR to forget its cached information. .TP \fBauto_load \fIcmd\fR This command attempts to load the definition for a Tcl command named diff --git a/doc/man.macros b/doc/man.macros index 86525bd..bdf69ff 100644 --- a/doc/man.macros +++ b/doc/man.macros @@ -59,7 +59,7 @@ '\" .UL arg1 arg2 '\" Print arg1 underlined, then print arg2 normally. '\" -'\" RCS: @(#) $Id: man.macros,v 1.2 1998/09/14 18:39:54 stanton Exp $ +'\" RCS: @(#) $Id: man.macros,v 1.3 1999/04/16 00:46:35 stanton Exp $ '\" '\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. .if t .wh -1.3i ^B @@ -72,8 +72,8 @@ . ie !"\\$2"" .TP \\n()Cu . el .TP 15 .\} -.ie !"\\$3"" \{\ .ta \\n()Au \\n()Bu +.ie !"\\$3"" \{\ \&\\$1 \\fI\\$2\\fP (\\$3) .\".b .\} diff --git a/doc/msgcat.n b/doc/msgcat.n new file mode 100644 index 0000000..e04d2a6 --- /dev/null +++ b/doc/msgcat.n @@ -0,0 +1,207 @@ +'\" +'\" Copyright (c) 1998 Mark Harrison. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) msgcat.n +'\" +.so man.macros +.TH "msgcat" n 8.1 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +msgcat \- Tcl message catalog +.SH SYNOPSIS +\fB::msgcat::mc src-string\fR +.sp +\fB::msgcat::mclocale \fR?\fInewLocale\fR? +.sp +\fB::msgcat::mcpreferences\fR +.sp +\fB::msgcat::mcload \fIdirname\fR +.sp +\fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? +.sp +\fB::msgcat::mcunknown \fIlocale src-string\fR +.BE + +.SH DESCRIPTION +.PP +The \fBmsgcat\fR package provides a set of functions +that can be used to manage multi-lingual user interfaces. +Text strings are defined in a ``message catalog'' which +is independent from the application, and +which can be edited or localized without modifying +the application source code. New languages +or locales are provided by adding a new file to +the message catalog. +.PP +Use of the message catalog is optional by any application +or package, but is encouraged if the application or package +wishes to be enabled for multi-lingual applications. + +.SH COMMANDS +.TP +\fB::msgcat::mc src-string\fR +Returns a translation of \fIsrc-string\fR according to the +user's current locale. If no translation string +exists, \fB::msgcat::mcunknown\fR is called and the string +returned from \fB::msgcat::mcunknown\fR is returned. +.PP +\fB::msgcat::mc\fR is the main function used to localize an +application. Instead of using an English string directly, an +applicaton can pass the English string through \fB::msgcat::mc\fR and +use the result. If an application is written for a single language in +this fashion, then it is easy to add support for additional languages +later simply by defining new message catalog entries. +.TP +\fB::msgcat::mclocale \fR?\fInewLocale\fR? +This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR +is omitted, the current locale is returned, otherwise the new locale +is returned. The initial locale defaults to the locale specified in +the user's environment. See \fBLOCALE AND SUBLOCALE SPECIFICATION\fR +below for a description of the locale string format. +.TP +\fB::msgcat::mcpreferences\fR +Returns an ordered list of the locales preferred by +the user, based on the user's language specification. +The list is ordered from most specific to least +preference. If the user has specified LANG=en_US_funky, +this procedure would return {en_US_funky en_US en}. +.TP +\fB::msgcat::mcload \fIdirname\fR +Searches the specified directory for files that match +the language specifications returned by \fB::msgcat::mcpreferences\fR. +Each file located is sourced. The file extension is ``.msg''. +The number of message files which matched the specification +and were loaded is returned. +.TP +\fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? +Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR +in the specified \fIlocale\fR. If \fItranslate-string\fR is not +specified, \fIsrc-string\fR is used for both. The function +return \fItranslate-string\fR. +.TP +\fB::msgcat::mcunknown \fIlocale src-string\fR +This routine is called by \fB::msgcat::mc\fR in the case when +a translation for \fIsrc-string\fR is not defined in the +current locale. The default action is to return +\fIsrc-string\fR. This procedure can be redefined by the +application, for example to log error messages for each unknown +string. The \fB::msgcat::mcunknown\fB procedure is invoked at the +same stack context as the call to \fB::msgcat::mc\fR. The return vaue +of \fB::msgcat::mcunknown\fB is used as the return vaue for the call +to \fB::msgcat::mc\fR. + +.SH "LOCALE AND SUBLOCALE SPECIFICATION" +.PP +The locale is specified by a locale string. +The locale string consists of +a language code, an optional country code, and an optional +system-specific code, each separated by ``_''. The country and language +codes are specified in standards ISO-639 and ISO-3166. +For example, the locale ``en'' specifies English and + ``en_US'' specifes U.S. English. +.PP +The locale defaults to the value in \fBenv(LANG)\fR at the time the +\fBmsgcat\fR package is loaded. If \fBenv(LANG)\fR is not defined, then the +locale defaults to ``C''. +.PP +When a locale is specified by the user, a ``best match'' search is +performed during string translation. For example, if a user specifies +en_UK_Funky, the locales ``en_UK_Funky'', ``en_UK'', and ``en'' are +searched in order until a matching translation string is found. If no +translation string is available, then \fB::msgcat::unknown\fR is +called. + +.SH "NAMESPACES AND MESSAGE CATALOGS" +.PP +Strings stored in the message catalog are stored relative +to the namespace from which they were added. This allows +multiple packages to use the same strings without fear +of collisions with other packages. It also allows the +source string to be shorter and less prone to typographical +error. +.PP +For example, executing the code +.CS +mcset en hello "hello from ::" +namespace eval foo {mcset en hello "hello from ::foo"} +puts [mc hello] +namespace eval foo {puts [mc hello]} +.CE +will print +.CS +hello from :: +hello from ::foo +.CE + +.SH "LOCATION AND FORMAT OF MESSAGE FILES" +.PP +Message files can be located in any directory, subject +to the following conditions: +.IP [1] +All message files for a package are in the same directory. +.IP [2] +The message file name is a locale specifier followed +by ``.msg''. For example: +.CS +es.msg -- spanish +en_UK.msg -- UK English +.CE +.IP [3] +The file contains a series of calls to mcset, setting the +necessary translation strings for the language. For example: +.CS +::msgcat::mcset es "Free Beer!" "Cerveza Gracias!" +.CE + +.SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES" +.PP +If a package is installed into a subdirectory of the +\fBtcl_pkgPath\fR and loaded via \fBpackage require\fR, the +following procedure is recommended. +.IP [1] +During package installation, create a subdirectory +\fBmsgs\fR under your package directory. +.IP [2] +Copy your *.msg files into that directory. +.IP [3] + Add the following command to your package +initialization script: +.CS +# load language files, stored in msgs subdirectory +::msgcat::mcload [file join [file dirname [info script]] msgs] +.CE + +.SH "POSTITIONAL CODES FOR FORMAT AND SCAN COMMANDS" +.PP +It is possible that a message string used as an argument +to \fBformat\fR might have positionally dependent parameters that +might need to be repositioned. For example, it might be +syntactically desirable to rearrange the sentence structure +while translating. +.CS +format "We produced %d units in location %s" $num $city +format "In location %s we produced %d units" $city $num +.CE +.PP +This can be handled by using the positional +parameters: +.CS +format "We produced %1\\\\$d units in location %2\\\\$s" $num $city +format "In location %2\\\\$s we produced %1\\\\$d units" $num $city +.CE +.PP +Similarly, positional parameters can be used with \fBscan\fR to +extract values from internationalized strings. + +.SH "SEE ALSO" +format(n), scan(n), namespace(n), package(n) + +.SH CREDITS +.PP +The message catalog code was developed by Mark Harrison. +.SH KEYWORDS +internationalization, i18n, localization, l10n, message, text, translation diff --git a/doc/namespace.n b/doc/namespace.n index a8b6b16..eeb45f5 100644 --- a/doc/namespace.n +++ b/doc/namespace.n @@ -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: namespace.n,v 1.2 1998/09/14 18:39:54 stanton Exp $ +'\" RCS: @(#) $Id: namespace.n,v 1.3 1999/04/16 00:46:35 stanton Exp $ '\" .so man.macros .TH namespace n 8.0 Tcl "Tcl Built-In Commands" @@ -245,21 +245,21 @@ The \fBnamespace eval\fR command lets you create new namespaces. For example, .CS \fBnamespace eval Counter { - namespace export Bump + namespace export bump variable num 0 - proc Bump {} { + proc bump {} { variable num incr num } }\fR .CE creates a new namespace containing the variable \fBnum\fR and -the procedure \fBBump\fR. +the procedure \fBbump\fR. The commands and variables in this namespace are separate from other commands and variables in the same program. -If there is a command named \fBBump\fR in the global namespace, -for example, it will be different from the command \fBBump\fR +If there is a command named \fBbump\fR in the global namespace, +for example, it will be different from the command \fBbump\fR in the \fBCounter\fR namespace. .PP Namespace variables resemble global variables in Tcl. @@ -276,7 +276,7 @@ as the namespace definition shown above: .CS \fBnamespace eval Counter { variable num 0 - proc Bump {} { + proc bump {} { variable num return [incr num] } @@ -322,7 +322,7 @@ Names must be qualified by the namespace that contains them. From the global namespace, we might access the \fBCounter\fR procedures like this: .CS -\fBCounter::Bump 5 +\fBCounter::bump 5 Counter::Reset\fR .CE We could access the current count like this: @@ -332,10 +332,10 @@ We could access the current count like this: When one namespace contains another, you may need more than one qualifier to reach its elements. If we had a namespace \fBFoo\fR that contained the namespace \fBCounter\fR, -you could invoke its \fBBump\fR procedure +you could invoke its \fBbump\fR procedure from the global namespace like this: .CS -\fBFoo::Counter::Bump 3\fR +\fBFoo::Counter::bump 3\fR .CE .PP You can also use qualified names when you create and rename commands. @@ -517,36 +517,36 @@ the command is automatically removed from all namespaces that import it. You can export commands from a namespace like this: .CS \fBnamespace eval Counter { - namespace export Bump Reset - variable num 0 - variable max 100 + namespace export bump reset + variable Num 0 + variable Max 100 - proc Bump {{by 1}} { - variable num - incr num $by - check - return $num + proc bump {{by 1}} { + variable Num + incr Num $by + Check + return $Num } - proc Reset {} { - variable num - set num 0 + proc reset {} { + variable Num + set Num 0 } - proc check {} { - variable num - variable max - if {$num > $max} { + proc Check {} { + variable Num + variable Max + if {$Num > $Max} { error "too high!" } } }\fR .CE -The procedures \fBBump\fR and \fBReset\fR are exported, +The procedures \fBbump\fR and \fBreset\fR are exported, so they are included when you import from the \fBCounter\fR namespace, like this: .CS \fBnamespace import Counter::*\fR .CE -However, the \fBcheck\fR procedure is not exported, +However, the \fBCheck\fR procedure is not exported, so it is ignored by the import operation. .PP The \fBnamespace import\fR command only imports commands diff --git a/doc/open.n b/doc/open.n index 76d0b1c..03e4339 100644 --- a/doc/open.n +++ b/doc/open.n @@ -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: open.n,v 1.3 1999/04/15 22:38:46 stanton Exp $ +'\" RCS: @(#) $Id: open.n,v 1.4 1999/04/16 00:46:35 stanton Exp $ '\" .so man.macros .TH open n 7.6 Tcl "Tcl Built-In Commands" @@ -217,9 +217,7 @@ no interactions between command pipelines and the console. .TP \fBMacintosh\fR . -Access to the serial port is not accomplished through magic cookies passed -to the \fIopen\fR command on the Macintosh. Instead, you can use Sean Wood's -(yoda@drexel.edu) \fIDevice\fR extension for the same purpose. +Opening a serial port is not currently implemented under Macintosh. .sp Opening a command pipeline is not supported under Macintosh, since applications do not support the concept of standard input or output. diff --git a/doc/puts.n b/doc/puts.n index 2042f9d..99e61a4 100644 --- a/doc/puts.n +++ b/doc/puts.n @@ -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: puts.n,v 1.2 1998/09/14 18:39:54 stanton Exp $ +'\" RCS: @(#) $Id: puts.n,v 1.3 1999/04/16 00:46:35 stanton Exp $ '\" .so man.macros .TH puts n 7.5 Tcl "Tcl Built-In Commands" @@ -34,8 +34,8 @@ value of the \fB\-translation\fR option for the channel (for example, on PCs newlines are normally replaced with carriage-return-linefeed sequences; on Macintoshes newlines are normally replaced with carriage-returns). -See the \fBfconfigure\fR manual entry for a discussion of end-of-line -translations. +See the \fBfconfigure\fR manual entry for a discussion on ways in +which \fBfconfigure\fR will alter output. .PP Tcl buffers output internally, so characters written with \fBputs\fR may not appear immediately on the output file or device; Tcl will diff --git a/doc/read.n b/doc/read.n index 77de6ce..21d9549 100644 --- a/doc/read.n +++ b/doc/read.n @@ -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: read.n,v 1.2 1998/09/14 18:39:54 stanton Exp $ +'\" RCS: @(#) $Id: read.n,v 1.3 1999/04/16 00:46:35 stanton Exp $ '\" .so man.macros .TH read n 7.5 Tcl "Tcl Built-In Commands" @@ -40,8 +40,8 @@ before reaching the end of the file. \fBRead\fR translates end-of-line sequences in the input into newline characters according to the \fB\-translation\fR option for the channel. -See the manual entry for \fBfconfigure\fR for details on the -\fB\-translation\fR option. +See the \fBfconfigure\fR manual entry for a discussion on ways in +which \fBfconfigure\fR will alter input. .SH "SEE ALSO" eof(n), fblocked(n), fconfigure(n) diff --git a/doc/regexp.n b/doc/regexp.n index ed61c8d..0d08dcf 100644 --- a/doc/regexp.n +++ b/doc/regexp.n @@ -1,18 +1,18 @@ '\" -'\" Copyright (c) 1993 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1998 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: regexp.n,v 1.2 1998/09/14 18:39:54 stanton Exp $ +'\" RCS: @(#) $Id: regexp.n,v 1.3 1999/04/16 00:46:35 stanton Exp $ '\" .so man.macros -.TH regexp n "" Tcl "Tcl Built-In Commands" +.TH regexp n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regexp \- Match a regular expression against a string + .SH SYNOPSIS \fBregexp \fR?\fIswitches\fR? \fIexp string \fR?\fImatchVar\fR? ?\fIsubMatchVar subMatchVar ...\fR? .BE @@ -31,27 +31,61 @@ the characters in \fIstring\fR that matched the leftmost parenthesized subexpression within \fIexp\fR, the next \fIsubMatchVar\fR will contain the characters that matched the next parenthesized subexpression to the right in \fIexp\fR, and so on. -.LP +.PP If the initial arguments to \fBregexp\fR start with \fB\-\fR then they are treated as switches. The following switches are currently supported: -.TP 10 +.TP 15 \fB\-nocase\fR Causes upper-case characters in \fIstring\fR to be treated as lower case during the matching process. -.TP 10 +.TP 15 \fB\-indices\fR Changes what is stored in the \fIsubMatchVar\fRs. -Instead of storing the matching characters from \fBstring\fR, +Instead of storing the matching characters from \fIstring\fR, each variable will contain a list of two decimal strings giving the indices in \fIstring\fR of the first and last characters in the matching range of characters. -.TP 10 +.VS 8.1 +.TP 15 +\fB\-expanded\fR +Enables use of the expanded regular expression syntax where +whitespace and comments are ignored. This is the same as specifying +the \fB(?x)\fR embedded option (see METASYNTAX, below). +.TP 15 +\fB\-line\fR +Enables newline-sensitive matching. By default, newline is a +completely ordinary character with no special meaning. With this +flag, `[^' bracket expressions and `.' never match newline, `^' +matches an empty string after any newline in addition to its normal +function, and `$' matches an empty string before any newline in +addition to its normal function. This flag is equivalent to +specifying both \fB\-linestop\fR and \fB\-lineanchor\fR, or the +\fB(?n)\fR embedded option (see METASYNTAX, below). +.TP 15 +\fB\-linestop\fR +Changes the behavior of `[^' bracket expressions and `.' so that they +stop at newlines. This is the same as specifying the \fB(?p)\fR +embedded option (see METASYNTAX, below). +.TP 15 +\fB\-lineanchor\fR +Changes the behavior of `^' and `$' (the ``anchors'') so they match the +beginning and end of a line respectively. This is the same as +specifying the \fB(?w)\fR embedded option (see METASYNTAX, below). +.TP 15 +\fB\-about\fR +Instead of attempting to match the regular expression, returns a list +containing information about the regular expression. The first +element of the list is a subexpression count. The second element is a +list of property names that describe various attributes of the regular +expression. This switch is primarily intended for debugging purposes. +.VE 8.1 +.TP 15 \fB\-\|\-\fR Marks the end of switches. The argument following this one will be treated as \fIexp\fR even if it starts with a \fB\-\fR. -.LP +.PP If there are more \fIsubMatchVar\fR's than parenthesized subexpressions within \fIexp\fR, or if a particular subexpression in \fIexp\fR doesn't match the string (e.g. because it was in a @@ -59,87 +93,956 @@ portion of the expression that wasn't matched), then the corresponding \fIsubMatchVar\fR will be set to ``\fB\-1 \-1\fR'' if \fB\-indices\fR has been specified or to an empty string otherwise. -.SH "REGULAR EXPRESSIONS" -.PP -Regular expressions are implemented using Henry Spencer's package -(thanks, Henry!), -and much of the description of regular expressions below is copied verbatim -from his manual entry. -.PP -A regular expression is zero or more \fIbranches\fR, separated by ``|''. -It matches anything that matches one of the branches. -.PP -A branch is zero or more \fIpieces\fR, concatenated. -It matches a match for the first, followed by a match for the second, etc. -.PP -A piece is an \fIatom\fR possibly followed by ``*'', ``+'', or ``?''. -An atom followed by ``*'' matches a sequence of 0 or more matches of the atom. -An atom followed by ``+'' matches a sequence of 1 or more matches of the atom. -An atom followed by ``?'' matches a match of the atom, or the null string. -.PP -An atom is a regular expression in parentheses (matching a match for the -regular expression), a \fIrange\fR (see below), ``.'' -(matching any single character), ``^'' (matching the null string at the -beginning of the input string), ``$'' (matching the null string at the -end of the input string), a ``\e'' followed by a single character (matching -that character), or a single character with no other significance -(matching that character). -.PP -A \fIrange\fR is a sequence of characters enclosed in ``[]''. -It normally matches any single character from the sequence. -If the sequence begins with ``^'', -it matches any single character \fInot\fR from the rest of the sequence. -If two characters in the sequence are separated by ``\-'', this is shorthand -for the full list of ASCII characters between them -(e.g. ``[0-9]'' matches any decimal digit). -To include a literal ``]'' in the sequence, make it the first character -(following a possible ``^''). -To include a literal ``\-'', make it the first or last character. +.SH "DIFFERENT FLAVORS OF REs" +.VS 8.1 +Regular expressions (``RE''s), as defined by POSIX, come in two +flavors: \fIextended\fR REs (``EREs'') and \fIbasic\fR REs (``BREs''). +EREs are roughly those of the traditional \fIegrep\fR, while BREs are +roughly those of the traditional \fIed\fR . This implementation adds +a third flavor, \fIadvanced\fR REs (``AREs''), basically EREs with +some significant extensions. +.PP +This manual page primarily describes AREs. BREs mostly exist for +backward compatibility in some old programs; they will be discussed at +the end. POSIX EREs are almost an exact subset of AREs. Features of +AREs that are not present in EREs will be indicated. -.SH "CHOOSING AMONG ALTERNATIVE MATCHES" -.PP -In general there may be more than one way to match a regular expression -to an input string. For example, consider the command -.CS -\fBregexp (a*)b* aabaaabb x y\fR -.CE -Considering only the rules given so far, \fBx\fR and \fBy\fR could -end up with the values \fBaabb\fR and \fBaa\fR, \fBaaab\fR and \fBaaa\fR, -\fBab\fR and \fBa\fR, or any of several other combinations. -To resolve this potential ambiguity \fBregexp\fR chooses among -alternatives using the rule ``first then longest''. -In other words, it considers the possible matches in order working -from left to right across the input string and the pattern, and it -attempts to match longer pieces of the input string before shorter -ones. More specifically, the following rules apply in decreasing -order of priority: -.IP [1] -If a regular expression could match two different parts of an input string -then it will match the one that begins earliest. -.IP [2] -If a regular expression contains \fB|\fR operators then the leftmost -matching sub-expression is chosen. -.IP [3] -In \fB*\fR, \fB+\fR, and \fB?\fR constructs, longer matches are chosen -in preference to shorter ones. -.IP [4] -In sequences of expression components the components are considered -from left to right. -.LP -In the example from above, \fB(a*)b*\fR matches \fBaab\fR: the \fB(a*)\fR -portion of the pattern is matched first and it consumes the leading -\fBaa\fR; then the \fBb*\fR portion of the pattern consumes the -next \fBb\fR. Or, consider the following example: -.CS -\fBregexp (ab|a)(b*)c abc x y z\fR -.CE -After this command \fBx\fR will be \fBabc\fR, \fBy\fR will be -\fBab\fR, and \fBz\fR will be an empty string. -Rule 4 specifies that \fB(ab|a)\fR gets first shot at the input -string and Rule 2 specifies that the \fBab\fR sub-expression -is checked before the \fBa\fR sub-expression. -Thus the \fBb\fR has already been claimed before the \fB(b*)\fR -component is checked and \fB(b*)\fR must match an empty string. +.SH "REGULAR EXPRESSION SYNTAX" +.PP +Tcl regular expressions are implemented using the package written by +Henry Spencer, based on the 1003.2 spec and some (not quite all) of +the Perl5 extensions (thanks, Henry!). Much of the description of +regular expressions below is copied verbatim from his manual entry. +.PP +An ARE is one or more \fIbranches\fR, +separated by `\fB|\fR', +matching anything that matches any of the branches. +.PP +A branch is zero or more \fIconstraints\fR or \fIquantified atoms\fR, +concatenated. +It matches a match for the first, followed by a match for the second, etc; +an empty branch matches the empty string. +.PP +A quantified atom is an \fIatom\fR possibly followed +by a single \fIquantifier\fR. +Without a quantifier, it matches a match for the atom. +The quantifiers, +and what a so-quantified atom matches, are: +.RS 2 +.TP 6 +\fB*\fR +a sequence of 0 or more matches of the atom +.TP +\fB+\fR +a sequence of 1 or more matches of the atom +.TP +\fB?\fR +a sequence of 0 or 1 matches of the atom +.TP +\fB{\fIm\fB}\fR +a sequence of exactly \fIm\fR matches of the atom +.TP +\fB{\fIm\fB,}\fR +a sequence of \fIm\fR or more matches of the atom +.TP +\fB{\fIm\fB,\fIn\fB}\fR +a sequence of \fIm\fR through \fIn\fR (inclusive) matches of the atom; +\fIm\fR may not exceed \fIn\fR +.TP +\fB*? +? ?? {\fIm\fB}? {\fIm\fB,}? {\fIm\fB,\fIn\fB}?\fR +\fInon-greedy\fR quantifiers, +which match the same possibilities, +but prefer the smallest number rather than the largest number +of matches (see MATCHING) +.RE +.PP +The forms using +\fB{\fR and \fB}\fR +are known as \fIbound\fRs. +The numbers +\fIm\fR and \fIn\fR are unsigned decimal integers +with permissible values from 0 to 255 inclusive. +.PP +An atom is one of: +.RS 2 +.TP 6 +\fB(\fIre\fB)\fR +(where \fIre\fR is any regular expression) +matches a match for +\fIre\fR, with the match noted for possible reporting +.TP +\fB(?:\fIre\fB)\fR +as previous, +but does no reporting +(a ``non-capturing'' set of parentheses) +.TP +\fB()\fR +matches an empty string, +noted for possible reporting +.TP +\fB(?:)\fR +matches an empty string, +without reporting +.TP +\fB[\fIchars\fB]\fR +a \fIbracket expression\fR, +matching any one of the \fIchars\fR (see BRACKET EXPRESSIONS for more detail) +.TP + \fB.\fR +matches any single character +.TP +\fB\e\fIk\fR +(where \fIk\fR is a non-alphanumeric character) +matches that character taken as an ordinary character, +e.g. \e\e matches a backslash character +.TP +\fB\e\fIc\fR +where \fIc\fR is alphanumeric +(possibly followed by other characters), +an \fIescape\fR (AREs only), +see ESCAPES below +.TP +\fB{\fR +when followed by a character other than a digit, +matches the character +`\fB{\fR'; +when followed by a digit, it is the beginning of a +\fIbound\fR (see above) +.TP +\fIx\fR +where \fIx\fR is +a single character with no other significance, matches that character. +.RE +.PP +A \fIconstraint\fR matches an empty string when specific conditions +are met. +A constraint may not be followed by a quantifier. +The simple constraints are as follows; some more constraints are +described later, under ESCAPES. +.RS 2 +.TP 8 +\fB^\fR +matches at the beginning of a line +.TP +\fB$\fR +matches at the end of a line +.TP +\fB(?=\fIre\fB)\fR +\fIpositive lookahead\fR (AREs only), matches at any point +where a substring matching \fIre\fR begins +.TP +\fB(?!\fIre\fB)\fR +\fInegative lookahead\fR (AREs only), matches at any point +where no substring matching \fIre\fR begins +.RE +.PP +The lookahead constraints may not contain back references (see later), +and all parentheses within them are considered non-capturing. +.PP +An RE may not end with +`\fB\e\fR'. + +.SH "BRACKET EXPRESSIONS" +A \fIbracket expression\fR is a list of characters enclosed in +`\fB[\|]\fR'. +It normally matches any single character from the list (but see below). +If the list begins with +`\fB^\fR', +it matches any single character +(but see below) \fInot\fR from the rest of the list. +.PP +If two characters in the list are separated by +`\fB\-\fR', +this is shorthand +for the full \fIrange\fR of characters between those two (inclusive) in the +collating sequence, +e.g. +\fB[0\-9]\fR +in ASCII matches any decimal digit. +Two ranges may not share an +endpoint, so e.g. +\fBa\-c\-e\fR +is illegal. +Ranges are very collating-sequence-dependent, +and portable programs should avoid relying on them. +.PP +To include a literal +\fB]\fR +or +\fB\-\fR +in the list, +the simplest method is to +enclose it in +\fB[.\fR +and +\fB.]\fR +to make it a collating element (see below). +Alternatively, +make it the first character +(following a possible +`\fB^\fR'), +or (AREs only) precede it with +`\fB\e\fR'. +Alternatively, for +`\fB\-\fR', +make it the last character, +or the second endpoint of a range. +To use a literal +\fB\-\fR +as the first endpoint of a range, +make it a collating element +or (AREs only) precede it with +`\fB\e\fR'. +With the exception of these, some combinations using +\fB[\fR +(see next +paragraphs), and escapes, +all other special characters lose their +special significance within a bracket expression. +.PP +Within a bracket expression, a collating element (a character, +a multi-character sequence that collates as if it were a single character, +or a collating-sequence name for either) +enclosed in +\fB[.\fR +and +\fB.]\fR +stands for the +sequence of characters of that collating element. +The sequence is a single element of the bracket expression's list. +A bracket expression in a locale which has +multi-character collating elements +can thus match more than one character. +Most insidiously, if +\fB^\fR +is used, +this can happen even if no multi-character collating +elements appear in the bracket expression! +If the collating sequence includes a +\fBch\fR +multi-character collating element, +then the RE +\fB[[.ch.]]*c\fR +matches the first five characters +of +`\fBchchcc\fR', +and the RE +\fB[^c]b\fR +matches all of +`\fBchb\fR'. +.PP +Within a bracket expression, a collating element enclosed in +\fB[=\fR +and +\fB=]\fR +is an equivalence class, standing for the sequences of characters +of all collating elements equivalent to that one, including itself. +(If there are no other equivalent collating elements, +the treatment is as if the enclosing delimiters were +`\fB[.\fR'\& +and +`\fB.]\fR'.) +For example, if +\fBo\fR +and +\fB\o'o^'\fR +are the members of an equivalence class, +then +`\fB[[=o=]]\fR', +`\fB[[=\o'o^'=]]\fR', +and +`\fB[o\o'o^']\fR'\& +are all synonymous. +An equivalence class may not be an endpoint +of a range. +.PP +Within a bracket expression, the name of a \fIcharacter class\fR enclosed +in +\fB[:\fR +and +\fB:]\fR +stands for the list of all characters +(not all collating elements!) +belonging to that +class. +Standard character class names are: +.PP +.RS +.ne 5 +.nf +.ta 3c 6c 9c +\fBalnum digit punct +alpha graph space +blank lower upper +cntrl print xdigit\fR +.fi +.RE +.PP +These stand for the character classes defined in +\fIctype\fR(3). +A locale may provide others. +A character class may not be used as an endpoint of a range. +.PP +There are two special cases of bracket expressions: +the bracket expressions +\fB[[:<:]]\fR +and +\fB[[:>:]]\fR +are constraints, matching empty strings at +the beginning and end of a word respectively. +'\" note, discussion of escapes below references this definition of word +A word is defined as a sequence of +word characters +which is neither preceded nor followed by +word characters. +A word character is an +\fIalnum\fR +character (as defined by +\fIctype\fR(3)) +or an underscore +(\fB_\fR). +These special bracket expressions are deprecated; +users of AREs should use constraint escapes instead (see below). +.SH ESCAPES +Escapes (AREs only), which begin with a +\fB\e\fR +followed by an alphanumeric character, +come in several varieties: +character entry, class shorthands, constraint escapes, and back references. +A +\fB\e\fR +followed by an alphanumeric character but not constituting +a valid escape is illegal in AREs. +In EREs, there are no escapes: +outside a bracket expression, +a +\fB\e\fR +followed by an alphanumeric character merely stands for that +character as an ordinary character, +and inside a bracket expression, +\fB\e\fR +is an ordinary character. +(The latter is the one actual incompatibility between EREs and AREs.) +.PP +Character-entry escapes (AREs only) exist to make it easier to specify +non-printing and otherwise inconvenient characters in REs: +.RS 2 +.TP 5 +\fB\ea\fR +alert, aka bell, character, as in C +.TP +\fB\eb\fR +backspace, as in C +.TP +\fB\eB\fR +synonym for +\fB\e\fR +to help reduce backslash doubling in some +applications where there are multiple levels of backslash processing +.TP +\fB\ec\fIX\fR +(where X is any character) the character whose +low-order 5 bits are the same as those of +\fIX\fR, +and whose other bits are all zero +.TP +\fB\ee\fR +the character whose collating-sequence name +is +`\fBESC\fR', +or failing that, the character with octal value 033 +.TP +\fB\ef\fR +formfeed, as in C +.TP +\fB\en\fR +newline, as in C +.TP +\fB\er\fR +carriage return, as in C +.TP +\fB\et\fR +horizontal tab, as in C +.TP +\fB\eu\fIwxyz\fR +(where +\fIwxyz\fR +is exactly four hexadecimal digits) +the Unicode character +\fBU+\fIwxyz\fR +in the local byte ordering +.TP +\fB\eU\fIstuvwxyz\fR +(where +\fIstuvwxyz\fR +is exactly eight hexadecimal digits) +reserved for a somewhat-hypothetical Unicode extension to 32 bits +.TP +\fB\ev\fR +vertical tab, as in C +are all available. +.TP +\fB\ex\fIhhh\fR +(where +\fIhhh\fR +is any sequence of hexadecimal digits) +the character whose hexadecimal value is +\fB0x\fIhhh\fR +(a single character no matter how many hexadecimal digits are used). +.TP +\fB\e0\fR +the character whose value is +\fB0\fR +.TP +\fB\e\fIxy\fR +(where +\fIxy\fR +is exactly two octal digits, +and is not a +\fIback reference\fR (see below)) +the character whose octal value is +\fB0\fIxy\fR +.TP +\fB\e\fIxyz\fR +(where +\fIxyz\fR +is exactly three octal digits, +and is not a +back reference (see below)) +the character whose octal value is +\fB0\fIxyz\fR +.RE +.PP +Hexadecimal digits are +`\fB0\fR'-`\fB9\fR', +`\fBa\fR'-`\fBf\fR', +and +`\fBA\fR'-`\fBF\fR'. +Octal digits are +`\fB0\fR'-`\fB7\fR'. +.PP +The character-entry escapes are always taken as ordinary characters. +For example, +\fB\e135\fR +is +\fB]\fR +in ASCII, +but +\fB\e135\fR +does not terminate a bracket expression. +Beware, however, that some applications (e.g., C compilers) interpret +such sequences themselves before the regular-expression package +gets to see them, which may require doubling (quadrupling, etc.) the +`\fB\e\fR'. +.PP +Class-shorthand escapes (AREs only) provide shorthands for certain commonly-used +character classes: +.RS 2 +.TP 10 +\fB\ed\fR +\fB[[:digit:]]\fR +.TP +\fB\es\fR +\fB[[:space:]]\fR +.TP +\fB\ew\fR +\fB[[:alnum:]_]\fR +(note underscore) +.TP +\fB\eD\fR +\fB[^[:digit:]]\fR +.TP +\fB\eS\fR +\fB[^[:space:]]\fR +.TP +\fB\eW\fR +\fB[^[:alnum:]_]\fR +(note underscore) +.RE +.PP +Within bracket expressions, +`\fB\ed\fR', +`\fB\es\fR', +and +`\fB\ew\fR'\& +lose their outer brackets, +and +`\fB\eD\fR', +`\fB\eS\fR', +and +`\fB\eW\fR'\& +are illegal. +.PP +A constraint escape (AREs only) is a constraint, +matching the empty string if specific conditions are met, +written as an escape: +.RS 2 +.TP 6 +\fB\eA\fR +matches only at the beginning of the string +(see MATCHING, below, for how this differs from +`\fB^\fR') +.TP +\fB\em\fR +matches only at the beginning of a word +.TP +\fB\eM\fR +matches only at the end of a word +.TP +\fB\ey\fR +matches only at the beginning or end of a word +.TP +\fB\eY\fR +matches only at a point which is not the beginning or end of a word +.TP +\fB\eZ\fR +matches only at the end of the string +(see MATCHING, below, for how this differs from +`\fB$\fR') +.TP +\fB\e\fIm\fR +(where +\fIm\fR +is a nonzero digit) a \fIback reference\fR, see below +.TP +\fB\e\fImnn\fR +(where +\fIm\fR +is a nonzero digit, and +\fInn\fR +is some more digits, +and the decimal value +\fImnn\fR +is not greater than the number of closing capturing parentheses seen so far) +a \fIback reference\fR, see below +.RE +.PP +A word is defined as in the specification of +\fB[[:<:]]\fR +and +\fB[[:>:]]\fR +above. +Constraint escapes are illegal within bracket expressions. +.PP +A back reference (AREs only) matches the same string matched by the parenthesized +subexpression specified by the number, +so that (e.g.) +\fB([bc])\e1\fR +matches +\fBbb\fR +or +\fBcc\fR +but not +`\fBbc\fR'. +The subexpression must entirely precede the back reference in the RE. +Subexpressions are numbered in the order of their leading parentheses. +Non-capturing parentheses do not define subexpressions. +.PP +There is an inherent historical ambiguity between octal character-entry +escapes and back references, which is resolved by heuristics, +as hinted at above. +A leading zero always indicates an octal escape. +A single non-zero digit, not followed by another digit, +is always taken as a back reference. +A multi-digit sequence not starting with a zero is taken as a back +reference if it comes after a suitable subexpression +(i.e. the number is in the legal range for a back reference), +and otherwise is taken as octal. +.SH "METASYNTAX" +In addition to the main syntax described above, there are some special +forms and miscellaneous syntactic facilities available. +.PP +Normally the flavor of RE being used is specified by +application-dependent means. +However, this can be overridden by a \fIdirector\fR. +If an RE of any flavor begins with +`\fB***:\fR', +the rest of the RE is an ARE. +If an RE of any flavor begins with +`\fB***=\fR', +the rest of the RE is taken to be a literal string, +with all characters considered ordinary characters. +.PP +An ARE may begin with \fIembedded options\fR: +a sequence +\fB(?\fIxyz\fB)\fR +(where +\fIxyz\fR +is one or more alphabetic characters) +specifies options affecting the rest of the RE. +These supplement, and can override, +any options specified by the application. +The available option letters are: +.RS 2 +.TP 3 +\fBb\fR +rest of RE is a BRE +.TP 3 +\fBc\fR +case-sensitive matching (usual default) +.TP 3 +\fBe\fR +rest of RE is an ERE +.TP 3 +\fBi\fR +case-insensitive matching (see MATCHING, below) +.TP 3 +\fBm\fR +historical synonym for +\fBn\fR +.TP 3 +\fBn\fR +newline-sensitive matching (see MATCHING, below) +.TP 3 +\fBp\fR +partial newline-sensitive matching (see MATCHING, below) +.TP 3 +\fBq\fR +rest of RE is a literal (``quoted'') string, all ordinary characters +.TP 3 +\fBs\fR +non-newline-sensitive matching (usual default) +.TP 3 +\fBt\fR +tight syntax (usual default; see below) +.TP 3 +\fBw\fR +inverse partial newline-sensitive (``weird'') matching (see MATCHING, below) +.TP 3 +\fBx\fR +expanded syntax (see below) +.RE +.PP +Embedded options take effect at the +\fB)\fR +terminating the sequence. +They are available only at the start of an ARE, +and may not be used later within it. +.PP +In addition to the usual (\fItight\fR) RE syntax, in which all characters are +significant, there is an \fIexpanded\fR syntax, +available in all flavors of RE +with the \fB-expanded\fR switch, or in AREs with the embedded x option. +In the expanded syntax, +white-space characters are ignored +and all characters between a +\fB#\fR +and the following newline (or the end of the RE) are ignored, +permitting paragraphing and commenting a complex RE. +There are three exceptions to that basic rule: +.RS 2 +.PP +a white-space character or `\fB#\fR' preceded by `\fB\e\fR' is retained +.PP +white space or `\fB#\fR' within a bracket expression is retained +.PP +white space and comments are illegal within multi-character symbols +like the ARE `\fB(?:\fR' or the BRE `\fB\e(\fR' +.RE +.PP +Expanded-syntax +white-space characters are blank, tab, newline, etc. (any character +defined as \fIspace\fR by +\fIctype\fR(3)). +Exactly how a multi-line expanded-syntax RE +can be entered interactively by a user, +if at all, is application-specific; +expanded syntax is primarily a scripting facility. +.PP +Finally, in an ARE, +outside bracket expressions, the sequence +`\fB(?#\fIttt\fB)\fR' +(where +\fIttt\fR +is any text not containing a +`\fB)\fR') +is a comment, +completely ignored. +Again, this is not allowed between the characters of +multi-character symbols like +`\fB(?:\fR'. +Such comments are more a historical artifact than a useful facility, +and their use is deprecated; +use the expanded syntax instead. +.PP +\fINone\fR of these metasyntax extensions is available if the application +(or an initial +\fB***=\fR +director) +has specified that the user's input be treated as a literal string +rather than as an RE. +.SH MATCHING +In the event that an RE could match more than one substring of a given +string, +the RE matches the one starting earliest in the string. +If the RE could match more than one substring starting at that point, +its choice is determined by its \fIpreference\fR: +either the longest substring, or the shortest. +.PP +Most atoms, and all constraints, have no preference. +A parenthesized RE has the same preference (possibly none) as the RE. +A quantified atom with quantifier +\fB{\fIm\fB}\fR +or +\fB{\fIm\fB}?\fR +has the same preference (possibly none) as the atom itself. +A quantified atom with other normal quantifiers (including +\fB{\fIm\fB,\fIn\fB}\fR +with +\fIm\fR +equal to +\fIn\fR) +prefers longest match. +A quantified atom with other non-greedy quantifiers (including +\fB{\fIm\fB,\fIn\fB}?\fR +with +\fIm\fR +equal to +\fIn\fR) +prefers shortest match. +A branch has the same preference as the first quantified atom in it +which has a preference. +An RE consisting of two or more branches connected by the +\fB|\fR +operator prefers longest match. +.PP +Subject to the constraints imposed by the rules for matching the whole RE, +subexpressions also match the longest or shortest possible substrings, +based on their preferences, +with subexpressions starting earlier in the RE taking priority over +ones starting later. +Note that outer subexpressions thus take priority over +their component subexpressions. +.PP +Note that the quantifiers +\fB{1,1}\fR +and +\fB{1,1}?\fR +can be used to force longest and shortest preference, respectively, +on a subexpression or a whole RE. +.PP +Match lengths are measured in characters, not collating elements. +An empty string is considered longer than no match at all. +For example, +\fBbb*\fR +matches the three middle characters of +`\fBabbbc\fR', +\fB(week|wee)(night|knights)\fR +matches all ten characters of +`\fBweeknights\fR', +when +\fB(.*).*\fR +is matched against +\fBabc\fR +the parenthesized subexpression +matches all three characters, and +when +\fB(a*)*\fR +is matched against +\fBbc\fR +both the whole RE and the parenthesized +subexpression match an empty string. +.PP +If case-independent matching is specified, +the effect is much as if all case distinctions had vanished from the +alphabet. +When an alphabetic that exists in multiple cases appears as an +ordinary character outside a bracket expression, it is effectively +transformed into a bracket expression containing both cases, +so that +\fBx\fR +becomes +`\fB[xX]\fR'. +When it appears inside a bracket expression, all case counterparts +of it are added to the bracket expression, so that +\fB[x]\fR +becomes +\fB[xX]\fR +and +\fB[^x]\fR +becomes +`\fB[^xX]\fR'. +.PP +If newline-sensitive matching is specified, +\fB.\fR +and bracket expressions using +\fB^\fR +will never match the newline character +(so that matches will never cross newlines unless the RE +explicitly arranges it) +and +\fB^\fR +and +\fB$\fR +will match the empty string after and before a newline +respectively, in addition to matching at beginning and end of string +respectively. +ARE +\fB\eA\fR +and +\fB\eZ\fR +continue to match beginning or end of string \fIonly\fR. +.PP +If partial newline-sensitive matching is specified, +this affects +\fB.\fR +and bracket expressions +as with newline-sensitive matching, but not +\fB^\fR +and +`\fB$\fR'. +.PP +If inverse partial newline-sensitive matching is specified, +this affects +\fB^\fR +and +\fB$\fR +as with +newline-sensitive matching, +but not +\fB.\fR +and bracket expressions. +This isn't very useful but is provided for symmetry. +.SH "LIMITS AND COMPATIBILITY" +No particular limit is imposed on the length of REs. +Programs intended to be highly portable should not employ REs longer +than 256 bytes, +as a POSIX-compliant implementation can refuse to accept such REs. +.PP +The only feature of AREs that is actually incompatible with +POSIX EREs is that +\fB\e\fR +does not lose its special +significance inside bracket expressions. +All other ARE features use syntax which is illegal or has +undefined or unspecified effects in POSIX EREs; +the +\fB***\fR +syntax of directors likewise is outside the POSIX +syntax for both BREs and EREs. +.PP +Many of the ARE extensions are borrowed from Perl, but some have +been changed to clean them up, and a few Perl extensions are not present. +Incompatibilities of note include +`\fB\eb\fR', +`\fB\eB\fR', +the lack of special treatment for a trailing newline, +the addition of complemented bracket expressions to the things +affected by newline-sensitive matching, +the restrictions on parentheses and back references in lookahead constraints, +and the longest/shortest-match (rather than first-match) matching semantics. +.PP +The matching rules for REs containing both normal and non-greedy quantifiers +have changed since early beta-test versions of this package. +(The new rules are much simpler and cleaner, +but don't work as hard at guessing the user's real intentions.) +.PP +Henry Spencer's original 1986 \fIregexp\fR package, +still in widespread use (e.g., in pre-8.1 releases of Tcl), +implemented an early version of today's EREs. +There are four incompatibilities between \fIregexp\fR's near-EREs +(`RREs' for short) and AREs. +In roughly increasing order of significance: +.PP +.RS +In AREs, +\fB\e\fR +followed by an alphanumeric character is either an +escape or an error, +while in RREs, it was just another way of writing the +alphanumeric. +This should not be a problem because there was no reason to write +such a sequence in RREs. +.PP +\fB{\fR +followed by a digit in an ARE is the beginning of a bound, +while in RREs, +\fB{\fR +was always an ordinary character. +Such sequences should be rare, +and will often result in an error because following characters +will not look like a valid bound. +.PP +In AREs, +\fB\e\fR +remains a special character within +`\fB[\|]\fR', +so a literal +\fB\e\fR +within +\fB[\|]\fR +must be written +`\fB\e\e\fR'. +\fB\e\e\fR +also gives a literal +\fB\e\fR +within +\fB[\|]\fR +in RREs, +but only truly paranoid programmers routinely doubled the backslash. +.PP +AREs report the longest/shortest match for the RE, +rather than the first found in a specified search order. +This may affect some RREs which were written in the expectation that +the first match would be reported. +(The careful crafting of RREs to optimize the search order for fast +matching is obsolete (AREs examine all possible matches +in parallel, and their performance is largely insensitive to their +complexity) but cases where the search order was exploited to deliberately +find a match which was \fInot\fR the longest/shortest will need rewriting.) +.RE + +.SH "BASIC REGULAR EXPRESSIONS" +BREs differ from EREs in several respects. +`\fB|\fR', +`\fB+\fR', +and +\fB?\fR +are ordinary characters and there is no equivalent +for their functionality. +The delimiters for bounds are +\fB\e{\fR +and +`\fB\e}\fR', +with +\fB{\fR +and +\fB}\fR +by themselves ordinary characters. +The parentheses for nested subexpressions are +\fB\e(\fR +and +`\fB\e)\fR', +with +\fB(\fR +and +\fB)\fR +by themselves ordinary characters. +\fB^\fR +is an ordinary character except at the beginning of the +RE or the beginning of a parenthesized subexpression, +\fB$\fR +is an ordinary character except at the end of the +RE or the end of a parenthesized subexpression, +and +\fB*\fR +is an ordinary character if it appears at the beginning of the +RE or the beginning of a parenthesized subexpression +(after a possible leading +`\fB^\fR'). +Finally, +single-digit back references are available, +and +\fB\e<\fR +and +\fB\e>\fR +are synonyms for +\fB[[:<:]]\fR +and +\fB[[:>:]]\fR +respectively; +no other escapes are available. +.VE 8.1 .SH KEYWORDS match, regular expression, string diff --git a/doc/registry.n b/doc/registry.n index 4b7dbf3..f0e199f 100644 --- a/doc/registry.n +++ b/doc/registry.n @@ -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: registry.n,v 1.3 1999/02/02 22:25:21 stanton Exp $ +'\" RCS: @(#) $Id: registry.n,v 1.4 1999/04/16 00:46:35 stanton Exp $ '\" .so man.macros .TH registry n 8.0 Tcl "Tcl Built-In Commands" @@ -112,7 +112,6 @@ registry command: . The registry value contains arbitrary binary data. The data is represented exactly in Tcl, including any embedded nulls. -Tcl .TP \fBnone\fR . diff --git a/doc/resource.n b/doc/resource.n index 9858abc..428591b 100644 --- a/doc/resource.n +++ b/doc/resource.n @@ -3,7 +3,7 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" RCS: @(#) $Id: resource.n,v 1.3 1998/12/29 22:55:12 surles Exp $ +'\" RCS: @(#) $Id: resource.n,v 1.4 1999/04/16 00:46:36 stanton Exp $ '\" .so man.macros .TH resource n 8.0 Tcl "Tcl Built-In Commands" @@ -55,7 +55,7 @@ If the \fB-file\fR option is specified then the resource will be deleted from the file pointed to by \fIresourceRef\fR. Otherwise the first resource with the given \fIresourceName\fR and or \fIresourceId\fR which is found on the resource file path will be -deleted. To inspect the file path, use the \fIresource files\fB command. +deleted. To inspect the file path, use the \fIresource files\fR command. .RE .TP \fBresource files ?\fIresourceRef\fR? diff --git a/doc/safe.n b/doc/safe.n index 6451823..749a57b 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -4,16 +4,15 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: safe.n,v 1.2 1998/09/14 18:39:55 stanton Exp $ +'\" RCS: @(#) $Id: safe.n,v 1.3 1999/04/16 00:46:36 stanton Exp $ '\" .so man.macros .TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Safe Base \- A mechanism for creating and manipulating safe interpreters. +Safe\ Base \- A mechanism for creating and manipulating safe interpreters. .SH SYNOPSIS -.PP \fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR? .sp \fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR? @@ -50,7 +49,7 @@ hosting application to any party. .PP The Safe Base allows a master interpreter to create safe, restricted interpreters that contain a set of predefined aliases for the \fBsource\fR, -\fBload\fR, \fBfile\fR and \fBexit\fR commands and +\fBload\fR, \fBfile\fR, \fBencoding\fR, and \fBexit\fR commands and are able to use the auto-loading and package mechanisms. .PP No knowledge of the file system structure is leaked to the @@ -246,6 +245,12 @@ the \fBfile\fR command; it allows only \fBdirname\fR, \fBjoin\fR, subcommands. For more details on what these subcommands do see the manual page for the \fBfile\fR command. .TP +\fBencoding\fR ?\fIsubCmd args...\fR? +The \fBenconding\fR alias provides access to a safe subset of the +subcommands of the \fBencoding\fR command; it disallows setting of +the system encoding, but allows all other subcommands including +\fBsystem\fR to check the current encoding. +.TP \fBexit\fR The calling interpreter is deleted and its computation is stopped, but the Tcl process in which this interpreter exists is not terminated. @@ -262,9 +267,9 @@ is to prevent. .PP The commands available in a safe interpreter, in addition to the safe set as defined in \fBinterp\fR manual page, are mediated aliases -for \fBsource\fR, \fBload\fR, \fBexit\fR, and a safe subset of \fBfile\fR. -The safe interpreter can also auto-load code and it can request that -packages be loaded. +for \fBsource\fR, \fBload\fR, \fBexit\fR, and safe subsets of +\fBfile\fR and \fBencoding\fR. The safe interpreter can also auto-load +code and it can request that packages be loaded. .PP Because some of these commands access the local file system, there is a potential for information leakage about its directory structure. diff --git a/doc/scan.n b/doc/scan.n index 8d9b2ad..123ec5b 100644 --- a/doc/scan.n +++ b/doc/scan.n @@ -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: scan.n,v 1.2 1998/09/14 18:39:55 stanton Exp $ +'\" RCS: @(#) $Id: scan.n,v 1.3 1999/04/16 00:46:36 stanton Exp $ '\" .so man.macros .TH scan n "" Tcl "Tcl Built-In Commands" @@ -31,25 +31,41 @@ and assigned to the corresponding variable. .SH "DETAILS ON SCANNING" .PP -\fBScan\fR operates by scanning \fIstring\fR and \fIformatString\fR together. -If the next character in \fIformatString\fR is a blank or tab then it +\fBScan\fR operates by scanning \fIstring\fR and \fIformat\fR together. +If the next character in \fIformat\fR is a blank or tab then it matches any number of white space characters in \fIstring\fR (including zero). Otherwise, if it isn't a \fB%\fR character then it must match the next character of \fIstring\fR. -When a \fB%\fR is encountered in \fIformatString\fR, it indicates +When a \fB%\fR is encountered in \fIformat\fR, it indicates the start of a conversion specifier. -A conversion specifier contains three fields after the \fB%\fR: +A conversion specifier contains up to four fields after the \fB%\fR: a \fB*\fR, which indicates that the converted value is to be discarded -instead of assigned to a variable; a number indicating a maximum field -width; and a conversion character. +.VS 8.1 +instead of assigned to a variable; a XPG3 position specifier; a number +.VE 8.1 +indicating a maximum field width; and a conversion character. All of these fields are optional except for the conversion character. +The fields that are present must appear in the order given above. .PP -When \fBscan\fR finds a conversion specifier in \fIformatString\fR, it -first skips any white-space characters in \fIstring\fR. +When \fBscan\fR finds a conversion specifier in \fIformat\fR, it +first skips any white-space characters in \fIstring\fR (unless the +specifier is \fB[\fR or \fBc\fR). Then it converts the next input characters according to the conversion specifier and stores the result in the variable given by the next argument to \fBscan\fR. +.VS 8.1 +.PP +If the \fB%\fR is followed by a decimal number and a \fB$\fR, as in +``\fB%2$d\fR'', then the variable to use is not taken from the next +sequential argument. Instead, it is taken from the argument indicated +by the number, where 1 corresponds to the first \fIvarName\fR. If +there are any positional specifiers in \fIformat\fR then all of the +specifiers must be positional. Every \fIvarName\fR on the argument +list must correspond to exactly one conversion specifier or an error +is generated. +.VE 8.1 +.PP The following conversion characters are supported: .TP 10 \fBd\fR @@ -63,6 +79,17 @@ value is stored in the variable as a decimal string. \fBx\fR The input field must be a hexadecimal integer. It is read in and the value is stored in the variable as a decimal string. +.VS 8.1 +.TP 10 +\fBu\fR +The input field must be a decimal integer. The value is stored in the +variable as an unsigned decimal integer string. +.TP 10 +\fBi\fR +The input field must be an integer. The base (i.e. decimal, octal, or +hexadecimal) is determined in the same fashion as described in +\fBexpr\fR. The value is stored in the variable as a decimal string. +.VE 8.1 .TP 10 \fBc\fR A single character is read in and its binary value is stored in @@ -92,6 +119,13 @@ The matching string is stored in the variable. If the first character between the brackets is a \fB]\fR then it is treated as part of \fIchars\fR rather than the closing bracket for the set. +.VS 8.1 +If \fIchars\fR +contains a sequence of the form \fIa\fB\-\fIb\fR then any +character between \fIa\fR and \fIb\fR (inclusive) will match. +If the first or last character between the brackets is a \fB\-\fR, then +it is treated as part of \fIchars\fR rather than indicating a range. +.VE 8.1 .TP 10 \fB[^\fIchars\fB]\fR The input field consists of any number of characters not in @@ -100,6 +134,18 @@ The matching string is stored in the variable. If the character immediately following the \fB^\fR is a \fB]\fR then it is treated as part of the set rather than the closing bracket for the set. +.VS 8.1 +If \fIchars\fR +contains a sequence of the form \fIa\fB\-\fIb\fR then any +character between \fIa\fR and \fIb\fR (inclusive) will be excluded +from the set. +If the first or last character between the brackets is a \fB\-\fR, then +it is treated as part of \fIchars\fR rather than indicating a range. +.TP 10 +\fBn\fR +No input is consumed from the input string. Instead, the total number +of chacters scanned from the input string so far is stored in the variable. +.VE 8.1 .LP The number of characters read from the input for a conversion is the largest number that makes sense for that particular conversion (e.g. @@ -115,9 +161,11 @@ then no variable is assigned and the next scan argument is not consumed. .PP The behavior of the \fBscan\fR command is the same as the behavior of the ANSI C \fBsscanf\fR procedure except for the following differences: +.VS 8.1 .IP [1] -\fB%p\fR and \fB%n\fR conversion specifiers are not currently +\fB%p\fR conversion specifier is not currently supported. +.VE 8.1 .IP [2] For \fB%c\fR conversions a single character value is converted to a decimal string, which is then assigned to the diff --git a/doc/socket.n b/doc/socket.n index ebb7383..d73883f 100644 --- a/doc/socket.n +++ b/doc/socket.n @@ -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: socket.n,v 1.3 1999/02/03 00:51:19 stanton Exp $ +'\" RCS: @(#) $Id: socket.n,v 1.4 1999/04/16 00:46:36 stanton Exp $ .so man.macros .TH socket n 8.0 Tcl "Tcl Built-In Commands" .BS @@ -104,14 +104,14 @@ will be accepted. .SH CONFIGURATION OPTIONS The \fBfconfigure\fR command can be used to query several readonly configuration options for socket channels: -.VS +.VS 8.0.5 .TP \fB\-error\fR This option gets the current error status of the given socket. This is useful when you need to determine if an asynchronous connect operation succeeded. If there was an error, the error message is returned. If there was no error, an empty string is returned. -.VE +.VE 8.0.5 .TP \fB\-sockname\fR This option returns a list of three elements, the address, the host name diff --git a/doc/string.n b/doc/string.n index 44ef20c..42d6e0b 100644 --- a/doc/string.n +++ b/doc/string.n @@ -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: string.n,v 1.2 1998/09/14 18:39:55 stanton Exp $ +'\" RCS: @(#) $Id: string.n,v 1.3 1999/04/16 00:46:36 stanton Exp $ '\" .so man.macros .TH string n 7.6 Tcl "Tcl Built-In Commands" @@ -85,14 +85,22 @@ If \fIfirst\fR is less than zero then it is treated as if it were zero, and if \fIlast\fR is greater than or equal to the length of the string then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. +.VS .TP \fBstring tolower \fIstring\fR -Returns a value equal to \fIstring\fR except that all upper case -letters have been converted to lower case. +Returns a value equal to \fIstring\fR except that all upper (or title) +case letters have been converted to lower case. .TP -\fBstring toupper \fIstring\fR -Returns a value equal to \fIstring\fR except that all lower case -letters have been converted to upper case. +\fBstring totitle \fIstring\fR +Returns a value equal to \fIstring\fR except that the first character +in \fIstring\fR is converted to its Unicode title case variant (or upper +case if there is no title case variant) and the rest of the string is +converted to lower case. +.TP +\fBstring toupper \fIstring\fR +Returns a value equal to \fIstring\fR except that all lower (or title) +case letters have been converted to upper case. +.VE .TP \fBstring trim \fIstring\fR ?\fIchars\fR? Returns a value equal to \fIstring\fR except that any leading @@ -114,18 +122,22 @@ trailing characters from the set given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (spaces, tabs, newlines, and carriage returns). +.VS .TP \fBstring wordend \fIstring index\fR -Returns the index of the character just after the last one in the -word containing character \fIindex\fR of \fIstring\fR. -A word is considered to be any contiguous range of alphanumeric -or underscore characters, or any single character other than these. +Returns the index of the character just after the last one in the word +containing character \fIindex\fR of \fIstring\fR. A word is +considered to be any contiguous range of alphanumeric (Unicode letters +or decimal digits) or underscore (Unicode connector punctuation) +characters, or any single character other than these. .TP \fBstring wordstart \fIstring index\fR -Returns the index of the first character in the -word containing character \fIindex\fR of \fIstring\fR. -A word is considered to be any contiguous range of alphanumeric -or underscore characters, or any single character other than these. +Returns the index of the first character in the word containing +character \fIindex\fR of \fIstring\fR. A word is considered to be any +contiguous range of alphanumeric (Unicode letters or decimal digits) +or underscore (Unicode connector punctuation) characters, or any +single character other than these. +.VE .SH KEYWORDS case conversion, compare, index, match, pattern, string, word diff --git a/doc/tclvars.n b/doc/tclvars.n index 8536327..2e68519 100644 --- a/doc/tclvars.n +++ b/doc/tclvars.n @@ -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: tclvars.n,v 1.2 1998/09/14 18:39:55 stanton Exp $ +'\" RCS: @(#) $Id: tclvars.n,v 1.3 1999/04/16 00:46:36 stanton Exp $ '\" .so man.macros .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" @@ -259,16 +259,27 @@ is the value returned by \fBuname -m\fR. .TP \fBos\fR The name of the operating system running on this machine, -such as \fBWin32s\fR, \fBWindows NT\fR, \fBMacOS\fR, or \fBSunOS\fR. +such as \fBWindows 95\fR, \fBWindows NT\fR, \fBMacOS\fR, or \fBSunOS\fR. On UNIX machines, this is the value returned by \fBuname -s\fR. +On Windows 95 and Windows 98, the value returned will be \fBWindows +95\fR to provide better backwards compatibility to Windows 95; to +distinguish between the two, check the \fBosVersion\fR. .TP \fBosVersion\fR The version number for the operating system running on this machine. -On UNIX machines, this is the value returned by \fBuname -r\fR. +On UNIX machines, this is the value returned by \fBuname -r\fR. On +Windows 95, the version will be 4.0; on Windows 98, the version will +be 4.10. .TP \fBplatform\fR Either \fBwindows\fR, \fBmacintosh\fR, or \fBunix\fR. This identifies the general operating environment of the machine. +.TP +\fBuser\fR +Either \fBwindows\fR, \fBmacintosh\fR, or \fBunix\fR. This identifies the +current user based on the login information available on the platform. +This comes from the USER or LOGNAME environment variable on Unix, +and the value from GetUserName on Windows and Macintosh. .RE .TP \fBtcl_precision\fR diff --git a/generic/regc_color.c b/generic/regc_color.c new file mode 100644 index 0000000..e86fea0 --- /dev/null +++ b/generic/regc_color.c @@ -0,0 +1,742 @@ +/* + * colorings of characters + * This file is #included by regcomp.c. + * + * Note that there are some incestuous relationships between this code and + * NFA arc maintenance, which perhaps ought to be cleaned up sometime. + */ + + + +#define CISERR() VISERR(cm->v) +#define CERR(e) VERR(cm->v, (e)) + + + +/* + - initcm - set up new colormap + ^ static VOID initcm(struct vars *, struct colormap *); + */ +static VOID +initcm(v, cm) +struct vars *v; +struct colormap *cm; +{ + int i; + int j; + union tree *t; + union tree *nextt; + struct colordesc *cd; + + cm->magic = CMMAGIC; + cm->v = v; + + cm->ncds = NINLINECDS; + cm->cd = cm->cdspace; + cm->max = 0; + cm->free = 0; + + cd = cm->cd; /* cm->cd[WHITE] */ + cd->sub = NOSUB; + cd->arcs = NULL; + cd->flags = 0; + cd->nchrs = CHR_MAX - CHR_MIN + 1; + + /* upper levels of tree */ + for (t = &cm->tree[0], j = NBYTS-1; j > 0; t = nextt, j--) { + nextt = t + 1; + for (i = BYTTAB-1; i >= 0; i--) + t->tptr[i] = nextt; + } + /* bottom level is solid white */ + t = &cm->tree[NBYTS-1]; + for (i = BYTTAB-1; i >= 0; i--) + t->tcolor[i] = WHITE; + cd->block = t; +} + +/* + - freecm - free dynamically-allocated things in a colormap + ^ static VOID freecm(struct colormap *); + */ +static VOID +freecm(cm) +struct colormap *cm; +{ + size_t i; + union tree *cb; + + cm->magic = 0; + if (NBYTS > 1) + cmtreefree(cm, cm->tree, 0); + for (i = 1; i < cm->max; i++) /* skip WHITE */ + if (!UNUSEDCOLOR(&cm->cd[i])) { + cb = cm->cd[i].block; + if (cb != NULL) + FREE(cb); + } + if (cm->cd != cm->cdspace) + FREE(cm->cd); +} + +/* + - cmtreefree - free a non-terminal part of a colormap tree + ^ static VOID cmtreefree(struct colormap *, union tree *, int); + */ +static VOID +cmtreefree(cm, tree, level) +struct colormap *cm; +union tree *tree; +int level; /* level number (top == 0) of this block */ +{ + int i; + union tree *t; + union tree *fillt = &cm->tree[level+1]; + union tree *cb; + + assert(level < NBYTS-1); /* this level has pointers */ + for (i = BYTTAB-1; i >= 0; i--) { + t = tree->tptr[i]; + assert(t != NULL); + if (t != fillt) { + if (level < NBYTS-2) { /* more pointer blocks below */ + cmtreefree(cm, t, level+1); + FREE(t); + } else { /* color block below */ + cb = cm->cd[t->tcolor[0]].block; + if (t != cb) /* not a solid block */ + FREE(t); + } + } + } +} + +/* + - setcolor - set the color of a character in a colormap + ^ static color setcolor(struct colormap *, pchr, pcolor); + */ +static color /* previous color */ +setcolor(cm, c, co) +struct colormap *cm; +pchr c; +pcolor co; +{ + uchr uc = c; + int shift; + int level; + int b; + int bottom; + union tree *t; + union tree *newt; + union tree *fillt; + union tree *lastt; + union tree *cb; + color prev; + + assert(cm->magic == CMMAGIC); + if (CISERR() || co == COLORLESS) + return COLORLESS; + + t = cm->tree; + for (level = 0, shift = BYTBITS * (NBYTS - 1); shift > 0; + level++, shift -= BYTBITS) { + b = (uc >> shift) & BYTMASK; + lastt = t; + t = lastt->tptr[b]; + assert(t != NULL); + fillt = &cm->tree[level+1]; + bottom = (shift <= BYTBITS) ? 1 : 0; + cb = (bottom) ? cm->cd[t->tcolor[0]].block : fillt; + if (t == fillt || t == cb) { /* must allocate a new block */ + newt = (union tree *)MALLOC((bottom) ? + sizeof(struct colors) : sizeof(struct ptrs)); + if (newt == NULL) { + CERR(REG_ESPACE); + return COLORLESS; + } + if (bottom) + memcpy(VS(newt->tcolor), VS(t->tcolor), + BYTTAB*sizeof(color)); + else + memcpy(VS(newt->tptr), VS(t->tptr), + BYTTAB*sizeof(union tree *)); + t = newt; + lastt->tptr[b] = t; + } + } + + b = uc & BYTMASK; + prev = t->tcolor[b]; + t->tcolor[b] = (color)co; + return prev; +} + +/* + - maxcolor - report largest color number in use + ^ static color maxcolor(struct colormap *); + */ +static color +maxcolor(cm) +struct colormap *cm; +{ + if (CISERR()) + return COLORLESS; + + return (color)cm->max; +} + +/* + - newcolor - find a new color (must be subject of setcolor at once) + * Beware: may relocate the colordescs. + ^ static color newcolor(struct colormap *); + */ +static color /* COLORLESS for error */ +newcolor(cm) +struct colormap *cm; +{ + struct colordesc *cd; + struct colordesc *new; + size_t n; + + if (CISERR()) + return COLORLESS; + + if (cm->free != 0) { + assert(cm->free > 0); + assert((size_t)cm->free < cm->ncds); + cd = &cm->cd[cm->free]; + assert(UNUSEDCOLOR(cd)); + assert(cd->arcs == NULL); + cm->free = cd->sub; + } else if (cm->max < cm->ncds - 1) { + cm->max++; + cd = &cm->cd[cm->max]; + } else { + /* oops, must allocate more */ + n = cm->ncds * 2; + if (cm->cd == cm->cdspace) { + new = (struct colordesc *)MALLOC(n * + sizeof(struct colordesc)); + if (new != NULL) + memcpy(VS(new), VS(cm->cdspace), cm->ncds * + sizeof(struct colordesc)); + } else + new = (struct colordesc *)REALLOC(cm->cd, + n * sizeof(struct colordesc)); + if (new == NULL) { + CERR(REG_ESPACE); + return COLORLESS; + } + cm->cd = new; + cm->ncds = n; + assert(cm->max < cm->ncds - 1); + cm->max++; + cd = &cm->cd[cm->max]; + } + + cd->nchrs = 0; + cd->sub = NOSUB; + cd->arcs = NULL; + cd->flags = 0; + cd->block = NULL; + + return (color)(cd - cm->cd); +} + +/* + - freecolor - free a color (must have no arcs or subcolor) + ^ static VOID freecolor(struct colormap *, pcolor); + */ +static VOID +freecolor(cm, co) +struct colormap *cm; +pcolor co; +{ + struct colordesc *cd = &cm->cd[co]; + color pco, nco; /* for freelist scan */ + + assert(co >= 0); + if (co == WHITE) + return; + + assert(cd->arcs == NULL); + assert(cd->sub == NOSUB); + assert(cd->nchrs == 0); + cd->flags = FREECOL; + if (cd->block != NULL) { + FREE(cd->block); + cd->block = NULL; /* just paranoia */ + } + + if ((size_t)co == cm->max) { + while (cm->max > WHITE && UNUSEDCOLOR(&cm->cd[cm->max])) + cm->max--; + assert(cm->max >= 0); + while ((size_t)cm->free > cm->max) + cm->free = cm->cd[cm->free].sub; + if (cm->free > 0) { + assert(cm->free < cm->max); + pco = cm->free; + nco = cm->cd[pco].sub; + while (nco > 0) + if ((size_t)nco > cm->max) { + /* take this one out of freelist */ + nco = cm->cd[nco].sub; + cm->cd[pco].sub = nco; + } else { + assert(nco < cm->max); + pco = nco; + nco = cm->cd[pco].sub; + } + } + } else { + cd->sub = cm->free; + cm->free = (color)(cd - cm->cd); + } +} + +/* + - pseudocolor - allocate a false color, to be managed by other means + ^ static color pseudocolor(struct colormap *); + */ +static color +pseudocolor(cm) +struct colormap *cm; +{ + color co; + + co = newcolor(cm); + if (CISERR()) + return COLORLESS; + cm->cd[co].nchrs = 1; + cm->cd[co].flags = PSEUDO; + return co; +} + +/* + - subcolor - allocate a new subcolor (if necessary) to this chr + ^ static color subcolor(struct colormap *, pchr c); + */ +static color +subcolor(cm, c) +struct colormap *cm; +pchr c; +{ + color co; /* current color of c */ + color sco; /* new subcolor */ + + co = GETCOLOR(cm, c); + sco = newsub(cm, co); + if (sco == COLORLESS) { + return COLORLESS; + } + if (co == sco) /* already in an open subcolor */ + return co; /* rest is redundant */ + cm->cd[co].nchrs--; + cm->cd[sco].nchrs++; + setcolor(cm, c, sco); + return sco; +} + +/* + - newsub - allocate a new subcolor (if necessary) for a color + ^ static color newsub(struct colormap *, pcolor); + */ +static color +newsub(cm, co) +struct colormap *cm; +pcolor co; +{ + color sco; /* new subcolor */ + + sco = cm->cd[co].sub; + if (sco == NOSUB) { /* color has no open subcolor */ + if (cm->cd[co].nchrs == 1) /* optimization */ + return co; + sco = newcolor(cm); /* must create subcolor */ + if (sco == COLORLESS) + return COLORLESS; + cm->cd[co].sub = sco; + cm->cd[sco].sub = sco; /* open subcolor points to self */ + } + assert(sco != NOSUB); + + return sco; +} + +/* + - subrange - allocate new subcolors to this range of chrs, fill in arcs + ^ static VOID subrange(struct vars *, pchr, pchr, struct state *, + ^ struct state *); + */ +static VOID +subrange(v, from, to, lp, rp) +struct vars *v; +pchr from; +pchr to; +struct state *lp; +struct state *rp; +{ + uchr uf; + int i; + + assert(from <= to); + + /* first, align "from" on a tree-block boundary */ + uf = (uchr)from; + i = (int)( ((uf + BYTTAB-1) & (uchr)~BYTMASK) - uf ); + for (; from <= to && i > 0; i--, from++) + newarc(v->nfa, PLAIN, subcolor(v->cm, from), lp, rp); + if (from > to) /* didn't reach a boundary */ + return; + + /* deal with whole blocks */ + for (; to - from >= BYTTAB; from += BYTTAB) + subblock(v, from, lp, rp); + + /* clean up any remaining partial table */ + for (; from <= to; from++) + newarc(v->nfa, PLAIN, subcolor(v->cm, from), lp, rp); +} + +/* + - subblock - allocate new subcolors for one tree block of chrs, fill in arcs + ^ static VOID subblock(struct vars *, pchr, struct state *, struct state *); + */ +static VOID +subblock(v, start, lp, rp) +struct vars *v; +pchr start; /* first of BYTTAB chrs */ +struct state *lp; +struct state *rp; +{ + uchr uc = start; + struct colormap *cm = v->cm; + int shift; + int level; + int i; + int b; + union tree *t; + union tree *cb; + union tree *fillt; + union tree *lastt; + int previ; + int ndone; + color co; + color sco; + + assert((uc & BYTMASK) == 0); + + /* find its color block, making new pointer blocks as needed */ + t = cm->tree; + fillt = NULL; + for (level = 0, shift = BYTBITS * (NBYTS - 1); shift > 0; + level++, shift -= BYTBITS) { + b = (uc >> shift) & BYTMASK; + lastt = t; + t = lastt->tptr[b]; + assert(t != NULL); + fillt = &cm->tree[level+1]; + if (t == fillt && shift > BYTBITS) { /* need new ptr block */ + t = (union tree *)MALLOC(sizeof(struct ptrs)); + if (t == NULL) { + CERR(REG_ESPACE); + return; + } + memcpy(VS(t->tptr), VS(fillt->tptr), + BYTTAB*sizeof(union tree *)); + lastt->tptr[b] = t; + } + } + + /* special cases: fill block or solid block */ + co = t->tcolor[0]; + cb = cm->cd[co].block; + if (t == fillt || t == cb) { + /* either way, we want a subcolor solid block */ + sco = newsub(cm, co); + t = cm->cd[sco].block; + if (t == NULL) { /* must set it up */ + t = (union tree *)MALLOC(sizeof(struct colors)); + if (t == NULL) { + CERR(REG_ESPACE); + return; + } + for (i = 0; i < BYTTAB; i++) + t->tcolor[i] = sco; + cm->cd[sco].block = t; + } + /* find loop must have run at least once */ + lastt->tptr[b] = t; + newarc(v->nfa, PLAIN, sco, lp, rp); + cm->cd[co].nchrs -= BYTTAB; + cm->cd[sco].nchrs += BYTTAB; + return; + } + + /* general case, a mixed block to be altered */ + i = 0; + while (i < BYTTAB) { + co = t->tcolor[i]; + sco = newsub(cm, co); + newarc(v->nfa, PLAIN, sco, lp, rp); + previ = i; + do { + t->tcolor[i++] = sco; + } while (i < BYTTAB && t->tcolor[i] == co); + ndone = i - previ; + cm->cd[co].nchrs -= ndone; + cm->cd[sco].nchrs += ndone; + } +} + +/* + - okcolors - promote subcolors to full colors + ^ static VOID okcolors(struct nfa *, struct colormap *); + */ +static VOID +okcolors(nfa, cm) +struct nfa *nfa; +struct colormap *cm; +{ + struct colordesc *cd; + struct colordesc *end = CDEND(cm); + struct colordesc *scd; + struct arc *a; + color co; + color sco; + + for (cd = cm->cd, co = 0; cd < end; cd++, co++) { + sco = cd->sub; + if (UNUSEDCOLOR(cd) || sco == NOSUB) { + /* has no subcolor, no further action */ + } else if (sco == co) { + /* is subcolor, let parent deal with it */ + } else if (cd->nchrs == 0) { + /* parent empty, its arcs change color to subcolor */ + cd->sub = NOSUB; + scd = &cm->cd[sco]; + assert(scd->nchrs > 0); + assert(scd->sub == sco); + scd->sub = NOSUB; + while ((a = cd->arcs) != NULL) { + assert(a->co == co); + /* uncolorchain(cm, a); */ + cd->arcs = a->colorchain; + a->co = sco; + /* colorchain(cm, a); */ + a->colorchain = scd->arcs; + scd->arcs = a; + } + freecolor(cm, co); + } else { + /* parent's arcs must gain parallel subcolor arcs */ + cd->sub = NOSUB; + scd = &cm->cd[sco]; + assert(scd->nchrs > 0); + assert(scd->sub == sco); + scd->sub = NOSUB; + for (a = cd->arcs; a != NULL; a = a->colorchain) { + assert(a->co == co); + newarc(nfa, a->type, sco, a->from, a->to); + } + } + } +} + +/* + - colorchain - add this arc to the color chain of its color + ^ static VOID colorchain(struct colormap *, struct arc *); + */ +static VOID +colorchain(cm, a) +struct colormap *cm; +struct arc *a; +{ + struct colordesc *cd = &cm->cd[a->co]; + + a->colorchain = cd->arcs; + cd->arcs = a; +} + +/* + - uncolorchain - delete this arc from the color chain of its color + ^ static VOID uncolorchain(struct colormap *, struct arc *); + */ +static VOID +uncolorchain(cm, a) +struct colormap *cm; +struct arc *a; +{ + struct colordesc *cd = &cm->cd[a->co]; + struct arc *aa; + + aa = cd->arcs; + if (aa == a) /* easy case */ + cd->arcs = a->colorchain; + else { + for (; aa != NULL && aa->colorchain != a; aa = aa->colorchain) + continue; + assert(aa != NULL); + aa->colorchain = a->colorchain; + } + a->colorchain = NULL; /* paranoia */ +} + +/* + - singleton - is this character in its own color? + ^ static int singleton(struct colormap *, pchr c); + */ +#if 0 +static int /* predicate */ +singleton(cm, c) +struct colormap *cm; +pchr c; +{ + color co; /* color of c */ + + co = GETCOLOR(cm, c); + if (cm->cd[co].nchrs == 1 && cm->cd[co].sub == NOSUB) + return 1; + return 0; +} +#endif +/* + - rainbow - add arcs of all full colors (but one) between specified states + ^ static VOID rainbow(struct nfa *, struct colormap *, int, pcolor, + ^ struct state *, struct state *); + */ +static VOID +rainbow(nfa, cm, type, but, from, to) +struct nfa *nfa; +struct colormap *cm; +int type; +pcolor but; /* COLORLESS if no exceptions */ +struct state *from; +struct state *to; +{ + struct colordesc *cd; + struct colordesc *end = CDEND(cm); + color co; + + for (cd = cm->cd, co = 0; cd < end && !CISERR(); cd++, co++) + if (!UNUSEDCOLOR(cd) && cd->sub != co && co != but && + !(cd->flags&PSEUDO)) + newarc(nfa, type, co, from, to); +} + +/* + - colorcomplement - add arcs of complementary colors + * The calling sequence ought to be reconciled with cloneouts(). + ^ static VOID colorcomplement(struct nfa *, struct colormap *, int, + ^ struct state *, struct state *, struct state *); + */ +static VOID +colorcomplement(nfa, cm, type, of, from, to) +struct nfa *nfa; +struct colormap *cm; +int type; +struct state *of; /* complements of this guy's PLAIN outarcs */ +struct state *from; +struct state *to; +{ + struct colordesc *cd; + struct colordesc *end = CDEND(cm); + color co; + + assert(of != from); + for (cd = cm->cd, co = 0; cd < end && !CISERR(); cd++, co++) + if (!UNUSEDCOLOR(cd) && !(cd->flags&PSEUDO)) + if (findarc(of, PLAIN, co) == NULL) + newarc(nfa, type, co, from, to); +} + + + +#ifdef REG_DEBUG + +/* + - dumpcolors - debugging output + ^ static VOID dumpcolors(struct colormap *, FILE *); + */ +static VOID +dumpcolors(cm, f) +struct colormap *cm; +FILE *f; +{ + struct colordesc *cd; + struct colordesc *end; + color co; + chr c; + char *has; + + fprintf(f, "max %ld\n", (long)cm->max); + if (NBYTS > 1) + fillcheck(cm, cm->tree, 0, f); + end = CDEND(cm); + for (cd = cm->cd + 1, co = 1; cd < end; cd++, co++) /* skip 0 */ + if (!UNUSEDCOLOR(cd)) { + assert(cd->nchrs > 0); + has = (cd->block != NULL) ? "#" : ""; + if (cd->flags&PSEUDO) + fprintf(f, "#%2ld%s(ps): ", (long)co, has); + else + fprintf(f, "#%2ld%s(%2d): ", (long)co, + has, cd->nchrs); + /* it's hard to do this more efficiently */ + for (c = CHR_MIN; c < CHR_MAX; c++) + if (GETCOLOR(cm, c) == co) + dumpchr(c, f); + assert(c == CHR_MAX); + if (GETCOLOR(cm, c) == co) + dumpchr(c, f); + fprintf(f, "\n"); + } +} + +/* + - fillcheck - check proper filling of a tree + ^ static VOID fillcheck(struct colormap *, union tree *, int, FILE *); + */ +static VOID +fillcheck(cm, tree, level, f) +struct colormap *cm; +union tree *tree; +int level; /* level number (top == 0) of this block */ +FILE *f; +{ + int i; + union tree *t; + union tree *fillt = &cm->tree[level+1]; + + assert(level < NBYTS-1); /* this level has pointers */ + for (i = BYTTAB-1; i >= 0; i--) { + t = tree->tptr[i]; + if (t == NULL) + fprintf(f, "NULL found in filled tree!\n"); + else if (t == fillt) + {} + else if (level < NBYTS-2) /* more pointer blocks below */ + fillcheck(cm, t, level+1, f); + } +} + +/* + - dumpchr - print a chr + * Kind of char-centric but works well enough for debug use. + ^ static VOID dumpchr(pchr, FILE *); + */ +static VOID +dumpchr(c, f) +pchr c; +FILE *f; +{ + if (c == '\\') + fprintf(f, "\\\\"); + else if (c > ' ' && c <= '~') + putc((char)c, f); + else + fprintf(f, "\\u%04lx", (long)c); +} + +#endif /* ifdef REG_DEBUG */ diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c new file mode 100644 index 0000000..c79e741 --- /dev/null +++ b/generic/regc_cvec.c @@ -0,0 +1,170 @@ +/* + * Utility functions for handling cvecs + * This file is #included by regcomp.c. + */ + +/* + - newcvec - allocate a new cvec + ^ static struct cvec *newcvec(int, int, int); + */ +static struct cvec * +newcvec(nchrs, nranges, nmcces) +int nchrs; /* to hold this many chrs... */ +int nranges; /* ... and this many ranges... */ +int nmcces; /* ... and this many MCCEs */ +{ + size_t n; + size_t nc; + struct cvec *cv; + + nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2; + n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *) + + nc*sizeof(chr); + cv = (struct cvec *)MALLOC(n); + if (cv == NULL) + return NULL; + cv->chrspace = nc; + cv->chrs = (chr *)&cv->mcces[nmcces]; /* chrs just after MCCE ptrs */ + cv->mccespace = nmcces; + cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1); + cv->rangespace = nranges; + return clearcvec(cv); +} + +/* + - clearcvec - clear a possibly-new cvec + * Returns pointer as convenience. + ^ static struct cvec *clearcvec(struct cvec *); + */ +static struct cvec * +clearcvec(cv) +struct cvec *cv; +{ + int i; + + assert(cv != NULL); + cv->nchrs = 0; + assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]); + cv->nmcces = 0; + cv->nmccechrs = 0; + cv->nranges = 0; + for (i = 0; i < cv->mccespace; i++) + cv->mcces[i] = NULL; + + return cv; +} + +/* + - addchr - add a chr to a cvec + ^ static VOID addchr(struct cvec *, pchr); + */ +static VOID +addchr(cv, c) +struct cvec *cv; +pchr c; +{ + assert(cv->nchrs < cv->chrspace - cv->nmccechrs); + cv->chrs[cv->nchrs++] = (chr)c; +} + +/* + - addrange - add a range to a cvec + ^ static VOID addrange(struct cvec *, pchr, pchr); + */ +static VOID +addrange(cv, from, to) +struct cvec *cv; +pchr from; +pchr to; +{ + assert(cv->nranges < cv->rangespace); + cv->ranges[cv->nranges*2] = (chr)from; + cv->ranges[cv->nranges*2 + 1] = (chr)to; + cv->nranges++; +} + +#ifdef USE_MCCE +/* + - addmcce - add an MCCE to a cvec + ^ static VOID addmcce(struct cvec *, chr *, chr *); + */ +static VOID +addmcce(cv, startp, endp) +struct cvec *cv; +chr *startp; /* beginning of text */ +chr *endp; /* just past end of text */ +{ + int n = endp - startp; + int i; + chr *s; + chr *d; + + assert(n > 0); + assert(cv->nchrs + n < cv->chrspace - cv->nmccechrs); + assert(cv->nmcces < cv->mccespace); + d = &cv->chrs[cv->chrspace - cv->nmccechrs - n - 1]; + cv->mcces[cv->nmcces++] = d; + for (s = startp, i = n; i > 0; s++, i--) + *d++ = *s; + *d++ = 0; /* endmarker */ + assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]); + cv->nmccechrs += n + 1; +} +#endif + +/* + - haschr - does a cvec contain this chr? + ^ static int haschr(struct cvec *, pchr); + */ +static int /* predicate */ +haschr(cv, c) +struct cvec *cv; +pchr c; +{ + int i; + chr *p; + + for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) + if (*p == c) + return 1; + for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) + if (*p <= c && c <= *(p+1)) + return 1; + return 0; +} + +/* + - getcvec - get a cvec, remembering it as v->cv + ^ static struct cvec *getcvec(struct vars *, int, int, int); + */ +static struct cvec * +getcvec(v, nchrs, nranges, nmcces) +struct vars *v; +int nchrs; /* to hold this many chrs... */ +int nranges; /* ... and this many ranges... */ +int nmcces; /* ... and this many MCCEs */ +{ + if (v->cv != NULL && nchrs <= v->cv->chrspace && + nranges <= v->cv->rangespace && + nmcces <= v->cv->mccespace) + return clearcvec(v->cv); + + if (v->cv != NULL) + freecvec(v->cv); + v->cv = newcvec(nchrs, nranges, nmcces); + if (v->cv == NULL) + ERR(REG_ESPACE); + + return v->cv; +} + +/* + - freecvec - free a cvec + ^ static VOID freecvec(struct cvec *); + */ +static VOID +freecvec(cv) +struct cvec *cv; +{ + FREE(cv); +} diff --git a/generic/regc_lex.c b/generic/regc_lex.c new file mode 100644 index 0000000..5b93e0b --- /dev/null +++ b/generic/regc_lex.c @@ -0,0 +1,1010 @@ +/* + * lexical analyzer + * This file is #included by regcomp.c. + */ + +/* scanning macros (know about v) */ +#define ATEOS() (v->now >= v->stop) +#define HAVE(n) (v->stop - v->now >= (n)) +#define NEXT1(c) (!ATEOS() && *v->now == CHR(c)) +#define NEXT2(a,b) (HAVE(2) && *v->now == CHR(a) && *(v->now+1) == CHR(b)) +#define NEXT3(a,b,c) (HAVE(3) && *v->now == CHR(a) && \ + *(v->now+1) == CHR(b) && \ + *(v->now+2) == CHR(c)) +#define SET(c) (v->nexttype = (c)) +#define SETV(c, n) (v->nexttype = (c), v->nextvalue = (n)) +#define RET(c) return (SET(c), 1) +#define RETV(c, n) return (SETV(c, n), 1) +#define FAILW(e) return (ERR(e), 0) /* ERR does SET(EOS) */ +#define LASTTYPE(t) (v->lasttype == (t)) + +/* lexical contexts */ +#define L_ERE 1 /* mainline ERE/ARE */ +#define L_BRE 2 /* mainline BRE */ +#define L_Q 3 /* REG_QUOTE */ +#define L_EBND 4 /* ERE/ARE bound */ +#define L_BBND 5 /* BRE bound */ +#define L_BRACK 6 /* brackets */ +#define L_CEL 7 /* collating element */ +#define L_ECL 8 /* equivalence class */ +#define L_CCL 9 /* character class */ +#define INTOCON(c) (v->lexcon = (c)) +#define INCON(con) (v->lexcon == (con)) + +/* construct pointer past end of chr array */ +#define ENDOF(array) ((array) + sizeof(array)/sizeof(chr)) + +/* + - lexstart - set up lexical stuff, scan leading options + ^ static VOID lexstart(struct vars *); + */ +static VOID +lexstart(v) +struct vars *v; +{ + prefixes(v); /* may turn on new type bits etc. */ + NOERR(); + + if (v->cflags®_QUOTE) { + assert(!(v->cflags&(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE))); + INTOCON(L_Q); + } else if (v->cflags®_EXTENDED) { + assert(!(v->cflags®_QUOTE)); + INTOCON(L_ERE); + } else { + assert(!(v->cflags&(REG_QUOTE|REG_ADVF))); + INTOCON(L_BRE); + } + + v->nexttype = EMPTY; /* remember we were at the start */ + next(v); /* set up the first token */ +} + +/* + - prefixes - implement various special prefixes + ^ static VOID prefixes(struct vars *); + */ +static VOID +prefixes(v) +struct vars *v; +{ + /* literal string doesn't get any of this stuff */ + if (v->cflags®_QUOTE) + return; + + /* initial "***" gets special things */ + if (HAVE(4) && NEXT3('*', '*', '*')) + switch (*(v->now + 3)) { + case CHR('?'): /* "***?" error, msg shows version */ + ERR(REG_BADPAT); + return; /* proceed no further */ + break; + case CHR('='): /* "***=" shifts to literal string */ + NOTE(REG_UNONPOSIX); + v->cflags |= REG_QUOTE; + v->cflags &= ~(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE); + v->now += 4; + return; /* and there can be no more prefixes */ + break; + case CHR(':'): /* "***:" shifts to AREs */ + NOTE(REG_UNONPOSIX); + v->cflags |= REG_ADVANCED; + v->now += 4; + break; + default: /* otherwise *** is just an error */ + ERR(REG_BADRPT); + return; + break; + } + + /* BREs and EREs don't get embedded options */ + if ((v->cflags®_ADVANCED) != REG_ADVANCED) + return; + + /* embedded options (AREs only) */ + if (HAVE(3) && NEXT2('(', '?') && iscalpha(*(v->now + 2))) { + NOTE(REG_UNONPOSIX); + v->now += 2; + for (; !ATEOS() && iscalpha(*v->now); v->now++) + switch (*v->now) { + case CHR('b'): /* BREs (but why???) */ + v->cflags &= ~(REG_ADVANCED|REG_QUOTE); + break; + case CHR('c'): /* case sensitive */ + v->cflags &= ~REG_ICASE; + break; + case CHR('e'): /* plain EREs */ + v->cflags |= REG_EXTENDED; + v->cflags &= ~(REG_ADVF|REG_QUOTE); + break; + case CHR('i'): /* case insensitive */ + v->cflags |= REG_ICASE; + break; + case CHR('m'): /* Perloid synonym for n */ + case CHR('n'): /* \n affects ^ $ . [^ */ + v->cflags |= REG_NEWLINE; + break; + case CHR('p'): /* ~Perl, \n affects . [^ */ + v->cflags |= REG_NLSTOP; + v->cflags &= ~REG_NLANCH; + break; + case CHR('q'): /* literal string */ + v->cflags |= REG_QUOTE; + v->cflags &= ~REG_ADVANCED; + break; + case CHR('s'): /* single line, \n ordinary */ + v->cflags &= ~REG_NEWLINE; + break; + case CHR('t'): /* tight syntax */ + v->cflags &= ~REG_EXPANDED; + break; + case CHR('w'): /* weird, \n affects ^ $ only */ + v->cflags &= ~REG_NLSTOP; + v->cflags |= REG_NLANCH; + break; + case CHR('x'): /* expanded syntax */ + v->cflags |= REG_EXPANDED; + break; + default: + ERR(REG_BADOPT); + return; + } + if (!NEXT1(')')) { + ERR(REG_BADOPT); + return; + } + v->now++; + if (v->cflags®_QUOTE) + v->cflags &= ~(REG_EXPANDED|REG_NEWLINE); + } +} + +/* + - lexnest - "call a subroutine", interpolating string at the lexical level + * Note, this is not a very general facility. There are a number of + * implicit assumptions about what sorts of strings can be subroutines. + ^ static VOID lexnest(struct vars *, chr *, chr *); + */ +static VOID +lexnest(v, beginp, endp) +struct vars *v; +chr *beginp; /* start of interpolation */ +chr *endp; /* one past end of interpolation */ +{ + assert(v->savenow == NULL); /* only one level of nesting */ + v->savenow = v->now; + v->savestop = v->stop; + v->now = beginp; + v->stop = endp; +} + +/* + * string constants to interpolate as expansions of things like \d + */ +static chr backd[] = { /* \d */ + CHR('['), CHR('['), CHR(':'), + CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'), + CHR(':'), CHR(']'), CHR(']') +}; +static chr backD[] = { /* \D */ + CHR('['), CHR('^'), CHR('['), CHR(':'), + CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'), + CHR(':'), CHR(']'), CHR(']') +}; +static chr brbackd[] = { /* \d within brackets */ + CHR('['), CHR(':'), + CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'), + CHR(':'), CHR(']') +}; +static chr backs[] = { /* \s */ + CHR('['), CHR('['), CHR(':'), + CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'), + CHR(':'), CHR(']'), CHR(']') +}; +static chr backS[] = { /* \S */ + CHR('['), CHR('^'), CHR('['), CHR(':'), + CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'), + CHR(':'), CHR(']'), CHR(']') +}; +static chr brbacks[] = { /* \s within brackets */ + CHR('['), CHR(':'), + CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'), + CHR(':'), CHR(']') +}; +static chr backw[] = { /* \w */ + CHR('['), CHR('['), CHR(':'), + CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), + CHR(':'), CHR(']'), CHR('_'), CHR(']') +}; +static chr backW[] = { /* \W */ + CHR('['), CHR('^'), CHR('['), CHR(':'), + CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), + CHR(':'), CHR(']'), CHR('_'), CHR(']') +}; +static chr brbackw[] = { /* \w within brackets */ + CHR('['), CHR(':'), + CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), + CHR(':'), CHR(']'), CHR('_') +}; + +/* + - lexword - interpolate a bracket expression for word characters + * Possibly ought to inquire whether there is a "word" character class. + ^ static VOID lexword(struct vars *); + */ +static VOID +lexword(v) +struct vars *v; +{ + lexnest(v, backw, ENDOF(backw)); +} + +/* + - next - get next token + ^ static int next(struct vars *); + */ +static int /* 1 normal, 0 failure */ +next(v) +struct vars *v; +{ + chr c; + + /* errors yield an infinite sequence of failures */ + if (ISERR()) + return 0; /* the error has set nexttype to EOS */ + + /* remember flavor of last token */ + v->lasttype = v->nexttype; + + /* if we're nested and we've hit end, return to outer level */ + if (v->savenow != NULL && ATEOS()) { + v->now = v->savenow; + v->stop = v->savestop; + v->savenow = v->savestop = NULL; + } + + /* skip white space etc. if appropriate (not in literal or []) */ + if (v->cflags®_EXPANDED) + switch (v->lexcon) { + case L_ERE: + case L_BRE: + case L_EBND: + case L_BBND: + skip(v); + break; + } + + /* handle EOS, depending on context */ + if (ATEOS()) { + switch (v->lexcon) { + case L_ERE: + case L_BRE: + case L_Q: + RET(EOS); + break; + case L_EBND: + case L_BBND: + FAILW(REG_EBRACE); + break; + case L_BRACK: + case L_CEL: + case L_ECL: + case L_CCL: + FAILW(REG_EBRACK); + break; + } + assert(NOTREACHED); + } + + /* okay, time to actually get a character */ + c = *v->now++; + + /* deal with the easy contexts, punt EREs to code below */ + switch (v->lexcon) { + case L_BRE: /* punt BREs to separate function */ + return brenext(v, c); + break; + case L_ERE: /* see below */ + break; + case L_Q: /* literal strings are easy */ + RETV(PLAIN, c); + break; + case L_BBND: /* bounds are fairly simple */ + case L_EBND: + switch (c) { + case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'): + case CHR('4'): case CHR('5'): case CHR('6'): case CHR('7'): + case CHR('8'): case CHR('9'): + RETV(DIGIT, (chr)DIGITVAL(c)); + break; + case CHR(','): + RET(','); + break; + case CHR('}'): /* ERE bound ends with } */ + if (INCON(L_EBND)) { + INTOCON(L_ERE); + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('}', 0); + } + RETV('}', 1); + } else + FAILW(REG_BADBR); + break; + case CHR('\\'): /* BRE bound ends with \} */ + if (INCON(L_BBND) && NEXT1('}')) { + v->now++; + INTOCON(L_BRE); + RET('}'); + } else + FAILW(REG_BADBR); + break; + default: + FAILW(REG_BADBR); + break; + } + assert(NOTREACHED); + break; + case L_BRACK: /* brackets are not too hard */ + switch (c) { + case CHR(']'): + if (LASTTYPE('[')) + RETV(PLAIN, c); + else { + INTOCON((v->cflags®_EXTENDED) ? + L_ERE : L_BRE); + RET(']'); + } + break; + case CHR('\\'): + NOTE(REG_UBBS); + if (!(v->cflags®_ADVF)) + RETV(PLAIN, c); + NOTE(REG_UNONPOSIX); + if (ATEOS()) + FAILW(REG_EESCAPE); + (DISCARD)lexescape(v); + switch (v->nexttype) { /* not all escapes okay here */ + case PLAIN: + return 1; + break; + case CCLASS: + switch (v->nextvalue) { + case 'd': + lexnest(v, brbackd, ENDOF(brbackd)); + break; + case 's': + lexnest(v, brbacks, ENDOF(brbacks)); + break; + case 'w': + lexnest(v, brbackw, ENDOF(brbackw)); + break; + default: + FAILW(REG_EESCAPE); + break; + } + /* lexnest done, back up and try again */ + v->nexttype = v->lasttype; + return next(v); + break; + } + /* not one of the acceptable escapes */ + FAILW(REG_EESCAPE); + break; + case CHR('-'): + if (LASTTYPE('[') || NEXT1(']')) + RETV(PLAIN, c); + else + RETV(RANGE, c); + break; + case CHR('['): + if (ATEOS()) + FAILW(REG_EBRACK); + switch (*v->now++) { + case CHR('.'): + INTOCON(L_CEL); + /* might or might not be locale-specific */ + RET(COLLEL); + break; + case CHR('='): + INTOCON(L_ECL); + NOTE(REG_ULOCALE); + RET(ECLASS); + break; + case CHR(':'): + INTOCON(L_CCL); + NOTE(REG_ULOCALE); + RET(CCLASS); + break; + default: /* oops */ + v->now--; + RETV(PLAIN, c); + break; + } + assert(NOTREACHED); + break; + default: + RETV(PLAIN, c); + break; + } + assert(NOTREACHED); + break; + case L_CEL: /* collating elements are easy */ + if (c == CHR('.') && NEXT1(']')) { + v->now++; + INTOCON(L_BRACK); + RETV(END, '.'); + } else + RETV(PLAIN, c); + break; + case L_ECL: /* ditto equivalence classes */ + if (c == CHR('=') && NEXT1(']')) { + v->now++; + INTOCON(L_BRACK); + RETV(END, '='); + } else + RETV(PLAIN, c); + break; + case L_CCL: /* ditto character classes */ + if (c == CHR(':') && NEXT1(']')) { + v->now++; + INTOCON(L_BRACK); + RETV(END, ':'); + } else + RETV(PLAIN, c); + break; + default: + assert(NOTREACHED); + break; + } + + /* that got rid of everything except EREs and AREs */ + assert(INCON(L_ERE)); + + /* deal with EREs and AREs, except for backslashes */ + switch (c) { + case CHR('|'): + RET('|'); + break; + case CHR('*'): + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('*', 0); + } + RETV('*', 1); + break; + case CHR('+'): + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('+', 0); + } + RETV('+', 1); + break; + case CHR('?'): + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('?', 0); + } + RETV('?', 1); + break; + case CHR('{'): /* bounds start or plain character */ + if (v->cflags®_EXPANDED) + skip(v); + if (ATEOS() || !iscdigit(*v->now)) { + NOTE(REG_UBRACES); + NOTE(REG_UUNSPEC); + RETV(PLAIN, c); + } else { + NOTE(REG_UBOUNDS); + INTOCON(L_EBND); + RET('{'); + } + assert(NOTREACHED); + break; + case CHR('('): /* parenthesis, or advanced extension */ + if ((v->cflags®_ADVF) && NEXT1('?')) { + NOTE(REG_UNONPOSIX); + v->now++; + switch (*v->now++) { + case CHR(':'): /* non-capturing paren */ + RETV('(', 0); + break; + case CHR('#'): /* comment */ + while (!ATEOS() && *v->now != CHR(')')) + v->now++; + if (!ATEOS()) + v->now++; + assert(v->nexttype == v->lasttype); + return next(v); + break; + case CHR('='): /* positive lookahead */ + NOTE(REG_ULOOKAHEAD); + RETV(LACON, 1); + break; + case CHR('!'): /* negative lookahead */ + NOTE(REG_ULOOKAHEAD); + RETV(LACON, 0); + break; + default: + FAILW(REG_BADRPT); + break; + } + assert(NOTREACHED); + } + if (v->cflags®_NOSUB) + RETV('(', 0); /* all parens non-capturing */ + else + RETV('(', 1); + break; + case CHR(')'): + if (LASTTYPE('(')) { + NOTE(REG_UUNSPEC); + } + RETV(')', c); + break; + case CHR('['): /* easy except for [[:<:]] and [[:>:]] */ + if (HAVE(6) && *(v->now+0) == CHR('[') && + *(v->now+1) == CHR(':') && + (*(v->now+2) == CHR('<') || + *(v->now+2) == CHR('>')) && + *(v->now+3) == CHR(':') && + *(v->now+4) == CHR(']') && + *(v->now+5) == CHR(']')) { + c = *(v->now+2); + v->now += 6; + NOTE(REG_UNONPOSIX); + RET((c == CHR('<')) ? '<' : '>'); + } + INTOCON(L_BRACK); + if (NEXT1('^')) { + v->now++; + RETV('[', 0); + } + RETV('[', 1); + break; + case CHR('.'): + RET('.'); + break; + case CHR('^'): + RET('^'); + break; + case CHR('$'): + RET('$'); + break; + case CHR('\\'): /* mostly punt backslashes to code below */ + if (ATEOS()) + FAILW(REG_EESCAPE); + break; + default: /* ordinary character */ + RETV(PLAIN, c); + break; + } + + /* ERE/ARE backslash handling; backslash already eaten */ + assert(!ATEOS()); + if (!(v->cflags®_ADVF)) { /* only AREs have non-trivial escapes */ + if (iscalnum(*v->now)) { + NOTE(REG_UBSALNUM); + NOTE(REG_UUNSPEC); + } + RETV(PLAIN, *v->now++); + } + (DISCARD)lexescape(v); + if (ISERR()) + FAILW(REG_EESCAPE); + if (v->nexttype == CCLASS) { /* fudge at lexical level */ + switch (v->nextvalue) { + case 'd': lexnest(v, backd, ENDOF(backd)); break; + case 'D': lexnest(v, backD, ENDOF(backD)); break; + case 's': lexnest(v, backs, ENDOF(backs)); break; + case 'S': lexnest(v, backS, ENDOF(backS)); break; + case 'w': lexnest(v, backw, ENDOF(backw)); break; + case 'W': lexnest(v, backW, ENDOF(backW)); break; + default: + assert(NOTREACHED); + FAILW(REG_ASSERT); + break; + } + /* lexnest done, back up and try again */ + v->nexttype = v->lasttype; + return next(v); + } + /* otherwise, lexescape has already done the work */ + return !ISERR(); +} + +/* + - lexescape - parse an ARE backslash escape (backslash already eaten) + * Note slightly nonstandard use of the CCLASS type code. + ^ static int lexescape(struct vars *); + */ +static int /* not actually used, but convenient for RETV */ +lexescape(v) +struct vars *v; +{ + chr c; + static chr alert[] = { + CHR('a'), CHR('l'), CHR('e'), CHR('r'), CHR('t') + }; + static chr esc[] = { + CHR('E'), CHR('S'), CHR('C') + }; + chr *save; + + assert(v->cflags®_ADVF); + + assert(!ATEOS()); + c = *v->now++; + if (!iscalnum(c)) + RETV(PLAIN, c); + + NOTE(REG_UNONPOSIX); + switch (c) { + case CHR('a'): + RETV(PLAIN, chrnamed(v, alert, ENDOF(alert), CHR('\007'))); + break; + case CHR('A'): + RETV(SBEGIN, 0); + break; + case CHR('b'): + RETV(PLAIN, CHR('\b')); + break; + case CHR('B'): + RETV(PLAIN, CHR('\\')); + break; + case CHR('c'): + NOTE(REG_UUNPORT); + if (ATEOS()) + FAILW(REG_EESCAPE); + RETV(PLAIN, (chr)(*v->now++ & 037)); + break; + case CHR('d'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'd'); + break; + case CHR('D'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'D'); + break; + case CHR('e'): + NOTE(REG_UUNPORT); + RETV(PLAIN, chrnamed(v, esc, ENDOF(esc), CHR('\033'))); + break; + case CHR('f'): + RETV(PLAIN, CHR('\f')); + break; + case CHR('m'): + RET('<'); + break; + case CHR('M'): + RET('>'); + break; + case CHR('n'): + RETV(PLAIN, CHR('\n')); + break; + case CHR('r'): + RETV(PLAIN, CHR('\r')); + break; + case CHR('s'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 's'); + break; + case CHR('S'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'S'); + break; + case CHR('t'): + RETV(PLAIN, CHR('\t')); + break; + case CHR('u'): + c = lexdigits(v, 16, 4, 4); + if (ISERR()) + FAILW(REG_EESCAPE); + RETV(PLAIN, c); + break; + case CHR('U'): + c = lexdigits(v, 16, 8, 8); + if (ISERR()) + FAILW(REG_EESCAPE); + RETV(PLAIN, c); + break; + case CHR('v'): + RETV(PLAIN, CHR('\v')); + break; + case CHR('w'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'w'); + break; + case CHR('W'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'W'); + break; + case CHR('x'): + NOTE(REG_UUNPORT); + c = lexdigits(v, 16, 1, 255); /* REs >255 long outside spec */ + if (ISERR()) + FAILW(REG_EESCAPE); + RETV(PLAIN, c); + break; + case CHR('y'): + NOTE(REG_ULOCALE); + RETV(WBDRY, 0); + break; + case CHR('Y'): + NOTE(REG_ULOCALE); + RETV(NWBDRY, 0); + break; + case CHR('Z'): + RETV(SEND, 0); + break; + case CHR('1'): case CHR('2'): case CHR('3'): case CHR('4'): + case CHR('5'): case CHR('6'): case CHR('7'): case CHR('8'): + case CHR('9'): + save = v->now; + v->now--; /* put first digit back */ + c = lexdigits(v, 10, 1, 255); /* REs >255 long outside spec */ + if (ISERR()) + FAILW(REG_EESCAPE); + /* ugly heuristic (first test is "exactly 1 digit?") */ + if (v->now - save == 0 || (int)c <= v->nsubexp) { + NOTE(REG_UBACKREF); + RETV(BACKREF, (chr)c); + } + /* oops, doesn't look like it's a backref after all... */ + v->now = save; + /* and fall through into octal number */ + case CHR('0'): + NOTE(REG_UUNPORT); + v->now--; /* put first digit back */ + c = lexdigits(v, 8, 1, 3); + if (ISERR()) + FAILW(REG_EESCAPE); + RETV(PLAIN, c); + break; + default: + assert(iscalpha(c)); + FAILW(REG_EESCAPE); /* unknown alphabetic escape */ + break; + } + assert(NOTREACHED); +} + +/* + - lexdigits - slurp up digits and return chr value + ^ static chr lexdigits(struct vars *, int, int, int); + */ +static chr /* chr value; errors signalled via ERR */ +lexdigits(v, base, minlen, maxlen) +struct vars *v; +int base; +int minlen; +int maxlen; +{ + uchr n; /* unsigned to avoid overflow misbehavior */ + int len; + chr c; + int d; + CONST uchr ub = (uchr) base; + + n = 0; + for (len = 0; len < maxlen && !ATEOS(); len++) { + c = *v->now++; + switch (c) { + case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'): + case CHR('4'): case CHR('5'): case CHR('6'): case CHR('7'): + case CHR('8'): case CHR('9'): + d = DIGITVAL(c); + break; + case CHR('a'): case CHR('A'): d = 10; break; + case CHR('b'): case CHR('B'): d = 11; break; + case CHR('c'): case CHR('C'): d = 12; break; + case CHR('d'): case CHR('D'): d = 13; break; + case CHR('e'): case CHR('E'): d = 14; break; + case CHR('f'): case CHR('F'): d = 15; break; + default: + v->now--; /* oops, not a digit at all */ + d = -1; + break; + } + + if (d >= base) { /* not a plausible digit */ + v->now--; + d = -1; + } + if (d < 0) + break; /* NOTE BREAK OUT */ + n = n*ub + (uchr)d; + } + if (len < minlen) + ERR(REG_EESCAPE); + + return (chr)n; +} + +/* + - brenext - get next BRE token + * This is much like EREs except for all the stupid backslashes and the + * context-dependency of some things. + ^ static int brenext(struct vars *, pchr); + */ +static int /* 1 normal, 0 failure */ +brenext(v, pc) +struct vars *v; +pchr pc; +{ + chr c = (chr)pc; + + switch (c) { + case CHR('*'): + if (LASTTYPE(EMPTY) || LASTTYPE('(') || LASTTYPE('^')) + RETV(PLAIN, c); + RET('*'); + break; + case CHR('['): + if (HAVE(6) && *(v->now+0) == CHR('[') && + *(v->now+1) == CHR(':') && + (*(v->now+2) == CHR('<') || + *(v->now+2) == CHR('>')) && + *(v->now+3) == CHR(':') && + *(v->now+4) == CHR(']') && + *(v->now+5) == CHR(']')) { + c = *(v->now+2); + v->now += 6; + NOTE(REG_UNONPOSIX); + RET((c == CHR('<')) ? '<' : '>'); + } + INTOCON(L_BRACK); + if (NEXT1('^')) { + v->now++; + RETV('[', 0); + } + RETV('[', 1); + break; + case CHR('.'): + RET('.'); + break; + case CHR('^'): + if (LASTTYPE(EMPTY)) + RET('^'); + if (LASTTYPE('(')) { + NOTE(REG_UUNSPEC); + RET('^'); + } + RETV(PLAIN, c); + break; + case CHR('$'): + if (v->cflags®_EXPANDED) + skip(v); + if (ATEOS()) + RET('$'); + if (NEXT2('\\', ')')) { + NOTE(REG_UUNSPEC); + RET('$'); + } + RETV(PLAIN, c); + break; + case CHR('\\'): + break; /* see below */ + default: + RETV(PLAIN, c); + break; + } + + assert(c == CHR('\\')); + + if (ATEOS()) + FAILW(REG_EESCAPE); + + c = *v->now++; + switch (c) { + case CHR('{'): + INTOCON(L_BBND); + NOTE(REG_UBOUNDS); + RET('{'); + break; + case CHR('('): + RETV('(', 1); + break; + case CHR(')'): + RETV(')', c); + break; + case CHR('<'): + NOTE(REG_UNONPOSIX); + RET('<'); + break; + case CHR('>'): + NOTE(REG_UNONPOSIX); + RET('>'); + break; + case CHR('1'): case CHR('2'): case CHR('3'): case CHR('4'): + case CHR('5'): case CHR('6'): case CHR('7'): case CHR('8'): + case CHR('9'): + NOTE(REG_UBACKREF); + RETV(BACKREF, (chr)DIGITVAL(c)); + break; + default: + if (iscalnum(c)) { + NOTE(REG_UBSALNUM); + NOTE(REG_UUNSPEC); + } + RETV(PLAIN, c); + break; + } + + assert(NOTREACHED); +} + +/* + - skip - skip white space and comments in expanded form + ^ static VOID skip(struct vars *); + */ +static VOID +skip(v) +struct vars *v; +{ + chr *start = v->now; + + assert(v->cflags®_EXPANDED); + + for (;;) { + while (!ATEOS() && iscspace(*v->now)) + v->now++; + if (ATEOS() || *v->now != CHR('#')) + break; /* NOTE BREAK OUT */ + assert(NEXT1('#')); + while (!ATEOS() && *v->now != CHR('\n')) + v->now++; + /* leave the newline to be picked up by the iscspace loop */ + } + + if (v->now != start) + NOTE(REG_UNONPOSIX); +} + +/* + - newline - return the chr for a newline + * This helps confine use of CHR to this source file. + ^ static chr newline(NOPARMS); + */ +static chr +newline() +{ + return CHR('\n'); +} + +/* + - chrnamed - return the chr known by a given (chr string) name + * The code is a bit clumsy, but this routine gets only such specialized + * use that it hardly matters. + ^ static chr chrnamed(struct vars *, chr *, chr *, pchr); + */ +static chr +chrnamed(v, startp, endp, lastresort) +struct vars *v; +chr *startp; /* start of name */ +chr *endp; /* just past end of name */ +pchr lastresort; /* what to return if name lookup fails */ +{ + celt c; + int errsave; + int e; + struct cvec *cv; + + errsave = v->err; + v->err = 0; + c = element(v, startp, endp); + e = v->err; + v->err = errsave; + + if (e != 0) + return (chr)lastresort; + + cv = range(v, c, c, 0); + if (cv->nchrs == 0) + return (chr)lastresort; + return cv->chrs[0]; +} diff --git a/generic/regc_locale.c b/generic/regc_locale.c new file mode 100644 index 0000000..82e83e2 --- /dev/null +++ b/generic/regc_locale.c @@ -0,0 +1,781 @@ +/* + * regc_locale.c -- + * + * This file contains the Unicode locale specific regexp routines. + * This file is #included by regcomp.c. + * + * Copyright (c) 1998 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: regc_locale.c,v 1.2 1999/04/16 00:46:37 stanton Exp $ + */ + +/* ASCII character-name table */ + +static struct cname { + char *name; + char code; +} cnames[] = { + {"NUL", '\0'}, + {"SOH", '\001'}, + {"STX", '\002'}, + {"ETX", '\003'}, + {"EOT", '\004'}, + {"ENQ", '\005'}, + {"ACK", '\006'}, + {"BEL", '\007'}, + {"alert", '\007'}, + {"BS", '\010'}, + {"backspace", '\b'}, + {"HT", '\011'}, + {"tab", '\t'}, + {"LF", '\012'}, + {"newline", '\n'}, + {"VT", '\013'}, + {"vertical-tab", '\v'}, + {"FF", '\014'}, + {"form-feed", '\f'}, + {"CR", '\015'}, + {"carriage-return", '\r'}, + {"SO", '\016'}, + {"SI", '\017'}, + {"DLE", '\020'}, + {"DC1", '\021'}, + {"DC2", '\022'}, + {"DC3", '\023'}, + {"DC4", '\024'}, + {"NAK", '\025'}, + {"SYN", '\026'}, + {"ETB", '\027'}, + {"CAN", '\030'}, + {"EM", '\031'}, + {"SUB", '\032'}, + {"ESC", '\033'}, + {"IS4", '\034'}, + {"FS", '\034'}, + {"IS3", '\035'}, + {"GS", '\035'}, + {"IS2", '\036'}, + {"RS", '\036'}, + {"IS1", '\037'}, + {"US", '\037'}, + {"space", ' '}, + {"exclamation-mark", '!'}, + {"quotation-mark", '"'}, + {"number-sign", '#'}, + {"dollar-sign", '$'}, + {"percent-sign", '%'}, + {"ampersand", '&'}, + {"apostrophe", '\''}, + {"left-parenthesis", '('}, + {"right-parenthesis", ')'}, + {"asterisk", '*'}, + {"plus-sign", '+'}, + {"comma", ','}, + {"hyphen", '-'}, + {"hyphen-minus", '-'}, + {"period", '.'}, + {"full-stop", '.'}, + {"slash", '/'}, + {"solidus", '/'}, + {"zero", '0'}, + {"one", '1'}, + {"two", '2'}, + {"three", '3'}, + {"four", '4'}, + {"five", '5'}, + {"six", '6'}, + {"seven", '7'}, + {"eight", '8'}, + {"nine", '9'}, + {"colon", ':'}, + {"semicolon", ';'}, + {"less-than-sign", '<'}, + {"equals-sign", '='}, + {"greater-than-sign", '>'}, + {"question-mark", '?'}, + {"commercial-at", '@'}, + {"left-square-bracket", '['}, + {"backslash", '\\'}, + {"reverse-solidus", '\\'}, + {"right-square-bracket", ']'}, + {"circumflex", '^'}, + {"circumflex-accent", '^'}, + {"underscore", '_'}, + {"low-line", '_'}, + {"grave-accent", '`'}, + {"left-brace", '{'}, + {"left-curly-bracket", '{'}, + {"vertical-line", '|'}, + {"right-brace", '}'}, + {"right-curly-bracket", '}'}, + {"tilde", '~'}, + {"DEL", '\177'}, + {NULL, 0} +}; + +/* Unicode character-class tables */ + +typedef struct crange { + chr start; + chr end; +} crange; + +static crange alphaTable[] = { + {0X0041, 0X005A}, {0X0061, 0X007A}, {0X00AA, 0X00AA}, {0X00B5, 0X00B5}, + {0X00BA, 0X00BA}, {0X00C0, 0X00D6}, {0X00D8, 0X00F6}, {0X00F8, 0X01F5}, + {0X01FA, 0X0217}, {0X0250, 0X02A8}, {0X02B0, 0X02B8}, {0X02BB, 0X02C1}, + {0X02E0, 0X02E4}, {0X037A, 0X037A}, {0x0386, 0x0386}, {0X0388, 0X038A}, + {0X038C, 0X038C}, {0X038E, 0X03A1}, {0X03A3, 0X03CE}, {0X03D0, 0X03D6}, + {0X03DA, 0X03DA}, {0X03DC, 0X03DC}, {0X03DE, 0X03DE}, {0X03E0, 0X03E0}, + {0X03E2, 0X03F3}, {0X0401, 0X040C}, {0X040E, 0X044F}, {0X0451, 0X045C}, + {0X045E, 0X0481}, {0X0490, 0X04C4}, {0X04C7, 0X04C8}, {0X04CB, 0X04CC}, + {0X04D0, 0X04EB}, {0X04EE, 0X04F5}, {0X04F8, 0X04F9}, {0x0531, 0x0556}, + {0x0559, 0x0559}, {0x0561, 0x0587}, {0X05D0, 0X05EA}, {0X05F0, 0X05F2}, + {0X0621, 0X063A}, {0x0641, 0x0652}, {0X0670, 0X06B7}, {0X06BA, 0X06BE}, + {0X06C0, 0X06CE}, {0X06D0, 0X06D3}, {0X06D5, 0X06DC}, {0X06E1, 0X06E8}, + {0X06ED, 0X06ED}, {0x0901, 0x0903}, {0x0905, 0x0939}, {0X093D, 0X094C}, + {0x0958, 0x0963}, {0x0981, 0x0983}, {0X0985, 0X098C}, {0X098F, 0X0990}, + {0X0993, 0X09A8}, {0X09AA, 0X09B0}, {0X09B2, 0X09B2}, {0X09B6, 0X09B9}, + {0X09BE, 0X09C4}, {0X09C7, 0X09C8}, {0X09CB, 0X09CC}, {0X09D7, 0X09D7}, + {0X09DC, 0X09DD}, {0X09DF, 0X09E3}, {0X09F0, 0X09F1}, {0X0A02, 0X0A02}, + {0X0A05, 0X0A0A}, {0X0A0F, 0X0A10}, {0X0A13, 0X0A28}, {0X0A2A, 0X0A30}, + {0X0A32, 0X0A33}, {0X0A35, 0X0A36}, {0X0A38, 0X0A39}, {0X0A3E, 0X0A42}, + {0X0A47, 0X0A48}, {0X0A4B, 0X0A4C}, {0X0A59, 0X0A5C}, {0X0A5E, 0X0A5E}, + {0X0A70, 0X0A74}, {0X0A81, 0X0A83}, {0X0A85, 0X0A8B}, {0X0A8D, 0X0A8D}, + {0X0A8F, 0X0A91}, {0X0A93, 0X0AA8}, {0X0AAA, 0X0AB0}, {0X0AB2, 0X0AB3}, + {0X0AB5, 0X0AB9}, {0X0ABD, 0X0AC5}, {0X0AC7, 0X0AC9}, {0X0ACB, 0X0ACC}, + {0X0AE0, 0X0AE0}, {0X0B01, 0X0B03}, {0X0B05, 0X0B0C}, {0X0B0F, 0X0B10}, + {0X0B13, 0X0B28}, {0X0B2A, 0X0B30}, {0X0B32, 0X0B33}, {0X0B36, 0X0B39}, + {0X0B3D, 0X0B43}, {0X0B47, 0X0B48}, {0X0B4B, 0X0B4C}, {0X0B56, 0X0B57}, + {0X0B5C, 0X0B5D}, {0X0B5F, 0X0B61}, {0X0B82, 0X0B83}, {0X0B85, 0X0B8A}, + {0X0B8E, 0X0B90}, {0X0B92, 0X0B95}, {0X0B99, 0X0B9A}, {0X0B9C, 0X0B9C}, + {0X0B9E, 0X0B9F}, {0X0BA3, 0X0BA4}, {0X0BA8, 0X0BAA}, {0X0BAE, 0X0BB5}, + {0X0BB7, 0X0BB9}, {0X0BBE, 0X0BC2}, {0X0BC6, 0X0BC8}, {0X0BCA, 0X0BCC}, + {0X0BD7, 0X0BD7}, {0X0C01, 0X0C03}, {0X0C05, 0X0C0C}, {0X0C0E, 0X0C10}, + {0X0C12, 0X0C28}, {0X0C2A, 0X0C33}, {0X0C35, 0X0C39}, {0X0C3E, 0X0C44}, + {0X0C46, 0X0C48}, {0X0C4A, 0X0C4C}, {0X0C55, 0X0C56}, {0X0C60, 0X0C61}, + {0X0C82, 0X0C83}, {0X0C85, 0X0C8C}, {0X0C8E, 0X0C90}, {0X0C92, 0X0CA8}, + {0X0CAA, 0X0CB3}, {0X0CB5, 0X0CB9}, {0X0CBE, 0X0CC4}, {0X0CC6, 0X0CC8}, + {0X0CCA, 0X0CCC}, {0X0CD5, 0X0CD6}, {0X0CDE, 0X0CDE}, {0X0CE0, 0X0CE1}, + {0X0D02, 0X0D03}, {0X0D05, 0X0D0C}, {0X0D0E, 0X0D10}, {0X0D12, 0X0D28}, + {0X0D2A, 0X0D39}, {0X0D3E, 0X0D43}, {0X0D46, 0X0D48}, {0X0D4A, 0X0D4C}, + {0X0D57, 0X0D57}, {0X0D60, 0X0D61}, {0X0E01, 0X0E2E}, {0X0E30, 0X0E3A}, + {0X0E40, 0X0E45}, {0X0E47, 0X0E47}, {0X0E4D, 0X0E4D}, {0X0E81, 0X0E82}, + {0X0E84, 0X0E84}, {0X0E87, 0X0E88}, {0X0E8A, 0X0E8A}, {0X0E8D, 0X0E8D}, + {0X0E94, 0X0E97}, {0X0E99, 0X0E9F}, {0X0EA1, 0X0EA3}, {0X0EA5, 0X0EA5}, + {0X0EA7, 0X0EA7}, {0X0EAA, 0X0EAB}, {0X0EAD, 0X0EAE}, {0X0EB0, 0X0EB9}, + {0X0EBB, 0X0EBD}, {0X0EC0, 0X0EC4}, {0X0ECD, 0X0ECD}, {0X0EDC, 0X0EDD}, + {0X0F40, 0X0F47}, {0X0F49, 0X0F69}, {0X0F71, 0X0F81}, {0X0F90, 0X0F95}, + {0X0F97, 0X0F97}, {0X0F99, 0X0FAD}, {0X0FB1, 0X0FB7}, {0X0FB9, 0X0FB9}, + {0X10A0, 0X10C5}, {0X10D0, 0X10F6}, {0x1100, 0x1159}, {0X115F, 0X11A2}, + {0X11A8, 0X11F9}, {0X1E00, 0X1E9B}, {0X1EA0, 0X1EF9}, {0X1F00, 0X1F15}, + {0X1F18, 0X1F1D}, {0X1F20, 0X1F45}, {0X1F48, 0X1F4D}, {0X1F50, 0X1F57}, + {0X1F59, 0X1F59}, {0X1F5B, 0X1F5B}, {0X1F5D, 0X1F5D}, {0X1F5F, 0X1F7D}, + {0X1F80, 0X1FB4}, {0X1FB6, 0X1FBC}, {0X1FBE, 0X1FBE}, {0X1FC2, 0X1FC4}, + {0X1FC6, 0X1FCC}, {0X1FD0, 0X1FD3}, {0X1FD6, 0X1FDB}, {0X1FE0, 0X1FEC}, + {0X1FF2, 0X1FF4}, {0X1FF6, 0X1FFC}, {0X207F, 0X207F}, {0x2102, 0x2102}, + {0x2107, 0x2107}, {0X210A, 0X2113}, {0x2115, 0x2115}, {0X2118, 0X211D}, + {0x2124, 0x2124}, {0x2126, 0x2126}, {0x2128, 0x2128}, {0X212A, 0X2131}, + {0x2133, 0x2138}, {0x2160, 0x2182}, {0x3041, 0x3094}, {0X30A1, 0X30FA}, + {0X3105, 0X312C}, {0X3131, 0X318E}, {0XAC00, 0XD7A3}, {0XFB00, 0XFB06}, + {0XFB13, 0XFB17}, {0XFB1F, 0XFB28}, {0XFB2A, 0XFB36}, {0XFB38, 0XFB3C}, + {0XFB3E, 0XFB3E}, {0XFB40, 0XFB41}, {0XFB43, 0XFB44}, {0XFB46, 0XFBB1}, + {0XFBD3, 0XFD3D}, {0XFD50, 0XFD8F}, {0XFD92, 0XFDC7}, {0XFDF0, 0XFDFB}, + {0XFE70, 0XFE72}, {0XFE74, 0XFE74}, {0XFE76, 0XFEFC}, {0XFF21, 0XFF3A}, + {0XFF41, 0XFF5A}, {0XFF66, 0XFF6F}, {0XFF71, 0XFF9D}, {0XFFA0, 0XFFBE}, + {0XFFC2, 0XFFC7}, {0XFFCA, 0XFFCF}, {0XFFD2, 0XFFD7}, {0XFFDA, 0XFFDC} +}; + +#define NUM_ALPHA (sizeof(alphaTable)/sizeof(crange)) + +static crange digitTable[] = { + {0x0030, 0x0039} +}; + +#define NUM_DIGIT (sizeof(digitTable)/sizeof(crange)) + +static crange punctTable[] = { + {0x0021, 0x0023}, {0X0025, 0X002A}, {0X002C, 0X002F}, {0X003A, 0X003B}, + {0X003F, 0X0040}, {0X005B, 0X005D}, {0X005F, 0X005F}, {0X007B, 0X007B}, + {0X007D, 0X007D}, {0X00A1, 0X00A1}, {0X00AB, 0X00AB}, {0X00AD, 0X00AD}, + {0X00BB, 0X00BB}, {0X00BF, 0X00BF}, {0X02BC, 0X02BC}, {0x0374, 0x0375}, + {0X037E, 0X037E}, {0x0387, 0x0387}, {0X055A, 0X055F}, {0x0589, 0x0589}, + {0X05BE, 0X05BE}, {0X05C0, 0X05C0}, {0X05C3, 0X05C3}, {0X05F3, 0X05F4}, + {0X060C, 0X060C}, {0X061B, 0X061B}, {0X061F, 0X061F}, {0X066A, 0X066D}, + {0X06D4, 0X06D4}, {0x0964, 0x0965}, {0x0970, 0x0970}, {0X0E2F, 0X0E2F}, + {0X0E5A, 0X0E5B}, {0X0EAF, 0X0EAF}, {0X0F04, 0X0F12}, {0X0F3A, 0X0F3F}, + {0X0F85, 0X0F85}, {0X10FB, 0X10FB}, {0x2010, 0x2027}, {0x2030, 0x2043}, + {0x2045, 0x2046}, {0X207D, 0X207E}, {0X208D, 0X208E}, {0X2329, 0X232A}, + {0x3001, 0x3003}, {0x3006, 0x3006}, {0x3008, 0x3011}, {0X3014, 0X301F}, + {0x3030, 0x3030}, {0X30FB, 0X30FB}, {0XFD3E, 0XFD3F}, {0XFE30, 0XFE44}, + {0XFE49, 0XFE52}, {0XFE54, 0XFE61}, {0XFE63, 0XFE63}, {0XFE68, 0XFE68}, + {0XFE6A, 0XFE6B}, {0XFF01, 0XFF03}, {0XFF05, 0XFF0A}, {0XFF0C, 0XFF0F}, + {0XFF1A, 0XFF1B}, {0XFF1F, 0XFF20}, {0XFF3B, 0XFF3D}, {0XFF3F, 0XFF3F}, + {0XFF5B, 0XFF5B}, {0XFF5D, 0XFF5D}, {0XFF61, 0XFF65} +}; + +#define NUM_PUNCT (sizeof(punctTable)/sizeof(crange)) + +static crange spaceTable[] = { + {0x0000, 0x0000}, {0x0009, 0x000D}, {0x0020, 0x0020}, {0x00A0, 0x00A0}, + {0x2000, 0x200F}, {0x2028, 0x202E}, {0X206A, 0X206F}, {0x3000, 0x3000}, + {0xFEFF, 0xFEFF} +}; + +#define NUM_SPACE (sizeof(spaceTable)/sizeof(crange)) + +static crange upperRangeTable[] = { + {0x0041, 0x005a}, {0x00c0, 0x00d6}, {0x00d8, 0x00de}, {0x0189, 0x018b}, + {0x018e, 0x0191}, {0x0388, 0x038a}, {0x0391, 0x03a1}, {0x03a3, 0x03ab}, + {0x03d2, 0x03d4}, {0x0401, 0x040c}, {0x040e, 0x042f}, {0x0531, 0x0556}, + {0x10a0, 0x10c5}, {0x1f08, 0x1f0f}, {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, + {0x1f38, 0x1f3f}, {0x1f48, 0x1f4d}, {0x1f68, 0x1f6f}, {0x1f88, 0x1f8f}, + {0x1f98, 0x1f9f}, {0x1fa8, 0x1faf}, {0x1fb8, 0x1fbc}, {0x1fc8, 0x1fcc}, + {0x1fd8, 0x1fdb}, {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffc}, {0x210b, 0x210d}, + {0x2110, 0x2112}, {0x2118, 0x211d}, {0x212a, 0x212d}, {0x2130, 0x2131}, + {0xff21, 0xff3a} +}; + +#define NUM_UPPER_RANGE (sizeof(upperRangeTable)/sizeof(crange)) + +static chr upperCharTable[] = { + 0x0100, 0x0102, 0x0104, 0x0106, 0x0108, 0x010a, 0x010c, 0x010e, 0x0110, + 0x0112, 0x0114, 0x0116, 0x0118, 0x011a, 0x011c, 0x011e, 0x0120, 0x0122, + 0x0124, 0x0126, 0x0128, 0x012a, 0x012c, 0x012e, 0x0130, 0x0132, 0x0134, + 0x0136, 0x0139, 0x013b, 0x013d, 0x013f, 0x0141, 0x0143, 0x0145, 0x0147, + 0x014a, 0x014c, 0x014e, 0x0150, 0x0152, 0x0154, 0x0156, 0x0158, 0x015a, + 0x015c, 0x015e, 0x0160, 0x0162, 0x0164, 0x0166, 0x0168, 0x016a, 0x016c, + 0x016e, 0x0170, 0x0172, 0x0174, 0x0176, 0x0178, 0x0179, 0x017b, 0x017d, + 0x0181, 0x0182, 0x0184, 0x0186, 0x0187, 0x0193, 0x0194, 0x0196, 0x0197, + 0x0198, 0x019c, 0x019d, 0x019f, 0x01a0, 0x01a2, 0x01a4, 0x01a6, 0x01a7, + 0x01a9, 0x01ac, 0x01ae, 0x01af, 0x01b1, 0x01b2, 0x01b3, 0x01b5, 0x01b7, + 0x01b8, 0x01bc, 0x01c4, 0x01c7, 0x01ca, 0x01cd, 0x01cf, 0x01d1, 0x01d3, + 0x01d5, 0x01d7, 0x01d9, 0x01db, 0x01de, 0x01e0, 0x01e2, 0x01e4, 0x01e6, + 0x01e8, 0x01ea, 0x01ec, 0x01ee, 0x01f1, 0x01f4, 0x01fa, 0x01fc, 0x01fe, + 0x0200, 0x0202, 0x0204, 0x0206, 0x0208, 0x020a, 0x020c, 0x020e, 0x0210, + 0x0212, 0x0214, 0x0216, 0x0386, 0x038c, 0x038e, 0x038f, 0x03da, 0x03dc, + 0x03de, 0x03e0, 0x03e2, 0x03e4, 0x03e6, 0x03e8, 0x03ea, 0x03ec, 0x03ee, + 0x0460, 0x0462, 0x0464, 0x0466, 0x0468, 0x046a, 0x046c, 0x046e, 0x0470, + 0x0472, 0x0474, 0x0476, 0x0478, 0x047a, 0x047c, 0x047e, 0x0480, 0x0490, + 0x0492, 0x0494, 0x0496, 0x0498, 0x049a, 0x049c, 0x049e, 0x04a0, 0x04a2, + 0x04a4, 0x04a6, 0x04a8, 0x04aa, 0x04ac, 0x04ae, 0x04b0, 0x04b2, 0x04b4, + 0x04b6, 0x04b8, 0x04ba, 0x04bc, 0x04be, 0x04c1, 0x04c3, 0x04c7, 0x04cb, + 0x04d0, 0x04d2, 0x04d4, 0x04d6, 0x04d8, 0x04da, 0x04dc, 0x04de, 0x04e0, + 0x04e2, 0x04e4, 0x04e6, 0x04e8, 0x04ea, 0x04ee, 0x04f0, 0x04f2, 0x04f4, + 0x04f8, 0x1e00, 0x1e02, 0x1e04, 0x1e06, 0x1e08, 0x1e0a, 0x1e0c, 0x1e0e, + 0x1e10, 0x1e12, 0x1e14, 0x1e16, 0x1e18, 0x1e1a, 0x1e1c, 0x1e1e, 0x1e20, + 0x1e22, 0x1e24, 0x1e26, 0x1e28, 0x1e2a, 0x1e2c, 0x1e2e, 0x1e30, 0x1e32, + 0x1e34, 0x1e36, 0x1e38, 0x1e3a, 0x1e3c, 0x1e3e, 0x1e40, 0x1e42, 0x1e44, + 0x1e46, 0x1e48, 0x1e4a, 0x1e4c, 0x1e4e, 0x1e50, 0x1e52, 0x1e54, 0x1e56, + 0x1e58, 0x1e5a, 0x1e5c, 0x1e5e, 0x1e60, 0x1e62, 0x1e64, 0x1e66, 0x1e68, + 0x1e6a, 0x1e6c, 0x1e6e, 0x1e70, 0x1e72, 0x1e74, 0x1e76, 0x1e78, 0x1e7a, + 0x1e7c, 0x1e7e, 0x1e80, 0x1e82, 0x1e84, 0x1e86, 0x1e88, 0x1e8a, 0x1e8c, + 0x1e8e, 0x1e90, 0x1e92, 0x1e94, 0x1ea0, 0x1ea2, 0x1ea4, 0x1ea6, 0x1ea8, + 0x1eaa, 0x1eac, 0x1eae, 0x1eb0, 0x1eb2, 0x1eb4, 0x1eb6, 0x1eb8, 0x1eba, + 0x1ebc, 0x1ebe, 0x1ec0, 0x1ec2, 0x1ec4, 0x1ec6, 0x1ec8, 0x1eca, 0x1ecc, + 0x1ece, 0x1ed0, 0x1ed2, 0x1ed4, 0x1ed6, 0x1ed8, 0x1eda, 0x1edc, 0x1ede, + 0x1ee0, 0x1ee2, 0x1ee4, 0x1ee6, 0x1ee8, 0x1eea, 0x1eec, 0x1eee, 0x1ef0, + 0x1ef2, 0x1ef4, 0x1ef6, 0x1ef8, 0x1f59, 0x1f5b, 0x1f5d, 0x1f5f, 0x1fbe, + 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x2133 +}; + +#define NUM_UPPER_CHAR (sizeof(upperCharTable)/sizeof(chr)) + +static crange lowerRangeTable[] = { + {0x0061, 0x007a}, {0x00df, 0x00f6}, {0x00f8, 0x00ff}, {0x0199, 0x019b}, + {0x0250, 0x02a8}, {0x03ac, 0x03ce}, {0x03ef, 0x03f2}, {0x0430, 0x044f}, + {0x0451, 0x045c}, {0x0561, 0x0587}, {0x10d0, 0x10f6}, {0x1e95, 0x1e9b}, + {0x1f00, 0x1f07}, {0x1f10, 0x1f15}, {0x1f20, 0x1f27}, {0x1f30, 0x1f37}, + {0x1f40, 0x1f45}, {0x1f50, 0x1f57}, {0x1f60, 0x1f67}, {0x1f70, 0x1f7d}, + {0x1f80, 0x1f87}, {0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, {0x1fb0, 0x1fb4}, + {0x1fd0, 0x1fd3}, {0x1fe0, 0x1fe7}, {0x1ff2, 0x1ff4}, {0xfb00, 0xfb06}, + {0xfb13, 0xfb17}, {0xff41, 0xff5a} +}; + +#define NUM_LOWER_RANGE (sizeof(lowerRangeTable)/sizeof(crange)) + +static chr lowerCharTable[] = { + 0x00aa, 0x00b5, 0x00ba, 0x0101, 0x0103, 0x0105, 0x0107, 0x0109, 0x010b, + 0x010d, 0x010f, 0x0111, 0x0113, 0x0115, 0x0117, 0x0119, 0x011b, 0x011d, + 0x011f, 0x0121, 0x0123, 0x0125, 0x0127, 0x0129, 0x012b, 0x012d, 0x012f, + 0x0131, 0x0133, 0x0135, 0x0138, 0x013a, 0x013c, 0x013e, 0x0140, 0x0142, + 0x0144, 0x0146, 0x0149, 0x014b, 0x014d, 0x014f, 0x0151, 0x0153, 0x0155, + 0x0157, 0x0159, 0x015b, 0x015d, 0x015f, 0x0161, 0x0163, 0x0165, 0x0167, + 0x0169, 0x016b, 0x016d, 0x016f, 0x0171, 0x0173, 0x0175, 0x0177, 0x017a, + 0x017c, 0x017e, 0x017f, 0x0180, 0x0183, 0x0185, 0x0188, 0x018c, 0x018d, + 0x0192, 0x0195, 0x019e, 0x01a1, 0x01a3, 0x01a5, 0x01a8, 0x01ab, 0x01ad, + 0x01b0, 0x01b4, 0x01b6, 0x01b9, 0x01ba, 0x01bd, 0x01c6, 0x01c9, 0x01cc, + 0x01ce, 0x01d0, 0x01d2, 0x01d4, 0x01d6, 0x01d8, 0x01da, 0x01dd, 0x01df, + 0x01e1, 0x01e3, 0x01e5, 0x01e7, 0x01e9, 0x01eb, 0x01ed, 0x01f0, 0x01f3, + 0x01f5, 0x01fb, 0x01fd, 0x01ff, 0x0201, 0x0203, 0x0205, 0x0207, 0x0209, + 0x020b, 0x020d, 0x020f, 0x0211, 0x0213, 0x0215, 0x0217, 0x0390, 0x03d0, + 0x03d1, 0x03d5, 0x03d6, 0x03e3, 0x03e5, 0x03e7, 0x03e9, 0x03eb, 0x03ed, + 0x045e, 0x045f, 0x0461, 0x0463, 0x0465, 0x0467, 0x0469, 0x046b, 0x046d, + 0x046f, 0x0471, 0x0473, 0x0475, 0x0477, 0x0479, 0x047b, 0x047d, 0x047f, + 0x0481, 0x0491, 0x0493, 0x0495, 0x0497, 0x0499, 0x049b, 0x049d, 0x049f, + 0x04a1, 0x04a3, 0x04a5, 0x04a7, 0x04a9, 0x04ab, 0x04ad, 0x04af, 0x04b1, + 0x04b3, 0x04b5, 0x04b7, 0x04b9, 0x04bb, 0x04bd, 0x04bf, 0x04c2, 0x04c4, + 0x04c8, 0x04cc, 0x04d1, 0x04d3, 0x04d5, 0x04d7, 0x04d9, 0x04db, 0x04dd, + 0x04df, 0x04e1, 0x04e3, 0x04e5, 0x04e7, 0x04e9, 0x04eb, 0x04ef, 0x04f1, + 0x04f3, 0x04f5, 0x04f9, 0x1e01, 0x1e03, 0x1e05, 0x1e07, 0x1e09, 0x1e0b, + 0x1e0d, 0x1e0f, 0x1e11, 0x1e13, 0x1e15, 0x1e17, 0x1e19, 0x1e1b, 0x1e1d, + 0x1e1f, 0x1e21, 0x1e23, 0x1e25, 0x1e27, 0x1e29, 0x1e2b, 0x1e2d, 0x1e2f, + 0x1e31, 0x1e33, 0x1e35, 0x1e37, 0x1e39, 0x1e3b, 0x1e3d, 0x1e3f, 0x1e41, + 0x1e43, 0x1e45, 0x1e47, 0x1e49, 0x1e4b, 0x1e4d, 0x1e4f, 0x1e51, 0x1e53, + 0x1e55, 0x1e57, 0x1e59, 0x1e5b, 0x1e5d, 0x1e5f, 0x1e61, 0x1e63, 0x1e65, + 0x1e67, 0x1e69, 0x1e6b, 0x1e6d, 0x1e6f, 0x1e71, 0x1e73, 0x1e75, 0x1e77, + 0x1e79, 0x1e7b, 0x1e7d, 0x1e7f, 0x1e81, 0x1e83, 0x1e85, 0x1e87, 0x1e89, + 0x1e8b, 0x1e8d, 0x1e8f, 0x1e91, 0x1e93, 0x1ea1, 0x1ea3, 0x1ea5, 0x1ea7, + 0x1ea9, 0x1eab, 0x1ead, 0x1eaf, 0x1eb1, 0x1eb3, 0x1eb5, 0x1eb7, 0x1eb9, + 0x1ebb, 0x1ebd, 0x1ebf, 0x1ec1, 0x1ec3, 0x1ec5, 0x1ec7, 0x1ec9, 0x1ecb, + 0x1ecd, 0x1ecf, 0x1ed1, 0x1ed3, 0x1ed5, 0x1ed7, 0x1ed9, 0x1edb, 0x1edd, + 0x1edf, 0x1ee1, 0x1ee3, 0x1ee5, 0x1ee7, 0x1ee9, 0x1eeb, 0x1eed, 0x1eef, + 0x1ef1, 0x1ef3, 0x1ef5, 0x1ef7, 0x1ef9, 0x1fb6, 0x1fb7, 0x1fc2, 0x1fc3, + 0x1fc4, 0x1fc6, 0x1fc7, 0x1fd6, 0x1fd7, 0x1ff6, 0x1ff7, 0x207f, 0x210a, + 0x210e, 0x210f, 0x2113, 0x212e, 0x212f, 0x2134 +}; + +#define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr)) + +/* + * The graph table includes the set of characters that are neither ISO control + * characters nor in the space table. + */ + +static crange graphTable[] = { + {0x0021, 0x007e}, {0x00a1, 0x1fff}, {0x2010, 0x2027}, {0x202f, 0x2069}, + {0x2070, 0x2fff}, {0x3001, 0xfefe}, {0xff00, 0xffff} +}; + +#define NUM_GRAPH (sizeof(graphTable)/sizeof(crange)) +#define CH NOCELT + +/* + - nmcces - how many distinct MCCEs are there? + ^ static int nmcces(struct vars *); + */ +static int +nmcces(v) +struct vars *v; +{ + return 0; +} + +/* + - nleaders - how many chrs can be first chrs of MCCEs? + ^ static int nleaders(struct vars *); + */ +static int +nleaders(v) +struct vars *v; +{ + return 0; +} + +/* + - allmcces - return a cvec with all the MCCEs of the locale + ^ static struct cvec *allmcces(struct vars *, struct cvec *); + */ +static struct cvec * +allmcces(v, cv) +struct vars *v; +struct cvec *cv; /* this is supposed to have enough room */ +{ + return clearcvec(cv); +} + +/* + - element - map collating-element name to celt + ^ static celt element(struct vars *, chr *, chr *); + */ +static celt +element(v, startp, endp) +struct vars *v; +chr *startp; /* points to start of name */ +chr *endp; /* points just past end of name */ +{ + struct cname *cn; + size_t len; + Tcl_DString ds; + char *np; + + /* generic: one-chr names stand for themselves */ + assert(startp < endp); + len = endp - startp; + if (len == 1) + return *startp; + + NOTE(REG_ULOCALE); + + /* search table */ + Tcl_DStringInit(&ds); + np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); + for (cn = cnames; cn->name != NULL; cn++) + if (strlen(cn->name) == len && strncmp(cn->name, np, len) == 0) + break; /* NOTE BREAK OUT */ + Tcl_DStringFree(&ds); + if (cn->name != NULL) + return CHR(cn->code); + + /* couldn't find it */ + ERR(REG_ECOLLATE); + return 0; +} + +/* + - range - supply cvec for a range, including legality check + ^ static struct cvec *range(struct vars *, celt, celt, int); + */ +static struct cvec * +range(v, a, b, cases) +struct vars *v; +celt a; +celt b; /* might equal a */ +int cases; /* case-independent? */ +{ + int nchrs; + struct cvec *cv; + celt c, lc, uc, tc; + + if (a != b && !before(a, b)) { + ERR(REG_ERANGE); + return NULL; + } + + if (!cases) { /* easy version */ + cv = getcvec(v, 0, 1, 0); + NOERRN(); + addrange(cv, a, b); + return cv; + } + + /* + * When case-independent, it's hard to decide when cvec ranges are + * usable, so for now at least, we won't try. We allocate enough + * space for two case variants plus a little extra for the two + * title case variants. + */ + + nchrs = (b - a + 1)*2 + 4; + + cv = getcvec(v, nchrs, 0, 0); + NOERRN(); + + for (c = a; c <= b; c++) { + addchr(cv, c); + lc = Tcl_UniCharToLower((chr)c); + uc = Tcl_UniCharToUpper((chr)c); + tc = Tcl_UniCharToTitle((chr)c); + if (c != lc) { + addchr(cv, lc); + } + if (c != uc) { + addchr(cv, uc); + } + if (c != tc && tc != uc) { + addchr(cv, tc); + } + } + + return cv; +} + +/* + - before - is celt x before celt y, for purposes of range legality? + ^ static int before(celt, celt); + */ +static int /* predicate */ +before(x, y) +celt x; +celt y; +{ + /* trivial because no MCCEs */ + if (x < y) + return 1; + return 0; +} + +/* + - eclass - supply cvec for an equivalence class + * Must include case counterparts on request. + ^ static struct cvec *eclass(struct vars *, celt, int); + */ +static struct cvec * +eclass(v, c, cases) +struct vars *v; +celt c; +int cases; /* all cases? */ +{ + struct cvec *cv; + + /* crude fake equivalence class for testing */ + if ((v->cflags®_FAKEEC) && c == 'x') { + cv = getcvec(v, 4, 0, 0); + addchr(cv, (chr)'x'); + addchr(cv, (chr)'y'); + if (cases) { + addchr(cv, (chr)'X'); + addchr(cv, (chr)'Y'); + } + return cv; + } + + /* otherwise, none */ + if (cases) + return allcases(v, c); + cv = getcvec(v, 1, 0, 0); + assert(cv != NULL); + addchr(cv, (chr)c); + return cv; +} + +/* + - cclass - supply cvec for a character class + * Must include case counterparts on request. + ^ static struct cvec *cclass(struct vars *, chr *, chr *, int); + */ +static struct cvec * +cclass(v, startp, endp, cases) +struct vars *v; +chr *startp; /* where the name starts */ +chr *endp; /* just past the end of the name */ +int cases; /* case-independent? */ +{ + size_t len; + struct cvec *cv = NULL; + Tcl_DString ds; + char *np, **namePtr; + int i, index; + + /* + * The following arrays define the valid character class names. + */ + + static char *classNames[] = { + "alnum", "alpha", "blank", "cntrl", "digit", "graph", "lower", + "print", "punct", "space", "upper", "xdigit", NULL + }; + + enum classes { + CC_ALNUM, CC_ALPHA, CC_BLANK, CC_CNTRL, CC_DIGIT, CC_GRAPH, CC_LOWER, + CC_PRINT, CC_PUNCT, CC_SPACE, CC_UPPER, CC_XDIGIT + }; + + + /* + * Extract the class name + */ + + len = endp - startp; + Tcl_DStringInit(&ds); + np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); + + /* + * Remap lower and upper to alpha if the match is case insensitive. + */ + + if (cases && len == 5 && (strncmp("lower", np, 5) == 0 + || strncmp("upper", np, 5) == 0)) { + np = "alpha"; + } + + /* + * Map the name to the corresponding enumerated value. + */ + + index = -1; + for (namePtr = classNames, i = 0; *namePtr != NULL; namePtr++, i++) { + if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) { + index = i; + break; + } + } + Tcl_DStringInit(&ds); + if (index == -1) { + ERR(REG_ECTYPE); + return NULL; + } + + /* + * Now compute the character class contents. + */ + + switch((enum classes) index) { + case CC_PRINT: + case CC_ALNUM: + cv = getcvec(v, 0, NUM_DIGIT + NUM_ALPHA, 0); + if (cv) { + for (i = 0; i < NUM_ALPHA; i++) { + addrange(cv, alphaTable[i].start, alphaTable[i].end); + } + for (i = 0; i < NUM_DIGIT; i++) { + addrange(cv, digitTable[i].start, digitTable[i].end); + } + } + break; + case CC_ALPHA: + cv = getcvec(v, 0, NUM_ALPHA, 0); + if (cv) { + for (i = 0; i < NUM_ALPHA; i++) { + addrange(cv, alphaTable[i].start, alphaTable[i].end); + } + } + break; + case CC_BLANK: + cv = getcvec(v, 2, 0, 0); + addchr(cv, '\t'); + addchr(cv, ' '); + break; + case CC_CNTRL: + cv = getcvec(v, 0, 2, 0); + addrange(cv, 0x0, 0x1f); + addrange(cv, 0x7f, 0x9f); + break; + case CC_DIGIT: + cv = getcvec(v, 0, NUM_DIGIT, 0); + if (cv) { + for (i = 0; i < NUM_DIGIT; i++) { + addrange(cv, digitTable[i].start, digitTable[i].end); + } + } + break; + case CC_PUNCT: + cv = getcvec(v, 0, NUM_PUNCT, 0); + if (cv) { + for (i = 0; i < NUM_PUNCT; i++) { + addrange(cv, punctTable[i].start, punctTable[i].end); + } + } + break; + case CC_XDIGIT: + cv = getcvec(v, 0, NUM_DIGIT+2, 0); + if (cv) { + for (i = 0; i < NUM_DIGIT; i++) { + addrange(cv, digitTable[i].start, digitTable[i].end); + } + addrange(cv, 'a', 'f'); + addrange(cv, 'A', 'F'); + } + break; + case CC_SPACE: + cv = getcvec(v, 0, NUM_SPACE, 0); + if (cv) { + for (i = 0; i < NUM_SPACE; i++) { + addrange(cv, spaceTable[i].start, spaceTable[i].end); + } + } + break; + case CC_LOWER: + cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE, 0); + if (cv) { + for (i = 0; i < NUM_LOWER_RANGE; i++) { + addrange(cv, lowerRangeTable[i].start, + lowerRangeTable[i].end); + } + for (i = 0; i < NUM_LOWER_CHAR; i++) { + addchr(cv, lowerCharTable[i]); + } + } + break; + case CC_UPPER: + cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE, 0); + if (cv) { + for (i = 0; i < NUM_UPPER_RANGE; i++) { + addrange(cv, upperRangeTable[i].start, + upperRangeTable[i].end); + } + for (i = 0; i < NUM_UPPER_CHAR; i++) { + addchr(cv, upperCharTable[i]); + } + } + break; + case CC_GRAPH: + cv = getcvec(v, 0, NUM_GRAPH, 0); + if (cv) { + for (i = 0; i < NUM_GRAPH; i++) { + addrange(cv, graphTable[i].start, graphTable[i].end); + } + } + break; + } + if (cv == NULL) { + ERR(REG_ESPACE); + } + return cv; +} + +/* + - allcases - supply cvec for all case counterparts of a chr (including itself) + * This is a shortcut, preferably an efficient one, for simple characters; + * messy cases are done via range(). + ^ static struct cvec *allcases(struct vars *, pchr); + */ +static struct cvec * +allcases(v, pc) +struct vars *v; +pchr pc; +{ + struct cvec *cv; + chr c = (chr)pc; + chr lc, uc, tc; + + lc = Tcl_UniCharToLower((chr)c); + uc = Tcl_UniCharToUpper((chr)c); + tc = Tcl_UniCharToTitle((chr)c); + + if (tc != uc) { + cv = getcvec(v, 3, 0, 0); + addchr(cv, tc); + } else { + cv = getcvec(v, 2, 0, 0); + } + addchr(cv, lc); + if (lc != uc) { + addchr(cv, uc); + } + return cv; +} + +/* + - cmp - chr-substring compare + * Backrefs need this. It should preferably be efficient. + * Note that it does not need to report anything except equal/unequal. + * Note also that the length is exact, and the comparison should not + * stop at embedded NULs! + ^ static int cmp(CONST chr *, CONST chr *, size_t); + */ +static int /* 0 for equal, nonzero for unequal */ +cmp(x, y, len) +CONST chr *x; +CONST chr *y; +size_t len; /* exact length of comparison */ +{ + return memcmp(VS(x), VS(y), len*sizeof(chr)); +} + +/* + - casecmp - case-independent chr-substring compare + * REG_ICASE backrefs need this. It should preferably be efficient. + * Note that it does not need to report anything except equal/unequal. + * Note also that the length is exact, and the comparison should not + * stop at embedded NULs! + ^ static int casecmp(CONST chr *, CONST chr *, size_t); + */ +static int /* 0 for equal, nonzero for unequal */ +casecmp(x, y, len) +CONST chr *x; +CONST chr *y; +size_t len; /* exact length of comparison */ +{ + size_t i; + CONST chr *xp; + CONST chr *yp; + + for (xp = x, yp = y, i = len; i > 0; i--) + if (Tcl_UniCharToLower(*xp++) != Tcl_UniCharToLower(*yp++)) + return 1; + return 0; +} diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c new file mode 100644 index 0000000..80e9ac7 --- /dev/null +++ b/generic/regc_nfa.c @@ -0,0 +1,1528 @@ +/* + * NFA utilities. + * This file is #included by regcomp.c. + * + * One or two things that technically ought to be in here + * are actually in color.c, thanks to some incestuous relationships in + * the color chains. + */ + +#define NISERR() VISERR(nfa->v) +#define NERR(e) VERR(nfa->v, (e)) + + +/* + - newnfa - set up an NFA + ^ static struct nfa *newnfa(struct vars *, struct colormap *, struct nfa *); + */ +static struct nfa * /* the NFA, or NULL */ +newnfa(v, cm, parent) +struct vars *v; +struct colormap *cm; +struct nfa *parent; /* NULL if primary NFA */ +{ + struct nfa *nfa; + + nfa = (struct nfa *)MALLOC(sizeof(struct nfa)); + if (nfa == NULL) + return NULL; + + nfa->states = NULL; + nfa->slast = NULL; + nfa->free = NULL; + nfa->nstates = 0; + nfa->cm = cm; + nfa->v = v; + nfa->bos[0] = nfa->bos[1] = COLORLESS; + nfa->eos[0] = nfa->eos[1] = COLORLESS; + nfa->post = newfstate(nfa, '@'); /* number 0 */ + nfa->pre = newfstate(nfa, '>'); /* number 1 */ + nfa->parent = parent; + + nfa->init = newstate(nfa); /* may become invalid later */ + nfa->final = newstate(nfa); + if (ISERR()) { + freenfa(nfa); + return NULL; + } + rainbow(nfa, nfa->cm, PLAIN, COLORLESS, nfa->pre, nfa->init); + newarc(nfa, '^', 1, nfa->pre, nfa->init); + newarc(nfa, '^', 0, nfa->pre, nfa->init); + rainbow(nfa, nfa->cm, PLAIN, COLORLESS, nfa->final, nfa->post); + newarc(nfa, '$', 1, nfa->final, nfa->post); + newarc(nfa, '$', 0, nfa->final, nfa->post); + + if (ISERR()) { + freenfa(nfa); + return NULL; + } + return nfa; +} + +/* + - freenfa - free an entire NFA + ^ static VOID freenfa(struct nfa *); + */ +static VOID +freenfa(nfa) +struct nfa *nfa; +{ + struct state *s; + + while ((s = nfa->states) != NULL) { + s->nins = s->nouts = 0; /* don't worry about arcs */ + freestate(nfa, s); + } + while ((s = nfa->free) != NULL) { + nfa->free = s->next; + destroystate(nfa, s); + } + + nfa->slast = NULL; + nfa->nstates = -1; + nfa->pre = NULL; + nfa->post = NULL; + FREE(nfa); +} + +/* + - newfstate - allocate an NFA state, with specified flag value + ^ static struct state *newfstate(struct nfa *, int flag); + */ +static struct state * /* NULL on error */ +newfstate(nfa, flag) +struct nfa *nfa; +int flag; +{ + struct state *s; + int i; + + if (nfa->free != NULL) { + s = nfa->free; + nfa->free = s->next; + } else { + s = (struct state *)MALLOC(sizeof(struct state)); + if (s == NULL) { + NERR(REG_ESPACE); + return NULL; + } + s->oas.next = NULL; + s->free = &s->oas.a[0]; + for (i = 0; i < ABSIZE; i++) { + s->oas.a[i].type = 0; + s->oas.a[i].freechain = &s->oas.a[i+1]; + } + s->oas.a[ABSIZE-1].freechain = NULL; + } + + assert(nfa->nstates >= 0); + s->no = nfa->nstates++; + s->flag = (char)flag; + if (nfa->states == NULL) + nfa->states = s; + s->nins = 0; + s->ins = NULL; + s->nouts = 0; + s->outs = NULL; + s->tmp = NULL; + s->next = NULL; + if (nfa->slast != NULL) { + assert(nfa->slast->next == NULL); + nfa->slast->next = s; + } + s->prev = nfa->slast; + nfa->slast = s; + return s; +} + +/* + - newstate - allocate an ordinary NFA state + ^ static struct state *newstate(struct nfa *); + */ +static struct state * /* NULL on error */ +newstate(nfa) +struct nfa *nfa; +{ + return newfstate(nfa, 0); +} + +/* + - dropstate - delete a state's inarcs and outarcs and free it + ^ static VOID dropstate(struct nfa *, struct state *); + */ +static VOID +dropstate(nfa, s) +struct nfa *nfa; +struct state *s; +{ + struct arc *a; + + while ((a = s->ins) != NULL) + freearc(nfa, a); + while ((a = s->outs) != NULL) + freearc(nfa, a); + freestate(nfa, s); +} + +/* + - freestate - free a state, which has no in-arcs or out-arcs + ^ static VOID freestate(struct nfa *, struct state *); + */ +static VOID +freestate(nfa, s) +struct nfa *nfa; +struct state *s; +{ + assert(s != NULL); + assert(s->nins == 0 && s->nouts == 0); + + s->no = FREESTATE; + s->flag = 0; + if (s->next != NULL) + s->next->prev = s->prev; + else { + assert(s == nfa->slast); + nfa->slast = s->prev; + } + if (s->prev != NULL) + s->prev->next = s->next; + else { + assert(s == nfa->states); + nfa->states = s->next; + } + s->prev = NULL; + s->next = nfa->free; /* don't delete it, put it on the free list */ + nfa->free = s; +} + +/* + - destroystate - really get rid of an already-freed state + ^ static VOID destroystate(struct nfa *, struct state *); + */ +static VOID +destroystate(nfa, s) +struct nfa *nfa; +struct state *s; +{ + struct arcbatch *ab; + struct arcbatch *abnext; + + assert(s->no == FREESTATE); + for (ab = s->oas.next; ab != NULL; ab = abnext) { + abnext = ab->next; + FREE(ab); + } + s->ins = NULL; + s->outs = NULL; + s->next = NULL; + FREE(s); +} + +/* + - newarc - set up a new arc within an NFA + ^ static VOID newarc(struct nfa *, int, pcolor, struct state *, + ^ struct state *); + */ +static VOID +newarc(nfa, t, co, from, to) +struct nfa *nfa; +int t; +pcolor co; +struct state *from; +struct state *to; +{ + struct arc *a; + + assert(from != NULL && to != NULL); + + /* check for duplicates */ + for (a = from->outs; a != NULL; a = a->outchain) + if (a->type == t && a->co == co && a->to == to) + return; + + a = allocarc(nfa, from); + if (NISERR()) + return; + assert(a != NULL); + + a->type = t; + a->co = (color)co; + a->to = to; + a->from = from; + + /* + * Put the new arc on the beginning, not the end, of the chains. + * Not only is this easier, it has the very useful side effect that + * deleting the most-recently-added arc is the cheapest case rather + * than the most expensive one. + */ + a->inchain = to->ins; + to->ins = a; + a->outchain = from->outs; + from->outs = a; + + from->nouts++; + to->nins++; + + if (COLORED(a) && nfa->parent == NULL) + colorchain(nfa->cm, a); + + return; +} + +/* + - allocarc - allocate a new out-arc within a state + ^ static struct arc *allocarc(struct nfa *, struct state *); + */ +static struct arc * /* NULL for failure */ +allocarc(nfa, s) +struct nfa *nfa; +struct state *s; +{ + struct arc *a; + struct arcbatch *new; + int i; + + /* if none at hand, get more */ + if (s->free == NULL) { + new = (struct arcbatch *)MALLOC(sizeof(struct arcbatch)); + if (new == NULL) { + NERR(REG_ESPACE); + return NULL; + } + new->next = s->oas.next; + s->oas.next = new; + + for (i = 0; i < ABSIZE; i++) { + new->a[i].type = 0; + new->a[i].freechain = &new->a[i+1]; + } + new->a[ABSIZE-1].freechain = NULL; + s->free = &new->a[0]; + } + assert(s->free != NULL); + + a = s->free; + s->free = a->freechain; + return a; +} + +/* + - freearc - free an arc + ^ static VOID freearc(struct nfa *, struct arc *); + */ +static VOID +freearc(nfa, victim) +struct nfa *nfa; +struct arc *victim; +{ + struct state *from = victim->from; + struct state *to = victim->to; + struct arc *a; + + assert(victim->type != 0); + + /* take it off color chain if necessary */ + if (COLORED(victim) && nfa->parent == NULL) + uncolorchain(nfa->cm, victim); + + /* take it off source's out-chain */ + assert(from != NULL); + assert(from->outs != NULL); + a = from->outs; + if (a == victim) /* simple case: first in chain */ + from->outs = victim->outchain; + else { + for (; a != NULL && a->outchain != victim; a = a->outchain) + continue; + assert(a != NULL); + a->outchain = victim->outchain; + } + from->nouts--; + + /* take it off target's in-chain */ + assert(to != NULL); + assert(to->ins != NULL); + a = to->ins; + if (a == victim) /* simple case: first in chain */ + to->ins = victim->inchain; + else { + for (; a != NULL && a->inchain != victim; a = a->inchain) + continue; + assert(a != NULL); + a->inchain = victim->inchain; + } + to->nins--; + + /* clean up and place on free list */ + victim->type = 0; + victim->from = NULL; /* precautions... */ + victim->to = NULL; + victim->inchain = NULL; + victim->outchain = NULL; + victim->freechain = from->free; + from->free = victim; +} + +/* + - findarc - find arc, if any, from given source with given type and color + * If there is more than one such arc, the result is random. + ^ static struct arc *findarc(struct state *, int, pcolor); + */ +static struct arc * +findarc(s, type, co) +struct state *s; +int type; +pcolor co; +{ + struct arc *a; + + for (a = s->outs; a != NULL; a = a->outchain) + if (a->type == type && a->co == co) + return a; + return NULL; +} + +/* + - cparc - allocate a new arc within an NFA, copying details from old one + ^ static VOID cparc(struct nfa *, struct arc *, struct state *, + ^ struct state *); + */ +static VOID +cparc(nfa, oa, from, to) +struct nfa *nfa; +struct arc *oa; +struct state *from; +struct state *to; +{ + newarc(nfa, oa->type, oa->co, from, to); +} + +/* + - moveins - move all in arcs of a state to another state + * You might think this could be done better by just updating the + * existing arcs, and you would be right if it weren't for the desire + * for duplicate suppression, which makes it easier to just make new + * ones to exploit the suppression built into newarc. + ^ static VOID moveins(struct nfa *, struct state *, struct state *); + */ +static VOID +moveins(nfa, old, new) +struct nfa *nfa; +struct state *old; +struct state *new; +{ + struct arc *a; + + assert(old != new); + + while ((a = old->ins) != NULL) { + cparc(nfa, a, a->from, new); + freearc(nfa, a); + } + assert(old->nins == 0); + assert(old->ins == NULL); +} + +/* + - copyins - copy all in arcs of a state to another state + ^ static VOID copyins(struct nfa *, struct state *, struct state *); + */ +static VOID +copyins(nfa, old, new) +struct nfa *nfa; +struct state *old; +struct state *new; +{ + struct arc *a; + + assert(old != new); + + for (a = old->ins; a != NULL; a = a->inchain) + cparc(nfa, a, a->from, new); +} + +/* + - moveouts - move all out arcs of a state to another state + ^ static VOID moveouts(struct nfa *, struct state *, struct state *); + */ +static VOID +moveouts(nfa, old, new) +struct nfa *nfa; +struct state *old; +struct state *new; +{ + struct arc *a; + + assert(old != new); + + while ((a = old->outs) != NULL) { + cparc(nfa, a, new, a->to); + freearc(nfa, a); + } +} + +/* + - copyouts - copy all out arcs of a state to another state + ^ static VOID copyouts(struct nfa *, struct state *, struct state *); + */ +static VOID +copyouts(nfa, old, new) +struct nfa *nfa; +struct state *old; +struct state *new; +{ + struct arc *a; + + assert(old != new); + + for (a = old->outs; a != NULL; a = a->outchain) + cparc(nfa, a, new, a->to); +} + +/* + - cloneouts - copy out arcs of a state to another state pair, modifying type + ^ static VOID cloneouts(struct nfa *, struct state *, struct state *, + ^ struct state *, int); + */ +static VOID +cloneouts(nfa, old, from, to, type) +struct nfa *nfa; +struct state *old; +struct state *from; +struct state *to; +int type; +{ + struct arc *a; + + assert(old != from); + + for (a = old->outs; a != NULL; a = a->outchain) + newarc(nfa, type, a->co, from, to); +} + +/* + - delsub - delete a sub-NFA, updating subre pointers if necessary + * This uses a recursive traversal of the sub-NFA, marking already-seen + * states using their tmp pointer. + ^ static VOID delsub(struct nfa *, struct state *, struct state *); + */ +static VOID +delsub(nfa, lp, rp) +struct nfa *nfa; +struct state *lp; /* the sub-NFA goes from here... */ +struct state *rp; /* ...to here, *not* inclusive */ +{ + assert(lp != rp); + + rp->tmp = rp; /* mark end */ + + deltraverse(nfa, lp, lp); + assert(lp->nouts == 0 && rp->nins == 0); /* did the job */ + assert(lp->no != FREESTATE && rp->no != FREESTATE); /* no more */ + + rp->tmp = NULL; /* unmark end */ + lp->tmp = NULL; /* and begin, marked by deltraverse */ +} + +/* + - deltraverse - the recursive heart of delsub + * This routine's basic job is to destroy all out-arcs of the state. + ^ static VOID deltraverse(struct nfa *, struct state *, struct state *); + */ +static VOID +deltraverse(nfa, leftend, s) +struct nfa *nfa; +struct state *leftend; +struct state *s; +{ + struct arc *a; + struct state *to; + + if (s->nouts == 0) + return; /* nothing to do */ + if (s->tmp != NULL) + return; /* already in progress */ + + s->tmp = s; /* mark as in progress */ + + while ((a = s->outs) != NULL) { + to = a->to; + deltraverse(nfa, leftend, to); + assert(to->nouts == 0 || to->tmp != NULL); + freearc(nfa, a); + if (to->nins == 0 && to->tmp == NULL) { + assert(to->nouts == 0); + freestate(nfa, to); + } + } + + assert(s->no != FREESTATE); /* we're still here */ + assert(s == leftend || s->nins != 0); /* and still reachable */ + assert(s->nouts == 0); /* but have no outarcs */ + + s->tmp = NULL; /* we're done here */ +} + +/* + - dupnfa - duplicate sub-NFA + * Another recursive traversal, this time using tmp to point to duplicates + * as well as mark already-seen states. (You knew there was a reason why + * it's a state pointer, didn't you? :-)) + ^ static VOID dupnfa(struct nfa *, struct state *, struct state *, + ^ struct state *, struct state *); + */ +static VOID +dupnfa(nfa, start, stop, from, to) +struct nfa *nfa; +struct state *start; /* duplicate of subNFA starting here */ +struct state *stop; /* and stopping here */ +struct state *from; /* stringing duplicate from here */ +struct state *to; /* to here */ +{ + if (start == stop) { + newarc(nfa, EMPTY, 0, from, to); + return; + } + + stop->tmp = to; + duptraverse(nfa, start, from); + /* done, except for clearing out the tmp pointers */ + + stop->tmp = NULL; + cleartraverse(nfa, start); +} + +/* + - duptraverse - recursive heart of dupnfa + ^ static VOID duptraverse(struct nfa *, struct state *, struct state *); + */ +static VOID +duptraverse(nfa, s, stmp) +struct nfa *nfa; +struct state *s; +struct state *stmp; /* s's duplicate, or NULL */ +{ + struct arc *a; + + if (s->tmp != NULL) + return; /* already done */ + + s->tmp = (stmp == NULL) ? newstate(nfa) : stmp; + if (s->tmp == NULL) { + assert(NISERR()); + return; + } + + for (a = s->outs; a != NULL && !NISERR(); a = a->outchain) { + duptraverse(nfa, a->to, (struct state *)NULL); + assert(a->to->tmp != NULL); + cparc(nfa, a, s->tmp, a->to->tmp); + } +} + +/* + - cleartraverse - recursive cleanup for algorithms that leave tmp ptrs set + ^ static VOID cleartraverse(struct nfa *, struct state *); + */ +static VOID +cleartraverse(nfa, s) +struct nfa *nfa; +struct state *s; +{ + struct arc *a; + + if (s->tmp == NULL) + return; + s->tmp = NULL; + + for (a = s->outs; a != NULL; a = a->outchain) + cleartraverse(nfa, a->to); +} + +/* + - specialcolors - fill in special colors for an NFA + ^ static VOID specialcolors(struct nfa *); + */ +static VOID +specialcolors(nfa) +struct nfa *nfa; +{ + /* false colors for BOS, BOL, EOS, EOL */ + if (nfa->parent == NULL) { + nfa->bos[0] = pseudocolor(nfa->cm); + nfa->bos[1] = pseudocolor(nfa->cm); + nfa->eos[0] = pseudocolor(nfa->cm); + nfa->eos[1] = pseudocolor(nfa->cm); + } else { + assert(nfa->parent->bos[0] != COLORLESS); + nfa->bos[0] = nfa->parent->bos[0]; + assert(nfa->parent->bos[1] != COLORLESS); + nfa->bos[1] = nfa->parent->bos[1]; + assert(nfa->parent->eos[0] != COLORLESS); + nfa->eos[0] = nfa->parent->eos[0]; + assert(nfa->parent->eos[1] != COLORLESS); + nfa->eos[1] = nfa->parent->eos[1]; + } +} + +/* + - optimize - optimize an NFA + ^ static int optimize(struct nfa *, FILE *); + */ +static int /* re_info bits */ +optimize(nfa, f) +struct nfa *nfa; +FILE *f; /* for debug output; NULL none */ +{ + int verbose = (f != NULL) ? 1 : 0; + + if (verbose) + fprintf(f, "\ninitial cleanup:\n"); + cleanup(nfa); /* may simplify situation */ + if (verbose) + dumpnfa(nfa, f); + if (verbose) + fprintf(f, "\nempties:\n"); + fixempties(nfa, f); /* get rid of EMPTY arcs */ + if (verbose) + fprintf(f, "\nconstraints:\n"); + pullback(nfa, f); /* pull back constraints backward */ + pushfwd(nfa, f); /* push fwd constraints forward */ + if (verbose) + fprintf(f, "\nfinal cleanup:\n"); + cleanup(nfa); /* final tidying */ + return analyze(nfa); /* and analysis */ +} + +/* + - pullback - pull back constraints backward to (with luck) eliminate them + ^ static VOID pullback(struct nfa *, FILE *); + */ +static VOID +pullback(nfa, f) +struct nfa *nfa; +FILE *f; /* for debug output; NULL none */ +{ + struct state *s; + struct state *nexts; + struct arc *a; + struct arc *nexta; + int progress; + + /* find and pull until there are no more */ + do { + progress = 0; + for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { + nexts = s->next; + for (a = s->outs; a != NULL && !NISERR(); a = nexta) { + nexta = a->outchain; + if (a->type == '^' || a->type == BEHIND) + if (pull(nfa, a)) + progress = 1; + assert(nexta == NULL || s->no != FREESTATE); + } + } + if (progress && f != NULL) + dumpnfa(nfa, f); + } while (progress && !NISERR()); + if (NISERR()) + return; + + for (a = nfa->pre->outs; a != NULL; a = nexta) { + nexta = a->outchain; + if (a->type == '^') { + assert(a->co == 0 || a->co == 1); + newarc(nfa, PLAIN, nfa->bos[a->co], a->from, a->to); + freearc(nfa, a); + } + } +} + +/* + - pull - pull a back constraint backward past its source state + * A significant property of this function is that it deletes at most + * one state -- the constraint's from state -- and only if the constraint + * was that state's last outarc. + ^ static int pull(struct nfa *, struct arc *); + */ +static int /* 0 couldn't, 1 could */ +pull(nfa, con) +struct nfa *nfa; +struct arc *con; +{ + struct state *from = con->from; + struct state *to = con->to; + struct arc *a; + struct arc *nexta; + struct state *s; + + if (from == to) { /* circular constraint is pointless */ + freearc(nfa, con); + return 1; + } + if (from->flag) /* can't pull back beyond start */ + return 0; + if (from->nins == 0) { /* unreachable */ + freearc(nfa, con); + return 1; + } + + /* first, clone from state if necessary to avoid other outarcs */ + if (from->nouts > 1) { + s = newstate(nfa); + if (NISERR()) + return 0; + assert(to != from); /* con is not an inarc */ + copyins(nfa, from, s); /* duplicate inarcs */ + cparc(nfa, con, s, to); /* move constraint arc */ + freearc(nfa, con); + from = s; + con = from->outs; + } + assert(from->nouts == 1); + + /* propagate the constraint into the from state's inarcs */ + for (a = from->ins; a != NULL; a = nexta) { + nexta = a->inchain; + switch (combine(con, a)) { + case INCOMPATIBLE: /* destroy the arc */ + freearc(nfa, a); + break; + case SATISFIED: /* no action needed */ + break; + case COMPATIBLE: /* swap the two arcs, more or less */ + s = newstate(nfa); + if (NISERR()) + return 0; + cparc(nfa, a, s, to); /* anticipate move */ + cparc(nfa, con, a->from, s); + if (NISERR()) + return 0; + freearc(nfa, a); + break; + default: + assert(NOTREACHED); + break; + } + } + + /* remaining inarcs, if any, incorporate the constraint */ + moveins(nfa, from, to); + dropstate(nfa, from); /* will free the constraint */ + return 1; +} + +/* + - pushfwd - push forward constraints forward to (with luck) eliminate them + ^ static VOID pushfwd(struct nfa *, FILE *); + */ +static VOID +pushfwd(nfa, f) +struct nfa *nfa; +FILE *f; /* for debug output; NULL none */ +{ + struct state *s; + struct state *nexts; + struct arc *a; + struct arc *nexta; + int progress; + + /* find and push until there are no more */ + do { + progress = 0; + for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { + nexts = s->next; + for (a = s->ins; a != NULL && !NISERR(); a = nexta) { + nexta = a->inchain; + if (a->type == '$' || a->type == AHEAD) + if (push(nfa, a)) + progress = 1; + assert(nexta == NULL || s->no != FREESTATE); + } + } + if (progress && f != NULL) + dumpnfa(nfa, f); + } while (progress && !NISERR()); + if (NISERR()) + return; + + for (a = nfa->post->ins; a != NULL; a = nexta) { + nexta = a->inchain; + if (a->type == '$') { + assert(a->co == 0 || a->co == 1); + newarc(nfa, PLAIN, nfa->eos[a->co], a->from, a->to); + freearc(nfa, a); + } + } +} + +/* + - push - push a forward constraint forward past its destination state + * A significant property of this function is that it deletes at most + * one state -- the constraint's to state -- and only if the constraint + * was that state's last inarc. + ^ static int push(struct nfa *, struct arc *); + */ +static int /* 0 couldn't, 1 could */ +push(nfa, con) +struct nfa *nfa; +struct arc *con; +{ + struct state *from = con->from; + struct state *to = con->to; + struct arc *a; + struct arc *nexta; + struct state *s; + + if (to == from) { /* circular constraint is pointless */ + freearc(nfa, con); + return 1; + } + if (to->flag) /* can't push forward beyond end */ + return 0; + if (to->nouts == 0) { /* dead end */ + freearc(nfa, con); + return 1; + } + + /* first, clone to state if necessary to avoid other inarcs */ + if (to->nins > 1) { + s = newstate(nfa); + if (NISERR()) + return 0; + copyouts(nfa, to, s); /* duplicate outarcs */ + cparc(nfa, con, from, s); /* move constraint */ + freearc(nfa, con); + to = s; + con = to->ins; + } + assert(to->nins == 1); + + /* propagate the constraint into the to state's outarcs */ + for (a = to->outs; a != NULL; a = nexta) { + nexta = a->outchain; + switch (combine(con, a)) { + case INCOMPATIBLE: /* destroy the arc */ + freearc(nfa, a); + break; + case SATISFIED: /* no action needed */ + break; + case COMPATIBLE: /* swap the two arcs, more or less */ + s = newstate(nfa); + if (NISERR()) + return 0; + cparc(nfa, con, s, a->to); /* anticipate move */ + cparc(nfa, a, from, s); + if (NISERR()) + return 0; + freearc(nfa, a); + break; + default: + assert(NOTREACHED); + break; + } + } + + /* remaining outarcs, if any, incorporate the constraint */ + moveouts(nfa, to, from); + dropstate(nfa, to); /* will free the constraint */ + return 1; +} + +/* + - combine - constraint lands on an arc, what happens? + ^ #def INCOMPATIBLE 1 // destroys arc + ^ #def SATISFIED 2 // constraint satisfied + ^ #def COMPATIBLE 3 // compatible but not satisfied yet + ^ static int combine(struct arc *, struct arc *); + */ +static int +combine(con, a) +struct arc *con; +struct arc *a; +{ +# define CA(ct,at) (((ct)<type, a->type)) { + case CA('^', PLAIN): /* newlines are handled separately */ + case CA('$', PLAIN): + return INCOMPATIBLE; + break; + case CA(AHEAD, PLAIN): /* color constraints meet colors */ + case CA(BEHIND, PLAIN): + if (con->co == a->co) + return SATISFIED; + return INCOMPATIBLE; + break; + case CA('^', '^'): /* collision, similar constraints */ + case CA('$', '$'): + case CA(AHEAD, AHEAD): + case CA(BEHIND, BEHIND): + if (con->co == a->co) /* true duplication */ + return SATISFIED; + return INCOMPATIBLE; + break; + case CA('^', BEHIND): /* collision, dissimilar constraints */ + case CA(BEHIND, '^'): + case CA('$', AHEAD): + case CA(AHEAD, '$'): + return INCOMPATIBLE; + break; + case CA('^', '$'): /* constraints passing each other */ + case CA('^', AHEAD): + case CA(BEHIND, '$'): + case CA(BEHIND, AHEAD): + case CA('$', '^'): + case CA('$', BEHIND): + case CA(AHEAD, '^'): + case CA(AHEAD, BEHIND): + case CA('^', LACON): + case CA(BEHIND, LACON): + case CA('$', LACON): + case CA(AHEAD, LACON): + return COMPATIBLE; + break; + } + assert(NOTREACHED); + return INCOMPATIBLE; /* for benefit of blind compilers */ +} + +/* + - fixempties - get rid of EMPTY arcs + ^ static VOID fixempties(struct nfa *, FILE *); + */ +static VOID +fixempties(nfa, f) +struct nfa *nfa; +FILE *f; /* for debug output; NULL none */ +{ + struct state *s; + struct state *nexts; + struct arc *a; + struct arc *nexta; + int progress; + + /* find and eliminate empties until there are no more */ + do { + progress = 0; + for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { + nexts = s->next; + for (a = s->outs; a != NULL && !NISERR(); a = nexta) { + nexta = a->outchain; + if (a->type == EMPTY && unempty(nfa, a)) + progress = 1; + assert(nexta == NULL || s->no != FREESTATE); + } + } + if (progress && f != NULL) + dumpnfa(nfa, f); + } while (progress && !NISERR()); +} + +/* + - unempty - optimize out an EMPTY arc, if possible + * Actually, as it stands this function always succeeds, but the return + * value is kept with an eye on possible future changes. + ^ static int unempty(struct nfa *, struct arc *); + */ +static int /* 0 couldn't, 1 could */ +unempty(nfa, a) +struct nfa *nfa; +struct arc *a; +{ + struct state *from = a->from; + struct state *to = a->to; + int usefrom; /* work on from, as opposed to to? */ + + assert(a->type == EMPTY); + assert(from != nfa->pre && to != nfa->post); + + if (from == to) { /* vacuous loop */ + freearc(nfa, a); + return 1; + } + + /* decide which end to work on */ + usefrom = 1; /* default: attack from */ + if (from->nouts > to->nins) + usefrom = 0; + else if (from->nouts == to->nins) { + /* decide on secondary issue: move/copy fewest arcs */ + if (from->nins > to->nouts) + usefrom = 0; + } + + freearc(nfa, a); + if (usefrom) { + if (from->nouts == 0) { + /* was the state's only outarc */ + moveins(nfa, from, to); + freestate(nfa, from); + } else + copyins(nfa, from, to); + } else { + if (to->nins == 0) { + /* was the state's only inarc */ + moveouts(nfa, to, from); + freestate(nfa, to); + } else + copyouts(nfa, to, from); + } + + return 1; +} + +/* + - cleanup - clean up NFA after optimizations + ^ static VOID cleanup(struct nfa *); + */ +static VOID +cleanup(nfa) +struct nfa *nfa; +{ + struct state *s; + struct state *nexts; + int n; + + /* clear out unreachable or dead-end states */ + /* use pre to mark reachable, then post to mark can-reach-post */ + markreachable(nfa, nfa->pre, (struct state *)NULL, nfa->pre); + markcanreach(nfa, nfa->post, nfa->pre, nfa->post); + for (s = nfa->states; s != NULL; s = nexts) { + nexts = s->next; + if (s->tmp != nfa->post && !s->flag) + dropstate(nfa, s); + } + assert(nfa->post->nins == 0 || nfa->post->tmp == nfa->post); + cleartraverse(nfa, nfa->pre); + assert(nfa->post->nins == 0 || nfa->post->tmp == NULL); + /* the nins==0 (final unreachable) case will be caught later */ + + /* renumber surviving states */ + n = 0; + for (s = nfa->states; s != NULL; s = s->next) + s->no = n++; + nfa->nstates = n; +} + +/* + - markreachable - recursive marking of reachable states + ^ static VOID markreachable(struct nfa *, struct state *, struct state *, + ^ struct state *); + */ +static VOID +markreachable(nfa, s, okay, mark) +struct nfa *nfa; +struct state *s; +struct state *okay; /* consider only states with this mark */ +struct state *mark; /* the value to mark with */ +{ + struct arc *a; + + if (s->tmp != okay) + return; + s->tmp = mark; + + for (a = s->outs; a != NULL; a = a->outchain) + markreachable(nfa, a->to, okay, mark); +} + +/* + - markcanreach - recursive marking of states which can reach here + ^ static VOID markcanreach(struct nfa *, struct state *, struct state *, + ^ struct state *); + */ +static VOID +markcanreach(nfa, s, okay, mark) +struct nfa *nfa; +struct state *s; +struct state *okay; /* consider only states with this mark */ +struct state *mark; /* the value to mark with */ +{ + struct arc *a; + + if (s->tmp != okay) + return; + s->tmp = mark; + + for (a = s->ins; a != NULL; a = a->inchain) + markcanreach(nfa, a->from, okay, mark); +} + +/* + - analyze - ascertain potentially-useful facts about an optimized NFA + ^ static int analyze(struct nfa *); + */ +static int /* re_info bits to be ORed in */ +analyze(nfa) +struct nfa *nfa; +{ + struct arc *a; + struct arc *aa; + + if (nfa->pre->outs == NULL) + return REG_UIMPOSSIBLE; + for (a = nfa->pre->outs; a != NULL; a = a->outchain) + for (aa = a->to->outs; aa != NULL; aa = aa->outchain) + if (aa->to == nfa->post) + return REG_UEMPTYMATCH; + return 0; +} + +/* + - compact - compact an NFA + ^ static VOID compact(struct nfa *, struct cnfa *); + */ +static VOID +compact(nfa, cnfa) +struct nfa *nfa; +struct cnfa *cnfa; +{ + struct state *s; + struct arc *a; + size_t nstates; + size_t narcs; + struct carc *ca; + struct carc *first; + + assert (!NISERR()); + + nstates = 0; + narcs = 0; + for (s = nfa->states; s != NULL; s = s->next) { + nstates++; + narcs += 1 + s->nouts + 1; + /* 1 as a fake for flags, nouts for arcs, 1 as endmarker */ + } + + cnfa->states = (struct carc **)MALLOC(nstates * sizeof(struct carc *)); + cnfa->arcs = (struct carc *)MALLOC(narcs * sizeof(struct carc)); + if (cnfa->states == NULL || cnfa->arcs == NULL) { + if (cnfa->states != NULL) + FREE(cnfa->states); + if (cnfa->arcs != NULL) + FREE(cnfa->arcs); + NERR(REG_ESPACE); + return; + } + cnfa->nstates = nstates; + cnfa->pre = nfa->pre->no; + cnfa->post = nfa->post->no; + cnfa->bos[0] = nfa->bos[0]; + cnfa->bos[1] = nfa->bos[1]; + cnfa->eos[0] = nfa->eos[0]; + cnfa->eos[1] = nfa->eos[1]; + cnfa->ncolors = maxcolor(nfa->cm) + 1; + cnfa->flags = 0; + + ca = cnfa->arcs; + for (s = nfa->states; s != NULL; s = s->next) { + assert((size_t)s->no < nstates); + cnfa->states[s->no] = ca; + ca->co = 0; /* clear and skip flags "arc" */ + ca++; + first = ca; + for (a = s->outs; a != NULL; a = a->outchain) + switch (a->type) { + case PLAIN: + ca->co = a->co; + ca->to = a->to->no; + ca++; + break; + case LACON: + assert(s->no != cnfa->pre); + ca->co = (color)(cnfa->ncolors + a->co); + ca->to = a->to->no; + ca++; + cnfa->flags |= HASLACONS; + break; + default: + assert(NOTREACHED); + break; + } + carcsort(first, ca-1); + ca->co = COLORLESS; + ca->to = 0; + ca++; + } + assert(ca == &cnfa->arcs[narcs]); + assert(cnfa->nstates != 0); + + /* mark no-progress states */ + for (a = nfa->pre->outs; a != NULL; a = a->outchain) + cnfa->states[a->to->no]->co = 1; + cnfa->states[nfa->pre->no]->co = 1; +} + +/* + - carcsort - sort compacted-NFA arcs by color + * Really dumb algorithm, but if the list is long enough for that to matter, + * you're in real trouble anyway. + ^ static VOID carcsort(struct carc *, struct carc *); + */ +static VOID +carcsort(first, last) +struct carc *first; +struct carc *last; +{ + struct carc *p; + struct carc *q; + struct carc tmp; + + if (last - first <= 1) + return; + + for (p = first; p <= last; p++) + for (q = p; q <= last; q++) + if (p->co > q->co || + (p->co == q->co && p->to > q->to)) { + assert(p != q); + tmp = *p; + *p = *q; + *q = tmp; + } +} + +/* + - freecnfa - free a compacted NFA + ^ static VOID freecnfa(struct cnfa *); + */ +static VOID +freecnfa(cnfa) +struct cnfa *cnfa; +{ + assert(cnfa->nstates != 0); /* not empty already */ + cnfa->nstates = 0; + FREE(cnfa->states); + FREE(cnfa->arcs); +} + +/* + - dumpnfa - dump an NFA in human-readable form + ^ static VOID dumpnfa(struct nfa *, FILE *); + */ +static VOID +dumpnfa(nfa, f) +struct nfa *nfa; +FILE *f; +{ +#ifdef REG_DEBUG + struct state *s; + + fprintf(f, "pre %d, post %d", nfa->pre->no, nfa->post->no); + if (nfa->bos[0] != COLORLESS) + fprintf(f, ", bos [%ld]", (long)nfa->bos[0]); + if (nfa->bos[1] != COLORLESS) + fprintf(f, ", bol [%ld]", (long)nfa->bos[1]); + if (nfa->eos[0] != COLORLESS) + fprintf(f, ", eos [%ld]", (long)nfa->eos[0]); + if (nfa->eos[1] != COLORLESS) + fprintf(f, ", eol [%ld]", (long)nfa->eos[1]); + fprintf(f, "\n"); + for (s = nfa->states; s != NULL; s = s->next) + dumpstate(s, f); + if (nfa->parent == NULL) + dumpcolors(nfa->cm, f); + fflush(f); +#endif +} + +#ifdef REG_DEBUG /* subordinates of dumpnfa */ + +/* + - dumpstate - dump an NFA state in human-readable form + ^ static VOID dumpstate(struct state *, FILE *); + */ +static VOID +dumpstate(s, f) +struct state *s; +FILE *f; +{ + struct arc *a; + + fprintf(f, "%d%s%c", s->no, (s->tmp != NULL) ? "T" : "", + (s->flag) ? s->flag : '.'); + if (s->prev != NULL && s->prev->next != s) + fprintf(f, "\tstate chain bad\n"); + if (s->nouts == 0) + fprintf(f, "\tno out arcs\n"); + else + dumparcs(s, f); + fflush(f); + for (a = s->ins; a != NULL; a = a->inchain) { + if (a->to != s) + fprintf(f, "\tlink from %d to %d on %d's in-chain\n", + a->from->no, a->to->no, s->no); + } +} + +/* + - dumparcs - dump out-arcs in human-readable form + ^ static VOID dumparcs(struct state *, FILE *); + */ +static VOID +dumparcs(s, f) +struct state *s; +FILE *f; +{ + int pos; + + assert(s->nouts > 0); + /* printing arcs in reverse order is usually clearer */ + pos = dumprarcs(s->outs, s, f, 1); + if (pos != 1) + fprintf(f, "\n"); +} + +/* + - dumprarcs - dump remaining outarcs, recursively, in reverse order + ^ static int dumprarcs(struct arc *, struct state *, FILE *, int); + */ +static int /* resulting print position */ +dumprarcs(a, s, f, pos) +struct arc *a; +struct state *s; +FILE *f; +int pos; /* initial print position */ +{ + if (a->outchain != NULL) + pos = dumprarcs(a->outchain, s, f, pos); + dumparc(a, s, f); + if (pos == 5) { + fprintf(f, "\n"); + pos = 1; + } else + pos++; + return pos; +} + +/* + - dumparc - dump one outarc in readable form, including prefixing tab + ^ static VOID dumparc(struct arc *, struct state *, FILE *); + */ +static VOID +dumparc(a, s, f) +struct arc *a; +struct state *s; +FILE *f; +{ + struct arc *aa; + struct arcbatch *ab; + + fprintf(f, "\t"); + switch (a->type) { + case PLAIN: + fprintf(f, "[%ld]", (long)a->co); + break; + case AHEAD: + fprintf(f, ">%ld>", (long)a->co); + break; + case BEHIND: + fprintf(f, "<%ld<", (long)a->co); + break; + case LACON: + fprintf(f, ":%ld:", (long)a->co); + break; + case '^': + case '$': + fprintf(f, "%c%d", a->type, (int)a->co); + break; + case EMPTY: + break; + default: + fprintf(f, "0x%x/0%lo", a->type, (long)a->co); + break; + } + if (a->from != s) + fprintf(f, "?%d?", a->from->no); + for (ab = &a->from->oas; ab != NULL; ab = ab->next) { + for (aa = &ab->a[0]; aa < &ab->a[ABSIZE]; aa++) + if (aa == a) + break; /* NOTE BREAK OUT */ + if (aa < &ab->a[ABSIZE]) /* propagate break */ + break; /* NOTE BREAK OUT */ + } + if (ab == NULL) + fprintf(f, "?!?"); /* not in allocated space */ + fprintf(f, "->"); + if (a->to == NULL) { + fprintf(f, "NULL"); + return; + } + fprintf(f, "%d", a->to->no); + for (aa = a->to->ins; aa != NULL; aa = aa->inchain) + if (aa == a) + break; /* NOTE BREAK OUT */ + if (aa == NULL) + fprintf(f, "?!?"); /* missing from in-chain */ +} + +#endif /* ifdef REG_DEBUG */ + +/* + - dumpcnfa - dump a compacted NFA in human-readable form + ^ static VOID dumpcnfa(struct cnfa *, FILE *); + */ +static VOID +dumpcnfa(cnfa, f) +struct cnfa *cnfa; +FILE *f; +{ +#ifdef REG_DEBUG + int st; + + fprintf(f, "pre %d, post %d", cnfa->pre, cnfa->post); + if (cnfa->bos[0] != COLORLESS) + fprintf(f, ", bos [%ld]", (long)cnfa->bos[0]); + if (cnfa->bos[1] != COLORLESS) + fprintf(f, ", bol [%ld]", (long)cnfa->bos[1]); + if (cnfa->eos[0] != COLORLESS) + fprintf(f, ", eos [%ld]", (long)cnfa->eos[0]); + if (cnfa->eos[1] != COLORLESS) + fprintf(f, ", eol [%ld]", (long)cnfa->eos[1]); + if (cnfa->flags&HASLACONS) + fprintf(f, ", haslacons"); + fprintf(f, "\n"); + for (st = 0; st < cnfa->nstates; st++) + dumpcstate(st, cnfa->states[st], cnfa, f); + fflush(f); +#endif +} + +#ifdef REG_DEBUG /* subordinates of dumpcnfa */ + +/* + - dumpcstate - dump a compacted-NFA state in human-readable form + ^ static VOID dumpcstate(int, struct carc *, struct cnfa *, FILE *); + */ +static VOID +dumpcstate(st, ca, cnfa, f) +int st; +struct carc *ca; +struct cnfa *cnfa; +FILE *f; +{ + int i; + int pos; + + fprintf(f, "%d%s", st, (ca[0].co) ? ":" : "."); + pos = 1; + for (i = 1; ca[i].co != COLORLESS; i++) { + if (ca[i].co < cnfa->ncolors) + fprintf(f, "\t[%ld]->%d", (long)ca[i].co, ca[i].to); + else + fprintf(f, "\t:%ld:->%d", (long)ca[i].co-cnfa->ncolors, + ca[i].to); + if (pos == 5) { + fprintf(f, "\n"); + pos = 1; + } else + pos++; + } + if (i == 1 || pos != 1) + fprintf(f, "\n"); + fflush(f); +} + +#endif /* ifdef REG_DEBUG */ diff --git a/generic/regcomp.c b/generic/regcomp.c new file mode 100644 index 0000000..8e1b61c --- /dev/null +++ b/generic/regcomp.c @@ -0,0 +1,2124 @@ +/* + * re_*comp and friends - compile REs + * This file #includes several others (see the bottom). + */ + +#include "regguts.h" + +/* + * forward declarations, up here so forward datatypes etc. are defined early + */ +/* =====^!^===== begin forwards =====^!^===== */ +/* automatically gathered by fwd; do not hand-edit */ +/* === regcomp.c === */ +int compile _ANSI_ARGS_((regex_t *, CONST chr *, size_t, int)); +static VOID moresubs _ANSI_ARGS_((struct vars *, int)); +static int freev _ANSI_ARGS_((struct vars *, int)); +static VOID makescan _ANSI_ARGS_((struct vars *, struct nfa *)); +static struct subre *parse _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *)); +static struct subre *parsebranch _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *, int)); +static VOID parseqatom _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *, struct subre *)); +static VOID nonword _ANSI_ARGS_((struct vars *, int, struct state *, struct state *)); +static VOID word _ANSI_ARGS_((struct vars *, int, struct state *, struct state *)); +static int scannum _ANSI_ARGS_((struct vars *)); +static VOID repeat _ANSI_ARGS_((struct vars *, struct state *, struct state *, int, int)); +static VOID bracket _ANSI_ARGS_((struct vars *, struct state *, struct state *)); +static VOID cbracket _ANSI_ARGS_((struct vars *, struct state *, struct state *)); +static VOID brackpart _ANSI_ARGS_((struct vars *, struct state *, struct state *)); +static chr *scanplain _ANSI_ARGS_((struct vars *)); +static VOID leaders _ANSI_ARGS_((struct vars *, struct cvec *)); +static VOID onechr _ANSI_ARGS_((struct vars *, pchr, struct state *, struct state *)); +static VOID dovec _ANSI_ARGS_((struct vars *, struct cvec *, struct state *, struct state *)); +static celt nextleader _ANSI_ARGS_((struct vars *, pchr, pchr)); +static VOID wordchrs _ANSI_ARGS_((struct vars *)); +static struct subre *subre _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *)); +static VOID freesubre _ANSI_ARGS_((struct vars *, struct subre *)); +static VOID freesrnode _ANSI_ARGS_((struct vars *, struct subre *)); +static VOID optst _ANSI_ARGS_((struct vars *, struct subre *)); +static int numst _ANSI_ARGS_((struct subre *, int)); +static VOID markst _ANSI_ARGS_((struct subre *)); +static VOID cleanst _ANSI_ARGS_((struct vars *)); +static int nfatree _ANSI_ARGS_((struct vars *, struct subre *, FILE *)); +static int nfanode _ANSI_ARGS_((struct vars *, struct subre *, FILE *)); +static int newlacon _ANSI_ARGS_((struct vars *, struct state *, struct state *, int)); +static VOID freelacons _ANSI_ARGS_((struct subre *, int)); +static VOID rfree _ANSI_ARGS_((regex_t *)); +static VOID dump _ANSI_ARGS_((regex_t *, FILE *)); +static VOID dumpst _ANSI_ARGS_((struct subre *, FILE *, int)); +static VOID stdump _ANSI_ARGS_((struct subre *, FILE *, int, int)); +/* === regc_lex.c === */ +static VOID lexstart _ANSI_ARGS_((struct vars *)); +static VOID prefixes _ANSI_ARGS_((struct vars *)); +static VOID lexnest _ANSI_ARGS_((struct vars *, chr *, chr *)); +static VOID lexword _ANSI_ARGS_((struct vars *)); +static int next _ANSI_ARGS_((struct vars *)); +static int lexescape _ANSI_ARGS_((struct vars *)); +static chr lexdigits _ANSI_ARGS_((struct vars *, int, int, int)); +static int brenext _ANSI_ARGS_((struct vars *, pchr)); +static VOID skip _ANSI_ARGS_((struct vars *)); +static chr newline _ANSI_ARGS_((NOPARMS)); +static chr chrnamed _ANSI_ARGS_((struct vars *, chr *, chr *, pchr)); +/* === regc_color.c === */ +static VOID initcm _ANSI_ARGS_((struct vars *, struct colormap *)); +static VOID freecm _ANSI_ARGS_((struct colormap *)); +static VOID cmtreefree _ANSI_ARGS_((struct colormap *, union tree *, int)); +static color setcolor _ANSI_ARGS_((struct colormap *, pchr, pcolor)); +static color maxcolor _ANSI_ARGS_((struct colormap *)); +static color newcolor _ANSI_ARGS_((struct colormap *)); +static VOID freecolor _ANSI_ARGS_((struct colormap *, pcolor)); +static color pseudocolor _ANSI_ARGS_((struct colormap *)); +static color subcolor _ANSI_ARGS_((struct colormap *, pchr c)); +static color newsub _ANSI_ARGS_((struct colormap *, pcolor)); +static VOID subrange _ANSI_ARGS_((struct vars *, pchr, pchr, struct state *, struct state *)); +static VOID subblock _ANSI_ARGS_((struct vars *, pchr, struct state *, struct state *)); +static VOID okcolors _ANSI_ARGS_((struct nfa *, struct colormap *)); +static VOID colorchain _ANSI_ARGS_((struct colormap *, struct arc *)); +static VOID uncolorchain _ANSI_ARGS_((struct colormap *, struct arc *)); +#if 0 +static int singleton _ANSI_ARGS_((struct colormap *, pchr c)); +#endif +static VOID rainbow _ANSI_ARGS_((struct nfa *, struct colormap *, int, pcolor, struct state *, struct state *)); +static VOID colorcomplement _ANSI_ARGS_((struct nfa *, struct colormap *, int, struct state *, struct state *, struct state *)); +#ifdef REG_DEBUG +static VOID dumpcolors _ANSI_ARGS_((struct colormap *, FILE *)); +static VOID fillcheck _ANSI_ARGS_((struct colormap *, union tree *, int, FILE *)); +static VOID dumpchr _ANSI_ARGS_((pchr, FILE *)); +#endif +/* === regc_nfa.c === */ +static struct nfa *newnfa _ANSI_ARGS_((struct vars *, struct colormap *, struct nfa *)); +static VOID freenfa _ANSI_ARGS_((struct nfa *)); +static struct state *newfstate _ANSI_ARGS_((struct nfa *, int flag)); +static struct state *newstate _ANSI_ARGS_((struct nfa *)); +static VOID dropstate _ANSI_ARGS_((struct nfa *, struct state *)); +static VOID freestate _ANSI_ARGS_((struct nfa *, struct state *)); +static VOID destroystate _ANSI_ARGS_((struct nfa *, struct state *)); +static VOID newarc _ANSI_ARGS_((struct nfa *, int, pcolor, struct state *, struct state *)); +static struct arc *allocarc _ANSI_ARGS_((struct nfa *, struct state *)); +static VOID freearc _ANSI_ARGS_((struct nfa *, struct arc *)); +static struct arc *findarc _ANSI_ARGS_((struct state *, int, pcolor)); +static VOID cparc _ANSI_ARGS_((struct nfa *, struct arc *, struct state *, struct state *)); +static VOID moveins _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID copyins _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID moveouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID copyouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID cloneouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *, int)); +static VOID delsub _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID deltraverse _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID dupnfa _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *, struct state *)); +static VOID duptraverse _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID cleartraverse _ANSI_ARGS_((struct nfa *, struct state *)); +static VOID specialcolors _ANSI_ARGS_((struct nfa *)); +static int optimize _ANSI_ARGS_((struct nfa *, FILE *)); +static VOID pullback _ANSI_ARGS_((struct nfa *, FILE *)); +static int pull _ANSI_ARGS_((struct nfa *, struct arc *)); +static VOID pushfwd _ANSI_ARGS_((struct nfa *, FILE *)); +static int push _ANSI_ARGS_((struct nfa *, struct arc *)); +#define INCOMPATIBLE 1 /* destroys arc */ +#define SATISFIED 2 /* constraint satisfied */ +#define COMPATIBLE 3 /* compatible but not satisfied yet */ +static int combine _ANSI_ARGS_((struct arc *, struct arc *)); +static VOID fixempties _ANSI_ARGS_((struct nfa *, FILE *)); +static int unempty _ANSI_ARGS_((struct nfa *, struct arc *)); +static VOID cleanup _ANSI_ARGS_((struct nfa *)); +static VOID markreachable _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *)); +static VOID markcanreach _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *)); +static int analyze _ANSI_ARGS_((struct nfa *)); +static VOID compact _ANSI_ARGS_((struct nfa *, struct cnfa *)); +static VOID carcsort _ANSI_ARGS_((struct carc *, struct carc *)); +static VOID freecnfa _ANSI_ARGS_((struct cnfa *)); +static VOID dumpnfa _ANSI_ARGS_((struct nfa *, FILE *)); +#ifdef REG_DEBUG +static VOID dumpstate _ANSI_ARGS_((struct state *, FILE *)); +static VOID dumparcs _ANSI_ARGS_((struct state *, FILE *)); +static int dumprarcs _ANSI_ARGS_((struct arc *, struct state *, FILE *, int)); +static VOID dumparc _ANSI_ARGS_((struct arc *, struct state *, FILE *)); +#endif +static VOID dumpcnfa _ANSI_ARGS_((struct cnfa *, FILE *)); +#ifdef REG_DEBUG +static VOID dumpcstate _ANSI_ARGS_((int, struct carc *, struct cnfa *, FILE *)); +#endif +/* === regc_cvec.c === */ +static struct cvec *newcvec _ANSI_ARGS_((int, int, int)); +static struct cvec *clearcvec _ANSI_ARGS_((struct cvec *)); +static VOID addchr _ANSI_ARGS_((struct cvec *, pchr)); +static VOID addrange _ANSI_ARGS_((struct cvec *, pchr, pchr)); +#ifdef USE_MCCE +static VOID addmcce _ANSI_ARGS_((struct cvec *, chr *, chr *)); +#endif +static int haschr _ANSI_ARGS_((struct cvec *, pchr)); +static struct cvec *getcvec _ANSI_ARGS_((struct vars *, int, int, int)); +static VOID freecvec _ANSI_ARGS_((struct cvec *)); +/* === regc_locale.c === */ +static int nmcces _ANSI_ARGS_((struct vars *)); +static int nleaders _ANSI_ARGS_((struct vars *)); +static struct cvec *allmcces _ANSI_ARGS_((struct vars *, struct cvec *)); +static celt element _ANSI_ARGS_((struct vars *, chr *, chr *)); +static struct cvec *range _ANSI_ARGS_((struct vars *, celt, celt, int)); +static int before _ANSI_ARGS_((celt, celt)); +static struct cvec *eclass _ANSI_ARGS_((struct vars *, celt, int)); +static struct cvec *cclass _ANSI_ARGS_((struct vars *, chr *, chr *, int)); +static struct cvec *allcases _ANSI_ARGS_((struct vars *, pchr)); +static int cmp _ANSI_ARGS_((CONST chr *, CONST chr *, size_t)); +static int casecmp _ANSI_ARGS_((CONST chr *, CONST chr *, size_t)); +/* automatically gathered by fwd; do not hand-edit */ +/* =====^!^===== end forwards =====^!^===== */ + + + +/* internal variables, bundled for easy passing around */ +struct vars { + regex_t *re; + chr *now; /* scan pointer into string */ + chr *stop; /* end of string */ + chr *savenow; /* saved now and stop for "subroutine call" */ + chr *savestop; + int err; /* error code (0 if none) */ + int cflags; /* copy of compile flags */ + int lasttype; /* type of previous token */ + int nexttype; /* type of next token */ + chr nextvalue; /* value (if any) of next token */ + int lexcon; /* lexical context type (see lex.c) */ + int nsubexp; /* subexpression count */ + struct subre **subs; /* subRE pointer vector */ + size_t nsubs; /* length of vector */ + struct subre *sub10[10]; /* initial vector, enough for most */ + struct nfa *nfa; /* the NFA */ + struct colormap *cm; /* character color map */ + color nlcolor; /* color of newline */ + struct state *wordchrs; /* state in nfa holding word-char outarcs */ + struct subre *tree; /* subexpression tree */ + struct subre *treechain; /* all tree nodes allocated */ + struct subre *treefree; /* any free tree nodes */ + int ntree; /* number of tree nodes */ + struct cvec *cv; /* interface cvec */ + struct cvec *cv2; /* utility cvec */ + struct cvec *mcces; /* collating-element information */ +# define ISCELEADER(v,c) (v->mcces != NULL && haschr(v->mcces, (c))) + struct state *mccepbegin; /* in nfa, start of MCCE prototypes */ + struct state *mccepend; /* in nfa, end of MCCE prototypes */ + struct subre *lacons; /* lookahead-constraint vector */ + int nlacons; /* size of lacons */ + int usedshorter; /* used short-preferring quantifiers */ + int unmatchable; /* can never match */ +}; + +/* parsing macros; most know that `v' is the struct vars pointer */ +#define NEXT() (next(v)) /* advance by one token */ +#define SEE(t) (v->nexttype == (t)) /* is next token this? */ +#define EAT(t) (SEE(t) && next(v)) /* if next is this, swallow it */ +#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */ +#define ISERR() VISERR(v) +#define VERR(vv,e) ((vv)->nexttype = EOS, ((vv)->err) ? (vv)->err :\ + ((vv)->err = (e))) +#define ERR(e) VERR(v, e) /* record an error */ +#define NOERR() {if (ISERR()) return;} /* if error seen, return */ +#define NOERRN() {if (ISERR()) return NULL;} /* NOERR with retval */ +#define NOERRZ() {if (ISERR()) return 0;} /* NOERR with retval */ +#define INSIST(c, e) ((c) ? 0 : ERR(e)) /* if condition false, error */ +#define NOTE(b) (v->re->re_info |= (b)) /* note visible condition */ +#define EMPTYARC(x, y) newarc(v->nfa, EMPTY, 0, x, y) + +/* token type codes, some also used as NFA arc types */ +#define EMPTY 'n' /* no token present */ +#define EOS 'e' /* end of string */ +#define PLAIN 'p' /* ordinary character */ +#define DIGIT 'd' /* digit (in bound) */ +#define BACKREF 'b' /* back reference */ +#define COLLEL 'I' /* start of [. */ +#define ECLASS 'E' /* start of [= */ +#define CCLASS 'C' /* start of [: */ +#define END 'X' /* end of [. [= [: */ +#define RANGE 'R' /* - within [] which might be range delim. */ +#define LACON 'L' /* lookahead constraint subRE */ +#define AHEAD 'a' /* color-lookahead arc */ +#define BEHIND 'r' /* color-lookbehind arc */ +#define WBDRY 'w' /* word boundary constraint */ +#define NWBDRY 'W' /* non-word-boundary constraint */ +#define SBEGIN 'A' /* beginning of string (even if not BOL) */ +#define SEND 'Z' /* end of string (even if not EOL) */ +#define PREFER 'P' /* length preference */ + +/* is an arc colored, and hence on a color chain? */ +#define COLORED(a) ((a)->type == PLAIN || (a)->type == AHEAD || \ + (a)->type == BEHIND) + + + +/* static function list */ +static struct fns functions = { + rfree, /* regfree insides */ +}; + + + +/* + - compile - compile regular expression + ^ int compile(regex_t *, CONST chr *, size_t, int); + */ +int +compile(re, string, len, flags) +regex_t *re; +CONST chr *string; +size_t len; +int flags; +{ + struct vars var; + struct vars *v = &var; + struct guts *g; + int i; + size_t j; + FILE *debug = (flags®_PROGRESS) ? stdout : (FILE *)NULL; +# define CNOERR() { if (ISERR()) return freev(v, v->err); } + + /* sanity checks */ + + if (re == NULL || string == NULL) + return REG_INVARG; + if ((flags®_QUOTE) && + (flags&(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE))) + return REG_INVARG; + if (!(flags®_EXTENDED) && (flags®_ADVF)) + return REG_INVARG; + + /* initial setup (after which freev() is callable) */ + v->re = re; + v->now = (chr *)string; + v->stop = v->now + len; + v->savenow = v->savestop = NULL; + v->err = 0; + v->cflags = flags; + v->nsubexp = 0; + v->subs = v->sub10; + v->nsubs = 10; + for (j = 0; j < v->nsubs; j++) + v->subs[j] = NULL; + v->nfa = NULL; + v->cm = NULL; + v->nlcolor = COLORLESS; + v->wordchrs = NULL; + v->tree = NULL; + v->treechain = NULL; + v->treefree = NULL; + v->cv = NULL; + v->cv2 = NULL; + v->mcces = NULL; + v->lacons = NULL; + v->nlacons = 0; + re->re_magic = REMAGIC; + re->re_info = 0; /* bits get set during parse */ + re->re_csize = sizeof(chr); + re->re_guts = NULL; + re->re_fns = VS(&functions); + + /* more complex setup, malloced things */ + re->re_guts = VS(MALLOC(sizeof(struct guts))); + if (re->re_guts == NULL) + return freev(v, REG_ESPACE); + g = (struct guts *)re->re_guts; + g->tree = NULL; + initcm(v, &g->cmap); + v->cm = &g->cmap; + g->lacons = NULL; + g->nlacons = 0; + ZAPCNFA(g->search); + v->nfa = newnfa(v, v->cm, (struct nfa *)NULL); + CNOERR(); + v->cv = newcvec(100, 20, 10); + if (v->cv == NULL) + return freev(v, REG_ESPACE); + i = nmcces(v); + if (i > 0) { + v->mcces = newcvec(nleaders(v), 0, i); + CNOERR(); + v->mcces = allmcces(v, v->mcces); + leaders(v, v->mcces); + } + CNOERR(); + + /* parsing */ + lexstart(v); /* also handles prefixes */ + if ((v->cflags®_NLSTOP) || (v->cflags®_NLANCH)) { + /* assign newline a unique color */ + v->nlcolor = subcolor(v->cm, newline()); + okcolors(v->nfa, v->cm); + } + CNOERR(); + v->tree = parse(v, EOS, PLAIN, v->nfa->init, v->nfa->final); + assert(SEE(EOS)); /* even if error; ISERR() => SEE(EOS) */ + CNOERR(); + assert(v->tree != NULL); + + /* finish setup of nfa and its subre tree */ + specialcolors(v->nfa); + CNOERR(); + if (debug != NULL) { + dumpnfa(v->nfa, debug); + dumpst(v->tree, debug, 1); + } + v->usedshorter = 0; + v->unmatchable = 0; + optst(v, v->tree); + v->ntree = numst(v->tree, 1); + markst(v->tree); + cleanst(v); + if (debug != NULL) { + fprintf(debug, "-->\n"); + dumpst(v->tree, debug, 1); + } + + /* build compacted NFAs for tree, lacons, fast search */ + re->re_info |= nfatree(v, v->tree, debug); + if (debug != NULL) { + fprintf(debug, "---->\n"); + dumpst(v->tree, debug, 1); + } + CNOERR(); + if (re->re_info®_UIMPOSSIBLE) + v->unmatchable = 1; + assert(v->nlacons == 0 || v->lacons != NULL); + for (i = 1; i < v->nlacons; i++) + nfanode(v, &v->lacons[i], debug); + CNOERR(); + (DISCARD)optimize(v->nfa, debug); + CNOERR(); + makescan(v, v->nfa); + CNOERR(); + compact(v->nfa, &g->search); + CNOERR(); + + /* looks okay, package it up */ + re->re_nsub = v->nsubexp; + v->re = NULL; /* freev no longer frees re */ + g->magic = GUTSMAGIC; + g->cflags = v->cflags; + g->info = re->re_info; + g->nsub = re->re_nsub; + g->tree = v->tree; + v->tree = NULL; + g->ntree = v->ntree; + g->compare = (v->cflags®_ICASE) ? casecmp : cmp; + g->lacons = v->lacons; + v->lacons = NULL; + g->nlacons = v->nlacons; + g->usedshorter = v->usedshorter; + g->unmatchable = v->unmatchable; + + if (flags®_DUMP) + dump(re, stdout); + + assert(v->err == 0); + return freev(v, 0); +} + +/* + - moresubs - enlarge subRE vector + ^ static VOID moresubs(struct vars *, int); + */ +static VOID +moresubs(v, wanted) +struct vars *v; +int wanted; /* want enough room for this one */ +{ + struct subre **p; + size_t n; + + assert(wanted > 0 && (size_t)wanted >= v->nsubs); + n = (size_t)wanted * 3 / 2 + 1; + if (v->subs == v->sub10) { + p = (struct subre **)MALLOC(n * sizeof(struct subre *)); + if (p != NULL) + memcpy(VS(p), VS(v->subs), + v->nsubs * sizeof(struct subre *)); + } else + p = (struct subre**)REALLOC(v->subs, n*sizeof(struct subre *)); + if (p == NULL) { + ERR(REG_ESPACE); + return; + } + v->subs = p; + for (p = &v->subs[v->nsubs]; v->nsubs < n; p++, v->nsubs++) + *p = NULL; + assert(v->nsubs == n); + assert((size_t)wanted < v->nsubs); +} + +/* + - freev - free vars struct's substructures where necessary + * Optionally does error-number setting, and always returns error code + * (if any), to make error-handling code terser. + ^ static int freev(struct vars *, int); + */ +static int +freev(v, err) +struct vars *v; +int err; +{ + if (v->re != NULL) + rfree(v->re); + if (v->subs != v->sub10) + FREE(v->subs); + if (v->nfa != NULL) + freenfa(v->nfa); + if (v->tree != NULL) + freesubre(v, v->tree); + if (v->treechain != NULL) + cleanst(v); + if (v->cv != NULL) + freecvec(v->cv); + if (v->cv2 != NULL) + freecvec(v->cv2); + if (v->mcces != NULL) + freecvec(v->mcces); + if (v->lacons != NULL) + freelacons(v->lacons, v->nlacons); + ERR(err); /* nop if err==0 */ + + return v->err; +} + +/* + - makescan - turn an NFA into a fast-scan NFA (implicit prepend of .*?) + * NFA must have been optimize()d already. + ^ static VOID makescan(struct vars *, struct nfa *); + */ +static VOID +makescan(v, nfa) +struct vars *v; +struct nfa *nfa; +{ + struct arc *a; + struct arc *b; + struct state *pre = nfa->pre; + struct state *s; + struct state *s2; + struct state *slist; + + /* no loops are needed if it's anchored */ + for (a = pre->outs; a != NULL; a = a->outchain) { + assert(a->type == PLAIN); + if (a->co != nfa->bos[0] && a->co != nfa->bos[1]) + break; + } + if (a != NULL) { + /* add implicit .* in front */ + rainbow(nfa, v->cm, PLAIN, COLORLESS, pre, pre); + + /* and ^* and \Z* too -- not always necessary, but harmless */ + newarc(nfa, PLAIN, nfa->bos[0], pre, pre); + newarc(nfa, PLAIN, nfa->bos[1], pre, pre); + } + + /* + * Now here's the subtle part. Because many REs have no lookback + * constraints, often knowing when you were in the pre state tells + * you little; it's the next state(s) that are informative. But + * some of them may have other inarcs, i.e. it may be possible to + * make actual progress and then return to one of them. We must + * de-optimize such cases, splitting each such state into progress + * and no-progress states. + */ + + /* first, make a list of the states */ + slist = NULL; + for (a = pre->outs; a != NULL; a = a->outchain) { + s = a->to; + for (b = s->ins; b != NULL; b = b->inchain) + if (b->from != pre) + break; + if (b != NULL) { /* must be split */ + s->tmp = slist; + slist = s; + } + } + + /* do the splits */ + for (s = slist; s != NULL; s = s2) { + s2 = newstate(nfa); + copyouts(nfa, s, s2); + for (a = s->ins; a != NULL; a = b) { + b = a->inchain; + if (a->from != pre) { + cparc(nfa, a, a->from, s2); + freearc(nfa, a); + } + } + s2 = s->tmp; + s->tmp = NULL; /* clean up while we're at it */ + } +} + +/* + - parse - parse an RE + * This is actually just the top level, which parses a bunch of branches + * tied together with '|'. They appear in the tree as the left children + * of a chain of '|' subres. + ^ static struct subre *parse(struct vars *, int, int, struct state *, + ^ struct state *); + */ +static struct subre * +parse(v, stopper, type, init, final) +struct vars *v; +int stopper; /* EOS or ')' */ +int type; /* LACON (lookahead subRE) or PLAIN */ +struct state *init; /* initial state */ +struct state *final; /* final state */ +{ + struct state *left; /* scaffolding for branch */ + struct state *right; + struct subre *branches; /* top level */ + struct subre *branch; /* current branch */ + struct subre *t; /* temporary */ + int firstbranch; /* is this the first branch? */ + + assert(stopper == ')' || stopper == EOS); + + branches = subre(v, '|', LONGER, init, final); + NOERRN(); + branch = branches; + firstbranch = 1; + do { /* a branch */ + if (!firstbranch) { + /* need a place to hang it */ + branch->right = subre(v, '|', LONGER, init, final); + NOERRN(); + branch = branch->right; + } + firstbranch = 0; + left = newstate(v->nfa); + right = newstate(v->nfa); + NOERRN(); + EMPTYARC(init, left); + EMPTYARC(right, final); + NOERRN(); + branch->left = parsebranch(v, stopper, type, left, right, 0); + NOERRN(); + branch->flags |= UP(branch->flags | branch->left->flags); + if ((branch->flags &~ branches->flags) != 0) /* new flags */ + for (t = branches; t != branch; t = t->right) + t->flags |= branch->flags; + } while (EAT('|')); + assert(SEE(stopper) || SEE(EOS)); + + if (!SEE(stopper)) { + assert(stopper == ')' && SEE(EOS)); + ERR(REG_EPAREN); + } + + /* optimize out simple cases */ + if (branch == branches) { /* only one branch */ + assert(branch->right == NULL); + t = branch->left; + branch->left = NULL; + freesubre(v, branches); + branches = t; + } else if (!MESSY(branches->flags)) { /* no interesting innards */ + freesubre(v, branches->left); + branches->left = NULL; + freesubre(v, branches->right); + branches->right = NULL; + branches->op = '='; + } + + return branches; +} + +/* + - parsebranch - parse one branch of an RE + * This mostly manages concatenation, working closely with parseqatom(). + * Concatenated things are bundled up as much as possible, with separate + * ',' nodes introduced only when necessary due to substructure. + ^ static struct subre *parsebranch(struct vars *, int, int, struct state *, + ^ struct state *, int); + */ +static struct subre * +parsebranch(v, stopper, type, left, right, partial) +struct vars *v; +int stopper; /* EOS or ')' */ +int type; /* LACON (lookahead subRE) or PLAIN */ +struct state *left; /* leftmost state */ +struct state *right; /* rightmost state */ +int partial; /* is this only part of a branch? */ +{ + struct state *lp; /* left end of current construct */ + int seencontent; /* is there anything in this branch yet? */ + struct subre *t; + + lp = left; + seencontent = 0; + t = subre(v, '=', 0, left, right); /* op '=' is tentative */ + NOERRN(); + while (!SEE('|') && !SEE(stopper) && !SEE(EOS)) { + if (seencontent) { /* implicit concat operator */ + lp = newstate(v->nfa); + NOERRN(); + moveins(v->nfa, right, lp); + } + seencontent = 1; + + /* NB, recursion in parseqatom() may swallow rest of branch */ + parseqatom(v, stopper, type, lp, right, t); + } + + if (!seencontent) { /* empty branch */ + if (!partial) + NOTE(REG_UUNSPEC); + assert(lp == left); + EMPTYARC(left, right); + } + + return t; +} + +/* + - parseqatom - parse one quantified atom or constraint of an RE + * The bookkeeping near the end cooperates very closely with parsebranch(); + * in particular, it contains a recursion that can involve parsing the rest + * of the branch, making this function's name somewhat inaccurate. + ^ static VOID parseqatom(struct vars *, int, int, struct state *, + ^ struct state *, struct subre *); + */ +static VOID +parseqatom(v, stopper, type, lp, rp, top) +struct vars *v; +int stopper; /* EOS or ')' */ +int type; /* LACON (lookahead subRE) or PLAIN */ +struct state *lp; /* left state to hang it on */ +struct state *rp; /* right state to hang it on */ +struct subre *top; /* subtree top */ +{ + struct state *s; /* temporaries for new states */ + struct state *s2; +# define ARCV(t, val) newarc(v->nfa, t, val, lp, rp) + int m, n; + struct subre *atom; /* atom's subtree */ + struct subre *t; + int cap; /* capturing parens? */ + int pos; /* positive lookahead? */ + int subno; /* capturing-parens or backref number */ + int atomtype; + int qprefer; /* quantifier short/long preference */ + int f; + struct subre **atomp; /* where the pointer to atom is */ + + /* initial bookkeeping */ + atom = NULL; + assert(lp->nouts == 0); /* must string new code */ + assert(rp->nins == 0); /* between lp and rp */ + subno = 0; /* just to shut lint up */ + + /* an atom or constraint... */ + atomtype = v->nexttype; + switch (atomtype) { + /* first, constraints, which end by returning */ + case '^': + ARCV('^', 1); + if (v->cflags®_NLANCH) + ARCV(BEHIND, v->nlcolor); + NEXT(); + return; + break; + case '$': + ARCV('$', 1); + if (v->cflags®_NLANCH) + ARCV(AHEAD, v->nlcolor); + NEXT(); + return; + break; + case SBEGIN: + ARCV('^', 1); /* BOL */ + ARCV('^', 0); /* or BOS */ + NEXT(); + return; + break; + case SEND: + ARCV('$', 1); /* EOL */ + ARCV('$', 0); /* or EOS */ + NEXT(); + return; + break; + case '<': + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERR(); + nonword(v, BEHIND, lp, s); + word(v, AHEAD, s, rp); + return; + break; + case '>': + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERR(); + word(v, BEHIND, lp, s); + nonword(v, AHEAD, s, rp); + return; + break; + case WBDRY: + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERR(); + nonword(v, BEHIND, lp, s); + word(v, AHEAD, s, rp); + s = newstate(v->nfa); + NOERR(); + word(v, BEHIND, lp, s); + nonword(v, AHEAD, s, rp); + return; + break; + case NWBDRY: + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERR(); + word(v, BEHIND, lp, s); + word(v, AHEAD, s, rp); + s = newstate(v->nfa); + NOERR(); + nonword(v, BEHIND, lp, s); + nonword(v, AHEAD, s, rp); + return; + break; + case LACON: /* lookahead constraint */ + pos = v->nextvalue; + NEXT(); + s = newstate(v->nfa); + s2 = newstate(v->nfa); + NOERR(); + t = parse(v, ')', LACON, s, s2); + freesubre(v, t); /* internal structure irrelevant */ + assert(SEE(')') || ISERR()); + NEXT(); + n = newlacon(v, s, s2, pos); + NOERR(); + ARCV(LACON, n); + return; + break; + /* then errors, to get them out of the way */ + case '*': + case '+': + case '?': + case '{': + ERR(REG_BADRPT); + return; + break; + default: + ERR(REG_ASSERT); + return; + break; + /* then plain characters, and minor variants on that theme */ + case ')': /* unbalanced paren */ + if ((v->cflags®_ADVANCED) != REG_EXTENDED) { + ERR(REG_EPAREN); + return; + } + /* legal in EREs due to specification botch */ + NOTE(REG_UPBOTCH); + /* fallthrough into case PLAIN */ + case PLAIN: + onechr(v, v->nextvalue, lp, rp); + okcolors(v->nfa, v->cm); + NOERR(); + NEXT(); + break; + case '[': + if (v->nextvalue == 1) + bracket(v, lp, rp); + else + cbracket(v, lp, rp); + assert(SEE(']') || ISERR()); + NEXT(); + break; + case '.': + rainbow(v->nfa, v->cm, PLAIN, + (v->cflags®_NLSTOP) ? v->nlcolor : COLORLESS, + lp, rp); + NEXT(); + break; + /* and finally the ugly stuff */ + case '(': /* value flags as capturing or non */ + cap = (type == LACON) ? 0 : v->nextvalue; + if (cap) { + v->nsubexp++; + subno = v->nsubexp; + if ((size_t)subno >= v->nsubs) + moresubs(v, subno); + assert((size_t)subno < v->nsubs); + } else + atomtype = PLAIN; /* something that's not '(' */ + NEXT(); + /* need new endpoints because tree will contain pointers */ + s = newstate(v->nfa); + s2 = newstate(v->nfa); + NOERR(); + EMPTYARC(lp, s); + EMPTYARC(s2, rp); + NOERR(); + atom = parse(v, ')', PLAIN, s, s2); + assert(SEE(')') || ISERR()); + NEXT(); + NOERR(); + if (cap) { + v->subs[subno] = atom; + t = subre(v, '(', atom->flags|CAP, lp, rp); + NOERR(); + t->subno = subno; + t->left = atom; + atom = t; + } + /* postpone everything else pending possible {0} */ + break; + case BACKREF: /* the Feature From The Black Lagoon */ + INSIST(type != LACON, REG_ESUBREG); + INSIST(v->nextvalue < v->nsubs, REG_ESUBREG); + INSIST(v->subs[v->nextvalue] != NULL, REG_ESUBREG); + NOERR(); + assert(v->nextvalue > 0); + atom = subre(v, 'b', BACKR, lp, rp); + subno = v->nextvalue; + atom->subno = subno; + EMPTYARC(lp, rp); /* temporarily, so there's something */ + NEXT(); + break; + } + + /* ...and an atom may be followed by a quantifier */ + switch (v->nexttype) { + case '*': + m = 0; + n = INFINITY; + qprefer = (v->nextvalue) ? LONGER : SHORTER; + NEXT(); + break; + case '+': + m = 1; + n = INFINITY; + qprefer = (v->nextvalue) ? LONGER : SHORTER; + NEXT(); + break; + case '?': + m = 0; + n = 1; + qprefer = (v->nextvalue) ? LONGER : SHORTER; + NEXT(); + break; + case '{': + NEXT(); + m = scannum(v); + if (EAT(',')) { + if (SEE(DIGIT)) + n = scannum(v); + else + n = INFINITY; + if (m > n) { + ERR(REG_BADBR); + return; + } + /* {m,n} exercises preference, even if it's {m,m} */ + qprefer = (v->nextvalue) ? LONGER : SHORTER; + } else { + n = m; + /* {m} passes operand's preference through */ + qprefer = 0; + } + if (!SEE('}')) { /* catches errors too */ + ERR(REG_BADBR); + return; + } + NEXT(); + break; + default: /* no quantifier */ + m = n = 1; + qprefer = 0; + break; + } + + /* annoying special case: {0} or {0,0} cancels everything */ + if (m == 0 && n == 0) { + if (atom != NULL) + freesubre(v, atom); + if (atomtype == '(') + v->subs[subno] = NULL; + delsub(v->nfa, lp, rp); + EMPTYARC(lp, rp); + return; + } + + /* if not a messy case, avoid hard part */ + assert(!MESSY(top->flags)); + f = top->flags | qprefer | ((atom != NULL) ? atom->flags : 0); + if (atomtype != '(' && atomtype != BACKREF && !MESSY(UP(f))) { + if (!(m == 1 && n == 1)) + repeat(v, lp, rp, m, n); + if (atom != NULL) + freesubre(v, atom); + top->flags = f; + return; + } + + /* + * hard part: something messy + * That is, capturing parens, back reference, short/long clash, or + * an atom with substructure containing one of those. + */ + + /* now we'll need a subre for the contents even if they're boring */ + if (atom == NULL) { + atom = subre(v, '=', 0, lp, rp); + NOERR(); + } + + /* + * prepare a general-purpose state skeleton + * + * ---> [s] ---prefix---> [begin] ---atom---> [end] ----rest---> [rp] + * / / + * [lp] ----> [s2] ----bypass--------------------- + * + * where bypass is an empty, and prefix is some repetitions of atom + */ + s = newstate(v->nfa); /* first, new endpoints for the atom */ + s2 = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + moveins(v->nfa, rp, s2); + NOERR(); + atom->begin = s; + atom->end = s2; + s = newstate(v->nfa); /* and spots for prefix and bypass */ + s2 = newstate(v->nfa); + NOERR(); + EMPTYARC(lp, s); + EMPTYARC(lp, s2); + NOERR(); + + /* break remaining subRE into x{...} and what follows */ + t = subre(v, '.', COMBINE(qprefer, atom->flags), lp, rp); + t->left = atom; + atomp = &t->left; + /* here we should recurse... but we must postpone that to the end */ + + /* split top into prefix and remaining */ + assert(top->op == '=' && top->left == NULL && top->right == NULL); + top->left = subre(v, '=', top->flags, top->begin, lp); + top->op = '.'; + top->right = t; + + /* if it's a backref, now is the time to replicate the subNFA */ + if (atomtype == BACKREF) { + assert(atom->begin->nouts == 1); /* just the EMPTY */ + delsub(v->nfa, atom->begin, atom->end); + assert(v->subs[subno] != NULL); + /* and here's why the recursion got postponed: it must */ + /* wait until the skeleton is filled in, because it may */ + /* hit a backref that wants to copy the filled-in skeleton */ + dupnfa(v->nfa, v->subs[subno]->begin, v->subs[subno]->end, + atom->begin, atom->end); + NOERR(); + } + + /* it's quantifier time; first, turn x{0,...} into x{1,...}|empty */ + if (m == 0) { + EMPTYARC(s2, atom->end); /* the bypass */ + assert(PREF(qprefer) != 0); + f = COMBINE(qprefer, atom->flags); + t = subre(v, '|', f, lp, atom->end); + NOERR(); + t->left = atom; + t->right = subre(v, '|', PREF(f), s2, atom->end); + NOERR(); + t->right->left = subre(v, '=', 0, s2, atom->end); + NOERR(); + *atomp = t; + atomp = &t->left; + m = 1; + } + + /* deal with the rest of the quantifier */ + if (atomtype == BACKREF) { + /* special case: backrefs have internal quantifiers */ + EMPTYARC(s, atom->begin); /* empty prefix */ + /* just stuff everything into atom */ + repeat(v, atom->begin, atom->end, m, n); + atom->min = (short)m; + atom->max = (short)n; + atom->flags |= COMBINE(qprefer, atom->flags); + } else if (m == 1 && n == 1) { + /* no/vacuous quantifier: done */ + EMPTYARC(s, atom->begin); /* empty prefix */ + } else { + /* turn x{m,n} into x{m-1,n-1}x, with capturing */ + /* parens in only second x */ + dupnfa(v->nfa, atom->begin, atom->end, s, atom->begin); + assert(m >= 1 && m != INFINITY && n >= 1); + repeat(v, s, atom->begin, m-1, (n == INFINITY) ? n : n-1); + f = COMBINE(qprefer, atom->flags); + t = subre(v, '.', f, s, atom->end); /* prefix and atom */ + NOERR(); + t->left = subre(v, '=', PREF(f), s, atom->begin); + NOERR(); + t->right = atom; + *atomp = t; + } + + /* and finally, look after that postponed recursion */ + t = top->right; + if (!(SEE('|') || SEE(stopper) || SEE(EOS))) + t->right = parsebranch(v, stopper, type, atom->end, rp, 1); + else { + EMPTYARC(atom->end, rp); + t->right = subre(v, '=', 0, atom->end, rp); + } + assert(SEE('|') || SEE(stopper) || SEE(EOS)); + t->flags |= COMBINE(t->flags, t->right->flags); + top->flags |= COMBINE(top->flags, t->flags); +} + +/* + - nonword - generate arcs for non-word-character ahead or behind + ^ static VOID nonword(struct vars *, int, struct state *, struct state *); + */ +static VOID +nonword(v, dir, lp, rp) +struct vars *v; +int dir; /* AHEAD or BEHIND */ +struct state *lp; +struct state *rp; +{ + int anchor = (dir == AHEAD) ? '$' : '^'; + + assert(dir == AHEAD || dir == BEHIND); + newarc(v->nfa, anchor, 1, lp, rp); + newarc(v->nfa, anchor, 0, lp, rp); + colorcomplement(v->nfa, v->cm, dir, v->wordchrs, lp, rp); + /* (no need for special attention to \n) */ +} + +/* + - word - generate arcs for word character ahead or behind + ^ static VOID word(struct vars *, int, struct state *, struct state *); + */ +static VOID +word(v, dir, lp, rp) +struct vars *v; +int dir; /* AHEAD or BEHIND */ +struct state *lp; +struct state *rp; +{ + assert(dir == AHEAD || dir == BEHIND); + cloneouts(v->nfa, v->wordchrs, lp, rp, dir); + /* (no need for special attention to \n) */ +} + +/* + - scannum - scan a number + ^ static int scannum(struct vars *); + */ +static int /* value, <= DUPMAX */ +scannum(v) +struct vars *v; +{ + int n = 0; + + while (SEE(DIGIT) && n < DUPMAX) { + n = n*10 + v->nextvalue; + NEXT(); + } + if (SEE(DIGIT) || n > DUPMAX) { + ERR(REG_BADBR); + return 0; + } + return n; +} + +/* + - repeat - replicate subNFA for quantifiers + * The duplication sequences used here are chosen carefully so that any + * pointers starting out pointing into the subexpression end up pointing into + * the last occurrence. (Note that it may not be strung between the same + * left and right end states, however!) This used to be important for the + * subRE tree, although the important bits are now handled by the in-line + * code in parse(), and when this is called, it doesn't matter any more. + ^ static VOID repeat(struct vars *, struct state *, struct state *, int, int); + */ +static VOID +repeat(v, lp, rp, m, n) +struct vars *v; +struct state *lp; +struct state *rp; +int m; +int n; +{ +# define SOME 2 +# define INF 3 +# define PAIR(x, y) ((x)*4 + (y)) +# define REDUCE(x) ( ((x) == INFINITY) ? INF : (((x) > 1) ? SOME : (x)) ) + CONST int rm = REDUCE(m); + CONST int rn = REDUCE(n); + struct state *s; + struct state *s2; + + switch (PAIR(rm, rn)) { + case PAIR(0, 0): /* empty string */ + delsub(v->nfa, lp, rp); + EMPTYARC(lp, rp); + break; + case PAIR(0, 1): /* do as x| */ + EMPTYARC(lp, rp); + break; + case PAIR(0, SOME): /* do as x{1,n}| */ + repeat(v, lp, rp, 1, n); + NOERR(); + EMPTYARC(lp, rp); + break; + case PAIR(0, INF): /* loop x around */ + s = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + moveins(v->nfa, rp, s); + EMPTYARC(lp, s); + EMPTYARC(s, rp); + break; + case PAIR(1, 1): /* no action required */ + break; + case PAIR(1, SOME): /* do as x{0,n-1}x = (x{1,n-1}|)x */ + s = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + dupnfa(v->nfa, s, rp, lp, s); + NOERR(); + repeat(v, lp, s, 1, n-1); + NOERR(); + EMPTYARC(lp, s); + break; + case PAIR(1, INF): /* add loopback arc */ + s = newstate(v->nfa); + s2 = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + moveins(v->nfa, rp, s2); + EMPTYARC(lp, s); + EMPTYARC(s2, rp); + EMPTYARC(s2, s); + break; + case PAIR(SOME, SOME): /* do as x{m-1,n-1}x */ + s = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + dupnfa(v->nfa, s, rp, lp, s); + NOERR(); + repeat(v, lp, s, m-1, n-1); + break; + case PAIR(SOME, INF): /* do as x{m-1,}x */ + s = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + dupnfa(v->nfa, s, rp, lp, s); + NOERR(); + repeat(v, lp, s, m-1, n); + break; + default: + ERR(REG_ASSERT); + break; + } +} + +/* + - bracket - handle non-complemented bracket expression + * Also called from cbracket for complemented bracket expressions. + ^ static VOID bracket(struct vars *, struct state *, struct state *); + */ +static VOID +bracket(v, lp, rp) +struct vars *v; +struct state *lp; +struct state *rp; +{ + assert(SEE('[')); + NEXT(); + while (!SEE(']') && !SEE(EOS)) + brackpart(v, lp, rp); + assert(SEE(']') || ISERR()); + okcolors(v->nfa, v->cm); +} + +/* + - cbracket - handle complemented bracket expression + * We do it by calling bracket() with dummy endpoints, and then complementing + * the result. The alternative would be to invoke rainbow(), and then delete + * arcs as the b.e. is seen... but that gets messy. + ^ static VOID cbracket(struct vars *, struct state *, struct state *); + */ +static VOID +cbracket(v, lp, rp) +struct vars *v; +struct state *lp; +struct state *rp; +{ + struct state *left = newstate(v->nfa); + struct state *right = newstate(v->nfa); + struct state *s; + struct arc *a; /* arc from lp */ + struct arc *ba; /* arc from left, from bracket() */ + struct arc *pa; /* MCCE-prototype arc */ + color co; + chr *p; + int i; + + NOERR(); + bracket(v, left, right); + if (v->cflags®_NLSTOP) + newarc(v->nfa, PLAIN, v->nlcolor, left, right); + NOERR(); + + assert(lp->nouts == 0); /* all outarcs will be ours */ + + /* easy part of complementing */ + colorcomplement(v->nfa, v->cm, PLAIN, left, lp, rp); + NOERR(); + if (v->mcces == NULL) { /* no MCCEs -- we're done */ + dropstate(v->nfa, left); + assert(right->nins == 0); + freestate(v->nfa, right); + return; + } + + /* but complementing gets messy in the presence of MCCEs... */ + NOTE(REG_ULOCALE); + for (p = v->mcces->chrs, i = v->mcces->nchrs; i > 0; p++, i--) { + co = GETCOLOR(v->cm, *p); + a = findarc(lp, PLAIN, co); + ba = findarc(left, PLAIN, co); + if (ba == NULL) { + assert(a != NULL); + freearc(v->nfa, a); + } else { + assert(a == NULL); + } + s = newstate(v->nfa); + NOERR(); + newarc(v->nfa, PLAIN, co, lp, s); + NOERR(); + pa = findarc(v->mccepbegin, PLAIN, co); + assert(pa != NULL); + if (ba == NULL) { /* easy case, need all of them */ + cloneouts(v->nfa, pa->to, s, rp, PLAIN); + newarc(v->nfa, '$', 1, s, rp); + newarc(v->nfa, '$', 0, s, rp); + colorcomplement(v->nfa, v->cm, AHEAD, pa->to, s, rp); + } else { /* must be selective */ + if (findarc(ba->to, '$', 1) == NULL) { + newarc(v->nfa, '$', 1, s, rp); + newarc(v->nfa, '$', 0, s, rp); + colorcomplement(v->nfa, v->cm, AHEAD, pa->to, + s, rp); + } + for (pa = pa->to->outs; pa != NULL; pa = pa->outchain) + if (findarc(ba->to, PLAIN, pa->co) == NULL) + newarc(v->nfa, PLAIN, pa->co, s, rp); + if (s->nouts == 0) /* limit of selectivity: none */ + dropstate(v->nfa, s); /* frees arc too */ + } + NOERR(); + } + + delsub(v->nfa, left, right); + assert(left->nouts == 0); + freestate(v->nfa, left); + assert(right->nins == 0); + freestate(v->nfa, right); +} + +/* + - brackpart - handle one item (or range) within a bracket expression + ^ static VOID brackpart(struct vars *, struct state *, struct state *); + */ +static VOID +brackpart(v, lp, rp) +struct vars *v; +struct state *lp; +struct state *rp; +{ + celt startc; + celt endc; + struct cvec *cv; + chr *startp; + chr *endp; + chr c[1]; + + /* parse something, get rid of special cases, take shortcuts */ + switch (v->nexttype) { + case RANGE: /* a-b-c or other botch */ + ERR(REG_ERANGE); + return; + break; + case PLAIN: + c[0] = v->nextvalue; + NEXT(); + /* shortcut for ordinary chr (not range, not MCCE leader) */ + if (!SEE(RANGE) && !ISCELEADER(v, c[0])) { + onechr(v, c[0], lp, rp); + return; + } + startc = element(v, c, c+1); + NOERR(); + break; + case COLLEL: + startp = v->now; + endp = scanplain(v); + INSIST(startp < endp, REG_ECOLLATE); + NOERR(); + startc = element(v, startp, endp); + NOERR(); + break; + case ECLASS: + startp = v->now; + endp = scanplain(v); + INSIST(startp < endp, REG_ECOLLATE); + NOERR(); + startc = element(v, startp, endp); + NOERR(); + cv = eclass(v, startc, (v->cflags®_ICASE)); + NOERR(); + dovec(v, cv, lp, rp); + return; + break; + case CCLASS: + startp = v->now; + endp = scanplain(v); + INSIST(startp < endp, REG_ECTYPE); + NOERR(); + cv = cclass(v, startp, endp, (v->cflags®_ICASE)); + NOERR(); + dovec(v, cv, lp, rp); + return; + break; + default: + ERR(REG_ASSERT); + return; + break; + } + + if (SEE(RANGE)) { + NEXT(); + switch (v->nexttype) { + case PLAIN: + case RANGE: + c[0] = v->nextvalue; + NEXT(); + endc = element(v, c, c+1); + NOERR(); + break; + case COLLEL: + startp = v->now; + endp = scanplain(v); + INSIST(startp < endp, REG_ECOLLATE); + NOERR(); + endc = element(v, startp, endp); + NOERR(); + break; + default: + ERR(REG_ERANGE); + return; + break; + } + } else + endc = startc; + + /* + * Ranges are unportable. Actually, standard C does + * guarantee that digits are contiguous, but making + * that an exception is just too complicated. + */ + if (startc != endc) + NOTE(REG_UUNPORT); + cv = range(v, startc, endc, (v->cflags®_ICASE)); + NOERR(); + dovec(v, cv, lp, rp); +} + +/* + - scanplain - scan PLAIN contents of [. etc. + * Certain bits of trickery in lex.c know that this code does not try + * to look past the final bracket of the [. etc. + ^ static chr *scanplain(struct vars *); + */ +static chr * /* just after end of sequence */ +scanplain(v) +struct vars *v; +{ + chr *endp; + + assert(SEE(COLLEL) || SEE(ECLASS) || SEE(CCLASS)); + NEXT(); + + endp = v->now; + while (SEE(PLAIN)) { + endp = v->now; + NEXT(); + } + + assert(SEE(END) || ISERR()); + NEXT(); + + return endp; +} + +/* + - leaders - process a cvec of collating elements to also include leaders + * Also gives all characters involved their own colors, which is almost + * certainly necessary, and sets up little disconnected subNFA. + ^ static VOID leaders(struct vars *, struct cvec *); + */ +static VOID +leaders(v, cv) +struct vars *v; +struct cvec *cv; +{ + int mcce; + chr *p; + chr leader; + struct state *s; + struct arc *a; + + v->mccepbegin = newstate(v->nfa); + v->mccepend = newstate(v->nfa); + NOERR(); + + for (mcce = 0; mcce < cv->nmcces; mcce++) { + p = cv->mcces[mcce]; + leader = *p; + if (!haschr(cv, leader)) { + addchr(cv, leader); + s = newstate(v->nfa); + newarc(v->nfa, PLAIN, subcolor(v->cm, leader), + v->mccepbegin, s); + okcolors(v->nfa, v->cm); + } else { + a = findarc(v->mccepbegin, PLAIN, + GETCOLOR(v->cm, leader)); + assert(a != NULL); + s = a->to; + assert(s != v->mccepend); + } + p++; + assert(*p != 0 && *(p+1) == 0); /* only 2-char MCCEs for now */ + newarc(v->nfa, PLAIN, subcolor(v->cm, *p), s, v->mccepend); + okcolors(v->nfa, v->cm); + } +} + +/* + - onechr - fill in arcs for a plain character, and possible case complements + * This is mostly a shortcut for efficient handling of the common case. + ^ static VOID onechr(struct vars *, pchr, struct state *, struct state *); + */ +static VOID +onechr(v, c, lp, rp) +struct vars *v; +pchr c; +struct state *lp; +struct state *rp; +{ + if (!(v->cflags®_ICASE)) { + newarc(v->nfa, PLAIN, subcolor(v->cm, c), lp, rp); + return; + } + + /* rats, need general case anyway... */ + dovec(v, allcases(v, c), lp, rp); +} + +/* + - dovec - fill in arcs for each element of a cvec + * This one has to handle the messy cases, like MCCEs and MCCE leaders. + ^ static VOID dovec(struct vars *, struct cvec *, struct state *, + ^ struct state *); + */ +static VOID +dovec(v, cv, lp, rp) +struct vars *v; +struct cvec *cv; +struct state *lp; +struct state *rp; +{ + chr ch, from, to; + celt ce; + chr *p; + int i; + color co; + struct cvec *leads; + struct arc *a; + struct arc *pa; /* arc in prototype */ + struct state *s; + struct state *ps; /* state in prototype */ + + /* need a place to store leaders, if any */ + if (nmcces(v) > 0) { + assert(v->mcces != NULL); + if (v->cv2 == NULL || v->cv2->nchrs < v->mcces->nchrs) { + if (v->cv2 != NULL) + free(v->cv2); + v->cv2 = newcvec(v->mcces->nchrs, 0, v->mcces->nmcces); + NOERR(); + leads = v->cv2; + } else + leads = clearcvec(v->cv2); + } else + leads = NULL; + + /* first, get the ordinary characters out of the way */ + for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) { + ch = *p; + if (!ISCELEADER(v, ch)) + newarc(v->nfa, PLAIN, subcolor(v->cm, ch), lp, rp); + else { + assert(singleton(v->cm, ch)); + assert(leads != NULL); + if (!haschr(leads, ch)) + addchr(leads, ch); + } + } + + /* and the ranges */ + for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) { + from = *p; + to = *(p+1); + while (from <= to && (ce = nextleader(v, from, to)) != NOCELT) { + if (from < ce) + subrange(v, from, ce - 1, lp, rp); + assert(singleton(v->cm, ce)); + assert(leads != NULL); + if (!haschr(leads, ce)) + addchr(leads, ce); + from = ce + 1; + } + if (from <= to) + subrange(v, from, to, lp, rp); + } + + if ((leads == NULL || leads->nchrs == 0) && cv->nmcces == 0) + return; + + /* deal with the MCCE leaders */ + NOTE(REG_ULOCALE); + for (p = leads->chrs, i = leads->nchrs; i > 0; p++, i--) { + co = GETCOLOR(v->cm, *p); + a = findarc(lp, PLAIN, co); + if (a != NULL) + s = a->to; + else { + s = newstate(v->nfa); + NOERR(); + newarc(v->nfa, PLAIN, co, lp, s); + NOERR(); + } + pa = findarc(v->mccepbegin, PLAIN, co); + assert(pa != NULL); + ps = pa->to; + newarc(v->nfa, '$', 1, s, rp); + newarc(v->nfa, '$', 0, s, rp); + colorcomplement(v->nfa, v->cm, AHEAD, ps, s, rp); + NOERR(); + } + + /* and the MCCEs */ + for (i = 0; i < cv->nmcces; i++) { + p = cv->mcces[i]; + assert(singleton(v->cm, *p)); + ch = *p++; + co = GETCOLOR(v->cm, ch); + a = findarc(lp, PLAIN, co); + if (a != NULL) + s = a->to; + else { + s = newstate(v->nfa); + NOERR(); + newarc(v->nfa, PLAIN, co, lp, s); + NOERR(); + } + assert(*p != 0); /* at least two chars */ + assert(singleton(v->cm, *p)); + ch = *p++; + co = GETCOLOR(v->cm, ch); + assert(*p == 0); /* and only two, for now */ + newarc(v->nfa, PLAIN, co, s, rp); + NOERR(); + } +} + +/* + - nextleader - find next MCCE leader within range + ^ static celt nextleader(struct vars *, pchr, pchr); + */ +static celt /* NOCELT means none */ +nextleader(v, from, to) +struct vars *v; +pchr from; +pchr to; +{ + int i; + chr *p; + chr ch; + celt it = NOCELT; + + if (v->mcces == NULL) + return it; + + for (i = v->mcces->nchrs, p = v->mcces->chrs; i > 0; i--, p++) { + ch = *p; + if (from <= ch && ch <= to) + if (it == NOCELT || ch < it) + it = ch; + } + return it; +} + +/* + - wordchrs - set up word-chr list for word-boundary stuff, if needed + * The list is kept as a bunch of arcs between two dummy states; it's + * disposed of by the unreachable-states sweep in NFA optimization. + * Does NEXT(). Must not be called from any unusual lexical context. + * This should be reconciled with the \w etc. handling in lex.c, and + * should be cleaned up to reduce dependencies on input scanning. + ^ static VOID wordchrs(struct vars *); + */ +static VOID +wordchrs(v) +struct vars *v; +{ + struct state *left; + struct state *right; + + if (v->wordchrs != NULL) { + NEXT(); /* for consistency */ + return; + } + + left = newstate(v->nfa); + right = newstate(v->nfa); + NOERR(); + /* fine point: implemented with [::], and lexer will set REG_ULOCALE */ + lexword(v); + NEXT(); + assert(v->savenow != NULL && SEE('[')); + bracket(v, left, right); + assert((v->savenow != NULL && SEE(']')) || ISERR()); + NEXT(); + NOERR(); + v->wordchrs = left; +} + +/* + - subre - allocate a subre + ^ static struct subre *subre(struct vars *, int, int, struct state *, + ^ struct state *); + */ +static struct subre * +subre(v, op, flags, begin, end) +struct vars *v; +int op; +int flags; +struct state *begin; +struct state *end; +{ + struct subre *ret; + + ret = v->treefree; + if (ret != NULL) + v->treefree = ret->left; + else { + ret = (struct subre *)MALLOC(sizeof(struct subre)); + if (ret == NULL) { + ERR(REG_ESPACE); + return NULL; + } + ret->chain = v->treechain; + v->treechain = ret; + } + + assert(strchr("|.b(=", op) != NULL); + + ret->op = op; + ret->flags = flags; + ret->retry = 0; + ret->subno = 0; + ret->min = ret->max = 1; + ret->left = NULL; + ret->right = NULL; + ret->begin = begin; + ret->end = end; + ZAPCNFA(ret->cnfa); + + return ret; +} + +/* + - freesubre - free a subRE subtree + ^ static VOID freesubre(struct vars *, struct subre *); + */ +static VOID +freesubre(v, sr) +struct vars *v; /* might be NULL */ +struct subre *sr; +{ + if (sr == NULL) + return; + + if (sr->left != NULL) + freesubre(v, sr->left); + if (sr->right != NULL) + freesubre(v, sr->right); + + freesrnode(v, sr); +} + +/* + - freesrnode - free one node in a subRE subtree + ^ static VOID freesrnode(struct vars *, struct subre *); + */ +static VOID +freesrnode(v, sr) +struct vars *v; /* might be NULL */ +struct subre *sr; +{ + if (sr == NULL) + return; + + if (!NULLCNFA(sr->cnfa)) + freecnfa(&sr->cnfa); + sr->flags = 0; + + if (v != NULL) { + sr->left = v->treefree; + v->treefree = sr; + } else + FREE(sr); +} + +/* + - optst - optimize a subRE subtree + ^ static VOID optst(struct vars *, struct subre *); + */ +static VOID +optst(v, t) +struct vars *v; +struct subre *t; +{ + if (t == NULL) + return; + + /* preference cleanup and analysis */ + if (t->flags&SHORTER) + v->usedshorter = 1; + + /* recurse through children */ + if (t->left != NULL) + optst(v, t->left); + if (t->right != NULL) + optst(v, t->right); +} + +/* + - numst - number tree nodes (assigning retry indexes) + ^ static int numst(struct subre *, int); + */ +static int /* next number */ +numst(t, start) +struct subre *t; +int start; /* starting point for subtree numbers */ +{ + int i; + + assert(t != NULL); + + i = start; + t->retry = (short)i++; + if (t->left != NULL) + i = numst(t->left, i); + if (t->right != NULL) + i = numst(t->right, i); + return i; +} + +/* + - markst - mark tree nodes as INUSE + ^ static VOID markst(struct subre *); + */ +static VOID +markst(t) +struct subre *t; +{ + assert(t != NULL); + + t->flags |= INUSE; + if (t->left != NULL) + markst(t->left); + if (t->right != NULL) + markst(t->right); +} + +/* + - cleanst - free any tree nodes not marked INUSE + ^ static VOID cleanst(struct vars *); + */ +static VOID +cleanst(v) +struct vars *v; +{ + struct subre *t; + struct subre *next; + + for (t = v->treechain; t != NULL; t = next) { + next = t->chain; + if (!(t->flags&INUSE)) + FREE(t); + } + v->treechain = NULL; + v->treefree = NULL; /* just on general principles */ +} + +/* + - nfatree - turn a subRE subtree into a tree of compacted NFAs + ^ static int nfatree(struct vars *, struct subre *, FILE *); + */ +static int /* optimize results from top node */ +nfatree(v, t, f) +struct vars *v; +struct subre *t; +FILE *f; /* for debug output */ +{ + assert(t != NULL && t->begin != NULL); + + if (t->left != NULL) + (DISCARD)nfatree(v, t->left, f); + if (t->right != NULL) + (DISCARD)nfatree(v, t->right, f); + + return nfanode(v, t, f); +} + +/* + - nfanode - do one NFA for nfatree + ^ static int nfanode(struct vars *, struct subre *, FILE *); + */ +static int /* optimize results */ +nfanode(v, t, f) +struct vars *v; +struct subre *t; +FILE *f; /* for debug output */ +{ + struct nfa *nfa; + int ret = 0; + + assert(t->begin != NULL); + + nfa = newnfa(v, v->cm, v->nfa); + NOERRZ(); + dupnfa(nfa, t->begin, t->end, nfa->init, nfa->final); + if (!ISERR()) { + specialcolors(nfa); + ret = optimize(nfa, f); + } + if (!ISERR()) + compact(nfa, &t->cnfa); + + freenfa(nfa); + return ret; +} + +/* + - newlacon - allocate a lookahead-constraint subRE + ^ static int newlacon(struct vars *, struct state *, struct state *, int); + */ +static int /* lacon number */ +newlacon(v, begin, end, pos) +struct vars *v; +struct state *begin; +struct state *end; +int pos; +{ + int n; + struct subre *sub; + + if (v->nlacons == 0) { + v->lacons = (struct subre *)MALLOC(2 * sizeof(struct subre)); + n = 1; /* skip 0th */ + v->nlacons = 2; + } else { + v->lacons = (struct subre *)REALLOC(v->lacons, + (v->nlacons+1)*sizeof(struct subre)); + n = v->nlacons++; + } + if (v->lacons == NULL) { + ERR(REG_ESPACE); + return 0; + } + sub = &v->lacons[n]; + sub->begin = begin; + sub->end = end; + sub->subno = pos; + ZAPCNFA(sub->cnfa); + return n; +} + +/* + - freelacons - free lookahead-constraint subRE vector + ^ static VOID freelacons(struct subre *, int); + */ +static VOID +freelacons(subs, n) +struct subre *subs; +int n; +{ + struct subre *sub; + int i; + + assert(n > 0); + for (sub = subs + 1, i = n - 1; i > 0; sub++, i--) /* no 0th */ + if (!NULLCNFA(sub->cnfa)) + freecnfa(&sub->cnfa); + FREE(subs); +} + +/* + - rfree - free a whole RE (insides of regfree) + ^ static VOID rfree(regex_t *); + */ +static VOID +rfree(re) +regex_t *re; +{ + struct guts *g; + + if (re == NULL || re->re_magic != REMAGIC) + return; + + re->re_magic = 0; /* invalidate RE */ + g = (struct guts *)re->re_guts; + re->re_guts = NULL; + re->re_fns = NULL; + g->magic = 0; + freecm(&g->cmap); + if (g->tree != NULL) + freesubre((struct vars *)NULL, g->tree); + if (g->lacons != NULL) + freelacons(g->lacons, g->nlacons); + if (!NULLCNFA(g->search)) + freecnfa(&g->search); + FREE(g); +} + +/* + - dump - dump an RE in human-readable form + ^ static VOID dump(regex_t *, FILE *); + */ +static VOID +dump(re, f) +regex_t *re; +FILE *f; +{ +#ifdef REG_DEBUG + struct guts *g; + int i; + + if (re->re_magic != REMAGIC) + fprintf(f, "bad magic number (0x%x not 0x%x)\n", re->re_magic, + REMAGIC); + if (re->re_guts == NULL) { + fprintf(f, "NULL guts!!!\n"); + return; + } + g = (struct guts *)re->re_guts; + if (g->magic != GUTSMAGIC) + fprintf(f, "bad guts magic number (0x%x not 0x%x)\n", g->magic, + GUTSMAGIC); + + fprintf(f, "nsub %d, info 0%o, csize %d, ntree %d, usedshort %d\n", + re->re_nsub, re->re_info, re->re_csize, g->ntree, + g->usedshorter); + + dumpcolors(&g->cmap, f); + if (!NULLCNFA(g->search)) { + printf("search:\n"); + dumpcnfa(&g->search, f); + } + for (i = 1; i < g->nlacons; i++) { + fprintf(f, "la%d (%s):\n", i, + (g->lacons[i].subno) ? "positive" : "negative"); + dumpcnfa(&g->lacons[i].cnfa, f); + } + dumpst(g->tree, f, 0); +#endif +} + +/* + - dumpst - dump a subRE tree + ^ static VOID dumpst(struct subre *, FILE *, int); + */ +static VOID +dumpst(t, f, nfapresent) +struct subre *t; +FILE *f; +int nfapresent; /* is the original NFA still around? */ +{ + if (t == NULL) + fprintf(f, "null tree\n"); + else + stdump(t, f, nfapresent, 0); + fflush(f); +} + +/* + - stdump - recursive guts of dumpst + ^ static VOID stdump(struct subre *, FILE *, int, int); + */ +static VOID +stdump(t, f, nfapresent, level) +struct subre *t; +FILE *f; +int nfapresent; /* is the original NFA still around? */ +int level; +{ + int i; +# define RTSEP " " + + for (i = 0; i < level; i++) + fprintf(f, RTSEP); + fprintf(f, "%c (", t->op); + if (t->flags&LONGER) + fprintf(f, "L"); + if (t->flags&SHORTER) + fprintf(f, "S"); + if (t->flags&MIXED) + fprintf(f, "M"); + if (t->flags&CAP) + fprintf(f, "c"); + if (t->flags&BACKR) + fprintf(f, "b"); + if (!(t->flags&INUSE)) + fprintf(f, "!u"); + fprintf(f, ") r%d", t->retry); + if (t->subno != 0) + fprintf(f, " #%d", t->subno); + if (t->min != 1 || t->max != 1) { + fprintf(f, "{%d,", t->min); + if (t->max != INFINITY) + fprintf(f, "%d", t->max); + fprintf(f, "}"); + } + if (nfapresent) + fprintf(f, " %ld-%ld", (long)t->begin->no, (long)t->end->no); + if (!NULLCNFA(t->cnfa)) + fprintf(f, ":"); + fprintf(f, "\n"); + if (t->left != NULL) + stdump(t->left, f, nfapresent, level+1); + if (!NULLCNFA(t->cnfa)) + dumpcnfa(&t->cnfa, f); + if (t->right != NULL) + stdump(t->right, f, nfapresent, level+1); +} + +#include "regc_lex.c" +#include "regc_color.c" +#include "regc_nfa.c" +#include "regc_cvec.c" +#include "regc_locale.c" diff --git a/generic/regcustom.h b/generic/regcustom.h new file mode 100644 index 0000000..b1d53a9 --- /dev/null +++ b/generic/regcustom.h @@ -0,0 +1,85 @@ +/* headers (which also pick up the standard ones, or equivalents) */ +#include "tclInt.h" + +/* overrides for regguts.h definitions */ +/* function-pointer declarations */ +#define FUNCPTR(name, args) (*name) _ANSI_ARGS_(args) +#define MALLOC(n) ckalloc(n) +#define FREE(p) ckfree(VS(p)) +#define REALLOC(p,n) ckrealloc(VS(p),n) + + + +/* + * Do not insert extras between the "begin" and "end" lines -- this + * chunk is automatically extracted to be fitted into regex.h. + */ +/* --- begin --- */ +/* ensure certain things don't sneak in from system headers */ +#ifdef __REG_WIDE_T +#undef __REG_WIDE_T +#endif +#ifdef __REG_WIDE_COMPILE +#undef __REG_WIDE_COMPILE +#endif +#ifdef __REG_WIDE_EXEC +#undef __REG_WIDE_EXEC +#endif +#ifdef __REG_REGOFF_T +#undef __REG_REGOFF_T +#endif +#ifdef __REG_VOID_T +#undef __REG_VOID_T +#endif +#ifdef __REG_CONST +#undef __REG_CONST +#endif +/* interface types */ +#define __REG_WIDE_T Tcl_UniChar +#define __REG_REGOFF_T long /* not really right, but good enough... */ +#define __REG_VOID_T VOID +#define __REG_CONST CONST +/* names and declarations */ +#define __REG_WIDE_COMPILE TclReComp +#define __REG_WIDE_EXEC TclReExec +#ifndef __REG_NOFRONT +#define __REG_NOFRONT /* don't want regcomp() and regexec() */ +#endif +#ifndef __REG_NOCHAR +#define __REG_NOCHAR /* or the char versions */ +#endif +#define regfree TclReFree +#define regerror TclReError +/* --- end --- */ + + + +/* internal character type and related */ +typedef Tcl_UniChar chr; /* the type itself */ +typedef int pchr; /* what it promotes to */ +typedef unsigned uchr; /* unsigned type that will hold a chr */ +typedef int celt; /* type to hold chr, MCCE number, or NOCELT */ +#define NOCELT (-1) /* celt value which is not valid chr or MCCE */ +#define CHR(c) (UCHAR(c)) /* turn char literal into chr literal */ +#define DIGITVAL(c) ((c)-'0') /* turn chr digit into its value */ +#define CHRBITS 16 /* bits in a chr; must not use sizeof */ +#define CHR_MIN 0x0000 /* smallest and largest chr; the value */ +#define CHR_MAX 0xffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ + +/* functions operating on chr */ +#define iscalnum(x) Tcl_UniCharIsAlnum(x) +#define iscalpha(x) Tcl_UniCharIsAlpha(x) +#define iscdigit(x) Tcl_UniCharIsDigit(x) +#define iscspace(x) Tcl_UniCharIsSpace(x) + +/* name the external functions */ +#define compile TclReComp +#define exec TclReExec + +/* enable/disable debugging code (by whether REG_DEBUG is defined or not) */ +#ifdef notdef +#define REG_DEBUG /* */ +#endif + +/* and pick up the standard header */ +#include "regex.h" diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c new file mode 100644 index 0000000..eb31ffc6 --- /dev/null +++ b/generic/rege_dfa.c @@ -0,0 +1,627 @@ +/* + * DFA routines + * This file is #included by regexec.c. + */ + +/* + - longest - longest-preferred matching engine + ^ static chr *longest(struct vars *, struct dfa *, chr *, chr *); + */ +static chr * /* endpoint, or NULL */ +longest(v, d, start, stop) +struct vars *v; /* used only for debug and exec flags */ +struct dfa *d; +chr *start; /* where the match should start */ +chr *stop; /* match must end at or before here */ +{ + chr *cp; + chr *realstop = (stop == v->stop) ? stop : stop + 1; + color co; + struct sset *css; + struct sset *ss; + chr *post; + int i; + struct colormap *cm = d->cm; + + /* initialize */ + css = initialize(v, d, start); + cp = start; + + /* startup */ + FDEBUG(("+++ startup +++\n")); + if (cp == v->start) { + co = d->cnfa->bos[(v->eflags®_NOTBOL) ? 0 : 1]; + FDEBUG(("color %ld\n", (long)co)); + } else { + co = GETCOLOR(cm, *(cp - 1)); + FDEBUG(("char %c, color %ld\n", (char)*(cp-1), (long)co)); + } + css = miss(v, d, css, co, cp, start); + if (css == NULL) + return NULL; + css->lastseen = cp; + + /* main loop */ + if (v->eflags®_FTRACE) + while (cp < realstop) { + FDEBUG(("+++ at c%d +++\n", css - d->ssets)); + co = GETCOLOR(cm, *cp); + FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co)); + ss = css->outs[co]; + if (ss == NULL) { + ss = miss(v, d, css, co, cp+1, start); + if (ss == NULL) + break; /* NOTE BREAK OUT */ + } + cp++; + ss->lastseen = cp; + css = ss; + } + else + while (cp < realstop) { + co = GETCOLOR(cm, *cp); + ss = css->outs[co]; + if (ss == NULL) { + ss = miss(v, d, css, co, cp+1, start); + if (ss == NULL) + break; /* NOTE BREAK OUT */ + } + cp++; + ss->lastseen = cp; + css = ss; + } + + /* shutdown */ + FDEBUG(("+++ shutdown at c%d +++\n", css - d->ssets)); + if (cp == v->stop && stop == v->stop) { + co = d->cnfa->eos[(v->eflags®_NOTEOL) ? 0 : 1]; + FDEBUG(("color %ld\n", (long)co)); + ss = miss(v, d, css, co, cp, start); + /* special case: match ended at eol? */ + if (ss != NULL && (ss->flags&POSTSTATE)) + return cp; + else if (ss != NULL) + ss->lastseen = cp; /* to be tidy */ + } + + /* find last match, if any */ + post = d->lastpost; + for (ss = d->ssets, i = 0; i < d->nssused; ss++, i++) + if ((ss->flags&POSTSTATE) && post != ss->lastseen && + (post == NULL || post < ss->lastseen)) + post = ss->lastseen; + if (post != NULL) /* found one */ + return post - 1; + + return NULL; +} + +/* + - shortest - shortest-preferred matching engine + ^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *, + ^ chr **); + */ +static chr * /* endpoint, or NULL */ +shortest(v, d, start, min, max, coldp) +struct vars *v; /* used only for debug and exec flags */ +struct dfa *d; +chr *start; /* where the match should start */ +chr *min; /* match must end at or after here */ +chr *max; /* match must end at or before here */ +chr **coldp; /* store coldstart pointer here, if nonNULL */ +{ + chr *cp; + chr *realmin = (min == v->stop) ? min : min + 1; + chr *realmax = (max == v->stop) ? max : max + 1; + color co; + struct sset *css; + struct sset *ss; + struct colormap *cm = d->cm; + chr *nopr; + int i; + + /* initialize */ + css = initialize(v, d, start); + cp = start; + + /* startup */ + FDEBUG(("--- startup ---\n")); + if (cp == v->start) { + co = d->cnfa->bos[(v->eflags®_NOTBOL) ? 0 : 1]; + FDEBUG(("color %ld\n", (long)co)); + } else { + co = GETCOLOR(cm, *(cp - 1)); + FDEBUG(("char %c, color %ld\n", (char)*(cp-1), (long)co)); + } + css = miss(v, d, css, co, cp, start); + if (css == NULL) + return NULL; + css->lastseen = cp; + ss = css; + + /* main loop */ + if (v->eflags®_FTRACE) + while (cp < realmax) { + FDEBUG(("--- at c%d ---\n", css - d->ssets)); + co = GETCOLOR(cm, *cp); + FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co)); + ss = css->outs[co]; + if (ss == NULL) { + ss = miss(v, d, css, co, cp+1, start); + if (ss == NULL) + break; /* NOTE BREAK OUT */ + } + cp++; + ss->lastseen = cp; + css = ss; + if ((ss->flags&POSTSTATE) && cp >= realmin) + break; /* NOTE BREAK OUT */ + } + else + while (cp < realmax) { + co = GETCOLOR(cm, *cp); + ss = css->outs[co]; + if (ss == NULL) { + ss = miss(v, d, css, co, cp+1, start); + if (ss == NULL) + break; /* NOTE BREAK OUT */ + } + cp++; + ss->lastseen = cp; + css = ss; + if ((ss->flags&POSTSTATE) && cp >= realmin) + break; /* NOTE BREAK OUT */ + } + + if (ss == NULL) + return NULL; + else if (ss->flags&POSTSTATE) { + assert(cp >= realmin); + cp--; + } else if (cp == v->stop && max == v->stop) { + co = d->cnfa->eos[(v->eflags®_NOTEOL) ? 0 : 1]; + FDEBUG(("color %ld\n", (long)co)); + ss = miss(v, d, css, co, cp, start); + /* match might have ended at eol */ + } + + if (ss == NULL || !(ss->flags&POSTSTATE)) + return NULL; + + /* find last no-progress state set, if any */ + nopr = d->lastnopr; + for (ss = d->ssets, i = 0; i < d->nssused; ss++, i++) + if ((ss->flags&NOPROGRESS) && nopr != ss->lastseen && + (nopr == NULL || nopr < ss->lastseen)) + nopr = ss->lastseen; + assert(nopr != NULL); + if (coldp != NULL) + *coldp = (nopr == v->start) ? nopr : nopr-1; + return cp; +} + +/* + - newdfa - set up a fresh DFA + ^ static struct dfa *newdfa(struct vars *, struct cnfa *, + ^ struct colormap *, struct smalldfa *); + */ +static struct dfa * +newdfa(v, cnfa, cm, small) +struct vars *v; +struct cnfa *cnfa; +struct colormap *cm; +struct smalldfa *small; /* preallocated space, may be NULL */ +{ + struct dfa *d; + size_t nss = cnfa->nstates * 2; + int wordsper = (cnfa->nstates + UBITS - 1) / UBITS; + struct smalldfa *smallwas = small; + + assert(cnfa != NULL && cnfa->nstates != 0); + + if (nss <= FEWSTATES && cnfa->ncolors <= FEWCOLORS) { + assert(wordsper == 1); + if (small == NULL) { + small = (struct smalldfa *)MALLOC( + sizeof(struct smalldfa)); + if (small == NULL) { + ERR(REG_ESPACE); + return NULL; + } + } + d = &small->dfa; + d->ssets = small->ssets; + d->statesarea = small->statesarea; + d->work = &d->statesarea[nss]; + d->outsarea = small->outsarea; + d->incarea = small->incarea; + d->cptsmalloced = 0; + d->mallocarea = (smallwas == NULL) ? (char *)small : NULL; + } else { + d = (struct dfa *)MALLOC(sizeof(struct dfa)); + if (d == NULL) { + ERR(REG_ESPACE); + return NULL; + } + d->ssets = (struct sset *)MALLOC(nss * sizeof(struct sset)); + d->statesarea = (unsigned *)MALLOC((nss+WORK) * wordsper * + sizeof(unsigned)); + d->work = &d->statesarea[nss * wordsper]; + d->outsarea = (struct sset **)MALLOC(nss * cnfa->ncolors * + sizeof(struct sset *)); + d->incarea = (struct arcp *)MALLOC(nss * cnfa->ncolors * + sizeof(struct arcp)); + d->cptsmalloced = 1; + d->mallocarea = (char *)d; + if (d->ssets == NULL || d->statesarea == NULL || + d->outsarea == NULL || d->incarea == NULL) { + freedfa(d); + ERR(REG_ESPACE); + return NULL; + } + } + + d->nssets = (v->eflags®_SMALL) ? 7 : nss; + d->nssused = 0; + d->nstates = cnfa->nstates; + d->ncolors = cnfa->ncolors; + d->wordsper = wordsper; + d->cnfa = cnfa; + d->cm = cm; + d->lastpost = NULL; + d->lastnopr = NULL; + d->search = d->ssets; + + /* initialization of sset fields is done as needed */ + + return d; +} + +/* + - freedfa - free a DFA + ^ static VOID freedfa(struct dfa *); + */ +static VOID +freedfa(d) +struct dfa *d; +{ + if (d->cptsmalloced) { + if (d->ssets != NULL) + FREE(d->ssets); + if (d->statesarea != NULL) + FREE(d->statesarea); + if (d->outsarea != NULL) + FREE(d->outsarea); + if (d->incarea != NULL) + FREE(d->incarea); + } + + if (d->mallocarea != NULL) + FREE(d->mallocarea); +} + +/* + - hash - construct a hash code for a bitvector + * There are probably better ways, but they're more expensive. + ^ static unsigned hash(unsigned *, int); + */ +static unsigned +hash(uv, n) +unsigned *uv; +int n; +{ + int i; + unsigned h; + + h = 0; + for (i = 0; i < n; i++) + h ^= uv[i]; + return h; +} + +/* + - initialize - hand-craft a cache entry for startup, otherwise get ready + ^ static struct sset *initialize(struct vars *, struct dfa *, chr *); + */ +static struct sset * +initialize(v, d, start) +struct vars *v; /* used only for debug flags */ +struct dfa *d; +chr *start; +{ + struct sset *ss; + int i; + + /* is previous one still there? */ + if (d->nssused > 0 && (d->ssets[0].flags&STARTER)) + ss = &d->ssets[0]; + else { /* no, must (re)build it */ + ss = getvacant(v, d, start, start); + for (i = 0; i < d->wordsper; i++) + ss->states[i] = 0; + BSET(ss->states, d->cnfa->pre); + ss->hash = HASH(ss->states, d->wordsper); + assert(d->cnfa->pre != d->cnfa->post); + ss->flags = STARTER|LOCKED|NOPROGRESS; + /* lastseen dealt with below */ + } + + for (i = 0; i < d->nssused; i++) + d->ssets[i].lastseen = NULL; + ss->lastseen = start; /* maybe untrue, but harmless */ + d->lastpost = NULL; + d->lastnopr = NULL; + return ss; +} + +/* + - miss - handle a cache miss + ^ static struct sset *miss(struct vars *, struct dfa *, struct sset *, + ^ pcolor, chr *, chr *); + */ +static struct sset * /* NULL if goes to empty set */ +miss(v, d, css, co, cp, start) +struct vars *v; /* used only for debug flags */ +struct dfa *d; +struct sset *css; +pcolor co; +chr *cp; /* next chr */ +chr *start; /* where the attempt got started */ +{ + struct cnfa *cnfa = d->cnfa; + int i; + unsigned h; + struct carc *ca; + struct sset *p; + int ispost; + int noprogress; + int gotstate; + int dolacons; + int didlacons; + + /* for convenience, we can be called even if it might not be a miss */ + if (css->outs[co] != NULL) { + FDEBUG(("hit\n")); + return css->outs[co]; + } + FDEBUG(("miss\n")); + + /* first, what set of states would we end up in? */ + for (i = 0; i < d->wordsper; i++) + d->work[i] = 0; + ispost = 0; + noprogress = 1; + gotstate = 0; + for (i = 0; i < d->nstates; i++) + if (ISBSET(css->states, i)) + for (ca = cnfa->states[i]+1; ca->co != COLORLESS; ca++) + if (ca->co == co) { + BSET(d->work, ca->to); + gotstate = 1; + if (ca->to == cnfa->post) + ispost = 1; + if (!cnfa->states[ca->to]->co) + noprogress = 0; + FDEBUG(("%d -> %d\n", i, ca->to)); + } + dolacons = (gotstate) ? (cnfa->flags&HASLACONS) : 0; + didlacons = 0; + while (dolacons) { /* transitive closure */ + dolacons = 0; + for (i = 0; i < d->nstates; i++) + if (ISBSET(d->work, i)) + for (ca = cnfa->states[i]+1; ca->co != COLORLESS; + ca++) + if (ca->co > cnfa->ncolors && + !ISBSET(d->work, ca->to) && + lacon(v, cnfa, cp, + ca->co)) { + BSET(d->work, ca->to); + dolacons = 1; + didlacons = 1; + if (ca->to == cnfa->post) + ispost = 1; + if (!cnfa->states[ca->to]->co) + noprogress = 0; + FDEBUG(("%d :> %d\n",i,ca->to)); + } + } + if (!gotstate) + return NULL; + h = HASH(d->work, d->wordsper); + + /* next, is that in the cache? */ + for (p = d->ssets, i = d->nssused; i > 0; p++, i--) + if (HIT(h, d->work, p, d->wordsper)) { +#ifndef xxx +p->hash == h && +memcmp(VS(d->work), VS(p->states), + d->wordsper*sizeof(unsigned)) == 0) { +#endif + FDEBUG(("cached c%d\n", p - d->ssets)); + break; /* NOTE BREAK OUT */ + } + if (i == 0) { /* nope, need a new cache entry */ + p = getvacant(v, d, cp, start); + assert(p != css); + for (i = 0; i < d->wordsper; i++) + p->states[i] = d->work[i]; + p->hash = h; + p->flags = (ispost) ? POSTSTATE : 0; + if (noprogress) + p->flags |= NOPROGRESS; + /* lastseen to be dealt with by caller */ + } + + if (!didlacons) { /* lookahead conds. always cache miss */ + css->outs[co] = p; + css->inchain[co] = p->ins; + p->ins.ss = css; + p->ins.co = (color)co; + } + return p; +} + +/* + - lacon - lookahead-constraint checker for miss() + ^ static int lacon(struct vars *, struct cnfa *, chr *, pcolor); + */ +static int /* predicate: constraint satisfied? */ +lacon(v, pcnfa, cp, co) +struct vars *v; +struct cnfa *pcnfa; /* parent cnfa */ +chr *cp; +pcolor co; /* "color" of the lookahead constraint */ +{ + int n; + struct subre *sub; + struct dfa *d; + struct smalldfa sd; + chr *end; + + n = co - pcnfa->ncolors; + assert(n < v->g->nlacons && v->g->lacons != NULL); + FDEBUG(("=== testing lacon %d\n", n)); + sub = &v->g->lacons[n]; + d = newdfa(v, &sub->cnfa, &v->g->cmap, &sd); + if (d == NULL) { + ERR(REG_ESPACE); + return 0; + } + end = longest(v, d, cp, v->stop); + freedfa(d); + FDEBUG(("=== lacon %d match %d\n", n, (end != NULL))); + return (sub->subno) ? (end != NULL) : (end == NULL); +} + +/* + - getvacant - get a vacant state set + * This routine clears out the inarcs and outarcs, but does not otherwise + * clear the innards of the state set -- that's up to the caller. + ^ static struct sset *getvacant(struct vars *, struct dfa *, chr *, chr *); + */ +static struct sset * +getvacant(v, d, cp, start) +struct vars *v; /* used only for debug flags */ +struct dfa *d; +chr *cp; +chr *start; +{ + int i; + struct sset *ss; + struct sset *p; + struct arcp ap; + struct arcp lastap; + color co; + + ss = pickss(v, d, cp, start); + assert(!(ss->flags&LOCKED)); + + /* clear out its inarcs, including self-referential ones */ + ap = ss->ins; + while ((p = ap.ss) != NULL) { + co = ap.co; + FDEBUG(("zapping c%d's %ld outarc\n", p - d->ssets, (long)co)); + p->outs[co] = NULL; + ap = p->inchain[co]; + p->inchain[co].ss = NULL; /* paranoia */ + } + ss->ins.ss = NULL; + + /* take it off the inarc chains of the ssets reached by its outarcs */ + for (i = 0; i < d->ncolors; i++) { + p = ss->outs[i]; + assert(p != ss); /* not self-referential */ + if (p == NULL) + continue; /* NOTE CONTINUE */ + FDEBUG(("del outarc %d from c%d's in chn\n", i, p - d->ssets)); + if (p->ins.ss == ss && p->ins.co == i) + p->ins = ss->inchain[i]; + else { + assert(p->ins.ss != NULL); + for (ap = p->ins; ap.ss != NULL && + !(ap.ss == ss && ap.co == i); + ap = ap.ss->inchain[ap.co]) + lastap = ap; + assert(ap.ss != NULL); + lastap.ss->inchain[lastap.co] = ss->inchain[i]; + } + ss->outs[i] = NULL; + ss->inchain[i].ss = NULL; + } + + /* if ss was a success state, may need to remember location */ + if ((ss->flags&POSTSTATE) && ss->lastseen != d->lastpost && + (d->lastpost == NULL || d->lastpost < ss->lastseen)) + d->lastpost = ss->lastseen; + + /* likewise for a no-progress state */ + if ((ss->flags&NOPROGRESS) && ss->lastseen != d->lastnopr && + (d->lastnopr == NULL || d->lastnopr < ss->lastseen)) + d->lastnopr = ss->lastseen; + + return ss; +} + +/* + - pickss - pick the next stateset to be used + ^ static struct sset *pickss(struct vars *, struct dfa *, chr *, chr *); + */ +static struct sset * +pickss(v, d, cp, start) +struct vars *v; /* used only for debug flags */ +struct dfa *d; +chr *cp; +chr *start; +{ + int i; + struct sset *ss; + struct sset *end; + chr *ancient; + + /* shortcut for cases where cache isn't full */ + if (d->nssused < d->nssets) { + i = d->nssused; + d->nssused++; + ss = &d->ssets[i]; + FDEBUG(("new c%d\n", i)); + /* set up innards */ + ss->states = &d->statesarea[i * d->wordsper]; + ss->flags = 0; + ss->ins.ss = NULL; + ss->ins.co = WHITE; /* give it some value */ + ss->outs = &d->outsarea[i * d->ncolors]; + ss->inchain = &d->incarea[i * d->ncolors]; + for (i = 0; i < d->ncolors; i++) { + ss->outs[i] = NULL; + ss->inchain[i].ss = NULL; + } + return ss; + } + + /* look for oldest, or old enough anyway */ + if (cp - start > d->nssets*2/3) /* oldest 33% are expendable */ + ancient = cp - d->nssets*2/3; + else + ancient = start; + for (ss = d->search, end = &d->ssets[d->nssets]; ss < end; ss++) + if ((ss->lastseen == NULL || ss->lastseen < ancient) && + !(ss->flags&LOCKED)) { + d->search = ss + 1; + FDEBUG(("replacing c%d\n", ss - d->ssets)); + return ss; + } + for (ss = d->ssets, end = d->search; ss < end; ss++) + if ((ss->lastseen == NULL || ss->lastseen < ancient) && + !(ss->flags&LOCKED)) { + d->search = ss + 1; + FDEBUG(("replacing c%d\n", ss - d->ssets)); + return ss; + } + + /* nobody's old enough?!? -- something's really wrong */ + FDEBUG(("can't find victim to replace!\n")); + assert(NOTREACHED); + ERR(REG_ASSERT); + return d->ssets; +} diff --git a/generic/regerror.c b/generic/regerror.c new file mode 100644 index 0000000..6779e51 --- /dev/null +++ b/generic/regerror.c @@ -0,0 +1,82 @@ +/* + * regerror - error-code expansion + */ + +#include "regguts.h" + +/* unknown-error explanation */ +static char unk[] = "*** unknown regex error code 0x%x ***"; + +/* struct to map among codes, code names, and explanations */ +static struct rerr { + int code; + char *name; + char *explain; +} rerrs[] = { + /* the actual table is built from regex.h */ +# include "regerrs.h" + { -1, "", "oops" }, /* explanation special-cased in code */ +}; + +/* + - regerror - the interface to error numbers + */ +/* ARGSUSED */ +size_t /* actual space needed (including NUL) */ +regerror(errcode, preg, errbuf, errbuf_size) +int errcode; /* error code, or REG_ATOI or REG_ITOA */ +CONST regex_t *preg; /* associated regex_t (unused at present) */ +char *errbuf; /* result buffer (unless errbuf_size==0) */ +size_t errbuf_size; /* available space in errbuf, can be 0 */ +{ + struct rerr *r; + char *msg; + char convbuf[sizeof(unk)+50]; /* 50 = plenty for int */ + size_t len; + int icode; + + switch (errcode) { + case REG_ATOI: /* convert name to number */ + for (r = rerrs; r->code >= 0; r++) + if (strcmp(r->name, errbuf) == 0) + break; + sprintf(convbuf, "%d", r->code); /* -1 for unknown */ + msg = convbuf; + break; + case REG_ITOA: /* convert number to name */ + icode = atoi(errbuf); /* not our problem if this fails */ + for (r = rerrs; r->code >= 0; r++) + if (r->code == icode) + break; + if (r->code >= 0) + msg = r->name; + else { /* unknown; tell him the number */ + sprintf(convbuf, "REG_%u", (unsigned)icode); + msg = convbuf; + } + break; + default: /* a real, normal error code */ + for (r = rerrs; r->code >= 0; r++) + if (r->code == errcode) + break; + if (r->code >= 0) + msg = r->explain; + else { /* unknown; say so */ + sprintf(convbuf, unk, errcode); + msg = convbuf; + } + break; + } + + len = strlen(msg) + 1; /* space needed, including NUL */ + if (errbuf_size > 0) { + if (errbuf_size > len) + strcpy(errbuf, msg); + else { /* truncate to fit */ + strncpy(errbuf, msg, errbuf_size-1); + errbuf[errbuf_size-1] = '\0'; + } + } + + return len; +} diff --git a/generic/regerrs.h b/generic/regerrs.h new file mode 100644 index 0000000..1b6552c --- /dev/null +++ b/generic/regerrs.h @@ -0,0 +1,18 @@ +{ REG_OKAY, "REG_OKAY", "no errors detected" }, +{ REG_NOMATCH, "REG_NOMATCH", "failed to match" }, +{ REG_BADPAT, "REG_BADPAT", "invalid regexp (reg version 0.2)" }, +{ REG_ECOLLATE, "REG_ECOLLATE", "invalid collating element" }, +{ REG_ECTYPE, "REG_ECTYPE", "invalid character class" }, +{ REG_EESCAPE, "REG_EESCAPE", "invalid escape \\ sequence" }, +{ REG_ESUBREG, "REG_ESUBREG", "invalid backreference number" }, +{ REG_EBRACK, "REG_EBRACK", "brackets [] not balanced" }, +{ REG_EPAREN, "REG_EPAREN", "parentheses () not balanced" }, +{ REG_EBRACE, "REG_EBRACE", "braces {} not balanced" }, +{ REG_BADBR, "REG_BADBR", "invalid repetition count(s)" }, +{ REG_ERANGE, "REG_ERANGE", "invalid character range" }, +{ REG_ESPACE, "REG_ESPACE", "out of memory" }, +{ REG_BADRPT, "REG_BADRPT", "quantifier operand invalid" }, +{ REG_ASSERT, "REG_ASSERT", "\"can't happen\" -- you found a bug" }, +{ REG_INVARG, "REG_INVARG", "invalid argument to regex function" }, +{ REG_MIXED, "REG_MIXED", "character widths of regex and string differ" }, +{ REG_BADOPT, "REG_BADOPT", "invalid embedded option" }, diff --git a/generic/regex.h b/generic/regex.h new file mode 100644 index 0000000..2f3ebfa --- /dev/null +++ b/generic/regex.h @@ -0,0 +1,308 @@ +#ifndef _REGEX_H_ +#define _REGEX_H_ /* never again */ +/* + * regular expressions + * + * Prototypes etc. marked with "^" within comments get gathered up (and + * possibly edited) by the regfwd program and inserted near the bottom of + * this file. + * + * We offer the option of declaring one wide-character version of the + * RE functions as well as the char versions. To do that, define + * __REG_WIDE_T to the type of wide characters (unfortunately, there + * is no consensus that wchar_t is suitable) and __REG_WIDE_COMPILE and + * __REG_WIDE_EXEC to the names to be used for the compile and execute + * functions (suggestion: re_Xcomp and re_Xexec, where X is a letter + * suggestive of the wide type, e.g. re_ucomp and re_uexec for Unicode). + * For cranky old compilers, it may be necessary to do something like: + * #define __REG_WIDE_COMPILE(a,b,c,d) re_Xcomp(a,b,c,d) + * #define __REG_WIDE_EXEC(a,b,c,d,e,f,g) re_Xexec(a,b,c,d,e,f,g) + * rather than just #defining the names as parameterless macros. + * + * For some specialized purposes, it may be desirable to suppress the + * declarations of the "front end" functions, regcomp() and regexec(), + * or of the char versions of the compile and execute functions. To + * suppress the front-end functions, define __REG_NOFRONT. To suppress + * the char versions, define __REG_NOCHAR. + * + * The right place to do those defines (and some others you may want, see + * below) would be . If you don't have control of that file, + * the right place to add your own defines to this file is marked below. + * This is normally done automatically, by the makefile and regmkhdr, based + * on the contents of regcustom.h. + */ + + + +/* + * voodoo for C++ + */ +#ifdef __cplusplus +extern "C" { +#endif + + + +/* + * Add your own defines, if needed, here. + */ + + + +/* + * Location where a chunk of regcustom.h is automatically spliced into + * this file (working from its prototype, regproto.h). + */ +/* --- begin --- */ +/* ensure certain things don't sneak in from system headers */ +#ifdef __REG_WIDE_T +#undef __REG_WIDE_T +#endif +#ifdef __REG_WIDE_COMPILE +#undef __REG_WIDE_COMPILE +#endif +#ifdef __REG_WIDE_EXEC +#undef __REG_WIDE_EXEC +#endif +#ifdef __REG_REGOFF_T +#undef __REG_REGOFF_T +#endif +#ifdef __REG_VOID_T +#undef __REG_VOID_T +#endif +#ifdef __REG_CONST +#undef __REG_CONST +#endif +/* interface types */ +#define __REG_WIDE_T Tcl_UniChar +#define __REG_REGOFF_T long /* not really right, but good enough... */ +#define __REG_VOID_T VOID +#define __REG_CONST CONST +/* names and declarations */ +#define __REG_WIDE_COMPILE TclReComp +#define __REG_WIDE_EXEC TclReExec +#ifndef __REG_NOFRONT +#define __REG_NOFRONT /* don't want regcomp() and regexec() */ +#endif +#ifndef __REG_NOCHAR +#define __REG_NOCHAR /* or the char versions */ +#endif +#define regfree TclReFree +#define regerror TclReError +/* --- end --- */ + + +/* + * interface types etc. + */ + +/* + * regoff_t has to be large enough to hold either off_t or ssize_t, + * and must be signed; it's only a guess that long is suitable, so we + * offer an override. + */ +#ifdef __REG_REGOFF_T +typedef __REG_REGOFF_T regoff_t; +#else +typedef long regoff_t; +#endif + +/* + * For benefit of old compilers, we offer the option of + * overriding the `void' type used to declare nonexistent return types. + */ +#ifdef __REG_VOID_T +typedef __REG_VOID_T re_void; +#else +typedef void re_void; +#endif + +/* + * Also for benefit of old compilers, can supply a macro + * which expands to a substitute for `const'. + */ +#ifndef __REG_CONST +#define __REG_CONST const +#endif + + + +/* + * other interface types + */ + +/* the biggie, a compiled RE (or rather, a front end to same) */ +typedef struct { + int re_magic; /* magic number */ + size_t re_nsub; /* number of subexpressions */ + int re_info; /* information about RE */ +# define REG_UBACKREF 000001 +# define REG_ULOOKAHEAD 000002 +# define REG_UBOUNDS 000004 +# define REG_UBRACES 000010 +# define REG_UBSALNUM 000020 +# define REG_UPBOTCH 000040 +# define REG_UBBS 000100 +# define REG_UNONPOSIX 000200 +# define REG_UUNSPEC 000400 +# define REG_UUNPORT 001000 +# define REG_ULOCALE 002000 +# define REG_UEMPTYMATCH 004000 +# define REG_UIMPOSSIBLE 010000 + int re_csize; /* sizeof(character) */ + char *re_endp; /* backward compatibility kludge */ + /* the rest is opaque pointers to hidden innards */ + char *re_guts; /* `char *' is more portable than `void *' */ + char *re_fns; +} regex_t; + +/* result reporting (may acquire more fields later) */ +typedef struct { + regoff_t rm_so; /* start of substring */ + regoff_t rm_eo; /* end of substring */ +} regmatch_t; + +/* supplementary control and reporting (placeholder for later work) */ +typedef struct { + int rm_dummy; +} rm_detail_t; + + + +/* + * compilation + ^ #ifndef __REG_NOCHAR + ^ int re_comp(regex_t *, __REG_CONST char *, size_t, int); + ^ #endif + ^ #ifndef __REG_NOFRONT + ^ int regcomp(regex_t *, __REG_CONST char *, int); + ^ #endif + ^ #ifdef __REG_WIDE_T + ^ int __REG_WIDE_COMPILE(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int); + ^ #endif + */ +#define REG_BASIC 000000 /* BREs (convenience) */ +#define REG_EXTENDED 000001 /* EREs */ +#define REG_ADVF 000002 /* advanced features in EREs */ +#define REG_ADVANCED 000003 /* AREs (which are also EREs) */ +#define REG_QUOTE 000004 /* no special characters, none */ +#define REG_NOSPEC REG_QUOTE /* historical synonym */ +#define REG_ICASE 000010 /* ignore case */ +#define REG_NOSUB 000020 /* don't care about subexpressions */ +#define REG_EXPANDED 000040 /* expanded format, white space & comments */ +#define REG_NLSTOP 000100 /* \n doesn't match . or [^ ] */ +#define REG_NLANCH 000200 /* ^ matches after \n, $ before */ +#define REG_NEWLINE 000300 /* newlines are line terminators */ +#define REG_PEND 000400 /* ugh -- backward-compatibility hack */ +#define REG_DUMP 004000 /* none of your business :-) */ +#define REG_FAKEEC 010000 /* none of your business :-) */ +#define REG_PROGRESS 020000 /* none of your business :-) */ + + + +/* + * execution + ^ #ifndef __REG_NOCHAR + ^ int re_exec(regex_t *, __REG_CONST char *, size_t, + ^ rm_detail_t *, size_t, regmatch_t [], int); + ^ #endif + ^ #ifndef __REG_NOFRONT + ^ int regexec(regex_t *, __REG_CONST char *, size_t, regmatch_t [], int); + ^ #endif + ^ #ifdef __REG_WIDE_T + ^ int __REG_WIDE_EXEC(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, + ^ rm_detail_t *, size_t, regmatch_t [], int); + ^ #endif + */ +#define REG_NOTBOL 0001 /* BOS is not BOL */ +#define REG_NOTEOL 0002 /* EOS is not EOL */ +#define REG_STARTEND 0004 /* backward compatibility kludge */ +#define REG_FTRACE 0010 /* none of your business */ +#define REG_MTRACE 0020 /* none of your business */ +#define REG_SMALL 0040 /* none of your business */ + + + +/* + * misc generics (may be more functions here eventually) + ^ re_void regfree(regex_t *); + */ + + + +/* + * error reporting + * Be careful if modifying the list of error codes -- the table used by + * regerror() is generated automatically from this file! + * + * Note that there is no wide-char variant of regerror at this time; what + * kind of character is used for error reports is independent of what kind + * is used in matching. + * + ^ extern size_t regerror(int, __REG_CONST regex_t *, char *, size_t); + */ +#define REG_OKAY 0 /* no errors detected */ +#define REG_NOMATCH 1 /* failed to match */ +#define REG_BADPAT 2 /* invalid regexp */ +#define REG_ECOLLATE 3 /* invalid collating element */ +#define REG_ECTYPE 4 /* invalid character class */ +#define REG_EESCAPE 5 /* invalid escape \ sequence */ +#define REG_ESUBREG 6 /* invalid backreference number */ +#define REG_EBRACK 7 /* brackets [] not balanced */ +#define REG_EPAREN 8 /* parentheses () not balanced */ +#define REG_EBRACE 9 /* braces {} not balanced */ +#define REG_BADBR 10 /* invalid repetition count(s) */ +#define REG_ERANGE 11 /* invalid character range */ +#define REG_ESPACE 12 /* out of memory */ +#define REG_BADRPT 13 /* quantifier operand invalid */ +#define REG_ASSERT 15 /* "can't happen" -- you found a bug */ +#define REG_INVARG 16 /* invalid argument to regex function */ +#define REG_MIXED 17 /* character widths of regex and string differ */ +#define REG_BADOPT 18 /* invalid embedded option */ +/* two specials for debugging and testing */ +#define REG_ATOI 101 /* convert error-code name to number */ +#define REG_ITOA 102 /* convert error-code number to name */ + + + +/* + * the prototypes, as possibly munched by regfwd + */ +/* =====^!^===== begin forwards =====^!^===== */ +/* automatically gathered by fwd; do not hand-edit */ +/* === regproto.h === */ +#ifndef __REG_NOCHAR +int re_comp _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, int)); +#endif +#ifndef __REG_NOFRONT +int regcomp _ANSI_ARGS_((regex_t *, __REG_CONST char *, int)); +#endif +#ifdef __REG_WIDE_T +int __REG_WIDE_COMPILE _ANSI_ARGS_((regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int)); +#endif +#ifndef __REG_NOCHAR +int re_exec _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, rm_detail_t *, size_t, regmatch_t [], int)); +#endif +#ifndef __REG_NOFRONT +int regexec _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, regmatch_t [], int)); +#endif +#ifdef __REG_WIDE_T +int __REG_WIDE_EXEC _ANSI_ARGS_((regex_t *, __REG_CONST __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int)); +#endif +re_void regfree _ANSI_ARGS_((regex_t *)); +extern size_t regerror _ANSI_ARGS_((int, __REG_CONST regex_t *, char *, size_t)); +/* automatically gathered by fwd; do not hand-edit */ +/* =====^!^===== end forwards =====^!^===== */ + + + +/* + * more C++ voodoo + */ +#ifdef __cplusplus +} +#endif + + + +#endif diff --git a/generic/regexec.c b/generic/regexec.c new file mode 100644 index 0000000..088d12b --- /dev/null +++ b/generic/regexec.c @@ -0,0 +1,952 @@ +/* + * re_*exec and friends - match REs + */ + +#include "regguts.h" + + + +/* internal variables, bundled for easy passing around */ +struct vars { + regex_t *re; + struct guts *g; + int eflags; /* copies of arguments */ + size_t nmatch; + regmatch_t *pmatch; + chr *start; /* start of string */ + chr *stop; /* just past end of string */ + int err; /* error code if any (0 none) */ + regoff_t *mem; /* memory vector for backtracking */ +}; +#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */ +#define ISERR() VISERR(v) +#define VERR(vv,e) (((vv)->err) ? (vv)->err : ((vv)->err = (e))) +#define ERR(e) VERR(v, e) /* record an error */ +#define NOERR() {if (ISERR()) return;} /* if error seen, return */ +#define OFF(p) ((p) - v->start) +#define LOFF(p) ((long)OFF(p)) + + + +/* lazy-DFA representation */ +struct arcp { /* "pointer" to an outarc */ + struct sset *ss; + color co; +}; + +struct sset { /* state set */ + unsigned *states; /* pointer to bitvector */ + unsigned hash; /* hash of bitvector */ +# define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw)) +# define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \ + memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0)) + int flags; +# define STARTER 01 /* the initial state set */ +# define POSTSTATE 02 /* includes the goal state */ +# define LOCKED 04 /* locked in cache */ +# define NOPROGRESS 010 /* zero-progress state set */ + struct arcp ins; /* chain of inarcs pointing here */ + chr *lastseen; /* last entered on arrival here */ + struct sset **outs; /* outarc vector indexed by color */ + struct arcp *inchain; /* chain-pointer vector for outarcs */ +}; + +struct dfa { + int nssets; /* size of cache */ + int nssused; /* how many entries occupied yet */ + int nstates; /* number of states */ + int ncolors; /* length of outarc and inchain vectors */ + int wordsper; /* length of state-set bitvectors */ + struct sset *ssets; /* state-set cache */ + unsigned *statesarea; /* bitvector storage */ + unsigned *work; /* pointer to work area within statesarea */ + struct sset **outsarea; /* outarc-vector storage */ + struct arcp *incarea; /* inchain storage */ + struct cnfa *cnfa; + struct colormap *cm; + chr *lastpost; /* location of last cache-flushed success */ + chr *lastnopr; /* location of last cache-flushed NOPROGRESS */ + struct sset *search; /* replacement-search-pointer memory */ + int cptsmalloced; /* were the areas individually malloced? */ + char *mallocarea; /* self, or master malloced area, or NULL */ +}; + +#define WORK 1 /* number of work bitvectors needed */ + +/* setup for non-malloc allocation for small cases */ +#define FEWSTATES 20 /* must be less than UBITS */ +#define FEWCOLORS 15 +struct smalldfa { + struct dfa dfa; + struct sset ssets[FEWSTATES*2]; + unsigned statesarea[FEWSTATES*2 + WORK]; + struct sset *outsarea[FEWSTATES*2 * FEWCOLORS]; + struct arcp incarea[FEWSTATES*2 * FEWCOLORS]; +}; + + + + +/* + * forward declarations + */ +/* =====^!^===== begin forwards =====^!^===== */ +/* automatically gathered by fwd; do not hand-edit */ +/* === regexec.c === */ +int exec _ANSI_ARGS_((regex_t *, CONST chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int)); +static int find _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *)); +static int cfind _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *)); +static VOID zapsubs _ANSI_ARGS_((regmatch_t *, size_t)); +static VOID zapmem _ANSI_ARGS_((struct vars *, struct subre *)); +static VOID subset _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int dissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int condissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int altdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int cdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int ccondissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int crevdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int cbrdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int caltdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +/* === rege_dfa.c === */ +static chr *longest _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *)); +static chr *shortest _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *, chr *, chr **)); +static struct dfa *newdfa _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *, struct smalldfa *)); +static VOID freedfa _ANSI_ARGS_((struct dfa *)); +static unsigned hash _ANSI_ARGS_((unsigned *, int)); +static struct sset *initialize _ANSI_ARGS_((struct vars *, struct dfa *, chr *)); +static struct sset *miss _ANSI_ARGS_((struct vars *, struct dfa *, struct sset *, pcolor, chr *, chr *)); +static int lacon _ANSI_ARGS_((struct vars *, struct cnfa *, chr *, pcolor)); +static struct sset *getvacant _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *)); +static struct sset *pickss _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *)); +/* automatically gathered by fwd; do not hand-edit */ +/* =====^!^===== end forwards =====^!^===== */ + + + +/* + - exec - match regular expression + ^ int exec(regex_t *, CONST chr *, size_t, rm_detail_t *, + ^ size_t, regmatch_t [], int); + */ +int +exec(re, string, len, details, nmatch, pmatch, flags) +regex_t *re; +CONST chr *string; +size_t len; +rm_detail_t *details; /* hook for future elaboration */ +size_t nmatch; +regmatch_t pmatch[]; +int flags; +{ + struct vars var; + register struct vars *v = &var; + int st; + size_t n; + int complications; +# define LOCALMAT 20 + regmatch_t mat[LOCALMAT]; +# define LOCALMEM 40 + regoff_t mem[LOCALMEM]; + + /* sanity checks */ + if (re == NULL || string == NULL || re->re_magic != REMAGIC) + return REG_INVARG; + if (re->re_csize != sizeof(chr)) + return REG_MIXED; + + /* setup */ + v->re = re; + v->g = (struct guts *)re->re_guts; + if (v->g->unmatchable) + return REG_NOMATCH; + complications = (v->g->info®_UBACKREF) ? 1 : 0; + if (v->g->usedshorter) + complications = 1; + v->eflags = flags; + if (v->g->cflags®_NOSUB) + nmatch = 0; /* override client */ + v->nmatch = nmatch; + if (complications && v->nmatch < v->g->nsub + 1) { + /* need work area bigger than what user gave us */ + if (v->g->nsub + 1 <= LOCALMAT) + v->pmatch = mat; + else + v->pmatch = (regmatch_t *)MALLOC((v->g->nsub + 1) * + sizeof(regmatch_t)); + if (v->pmatch == NULL) + return REG_ESPACE; + v->nmatch = v->g->nsub + 1; + } else + v->pmatch = pmatch; + v->start = (chr *)string; + v->stop = (chr *)string + len; + v->err = 0; + if (complications) { + assert(v->g->ntree >= 0); + n = (size_t)v->g->ntree; + if (n <= LOCALMEM) + v->mem = mem; + else + v->mem = (regoff_t *)MALLOC(n*sizeof(regoff_t)); + if (v->mem == NULL) { + if (v->pmatch != pmatch && v->pmatch != mat) + FREE(v->pmatch); + return REG_ESPACE; + } + } else + v->mem = NULL; + + /* do it */ + assert(v->g->tree != NULL); + if (complications) + st = cfind(v, &v->g->tree->cnfa, &v->g->cmap); + else + st = find(v, &v->g->tree->cnfa, &v->g->cmap); + + /* copy (portion of) match vector over if necessary */ + if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) { + zapsubs(pmatch, nmatch); + n = (nmatch < v->nmatch) ? nmatch : v->nmatch; + memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t)); + } + + /* clean up */ + if (v->pmatch != pmatch && v->pmatch != mat) + FREE(v->pmatch); + if (v->mem != NULL && v->mem != mem) + FREE(v->mem); + return st; +} + +/* + - find - find a match for the main NFA (no-complications case) + ^ static int find(struct vars *, struct cnfa *, struct colormap *); + */ +static int +find(v, cnfa, cm) +struct vars *v; +struct cnfa *cnfa; +struct colormap *cm; +{ + struct smalldfa da; + struct dfa *d = newdfa(v, cnfa, cm, &da); + struct smalldfa sa; + struct dfa *s = newdfa(v, &v->g->search, cm, &sa); + chr *begin; + chr *end; + chr *open; /* open and close of range of possible starts */ + chr *close; + + if (d == NULL) + return v->err; + if (s == NULL) { + freedfa(d); + return v->err; + } + + close = v->start; + do { + MDEBUG(("\nsearch at %ld\n", LOFF(close))); + close = shortest(v, s, close, close, v->stop, &open); + if (close == NULL) + break; /* NOTE BREAK */ + if (v->nmatch == 0) { + /* don't need exact location */ + freedfa(d); + freedfa(s); + return REG_OKAY; + } + MDEBUG(("between %ld and %ld\n", LOFF(open), LOFF(close))); + for (begin = open; begin <= close; begin++) { + MDEBUG(("\nfind trying at %ld\n", LOFF(begin))); + end = longest(v, d, begin, v->stop); + if (end != NULL) { + assert(v->nmatch > 0); + v->pmatch[0].rm_so = OFF(begin); + v->pmatch[0].rm_eo = OFF(end); + freedfa(d); + freedfa(s); + if (v->nmatch > 1) { + zapsubs(v->pmatch, v->nmatch); + return dissect(v, v->g->tree, begin, + end); + } + if (ISERR()) + return v->err; + return REG_OKAY; + } + } + } while (close < v->stop); + + freedfa(d); + freedfa(s); + if (ISERR()) + return v->err; + return REG_NOMATCH; +} + +/* + - cfind - find a match for the main NFA (with complications) + ^ static int cfind(struct vars *, struct cnfa *, struct colormap *); + */ +static int +cfind(v, cnfa, cm) +struct vars *v; +struct cnfa *cnfa; +struct colormap *cm; +{ + struct smalldfa da; + struct dfa *d = newdfa(v, cnfa, cm, &da); + struct smalldfa sa; + struct dfa *s = newdfa(v, &v->g->search, cm, &sa); + chr *begin; + chr *end; + chr *open; /* open and close of range of possible starts */ + chr *close; + chr *estart; + chr *estop; + int er; + int shorter = v->g->tree->flags&SHORTER; + + if (d == NULL) + return v->err; + if (s == NULL) { + freedfa(d); + return v->err; + } + + close = v->start; + do { + MDEBUG(("\ncsearch at %ld\n", LOFF(close))); + close = shortest(v, s, close, close, v->stop, &open); + if (close == NULL) + break; /* NOTE BREAK */ + MDEBUG(("cbetween %ld and %ld\n", LOFF(open), LOFF(close))); + for (begin = open; begin <= close; begin++) { + MDEBUG(("\ncfind trying at %ld\n", LOFF(begin))); + estart = begin; + estop = v->stop; + for (;;) { + if (shorter) + end = shortest(v, d, begin, estart, + estop, (chr **)NULL); + else + end = longest(v, d, begin, estop); + if (end == NULL) + break; /* NOTE BREAK OUT */ + MDEBUG(("tentative end %ld\n", LOFF(end))); + zapsubs(v->pmatch, v->nmatch); + zapmem(v, v->g->tree); + er = cdissect(v, v->g->tree, begin, end); + switch (er) { + case REG_OKAY: + if (v->nmatch > 0) { + v->pmatch[0].rm_so = OFF(begin); + v->pmatch[0].rm_eo = OFF(end); + } + freedfa(d); + freedfa(s); + if (ISERR()) + return v->err; + return REG_OKAY; + break; + case REG_NOMATCH: + /* go around and try again */ + if ((shorter) ? end == estop : + end == begin) { + /* no point in trying again */ + freedfa(s); + freedfa(d); + return REG_NOMATCH; + } + if (shorter) + estart = end + 1; + else + estop = end - 1; + break; + default: + freedfa(d); + freedfa(s); + return er; + break; + } + } + } + } while (close < v->stop); + + freedfa(d); + freedfa(s); + if (ISERR()) + return v->err; + return REG_NOMATCH; +} + +/* + - zapsubs - initialize the subexpression matches to "no match" + ^ static VOID zapsubs(regmatch_t *, size_t); + */ +static VOID +zapsubs(p, n) +regmatch_t *p; +size_t n; +{ + size_t i; + + for (i = n-1; i > 0; i--) { + p[i].rm_so = -1; + p[i].rm_eo = -1; + } +} + +/* + - zapmem - initialize the retry memory of a subtree to zeros + ^ static VOID zapmem(struct vars *, struct subre *); + */ +static VOID +zapmem(v, t) +struct vars *v; +struct subre *t; +{ + if (t == NULL) + return; + + assert(v->mem != NULL); + v->mem[t->retry] = 0; + if (t->op == '(') { + assert(t->subno > 0); + v->pmatch[t->subno].rm_so = -1; + v->pmatch[t->subno].rm_eo = -1; + } + + if (t->left != NULL) + zapmem(v, t->left); + if (t->right != NULL) + zapmem(v, t->right); +} + +/* + - subset - set any subexpression relevant to a successful subre + ^ static VOID subset(struct vars *, struct subre *, chr *, chr *); + */ +static VOID +subset(v, sub, begin, end) +struct vars *v; +struct subre *sub; +chr *begin; +chr *end; +{ + int n = sub->subno; + + assert(n > 0); + if ((size_t)n >= v->nmatch) + return; + + MDEBUG(("setting %d\n", n)); + v->pmatch[n].rm_so = OFF(begin); + v->pmatch[n].rm_eo = OFF(end); +} + +/* + - dissect - determine subexpression matches (uncomplicated case) + ^ static int dissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +dissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + assert(t != NULL); + MDEBUG(("dissect %ld-%ld\n", LOFF(begin), LOFF(end))); + + switch (t->op) { + case '=': /* terminal node */ + assert(t->left == NULL && t->right == NULL); + return REG_OKAY; /* no action, parent did the work */ + break; + case '|': /* alternation */ + assert(t->left != NULL); + return altdissect(v, t, begin, end); + break; + case 'b': /* back ref -- shouldn't be calling us! */ + return REG_ASSERT; + break; + case '.': /* concatenation */ + assert(t->left != NULL && t->right != NULL); + return condissect(v, t, begin, end); + break; + case '(': /* capturing */ + assert(t->left != NULL && t->right == NULL); + assert(t->subno > 0); + subset(v, t, begin, end); + return dissect(v, t->left, begin, end); + break; + default: + return REG_ASSERT; + break; + } +} + +/* + - condissect - determine concatenation subexpression matches (uncomplicated) + ^ static int condissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +condissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct smalldfa da; + struct dfa *d; + struct smalldfa d2a; + struct dfa *d2; + chr *mid; + int i; + + assert(t->op == '.'); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + assert(t->right != NULL && t->right->cnfa.nstates > 0); + + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da); + if (ISERR()) + return v->err; + d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a); + if (ISERR()) { + freedfa(d); + return v->err; + } + + /* pick a tentative midpoint */ + mid = longest(v, d, begin, end); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return REG_ASSERT; + } + MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); + + /* iterate until satisfaction or failure */ + while (longest(v, d2, mid, end) != end) { + /* that midpoint didn't work, find a new one */ + if (mid == begin) { + /* all possibilities exhausted! */ + MDEBUG(("no midpoint!\n")); + freedfa(d); + freedfa(d2); + return REG_ASSERT; + } + mid = longest(v, d, begin, mid-1); + if (mid == NULL) { + /* failed to find a new one! */ + MDEBUG(("failed midpoint!\n")); + freedfa(d); + freedfa(d2); + return REG_ASSERT; + } + MDEBUG(("new midpoint %ld\n", LOFF(mid))); + } + + /* satisfaction */ + MDEBUG(("successful\n")); + freedfa(d); + freedfa(d2); + i = dissect(v, t->left, begin, mid); + if (i != REG_OKAY) + return i; + return dissect(v, t->right, mid, end); +} + +/* + - altdissect - determine alternative subexpression matches (uncomplicated) + ^ static int altdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +altdissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct smalldfa da; + struct dfa *d; + int i; + + assert(t != NULL); + assert(t->op == '|'); + + for (i = 0; t != NULL; t = t->right, i++) { + MDEBUG(("trying %dth\n", i)); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da); + if (ISERR()) + return v->err; + if (longest(v, d, begin, end) == end) { + MDEBUG(("success\n")); + freedfa(d); + return dissect(v, t->left, begin, end); + } + freedfa(d); + } + return REG_ASSERT; /* none of them matched?!? */ +} + +/* + - cdissect - determine subexpression matches (with complications) + * The retry memory stores the offset of the trial midpoint from begin, + * plus 1 so that 0 uniquely means "clean slate". + ^ static int cdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +cdissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + int er; + + assert(t != NULL); + MDEBUG(("cdissect %ld-%ld\n", LOFF(begin), LOFF(end))); + + switch (t->op) { + case '=': /* terminal node */ + assert(t->left == NULL && t->right == NULL); + return REG_OKAY; /* no action, parent did the work */ + break; + case '|': /* alternation */ + assert(t->left != NULL); + return caltdissect(v, t, begin, end); + break; + case 'b': /* back ref -- shouldn't be calling us! */ + assert(t->left == NULL && t->right == NULL); + return cbrdissect(v, t, begin, end); + break; + case '.': /* concatenation */ + assert(t->left != NULL && t->right != NULL); + return ccondissect(v, t, begin, end); + break; + case '(': /* capturing */ + assert(t->left != NULL && t->right == NULL); + assert(t->subno > 0); + er = cdissect(v, t->left, begin, end); + if (er == REG_OKAY) + subset(v, t, begin, end); + return er; + break; + default: + return REG_ASSERT; + break; + } +} + +/* + - ccondissect - concatenation subexpression matches (with complications) + * The retry memory stores the offset of the trial midpoint from begin, + * plus 1 so that 0 uniquely means "clean slate". + ^ static int ccondissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +ccondissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct smalldfa da; + struct dfa *d; + struct smalldfa d2a; + struct dfa *d2; + chr *mid; + int er; + + assert(t->op == '.'); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + assert(t->right != NULL && t->right->cnfa.nstates > 0); + + if (t->left->flags&SHORTER) /* reverse scan */ + return crevdissect(v, t, begin, end); + + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da); + if (ISERR()) + return v->err; + d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a); + if (ISERR()) { + freedfa(d); + return v->err; + } + MDEBUG(("cconcat %d\n", t->retry)); + + /* pick a tentative midpoint */ + if (v->mem[t->retry] == 0) { + mid = longest(v, d, begin, end); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + } else { + mid = begin + (v->mem[t->retry] - 1); + MDEBUG(("working midpoint %ld\n", LOFF(mid))); + } + + /* iterate until satisfaction or failure */ + for (;;) { + /* try this midpoint on for size */ + er = cdissect(v, t->left, begin, mid); + if (er == REG_OKAY && longest(v, d2, mid, end) == end && + (er = cdissect(v, t->right, mid, end)) == + REG_OKAY) + break; /* NOTE BREAK OUT */ + if (er != REG_OKAY && er != REG_NOMATCH) { + freedfa(d); + freedfa(d2); + return er; + } + + /* that midpoint didn't work, find a new one */ + if (mid == begin) { + /* all possibilities exhausted */ + MDEBUG(("%d no midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + mid = longest(v, d, begin, mid-1); + if (mid == NULL) { + /* failed to find a new one */ + MDEBUG(("%d failed midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + zapmem(v, t->left); + zapmem(v, t->right); + } + + /* satisfaction */ + MDEBUG(("successful\n")); + freedfa(d); + freedfa(d2); + return REG_OKAY; +} + +/* + - crevdissect - determine shortest-first subexpression matches + * The retry memory stores the offset of the trial midpoint from begin, + * plus 1 so that 0 uniquely means "clean slate". + ^ static int crevdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +crevdissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct smalldfa da; + struct dfa *d; + struct smalldfa d2a; + struct dfa *d2; + chr *mid; + int er; + + assert(t->op == '.'); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + assert(t->right != NULL && t->right->cnfa.nstates > 0); + assert(t->left->flags&SHORTER); + + /* concatenation -- need to split the substring between parts */ + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da); + if (ISERR()) + return v->err; + d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a); + if (ISERR()) { + freedfa(d); + return v->err; + } + MDEBUG(("crev %d\n", t->retry)); + + /* pick a tentative midpoint */ + if (v->mem[t->retry] == 0) { + mid = shortest(v, d, begin, begin, end, (chr **)NULL); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + } else { + mid = begin + (v->mem[t->retry] - 1); + MDEBUG(("working midpoint %ld\n", LOFF(mid))); + } + + /* iterate until satisfaction or failure */ + for (;;) { + /* try this midpoint on for size */ + er = cdissect(v, t->left, begin, mid); + if (er == REG_OKAY && longest(v, d2, mid, end) == end && + (er = cdissect(v, t->right, mid, end)) == + REG_OKAY) + break; /* NOTE BREAK OUT */ + if (er != REG_OKAY && er != REG_NOMATCH) { + freedfa(d); + freedfa(d2); + return er; + } + + /* that midpoint didn't work, find a new one */ + if (mid == end) { + /* all possibilities exhausted */ + MDEBUG(("%d no midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + mid = shortest(v, d, begin, mid+1, end, (chr **)NULL); + if (mid == NULL) { + /* failed to find a new one */ + MDEBUG(("%d failed midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + zapmem(v, t->left); + zapmem(v, t->right); + } + + /* satisfaction */ + MDEBUG(("successful\n")); + freedfa(d); + freedfa(d2); + return REG_OKAY; +} + +/* + - cbrdissect - determine backref subexpression matches + ^ static int cbrdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +cbrdissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + int i; + int n = t->subno; + size_t len; + chr *paren; + chr *p; + chr *stop; + int min = t->min; + int max = t->max; + + assert(t != NULL); + assert(t->op == 'b'); + assert(n >= 0); + assert((size_t)n < v->nmatch); + + MDEBUG(("cbackref n%d %d{%d-%d}\n", t->retry, n, min, max)); + + if (v->pmatch[n].rm_so == -1) + return REG_NOMATCH; + paren = v->start + v->pmatch[n].rm_so; + len = v->pmatch[n].rm_eo - v->pmatch[n].rm_so; + + /* no room to maneuver -- retries are pointless */ + if (v->mem[t->retry]) + return REG_NOMATCH; + v->mem[t->retry] = 1; + + /* special-case zero-length string */ + if (len == 0) { + if (begin == end) + return REG_OKAY; + return REG_NOMATCH; + } + + /* and too-short string */ + assert(end >= begin); + if ((size_t)(end - begin) < len) + return REG_NOMATCH; + stop = end - len; + + /* count occurrences */ + i = 0; + for (p = begin; p <= stop && (i < max || max == INFINITY); p += len) { + if ((*v->g->compare)(paren, p, len) != 0) + break; + i++; + } + MDEBUG(("cbackref found %d\n", i)); + + /* and sort it out */ + if (p != end) /* didn't consume all of it */ + return REG_NOMATCH; + if (min <= i && (i <= max || max == INFINITY)) + return REG_OKAY; + return REG_NOMATCH; /* out of range */ +} + +/* + - caltdissect - determine alternative subexpression matches (w. complications) + ^ static int caltdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +caltdissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct smalldfa da; + struct dfa *d; + int er; +# define UNTRIED 0 /* not yet tried at all */ +# define TRYING 1 /* top matched, trying submatches */ +# define TRIED 2 /* top didn't match or submatches exhausted */ + + if (t == NULL) + return REG_NOMATCH; + assert(t->op == '|'); + if (v->mem[t->retry] == TRIED) + return caltdissect(v, t->right, begin, end); + + MDEBUG(("calt n%d\n", t->retry)); + assert(t->left != NULL); + + if (v->mem[t->retry] == UNTRIED) { + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da); + if (ISERR()) + return v->err; + if (longest(v, d, begin, end) != end) { + freedfa(d); + v->mem[t->retry] = TRIED; + return caltdissect(v, t->right, begin, end); + } + freedfa(d); + MDEBUG(("calt matched\n")); + v->mem[t->retry] = TRYING; + } + + er = cdissect(v, t->left, begin, end); + if (er != REG_NOMATCH) + return er; + + v->mem[t->retry] = TRIED; + return caltdissect(v, t->right, begin, end); +} + + + +#include "rege_dfa.c" diff --git a/generic/regexp.c b/generic/regexp.c deleted file mode 100644 index 8d95c45..0000000 --- a/generic/regexp.c +++ /dev/null @@ -1,1333 +0,0 @@ -/* - * TclRegComp and TclRegExec -- TclRegSub is elsewhere - * - * Copyright (c) 1986 by University of Toronto. - * Written by Henry Spencer. Not derived from licensed software. - * - * Permission is granted to anyone to use this software for any - * purpose on any computer system, and to redistribute it freely, - * subject to the following restrictions: - * - * 1. The author is not responsible for the consequences of use of - * this software, no matter how awful, even if they arise - * from defects in it. - * - * 2. The origin of this software must not be misrepresented, either - * by explicit claim or by omission. - * - * 3. Altered versions must be plainly marked as such, and must not - * be misrepresented as being the original software. - * - * Beware that some of this code is subtly aware of the way operator - * precedence is structured in regular expressions. Serious changes in - * regular-expression syntax might require a total rethink. - * - * *** NOTE: this code has been altered slightly for use in Tcl: *** - * *** 1. Use ckalloc and ckfree instead of malloc and free. *** - * *** 2. Add extra argument to regexp to specify the real *** - * *** start of the string separately from the start of the *** - * *** current search. This is needed to search for multiple *** - * *** matches within a string. *** - * *** 3. Names have been changed, e.g. from regcomp to *** - * *** TclRegComp, to avoid clashes with other *** - * *** regexp implementations used by applications. *** - * *** 4. Added errMsg declaration and TclRegError procedure *** - * *** 5. Various lint-like things, such as casting arguments *** - * *** in procedure calls. *** - * - * *** NOTE: This code has been altered for use in MT-Sturdy Tcl *** - * *** 1. All use of static variables has been changed to access *** - * *** fields of a structure. *** - * *** 2. This in addition to changes to TclRegError makes the *** - * *** code multi-thread safe. *** - * - * RCS: @(#) $Id: regexp.c,v 1.2 1998/09/14 18:39:57 stanton Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * The variable below is set to NULL before invoking regexp functions - * and checked after those functions. If an error occurred then TclRegError - * will set the variable to point to a (static) error message. This - * mechanism unfortunately does not support multi-threading, but the - * procedures TclRegError and TclGetRegError can be modified to use - * thread-specific storage for the variable and thereby make the code - * thread-safe. - */ - -static char *errMsg = NULL; - -/* - * The "internal use only" fields in regexp.h are present to pass info from - * compile to execute that permits the execute phase to run lots faster on - * simple cases. They are: - * - * regstart char that must begin a match; '\0' if none obvious - * reganch is the match anchored (at beginning-of-line only)? - * regmust string (pointer into program) that match must include, or NULL - * regmlen length of regmust string - * - * Regstart and reganch permit very fast decisions on suitable starting points - * for a match, cutting down the work a lot. Regmust permits fast rejection - * of lines that cannot possibly match. The regmust tests are costly enough - * that TclRegComp() supplies a regmust only if the r.e. contains something - * potentially expensive (at present, the only such thing detected is * or + - * at the start of the r.e., which can involve a lot of backup). Regmlen is - * supplied because the test in TclRegExec() needs it and TclRegComp() is - * computing it anyway. - */ - -/* - * Structure for regexp "program". This is essentially a linear encoding - * of a nondeterministic finite-state machine (aka syntax charts or - * "railroad normal form" in parsing technology). Each node is an opcode - * plus a "next" pointer, possibly plus an operand. "Next" pointers of - * all nodes except BRANCH implement concatenation; a "next" pointer with - * a BRANCH on both ends of it is connecting two alternatives. (Here we - * have one of the subtle syntax dependencies: an individual BRANCH (as - * opposed to a collection of them) is never concatenated with anything - * because of operator precedence.) The operand of some types of node is - * a literal string; for others, it is a node leading into a sub-FSM. In - * particular, the operand of a BRANCH node is the first node of the branch. - * (NB this is *not* a tree structure: the tail of the branch connects - * to the thing following the set of BRANCHes.) The opcodes are: - */ - -/* definition number opnd? meaning */ -#define END 0 /* no End of program. */ -#define BOL 1 /* no Match "" at beginning of line. */ -#define EOL 2 /* no Match "" at end of line. */ -#define ANY 3 /* no Match any one character. */ -#define ANYOF 4 /* str Match any character in this string. */ -#define ANYBUT 5 /* str Match any character not in this string. */ -#define BRANCH 6 /* node Match this alternative, or the next... */ -#define BACK 7 /* no Match "", "next" ptr points backward. */ -#define EXACTLY 8 /* str Match this string. */ -#define NOTHING 9 /* no Match empty string. */ -#define STAR 10 /* node Match this (simple) thing 0 or more times. */ -#define PLUS 11 /* node Match this (simple) thing 1 or more times. */ -#define OPEN 20 /* no Mark this point in input as start of #n. */ - /* OPEN+1 is number 1, etc. */ -#define CLOSE (OPEN+NSUBEXP) /* no Analogous to OPEN. */ - -/* - * Opcode notes: - * - * BRANCH The set of branches constituting a single choice are hooked - * together with their "next" pointers, since precedence prevents - * anything being concatenated to any individual branch. The - * "next" pointer of the last BRANCH in a choice points to the - * thing following the whole choice. This is also where the - * final "next" pointer of each individual branch points; each - * branch starts with the operand node of a BRANCH node. - * - * BACK Normal "next" pointers all implicitly point forward; BACK - * exists to make loop structures possible. - * - * STAR,PLUS '?', and complex '*' and '+', are implemented as circular - * BRANCH structures using BACK. Simple cases (one character - * per match) are implemented with STAR and PLUS for speed - * and to minimize recursive plunges. - * - * OPEN,CLOSE ...are numbered at compile time. - */ - -/* - * A node is one char of opcode followed by two chars of "next" pointer. - * "Next" pointers are stored as two 8-bit pieces, high order first. The - * value is a positive offset from the opcode of the node containing it. - * An operand, if any, simply follows the node. (Note that much of the - * code generation knows about this implicit relationship.) - * - * Using two bytes for the "next" pointer is vast overkill for most things, - * but allows patterns to get big without disasters. - */ -#define OP(p) (*(p)) -#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377)) -#define OPERAND(p) ((p) + 3) - -/* - * See regmagic.h for one further detail of program structure. - */ - - -/* - * Utility definitions. - */ -#ifndef CHARBITS -#define UCHARAT(p) ((int)*(unsigned char *)(p)) -#else -#define UCHARAT(p) ((int)*(p)&CHARBITS) -#endif - -#define FAIL(m) { TclRegError(m); return(NULL); } -#define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?') -#define META "^$.[()|?+*\\" - -/* - * Flags to be passed up and down. - */ -#define HASWIDTH 01 /* Known never to match null string. */ -#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ -#define SPSTART 04 /* Starts with * or +. */ -#define WORST 0 /* Worst case. */ - -/* - * Global work variables for TclRegComp(). - */ -struct regcomp_state { - char *regparse; /* Input-scan pointer. */ - int regnpar; /* () count. */ - char *regcode; /* Code-emit pointer; ®dummy = don't. */ - long regsize; /* Code size. */ -}; - -static char regdummy; - -/* - * The first byte of the regexp internal "program" is actually this magic - * number; the start node begins in the second byte. - */ -#define MAGIC 0234 - - -/* - * Forward declarations for TclRegComp()'s friends. - */ - -static char * reg _ANSI_ARGS_((int paren, int *flagp, - struct regcomp_state *rcstate)); -static char * regatom _ANSI_ARGS_((int *flagp, - struct regcomp_state *rcstate)); -static char * regbranch _ANSI_ARGS_((int *flagp, - struct regcomp_state *rcstate)); -static void regc _ANSI_ARGS_((int b, - struct regcomp_state *rcstate)); -static void reginsert _ANSI_ARGS_((int op, char *opnd, - struct regcomp_state *rcstate)); -static char * regnext _ANSI_ARGS_((char *p)); -static char * regnode _ANSI_ARGS_((int op, - struct regcomp_state *rcstate)); -static void regoptail _ANSI_ARGS_((char *p, char *val)); -static char * regpiece _ANSI_ARGS_((int *flagp, - struct regcomp_state *rcstate)); -static void regtail _ANSI_ARGS_((char *p, char *val)); - -#ifdef STRCSPN -static int strcspn _ANSI_ARGS_((char *s1, char *s2)); -#endif - -/* - - TclRegComp - compile a regular expression into internal code - * - * We can't allocate space until we know how big the compiled form will be, - * but we can't compile it (and thus know how big it is) until we've got a - * place to put the code. So we cheat: we compile it twice, once with code - * generation turned off and size counting turned on, and once "for real". - * This also means that we don't allocate space until we are sure that the - * thing really will compile successfully, and we never have to move the - * code and thus invalidate pointers into it. (Note that it has to be in - * one piece because free() must be able to free it all.) - * - * Beware that the optimization-preparation code in here knows about some - * of the structure of the compiled regexp. - */ -regexp * -TclRegComp(exp) -char *exp; -{ - register regexp *r; - register char *scan; - register char *longest; - register int len; - int flags; - struct regcomp_state state; - struct regcomp_state *rcstate= &state; - - if (exp == NULL) - FAIL("NULL argument"); - - /* First pass: determine size, legality. */ - rcstate->regparse = exp; - rcstate->regnpar = 1; - rcstate->regsize = 0L; - rcstate->regcode = ®dummy; - regc(MAGIC, rcstate); - if (reg(0, &flags, rcstate) == NULL) - return(NULL); - - /* Small enough for pointer-storage convention? */ - if (rcstate->regsize >= 32767L) /* Probably could be 65535L. */ - FAIL("regexp too big"); - - /* Allocate space. */ - r = (regexp *)ckalloc(sizeof(regexp) + (unsigned)rcstate->regsize); - if (r == NULL) - FAIL("out of space"); - - /* Second pass: emit code. */ - rcstate->regparse = exp; - rcstate->regnpar = 1; - rcstate->regcode = r->program; - regc(MAGIC, rcstate); - if (reg(0, &flags, rcstate) == NULL) - return(NULL); - - /* Dig out information for optimizations. */ - r->regstart = '\0'; /* Worst-case defaults. */ - r->reganch = 0; - r->regmust = NULL; - r->regmlen = 0; - scan = r->program+1; /* First BRANCH. */ - if (OP(regnext(scan)) == END) { /* Only one top-level choice. */ - scan = OPERAND(scan); - - /* Starting-point info. */ - if (OP(scan) == EXACTLY) - r->regstart = *OPERAND(scan); - else if (OP(scan) == BOL) - r->reganch++; - - /* - * If there's something expensive in the r.e., find the - * longest literal string that must appear and make it the - * regmust. Resolve ties in favor of later strings, since - * the regstart check works with the beginning of the r.e. - * and avoiding duplication strengthens checking. Not a - * strong reason, but sufficient in the absence of others. - */ - if (flags&SPSTART) { - longest = NULL; - len = 0; - for (; scan != NULL; scan = regnext(scan)) - if (OP(scan) == EXACTLY && ((int) strlen(OPERAND(scan))) >= len) { - longest = OPERAND(scan); - len = strlen(OPERAND(scan)); - } - r->regmust = longest; - r->regmlen = len; - } - } - - return(r); -} - -/* - - reg - regular expression, i.e. main body or parenthesized thing - * - * Caller must absorb opening parenthesis. - * - * Combining parenthesis handling with the base level of regular expression - * is a trifle forced, but the need to tie the tails of the branches to what - * follows makes it hard to avoid. - */ -static char * -reg(paren, flagp, rcstate) -int paren; /* Parenthesized? */ -int *flagp; -struct regcomp_state *rcstate; -{ - register char *ret; - register char *br; - register char *ender; - register int parno = 0; - int flags; - - *flagp = HASWIDTH; /* Tentatively. */ - - /* Make an OPEN node, if parenthesized. */ - if (paren) { - if (rcstate->regnpar >= NSUBEXP) - FAIL("too many ()"); - parno = rcstate->regnpar; - rcstate->regnpar++; - ret = regnode(OPEN+parno,rcstate); - } else - ret = NULL; - - /* Pick up the branches, linking them together. */ - br = regbranch(&flags,rcstate); - if (br == NULL) - return(NULL); - if (ret != NULL) - regtail(ret, br); /* OPEN -> first. */ - else - ret = br; - if (!(flags&HASWIDTH)) - *flagp &= ~HASWIDTH; - *flagp |= flags&SPSTART; - while (*rcstate->regparse == '|') { - rcstate->regparse++; - br = regbranch(&flags,rcstate); - if (br == NULL) - return(NULL); - regtail(ret, br); /* BRANCH -> BRANCH. */ - if (!(flags&HASWIDTH)) - *flagp &= ~HASWIDTH; - *flagp |= flags&SPSTART; - } - - /* Make a closing node, and hook it on the end. */ - ender = regnode((paren) ? CLOSE+parno : END,rcstate); - regtail(ret, ender); - - /* Hook the tails of the branches to the closing node. */ - for (br = ret; br != NULL; br = regnext(br)) - regoptail(br, ender); - - /* Check for proper termination. */ - if (paren && *rcstate->regparse++ != ')') { - FAIL("unmatched ()"); - } else if (!paren && *rcstate->regparse != '\0') { - if (*rcstate->regparse == ')') { - FAIL("unmatched ()"); - } else - FAIL("junk on end"); /* "Can't happen". */ - /* NOTREACHED */ - } - - return(ret); -} - -/* - - regbranch - one alternative of an | operator - * - * Implements the concatenation operator. - */ -static char * -regbranch(flagp, rcstate) -int *flagp; -struct regcomp_state *rcstate; -{ - register char *ret; - register char *chain; - register char *latest; - int flags; - - *flagp = WORST; /* Tentatively. */ - - ret = regnode(BRANCH,rcstate); - chain = NULL; - while (*rcstate->regparse != '\0' && *rcstate->regparse != '|' && - *rcstate->regparse != ')') { - latest = regpiece(&flags, rcstate); - if (latest == NULL) - return(NULL); - *flagp |= flags&HASWIDTH; - if (chain == NULL) /* First piece. */ - *flagp |= flags&SPSTART; - else - regtail(chain, latest); - chain = latest; - } - if (chain == NULL) /* Loop ran zero times. */ - (void) regnode(NOTHING,rcstate); - - return(ret); -} - -/* - - regpiece - something followed by possible [*+?] - * - * Note that the branching code sequences used for ? and the general cases - * of * and + are somewhat optimized: they use the same NOTHING node as - * both the endmarker for their branch list and the body of the last branch. - * It might seem that this node could be dispensed with entirely, but the - * endmarker role is not redundant. - */ -static char * -regpiece(flagp, rcstate) -int *flagp; -struct regcomp_state *rcstate; -{ - register char *ret; - register char op; - register char *next; - int flags; - - ret = regatom(&flags,rcstate); - if (ret == NULL) - return(NULL); - - op = *rcstate->regparse; - if (!ISMULT(op)) { - *flagp = flags; - return(ret); - } - - if (!(flags&HASWIDTH) && op != '?') - FAIL("*+ operand could be empty"); - *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); - - if (op == '*' && (flags&SIMPLE)) - reginsert(STAR, ret, rcstate); - else if (op == '*') { - /* Emit x* as (x&|), where & means "self". */ - reginsert(BRANCH, ret, rcstate); /* Either x */ - regoptail(ret, regnode(BACK,rcstate)); /* and loop */ - regoptail(ret, ret); /* back */ - regtail(ret, regnode(BRANCH,rcstate)); /* or */ - regtail(ret, regnode(NOTHING,rcstate)); /* null. */ - } else if (op == '+' && (flags&SIMPLE)) - reginsert(PLUS, ret, rcstate); - else if (op == '+') { - /* Emit x+ as x(&|), where & means "self". */ - next = regnode(BRANCH,rcstate); /* Either */ - regtail(ret, next); - regtail(regnode(BACK,rcstate), ret); /* loop back */ - regtail(next, regnode(BRANCH,rcstate)); /* or */ - regtail(ret, regnode(NOTHING,rcstate)); /* null. */ - } else if (op == '?') { - /* Emit x? as (x|) */ - reginsert(BRANCH, ret, rcstate); /* Either x */ - regtail(ret, regnode(BRANCH,rcstate)); /* or */ - next = regnode(NOTHING,rcstate); /* null. */ - regtail(ret, next); - regoptail(ret, next); - } - rcstate->regparse++; - if (ISMULT(*rcstate->regparse)) - FAIL("nested *?+"); - - return(ret); -} - -/* - - regatom - the lowest level - * - * Optimization: gobbles an entire sequence of ordinary characters so that - * it can turn them into a single node, which is smaller to store and - * faster to run. Backslashed characters are exceptions, each becoming a - * separate node; the code is simpler that way and it's not worth fixing. - */ -static char * -regatom(flagp, rcstate) -int *flagp; -struct regcomp_state *rcstate; -{ - register char *ret; - int flags; - - *flagp = WORST; /* Tentatively. */ - - switch (*rcstate->regparse++) { - case '^': - ret = regnode(BOL,rcstate); - break; - case '$': - ret = regnode(EOL,rcstate); - break; - case '.': - ret = regnode(ANY,rcstate); - *flagp |= HASWIDTH|SIMPLE; - break; - case '[': { - register int clss; - register int classend; - - if (*rcstate->regparse == '^') { /* Complement of range. */ - ret = regnode(ANYBUT,rcstate); - rcstate->regparse++; - } else - ret = regnode(ANYOF,rcstate); - if (*rcstate->regparse == ']' || *rcstate->regparse == '-') - regc(*rcstate->regparse++,rcstate); - while (*rcstate->regparse != '\0' && *rcstate->regparse != ']') { - if (*rcstate->regparse == '-') { - rcstate->regparse++; - if (*rcstate->regparse == ']' || *rcstate->regparse == '\0') - regc('-',rcstate); - else { - clss = UCHARAT(rcstate->regparse-2)+1; - classend = UCHARAT(rcstate->regparse); - if (clss > classend+1) - FAIL("invalid [] range"); - for (; clss <= classend; clss++) - regc((char)clss,rcstate); - rcstate->regparse++; - } - } else - regc(*rcstate->regparse++,rcstate); - } - regc('\0',rcstate); - if (*rcstate->regparse != ']') - FAIL("unmatched []"); - rcstate->regparse++; - *flagp |= HASWIDTH|SIMPLE; - } - break; - case '(': - ret = reg(1, &flags, rcstate); - if (ret == NULL) - return(NULL); - *flagp |= flags&(HASWIDTH|SPSTART); - break; - case '\0': - case '|': - case ')': - FAIL("internal urp"); /* Supposed to be caught earlier. */ - /* NOTREACHED */ - case '?': - case '+': - case '*': - FAIL("?+* follows nothing"); - /* NOTREACHED */ - case '\\': - if (*rcstate->regparse == '\0') - FAIL("trailing \\"); - ret = regnode(EXACTLY,rcstate); - regc(*rcstate->regparse++,rcstate); - regc('\0',rcstate); - *flagp |= HASWIDTH|SIMPLE; - break; - default: { - register int len; - register char ender; - - rcstate->regparse--; - len = strcspn(rcstate->regparse, META); - if (len <= 0) - FAIL("internal disaster"); - ender = *(rcstate->regparse+len); - if (len > 1 && ISMULT(ender)) - len--; /* Back off clear of ?+* operand. */ - *flagp |= HASWIDTH; - if (len == 1) - *flagp |= SIMPLE; - ret = regnode(EXACTLY,rcstate); - while (len > 0) { - regc(*rcstate->regparse++,rcstate); - len--; - } - regc('\0',rcstate); - } - break; - } - - return(ret); -} - -/* - - regnode - emit a node - */ -static char * /* Location. */ -regnode(op, rcstate) -int op; -struct regcomp_state *rcstate; -{ - register char *ret; - register char *ptr; - - ret = rcstate->regcode; - if (ret == ®dummy) { - rcstate->regsize += 3; - return(ret); - } - - ptr = ret; - *ptr++ = (char)op; - *ptr++ = '\0'; /* Null "next" pointer. */ - *ptr++ = '\0'; - rcstate->regcode = ptr; - - return(ret); -} - -/* - - regc - emit (if appropriate) a byte of code - */ -static void -regc(b, rcstate) -int b; -struct regcomp_state *rcstate; -{ - if (rcstate->regcode != ®dummy) - *rcstate->regcode++ = (char)b; - else - rcstate->regsize++; -} - -/* - - reginsert - insert an operator in front of already-emitted operand - * - * Means relocating the operand. - */ -static void -reginsert(op, opnd, rcstate) -int op; -char *opnd; -struct regcomp_state *rcstate; -{ - register char *src; - register char *dst; - register char *place; - - if (rcstate->regcode == ®dummy) { - rcstate->regsize += 3; - return; - } - - src = rcstate->regcode; - rcstate->regcode += 3; - dst = rcstate->regcode; - while (src > opnd) - *--dst = *--src; - - place = opnd; /* Op node, where operand used to be. */ - *place++ = (char)op; - *place++ = '\0'; - *place = '\0'; -} - -/* - - regtail - set the next-pointer at the end of a node chain - */ -static void -regtail(p, val) -char *p; -char *val; -{ - register char *scan; - register char *temp; - register int offset; - - if (p == ®dummy) - return; - - /* Find last node. */ - scan = p; - for (;;) { - temp = regnext(scan); - if (temp == NULL) - break; - scan = temp; - } - - if (OP(scan) == BACK) - offset = scan - val; - else - offset = val - scan; - *(scan+1) = (char)((offset>>8)&0377); - *(scan+2) = (char)(offset&0377); -} - -/* - - regoptail - regtail on operand of first argument; nop if operandless - */ -static void -regoptail(p, val) -char *p; -char *val; -{ - /* "Operandless" and "op != BRANCH" are synonymous in practice. */ - if (p == NULL || p == ®dummy || OP(p) != BRANCH) - return; - regtail(OPERAND(p), val); -} - -/* - * TclRegExec and friends - */ - -/* - * Global work variables for TclRegExec(). - */ -struct regexec_state { - char *reginput; /* String-input pointer. */ - char *regbol; /* Beginning of input, for ^ check. */ - char **regstartp; /* Pointer to startp array. */ - char **regendp; /* Ditto for endp. */ -}; - -/* - * Forwards. - */ -static int regtry _ANSI_ARGS_((regexp *prog, char *string, - struct regexec_state *restate)); -static int regmatch _ANSI_ARGS_((char *prog, - struct regexec_state *restate)); -static int regrepeat _ANSI_ARGS_((char *p, - struct regexec_state *restate)); - -#ifdef DEBUG -int regnarrate = 0; -void regdump _ANSI_ARGS_((regexp *r)); -static char *regprop _ANSI_ARGS_((char *op)); -#endif - -/* - - TclRegExec - match a regexp against a string - */ -int -TclRegExec(prog, string, start) -register regexp *prog; -register char *string; -char *start; -{ - register char *s; - struct regexec_state state; - struct regexec_state *restate= &state; - - /* Be paranoid... */ - if (prog == NULL || string == NULL) { - TclRegError("NULL parameter"); - return(0); - } - - /* Check validity of program. */ - if (UCHARAT(prog->program) != MAGIC) { - TclRegError("corrupted program"); - return(0); - } - - /* If there is a "must appear" string, look for it. */ - if (prog->regmust != NULL) { - s = string; - while ((s = strchr(s, prog->regmust[0])) != NULL) { - if (strncmp(s, prog->regmust, (size_t) prog->regmlen) - == 0) - break; /* Found it. */ - s++; - } - if (s == NULL) /* Not present. */ - return(0); - } - - /* Mark beginning of line for ^ . */ - restate->regbol = start; - - /* Simplest case: anchored match need be tried only once. */ - if (prog->reganch) - return(regtry(prog, string, restate)); - - /* Messy cases: unanchored match. */ - s = string; - if (prog->regstart != '\0') - /* We know what char it must start with. */ - while ((s = strchr(s, prog->regstart)) != NULL) { - if (regtry(prog, s, restate)) - return(1); - s++; - } - else - /* We don't -- general case. */ - do { - if (regtry(prog, s, restate)) - return(1); - } while (*s++ != '\0'); - - /* Failure. */ - return(0); -} - -/* - - regtry - try match at specific point - */ -static int /* 0 failure, 1 success */ -regtry(prog, string, restate) -regexp *prog; -char *string; -struct regexec_state *restate; -{ - register int i; - register char **sp; - register char **ep; - - restate->reginput = string; - restate->regstartp = prog->startp; - restate->regendp = prog->endp; - - sp = prog->startp; - ep = prog->endp; - for (i = NSUBEXP; i > 0; i--) { - *sp++ = NULL; - *ep++ = NULL; - } - if (regmatch(prog->program + 1,restate)) { - prog->startp[0] = string; - prog->endp[0] = restate->reginput; - return(1); - } else - return(0); -} - -/* - - regmatch - main matching routine - * - * Conceptually the strategy is simple: check to see whether the current - * node matches, call self recursively to see whether the rest matches, - * and then act accordingly. In practice we make some effort to avoid - * recursion, in particular by going through "ordinary" nodes (that don't - * need to know whether the rest of the match failed) by a loop instead of - * by recursion. - */ -static int /* 0 failure, 1 success */ -regmatch(prog, restate) -char *prog; -struct regexec_state *restate; -{ - register char *scan; /* Current node. */ - char *next; /* Next node. */ - - scan = prog; -#ifdef DEBUG - if (scan != NULL && regnarrate) - fprintf(stderr, "%s(\n", regprop(scan)); -#endif - while (scan != NULL) { -#ifdef DEBUG - if (regnarrate) - fprintf(stderr, "%s...\n", regprop(scan)); -#endif - next = regnext(scan); - - switch (OP(scan)) { - case BOL: - if (restate->reginput != restate->regbol) { - return 0; - } - break; - case EOL: - if (*restate->reginput != '\0') { - return 0; - } - break; - case ANY: - if (*restate->reginput == '\0') { - return 0; - } - restate->reginput++; - break; - case EXACTLY: { - register int len; - register char *opnd; - - opnd = OPERAND(scan); - /* Inline the first character, for speed. */ - if (*opnd != *restate->reginput) { - return 0 ; - } - len = strlen(opnd); - if (len > 1 && strncmp(opnd, restate->reginput, (size_t) len) - != 0) { - return 0; - } - restate->reginput += len; - break; - } - case ANYOF: - if (*restate->reginput == '\0' - || strchr(OPERAND(scan), *restate->reginput) == NULL) { - return 0; - } - restate->reginput++; - break; - case ANYBUT: - if (*restate->reginput == '\0' - || strchr(OPERAND(scan), *restate->reginput) != NULL) { - return 0; - } - restate->reginput++; - break; - case NOTHING: - break; - case BACK: - break; - case OPEN+1: - case OPEN+2: - case OPEN+3: - case OPEN+4: - case OPEN+5: - case OPEN+6: - case OPEN+7: - case OPEN+8: - case OPEN+9: { - register int no; - register char *save; - - doOpen: - no = OP(scan) - OPEN; - save = restate->reginput; - - if (regmatch(next,restate)) { - /* - * Don't set startp if some later invocation of the - * same parentheses already has. - */ - if (restate->regstartp[no] == NULL) { - restate->regstartp[no] = save; - } - return 1; - } else { - return 0; - } - } - case CLOSE+1: - case CLOSE+2: - case CLOSE+3: - case CLOSE+4: - case CLOSE+5: - case CLOSE+6: - case CLOSE+7: - case CLOSE+8: - case CLOSE+9: { - register int no; - register char *save; - - doClose: - no = OP(scan) - CLOSE; - save = restate->reginput; - - if (regmatch(next,restate)) { - /* - * Don't set endp if some later - * invocation of the same parentheses - * already has. - */ - if (restate->regendp[no] == NULL) - restate->regendp[no] = save; - return 1; - } else { - return 0; - } - } - case BRANCH: { - register char *save; - - if (OP(next) != BRANCH) { /* No choice. */ - next = OPERAND(scan); /* Avoid recursion. */ - } else { - do { - save = restate->reginput; - if (regmatch(OPERAND(scan),restate)) - return(1); - restate->reginput = save; - scan = regnext(scan); - } while (scan != NULL && OP(scan) == BRANCH); - return 0; - } - break; - } - case STAR: - case PLUS: { - register char nextch; - register int no; - register char *save; - register int min; - - /* - * Lookahead to avoid useless match attempts - * when we know what character comes next. - */ - nextch = '\0'; - if (OP(next) == EXACTLY) - nextch = *OPERAND(next); - min = (OP(scan) == STAR) ? 0 : 1; - save = restate->reginput; - no = regrepeat(OPERAND(scan),restate); - while (no >= min) { - /* If it could work, try it. */ - if (nextch == '\0' || *restate->reginput == nextch) - if (regmatch(next,restate)) - return(1); - /* Couldn't or didn't -- back up. */ - no--; - restate->reginput = save + no; - } - return(0); - } - case END: - return(1); /* Success! */ - default: - if (OP(scan) > OPEN && OP(scan) < OPEN+NSUBEXP) { - goto doOpen; - } else if (OP(scan) > CLOSE && OP(scan) < CLOSE+NSUBEXP) { - goto doClose; - } - TclRegError("memory corruption"); - return 0; - } - - scan = next; - } - - /* - * We get here only if there's trouble -- normally "case END" is - * the terminating point. - */ - TclRegError("corrupted pointers"); - return(0); -} - -/* - - regrepeat - repeatedly match something simple, report how many - */ -static int -regrepeat(p, restate) -char *p; -struct regexec_state *restate; -{ - register int count = 0; - register char *scan; - register char *opnd; - - scan = restate->reginput; - opnd = OPERAND(p); - switch (OP(p)) { - case ANY: - count = strlen(scan); - scan += count; - break; - case EXACTLY: - while (*opnd == *scan) { - count++; - scan++; - } - break; - case ANYOF: - while (*scan != '\0' && strchr(opnd, *scan) != NULL) { - count++; - scan++; - } - break; - case ANYBUT: - while (*scan != '\0' && strchr(opnd, *scan) == NULL) { - count++; - scan++; - } - break; - default: /* Oh dear. Called inappropriately. */ - TclRegError("internal foulup"); - count = 0; /* Best compromise. */ - break; - } - restate->reginput = scan; - - return(count); -} - -/* - - regnext - dig the "next" pointer out of a node - */ -static char * -regnext(p) -register char *p; -{ - register int offset; - - if (p == ®dummy) - return(NULL); - - offset = NEXT(p); - if (offset == 0) - return(NULL); - - if (OP(p) == BACK) - return(p-offset); - else - return(p+offset); -} - -#ifdef DEBUG - -static char *regprop(); - -/* - - regdump - dump a regexp onto stdout in vaguely comprehensible form - */ -void -regdump(r) -regexp *r; -{ - register char *s; - register char op = EXACTLY; /* Arbitrary non-END op. */ - register char *next; - - - s = r->program + 1; - while (op != END) { /* While that wasn't END last time... */ - op = OP(s); - printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */ - next = regnext(s); - if (next == NULL) /* Next ptr. */ - printf("(0)"); - else - printf("(%d)", (s-r->program)+(next-s)); - s += 3; - if (op == ANYOF || op == ANYBUT || op == EXACTLY) { - /* Literal string, where present. */ - while (*s != '\0') { - putchar(*s); - s++; - } - s++; - } - putchar('\n'); - } - - /* Header fields of interest. */ - if (r->regstart != '\0') - printf("start `%c' ", r->regstart); - if (r->reganch) - printf("anchored "); - if (r->regmust != NULL) - printf("must have \"%s\"", r->regmust); - printf("\n"); -} - -/* - - regprop - printable representation of opcode - */ -static char * -regprop(op) -char *op; -{ - register char *p; - static char buf[50]; - - (void) strcpy(buf, ":"); - - switch (OP(op)) { - case BOL: - p = "BOL"; - break; - case EOL: - p = "EOL"; - break; - case ANY: - p = "ANY"; - break; - case ANYOF: - p = "ANYOF"; - break; - case ANYBUT: - p = "ANYBUT"; - break; - case BRANCH: - p = "BRANCH"; - break; - case EXACTLY: - p = "EXACTLY"; - break; - case NOTHING: - p = "NOTHING"; - break; - case BACK: - p = "BACK"; - break; - case END: - p = "END"; - break; - case OPEN+1: - case OPEN+2: - case OPEN+3: - case OPEN+4: - case OPEN+5: - case OPEN+6: - case OPEN+7: - case OPEN+8: - case OPEN+9: - sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); - p = NULL; - break; - case CLOSE+1: - case CLOSE+2: - case CLOSE+3: - case CLOSE+4: - case CLOSE+5: - case CLOSE+6: - case CLOSE+7: - case CLOSE+8: - case CLOSE+9: - sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); - p = NULL; - break; - case STAR: - p = "STAR"; - break; - case PLUS: - p = "PLUS"; - break; - default: - if (OP(op) > OPEN && OP(op) < OPEN+NSUBEXP) { - sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); - p = NULL; - break; - } else if (OP(op) > CLOSE && OP(op) < CLOSE+NSUBEXP) { - sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); - p = NULL; - } else { - TclRegError("corrupted opcode"); - } - break; - } - if (p != NULL) - (void) strcat(buf, p); - return(buf); -} -#endif - -/* - * The following is provided for those people who do not have strcspn() in - * their C libraries. They should get off their butts and do something - * about it; at least one public-domain implementation of those (highly - * useful) string routines has been published on Usenet. - */ -#ifdef STRCSPN -/* - * strcspn - find length of initial segment of s1 consisting entirely - * of characters not from s2 - */ - -static int -strcspn(s1, s2) -char *s1; -char *s2; -{ - register char *scan1; - register char *scan2; - register int count; - - count = 0; - for (scan1 = s1; *scan1 != '\0'; scan1++) { - for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */ - if (*scan1 == *scan2++) - return(count); - count++; - } - return(count); -} -#endif - -/* - *---------------------------------------------------------------------- - * - * TclRegError -- - * - * This procedure is invoked by the regexp code when an error - * occurs. It saves the error message so it can be seen by the - * code that called Spencer's code. - * - * Results: - * None. - * - * Side effects: - * The value of "string" is saved in "errMsg". - * - *---------------------------------------------------------------------- - */ - -void -TclRegError(string) - char *string; /* Error message. */ -{ - errMsg = string; -} - -char * -TclGetRegError() -{ - return errMsg; -} diff --git a/generic/regfree.c b/generic/regfree.c new file mode 100644 index 0000000..a5c3f0b --- /dev/null +++ b/generic/regfree.c @@ -0,0 +1,25 @@ +/* + * regfree - free an RE + * + * You might think that this could be incorporated into regcomp.c, and + * that would be a reasonable idea... except that this is a generic + * function (with a generic name), applicable to all compiled REs + * regardless of the size of their characters, whereas the stuff in + * regcomp.c gets compiled once per character size. + */ + +#include "regguts.h" + +/* + - regfree - free an RE (generic function, punts to RE-specific function) + * + * Ignoring invocation with NULL is a convenience. + */ +VOID +regfree(re) +regex_t *re; +{ + if (re == NULL) + return; + (*((struct fns *)re->re_fns)->free)(re); +} diff --git a/generic/regfronts.c b/generic/regfronts.c new file mode 100644 index 0000000..a9bd556 --- /dev/null +++ b/generic/regfronts.c @@ -0,0 +1,56 @@ +/* + * regcomp and regexec - front ends to re_ routines + * + * Mostly for implementation of backward-compatibility kludges. Note + * that these routines exist ONLY in char versions. + */ + +#include "regguts.h" + +/* + - regcomp - compile regular expression + */ +int +regcomp(re, str, flags) +regex_t *re; +CONST char *str; +int flags; +{ + size_t len; + int f = flags; + + if (f®_PEND) { + len = re->re_endp - str; + f &= ~REG_PEND; + } else + len = strlen(str); + + return re_comp(re, str, len, f); +} + +/* + - regexec - execute regular expression + */ +int +regexec(re, str, nmatch, pmatch, flags) +regex_t *re; +CONST char *str; +size_t nmatch; +regmatch_t pmatch[]; +int flags; +{ + CONST char *start; + size_t len; + int f = flags; + + if (f®_STARTEND) { + start = str + pmatch[0].rm_so; + len = pmatch[0].rm_eo - pmatch[0].rm_so; + f &= ~REG_STARTEND; + } else { + start = str; + len = strlen(str); + } + + return re_exec(re, start, len, nmatch, pmatch, f); +} diff --git a/generic/regguts.h b/generic/regguts.h new file mode 100644 index 0000000..badd8d4 --- /dev/null +++ b/generic/regguts.h @@ -0,0 +1,388 @@ +/* + * Internal interface definitions, etc., for the regex package + */ + + + +/* + * Environmental customization. It should not (I hope) be necessary to + * alter the file you are now reading -- regcustom.h should handle it all, + * given care here and elsewhere. + */ +#include "regcustom.h" + + + +/* + * Things that regcustom.h might override. + */ + +/* standard header files (NULL is a reasonable indicator for them) */ +#ifndef NULL +#include +#include +#include +#include +#include +#endif + +/* assertions */ +#ifndef assert +#ifndef REG_DEBUG +#define NDEBUG +#include +#endif +#endif + +/* voids */ +#ifndef VOID +#define VOID void /* for function return values */ +#endif +#ifndef DISCARD +#define DISCARD VOID /* for throwing values away */ +#endif +#ifndef PVOID +#define PVOID VOID * /* generic pointer */ +#endif +#ifndef VS +#define VS(x) ((PVOID)(x)) /* cast something to generic ptr */ +#endif +#ifndef NOPARMS +#define NOPARMS VOID /* for empty parm lists */ +#endif + +/* function-pointer declarator */ +#ifndef FUNCPTR +#if __STDC__ >= 1 +#define FUNCPTR(name, args) (*name)args +#else +#define FUNCPTR(name, args) (*name)() +#endif +#endif + +/* memory allocation */ +#ifndef MALLOC +#define MALLOC(n) malloc(n) +#endif +#ifndef REALLOC +#define REALLOC(p, n) realloc(VS(p), n) +#endif +#ifndef FREE +#define FREE(p) free(VS(p)) +#endif + +/* want size of a char in bits, and max value in bounded quantifiers */ +#ifndef CHAR_BIT +#include +#endif +#ifndef _POSIX2_RE_DUP_MAX +#define _POSIX2_RE_DUP_MAX 255 /* normally from */ +#endif + + + +/* + * misc + */ + +#define NOTREACHED 0 +#define xxx 1 + +#define DUPMAX _POSIX2_RE_DUP_MAX +#define INFINITY (DUPMAX+1) + +#define REMAGIC 0xfed7 /* magic number for main struct */ + + + +/* + * debugging facilities + */ +#ifdef REG_DEBUG +/* FDEBUG does finite-state tracing */ +#define FDEBUG(arglist) { if (v->eflags®_FTRACE) printf arglist; } +/* MDEBUG does higher-level tracing */ +#define MDEBUG(arglist) { if (v->eflags®_MTRACE) printf arglist; } +#else +#define FDEBUG(arglist) {} +#define MDEBUG(arglist) {} +#endif + + + +/* + * bitmap manipulation + */ +#define UBITS (CHAR_BIT * sizeof(unsigned)) +#define BSET(uv, sn) ((uv)[(sn)/UBITS] |= (unsigned)1 << ((sn)%UBITS)) +#define ISBSET(uv, sn) ((uv)[(sn)/UBITS] & ((unsigned)1 << ((sn)%UBITS))) + + + +/* + * We dissect a chr into byts for colormap table indexing. Here we define + * a byt, which will be the same as a byte on most machines... The exact + * size of a byt is not critical, but about 8 bits is good, and extraction + * of 8-bit chunks is sometimes especially fast. + */ +#ifndef BYTBITS +#define BYTBITS 8 /* bits in a byt */ +#endif +#define BYTTAB (1<flags&FREECOL) + union tree *block; /* block of solid color, if any */ +}; + +/* the color map itself */ +struct colormap { + int magic; +# define CMMAGIC 0x876 + struct vars *v; /* for compile error reporting */ + size_t ncds; /* number of colordescs */ + size_t max; /* highest in use */ + color free; /* beginning of free chain (if non-0) */ + struct colordesc *cd; +# define CDEND(cm) (&(cm)->cd[(cm)->max + 1]) +# define NINLINECDS ((size_t)10) + struct colordesc cdspace[NINLINECDS]; + union tree tree[NBYTS]; /* tree top, plus fill blocks */ +}; + +/* optimization magic to do fast chr->color mapping */ +#define B0(c) ((c) & BYTMASK) +#define B1(c) (((c)>>BYTBITS) & BYTMASK) +#define B2(c) (((c)>>(2*BYTBITS)) & BYTMASK) +#define B3(c) (((c)>>(3*BYTBITS)) & BYTMASK) +#if NBYTS == 1 +#define GETCOLOR(cm, c) ((cm)->tree->tcolor[B0(c)]) +#endif +/* beware, for NBYTS>1, GETCOLOR() is unsafe -- 2nd arg used repeatedly */ +#if NBYTS == 2 +#define GETCOLOR(cm, c) ((cm)->tree->tptr[B1(c)]->tcolor[B0(c)]) +#endif +#if NBYTS == 4 +#define GETCOLOR(cm, c) ((cm)->tree->tptr[B3(c)]->tptr[B2(c)]->tptr[B1(c)]->tcolor[B0(c)]) +#endif + + + +/* + * Interface definitions for locale-interface functions in locale.c. + * Multi-character collating elements (MCCEs) cause most of the trouble. + */ +struct cvec { + int nchrs; /* number of chrs */ + int chrspace; /* number of chrs possible */ + chr *chrs; /* pointer to vector of chrs */ + int nranges; /* number of ranges (chr pairs) */ + int rangespace; /* number of chrs possible */ + chr *ranges; /* pointer to vector of chr pairs */ + int nmcces; /* number of MCCEs */ + int mccespace; /* number of MCCEs possible */ + int nmccechrs; /* number of chrs used for MCCEs */ + chr *mcces[1]; /* pointers to 0-terminated MCCEs */ + /* and both batches of chrs are on the end */ +}; + +/* caution: this value cannot be changed easily */ +#define MAXMCCE 2 /* length of longest MCCE */ + + + +/* + * definitions for NFA internal representation + * + * Having a "from" pointer within each arc may seem redundant, but it + * saves a lot of hassle. + */ +struct state; + +struct arc { + int type; +# define ARCFREE '\0' + color co; + struct state *from; /* where it's from (and contained within) */ + struct state *to; /* where it's to */ + struct arc *outchain; /* *from's outs chain or free chain */ +# define freechain outchain + struct arc *inchain; /* *to's ins chain */ + struct arc *colorchain; /* color's arc chain */ +}; + +struct arcbatch { /* for bulk allocation of arcs */ + struct arcbatch *next; +# define ABSIZE 10 + struct arc a[ABSIZE]; +}; + +struct state { + int no; +# define FREESTATE (-1) + char flag; /* marks special states */ + int nins; /* number of inarcs */ + struct arc *ins; /* chain of inarcs */ + int nouts; /* number of outarcs */ + struct arc *outs; /* chain of outarcs */ + struct arc *free; /* chain of free arcs */ + struct state *tmp; /* temporary for traversal algorithms */ + struct state *next; /* chain for traversing all */ + struct state *prev; /* back chain */ + struct arcbatch oas; /* first arcbatch, avoid malloc in easy case */ +}; + +struct nfa { + struct state *pre; /* pre-initial state */ + struct state *init; /* initial state */ + struct state *final; /* final state */ + struct state *post; /* post-final state */ + int nstates; /* for numbering states */ + struct state *states; /* state-chain header */ + struct state *slast; /* tail of the chain */ + struct state *free; /* free list */ + struct colormap *cm; /* the color map */ + color bos[2]; /* colors, if any, assigned to BOS and BOL */ + color eos[2]; /* colors, if any, assigned to EOS and EOL */ + struct vars *v; /* simplifies compile error reporting */ + struct nfa *parent; /* parent NFA, if any */ +}; + + + +/* + * definitions for compacted NFA + */ +struct carc { + color co; /* COLORLESS is list terminator */ + int to; /* state number */ +}; + +struct cnfa { + int nstates; /* number of states */ + int ncolors; /* number of colors */ + int flags; +# define HASLACONS 01 /* uses lookahead constraints */ + int pre; /* setup state number */ + int post; /* teardown state number */ + color bos[2]; /* colors, if any, assigned to BOS and BOL */ + color eos[2]; /* colors, if any, assigned to EOS and EOL */ + struct carc **states; /* vector of pointers to outarc lists */ + struct carc *arcs; /* the area for the lists */ +}; +#define ZAPCNFA(cnfa) ((cnfa).nstates = 0) +#define NULLCNFA(cnfa) ((cnfa).nstates == 0) + + + +/* + * subexpression tree + */ +struct subre { + char op; /* '|', '.' (concat), 'b' (backref), '(', '=' */ + char flags; +# define LONGER 01 /* prefers longer match */ +# define SHORTER 02 /* prefers shorter match */ +# define MIXED 04 /* mixed preference below */ +# define CAP 010 /* capturing parens below */ +# define BACKR 020 /* back reference below */ +# define INUSE 0100 /* in use in final tree */ +# define LOCAL 03 /* bits which may not propagate up */ +# define LMIX(f) ((f)<<2) /* LONGER -> MIXED */ +# define SMIX(f) ((f)<<1) /* SHORTER -> MIXED */ +# define UP(f) (((f)&~LOCAL) | (LMIX(f) & SMIX(f) & MIXED)) +# define MESSY(f) ((f)&(MIXED|CAP|BACKR)) +# define PREF(f) ((f)&LOCAL) +# define PREF2(f1, f2) ((PREF(f1) != 0) ? PREF(f1) : PREF(f2)) +# define COMBINE(f1, f2) (UP((f1)|(f2)) | PREF2(f1, f2)) + short retry; /* index into retry memory */ + int subno; /* subexpression number (for 'b' and '(') */ + short min; /* min repetitions, for backref only */ + short max; /* max repetitions, for backref only */ + struct subre *left; /* left child, if any (also freelist chain) */ + struct subre *right; /* right child, if any */ + struct state *begin; /* outarcs from here... */ + struct state *end; /* ...ending in inarcs here */ + struct cnfa cnfa; /* compacted NFA, if any */ + struct subre *chain; /* for bookkeeping and error cleanup */ +}; + + + +/* + * table of function pointers for generic manipulation functions + * A regex_t's re_fns points to one of these. + */ +struct fns { + VOID FUNCPTR(free, (regex_t *)); +}; + + + +/* + * the insides of a regex_t, hidden behind a void * + */ +struct guts { + int magic; +# define GUTSMAGIC 0xfed9 + int cflags; /* copy of compile flags */ + int info; /* copy of re_info */ + size_t nsub; /* copy of re_nsub */ + struct subre *tree; + struct cnfa search; /* for fast preliminary search */ + int ntree; + struct colormap cmap; + int FUNCPTR(compare, (CONST chr *, CONST chr *, size_t)); + struct subre *lacons; /* lookahead-constraint vector */ + int nlacons; /* size of lacons */ + int usedshorter; /* used non-greedy quantifiers? */ + int unmatchable; /* cannot match anything? */ +}; diff --git a/generic/tcl.decls b/generic/tcl.decls index 11058d2..671f5ff 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -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.7 1999/03/11 02:49:33 stanton Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.8 1999/04/16 00:46:41 stanton Exp $ library tcl @@ -35,7 +35,7 @@ declare 1 generic { int exact, ClientData *clientDataPtr) } declare 2 generic { - void panic(char *format, ...) + void Tcl_Panic(char *format, ...) } declare 3 generic { char * Tcl_Alloc(unsigned int size) @@ -123,7 +123,8 @@ declare 27 generic { Tcl_Obj * Tcl_DbNewObj(char *file, int line) } declare 28 generic { - Tcl_Obj * Tcl_DbNewStringObj(char *bytes, int length, char *file, int line) + Tcl_Obj * Tcl_DbNewStringObj(CONST char *bytes, int length, \ + char *file, int line) } declare 29 generic { Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr) @@ -132,7 +133,7 @@ declare 30 generic { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 generic { - int Tcl_GetBoolean(Tcl_Interp *interp, char *string, int *boolPtr) + int Tcl_GetBoolean(Tcl_Interp *interp, char *str, int *boolPtr) } declare 32 generic { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ @@ -142,7 +143,7 @@ declare 33 generic { unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr) } declare 34 generic { - int Tcl_GetDouble(Tcl_Interp *interp, char *string, double *doublePtr) + int Tcl_GetDouble(Tcl_Interp *interp, char *str, double *doublePtr) } declare 35 generic { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ @@ -153,7 +154,7 @@ declare 36 generic { char **tablePtr, char *msg, int flags, int *indexPtr) } declare 37 generic { - int Tcl_GetInt(Tcl_Interp *interp, char *string, int *intPtr) + int Tcl_GetInt(Tcl_Interp *interp, char *str, int *intPtr) } declare 38 generic { int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr) @@ -215,10 +216,10 @@ declare 55 generic { Tcl_Obj * Tcl_NewObj(void) } declare 56 generic { - Tcl_Obj *Tcl_NewStringObj(char *bytes, int length) + Tcl_Obj *Tcl_NewStringObj(CONST char *bytes, int length) } declare 57 generic { - void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) + void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) } declare 58 generic { unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length) @@ -230,31 +231,32 @@ declare 60 generic { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } declare 61 generic { - void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) + void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) } declare 62 generic { - void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *CONST objv[]) + void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *CONST objv[]) } declare 63 generic { - void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) + void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) } declare 64 generic { void Tcl_SetObjLength(Tcl_Obj *objPtr, int length) } declare 65 generic { - void Tcl_SetStringObj(Tcl_Obj *objPtr, char *bytes, int length) + void Tcl_SetStringObj(Tcl_Obj *objPtr, char *bytes, int length) } declare 66 generic { - void Tcl_AddErrorInfo(Tcl_Interp *interp, char *message) + void Tcl_AddErrorInfo(Tcl_Interp *interp, CONST char *message) } declare 67 generic { - void Tcl_AddObjErrorInfo(Tcl_Interp *interp, char *message, int length) + void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message, \ + int length) } declare 68 generic { void Tcl_AllowExceptions(Tcl_Interp *interp) } declare 69 generic { - void Tcl_AppendElement(Tcl_Interp *interp, char *string) + void Tcl_AppendElement(Tcl_Interp *interp, CONST char *string) } declare 70 generic { void Tcl_AppendResult(Tcl_Interp *interp, ...) @@ -421,8 +423,7 @@ declare 116 generic { void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData) } declare 117 generic { - char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *string, \ - int length) + char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *str, int length) } declare 118 generic { char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, CONST char *string) @@ -477,19 +478,19 @@ declare 134 generic { char *cmdName) } declare 135 generic { - int Tcl_ExprBoolean(Tcl_Interp *interp, char *string, int *ptr) + int Tcl_ExprBoolean(Tcl_Interp *interp, 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 *string, double *ptr) + int Tcl_ExprDouble(Tcl_Interp *interp, 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 *string, long *ptr) + int Tcl_ExprLong(Tcl_Interp *interp, char *str, long *ptr) } declare 140 generic { int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr) @@ -505,7 +506,7 @@ declare 143 generic { void Tcl_Finalize(void) } declare 144 generic { - void Tcl_FindExecutable(char *argv0) + void Tcl_FindExecutable(CONST char *argv0) } declare 145 generic { Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, \ @@ -519,11 +520,13 @@ declare 147 generic { } declare 148 generic { int Tcl_GetAlias(Tcl_Interp *interp, char *slaveCmd, \ - Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *argcPtr, char ***argvPtr) + Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *argcPtr, \ + char ***argvPtr) } declare 149 generic { int Tcl_GetAliasObj(Tcl_Interp *interp, char *slaveCmd, \ - Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) + Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *objcPtr, \ + Tcl_Obj ***objv) } declare 150 generic { ClientData Tcl_GetAssocData(Tcl_Interp *interp, char *name, \ @@ -586,7 +589,7 @@ declare 166 generic { # generic interface, so we inlcude it here for compatibility reasons. declare 167 unix { - int Tcl_GetOpenFile(Tcl_Interp *interp, char *string, int write, \ + int Tcl_GetOpenFile(Tcl_Interp *interp, char *str, int write, \ int checkUsage, ClientData *filePtr) } @@ -736,11 +739,11 @@ declare 212 generic { Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, char *string) } declare 213 generic { - int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, char *string, \ - char *start) + int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, \ + CONST char *str, CONST char *start) } declare 214 generic { - int Tcl_RegExpMatch(Tcl_Interp *interp, char *string, char *pattern) + int Tcl_RegExpMatch(Tcl_Interp *interp, char *str, char *pattern) } declare 215 generic { void Tcl_RegExpRange(Tcl_RegExp regexp, int index, char **startPtr, \ @@ -753,10 +756,10 @@ declare 217 generic { void Tcl_ResetResult(Tcl_Interp *interp) } declare 218 generic { - int Tcl_ScanElement(CONST char *string, int *flagPtr) + int Tcl_ScanElement(CONST char *str, int *flagPtr) } declare 219 generic { - int Tcl_ScanCountedElement(CONST char *string, int length, int *flagPtr) + int Tcl_ScanCountedElement(CONST char *str, int length, int *flagPtr) } declare 220 generic { int Tcl_Seek(Tcl_Channel chan, int offset, int mode) @@ -798,7 +801,7 @@ declare 231 generic { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) } declare 232 generic { - void Tcl_SetResult(Tcl_Interp *interp, char *string, \ + void Tcl_SetResult(Tcl_Interp *interp, char *str, \ Tcl_FreeProc *freeProc) } declare 233 generic { @@ -831,18 +834,18 @@ declare 241 generic { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 generic { - int Tcl_SplitList(Tcl_Interp *interp, char *list, int *argcPtr, \ + int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr, \ char ***argvPtr) } declare 243 generic { - void Tcl_SplitPath(char *path, int *argcPtr, char ***argvPtr) + void Tcl_SplitPath(CONST char *path, int *argcPtr, char ***argvPtr) } declare 244 generic { void Tcl_StaticPackage(Tcl_Interp *interp, char *pkgName, \ Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } declare 245 generic { - int Tcl_StringMatch(char *string, char *pattern) + int Tcl_StringMatch(CONST char *str, CONST char *pattern) } declare 246 generic { int Tcl_Tell(Tcl_Channel chan) @@ -928,7 +931,7 @@ declare 269 generic { char * Tcl_HashStats(Tcl_HashTable *tablePtr) } declare 270 generic { - char * Tcl_ParseVar(Tcl_Interp *interp, char *string, char **termPtr) + char * Tcl_ParseVar(Tcl_Interp *interp, char *str, char **termPtr) } declare 271 generic { char * Tcl_PkgPresent(Tcl_Interp *interp, char *name, char *version, \ @@ -955,14 +958,16 @@ declare 277 generic { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } declare 278 generic { - void panicVA(char *format, va_list argList) + void Tcl_PanicVA(char *format, va_list argList) } declare 279 generic { void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type) } +declare 280 generic { + void Tcl_InitMemory(Tcl_Interp *interp) +} + # Reserved for future use (8.0.x vs. 8.1) -# declare 280 generic { -# } # declare 281 generic { # } # declare 282 generic { @@ -974,6 +979,278 @@ declare 279 generic { # declare 285 generic { # } + +# Added in 8.1: + +declare 286 generic { + void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr) +} +declare 287 generic { + Tcl_Encoding Tcl_CreateEncoding(Tcl_EncodingType *typePtr) +} +declare 288 generic { + void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData) +} +declare 289 generic { + void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData) +} +declare 290 generic { + void Tcl_DiscardResult(Tcl_SavedResult *statePtr) +} +declare 291 generic { + int Tcl_EvalEx(Tcl_Interp *interp, char *script, int numBytes, int flags) +} +declare 292 generic { + int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \ + int flags) +} +declare 293 generic { + int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) +} +declare 294 generic { + void Tcl_ExitThread(int status) +} +declare 295 generic { + int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, \ + CONST char *src, int srcLen, int flags, \ + Tcl_EncodingState *statePtr, char *dst, int dstLen, \ + int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) +} +declare 296 generic { + char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, CONST char *src, \ + int srcLen, Tcl_DString *dsPtr) +} +declare 297 generic { + void Tcl_FinalizeThread(void) +} +declare 298 generic { + void Tcl_FinalizeNotifier(ClientData clientData) +} +declare 299 generic { + void Tcl_FreeEncoding(Tcl_Encoding encoding) +} +declare 300 generic { + Tcl_ThreadId Tcl_GetCurrentThread(void) +} +declare 301 generic { + Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name) +} +declare 302 generic { + char * Tcl_GetEncodingName(Tcl_Encoding encoding) +} +declare 303 generic { + void Tcl_GetEncodingNames(Tcl_Interp *interp) +} +declare 304 generic { + int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + char **tablePtr, int offset, char *msg, int flags, int *indexPtr) +} +declare 305 generic { + VOID * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size) +} +declare 306 generic { + Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \ + int flags) +} +declare 307 generic { + ClientData Tcl_InitNotifier(void) +} +declare 308 generic { + void Tcl_MutexLock(Tcl_Mutex *mutexPtr) +} +declare 309 generic { + void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr) +} +declare 310 generic { + void Tcl_ConditionNotify(Tcl_Condition *condPtr) +} +declare 311 generic { + void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, \ + Tcl_Time *timePtr) +} +declare 312 generic { + int Tcl_NumUtfChars(CONST char *src, int len) +} +declare 313 generic { + int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, \ + int appendFlag) +} +declare 314 generic { + void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +} +declare 315 generic { + void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +} +declare 316 generic { + int Tcl_SetSystemEncoding(Tcl_Interp *interp, CONST char *name) +} +declare 317 generic { + Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \ + Tcl_Obj *newValuePtr, int flags) +} +declare 318 generic { + void Tcl_ThreadAlert(Tcl_ThreadId threadId) +} +declare 319 generic { + void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr, \ + Tcl_QueuePosition position) +} +declare 320 generic { + Tcl_UniChar Tcl_UniCharAtIndex(CONST char *src, int index) +} +declare 321 generic { + Tcl_UniChar Tcl_UniCharToLower(int ch) +} +declare 322 generic { + Tcl_UniChar Tcl_UniCharToTitle(int ch) +} +declare 323 generic { + Tcl_UniChar Tcl_UniCharToUpper(int ch) +} +declare 324 generic { + int Tcl_UniCharToUtf(int ch, char *buf) +} +declare 325 generic { + char * Tcl_UtfAtIndex(CONST char *src, int index) +} +declare 326 generic { + int Tcl_UtfCharComplete(CONST char *src, int len) +} +declare 327 generic { + int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst) +} +declare 328 generic { + char * Tcl_UtfFindFirst(CONST char *src, int ch) +} +declare 329 generic { + char * Tcl_UtfFindLast(CONST char *src, int ch) +} +declare 330 generic { + char * Tcl_UtfNext(CONST char *src) +} +declare 331 generic { + char * Tcl_UtfPrev(CONST char *src, CONST char *start) +} +declare 332 generic { + int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, \ + CONST char *src, int srcLen, int flags, \ + Tcl_EncodingState *statePtr, char *dst, int dstLen, \ + int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) +} +declare 333 generic { + char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, CONST char *src, \ + int srcLen, Tcl_DString *dsPtr) +} +declare 334 generic { + int Tcl_UtfToLower(char *src) +} +declare 335 generic { + int Tcl_UtfToTitle(char *src) +} +declare 336 generic { + int Tcl_UtfToUniChar(CONST char *src, Tcl_UniChar *chPtr) +} +declare 337 generic { + int Tcl_UtfToUpper(char *src) +} +declare 338 generic { + int Tcl_WriteChars(Tcl_Channel chan, CONST char *src, int srcLen) +} +declare 339 generic { + int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) +} +declare 340 generic { + char * Tcl_GetString(Tcl_Obj *objPtr) +} +declare 341 generic { + char * Tcl_GetDefaultEncodingDir(void) +} +declare 342 generic { + void Tcl_SetDefaultEncodingDir(char *path) +} +declare 343 generic { + void Tcl_AlertNotifier(ClientData clientData) +} +declare 344 generic { + void Tcl_ServiceModeHook(int mode) +} +declare 345 generic { + int Tcl_UniCharIsAlnum(int ch) +} +declare 346 generic { + int Tcl_UniCharIsAlpha(int ch) +} +declare 347 generic { + int Tcl_UniCharIsDigit(int ch) +} +declare 348 generic { + int Tcl_UniCharIsLower(int ch) +} +declare 349 generic { + int Tcl_UniCharIsSpace(int ch) +} +declare 350 generic { + int Tcl_UniCharIsUpper(int ch) +} +declare 351 generic { + int Tcl_UniCharIsWordChar(int ch) +} +declare 352 generic { + int Tcl_UniCharLen(Tcl_UniChar *str) +} +declare 353 generic { + int Tcl_UniCharNcmp(const Tcl_UniChar *cs, const Tcl_UniChar *ct, size_t n) +} +declare 354 generic { + char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string, int numChars, \ + Tcl_DString *dsPtr) +} +declare 355 generic { + Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string, int length, \ + Tcl_DString *dsPtr) +} +declare 356 generic { + Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) +} + +declare 357 generic { + Tcl_Obj *Tcl_EvalTokens (Tcl_Interp *interp, Tcl_Token *tokenPtr, \ + int count) +} +declare 358 generic { + void Tcl_FreeParse (Tcl_Parse *parsePtr) +} +declare 359 generic { + void Tcl_LogCommandInfo (Tcl_Interp *interp, char *script, \ + char *command, int length) +} +declare 360 generic { + int Tcl_ParseBraces (Tcl_Interp *interp, char *string, \ + int numBytes, Tcl_Parse *parsePtr,int append, char **termPtr) +} +declare 361 generic { + int Tcl_ParseCommand (Tcl_Interp *interp, char *string, int numBytes, \ + int nested, Tcl_Parse *parsePtr) +} +declare 362 generic { + int Tcl_ParseExpr(Tcl_Interp *interp, char *string, int numBytes, \ + Tcl_Parse *parsePtr) +} +declare 363 generic { + int Tcl_ParseQuotedString(Tcl_Interp *interp, char *string, int numBytes, \ + Tcl_Parse *parsePtr, int append, char **termPtr) +} +declare 364 generic { + int Tcl_ParseVarName (Tcl_Interp *interp, char *string, \ + int numBytes, Tcl_Parse *parsePtr, int append) +} +declare 365 generic { + char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) +} +declare 366 generic { + int Tcl_Chdir(CONST char *dirName) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are @@ -981,6 +1258,18 @@ declare 279 generic { interface tclPlat +###################### +# Windows declarations + +# Added in Tcl 8.1 + +declare 0 win { + TCHAR * Tcl_WinUtfToTChar(CONST char *str, int len, Tcl_DString *dsPtr) +} +declare 1 win { + char * Tcl_WinTCharToUtf(CONST TCHAR *str, int len, Tcl_DString *dsPtr) +} + ################## # Mac declarations @@ -1030,4 +1319,3 @@ declare 7 mac { declare 8 mac { int strcasecmp(CONST char *s1, CONST char *s2) } - diff --git a/generic/tcl.h b/generic/tcl.h index 9a56498..2a8be54 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -5,14 +5,14 @@ * of the Tcl interpreter. * * Copyright (c) 1987-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1993-1996 Lucent Technologies. - * Copyright (c) 1998-1999 Scriptics Corporation. + * Copyright (c) 1994-1998 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: tcl.h,v 1.38 1999/03/12 23:03:51 stanton Exp $ + * RCS: @(#) $Id: tcl.h,v 1.39 1999/04/16 00:46:42 stanton Exp $ */ #ifndef _TCL @@ -30,24 +30,25 @@ * When version numbers change here, must also go into the following files * and update the version numbers: * - * README * library/init.tcl (only if major.minor changes, not patchlevel) * unix/configure.in * win/makefile.bc (only if major.minor changes, not patchlevel) * win/makefile.vc (only if major.minor changes, not patchlevel) - * win/README - * win/README.binary + * win/pkgIndex.tcl (for tclregNN.dll, not patchlevel) + * README * mac/README - * + * win/README.binary + * win/README (only if major.minor changes, not patchlevel) + * unix/README (only if major.minor changes, not patchlevel) */ #define TCL_MAJOR_VERSION 8 -#define TCL_MINOR_VERSION 0 -#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 5 +#define TCL_MINOR_VERSION 1 +#define TCL_RELEASE_LEVEL TCL_BETA_RELEASE +#define TCL_RELEASE_SERIAL 3 -#define TCL_VERSION "8.0" -#define TCL_PATCH_LEVEL "8.0.5" +#define TCL_VERSION "8.1" +#define TCL_PATCH_LEVEL "8.1b3" /* * The following definitions set up the proper options for Windows @@ -99,6 +100,7 @@ # ifndef NO_STRERROR # define NO_STRERROR 1 # endif +# define INLINE #endif /* @@ -129,6 +131,29 @@ # endif #endif +/* + * Special macro to define mutexes, that doesn't do anything + * if we are not using threads. + */ + +#ifdef TCL_THREADS +#define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name; +#else +#define TCL_DECLARE_MUTEX(name) +#endif + +/* + * Macros that eliminate the overhead of the thread synchronization + * functions when compiling without thread support. + */ + +#ifndef TCL_THREADS +#define Tcl_MutexLock(mutexPtr) +#define Tcl_MutexUnlock(mutexPtr) +#define Tcl_ConditionNotify(condPtr) +#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) +#endif /* TCL_THREADS */ + /* * A special definition used to allow this header file to be included * in resource files so that they can get obtain version information from @@ -222,10 +247,14 @@ /* * Definitions that allow this header file to be used either with or - * without ANSI C features like function prototypes. */ + * without ANSI C features like function prototypes. + */ #undef _ANSI_ARGS_ #undef CONST +#ifndef INLINE +# define INLINE +#endif #if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) || defined(USE_PROTOTYPE) # define _USING_PROTOTYPES_ 1 @@ -322,9 +351,15 @@ typedef struct Tcl_Interp { typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_Command_ *Tcl_Command; +typedef struct Tcl_Condition_ *Tcl_Condition; +typedef struct Tcl_EncodingState_ *Tcl_EncodingState; +typedef struct Tcl_Encoding_ *Tcl_Encoding; typedef struct Tcl_Event Tcl_Event; +typedef struct Tcl_Mutex_ *Tcl_Mutex; typedef struct Tcl_Pid_ *Tcl_Pid; typedef struct Tcl_RegExp_ *Tcl_RegExp; +typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey; +typedef struct Tcl_ThreadId_ *Tcl_ThreadId; typedef struct Tcl_TimerToken_ *Tcl_TimerToken; typedef struct Tcl_Trace_ *Tcl_Trace; typedef struct Tcl_Var_ *Tcl_Var; @@ -395,6 +430,11 @@ typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData, ClientData cmdClientData, int argc, char *argv[])); typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr)); +typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, + char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +typedef void (Tcl_EncodingFreeProc)_ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData, int flags)); @@ -414,7 +454,7 @@ typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[])); + Tcl_Interp *interp, int objc, struct Tcl_Obj *CONST objv[])); typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(char *, format)); typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, @@ -468,8 +508,8 @@ typedef struct Tcl_Obj { * means the string rep is invalid and must * be regenerated from the internal rep. * Clients should use Tcl_GetStringFromObj - * to get a pointer to the byte array as a - * readonly value. */ + * or Tcl_GetString to get a pointer to the + * byte array as a readonly value. */ int length; /* The number of bytes at *bytes, not * including the terminating null. */ Tcl_ObjType *typePtr; /* Denotes the object's type. Always @@ -520,7 +560,7 @@ EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); /* * Macros and definitions that help to debug the use of Tcl objects. - * When TCL_MEM_DEBUG is defined, the Tcl_New* declarations are + * When TCL_MEM_DEBUG is defined, the Tcl_New declarations are * overridden to call debugging versions of the object creation procedures. */ @@ -544,6 +584,23 @@ EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); #endif /* TCL_MEM_DEBUG */ /* + * The following structure contains the state needed by + * Tcl_SaveResult. No-one outside of Tcl should access any of these + * fields. This structure is typically allocated on the stack. + */ + +typedef struct Tcl_SavedResult { + char *result; + Tcl_FreeProc *freeProc; + Tcl_Obj *objResultPtr; + char *appendResult; + int appendAvl; + int appendUsed; + char resultSpace[TCL_RESULT_SIZE+1]; +} Tcl_SavedResult; + + +/* * The following definitions support Tcl's namespace facility. * Note: the first five fields must match exactly the fields in a * Namespace structure (see tcl.h). @@ -665,13 +722,21 @@ typedef struct Tcl_DString { /* * Definitions for the maximum number of digits of precision that may * be specified in the "tcl_precision" variable, and the number of - * characters of buffer space required by Tcl_PrintDouble. + * bytes of buffer space required by Tcl_PrintDouble. */ #define TCL_MAX_PREC 17 #define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) /* + * Definition for a number of bytes of buffer space sufficient to hold the + * string representation of an integer in base 10 (assuming the existence + * of 64-bit integers). + */ + +#define TCL_INTEGER_SPACE 24 + +/* * Flag that may be passed to Tcl_ConvertElement to force it not to * output braces (careful! if you change this flag be sure to change * the definitions at the front of tclUtil.c). @@ -687,13 +752,14 @@ typedef struct Tcl_DString { #define TCL_EXACT 1 /* - * Flag values passed to Tcl_RecordAndEval. + * Flag values passed to Tcl_RecordAndEval and/or Tcl_EvalObj. * WARNING: these bit choices must not conflict with the bit choices * for evalFlag bits in tclInt.h!! */ #define TCL_NO_EVAL 0x10000 #define TCL_EVAL_GLOBAL 0x20000 +#define TCL_EVAL_DIRECT 0x40000 /* * Special freeProc values that may be passed to Tcl_SetResult (see @@ -718,7 +784,19 @@ typedef struct Tcl_DString { #define TCL_TRACE_DESTROYED 0x80 #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 -#define TCL_PARSE_PART1 0x400 +#define TCL_TRACE_ARRAY 0x800 + +/* + * The TCL_PARSE_PART1 flag is deprecated and has no effect. + * The part1 is now always parsed whenever the part2 is NULL. + * (This is to avoid a common error when converting code to + * use the new object based APIs and forgetting to give the + * flag) + */ +#ifndef TCL_NO_DEPRECATED +#define TCL_PARSE_PART1 0x400 +#endif + /* * Types for linked variables: @@ -731,45 +809,6 @@ typedef struct Tcl_DString { #define TCL_LINK_READ_ONLY 0x80 /* - * The following declarations either map ckalloc and ckfree to - * malloc and free, or they map them to procedures with all sorts - * of debugging hooks defined in tclCkalloc.c. - */ - -#ifdef TCL_MEM_DEBUG - -# define Tcl_Alloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) -# define Tcl_Free(x) Tcl_DbCkfree(x, __FILE__, __LINE__) -# define Tcl_Realloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) -# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) -# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) -# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) - -#else - -/* - * If USE_TCLALLOC is true, then we need to call Tcl_Alloc instead of - * the native malloc/free. The only time USE_TCLALLOC should not be - * true is when compiling the Tcl/Tk libraries on Unix systems. In this - * case we can safely call the native malloc/free directly as a performance - * optimization. - */ - -# if USE_TCLALLOC -# define ckalloc(x) Tcl_Alloc(x) -# define ckfree(x) Tcl_Free(x) -# define ckrealloc(x,y) Tcl_Realloc(x,y) -# else -# define ckalloc(x) malloc(x) -# define ckfree(x) free(x) -# define ckrealloc(x,y) realloc(x,y) -# endif -# define Tcl_DumpActiveMemory(x) -# define Tcl_ValidateAllMemory(x,y) - -#endif /* !TCL_MEM_DEBUG */ - -/* * Forward declaration of Tcl_HashTable. Needed by some C++ compilers * to prevent errors when the forward reference to Tcl_HashTable is * encountered in the Tcl_HashEntry structure. @@ -960,6 +999,21 @@ typedef struct Tcl_Time { #define TCL_ENFORCE_MODE (1<<4) /* + * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel + * should be closed. + */ + +#define TCL_CLOSE_READ (1<<1) +#define TCL_CLOSE_WRITE (1<<2) + +/* + * Value to use as the closeProc for a channel that supports the + * close2Proc interface. + */ + +#define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)1) + +/* * Typedefs for the various operations in a channel type: */ @@ -967,6 +1021,8 @@ typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_(( ClientData instanceData, int mode)); typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp)); +typedef int (Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, int flags)); typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData, char *buf, int toRead, int *errorCodePtr)); typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData, @@ -986,6 +1042,43 @@ typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_(( ClientData *handlePtr)); /* + * The following declarations either map ckalloc and ckfree to + * malloc and free, or they map them to procedures with all sorts + * of debugging hooks defined in tclCkalloc.c. + */ + +#ifdef TCL_MEM_DEBUG + +# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) +# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) +# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) + +#else /* !TCL_MEM_DEBUG */ + +/* + * If USE_TCLALLOC is true, then we need to call Tcl_Alloc instead of + * the native malloc/free. The only time USE_TCLALLOC should not be + * true is when compiling the Tcl/Tk libraries on Unix systems. In this + * case we can safely call the native malloc/free directly as a performance + * optimization. + */ + +# if USE_TCLALLOC +# define ckalloc(x) Tcl_Alloc(x) +# define ckfree(x) Tcl_Free(x) +# define ckrealloc(x,y) Tcl_Realloc(x,y) +# else +# define ckalloc(x) malloc(x) +# define ckfree(x) free(x) +# define ckrealloc(x,y) realloc(x,y) +# endif +# define Tcl_InitMemory(x) +# define Tcl_DumpActiveMemory(x) +# define Tcl_ValidateAllMemory(x,y) + +#endif /* !TCL_MEM_DEBUG */ + +/* * Enum for different end of line translation and recognition modes. */ @@ -1011,8 +1104,10 @@ typedef struct Tcl_ChannelType { Tcl_DriverBlockModeProc *blockModeProc; /* Set blocking mode for the * raw channel. May be NULL. */ - Tcl_DriverCloseProc *closeProc; /* Procedure to call to close - * the channel. */ + Tcl_DriverCloseProc *closeProc; /* Procedure to call to close the + * channel, or TCL_CLOSE2PROC if the + * close2Proc should be used + * instead. */ Tcl_DriverInputProc *inputProc; /* Procedure to call for input * on channel. */ Tcl_DriverOutputProc *outputProc; /* Procedure to call for output @@ -1028,7 +1123,10 @@ typedef struct Tcl_ChannelType { Tcl_DriverGetHandleProc *getHandleProc; /* Get an OS handle from the channel * or NULL if not supported. */ - VOID *reserved; /* reserved for future expansion */ + Tcl_DriverClose2Proc *close2Proc; /* Procedure to call to close the + * channel if the device supports + * closing the read & write sides + * independently. */ } Tcl_ChannelType; /* @@ -1052,6 +1150,298 @@ typedef enum Tcl_PathType { } Tcl_PathType; /* + * The following structure represents a user-defined encoding. It collects + * together all the functions that are used by the specific encoding. + */ + +typedef struct Tcl_EncodingType { + CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp". + * This name is the unique key for this + * encoding type. */ + Tcl_EncodingConvertProc *toUtfProc; + /* Procedure to convert from external + * encoding into UTF-8. */ + Tcl_EncodingConvertProc *fromUtfProc; + /* Procedure to convert from UTF-8 into + * external encoding. */ + Tcl_EncodingFreeProc *freeProc; + /* If non-NULL, procedure to call when this + * encoding is deleted. */ + ClientData clientData; /* Arbitrary value associated with encoding + * type. Passed to conversion procedures. */ + int nullSize; /* Number of zero bytes that signify + * end-of-string in this encoding. This + * number is used to determine the source + * string length when the srcLen argument is + * negative. Must be 1 or 2. */ +} Tcl_EncodingType; + +/* + * The following definitions are used as values for the conversion control + * flags argument when converting text from one character set to another: + * + * TCL_ENCODING_START: Signifies that the source buffer is the first + * block in a (potentially multi-block) input + * stream. Tells the conversion procedure to + * reset to an initial state and perform any + * initialization that needs to occur before the + * first byte is converted. If the source + * buffer contains the entire input stream to be + * converted, this flag should be set. + * + * TCL_ENCODING_END: Signifies that the source buffer is the last + * block in a (potentially multi-block) input + * stream. Tells the conversion routine to + * perform any finalization that needs to occur + * after the last byte is converted and then to + * reset to an initial state. If the source + * buffer contains the entire input stream to be + * converted, this flag should be set. + * + * TCL_ENCODING_STOPONERROR: If set, then the converter will return + * immediately upon encountering an invalid + * byte sequence or a source character that has + * no mapping in the target encoding. If clear, + * then the converter will skip the problem, + * substituting one or more "close" characters + * in the destination buffer and then continue + * to sonvert the source. + */ + +#define TCL_ENCODING_START 0x01 +#define TCL_ENCODING_END 0x02 +#define TCL_ENCODING_STOPONERROR 0x04 + +/* + *---------------------------------------------------------------- + * The following data structures and declarations are for the new + * Tcl parser. This stuff should all move to tcl.h eventually. + *---------------------------------------------------------------- + */ + +/* + * For each word of a command, and for each piece of a word such as a + * variable reference, one of the following structures is created to + * describe the token. + */ + +typedef struct Tcl_Token { + int type; /* Type of token, such as TCL_TOKEN_WORD; + * see below for valid types. */ + char *start; /* First character in token. */ + int size; /* Number of bytes in token. */ + int numComponents; /* If this token is composed of other + * tokens, this field tells how many of + * them there are (including components of + * components, etc.). The component tokens + * immediately follow this one. */ +} Tcl_Token; + +/* + * Type values defined for Tcl_Token structures. These values are + * defined as mask bits so that it's easy to check for collections of + * types. + * + * TCL_TOKEN_WORD - The token describes one word of a command, + * from the first non-blank character of + * the word (which may be " or {) up to but + * not including the space, semicolon, or + * bracket that terminates the word. + * NumComponents counts the total number of + * sub-tokens that make up the word. This + * includes, for example, sub-tokens of + * TCL_TOKEN_VARIABLE tokens. + * TCL_TOKEN_SIMPLE_WORD - This token is just like TCL_TOKEN_WORD + * except that the word is guaranteed to + * consist of a single TCL_TOKEN_TEXT + * sub-token. + * TCL_TOKEN_TEXT - The token describes a range of literal + * text that is part of a word. + * NumComponents is always 0. + * TCL_TOKEN_BS - The token describes a backslash sequence + * that must be collapsed. NumComponents + * is always 0. + * TCL_TOKEN_COMMAND - The token describes a command whose result + * must be substituted into the word. The + * token includes the enclosing brackets. + * NumComponents is always 0. + * TCL_TOKEN_VARIABLE - The token describes a variable + * substitution, including the dollar sign, + * variable name, and array index (if there + * is one) up through the right + * parentheses. NumComponents tells how + * many additional tokens follow to + * represent the variable name. The first + * token will be a TCL_TOKEN_TEXT token + * that describes the variable name. If + * the variable is an array reference then + * there will be one or more additional + * tokens, of type TCL_TOKEN_TEXT, + * TCL_TOKEN_BS, TCL_TOKEN_COMMAND, and + * TCL_TOKEN_VARIABLE, that describe the + * array index; numComponents counts the + * total number of nested tokens that make + * up the variable reference, including + * sub-tokens of TCL_TOKEN_VARIABLE tokens. + * TCL_TOKEN_SUB_EXPR - The token describes one subexpression of a + * expression, from the first non-blank + * character of the subexpression up to but not + * including the space, brace, or bracket + * that terminates the subexpression. + * NumComponents counts the total number of + * following subtokens that make up the + * subexpression; this includes all subtokens + * for any nested TCL_TOKEN_SUB_EXPR tokens. + * For example, a numeric value used as a + * primitive operand is described by a + * TCL_TOKEN_SUB_EXPR token followed by a + * TCL_TOKEN_TEXT token. A binary subexpression + * is described by a TCL_TOKEN_SUB_EXPR token + * followed by the TCL_TOKEN_OPERATOR token + * for the operator, then TCL_TOKEN_SUB_EXPR + * tokens for the left then the right operands. + * TCL_TOKEN_OPERATOR - The token describes one expression operator. + * An operator might be the name of a math + * function such as "abs". A TCL_TOKEN_OPERATOR + * token is always preceeded by one + * TCL_TOKEN_SUB_EXPR token for the operator's + * subexpression, and is followed by zero or + * more TCL_TOKEN_SUB_EXPR tokens for the + * operator's operands. NumComponents is + * always 0. + */ + +#define TCL_TOKEN_WORD 1 +#define TCL_TOKEN_SIMPLE_WORD 2 +#define TCL_TOKEN_TEXT 4 +#define TCL_TOKEN_BS 8 +#define TCL_TOKEN_COMMAND 16 +#define TCL_TOKEN_VARIABLE 32 +#define TCL_TOKEN_SUB_EXPR 64 +#define TCL_TOKEN_OPERATOR 128 + +/* + * A structure of the following type is filled in by Tcl_ParseCommand. + * It describes a single command parsed from an input string. + */ + +#define NUM_STATIC_TOKENS 20 + +typedef struct Tcl_Parse { + char *commentStart; /* Pointer to # that begins the first of + * one or more comments preceding the + * command. */ + int commentSize; /* Number of bytes in comments (up through + * newline character that terminates the + * last comment). If there were no + * comments, this field is 0. */ + char *commandStart; /* First character in first word of command. */ + int commandSize; /* Number of bytes in command, including + * first character of first word, up + * through the terminating newline, + * close bracket, or semicolon. */ + int numWords; /* Total number of words in command. May + * be 0. */ + Tcl_Token *tokenPtr; /* Pointer to first token representing + * the words of the command. Initially + * points to staticTokens, but may change + * to point to malloc-ed space if command + * exceeds space in staticTokens. */ + int numTokens; /* Total number of tokens in command. */ + int tokensAvailable; /* Total number of tokens available at + * *tokenPtr. */ + + /* + * The fields below are intended only for the private use of the + * parser. They should not be used by procedures that invoke + * Tcl_ParseCommand. + */ + + char *string; /* The original command string passed to + * Tcl_ParseCommand. */ + char *end; /* Points to the character just after the + * last one in the command string. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting, + * or NULL. */ + char *term; /* Points to character in string that + * terminated most recent token. Filled in + * by ParseTokens. If an error occurs, + * points to beginning of region where the + * error occurred (e.g. the open brace if + * the close brace is missing). */ + int incomplete; /* This field is set to 1 by Tcl_ParseCommand + * if the command appears to be incomplete. + * This information is used by + * Tcl_CommandComplete. */ + Tcl_Token staticTokens[NUM_STATIC_TOKENS]; + /* Initial space for tokens for command. + * This space should be large enough to + * accommodate most commands; dynamic + * space is allocated for very large + * commands that don't fit here. */ +} Tcl_Parse; + +/* + * The following definitions are the error codes returned by the conversion + * routines: + * + * TCL_OK: All characters were converted. + * + * TCL_CONVERT_NOSPACE: The output buffer would not have been large + * enough for all of the converted data; as many + * characters as could fit were converted though. + * + * TCL_CONVERT_MULTIBYTE: The last few bytes in the source string were + * the beginning of a multibyte sequence, but + * more bytes were needed to complete this + * sequence. A subsequent call to the conversion + * routine should pass the beginning of this + * unconverted sequence plus additional bytes + * from the source stream to properly convert + * the formerly split-up multibyte sequence. + * + * TCL_CONVERT_SYNTAX: The source stream contained an invalid + * character sequence. This may occur if the + * input stream has been damaged or if the input + * encoding method was misidentified. This error + * is reported only if TCL_ENCODING_STOPONERROR + * was specified. + * + * TCL_CONVERT_UNKNOWN: The source string contained a character + * that could not be represented in the target + * encoding. This error is reported only if + * TCL_ENCODING_STOPONERROR was specified. + */ + +#define TCL_CONVERT_MULTIBYTE -1 +#define TCL_CONVERT_SYNTAX -2 +#define TCL_CONVERT_UNKNOWN -3 +#define TCL_CONVERT_NOSPACE -4 + +/* + * The maximum number of bytes that are necessary to represent a single + * Unicode character in UTF-8. + */ + +#define TCL_UTF_MAX 3 + +/* + * This represents a Unicode character. + */ + +typedef unsigned short Tcl_UniChar; + +/* + * Deprecated Tcl procedures: + */ + +#ifndef TCL_NO_DEPRECATED +#define Tcl_EvalObj(interp,objPtr) Tcl_EvalObjEx((interp),(objPtr),0) +#define Tcl_GlobalEvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) +#endif + +/* * These function have been renamed. The old names are deprecated, but we * define these macros for backwards compatibilty. */ @@ -1061,18 +1451,15 @@ typedef enum Tcl_PathType { #define Tcl_Ckrealloc Tcl_Realloc #define Tcl_Return Tcl_SetResult #define Tcl_TildeSubst Tcl_TranslateFileName - -/* - * In later releases, Tcl_Panic will be the correct name to use. For now - * we leave it as panic to avoid breaking existing binaries. - */ - -#define Tcl_Panic panic -#define Tcl_PanicVA panicVA +#define panic Tcl_Panic +#define panicVA Tcl_PanicVA /* * The following constant is used to test for older versions of Tcl * in the stubs tables. + * + * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different + * value since the stubs tables don't match. */ #define TCL_STUB_MAGIC 0xFCA3BACF @@ -1088,6 +1475,18 @@ typedef enum Tcl_PathType { EXTERN char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, char *version, int exact)); +#ifndef USE_TCL_STUBS + +/* + * When not using stubs, make it a macro. + */ + +#define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgRequire(interp, "Tcl", version, exact) + +#endif + + /* * Include the public function declarations that are accessible via * the stubs table. @@ -1099,7 +1498,6 @@ EXTERN char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, * Public functions that are not accessible via the stubs table. */ -EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, Tcl_AppInitProc *appInitProc)); diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 9314c2a..c44cf9f 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -8,13 +8,14 @@ * * Copyright (c) 1983 Regents of the University of California. * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAlloc.c,v 1.5 1999/03/11 02:49:34 stanton Exp $ + * RCS: @(#) $Id: tclAlloc.c,v 1.6 1999/04/16 00:46:42 stanton Exp $ */ #include "tclInt.h" @@ -31,7 +32,7 @@ typedef unsigned long caddr_t; /* - * The overhead on a block is at least 4 bytes. When free, this space + * The overhead on a block is at least 8 bytes. When free, this space * contains a pointer to the next free block, and the bottom two bits must * be zero. When in use, the first byte is set to MAGIC, and the second * byte is the size index. The remaining bytes are for alignment. @@ -43,6 +44,7 @@ typedef unsigned long caddr_t; union overhead { union overhead *ov_next; /* when free */ + unsigned char ov_padding[8]; /* Ensure the structure is 8-byte aligned. */ struct { unsigned char ovu_magic0; /* magic number */ unsigned char ovu_index; /* bucket # */ @@ -51,13 +53,14 @@ union overhead { #ifdef RCHECK unsigned short ovu_rmagic; /* range magic number */ unsigned long ovu_size; /* actual block size */ + unsigned short ovu_unused2; /* padding to 8-byte align */ #endif } ovu; #define ov_magic0 ovu.ovu_magic0 #define ov_magic1 ovu.ovu_magic1 #define ov_index ovu.ovu_index #define ov_rmagic ovu.ovu_rmagic -#define ov_size ovu.ovu_size +#define ov_size ovu.ovu_size }; @@ -82,6 +85,36 @@ union overhead { #define MAXMALLOC (1<<(NBUCKETS+2)) static union overhead *nextf[NBUCKETS]; +/* + * The following structure is used to keep track of all system memory + * currently owned by Tcl. When finalizing, all this memory will + * be returned to the system. + */ + +struct block { + struct block *nextPtr; /* Linked list. */ + struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte + * alignment for suballocated blocks. */ +}; + +static struct block *blockList; /* Tracks the suballocated blocks. */ +static struct block bigBlocks = { /* Big blocks aren't suballocated. */ + &bigBlocks, &bigBlocks +}; + +/* + * The allocator is protected by a special mutex that must be + * explicitly initialized. Futhermore, because Tcl_Alloc may be + * used before anything else in Tcl, we make this module self-initializing + * after all with the allocInit variable. + */ + +#ifdef TCL_THREADS +static TclpMutex allocMutex; +#endif +static int allocInit = 0; + + #ifdef MSTATS /* @@ -106,6 +139,89 @@ static unsigned int nmalloc[NBUCKETS+1]; */ static void MoreCore _ANSI_ARGS_((int bucket)); + + +/* + *------------------------------------------------------------------------- + * + * TclInitAlloc -- + * + * Initialize the memory system. + * + * Results: + * None. + * + * Side effects: + * Initialize the mutex used to serialize allocations. + * + *------------------------------------------------------------------------- + */ + +void +TclInitAlloc() +{ + if (!allocInit) { + allocInit = 1; + TclpMutexInit(&allocMutex); + } +} + +/* + *------------------------------------------------------------------------- + * + * TclFinalizeAllocSubsystem -- + * + * Release all resources being used by this subsystem, including + * aggressively freeing all memory allocated by TclpAlloc() that + * has not yet been released with TclpFree(). + * + * After this function is called, all memory allocated with + * TclpAlloc() should be considered unusable. + * + * Results: + * None. + * + * Side effects: + * This subsystem is self-initializing, since memory can be + * allocated before Tcl is formally initialized. After this call, + * this subsystem has been reset to its initial state and is + * usable again. + * + *------------------------------------------------------------------------- + */ + +void +TclFinalizeAllocSubsystem() +{ + int i; + struct block *blockPtr, *nextPtr; + + TclpMutexLock(&allocMutex); + for (blockPtr = blockList; blockPtr != NULL; blockPtr = nextPtr) { + nextPtr = blockPtr->nextPtr; + TclpSysFree(blockPtr); + } + blockList = NULL; + + for (blockPtr = bigBlocks.nextPtr; blockPtr != &bigBlocks; ) { + nextPtr = blockPtr->nextPtr; + TclpSysFree(blockPtr); + blockPtr = nextPtr; + } + bigBlocks.nextPtr = &bigBlocks; + bigBlocks.prevPtr = &bigBlocks; + + for (i = 0; i < NBUCKETS; i++) { + nextf[i] = NULL; +#ifdef MSTATS + nmalloc[i] = 0; +#endif + } +#ifdef MSTATS + nmalloc[i] = 0; +#endif + TclpMutexUnlock(&allocMutex); +} /* *---------------------------------------------------------------------- @@ -124,21 +240,41 @@ static void MoreCore _ANSI_ARGS_((int bucket)); */ char * -TclpAlloc( - unsigned int nbytes) /* Number of bytes to allocate. */ +TclpAlloc(nbytes) + unsigned int nbytes; /* Number of bytes to allocate. */ { register union overhead *op; register long bucket; register unsigned amt; + struct block *bigBlockPtr; + if (!allocInit) { + /* + * We have to make the "self initializing" because Tcl_Alloc + * may be used before any other part of Tcl. E.g., see + * main() for tclsh! + */ + + allocInit = 1; + TclpMutexInit(&allocMutex); + } + TclpMutexLock(&allocMutex); /* * First the simple case: we simple allocate big blocks directly */ if (nbytes + OVERHEAD >= MAXMALLOC) { - op = (union overhead *)TclpSysAlloc(nbytes+OVERHEAD, 0); - if (op == NULL) { + bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) + (sizeof(struct block) + OVERHEAD + nbytes), 0); + if (bigBlockPtr == NULL) { + TclpMutexUnlock(&allocMutex); return NULL; } + bigBlockPtr->nextPtr = bigBlocks.nextPtr; + bigBlocks.nextPtr = bigBlockPtr; + bigBlockPtr->prevPtr = &bigBlocks; + bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; + + op = (union overhead *) (bigBlockPtr + 1); op->ov_magic0 = op->ov_magic1 = MAGIC; op->ov_index = 0xff; #ifdef MSTATS @@ -153,6 +289,7 @@ TclpAlloc( op->ov_rmagic = RMAGIC; *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; #endif + TclpMutexUnlock(&allocMutex); return (void *)(op+1); } /* @@ -170,6 +307,7 @@ TclpAlloc( while (nbytes + OVERHEAD > amt) { amt <<= 1; if (amt == 0) { + TclpMutexUnlock(&allocMutex); return (NULL); } bucket++; @@ -183,6 +321,7 @@ TclpAlloc( if ((op = nextf[bucket]) == NULL) { MoreCore(bucket); if ((op = nextf[bucket]) == NULL) { + TclpMutexUnlock(&allocMutex); return (NULL); } } @@ -204,6 +343,7 @@ TclpAlloc( op->ov_rmagic = RMAGIC; *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; #endif + TclpMutexUnlock(&allocMutex); return ((char *)(op + 1)); } @@ -214,6 +354,8 @@ TclpAlloc( * * Allocate more memory to the indicated bucket. * + * Assumes Mutex is already held. + * * Results: * None. * @@ -224,13 +366,14 @@ TclpAlloc( */ static void -MoreCore( - int bucket) /* What bucket to allocat to. */ +MoreCore(bucket) + int bucket; /* What bucket to allocat to. */ { register union overhead *op; register long sz; /* size of desired block */ long amt; /* amount to allocate */ int nblks; /* how many blocks we get */ + struct block *blockPtr; /* * sbrk_size <= 0 only for big, FLUFFY, requests (about @@ -243,11 +386,16 @@ MoreCore( nblks = amt / sz; ASSERT(nblks*sz == amt); - op = (union overhead *)TclpSysAlloc(amt, 1); + blockPtr = (struct block *) TclpSysAlloc((unsigned) + (sizeof(struct block) + amt), 1); /* no more room! */ - if (op == NULL) { + if (blockPtr == NULL) { return; } + blockPtr->nextPtr = blockList; + blockList = blockPtr; + + op = (union overhead *) (blockPtr + 1); /* * Add new memory allocated to that on @@ -278,21 +426,24 @@ MoreCore( */ void -TclpFree( - char *cp) /* Pointer to memory to free. */ +TclpFree(cp) + char *cp; /* Pointer to memory to free. */ { register long size; register union overhead *op; + struct block *bigBlockPtr; if (cp == NULL) { return; } + TclpMutexLock(&allocMutex); op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */ ASSERT(op->ov_magic1 == MAGIC); if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) { + TclpMutexUnlock(&allocMutex); return; } @@ -303,7 +454,11 @@ TclpFree( #ifdef MSTATS nmalloc[NBUCKETS]--; #endif - TclpSysFree(op); + bigBlockPtr = (struct block *) op - 1; + bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr; + bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr; + TclpSysFree(bigBlockPtr); + TclpMutexUnlock(&allocMutex); return; } ASSERT(size < NBUCKETS); @@ -312,6 +467,7 @@ TclpFree( #ifdef MSTATS nmalloc[size]--; #endif + TclpMutexUnlock(&allocMutex); } /* @@ -331,12 +487,13 @@ TclpFree( */ char * -TclpRealloc( - char *cp, /* Pointer to alloced block. */ - unsigned int nbytes) /* New size of memory. */ +TclpRealloc(cp, nbytes) + char *cp; /* Pointer to alloced block. */ + unsigned int nbytes; /* New size of memory. */ { int i; union overhead *op; + struct block *bigBlockPtr; int expensive; unsigned long maxsize; @@ -344,11 +501,14 @@ TclpRealloc( return (TclpAlloc(nbytes)); } + TclpMutexLock(&allocMutex); + op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */ ASSERT(op->ov_magic1 == MAGIC); if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) { + TclpMutexUnlock(&allocMutex); return NULL; } @@ -361,10 +521,28 @@ TclpRealloc( */ if (i == 0xff) { - op = (union overhead *) TclpSysRealloc(op, nbytes+OVERHEAD); - if (op == NULL) { + struct block *prevPtr, *nextPtr; + bigBlockPtr = (struct block *) op - 1; + prevPtr = bigBlockPtr->prevPtr; + nextPtr = bigBlockPtr->nextPtr; + bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, + sizeof(struct block) + OVERHEAD + nbytes); + if (bigBlockPtr == NULL) { + TclpMutexUnlock(&allocMutex); return NULL; } + + if (prevPtr->nextPtr != bigBlockPtr) { + /* + * If the block has moved, splice the new block into the list where + * the old block used to be. + */ + + prevPtr->nextPtr = bigBlockPtr; + nextPtr->prevPtr = bigBlockPtr; + } + + op = (union overhead *) (bigBlockPtr + 1); #ifdef MSTATS nmalloc[NBUCKETS]++; #endif @@ -376,6 +554,7 @@ TclpRealloc( op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; #endif + TclpMutexUnlock(&allocMutex); return (char *)(op+1); } maxsize = 1 << (i+3); @@ -388,7 +567,9 @@ TclpRealloc( if (expensive) { void *newp; - + + TclpMutexUnlock(&allocMutex); + newp = TclpAlloc(nbytes); if ( newp == NULL ) { return NULL; @@ -408,6 +589,7 @@ TclpRealloc( op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; #endif + TclpMutexUnlock(&allocMutex); return(cp); } @@ -431,14 +613,15 @@ TclpRealloc( #ifdef MSTATS void -mstats( - char *s) /* Where to write info. */ +mstats(s) + char *s; /* Where to write info. */ { register int i, j; register union overhead *p; int totfree = 0, totused = 0; + TclpMutexLock(&allocMutex); fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) @@ -454,11 +637,11 @@ mstats( totused, totfree); fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", MAXMALLOC, nmalloc[NBUCKETS]); + TclpMutexUnlock(&allocMutex); } #endif -#else /* !USE_TCLALLOC */ - +#else /* !USE_TCLALLOC */ /* *---------------------------------------------------------------------- @@ -477,8 +660,8 @@ mstats( */ char * -TclpAlloc( - unsigned int nbytes) /* Number of bytes to allocate. */ +TclpAlloc(nbytes) + unsigned int nbytes; /* Number of bytes to allocate. */ { return (char*) malloc(nbytes); } @@ -500,8 +683,8 @@ TclpAlloc( */ void -TclpFree( - char *cp) /* Pointer to memory to free. */ +TclpFree(cp) + char *cp; /* Pointer to memory to free. */ { free(cp); return; @@ -524,9 +707,9 @@ TclpFree( */ char * -TclpRealloc( - char *cp, /* Pointer to alloced block. */ - unsigned int nbytes) /* New size of memory. */ +TclpRealloc(cp, nbytes) + char *cp; /* Pointer to alloced block. */ + unsigned int nbytes; /* New size of memory. */ { return (char*) realloc(cp, nbytes); } diff --git a/generic/tclAsync.c b/generic/tclAsync.c index 18af186..fc80385 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -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: tclAsync.c,v 1.3 1999/03/11 00:19:23 stanton Exp $ + * RCS: @(#) $Id: tclAsync.c,v 1.4 1999/04/16 00:46:42 stanton Exp $ */ #include "tclInt.h" @@ -43,6 +43,8 @@ static AsyncHandler *firstHandler; /* First handler defined for process, * or NULL if none. */ static AsyncHandler *lastHandler; /* Last handler or NULL. */ +TCL_DECLARE_MUTEX(asyncMutex) /* Process-wide async handler lock */ + /* * The variable below is set to 1 whenever a handler becomes ready and * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be @@ -92,12 +94,14 @@ Tcl_AsyncCreate(proc, clientData) asyncPtr->nextPtr = NULL; asyncPtr->proc = proc; asyncPtr->clientData = clientData; + Tcl_MutexLock(&asyncMutex); if (firstHandler == NULL) { firstHandler = asyncPtr; } else { lastHandler->nextPtr = asyncPtr; } lastHandler = asyncPtr; + Tcl_MutexUnlock(&asyncMutex); return (Tcl_AsyncHandler) asyncPtr; } @@ -124,11 +128,13 @@ void Tcl_AsyncMark(async) Tcl_AsyncHandler async; /* Token for handler. */ { + Tcl_MutexLock(&asyncMutex); ((AsyncHandler *) async)->ready = 1; if (!asyncActive) { - TclpAsyncMark(async); asyncReady = 1; + TclpAsyncMark(async); } + Tcl_MutexUnlock(&asyncMutex); } /* @@ -161,8 +167,10 @@ Tcl_AsyncInvoke(interp, code) * just completed. */ { AsyncHandler *asyncPtr; + Tcl_MutexLock(&asyncMutex); if (asyncReady == 0) { + Tcl_MutexUnlock(&asyncMutex); return code; } asyncReady = 0; @@ -193,9 +201,12 @@ Tcl_AsyncInvoke(interp, code) break; } asyncPtr->ready = 0; + Tcl_MutexUnlock(&asyncMutex); code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code); + Tcl_MutexLock(&asyncMutex); } asyncActive = 0; + Tcl_MutexUnlock(&asyncMutex); return code; } @@ -223,6 +234,7 @@ Tcl_AsyncDelete(async) AsyncHandler *asyncPtr = (AsyncHandler *) async; AsyncHandler *prevPtr; + Tcl_MutexLock(&asyncMutex); if (firstHandler == asyncPtr) { firstHandler = asyncPtr->nextPtr; if (firstHandler == NULL) { @@ -238,6 +250,7 @@ Tcl_AsyncDelete(async) lastHandler = prevPtr; } } + Tcl_MutexUnlock(&asyncMutex); ckfree((char *) asyncPtr); } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 24c7189..e673a3c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -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.18 1999/03/11 02:49:34 stanton Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.19 1999/04/16 00:46:42 stanton Exp $ */ #include "tclInt.h" @@ -26,8 +26,13 @@ */ static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); -static void HiddenCmdsDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); +static void ProcessUnexpectedResult _ANSI_ARGS_(( + Tcl_Interp *interp, int returnCode)); +static void RecordTracebackInfo _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr, + int numSrcBytes)); + +extern TclStubs tclStubs; /* * The following structure defines the commands in the Tcl core. @@ -62,7 +67,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, (CompileProc *) NULL, 1}, - {"break", Tcl_BreakCmd, (Tcl_ObjCmdProc *) NULL, + {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, (CompileProc *) NULL, 1}, @@ -72,8 +77,10 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, (CompileProc *) NULL, 1}, - {"continue", Tcl_ContinueCmd, (Tcl_ObjCmdProc *) NULL, + {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd, TclCompileContinueCmd, 1}, + {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd, + (CompileProc *) NULL, 0}, {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, (CompileProc *) NULL, 1}, {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd, @@ -84,9 +91,9 @@ static CmdInfo builtInCmds[] = { TclCompileExprCmd, 1}, {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, (CompileProc *) NULL, 1}, - {"fileevent", Tcl_FileEventCmd, (Tcl_ObjCmdProc *) NULL, + {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd, (CompileProc *) NULL, 1}, - {"for", Tcl_ForCmd, (Tcl_ObjCmdProc *) NULL, + {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd, TclCompileForCmd, 1}, {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, TclCompileForeachCmd, 1}, @@ -94,14 +101,12 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, (CompileProc *) NULL, 1}, - {"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL, + {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd, TclCompileIfCmd, 1}, - {"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL, + {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd, TclCompileIncrCmd, 1}, {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, (CompileProc *) NULL, 1}, - {"interp", (Tcl_CmdProc *) NULL, Tcl_InterpObjCmd, - (CompileProc *) NULL, 1}, {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, (CompileProc *) NULL, 1}, {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, @@ -114,7 +119,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, (CompileProc *) NULL, 1}, - {"load", Tcl_LoadCmd, (Tcl_ObjCmdProc *) NULL, + {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd, (CompileProc *) NULL, 0}, {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, (CompileProc *) NULL, 1}, @@ -126,31 +131,31 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, (CompileProc *) NULL, 1}, - {"package", Tcl_PackageCmd, (Tcl_ObjCmdProc *) NULL, + {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd, (CompileProc *) NULL, 1}, {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, (CompileProc *) NULL, 1}, - {"regexp", Tcl_RegexpCmd, (Tcl_ObjCmdProc *) NULL, + {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd, (CompileProc *) NULL, 1}, - {"regsub", Tcl_RegsubCmd, (Tcl_ObjCmdProc *) NULL, + {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd, (CompileProc *) NULL, 1}, {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, (CompileProc *) NULL, 1}, {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, (CompileProc *) NULL, 1}, - {"scan", Tcl_ScanCmd, (Tcl_ObjCmdProc *) NULL, + {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, (CompileProc *) NULL, 1}, - {"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL, + {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, TclCompileSetCmd, 1}, {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, (CompileProc *) NULL, 1}, {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, (CompileProc *) NULL, 1}, - {"subst", Tcl_SubstCmd, (Tcl_ObjCmdProc *) NULL, + {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, (CompileProc *) NULL, 1}, {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, (CompileProc *) NULL, 1}, - {"trace", Tcl_TraceCmd, (Tcl_ObjCmdProc *) NULL, + {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd, (CompileProc *) NULL, 1}, {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, (CompileProc *) NULL, 1}, @@ -160,7 +165,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, (CompileProc *) NULL, 1}, - {"while", Tcl_WhileCmd, (Tcl_ObjCmdProc *) NULL, + {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd, TclCompileWhileCmd, 1}, /* @@ -178,7 +183,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, (CompileProc *) NULL, 1}, - {"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL, + {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd, (CompileProc *) NULL, 0}, {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, (CompileProc *) NULL, 0}, @@ -186,7 +191,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, (CompileProc *) NULL, 1}, - {"glob", Tcl_GlobCmd, (Tcl_ObjCmdProc *) NULL, + {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd, (CompileProc *) NULL, 0}, {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd, (CompileProc *) NULL, 0}, @@ -194,21 +199,21 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, (CompileProc *) NULL, 1}, - {"pwd", Tcl_PwdCmd, (Tcl_ObjCmdProc *) NULL, + {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd, (CompileProc *) NULL, 0}, {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, (CompileProc *) NULL, 1}, - {"seek", Tcl_SeekCmd, (Tcl_ObjCmdProc *) NULL, + {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd, (CompileProc *) NULL, 1}, - {"socket", Tcl_SocketCmd, (Tcl_ObjCmdProc *) NULL, + {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd, (CompileProc *) NULL, 0}, - {"tell", Tcl_TellCmd, (Tcl_ObjCmdProc *) NULL, + {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd, (CompileProc *) NULL, 1}, {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, (CompileProc *) NULL, 1}, - {"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL, + {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd, (CompileProc *) NULL, 1}, - {"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL, + {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd, (CompileProc *) NULL, 1}, #ifdef MAC_TCL @@ -216,14 +221,14 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 0}, {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, - {"ls", Tcl_LsCmd, (Tcl_ObjCmdProc *) NULL, + {"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd, (CompileProc *) NULL, 0}, {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd, (CompileProc *) NULL, 1}, {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd, (CompileProc *) NULL, 0}, #else - {"exec", Tcl_ExecCmd, (Tcl_ObjCmdProc *) NULL, + {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd, (CompileProc *) NULL, 0}, {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, (CompileProc *) NULL, 0}, @@ -233,35 +238,7 @@ static CmdInfo builtInCmds[] = { {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0} }; - -/* - *---------------------------------------------------------------------- - * - * Tcl_InitStubs -- - * - * Ensures that the correct version of Tcl is loaded. This is - * a trivial implementation of the stubs library initializer - * that will get called if a stubs aware extension is directly - * linked with the Tcl library. - * - * Results: - * The actual version of Tcl that satisfies the request, or - * NULL to indicate that an error occurred. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ -char * -Tcl_InitStubs (interp, version, exact) - Tcl_Interp *interp; - char *version; - int exact; -{ - return Tcl_PkgRequire(interp, "Tcl", version, exact); -} /* *---------------------------------------------------------------------- @@ -285,14 +262,23 @@ Tcl_InitStubs (interp, version, exact) Tcl_Interp * Tcl_CreateInterp() { - register Interp *iPtr; - register Command *cmdPtr; - register CmdInfo *cmdInfoPtr; + Interp *iPtr; + Tcl_Interp *interp; + Command *cmdPtr; + BuiltinFunc *builtinFuncPtr; + MathFunc *mathFuncPtr; + Tcl_HashEntry *hPtr; + CmdInfo *cmdInfoPtr; + int i; union { char c[sizeof(short)]; short s; } order; - int i; +#ifdef TCL_COMPILE_STATS + ByteCodeStats *statsPtr; +#endif /* TCL_COMPILE_STATS */ + + TclInitSubsystems(NULL); /* * Panic if someone updated the CallFrame structure without @@ -310,15 +296,20 @@ Tcl_CreateInterp() * Tcl object type table and other object management code. */ - TclInitNamespaces(); - iPtr = (Interp *) ckalloc(sizeof(Interp)); - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - iPtr->objResultPtr = Tcl_NewObj(); /* an empty object */ + interp = (Tcl_Interp *) iPtr; + + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = NULL; + iPtr->errorLine = 0; + iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); - iPtr->errorLine = 0; + iPtr->handle = TclHandleCreate(iPtr); + iPtr->globalNsPtr = NULL; + iPtr->hiddenCmdTablePtr = NULL; + iPtr->interpInfo = NULL; Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); + iPtr->numLevels = 0; iPtr->maxNestingDepth = 1000; iPtr->framePtr = NULL; @@ -327,9 +318,11 @@ Tcl_CreateInterp() iPtr->returnCode = TCL_OK; iPtr->errorInfo = NULL; iPtr->errorCode = NULL; + iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; + for (i = 0; i < NUM_REGEXPS; i++) { iPtr->patterns[i] = NULL; iPtr->patLengths[i] = -1; @@ -339,6 +332,7 @@ Tcl_CreateInterp() iPtr->packageUnknown = NULL; iPtr->cmdCount = 0; iPtr->termOffset = 0; + TclInitLiteralTable(&(iPtr->literalTable)); iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; @@ -353,26 +347,63 @@ Tcl_CreateInterp() iPtr->resultSpace[0] = 0; iPtr->globalNsPtr = NULL; /* force creation of global ns below */ - iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace( - (Tcl_Interp *) iPtr, "", (ClientData) NULL, - (Tcl_NamespaceDeleteProc *) NULL); + iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", + (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (iPtr->globalNsPtr == NULL) { panic("Tcl_CreateInterp: can't create global namespace"); } /* - * Initialize support for code compilation. Do this after initializing - * namespaces since TclCreateExecEnv will try to reference a Tcl - * variable (it links to the Tcl "tcl_traceExec" variable). + * Initialize support for code compilation and execution. We call + * TclCreateExecEnv after initializing namespaces since it tries to + * reference a Tcl variable (it links to the Tcl "tcl_traceExec" + * variable). */ + + iPtr->execEnvPtr = TclCreateExecEnv(interp); + + /* + * Initialize the compilation and execution statistics kept for this + * interpreter. + */ + +#ifdef TCL_COMPILE_STATS + statsPtr = &(iPtr->stats); + statsPtr->numExecutions = 0; + statsPtr->numCompilations = 0; + statsPtr->numByteCodesFreed = 0; + (VOID *) memset(statsPtr->instructionCount, 0, + sizeof(statsPtr->instructionCount)); + + statsPtr->totalSrcBytes = 0.0; + statsPtr->totalByteCodeBytes = 0.0; + statsPtr->currentSrcBytes = 0.0; + statsPtr->currentByteCodeBytes = 0.0; + (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); + (VOID *) memset(statsPtr->byteCodeCount, 0, + sizeof(statsPtr->byteCodeCount)); + (VOID *) memset(statsPtr->lifetimeCount, 0, + sizeof(statsPtr->lifetimeCount)); - iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr); + statsPtr->currentInstBytes = 0.0; + statsPtr->currentLitBytes = 0.0; + statsPtr->currentExceptBytes = 0.0; + statsPtr->currentAuxBytes = 0.0; + statsPtr->currentCmdMapBytes = 0.0; + + statsPtr->numLiteralsCreated = 0; + statsPtr->totalLitStringBytes = 0.0; + statsPtr->currentLitStringBytes = 0.0; + (VOID *) memset(statsPtr->literalCount, 0, + sizeof(statsPtr->literalCount)); +#endif /* TCL_COMPILE_STATS */ /* * Initialise the stub table pointer. */ - iPtr->stubTable = tclStubsPtr; + iPtr->stubTable = &tclStubs; + /* * Create the core commands. Do it here, rather than calling @@ -428,72 +459,93 @@ Tcl_CreateInterp() } /* - * Initialize/Create "errorInfo" and "errorCode" global vars - * (because some part of the C code assume they exists - * and we can get a seg fault otherwise (in multiple - * interps loading of extensions for instance) --dl) - */ - /* - * We can't assume that because we initialize - * the variables here, they won't be unset later. - * so we had 2 choices: - * + Check every place where a GetVar of those is used - * and the NULL result is not checked (like in tclLoad.c) - * + Make SetVar,... NULL friendly - * We choosed the second option because : - * + It is easy and low cost to check for NULL pointer before - * calling strlen() - * + It can be helpfull to other people using those API - * + Passing a NULL value to those closest 'meaning' is empty string - * (specially with the new objects where 0 bytes strings are ok) - * So the following init is commented out: -- dl - */ - /* - (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "", - TCL_GLOBAL_ONLY); - (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE", - TCL_GLOBAL_ONLY); + * Register the builtin math functions. */ -#ifndef TCL_GENERIC_ONLY - TclSetupEnv((Tcl_Interp *) iPtr); -#endif + i = 0; + for (builtinFuncPtr = builtinFuncTable; builtinFuncPtr->name != NULL; + builtinFuncPtr++) { + Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name, + builtinFuncPtr->numArgs, builtinFuncPtr->argTypes, + (Tcl_MathProc *) NULL, (ClientData) 0); + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, + builtinFuncPtr->name); + if (hPtr == NULL) { + panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name); + return NULL; + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + mathFuncPtr->builtinFuncIndex = i; + i++; + } + iPtr->flags |= EXPR_INITIALIZED; /* * Do Multiple/Safe Interps Tcl init stuff */ - (void) TclInterpInit((Tcl_Interp *)iPtr); + + TclInterpInit(interp); /* - * Set up variables such as tcl_version. + * We used to create the "errorInfo" and "errorCode" global vars at this + * point because so much of the Tcl implementation assumes they already + * exist. This is not quite enough, however, since they can be unset + * at any time. + * + * There are 2 choices: + * + Check every place where a GetVar of those is used + * and the NULL result is not checked (like in tclLoad.c) + * + Make SetVar,... NULL friendly + * We choose the second option because : + * + It is easy and low cost to check for NULL pointer before + * calling strlen() + * + It can be helpfull to other people using those API + * + Passing a NULL value to those closest 'meaning' is empty string + * (specially with the new objects where 0 bytes strings are ok) + * So the following init is commented out: -- dl + * + * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, + * "", TCL_GLOBAL_ONLY); + * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, + * "NONE", TCL_GLOBAL_ONLY); */ - TclPlatformInit((Tcl_Interp *)iPtr); - Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL, - TCL_GLOBAL_ONLY); - Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION, - TCL_GLOBAL_ONLY); - Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - TclPrecTraceProc, (ClientData) NULL); +#ifndef TCL_GENERIC_ONLY + TclSetupEnv(interp); +#endif /* * Compute the byte order of this machine. */ order.s = 1; - Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder", - (order.c[0] == 1) ? "littleEndian" : "bigEndian", + Tcl_SetVar2(interp, "tcl_platform", "byteOrder", + ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), TCL_GLOBAL_ONLY); /* + * Set up other variables such as tcl_version and tcl_library + */ + + Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); + Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, (ClientData) NULL); + TclpSetVariables(interp); + + /* * Register Tcl's version number. */ - Tcl_PkgProvideEx((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION, - (ClientData) tclStubsPtr); + Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); - return (Tcl_Interp *) iPtr; +#ifdef Tcl_InitStubs +#undef Tcl_InitStubs +#endif + Tcl_InitStubs(interp, TCL_VERSION, 1); + + return interp; } /* @@ -562,13 +614,18 @@ Tcl_CallWhenDeleted(interp, proc, clientData) { Interp *iPtr = (Interp *) interp; static int assocDataCounter = 0; +#ifdef TCL_THREADS + static Tcl_Mutex assocMutex; +#endif int new; - char buffer[128]; + char buffer[32 + TCL_INTEGER_SPACE]; AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; + Tcl_MutexLock(&assocMutex); sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); assocDataCounter++; + Tcl_MutexUnlock(&assocMutex); if (iPtr->assocData == (Tcl_HashTable *) NULL) { iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); @@ -763,6 +820,82 @@ Tcl_GetAssocData(interp, name, procPtr) /* *---------------------------------------------------------------------- * + * Tcl_InterpDeleted -- + * + * Returns nonzero if the interpreter has been deleted with a call + * to Tcl_DeleteInterp. + * + * Results: + * Nonzero if the interpreter is deleted, zero otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InterpDeleted(interp) + Tcl_Interp *interp; +{ + return (((Interp *) interp)->flags & DELETED) ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteInterp -- + * + * Ensures that the interpreter will be deleted eventually. If there + * are no Tcl_Preserve calls in effect for this interpreter, it is + * deleted immediately, otherwise the interpreter is deleted when + * the last Tcl_Preserve is matched by a call to Tcl_Release. In either + * case, the procedure runs the currently registered deletion callbacks. + * + * Results: + * None. + * + * Side effects: + * The interpreter is marked as deleted. The caller may still use it + * safely if there are calls to Tcl_Preserve in effect for the + * interpreter, but further calls to Tcl_Eval etc in this interpreter + * will fail. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteInterp(interp) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ +{ + Interp *iPtr = (Interp *) interp; + + /* + * If the interpreter has already been marked deleted, just punt. + */ + + if (iPtr->flags & DELETED) { + return; + } + + /* + * Mark the interpreter as deleted. No further evals will be allowed. + */ + + iPtr->flags |= DELETED; + + /* + * Ensure that the interpreter is eventually deleted. + */ + + Tcl_EventuallyFree((ClientData) interp, + (Tcl_FreeProc *) DeleteInterpProc); +} + +/* + *---------------------------------------------------------------------- + * * DeleteInterpProc -- * * Helper procedure to delete an interpreter. This procedure is @@ -789,7 +922,6 @@ DeleteInterpProc(interp) Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *hTablePtr; - AssocData *dPtr; ResolverScheme *resPtr, *nextResPtr; int i; @@ -810,6 +942,8 @@ DeleteInterpProc(interp) panic("DeleteInterpProc called on interpreter not marked deleted"); } + TclHandleFree(iPtr->handle); + /* * Dismantle everything in the global namespace except for the * "errorInfo" and "errorCode" variables. These remain until the @@ -822,6 +956,27 @@ DeleteInterpProc(interp) TclTeardownNamespace(iPtr->globalNsPtr); /* + * Delete all the hidden commands. + */ + + hTablePtr = iPtr->hiddenCmdTablePtr; + if (hTablePtr != NULL) { + /* + * Non-pernicious deletion. The deletion callbacks will not be + * allowed to create any new hidden or non-hidden commands. + * Tcl_DeleteCommandFromToken() will remove the entry from the + * hiddenCmdTablePtr. + */ + + hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_DeleteCommandFromToken(interp, + (Tcl_Command) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree((char *) hTablePtr); + } + /* * Tear down the math function table. */ @@ -838,6 +993,8 @@ DeleteInterpProc(interp) */ while (iPtr->assocData != (Tcl_HashTable *) NULL) { + AssocData *dPtr; + hTablePtr = iPtr->assocData; iPtr->assocData = (Tcl_HashTable *) NULL; for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); @@ -911,187 +1068,17 @@ DeleteInterpProc(interp) resPtr = nextResPtr; } - ckfree((char *) iPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InterpDeleted -- - * - * Returns nonzero if the interpreter has been deleted with a call - * to Tcl_DeleteInterp. - * - * Results: - * Nonzero if the interpreter is deleted, zero otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_InterpDeleted(interp) - Tcl_Interp *interp; -{ - return (((Interp *) interp)->flags & DELETED) ? 1 : 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteInterp -- - * - * Ensures that the interpreter will be deleted eventually. If there - * are no Tcl_Preserve calls in effect for this interpreter, it is - * deleted immediately, otherwise the interpreter is deleted when - * the last Tcl_Preserve is matched by a call to Tcl_Release. In either - * case, the procedure runs the currently registered deletion callbacks. - * - * Results: - * None. - * - * Side effects: - * The interpreter is marked as deleted. The caller may still use it - * safely if there are calls to Tcl_Preserve in effect for the - * interpreter, but further calls to Tcl_Eval etc in this interpreter - * will fail. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteInterp(interp) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by a previous call to Tcl_CreateInterp). */ -{ - Interp *iPtr = (Interp *) interp; - - /* - * If the interpreter has already been marked deleted, just punt. - */ - - if (iPtr->flags & DELETED) { - return; - } - /* - * Mark the interpreter as deleted. No further evals will be allowed. + * Free up literal objects created for scripts compiled by the + * interpreter. */ - iPtr->flags |= DELETED; - - /* - * Ensure that the interpreter is eventually deleted. - */ - - Tcl_EventuallyFree((ClientData) interp, - (Tcl_FreeProc *) DeleteInterpProc); -} - -/* - *---------------------------------------------------------------------- - * - * HiddenCmdsDeleteProc -- - * - * Called on interpreter deletion to delete all the hidden - * commands in an interpreter. - * - * Results: - * None. - * - * Side effects: - * Frees up memory. - * - *---------------------------------------------------------------------- - */ - -static void -HiddenCmdsDeleteProc(clientData, interp) - ClientData clientData; /* The hidden commands hash table. */ - Tcl_Interp *interp; /* The interpreter being deleted. */ -{ - Tcl_HashTable *hiddenCmdTblPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - Command *cmdPtr; - - hiddenCmdTblPtr = (Tcl_HashTable *) clientData; - for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) { - - /* - * Cannot use Tcl_DeleteCommand because (a) the command is not - * in the command hash table, and (b) that table has already been - * deleted above. Hence we emulate what it does, below. - */ - - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - - /* - * The code here is tricky. We can't delete the hash table entry - * before invoking the deletion callback because there are cases - * where the deletion callback needs to invoke the command (e.g. - * object systems such as OTcl). However, this means that the - * callback could try to delete or rename the command. The deleted - * flag allows us to detect these cases and skip nested deletes. - */ - - if (cmdPtr->deleted) { - - /* - * Another deletion is already in progress. Remove the hash - * table entry now, but don't invoke a callback or free the - * command structure. - */ - - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = NULL; - continue; - } - cmdPtr->deleted = 1; - if (cmdPtr->deleteProc != NULL) { - (*cmdPtr->deleteProc)(cmdPtr->deleteData); - } - - /* - * Bump the command epoch counter. This will invalidate all cached - * references that refer to this command. - */ - - cmdPtr->cmdEpoch++; - - /* - * Don't use hPtr to delete the hash entry here, because it's - * possible that the deletion callback renamed the command. - * Instead, use cmdPtr->hptr, and make sure that no-one else - * has already deleted the hash entry. - */ - - if (cmdPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(cmdPtr->hPtr); - } - - /* - * Now free the Command structure, unless there is another reference - * to it from a CmdName Tcl object in some ByteCode code - * sequence. In that case, delay the cleanup until all references - * are either discarded (when a ByteCode is freed) or replaced by a - * new reference (when a cached CmdName Command reference is found - * to be invalid and TclExecuteByteCode looks up the command in the - * command hashtable). - */ - - TclCleanupCommand(cmdPtr); - } - Tcl_DeleteHashTable(hiddenCmdTblPtr); - ckfree((char *) hiddenCmdTblPtr); + TclDeleteLiteralTable(interp, &(iPtr->literalTable)); + ckfree((char *) iPtr); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_HideCommand -- * @@ -1099,14 +1086,14 @@ HiddenCmdsDeleteProc(clientData, interp) * an interpreter, only from within an ancestor. * * Results: - * A standard Tcl result; also leaves a message in interp->result + * A standard Tcl result; also leaves a message in the interp's result * if an error occurs. * * Side effects: * Removes a command from the command table and create an entry * into the hidden command table under the specified token name. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -1118,7 +1105,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) Interp *iPtr = (Interp *) interp; Tcl_Command cmd; Command *cmdPtr; - Tcl_HashTable *hTblPtr; + Tcl_HashTable *hiddenCmdTablePtr; Tcl_HashEntry *hPtr; int new; @@ -1189,14 +1176,12 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * Initialize the hidden command table if necessary. */ - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", - NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - hTblPtr = (Tcl_HashTable *) + hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; + if (hiddenCmdTablePtr == NULL) { + hiddenCmdTablePtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); - Tcl_SetAssocData(interp, "tclHiddenCmds", HiddenCmdsDeleteProc, - (ClientData) hTblPtr); + Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); + iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } /* @@ -1205,7 +1190,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * exists. */ - hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new); + hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new); if (!new) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "hidden command named \"", hiddenCmdToken, "\" already exists", @@ -1265,7 +1250,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * * Results: * A standard Tcl result. If an error occurs, a message is left - * in interp->result. + * in the interp's result. * * Side effects: * Moves commands from one hash table to another. @@ -1284,7 +1269,7 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) Command *cmdPtr; Namespace *nsPtr; Tcl_HashEntry *hPtr; - Tcl_HashTable *hTblPtr; + Tcl_HashTable *hiddenCmdTablePtr; int new; if (iPtr->flags & DELETED) { @@ -1311,24 +1296,14 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) } /* - * Find the hash table for the hidden commands; error out if there - * is none. - */ - - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", - NULL); - if (hTblPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown hidden command \"", hiddenCmdToken, - "\"", (char *) NULL); - return TCL_ERROR; - } - - /* * Get the command from the hidden command table: */ - hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken); + hPtr = NULL; + hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; + if (hiddenCmdTablePtr != NULL) { + hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); + } if (hPtr == (Tcl_HashEntry *) NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown hidden command \"", hiddenCmdToken, @@ -1508,7 +1483,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) * could get stuck in an infinite loop). */ - ckfree((char*) cmdPtr); + ckfree((char*) Tcl_GetHashValue(hPtr)); } } cmdPtr = (Command *) ckalloc(sizeof(Command)); @@ -1562,7 +1537,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) * * Results: * The return value is a token for the command, which can - * be used in future calls to Tcl_NameOfCommand. + * be used in future calls to Tcl_GetCommandName. * * Side effects: * If no command named "cmdName" already exists for interp, one is @@ -1760,7 +1735,6 @@ TclInvokeStringCommand(clientData, interp, objc, objv) * Create the string argument array "argv". Make sure argv is large * enough to hold the objc arguments plus 1 extra for the zero * end-of-argv word. - * THIS FAILS IF ANY ARGUMENT OBJECT CONTAINS AN EMBEDDED NULL. */ if ((objc + 1) > NUM_ARGS) { @@ -1768,7 +1742,7 @@ TclInvokeStringCommand(clientData, interp, objc, objv) } for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetStringFromObj(objv[i], (int *) NULL); + argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; @@ -1861,11 +1835,9 @@ TclInvokeObjectCommand(clientData, interp, argc, argv) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULL BYTES. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); /* @@ -2436,83 +2408,92 @@ TclCleanupCommand(cmdPtr) /* *---------------------------------------------------------------------- * - * Tcl_Eval -- + * Tcl_CreateMathFunc -- * - * Execute a Tcl command in a string. + * Creates a new math function for expressions in a given + * interpreter. * * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and interp->result contains a string value - * to supplement the return code. The value of interp->result - * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: - * you must copy it or lose it! + * None. * * Side effects: - * The string is compiled to produce a ByteCode object that holds the - * command's bytecode instructions. However, this ByteCode object is - * lost after executing the command. The command's execution will - * almost certainly have side effects. interp->termOffset is set to the - * offset of the character in "string" just after the last one - * successfully compiled or executed. + * The function defined by "name" is created or redefined. If the + * function already exists then its definition is replaced; this + * includes the builtin functions. Redefining a builtin function forces + * all existing code to be invalidated since that code may be compiled + * using an instruction specific to the replaced function. In addition, + * redefioning a non-builtin function will force existing code to be + * invalidated if the number of arguments has changed. * *---------------------------------------------------------------------- */ -int -Tcl_Eval(interp, string) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by previous call to Tcl_CreateInterp). */ - char *string; /* Pointer to TCL command to execute. */ +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"). */ + int numArgs; /* Nnumber of arguments required by + * function. */ + Tcl_ValueType *argTypes; /* Array of types acceptable for + * each argument. */ + Tcl_MathProc *proc; /* Procedure that implements the + * math function. */ + ClientData clientData; /* Additional value to pass to the + * function. */ { - register Tcl_Obj *cmdPtr; - int length = strlen(string); - int result; - - if (length > 0) { - /* - * Initialize a Tcl object from the command string. - */ - - TclNewObj(cmdPtr); - TclInitStringRep(cmdPtr, string, length); - Tcl_IncrRefCount(cmdPtr); - - /* - * Compile and execute the bytecodes. - */ - - result = Tcl_EvalObj(interp, cmdPtr); + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; + int new, i; - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ + hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); + if (new) { + Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); + if (!new) { + if (mathFuncPtr->builtinFuncIndex >= 0) { + /* + * We are redefining a builtin math function. Invalidate the + * interpreter's existing code by incrementing its + * compileEpoch member. This field is checked in Tcl_EvalObj + * and ObjInterpProc, and code whose compilation epoch doesn't + * match is recompiled. Newly compiled code will no longer + * treat the function as builtin. + */ - /* - * Discard the Tcl object created to hold the command and its code. - */ - - Tcl_DecrRefCount(cmdPtr); - } else { - /* - * An empty string. Just reset the interpreter's result. - */ + iPtr->compileEpoch++; + } else { + /* + * A non-builtin function is being redefined. We must invalidate + * existing code if the number of arguments has changed. This + * is because existing code was compiled assuming that number. + */ - Tcl_ResetResult(interp); - result = TCL_OK; + if (numArgs != mathFuncPtr->numArgs) { + iPtr->compileEpoch++; + } + } } - return result; + + mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ + if (numArgs > MAX_MATH_ARGS) { + numArgs = MAX_MATH_ARGS; + } + mathFuncPtr->numArgs = numArgs; + for (i = 0; i < numArgs; i++) { + mathFuncPtr->argTypes[i] = argTypes[i]; + } + mathFuncPtr->proc = proc; + mathFuncPtr->clientData = clientData; } /* *---------------------------------------------------------------------- * - * Tcl_EvalObj -- + * Tcl_EvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are * compiled into bytecodes if necessary. @@ -2534,27 +2515,59 @@ Tcl_Eval(interp, string) *---------------------------------------------------------------------- */ -#undef Tcl_EvalObj - int -Tcl_EvalObj(interp, objPtr) +Tcl_EvalObjEx(interp, objPtr, flags) Tcl_Interp *interp; /* Token for command interpreter * (returned by a previous call to * Tcl_CreateInterp). */ - Tcl_Obj *objPtr; /* Pointer to object containing + register Tcl_Obj *objPtr; /* Pointer to object containing * commands to execute. */ + int flags; /* Collection of OR-ed bits that + * control the evaluation of the + * script. Supported values are + * TCL_EVAL_GLOBAL and + * TCL_EVAL_DIRECT. */ { register Interp *iPtr = (Interp *) interp; - int flags; /* Interp->evalFlags value when the + int evalFlags; /* Interp->evalFlags value when the * procedure was called. */ register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ int oldCount = iPtr->cmdCount; /* Used to tell whether any commands * at all were executed. */ - int numSrcChars; - register int result; + int numSrcBytes; + int result; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ Namespace *namespacePtr; /* + * Prevent the object from being deleted as a side effect of evaling it. + */ + + Tcl_IncrRefCount(objPtr); + + if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) { + /* + * We're not supposed to use the compiler or byte-code interpreter. + * Let Tcl_EvalEx evaluate the command directly (and probably + * more slowly). + */ + + char *p; + int length; + + p = Tcl_GetStringFromObj(objPtr, &length); + result = Tcl_EvalEx(interp, p, length, flags); + Tcl_DecrRefCount(objPtr); + return result; + } + + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; + } + + /* * Reset both the interpreter's string and object results and clear out * any error information. This makes sure that we return an empty * result if there are no commands in the command string. @@ -2571,21 +2584,23 @@ Tcl_EvalObj(interp, objPtr) if (iPtr->numLevels > iPtr->maxNestingDepth) { iPtr->numLevels--; Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); - return TCL_ERROR; + "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); + result = TCL_ERROR; + goto done; } /* - * On the Mac, we will never reach the default recursion limit before blowing - * the stack. So we need to do a check here. + * On the Mac, we will never reach the default recursion limit before + * blowing the stack. So we need to do a check here. */ if (TclpCheckStackSpace() == 0) { /*NOTREACHED*/ iPtr->numLevels--; Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); - return TCL_ERROR; + "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); + result = TCL_ERROR; + goto done; } /* @@ -2597,9 +2612,10 @@ Tcl_EvalObj(interp, objPtr) Tcl_AppendToObj(Tcl_GetObjResult(interp), "attempt to call eval in deleted interpreter", -1); Tcl_SetErrorCode(interp, "CORE", "IDELETE", - "attempt to call eval in deleted interpreter", (char *) NULL); - iPtr->numLevels--; - return TCL_ERROR; + "attempt to call eval in deleted interpreter", + (char *) NULL); + result = TCL_ERROR; + goto done; } /* @@ -2624,12 +2640,12 @@ Tcl_EvalObj(interp, objPtr) if (objPtr->typePtr == &tclByteCodeType) { codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if ((codePtr->iPtr != iPtr) + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if (codePtr->iPtr != iPtr) { + if ((Interp *) *codePtr->interpHandle != iPtr) { panic("Tcl_EvalObj: compiled script jumped interps"); } codePtr->compileEpoch = iPtr->compileEpoch; @@ -2639,15 +2655,22 @@ Tcl_EvalObj(interp, objPtr) } } if (objPtr->typePtr != &tclByteCodeType) { - /* - * First reset any error line number information. - */ - - iPtr->errorLine = 1; /* no correct line # information yet */ + iPtr->errorLine = 1; result = tclByteCodeType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { - iPtr->numLevels--; - return result; + goto done; + } + } else { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch)) { + (*tclByteCodeType.freeIntRepProc)(objPtr); + iPtr->errorLine = 1; + result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr); + if (result != TCL_OK) { + iPtr->numLevels--; + return result; + } } } codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; @@ -2657,7 +2680,7 @@ Tcl_EvalObj(interp, objPtr) * Resetting the flags must be done after any compilation. */ - flags = iPtr->evalFlags; + evalFlags = iPtr->evalFlags; iPtr->evalFlags = 0; /* @@ -2665,8 +2688,8 @@ Tcl_EvalObj(interp, objPtr) * don't bother executing the code. */ - numSrcChars = codePtr->numSrcChars; - if ((numSrcChars > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + numSrcBytes = codePtr->numSrcBytes; + if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. @@ -2679,7 +2702,6 @@ Tcl_EvalObj(interp, objPtr) TclCleanupByteCode(codePtr); } } else { - Tcl_ResetResult(interp); result = TCL_OK; } @@ -2690,33 +2712,23 @@ Tcl_EvalObj(interp, objPtr) * empty bodies. */ - if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) { + if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) { result = Tcl_AsyncInvoke(interp, result); } /* - * Free up any extra resources that were allocated. + * Update the interpreter's evaluation level count. If we are again at + * the top level, process any unusual return code returned by the + * evaluated code. */ - iPtr->numLevels--; - if (iPtr->numLevels == 0) { + if (iPtr->numLevels == 1) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } if ((result != TCL_OK) && (result != TCL_ERROR) - && !(flags & TCL_ALLOW_EXCEPTIONS)) { - Tcl_ResetResult(interp); - if (result == TCL_BREAK) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"break\" outside of a loop", -1); - } else if (result == TCL_CONTINUE) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"continue\" outside of a loop", -1); - } else { - char buf[50]; - sprintf(buf, "command returned bad code: %d", result); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - } + && ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) { + ProcessUnexpectedResult(interp, result); result = TCL_ERROR; } } @@ -2727,33 +2739,7 @@ Tcl_EvalObj(interp, objPtr) */ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - char buf[200]; - char *ellipsis = ""; - char *bytes; - int length; - - /* - * Figure out how much of the command to print in the error - * message (up to a certain number of characters, or up to - * the first new-line). - * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL. - */ - - bytes = Tcl_GetStringFromObj(objPtr, &length); - length = TclMin(numSrcChars, length); - if (length > 150) { - length = 150; - ellipsis = " ..."; - } - - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - sprintf(buf, "\n while executing\n\"%.*s%s\"", - length, bytes, ellipsis); - } else { - sprintf(buf, "\n invoked from within\n\"%.*s%s\"", - length, bytes, ellipsis); - } - Tcl_AddObjErrorInfo(interp, buf, -1); + RecordTracebackInfo(interp, objPtr, numSrcBytes); } /* @@ -2763,13 +2749,114 @@ Tcl_EvalObj(interp, objPtr) * compiled. */ - iPtr->termOffset = numSrcChars; + iPtr->termOffset = numSrcBytes; iPtr->flags &= ~ERR_ALREADY_LOGGED; + + done: + TclDecrRefCount(objPtr); + iPtr->varFramePtr = savedVarFramePtr; + iPtr->numLevels--; return result; } /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- + * + * ProcessUnexpectedResult -- + * + * Procedure called by Tcl_EvalObj to set the interpreter's result + * value to an appropriate error message when the code it evaluates + * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to + * the topmost evaluation level. + * + * Results: + * None. + * + * Side effects: + * The interpreter result is set to an error message appropriate to + * the result code. + * + *---------------------------------------------------------------------- + */ + +static void +ProcessUnexpectedResult(interp, returnCode) + Tcl_Interp *interp; /* The interpreter in which the unexpected + * result code was returned. */ + int returnCode; /* The unexpected result code. */ +{ + Tcl_ResetResult(interp); + if (returnCode == TCL_BREAK) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"break\" outside of a loop", -1); + } else if (returnCode == TCL_CONTINUE) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"continue\" outside of a loop", -1); + } else { + char buf[30 + TCL_INTEGER_SPACE]; + + sprintf(buf, "command returned bad code: %d", returnCode); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } +} + +/* + *---------------------------------------------------------------------- + * + * RecordTracebackInfo -- + * + * Procedure called by Tcl_EvalObj to record information about what was + * being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Appends information about the script being evaluated to the + * interpreter's "errorInfo" variable. + * + *---------------------------------------------------------------------- + */ + +static void +RecordTracebackInfo(interp, objPtr, numSrcBytes) + Tcl_Interp *interp; /* The interpreter in which the error + * occurred. */ + Tcl_Obj *objPtr; /* Points to object containing script whose + * evaluation resulted in an error. */ + int numSrcBytes; /* Number of bytes compiled in script. */ +{ + Interp *iPtr = (Interp *) interp; + char buf[200]; + char *ellipsis, *bytes; + int length; + + /* + * Decide how much of the command to print in the error message + * (up to a certain number of bytes). + */ + + bytes = Tcl_GetStringFromObj(objPtr, &length); + length = TclMin(numSrcBytes, length); + + ellipsis = ""; + if (length > 150) { + length = 150; + ellipsis = " ..."; + } + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(buf, "\n while executing\n\"%.*s%s\"", + length, bytes, ellipsis); + } else { + sprintf(buf, "\n invoked from within\n\"%.*s%s\"", + length, bytes, ellipsis); + } + Tcl_AddObjErrorInfo(interp, buf, -1); +} + +/* + *--------------------------------------------------------------------------- * * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- * @@ -2778,15 +2865,15 @@ Tcl_EvalObj(interp, objPtr) * * Results: * Each of the procedures below returns a standard Tcl result. If an - * error occurs then an error message is left in interp->result. - * Otherwise the value of the expression, in the appropriate form, is - * stored at *ptr. If the expression had a result that was + * error occurs then an error message is left in the interp's result. + * Otherwise the value of the expression, in the appropriate form, + * is stored at *ptr. If the expression had a result that was * incompatible with the desired form then an error is returned. * * Side effects: * None. * - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -2824,12 +2911,9 @@ Tcl_ExprLong(interp, string, ptr) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -2878,12 +2962,9 @@ Tcl_ExprDouble(interp, string, ptr) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -2931,12 +3012,9 @@ Tcl_ExprBoolean(interp, string, ptr) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -3044,9 +3122,6 @@ Tcl_ExprBooleanObj(interp, objPtr, ptr) *ptr = (resultPtr->internalRep.doubleValue != 0.0); } else { result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); - if (result != TCL_OK) { - return result; - } } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } @@ -3123,11 +3198,9 @@ TclInvoke(interp, argc, argv, flags) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); /* @@ -3215,15 +3288,15 @@ TclGlobalInvoke(interp, argc, argv, flags) int TclObjInvokeGlobal(interp, objc, objv, flags) - Tcl_Interp *interp; /* Interpreter in which command is - * to be invoked. */ + Tcl_Interp *interp; /* Interpreter in which command is to be + * invoked. */ int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] - * points to the name of the - * command to invoke. */ - int flags; /* Combination of flags controlling - * the call: TCL_INVOKE_HIDDEN and - * TCL_INVOKE_NO_UNKNOWN. */ + Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the + * name of the command to invoke. */ + int flags; /* Combination of flags controlling the + * call: TCL_INVOKE_HIDDEN, + * TCL_INVOKE_NO_UNKNOWN, or + * TCL_INVOKE_NO_TRACEBACK. */ { register Interp *iPtr = (Interp *) interp; int result; @@ -3255,15 +3328,15 @@ TclObjInvokeGlobal(interp, objc, objv, flags) int TclObjInvoke(interp, objc, objv, flags) - Tcl_Interp *interp; /* Interpreter in which command is - * to be invoked. */ + Tcl_Interp *interp; /* Interpreter in which command is to be + * invoked. */ int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] - * points to the name of the - * command to invoke. */ - int flags; /* Combination of flags controlling - * the call: TCL_INVOKE_HIDDEN and - * TCL_INVOKE_NO_UNKNOWN. */ + Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the + * name of the command to invoke. */ + int flags; /* Combination of flags controlling the + * call: TCL_INVOKE_HIDDEN, + * TCL_INVOKE_NO_UNKNOWN, or + * TCL_INVOKE_NO_TRACEBACK. */ { register Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ @@ -3287,35 +3360,24 @@ TclObjInvoke(interp, objc, objv, flags) return TCL_ERROR; } - /* - * THE FOLLOWING CODE FAILS IF THE STRING REP CONTAINS NULLS. - */ - - cmdName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + cmdName = Tcl_GetString(objv[0]); if (flags & TCL_INVOKE_HIDDEN) { /* - * Find the table of hidden commands; error out if none. + * We never invoke "unknown" for hidden commands. */ - - hTblPtr = (Tcl_HashTable *) - Tcl_GetAssocData(interp, "tclHiddenCmds", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - badhiddenCmdToken: + + hPtr = NULL; + hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr; + if (hTblPtr != NULL) { + hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); + } + if (hPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid hidden command name \"", cmdName, "\"", (char *) NULL); return TCL_ERROR; } - hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); - - /* - * We never invoke "unknown" for hidden commands. - */ - - if (hPtr == NULL) { - goto badhiddenCmdToken; - } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); } else { cmdPtr = NULL; @@ -3376,7 +3438,9 @@ TclObjInvoke(interp, objc, objv, flags) * executed when the error occurred. */ - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + if ((result == TCL_ERROR) + && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) + && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { Tcl_DString ds; Tcl_DStringInit(&ds); @@ -3408,13 +3472,14 @@ TclObjInvoke(interp, objc, objv, flags) */ if (localObjv != (Tcl_Obj **) NULL) { + Tcl_DecrRefCount(localObjv[0]); ckfree((char *) localObjv); } return result; } /* - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_ExprString -- * @@ -3422,17 +3487,16 @@ TclObjInvoke(interp, objc, objv, flags) * form. * * Results: - * A standard Tcl result. If the result is TCL_OK, then the - * interpreter's result is set to the string value of the - * expression. If the result is TCL_OK, then interp->result - * contains an error message. + * A standard Tcl result. If the result is TCL_OK, then the interp's + * result is set to the string value of the expression. If the result + * is TCL_ERROR, then the interp's result contains an error message. * * Side effects: * A Tcl object is allocated to hold a copy of the expression string. * This expression object is passed to Tcl_ExprObj and then * deallocated. * - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -3444,7 +3508,7 @@ Tcl_ExprString(interp, string) register Tcl_Obj *exprPtr; Tcl_Obj *resultPtr; int length = strlen(string); - char buf[100]; + char buf[TCL_DOUBLE_SPACE]; int result = TCL_OK; if (length > 0) { @@ -3468,24 +3532,19 @@ Tcl_ExprString(interp, string) } else { /* * Set interpreter's string result from the result object. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(resultPtr, (int *) NULL), - TCL_VOLATILE); + Tcl_SetResult(interp, TclGetString(resultPtr), + TCL_VOLATILE); } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } else { /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -3535,15 +3594,42 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure * allocated in frame. */ + LiteralTable *localTablePtr = &(compEnv.localLitTable); register ByteCode *codePtr = NULL; /* Tcl Internal type of bytecode. * Initialized to avoid compiler warning. */ AuxData *auxDataPtr; - Interp dummy; + LiteralEntry *entryPtr; Tcl_Obj *saveObjPtr; char *string; - int result; - int i; + int length, i, result; + + /* + * First handle some common expressions specially. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + if (length == 1) { + if (*string == '0') { + *resultPtrPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } else if (*string == '1') { + *resultPtrPtr = Tcl_NewLongObj(1); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } + } else if ((length == 2) && (*string == '!')) { + if (*(string+1) == '0') { + *resultPtrPtr = Tcl_NewLongObj(1); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } else if (*(string+1) == '1') { + *resultPtrPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } + } /* * Get the ByteCode from the object. If it exists, make sure it hasn't @@ -3556,72 +3642,53 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) * Precompiled expressions, however, are immutable and therefore * they are not recompiled, even if the epoch has changed. * - * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE. */ if (objPtr->typePtr == &tclByteCodeType) { codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if ((codePtr->iPtr != iPtr) + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if (codePtr->iPtr != iPtr) { + if ((Interp *) *codePtr->interpHandle != iPtr) { panic("Tcl_ExprObj: compiled expression jumped interps"); } codePtr->compileEpoch = iPtr->compileEpoch; } else { - tclByteCodeType.freeIntRepProc(objPtr); + (*tclByteCodeType.freeIntRepProc)(objPtr); objPtr->typePtr = (Tcl_ObjType *) NULL; } } } if (objPtr->typePtr != &tclByteCodeType) { - int length; - string = Tcl_GetStringFromObj(objPtr, &length); - TclInitCompileEnv(interp, &compEnv, string); - result = TclCompileExpr(interp, string, string + length, - /*flags*/ 0, &compEnv); - if (result == TCL_OK) { - /* - * If the expression yielded no instructions (e.g., was empty), - * push an integer zero object as the expressions's result. - */ - - if (compEnv.codeNext == NULL) { - int objIndex = TclObjIndexForString("0", 0, - /*allocStrRep*/ 0, /*inHeap*/ 0, &compEnv); - Tcl_Obj *objPtr = compEnv.objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, &compEnv); - } - - /* - * Add done instruction at the end of the instruction sequence. - */ - - TclEmitOpcode(INST_DONE, &compEnv); - - TclInitByteCodeObj(objPtr, &compEnv); - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if (tclTraceCompile == 2) { - TclPrintByteCodeObj(interp, objPtr); - } - TclFreeCompileEnv(&compEnv); - } else { + TclInitCompileEnv(interp, &compEnv, string, length); + result = TclCompileExpr(interp, string, length, &compEnv); + + /* + * Free the compilation environment's literal table bucket array if + * it was dynamically allocated. + */ + + if (localTablePtr->buckets != localTablePtr->staticBuckets) { + ckfree((char *) localTablePtr->buckets); + } + + if (result != TCL_OK) { /* - * Compilation errors. Decrement the ref counts on any objects - * in the object array before freeing the compilation - * environment. + * Compilation errors. Free storage allocated for compilation. */ - - for (i = 0; i < compEnv.objArrayNext; i++) { - Tcl_Obj *elemPtr = compEnv.objArrayPtr[i]; - Tcl_DecrRefCount(elemPtr); - } +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(&compEnv); +#endif /*TCL_COMPILE_DEBUG*/ + entryPtr = compEnv.literalArrayPtr; + for (i = 0; i < compEnv.literalArrayNext; i++) { + TclReleaseLiteral(interp, entryPtr->objPtr); + entryPtr++; + } +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(iPtr); +#endif /*TCL_COMPILE_DEBUG*/ + auxDataPtr = compEnv.auxDataArrayPtr; for (i = 0; i < compEnv.auxDataArrayNext; i++) { if (auxDataPtr->type->freeProc != NULL) { @@ -3632,28 +3699,43 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) TclFreeCompileEnv(&compEnv); return result; } + + /* + * Successful compilation. If the expression yielded no + * instructions, push an zero object as the expression's result. + */ + + if (compEnv.codeNext == compEnv.codeStart) { + TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0), + &compEnv); + } + + /* + * Add a "done" instruction as the last instruction and change the + * object into a ByteCode object. Ownership of the literal objects + * and aux data items is given to the ByteCode object. + */ + + compEnv.numSrcBytes = iPtr->termOffset; + TclEmitOpcode(INST_DONE, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + TclFreeCompileEnv(&compEnv); + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile == 2) { + TclPrintByteCodeObj(interp, objPtr); + } +#endif /* TCL_COMPILE_DEBUG */ } /* * Execute the expression after first saving the interpreter's result. */ - dummy.objResultPtr = Tcl_NewObj(); - Tcl_IncrRefCount(dummy.objResultPtr); - if (interp->freeProc == 0) { - dummy.freeProc = (Tcl_FreeProc *) 0; - dummy.result = ""; - Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, - TCL_VOLATILE); - } else { - dummy.freeProc = interp->freeProc; - dummy.result = interp->result; - interp->freeProc = (Tcl_FreeProc *) 0; - } - saveObjPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(saveObjPtr); - + Tcl_ResetResult(interp); + /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. @@ -3664,6 +3746,8 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; } /* @@ -3679,17 +3763,9 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) *resultPtrPtr = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->objResultPtr); - Tcl_SetResult(interp, dummy.result, - ((dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc)); - Tcl_DecrRefCount(iPtr->objResultPtr); - iPtr->objResultPtr = saveObjPtr; - } else { - Tcl_DecrRefCount(saveObjPtr); - Tcl_FreeResult((Tcl_Interp *) &dummy); + Tcl_SetObjResult(interp, saveObjPtr); } - - Tcl_DecrRefCount(dummy.objResultPtr); - dummy.objResultPtr = NULL; + Tcl_DecrRefCount(saveObjPtr); return result; } @@ -3844,7 +3920,7 @@ void Tcl_AddErrorInfo(interp, message) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ - char *message; /* Message to record. */ + CONST char *message; /* Message to record. */ { Tcl_AddObjErrorInfo(interp, message, -1); } @@ -3876,29 +3952,26 @@ void Tcl_AddObjErrorInfo(interp, message, length) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ - char *message; /* Points to the first byte of an array of + CONST char *message; /* Points to the first byte of an array of * bytes of the message. */ - register int length; /* The number of bytes in the message. + int length; /* The number of bytes in the message. * If < 0, then append all bytes up to a * NULL byte. */ { register Interp *iPtr = (Interp *) interp; - Tcl_Obj *namePtr, *messagePtr; + Tcl_Obj *messagePtr; /* * If we are just starting to log an error, errorInfo is initialized * from the error message in the interpreter's result. */ - namePtr = Tcl_NewStringObj("errorInfo", -1); - Tcl_IncrRefCount(namePtr); - if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ iPtr->flags |= ERR_IN_PROGRESS; if (iPtr->result[0] == 0) { - (void) Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, - iPtr->objResultPtr, TCL_GLOBAL_ONLY); + (void) Tcl_SetVar2Ex(interp, "errorInfo", NULL, iPtr->objResultPtr, + TCL_GLOBAL_ONLY); } else { /* use the string result */ Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, TCL_GLOBAL_ONLY); @@ -3922,16 +3995,14 @@ Tcl_AddObjErrorInfo(interp, message, length) if (length != 0) { messagePtr = Tcl_NewStringObj(message, length); Tcl_IncrRefCount(messagePtr); - Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr, + Tcl_SetVar2Ex(interp, "errorInfo", NULL, messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ } - - Tcl_DecrRefCount(namePtr); /* free the name object */ } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_VarEvalVA -- * @@ -3939,13 +4010,13 @@ Tcl_AddObjErrorInfo(interp, message, length) * all together and execute the result as a Tcl command. * * Results: - * A standard Tcl return result. An error message or other - * result may be left in interp->result. + * A standard Tcl return result. An error message or other result may + * be left in the interp's result. * * Side effects: * Depends on what was done by the command. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -4011,14 +4082,14 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_GlobalEval -- * * Evaluate a command at global level in an interpreter. * * Results: - * A standard Tcl result is returned, and interp->result is + * A standard Tcl result is returned, and the interp's result is * modified accordingly. * * Side effects: @@ -4027,7 +4098,7 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) * procedures active), just as if an "uplevel #0" command were * being executed. * - *---------------------------------------------------------------------- + --------------------------------------------------------------------------- */ int @@ -4049,51 +4120,6 @@ Tcl_GlobalEval(interp, command) /* *---------------------------------------------------------------------- * - * Tcl_GlobalEvalObj -- - * - * Execute Tcl commands stored in a Tcl object at global level in - * an interpreter. These commands are compiled into bytecodes if - * necessary. - * - * Results: - * A standard Tcl result is returned, and the interpreter's result - * contains a Tcl object value to supplement the return code. - * - * Side effects: - * The object is converted, if necessary, to a ByteCode object that - * holds the bytecode instructions for the commands. Executing the - * commands will almost certainly have side effects that depend on - * those commands. - * - * The commands are executed in interp, and the execution - * is carried out in the variable context of global level (no - * procedures active), just as if an "uplevel #0" command were - * being executed. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GlobalEvalObj(interp, objPtr) - Tcl_Interp *interp; /* Interpreter in which to evaluate - * commands. */ - Tcl_Obj *objPtr; /* Pointer to object containing commands - * to execute. */ -{ - register Interp *iPtr = (Interp *) interp; - int result; - CallFrame *savedVarFramePtr; - - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = NULL; - result = Tcl_EvalObj(interp, objPtr); - iPtr->varFramePtr = savedVarFramePtr; - return result; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SetRecursionLimit -- * * Set the maximum number of recursive calls that may be active diff --git a/generic/tclBinary.c b/generic/tclBinary.c index e6d5d31..5156465 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -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: tclBinary.c,v 1.4 1999/03/10 05:52:46 stanton Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.5 1999/04/16 00:46:42 stanton Exp $ */ #include @@ -36,17 +36,35 @@ static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, char *cmdPtr, int *countPtr)); -static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, - int type)); +static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, int type)); static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr)); + /* - * The following object type represents an array of bytes. This type should - * be used to represent arbitrary binary data instead of a string object - * because although they are equivalent at the moment they will not be in - * future versions which support unicode. + * The following object type represents an array of bytes. An array of + * bytes is not equivalent to an internationalized string. Conceptually, a + * string is an array of 16-bit quantities organized as a sequence of properly + * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities. + * Accessor functions are provided to convert a ByteArray to a String or a + * String to a ByteArray. Two or more consecutive bytes in an array of bytes + * may look like a single UTF-8 character if the array is casually treated as + * a string. But obtaining the String from a ByteArray is guaranteed to + * produced properly formed UTF-8 sequences so that there is a one-to-one + * map between bytes and characters. + * + * Converting a ByteArray to a String proceeds by casting each byte in the + * array to a 16-bit quantity, treating that number as a Unicode character, + * and storing the UTF-8 version of that Unicode character in the String. + * For ByteArrays consisting entirely of values 1..127, the corresponding + * String representation is the same as the ByteArray representation. + * + * Converting a String to a ByteArray proceeds by getting the Unicode + * representation of each character in the String, casting it to a + * byte by truncating the upper 8 bits, and then storing the byte in the + * ByteArray. Converting from ByteArray to String and back to ByteArray + * is not lossy, but converting an arbitrary String to a ByteArray may be. */ Tcl_ObjType tclByteArrayType = { @@ -87,12 +105,8 @@ typedef struct ByteArray { * * Tcl_NewByteArrayObj -- * - * This procedure is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new ByteArray object and - * initializes it from the given array of bytes. - * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewByteArrayObj. + * This procedure is creates a new ByteArray object and initializes + * it from the given array of bytes. * * Results: * The newly create object is returned. This object will have no @@ -108,6 +122,7 @@ typedef struct ByteArray { #ifdef TCL_MEM_DEBUG #undef Tcl_NewByteArrayObj + Tcl_Obj * Tcl_NewByteArrayObj(bytes, length) unsigned char *bytes; /* The array of bytes used to initialize @@ -197,7 +212,7 @@ Tcl_DbNewByteArrayObj(bytes, length, file, line) return Tcl_NewByteArrayObj(bytes, length); } #endif /* TCL_MEM_DEBUG */ - + /* *--------------------------------------------------------------------------- * @@ -355,17 +370,23 @@ SetByteArrayFromAny(interp, objPtr) { Tcl_ObjType *typePtr; int length; - char *src; + char *src, *srcEnd; + unsigned char *dst; ByteArray *byteArrayPtr; + Tcl_UniChar ch; typePtr = objPtr->typePtr; if (typePtr != &tclByteArrayType) { src = Tcl_GetStringFromObj(objPtr, &length); + srcEnd = src + length; byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); - memcpy((VOID *) byteArrayPtr->bytes, (VOID *) src, (size_t) length); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + src += Tcl_UtfToUniChar(src, &ch); + *dst++ = (unsigned char) ch; + } - byteArrayPtr->used = length; + byteArrayPtr->used = dst - byteArrayPtr->bytes; byteArrayPtr->allocated = length; if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) { @@ -465,7 +486,7 @@ UpdateStringOfByteArray(objPtr) Tcl_Obj *objPtr; /* ByteArray object whose string rep to * update. */ { - int length; + int i, length, size; unsigned char *src; char *dst; ByteArray *byteArrayPtr; @@ -475,15 +496,29 @@ UpdateStringOfByteArray(objPtr) length = byteArrayPtr->used; /* - * The byte array is the string representation. + * How much space will string rep need? */ - - dst = (char *) ckalloc((unsigned) (length + 1)); + + size = length; + for (i = 0; i < length; i++) { + if ((src[i] == 0) || (src[i] > 127)) { + size++; + } + } + + dst = (char *) ckalloc((unsigned) (size + 1)); objPtr->bytes = dst; - objPtr->length = length; + objPtr->length = size; - memcpy((VOID *) dst, (VOID *) src, (size_t) length); - dst[length] = '\0'; + if (size == length) { + memcpy((VOID *) dst, (VOID *) src, (size_t) size); + dst[size] = '\0'; + } else { + for (i = 0; i < length; i++) { + dst += Tcl_UniCharToUtf(src[i], dst); + } + *dst = '\0'; + } } /* @@ -523,37 +558,43 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) unsigned char *maxPos; /* Greatest position within result buffer that * cursor has visited.*/ char *errorString, *errorValue, *str; - int offset, size, length; - - static char *subCmds[] = { "format", "scan", (char *) NULL }; - enum { BinaryFormat, BinaryScan } index; + int offset, size, length, index; + static char *options[] = { + "format", "scan", NULL + }; + enum options { + BINARY_FORMAT, BINARY_SCAN + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, - (int *) &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { - case BinaryFormat: + switch ((enum options) index) { + case BINARY_FORMAT: { if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); return TCL_ERROR; } + /* * To avoid copying the data, we format the string in two passes. * The first pass computes the size of the output buffer. The * second pass places the formatted data into the buffer. */ - format = Tcl_GetStringFromObj(objv[2], NULL); + format = Tcl_GetString(objv[2]); arg = 3; - offset = length = 0; - while (*format != 0) { + offset = 0; + length = 0; + while (*format != '\0') { + str = format; if (!GetFormatSpec(&format, &cmd, &count)) { break; } @@ -563,10 +604,10 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) case 'b': case 'B': case 'h': - case 'H': + case 'H': { /* * For string-type specifiers, the count corresponds - * to the number of characters in a single argument. + * to the number of bytes in a single argument. */ if (arg >= objc) { @@ -586,24 +627,29 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset += (count + 1) / 2; } break; - - case 'c': + } + case 'c': { size = 1; goto doNumbers; + } case 's': - case 'S': + case 'S': { size = 2; goto doNumbers; + } case 'i': - case 'I': + case 'I': { size = 4; goto doNumbers; - case 'f': + } + case 'f': { size = sizeof(float); goto doNumbers; - case 'd': + } + case 'd': { size = sizeof(double); - doNumbers: + + doNumbers: if (arg >= objc) { goto badIndex; } @@ -628,23 +674,28 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) if (count == BINARY_ALL) { count = listc; } else if (count > listc) { - errorString = "number of elements in list does not match count"; - goto error; + Tcl_AppendResult(interp, + "number of elements in list does not match count", + (char *) NULL); + return TCL_ERROR; } } offset += count*size; break; - - case 'x': + } + case 'x': { if (count == BINARY_ALL) { - errorString = "cannot use \"*\" in format string with \"x\""; - goto error; + Tcl_AppendResult(interp, + "cannot use \"*\" in format string with \"x\"", + (char *) NULL); + return TCL_ERROR; } else if (count == BINARY_NOCOUNT) { count = 1; } offset += count; break; - case 'X': + } + case 'X': { if (count == BINARY_NOCOUNT) { count = 1; } @@ -656,7 +707,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } offset -= count; break; - case '@': + } + case '@': { if (offset > length) { length = offset; } @@ -668,15 +720,10 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset = count; } break; + } default: { - char buf[2]; - - Tcl_ResetResult(interp); - buf[0] = cmd; - buf[1] = '\0'; - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad field specifier \"", buf, "\"", NULL); - return TCL_ERROR; + errorString = str; + goto badfield; } } } @@ -694,7 +741,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) resultPtr = Tcl_GetObjResult(interp); buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset(buffer, 0, (size_t) length); + memset((VOID *) buffer, 0, (size_t) length); /* * Pack the data into the result object. Note that we can skip @@ -703,7 +750,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) */ arg = 3; - format = Tcl_GetStringFromObj(objv[2], NULL); + format = Tcl_GetString(objv[2]); cursor = buffer; maxPos = cursor; while (*format != 0) { @@ -733,7 +780,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } else { memcpy((VOID *) cursor, (VOID *) bytes, (size_t) length); - memset(cursor+length, pad, + memset((VOID *) (cursor + length), pad, (size_t) (count - length)); } cursor += count; @@ -765,7 +812,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) goto badValue; } if (((offset + 1) % 8) == 0) { - *cursor++ = (char)(value & 0xff); + *cursor++ = (unsigned char) value; value = 0; } } @@ -779,7 +826,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) goto badValue; } if (!((offset + 1) % 8)) { - *cursor++ = (char)(value & 0xff); + *cursor++ = (unsigned char) value; value = 0; } } @@ -790,7 +837,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } else { value >>= 8 - (offset % 8); } - *cursor++ = (char)(value & 0xff); + *cursor++ = (unsigned char) value; } while (cursor < last) { *cursor++ = '\0'; @@ -817,15 +864,18 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) if (cmd == 'H') { for (offset = 0; offset < count; offset++) { value <<= 4; - c = tolower(((unsigned char *) str)[offset]); - if ((c >= 'a') && (c <= 'f')) { - value |= ((c - 'a' + 10) & 0xf); - } else if ((c >= '0') && (c <= '9')) { - value |= (c - '0') & 0xf; - } else { + if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; goto badValue; } + c = str[offset] - '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= (c & 0xf); if (offset % 2) { *cursor++ = (char) value; value = 0; @@ -834,17 +884,21 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } else { for (offset = 0; offset < count; offset++) { value >>= 4; - c = tolower(((unsigned char *) str)[offset]); - if ((c >= 'a') && (c <= 'f')) { - value |= ((c - 'a' + 10) << 4) & 0xf0; - } else if ((c >= '0') && (c <= '9')) { - value |= ((c - '0') << 4) & 0xf0; - } else { + + if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; goto badValue; } + c = str[offset] - '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= ((c << 4) & 0xf0); if (offset % 2) { - *cursor++ = (char)(value & 0xff); + *cursor++ = (unsigned char)(value & 0xff); value = 0; } } @@ -855,7 +909,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } else { value >>= 4; } - *cursor++ = (char) value; + *cursor++ = (unsigned char) value; } while (cursor < last) { @@ -899,14 +953,15 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } break; } - case 'x': + case 'x': { if (count == BINARY_NOCOUNT) { count = 1; } memset(cursor, 0, (size_t) count); cursor += count; break; - case 'X': + } + case 'X': { if (cursor > maxPos) { maxPos = cursor; } @@ -920,7 +975,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) cursor -= count; } break; - case '@': + } + case '@': { if (cursor > maxPos) { maxPos = cursor; } @@ -930,11 +986,12 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) cursor = buffer + count; } break; + } } } break; - - case BinaryScan: { + } + case BINARY_SCAN: { int i; Tcl_Obj *valuePtr, *elementPtr; @@ -944,11 +1001,12 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } buffer = Tcl_GetByteArrayFromObj(objv[2], &length); - format = Tcl_GetStringFromObj(objv[3], NULL); + format = Tcl_GetString(objv[3]); cursor = buffer; arg = 4; offset = 0; - while (*format != 0) { + while (*format != '\0') { + str = format; if (!GetFormatSpec(&format, &cmd, &count)) { goto done; } @@ -956,7 +1014,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) case 'a': case 'A': { unsigned char *src; - + if (arg >= objc) { goto badIndex; } @@ -987,9 +1045,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } valuePtr = Tcl_NewByteArrayObj(src, size); - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; @@ -1006,19 +1064,19 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) goto badIndex; } if (count == BINARY_ALL) { - count = (length - offset)*8; + count = (length - offset) * 8; } else { if (count == BINARY_NOCOUNT) { count = 1; } - if (count > (length - offset)*8) { + if (count > (length - offset) * 8) { goto done; } } src = buffer + offset; valuePtr = Tcl_NewObj(); Tcl_SetObjLength(valuePtr, count); - dest = Tcl_GetStringFromObj(valuePtr, NULL); + dest = Tcl_GetString(valuePtr); if (cmd == 'b') { for (i = 0; i < count; i++) { @@ -1040,9 +1098,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; @@ -1052,8 +1110,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } case 'h': case 'H': { - unsigned char *src; char *dest; + unsigned char *src; int i; static char hexdigit[] = "0123456789abcdef"; @@ -1073,7 +1131,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) src = buffer + offset; valuePtr = Tcl_NewObj(); Tcl_SetObjLength(valuePtr, count); - dest = Tcl_GetStringFromObj(valuePtr, NULL); + dest = Tcl_GetString(valuePtr); if (cmd == 'h') { for (i = 0; i < count; i++) { @@ -1095,9 +1153,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; @@ -1105,27 +1163,31 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset += (count + 1) / 2; break; } - case 'c': + case 'c': { size = 1; goto scanNumber; + } case 's': - case 'S': + case 'S': { size = 2; goto scanNumber; + } case 'i': - case 'I': + case 'I': { size = 4; goto scanNumber; - case 'f': + } + case 'f': { size = sizeof(float); goto scanNumber; + } case 'd': { unsigned char *src; - + size = sizeof(double); /* fall through */ - scanNumber: + scanNumber: if (arg >= objc) { goto badIndex; } @@ -1153,16 +1215,16 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset += count*size; } - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } break; } - case 'x': + case 'x': { if (count == BINARY_NOCOUNT) { count = 1; } @@ -1173,7 +1235,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset += count; } break; - case 'X': + } + case 'X': { if (count == BINARY_NOCOUNT) { count = 1; } @@ -1183,7 +1246,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset -= count; } break; - case '@': + } + case '@': { if (count == BINARY_NOCOUNT) { goto badCount; } @@ -1193,15 +1257,10 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset = count; } break; + } default: { - char buf[2]; - - Tcl_ResetResult(interp); - buf[0] = cmd; - buf[1] = '\0'; - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad field specifier \"", buf, "\"", NULL); - return TCL_ERROR; + errorString = str; + goto badfield; } } } @@ -1232,9 +1291,18 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) errorString = "not enough arguments for all format specifiers"; goto error; + badfield: { + Tcl_UniChar ch; + char buf[TCL_UTF_MAX + 1]; + + Tcl_UtfToUniChar(errorString, &ch); + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); + return TCL_ERROR; + } + error: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), errorString, -1); + Tcl_AppendResult(interp, errorString, NULL); return TCL_ERROR; } @@ -1290,7 +1358,7 @@ GetFormatSpec(formatPtr, cmdPtr, countPtr) if (**formatPtr == '*') { (*formatPtr)++; (*countPtr) = BINARY_ALL; - } else if (isdigit(UCHAR(**formatPtr))) { + } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ (*countPtr) = strtoul(*formatPtr, formatPtr, 10); } else { (*countPtr) = BINARY_NOCOUNT; @@ -1325,9 +1393,8 @@ FormatNumber(interp, type, src, cursorPtr) { int value; double dvalue; - char cmd = (char)type; - if (cmd == 'd' || cmd == 'f') { + if ((type == 'd') || (type == 'f')) { /* * For floating point types, we need to copy the data using * memcpy to avoid alignment issues. @@ -1336,9 +1403,9 @@ FormatNumber(interp, type, src, cursorPtr) if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { return TCL_ERROR; } - if (cmd == 'd') { - memcpy((*cursorPtr), &dvalue, sizeof(double)); - (*cursorPtr) += sizeof(double); + if (type == 'd') { + memcpy((VOID *) *cursorPtr, (VOID *) &dvalue, sizeof(double)); + *cursorPtr += sizeof(double); } else { float fvalue; @@ -1353,31 +1420,31 @@ FormatNumber(interp, type, src, cursorPtr) } else { fvalue = (float) dvalue; } - memcpy((*cursorPtr), &fvalue, sizeof(float)); - (*cursorPtr) += sizeof(float); + memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float)); + *cursorPtr += sizeof(float); } } else { if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } - if (cmd == 'c') { - *(*cursorPtr)++ = (char)(value & 0xff); - } else if (cmd == 's') { - *(*cursorPtr)++ = (char)(value & 0xff); - *(*cursorPtr)++ = (char)((value >> 8) & 0xff); - } else if (cmd == 'S') { - *(*cursorPtr)++ = (char)((value >> 8) & 0xff); - *(*cursorPtr)++ = (char)(value & 0xff); - } else if (cmd == 'i') { - *(*cursorPtr)++ = (char)(value & 0xff); - *(*cursorPtr)++ = (char)((value >> 8) & 0xff); - *(*cursorPtr)++ = (char)((value >> 16) & 0xff); - *(*cursorPtr)++ = (char)((value >> 24) & 0xff); - } else if (cmd == 'I') { - *(*cursorPtr)++ = (char)((value >> 24) & 0xff); - *(*cursorPtr)++ = (char)((value >> 16) & 0xff); - *(*cursorPtr)++ = (char)((value >> 8) & 0xff); - *(*cursorPtr)++ = (char)(value & 0xff); + if (type == 'c') { + *(*cursorPtr)++ = (unsigned char) value; + } else if (type == 's') { + *(*cursorPtr)++ = (unsigned char) value; + *(*cursorPtr)++ = (unsigned char) (value >> 8); + } else if (type == 'S') { + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) value; + } else if (type == 'i') { + *(*cursorPtr)++ = (unsigned char) value; + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) (value >> 16); + *(*cursorPtr)++ = (unsigned char) (value >> 24); + } else if (type == 'I') { + *(*cursorPtr)++ = (unsigned char) (value >> 24); + *(*cursorPtr)++ = (unsigned char) (value >> 16); + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) value; } } return TCL_OK; @@ -1406,7 +1473,7 @@ ScanNumber(buffer, type) unsigned char *buffer; /* Buffer to scan number from. */ int type; /* Format character from "binary scan" */ { - int value; + long value; /* * We cannot rely on the compiler to properly sign extend integer values @@ -1416,37 +1483,45 @@ ScanNumber(buffer, type) * needed. */ - switch ((char) type) { - case 'c': - value = buffer[0]; + switch (type) { + case 'c': { + /* + * Characters need special handling. We want to produce a + * signed result, but on some platforms (such as AIX) chars + * are unsigned. To deal with this, check for a value that + * should be negative but isn't. + */ + value = buffer[0]; if (value & 0x80) { value |= -0x100; } return Tcl_NewLongObj((long)value); - case 's': - value = (((unsigned char)buffer[0]) - + ((unsigned char)buffer[1] << 8)); + } + case 's': { + value = (long) (buffer[0] + (buffer[1] << 8)); goto shortValue; - case 'S': - value = (((unsigned char)buffer[1]) - + ((unsigned char)buffer[0] << 8)); + } + case 'S': { + value = (long) (buffer[1] + (buffer[0] << 8)); shortValue: if (value & 0x8000) { value |= -0x10000; } - return Tcl_NewLongObj((long)value); - case 'i': - value = (((unsigned char)buffer[0]) - + ((unsigned char)buffer[1] << 8) - + ((unsigned char)buffer[2] << 16) - + ((unsigned char)buffer[3] << 24)); + return Tcl_NewLongObj(value); + } + case 'i': { + value = (long) (buffer[0] + + (buffer[1] << 8) + + (buffer[2] << 16) + + (buffer[3] << 24)); goto intValue; - case 'I': - value = (((unsigned char)buffer[3]) - + ((unsigned char)buffer[2] << 8) - + ((unsigned char)buffer[1] << 16) - + ((unsigned char)buffer[0] << 24)); + } + case 'I': { + value = (long) (buffer[3] + + (buffer[2] << 8) + + (buffer[1] << 16) + + (buffer[0] << 24)); intValue: /* * Check to see if the value was sign extended properly on @@ -1457,16 +1532,16 @@ ScanNumber(buffer, type) value -= (((unsigned int)1)<<31); value -= (((unsigned int)1)<<31); } - - return Tcl_NewLongObj((long)value); + return Tcl_NewLongObj(value); + } case 'f': { float fvalue; - memcpy(&fvalue, buffer, sizeof(float)); + memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float)); return Tcl_NewDoubleObj(fvalue); } case 'd': { double dvalue; - memcpy(&dvalue, buffer, sizeof(double)); + memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double)); return Tcl_NewDoubleObj(dvalue); } } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 61d4623..f19d597 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -5,14 +5,15 @@ * involving overwritten, double freeing memory and loss of memory. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1997 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. * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.3 1999/03/10 05:52:47 stanton Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.4 1999/04/16 00:46:42 stanton Exp $ */ #include "tclInt.h" @@ -102,9 +103,31 @@ static int init_malloced_bodies = TRUE; #endif /* + * The following variable indicates to TclFinalizeMemorySubsystem() + * that it should dump out the state of memory before exiting. If the + * value is non-NULL, it gives the name of the file in which to + * dump memory usage information. + */ + +char *tclMemDumpFileName = NULL; + +static char dumpFile[100]; /* Records where to dump memory allocation + * information. */ + +/* + * Mutex to serialize allocations. This is a low-level mutex that must + * be explicitly initialized. This is necessary because the self + * initializing mutexes use ckalloc... + */ +static TclpMutex ckallocMutex; +static int ckallocInit = 0; + +/* * Prototypes for procedures defined in this file: */ +static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); static int MemoryCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static void ValidateMemory _ANSI_ARGS_(( @@ -114,6 +137,25 @@ static void ValidateMemory _ANSI_ARGS_(( /* *---------------------------------------------------------------------- * + * TclInitDbCkalloc -- + * Initialize the locks used by the allocator. + * This is only appropriate to call in a single threaded environtment, + * such as during TclInitSubsystems. + * + *---------------------------------------------------------------------- + */ +void +TclInitDbCkalloc() +{ + if (!ckallocInit) { + ckallocInit = 1; + TclpMutexInit(&ckallocMutex); + } +} + +/* + *---------------------------------------------------------------------- + * * TclDumpMemoryInfo -- * Display the global memory management statistics. * @@ -164,7 +206,7 @@ ValidateMemory(memHeaderP, file, line, nukeGuards) fflush(stdout); byte &= 0xff; fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, - (isprint(UCHAR(byte)) ? byte : ' ')); + (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } if (guard_failed) { @@ -185,7 +227,7 @@ ValidateMemory(memHeaderP, file, line, nukeGuards) fflush (stdout); byte &= 0xff; fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, - (isprint(UCHAR(byte)) ? byte : ' ')); + (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } @@ -222,9 +264,15 @@ Tcl_ValidateAllMemory (file, line) { struct mem_header *memScanP; - for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) + if (!ckallocInit) { + ckallocInit = 1; + TclpMutexInit(&ckallocMutex); + } + TclpMutexLock(&ckallocMutex); + for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { ValidateMemory(memScanP, file, line, FALSE); - + } + TclpMutexUnlock(&ckallocMutex); } /* @@ -246,10 +294,16 @@ Tcl_DumpActiveMemory (fileName) struct mem_header *memScanP; char *address; - fileP = fopen(fileName, "w"); - if (fileP == NULL) - return TCL_ERROR; + if (fileName == NULL) { + fileP = stdout; + } else { + fileP = fopen(fileName, "w"); + if (fileP == NULL) { + return TCL_ERROR; + } + } + TclpMutexLock(&ckallocMutex); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body [0]; fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", @@ -259,7 +313,11 @@ Tcl_DumpActiveMemory (fileName) (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } - fclose (fileP); + TclpMutexUnlock(&ckallocMutex); + + if (fileP != stderr) { + fclose (fileP); + } return TCL_OK; } @@ -313,6 +371,11 @@ Tcl_DbCkalloc(size, file, line) memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); } + if (!ckallocInit) { + ckallocInit = 1; + TclpMutexInit(&ckallocMutex); + } + TclpMutexLock(&ckallocMutex); result->length = size; result->tagPtr = curTagPtr; if (curTagPtr != NULL) { @@ -322,6 +385,7 @@ Tcl_DbCkalloc(size, file, line) result->line = line; result->flink = allocHead; result->blink = NULL; + if (allocHead != NULL) allocHead->blink = result; allocHead = result; @@ -357,6 +421,8 @@ Tcl_DbCkalloc(size, file, line) if (current_bytes_malloced > maximum_bytes_malloced) maximum_bytes_malloced = current_bytes_malloced; + TclpMutexUnlock(&ckallocMutex); + return result->body; } @@ -403,6 +469,7 @@ Tcl_DbCkfree(ptr, file, line) if (validate_memory) Tcl_ValidateAllMemory(file, line); + TclpMutexLock(&ckallocMutex); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length); @@ -429,6 +496,8 @@ Tcl_DbCkfree(ptr, file, line) if (allocHead == memp) allocHead = memp->flink; TclpFree((char *) memp); + TclpMutexUnlock(&ckallocMutex); + return 0; } @@ -580,7 +649,14 @@ MemoryCmd (clientData, interp, argc, argv) return TCL_OK; } if (strcmp(argv[1],"info") == 0) { - TclDumpMemoryInfo(stdout); + char buffer[400]; + sprintf(buffer, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", + "total mallocs", total_mallocs, "total frees", total_frees, + "current packets allocated", current_malloc_packets, + "current bytes allocated", current_bytes_malloced, + "maximum packets allocated", maximum_malloc_packets, + "maximum bytes allocated", maximum_bytes_malloced); + Tcl_SetResult(interp, buffer, TCL_VOLATILE); return TCL_OK; } if (strcmp(argv[1],"init") == 0) { @@ -648,6 +724,42 @@ bad_suboption: /* *---------------------------------------------------------------------- * + * CheckmemCmd -- + * + * This is the command procedure for the "checkmem" command, which + * causes the application to exit after printing information about + * memory usage to the file passed to this command as its first + * argument. + * + * Results: + * Returns a standard Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CheckmemCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter for evaluation. */ + int argc; /* Number of arguments. */ + char *argv[]; /* String values of arguments. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName\"", (char *) NULL); + return TCL_ERROR; + } + tclMemDumpFileName = dumpFile; + strcpy(tclMemDumpFileName, argv[1]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_InitMemory -- * Initialize the memory command. * @@ -657,11 +769,19 @@ void Tcl_InitMemory(interp) Tcl_Interp *interp; { + TclInitDbCkalloc(); Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); } -#else /* TCL_MEM_DEBUG */ + +#else /* TCL_MEM_DEBUG */ + +#undef Tcl_InitMemory +#undef Tcl_DumpActiveMemory +#undef Tcl_ValidateAllMemory /* @@ -778,8 +898,8 @@ Tcl_DbCkfree(ptr, file, line) /* *---------------------------------------------------------------------- * - * Tcl_InitMemory, et al. -- - * Dummy implementations of memory routines, which is only available + * Tcl_InitMemory -- + * Dummy initialization for memory command, which is only available * if TCL_MEM_DEBUG is on. * *---------------------------------------------------------------------- @@ -791,9 +911,6 @@ Tcl_InitMemory(interp) { } -#undef Tcl_DumpActiveMemory -#undef Tcl_ValidateAllMemory - int Tcl_DumpActiveMemory(fileName) char *fileName; @@ -814,4 +931,44 @@ TclDumpMemoryInfo(outFile) { } -#endif /* TCL_MEM_DEBUG */ +#endif /* TCL_MEM_DEBUG */ + +/* + *--------------------------------------------------------------------------- + * + * TclFinalizeMemorySubsystem -- + * + * This procedure is called to finalize all the structures that + * are used by the memory allocator on a per-process basis. + * + * Results: + * None. + * + * Side effects: + * This subsystem is self-initializing, since memory can be + * allocated before Tcl is formally initialized. After this call, + * this subsystem has been reset to its initial state and is + * usable again. + * + *--------------------------------------------------------------------------- + */ + +void +TclFinalizeMemorySubsystem() +{ +#ifdef TCL_MEM_DEBUG + TclpMutexLock(&ckallocMutex); + if (tclMemDumpFileName != NULL) { + Tcl_DumpActiveMemory(tclMemDumpFileName); + } + if (curTagPtr != NULL) { + TclpFree((char *) curTagPtr); + } + allocHead = NULL; + TclpMutexUnlock(&ckallocMutex); +#endif + +#if USE_TCLALLOC + TclFinalizeAllocSubsystem(); +#endif +} diff --git a/generic/tclClock.c b/generic/tclClock.c index bd96000..2015f53 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -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: tclClock.c,v 1.3 1999/03/10 05:52:47 stanton Exp $ + * RCS: @(#) $Id: tclClock.c,v 1.4 1999/04/16 00:46:43 stanton Exp $ */ #include "tcl.h" @@ -19,6 +19,12 @@ #include "tclPort.h" /* + * The date parsing stuff uses lexx and has tons o statics. + */ + +TCL_DECLARE_MUTEX(clockMutex) + +/* * Function prototypes for local procedures in this file: */ @@ -172,13 +178,16 @@ Tcl_ClockObjCmd (client, interp, objc, objv) } scanStr = Tcl_GetStringFromObj(objv[2], &dummy); + Tcl_MutexLock(&clockMutex); if (TclGetDate(scanStr, (unsigned long) baseClock, zone, (unsigned long *) &clockVal) < 0) { + Tcl_MutexUnlock(&clockMutex); Tcl_AppendStringsToObj(resultPtr, "unable to convert date-time string \"", scanStr, "\"", (char *) NULL); return TCL_ERROR; } + Tcl_MutexUnlock(&clockMutex); Tcl_SetLongObj(resultPtr, (long) clockVal); return TCL_OK; @@ -222,11 +231,12 @@ FormatClock(interp, clockVal, useGMT, format) Tcl_DString buffer; int bufSize; char *p; -#ifdef TCL_USE_TIMEZONE_VAR - int savedTimeZone; - char *savedTZEnv; -#endif Tcl_Obj *resultPtr; + int result; +#ifndef HAVE_TM_ZONE + int savedTimeZone = 0; /* lint. */ + char *savedTZEnv = NULL; /* lint. */ +#endif resultPtr = Tcl_GetObjResult(interp); #ifdef HAVE_TZSET @@ -235,18 +245,21 @@ FormatClock(interp, clockVal, useGMT, format) */ static int calledTzset = 0; + Tcl_MutexLock(&clockMutex); if (!calledTzset) { tzset(); calledTzset = 1; } + Tcl_MutexUnlock(&clockMutex); #endif -#ifdef TCL_USE_TIMEZONE_VAR +#ifndef HAVE_TM_ZONE /* - * This is a horrible kludge for systems not having the timezone in - * struct tm. No matter what was specified, they use the global time - * zone. (Thanks Solaris). + * This is a kludge for systems not having the timezone string in + * struct tm. No matter what was specified, they use the local + * timezone string. */ + if (useGMT) { char *varValue; @@ -280,14 +293,12 @@ FormatClock(interp, clockVal, useGMT, format) Tcl_DStringInit(&buffer); Tcl_DStringSetLength(&buffer, bufSize); - if ((TclStrftime(buffer.string, (unsigned int) bufSize, format, - timeDataPtr) == 0) && (*format != '\0')) { - Tcl_AppendStringsToObj(resultPtr, "bad format string \"", - format, "\"", (char *) NULL); - return TCL_ERROR; - } + Tcl_MutexLock(&clockMutex); + result = TclpStrftime(buffer.string, (unsigned int) bufSize, format, + timeDataPtr); + Tcl_MutexUnlock(&clockMutex); -#ifdef TCL_USE_TIMEZONE_VAR +#ifndef HAVE_TM_ZONE if (useGMT) { if (savedTZEnv != NULL) { Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY); @@ -299,6 +310,11 @@ FormatClock(interp, clockVal, useGMT, format) tzset(); } #endif + if ((result == 0) && (*format != '\0')) { + Tcl_AppendStringsToObj(resultPtr, "bad format string \"", format, + "\"", (char *) NULL); + return TCL_ERROR; + } Tcl_SetStringObj(resultPtr, buffer.string, -1); Tcl_DStringFree(&buffer); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index fd31e52..8aa6880 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,24 +11,36 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.4 1998/12/23 02:01:42 rjohnson Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.5 1999/04/16 00:46:43 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" +#include + +typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf)); /* * Prototypes for local procedures defined in this file: */ +static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int mode)); +static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, StatProc *statProc, + struct stat *statPtr)); static char * GetTypeFromMode _ANSI_ARGS_((int mode)); +static int SplitPath _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr)); static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, char *varName, struct stat *statPtr)); +static char ** StringifyObjects _ANSI_ARGS_((int objc, + Tcl_Obj *CONST objv[])); /* *---------------------------------------------------------------------- * - * Tcl_BreakCmd -- + * Tcl_BreakObjCmd -- * * This procedure is invoked to process the "break" Tcl command. * See the user documentation for details on what it does. @@ -48,15 +60,14 @@ static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, /* ARGSUSED */ int -Tcl_BreakCmd(dummy, interp, argc, argv) +Tcl_BreakObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], "\"", (char *) NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } return TCL_BREAK; @@ -90,7 +101,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) register int i; int body, result; char *string, *arg; - int argLen, caseObjc; + int caseObjc; Tcl_Obj *CONST *caseObjv; Tcl_Obj *armPtr; @@ -100,14 +111,10 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. - */ - - string = Tcl_GetStringFromObj(objv[1], &argLen); + string = Tcl_GetString(objv[1]); body = -1; - arg = Tcl_GetStringFromObj(objv[2], &argLen); + arg = Tcl_GetString(objv[2]); if (strcmp(arg, "in") == 0) { i = 3; } else { @@ -119,7 +126,6 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) /* * If all of the pattern/command pairs are lumped into a single * argument, split them out again. - * THIS FAILS IF THE ARG'S STRING REP CONTAINS A NULL */ if (caseObjc == 1) { @@ -133,9 +139,9 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) int patObjc, j; char **patObjv; char *pat; - register char *p; + unsigned char *p; - if (i == (caseObjc-1)) { + if (i == (caseObjc - 1)) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "extra case pattern with no body", -1); @@ -147,18 +153,18 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) * no backslash sequences. */ - pat = Tcl_GetStringFromObj(caseObjv[i], &argLen); - for (p = pat; *p != 0; p++) { /* FAILS IF NULL BYTE */ - if (isspace(UCHAR(*p)) || (*p == '\\')) { + pat = Tcl_GetString(caseObjv[i]); + for (p = (unsigned char *) pat; *p != '\0'; p++) { + if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */ break; } } - if (*p == 0) { + if (*p == '\0') { if ((*pat == 'd') && (strcmp(pat, "default") == 0)) { - body = i+1; + body = i + 1; } if (Tcl_StringMatch(string, pat)) { - body = i+1; + body = i + 1; goto match; } continue; @@ -176,7 +182,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) } for (j = 0; j < patObjc; j++) { if (Tcl_StringMatch(string, patObjv[j])) { - body = i+1; + body = i + 1; break; } } @@ -188,13 +194,14 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) match: if (body != -1) { - armPtr = caseObjv[body-1]; - result = Tcl_EvalObj(interp, caseObjv[body]); + armPtr = caseObjv[body - 1]; + result = Tcl_EvalObjEx(interp, caseObjv[body], 0); if (result == TCL_ERROR) { - char msg[100]; + char msg[100 + TCL_INTEGER_SPACE]; - arg = Tcl_GetStringFromObj(armPtr, &argLen); - sprintf(msg, "\n (\"%.*s\" arm line %d)", argLen, arg, + arg = Tcl_GetString(armPtr); + sprintf(msg, + "\n (\"%.50s\" arm line %d)", arg, interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } @@ -251,11 +258,11 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) varNamePtr = objv[2]; } - result = Tcl_EvalObj(interp, objv[1]); + result = Tcl_EvalObjEx(interp, objv[1], 0); if (objc == 3) { if (Tcl_ObjSetVar2(interp, varNamePtr, NULL, - Tcl_GetObjResult(interp), TCL_PARSE_PART1) == NULL) { + Tcl_GetObjResult(interp), 0) == NULL) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "couldn't save command result in variable", -1); @@ -301,8 +308,7 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *dirName; - int dirLength; - Tcl_DString buffer; + Tcl_DString ds; int result; if (objc > 2) { @@ -311,17 +317,23 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) } if (objc == 2) { - dirName = Tcl_GetStringFromObj(objv[1], &dirLength); + dirName = Tcl_GetString(objv[1]); } else { dirName = "~"; } - dirName = Tcl_TranslateFileName(interp, dirName, &buffer); - if (dirName == NULL) { + if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) { return TCL_ERROR; } - result = TclChdir(interp, dirName); - Tcl_DStringFree(&buffer); - return result; + + result = Tcl_Chdir(Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + + if (result != 0) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; } /* @@ -330,7 +342,7 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) * Tcl_ConcatObjCmd -- * * This object-based procedure is invoked to process the "concat" Tcl - * command. See the user documentation for details on what it does/ + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -358,7 +370,7 @@ Tcl_ConcatObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_ContinueCmd - + * Tcl_ContinueObjCmd - * * This procedure is invoked to process the "continue" Tcl command. * See the user documentation for details on what it does. @@ -378,15 +390,14 @@ Tcl_ConcatObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_ContinueCmd(dummy, interp, argc, argv) +Tcl_ContinueObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - "\"", (char *) NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } return TCL_CONTINUE; @@ -395,6 +406,131 @@ Tcl_ContinueCmd(dummy, interp, argc, argv) /* *---------------------------------------------------------------------- * + * Tcl_EncodingObjCmd -- + * + * This command manipulates encodings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EncodingObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int index, length; + Tcl_Encoding encoding; + char *string; + Tcl_DString ds; + Tcl_Obj *resultPtr; + + static char *optionStrings[] = { + "convertfrom", "convertto", "names", "system", + NULL + }; + enum options { + ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case ENC_CONVERTTO: + case ENC_CONVERTFROM: { + char *name; + Tcl_Obj *data; + if (objc == 3) { + name = NULL; + data = objv[2]; + } else if (objc == 4) { + name = Tcl_GetString(objv[2]); + data = objv[3]; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); + return TCL_ERROR; + } + + encoding = Tcl_GetEncoding(interp, name); + if (!encoding) { + return TCL_ERROR; + } + + if ((enum options) index == ENC_CONVERTFROM) { + /* + * Treat the string as binary data. + */ + + string = (char *) Tcl_GetByteArrayFromObj(data, &length); + Tcl_ExternalToUtfDString(encoding, string, length, &ds); + + /* + * Note that we cannot use Tcl_DStringResult here because + * it will truncate the string at the first null byte. + */ + + Tcl_SetStringObj(Tcl_GetObjResult(interp), + Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } else { + /* + * Store the result as binary data. + */ + + string = Tcl_GetStringFromObj(data, &length); + Tcl_UtfToExternalDString(encoding, string, length, &ds); + resultPtr = Tcl_GetObjResult(interp); + Tcl_SetByteArrayObj(resultPtr, + (unsigned char *) Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } + + Tcl_FreeEncoding(encoding); + break; + } + case ENC_NAMES: { + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_GetEncodingNames(interp); + break; + } + case ENC_SYSTEM: { + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); + return TCL_ERROR; + } + if (objc == 2) { + Tcl_SetResult(interp, Tcl_GetEncodingName(NULL), TCL_STATIC); + } else { + return Tcl_SetSystemEncoding(interp, + Tcl_GetStringFromObj(objv[2], NULL)); + } + break; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ErrorObjCmd -- * * This procedure is invoked to process the "error" Tcl command. @@ -418,7 +554,6 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - register Tcl_Obj *namePtr; char *info; int infoLen; @@ -436,11 +571,8 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv) } if (objc == 4) { - namePtr = Tcl_NewStringObj("errorCode", -1); - Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, objv[3], - TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY); iPtr->flags |= ERROR_CODE_SET; - Tcl_DecrRefCount(namePtr); /* we're done with name object */ } Tcl_SetObjResult(interp, objv[1]); @@ -481,7 +613,7 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) } if (objc == 2) { - result = Tcl_EvalObj(interp, objv[1]); + result = Tcl_EvalObjEx(interp, objv[1], 0); } else { /* * More than one argument: concatenate them together with spaces @@ -489,11 +621,13 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) */ objPtr = Tcl_ConcatObj(objc-1, objv+1); - result = Tcl_EvalObj(interp, objPtr); - Tcl_DecrRefCount(objPtr); /* we're done with the object */ + Tcl_IncrRefCount(objPtr); + result = Tcl_EvalObjEx(interp, objPtr, 0); + Tcl_DecrRefCount(objPtr); } if (result == TCL_ERROR) { - char msg[60]; + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } @@ -573,7 +707,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ +{ register Tcl_Obj *objPtr; Tcl_Obj *resultPtr; register char *bytes; @@ -595,7 +729,6 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) /* * Create a new object holding the concatenated argument strings. - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. */ bytes = Tcl_GetStringFromObj(objv[1], &length); @@ -652,103 +785,86 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *fileName, *extension, *errorString; - int statOp = 0; /* Init. to avoid compiler warning. */ - int length; - int mode = 0; /* Initialized only to prevent - * compiler warning message. */ - struct stat statBuf; - Tcl_DString buffer; Tcl_Obj *resultPtr; - int index, result; + int index; /* * This list of constants should match the fileOption string array below. */ -enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, - FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY, - FILE_ISFILE, FILE_JOIN, FILE_LSTAT, FILE_MTIME, FILE_MKDIR, - FILE_NATIVENAME, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE, - FILE_READLINK, FILE_RENAME, FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, - FILE_STAT, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE}; - - - static char *fileOptions[] = {"atime", "attributes", "copy", "delete", - "dirname", "executable", "exists", "extension", "isdirectory", - "isfile", "join", "lstat", "mtime", "mkdir", "nativename", - "owned", "pathtype", "readable", "readlink", "rename", - "rootname", "size", "split", "stat", "tail", "type", "volumes", - "writable", (char *) NULL}; + static char *fileOptions[] = { + "atime", "attributes", "copy", "delete", + "dirname", "executable", "exists", "extension", + "isdirectory", "isfile", "join", "lstat", + "mtime", "mkdir", "nativename", "owned", + "pathtype", "readable", "readlink", "rename", + "rootname", "size", "split", "stat", + "tail", "type", "volumes", "writable", + (char *) NULL + }; + enum options { + FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, + FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, + FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT, + FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, FILE_OWNED, + FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME, + FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, FILE_STAT, + FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } - - if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index) - != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - - result = TCL_OK; - /* - * First, do the volumes command, since it is the only one that - * has objc == 2. - */ - - if ( index == FILE_VOLUMES) { - if ( objc != 2 ) { - Tcl_WrongNumArgs(interp, 1, objv, "volumes"); - return TCL_ERROR; - } - result = TclpListVolumes(interp); - return result; - } - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?arg ...?"); - return TCL_ERROR; - } - Tcl_DStringInit(&buffer); resultPtr = Tcl_GetObjResult(interp); - - - /* - * Handle operations on the file name. - */ - - switch (index) { - case FILE_ATTRIBUTES: - result = TclFileAttrsCmd(interp, objc - 2, objv + 2); - goto done; - case FILE_DIRNAME: { - int pargc; - char **pargv; - + switch ((enum options) index) { + case FILE_ATIME: { + struct stat buf; + if (objc != 3) { - errorString = "dirname name"; - goto not3Args; + goto only3Args; + } + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; } + Tcl_SetLongObj(resultPtr, (long) buf.st_atime); + return TCL_OK; + } + case FILE_ATTRIBUTES: { + return TclFileAttrsCmd(interp, objc, objv); + } + case FILE_COPY: { + int result; + char **argv; - fileName = Tcl_GetStringFromObj(objv[2], &length); + argv = StringifyObjects(objc, objv); + result = TclFileCopyCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_DELETE: { + int result; + char **argv; - /* - * If there is only one element, and it starts with a tilde, - * perform tilde substitution and resplit the path. - */ + argv = StringifyObjects(objc, objv); + result = TclFileDeleteCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_DIRNAME: { + int argc; + char **argv; - Tcl_SplitPath(fileName, &pargc, &pargv); - if ((pargc == 1) && (*fileName == '~')) { - ckfree((char*) pargv); - fileName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (fileName == NULL) { - result = TCL_ERROR; - goto done; - } - Tcl_SplitPath(fileName, &pargc, &pargv); - Tcl_DStringSetLength(&buffer, 0); + if (objc != 3) { + goto only3Args; + } + if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { + return TCL_ERROR; } /* @@ -757,324 +873,209 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, * return the current directory. */ - if (pargc > 1) { - Tcl_JoinPath(pargc-1, pargv, &buffer); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), - buffer.length); - } else if ((pargc == 0) - || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetStringObj(resultPtr, (tclPlatform == TCL_PLATFORM_MAC) - ? ":" : ".", 1); + if (argc > 1) { + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(argc - 1, argv, &ds); + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } else if ((argc == 0) + || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetStringObj(resultPtr, + ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1); } else { - Tcl_SetStringObj(resultPtr, pargv[0], -1); } - ckfree((char *)pargv); - goto done; + Tcl_SetStringObj(resultPtr, argv[0], -1); + } + ckfree((char *) argv); + return TCL_OK; } - case FILE_TAIL: { - int pargc; - char **pargv; - + case FILE_EXECUTABLE: { if (objc != 3) { - errorString = "tail name"; - goto not3Args; - } - - fileName = Tcl_GetStringFromObj(objv[2], &length); - - /* - * If there is only one element, and it starts with a tilde, - * perform tilde substitution and resplit the path. - */ - - Tcl_SplitPath(fileName, &pargc, &pargv); - if ((pargc == 1) && (*fileName == '~')) { - ckfree((char*) pargv); - fileName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (fileName == NULL) { - result = TCL_ERROR; - goto done; - } - Tcl_SplitPath(fileName, &pargc, &pargv); - Tcl_DStringSetLength(&buffer, 0); + goto only3Args; } - - /* - * Return the last component, unless it is the only component, - * and it is the root of an absolute path. - */ - - if (pargc > 0) { - if ((pargc > 1) - || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetStringObj(resultPtr, pargv[pargc - 1], -1); - } - } - ckfree((char *)pargv); - goto done; + return CheckAccess(interp, objv[2], X_OK); } - case FILE_ROOTNAME: { - char *fileName; - + case FILE_EXISTS: { if (objc != 3) { - errorString = "rootname name"; - goto not3Args; - } - - fileName = Tcl_GetStringFromObj(objv[2], &length); - extension = TclGetExtension(fileName); - if (extension == NULL) { - Tcl_SetObjResult(interp, objv[2]); - } else { - Tcl_SetStringObj(resultPtr, fileName, - (int) (length - strlen(extension))); + goto only3Args; } - goto done; + return CheckAccess(interp, objv[2], F_OK); } - case FILE_EXTENSION: + case FILE_EXTENSION: { + char *fileName, *extension; if (objc != 3) { - errorString = "extension name"; - goto not3Args; + goto only3Args; } - extension = TclGetExtension(Tcl_GetStringFromObj(objv[2],&length)); - + fileName = Tcl_GetString(objv[2]); + extension = TclGetExtension(fileName); if (extension != NULL) { - Tcl_SetStringObj(resultPtr, extension, (int)strlen(extension)); + Tcl_SetStringObj(resultPtr, extension, -1); } - goto done; - case FILE_PATHTYPE: + return TCL_OK; + } + case FILE_ISDIRECTORY: { + int value; + struct stat buf; + if (objc != 3) { - errorString = "pathtype name"; - goto not3Args; + goto only3Args; } - switch (Tcl_GetPathType(Tcl_GetStringFromObj(objv[2], &length))) { - case TCL_PATH_ABSOLUTE: - Tcl_SetStringObj(resultPtr, "absolute", -1); - break; - case TCL_PATH_RELATIVE: - Tcl_SetStringObj(resultPtr, "relative", -1); - break; - case TCL_PATH_VOLUME_RELATIVE: - Tcl_SetStringObj(resultPtr, "volumerelative", -1); - break; + value = 0; + if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) { + value = S_ISDIR(buf.st_mode); } - goto done; - case FILE_SPLIT: { - int pargc, i; - char **pargvList; - Tcl_Obj *listObjPtr; - - if (objc != 3) { - errorString = "split name"; - goto not3Args; - } - - Tcl_SplitPath(Tcl_GetStringFromObj(objv[2], &length), &pargc, - &pargvList); - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (i = 0; i < pargc; i++) { - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj(pargvList[i], -1)); - } - ckfree((char *) pargvList); - Tcl_SetObjResult(interp, listObjPtr); - goto done; + Tcl_SetBooleanObj(resultPtr, value); + return TCL_OK; } - case FILE_JOIN: { - char **pargv = (char **) ckalloc((objc - 2) * sizeof(char *)); - int i; + case FILE_ISFILE: { + int value; + struct stat buf; - for (i = 2; i < objc; i++) { - pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length); - } - Tcl_JoinPath(objc - 2, pargv, &buffer); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), - buffer.length); - ckfree((char *) pargv); - Tcl_DStringFree(&buffer); - goto done; - } - case FILE_RENAME: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; - - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) { + value = S_ISREG(buf.st_mode); } - result = TclFileRenameCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; + Tcl_SetBooleanObj(resultPtr, value); + return TCL_OK; } - case FILE_MKDIR: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; - - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + case FILE_JOIN: { + char **argv; + Tcl_DString ds; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; } - result = TclFileMakeDirsCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; + argv = StringifyObjects(objc - 2, objv + 2); + Tcl_DStringInit(&ds); + Tcl_JoinPath(objc - 2, argv, &ds); + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + ckfree((char *) argv); + return TCL_OK; } - case FILE_DELETE: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; - - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + case FILE_LSTAT: { + char *varName; + struct stat buf; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { + return TCL_ERROR; } - result = TclFileDeleteCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; + varName = Tcl_GetString(objv[3]); + return StoreStatData(interp, varName, &buf); } - case FILE_COPY: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; + case FILE_MTIME: { + struct stat buf; - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + if (objc != 3) { + goto only3Args; } - result = TclFileCopyCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; - } - case FILE_NATIVENAME: - fileName = Tcl_TranslateFileName(interp, - Tcl_GetStringFromObj(objv[2], &length), &buffer); - if (fileName == NULL) { - result = TCL_ERROR ; - } else { - Tcl_SetStringObj(resultPtr, fileName, -1); + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; } - goto done; - } - - /* - * Next, handle operations that can be satisfied with the "access" - * kernel call. - */ + Tcl_SetLongObj(resultPtr, (long) buf.st_mtime); + return TCL_OK; + } + case FILE_MKDIR: { + char **argv; + int result; - fileName = Tcl_TranslateFileName(interp, - Tcl_GetStringFromObj(objv[2], &length), &buffer); - - switch (index) { - case FILE_READABLE: - if (objc != 3) { - errorString = "readable name"; - goto not3Args; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; } - mode = R_OK; -checkAccess: - /* - * The result might have been set within Tcl_TranslateFileName - * (like no such user "blah" for file exists ~blah) - * but we don't want to flag an error in that case. - */ - if (fileName == NULL) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - } else { - Tcl_SetBooleanObj(resultPtr, (TclAccess(fileName, mode) != -1)); - } - goto done; - case FILE_WRITABLE: + argv = StringifyObjects(objc, objv); + result = TclFileMakeDirsCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_NATIVENAME: { + char *fileName; + Tcl_DString ds; + if (objc != 3) { - errorString = "writable name"; - goto not3Args; + goto only3Args; } - mode = W_OK; - goto checkAccess; - case FILE_EXECUTABLE: - if (objc != 3) { - errorString = "executable name"; - goto not3Args; + fileName = Tcl_GetString(objv[2]); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; } - mode = X_OK; - goto checkAccess; - case FILE_EXISTS: + Tcl_SetStringObj(resultPtr, fileName, Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + return TCL_OK; + } + case FILE_OWNED: { + int value; + struct stat buf; + if (objc != 3) { - errorString = "exists name"; - goto not3Args; + goto only3Args; } - mode = F_OK; - goto checkAccess; - } + value = 0; + if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) { + /* + * For Windows and Macintosh, there are no user ids + * associated with a file, so we always return 1. + */ - - /* - * Lastly, check stuff that requires the file to be stat-ed. - */ +#if (defined(__WIN32__) || defined(MAC_TCL)) + value = 1; +#else + value = (geteuid() == buf.st_uid); +#endif + } + Tcl_SetBooleanObj(resultPtr, value); + return TCL_OK; + } + case FILE_PATHTYPE: { + char *fileName; - if (fileName == NULL) { - result = TCL_ERROR; - goto done; - } - - switch (index) { - case FILE_ATIME: - if (objc != 3) { - errorString = "atime name"; - goto not3Args; - } - - if (TclStat(fileName, &statBuf) == -1) { - goto badStat; - } - Tcl_SetLongObj(resultPtr, (long) statBuf.st_atime); - goto done; - case FILE_ISDIRECTORY: - if (objc != 3) { - errorString = "isdirectory name"; - goto not3Args; - } - statOp = 2; - break; - case FILE_ISFILE: - if (objc != 3) { - errorString = "isfile name"; - goto not3Args; - } - statOp = 1; - break; - case FILE_LSTAT: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "lstat name varName"); - result = TCL_ERROR; - goto done; - } - - if (lstat(fileName, &statBuf) == -1) { - Tcl_AppendStringsToObj(resultPtr, "couldn't lstat \"", - Tcl_GetStringFromObj(objv[2], &length), "\": ", - Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; - } - result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3], - &length), &statBuf); - goto done; - case FILE_MTIME: if (objc != 3) { - errorString = "mtime name"; - goto not3Args; + goto only3Args; } - if (TclStat(fileName, &statBuf) == -1) { - goto badStat; + fileName = Tcl_GetString(objv[2]); + switch (Tcl_GetPathType(fileName)) { + case TCL_PATH_ABSOLUTE: + Tcl_SetStringObj(resultPtr, "absolute", -1); + break; + case TCL_PATH_RELATIVE: + Tcl_SetStringObj(resultPtr, "relative", -1); + break; + case TCL_PATH_VOLUME_RELATIVE: + Tcl_SetStringObj(resultPtr, "volumerelative", -1); + break; } - Tcl_SetLongObj(resultPtr, (long) statBuf.st_mtime); - goto done; - case FILE_OWNED: + return TCL_OK; + } + case FILE_READABLE: { if (objc != 3) { - errorString = "owned name"; - goto not3Args; - } - statOp = 0; - break; + goto only3Args; + } + return CheckAccess(interp, objv[2], R_OK); + } case FILE_READLINK: { - char linkValue[MAXPATHLEN + 1]; - int linkLength; + char *fileName, *contents; + Tcl_DString name, link; if (objc != 3) { - errorString = "readlink name"; - goto not3Args; + goto only3Args; + } + + fileName = Tcl_GetString(objv[2]); + fileName = Tcl_TranslateFileName(interp, fileName, &name); + if (fileName == NULL) { + return TCL_ERROR; } /* @@ -1086,97 +1087,301 @@ checkAccess: */ #ifndef S_IFLNK - linkLength = -1; + contents = NULL; errno = EINVAL; #else - linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1); + contents = TclpReadlink(fileName, &link); #endif /* S_IFLNK */ - if (linkLength == -1) { - Tcl_AppendStringsToObj(resultPtr, "couldn't readlink \"", - Tcl_GetStringFromObj(objv[2], &length), "\": ", + + Tcl_DStringFree(&name); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not readlink \"", + Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; + return TCL_ERROR; } - linkValue[linkLength] = 0; - Tcl_SetStringObj(resultPtr, linkValue, linkLength); - goto done; + Tcl_DStringResult(interp, &link); + return TCL_OK; } - case FILE_SIZE: + case FILE_RENAME: { + int result; + char **argv; + + argv = StringifyObjects(objc, objv); + result = TclFileRenameCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_ROOTNAME: { + int length; + char *fileName, *extension; + if (objc != 3) { - errorString = "size name"; - goto not3Args; + goto only3Args; } - if (TclStat(fileName, &statBuf) == -1) { - goto badStat; + fileName = Tcl_GetStringFromObj(objv[2], &length); + extension = TclGetExtension(fileName); + if (extension == NULL) { + Tcl_SetObjResult(interp, objv[2]); + } else { + Tcl_SetStringObj(resultPtr, fileName, + (int) (length - strlen(extension))); } - Tcl_SetLongObj(resultPtr, (long) statBuf.st_size); - goto done; - case FILE_STAT: + return TCL_OK; + } + case FILE_SIZE: { + struct stat buf; + + if (objc != 3) { + goto only3Args; + } + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetLongObj(resultPtr, (long) buf.st_size); + return TCL_OK; + } + case FILE_SPLIT: { + int i, argc; + char **argv; + char *fileName; + Tcl_Obj *objPtr; + + if (objc != 3) { + goto only3Args; + } + fileName = Tcl_GetString(objv[2]); + Tcl_SplitPath(fileName, &argc, &argv); + for (i = 0; i < argc; i++) { + objPtr = Tcl_NewStringObj(argv[i], -1); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); + } + ckfree((char *) argv); + return TCL_OK; + } + case FILE_STAT: { + char *varName; + struct stat buf; + if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); - result = TCL_ERROR; - goto done; + return TCL_ERROR; } - - if (TclStat(fileName, &statBuf) == -1) { -badStat: - Tcl_AppendStringsToObj(resultPtr, "couldn't stat \"", - Tcl_GetStringFromObj(objv[2], &length), - "\": ", Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; } - result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3], - &length), &statBuf); - goto done; - case FILE_TYPE: + varName = Tcl_GetString(objv[3]); + return StoreStatData(interp, varName, &buf); + } + case FILE_TAIL: { + int argc; + char **argv; + if (objc != 3) { - errorString = "type name"; - goto not3Args; + goto only3Args; } - if (lstat(fileName, &statBuf) == -1) { - goto badStat; + if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { + return TCL_ERROR; } - errorString = GetTypeFromMode((int) statBuf.st_mode); - Tcl_SetStringObj(resultPtr, errorString, -1); - goto done; - } - if (TclStat(fileName, &statBuf) == -1) { - Tcl_SetBooleanObj(resultPtr, 0); - goto done; - } - switch (statOp) { - case 0: /* - * For Windows and Macintosh, there are no user ids - * associated with a file, so we always return 1. + * Return the last component, unless it is the only component, + * and it is the root of an absolute path. */ -#if (defined(__WIN32__) || defined(MAC_TCL)) - mode = 1; -#else - mode = (geteuid() == statBuf.st_uid); -#endif - break; - case 1: - mode = S_ISREG(statBuf.st_mode); - break; - case 2: - mode = S_ISDIR(statBuf.st_mode); - break; + if (argc > 0) { + if ((argc > 1) + || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetStringObj(resultPtr, argv[argc - 1], -1); + } + } + ckfree((char *) argv); + return TCL_OK; + } + case FILE_TYPE: { + struct stat buf; + + if (objc != 3) { + goto only3Args; + } + if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetStringObj(resultPtr, + GetTypeFromMode((unsigned short) buf.st_mode), -1); + return TCL_OK; + } + case FILE_VOLUMES: { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + return TclpListVolumes(interp); + } + case FILE_WRITABLE: { + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], W_OK); + } } - Tcl_SetBooleanObj(resultPtr, mode); -done: - Tcl_DStringFree(&buffer); - return result; + only3Args: + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * SplitPath -- + * + * Utility procedure used by Tcl_FileObjCmd() to split a path. + * Differs from standard Tcl_SplitPath in its handling of home + * directories; Tcl_SplitPath preserves the "~" while this + * procedure computes the actual full path name. + * + * Results: + * The return value is TCL_OK if the path could be split, TCL_ERROR + * otherwise. If TCL_ERROR was returned, an error message is left + * in interp. If TCL_OK was returned, *argvPtr is set to a newly + * allocated array of strings that represent the individual + * directories in the specified path, and *argcPtr is filled with + * the length of that array. + * + * Side effects: + * Memory allocated. The caller must eventually free this memory + * by calling ckfree() on *argvPtr. + * + *--------------------------------------------------------------------------- + */ + +static int +SplitPath(interp, objPtr, argcPtr, argvPtr) + Tcl_Interp *interp; /* Interp for error return. May be NULL. */ + Tcl_Obj *objPtr; /* Path to be split. */ + int *argcPtr; /* Filled with length of following array. */ + char ***argvPtr; /* Filled with array of strings representing + * the elements of the specified path. */ +{ + char *fileName; + + fileName = Tcl_GetString(objPtr); + + /* + * If there is only one element, and it starts with a tilde, + * perform tilde substitution and resplit the path. + */ + + Tcl_SplitPath(fileName, argcPtr, argvPtr); + if ((*argcPtr == 1) && (fileName[0] == '~')) { + Tcl_DString ds; + + ckfree((char *) *argvPtr); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SplitPath(fileName, argcPtr, argvPtr); + Tcl_DStringFree(&ds); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * CheckAccess -- + * + * Utility procedure used by Tcl_FileObjCmd() to query file + * attributes available through the access() system call. + * + * Results: + * Always returns TCL_OK. Sets interp's result to boolean true or + * false depending on whether the file has the specified attribute. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +CheckAccess(interp, objPtr, mode) + Tcl_Interp *interp; /* Interp for status return. Must not be + * NULL. */ + Tcl_Obj *objPtr; /* Name of file to check. */ + int mode; /* Attribute to check; passed as argument to + * access(). */ +{ + int value; + char *fileName; + Tcl_DString ds; + + fileName = Tcl_GetString(objPtr); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + value = 0; + } else { + value = (TclAccess(fileName, mode) == 0); + Tcl_DStringFree(&ds); + } + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); -not3Args: - Tcl_WrongNumArgs(interp, 1, objv, errorString); - result = TCL_ERROR; - goto done; + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * GetStatBuf -- + * + * Utility procedure used by Tcl_FileObjCmd() to query file + * attributes available through the stat() or lstat() system call. + * + * Results: + * The return value is TCL_OK if the specified file exists and can + * be stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an + * error message is left in interp's result. If TCL_OK is returned, + * *statPtr is filled with information about the specified file. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +GetStatBuf(interp, objPtr, statProc, statPtr) + Tcl_Interp *interp; /* Interp for error return. May be NULL. */ + Tcl_Obj *objPtr; /* Path name to examine. */ + StatProc *statProc; /* Either stat() or lstat() depending on + * desired behavior. */ + struct stat *statPtr; /* Filled with info about file obtained by + * calling (*statProc)(). */ +{ + char *fileName; + Tcl_DString ds; + int status; + + fileName = Tcl_GetString(objPtr); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; + } + + status = (*statProc)(Tcl_DStringValue(&ds), statPtr); + Tcl_DStringFree(&ds); + + if (status < 0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "could not read \"", + Tcl_GetString(objPtr), "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + return TCL_OK; } /* @@ -1190,7 +1395,7 @@ not3Args: * * Results: * Returns a standard Tcl return value. If an error occurs then - * a message is left in interp->result. + * a message is left in interp's result. * * Side effects: * Elements of the associative array given by "varName" are modified. @@ -1206,34 +1411,34 @@ StoreStatData(interp, varName, statPtr) struct stat *statPtr; /* Pointer to buffer containing * stat data to store in varName. */ { - char string[30]; + char string[TCL_INTEGER_SPACE]; - sprintf(string, "%ld", (long) statPtr->st_dev); + TclFormatInt(string, (long) statPtr->st_dev); if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_ino); + TclFormatInt(string, (long) statPtr->st_ino); if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_mode); + TclFormatInt(string, (unsigned short) statPtr->st_mode); if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_nlink); + TclFormatInt(string, (long) statPtr->st_nlink); if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_uid); + TclFormatInt(string, (long) statPtr->st_uid); if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_gid); + TclFormatInt(string, (long) statPtr->st_gid); if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; @@ -1243,24 +1448,24 @@ StoreStatData(interp, varName, statPtr) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_atime); + TclFormatInt(string, (long) statPtr->st_atime); if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_mtime); + TclFormatInt(string, (long) statPtr->st_mtime); if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_ctime); + TclFormatInt(string, (long) statPtr->st_ctime); if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } if (Tcl_SetVar2(interp, varName, "type", - GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) - == NULL) { + GetTypeFromMode((unsigned short) statPtr->st_mode), + TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } return TCL_OK; @@ -1312,7 +1517,7 @@ GetTypeFromMode(mode) /* *---------------------------------------------------------------------- * - * Tcl_ForCmd -- + * Tcl_FoObjCmd -- * * This procedure is invoked to process the "for" Tcl command. * See the user documentation for details on what it does. @@ -1333,21 +1538,20 @@ GetTypeFromMode(mode) /* ARGSUSED */ int -Tcl_ForCmd(dummy, interp, argc, argv) +Tcl_ForObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " start test next command\"", (char *) NULL); + if (objc != 5) { + Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); return TCL_ERROR; } - result = Tcl_Eval(interp, argv[1]); + result = Tcl_EvalObjEx(interp, objv[1], 0); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); @@ -1355,23 +1559,24 @@ Tcl_ForCmd(dummy, interp, argc, argv) return result; } while (1) { - result = Tcl_ExprBoolean(interp, argv[2], &value); + result = Tcl_ExprBooleanObj(interp, objv[2], &value); if (result != TCL_OK) { return result; } if (!value) { break; } - result = Tcl_Eval(interp, argv[4]); + result = Tcl_EvalObjEx(interp, objv[4], 0); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { - char msg[60]; + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine); Tcl_AddErrorInfo(interp, msg); } break; } - result = Tcl_Eval(interp, argv[3]); + result = Tcl_EvalObjEx(interp, objv[3], 0); if (result == TCL_BREAK) { break; } else if (result != TCL_OK) { @@ -1490,7 +1695,6 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) /* * Break up the value lists and variable lists into elements - * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE. */ maxj = 0; @@ -1562,8 +1766,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) valuePtr = Tcl_NewObj(); /* empty string */ isEmptyObj = 1; } - varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL, - valuePtr, TCL_PARSE_PART1); + varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], + NULL, valuePtr, 0); if (varValuePtr == NULL) { if (isEmptyObj) { Tcl_DecrRefCount(valuePtr); @@ -1571,8 +1775,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "couldn't set loop variable: \"", - Tcl_GetStringFromObj(varvList[i][v], (int *) NULL), - "\"", (char *) NULL); + Tcl_GetString(varvList[i][v]), "\"", (char *) NULL); result = TCL_ERROR; goto done; } @@ -1580,7 +1783,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) } } - result = Tcl_EvalObj(interp, bodyPtr); + result = Tcl_EvalObjEx(interp, bodyPtr, 0); if (result != TCL_OK) { if (result == TCL_CONTINUE) { result = TCL_OK; @@ -1588,7 +1791,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) result = TCL_OK; break; } else if (result == TCL_ERROR) { - char msg[100]; + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"foreach\" body line %d)", interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); @@ -1643,10 +1847,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - register char *format; /* Used to read characters from the format + char *format; /* Used to read characters from the format * string. */ int formatLen; /* The length of the format string */ - char *endPtr; /* Points to the last char in format array */ + char *endPtr; /* Points to the last char in format array */ char newFormat[40]; /* A new format specifier is generated here. */ int width; /* Field width from field specifier, or 0 if * no width given. */ @@ -1666,8 +1870,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * sprintf, according to the following * definitions: */ # define INT_VALUE 0 -# define PTR_VALUE 1 -# define DOUBLE_VALUE 2 +# define CHAR_VALUE 1 +# define PTR_VALUE 2 +# define DOUBLE_VALUE 3 +# define STRING_VALUE 4 # define MAX_FLOAT_SIZE 320 Tcl_Obj *resultPtr; /* Where result is stored finally. */ @@ -1688,6 +1894,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * seen. */ int useShort; /* Value to be printed is short (half word). */ char *end; /* Used to locate end of numerical fields. */ + int stringLen = 0; /* Length of string in characters rather + * than bytes. Used for %s substitution. */ + int gotMinus; /* Non-zero indicates that a minus flag has + * been seen in the current field. */ + int gotPrecision; /* Non-zero indicates that a precision has + * been set for the current field. */ /* * This procedure is a bit nasty. The goal is to use sprintf to @@ -1695,7 +1907,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * 1. this procedure can't trust its arguments. * 2. we must be able to provide a large enough result area to hold * whatever's generated. This is hard to estimate. - * 2. there's no way to move the arguments from objv to the call + * 3. there's no way to move the arguments from objv to the call * to sprintf in a reasonable way. This is particularly nasty * because some of the arguments may be two-word values (doubles). * So, what happens here is to scan the format string one % group @@ -1703,12 +1915,11 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) */ if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, - "formatString ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?"); return TCL_ERROR; } - format = Tcl_GetStringFromObj(objv[1], &formatLen); + format = (char *) Tcl_GetStringFromObj(objv[1], &formatLen); endPtr = format + formatLen; resultPtr = Tcl_NewObj(); objIndex = 2; @@ -1717,6 +1928,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) register char *newPtr = newFormat; width = precision = noPercent = useShort = 0; + gotMinus = gotPrecision = 0; whichValue = PTR_VALUE; /* @@ -1748,7 +1960,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) *newPtr = '%'; newPtr++; format++; - if (isdigit(UCHAR(*format))) { + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ int tmp; /* @@ -1757,7 +1969,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * in the same format string. */ - tmp = strtoul(format, &end, 10); + tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */ if (*end != '$') { goto notXpg; } @@ -1782,21 +1994,30 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) xpgCheckDone: while ((*format == '-') || (*format == '#') || (*format == '0') || (*format == ' ') || (*format == '+')) { + if (*format == '-') { + gotMinus = 1; + } *newPtr = *format; newPtr++; format++; } - if (isdigit(UCHAR(*format))) { - width = strtoul(format, &end, 10); + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ + width = strtoul(format, &end, 10); /* INTL: Tcl source. */ format = end; } else if (*format == '*') { if (objIndex >= objc) { goto badIndex; } - if (Tcl_GetIntFromObj(interp, objv[objIndex], - &width) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &width) != TCL_OK) { goto fmtError; } + if (width < 0) { + width = -width; + *newPtr = '-'; + gotMinus = 1; + newPtr++; + } objIndex++; format++; } @@ -1812,7 +2033,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) width = 0; } if (width != 0) { - TclFormatInt(newPtr, width); + TclFormatInt(newPtr, width); /* INTL: printf format. */ while (*newPtr != 0) { newPtr++; } @@ -1821,23 +2042,24 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) *newPtr = '.'; newPtr++; format++; + gotPrecision = 1; } - if (isdigit(UCHAR(*format))) { - precision = strtoul(format, &end, 10); + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ + precision = strtoul(format, &end, 10); /* INTL: "C" locale. */ format = end; } else if (*format == '*') { if (objIndex >= objc) { goto badIndex; } - if (Tcl_GetIntFromObj(interp, objv[objIndex], - &precision) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &precision) != TCL_OK) { goto fmtError; } objIndex++; format++; } - if (precision != 0) { - TclFormatInt(newPtr, precision); + if (gotPrecision) { + TclFormatInt(newPtr, precision); /* INTL: printf format. */ while (*newPtr != 0) { newPtr++; } @@ -1864,31 +2086,47 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) case 'u': case 'x': case 'X': - if (Tcl_GetIntFromObj(interp, objv[objIndex], - (int *) &intValue) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } whichValue = INT_VALUE; size = 40 + precision; break; case 's': + /* + * Compute the length of the string in characters and add + * any additional space required by the field width. All of + * the extra characters will be spaces, so one byte per + * character is adequate. + */ + + whichValue = STRING_VALUE; ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size); + stringLen = Tcl_NumUtfChars(ptrValue, size); + if (gotPrecision && (precision < stringLen)) { + stringLen = precision; + } + size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; + if (width > stringLen) { + size += (width - stringLen); + } break; case 'c': - if (Tcl_GetIntFromObj(interp, objv[objIndex], - (int *) &intValue) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } - whichValue = INT_VALUE; - size = 1; + whichValue = CHAR_VALUE; + size = width + TCL_UTF_MAX; break; case 'e': case 'E': case 'f': case 'g': case 'G': - if (Tcl_GetDoubleFromObj(interp, objv[objIndex], - &doubleValue) != TCL_OK) { + if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &doubleValue) != TCL_OK) { goto fmtError; } whichValue = DOUBLE_VALUE; @@ -1902,13 +2140,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) "format string ended in middle of field specifier", TCL_STATIC); goto fmtError; - default: - { - char buf[40]; - sprintf(buf, "bad field specifier \"%c\"", *format); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - goto fmtError; - } + default: { + char buf[40]; + sprintf(buf, "bad field specifier \"%c\"", *format); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + goto fmtError; + } } objIndex++; format++; @@ -1932,17 +2169,68 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) dst = (char *) ckalloc((unsigned) (size + 1)); dstSize = size; } + switch (whichValue) { + case DOUBLE_VALUE: { + sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */ + break; + } + case INT_VALUE: { + if (useShort) { + sprintf(dst, newFormat, (short) intValue); + } else { + sprintf(dst, newFormat, intValue); + } + break; + } + case CHAR_VALUE: { + char *ptr; + ptr = dst; + if (!gotMinus) { + for ( ; --width > 0; ptr++) { + *ptr = ' '; + } + } + ptr += Tcl_UniCharToUtf(intValue, ptr); + for ( ; --width > 0; ptr++) { + *ptr = ' '; + } + *ptr = '\0'; + break; + } + case STRING_VALUE: { + char *ptr; + int pad; + + ptr = dst; + if (width > stringLen) { + pad = width - stringLen; + } else { + pad = 0; + } - if (whichValue == DOUBLE_VALUE) { - sprintf(dst, newFormat, doubleValue); - } else if (whichValue == INT_VALUE) { - if (useShort) { - sprintf(dst, newFormat, (short) intValue); - } else { - sprintf(dst, newFormat, intValue); + if (!gotMinus) { + while (pad > 0) { + *ptr++ = ' '; + pad--; + } + } + + size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; + if (size) { + memcpy(ptr, ptrValue, (size_t) size); + ptr += size; + } + while (pad > 0) { + *ptr++ = ' '; + pad--; + } + *ptr = '\0'; + break; + } + default: { + sprintf(dst, newFormat, ptrValue); + break; } - } else { - sprintf(dst, newFormat, ptrValue); } Tcl_AppendToObj(resultPtr, dst, -1); } @@ -1975,3 +2263,43 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } + +/* + *--------------------------------------------------------------------------- + * + * StringifyObjects -- + * + * Helper function to bridge the gap between an object-based procedure + * and an older string-based procedure. + * + * Given an array of objects, allocate an array that consists of the + * string representations of those objects. + * + * Results: + * The return value is a pointer to the newly allocated array of + * strings. Elements 0 to (objc-1) of the string array point to the + * string representation of the corresponding element in the source + * object array; element objc of the string array is NULL. + * + * Side effects: + * Memory allocated. The caller must eventually free this memory + * by calling ckfree() on the return value. + * + *--------------------------------------------------------------------------- + */ + +static char ** +StringifyObjects(objc, objv) + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int i; + char **argv; + + argv = (char **) ckalloc((objc + 1) * sizeof(char *)); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); + } + argv[i] = NULL; + return argv; +} diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 25b563b..6db0c53 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -14,12 +14,13 @@ * 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.11 1999/02/03 00:55:04 stanton Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.12 1999/04/16 00:46:43 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclCompile.h" +#include "tclRegexp.h" /* * During execution of the "lsort" command, structures of the following @@ -45,7 +46,7 @@ typedef struct SortInfo { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* * values defined below */ - Tcl_DString compareCmd; /* The Tcl comparison command when sortMode + Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode * is SORTMODE_COMMAND. Pre-initialized to * hold base of command.*/ int index; /* If the -index option was specified, this @@ -149,7 +150,7 @@ static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr, /* *---------------------------------------------------------------------- * - * Tcl_IfCmd -- + * Tcl_IfObjCmd -- * * This procedure is invoked to process the "if" Tcl command. * See the user documentation for details on what it does. @@ -169,44 +170,55 @@ static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr, /* ARGSUSED */ int -Tcl_IfCmd(dummy, interp, argc, argv) +Tcl_IfObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { + int thenScriptIndex = 0; /* then script to be evaled after syntax check */ int i, result, value; - + char *clause; i = 1; while (1) { /* - * At this point in the loop, argv and argc refer to an expression + * At this point in the loop, objv and objc refer to an expression * to test, either for the main expression or an expression * following an "elseif". The arguments after the expression must * be "then" (optional) and a script to execute if the expression is * true. */ - if (i >= argc) { + if (i >= objc) { + clause = Tcl_GetString(objv[i-1]); Tcl_AppendResult(interp, "wrong # args: no expression after \"", - argv[i-1], "\" argument", (char *) NULL); + clause, "\" argument", (char *) NULL); return TCL_ERROR; } - result = Tcl_ExprBoolean(interp, argv[i], &value); - if (result != TCL_OK) { - return result; + if (!thenScriptIndex) { + result = Tcl_ExprBooleanObj(interp, objv[i], &value); + if (result != TCL_OK) { + return result; + } } i++; - if ((i < argc) && (strcmp(argv[i], "then") == 0)) { - i++; - } - if (i >= argc) { + if (i >= objc) { + missingScript: + clause = Tcl_GetString(objv[i-1]); Tcl_AppendResult(interp, "wrong # args: no script following \"", - argv[i-1], "\" argument", (char *) NULL); + clause, "\" argument", (char *) NULL); return TCL_ERROR; } + clause = Tcl_GetString(objv[i]); + if ((i < objc) && (strcmp(clause, "then") == 0)) { + i++; + } + if (i >= objc) { + goto missingScript; + } if (value) { - return Tcl_Eval(interp, argv[i]); + thenScriptIndex = i; + value = 0; } /* @@ -215,10 +227,14 @@ Tcl_IfCmd(dummy, interp, argc, argv) */ i++; - if (i >= argc) { + if (i >= objc) { + if (thenScriptIndex) { + return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + } return TCL_OK; } - if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) { + clause = Tcl_GetString(objv[i]); + if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) { i++; continue; } @@ -231,22 +247,31 @@ Tcl_IfCmd(dummy, interp, argc, argv) * argument when we get here. */ - if (strcmp(argv[i], "else") == 0) { + if (strcmp(clause, "else") == 0) { i++; - if (i >= argc) { + if (i >= objc) { Tcl_AppendResult(interp, "wrong # args: no script following \"else\" argument", (char *) NULL); return TCL_ERROR; } } - return Tcl_Eval(interp, argv[i]); + if (i < objc - 1) { + Tcl_AppendResult(interp, + "wrong # args: extra words after \"else\" clause in \"if\" command", + (char *) NULL); + return TCL_ERROR; + } + if (thenScriptIndex) { + return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + } + return Tcl_EvalObjEx(interp, objv[i], 0); } /* *---------------------------------------------------------------------- * - * Tcl_IncrCmd -- + * Tcl_IncrObjCmd -- * * This procedure is invoked to process the "incr" Tcl command. * See the user documentation for details on what it does. @@ -266,54 +291,49 @@ Tcl_IfCmd(dummy, interp, argc, argv) /* ARGSUSED */ int -Tcl_IncrCmd(dummy, interp, argc, argv) +Tcl_IncrObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int value; - char *oldString, *result; - char newString[30]; - - if ((argc != 2) && (argc != 3)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " varName ?increment?\"", (char *) NULL); + long incrAmount; + Tcl_Obj *newValuePtr; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); return TCL_ERROR; } - oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG); - if (oldString == NULL) { - return TCL_ERROR; - } - if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) { - Tcl_AddErrorInfo(interp, - "\n (reading value of variable to increment)"); - return TCL_ERROR; - } - if (argc == 2) { - value += 1; + /* + * Calculate the amount to increment by. + */ + + if (objc == 2) { + incrAmount = 1; } else { - int increment; - - if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) { - Tcl_AddErrorInfo(interp, - "\n (reading increment)"); + if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } - value += increment; } - TclFormatInt(newString, value); - result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG); - if (result == NULL) { + + /* + * Increment the variable's value. + */ + + newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount, + TCL_LEAVE_ERR_MSG); + if (newValuePtr == NULL) { return TCL_ERROR; } /* - * Copy the result since the variable's value might change. + * Set the interpreter's object result to refer to the variable's new + * value object. */ - - Tcl_SetResult(interp, result, TCL_VOLATILE); + + Tcl_SetObjResult(interp, newValuePtr); return TCL_OK; } @@ -355,8 +375,8 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx - } index; - int result; + }; + int index, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); @@ -472,7 +492,7 @@ InfoArgsCmd(dummy, interp, objc, objv) return TCL_ERROR; } - name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + name = Tcl_GetString(objv[2]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -533,7 +553,7 @@ InfoBodyCmd(dummy, interp, objc, objv) return TCL_ERROR; } - name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + name = Tcl_GetString(objv[2]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -664,8 +684,9 @@ InfoCommandsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); - TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + + pattern = Tcl_GetString(objv[2]); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); if (nsPtr != NULL) { /* we successfully found the pattern's ns */ @@ -812,8 +833,8 @@ InfoDefaultCmd(dummy, interp, objc, objv) return TCL_ERROR; } - procName = Tcl_GetStringFromObj(objv[2], (int *) NULL); - argName = Tcl_GetStringFromObj(objv[3], (int *) NULL); + procName = Tcl_GetString(objv[2]); + argName = Tcl_GetString(objv[3]); procPtr = TclFindProc(iPtr, procName); if (procPtr == NULL) { @@ -828,10 +849,10 @@ InfoDefaultCmd(dummy, interp, objc, objv) && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, - localPtr->defValuePtr, 0); + localPtr->defValuePtr, 0); if (valueObjPtr == NULL) { defStoreError: - varName = Tcl_GetStringFromObj(objv[4], (int *) NULL); + varName = Tcl_GetString(objv[4]); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "couldn't store default value in variable \"", varName, "\"", (char *) NULL); @@ -841,7 +862,7 @@ InfoDefaultCmd(dummy, interp, objc, objv) } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, - nullObjPtr, 0); + nullObjPtr, 0); if (valueObjPtr == NULL) { Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ goto defStoreError; @@ -893,9 +914,9 @@ InfoExistsCmd(dummy, interp, objc, objv) return TCL_ERROR; } - varName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + varName = Tcl_GetString(objv[2]); varPtr = TclLookupVar(interp, varName, (char *) NULL, - TCL_PARSE_PART1, "access", + 0, "access", /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) { Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); @@ -943,7 +964,7 @@ InfoGlobalsCmd(dummy, interp, objc, objv) if (objc == 2) { pattern = NULL; } else if (objc == 3) { - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + pattern = Tcl_GetString(objv[2]); } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; @@ -1064,7 +1085,7 @@ InfoLevelCmd(dummy, interp, objc, objv) levelError: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"", - Tcl_GetStringFromObj(objv[2], (int *) NULL), + Tcl_GetString(objv[2]), "\"", (char *) NULL); return TCL_ERROR; } @@ -1173,7 +1194,7 @@ InfoLoadedCmd(dummy, interp, objc, objv) if (objc == 2) { /* get loaded pkgs in all interpreters */ interpName = NULL; } else { /* get pkgs just in specified interp */ - interpName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + interpName = Tcl_GetString(objv[2]); } result = TclGetLoadedPackages(interp, interpName); return result; @@ -1214,7 +1235,7 @@ InfoLocalsCmd(dummy, interp, objc, objv) if (objc == 2) { pattern = NULL; } else if (objc == 3) { - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + pattern = Tcl_GetString(objv[2]); } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; @@ -1427,13 +1448,13 @@ InfoProcsCmd(dummy, interp, objc, objv) Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; - Command *cmdPtr; + Command *cmdPtr, *realCmdPtr; Tcl_Obj *listPtr; if (objc == 2) { pattern = NULL; } else if (objc == 3) { - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + pattern = Tcl_GetString(objv[2]); } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; @@ -1450,7 +1471,17 @@ InfoProcsCmd(dummy, interp, objc, objv) entryPtr = Tcl_NextHashEntry(&search)) { cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr); cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); - if (TclIsProc(cmdPtr)) { + + /* + * If the command isn't itself a proc, it still might be an + * imported command that points to a "real" proc in a different + * namespace. + */ + + realCmdPtr = (Command *) TclGetOriginalCommand( + (Tcl_Command) cmdPtr); + if (TclIsProc(cmdPtr) + || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) { if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(cmdName, -1)); @@ -1646,9 +1677,10 @@ InfoVarsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); - TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, - /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + pattern = Tcl_GetString(objv[2]); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, + &simplePattern); if (nsPtr != NULL) { /* we successfully found the pattern's ns */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); @@ -1913,7 +1945,7 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) Tcl_Obj *listPtr, *resultPtr; Tcl_ObjType *typePtr; int index, isDuplicate, len, result; - + if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?"); return TCL_ERROR; @@ -2247,7 +2279,7 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) && (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "list doesn't contain element ", - Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL); + Tcl_GetString(objv[2]), (int *) NULL); result = TCL_ERROR; goto errorReturn; } @@ -2303,19 +2335,20 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument values. */ { -#define EXACT 0 -#define GLOB 1 -#define REGEXP 2 char *bytes, *patternBytes; - int i, match, mode, index, result, listLen, length, elemLen; - Tcl_Obj **elemPtrs; - static char *switches[] = - {"-exact", "-glob", "-regexp", (char *) NULL}; - - mode = GLOB; + int i, match, mode, index, result, listc, length, elemLen; + Tcl_Obj *patObj, **listv; + static char *options[] = { + "-exact", "-glob", "-regexp", NULL + }; + enum options { + LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_REGEXP + }; + + mode = LSEARCH_GLOB; if (objc == 4) { - if (Tcl_GetIndexFromObj(interp, objv[1], switches, - "search mode", 0, &mode) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], options, "search mode", 0, + &mode) != TCL_OK) { return TCL_ERROR; } } else if (objc != 3) { @@ -2328,46 +2361,43 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) * a pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[objc-2], &listLen, &elemPtrs); + result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { return result; } - patternBytes = Tcl_GetStringFromObj(objv[objc-1], &length); - + patObj = objv[objc - 1]; + patternBytes = Tcl_GetStringFromObj(patObj, &length); + index = -1; - for (i = 0; i < listLen; i++) { + for (i = 0; i < listc; i++) { match = 0; - bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen); - switch (mode) { - case EXACT: + bytes = Tcl_GetStringFromObj(listv[i], &elemLen); + switch ((enum options) mode) { + case LSEARCH_EXACT: { if (length == elemLen) { match = (memcmp(bytes, patternBytes, (size_t) length) == 0); } break; - case GLOB: - /* - * WARNING: will not work with data containing NULLs. - */ + } + case LSEARCH_GLOB: { match = Tcl_StringMatch(bytes, patternBytes); break; - case REGEXP: - /* - * WARNING: will not work with data containing NULLs. - */ - match = Tcl_RegExpMatch(interp, bytes, patternBytes); + } + case LSEARCH_REGEXP: { + match = TclRegExpMatchObj(interp, bytes, patObj); if (match < 0) { return TCL_ERROR; } break; + } } - if (match) { + if (match != 0) { index = i; break; } } - Tcl_SetIntObj(Tcl_GetObjResult(interp), index); return TCL_OK; } @@ -2396,7 +2426,7 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument values. */ { - int i, index, dummy; + int i, index; Tcl_Obj *resultPtr; int length; Tcl_Obj *cmdPtr, **listObjPtrs; @@ -2477,9 +2507,21 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) } } if (sortInfo.sortMode == SORTMODE_COMMAND) { - Tcl_DStringInit(&sortInfo.compareCmd); - Tcl_DStringAppend(&sortInfo.compareCmd, - Tcl_GetStringFromObj(cmdPtr, &dummy), -1); + /* + * The existing command is a list. We want to flatten it, append + * two dummy arguments on the end, and replace these arguments + * later. + */ + + Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); + + if (Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()) + != TCL_OK) { + return TCL_ERROR; + } + Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); + sortInfo.compareCmdPtr = newCommandPtr; + Tcl_IncrRefCount(newCommandPtr); } sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1], @@ -2513,7 +2555,8 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) done: if (sortInfo.sortMode == SORTMODE_COMMAND) { - Tcl_DStringFree(&sortInfo.compareCmd); + Tcl_DecrRefCount(sortInfo.compareCmdPtr); + sortInfo.compareCmdPtr = NULL; } return sortInfo.resultCode; } @@ -2666,9 +2709,9 @@ SortCompare(objPtr1, objPtr2, infoPtr) SortInfo *infoPtr; /* Information passed from the * top-level "lsort" command */ { - int order, dummy, listLen, index; + int order, listLen, index; Tcl_Obj *objPtr; - char buffer[30]; + char buffer[TCL_INTEGER_SPACE]; order = 0; if (infoPtr->resultCode != TCL_OK) { @@ -2705,11 +2748,10 @@ SortCompare(objPtr1, objPtr2, infoPtr) if (objPtr == NULL) { objPtr = objPtr1; missingElement: - sprintf(buffer, "%d", infoPtr->index); + TclFormatInt(buffer, infoPtr->index); Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), "element ", buffer, " missing from sublist \"", - Tcl_GetStringFromObj(objPtr, (int *) NULL), - "\"", (char *) NULL); + Tcl_GetString(objPtr), "\"", (char *) NULL); infoPtr->resultCode = TCL_ERROR; return order; } @@ -2737,12 +2779,10 @@ SortCompare(objPtr1, objPtr2, infoPtr) objPtr2 = objPtr; } if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(Tcl_GetStringFromObj(objPtr1, &dummy), - Tcl_GetStringFromObj(objPtr2, &dummy)); + order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { order = DictionaryCompare( - Tcl_GetStringFromObj(objPtr1, &dummy), - Tcl_GetStringFromObj(objPtr2, &dummy)); + Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { int a, b; @@ -2772,22 +2812,26 @@ SortCompare(objPtr1, objPtr2, infoPtr) order = -1; } } else { - int oldLength; + Tcl_Obj **objv, *paramObjv[2]; + int objc; - /* - * Generate and evaluate a command to determine which string comes - * first. + paramObjv[0] = objPtr1; + paramObjv[1] = objPtr2; + + /* + * We made space in the command list for the two things to + * compare. Replace them and evaluate the result. */ - oldLength = Tcl_DStringLength(&infoPtr->compareCmd); - Tcl_DStringAppendElement(&infoPtr->compareCmd, - Tcl_GetStringFromObj(objPtr1, &dummy)); - Tcl_DStringAppendElement(&infoPtr->compareCmd, - Tcl_GetStringFromObj(objPtr2, &dummy)); - infoPtr->resultCode = Tcl_Eval(infoPtr->interp, - Tcl_DStringValue(&infoPtr->compareCmd)); - Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength); - if (infoPtr->resultCode != TCL_OK) { + Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); + Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, + 2, 2, paramObjv); + Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, + &objc, &objv); + + infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); + + if (infoPtr->resultCode != TCL_OK) { Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)"); return order; @@ -2840,11 +2884,13 @@ static int DictionaryCompare(left, right) char *left, *right; /* The strings to compare */ { + Tcl_UniChar uniLeft, uniRight; int diff, zeros; int secondaryDiff = 0; while (1) { - if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) { + if (isdigit(UCHAR(*right)) /* INTL: digit */ + && isdigit(UCHAR(*left))) { /* INTL: digit */ /* * There are decimal numbers embedded in the two * strings. Compare them as numbers, rather than @@ -2880,8 +2926,8 @@ DictionaryCompare(left, right) } right++; left++; - if (!isdigit(UCHAR(*right))) { - if (isdigit(UCHAR(*left))) { + if (!isdigit(UCHAR(*right))) { /* INTL: digit */ + if (isdigit(UCHAR(*left))) { /* INTL: digit */ return 1; } else { /* @@ -2894,23 +2940,40 @@ DictionaryCompare(left, right) } break; } - } else if (!isdigit(UCHAR(*left))) { + } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ return -1; } } continue; } - diff = UCHAR(*left) - UCHAR(*right); + + /* + * Convert character to Unicode for comparison purposes. If either + * string is at the terminating null, do a byte-wise comparison and + * bail out immediately. + */ + + if ((*left != '\0') && (*right != '\0')) { + left += Tcl_UtfToUniChar(left, &uniLeft); + right += Tcl_UtfToUniChar(right, &uniRight); + } else { + diff = UCHAR(*left) - UCHAR(*right); + break; + } + + diff = uniLeft - uniRight; if (diff) { - if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) { - diff = UCHAR(tolower(*left)) - UCHAR(*right); - if (diff) { + if (Tcl_UniCharIsUpper(uniLeft) && + Tcl_UniCharIsLower(uniRight)) { + diff = Tcl_UniCharToLower(uniLeft) - uniRight; + if (diff) { return diff; } else if (secondaryDiff == 0) { secondaryDiff = -1; } - } else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) { - diff = UCHAR(*left) - UCHAR(tolower(UCHAR(*right))); + } else if (Tcl_UniCharIsUpper(uniRight) + && Tcl_UniCharIsLower(uniLeft)) { + diff = uniLeft - Tcl_UniCharToLower(uniRight); if (diff) { return diff; } else if (secondaryDiff == 0) { @@ -2920,11 +2983,6 @@ DictionaryCompare(left, right) return diff; } } - if (*left == 0) { - break; - } - left++; - right++; } if (diff == 0) { diff = secondaryDiff; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 53583a8..38a3f8d 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -8,16 +8,34 @@ * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 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: tclCmdMZ.c,v 1.2 1998/09/14 18:39:57 stanton Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.3 1999/04/16 00:46:43 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclCompile.h" +#include "tclRegexp.h" + +/* + * Flag values used by Tcl_ScanObjCmd. + */ + +#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ +#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ +#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ +#define SCAN_WIDTH 0x8 /* A width value was supplied. */ + +#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */ +#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */ +#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */ +#define SCAN_XOK 0x80 /* An 'x' is allowed. */ +#define SCAN_PTOK 0x100 /* Decimal point is allowed. */ +#define SCAN_EXPOK 0x200 /* An exponent is allowed. */ /* * Structure used to hold information about variable traces: @@ -28,7 +46,7 @@ typedef struct { * to be invoked. */ char *errMsg; /* Error message returned from Tcl command, * or NULL. Malloc'ed. */ - int length; /* Number of non-NULL chars. in command. */ + size_t length; /* Number of non-NULL chars. in command. */ char command[4]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to * hold command. This field must be the @@ -47,7 +65,7 @@ static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, /* *---------------------------------------------------------------------- * - * Tcl_PwdCmd -- + * Tcl_PwdObjCmd -- * * This procedure is invoked to process the "pwd" Tcl command. * See the user documentation for details on what it does. @@ -63,35 +81,35 @@ static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, /* ARGSUSED */ int -Tcl_PwdCmd(dummy, interp, argc, argv) +Tcl_PwdObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *dirName; + Tcl_DString ds; - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], "\"", (char *) NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - dirName = TclGetCwd(interp); - if (dirName == NULL) { + if (Tcl_GetCwd(interp, &ds) == NULL) { return TCL_ERROR; } - Tcl_SetResult(interp, dirName, TCL_VOLATILE); + Tcl_DStringResult(interp, &ds); return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_RegexpCmd -- + * Tcl_RegexpObjCmd -- * * This procedure is invoked to process the "regexp" Tcl command. - * See the user documentation for details on what it does. + * See the user documentation for details on what it does. The + * REGEXP_TEST stuff is to minimize code differences between this + * and the "testregexp" command. * * Results: * A standard Tcl result. @@ -104,96 +122,124 @@ Tcl_PwdCmd(dummy, interp, argc, argv) /* ARGSUSED */ int -Tcl_RegexpCmd(dummy, interp, argc, argv) +Tcl_RegexpObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int noCase = 0; - int indices = 0; + int i, result, indices, stringLength, wLen, match, about; + int cflags, eflags; Tcl_RegExp regExpr; - char **argPtr, *string, *pattern, *start, *end; - int match = 0; /* Initialization needed only to - * prevent compiler warning. */ - int i; - Tcl_DString stringDString, patternDString; - - if (argc < 3) { - wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? exp string ?matchVar? ?subMatchVar ", - "subMatchVar ...?\"", (char *) NULL); - return TCL_ERROR; - } - argPtr = argv+1; - argc--; - while ((argc > 0) && (argPtr[0][0] == '-')) { - if (strcmp(argPtr[0], "-indices") == 0) { - indices = 1; - } else if (strcmp(argPtr[0], "-nocase") == 0) { - noCase = 1; - } else if (strcmp(argPtr[0], "--") == 0) { - argPtr++; - argc--; + char *string; + Tcl_DString stringBuffer, valueBuffer; + Tcl_UniChar *wStart; + static char *options[] = { + "-indices", "-nocase", "-about", "-expanded", + "-line", "-linestop", "-lineanchor", + "--", (char *) NULL + }; + enum options { + REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED, + REGEXP_LINE, REGEXP_LINESTOP, REGEXP_LINEANCHOR, + REGEXP_LAST + }; + + indices = 0; + about = 0; + cflags = REG_ADVANCED; + eflags = 0; + + for (i = 1; i < objc; i++) { + char *name; + int index; + + name = Tcl_GetString(objv[i]); + if (name[0] != '-') { break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argPtr[0], - "\": must be -indices, -nocase, or --", (char *) NULL); + } + if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, + &index) != TCL_OK) { return TCL_ERROR; } - argPtr++; - argc--; - } - if (argc < 2) { - goto wrongNumArgs; - } - - /* - * Convert the string and pattern to lower case, if desired, and - * perform the matching operation. - */ - - if (noCase) { - register char *p; - - Tcl_DStringInit(&patternDString); - Tcl_DStringAppend(&patternDString, argPtr[0], -1); - pattern = Tcl_DStringValue(&patternDString); - for (p = pattern; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); + switch ((enum options) index) { + case REGEXP_INDICES: { + indices = 1; + break; } - } - Tcl_DStringInit(&stringDString); - Tcl_DStringAppend(&stringDString, argPtr[1], -1); - string = Tcl_DStringValue(&stringDString); - for (p = string; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); + case REGEXP_NOCASE: { + cflags |= REG_ICASE; + break; + } + case REGEXP_ABOUT: { + about = 1; + break; + } + case REGEXP_EXPANDED: { + cflags |= REG_EXPANDED; + break; + } + case REGEXP_LINE: { + cflags |= REG_NEWLINE; + break; + } + case REGEXP_LINESTOP: { + cflags |= REG_NLSTOP; + break; + } + case REGEXP_LINEANCHOR: { + cflags |= REG_NLANCH; + break; + } + case REGEXP_LAST: { + i++; + goto endOfForLoop; } } - } else { - pattern = argPtr[0]; - string = argPtr[1]; - } - regExpr = Tcl_RegExpCompile(interp, pattern); - if (regExpr != NULL) { - match = Tcl_RegExpExec(interp, regExpr, string, string); } - if (noCase) { - Tcl_DStringFree(&stringDString); - Tcl_DStringFree(&patternDString); + + endOfForLoop: + if (objc - i < 2 - about) { + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); + return TCL_ERROR; } + objc -= i; + objv += i; + + regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } + + if (about) { + if (TclRegAbout(interp, regExpr) < 0) { + return TCL_ERROR; + } + return TCL_OK; + } + + result = TCL_OK; + string = Tcl_GetStringFromObj(objv[1], &stringLength); + + Tcl_DStringInit(&valueBuffer); + + Tcl_DStringInit(&stringBuffer); + wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer); + wLen = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar); + + match = TclRegExpExecUniChar(interp, regExpr, wStart, wLen, objc-2, eflags); if (match < 0) { - return TCL_ERROR; + result = TCL_ERROR; + goto done; } - if (!match) { - Tcl_SetResult(interp, "0", TCL_STATIC); - return TCL_OK; + if (match == 0) { + /* + * Set the interpreter's object result to an integer object w/ value 0. + */ + + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + goto done; } /* @@ -201,51 +247,59 @@ Tcl_RegexpCmd(dummy, interp, argc, argv) * index information in those variables. */ - argc -= 2; - for (i = 0; i < argc; i++) { - char *result, info[50]; + objc -= 2; + objv += 2; + + for (i = 0; i < objc; i++) { + char *varName, *value; + int start, end; + + varName = Tcl_GetString(objv[i]); - Tcl_RegExpRange(regExpr, i, &start, &end); - if (start == NULL) { + TclRegExpRangeUniChar(regExpr, i, &start, &end); + if (start < 0) { if (indices) { - result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0); + value = Tcl_SetVar(interp, varName, "-1 -1", 0); } else { - result = Tcl_SetVar(interp, argPtr[i+2], "", 0); + value = Tcl_SetVar(interp, varName, "", 0); } } else { if (indices) { - sprintf(info, "%d %d", (int)(start - string), - (int)(end - string - 1)); - result = Tcl_SetVar(interp, argPtr[i+2], info, 0); + char info[TCL_INTEGER_SPACE * 2]; + + sprintf(info, "%d %d", start, end - 1); + value = Tcl_SetVar(interp, varName, info, 0); } else { - char savedChar, *first, *last; - - first = argPtr[1] + (start - string); - last = argPtr[1] + (end - string); - if (first == last) { /* don't modify argument */ - result = Tcl_SetVar(interp, argPtr[i+2], "", 0); - } else { - savedChar = *last; - *last = 0; - result = Tcl_SetVar(interp, argPtr[i+2], first, 0); - *last = savedChar; - } + value = Tcl_UniCharToUtfDString(wStart + start, end - start, + &valueBuffer); + value = Tcl_SetVar(interp, varName, value, 0); + Tcl_DStringSetLength(&valueBuffer, 0); } } - if (result == NULL) { + if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", - argPtr[i+2], "\"", (char *) NULL); - return TCL_ERROR; + varName, "\"", (char *) NULL); + result = TCL_ERROR; + goto done; } } - Tcl_SetResult(interp, "1", TCL_STATIC); - return TCL_OK; + + /* + * Set the interpreter's object result to an integer object w/ value 1. + */ + + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + + done: + Tcl_DStringFree(&stringBuffer); + Tcl_DStringFree(&valueBuffer); + return result; } /* *---------------------------------------------------------------------- * - * Tcl_RegsubCmd -- + * Tcl_RegsubObjCmd -- * * This procedure is invoked to process the "regsub" Tcl command. * See the user documentation for details on what it does. @@ -261,81 +315,74 @@ Tcl_RegexpCmd(dummy, interp, argc, argv) /* ARGSUSED */ int -Tcl_RegsubCmd(dummy, interp, argc, argv) +Tcl_RegsubObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int noCase = 0, all = 0; + int i, result, flags, all, stringLength, numMatches; Tcl_RegExp regExpr; - char *string, *pattern, *p, *firstChar, **argPtr; - int match, code, numMatches; - char *start, *end, *subStart, *subEnd; - register char *src, c; - Tcl_DString stringDString, patternDString, resultDString; - - if (argc < 5) { - wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? exp string subSpec varName\"", (char *) NULL); - return TCL_ERROR; - } - argPtr = argv+1; - argc--; - while (argPtr[0][0] == '-') { - if (strcmp(argPtr[0], "-nocase") == 0) { - noCase = 1; - } else if (strcmp(argPtr[0], "-all") == 0) { - all = 1; - } else if (strcmp(argPtr[0], "--") == 0) { - argPtr++; - argc--; + Tcl_DString resultBuffer, stringBuffer; + CONST Tcl_UniChar *w, *wStart, *wEnd; + char *string, *subspec, *varname; + static char *options[] = { + "-all", "-nocase", "--", NULL + }; + enum options { + REGSUB_ALL, REGSUB_NOCASE, REGSUB_LAST + }; + + flags = 0; + all = 0; + + for (i = 1; i < objc; i++) { + char *name; + int index; + + name = Tcl_GetString(objv[i]); + if (name[0] != '-') { break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argPtr[0], - "\": must be -all, -nocase, or --", (char *) NULL); + } + if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, + &index) != TCL_OK) { return TCL_ERROR; } - argPtr++; - argc--; - } - if (argc != 4) { - goto wrongNumArgs; - } - - /* - * Convert the string and pattern to lower case, if desired. - */ - - if (noCase) { - Tcl_DStringInit(&patternDString); - Tcl_DStringAppend(&patternDString, argPtr[0], -1); - pattern = Tcl_DStringValue(&patternDString); - for (p = pattern; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); + switch ((enum options) index) { + case REGSUB_ALL: { + all = 1; + break; } - } - Tcl_DStringInit(&stringDString); - Tcl_DStringAppend(&stringDString, argPtr[1], -1); - string = Tcl_DStringValue(&stringDString); - for (p = string; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); + case REGSUB_NOCASE: { + flags |= REG_ICASE; + break; + } + case REGSUB_LAST: { + i++; + goto endOfForLoop; } } - } else { - pattern = argPtr[0]; - string = argPtr[1]; } - Tcl_DStringInit(&resultDString); - regExpr = Tcl_RegExpCompile(interp, pattern); + endOfForLoop: + if (objc - i != 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? exp string subSpec varName"); + return TCL_ERROR; + } + + objv += i; + regExpr = Tcl_GetRegExpFromObj(interp, objv[0], flags | REG_ADVANCED); if (regExpr == NULL) { - code = TCL_ERROR; - goto done; + return TCL_ERROR; } + result = TCL_OK; + string = Tcl_GetStringFromObj(objv[1], &stringLength); + subspec = Tcl_GetString(objv[2]); + varname = Tcl_GetString(objv[3]); + + Tcl_DStringInit(&resultBuffer); + /* * The following loop is to handle multiple matches within the * same source string; each iteration handles one match and its @@ -343,25 +390,39 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) * then the loop body only gets executed once. */ + Tcl_DStringInit(&stringBuffer); + wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer); + wEnd = wStart + Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar); + numMatches = 0; - for (p = string; *p != 0; ) { - match = Tcl_RegExpExec(interp, regExpr, p, string); + for (w = wStart; w < wEnd; ) { + int start, end, subStart, subEnd, match; + char *src, *firstChar; + char c; + + /* + * The flags argument is set if string is part of a larger string, + * so that "^" won't match. + */ + + match = TclRegExpExecUniChar(interp, regExpr, w, wEnd - w, 10, + ((w > wStart) ? REG_NOTBOL : 0)); if (match < 0) { - code = TCL_ERROR; + result = TCL_ERROR; goto done; } - if (!match) { + if (match == 0) { break; } - numMatches += 1; + numMatches++; /* * Copy the portion of the source string before the match to the * result variable. */ - Tcl_RegExpRange(regExpr, 0, &start, &end); - Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), start - p); + TclRegExpRangeUniChar(regExpr, 0, &start, &end); + Tcl_UniCharToUtfDString(w, start, &resultBuffer); /* * Append the subSpec argument to the variable, making appropriate @@ -369,8 +430,10 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) * conventions and because the code saves up ranges of characters in * subSpec to reduce the number of calls to Tcl_SetVar. */ - - for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) { + + src = subspec; + firstChar = subspec; + for (c = *src; c != '\0'; src++, c = *src) { int index; if (c == '&') { @@ -380,12 +443,10 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) if ((c >= '0') && (c <= '9')) { index = c - '0'; } else if ((c == '\\') || (c == '&')) { - *src = c; - src[1] = 0; - Tcl_DStringAppend(&resultDString, firstChar, -1); - *src = '\\'; - src[1] = c; - firstChar = src+2; + Tcl_DStringAppend(&resultBuffer, firstChar, + src - firstChar); + Tcl_DStringAppend(&resultBuffer, &c, 1); + firstChar = src + 2; src++; continue; } else { @@ -395,42 +456,31 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) continue; } if (firstChar != src) { - c = *src; - *src = 0; - Tcl_DStringAppend(&resultDString, firstChar, -1); - *src = c; + Tcl_DStringAppend(&resultBuffer, firstChar, src - firstChar); } - Tcl_RegExpRange(regExpr, index, &subStart, &subEnd); - if ((subStart != NULL) && (subEnd != NULL)) { - char *first, *last, saved; - - first = argPtr[1] + (subStart - string); - last = argPtr[1] + (subEnd - string); - saved = *last; - *last = 0; - Tcl_DStringAppend(&resultDString, first, -1); - *last = saved; + TclRegExpRangeUniChar(regExpr, index, &subStart, &subEnd); + if ((subStart >= 0) && (subEnd >= 0)) { + Tcl_UniCharToUtfDString(w + subStart, subEnd - subStart, + &resultBuffer); } if (*src == '\\') { src++; } - firstChar = src+1; + firstChar = src + 1; } if (firstChar != src) { - Tcl_DStringAppend(&resultDString, firstChar, -1); + Tcl_DStringAppend(&resultBuffer, firstChar, src - firstChar); } - if (end == p) { - + if (end == 0) { /* * Always consume at least one character of the input string * in order to prevent infinite loops. */ - Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), 1); - p = end + 1; - } else { - p = end; + Tcl_UniCharToUtfDString(w, 1, &resultBuffer); + w++; } + w += end; if (!all) { break; } @@ -441,30 +491,27 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) * result variable. */ - if ((*p != 0) || (numMatches == 0)) { - Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), -1); + if ((w < wEnd) || (numMatches == 0)) { + Tcl_UniCharToUtfDString(w, wEnd - w, &resultBuffer); } - if (Tcl_SetVar(interp, argPtr[3], Tcl_DStringValue(&resultDString), 0) - == NULL) { - Tcl_AppendResult(interp, - "couldn't set variable \"", argPtr[3], "\"", + if (Tcl_SetVar(interp, varname, Tcl_DStringValue(&resultBuffer), + 0) == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", varname, "\"", (char *) NULL); - code = TCL_ERROR; + result = TCL_ERROR; } else { - char buf[40]; + /* + * Set the interpreter's object result to an integer object holding the + * number of matches. + */ - TclFormatInt(buf, numMatches); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - code = TCL_OK; + Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches); } done: - if (noCase) { - Tcl_DStringFree(&stringDString); - Tcl_DStringFree(&patternDString); - } - Tcl_DStringFree(&resultDString); - return code; + Tcl_DStringFree(&stringBuffer); + Tcl_DStringFree(&resultBuffer); + return result; } /* @@ -499,8 +546,8 @@ Tcl_RenameObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - oldName = Tcl_GetStringFromObj(objv[1], (int *) NULL); - newName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + oldName = Tcl_GetString(objv[1]); + newName = Tcl_GetString(objv[2]); return TclRenameCommand(interp, oldName, newName); } @@ -541,10 +588,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) iPtr->errorCode = NULL; } code = TCL_OK; - - /* - * THIS FAILS IF AN OBJECT CONTAINS AN EMBEDDED NULL. - */ for (objv++, objc--; objc > 1; objv += 2, objc -= 2) { char *option = Tcl_GetStringFromObj(objv[0], &optionLen); @@ -569,7 +612,7 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad completion code \"", - Tcl_GetStringFromObj(objv[1], (int *) NULL), + Tcl_GetString(objv[1]), "\": must be ok, error, return, break, ", "continue, or an integer", (char *) NULL); return result; @@ -607,310 +650,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_ScanCmd -- - * - * This procedure is invoked to process the "scan" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_ScanCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ -# define MAX_FIELDS 20 - typedef struct { - char fmt; /* Format for field. */ - int size; /* How many bytes to allow for - * field. */ - char *location; /* Where field will be stored. */ - } Field; - Field fields[MAX_FIELDS]; /* Info about all the fields in the - * format string. */ - register Field *curField; - int numFields = 0; /* Number of fields actually - * specified. */ - int suppress; /* Current field is assignment- - * suppressed. */ - int totalSize = 0; /* Number of bytes needed to store - * all results combined. */ - char *results; /* Where scanned output goes. - * Malloced; NULL means not allocated - * yet. */ - int numScanned; /* sscanf's result. */ - register char *fmt; - int i, widthSpecified, length, code; - char buf[40]; - - /* - * The variables below are used to hold a copy of the format - * string, so that we can replace format specifiers like "%f" - * and "%F" with specifiers like "%lf" - */ - -# define STATIC_SIZE 5 - char copyBuf[STATIC_SIZE], *fmtCopy; - register char *dst; - - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " string format ?varName varName ...?\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * This procedure operates in four stages: - * 1. Scan the format string, collecting information about each field. - * 2. Allocate an array to hold all of the scanned fields. - * 3. Call sscanf to do all the dirty work, and have it store the - * parsed fields in the array. - * 4. Pick off the fields from the array and assign them to variables. - */ - - code = TCL_OK; - results = NULL; - length = strlen(argv[2]) * 2 + 1; - if (length < STATIC_SIZE) { - fmtCopy = copyBuf; - } else { - fmtCopy = (char *) ckalloc((unsigned) length); - } - dst = fmtCopy; - for (fmt = argv[2]; *fmt != 0; fmt++) { - *dst = *fmt; - dst++; - if (*fmt != '%') { - continue; - } - fmt++; - if (*fmt == '%') { - *dst = *fmt; - dst++; - continue; - } - if (*fmt == '*') { - suppress = 1; - *dst = *fmt; - dst++; - fmt++; - } else { - suppress = 0; - } - widthSpecified = 0; - while (isdigit(UCHAR(*fmt))) { - widthSpecified = 1; - *dst = *fmt; - dst++; - fmt++; - } - if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) { - fmt++; - } - *dst = *fmt; - dst++; - if (suppress) { - continue; - } - if (numFields == MAX_FIELDS) { - Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC); - code = TCL_ERROR; - goto done; - } - curField = &fields[numFields]; - numFields++; - switch (*fmt) { - case 'd': - case 'i': - case 'o': - case 'x': - curField->fmt = 'd'; - curField->size = sizeof(int); - break; - - case 'u': - curField->fmt = 'u'; - curField->size = sizeof(int); - break; - - case 's': - curField->fmt = 's'; - curField->size = strlen(argv[1]) + 1; - break; - - case 'c': - if (widthSpecified) { - Tcl_SetResult(interp, - "field width may not be specified in %c conversion", - TCL_STATIC); - code = TCL_ERROR; - goto done; - } - curField->fmt = 'c'; - curField->size = sizeof(int); - break; - - case 'e': - case 'f': - case 'g': - dst[-1] = 'l'; - dst[0] = 'f'; - dst++; - curField->fmt = 'f'; - curField->size = sizeof(double); - break; - - case '[': - curField->fmt = 's'; - curField->size = strlen(argv[1]) + 1; - do { - fmt++; - if (*fmt == 0) { - Tcl_SetResult(interp, - "unmatched [ in format string", TCL_STATIC); - code = TCL_ERROR; - goto done; - } - *dst = *fmt; - dst++; - } while (*fmt != ']'); - break; - - default: - { - char buf[50]; - - sprintf(buf, "bad scan conversion character \"%c\"", *fmt); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - code = TCL_ERROR; - goto done; - } - } - curField->size = TCL_ALIGN(curField->size); - totalSize += curField->size; - } - *dst = 0; - - if (numFields != (argc-3)) { - Tcl_SetResult(interp, - "different numbers of variable names and field specifiers", - TCL_STATIC); - code = TCL_ERROR; - goto done; - } - - /* - * Step 2: - */ - - results = (char *) ckalloc((unsigned) totalSize); - for (i = 0, totalSize = 0, curField = fields; - i < numFields; i++, curField++) { - curField->location = results + totalSize; - totalSize += curField->size; - } - - /* - * Fill in the remaining fields with NULL; the only purpose of - * this is to keep some memory analyzers, like Purify, from - * complaining. - */ - - for ( ; i < MAX_FIELDS; i++, curField++) { - curField->location = NULL; - } - - /* - * Step 3: - */ - - numScanned = sscanf(argv[1], fmtCopy, - fields[0].location, fields[1].location, fields[2].location, - fields[3].location, fields[4].location, fields[5].location, - fields[6].location, fields[7].location, fields[8].location, - fields[9].location, fields[10].location, fields[11].location, - fields[12].location, fields[13].location, fields[14].location, - fields[15].location, fields[16].location, fields[17].location, - fields[18].location, fields[19].location); - - /* - * Step 4: - */ - - if (numScanned < numFields) { - numFields = numScanned; - } - for (i = 0, curField = fields; i < numFields; i++, curField++) { - switch (curField->fmt) { - char string[TCL_DOUBLE_SPACE]; - - case 'd': - TclFormatInt(string, *((int *) curField->location)); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - storeError: - Tcl_AppendResult(interp, - "couldn't set variable \"", argv[i+3], "\"", - (char *) NULL); - code = TCL_ERROR; - goto done; - } - break; - - case 'u': - sprintf(string, "%u", *((int *) curField->location)); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; - } - break; - - case 'c': - TclFormatInt(string, *((char *) curField->location) & 0xff); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; - } - break; - - case 's': - if (Tcl_SetVar(interp, argv[i+3], curField->location, 0) - == NULL) { - goto storeError; - } - break; - - case 'f': - Tcl_PrintDouble((Tcl_Interp *) NULL, - *((double *) curField->location), string); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; - } - break; - } - } - TclFormatInt(buf, numScanned); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - done: - if (results != NULL) { - ckfree(results); - } - if (fmtCopy != copyBuf) { - ckfree(fmtCopy); - } - return code; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SourceObjCmd -- * * This procedure is invoked to process the "source" Tcl command. @@ -941,11 +680,7 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - /* - * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL. - */ - - bytes = Tcl_GetStringFromObj(objv[1], (int *) NULL); + bytes = Tcl_GetString(objv[1]); result = Tcl_EvalFile(interp, bytes); return result; } @@ -975,10 +710,11 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - register char *p, *p2; - char *splitChars, *string, *elementStart; - int splitCharLen, stringLen, i, j; - Tcl_Obj *listPtr; + Tcl_UniChar ch; + int len; + char *splitChars, *string, *end; + int splitCharLen, stringLen; + Tcl_Obj *listPtr, *objPtr; if (objc == 2) { splitChars = " \n\t\r"; @@ -991,41 +727,50 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) } string = Tcl_GetStringFromObj(objv[1], &stringLen); - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + end = string + stringLen; + listPtr = Tcl_GetObjResult(interp); - /* - * Handle the special case of splitting on every character. - */ + if (stringLen == 0) { + /* + * Do nothing. + */ + } else if (splitCharLen == 0) { + /* + * Handle the special case of splitting on every character. + */ - if (splitCharLen == 0) { - for (i = 0, p = string; i < stringLen; i++, p++) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(p, 1)); + for ( ; string < end; string += len) { + len = Tcl_UtfToUniChar(string, &ch); + objPtr = Tcl_NewStringObj(string, len); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } } else { + char *element, *p, *splitEnd; + int splitLen; + Tcl_UniChar splitChar; + /* * Normal case: split on any of a given set of characters. * Discard instances of the split characters. */ - for (i = 0, p = elementStart = string; i < stringLen; i++, p++) { - for (j = 0, p2 = splitChars; j < splitCharLen; j++, p2++) { - if (*p2 == *p) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(elementStart, (p-elementStart))); - elementStart = p+1; + splitEnd = splitChars + splitCharLen; + + for (element = string; string < end; string += len) { + len = Tcl_UtfToUniChar(string, &ch); + for (p = splitChars; p < splitEnd; p += splitLen) { + splitLen = Tcl_UtfToUniChar(p, &splitChar); + if (ch == splitChar) { + objPtr = Tcl_NewStringObj(element, string - element); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); + element = string + len; break; } } } - if (p != string) { - int remainingChars = stringLen - (elementStart-string); - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(elementStart, remainingChars)); - } + objPtr = Tcl_NewStringObj(element, string - element); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } - - Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -1035,7 +780,9 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) * Tcl_StringObjCmd -- * * This procedure is invoked to process the "string" Tcl command. - * See the user documentation for details on what it does. + * See the user documentation for details on what it does. Note + * that this command only functions correctly on properly formed + * Tcl UTF strings. * * Results: * A standard Tcl result. @@ -1061,14 +808,14 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) static char *options[] = { "compare", "first", "index", "last", "length", "match", "range", "tolower", - "toupper", "trim", "trimleft", "trimright", - "wordend", "wordstart", NULL + "toupper", "totitle", "trim", "trimleft", + "trimright", "wordend", "wordstart", (char *) NULL }; enum options { STR_COMPARE, STR_FIRST, STR_INDEX, STR_LAST, STR_LENGTH, STR_MATCH, STR_RANGE, STR_TOLOWER, - STR_TOUPPER, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, - STR_WORDEND, STR_WORDSTART + STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT, + STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART }; if (objc < 2) { @@ -1112,43 +859,67 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } + /* + * This algorithm fails on improperly formed UTF strings. + */ + match = -1; string1 = Tcl_GetStringFromObj(objv[2], &length1); string2 = Tcl_GetStringFromObj(objv[3], &length2); if (length1 > 0) { end = string2 + length2 - length1 + 1; for (p = string2; p < end; p++) { - /* - * Scan forward to find the first character. - */ - - p = memchr(p, *string1, (unsigned) (end - p)); - if (p == NULL) { - break; - } - if (memcmp(string1, p, (unsigned) length1) == 0) { - match = p - string2; - break; - } + /* + * Scan forward to find the first character. + */ + + p = memchr(p, *string1, (unsigned) (end - p)); + if (p == NULL) { + break; + } + if (memcmp(string1, p, (unsigned) length1) == 0) { + match = p - string2; + break; + } } } + + /* + * Compute the character index of the matching string by counting + * the number of characters before the match. + */ + + if (match != -1) { + match = Tcl_NumUtfChars(string2, match); + } Tcl_SetIntObj(resultPtr, match); break; } case STR_INDEX: { int index; + Tcl_UniChar ch; + char buf[TCL_UTF_MAX]; + char *start, *end; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); return TCL_ERROR; } - string1 = Tcl_GetStringFromObj(objv[2], &length1); if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { return TCL_ERROR; } - if ((index >= 0) && (index < length1)) { - Tcl_SetStringObj(resultPtr, string1 + index, 1); + if (index >= 0) { + start = Tcl_GetStringFromObj(objv[2], &length1); + end = start + length1; + for ( ; start < end; index--) { + start += Tcl_UtfToUniChar(start, &ch); + if (index == 0) { + Tcl_SetStringObj(resultPtr, buf, + Tcl_UniCharToUtf(ch, buf)); + break; + } + } } break; } @@ -1160,6 +931,10 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) goto badFirstLastArgs; } + /* + * This algorithm fails on improperly formed UTF strings. + */ + match = -1; string1 = Tcl_GetStringFromObj(objv[2], &length1); string2 = Tcl_GetStringFromObj(objv[3], &length2); @@ -1178,6 +953,15 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) } } } + + /* + * Compute the character index of the matching string by counting + * the number of characters before the match. + */ + + if (match != -1) { + match = Tcl_NumUtfChars(string2, match); + } Tcl_SetIntObj(resultPtr, match); break; } @@ -1187,8 +971,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - (void) Tcl_GetStringFromObj(objv[2], &length1); - Tcl_SetIntObj(resultPtr, length1); + string1 = Tcl_GetStringFromObj(objv[2], &length1); + Tcl_SetIntObj(resultPtr, Tcl_NumUtfChars(string1, length1)); break; } case STR_MATCH: { @@ -1211,6 +995,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) } string1 = Tcl_GetStringFromObj(objv[2], &length1); + length1 = Tcl_NumUtfChars(string1, length1); if (TclGetIntForIndex(interp, objv[3], length1 - 1, &first) != TCL_OK) { return TCL_ERROR; @@ -1226,39 +1011,17 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) last = length1 - 1; } if (last >= first) { - Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1); - } - break; - } - case STR_TOLOWER: { - register char *p, *end; + char *start, *end; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); - return TCL_ERROR; - } - - string1 = Tcl_GetStringFromObj(objv[2], &length1); - - /* - * Since I know resultPtr is not a shared object, I can reach - * in and diddle the bytes in its string rep to convert them in - * place to lower case. - */ - - Tcl_SetStringObj(resultPtr, string1, length1); - string1 = Tcl_GetStringFromObj(resultPtr, &length1); - end = string1 + length1; - for (p = string1; p < end; p++) { - if (isupper(UCHAR(*p))) { - *p = (char) tolower(UCHAR(*p)); - } + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); + Tcl_SetStringObj(resultPtr, start, end - start); } break; } - case STR_TOUPPER: { - register char *p, *end; - + case STR_TOLOWER: + case STR_TOUPPER: + case STR_TOTITLE: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; @@ -1267,30 +1030,33 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) string1 = Tcl_GetStringFromObj(objv[2], &length1); /* - * Since I know resultPtr is not a shared object, I can reach - * in and diddle the bytes in its string rep to convert them in - * place to upper case. + * Since the result object is not a shared object, it is + * safe to copy the string into the result and do the + * conversion in place. The conversion may change the length + * of the string, so reset the length after conversion. */ Tcl_SetStringObj(resultPtr, string1, length1); - string1 = Tcl_GetStringFromObj(resultPtr, &length1); - end = string1 + length1; - for (p = string1; p < end; p++) { - if (islower(UCHAR(*p))) { - *p = (char) toupper(UCHAR(*p)); - } + if ((enum options) index == STR_TOLOWER) { + length1 = Tcl_UtfToLower(Tcl_GetStringFromObj(resultPtr, NULL)); + } else if ((enum options) index == STR_TOUPPER) { + length1 = Tcl_UtfToUpper(Tcl_GetStringFromObj(resultPtr, NULL)); + } else { + length1 = Tcl_UtfToTitle(Tcl_GetStringFromObj(resultPtr, NULL)); } + Tcl_SetObjLength(resultPtr, length1); break; - } + case STR_TRIM: { - char ch; + Tcl_UniChar ch, trim; register char *p, *end; char *check, *checkEnd; + int offset; left = 1; right = 1; - trim: + dotrim: if (objc == 4) { string2 = Tcl_GetStringFromObj(objv[3], &length2); } else if (objc == 3) { @@ -1305,16 +1071,26 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) if (left) { end = string1 + length1; - for (p = string1; p < end; p++) { - ch = *p; - for (check = string2; ; check++) { + /* + * The outer loop iterates over the string. The inner + * loop iterates over the trim characters. The loops + * terminate as soon as a non-trim character is discovered + * and string1 is left pointing at the first non-trim + * character. + */ + + for (p = string1; p < end; p += offset) { + offset = Tcl_UtfToUniChar(p, &ch); + + for (check = string2; ; ) { if (check >= checkEnd) { p = end; break; } - if (ch == *check) { - length1--; - string1++; + check += Tcl_UtfToUniChar(check, &trim); + if (ch == trim) { + length1 -= offset; + string1 += offset; break; } } @@ -1322,16 +1098,25 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) } if (right) { end = string1; + + /* + * The outer loop iterates over the string. The inner + * loop iterates over the trim characters. The loops + * terminate as soon as a non-trim character is discovered + * and length1 marks the last non-trim character. + */ + for (p = string1 + length1; p > end; ) { - p--; - ch = *p; - for (check = string2; ; check++) { + p = Tcl_UtfPrev(p, string1); + offset = Tcl_UtfToUniChar(p, &ch); + for (check = string2; ; ) { if (check >= checkEnd) { p = end; break; } - if (ch == *check) { - length1--; + check += Tcl_UtfToUniChar(check, &trim); + if (ch == trim) { + length1 -= offset; break; } } @@ -1343,15 +1128,18 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) case STR_TRIMLEFT: { left = 1; right = 0; - goto trim; + goto dotrim; } case STR_TRIMRIGHT: { left = 0; right = 1; - goto trim; + goto dotrim; } case STR_WORDEND: { - int cur, c; + int cur; + Tcl_UniChar ch; + char *p, *end; + int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); @@ -1365,23 +1153,30 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) if (index < 0) { index = 0; } - cur = length1; - if (index < length1) { - for (cur = index; cur < length1; cur++) { - c = UCHAR(string1[cur]); - if (!isalnum(c) && (c != '_')) { + numChars = Tcl_NumUtfChars(string1, length1); + if (index < numChars) { + p = Tcl_UtfAtIndex(string1, index); + end = string1+length1; + for (cur = index; p < end; cur++) { + p += Tcl_UtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { break; } } if (cur == index) { - cur = index + 1; + cur++; } + } else { + cur = numChars; } Tcl_SetIntObj(resultPtr, cur); break; } case STR_WORDSTART: { - int cur, c; + int cur; + Tcl_UniChar ch; + char *p; + int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); @@ -1392,16 +1187,19 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { return TCL_ERROR; } - if (index >= length1) { - index = length1 - 1; + numChars = Tcl_NumUtfChars(string1, length1); + if (index >= numChars) { + index = numChars - 1; } cur = 0; if (index > 0) { + p = Tcl_UtfAtIndex(string1, index); for (cur = index; cur >= 0; cur--) { - c = UCHAR(string1[cur]); - if (!isalnum(c) && (c != '_')) { + Tcl_UtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { break; } + p = Tcl_UtfPrev(p, string1); } if (cur != index) { cur += 1; @@ -1417,7 +1215,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_SubstCmd -- + * Tcl_SubstObjCmd -- * * This procedure is invoked to process the "subst" Tcl command. * See the user documentation for details on what it does. This @@ -1435,51 +1233,59 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_SubstCmd(dummy, interp, argc, argv) +Tcl_SubstObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { + static char *substOptions[] = { + "-nobackslashes", "-nocommands", "-novariables", (char *) NULL + }; + enum substOptions { + SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS + }; Interp *iPtr = (Interp *) interp; Tcl_DString result; char *p, *old, *value; - int code, count, doVars, doCmds, doBackslashes, i; - size_t length; - char c; + int optionIndex, code, count, doVars, doCmds, doBackslashes, i; /* * Parse command-line options. */ doVars = doCmds = doBackslashes = 1; - for (i = 1; i < (argc-1); i++) { - p = argv[i]; + for (i = 1; i < (objc-1); i++) { + p = Tcl_GetString(objv[i]); if (*p != '-') { break; } - length = strlen(p); - if (length < 4) { - badSwitch: - Tcl_AppendResult(interp, "bad switch \"", p, - "\": must be -nobackslashes, -nocommands, ", - "or -novariables", (char *) NULL); + if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, + "switch", 0, &optionIndex) != TCL_OK) { + return TCL_ERROR; } - if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) { - doBackslashes = 0; - } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) { - doCmds = 0; - } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) { - doVars = 0; - } else { - goto badSwitch; + switch (optionIndex) { + case SUBST_NOBACKSLASHES: { + doBackslashes = 0; + break; + } + case SUBST_NOCOMMANDS: { + doCmds = 0; + break; + } + case SUBST_NOVARS: { + doVars = 0; + break; + } + default: { + panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); + } } } - if (i != (argc-1)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?-nobackslashes? ?-nocommands? ?-novariables? string\"", - (char *) NULL); + if (i != (objc-1)) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } @@ -1489,16 +1295,18 @@ Tcl_SubstCmd(dummy, interp, argc, argv) */ Tcl_DStringInit(&result); - old = p = argv[i]; + old = p = Tcl_GetString(objv[i]); while (*p != 0) { switch (*p) { case '\\': if (doBackslashes) { + char buf[TCL_UTF_MAX]; + if (p != old) { Tcl_DStringAppend(&result, old, p-old); } - c = Tcl_Backslash(p, &count); - Tcl_DStringAppend(&result, &c, 1); + Tcl_DStringAppend(&result, buf, + Tcl_UtfBackslash(p, &count, buf)); p += count; old = p; } else { @@ -1579,122 +1387,92 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { -#define EXACT 0 -#define GLOB 1 -#define REGEXP 2 - int switchObjc, index; - Tcl_Obj *CONST *switchObjv; - Tcl_Obj *patternObj, *bodyObj; - char *string, *pattern, *body; - int splitObjs, length, patternLen, i, code, mode, matched, bodyIdx; - static char *switches[] = - {"-exact", "-glob", "-regexp", "--", (char *) NULL}; - - switchObjc = objc-1; - switchObjv = objv+1; - mode = EXACT; - - while (switchObjc > 0) { - string = Tcl_GetStringFromObj(switchObjv[0], &length); - if (*string != '-') { + int i, j, index, mode, matched, result; + char *string, *pattern; + static char *options[] = { + "-exact", "-glob", "-regexp", "--", + NULL + }; + enum options { + OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST + }; + + mode = OPT_EXACT; + for (i = 1; i < objc; i++) { + string = Tcl_GetString(objv[i]); + if (string[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, switchObjv[0], switches, - "option", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { - case 0: /* -exact */ - mode = EXACT; - break; - case 1: /* -glob */ - mode = GLOB; - break; - case 2: /* -regexp */ - mode = REGEXP; - break; - case 3: /* -- */ - switchObjc--; - switchObjv++; - goto doneWithSwitches; + if (index == OPT_LAST) { + i++; + break; } - switchObjc--; - switchObjv++; + mode = index; } - doneWithSwitches: - if (switchObjc < 2) { + if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? string pattern body ... ?default body?"); return TCL_ERROR; } - - string = Tcl_GetStringFromObj(switchObjv[0], &length); - switchObjc--; - switchObjv++; + + string = Tcl_GetString(objv[i]); + objc -= i + 1; + objv += i + 1; /* * If all of the pattern/command pairs are lumped into a single * argument, split them out again. */ - splitObjs = 0; - if (switchObjc == 1) { - code = Tcl_ListObjLength(interp, switchObjv[0], &switchObjc); - if (code != TCL_OK) { - return code; + if (objc == 1) { + Tcl_Obj **listv; + + if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { + return TCL_ERROR; } - splitObjs = 1; + objv = listv; } - for (i = 0; i < switchObjc; i += 2) { - if (i == (switchObjc-1)) { + for (i = 0; i < objc; i += 2) { + if (i == objc - 1) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "extra switch pattern with no body", -1); - code = TCL_ERROR; - goto done; + return TCL_ERROR; } /* * See if the pattern matches the string. */ - if (splitObjs) { - code = Tcl_ListObjIndex(interp, switchObjv[0], i, &patternObj); - if (code != TCL_OK) { - return code; - } - pattern = Tcl_GetStringFromObj(patternObj, &patternLen); - } else { - pattern = Tcl_GetStringFromObj(switchObjv[i], &patternLen); - } - + pattern = Tcl_GetString(objv[i]); matched = 0; - if ((*pattern == 'd') && (i == switchObjc-2) + if ((i == objc - 2) + && (*pattern == 'd') && (strcmp(pattern, "default") == 0)) { matched = 1; } else { - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL. - */ switch (mode) { - case EXACT: + case OPT_EXACT: matched = (strcmp(string, pattern) == 0); break; - case GLOB: + case OPT_GLOB: matched = Tcl_StringMatch(string, pattern); break; - case REGEXP: - matched = Tcl_RegExpMatch(interp, string, pattern); + case OPT_REGEXP: + matched = TclRegExpMatchObj(interp, string, objv[i]); if (matched < 0) { - code = TCL_ERROR; - goto done; + return TCL_ERROR; } break; } } - if (!matched) { + if (matched == 0) { continue; } @@ -1703,53 +1481,28 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) * that are "-". */ - for (bodyIdx = i+1; ; bodyIdx += 2) { - if (bodyIdx >= switchObjc) { + for (j = i + 1; ; j += 2) { + if (j >= objc) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "no body specified for pattern \"", pattern, "\"", (char *) NULL); - code = TCL_ERROR; - goto done; - } - - if (splitObjs) { - code = Tcl_ListObjIndex(interp, switchObjv[0], bodyIdx, - &bodyObj); - if (code != TCL_OK) { - return code; - } - } else { - bodyObj = switchObjv[bodyIdx]; + return TCL_ERROR; } - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL. - */ - body = Tcl_GetStringFromObj(bodyObj, &length); - if ((length != 1) || (body[0] != '-')) { + if (strcmp(Tcl_GetString(objv[j]), "-") != 0) { break; } } - code = Tcl_EvalObj(interp, bodyObj); - if (code == TCL_ERROR) { - char msg[100]; + result = Tcl_EvalObjEx(interp, objv[j], 0); + if (result == TCL_ERROR) { + char msg[100 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern, interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } - goto done; + return result; } - - /* - * Nothing matched: return nothing. - */ - - code = TCL_OK; - - done: - return code; -#undef EXACT -#undef GLOB -#undef REGEXP + return TCL_OK; } /* @@ -1800,7 +1553,7 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) i = count; TclpGetTime(&start); while (i-- > 0) { - result = Tcl_EvalObj(interp, objPtr); + result = Tcl_EvalObjEx(interp, objPtr, 0); if (result != TCL_OK) { return result; } @@ -1819,7 +1572,7 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_TraceCmd -- + * Tcl_TraceObjCmd -- * * This procedure is invoked to process the "trace" Tcl command. * See the user documentation for details on what it does. @@ -1835,160 +1588,186 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_TraceCmd(dummy, interp, argc, argv) +Tcl_TraceObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int c; + int optionIndex, commandLength; + char *name, *rwuOps, *command, *p; size_t length; + static char *traceOptions[] = { + "variable", "vdelete", "vinfo", (char *) NULL + }; + enum traceOptions { + TRACE_VARIABLE, TRACE_VDELETE, TRACE_VINFO + }; - if (argc < 2) { - Tcl_AppendResult(interp, "too few args: should be \"", - argv[0], " option [arg arg ...]\"", (char *) NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option [arg arg ...]"); return TCL_ERROR; } - c = argv[1][1]; - length = strlen(argv[1]); - if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0) - && (length >= 2)) { - char *p; - int flags, length; - TraceVarInfo *tvarPtr; - - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " variable name ops command\"", (char *) NULL); - return TCL_ERROR; - } - flags = 0; - for (p = argv[3] ; *p != 0; p++) { - if (*p == 'r') { - flags |= TCL_TRACE_READS; - } else if (*p == 'w') { - flags |= TCL_TRACE_WRITES; - } else if (*p == 'u') { - flags |= TCL_TRACE_UNSETS; - } else { - goto badOps; - } - } - if (flags == 0) { - goto badOps; - } + if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, + "option", 0, &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum traceOptions) optionIndex) { + case TRACE_VARIABLE: { + int flags; + TraceVarInfo *tvarPtr; + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } - length = strlen(argv[4]); - tvarPtr = (TraceVarInfo *) ckalloc((unsigned) - (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); - tvarPtr->flags = flags; - tvarPtr->errMsg = NULL; - tvarPtr->length = length; - flags |= TCL_TRACE_UNSETS; - strcpy(tvarPtr->command, argv[4]); - if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc, - (ClientData) tvarPtr) != TCL_OK) { - ckfree((char *) tvarPtr); - return TCL_ERROR; - } - } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length) - && (length >= 2)) == 0) { - char *p; - int flags, length; - TraceVarInfo *tvarPtr; - ClientData clientData; - - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " vdelete name ops command\"", (char *) NULL); - return TCL_ERROR; - } + flags = 0; + rwuOps = Tcl_GetString(objv[3]); + for (p = rwuOps; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else { + goto badOps; + } + } + if (flags == 0) { + goto badOps; + } - flags = 0; - for (p = argv[3] ; *p != 0; p++) { - if (*p == 'r') { - flags |= TCL_TRACE_READS; - } else if (*p == 'w') { - flags |= TCL_TRACE_WRITES; - } else if (*p == 'u') { + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + tvarPtr = (TraceVarInfo *) ckalloc((unsigned) + (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + + length + 1)); + tvarPtr->flags = flags; + tvarPtr->errMsg = NULL; + tvarPtr->length = length; flags |= TCL_TRACE_UNSETS; - } else { - goto badOps; + strcpy(tvarPtr->command, command); + name = Tcl_GetString(objv[2]); + if (Tcl_TraceVar(interp, name, flags, TraceVarProc, + (ClientData) tvarPtr) != TCL_OK) { + ckfree((char *) tvarPtr); + return TCL_ERROR; + } + break; } - } - if (flags == 0) { - goto badOps; - } + case TRACE_VDELETE: { + int flags; + TraceVarInfo *tvarPtr; + ClientData clientData; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } - /* - * Search through all of our traces on this variable to - * see if there's one with the given command. If so, then - * delete the first one that matches. - */ + flags = 0; + rwuOps = Tcl_GetString(objv[3]); + for (p = rwuOps; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else { + goto badOps; + } + } + if (flags == 0) { + goto badOps; + } - length = strlen(argv[4]); - clientData = 0; - while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, - TraceVarProc, clientData)) != 0) { - tvarPtr = (TraceVarInfo *) clientData; - if ((tvarPtr->length == length) && (tvarPtr->flags == flags) - && (strncmp(argv[4], tvarPtr->command, - (size_t) length) == 0)) { - Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS, - TraceVarProc, clientData); - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); + /* + * Search through all of our traces on this variable to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + tvarPtr = (TraceVarInfo *) clientData; + if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + && (strncmp(command, tvarPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS, + TraceVarProc, clientData); + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + break; + } } - ckfree((char *) tvarPtr); break; } - } - } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0) - && (length >= 2)) { - ClientData clientData; - char ops[4], *p; - char *prefix = "{"; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " vinfo name\"", (char *) NULL); - return TCL_ERROR; - } - clientData = 0; - while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, - TraceVarProc, clientData)) != 0) { - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; - p = ops; - if (tvarPtr->flags & TCL_TRACE_READS) { - *p = 'r'; - p++; - } - if (tvarPtr->flags & TCL_TRACE_WRITES) { - *p = 'w'; - p++; + case TRACE_VINFO: { + ClientData clientData; + char ops[4]; + Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; + } + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + + pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + p = ops; + if (tvarPtr->flags & TCL_TRACE_READS) { + *p = 'r'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + *p = 'w'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + *p = 'u'; + p++; + } + *p = '\0'; + + /* + * Build a pair (2-item list) with the ops string as + * the first obj element and the tvarPtr->command string + * as the second obj element. Append the pair (as an + * element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewStringObj(ops, -1); + Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); + elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); + Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; } - if (tvarPtr->flags & TCL_TRACE_UNSETS) { - *p = 'u'; - p++; + default: { + panic("Tcl_TraceObjCmd: bad option index to TraceOptions"); } - *p = '\0'; - Tcl_AppendResult(interp, prefix, (char *) NULL); - Tcl_AppendElement(interp, ops); - Tcl_AppendElement(interp, tvarPtr->command); - Tcl_AppendResult(interp, "}", (char *) NULL); - prefix = " {"; - } - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be variable, vdelete, or vinfo", - (char *) NULL); - return TCL_ERROR; } return TCL_OK; badOps: - Tcl_AppendResult(interp, "bad operations \"", argv[3], + Tcl_AppendResult(interp, "bad operations \"", rwuOps, "\": should be one or more of rwu", (char *) NULL); return TCL_ERROR; } @@ -2022,13 +1801,11 @@ TraceVarProc(clientData, interp, name1, name2, flags) int flags; /* OR-ed bits giving operation and other * information. */ { - Interp *iPtr = (Interp *) interp; + Tcl_SavedResult state; TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; char *result; int code; - Interp dummy; Tcl_DString cmd; - Tcl_Obj *saveObjPtr, *oldObjResultPtr; result = NULL; if (tvarPtr->errMsg != NULL) { @@ -2048,7 +1825,7 @@ TraceVarProc(clientData, interp, name1, name2, flags) name2 = ""; } Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); + Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, name2); if (flags & TCL_TRACE_READS) { @@ -2060,53 +1837,25 @@ TraceVarProc(clientData, interp, name1, name2, flags) } /* - * Execute the command. Be careful to save and restore both the - * string and object results from the interpreter used for + * Execute the command. Save the interp's result used for * the command. We discard any object result the command returns. */ - dummy.objResultPtr = Tcl_NewObj(); - Tcl_IncrRefCount(dummy.objResultPtr); - if (interp->freeProc == 0) { - dummy.freeProc = (Tcl_FreeProc *) 0; - dummy.result = ""; - Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, - TCL_VOLATILE); - } else { - dummy.freeProc = interp->freeProc; - dummy.result = interp->result; - interp->freeProc = (Tcl_FreeProc *) 0; - } - - saveObjPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(saveObjPtr); - + Tcl_SaveResult(interp, &state); + code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); if (code != TCL_OK) { /* copy error msg to result */ - tvarPtr->errMsg = (char *) - ckalloc((unsigned) (strlen(interp->result) + 1)); - strcpy(tvarPtr->errMsg, interp->result); + char *string; + int length; + + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1)); + memcpy(tvarPtr->errMsg, string, (size_t) (length + 1)); result = tvarPtr->errMsg; - Tcl_ResetResult(interp); /* must clear error state. */ } - /* - * Restore the interpreter's string result. - */ - - Tcl_SetResult(interp, dummy.result, - (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc); + Tcl_RestoreResult(interp, &state); - /* - * Restore the interpreter's object result from saveObjPtr. - */ - - oldObjResultPtr = iPtr->objResultPtr; - iPtr->objResultPtr = saveObjPtr; /* was incremented above */ - Tcl_DecrRefCount(oldObjResultPtr); - - Tcl_DecrRefCount(dummy.objResultPtr); - dummy.objResultPtr = NULL; Tcl_DStringFree(&cmd); } if (flags & TCL_TRACE_DESTROYED) { @@ -2122,7 +1871,7 @@ TraceVarProc(clientData, interp, name1, name2, flags) /* *---------------------------------------------------------------------- * - * Tcl_WhileCmd -- + * Tcl_WhileObjCmd -- * * This procedure is invoked to process the "while" Tcl command. * See the user documentation for details on what it does. @@ -2142,32 +1891,32 @@ TraceVarProc(clientData, interp, name1, name2, flags) /* ARGSUSED */ int -Tcl_WhileCmd(dummy, interp, argc, argv) +Tcl_WhileObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " test command\"", (char *) NULL); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "test command"); return TCL_ERROR; } while (1) { - result = Tcl_ExprBoolean(interp, argv[1], &value); + result = Tcl_ExprBooleanObj(interp, objv[1], &value); if (result != TCL_OK) { return result; } if (!value) { break; } - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalObjEx(interp, objv[2], 0); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { - char msg[60]; + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"while\" body line %d)", interp->errorLine); Tcl_AddErrorInfo(interp, msg); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c new file mode 100644 index 0000000..09c3dd0 --- /dev/null +++ b/generic/tclCompCmds.c @@ -0,0 +1,1980 @@ +/* + * tclCompCmds.c -- + * + * This file contains compilation procedures that compile various + * Tcl commands into a sequence of instructions ("bytecodes"). + * + * Copyright (c) 1997-1998 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: tclCompCmds.c,v 1.2 1999/04/16 00:46:43 stanton Exp $ + */ + +#include "tclInt.h" +#include "tclCompile.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); +static void FreeForeachInfo _ANSI_ARGS_(( + ClientData clientData)); + +/* + * The structures below define the AuxData types defined in this file. + */ + +AuxDataType tclForeachInfoType = { + "ForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo /* freeProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * TclCompileBreakCmd -- + * + * Procedure called to compile the "break" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error during compilation. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "break" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileBreakCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + if (parsePtr->numWords != 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"break\"", -1); + envPtr->maxStackDepth = 0; + return TCL_ERROR; + } + + /* + * Emit a break instruction. + */ + + TclEmitOpcode(INST_BREAK, envPtr); + envPtr->maxStackDepth = 0; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileCatchCmd -- + * + * Procedure called to compile the "catch" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If the command is too complex for TclCompileCatchCmd, + * TCL_OUT_LINE_COMPILE is returned indicating that the catch command + * should be compiled "out of line" by emitting code to invoke its + * command procedure at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "catch" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileCatchCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + JumpFixup jumpFixup; + Tcl_Token *cmdTokenPtr, *nameTokenPtr; + char *name; + int localIndex, nameChars, range, maxDepth, startOffset, jumpDist; + int code; + char buffer[32 + TCL_INTEGER_SPACE]; + + envPtr->maxStackDepth = 0; + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"catch command ?varName?\"", -1); + return TCL_ERROR; + } + + /* + * If a variable was specified and the catch command is at global level + * (not in a procedure), don't compile it inline: the payoff is + * too small. + */ + + if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Make sure the variable name, if any, has no substitutions and just + * refers to a local scaler. + */ + + localIndex = -1; + cmdTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (parsePtr->numWords == 3) { + nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1); + if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + name = nameTokenPtr[1].start; + nameChars = nameTokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_OUT_LINE_COMPILE; + } + localIndex = TclFindCompiledLocal(nameTokenPtr[1].start, + nameTokenPtr[1].size, /*create*/ 1, + /*flags*/ VAR_SCALAR, envPtr->procPtr); + } else { + return TCL_OUT_LINE_COMPILE; + } + } + + /* + * We will compile the catch command. Emit a beginCatch instruction at + * the start of the catch body: the subcommand it controls. + */ + + maxDepth = 0; + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); + + startOffset = (envPtr->codeNext - envPtr->codeStart); + envPtr->exceptArrayPtr[range].codeOffset = startOffset; + code = TclCompileCmdWord(interp, cmdTokenPtr+1, + cmdTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"catch\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = envPtr->maxStackDepth; + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) - startOffset; + + /* + * The "no errors" epilogue code: store the body's result into the + * variable (if any), push "0" (TCL_OK) as the catch's "no error" + * result, and jump around the "error case" code. + */ + + if (localIndex != -1) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + } + } + TclEmitOpcode(INST_POP, envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), + envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + + /* + * The "error case" code: store the body's result into the variable (if + * any), then push the error result code. The initial PC offset here is + * the catch's error target. + */ + + envPtr->exceptArrayPtr[range].catchOffset = + (envPtr->codeNext - envPtr->codeStart); + if (localIndex != -1) { + TclEmitOpcode(INST_PUSH_RESULT, envPtr); + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } + TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); + + /* + * Update the target of the jump after the "no errors" code, then emit + * an endCatch instruction at the end of the catch command. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { + panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist); + } + TclEmitOpcode(INST_END_CATCH, envPtr); + + done: + envPtr->exceptDepth--; + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileContinueCmd -- + * + * Procedure called to compile the "continue" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while parsing string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "continue" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileContinueCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + /* + * There should be no argument after the "continue". + */ + + if (parsePtr->numWords != 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"continue\"", -1); + envPtr->maxStackDepth = 0; + return TCL_ERROR; + } + + /* + * Emit a continue instruction. + */ + + TclEmitOpcode(INST_CONTINUE, envPtr); + envPtr->maxStackDepth = 0; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileExprCmd -- + * + * Procedure called to compile the "expr" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "expr" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "expr" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileExprCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *firstWordPtr; + + envPtr->maxStackDepth = 0; + if (parsePtr->numWords == 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"expr arg ?arg ...?\"", -1); + return TCL_ERROR; + } + + firstWordPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1), + envPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileForCmd -- + * + * Procedure called to compile the "for" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while parsing string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "for" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileForCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; + JumpFixup jumpFalseFixup; + int maxDepth, jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist; + int bodyRange, nextRange, code; + unsigned char *jumpPc; + char buffer[32 + TCL_INTEGER_SPACE]; + + envPtr->maxStackDepth = 0; + if (parsePtr->numWords != 5) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"for start test next command\"", -1); + return TCL_ERROR; + } + + /* + * If the test expression requires substitutions, don't compile the for + * command inline. E.g., the expression might cause the loop to never + * execute or execute forever, as in "for {} "$x > 5" {incr x} {}". + */ + + startTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1); + if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Create ExceptionRange records for the body and the "next" command. + * The "next" command's ExceptionRange supports break but not continue + * (and has a -1 continueOffset). + */ + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + + /* + * Inline compile the initial command. + */ + + maxDepth = 0; + code = TclCompileCmdWord(interp, startTokenPtr+1, + startTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"for\" initial command)", -1); + } + goto done; + } + maxDepth = envPtr->maxStackDepth; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Compile the test then emit the conditional jump that exits the for. + */ + + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"for\" test expression)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Compile the loop body. + */ + + nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1); + envPtr->exceptArrayPtr[bodyRange].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"for\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[bodyRange].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[bodyRange].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Compile the "next" subcommand. + */ + + envPtr->exceptArrayPtr[bodyRange].continueOffset = + (envPtr->codeNext - envPtr->codeStart); + envPtr->exceptArrayPtr[nextRange].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, nextTokenPtr+1, + nextTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"for\" loop-end command)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[nextRange].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[nextRange].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Jump back to the test at the top of the loop. Generate a 4 byte jump + * if the distance to the test is > 120 bytes. This is conservative and + * ensures that we won't have to replace this jump if we later need to + * replace the ifFalse jump with a 4 byte jump. + */ + + jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); + jumpBackDist = (jumpBackOffset - testCodeOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + } + + /* + * Fix the target of the jumpFalse after the test. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body and "next" command ExceptionRanges since + * they moved down. + */ + + envPtr->exceptArrayPtr[bodyRange].codeOffset += 3; + envPtr->exceptArrayPtr[bodyRange].continueOffset += 3; + envPtr->exceptArrayPtr[nextRange].codeOffset += 3; + + /* + * Update the jump back to the test at the top of the loop since it + * also moved down 3 bytes. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + jumpBackDist += 3; + if (jumpBackDist > 120) { + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + } else { + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + } + } + + /* + * Set the loop's break target. + */ + + envPtr->exceptArrayPtr[bodyRange].breakOffset = + envPtr->exceptArrayPtr[nextRange].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * The for command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + code = TCL_OK; + + done: + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileForeachCmd -- + * + * Procedure called to compile the "foreach" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If the command is too complex for TclCompileForeachCmd, + * TCL_OUT_LINE_COMPILE is returned indicating that the foreach command + * should be compiled "out of line" by emitting code to invoke its + * command procedure at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "while" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "foreach" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileForeachCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Proc *procPtr = envPtr->procPtr; + ForeachInfo *infoPtr; /* Points to the structure describing this + * foreach command. Stored in a AuxData + * record in the ByteCode. */ + int firstValueTemp; /* Index of the first temp var in the frame + * used to point to a value list. */ + int loopCtTemp; /* Index of temp var holding the loop's + * iteration count. */ + Tcl_Token *tokenPtr, *bodyTokenPtr; + char *varList; + unsigned char *jumpPc; + JumpFixup jumpFalseFixup; + int jumpDist, jumpBackDist, jumpBackOffset, maxDepth, infoIndex, range; + int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; + char savedChar; + char buffer[32 + TCL_INTEGER_SPACE]; + + /* + * We parse the variable list argument words and create two arrays: + * varcList[i] is number of variables in i-th var list + * varvList[i] points to array of var names in i-th var list + */ + +#define STATIC_VAR_LIST_SIZE 5 + int varcListStaticSpace[STATIC_VAR_LIST_SIZE]; + char **varvListStaticSpace[STATIC_VAR_LIST_SIZE]; + int *varcList = varcListStaticSpace; + char ***varvList = varvListStaticSpace; + + /* + * If the foreach command isn't in a procedure, don't compile it inline: + * the payoff is too small. + */ + + envPtr->maxStackDepth = 0; + if (procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + maxDepth = 0; + + numWords = parsePtr->numWords; + if ((numWords < 4) || (numWords%2 != 0)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1); + return TCL_ERROR; + } + + /* + * Allocate storage for the varcList and varvList arrays if necessary. + */ + + numLists = (numWords - 2)/2; + if (numLists > STATIC_VAR_LIST_SIZE) { + varcList = (int *) ckalloc(numLists * sizeof(int)); + varvList = (char ***) ckalloc(numLists * sizeof(char **)); + } + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + varcList[loopIndex] = 0; + varvList[loopIndex] = (char **) NULL; + } + + /* + * Set the exception stack depth. + */ + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + + /* + * Break up each var list and set the varcList and varvList arrays. + * Don't compile the foreach inline if any var name needs substitutions + * or isn't a scalar, or if any var list needs substitutions. + */ + + loopIndex = 0; + for (i = 0, tokenPtr = parsePtr->tokenPtr; + i < numWords-1; + i++, tokenPtr += (tokenPtr->numComponents + 1)) { + if (i%2 == 1) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + code = TCL_OUT_LINE_COMPILE; + goto done; + } + varList = tokenPtr[1].start; + savedChar = varList[tokenPtr[1].size]; + + /* + * Note there is a danger that modifying the string could have + * undesirable side effects. In this case, Tcl_SplitList does + * not have any dependencies on shared strings so we should be + * safe. + */ + + varList[tokenPtr[1].size] = '\0'; + code = Tcl_SplitList(interp, varList, + &varcList[loopIndex], &varvList[loopIndex]); + varList[tokenPtr[1].size] = savedChar; + if (code != TCL_OK) { + goto done; + } + + numVars = varcList[loopIndex]; + for (j = 0; j < numVars; j++) { + char *varName = varvList[loopIndex][j]; + if (!TclIsLocalScalar(varName, (int) strlen(varName))) { + code = TCL_OUT_LINE_COMPILE; + goto done; + } + } + loopIndex++; + } + } + + /* + * We will compile the foreach command. + * Reserve (numLists + 1) temporary variables: + * - numLists temps to hold each value list + * - 1 temp for the loop counter (index of next element in each list) + * At this time we don't try to reuse temporaries; if there are two + * nonoverlapping foreach loops, they don't share any temps. + */ + + firstValueTemp = -1; + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, + /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + if (loopIndex == 0) { + firstValueTemp = tempVar; + } + } + loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, + /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + + /* + * Create and initialize the ForeachInfo and ForeachVarList data + * structures describing this command. Then create a AuxData record + * pointing to the ForeachInfo structure. + */ + + infoPtr = (ForeachInfo *) ckalloc((unsigned) + (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + infoPtr->numLists = numLists; + infoPtr->firstValueTemp = firstValueTemp; + infoPtr->loopCtTemp = loopCtTemp; + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + ForeachVarList *varListPtr; + numVars = varcList[loopIndex]; + varListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + (numVars * sizeof(int))); + varListPtr->numVars = numVars; + for (j = 0; j < numVars; j++) { + char *varName = varvList[loopIndex][j]; + int nameChars = strlen(varName); + varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, + nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + } + infoPtr->varLists[loopIndex] = varListPtr; + } + infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr); + + /* + * Evaluate then store each value list in the associated temporary. + */ + + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + + loopIndex = 0; + for (i = 0, tokenPtr = parsePtr->tokenPtr; + i < numWords-1; + i++, tokenPtr += (tokenPtr->numComponents + 1)) { + if ((i%2 == 0) && (i > 0)) { + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + + tempVar = (firstValueTemp + loopIndex); + if (tempVar <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + loopIndex++; + } + } + bodyTokenPtr = tokenPtr; + + /* + * Initialize the temporary var that holds the count of loop iterations. + */ + + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + + /* + * Top of loop code: assign each loop variable and check whether + * to terminate the loop. + */ + + envPtr->exceptArrayPtr[range].continueOffset = + (envPtr->codeNext - envPtr->codeStart); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Inline compile the loop body. + */ + + envPtr->exceptArrayPtr[range].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"foreach\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[range].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Jump back to the test at the top of the loop. Generate a 4 byte jump + * if the distance to the test is > 120 bytes. This is conservative and + * ensures that we won't have to replace this jump if we later need to + * replace the ifFalse jump with a 4 byte jump. + */ + + jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); + jumpBackDist = + (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + } + + /* + * Fix the target of the jump after the foreach_step test. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body's starting PC offset since it moved down. + */ + + envPtr->exceptArrayPtr[range].codeOffset += 3; + + /* + * Update the jump back to the test at the top of the loop since it + * also moved down 3 bytes. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + jumpBackDist += 3; + if (jumpBackDist > 120) { + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + } else { + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + } + } + + /* + * Set the loop's break target. + */ + + envPtr->exceptArrayPtr[range].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * The foreach command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + + done: + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + if (varvList[loopIndex] != (char **) NULL) { + ckfree((char *) varvList[loopIndex]); + } + } + if (varcList != varcListStaticSpace) { + ckfree((char *) varcList); + ckfree((char *) varvList); + } + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * DupForeachInfo -- + * + * This procedure duplicates a ForeachInfo structure created as + * auxiliary data during the compilation of a foreach command. + * + * Results: + * A pointer to a newly allocated copy of the existing ForeachInfo + * structure is returned. + * + * Side effects: + * Storage for the copied ForeachInfo record is allocated. If the + * original ForeachInfo structure pointed to any ForeachVarList + * records, these structures are also copied and pointers to them + * are stored in the new ForeachInfo record. + * + *---------------------------------------------------------------------- + */ + +static ClientData +DupForeachInfo(clientData) + ClientData clientData; /* The foreach command's compilation + * auxiliary data to duplicate. */ +{ + register ForeachInfo *srcPtr = (ForeachInfo *) clientData; + ForeachInfo *dupPtr; + register ForeachVarList *srcListPtr, *dupListPtr; + int numLists = srcPtr->numLists; + int numVars, i, j; + + dupPtr = (ForeachInfo *) ckalloc((unsigned) + (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + dupPtr->numLists = numLists; + dupPtr->firstValueTemp = srcPtr->firstValueTemp; + dupPtr->loopCtTemp = srcPtr->loopCtTemp; + + for (i = 0; i < numLists; i++) { + srcListPtr = srcPtr->varLists[i]; + numVars = srcListPtr->numVars; + dupListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + numVars*sizeof(int)); + dupListPtr->numVars = numVars; + for (j = 0; j < numVars; j++) { + dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; + } + dupPtr->varLists[i] = dupListPtr; + } + return (ClientData) dupPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeForeachInfo -- + * + * Procedure to free a ForeachInfo structure created as auxiliary data + * during the compilation of a foreach command. + * + * Results: + * None. + * + * Side effects: + * Storage for the ForeachInfo structure pointed to by the ClientData + * argument is freed as is any ForeachVarList record pointed to by the + * ForeachInfo structure. + * + *---------------------------------------------------------------------- + */ + +static void +FreeForeachInfo(clientData) + ClientData clientData; /* The foreach command's compilation + * auxiliary data to free. */ +{ + register ForeachInfo *infoPtr = (ForeachInfo *) clientData; + register ForeachVarList *listPtr; + int numLists = infoPtr->numLists; + register int i; + + for (i = 0; i < numLists; i++) { + listPtr = infoPtr->varLists[i]; + ckfree((char *) listPtr); + } + ckfree((char *) infoPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIfCmd -- + * + * Procedure called to compile the "if" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If the command is too complex for TclCompileIfCmd, + * TCL_OUT_LINE_COMPILE is returned indicating that the if command + * should be compiled "out of line" by emitting code to invoke its + * command procedure at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "if" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIfCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + JumpFixupArray jumpFalseFixupArray; + /* Used to fix the ifFalse jump after each + * test when its target PC is determined. */ + JumpFixupArray jumpEndFixupArray; + /* Used to fix the jump after each "then" + * body to the end of the "if" when that PC + * is determined. */ + Tcl_Token *tokenPtr, *testTokenPtr; + int jumpDist, jumpFalseDist, jumpIndex; + int numWords, wordIdx, numBytes, maxDepth, j, code; + char *word; + char buffer[100]; + + TclInitJumpFixupArray(&jumpFalseFixupArray); + TclInitJumpFixupArray(&jumpEndFixupArray); + maxDepth = 0; + code = TCL_OK; + + /* + * Each iteration of this loop compiles one "if expr ?then? body" + * or "elseif expr ?then? body" clause. + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + numWords = parsePtr->numWords; + while (wordIdx < numWords) { + /* + * Stop looping if the token isn't "if" or "elseif". + */ + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + break; + } + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((tokenPtr == parsePtr->tokenPtr) + || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { + tokenPtr += (tokenPtr->numComponents + 1); + wordIdx++; + } else { + break; + } + if (wordIdx >= numWords) { + sprintf(buffer, + "wrong # args: no expression after \"%.30s\" argument", + word); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); + code = TCL_ERROR; + goto done; + } + + /* + * Compile the test expression then emit the conditional jump + * around the "then" part. If the expression word isn't simple, + * we back off and compile the if command out-of-line. + */ + + testTokenPtr = tokenPtr; + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"if\" test expression)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { + TclExpandJumpFixupArray(&jumpFalseFixupArray); + } + jumpIndex = jumpFalseFixupArray.next; + jumpFalseFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + &(jumpFalseFixupArray.fixup[jumpIndex])); + + /* + * Skip over the optional "then" before the then clause. + */ + + tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + wordIdx++; + if (wordIdx >= numWords) { + sprintf(buffer, "wrong # args: no script following \"%.20s\" argument", testTokenPtr->start); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); + code = TCL_ERROR; + goto done; + } + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { + tokenPtr += (tokenPtr->numComponents + 1); + wordIdx++; + if (wordIdx >= numWords) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: no script following \"then\" argument", -1); + code = TCL_ERROR; + goto done; + } + } + } + + /* + * Compile the "then" command body. + */ + + code = TclCompileCmdWord(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"if\" then script line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + + /* + * Jump to the end of the "if" command. Both jumpFalseFixupArray and + * jumpEndFixupArray are indexed by "jumpIndex". + */ + + if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { + TclExpandJumpFixupArray(&jumpEndFixupArray); + } + jumpEndFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &(jumpEndFixupArray.fixup[jumpIndex])); + + /* + * Fix the target of the jumpFalse after the test. Generate a 4 byte + * jump if the distance is > 120 bytes. This is conservative, and + * ensures that we won't have to replace this jump if we later also + * need to replace the proceeding jump to the end of the "if" with a + * 4 byte jump. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + if (TclFixupForwardJump(envPtr, + &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) { + /* + * Adjust the code offset for the proceeding jump to the end + * of the "if" command. + */ + + jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; + } + + tokenPtr += (tokenPtr->numComponents + 1); + wordIdx++; + } + + /* + * Check for the optional else clause. + */ + + if ((wordIdx < numWords) + && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { + /* + * There is an else clause. Skip over the optional "else" word. + */ + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { + tokenPtr += (tokenPtr->numComponents + 1); + wordIdx++; + if (wordIdx >= numWords) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: no script following \"else\" argument", -1); + code = TCL_ERROR; + goto done; + } + } + + /* + * Compile the else command body. + */ + + code = TclCompileCmdWord(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"if\" else script line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + + /* + * Make sure there are no words after the else clause. + */ + + wordIdx++; + if (wordIdx < numWords) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: extra words after \"else\" clause in \"if\" command", -1); + code = TCL_ERROR; + goto done; + } + } else { + /* + * No else clause: the "if" command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0,/*onHeap*/ 0), envPtr); + maxDepth = TclMax(1, maxDepth); + } + + /* + * Fix the unconditional jumps to the end of the "if" command. + */ + + for (j = jumpEndFixupArray.next; j > 0; j--) { + jumpIndex = (j - 1); /* i.e. process the closest jump first */ + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpEndFixupArray.fixup[jumpIndex].codeOffset; + if (TclFixupForwardJump(envPtr, + &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) { + /* + * Adjust the immediately preceeding "ifFalse" jump. We moved + * it's target (just after this jump) down three bytes. + */ + + unsigned char *ifFalsePc = envPtr->codeStart + + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + unsigned char opCode = *ifFalsePc; + if (opCode == INST_JUMP_FALSE1) { + jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else if (opCode == INST_JUMP_FALSE4) { + jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else { + panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump"); + } + } + } + + /* + * Free the jumpFixupArray array if malloc'ed storage was used. + */ + + done: + TclFreeJumpFixupArray(&jumpFalseFixupArray); + TclFreeJumpFixupArray(&jumpEndFixupArray); + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIncrCmd -- + * + * Procedure called to compile the "incr" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If the command is too complex for TclCompileIncrCmd, + * TCL_OUT_LINE_COMPILE is returned indicating that the incr command + * should be compiled "out of line" by emitting code to invoke its + * command procedure at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "incr" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "incr" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIncrCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr, *incrTokenPtr; + Tcl_Parse elemParse; + int gotElemParse = 0; + char *name, *elName, *p; + int nameChars, elNameChars, haveImmValue, immValue, localIndex, i, code; + int maxDepth = 0; + char buffer[160]; + + envPtr->maxStackDepth = 0; + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"incr varName ?increment?\"", -1); + return TCL_ERROR; + } + + name = NULL; + elName = NULL; + elNameChars = 0; + localIndex = -1; + code = TCL_OK; + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * A simple variable name. Divide it up into "name" and "elName" + * strings. If it is not a local variable, look it up at runtime. + */ + + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + for (i = 0, p = name; i < nameChars; i++, p++) { + if (*p == '(') { + char *openParen = p; + p = (name + nameChars-1); + if (*p == ')') { /* last char is ')' => array reference */ + nameChars = (openParen - name); + elName = openParen+1; + elNameChars = (p - elName); + } + break; + } + } + if (envPtr->procPtr != NULL) { + localIndex = TclFindCompiledLocal(name, nameChars, + /*create*/ 0, /*flags*/ 0, envPtr->procPtr); + if (localIndex > 255) { /* we'll push the name */ + localIndex = -1; + } + } + if (localIndex < 0) { + TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, + /*onHeap*/ 0), envPtr); + maxDepth = 1; + } + + /* + * Compile the element script, if any. + */ + + if (elName != NULL) { + /* + * Temporarily replace the '(' and ')' by '"'s. + */ + + *(elName-1) = '"'; + *(elName+elNameChars) = '"'; + code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, + /*nested*/ 0, &elemParse); + *(elName-1) = '('; + *(elName+elNameChars) = ')'; + gotElemParse = 1; + if ((code != TCL_OK) || (elemParse.numWords > 1)) { + sprintf(buffer, "\n (parsing index for array \"%.*s\")", + TclMin(nameChars, 100), name); + Tcl_AddObjErrorInfo(interp, buffer, -1); + code = TCL_ERROR; + goto done; + } else if (elemParse.numWords == 1) { + code = TclCompileTokens(interp, elemParse.tokenPtr+1, + elemParse.tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } else { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, + /*alreadyAlloced*/ 0), envPtr); + maxDepth += 1; + } + } + } else { + /* + * Not a simple variable name. Look it up at runtime. + */ + + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + } + + /* + * If an increment is given, push it, but see first if it's a small + * integer. + */ + + haveImmValue = 0; + immValue = 0; + if (parsePtr->numWords == 3) { + incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + char *word = incrTokenPtr[1].start; + int numBytes = incrTokenPtr[1].size; + char savedChar = word[numBytes]; + long n; + + /* + * Note there is a danger that modifying the string could have + * undesirable side effects. In this case, TclLooksLikeInt and + * TclGetLong do not have any dependencies on shared strings so we + * should be safe. + */ + + word[numBytes] = '\0'; + if (TclLooksLikeInt(word, numBytes) + && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) { + if ((-127 <= n) && (n <= 127)) { + haveImmValue = 1; + immValue = n; + } + } + word[numBytes] = savedChar; + if (!haveImmValue) { + TclEmitPush(TclRegisterLiteral(envPtr, word, numBytes, + /*onHeap*/ 0), envPtr); + maxDepth += 1; + } + } else { + code = TclCompileTokens(interp, incrTokenPtr+1, + incrTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (increment expression)", -1); + } + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + } else { /* no incr amount given so use 1 */ + haveImmValue = 1; + immValue = 1; + } + + /* + * Emit the instruction to increment the variable. + */ + + if (name != NULL) { + if (elName == NULL) { + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, + envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, + envPtr); + } else { + TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); + } + } + } else { + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, + envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, + envPtr); + } else { + TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); + } + } + } + } else { /* non-simple variable name */ + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode(INST_INCR_STK, envPtr); + } + } + + done: + if (gotElemParse) { + Tcl_FreeParse(&elemParse); + } + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileSetCmd -- + * + * Procedure called to compile the "set" command. + * + * Results: + * The return value is a standard Tcl result, which is normally TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. If + * complation fails because the set command requires a second level of + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the + * set command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_SetCmd) at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the incr command. + * + * Side effects: + * Instructions are added to envPtr to execute the "set" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileSetCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr, *valueTokenPtr; + Tcl_Parse elemParse; + int gotElemParse = 0; + register char *p; + char *name, *elName; + int nameChars, elNameChars; + register int i; + int isAssignment, simpleVarName, localIndex, numWords; + int maxDepth = 0; + int code = TCL_OK; + + envPtr->maxStackDepth = 0; + numWords = parsePtr->numWords; + if ((numWords != 2) && (numWords != 3)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"set varName ?newValue?\"", -1); + return TCL_ERROR; + } + isAssignment = (numWords == 3); + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + + simpleVarName = 0; + name = elName = NULL; + nameChars = elNameChars = 0; + localIndex = -1; + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + simpleVarName = 1; + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + /* last char is ')' => potential array reference */ + if ( *(name + nameChars - 1) == ')') { + for (i = 0, p = name; i < nameChars; i++, p++) { + if (*p == '(') { + elName = p + 1; + elNameChars = nameChars - i - 2; + nameChars = i ; + break; + } + } + } + + /* + * If elName contains any double quotes ("), we can't inline + * compile the element script using the replace '()' by '"' + * technique below. + */ + + for (i = 0, p = elName; i < elNameChars; i++, p++) { + if (*p == '"') { + simpleVarName = 0; + break; + } + } + } else if ((varTokenPtr->numComponents == 4) + && (varTokenPtr[1].type == TCL_TOKEN_TEXT) + && (varTokenPtr[1].start[varTokenPtr[1].size-1] == '(') + && (varTokenPtr[4].type == TCL_TOKEN_TEXT) + && (varTokenPtr[4].size == 1) + && (varTokenPtr[4].start[0] == ')')) { + simpleVarName = 1; + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size - 1; + elName = varTokenPtr[2].start; + elNameChars = varTokenPtr[2].size; + } + + if (simpleVarName) { + /* + * See whether name has any namespace separators (::'s). + */ + + int hasNsQualifiers = 0; + for (i = 0, p = name; i < nameChars; i++, p++) { + if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { + hasNsQualifiers = 1; + break; + } + } + + /* + * Look up the var name's index in the array of local vars in the + * proc frame. If retrieving the var's value and it doesn't already + * exist, push its name and look it up at runtime. + */ + + if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { + localIndex = TclFindCompiledLocal(name, nameChars, + /*create*/ isAssignment, + /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), + envPtr->procPtr); + } + if (localIndex >= 0) { + maxDepth = 0; + } else { + TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, + /*onHeap*/ 0), envPtr); + maxDepth = 1; + } + + /* + * Compile the element script, if any. + */ + + if (elName != NULL) { + /* + * Temporarily replace the '(' and ')' by '"'s. + */ + + *(elName-1) = '"'; + *(elName+elNameChars) = '"'; + code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, + /*nested*/ 0, &elemParse); + *(elName-1) = '('; + *(elName+elNameChars) = ')'; + gotElemParse = 1; + if ((code != TCL_OK) || (elemParse.numWords > 1)) { + char buffer[160]; + sprintf(buffer, "\n (parsing index for array \"%.*s\")", + TclMin(nameChars, 100), name); + Tcl_AddObjErrorInfo(interp, buffer, -1); + code = TCL_ERROR; + goto done; + } else if (elemParse.numWords == 1) { + code = TclCompileTokens(interp, elemParse.tokenPtr+1, + elemParse.tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } else { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, + /*alreadyAlloced*/ 0), envPtr); + maxDepth += 1; + } + } + } else { + /* + * The var name isn't simple: compile and push it. + */ + + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + + /* + * If we are doing an assignment, push the new value. + */ + + if (isAssignment) { + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start, + valueTokenPtr[1].size, /*onHeap*/ 0), envPtr); + maxDepth += 1; + } else { + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + } + + /* + * Emit instructions to set/get the variable. + */ + + if (simpleVarName) { + if (elName == NULL) { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1((isAssignment? + INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), + localIndex, envPtr); + } else { + TclEmitInstInt4((isAssignment? + INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), + localIndex, envPtr); + } + } else { + TclEmitOpcode((isAssignment? + INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), + envPtr); + } + } else { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1((isAssignment? + INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), + localIndex, envPtr); + } else { + TclEmitInstInt4((isAssignment? + INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), + localIndex, envPtr); + } + } else { + TclEmitOpcode((isAssignment? + INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), + envPtr); + } + } + } else { + TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), + envPtr); + } + + done: + if (gotElemParse) { + Tcl_FreeParse(&elemParse); + } + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileWhileCmd -- + * + * Procedure called to compile the "while" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If compilation failed because the command is too + * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned + * indicating that the while command should be compiled "out of line" + * by emitting code to invoke its command procedure at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "while" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "while" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileWhileCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *testTokenPtr, *bodyTokenPtr; + JumpFixup jumpFalseFixup; + unsigned char *jumpPc; + int testCodeOffset, jumpDist, jumpBackDist, jumpBackOffset; + int range, maxDepth, code; + char buffer[32 + TCL_INTEGER_SPACE]; + + envPtr->maxStackDepth = 0; + maxDepth = 0; + if (parsePtr->numWords != 3) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"while test command\"", -1); + return TCL_ERROR; + } + + /* + * If the test expression requires substitutions, don't compile the + * while command inline. E.g., the expression might cause the loop to + * never execute or execute forever, as in "while "$x < 5" {}". + */ + + testTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Create a ExceptionRange record for the loop body. This is used to + * implement break and continue. + */ + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + envPtr->exceptArrayPtr[range].continueOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * Compile the test expression then emit the conditional jump that + * terminates the while. We already know it's a simple word. + */ + + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); + envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"while\" test expression)", -1); + } + goto error; + } + maxDepth = envPtr->maxStackDepth; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Compile the loop body. + */ + + bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + envPtr->exceptArrayPtr[range].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"while\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto error; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[range].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Jump back to the test at the top of the loop. Generate a 4 byte jump + * if the distance to the test is > 120 bytes. This is conservative and + * ensures that we won't have to replace this jump if we later need to + * replace the ifFalse jump with a 4 byte jump. + */ + + jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); + jumpBackDist = (jumpBackOffset - testCodeOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + } + + /* + * Fix the target of the jumpFalse after the test. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body's starting PC offset since it moved down. + */ + + envPtr->exceptArrayPtr[range].codeOffset += 3; + + /* + * Update the jump back to the test at the top of the loop since it + * also moved down 3 bytes. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + jumpBackDist += 3; + if (jumpBackDist > 120) { + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + } else { + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + } + } + + /* + * Set the loop's break target. + */ + + envPtr->exceptArrayPtr[range].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * The while command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return TCL_OK; + + error: + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return code; +} + + + diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 21be023..42342b1 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -3,12 +3,12 @@ * * This file contains the code to compile Tcl expressions. * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * Copyright (c) 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: tclCompExpr.c,v 1.2 1998/09/14 18:39:58 stanton Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.3 1999/04/16 00:46:44 stanton Exp $ */ #include "tclInt.h" @@ -37,7 +37,7 @@ extern int errno; /* Use errno from tclExecute.c. */ */ #ifdef TCL_COMPILE_DEBUG -static int traceCompileExpr = 0; +static int traceExprComp = 0; #endif /* TCL_COMPILE_DEBUG */ /* @@ -47,21 +47,12 @@ static int traceCompileExpr = 0; */ typedef struct ExprInfo { - int token; /* Type of the last token parsed in expr. - * See below for definitions. Corresponds - * to the characters just before next. */ - int objIndex; /* If token is a literal value, the index of - * an object holding the value in the code's - * object table; otherwise is NULL. */ - char *funcName; /* If the token is FUNC_NAME, points to the - * first character of the math function's - * name; otherwise is NULL. */ - char *next; /* Position of the next character to be - * scanned in the expression string. */ - char *originalExpr; /* The entire expression that was originally - * passed to Tcl_ExprString et al. */ - char *lastChar; /* Pointer to terminating null in - * originalExpr. */ + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Structure filled with information about + * the parsed expression. */ + char *expr; /* The expression that was originally passed + * to TclCompileExpr. */ + char *lastChar; /* Points just after last byte of expr. */ int hasOperators; /* Set 1 if the expr has operators; 0 if * expr is only a primary. If 1 after * compiling an expr, a tryCvtToNumeric @@ -82,135 +73,116 @@ typedef struct ExprInfo { } ExprInfo; /* - * Definitions of the different tokens that appear in expressions. The order - * of these must match the corresponding entries in the operatorStrings - * array below. - */ - -#define LITERAL 0 -#define FUNC_NAME (LITERAL + 1) -#define OPEN_BRACKET (LITERAL + 2) -#define CLOSE_BRACKET (LITERAL + 3) -#define OPEN_PAREN (LITERAL + 4) -#define CLOSE_PAREN (LITERAL + 5) -#define DOLLAR (LITERAL + 6) -#define QUOTE (LITERAL + 7) -#define COMMA (LITERAL + 8) -#define END (LITERAL + 9) -#define UNKNOWN (LITERAL + 10) - -/* - * Binary operators: + * Definitions of numeric codes representing each expression operator. + * The order of these must match the entries in the operatorTable below. + * Also the codes for the relational operators (OP_LESS, OP_GREATER, + * OP_LE, OP_GE, OP_EQ, and OP_NE) must be consecutive and in that order. + * Note that OP_PLUS and OP_MINUS represent both unary and binary operators. */ -#define MULT (UNKNOWN + 1) -#define DIVIDE (MULT + 1) -#define MOD (MULT + 2) -#define PLUS (MULT + 3) -#define MINUS (MULT + 4) -#define LEFT_SHIFT (MULT + 5) -#define RIGHT_SHIFT (MULT + 6) -#define LESS (MULT + 7) -#define GREATER (MULT + 8) -#define LEQ (MULT + 9) -#define GEQ (MULT + 10) -#define EQUAL (MULT + 11) -#define NEQ (MULT + 12) -#define BIT_AND (MULT + 13) -#define BIT_XOR (MULT + 14) -#define BIT_OR (MULT + 15) -#define AND (MULT + 16) -#define OR (MULT + 17) -#define QUESTY (MULT + 18) -#define COLON (MULT + 19) +#define OP_MULT 0 +#define OP_DIVIDE 1 +#define OP_MOD 2 +#define OP_PLUS 3 +#define OP_MINUS 4 +#define OP_LSHIFT 5 +#define OP_RSHIFT 6 +#define OP_LESS 7 +#define OP_GREATER 8 +#define OP_LE 9 +#define OP_GE 10 +#define OP_EQ 11 +#define OP_NEQ 12 +#define OP_BITAND 13 +#define OP_BITXOR 14 +#define OP_BITOR 15 +#define OP_LAND 16 +#define OP_LOR 17 +#define OP_QUESTY 18 +#define OP_LNOT 19 +#define OP_BITNOT 20 /* - * Unary operators. Unary minus and plus are represented by the (binary) - * tokens MINUS and PLUS. + * Table describing the expression operators. Entries in this table must + * correspond to the definitions of numeric codes for operators just above. */ -#define NOT (COLON + 1) -#define BIT_NOT (NOT + 1) +static int opTableInitialized = 0; /* 0 means not yet initialized. */ + +TCL_DECLARE_MUTEX(opMutex) + +typedef struct OperatorDesc { + char *name; /* Name of the operator. */ + int numOperands; /* Number of operands. 0 if the operator + * requires special handling. */ + int instruction; /* Instruction opcode for the operator. + * Ignored if numOperands is 0. */ +} OperatorDesc; + +OperatorDesc operatorTable[] = { + {"*", 2, INST_MULT}, + {"/", 2, INST_DIV}, + {"%", 2, INST_MOD}, + {"+", 0}, + {"-", 0}, + {"<<", 2, INST_LSHIFT}, + {">>", 2, INST_RSHIFT}, + {"<", 2, INST_LT}, + {">", 2, INST_GT}, + {"<=", 2, INST_LE}, + {">=", 2, INST_GE}, + {"==", 2, INST_EQ}, + {"!=", 2, INST_NEQ}, + {"&", 2, INST_BITAND}, + {"^", 2, INST_BITXOR}, + {"|", 2, INST_BITOR}, + {"&&", 0}, + {"||", 0}, + {"?", 0}, + {"!", 1, INST_LNOT}, + {"~", 1, INST_BITNOT}, + {NULL} +}; /* - * Mapping from tokens to strings; used for debugging messages. These - * entries must match the order and number of the token definitions above. + * Hashtable used to map the names of expression operators to the index + * of their OperatorDesc description. */ -#ifdef TCL_COMPILE_DEBUG -static char *tokenStrings[] = { - "LITERAL", "FUNCNAME", - "[", "]", "(", ")", "$", "\"", ",", "END", "UNKNOWN", - "*", "/", "%", "+", "-", - "<<", ">>", "<", ">", "<=", ">=", "==", "!=", - "&", "^", "|", "&&", "||", "?", ":", - "!", "~" -}; -#endif /* TCL_COMPILE_DEBUG */ +static Tcl_HashTable opHashTable; /* * Declarations for local procedures to this file: */ -static int CompileAddExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitAndExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitOrExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitXorExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileCondExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileEqualityExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileLandExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileLorExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, +static int CompileCondExpr _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, ExprInfo *infoPtr, + CompileEnv *envPtr, Tcl_Token **endPtrPtr)); +static int CompileLandOrLorExpr _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, int opIndex, + ExprInfo *infoPtr, CompileEnv *envPtr, + Tcl_Token **endPtrPtr)); +static int CompileMathFuncCall _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, char *funcName, + ExprInfo *infoPtr, CompileEnv *envPtr, + Tcl_Token **endPtrPtr)); +static int CompileSubExpr _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, ExprInfo *infoPtr, CompileEnv *envPtr)); -static int CompileMathFuncCall _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileMultiplyExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompilePrimaryExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileRelationalExpr _ANSI_ARGS_(( - Tcl_Interp *interp, ExprInfo *infoPtr, - int flags, CompileEnv *envPtr)); -static int CompileShiftExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileUnaryExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, CompileEnv *envPtr)); +static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr)); /* - * Macro used to debug the execution of the recursive descent parser used - * to compile expressions. + * Macro used to debug the execution of the expression compiler. */ #ifdef TCL_COMPILE_DEBUG -#define HERE(production, level) \ - if (traceCompileExpr) { \ - fprintf(stderr, "%*s%s: token=%s, next=\"%.20s\"\n", \ - (level), " ", (production), tokenStrings[infoPtr->token], \ - infoPtr->next); \ +#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \ + if (traceExprComp) { \ + fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \ + (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \ } #else -#define HERE(production, level) +#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) #endif /* TCL_COMPILE_DEBUG */ /* @@ -224,23 +196,11 @@ static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, * procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, * Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj. * - * Note that the topmost recursive-descent parsing routine used by - * TclCompileExpr to compile expressions is called "CompileCondExpr" - * and not, e.g., "CompileExpr". This is done to avoid an extra - * procedure call since such a procedure would only return the result - * of calling CompileCondExpr. Other recursive-descent procedures - * that need to parse expressions also call CompileCondExpr. - * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR * on failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed; this might - * be the offset of the ']' (if flags & TCL_BRACKET_TERM), or the - * offset of the '\0' at the end of the string. - * * envPtr->maxStackDepth is updated with the maximum number of stack * elements needed to execute the expression. * @@ -261,85 +221,73 @@ static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, */ int -TclCompileExpr(interp, string, lastChar, flags, envPtr) +TclCompileExpr(interp, script, numBytes, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ + char *script; /* The source script to compile. */ + int numBytes; /* Number of bytes in script. If < 0, the + * string consists of all bytes up to the + * first null character. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { - Interp *iPtr = (Interp *) interp; ExprInfo info; - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - -#ifdef TCL_COMPILE_DEBUG - if (traceCompileExpr) { - fprintf(stderr, "expr: string=\"%.30s\"\n", string); - } -#endif /* TCL_COMPILE_DEBUG */ + Tcl_Parse parse; + Tcl_HashEntry *hPtr; + int maxDepth, new, i, code; /* - * Register the builtin math functions the first time an expression is - * compiled. + * If this is the first time we've been called, initialize the table + * of expression operators. */ - if (!(iPtr->flags & EXPR_INITIALIZED)) { - BuiltinFunc *funcPtr; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int i; - - iPtr->flags |= EXPR_INITIALIZED; - i = 0; - for (funcPtr = builtinFuncTable; funcPtr->name != NULL; funcPtr++) { - Tcl_CreateMathFunc(interp, funcPtr->name, - funcPtr->numArgs, funcPtr->argTypes, - (Tcl_MathProc *) NULL, (ClientData) 0); - - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcPtr->name); - if (hPtr == NULL) { - panic("TclCompileExpr: Tcl_CreateMathFunc incorrectly registered '%s'", funcPtr->name); - return TCL_ERROR; + if (numBytes < 0) { + numBytes = (script? strlen(script) : 0); + } + if (!opTableInitialized) { + Tcl_MutexLock(&opMutex); + if (!opTableInitialized) { + Tcl_InitHashTable(&opHashTable, TCL_STRING_KEYS); + for (i = 0; operatorTable[i].name != NULL; i++) { + hPtr = Tcl_CreateHashEntry(&opHashTable, + operatorTable[i].name, &new); + if (new) { + Tcl_SetHashValue(hPtr, (ClientData) i); + } } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - mathFuncPtr->builtinFuncIndex = i; - i++; + opTableInitialized = 1; } + Tcl_MutexUnlock(&opMutex); } - info.token = UNKNOWN; - info.objIndex = -1; - info.funcName = NULL; - info.next = string; - info.originalExpr = string; - info.lastChar = lastChar; + /* + * Initialize the structure containing information abvout this + * expression compilation. + */ + + info.interp = interp; + info.parsePtr = &parse; + info.expr = script; + info.lastChar = (script + numBytes); info.hasOperators = 0; info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */ - info.exprIsComparison = 0; /* set 1 if topmost operator is <,==,etc. */ + info.exprIsComparison = 0; /* - * Get the first token then compile an expression. + * Parse the expression then compile it. */ - result = GetToken(interp, &info, envPtr); - if (result != TCL_OK) { + maxDepth = 0; + code = Tcl_ParseExpr(interp, script, numBytes, &parse); + if (code != TCL_OK) { goto done; } - - result = CompileCondExpr(interp, &info, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - if (info.token != END) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", string, "\"", (char *) NULL); - result = TCL_ERROR; + + code = CompileSubExpr(parse.tokenPtr, &info, envPtr); + if (code != TCL_OK) { + Tcl_FreeParse(&parse); goto done; } + maxDepth = envPtr->maxStackDepth; + if (!info.hasOperators) { /* * Attempt to convert the primary's object to an int or double. @@ -350,30 +298,54 @@ TclCompileExpr(interp, string, lastChar, flags, envPtr) TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } - maxDepth = envPtr->maxStackDepth; + Tcl_FreeParse(&parse); done: - envPtr->termOffset = (info.next - string); envPtr->maxStackDepth = maxDepth; envPtr->exprIsJustVarRef = info.exprIsJustVarRef; envPtr->exprIsComparison = info.exprIsComparison; - return result; + return code; } /* *---------------------------------------------------------------------- * - * CompileCondExpr -- + * TclFinalizeCompilation -- * - * This procedure compiles a Tcl conditional expression: - * condExpr ::= lorExpr ['?' condExpr ':' condExpr] + * Clean up the compilation environment so it can later be + * properly reinitialized. This procedure is called by + * TclFinalizeCompExecEnv() in tclObj.c, which in turn is called + * by Tcl_Finalize(). + * + * Results: + * None. + * + * Side effects: + * Cleans up the compilation environment. At the moment, just the + * table of expression operators is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeCompilation() +{ + Tcl_MutexLock(&opMutex); + if (opTableInitialized) { + Tcl_DeleteHashTable(&opHashTable); + opTableInitialized = 0; + } + Tcl_MutexUnlock(&opMutex); +} + +/* + *---------------------------------------------------------------------- + * + * CompileSubExpr -- * - * Note that this is the topmost recursive-descent parsing routine used - * by TclCompileExpr to compile expressions. It does not call an - * separate, higher-level "CompileExpr" procedure. This avoids an extra - * procedure call since such a procedure would only return the result - * of calling CompileCondExpr. Other recursive-descent procedures that - * need to parse expressions also call CompileCondExpr. + * Given a pointer to a TCL_TOKEN_SUB_EXPR token describing a + * subexpression, this procedure emits instructions to evaluate the + * subexpression at runtime. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR @@ -381,159 +353,302 @@ TclCompileExpr(interp, string, lastChar, flags, envPtr) * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * elements needed to execute the subexpression. + * + * envPtr->exprIsJustVarRef is set 1 if the subexpression consisted of + * a single variable reference as in the expression of "if $b then...". + * Otherwise it is set 0. This is used to implement Tcl's two level + * expression substitution semantics properly. + * + * envPtr->exprIsComparison is set 1 if the top-level operator in the + * subexpression is a comparison. Otherwise it is set 0. If 1, because + * the operands might be strings, the expr is compiled out-of-line in + * order to implement expr's 2 level substitution semantics properly. * * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. + * Adds instructions to envPtr to evaluate the subexpression. * *---------------------------------------------------------------------- */ static int -CompileCondExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ +CompileSubExpr(exprTokenPtr, infoPtr, envPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * to compile. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ CompileEnv *envPtr; /* Holds resulting instructions. */ { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; - /* Used to update or replace one-byte jumps - * around the then and else expressions when - * their target PCs are determined. */ - int elseCodeOffset, currCodeOffset, jumpDist, result; - - HERE("condExpr", 1); - result = CompileLorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - if (infoPtr->token == QUESTY) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '?' */ - if (result != TCL_OK) { - goto done; - } - - /* - * Emit the jump around the "then" clause to the "else" condExpr if - * the test was false. We emit a one byte (relative) jump here, and - * replace it later with a four byte jump if the jump target is more - * than 127 bytes away. - */ - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); - - /* - * Compile the "then" expression. Note that if a subexpression - * is only a primary, we need to try to convert it to numeric. - * This is done in order to support Tcl's policy of interpreting - * operands if at all possible as first integers, else - * floating-point numbers. - */ + Tcl_Interp *interp = infoPtr->interp; + Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr; + OperatorDesc *opDescPtr; + Tcl_HashEntry *hPtr; + char *operator; + char savedChar; + int maxDepth, objIndex, opIndex, length, code; + char buffer[TCL_UTF_MAX]; - infoPtr->hasOperators = 0; - infoPtr->exprIsJustVarRef = 0; - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - if (infoPtr->token != COLON) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - if (!infoPtr->hasOperators) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); - } - result = GetToken(interp, infoPtr, envPtr); /* skip over the ':' */ - if (result != TCL_OK) { - goto done; - } + if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) { + panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n", + exprTokenPtr->type); + } + maxDepth = 0; + code = TCL_OK; - /* - * Emit an unconditional jump around the "else" condExpr. - */ + /* + * Switch on the type of the first token after the subexpression token. + * After processing it, advance tokenPtr to point just after the + * subexpression's last token. + */ + + tokenPtr = exprTokenPtr+1; + TRACE(exprTokenPtr->start, exprTokenPtr->size, + tokenPtr->start, tokenPtr->size); + switch (tokenPtr->type) { + case TCL_TOKEN_WORD: + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + infoPtr->exprIsJustVarRef = 0; + break; + + case TCL_TOKEN_TEXT: + if (tokenPtr->size > 0) { + objIndex = TclRegisterLiteral(envPtr, tokenPtr->start, + tokenPtr->size, /*onHeap*/ 0); + } else { + objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0); + } + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + tokenPtr += 1; + infoPtr->exprIsJustVarRef = 0; + break; + + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, + buffer); + if (length > 0) { + objIndex = TclRegisterLiteral(envPtr, buffer, length, + /*onHeap*/ 0); + } else { + objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0); + } + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + tokenPtr += 1; + infoPtr->exprIsJustVarRef = 0; + break; + + case TCL_TOKEN_COMMAND: + code = TclCompileScript(interp, tokenPtr->start+1, + tokenPtr->size-2, /*nested*/ 1, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += 1; + infoPtr->exprIsJustVarRef = 0; + break; + + case TCL_TOKEN_VARIABLE: + code = TclCompileTokens(interp, tokenPtr, 1, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + break; + + case TCL_TOKEN_SUB_EXPR: + infoPtr->exprIsComparison = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + break; + + case TCL_TOKEN_OPERATOR: + /* + * Look up the operator. Temporarily overwrite the character + * just after the end of the operator with a 0 byte. If the + * operator isn't found, treat it as a math function. + */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpAroundElseFixup); + /* + * TODO: Note that the string is modified in place. This is unsafe + * and will break if any of the routines called while the string is + * modified have side effects that depend on the original string + * being unmodified (e.g. adding an entry to the literal table). + */ - /* - * Compile the "else" expression. - */ + operator = tokenPtr->start; + savedChar = operator[tokenPtr->size]; + operator[tokenPtr->size] = 0; + hPtr = Tcl_FindHashEntry(&opHashTable, operator); + if (hPtr == NULL) { + code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr, + envPtr, &endPtr); + operator[tokenPtr->size] = (char) savedChar; + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr = endPtr; + infoPtr->exprIsJustVarRef = 0; + infoPtr->exprIsComparison = 0; + break; + } + operator[tokenPtr->size] = (char) savedChar; + opIndex = (int) Tcl_GetHashValue(hPtr); + opDescPtr = &(operatorTable[opIndex]); - infoPtr->hasOperators = 0; - elseCodeOffset = TclCurrCodeOffset(); - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - if (!infoPtr->hasOperators) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); - } + /* + * If the operator is "normal", compile it using information + * from the operator table. + */ - /* - * Fix up the second jump: the unconditional jump around the "else" - * expression. If the distance is too great (> 127 bytes), replace - * it with a four byte instruction and move the instructions after - * the jump down. - */ + if (opDescPtr->numOperands > 0) { + tokenPtr++; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpAroundElseFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, jumpDist, 127)) { + if (opDescPtr->numOperands == 2) { + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), + maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + } + TclEmitOpcode(opDescPtr->instruction, envPtr); + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + infoPtr->exprIsComparison = + ((opIndex >= OP_LESS) && (opIndex <= OP_NEQ)); + break; + } + /* - * Update the else expression's starting code offset since it - * moved down 3 bytes too. + * The operator requires special treatment, and is either + * "+" or "-", or one of "&&", "||" or "?". */ - elseCodeOffset += 3; - } - - /* - * Now fix up the first branch: the jumpFalse after the test. If the - * distance is too great, replace it with a four byte instruction - * and update the code offsets for the commands in both the "then" - * and "else" expressions. - */ - - jumpDist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); - TclFixupForwardJump(envPtr, &jumpAroundThenFixup, jumpDist, 127); - - infoPtr->hasOperators = 1; + switch (opIndex) { + case OP_PLUS: + case OP_MINUS: + tokenPtr++; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + + /* + * Check whether the "+" or "-" is unary. + */ + + afterSubexprPtr = exprTokenPtr + + exprTokenPtr->numComponents+1; + if (tokenPtr == afterSubexprPtr) { + TclEmitOpcode(((opIndex==OP_PLUS)? + INST_UPLUS : INST_UMINUS), + envPtr); + break; + } + + /* + * The "+" or "-" is binary. + */ + + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), + maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), + envPtr); + break; - /* - * A comparison is not the top-level operator in this expression. - */ + case OP_LAND: + case OP_LOR: + code = CompileLandOrLorExpr(exprTokenPtr, opIndex, + infoPtr, envPtr, &endPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr = endPtr; + break; + + case OP_QUESTY: + code = CompileCondExpr(exprTokenPtr, infoPtr, + envPtr, &endPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr = endPtr; + break; + + default: + panic("CompileSubExpr: unexpected operator %d requiring special treatment\n", + opIndex); + } /* end switch on operator requiring special treatment */ + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + infoPtr->exprIsComparison = 0; + break; - infoPtr->exprIsComparison = 0; + default: + panic("CompileSubExpr: unexpected token type %d\n", + tokenPtr->type); } + /* + * Verify that the subexpression token had the required number of + * subtokens: that we've advanced tokenPtr just beyond the + * subexpression's last token. For example, a "*" subexpression must + * contain the tokens for exactly two operands. + */ + + if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) { + LogSyntaxError(infoPtr); + code = TCL_ERROR; + } + done: envPtr->maxStackDepth = maxDepth; - return result; + return code; } /* *---------------------------------------------------------------------- * - * CompileLorExpr -- + * CompileLandOrLorExpr -- * - * This procedure compiles a Tcl logical or expression: - * lorExpr ::= landExpr {'||' landExpr} + * This procedure compiles a Tcl logical and ("&&") or logical or + * ("||") subexpression. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * on failure. If TCL_OK is returned, a pointer to the token just after + * the last one in the subexpression is stored at the address in + * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack @@ -546,161 +661,116 @@ CompileCondExpr(interp, infoPtr, flags, envPtr) */ static int -CompileLorExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * containing the "&&" or "||" operator. */ + int opIndex; /* A code describing the expression + * operator: either OP_LAND or OP_LOR. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token + * just after the last token in the + * subexpression is stored here. */ { - int maxDepth; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixupArray jumpFixupArray; - /* Used to fix up the forward "short - * circuit" jump after each or-ed - * subexpression to just after the last - * subexpression. */ - JumpFixup jumpTrueFixup, jumpFixup; - /* Used to emit the jumps in the code to - * convert the first operand to a 0 or 1. */ - int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result; - Tcl_Obj *objPtr; - - HERE("lorExpr", 2); - result = CompileLandExpr(interp, infoPtr, flags, envPtr); - if ((result != TCL_OK) || (infoPtr->token != OR)) { - return result; /* envPtr->maxStackDepth is already set */ - } - - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - maxDepth = envPtr->maxStackDepth; - TclInitJumpFixupArray(&jumpFixupArray); - while (infoPtr->token == OR) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '||' */ - if (result != TCL_OK) { - goto done; - } - - if (jumpFixupArray.next == 0) { - /* - * Just the first "lor" operand is on the stack. The following - * is slightly ugly: we need to convert that first "lor" operand - * to a "0" or "1" to get the correct result if it is nonzero. - * Eventually we'll use a new instruction for this. - */ - - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup); - - objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) { - panic("CompileLorExpr: bad jump distance %d\n", jumpDist); - } - objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 1; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); - - jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("CompileLorExpr: bad jump distance %d\n", jumpDist); - } - } + JumpFixup shortCircuitFixup; /* Used to fix up the short circuit jump + * after the first subexpression. */ + JumpFixup lhsTrueFixup, lhsEndFixup; + /* Used to fix up jumps used to convert the + * first operand to 0 or 1. */ + Tcl_Token *tokenPtr; + int dist, maxDepth, code; - /* - * Duplicate the value on top of the stack to prevent the jump from - * consuming it. - */ + /* + * Emit code for the first operand. + */ - TclEmitOpcode(INST_DUP, envPtr); + maxDepth = 0; + tokenPtr = exprTokenPtr+2; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); - /* - * Emit the "short circuit" jump around the rest of the lorExp if - * the previous expression was true. We emit a one byte (relative) - * jump here, and replace it later with a four byte jump if the jump - * target is more than 127 bytes away. - */ + /* + * Convert the first operand to the result that Tcl requires: + * "0" or "1". Eventually we'll use a new instruction for this. + */ + + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup); + TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup); + dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) { + badDist: + panic("CompileLandOrLorExpr: bad jump distance %d\n", dist); + } + TclEmitPush(TclRegisterLiteral(envPtr, "1", 1, /*onHeap*/ 0), envPtr); + dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) { + goto badDist; + } - if (jumpFixupArray.next == jumpFixupArray.end) { - TclExpandJumpFixupArray(&jumpFixupArray); - } - fixupIndex = jumpFixupArray.next; - jumpFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, - &(jumpFixupArray.fixup[fixupIndex])); - - /* - * Compile the subexpression. - */ + /* + * Emit the "short circuit" jump around the rest of the expression. + * Duplicate the "0" or "1" on top of the stack first to keep the + * jump from consuming it. + */ - result = CompileLandExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + TclEmitOpcode(INST_DUP, envPtr); + TclEmitForwardJump(envPtr, + ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP), + &shortCircuitFixup); - /* - * Emit a "logical or" instruction. This does not try to "short- - * circuit" the evaluation of both operands of a Tcl "||" operator, - * but instead ensures that we either have a "1" or a "0" result. - */ + /* + * Emit code for the second operand. + */ - TclEmitOpcode(INST_LOR, envPtr); + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); /* - * Now that we know the target of the forward jumps, update the jumps - * with the correct distance. Also, if the distance is too great (> 127 - * bytes), replace the jump with a four byte instruction and move the - * instructions after the jump down. + * Emit a "logical and" or "logical or" instruction. This does not try + * to "short- circuit" the evaluation of both operands, but instead + * ensures that we either have a "1" or a "0" result. */ - - for (j = jumpFixupArray.next; j > 0; j--) { - fixupIndex = (j - 1); /* process closest jump first */ - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset); - TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127); - } + + TclEmitOpcode(((opIndex==OP_LAND)? INST_LAND : INST_LOR), envPtr); /* - * We get here only if one or more ||'s appear as top-level operators. + * Now that we know the target of the forward jump, update it with the + * correct distance. */ + dist = (envPtr->codeNext - envPtr->codeStart) + - shortCircuitFixup.codeOffset; + TclFixupForwardJump(envPtr, &shortCircuitFixup, dist, 127); + *endPtrPtr = tokenPtr; + done: - infoPtr->exprIsComparison = 0; - TclFreeJumpFixupArray(&jumpFixupArray); envPtr->maxStackDepth = maxDepth; - return result; + return code; } /* *---------------------------------------------------------------------- * - * CompileLandExpr -- + * CompileCondExpr -- * - * This procedure compiles a Tcl logical and expression: - * landExpr ::= bitOrExpr {'&&' bitOrExpr} + * This procedure compiles a Tcl conditional expression: + * condExpr ::= lorExpr ['?' condExpr ':' condExpr] * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * on failure. If TCL_OK is returned, a pointer to the token just after + * the last one in the subexpression is stored at the address in + * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack @@ -713,997 +783,109 @@ CompileLorExpr(interp, infoPtr, flags, envPtr) */ static int -CompileLandExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ +CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * containing the "?" operator. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ CompileEnv *envPtr; /* Holds resulting instructions. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token + * just after the last token in the + * subexpression is stored here. */ { - int maxDepth; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixupArray jumpFixupArray; - /* Used to fix up the forward "short - * circuit" jump after each and-ed - * subexpression to just after the last - * subexpression. */ - JumpFixup jumpTrueFixup, jumpFixup; - /* Used to emit the jumps in the code to - * convert the first operand to a 0 or 1. */ - int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result; - Tcl_Obj *objPtr; - - HERE("landExpr", 3); - result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); - if ((result != TCL_OK) || (infoPtr->token != AND)) { - return result; /* envPtr->maxStackDepth is already set */ - } + JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; + /* Used to update or replace one-byte jumps + * around the then and else expressions when + * their target PCs are determined. */ + Tcl_Token *tokenPtr; + int elseCodeOffset, dist, maxDepth, code; - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - maxDepth = envPtr->maxStackDepth; - TclInitJumpFixupArray(&jumpFixupArray); - while (infoPtr->token == AND) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '&&' */ - if (result != TCL_OK) { - goto done; - } + /* + * Emit code for the test. + */ - if (jumpFixupArray.next == 0) { - /* - * Just the first "land" operand is on the stack. The following - * is slightly ugly: we need to convert the first "land" operand - * to a "0" or "1" to get the correct result if it is - * nonzero. Eventually we'll use a new instruction. - */ - - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup); - - objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) { - panic("CompileLandExpr: bad jump distance %d\n", jumpDist); - } - objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 1; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); - - jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("CompileLandExpr: bad jump distance %d\n", jumpDist); - } - } - - /* - * Duplicate the value on top of the stack to prevent the jump from - * consuming it. - */ - - TclEmitOpcode(INST_DUP, envPtr); - - /* - * Emit the "short circuit" jump around the rest of the landExp if - * the previous expression was false. We emit a one byte (relative) - * jump here, and replace it later with a four byte jump if the jump - * target is more than 127 bytes away. - */ - - if (jumpFixupArray.next == jumpFixupArray.end) { - TclExpandJumpFixupArray(&jumpFixupArray); - } - fixupIndex = jumpFixupArray.next; - jumpFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &(jumpFixupArray.fixup[fixupIndex])); - - /* - * Compile the subexpression. - */ - - result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - /* - * Emit a "logical and" instruction. This does not try to "short- - * circuit" the evaluation of both operands of a Tcl "&&" operator, - * but instead ensures that we either have a "1" or a "0" result. - */ - - TclEmitOpcode(INST_LAND, envPtr); - } - - /* - * Now that we know the target of the forward jumps, update the jumps - * with the correct distance. Also, if the distance is too great (> 127 - * bytes), replace the jump with a four byte instruction and move the - * instructions after the jump down. - */ - - for (j = jumpFixupArray.next; j > 0; j--) { - fixupIndex = (j - 1); /* process closest jump first */ - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset); - TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), - jumpDist, 127); - } - - /* - * We get here only if one or more &&'s appear as top-level operators. - */ - - done: - infoPtr->exprIsComparison = 0; - TclFreeJumpFixupArray(&jumpFixupArray); - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileBitOrExpr -- - * - * This procedure compiles a Tcl bitwise or expression: - * bitOrExpr ::= bitXorExpr {'|' bitXorExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileBitOrExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - - HERE("bitOrExpr", 4); - result = CompileBitXorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - while (infoPtr->token == BIT_OR) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '|' */ - if (result != TCL_OK) { - goto done; - } - - result = CompileBitXorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITOR, envPtr); - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileBitXorExpr -- - * - * This procedure compiles a Tcl bitwise exclusive or expression: - * bitXorExpr ::= bitAndExpr {'^' bitAndExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileBitXorExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - - HERE("bitXorExpr", 5); - result = CompileBitAndExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - while (infoPtr->token == BIT_XOR) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '^' */ - if (result != TCL_OK) { - goto done; - } - - result = CompileBitAndExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITXOR, envPtr); - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileBitAndExpr -- - * - * This procedure compiles a Tcl bitwise and expression: - * bitAndExpr ::= equalityExpr {'&' equalityExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileBitAndExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - - HERE("bitAndExpr", 6); - result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - while (infoPtr->token == BIT_AND) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '&' */ - if (result != TCL_OK) { - goto done; - } - - result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITAND, envPtr); - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileEqualityExpr -- - * - * This procedure compiles a Tcl equality (inequality) expression: - * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileEqualityExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("equalityExpr", 7); - result = CompileRelationalExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == EQUAL) || (op == NEQ)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over == or != */ - if (result != TCL_OK) { - goto done; - } - - result = CompileRelationalExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == EQUAL) { - TclEmitOpcode(INST_EQ, envPtr); - } else { - TclEmitOpcode(INST_NEQ, envPtr); - } - - op = infoPtr->token; - - /* - * A comparison _is_ the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 1; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileRelationalExpr -- - * - * This procedure compiles a Tcl relational expression: - * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileRelationalExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("relationalExpr", 8); - result = CompileShiftExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == LESS) || (op == GREATER) || (op == LEQ) || (op == GEQ)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the op */ - if (result != TCL_OK) { - goto done; - } - - result = CompileShiftExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - switch (op) { - case LESS: - TclEmitOpcode(INST_LT, envPtr); - break; - case GREATER: - TclEmitOpcode(INST_GT, envPtr); - break; - case LEQ: - TclEmitOpcode(INST_LE, envPtr); - break; - case GEQ: - TclEmitOpcode(INST_GE, envPtr); - break; - } - - op = infoPtr->token; - - /* - * A comparison _is_ the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 1; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileShiftExpr -- - * - * This procedure compiles a Tcl shift expression: - * shiftExpr ::= addExpr {('<<' | '>>') addExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileShiftExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("shiftExpr", 9); - result = CompileAddExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == LEFT_SHIFT) || (op == RIGHT_SHIFT)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over << or >> */ - if (result != TCL_OK) { - goto done; - } - - result = CompileAddExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == LEFT_SHIFT) { - TclEmitOpcode(INST_LSHIFT, envPtr); - } else { - TclEmitOpcode(INST_RSHIFT, envPtr); - } - - op = infoPtr->token; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileAddExpr -- - * - * This procedure compiles a Tcl addition expression: - * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileAddExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("addExpr", 10); - result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == PLUS) || (op == MINUS)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over + or - */ - if (result != TCL_OK) { - goto done; - } - - result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == PLUS) { - TclEmitOpcode(INST_ADD, envPtr); - } else { - TclEmitOpcode(INST_SUB, envPtr); - } - - op = infoPtr->token; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileMultiplyExpr -- - * - * This procedure compiles a Tcl multiply expression: - * multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileMultiplyExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("multiplyExpr", 11); - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == MULT) || (op == DIVIDE) || (op == MOD)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over * or / */ - if (result != TCL_OK) { - goto done; - } - - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == MULT) { - TclEmitOpcode(INST_MULT, envPtr); - } else if (op == DIVIDE) { - TclEmitOpcode(INST_DIV, envPtr); - } else { - TclEmitOpcode(INST_MOD, envPtr); - } - - op = infoPtr->token; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileUnaryExpr -- - * - * This procedure compiles a Tcl unary expression: - * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileUnaryExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("unaryExpr", 12); - op = infoPtr->token; - if ((op == PLUS) || (op == MINUS) || (op == BIT_NOT) || (op == NOT)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the op */ - if (result != TCL_OK) { - goto done; - } - - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - switch (op) { - case PLUS: - TclEmitOpcode(INST_UPLUS, envPtr); - break; - case MINUS: - TclEmitOpcode(INST_UMINUS, envPtr); - break; - case BIT_NOT: - TclEmitOpcode(INST_BITNOT, envPtr); - break; - case NOT: - TclEmitOpcode(INST_LNOT, envPtr); - break; - } - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } else { /* must be a primaryExpr */ - result = CompilePrimaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; + maxDepth = 0; + tokenPtr = exprTokenPtr+2; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + + /* + * Emit the jump to the "else" expression if the test was false. + */ + + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompilePrimaryExpr -- - * - * This procedure compiles a Tcl primary expression: - * primaryExpr ::= literal | varReference | quotedString | - * '[' command ']' | mathFuncCall | '(' condExpr ')' - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ + /* + * Compile the "then" expression. Note that if a subexpression is only + * a primary, we need to try to convert it to numeric. We do this to + * support Tcl's policy of interpreting operands if at all possible as + * first integers, else floating-point numbers. + */ -static int -CompilePrimaryExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int theToken; - char *dollarPtr, *quotePtr, *cmdPtr, *termPtr; - int result = TCL_OK; + infoPtr->hasOperators = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + if (!infoPtr->hasOperators) { + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); + } /* - * We emit tryCvtToNumeric instructions after most of these primary - * expressions in order to support Tcl's policy of interpreting operands - * as first integers if possible, otherwise floating-point numbers if - * possible. + * Emit an unconditional jump around the "else" condExpr. */ + + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &jumpAroundElseFixup); - HERE("primaryExpr", 13); - theToken = infoPtr->token; + /* + * Compile the "else" expression. + */ - if ((theToken != DOLLAR) && (theToken != OPEN_PAREN)) { - infoPtr->exprIsJustVarRef = 0; + elseCodeOffset = (envPtr->codeNext - envPtr->codeStart); + infoPtr->hasOperators = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; } - switch (theToken) { - case LITERAL: /* int, double, or string in braces */ - TclEmitPush(infoPtr->objIndex, envPtr); - maxDepth = 1; - break; - - case DOLLAR: /* $var variable reference */ - dollarPtr = (infoPtr->next - 1); - envPtr->pushSimpleWords = 1; - result = TclCompileDollarVar(interp, dollarPtr, - infoPtr->lastChar, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - infoPtr->next = (dollarPtr + envPtr->termOffset); - break; - - case QUOTE: /* quotedString */ - quotePtr = infoPtr->next; - envPtr->pushSimpleWords = 1; - result = TclCompileQuotes(interp, quotePtr, - infoPtr->lastChar, '"', flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - infoPtr->next = (quotePtr + envPtr->termOffset); - break; - - case OPEN_BRACKET: /* '[' command ']' */ - cmdPtr = infoPtr->next; - envPtr->pushSimpleWords = 1; - result = TclCompileString(interp, cmdPtr, - infoPtr->lastChar, (flags | TCL_BRACKET_TERM), envPtr); - if (result != TCL_OK) { - goto done; - } - termPtr = (cmdPtr + envPtr->termOffset); - if (*termPtr == ']') { - infoPtr->next = (termPtr + 1); /* advance over the ']'. */ - } else if (termPtr == infoPtr->lastChar) { - /* - * Missing ] at end of nested command. - */ - - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-bracket", -1); - result = TCL_ERROR; - goto done; - } else { - panic("CompilePrimaryExpr: unexpected termination char '%c' for nested command\n", *termPtr); - } - maxDepth = envPtr->maxStackDepth; - break; - - case FUNC_NAME: - result = CompileMathFuncCall(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - break; - - case OPEN_PAREN: - result = GetToken(interp, infoPtr, envPtr); /* skip over the '(' */ - if (result != TCL_OK) { - goto done; - } - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - if (infoPtr->token != CLOSE_PAREN) { - goto syntaxError; - } - break; - - default: - goto syntaxError; + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + if (!infoPtr->hasOperators) { + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } - if (theToken != FUNC_NAME) { + /* + * Fix up the second jump around the "else" expression. + */ + + dist = (envPtr->codeNext - envPtr->codeStart) + - jumpAroundElseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) { /* - * Advance to the next token before returning. + * Update the else expression's starting code offset since it + * moved down 3 bytes too. */ - result = GetToken(interp, infoPtr, envPtr); - if (result != TCL_OK) { - goto done; - } + elseCodeOffset += 3; } + + /* + * Fix up the first jump to the "else" expression if the test was false. + */ + + dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); + TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127); + *endPtrPtr = tokenPtr; done: envPtr->maxStackDepth = maxDepth; - return result; - - syntaxError: - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - return TCL_ERROR; + return code; } /* @@ -1716,7 +898,9 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr) * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * on failure. If TCL_OK is returned, a pointer to the token just after + * the last one in the subexpression is stored at the address in + * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack @@ -1730,58 +914,35 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr) */ static int -CompileMathFuncCall(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ +CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * containing the math function call. */ + char *funcName; /* Name of the math function. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ CompileEnv *envPtr; /* Holds resulting instructions. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token + * just after the last token in the + * subexpression is stored here. */ { + Tcl_Interp *interp = infoPtr->interp; Interp *iPtr = (Interp *) interp; - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - MathFunc *mathFuncPtr; /* Info about math function. */ - int objIndex; /* The object array index for an object - * holding the function name if it is not - * builtin. */ + MathFunc *mathFuncPtr; Tcl_HashEntry *hPtr; - char *p, *funcName; - char savedChar; - int result, i; + Tcl_Token *tokenPtr, *afterSubexprPtr; + int maxDepth, code, i; /* - * infoPtr->funcName points to the first character of the math - * function's name. Look for the end of its name and look up the - * MathFunc record for the function. + * Look up the MathFunc record for the function. */ - funcName = p = infoPtr->funcName; - while (isalnum(UCHAR(*p)) || (*p == '_')) { - p++; - } - infoPtr->next = p; - - result = GetToken(interp, infoPtr, envPtr); /* skip over func name */ - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token != OPEN_PAREN) { - goto syntaxError; - } - result = GetToken(interp, infoPtr, envPtr); /* skip over '(' */ - if (result != TCL_OK) { - goto done; - } - - savedChar = *p; - *p = 0; + code = TCL_OK; + maxDepth = 0; hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown math function \"", funcName, "\"", (char *) NULL); - result = TCL_ERROR; - *p = savedChar; + code = TCL_ERROR; goto done; } mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); @@ -1790,597 +951,98 @@ CompileMathFuncCall(interp, infoPtr, flags, envPtr) * If not a builtin function, push an object with the function's name. */ - if (mathFuncPtr->builtinFuncIndex < 0) { /* not builtin */ - objIndex = TclObjIndexForString(funcName, -1, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); + if (mathFuncPtr->builtinFuncIndex < 0) { + TclEmitPush(TclRegisterLiteral(envPtr, funcName, -1, /*onHeap*/ 0), + envPtr); maxDepth = 1; } /* - * Restore the saved character after the function name. - */ - - *p = savedChar; - - /* - * Compile the arguments for the function, if there are any. + * Compile any arguments for the function. */ + tokenPtr = exprTokenPtr+2; + afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1); if (mathFuncPtr->numArgs > 0) { - for (i = 0; ; i++) { - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + for (i = 0; i < mathFuncPtr->numArgs; i++) { + if (tokenPtr == afterSubexprPtr) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too few arguments for math function", -1); + code = TCL_ERROR; goto done; } - - /* - * Check for a ',' between arguments or a ')' ending the - * argument list. - */ - - if (i == (mathFuncPtr->numArgs-1)) { - if (infoPtr->token == CLOSE_PAREN) { - break; /* exit the argument parsing loop */ - } else if (infoPtr->token == COMMA) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many arguments for math function", -1); - result = TCL_ERROR; - goto done; - } else { - goto syntaxError; - } - } - if (infoPtr->token != COMMA) { - if (infoPtr->token == CLOSE_PAREN) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too few arguments for math function", -1); - result = TCL_ERROR; - goto done; - } else { - goto syntaxError; - } - } - result = GetToken(interp, infoPtr, envPtr); /* skip over , */ - if (result != TCL_OK) { + infoPtr->exprIsComparison = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } + tokenPtr += (tokenPtr->numComponents + 1); maxDepth++; } - } - - if (infoPtr->token != CLOSE_PAREN) { - goto syntaxError; - } - result = GetToken(interp, infoPtr, envPtr); /* skip over ')' */ - if (result != TCL_OK) { + if (tokenPtr != afterSubexprPtr) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many arguments for math function", -1); + code = TCL_ERROR; + goto done; + } + } else if (tokenPtr != afterSubexprPtr) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many arguments for math function", -1); + code = TCL_ERROR; goto done; } /* * Compile the call on the math function. Note that the "objc" argument * count for non-builtin functions is incremented by 1 to include the - * the function name itself. + * function name itself. */ if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */ - TclEmitInstUInt1(INST_CALL_BUILTIN_FUNC1, - mathFuncPtr->builtinFuncIndex, envPtr); + TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1, + mathFuncPtr->builtinFuncIndex, envPtr); } else { - TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); + TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); } - - /* - * A comparison is not the top-level operator in this expression. - */ + *endPtrPtr = afterSubexprPtr; done: - infoPtr->exprIsComparison = 0; envPtr->maxStackDepth = maxDepth; - return result; - - syntaxError: - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * GetToken -- - * - * Lexical scanner used to compile expressions: parses a single - * operator or other syntactic element from an expression string. - * - * Results: - * TCL_OK is returned unless an error occurred. In that case a standard - * Tcl error is returned, using the interpreter's result to hold an - * error message. TCL_ERROR is returned if an integer overflow, or a - * floating-point overflow or underflow occurred while reading in a - * number. If the lexical analysis is successful, infoPtr->token refers - * to the next symbol in the expression string, and infoPtr->next is - * advanced past the token. Also, if the token is a integer, double, or - * string literal, then infoPtr->objIndex the index of an object - * holding the value in the code's object table; otherwise is NULL. - * - * Side effects: - * Object are added to envPtr to hold the values of scanned literal - * integers, doubles, or strings. - * - *---------------------------------------------------------------------- - */ - -static int -GetToken(interp, infoPtr, envPtr) - Tcl_Interp *interp; /* Interpreter to use for error - * reporting. */ - register ExprInfo *infoPtr; /* Describes the state of the - * compiling the expression, - * including the resulting token. */ - CompileEnv *envPtr; /* Holds objects that store literal - * values that are scanned. */ -{ - register char *src; /* Points to current source char. */ - register char c; /* The current char. */ - register int type; /* Current char's CHAR_TYPE type. */ - char *termPtr; /* Points to char terminating a literal. */ - char savedChar; /* Holds the character termporarily replaced - * by a null character during processing of - * literal tokens. */ - int objIndex; /* The object array index for an object - * holding a scanned literal. */ - long longValue; /* Value of a scanned integer literal. */ - double doubleValue; /* Value of a scanned double literal. */ - Tcl_Obj *objPtr; - - /* - * First initialize the scanner's "result" fields to default values. - */ - - infoPtr->token = UNKNOWN; - infoPtr->objIndex = -1; - infoPtr->funcName = NULL; - - /* - * Scan over leading white space at the start of a token. Note that a - * backslash-newline is treated as a space. - */ - - src = infoPtr->next; - c = *src; - type = CHAR_TYPE(src, infoPtr->lastChar); - while ((type & (TCL_SPACE | TCL_BACKSLASH)) || (c == '\n')) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; /* no longer white space */ - } - } else { - src++; - } - c = *src; - type = CHAR_TYPE(src, infoPtr->lastChar); - } - if (src == infoPtr->lastChar) { - infoPtr->token = END; - infoPtr->next = src; - return TCL_OK; - } - - /* - * Try to parse the token first as an integer or floating-point - * number. Don't check for a number if the first character is "+" or - * "-". If we did, we might treat a binary operator as unary by mistake, - * which would eventually cause a syntax error. - */ - - if ((*src != '+') && (*src != '-')) { - int startsWithDigit = isdigit(UCHAR(*src)); - - if (startsWithDigit && TclLooksLikeInt(src)) { - errno = 0; - longValue = strtoul(src, &termPtr, 0); - if (errno == ERANGE) { - char *s = "integer value too large to represent"; - - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, - (char *) NULL); - return TCL_ERROR; - } - if (termPtr != src) { - /* - * src was the start of a valid integer. Find/create an - * object in envPtr's object array to contain the integer. - */ - - savedChar = *termPtr; - *termPtr = '\0'; - objIndex = TclObjIndexForString(src, termPtr - src, - /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); - *termPtr = savedChar; /* restore the saved char */ - - objPtr = envPtr->objArrayPtr[objIndex]; - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = longValue; - objPtr->typePtr = &tclIntType; - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = termPtr; - return TCL_OK; - } - } else if (startsWithDigit || (*src == '.') - || (*src == 'n') || (*src == 'N')) { - errno = 0; - doubleValue = strtod(src, &termPtr); - if (termPtr != src) { - if (errno != 0) { - TclExprFloatError(interp, doubleValue); - return TCL_ERROR; - } - - /* - * Find/create an object in the object array containing the - * double. - */ - - savedChar = *termPtr; - *termPtr = '\0'; - objIndex = TclObjIndexForString(src, termPtr - src, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - *termPtr = savedChar; /* restore the saved char */ - - objPtr = envPtr->objArrayPtr[objIndex]; - objPtr->internalRep.doubleValue = doubleValue; - objPtr->typePtr = &tclDoubleType; - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = termPtr; - return TCL_OK; - } - } - } - - /* - * Not an integer or double literal. Check next for a string literal - * in braces. - */ - - if (*src == '{') { - int level = 0; /* The {} nesting level. */ - int hasBackslashNL = 0; /* Nonzero if '\newline' was found. */ - char *string = src; /* Set below to point just after the - * starting '{'. */ - char *last; /* Points just before terminating '}'. */ - int numChars; /* Number of chars in braced string. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null char - * during braced string processing. */ - int numRead; - - /* - * Check first for any backslash-newlines, since we must treat - * backslash-newlines specially (they must be replaced by spaces). - */ - - while (1) { - if (src == infoPtr->lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-brace", -1); - return TCL_ERROR; - } else if (CHAR_TYPE(src, infoPtr->lastChar) == TCL_NORMAL) { - src++; - continue; - } - c = *src++; - if (c == '{') { - level++; - } else if (c == '}') { - --level; - if (level == 0) { - last = (src - 2); /* i.e. just before terminating } */ - break; - } - } else if (c == '\\') { - if (*src == '\n') { - hasBackslashNL = 1; - } - (void) Tcl_Backslash(src-1, &numRead); - src += numRead - 1; - } - } - - /* - * Create a string object for the braced string. This will start at - * "string" and ends just after "last" (which points to the final - * character before the terminating '}'). If backslash-newlines were - * found, we copy characters one at a time into a heap-allocated - * buffer and do backslash-newline substitutions. - */ - - string++; - numChars = (last - string + 1); - savedChar = string[numChars]; - string[numChars] = '\0'; - if (hasBackslashNL && (numChars > 0)) { - char *buffer = ckalloc((unsigned) numChars + 1); - register char *dst = buffer; - register char *p = string; - while (p <= last) { - c = *dst++ = *p++; - if (c == '\\') { - if (*p == '\n') { - dst[-1] = Tcl_Backslash(p-1, &numRead); - p += numRead - 1; - } else { - (void) Tcl_Backslash(p-1, &numRead); - while (numRead > 1) { - *dst++ = *p++; - numRead--; - } - } - } - } - *dst = '\0'; - objIndex = TclObjIndexForString(buffer, dst - buffer, - /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); - } else { - objIndex = TclObjIndexForString(string, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - } - string[numChars] = savedChar; /* restore the saved char */ - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = src; - return TCL_OK; - } - - /* - * Not an literal value. - */ - - infoPtr->next = src+1; /* assume a 1 char token and advance over it */ - switch (*src) { - case '[': - infoPtr->token = OPEN_BRACKET; - return TCL_OK; - - case ']': - infoPtr->token = CLOSE_BRACKET; - return TCL_OK; - - case '(': - infoPtr->token = OPEN_PAREN; - return TCL_OK; - - case ')': - infoPtr->token = CLOSE_PAREN; - return TCL_OK; - - case '$': - infoPtr->token = DOLLAR; - return TCL_OK; - - case '"': - infoPtr->token = QUOTE; - return TCL_OK; - - case ',': - infoPtr->token = COMMA; - return TCL_OK; - - case '*': - infoPtr->token = MULT; - return TCL_OK; - - case '/': - infoPtr->token = DIVIDE; - return TCL_OK; - - case '%': - infoPtr->token = MOD; - return TCL_OK; - - case '+': - infoPtr->token = PLUS; - return TCL_OK; - - case '-': - infoPtr->token = MINUS; - return TCL_OK; - - case '?': - infoPtr->token = QUESTY; - return TCL_OK; - - case ':': - infoPtr->token = COLON; - return TCL_OK; - - case '<': - switch (src[1]) { - case '<': - infoPtr->next = src+2; - infoPtr->token = LEFT_SHIFT; - break; - case '=': - infoPtr->next = src+2; - infoPtr->token = LEQ; - break; - default: - infoPtr->token = LESS; - break; - } - return TCL_OK; - - case '>': - switch (src[1]) { - case '>': - infoPtr->next = src+2; - infoPtr->token = RIGHT_SHIFT; - break; - case '=': - infoPtr->next = src+2; - infoPtr->token = GEQ; - break; - default: - infoPtr->token = GREATER; - break; - } - return TCL_OK; - - case '=': - if (src[1] == '=') { - infoPtr->next = src+2; - infoPtr->token = EQUAL; - } else { - infoPtr->token = UNKNOWN; - } - return TCL_OK; - - case '!': - if (src[1] == '=') { - infoPtr->next = src+2; - infoPtr->token = NEQ; - } else { - infoPtr->token = NOT; - } - return TCL_OK; - - case '&': - if (src[1] == '&') { - infoPtr->next = src+2; - infoPtr->token = AND; - } else { - infoPtr->token = BIT_AND; - } - return TCL_OK; - - case '^': - infoPtr->token = BIT_XOR; - return TCL_OK; - - case '|': - if (src[1] == '|') { - infoPtr->next = src+2; - infoPtr->token = OR; - } else { - infoPtr->token = BIT_OR; - } - return TCL_OK; - - case '~': - infoPtr->token = BIT_NOT; - return TCL_OK; - - default: - if (isalpha(UCHAR(*src))) { - infoPtr->token = FUNC_NAME; - infoPtr->funcName = src; - while (isalnum(UCHAR(*src)) || (*src == '_')) { - src++; - } - infoPtr->next = src; - return TCL_OK; - } - infoPtr->next = src+1; - infoPtr->token = UNKNOWN; - return TCL_OK; - } + return code; } /* *---------------------------------------------------------------------- * - * Tcl_CreateMathFunc -- + * LogSyntaxError -- * - * Creates a new math function for expressions in a given - * interpreter. + * This procedure is invoked after an error occurs when compiling an + * expression. It sets the interpreter result to an error message + * describing the error. * * Results: * None. * * Side effects: - * The function defined by "name" is created or redefined. If the - * function already exists then its definition is replaced; this - * includes the builtin functions. Redefining a builtin function forces - * all existing code to be invalidated since that code may be compiled - * using an instruction specific to the replaced function. In addition, - * redefioning a non-builtin function will force existing code to be - * invalidated if the number of arguments has changed. + * Sets the interpreter result to an error message describing the + * expression that was being compiled when the error occurred. * *---------------------------------------------------------------------- */ -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"). */ - int numArgs; /* Nnumber of arguments required by - * function. */ - Tcl_ValueType *argTypes; /* Array of types acceptable for - * each argument. */ - Tcl_MathProc *proc; /* Procedure that implements the - * math function. */ - ClientData clientData; /* Additional value to pass to the - * function. */ +static void +LogSyntaxError(infoPtr) + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ { - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int new, i; - - hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); - if (new) { - Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - - if (!new) { - if (mathFuncPtr->builtinFuncIndex >= 0) { - /* - * We are redefining a builtin math function. Invalidate the - * interpreter's existing code by incrementing its - * compileEpoch member. This field is checked in Tcl_EvalObj - * and ObjInterpProc, and code whose compilation epoch doesn't - * match is recompiled. Newly compiled code will no longer - * treat the function as builtin. - */ - - iPtr->compileEpoch++; - } else { - /* - * A non-builtin function is being redefined. We must invalidate - * existing code if the number of arguments has changed. This - * is because existing code was compiled assuming that number. - */ + int numBytes = (infoPtr->lastChar - infoPtr->expr); + char buffer[100]; - if (numArgs != mathFuncPtr->numArgs) { - iPtr->compileEpoch++; - } - } - } - - mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ - if (numArgs > MAX_MATH_ARGS) { - numArgs = MAX_MATH_ARGS; - } - mathFuncPtr->numArgs = numArgs; - for (i = 0; i < numArgs; i++) { - mathFuncPtr->argTypes[i] = argTypes[i]; - } - mathFuncPtr->proc = proc; - mathFuncPtr->clientData = clientData; + sprintf(buffer, "syntax error in expression \"%.*s\"", + ((numBytes > 60)? 60 : numBytes), infoPtr->expr); + Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), + buffer, (char *) NULL); } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 15a30a7..12b6cd4 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -5,19 +5,27 @@ * of commands (like quoted strings or nested sub-commands) into a * sequence of instructions ("bytecodes"). * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1996-1998 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: tclCompile.c,v 1.13 1999/02/03 00:55:04 stanton Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.14 1999/04/16 00:46:44 stanton Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* + * Table of all AuxData types. + */ + +static Tcl_HashTable auxDataTypeTable; +static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ + +TCL_DECLARE_MUTEX(tableMutex) + +/* * Variable that controls whether compilation tracing is enabled and, if so, * what level of tracing is desired: * 0: no compilation tracing @@ -30,34 +38,11 @@ int tclTraceCompile = 0; static int traceInitialized = 0; /* - * Count of the number of compilations and various other compilation- - * related statistics. - */ - -#ifdef TCL_COMPILE_STATS -long tclNumCompilations = 0; -double tclTotalSourceBytes = 0.0; -double tclTotalCodeBytes = 0.0; - -double tclTotalInstBytes = 0.0; -double tclTotalObjBytes = 0.0; -double tclTotalExceptBytes = 0.0; -double tclTotalAuxBytes = 0.0; -double tclTotalCmdMapBytes = 0.0; - -double tclCurrentSourceBytes = 0.0; -double tclCurrentCodeBytes = 0.0; - -int tclSourceCount[32]; -int tclByteCodeCount[32]; -#endif /* TCL_COMPILE_STATS */ - -/* - * A table describing the Tcl bytecode instructions. The entries in this - * table must correspond to the list of instructions in tclInt.h. The names - * "op1" and "op4" refer to an instruction's one or four byte first operand. - * Similarly, "stktop" and "stknext" refer to the topmost and next to - * topmost stack elements. + * A table describing the Tcl bytecode instructions. Entries in this table + * must correspond to the instruction opcode definitions in tclCompile.h. + * The names "op1" and "op4" refer to an instruction's one or four byte + * first operand. Similarly, "stktop" and "stknext" refer to the topmost + * and next to topmost stack elements. * * Note that the load, store, and incr instructions do not distinguish local * from global variables; the bytecode interpreter at runtime uses the @@ -216,7 +201,7 @@ InstructionDesc instructionTable[] = { * terminate loop, else push 1. */ {"beginCatch4", 5, 1, {OPERAND_UINT4}}, - /* Record start of catch with the operand's exception range index. + /* Record start of catch with the operand's exception index. * Push the current stack depth onto a special catch stack. */ {"endCatch", 1, 0, {OPERAND_NONE}}, /* End of last catch. Pop the bytecode interpreter's catch stack. */ @@ -229,191 +214,32 @@ InstructionDesc instructionTable[] = { }; /* - * The following table assigns a type to each character. Only types - * meaningful to Tcl parsing are represented here. The table is - * designed to be referenced with either signed or unsigned characters, - * so it has 384 entries. The first 128 entries correspond to negative - * character values, the next 256 correspond to positive character - * values. The last 128 entries are identical to the first 128. The - * table is always indexed with a 128-byte offset (the 128th entry - * corresponds to a 0 character value). - */ - -unsigned char tclTypeTable[] = { - /* - * Negative character values, from -128 to -1: - */ - - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - - /* - * Positive character values, from 0-127: - */ - - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE, - TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL, - TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET, - TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE, - TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL, - - /* - * Large unsigned character values, from 128-255: - */ - - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, -}; - -/* - * Table of all AuxData types. - */ - -static Tcl_HashTable auxDataTypeTable; -static int auxDataTypeTableInitialized = 0; /* 0 means not yet - * initialized. */ - -/* * Prototypes for procedures defined later in this file: */ -static void AdvanceToNextWord _ANSI_ARGS_((char *string, - CompileEnv *envPtr)); -static int CollectArgInfo _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, - ArgInfo *argInfoPtr)); -static int CompileBraces _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, - CompileEnv *envPtr)); -static int CompileCmdWordInline _ANSI_ARGS_(( - Tcl_Interp *interp, char *string, - char *lastChar, int flags, CompileEnv *envPtr)); -static int CompileExprWord _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, - CompileEnv *envPtr)); -static int CompileMultipartWord _ANSI_ARGS_(( - Tcl_Interp *interp, char *string, - char *lastChar, int flags, CompileEnv *envPtr)); -static int CompileWord _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, - CompileEnv *envPtr)); -static int CreateExceptionRange _ANSI_ARGS_(( - ExceptionRangeType type, CompileEnv *envPtr)); static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); -static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); static unsigned char * EncodeCmdLocMap _ANSI_ARGS_(( CompileEnv *envPtr, ByteCode *codePtr, unsigned char *startPtr)); static void EnterCmdExtentData _ANSI_ARGS_(( CompileEnv *envPtr, int cmdNumber, - int numSrcChars, int numCodeBytes)); + int numSrcBytes, int numCodeBytes)); static void EnterCmdStartData _ANSI_ARGS_(( CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset)); -static void ExpandObjectArray _ANSI_ARGS_((CompileEnv *envPtr)); -static void FreeForeachInfo _ANSI_ARGS_(( - ClientData clientData)); static void FreeByteCodeInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); -static void FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr)); static int GetCmdLocEncodingSize _ANSI_ARGS_(( CompileEnv *envPtr)); -static void InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr)); -static int IsLocalScalar _ANSI_ARGS_((char *name, int len)); -static int LookupCompiledLocal _ANSI_ARGS_(( - char *name, int nameChars, int createIfNew, - int flagsIfCreated, Proc *procPtr)); +static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *script, char *command, int length)); +#ifdef TCL_COMPILE_STATS +static void RecordByteCodeStats _ANSI_ARGS_(( + ByteCode *codePtr)); +#endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); -static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr)); /* * The structure below defines the bytecode Tcl object type by @@ -421,786 +247,352 @@ static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr)); */ Tcl_ObjType tclByteCodeType = { - "bytecode", /* name */ - FreeByteCodeInternalRep, /* freeIntRepProc */ - DupByteCodeInternalRep, /* dupIntRepProc */ - UpdateStringOfByteCode, /* updateStringProc */ - SetByteCodeFromAny /* setFromAnyProc */ -}; - -/* - * The structures below define the AuxData types defined in this file. - */ - -AuxDataType tclForeachInfoType = { - "ForeachInfo", /* name */ - DupForeachInfo, /* dupProc */ - FreeForeachInfo /* freeProc */ + "bytecode", /* name */ + FreeByteCodeInternalRep, /* freeIntRepProc */ + DupByteCodeInternalRep, /* dupIntRepProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + SetByteCodeFromAny /* setFromAnyProc */ }; /* - *---------------------------------------------------------------------- + *----------------------------------------------------------------------- * - * TclPrintByteCodeObj -- + * SetByteCodeFromAny -- * - * This procedure prints ("disassembles") the instructions of a - * bytecode object to stdout. + * Part of the bytecode Tcl object type implementation. Attempts to + * generate an byte code internal form for the Tcl object "objPtr" by + * compiling its string representation. * * Results: - * None. + * The return value is a standard Tcl object result. If an error occurs + * during compilation, an error message is left in the interpreter's + * result unless "interp" is NULL. * * Side effects: - * None. + * Frees the old internal representation. If no error occurs, then the + * compiled code is stored as "objPtr"s bytecode representation. + * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable + * used to trace compilations. * *---------------------------------------------------------------------- */ -void -TclPrintByteCodeObj(interp, objPtr) - Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */ - Tcl_Obj *objPtr; /* The bytecode object to disassemble. */ +static int +SetByteCodeFromAny(interp, objPtr) + Tcl_Interp *interp; /* The interpreter for which the code is + * being compiled. Must not be NULL. */ + Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ { - ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - unsigned char *codeStart, *codeLimit, *pc; - unsigned char *codeDeltaNext, *codeLengthNext; - unsigned char *srcDeltaNext, *srcLengthNext; - int codeOffset, codeLen, srcOffset, srcLen; - int numCmds, numObjs, delta, objBytes, i; + Interp *iPtr = (Interp *) interp; + CompileEnv compEnv; /* Compilation environment structure + * allocated in frame. */ + LiteralTable *localTablePtr = &(compEnv.localLitTable); + register AuxData *auxDataPtr; + LiteralEntry *entryPtr; + register int i; + int length, nested, result; + char *string; - if (codePtr->refCount <= 0) { - return; /* already freed */ + if (!traceInitialized) { + if (Tcl_LinkVar(interp, "tcl_traceCompile", + (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { + panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); + } + traceInitialized = 1; } - codeStart = codePtr->codeStart; - codeLimit = (codeStart + codePtr->numCodeBytes); - numCmds = codePtr->numCommands; - numObjs = codePtr->numObjects; + if (iPtr->evalFlags & TCL_BRACKET_TERM) { + nested = 1; + } else { + nested = 0; + } + string = Tcl_GetStringFromObj(objPtr, &length); + TclInitCompileEnv(interp, &compEnv, string, length); + result = TclCompileScript(interp, string, length, nested, &compEnv); + if (result != TCL_OK) { + /* + * Compilation errors. + */ + + entryPtr = compEnv.literalArrayPtr; + for (i = 0; i < compEnv.literalArrayNext; i++) { + TclReleaseLiteral(interp, entryPtr->objPtr); + entryPtr++; + } +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(iPtr); +#endif /*TCL_COMPILE_DEBUG*/ - objBytes = (numObjs * sizeof(Tcl_Obj)); - for (i = 0; i < numObjs; i++) { - Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i]; - if (litObjPtr->bytes != NULL) { - objBytes += litObjPtr->length; + auxDataPtr = compEnv.auxDataArrayPtr; + for (i = 0; i < compEnv.auxDataArrayNext; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; } + goto done; } /* - * Print header lines describing the ByteCode. + * Successful compilation. Add a "done" instruction at the end. */ - fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n", - (unsigned int) codePtr, codePtr->refCount, - codePtr->compileEpoch, (unsigned int) codePtr->iPtr, - codePtr->iPtr->compileEpoch); - fprintf(stdout, " Source "); - TclPrintSource(stdout, codePtr->source, - TclMin(codePtr->numSrcChars, 70)); - fprintf(stdout, "\n Cmds %d, chars %d, inst %d, objs %u, aux %d, stk depth %u, code/src %.2f\n", - numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs, - codePtr->numAuxDataItems, codePtr->maxStackDepth, - (codePtr->numSrcChars? - ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0)); - fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n", - codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes, - objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)), - (codePtr->numAuxDataItems * sizeof(AuxData)), - codePtr->numCmdLocBytes); + compEnv.numSrcBytes = iPtr->termOffset; + TclEmitOpcode(INST_DONE, &compEnv); /* - * If the ByteCode is the compiled body of a Tcl procedure, print - * information about that procedure. Note that we don't know the - * procedure's name since ByteCode's can be shared among procedures. + * Change the object into a ByteCode object. Ownership of the literal + * objects and aux data items is given to the ByteCode object. */ - if (codePtr->procPtr != NULL) { - Proc *procPtr = codePtr->procPtr; - int numCompiledLocals = procPtr->numCompiledLocals; - fprintf(stdout, - " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n", - (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, - numCompiledLocals); - if (numCompiledLocals > 0) { - CompiledLocal *localPtr = procPtr->firstLocalPtr; - for (i = 0; i < numCompiledLocals; i++) { - fprintf(stdout, " %d: slot %d%s%s%s%s%s%s", - i, localPtr->frameIndex, - ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), - ((localPtr->flags & VAR_ARRAY)? ", array" : ""), - ((localPtr->flags & VAR_LINK)? ", link" : ""), - ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""), - ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""), - ((localPtr->flags & VAR_RESOLVED)? ", resolved" : "")); - if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "\n"); - } else { - fprintf(stdout, ", name=\"%s\"\n", localPtr->name); - } - localPtr = localPtr->nextPtr; - } - } +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(&compEnv); +#endif /*TCL_COMPILE_DEBUG*/ + TclInitByteCodeObj(objPtr, &compEnv); +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile == 2) { + TclPrintByteCodeObj(interp, objPtr); } +#endif /* TCL_COMPILE_DEBUG */ /* - * Print the ExceptionRange array. + * Free storage allocated during compilation. */ - - if (codePtr->numExcRanges > 0) { - fprintf(stdout, " Exception ranges %d, depth %d:\n", - codePtr->numExcRanges, codePtr->maxExcRangeDepth); - for (i = 0; i < codePtr->numExcRanges; i++) { - ExceptionRange *rangePtr = &(codePtr->excRangeArrayPtr[i]); - fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", - i, rangePtr->nestingLevel, - ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop":"catch"), - rangePtr->codeOffset, - (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - fprintf(stdout, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); - break; - case CATCH_EXCEPTION_RANGE: - fprintf(stdout, "catch %d\n", rangePtr->catchOffset); - break; - default: - panic("TclPrintSource: unrecognized ExceptionRange type %d\n", - rangePtr->type); - } - } - } - /* - * If there were no commands (e.g., an expression or an empty string - * was compiled), just print all instructions and return. - */ - - if (numCmds == 0) { - pc = codeStart; - while (pc < codeLimit) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); - } - return; + done: + if (localTablePtr->buckets != localTablePtr->staticBuckets) { + ckfree((char *) localTablePtr->buckets); } - - /* - * Print table showing the code offset, source offset, and source - * length for each command. These are encoded as a sequence of bytes. - */ + TclFreeCompileEnv(&compEnv); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DupByteCodeInternalRep -- + * + * Part of the bytecode Tcl object type implementation. However, it + * does not copy the internal representation of a bytecode Tcl_Obj, but + * instead leaves the new object untyped (with a NULL type pointer). + * Code will be compiled for the new object only if necessary. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - fprintf(stdout, " Commands %d:", numCmds); - codeDeltaNext = codePtr->codeDeltaStart; - codeLengthNext = codePtr->codeLengthStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - for (i = 0; i < numCmds; i++) { - if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; +static void +DupByteCodeInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + return; +} + +/* + *---------------------------------------------------------------------- + * + * FreeByteCodeInternalRep -- + * + * Part of the bytecode Tcl object type implementation. Frees the + * storage associated with a bytecode object's internal representation + * unless its code is actively being executed. + * + * Results: + * None. + * + * Side effects: + * The bytecode object's internal rep is marked invalid and its + * code gets freed unless the code is actively being executed. + * In that case the cleanup is delayed until the last execution + * of the code completes. + * + *---------------------------------------------------------------------- + */ - if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { - codeLengthNext++; - codeLen = TclGetInt4AtPtr(codeLengthNext); - codeLengthNext += 4; - } else { - codeLen = TclGetInt1AtPtr(codeLengthNext); - codeLengthNext++; - } - - if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - fprintf(stdout, "%s%4d: pc %d-%d, source %d-%d", - ((i % 2)? " " : "\n "), - (i+1), codeOffset, (codeOffset + codeLen - 1), - srcOffset, (srcOffset + srcLen - 1)); - } - if ((numCmds > 0) && ((numCmds % 2) != 0)) { - fprintf(stdout, "\n"); - } - - /* - * Print each instruction. If the instruction corresponds to the start - * of a command, print the command's source. Note that we don't need - * the code length here. - */ - - codeDeltaNext = codePtr->codeDeltaStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - pc = codeStart; - for (i = 0; i < numCmds; i++) { - if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - /* - * Print instructions before command i. - */ - - while ((pc-codeStart) < codeOffset) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); - } - - fprintf(stdout, " Command %d: ", (i+1)); - TclPrintSource(stdout, (codePtr->source + srcOffset), - TclMin(srcLen, 70)); - fprintf(stdout, "\n"); - } - if (pc < codeLimit) { - /* - * Print instructions after the last command. - */ +static void +FreeByteCodeInternalRep(objPtr) + register Tcl_Obj *objPtr; /* Object whose internal rep to free. */ +{ + register ByteCode *codePtr = + (ByteCode *) objPtr->internalRep.otherValuePtr; - while (pc < codeLimit) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); - } + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); } + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; } /* *---------------------------------------------------------------------- * - * TclPrintInstruction -- + * TclCleanupByteCode -- * - * This procedure prints ("disassembles") one instruction from a - * bytecode object to stdout. + * This procedure does all the real work of freeing up a bytecode + * object's ByteCode structure. It's called only when the structure's + * reference count becomes zero. * * Results: - * Returns the length in bytes of the current instruiction. + * None. * * Side effects: - * None. + * Frees objPtr's bytecode internal representation and sets its type + * and objPtr->internalRep.otherValuePtr NULL. Also releases its + * literals and frees its auxiliary data items. * *---------------------------------------------------------------------- */ -int -TclPrintInstruction(codePtr, pc) - ByteCode* codePtr; /* Bytecode containing the instruction. */ - unsigned char *pc; /* Points to first byte of instruction. */ +void +TclCleanupByteCode(codePtr) + register ByteCode *codePtr; /* Points to the ByteCode to free. */ { - Proc *procPtr = codePtr->procPtr; - unsigned char opCode = *pc; - register InstructionDesc *instDesc = &instructionTable[opCode]; - unsigned char *codeStart = codePtr->codeStart; - unsigned int pcOffset = (pc - codeStart); - int opnd, elemLen, i, j; - Tcl_Obj *elemPtr; - char *string; - - fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); - for (i = 0; i < instDesc->numOperands; i++) { - switch (instDesc->opTypes[i]) { - case OPERAND_INT1: - opnd = TclGetInt1AtPtr(pc+1+i); - if ((i == 0) && ((opCode == INST_JUMP1) - || (opCode == INST_JUMP_TRUE1) - || (opCode == INST_JUMP_FALSE1))) { - fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); - } else { - fprintf(stdout, "%d", opnd); - } - break; - case OPERAND_INT4: - opnd = TclGetInt4AtPtr(pc+1+i); - if ((i == 0) && ((opCode == INST_JUMP4) - || (opCode == INST_JUMP_TRUE4) - || (opCode == INST_JUMP_FALSE4))) { - fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); - } else { - fprintf(stdout, "%d", opnd); - } - break; - case OPERAND_UINT1: - opnd = TclGetUInt1AtPtr(pc+1+i); - if ((i == 0) && (opCode == INST_PUSH1)) { - elemPtr = codePtr->objArrayPtr[opnd]; - string = Tcl_GetStringFromObj(elemPtr, &elemLen); - fprintf(stdout, "%u # ", (unsigned int) opnd); - TclPrintSource(stdout, string, TclMin(elemLen, 40)); - } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1) - || (opCode == INST_LOAD_ARRAY1) - || (opCode == INST_STORE_SCALAR1) - || (opCode == INST_STORE_ARRAY1))) { - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - if (opnd >= localCt) { - panic("TclPrintInstruction: bad local var index %u (%u locals)\n", - (unsigned int) opnd, localCt); - return instDesc->numBytes; - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "%u # temp var %u", - (unsigned int) opnd, (unsigned int) opnd); - } else { - fprintf(stdout, "%u # var ", (unsigned int) opnd); - TclPrintSource(stdout, localPtr->name, 40); - } - } else { - fprintf(stdout, "%u ", (unsigned int) opnd); - } - break; - case OPERAND_UINT4: - opnd = TclGetUInt4AtPtr(pc+1+i); - if (opCode == INST_PUSH4) { - elemPtr = codePtr->objArrayPtr[opnd]; - string = Tcl_GetStringFromObj(elemPtr, &elemLen); - fprintf(stdout, "%u # ", opnd); - TclPrintSource(stdout, string, TclMin(elemLen, 40)); - } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4) - || (opCode == INST_LOAD_ARRAY4) - || (opCode == INST_STORE_SCALAR4) - || (opCode == INST_STORE_ARRAY4))) { - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - if (opnd >= localCt) { - panic("TclPrintInstruction: bad local var index %u (%u locals)\n", - (unsigned int) opnd, localCt); - return instDesc->numBytes; - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "%u # temp var %u", - (unsigned int) opnd, (unsigned int) opnd); - } else { - fprintf(stdout, "%u # var ", (unsigned int) opnd); - TclPrintSource(stdout, localPtr->name, 40); - } - } else { - fprintf(stdout, "%u ", (unsigned int) opnd); + Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; + int numLitObjects = codePtr->numLitObjects; + int numAuxDataItems = codePtr->numAuxDataItems; + register Tcl_Obj **objArrayPtr; + register AuxData *auxDataPtr; + int i; +#ifdef TCL_COMPILE_STATS + + if (interp != NULL) { + ByteCodeStats *statsPtr; + Tcl_Time destroyTime; + int lifetimeSec, lifetimeMicroSec, log2; + + statsPtr = &((Interp *) interp)->stats; + + statsPtr->numByteCodesFreed++; + statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; + statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; + + statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; + statsPtr->currentLitBytes -= + (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); + statsPtr->currentExceptBytes -= + (double) (codePtr->numExceptRanges * sizeof(ExceptionRange)); + statsPtr->currentAuxBytes -= + (double) (codePtr->numAuxDataItems * sizeof(AuxData)); + statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes; + + TclpGetTime(&destroyTime); + lifetimeSec = destroyTime.sec - codePtr->createTime.sec; + if (lifetimeSec > 2000) { /* avoid overflow */ + lifetimeSec = 2000; + } + lifetimeMicroSec = + 1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec); + + log2 = TclLog2(lifetimeMicroSec); + if (log2 > 31) { + log2 = 31; + } + statsPtr->lifetimeCount[log2]++; + } +#endif /* TCL_COMPILE_STATS */ + + /* + * A single heap object holds the ByteCode structure and its code, + * object, command location, and auxiliary data arrays. This means we + * only need to 1) decrement the ref counts of the LiteralEntry's in + * its literal array, 2) call the free procs for the auxiliary data + * items, and 3) free the ByteCode structure's heap object. + */ + + if (interp != NULL) { + /* + * If the interp has already been freed, then Tcl will have already + * forcefully released all the literals used by ByteCodes compiled + * with respect to that interp. + */ + + objArrayPtr = codePtr->objArrayPtr; + for (i = 0; i < numLitObjects; i++) { + /* + * TclReleaseLiteral sets a ByteCode's object array entry NULL to + * indicate that it has already freed the literal. + */ + + if (*objArrayPtr != NULL) { + TclReleaseLiteral(interp, *objArrayPtr); } - break; - case OPERAND_NONE: - default: - break; + objArrayPtr++; } } - fprintf(stdout, "\n"); - return instDesc->numBytes; + + auxDataPtr = codePtr->auxDataArrayPtr; + for (i = 0; i < numAuxDataItems; i++) { + if (auxDataPtr->type->freeProc != NULL) { + (*auxDataPtr->type->freeProc)(auxDataPtr->clientData); + } + auxDataPtr++; + } + + TclHandleRelease(codePtr->interpHandle); + ckfree((char *) codePtr); } /* *---------------------------------------------------------------------- * - * TclPrintSource -- + * TclInitCompileEnv -- * - * This procedure prints up to a specified number of characters from - * the argument string to a specified file. It tries to produce legible - * output by adding backslashes as necessary. + * Initializes a CompileEnv compilation environment structure for the + * compilation of a string in an interpreter. * * Results: * None. * * Side effects: - * Outputs characters to the specified file. + * The CompileEnv structure is initialized. * *---------------------------------------------------------------------- */ void -TclPrintSource(outFile, string, maxChars) - FILE *outFile; /* The file to print the source to. */ - char *string; /* The string to print. */ - int maxChars; /* Maximum number of chars to print. */ -{ - register char *p; - register int i = 0; - - if (string == NULL) { - fprintf(outFile, "\"\""); - return; - } - - fprintf(outFile, "\""); - p = string; - for (; (*p != '\0') && (i < maxChars); p++, i++) { - switch (*p) { - case '"': - fprintf(outFile, "\\\""); - continue; - case '\f': - fprintf(outFile, "\\f"); - continue; - case '\n': - fprintf(outFile, "\\n"); - continue; - case '\r': - fprintf(outFile, "\\r"); - continue; - case '\t': - fprintf(outFile, "\\t"); - continue; - case '\v': - fprintf(outFile, "\\v"); - continue; - default: - fprintf(outFile, "%c", *p); - continue; - } - } - fprintf(outFile, "\""); -} - -/* - *---------------------------------------------------------------------- - * - * FreeByteCodeInternalRep -- - * - * Part of the bytecode Tcl object type implementation. Frees the - * storage associated with a bytecode object's internal representation - * unless its code is actively being executed. - * - * Results: - * None. - * - * Side effects: - * The bytecode object's internal rep is marked invalid and its - * code gets freed unless the code is actively being executed. - * In that case the cleanup is delayed until the last execution - * of the code completes. - * - *---------------------------------------------------------------------- - */ - -static void -FreeByteCodeInternalRep(objPtr) - register Tcl_Obj *objPtr; /* Object whose internal rep to free. */ -{ - register ByteCode *codePtr = - (ByteCode *) objPtr->internalRep.otherValuePtr; - - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclCleanupByteCode -- - * - * This procedure does all the real work of freeing up a bytecode - * object's ByteCode structure. It's called only when the structure's - * reference count becomes zero. - * - * Results: - * None. - * - * Side effects: - * Frees objPtr's bytecode internal representation and sets - * its type and objPtr->internalRep.otherValuePtr NULL. Also - * decrements the ref counts on each object in its object array, - * and frees its auxiliary data items. - * - *---------------------------------------------------------------------- - */ - -void -TclCleanupByteCode(codePtr) - ByteCode *codePtr; /* ByteCode to free. */ -{ - Tcl_Obj **objArrayPtr = codePtr->objArrayPtr; - int numObjects = codePtr->numObjects; - int numAuxDataItems = codePtr->numAuxDataItems; - register AuxData *auxDataPtr; - register Tcl_Obj *elemPtr; - register int i; - -#ifdef TCL_COMPILE_STATS - tclCurrentSourceBytes -= (double) codePtr->numSrcChars; - tclCurrentCodeBytes -= (double) codePtr->totalSize; -#endif /* TCL_COMPILE_STATS */ - - /* - * A single heap object holds the ByteCode structure and its code, - * object, command location, and auxiliary data arrays. This means we - * only need to 1) decrement the ref counts on the objects in its - * object array, 2) call the free procs for the auxiliary data items, - * and 3) free the ByteCode structure's heap object. - */ - - for (i = 0; i < numObjects; i++) { - elemPtr = objArrayPtr[i]; - TclDecrRefCount(elemPtr); - } - - auxDataPtr = codePtr->auxDataArrayPtr; - for (i = 0; i < numAuxDataItems; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; - } - - ckfree((char *) codePtr); -} - -/* - *---------------------------------------------------------------------- - * - * DupByteCodeInternalRep -- - * - * Part of the bytecode Tcl object type implementation. However, it - * does not copy the internal representation of a bytecode Tcl_Obj, but - * instead leaves the new object untyped (with a NULL type pointer). - * Code will be compiled for the new object only if necessary. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -DupByteCodeInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr; /* Object with internal rep to set. */ -{ - return; -} - -/* - *----------------------------------------------------------------------- - * - * SetByteCodeFromAny -- - * - * Part of the bytecode Tcl object type implementation. Attempts to - * generate an byte code internal form for the Tcl object "objPtr" by - * compiling its string representation. - * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during compilation, an error message is left in the interpreter's - * result unless "interp" is NULL. - * - * Side effects: - * Frees the old internal representation. If no error occurs, then the - * compiled code is stored as "objPtr"s bytecode representation. - * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable - * used to trace compilations. - * - *---------------------------------------------------------------------- - */ - -static int -SetByteCodeFromAny(interp, objPtr) - Tcl_Interp *interp; /* The interpreter for which the code is - * compiled. */ - Tcl_Obj *objPtr; /* The object to convert. */ -{ - Interp *iPtr = (Interp *) interp; - char *string; - CompileEnv compEnv; /* Compilation environment structure - * allocated in frame. */ - AuxData *auxDataPtr; - register int i; - int length, result; - - if (!traceInitialized) { - if (Tcl_LinkVar(interp, "tcl_traceCompile", - (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { - panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); - } - traceInitialized = 1; - } - - string = Tcl_GetStringFromObj(objPtr, &length); - TclInitCompileEnv(interp, &compEnv, string); - result = TclCompileString(interp, string, string+length, - iPtr->evalFlags, &compEnv); - if (result == TCL_OK) { - /* - * Add a "done" instruction at the end of the instruction sequence. - */ - - TclEmitOpcode(INST_DONE, &compEnv); - - /* - * Convert the object to a ByteCode object. - */ - - TclInitByteCodeObj(objPtr, &compEnv); - } else { - /* - * Compilation errors. Decrement the ref counts on any objects in - * the object array and free any aux data items prior to freeing - * the compilation environment. - */ - - for (i = 0; i < compEnv.objArrayNext; i++) { - Tcl_Obj *elemPtr = compEnv.objArrayPtr[i]; - Tcl_DecrRefCount(elemPtr); - } - - auxDataPtr = compEnv.auxDataArrayPtr; - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; - } - } - TclFreeCompileEnv(&compEnv); - - if (result == TCL_OK) { - if (tclTraceCompile == 2) { - TclPrintByteCodeObj(interp, objPtr); - } - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfByteCode -- - * - * Part of the bytecode Tcl object type implementation. Called to - * update the string representation for a byte code object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * Generates a panic. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfByteCode(objPtr) - register Tcl_Obj *objPtr; /* ByteCode object with string rep that - * needs updating. */ -{ - /* - * This procedure is never invoked since the internal representation of - * a bytecode object is never modified. - */ - - panic("UpdateStringOfByteCode should never be called."); -} - -/* - *---------------------------------------------------------------------- - * - * TclInitCompileEnv -- - * - * Initializes a CompileEnv compilation environment structure for the - * compilation of a string in an interpreter. - * - * Results: - * None. - * - * Side effects: - * The CompileEnv structure is initialized. - * - *---------------------------------------------------------------------- - */ - -void -TclInitCompileEnv(interp, envPtr, string) - Tcl_Interp *interp; /* The interpreter for which a CompileEnv - * structure is initialized. */ - register CompileEnv *envPtr; /* Points to the CompileEnv structure to - * initialize. */ - char *string; /* The source string to be compiled. */ +TclInitCompileEnv(interp, envPtr, string, numBytes) + Tcl_Interp *interp; /* The interpreter for which a CompileEnv + * structure is initialized. */ + register CompileEnv *envPtr; /* Points to the CompileEnv structure to + * initialize. */ + char *string; /* The source string to be compiled. */ + int numBytes; /* Number of bytes in source string. */ { Interp *iPtr = (Interp *) interp; envPtr->iPtr = iPtr; envPtr->source = string; + envPtr->numSrcBytes = numBytes; envPtr->procPtr = iPtr->compiledProcPtr; envPtr->numCommands = 0; - envPtr->excRangeDepth = 0; - envPtr->maxExcRangeDepth = 0; + envPtr->exceptDepth = 0; + envPtr->maxExceptDepth = 0; envPtr->maxStackDepth = 0; - Tcl_InitHashTable(&(envPtr->objTable), TCL_STRING_KEYS); - envPtr->pushSimpleWords = 1; - envPtr->wordIsSimple = 0; - envPtr->numSimpleWordChars = 0; + TclInitLiteralTable(&(envPtr->localLitTable)); envPtr->exprIsJustVarRef = 0; envPtr->exprIsComparison = 0; - envPtr->termOffset = 0; envPtr->codeStart = envPtr->staticCodeSpace; envPtr->codeNext = envPtr->codeStart; envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES); envPtr->mallocedCodeArray = 0; - envPtr->objArrayPtr = envPtr->staticObjArraySpace; - envPtr->objArrayNext = 0; - envPtr->objArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; - envPtr->mallocedObjArray = 0; + envPtr->literalArrayPtr = envPtr->staticLiteralSpace; + envPtr->literalArrayNext = 0; + envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; + envPtr->mallocedLiteralArray = 0; - envPtr->excRangeArrayPtr = envPtr->staticExcRangeArraySpace; - envPtr->excRangeArrayNext = 0; - envPtr->excRangeArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; - envPtr->mallocedExcRangeArray = 0; + envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; + envPtr->exceptArrayNext = 0; + envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; + envPtr->mallocedExceptArray = 0; envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; @@ -1222,15 +614,14 @@ TclInitCompileEnv(interp, envPtr, string) * * Results: * None. - * + * * Side effects: * Allocated storage in the CompileEnv structure is freed. Note that - * ref counts for Tcl objects in its object table are not decremented. - * In addition, any storage referenced by any auxiliary data items - * in the CompileEnv structure are not freed either. The expectation - * is that when compilation is successful, "ownership" (i.e., the - * pointers to) these objects and aux data items will just be handed - * over to the corresponding ByteCode structure. + * its local literal table is not deleted and its literal objects are + * not released. In addition, storage referenced by its auxiliary data + * items is not freed. This is done so that, when compilation is + * successful, "ownership" of these objects and aux data items is + * handed over to the corresponding ByteCode structure. * *---------------------------------------------------------------------- */ @@ -1239,15 +630,14 @@ void TclFreeCompileEnv(envPtr) register CompileEnv *envPtr; /* Points to the CompileEnv structure. */ { - Tcl_DeleteHashTable(&(envPtr->objTable)); if (envPtr->mallocedCodeArray) { ckfree((char *) envPtr->codeStart); } - if (envPtr->mallocedObjArray) { - ckfree((char *) envPtr->objArrayPtr); + if (envPtr->mallocedLiteralArray) { + ckfree((char *) envPtr->literalArrayPtr); } - if (envPtr->mallocedExcRangeArray) { - ckfree((char *) envPtr->excRangeArrayPtr); + if (envPtr->mallocedExceptArray) { + ckfree((char *) envPtr->exceptArrayPtr); } if (envPtr->mallocedCmdMap) { ckfree((char *) envPtr->cmdMapPtr); @@ -1260,6681 +650,2554 @@ TclFreeCompileEnv(envPtr) /* *---------------------------------------------------------------------- * - * TclInitByteCodeObj -- + * TclCompileScript -- * - * Create a ByteCode structure and initialize it from a CompileEnv - * compilation environment structure. The ByteCode structure is - * smaller and contains just that information needed to execute - * the bytecode instructions resulting from compiling a Tcl script. - * The resulting structure is placed in the specified object. + * Compile a Tcl script in a string. * * Results: - * A newly constructed ByteCode object is stored in the internal - * representation of the objPtr. + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * interp->termOffset is set to the offset of the character in the + * script just after the last one successfully processed; this will be + * the offset of the ']' if (flags & TCL_BRACKET_TERM). + * envPtr->maxStackDepth is set to the maximum number of stack elements + * needed to execute the script's commands. * * Side effects: - * A single heap object is allocated to hold the new ByteCode structure - * and its code, object, command location, and aux data arrays. Note - * that "ownership" (i.e., the pointers to) the Tcl objects and aux - * data items will be handed over to the new ByteCode structure from - * the CompileEnv structure. + * Adds instructions to envPtr to evaluate the script at runtime. * *---------------------------------------------------------------------- */ -void -TclInitByteCodeObj(objPtr, envPtr) - Tcl_Obj *objPtr; /* Points object that should be - * initialized, and whose string rep - * contains the source code. */ - register CompileEnv *envPtr; /* Points to the CompileEnv structure from - * which to create a ByteCode structure. */ +int +TclCompileScript(interp, script, numBytes, nested, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + char *script; /* The source script to compile. */ + int numBytes; /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first null character. */ + int nested; /* Non-zero means this is a nested command: + * close bracket ']' should be considered a + * command terminator. If zero, close + * bracket has no special meaning. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ { - register ByteCode *codePtr; - size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; - size_t auxDataArrayBytes; - register size_t size, objBytes, totalSize; - register unsigned char *p; - unsigned char *nextPtr; - int srcLen = envPtr->termOffset; - int numObjects, i; - Namespace *namespacePtr; -#ifdef TCL_COMPILE_STATS - int srcLenLog2, sizeLog2; -#endif /*TCL_COMPILE_STATS*/ + Interp *iPtr = (Interp *) interp; + Tcl_Parse parse; + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute all cmds. */ + int lastTopLevelCmdIndex = -1; + /* Index of most recent toplevel command in + * the command location table. Initialized + * to avoid compiler warning. */ + int startCodeOffset = -1; /* Offset of first byte of current command's + * code. Init. to avoid compiler warning. */ + unsigned char *entryCodeNext = envPtr->codeNext; + char *p, *next; + Namespace *cmdNsPtr; + Command *cmdPtr; + Tcl_Token *tokenPtr; + int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex; + int commandLength, objIndex, code; + char prev; + Tcl_DString ds; - codeBytes = (envPtr->codeNext - envPtr->codeStart); - numObjects = envPtr->objArrayNext; - objArrayBytes = (envPtr->objArrayNext * sizeof(Tcl_Obj *)); - exceptArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange)); - auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); - cmdLocBytes = GetCmdLocEncodingSize(envPtr); - - size = sizeof(ByteCode); - size += TCL_ALIGN(codeBytes); /* align object array */ - size += TCL_ALIGN(objArrayBytes); /* align exception range array */ - size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ - size += auxDataArrayBytes; - size += cmdLocBytes; + Tcl_DStringInit(&ds); + + if (numBytes < 0) { + numBytes = strlen(script); + } + Tcl_ResetResult(interp); + isFirstCmd = 1; /* - * Compute the total number of bytes needed for this bytecode - * including the storage for the Tcl objects in its object array. + * Each iteration through the following loop compiles the next + * command from the script. */ - objBytes = (numObjects * sizeof(Tcl_Obj)); - for (i = 0; i < numObjects; i++) { - Tcl_Obj *litObjPtr = envPtr->objArrayPtr[i]; - if (litObjPtr->bytes != NULL) { - objBytes += litObjPtr->length; + p = script; + bytesLeft = numBytes; + gotParse = 0; + while (bytesLeft > 0) { + if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) { + code = TCL_ERROR; + goto error; + } + gotParse = 1; + if (parse.numWords > 0) { + /* + * If not the first command, pop the previous command's result + * and, if we're compiling a top level command, update the last + * command's code size to account for the pop instruction. + */ + + if (!isFirstCmd) { + TclEmitOpcode(INST_POP, envPtr); + if (!nested) { + envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - startCodeOffset; + } + } + + /* + * Determine the actual length of the command. + */ + + commandLength = parse.commandSize; + prev = '\0'; + if (commandLength > 0) { + prev = parse.commandStart[commandLength-1]; + } + if (((parse.commandStart+commandLength) != (script+numBytes)) + || ((prev=='\n') || (nested && (prev==']')))) { + /* + * The command didn't end at the end of the script (i.e. it + * ended at a terminator character such as ";". Reduce the + * length by one so that the trace message doesn't include + * the terminator character. + */ + + commandLength -= 1; + } + + /* + * If tracing, print a line for each top level command compiled. + */ + + if ((tclTraceCompile >= 1) + && !nested && (envPtr->procPtr == NULL)) { + fprintf(stdout, " Compiling: "); + TclPrintSource(stdout, parse.commandStart, + TclMin(commandLength, 55)); + fprintf(stdout, "\n"); + } + + /* + * Each iteration of the following loop compiles one word + * from the command. + */ + + envPtr->numCommands++; + currCmdIndex = (envPtr->numCommands - 1); + if (!nested) { + lastTopLevelCmdIndex = currCmdIndex; + } + startCodeOffset = (envPtr->codeNext - envPtr->codeStart); + EnterCmdStartData(envPtr, currCmdIndex, + (parse.commandStart - envPtr->source), startCodeOffset); + + for (wordIdx = 0, tokenPtr = parse.tokenPtr; + wordIdx < parse.numWords; + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * If this is the first word and the command has a + * compile procedure, let it compile the command. + */ + + if (wordIdx == 0) { + if (envPtr->procPtr != NULL) { + cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; + } else { + cmdNsPtr = NULL; /* use current NS */ + } + + /* + * We copy the string before trying to find the command + * by name. We used to modify the string in place, but + * this is not safe because the name resolution + * handlers could have side effects that rely on the + * unmodified string. + */ + + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, tokenPtr[1].start, + tokenPtr[1].size); + + cmdPtr = (Command *) Tcl_FindCommand(interp, + Tcl_DStringValue(&ds), + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); + + if ((cmdPtr != NULL) + && (cmdPtr->compileProc != NULL) + && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + code = (*(cmdPtr->compileProc))(interp, &parse, + envPtr); + if (code == TCL_OK) { + maxDepth = TclMax(envPtr->maxStackDepth, + maxDepth); + goto finishCommand; + } else if (code == TCL_OUT_LINE_COMPILE) { + /* do nothing */ + } else { /* an error */ + goto error; + } + } + + /* + * No compile procedure so push the word. If the + * command was found, push a CmdName object to + * reduce runtime lookups. + */ + + objIndex = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, + /*onHeap*/ 0); + if (cmdPtr != NULL) { + TclSetCmdNameObj(interp, + envPtr->literalArrayPtr[objIndex].objPtr, + cmdPtr); + } + } else { + objIndex = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, + /*onHeap*/ 0); + } + TclEmitPush(objIndex, envPtr); + maxDepth = TclMax((wordIdx + 1), maxDepth); + } else { + /* + * The word is not a simple string of characters. + */ + + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto error; + } + maxDepth = TclMax((wordIdx + envPtr->maxStackDepth), + maxDepth); + } + } + + /* + * Emit an invoke instruction for the command. We skip this + * if a compile procedure was found for the command. + */ + + if (wordIdx > 0) { + if (wordIdx <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + } + } + + /* + * Update the compilation environment structure and record the + * offsets of the source and code for the command. + */ + + finishCommand: + EnterCmdExtentData(envPtr, currCmdIndex, commandLength, + (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + isFirstCmd = 0; + } /* end if parse.numWords > 0 */ + + /* + * Advance to the next command in the script. + */ + + next = parse.commandStart + parse.commandSize; + bytesLeft -= (next - p); + p = next; + Tcl_FreeParse(&parse); + gotParse = 0; + if (nested && (p[-1] == ']')) { + /* + * We get here in the special case where TCL_BRACKET_TERM was + * set in the interpreter and we reached a close bracket in the + * script. Stop compilation. + */ + + break; } } - totalSize = (size + objBytes); -#ifdef TCL_COMPILE_STATS - tclNumCompilations++; - tclTotalSourceBytes += (double) srcLen; - tclTotalCodeBytes += (double) totalSize; + /* + * If the source script yielded no instructions (e.g., if it was empty), + * push an empty string as the command's result. + */ - tclTotalInstBytes += (double) codeBytes; - tclTotalObjBytes += (double) objBytes; - tclTotalExceptBytes += exceptArrayBytes; - tclTotalAuxBytes += (double) auxDataArrayBytes; - tclTotalCmdMapBytes += (double) cmdLocBytes; - - tclCurrentSourceBytes += (double) srcLen; - tclCurrentCodeBytes += (double) totalSize; - - srcLenLog2 = TclLog2(srcLen); - sizeLog2 = TclLog2((int) totalSize); - if ((srcLenLog2 > 31) || (sizeLog2 > 31)) { - panic("TclInitByteCodeObj: bad source or code sizes\n"); + if (envPtr->codeNext == entryCodeNext) { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*alreadyAlloced*/ 0), + envPtr); + maxDepth = 1; } - tclSourceCount[srcLenLog2]++; - tclByteCodeCount[sizeLog2]++; -#endif /* TCL_COMPILE_STATS */ - - if (envPtr->iPtr->varFramePtr != NULL) { - namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; + + if ((nested != 0) && (p > script) && (p[-1] == ']')) { + iPtr->termOffset = (p - 1) - script; } else { - namespacePtr = envPtr->iPtr->globalNsPtr; + iPtr->termOffset = (p - script); } - - p = (unsigned char *) ckalloc(size); - codePtr = (ByteCode *) p; - codePtr->iPtr = envPtr->iPtr; - codePtr->compileEpoch = envPtr->iPtr->compileEpoch; - codePtr->nsPtr = namespacePtr; - codePtr->nsEpoch = namespacePtr->resolverEpoch; - codePtr->refCount = 1; - codePtr->flags = 0; - codePtr->source = envPtr->source; - codePtr->procPtr = envPtr->procPtr; - codePtr->totalSize = totalSize; - codePtr->numCommands = envPtr->numCommands; - codePtr->numSrcChars = srcLen; - codePtr->numCodeBytes = codeBytes; - codePtr->numObjects = numObjects; - codePtr->numExcRanges = envPtr->excRangeArrayNext; - codePtr->numAuxDataItems = envPtr->auxDataArrayNext; - codePtr->auxDataArrayPtr = NULL; - codePtr->numCmdLocBytes = cmdLocBytes; - codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth; - codePtr->maxStackDepth = envPtr->maxStackDepth; - - p += sizeof(ByteCode); - codePtr->codeStart = p; - memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes); - - p += TCL_ALIGN(codeBytes); /* align object array */ - codePtr->objArrayPtr = (Tcl_Obj **) p; - memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes); + envPtr->maxStackDepth = maxDepth; + Tcl_DStringFree(&ds); + return TCL_OK; + + error: + /* + * Generate various pieces of error information, such as the line + * number where the error occurred and information to add to the + * errorInfo variable. Then free resources that had been allocated + * to the command. + */ - p += TCL_ALIGN(objArrayBytes); /* align exception range array */ - if (exceptArrayBytes > 0) { - codePtr->excRangeArrayPtr = (ExceptionRange *) p; - memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr, - exceptArrayBytes); - } - - p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ - if (auxDataArrayBytes > 0) { - codePtr->auxDataArrayPtr = (AuxData *) p; - memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, - auxDataArrayBytes); + commandLength = parse.commandSize; + prev = '\0'; + if (commandLength > 0) { + prev = parse.commandStart[commandLength-1]; } + if (((parse.commandStart+commandLength) != (script+numBytes)) + || ((prev == '\n') || (nested && (prev == ']')))) { + /* + * The command where the error occurred didn't end at the end + * of the script (i.e. it ended at a terminator character such + * as ";". Reduce the length by one so that the error message + * doesn't include the terminator character. + */ - p += auxDataArrayBytes; - nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); - if (((size_t)(nextPtr - p)) != cmdLocBytes) { - panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); + commandLength -= 1; } - - /* - * Free the old internal rep then convert the object to a - * bytecode object by making its internal rep point to the just - * compiled ByteCode. - */ - - if ((objPtr->typePtr != NULL) && - (objPtr->typePtr->freeIntRepProc != NULL)) { - objPtr->typePtr->freeIntRepProc(objPtr); + LogCompilationInfo(interp, script, parse.commandStart, commandLength); + if (gotParse) { + Tcl_FreeParse(&parse); } - objPtr->internalRep.otherValuePtr = (VOID *) codePtr; - objPtr->typePtr = &tclByteCodeType; + iPtr->termOffset = (p - script); + envPtr->maxStackDepth = maxDepth; + Tcl_DStringFree(&ds); + return code; } /* *---------------------------------------------------------------------- * - * GetCmdLocEncodingSize -- + * TclCompileTokens -- * - * Computes the total number of bytes needed to encode the command - * location information for some compiled code. + * Given an array of tokens parsed from a Tcl command (e.g., the tokens + * that make up a word) this procedure emits instructions to evaluate + * the tokens and concatenate their values to form a single result + * value on the interpreter's runtime evaluation stack. * * Results: - * The byte count needed to encode the compiled location information. + * The return value is a standard Tcl result. If an error occurs, an + * error message is left in the interpreter's result. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to evaluate the tokens. * * Side effects: - * None. + * Instructions are added to envPtr to push and evaluate the tokens + * at runtime. * *---------------------------------------------------------------------- */ -static int -GetCmdLocEncodingSize(envPtr) - CompileEnv *envPtr; /* Points to compilation environment - * structure containing the CmdLocation - * structure to encode. */ +int +TclCompileTokens(interp, tokenPtr, count, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens + * to compile. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ { - register CmdLocation *mapPtr = envPtr->cmdMapPtr; - int numCmds = envPtr->numCommands; - int codeDelta, codeLen, srcDelta, srcLen; - int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; - /* The offsets in their respective byte - * sequences where the next encoded offset - * or length should go. */ - int prevCodeOffset, prevSrcOffset, i; + Tcl_DString textBuffer; /* Holds concatenated chars from adjacent + * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ + char buffer[TCL_UTF_MAX]; + char *name, *p; + int numObjsToConcat, nameBytes, hasNsQualifiers, localVar; + int length, maxDepth, depthForVar, i, code; + unsigned char *entryCodeNext = envPtr->codeNext; - codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; - prevCodeOffset = prevSrcOffset = 0; - for (i = 0; i < numCmds; i++) { - codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); - if (codeDelta < 0) { - panic("GetCmdLocEncodingSize: bad code offset"); - } else if (codeDelta <= 127) { - codeDeltaNext++; - } else { - codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ - } - prevCodeOffset = mapPtr[i].codeOffset; + Tcl_DStringInit(&textBuffer); + maxDepth = 0; + numObjsToConcat = 0; + for ( ; count > 0; count--, tokenPtr++) { + switch (tokenPtr->type) { + case TCL_TOKEN_TEXT: + Tcl_DStringAppend(&textBuffer, tokenPtr->start, + tokenPtr->size); + break; - codeLen = mapPtr[i].numCodeBytes; - if (codeLen < 0) { - panic("GetCmdLocEncodingSize: bad code length"); - } else if (codeLen <= 127) { - codeLengthNext++; - } else { - codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ - } + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, + buffer); + Tcl_DStringAppend(&textBuffer, buffer, length); + break; - srcDelta = (mapPtr[i].srcOffset - prevSrcOffset); - if ((-127 <= srcDelta) && (srcDelta <= 127)) { - srcDeltaNext++; - } else { - srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ - } - prevSrcOffset = mapPtr[i].srcOffset; + case TCL_TOKEN_COMMAND: + /* + * Push any accumulated chars appearing before the command. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + maxDepth = TclMax(numObjsToConcat, maxDepth); + Tcl_DStringFree(&textBuffer); + } + + code = TclCompileScript(interp, tokenPtr->start+1, + tokenPtr->size-2, /*nested*/ 1, envPtr); + if (code != TCL_OK) { + goto error; + } + maxDepth = TclMax((numObjsToConcat + envPtr->maxStackDepth), + maxDepth); + numObjsToConcat++; + break; - srcLen = mapPtr[i].numSrcChars; - if (srcLen < 0) { - panic("GetCmdLocEncodingSize: bad source length"); - } else if (srcLen <= 127) { - srcLengthNext++; - } else { - srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ - } - } + case TCL_TOKEN_VARIABLE: + /* + * Push any accumulated chars appearing before the $. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + maxDepth = TclMax(numObjsToConcat, maxDepth); + Tcl_DStringFree(&textBuffer); + } + + /* + * Check if the name contains any namespace qualifiers. + */ + + name = tokenPtr[1].start; + nameBytes = tokenPtr[1].size; + hasNsQualifiers = 0; + for (i = 0, p = name; i < nameBytes; i++, p++) { + if ((*p == ':') && (i < (nameBytes-1)) + && (*(p+1) == ':')) { + hasNsQualifiers = 1; + break; + } + } - return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext); -} - -/* - *---------------------------------------------------------------------- - * - * EncodeCmdLocMap -- - * - * Encode the command location information for some compiled code into - * a ByteCode structure. The encoded command location map is stored as - * three adjacent byte sequences. - * - * Results: - * Pointer to the first byte after the encoded command location - * information. - * - * Side effects: - * The encoded information is stored into the block of memory headed - * by codePtr. Also records pointers to the start of the four byte - * sequences in fields in codePtr's ByteCode header structure. - * - *---------------------------------------------------------------------- - */ + /* + * Either push the variable's name, or find its index in + * the array of local variables in a procedure frame. + */ + + depthForVar = 0; + if ((envPtr->procPtr == NULL) || hasNsQualifiers) { + localVar = -1; + TclEmitPush(TclRegisterLiteral(envPtr, name, nameBytes, + /*onHeap*/ 0), envPtr); + depthForVar = 1; + } else { + localVar = TclFindCompiledLocal(name, nameBytes, + /*create*/ 0, /*flags*/ 0, envPtr->procPtr); + if (localVar < 0) { + TclEmitPush(TclRegisterLiteral(envPtr, name, + nameBytes, /*onHeap*/ 0), envPtr); + depthForVar = 1; + } + } + + /* + * Emit instructions to load the variable. + */ + + if (tokenPtr->numComponents == 1) { + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, + envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, + envPtr); + } + } else { + code = TclCompileTokens(interp, tokenPtr+2, + tokenPtr->numComponents-1, envPtr); + if (code != TCL_OK) { + sprintf(buffer, + "\n (parsing index for array \"%.*s\")", + ((nameBytes > 100)? 100 : nameBytes), name); + Tcl_AddObjErrorInfo(interp, buffer, -1); + goto error; + } + depthForVar += envPtr->maxStackDepth; + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, + envPtr); + } else { + TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, + envPtr); + } + } + maxDepth = TclMax(numObjsToConcat + depthForVar, maxDepth); + numObjsToConcat++; + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; + + default: + panic("Unexpected token type in TclCompileTokens"); + } + } -static unsigned char * -EncodeCmdLocMap(envPtr, codePtr, startPtr) - CompileEnv *envPtr; /* Points to compilation environment - * structure containing the CmdLocation - * structure to encode. */ - ByteCode *codePtr; /* ByteCode in which to encode envPtr's - * command location information. */ - unsigned char *startPtr; /* Points to the first byte in codePtr's - * memory block where the location - * information is to be stored. */ -{ - register CmdLocation *mapPtr = envPtr->cmdMapPtr; - int numCmds = envPtr->numCommands; - register unsigned char *p = startPtr; - int codeDelta, codeLen, srcDelta, srcLen, prevOffset; - register int i; - /* - * Encode the code offset for each command as a sequence of deltas. + * Push any accumulated characters appearing at the end. */ - codePtr->codeDeltaStart = p; - prevOffset = 0; - for (i = 0; i < numCmds; i++) { - codeDelta = (mapPtr[i].codeOffset - prevOffset); - if (codeDelta < 0) { - panic("EncodeCmdLocMap: bad code offset"); - } else if (codeDelta <= 127) { - TclStoreInt1AtPtr(codeDelta, p); - p++; - } else { - TclStoreInt1AtPtr(0xFF, p); - p++; - TclStoreInt4AtPtr(codeDelta, p); - p += 4; - } - prevOffset = mapPtr[i].codeOffset; + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + maxDepth = TclMax(numObjsToConcat, maxDepth); } /* - * Encode the code length for each command. + * If necessary, concatenate the parts of the word. */ - codePtr->codeLengthStart = p; - for (i = 0; i < numCmds; i++) { - codeLen = mapPtr[i].numCodeBytes; - if (codeLen < 0) { - panic("EncodeCmdLocMap: bad code length"); - } else if (codeLen <= 127) { - TclStoreInt1AtPtr(codeLen, p); - p++; - } else { - TclStoreInt1AtPtr(0xFF, p); - p++; - TclStoreInt4AtPtr(codeLen, p); - p += 4; - } + while (numObjsToConcat > 255) { + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ + } + if (numObjsToConcat > 1) { + TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); } /* - * Encode the source offset for each command as a sequence of deltas. + * If the tokens yielded no instructions, push an empty string. */ + + if (envPtr->codeNext == entryCodeNext) { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*alreadyAlloced*/ 0), + envPtr); + maxDepth = 1; + } + Tcl_DStringFree(&textBuffer); + envPtr->maxStackDepth = maxDepth; + return TCL_OK; - codePtr->srcDeltaStart = p; - prevOffset = 0; - for (i = 0; i < numCmds; i++) { - srcDelta = (mapPtr[i].srcOffset - prevOffset); - if ((-127 <= srcDelta) && (srcDelta <= 127)) { - TclStoreInt1AtPtr(srcDelta, p); - p++; - } else { - TclStoreInt1AtPtr(0xFF, p); - p++; - TclStoreInt4AtPtr(srcDelta, p); - p += 4; - } - prevOffset = mapPtr[i].srcOffset; + error: + Tcl_DStringFree(&textBuffer); + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileCmdWord -- + * + * Given an array of parse tokens for a word containing one or more Tcl + * commands, emit inline instructions to execute them. This procedure + * differs from TclCompileTokens in that a simple word such as a loop + * body enclosed in braces is not just pushed as a string, but is + * itself parsed into tokens and compiled. + * + * Results: + * The return value is a standard Tcl result. If an error occurs, an + * error message is left in the interpreter's result. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the tokens. + * + * Side effects: + * Instructions are added to envPtr to execute the tokens at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileCmdWord(interp, tokenPtr, count, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens + * for a command word to compile inline. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ +{ + int code; + + /* + * Handle the common case: if there is a single text token, compile it + * into an inline sequence of instructions. + */ + + envPtr->maxStackDepth = 0; + if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { + code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size, + /*nested*/ 0, envPtr); + return code; } /* - * Encode the source length for each command. + * Multiple tokens or the single token involves substitutions. Emit + * instructions to invoke the eval command procedure at runtime on the + * result of evaluating the tokens. */ - codePtr->srcLengthStart = p; - for (i = 0; i < numCmds; i++) { - srcLen = mapPtr[i].numSrcChars; - if (srcLen < 0) { - panic("EncodeCmdLocMap: bad source length"); - } else if (srcLen <= 127) { - TclStoreInt1AtPtr(srcLen, p); - p++; - } else { - TclStoreInt1AtPtr(0xFF, p); - p++; - TclStoreInt4AtPtr(srcLen, p); - p += 4; - } + code = TclCompileTokens(interp, tokenPtr, count, envPtr); + if (code != TCL_OK) { + return code; } - - return p; + TclEmitOpcode(INST_EVAL_STK, envPtr); + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclCompileString -- + * TclCompileExprWords -- * - * Compile a Tcl script in a null-terminated binary string. + * Given an array of parse tokens representing one or more words that + * contain a Tcl expression, emit inline instructions to execute the + * expression. This procedure differs from TclCompileExpr in that it + * supports Tcl's two-level substitution semantics for expressions that + * appear as command words. * * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->termOffset and interp->termOffset are filled in with the - * offset of the character in the string just after the last one - * successfully processed; this might be the offset of the ']' (if - * flags & TCL_BRACKET_TERM), or the offset of the '\0' at the end of - * the string. Also updates envPtr->maxStackDepth with the maximum - * number of stack elements needed to execute the string's commands. + * The return value is a standard Tcl result. If an error occurs, an + * error message is left in the interpreter's result. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. * * Side effects: - * Adds instructions to envPtr to evaluate the string at runtime. + * Instructions are added to envPtr to execute the expression. * *---------------------------------------------------------------------- */ int -TclCompileString(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +TclCompileExprWords(interp, tokenPtr, numWords, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + Tcl_Token *tokenPtr; /* Points to first in an array of word + * tokens tokens for the expression to + * compile inline. */ + int numWords; /* Number of word tokens starting at + * tokenPtr. Must be at least 1. Each word + * token contains one or more subtokens. */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ { - Interp *iPtr = (Interp *) interp; - register char *src = string;/* Points to current source char. */ - register char c = *src; /* The current char. */ - register int type; /* Current char's CHAR_TYPE type. */ - char termChar = (char)((flags & TCL_BRACKET_TERM)? ']' : '\0'); - /* Return when this character is found - * (either ']' or '\0'). Zero means newlines - * terminate cmds. */ - int isFirstCmd = 1; /* 1 if compiling the first cmd. */ - char *cmdSrcStart = NULL; /* Points to first non-blank char in each - * command. Initialized to avoid compiler - * warning. */ - int cmdIndex; /* The index of the current command in the - * compilation environment's command - * location table. */ - int lastTopLevelCmdIndex = -1; - /* Index of most recent toplevel command in - * the command location table. Initialized - * to avoid compiler warning. */ - int cmdCodeOffset = -1; /* Offset of first byte of current command's - * code. Initialized to avoid compiler - * warning. */ - int cmdWords; /* Number of words in current command. */ - Tcl_Command cmd; /* Used to search for commands. */ - Command *cmdPtr; /* Points to command's Command structure if - * first word is simple and command was - * found; else NULL. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute all cmds. */ - char *termPtr; /* Points to char that terminated word. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null character - * during processing of words. */ - int objIndex = -1; /* The object array index for a pushed - * object holding a word or word part - * Initialized to avoid compiler warning. */ - unsigned char *entryCodeNext = envPtr->codeNext; - /* Value of envPtr's current instruction - * pointer at entry. Used to tell if any - * instructions generated. */ - char *ellipsis = ""; /* Used to set errorInfo variable; "..." - * indicates that not all of offending - * command is included in errorInfo. "" - * means that the command is all there. */ - Tcl_Obj *objPtr; - int numChars; - int result = TCL_OK; - int savePushSimpleWords = envPtr->pushSimpleWords; + Tcl_Token *wordPtr, *partPtr; + JumpFixup jumpFixup; + int maxDepth, doExprInline, range, numBytes, i, j, code; + char *script; + char saveChar; + int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; + int saveExprIsComparison = envPtr->exprIsComparison; + + envPtr->maxStackDepth = 0; + maxDepth = 0; + range = -1; + code = TCL_OK; /* - * commands: command {(';' | '\n') command} + * If the expression is a single word that doesn't require + * substitutions, just compile it's string into inline instructions. */ - while ((src != lastChar) && (c != termChar)) { + if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { /* - * Skip white space, semicolons, backslash-newlines (treated as - * spaces), and comments before command. + * Temporarily overwrite the character just after the end of the + * string with a 0 byte. */ - type = CHAR_TYPE(src, lastChar); - while ((type & (TCL_SPACE | TCL_BACKSLASH)) - || (c == '\n') || (c == ';')) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; - } - } else { - src++; - } - c = *src; - type = CHAR_TYPE(src, lastChar); - } - - if (c == '#') { - while (src != lastChar) { - if (c == '\\') { - int numRead; - Tcl_Backslash(src, &numRead); - src += numRead; - } else if (c == '\n') { - src++; - c = *src; - envPtr->termOffset = (src - string); + script = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + saveChar = script[numBytes]; + script[numBytes] = 0; + code = TclCompileExpr(interp, script, numBytes, envPtr); + script[numBytes] = saveChar; + return code; + } + + /* + * Multiple words or the single word requires substitutions. We may + * need to call expr's command proc at runtime. This often recompiles + * the expression each time and is slow. However, there are some + * circumstances where we can still compile inline code "optimistically" + * and check for type errors during execution that signal when double + * substitutions must be done. + */ + + doExprInline = 1; + wordPtr = tokenPtr; + for (i = 0; ((i < numWords) && doExprInline); i++) { + if (wordPtr->type == TCL_TOKEN_WORD) { + for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents; + j++, partPtr++) { + if ((partPtr->type == TCL_TOKEN_BS) + || (partPtr->type == TCL_TOKEN_COMMAND)) { + doExprInline = 0; break; - } else { - src++; } - c = *src; } - continue; /* end of comment, restart outer command loop */ - } - - /* - * Compile one command: zero or more words terminated by a '\n', - * ';', ']' (if command is terminated by close bracket), or - * the end of string. - * - * command: word* - */ - - type = CHAR_TYPE(src, lastChar); - if ((type == TCL_COMMAND_END) - && ((c != ']') || (flags & TCL_BRACKET_TERM))) { - continue; /* empty command; restart outer cmd loop */ } + wordPtr += (wordPtr->numComponents + 1); + } - /* - * If not the first command, discard the previous command's result. - */ + /* + * If only variable substitutions appear (no backslash or command + * substitutions), inline compile the expr inside a "catch" so that if + * there is any error, we call expr's command proc at runtime. + */ + + if (doExprInline) { + Tcl_DString exprBuffer; + int startCodeOffset = (envPtr->codeNext - envPtr->codeStart); + int startExceptNext = envPtr->exceptArrayNext; - if (!isFirstCmd) { - TclEmitOpcode(INST_POP, envPtr); - if (!(flags & TCL_BRACKET_TERM)) { - /* - * We are compiling a top level command. Update the number - * of code bytes for the last command to account for the pop - * instruction. - */ - - (envPtr->cmdMapPtr[lastTopLevelCmdIndex]).numCodeBytes = - (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset; - } - } + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); + + Tcl_DStringInit(&exprBuffer); + wordPtr = tokenPtr; + for (i = 0; i < numWords; i++) { + if (i > 0) { + Tcl_DStringAppend(&exprBuffer, " ", 1); + } + for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents; + j++, partPtr++) { + switch (partPtr->type) { + case TCL_TOKEN_TEXT: + Tcl_DStringAppend(&exprBuffer, partPtr->start, + partPtr->size); + break; - /* - * Compile the words of the command. Process the first word - * specially, since it is the name of a command. If it is a "simple" - * string (just a sequence of characters), look it up in the table - * of compilation procedures. If a word other than the first is - * simple and represents an integer whose formatted representation - * is the same as the word, just push an integer object. Also record - * starting source and object information for the command. - */ + case TCL_TOKEN_VARIABLE: + Tcl_DStringAppend(&exprBuffer, partPtr->start, + partPtr->size); + j += partPtr->numComponents; + partPtr += partPtr->numComponents; + break; - envPtr->numCommands++; - cmdIndex = (envPtr->numCommands - 1); - if (!(flags & TCL_BRACKET_TERM)) { - lastTopLevelCmdIndex = cmdIndex; + default: + panic("unexpected token type in TclCompileExprWords"); + } + } + wordPtr += (wordPtr->numComponents + 1); } + envPtr->exceptArrayPtr[range].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileExpr(interp, Tcl_DStringValue(&exprBuffer), + Tcl_DStringLength(&exprBuffer), envPtr); + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[range].codeOffset; + maxDepth = envPtr->maxStackDepth; + Tcl_DStringFree(&exprBuffer); - cmdSrcStart = src; - cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart); - cmdWords = 0; - EnterCmdStartData(envPtr, cmdIndex, src-envPtr->source, - cmdCodeOffset); - - if ((!(flags & TCL_BRACKET_TERM)) - && (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + if ((code != TCL_OK) || (envPtr->exprIsJustVarRef) + || (envPtr->exprIsComparison)) { /* - * Display a line summarizing the top level command we are about - * to compile. + * Delete the inline code and call the expr command proc at + * runtime. There was a compilation error or the inline code + * might not have the right 2 level substitution semantics: + * e.g., if the expr consisted of a single variable ref or the + * top-level operator is a comparison (which might operate on + * strings). The code might appear to execute successfully but + * produce the wrong result. We depend on execution failing if a + * second level of substitutions is required. */ - char *p = cmdSrcStart; - int numChars, complete; - - while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END) - || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) { - p++; - } - numChars = (p - cmdSrcStart); - complete = 1; - if (numChars > 60) { - numChars = 60; - complete = 0; - } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) { - complete = 0; - } - fprintf(stdout, "Compiling: %.*s%s\n", - numChars, cmdSrcStart, (complete? "" : " ...")); + envPtr->codeNext = (envPtr->codeStart + startCodeOffset); + envPtr->exceptArrayNext = startExceptNext; + doExprInline = 0; + } else { + TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */ + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + envPtr->exceptArrayPtr[range].catchOffset = + (envPtr->codeNext - envPtr->codeStart); + TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */ } - - while ((type != TCL_COMMAND_END) - || ((c == ']') && !(flags & TCL_BRACKET_TERM))) { - /* - * Skip any leading white space at the start of a word. Note - * that a backslash-newline is treated as a space. - */ - - while (type & (TCL_SPACE | TCL_BACKSLASH)) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; - } - } else { - src++; - } - c = *src; - type = CHAR_TYPE(src, lastChar); - } - if ((type == TCL_COMMAND_END) - && ((c != ']') || (flags & TCL_BRACKET_TERM))) { - break; /* no words remain for command. */ - } + } + + /* + * Emit code to call the expr command proc at runtime. Concatenate the + * (already substituted once) expr tokens with a space between each. + */ + wordPtr = tokenPtr; + for (i = 0; i < numWords; i++) { + code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, + envPtr); + if (code != TCL_OK) { + break; + } + if (i < (numWords - 1)) { + TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0), + envPtr); + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + } else { + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + } + wordPtr += (wordPtr->numComponents + 1); + } + if (code == TCL_OK) { + int concatItems = 2*numWords - 1; + while (concatItems > 255) { + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + concatItems -= 254; + } + if (concatItems > 1) { + TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); + } + TclEmitOpcode(INST_EXPR_STK, envPtr); + } + + /* + * If generating inline code, update the target of the jump at the end. + */ + + if (doExprInline) { + int jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { /* - * Compile one word. We use an inline version of CompileWord to - * avoid an extra procedure call. + * Update the inline expression code's catch ExceptionRange + * target since it, being after the jump, also moved down. */ - - envPtr->pushSimpleWords = 0; - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; - if (type == TCL_QUOTE) { - result = TclCompileQuotes(interp, src, lastChar, - '"', flags, envPtr); - } else { - result = CompileBraces(interp, src, lastChar, - flags, envPtr); - } - termPtr = (src + envPtr->termOffset); - if (result != TCL_OK) { - src = termPtr; - goto done; - } - - /* - * Make sure terminating character of the quoted or braced - * string is the end of word. - */ - - c = *termPtr; - if ((c == '\\') && (*(termPtr+1) == '\n')) { - /* - * Line is continued on next line; the backslash- - * newline turns into space, which terminates the word. - */ - } else { - type = CHAR_TYPE(termPtr, lastChar); - if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) { - Tcl_ResetResult(interp); - if (*(src-1) == '"') { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-quote", -1); - } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-brace", -1); - } - result = TCL_ERROR; - } - } - } else { - result = CompileMultipartWord(interp, src, lastChar, - flags, envPtr); - termPtr = (src + envPtr->termOffset); - } - if (result != TCL_OK) { - ellipsis = "..."; - src = termPtr; - goto done; - } - if (envPtr->wordIsSimple) { - /* - * A simple word. Temporarily replace the terminating - * character with a null character. - */ - - numChars = envPtr->numSimpleWordChars; - savedChar = src[numChars]; - src[numChars] = '\0'; - - if ((cmdWords == 0) - && (!(iPtr->flags & DONT_COMPILE_CMDS_INLINE))) { - /* - * The first word of a command and inline command - * compilation has not been disabled (e.g., by command - * traces). Look up the first word in the interpreter's - * hashtable of commands. If a compilation procedure is - * found, let it compile the command after resetting - * error logging information. Note that if we are - * compiling a procedure, we must look up the command - * in the procedure's namespace and not the current - * namespace. - */ - - Namespace *cmdNsPtr; - - if (envPtr->procPtr != NULL) { - cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; - } else { - cmdNsPtr = NULL; - } - - cmdPtr = NULL; - cmd = Tcl_FindCommand(interp, src, - (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); - if (cmd != (Tcl_Command) NULL) { - cmdPtr = (Command *) cmd; - } - if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) { - char *firstArg = termPtr; - src[numChars] = savedChar; - iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS - | ERROR_CODE_SET); - result = (*(cmdPtr->compileProc))(interp, - firstArg, lastChar, flags, envPtr); - if (result == TCL_OK) { - src = (firstArg + envPtr->termOffset); - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - goto finishCommand; - } else if (result == TCL_OUT_LINE_COMPILE) { - result = TCL_OK; - src[numChars] = '\0'; - } else { - src = firstArg; - goto done; /* an error */ - } - } + envPtr->exceptArrayPtr[range].catchOffset += 3; + } + envPtr->exceptDepth--; + } + + envPtr->exprIsJustVarRef = saveExprIsJustVarRef; + envPtr->exprIsComparison = saveExprIsComparison; + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitByteCodeObj -- + * + * Create a ByteCode structure and initialize it from a CompileEnv + * compilation environment structure. The ByteCode structure is + * smaller and contains just that information needed to execute + * the bytecode instructions resulting from compiling a Tcl script. + * The resulting structure is placed in the specified object. + * + * Results: + * A newly constructed ByteCode object is stored in the internal + * representation of the objPtr. + * + * Side effects: + * A single heap object is allocated to hold the new ByteCode structure + * and its code, object, command location, and aux data arrays. Note + * that "ownership" (i.e., the pointers to) the Tcl objects and aux + * data items will be handed over to the new ByteCode structure from + * the CompileEnv structure. + * + *---------------------------------------------------------------------- + */ - /* - * No compile procedure was found for the command: push - * the word and continue to compile the remaining - * words. If a hashtable entry was found for the - * command, push a CmdName object instead to avoid - * runtime lookups. If necessary, convert the pushed - * object to be a CmdName object. If this is the first - * CmdName object in this code unit that refers to the - * command, increment the reference count in the - * Command structure to reflect the new reference from - * the CmdName object and, if the command is deleted - * later, to keep the Command structure from being freed - * until TclExecuteByteCode has a chance to recognize - * that the command was deleted. - */ +void +TclInitByteCodeObj(objPtr, envPtr) + Tcl_Obj *objPtr; /* Points object that should be + * initialized, and whose string rep + * contains the source code. */ + register CompileEnv *envPtr; /* Points to the CompileEnv structure from + * which to create a ByteCode structure. */ +{ + register ByteCode *codePtr; + size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; + size_t auxDataArrayBytes, structureSize; + register unsigned char *p; + unsigned char *nextPtr; + int numLitObjects = envPtr->literalArrayNext; + Namespace *namespacePtr; + int i; + Interp *iPtr; - objIndex = TclObjIndexForString(src, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - if (cmdPtr != NULL) { - objPtr = envPtr->objArrayPtr[objIndex]; - if ((objPtr->typePtr != &tclCmdNameType) - && (objPtr->bytes != NULL)) { - ResolvedCmdName *resPtr = (ResolvedCmdName *) - ckalloc(sizeof(ResolvedCmdName)); - Namespace *nsPtr = (Namespace *) - Tcl_GetCurrentNamespace(interp); - - resPtr->cmdPtr = cmdPtr; - resPtr->refNsPtr = nsPtr; - resPtr->refNsId = nsPtr->nsId; - resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - resPtr->refCount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = - (VOID *) resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; - cmdPtr->refCount++; - } - } - } else { - /* - * See if the word represents an integer whose formatted - * representation is the same as the word (e.g., this is - * true for 123 and -1 but not for 00005). If so, just - * push an integer object. - */ + iPtr = envPtr->iPtr; - int isCompilableInt = 0; - long n; - char buf[40]; - - if (TclLooksLikeInt(src)) { - int code = TclGetLong(interp, src, &n); - if (code == TCL_OK) { - TclFormatInt(buf, n); - if (strcmp(src, buf) == 0) { - isCompilableInt = 1; - objIndex = TclObjIndexForString(src, - numChars, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = n; - objPtr->typePtr = &tclIntType; - } - } else { - Tcl_ResetResult(interp); - } - } - if (!isCompilableInt) { - objIndex = TclObjIndexForString(src, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - } - } - src[numChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = TclMax((cmdWords + 1), maxDepth); - } else { /* not a simple word */ - maxDepth = TclMax((cmdWords + envPtr->maxStackDepth), - maxDepth); - } - src = termPtr; - c = *src; - type = CHAR_TYPE(src, lastChar); - cmdWords++; - } - - /* - * Emit an invoke instruction for the command. If a compile command - * was found for the command we called it and skipped this. - */ + codeBytes = (envPtr->codeNext - envPtr->codeStart); + objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *)); + exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange)); + auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); + cmdLocBytes = GetCmdLocEncodingSize(envPtr); + + /* + * Compute the total number of bytes needed for this bytecode. + */ - if (cmdWords > 0) { - if (cmdWords <= 255) { - TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr); - } else { - TclEmitInstUInt4(INST_INVOKE_STK4, cmdWords, envPtr); - } - } + structureSize = sizeof(ByteCode); + structureSize += TCL_ALIGN(codeBytes); /* align object array */ + structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */ + structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + structureSize += auxDataArrayBytes; + structureSize += cmdLocBytes; - /* - * Update the compilation environment structure. Record - * source/object information for the command. - */ + if (envPtr->iPtr->varFramePtr != NULL) { + namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; + } else { + namespacePtr = envPtr->iPtr->globalNsPtr; + } + + p = (unsigned char *) ckalloc((size_t) structureSize); + codePtr = (ByteCode *) p; + codePtr->interpHandle = TclHandlePreserve(iPtr->handle); + codePtr->compileEpoch = iPtr->compileEpoch; + codePtr->nsPtr = namespacePtr; + codePtr->nsEpoch = namespacePtr->resolverEpoch; + codePtr->refCount = 1; + codePtr->flags = 0; + codePtr->source = envPtr->source; + codePtr->procPtr = envPtr->procPtr; - finishCommand: - EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart, - (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset); - - isFirstCmd = 0; - envPtr->termOffset = (src - string); - c = *src; + codePtr->numCommands = envPtr->numCommands; + codePtr->numSrcBytes = envPtr->numSrcBytes; + codePtr->numCodeBytes = codeBytes; + codePtr->numLitObjects = numLitObjects; + codePtr->numExceptRanges = envPtr->exceptArrayNext; + codePtr->numAuxDataItems = envPtr->auxDataArrayNext; + codePtr->numCmdLocBytes = cmdLocBytes; + codePtr->maxExceptDepth = envPtr->maxExceptDepth; + codePtr->maxStackDepth = envPtr->maxStackDepth; + + p += sizeof(ByteCode); + codePtr->codeStart = p; + memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes); + + p += TCL_ALIGN(codeBytes); /* align object array */ + codePtr->objArrayPtr = (Tcl_Obj **) p; + for (i = 0; i < numLitObjects; i++) { + codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; } - done: - if (result == TCL_OK) { - /* - * If the source string yielded no instructions (e.g., if it was - * empty), push an empty string object as the command's result. - */ + p += TCL_ALIGN(objArrayBytes); /* align exception range array */ + if (exceptArrayBytes > 0) { + codePtr->exceptArrayPtr = (ExceptionRange *) p; + memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr, + (size_t) exceptArrayBytes); + } else { + codePtr->exceptArrayPtr = NULL; + } - if (entryCodeNext == envPtr->codeNext) { - int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } + p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + if (auxDataArrayBytes > 0) { + codePtr->auxDataArrayPtr = (AuxData *) p; + memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, + (size_t) auxDataArrayBytes); } else { - /* - * Add additional error information. First compute the line number - * where the error occurred. - */ - - register char *p; - int numChars; - char buf[200]; - - iPtr->errorLine = 1; - for (p = string; p != cmdSrcStart; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } + codePtr->auxDataArrayPtr = NULL; + } - /* - * Figure out how much of the command to print (up to a certain - * number of characters, or up to the end of the command). - */ + p += auxDataArrayBytes; + nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); +#ifdef TCL_COMPILE_DEBUG + if (((size_t)(nextPtr - p)) != cmdLocBytes) { + panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); + } +#endif + + /* + * Record various compilation-related statistics about the new ByteCode + * structure. Don't include overhead for statistics-related fields. + */ - p = cmdSrcStart; - while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END) - || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) { - p++; - } - numChars = (p - cmdSrcStart); - if (numChars > 150) { - numChars = 150; - ellipsis = " ..."; - } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) { - ellipsis = " ..."; - } - - sprintf(buf, "\n while compiling\n\"%.*s%s\"", - numChars, cmdSrcStart, ellipsis); - Tcl_AddObjErrorInfo(interp, buf, -1); - } - - envPtr->termOffset = (src - string); - iPtr->termOffset = envPtr->termOffset; - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; +#ifdef TCL_COMPILE_STATS + codePtr->structureSize = structureSize + - (sizeof(size_t) + sizeof(Tcl_Time)); + TclpGetTime(&(codePtr->createTime)); + + RecordByteCodeStats(codePtr); +#endif /* TCL_COMPILE_STATS */ + + /* + * Free the old internal rep then convert the object to a + * bytecode object by making its internal rep point to the just + * compiled ByteCode. + */ + + if ((objPtr->typePtr != NULL) && + (objPtr->typePtr->freeIntRepProc != NULL)) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + objPtr->internalRep.otherValuePtr = (VOID *) codePtr; + objPtr->typePtr = &tclByteCodeType; } /* *---------------------------------------------------------------------- * - * CompileWord -- + * LogCompilationInfo -- * - * This procedure compiles one word from a command string. It skips - * any leading white space. - * - * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this - * procedure emits push and other instructions to compute the - * word on the Tcl evaluation stack at execution time. If a caller sets - * envPtr->pushSimpleWords to 0, CompileWord will _not_ compile - * "simple" words: words that are just a sequence of characters without - * backslashes. It will leave their compilation up to the caller. - * - * As an important special case, if the word is simple, this procedure - * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the - * number of characters in the simple word. This allows the caller to - * process these words specially. + * This procedure is invoked after an error occurs during compilation. + * It adds information to the "errorInfo" variable to describe the + * command that was being compiled when the error occurred. * * Results: - * The return value is a standard Tcl result. If an error occurs, an - * error message is left in the interpreter's result. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed in the last - * word. This is normally the character just after the last one in a - * word (perhaps the command terminator), or the vicinity of an error - * (if the result is not TCL_OK). - * - * envPtr->wordIsSimple is set 1 if the word is simple: just a - * sequence of characters without backslashes. If so, the word's - * characters are the envPtr->numSimpleWordChars characters starting - * at string. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to evaluate the word. This is not changed if - * the word is simple and envPtr->pushSimpleWords was 0 (false). + * None. * * Side effects: - * Instructions are added to envPtr to compute and push the word - * at runtime. + * Information about the command is added to errorInfo and the + * line number stored internally in the interpreter is set. If this + * is the first call to this procedure or Tcl_AddObjErrorInfo since + * an error occurred, then old information in errorInfo is + * deleted. * *---------------------------------------------------------------------- */ -static int -CompileWord(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* First character of word. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same values - * passed to Tcl_EvalObj). */ - CompileEnv *envPtr; /* Holds the resulting instructions. */ +static void +LogCompilationInfo(interp, script, command, length) + Tcl_Interp *interp; /* Interpreter in which to log the + * information. */ + char *script; /* First character in script containing + * command (must be <= command). */ + char *command; /* First character in command that + * generated the error. */ + int length; /* Number of bytes in command (-1 means + * use all bytes up to first null byte). */ { - /* - * Compile one word: approximately - * - * word: quoted_string | braced_string | multipart_word - * quoted_string: '"' char* '"' - * braced_string: '{' char* '}' - * multipart_word (see CompileMultipartWord below) - */ - - register char *src = string; /* Points to current source char. */ - register int type = CHAR_TYPE(src, lastChar); - /* Current char's CHAR_TYPE type. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to compute and push the word. */ - char *termPtr = src; /* Points to the character that terminated - * the word. */ - int result = TCL_OK; + char buffer[200]; + register char *p; + char *ellipsis = ""; + Interp *iPtr = (Interp *) interp; - /* - * Skip any leading white space at the start of a word. Note that a - * backslash-newline is treated as a space. - */ + if (iPtr->flags & ERR_ALREADY_LOGGED) { + /* + * Someone else has already logged error information for this + * command; we shouldn't add anything more. + */ - while (type & (TCL_SPACE | TCL_BACKSLASH)) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; /* no longer white space */ - } - } else { - src++; - } - type = CHAR_TYPE(src, lastChar); - } - if (type == TCL_COMMAND_END) { - goto done; + return; } /* - * Compile the word. Handle quoted and braced string words here in order - * to avoid an extra procedure call. + * Compute the line number where the error occurred. */ - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; - if (type == TCL_QUOTE) { - result = TclCompileQuotes(interp, src, lastChar, '"', flags, - envPtr); - } else { - result = CompileBraces(interp, src, lastChar, flags, envPtr); - } - termPtr = (src + envPtr->termOffset); - if (result != TCL_OK) { - goto done; - } - - /* - * Make sure terminating character of the quoted or braced string is - * the end of word. - */ - - if ((*termPtr == '\\') && (*(termPtr+1) == '\n')) { - /* - * Line is continued on next line; the backslash-newline turns - * into space, which terminates the word. - */ - } else { - type = CHAR_TYPE(termPtr, lastChar); - if (!(type & (TCL_SPACE | TCL_COMMAND_END))) { - Tcl_ResetResult(interp); - if (*(src-1) == '"') { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-quote", -1); - } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-brace", -1); - } - result = TCL_ERROR; - goto done; - } + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; } - maxDepth = envPtr->maxStackDepth; - } else { - result = CompileMultipartWord(interp, src, lastChar, flags, envPtr); - termPtr = (src + envPtr->termOffset); - maxDepth = envPtr->maxStackDepth; } /* - * Done processing the word. The values of envPtr->wordIsSimple and - * envPtr->numSimpleWordChars are left at the values returned by - * TclCompileQuotes/Braces/MultipartWord. + * Create an error message to add to errorInfo, including up to a + * maximum number of characters of the command. */ - - done: - envPtr->termOffset = (termPtr - string); - envPtr->maxStackDepth = maxDepth; - return result; + + if (length < 0) { + length = strlen(command); + } + if (length > 150) { + length = 150; + ellipsis = "..."; + } + sprintf(buffer, "\n while compiling\n\"%.*s%s\"", + length, command, ellipsis); + Tcl_AddObjErrorInfo(interp, buffer, -1); } /* *---------------------------------------------------------------------- * - * CompileMultipartWord -- - * - * This procedure compiles one multipart word: a word comprised of some - * number of nested commands, variable references, or arbitrary - * characters. This procedure assumes that quoted string and braced - * string words and the end of command have already been handled by its - * caller. It also assumes that any leading white space has already - * been consumed. - * - * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this - * procedure emits push and other instructions to compute the word on - * the Tcl evaluation stack at execution time. If a caller sets - * envPtr->pushSimpleWords to 0, it will _not_ compile "simple" words: - * words that are just a sequence of characters without backslashes. - * It will leave their compilation up to the caller. This is done, for - * example, to provide special support for the first word of commands, - * which are almost always the (simple) name of a command. - * - * As an important special case, if the word is simple, this procedure - * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the - * number of characters in the simple word. This allows the caller to - * process these words specially. + * TclFindCompiledLocal -- * - * Results: - * The return value is a standard Tcl result. If an error occurs, an - * error message is left in the interpreter's result. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed in the last - * word. This is normally the character just after the last one in a - * word (perhaps the command terminator), or the vicinity of an error - * (if the result is not TCL_OK). - * - * envPtr->wordIsSimple is set 1 if the word is simple: just a - * sequence of characters without backslashes. If so, the word's - * characters are the envPtr->numSimpleWordChars characters starting - * at string. + * This procedure is called at compile time to look up and optionally + * allocate an entry ("slot") for a variable in a procedure's array of + * local variables. If the variable's name is NULL, a new temporary + * variable is always created. (Such temporary variables can only be + * referenced using their slot index.) * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to evaluate the word. This is not changed if - * the word is simple and envPtr->pushSimpleWords was 0 (false). + * Results: + * If create is 0 and the name is non-NULL, then if the variable is + * found, the index of its entry in the procedure's array of local + * variables is returned; otherwise -1 is returned. If name is NULL, + * the index of a new temporary variable is returned. Finally, if + * create is 1 and name is non-NULL, the index of a new entry is + * returned. * * Side effects: - * Instructions are added to envPtr to compute and push the word - * at runtime. + * Creates and registers a new local variable if create is 1 and + * the variable is unknown, or if the name is NULL. * *---------------------------------------------------------------------- */ -static int -CompileMultipartWord(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* First character of word. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same values - * passed to Tcl_EvalObj). */ - CompileEnv *envPtr; /* Holds the resulting instructions. */ +int +TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) + register char *name; /* Points to first character of the name of + * a scalar or array variable. If NULL, a + * temporary var should be created. */ + int nameBytes; /* Number of bytes in the name. */ + int create; /* If 1, allocate a local frame entry for + * the variable if it is new. */ + int flags; /* Flag bits for the compiled local if + * created. Only VAR_SCALAR, VAR_ARRAY, and + * VAR_LINK make sense. */ + register Proc *procPtr; /* Points to structure describing procedure + * containing the variable reference. */ { + register CompiledLocal *localPtr; + int localVar = -1; + register int i; + /* - * Compile one multi_part word: - * - * multi_part_word: word_part+ - * word_part: nested_cmd | var_reference | char+ - * nested_cmd: '[' command ']' - * var_reference: '$' name | '$' name '(' index_string ')' | - * '$' '{' braced_name '}') - * name: (letter | digit | underscore)+ - * braced_name: (non_close_brace_char)* - * index_string: (non_close_paren_char)* + * If not creating a temporary, does a local variable of the specified + * name already exist? */ - - register char *src = string; /* Points to current source char. */ - register char c = *src; /* The current char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int bracketNormal = !(flags & TCL_BRACKET_TERM); - int simpleWord = 0; /* Set 1 if word is simple. */ - int numParts = 0; /* Count of word_part objs pushed. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to compute and push the word. */ - char *start; /* Starting position of char+ word_part. */ - int hasBackslash; /* Nonzero if '\' in char+ word_part. */ - int numChars; /* Number of chars in char+ word_part. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null character - * during word_part processing. */ - int objIndex; /* The object array index for a pushed - * object holding a word_part. */ - int savePushSimpleWords = envPtr->pushSimpleWords; - int result = TCL_OK; - int numRead; - - type = CHAR_TYPE(src, lastChar); - while (1) { - /* - * Process a word_part: a sequence of chars, a var reference, or - * a nested command. - */ - - if ((type & (TCL_NORMAL | TCL_CLOSE_BRACE | TCL_BACKSLASH | - TCL_QUOTE | TCL_OPEN_BRACE)) || - ((c == ']') && bracketNormal)) { - /* - * A char+ word part. Scan first looking for any backslashes. - * Note that a backslash-newline must be treated as a word - * separator, as if the backslash-newline had been collapsed - * before command parsing began. - */ - - start = src; - hasBackslash = 0; - do { - if (type == TCL_BACKSLASH) { - hasBackslash = 1; - Tcl_Backslash(src, &numRead); - if (src[1] == '\n') { - src += numRead; - type = TCL_SPACE; /* force word end */ - break; - } - src += numRead; - } else { - src++; - } - c = *src; - type = CHAR_TYPE(src, lastChar); - } while (type & (TCL_NORMAL | TCL_BACKSLASH | TCL_QUOTE | - TCL_OPEN_BRACE | TCL_CLOSE_BRACE) - || ((c == ']') && bracketNormal)); - - if ((numParts == 0) && !hasBackslash - && (type & (TCL_SPACE | TCL_COMMAND_END))) { - /* - * The word is "simple": just a sequence of characters - * without backslashes terminated by a TCL_SPACE or - * TCL_COMMAND_END. Just return if we are not to compile - * simple words. - */ - - simpleWord = 1; - if (!envPtr->pushSimpleWords) { - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string); - envPtr->termOffset = envPtr->numSimpleWordChars; - envPtr->pushSimpleWords = savePushSimpleWords; - return TCL_OK; - } - } - - /* - * Create and push a string object for the char+ word_part, - * which starts at "start" and ends at the char just before - * src. If backslashes were found, copy the word_part's - * characters with substituted backslashes into a heap-allocated - * buffer and use it to create the string object. Temporarily - * replace the terminating character with a null character. - */ - numChars = (src - start); - savedChar = start[numChars]; - start[numChars] = '\0'; - if ((numChars > 0) && (hasBackslash)) { - char *buffer = ckalloc((unsigned) numChars + 1); - register char *dst = buffer; - register char *p = start; - while (p < src) { - if (*p == '\\') { - *dst = Tcl_Backslash(p, &numRead); - if (p[1] == '\n') { - break; - } - p += numRead; - dst++; - } else { - *dst++ = *p++; - } + if (name != NULL) { + int localCt = procPtr->numCompiledLocals; + localPtr = procPtr->firstLocalPtr; + for (i = 0; i < localCt; i++) { + if (!TclIsVarTemporary(localPtr)) { + char *localName = localPtr->name; + if ((name[0] == localName[0]) + && (nameBytes == localPtr->nameLength) + && (strncmp(name, localName, (unsigned) nameBytes) == 0)) { + return i; } - *dst = '\0'; - objIndex = TclObjIndexForString(buffer, dst-buffer, - /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); - } else { - objIndex = TclObjIndexForString(start, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - } - start[numChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = TclMax((numParts + 1), maxDepth); - } else if (type == TCL_DOLLAR) { - result = TclCompileDollarVar(interp, src, lastChar, - flags, envPtr); - src += envPtr->termOffset; - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); - c = *src; - type = CHAR_TYPE(src, lastChar); - } else if (type == TCL_OPEN_BRACKET) { - char *termPtr; - envPtr->pushSimpleWords = 1; - src++; - result = TclCompileString(interp, src, lastChar, - (flags | TCL_BRACKET_TERM), envPtr); - termPtr = (src + envPtr->termOffset); - if (*termPtr == ']') { - termPtr++; - } else if (*termPtr == '\0') { - /* - * Missing ] at end of nested command. - */ - - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-bracket", -1); - result = TCL_ERROR; - } - src = termPtr; - if (result != TCL_OK) { - goto done; } - maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); - c = *src; - type = CHAR_TYPE(src, lastChar); - } else if (type & (TCL_SPACE | TCL_COMMAND_END)) { - goto wordEnd; + localPtr = localPtr->nextPtr; } - numParts++; - } /* end of infinite loop */ + } - wordEnd: /* - * End of a non-simple word: TCL_SPACE, TCL_COMMAND_END, or - * backslash-newline. Concatenate the word_parts if necessary. + * Create a new variable if appropriate. */ + + if (create || (name == NULL)) { + localVar = procPtr->numCompiledLocals; + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameBytes+1)); + if (procPtr->firstLocalPtr == NULL) { + procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; + } else { + procPtr->lastLocalPtr->nextPtr = localPtr; + procPtr->lastLocalPtr = localPtr; + } + localPtr->nextPtr = NULL; + localPtr->nameLength = nameBytes; + localPtr->frameIndex = localVar; + localPtr->flags = flags; + if (name == NULL) { + localPtr->flags |= VAR_TEMPORARY; + } + localPtr->defValuePtr = NULL; + localPtr->resolveInfo = NULL; - while (numParts > 255) { - TclEmitInstUInt1(INST_CONCAT1, 255, envPtr); - numParts -= 254; /* concat pushes 1 obj, the result */ - } - if (numParts > 1) { - TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr); - } - - done: - if (simpleWord) { - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string); - } else { - envPtr->wordIsSimple = 0; - envPtr->numSimpleWordChars = 0; + if (name != NULL) { + memcpy((VOID *) localPtr->name, (VOID *) name, + (size_t) nameBytes); + } + localPtr->name[nameBytes] = '\0'; + procPtr->numCompiledLocals++; } - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; + return localVar; } /* *---------------------------------------------------------------------- * - * TclCompileQuotes -- - * - * This procedure compiles a double-quoted string such as a quoted Tcl - * command argument or a quoted value in a Tcl expression. This - * procedure is also used to compile array element names within - * parentheses (where the termChar will be ')' instead of '"'), or - * anything else that needs the substitutions that happen in quotes. - * - * Ordinarily, callers set envPtr->pushSimpleWords to 1 and - * TclCompileQuotes always emits push and other instructions to compute - * the word on the Tcl evaluation stack at execution time. If a caller - * sets envPtr->pushSimpleWords to 0, TclCompileQuotes will not compile - * "simple" words: words that are just a sequence of characters without - * backslashes. It will leave their compilation up to the caller. This - * is done to provide special support for the first word of commands, - * which are almost always the (simple) name of a command. + * TclInitCompiledLocals -- * - * As an important special case, if the word is simple, this procedure - * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the - * number of characters in the simple word. This allows the caller to - * process these words specially. + * This routine is invoked in order to initialize the compiled + * locals table for a new call frame. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing the quoted string. If an error - * occurs then the interpreter's result contains a standard error - * message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed; this is - * usually the character just after the matching close-quote. - * - * envPtr->wordIsSimple is set 1 if the word is simple: just a - * sequence of characters without backslashes. If so, the word's - * characters are the envPtr->numSimpleWordChars characters starting - * at string. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to evaluate the word. This is not changed if - * the word is simple and envPtr->pushSimpleWords was 0 (false). + * None. * * Side effects: - * Instructions are added to envPtr to push the quoted-string - * at runtime. + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. * *---------------------------------------------------------------------- */ -int -TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* Points to the character just after - * the opening '"' or '('. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int termChar; /* Character that terminates the "quoted" - * string (usually double-quote, but might - * be right-paren or something else). */ - int flags; /* Flags to control compilation (same - * values passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds the resulting instructions. */ +void +TclInitCompiledLocals(interp, framePtr, nsPtr) + Tcl_Interp *interp; /* Current interpreter. */ + CallFrame *framePtr; /* Call frame to initialize. */ + Namespace *nsPtr; /* Pointer to current namespace. */ { - register char *src = string; /* Points to current source char. */ - register char c = *src; /* The current char. */ - int simpleWord = 0; /* Set 1 if a simple quoted string word. */ - char *start; /* Start position of char+ string_part. */ - int hasBackslash; /* 1 if '\' found in char+ string_part. */ - int numRead; /* Count of chars read by Tcl_Backslash. */ - int numParts = 0; /* Count of string_part objs pushed. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to compute and push the string. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null - * char during string_part processing. */ - int objIndex; /* The object array index for a pushed - * object holding a string_part. */ - int numChars; /* Number of chars in string_part. */ - int savePushSimpleWords = envPtr->pushSimpleWords; - int result = TCL_OK; - + register CompiledLocal *localPtr; + Interp *iPtr = (Interp*) interp; + Tcl_ResolvedVarInfo *vinfo, *resVarInfo; + Var *varPtr = framePtr->compiledLocals; + Var *resolvedVarPtr; + ResolverScheme *resPtr; + int result; + /* - * quoted_string: '"' string_part* '"' (or termChar instead of ") - * string_part: var_reference | nested_cmd | char+ + * Initialize the array of local variables stored in the call frame. + * Some variables may have special resolution rules. In that case, + * we call their "resolver" procs to get our hands on the variable, + * and we make the compiled local a link to the real variable. */ + for (localPtr = framePtr->procPtr->firstLocalPtr; + localPtr != NULL; + localPtr = localPtr->nextPtr) { - while ((src != lastChar) && (c != termChar)) { - if (c == '$') { - result = TclCompileDollarVar(interp, src, lastChar, flags, - envPtr); - src += envPtr->termOffset; - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); - c = *src; - } else if (c == '[') { - char *termPtr; - envPtr->pushSimpleWords = 1; - src++; - result = TclCompileString(interp, src, lastChar, - (flags | TCL_BRACKET_TERM), envPtr); - termPtr = (src + envPtr->termOffset); - if (*termPtr == ']') { - termPtr++; - } - src = termPtr; - if (result != TCL_OK) { - goto done; - } - if (termPtr == lastChar) { - /* - * Missing ] at end of nested command. - */ - - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-bracket", -1); - result = TCL_ERROR; - goto done; - } - maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); - c = *src; - } else { - /* - * Start of a char+ string_part. Scan first looking for any - * backslashes. - */ + /* + * Check to see if this local is affected by namespace or + * interp resolvers. The resolver to use is cached for the + * next invocation of the procedure. + */ - start = src; - hasBackslash = 0; - do { - if (c == '\\') { - hasBackslash = 1; - Tcl_Backslash(src, &numRead); - src += numRead; - } else { - src++; - } - c = *src; - } while ((src != lastChar) && (c != '$') && (c != '[') - && (c != termChar)); - - if ((numParts == 0) && !hasBackslash - && ((src == lastChar) && (c == termChar))) { - /* - * The quoted string is "simple": just a sequence of - * characters without backslashes terminated by termChar or - * a null character. Just return if we are not to compile - * simple words. - */ + if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED)) + && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) { + resPtr = iPtr->resolverPtr; - simpleWord = 1; - if (!envPtr->pushSimpleWords) { - if ((src == lastChar) && (termChar != '\0')) { - char buf[40]; - sprintf(buf, "missing %c", termChar); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - result = TCL_ERROR; - } else { - src++; - } - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string - 1); - envPtr->termOffset = (src - string); - envPtr->pushSimpleWords = savePushSimpleWords; - return result; - } + if (nsPtr->compiledVarResProc) { + result = (*nsPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } else { + result = TCL_CONTINUE; } - /* - * Create and push a string object for the char+ string_part - * that starts at "start" and ends at the char just before - * src. If backslashes were found, copy the string_part's - * characters with substituted backslashes into a heap-allocated - * buffer and use it to create the string object. Temporarily - * replace the terminating character with a null character. - */ - - numChars = (src - start); - savedChar = start[numChars]; - start[numChars] = '\0'; - if ((numChars > 0) && (hasBackslash)) { - char *buffer = ckalloc((unsigned) numChars + 1); - register char *dst = buffer; - register char *p = start; - while (p < src) { - if (*p == '\\') { - *dst++ = Tcl_Backslash(p, &numRead); - p += numRead; - } else { - *dst++ = *p++; - } + while ((result == TCL_CONTINUE) && resPtr) { + if (resPtr->compiledVarResProc) { + result = (*resPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); } - *dst = '\0'; - objIndex = TclObjIndexForString(buffer, (dst - buffer), - /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); - } else { - objIndex = TclObjIndexForString(start, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + resPtr = resPtr->nextPtr; } - start[numChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = TclMax((numParts + 1), maxDepth); - } - numParts++; - } - - /* - * End of the quoted string: src points at termChar or '\0'. If - * necessary, concatenate the string_part objects on the stack. - */ - - if ((src == lastChar) && (termChar != '\0')) { - char buf[40]; - sprintf(buf, "missing %c", termChar); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - result = TCL_ERROR; - goto done; - } else { - src++; - } + if (result == TCL_OK) { + localPtr->resolveInfo = vinfo; + localPtr->flags |= VAR_RESOLVED; + } + } - if (numParts == 0) { /* - * The quoted string was empty. Push an empty string object. + * Now invoke the resolvers to determine the exact variables that + * should be used. */ - int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - } else { - /* - * Emit any needed concat instructions. - */ - - while (numParts > 255) { - TclEmitInstUInt1(INST_CONCAT1, 255, envPtr); - numParts -= 254; /* concat pushes 1 obj, the result */ - } - if (numParts > 1) { - TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr); - } - } + resVarInfo = localPtr->resolveInfo; + resolvedVarPtr = NULL; - done: - if (simpleWord) { - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string - 1); - } else { - envPtr->wordIsSimple = 0; - envPtr->numSimpleWordChars = 0; + if (resVarInfo && resVarInfo->fetchProc) { + resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, + resVarInfo); + } + + if (resolvedVarPtr) { + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = 0; + TclSetVarLink(varPtr); + varPtr->value.linkPtr = resolvedVarPtr; + resolvedVarPtr->refCount++; + } else { + varPtr->value.objPtr = NULL; + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = (localPtr->flags | VAR_UNDEFINED); + } + varPtr++; } - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; } /* - *-------------------------------------------------------------- - * - * CompileBraces -- - * - * This procedure compiles characters between matching curly braces. + *---------------------------------------------------------------------- * - * Ordinarily, callers set envPtr->pushSimpleWords to 1 and - * CompileBraces always emits a push instruction to compute the word on - * the Tcl evaluation stack at execution time. However, if a caller - * sets envPtr->pushSimpleWords to 0, CompileBraces will _not_ compile - * "simple" words: words that are just a sequence of characters without - * backslash-newlines. It will leave their compilation up to the - * caller. + * TclExpandCodeArray -- * - * As an important special case, if the word is simple, this procedure - * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the - * number of characters in the simple word. This allows the caller to - * process these words specially. + * Procedure that uses malloc to allocate more storage for a + * CompileEnv's code array. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. This is - * usually the character just after the matching close-brace. - * - * envPtr->wordIsSimple is set 1 if the word is simple: just a - * sequence of characters without backslash-newlines. If so, the word's - * characters are the envPtr->numSimpleWordChars characters starting - * at string. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to evaluate the word. This is not changed if - * the word is simple and envPtr->pushSimpleWords was 0 (false). + * None. * * Side effects: - * Instructions are added to envPtr to push the braced string - * at runtime. + * The byte code array in *envPtr is reallocated to a new array of + * double the size, and if envPtr->mallocedCodeArray is non-zero the + * old array is freed. Byte codes are copied from the old array to the + * new one. * - *-------------------------------------------------------------- + *---------------------------------------------------------------------- */ -static int -CompileBraces(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* Character just after opening bracket. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same - * values passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds the resulting instructions. */ +void +TclExpandCodeArray(envPtr) + CompileEnv *envPtr; /* Points to the CompileEnv whose code array + * must be enlarged. */ { - register char *src = string; /* Points to current source char. */ - register char c; /* The current char. */ - int simpleWord = 0; /* Set 1 if a simple braced string word. */ - int level = 1; /* {} nesting level. Initially 1 since { - * was parsed before we were called. */ - int hasBackslashNewline = 0; /* Nonzero if '\' found. */ - char *last; /* Points just before terminating '}'. */ - int numChars; /* Number of chars in braced string. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null - * char during braced string processing. */ - int objIndex; /* The object array index for a pushed - * object holding a braced string. */ - int numRead; - int result = TCL_OK; - /* - * Check for any backslash-newlines, since we must treat - * backslash-newlines specially (they must be replaced by spaces). + * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined + * code bytes are stored between envPtr->codeStart and + * (envPtr->codeNext - 1) [inclusive]. */ - - while (1) { - c = *src; - if (src == lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-brace", -1); - result = TCL_ERROR; - goto done; - } - if (CHAR_TYPE(src, lastChar) != TCL_NORMAL) { - if (c == '{') { - level++; - } else if (c == '}') { - --level; - if (level == 0) { - src++; - last = (src - 2); /* point just before terminating } */ - break; - } - } else if (c == '\\') { - if (*(src+1) == '\n') { - hasBackslashNewline = 1; - } - (void) Tcl_Backslash(src, &numRead); - src += numRead - 1; - } - } - src++; - } - - if (!hasBackslashNewline) { - /* - * The braced word is "simple": just a sequence of characters - * without backslash-newlines. Just return if we are not to compile - * simple words. - */ - - simpleWord = 1; - if (!envPtr->pushSimpleWords) { - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string - 1); - envPtr->termOffset = (src - string); - return TCL_OK; - } - } + + size_t currBytes = (envPtr->codeNext - envPtr->codeStart); + size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); + unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); /* - * Create and push a string object for the braced string. This starts at - * "string" and ends just after "last" (which points to the final - * character before the terminating '}'). If backslash-newlines were - * found, we copy characters one at a time into a heap-allocated buffer - * and do backslash-newline substitutions. + * Copy from old code array to new, free old code array if needed, and + * mark new code array as malloced. */ - - numChars = (last - string + 1); - savedChar = string[numChars]; - string[numChars] = '\0'; - if ((numChars > 0) && (hasBackslashNewline)) { - char *buffer = ckalloc((unsigned) numChars + 1); - register char *dst = buffer; - register char *p = string; - while (p <= last) { - c = *dst++ = *p++; - if (c == '\\') { - if (*p == '\n') { - dst[-1] = Tcl_Backslash(p-1, &numRead); - p += numRead - 1; - } else { - (void) Tcl_Backslash(p-1, &numRead); - while (numRead > 1) { - *dst++ = *p++; - numRead--; - } - } - } - } - *dst = '\0'; - objIndex = TclObjIndexForString(buffer, (dst - buffer), - /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); - } else { - objIndex = TclObjIndexForString(string, numChars, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); - } - string[numChars] = savedChar; - TclEmitPush(objIndex, envPtr); - - done: - if (simpleWord) { - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string - 1); - } else { - envPtr->wordIsSimple = 0; - envPtr->numSimpleWordChars = 0; + + memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes); + if (envPtr->mallocedCodeArray) { + ckfree((char *) envPtr->codeStart); } - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = 1; - return result; + envPtr->codeStart = newPtr; + envPtr->codeNext = (newPtr + currBytes); + envPtr->codeEnd = (newPtr + newBytes); + envPtr->mallocedCodeArray = 1; } /* *---------------------------------------------------------------------- * - * TclCompileDollarVar -- + * EnterCmdStartData -- * - * Given a string starting with a $ sign, parse a variable name - * and compile instructions to push its value. If the variable - * reference is just a '$' (i.e. the '$' isn't followed by anything - * that could possibly be a variable name), just push a string object - * containing '$'. + * Registers the starting source and bytecode location of a + * command. This information is used at runtime to map between + * instruction pc and source locations. * * Results: - * The return value is a standard Tcl result. If an error occurs - * then an error message is left in the interpreter's result. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one in the variable reference. - * - * envPtr->wordIsSimple is set 0 (false) because the word is not - * simple: it is not just a sequence of characters without backslashes. - * For the same reason, envPtr->numSimpleWordChars is set 0. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the string's commands. + * None. * * Side effects: - * Instructions are added to envPtr to look up the variable and - * push its value at runtime. + * Inserts source and code location information into the compilation + * environment envPtr for the command at index cmdIndex. The + * compilation environment's CmdLocation array is grown if necessary. * *---------------------------------------------------------------------- */ - -int -TclCompileDollarVar(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* First char (i.e. $) of var reference. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same - * values passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds the resulting instructions. */ -{ - register char *src = string; /* Points to current source char. */ - register char c; /* The current char. */ - char *name; /* Start of 1st part of variable name. */ - int nameChars; /* Count of chars in name. */ - int nameHasNsSeparators = 0; /* Set 1 if name contains "::"s. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null - * char during name processing. */ - int objIndex; /* The object array index for a pushed - * object holding a name part. */ - int isArrayRef = 0; /* 1 if reference to array element. */ - int localIndex = -1; /* Frame index of local if found. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to push the variable. */ - int savePushSimpleWords = envPtr->pushSimpleWords; - int result = TCL_OK; - - /* - * var_reference: '$' '{' braced_name '}' | - * '$' name ['(' index_string ')'] - * - * There are three cases: - * 1. The $ sign is followed by an open curly brace. Then the variable - * name is everything up to the next close curly brace, and the - * variable is a scalar variable. - * 2. The $ sign is not followed by an open curly brace. Then the - * variable name is everything up to the next character that isn't - * a letter, digit, underscore, or a "::" namespace separator. If the - * following character is an open parenthesis, then the information - * between parentheses is the array element name, which can include - * any of the substitutions permissible between quotes. - * 3. The $ sign is followed by something that isn't a letter, digit, - * underscore, or a "::" namespace separator: in this case, - * there is no variable name, and "$" is pushed. - */ - - src++; /* advance over the '$'. */ - /* - * Collect the first part of the variable's name into "name" and - * determine if it is an array reference and if it contains any - * namespace separator (::'s). - */ +static void +EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) + CompileEnv *envPtr; /* Points to the compilation environment + * structure in which to enter command + * location information. */ + int cmdIndex; /* Index of the command whose start data + * is being set. */ + int srcOffset; /* Offset of first char of the command. */ + int codeOffset; /* Offset of first byte of command code. */ +{ + CmdLocation *cmdLocPtr; - if (*src == '{') { - /* - * A scalar name in braces. - */ - - char *p; - - src++; - name = src; - c = *src; - while (c != '}') { - if (src == lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-brace for variable name", -1); - result = TCL_ERROR; - goto done; - } - src++; - c = *src; - } - nameChars = (src - name); - for (p = name; p < src; p++) { - if ((*p == ':') && (*(p+1) == ':')) { - nameHasNsSeparators = 1; - break; - } - } - src++; /* advance over the '}'. */ - } else { - /* - * Scalar name or array reference not in braces. - */ - - name = src; - c = *src; - while (isalnum(UCHAR(c)) || (c == '_') || (c == ':')) { - if (c == ':') { - if (*(src+1) == ':') { - nameHasNsSeparators = 1; - src += 2; - while (*src == ':') { - src++; - } - c = *src; - } else { - break; /* : by itself */ - } - } else { - src++; - c = *src; - } - } - if (src == name) { - /* - * A '$' by itself, not a name reference. Push a "$" string. - */ - - objIndex = TclObjIndexForString("$", 1, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - goto done; - } - nameChars = (src - name); - isArrayRef = (c == '('); + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { + panic("EnterCmdStartData: bad command index %d\n", cmdIndex); } - - /* - * Now emit instructions to load the variable. First either push the - * name of the scalar or array, or determine its index in the array of - * local variables in a procedure frame. Push the name if we are not - * compiling a procedure body or if the name has namespace - * qualifiers ("::"s). - */ - if (!isArrayRef) { /* scalar reference */ - if ((envPtr->procPtr == NULL) || nameHasNsSeparators) { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); - maxDepth = 1; - } else { - localIndex = LookupCompiledLocal(name, nameChars, - /*createIfNew*/ 0, /*flagsIfCreated*/ 0, - envPtr->procPtr); - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstUInt1(INST_LOAD_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstUInt4(INST_LOAD_SCALAR4, localIndex, envPtr); - } - maxDepth = 0; - } else { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); - maxDepth = 1; - } - } - } else { /* array reference */ - if ((envPtr->procPtr == NULL) || nameHasNsSeparators) { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } else { - localIndex = LookupCompiledLocal(name, nameChars, - /*createIfNew*/ 0, /*flagsIfCreated*/ 0, - envPtr->procPtr); - if (localIndex < 0) { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } - } - + if (cmdIndex >= envPtr->cmdMapEnd) { /* - * Parse and push the array element. Perform substitutions on it, - * just as is done for quoted strings. + * Expand the command location array by allocating more storage from + * the heap. The currently allocated CmdLocation entries are stored + * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive). */ - src++; - envPtr->pushSimpleWords = 1; - result = TclCompileQuotes(interp, src, lastChar, ')', flags, - envPtr); - src += envPtr->termOffset; - if (result != TCL_OK) { - char msg[200]; - sprintf(msg, "\n (parsing index for array \"%.*s\")", - (nameChars > 100? 100 : nameChars), name); - Tcl_AddObjErrorInfo(interp, msg, -1); - goto done; - } - maxDepth += envPtr->maxStackDepth; - + size_t currElems = envPtr->cmdMapEnd; + size_t newElems = 2*currElems; + size_t currBytes = currElems * sizeof(CmdLocation); + size_t newBytes = newElems * sizeof(CmdLocation); + CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); + /* - * Now emit the appropriate load instruction for the array element. + * Copy from old command location array to new, free old command + * location array if needed, and mark new array as malloced. */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes); + if (envPtr->mallocedCmdMap) { + ckfree((char *) envPtr->cmdMapPtr); + } + envPtr->cmdMapPtr = (CmdLocation *) newPtr; + envPtr->cmdMapEnd = newElems; + envPtr->mallocedCmdMap = 1; + } - if (localIndex < 0) { /* a global or an unknown local */ - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else { - if (localIndex <= 255) { - TclEmitInstUInt1(INST_LOAD_ARRAY1, localIndex, envPtr); - } else { - TclEmitInstUInt4(INST_LOAD_ARRAY4, localIndex, envPtr); - } + if (cmdIndex > 0) { + if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { + panic("EnterCmdStartData: cmd map not sorted by code offset"); } } - done: - envPtr->termOffset = (src - string); - envPtr->wordIsSimple = 0; - envPtr->numSimpleWordChars = 0; - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); + cmdLocPtr->codeOffset = codeOffset; + cmdLocPtr->srcOffset = srcOffset; + cmdLocPtr->numSrcBytes = -1; + cmdLocPtr->numCodeBytes = -1; } /* *---------------------------------------------------------------------- * - * IsLocalScalar -- + * EnterCmdExtentData -- * - * Checks to see if a variable name refers to a local scalar. + * Registers the source and bytecode length for a command. This + * information is used at runtime to map between instruction pc and + * source locations. * * Results: - * Returns 1 if the variable is a local scalar. + * None. * * Side effects: - * None. + * Inserts source and code length information into the compilation + * environment envPtr for the command at index cmdIndex. Starting + * source and bytecode information for the command must already + * have been registered. * *---------------------------------------------------------------------- */ -static int -IsLocalScalar(varName, length) - char *varName; /* The name to check. */ - int length; /* The number of characters in the string. */ +static void +EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) + CompileEnv *envPtr; /* Points to the compilation environment + * structure in which to enter command + * location information. */ + int cmdIndex; /* Index of the command whose source and + * code length data is being set. */ + int numSrcBytes; /* Number of command source chars. */ + int numCodeBytes; /* Offset of last byte of command code. */ { - char *p; - char *lastChar = varName + (length - 1); - - for (p = varName; p <= lastChar; p++) { - if ((CHAR_TYPE(p, lastChar) != TCL_NORMAL) && - (CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)) { - /* - * TCL_COMMAND_END is returned for the last character - * of the string. By this point we know it isn't - * an array or namespace reference. - */ + CmdLocation *cmdLocPtr; - return 0; - } - if (*p == '(') { - if (*lastChar == ')') { /* we have an array element */ - return 0; - } - } else if (*p == ':') { - if ((p != lastChar) && *(p+1) == ':') { /* qualified name */ - return 0; - } - } + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { + panic("EnterCmdExtentData: bad command index %d\n", cmdIndex); } - - return 1; + + if (cmdIndex > envPtr->cmdMapEnd) { + panic("EnterCmdExtentData: missing start data for command %d\n", + cmdIndex); + } + + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); + cmdLocPtr->numSrcBytes = numSrcBytes; + cmdLocPtr->numCodeBytes = numCodeBytes; } /* *---------------------------------------------------------------------- * - * TclCompileBreakCmd -- + * TclCreateExceptRange -- * - * Procedure called to compile the "break" command. + * Procedure that allocates and initializes a new ExceptionRange + * structure of the specified kind in a CompileEnv. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. + * Returns the index for the newly created ExceptionRange. * * Side effects: - * Instructions are added to envPtr to evaluate the "break" command - * at runtime. + * If there is not enough room in the CompileEnv's ExceptionRange + * array, the array in expanded: a new array of double the size is + * allocated, if envPtr->mallocedExceptArray is non-zero the old + * array is freed, and ExceptionRange entries are copied from the old + * array to the new one. * *---------------------------------------------------------------------- */ int -TclCompileBreakCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +TclCreateExceptRange(type, envPtr) + ExceptionRangeType type; /* The kind of ExceptionRange desired. */ + register CompileEnv *envPtr;/* Points to CompileEnv for which to + * create a new ExceptionRange structure. */ { - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int result = TCL_OK; + register ExceptionRange *rangePtr; + int index = envPtr->exceptArrayNext; - /* - * There should be no argument after the "break". - */ - - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"break\"", -1); - result = TCL_ERROR; - goto done; + if (index >= envPtr->exceptArrayEnd) { + /* + * Expand the ExceptionRange array. The currently allocated entries + * are stored between elements 0 and (envPtr->exceptArrayNext - 1) + * [inclusive]. + */ + + size_t currBytes = + envPtr->exceptArrayNext * sizeof(ExceptionRange); + int newElems = 2*envPtr->exceptArrayEnd; + size_t newBytes = newElems * sizeof(ExceptionRange); + ExceptionRange *newPtr = (ExceptionRange *) + ckalloc((unsigned) newBytes); + + /* + * Copy from old ExceptionRange array to new, free old + * ExceptionRange array if needed, and mark the new ExceptionRange + * array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr, + currBytes); + if (envPtr->mallocedExceptArray) { + ckfree((char *) envPtr->exceptArrayPtr); } + envPtr->exceptArrayPtr = (ExceptionRange *) newPtr; + envPtr->exceptArrayEnd = newElems; + envPtr->mallocedExceptArray = 1; } - - /* - * Emit a break instruction. - */ - - TclEmitOpcode(INST_BREAK, envPtr); - - done: - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = 0; - return result; + envPtr->exceptArrayNext++; + + rangePtr = &(envPtr->exceptArrayPtr[index]); + rangePtr->type = type; + rangePtr->nestingLevel = envPtr->exceptDepth; + rangePtr->codeOffset = -1; + rangePtr->numCodeBytes = -1; + rangePtr->breakOffset = -1; + rangePtr->continueOffset = -1; + rangePtr->catchOffset = -1; + return index; } /* *---------------------------------------------------------------------- * - * TclCompileCatchCmd -- + * TclCreateAuxData -- * - * Procedure called to compile the "catch" command. + * Procedure that allocates and initializes a new AuxData structure in + * a CompileEnv's array of compilation auxiliary data records. These + * AuxData records hold information created during compilation by + * CompileProcs and used by instructions during execution. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If compilation failed because the command is too - * complex for TclCompileCatchCmd, TCL_OUT_LINE_COMPILE is returned - * indicating that the catch command should be compiled "out of line" - * by emitting code to invoke its command procedure at runtime. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. + * Returns the index for the newly created AuxData structure. * * Side effects: - * Instructions are added to envPtr to evaluate the "catch" command - * at runtime. + * If there is not enough room in the CompileEnv's AuxData array, + * the AuxData array in expanded: a new array of double the size + * is allocated, if envPtr->mallocedAuxDataArray is non-zero + * the old array is freed, and AuxData entries are copied from + * the old array to the new one. * *---------------------------------------------------------------------- */ int -TclCompileCatchCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +TclCreateAuxData(clientData, typePtr, envPtr) + ClientData clientData; /* The compilation auxiliary data to store + * in the new aux data record. */ + AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */ + register CompileEnv *envPtr;/* Points to the CompileEnv for which a new + * aux data structure is to be allocated. */ { - Proc *procPtr = envPtr->procPtr; - /* Points to structure describing procedure - * containing the catch cmd, else NULL. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - ArgInfo argInfo; /* Structure holding information about the - * start and end of each argument word. */ - int range = -1; /* If we compile the catch command, the - * index for its catch range record in the - * ExceptionRange array. -1 if we are not - * compiling the command. */ - char *name; /* If a var name appears for a scalar local - * to a procedure, this points to the name's - * 1st char and nameChars is its length. */ - int nameChars; /* Length of the variable name, if any. */ - int localIndex = -1; /* Index of the variable in the current - * procedure's array of local variables. - * Otherwise -1 if not in a procedure or - * the variable wasn't found. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null character - * during processing of words. */ - JumpFixup jumpFixup; /* Used to emit the jump after the "no - * errors" epilogue code. */ - int numWords, objIndex, jumpDist, result; - char *bodyStart, *bodyEnd; - Tcl_Obj *objPtr; - int savePushSimpleWords = envPtr->pushSimpleWords; - - /* - * Scan the words of the command and record the start and finish of - * each argument word. - */ - - InitArgInfo(&argInfo); - result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); - numWords = argInfo.numArgs; /* i.e., the # after the command name */ - if (result != TCL_OK) { - goto done; - } - if ((numWords != 1) && (numWords != 2)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"catch command ?varName?\"", -1); - result = TCL_ERROR; - goto done; - } - - /* - * If a variable was specified and the catch command is at global level - * (not in a procedure), don't compile it inline: the payoff is - * too small. - */ - - if ((numWords == 2) && (procPtr == NULL)) { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - - /* - * Make sure the variable name, if any, has no substitutions and just - * refers to a local scaler. - */ - - if (numWords == 2) { - char *firstChar = argInfo.startArray[1]; - char *lastChar = argInfo.endArray[1]; - - if (*firstChar == '{') { - if (*lastChar != '}') { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-brace", -1); - result = TCL_ERROR; - goto done; - } - firstChar++; - lastChar--; - } - - nameChars = (lastChar - firstChar + 1); - if (!IsLocalScalar(firstChar, nameChars)) { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - - name = firstChar; - localIndex = LookupCompiledLocal(name, nameChars, - /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, - procPtr); - } - - /* - *==== At this point we believe we can compile the catch command ==== - */ - - /* - * Create and initialize a ExceptionRange record to hold information - * about this catch command. - */ - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr); - - /* - * Emit the instruction to mark the start of the catch command. - */ - - TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr); + int index; /* Index for the new AuxData structure. */ + register AuxData *auxDataPtr; + /* Points to the new AuxData structure */ - /* - * Inline compile the catch's body word: the command it controls. Also - * register the body's starting PC offset and byte length in the - * ExceptionRange record. - */ - - envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); - - bodyStart = argInfo.startArray[0]; - bodyEnd = argInfo.endArray[0]; - savedChar = *(bodyEnd+1); - *(bodyEnd+1) = '\0'; - result = CompileCmdWordInline(interp, bodyStart, (bodyEnd+1), - flags, envPtr); - *(bodyEnd+1) = savedChar; - - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"catch\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->excRangeArrayPtr[range].numCodeBytes = - TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; - - /* - * Now emit the "no errors" epilogue code for the catch. First, if a - * variable was specified, store the body's result into the - * variable; otherwise, just discard the body's result. Then push - * a "0" object as the catch command's "no error" TCL_OK result, - * and jump around the "error case" epilogue code. - */ - - if (localIndex != -1) { - if (localIndex <= 255) { - TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr); + index = envPtr->auxDataArrayNext; + if (index >= envPtr->auxDataArrayEnd) { + /* + * Expand the AuxData array. The currently allocated entries are + * stored between elements 0 and (envPtr->auxDataArrayNext - 1) + * [inclusive]. + */ + + size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); + int newElems = 2*envPtr->auxDataArrayEnd; + size_t newBytes = newElems * sizeof(AuxData); + AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); + + /* + * Copy from old AuxData array to new, free old AuxData array if + * needed, and mark the new AuxData array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, + currBytes); + if (envPtr->mallocedAuxDataArray) { + ckfree((char *) envPtr->auxDataArrayPtr); } + envPtr->auxDataArrayPtr = newPtr; + envPtr->auxDataArrayEnd = newElems; + envPtr->mallocedAuxDataArray = 1; } - TclEmitOpcode(INST_POP, envPtr); - - objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, /*inHeap*/ 0, - envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); - if (maxDepth == 0) { - maxDepth = 1; /* since we just pushed one object */ - } + envPtr->auxDataArrayNext++; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - /* - * Now emit the "error case" epilogue code. First, if a variable was - * specified, emit instructions to push the interpreter's object result - * and store it into the variable. Then emit an instruction to push the - * nonzero error result. Note that the initial PC offset here is the - * catch's error target. - */ - - envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset(); - if (localIndex != -1) { - TclEmitOpcode(INST_PUSH_RESULT, envPtr); - if (localIndex <= 255) { - TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); - } - TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); - - /* - * Now that we know the target of the jump after the "no errors" - * epilogue, update it with the correct distance. This is less - * than 127 bytes. - */ - - jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist); - } - - /* - * Emit the instruction to mark the end of the catch command. - */ - - TclEmitOpcode(INST_END_CATCH, envPtr); - - done: - if (numWords == 0) { - envPtr->termOffset = 0; - } else { - envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); - } - if (range != -1) { /* we compiled the catch command */ - envPtr->excRangeDepth--; - } - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->maxStackDepth = maxDepth; - FreeArgInfo(&argInfo); - return result; + auxDataPtr = &(envPtr->auxDataArrayPtr[index]); + auxDataPtr->clientData = clientData; + auxDataPtr->type = typePtr; + return index; } /* *---------------------------------------------------------------------- * - * TclCompileContinueCmd -- + * TclInitJumpFixupArray -- * - * Procedure called to compile the "continue" command. + * Initializes a JumpFixupArray structure to hold some number of + * jump fixup entries. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. + * None. * * Side effects: - * Instructions are added to envPtr to evaluate the "continue" command - * at runtime. + * The JumpFixupArray structure is initialized. * *---------------------------------------------------------------------- */ -int -TclCompileContinueCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +void +TclInitJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to initialize. */ { - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int result = TCL_OK; - - /* - * There should be no argument after the "continue". - */ - - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"continue\"", -1); - result = TCL_ERROR; - goto done; - } - } - - /* - * Emit a continue instruction. - */ - - TclEmitOpcode(INST_CONTINUE, envPtr); - - done: - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = 0; - return result; + fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; + fixupArrayPtr->next = 0; + fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1); + fixupArrayPtr->mallocedArray = 0; } /* *---------------------------------------------------------------------- * - * TclCompileExprCmd -- + * TclExpandJumpFixupArray -- * - * Procedure called to compile the "expr" command. + * Procedure that uses malloc to allocate more storage for a + * jump fixup array. * * Results: - * The return value is a standard Tcl result, which is TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "expr" command. + * None. * * Side effects: - * Instructions are added to envPtr to evaluate the "expr" command - * at runtime. + * The jump fixup array in *fixupArrayPtr is reallocated to a new array + * of double the size, and if fixupArrayPtr->mallocedArray is non-zero + * the old array is freed. Jump fixup structures are copied from the + * old array to the new one. * *---------------------------------------------------------------------- */ -int -TclCompileExprCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +void +TclExpandJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to enlarge. */ { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - ArgInfo argInfo; /* Structure holding information about the - * start and end of each argument word. */ - Tcl_DString buffer; /* Holds the concatenated expr command - * argument words. */ - int firstWord; /* 1 if processing the first word; 0 if - * processing subsequent words. */ - char *first, *last; /* Points to the first and last significant - * chars of the concatenated expression. */ - int inlineCode; /* 1 if inline "optimistic" code is - * emitted for the expression; else 0. */ - int range = -1; /* If we inline compile the concatenated - * expression, the index for its catch range - * record in the ExceptionRange array. - * Initialized to avoid compile warning. */ - JumpFixup jumpFixup; /* Used to emit the "success" jump after - * the inline concat. expression's code. */ - char savedChar; /* Holds the character termporarily replaced - * by a null character during compilation - * of the concatenated expression. */ - int numWords, objIndex, i, result; - char *wordStart, *wordEnd, *p; - char c; - int savePushSimpleWords = envPtr->pushSimpleWords; - int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; - int saveExprIsComparison = envPtr->exprIsComparison; - - /* - * Scan the words of the command and record the start and finish of - * each argument word. - */ - - InitArgInfo(&argInfo); - result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); - numWords = argInfo.numArgs; /* i.e., the # after the command name */ - if (result != TCL_OK) { - goto done; - } - if (numWords == 0) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"expr arg ?arg ...?\"", -1); - result = TCL_ERROR; - goto done; - } - - /* - * If there is a single argument word and it is enclosed in {}s, we may - * strip them off and safely compile the expr command into an inline - * sequence of instructions using TclCompileExpr. We know these - * instructions will have the right Tcl7.x expression semantics. - * - * Otherwise, if the word is not enclosed in {}s, or there are multiple - * words, we may need to call the expr command (Tcl_ExprObjCmd) at - * runtime. This recompiles the expression each time (typically) and so - * is slow. However, there are some circumstances where we can still - * compile inline instructions "optimistically" and check, during their - * execution, for double substitutions (these appear as nonnumeric - * operands). We check for any backslash or command substitutions. If - * none appear, and only variable substitutions are found, we generate - * inline instructions. If there is a compilation error, we must emit - * instructions that return the error at runtime, since this is when - * scripts in Tcl7.x would "see" the error. - * - * For now, if there are multiple words, or the single argument word is - * not in {}s, we concatenate the argument words and strip off any - * enclosing {}s or ""s. We call the expr command at runtime if - * either command or backslash substitutions appear (but not if - * only variable substitutions appear). - */ - - if (numWords == 1) { - wordStart = argInfo.startArray[0]; /* start of 1st arg word */ - wordEnd = argInfo.endArray[0]; /* last char of 1st arg word */ - if ((*wordStart == '{') && (*wordEnd == '}')) { - /* - * Simple case: a single argument word in {}'s. - */ - - *wordEnd = '\0'; - result = TclCompileExpr(interp, (wordStart + 1), wordEnd, - flags, envPtr); - *wordEnd = '}'; - - envPtr->termOffset = (wordEnd + 1) - string; - envPtr->pushSimpleWords = savePushSimpleWords; - FreeArgInfo(&argInfo); - return result; - } - } - /* - * There are multiple words or no braces around the single word. - * Concatenate the expression's argument words while stripping off - * any enclosing {}s or ""s. + * The currently allocated jump fixup entries are stored from fixup[0] + * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume + * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd. */ - - Tcl_DStringInit(&buffer); - firstWord = 1; - for (i = 0; i < numWords; i++) { - wordStart = argInfo.startArray[i]; - wordEnd = argInfo.endArray[i]; - if (((*wordStart == '{') && (*wordEnd == '}')) - || ((*wordStart == '"') && (*wordEnd == '"'))) { - wordStart++; - wordEnd--; - } - if (!firstWord) { - Tcl_DStringAppend(&buffer, " ", 1); - } - firstWord = 0; - if (wordEnd >= wordStart) { - Tcl_DStringAppend(&buffer, wordStart, (wordEnd-wordStart+1)); - } - } - /* - * Scan the concatenated expression's characters looking for any - * '['s or '\'s or '$'s. If any are found, just call the expr cmd - * at runtime. - */ - - inlineCode = 1; - first = Tcl_DStringValue(&buffer); - last = first + (Tcl_DStringLength(&buffer) - 1); - for (p = first; p <= last; p++) { - c = *p; - if ((c == '[') || (c == '\\') || (c == '$')) { - inlineCode = 0; - break; - } - } + size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); + int newElems = 2*(fixupArrayPtr->end + 1); + size_t newBytes = newElems * sizeof(JumpFixup); + JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); - if (inlineCode) { - /* - * Inline compile the concatenated expression inside a "catch" - * so that a runtime error will back off to a (slow) call on expr. - */ - - int startCodeOffset = (envPtr->codeNext - envPtr->codeStart); - int startRangeNext = envPtr->excRangeArrayNext; - - /* - * Create a ExceptionRange record to hold information about the - * "catch" range for the expression's inline code. Also emit the - * instruction to mark the start of the range. - */ - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr); - - /* - * Inline compile the concatenated expression. - */ - - envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); - savedChar = *(last + 1); - *(last + 1) = '\0'; - result = TclCompileExpr(interp, first, last + 1, flags, envPtr); - *(last + 1) = savedChar; - - maxDepth = envPtr->maxStackDepth; - envPtr->excRangeArrayPtr[range].numCodeBytes = - TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; - - if ((result != TCL_OK) || (envPtr->exprIsJustVarRef) - || (envPtr->exprIsComparison)) { - /* - * We must call the expr command at runtime. Either there was a - * compilation error or the inline code might fail to give the - * correct 2 level substitution semantics. - * - * The latter can happen if the expression consisted of just a - * single variable reference or if the top-level operator in the - * expr is a comparison (which might operate on strings). In the - * latter case, the expression's code might execute (apparently) - * successfully but produce the wrong result. We depend on its - * execution failing if a second level of substitutions is - * required. This causes the "catch" code we generate around the - * inline code to back off to a call on the expr command at - * runtime, and this always gives the right 2 level substitution - * semantics. - * - * We delete the inline code by backing up the code pc and catch - * index. Note that if there was a compilation error, we can't - * report the error yet since the expression might be valid - * after the second round of substitutions. - */ - - envPtr->codeNext = (envPtr->codeStart + startCodeOffset); - envPtr->excRangeArrayNext = startRangeNext; - inlineCode = 0; - } else { - TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset(); - TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */ - } - } - /* - * Emit code for the (slow) call on the expr command at runtime. - * Generate code to concatenate the (already substituted once) - * expression words with a space between each word. - */ - - for (i = 0; i < numWords; i++) { - wordStart = argInfo.startArray[i]; - wordEnd = argInfo.endArray[i]; - savedChar = *(wordEnd + 1); - *(wordEnd + 1) = '\0'; - envPtr->pushSimpleWords = 1; - result = CompileWord(interp, wordStart, wordEnd+1, flags, envPtr); - *(wordEnd + 1) = savedChar; - if (result != TCL_OK) { - break; - } - if (i != (numWords - 1)) { - objIndex = TclObjIndexForString(" ", 1, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - } else { - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - } - } - if (result == TCL_OK) { - int concatItems = 2*numWords - 1; - while (concatItems > 255) { - TclEmitInstUInt1(INST_CONCAT1, 255, envPtr); - concatItems -= 254; /* concat pushes 1 obj, the result */ - } - if (concatItems > 1) { - TclEmitInstUInt1(INST_CONCAT1, concatItems, envPtr); - } - TclEmitOpcode(INST_EXPR_STK, envPtr); - } - - /* - * If emitting inline code, update the target of the jump after - * that inline code. + * Copy from the old array to new, free the old array if needed, + * and mark the new array as malloced. */ - - if (inlineCode) { - int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - /* - * Update the inline expression code's catch ExceptionRange - * target since it, being after the jump, also moved down. - */ - - envPtr->excRangeArrayPtr[range].catchOffset += 3; - } - } - Tcl_DStringFree(&buffer); - - done: - if (numWords == 0) { - envPtr->termOffset = 0; - } else { - envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); - } - if (range != -1) { /* we inline compiled the expr */ - envPtr->excRangeDepth--; + + memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes); + if (fixupArrayPtr->mallocedArray) { + ckfree((char *) fixupArrayPtr->fixup); } - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->exprIsJustVarRef = saveExprIsJustVarRef; - envPtr->exprIsComparison = saveExprIsComparison; - envPtr->maxStackDepth = maxDepth; - FreeArgInfo(&argInfo); - return result; + fixupArrayPtr->fixup = (JumpFixup *) newPtr; + fixupArrayPtr->end = newElems; + fixupArrayPtr->mallocedArray = 1; } /* *---------------------------------------------------------------------- * - * TclCompileForCmd -- + * TclFreeJumpFixupArray -- * - * Procedure called to compile the "for" command. + * Free any storage allocated in a jump fixup array structure. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. + * None. * * Side effects: - * Instructions are added to envPtr to evaluate the "for" command - * at runtime. + * Allocated storage in the JumpFixupArray structure is freed. * *---------------------------------------------------------------------- */ -int -TclCompileForCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +void +TclFreeJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to free. */ { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - ArgInfo argInfo; /* Structure holding information about the - * start and end of each argument word. */ - int range1 = -1, range2; /* Indexes in the ExceptionRange array of - * the loop ranges for this loop: one for - * its body and one for its "next" cmd. */ - JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse - * jump after the "for" test when its target - * PC is determined. */ - int jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist, objIndex; - unsigned char *jumpPc; - int savePushSimpleWords = envPtr->pushSimpleWords; - int numWords, result; - - /* - * Scan the words of the command and record the start and finish of - * each argument word. - */ - - InitArgInfo(&argInfo); - result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); - numWords = argInfo.numArgs; /* i.e., the # after the command name */ - if (result != TCL_OK) { - goto done; - } - if (numWords != 4) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"for start test next command\"", -1); - result = TCL_ERROR; - goto done; - } - - /* - * If the test expression is not enclosed in braces, don't compile - * the for inline. As a result of Tcl's two level substitution - * semantics for expressions, the expression might have a constant - * value that results in the loop never executing, or executing forever. - * Consider "set x 0; for {} "$x > 5" {incr x} {}": the loop body - * should never be executed. - * NOTE: This is an overly aggressive test, since there are legitimate - * literals that could be compiled but aren't in braces. However, until - * the parser is integrated in 8.1, this is the simplest implementation. - */ - - if (*(argInfo.startArray[1]) != '{') { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - - /* - * Create a ExceptionRange record for the for loop's body. This is used - * to implement break and continue commands inside the body. - * Then create a second ExceptionRange record for the "next" command in - * order to implement break (but not continue) inside it. The second, - * "next" ExceptionRange will always have a -1 continueOffset. - */ - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - range1 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); - range2 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); - - /* - * Compile inline the next word: the initial command. - */ - - result = CompileCmdWordInline(interp, argInfo.startArray[0], - (argInfo.endArray[0] + 1), flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, "\n (\"for\" initial command)", -1); - } - goto done; - } - maxDepth = envPtr->maxStackDepth; - - /* - * Discard the start command's result. - */ - - TclEmitOpcode(INST_POP, envPtr); - - /* - * Compile the next word: the test expression. - */ - - testCodeOffset = TclCurrCodeOffset(); - envPtr->pushSimpleWords = 1; /* process words normally */ - result = CompileExprWord(interp, argInfo.startArray[1], - (argInfo.endArray[1] + 1), flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, "\n (\"for\" test expression)", -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - - /* - * Emit the jump that terminates the for command if the test was - * false. We emit a one byte (relative) jump here, and replace it later - * with a four byte jump if the jump target is > 127 bytes away. - */ - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); - - /* - * Compile the loop body word inline. Also register the loop body's - * starting PC offset and byte length in the its ExceptionRange record. - */ - - envPtr->excRangeArrayPtr[range1].codeOffset = TclCurrCodeOffset(); - result = CompileCmdWordInline(interp, argInfo.startArray[3], - (argInfo.endArray[3] + 1), flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->excRangeArrayPtr[range1].numCodeBytes = - (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range1].codeOffset); - - /* - * Discard the loop body's result. - */ - - TclEmitOpcode(INST_POP, envPtr); - - /* - * Finally, compile the "next" subcommand word inline. - */ - - envPtr->excRangeArrayPtr[range1].continueOffset = TclCurrCodeOffset(); - envPtr->excRangeArrayPtr[range2].codeOffset = TclCurrCodeOffset(); - result = CompileCmdWordInline(interp, argInfo.startArray[2], - (argInfo.endArray[2] + 1), flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, "\n (\"for\" loop-end command)", -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->excRangeArrayPtr[range2].numCodeBytes = - TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range2].codeOffset; - - /* - * Discard the "next" subcommand's result. - */ - - TclEmitOpcode(INST_POP, envPtr); - - /* - * Emit the unconditional jump back to the test at the top of the for - * loop. We generate a four byte jump if the distance to the test is - * greater than 120 bytes. This is conservative, and ensures that we - * won't have to replace this unconditional jump if we later need to - * replace the ifFalse jump with a four-byte jump. - */ - - jumpBackOffset = TclCurrCodeOffset(); - jumpBackDist = (jumpBackOffset - testCodeOffset); - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr); + if (fixupArrayPtr->mallocedArray) { + ckfree((char *) fixupArrayPtr->fixup); } +} + +/* + *---------------------------------------------------------------------- + * + * TclEmitForwardJump -- + * + * Procedure to emit a two-byte forward jump of kind "jumpType". Since + * the jump may later have to be grown to five bytes if the jump target + * is more than, say, 127 bytes away, this procedure also initializes a + * JumpFixup record with information about the jump. + * + * Results: + * None. + * + * Side effects: + * The JumpFixup record pointed to by "jumpFixupPtr" is initialized + * with information needed later if the jump is to be grown. Also, + * a two byte jump of the designated type is emitted at the current + * point in the bytecode stream. + * + *---------------------------------------------------------------------- + */ +void +TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr) + CompileEnv *envPtr; /* Points to the CompileEnv structure that + * holds the resulting instruction. */ + TclJumpType jumpType; /* Indicates the kind of jump: if true or + * false or unconditional. */ + JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to + * initialize with information about this + * forward jump. */ +{ /* - * Now that we know the target of the jumpFalse after the test, update - * it with the correct distance. If the distance is too great (more - * than 127 bytes), replace that jump with a four byte instruction and - * move the instructions after the jump down. + * Initialize the JumpFixup structure: + * - codeOffset is offset of first byte of jump below + * - cmdIndex is index of the command after the current one + * - exceptIndex is the index of the first ExceptionRange after + * the current one. */ - - jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { - /* - * Update the loop body's ExceptionRange record since it moved down: - * i.e., increment both its start and continue PC offsets. Also, - * update the "next" command's start PC offset in its ExceptionRange - * record since it also moved down. - */ - - envPtr->excRangeArrayPtr[range1].codeOffset += 3; - envPtr->excRangeArrayPtr[range1].continueOffset += 3; - envPtr->excRangeArrayPtr[range2].codeOffset += 3; - - /* - * Update the distance for the unconditional jump back to the test - * at the top of the loop since it moved down 3 bytes too. - */ - - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - if (jumpBackDist > 120) { - jumpBackDist += 3; - TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist, - jumpPc); - } else { - jumpBackDist += 3; - TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist, - jumpPc); - } - } - /* - * The current PC offset (after the loop's body and "next" subcommand) - * is the loop's break target. - */ - - envPtr->excRangeArrayPtr[range1].breakOffset = - envPtr->excRangeArrayPtr[range2].breakOffset = TclCurrCodeOffset(); + jumpFixupPtr->jumpType = jumpType; + jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart); + jumpFixupPtr->cmdIndex = envPtr->numCommands; + jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; - /* - * Push an empty string object as the for command's result. - */ - - objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, - envPtr); - TclEmitPush(objIndex, envPtr); - if (maxDepth == 0) { - maxDepth = 1; - } - - done: - if (numWords == 0) { - envPtr->termOffset = 0; - } else { - envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); - } - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->maxStackDepth = maxDepth; - if (range1 != -1) { - envPtr->excRangeDepth--; + switch (jumpType) { + case TCL_UNCONDITIONAL_JUMP: + TclEmitInstInt1(INST_JUMP1, 0, envPtr); + break; + case TCL_TRUE_JUMP: + TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr); + break; + default: + TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + break; } - FreeArgInfo(&argInfo); - return result; } /* *---------------------------------------------------------------------- * - * TclCompileForeachCmd -- + * TclFixupForwardJump -- * - * Procedure called to compile the "foreach" command. + * Procedure that updates a previously-emitted forward jump to jump + * a specified number of bytes, "jumpDist". If necessary, the jump is + * grown from two to five bytes; this is done if the jump distance is + * greater than "distThreshold" (normally 127 bytes). The jump is + * described by a JumpFixup record previously initialized by + * TclEmitForwardJump. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If complation failed because the command is too complex - * for TclCompileForeachCmd, TCL_OUT_LINE_COMPILE is returned - * indicating that the foreach command should be compiled "out of line" - * by emitting code to invoke its command procedure at runtime. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "while" command. + * 1 if the jump was grown and subsequent instructions had to be moved; + * otherwise 0. This result is returned to allow callers to update + * any additional code offsets they may hold. * * Side effects: - * Instructions are added to envPtr to evaluate the "foreach" command - * at runtime. + * The jump may be grown and subsequent instructions moved. If this + * happens, the code offsets for any commands and any ExceptionRange + * records between the jump and the current code address will be + * updated to reflect the moved code. Also, the bytecode instruction + * array in the CompileEnv structure may be grown and reallocated. * *---------------------------------------------------------------------- */ int -TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) + CompileEnv *envPtr; /* Points to the CompileEnv structure that + * holds the resulting instruction. */ + JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that + * describes the forward jump. */ + int jumpDist; /* Jump distance to set in jump + * instruction. */ + int distThreshold; /* Maximum distance before the two byte + * jump is grown to five bytes. */ { - Proc *procPtr = envPtr->procPtr; - /* Points to structure describing procedure - * containing foreach command, else NULL. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - ArgInfo argInfo; /* Structure holding information about the - * start and end of each argument word. */ - int numLists = 0; /* Count of variable (and value) lists. */ - int range = -1; /* Index in the ExceptionRange array of the - * ExceptionRange record for this loop. */ - ForeachInfo *infoPtr; /* Points to the structure describing this - * foreach command. Stored in a AuxData - * record in the ByteCode. */ - JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse - * jump after test when its target PC is - * determined. */ - char savedChar; /* Holds the char from string termporarily - * replaced by a null character during - * processing of argument words. */ - int firstListTmp = -1; /* If we decide to compile this foreach - * command, this is the index or "slot - * number" for the first temp var allocated - * in the proc frame that holds a pointer to - * a value list. Initialized to avoid a - * compiler warning. */ - int loopIterNumTmp; /* If we decide to compile this foreach - * command, the index for the temp var that - * holds the current iteration count. */ - char *varListStart, *varListEnd, *valueListStart, *bodyStart, *bodyEnd; - unsigned char *jumpPc; - int jumpDist, jumpBackDist, jumpBackOffset; - int numWords, numVars, infoIndex, tmpIndex, objIndex, i, j, result; - int savePushSimpleWords = envPtr->pushSimpleWords; - - /* - * We parse the variable list argument words and create two arrays: - * varcList[i] gives the number of variables in the i-th var list - * varvList[i] points to an array of the names in the i-th var list - * These are initially allocated on the stack, and are allocated on - * the heap if necessary. - */ - -#define STATIC_VAR_LIST_SIZE 4 - int varcListStaticSpace[STATIC_VAR_LIST_SIZE]; - char **varvListStaticSpace[STATIC_VAR_LIST_SIZE]; - - int *varcList = varcListStaticSpace; - char ***varvList = varvListStaticSpace; - - /* - * If the foreach command is at global level (not in a procedure), - * don't compile it inline: the payoff is too small. - */ - - if (procPtr == NULL) { - return TCL_OUT_LINE_COMPILE; + unsigned char *jumpPc, *p; + int firstCmd, lastCmd, firstRange, lastRange, k; + unsigned int numBytes; + + if (jumpDist <= distThreshold) { + jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); + switch (jumpFixupPtr->jumpType) { + case TCL_UNCONDITIONAL_JUMP: + TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); + break; + case TCL_TRUE_JUMP: + TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc); + break; + default: + TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc); + break; + } + return 0; } /* - * Scan the words of the command and record the start and finish of - * each argument word. + * We must grow the jump then move subsequent instructions down. + * Note that if we expand the space for generated instructions, + * code addresses might change; be careful about updating any of + * these addresses held in variables. */ - - InitArgInfo(&argInfo); - result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); - numWords = argInfo.numArgs; - if (result != TCL_OK) { - goto done; + + if ((envPtr->codeNext + 3) > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); } - if ((numWords < 3) || (numWords%2 != 1)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1); - result = TCL_ERROR; - goto done; + jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); + for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1; + numBytes > 0; numBytes--, p--) { + p[3] = p[0]; } - + envPtr->codeNext += 3; + jumpDist += 3; + switch (jumpFixupPtr->jumpType) { + case TCL_UNCONDITIONAL_JUMP: + TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc); + break; + case TCL_TRUE_JUMP: + TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc); + break; + default: + TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); + break; + } + /* - * Initialize the varcList and varvList arrays; allocate heap storage, - * if necessary, for them. Also make sure the variable names - * have no substitutions: that they're just "var" or "var(elem)" + * Adjust the code offsets for any commands and any ExceptionRange + * records between the jump and the current code address. */ - - numLists = (numWords - 1)/2; - if (numLists > STATIC_VAR_LIST_SIZE) { - varcList = (int *) ckalloc(numLists * sizeof(int)); - varvList = (char ***) ckalloc(numLists * sizeof(char **)); - } - for (i = 0; i < numLists; i++) { - varcList[i] = 0; - varvList[i] = (char **) NULL; + + firstCmd = jumpFixupPtr->cmdIndex; + lastCmd = (envPtr->numCommands - 1); + if (firstCmd < lastCmd) { + for (k = firstCmd; k <= lastCmd; k++) { + (envPtr->cmdMapPtr[k]).codeOffset += 3; + } } - for (i = 0; i < numLists; i++) { - /* - * Break each variable list into its component variables. If the - * lists is enclosed in {}s or ""s, strip them off first. - */ - - varListStart = argInfo.startArray[i*2]; - varListEnd = argInfo.endArray[i*2]; - if ((*varListStart == '{') || (*varListStart == '"')) { - if ((*varListEnd != '}') && (*varListEnd != '"')) { - Tcl_ResetResult(interp); - if (*varListStart == '"') { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-quote", -1); - } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-brace", -1); - } - result = TCL_ERROR; - goto done; + + firstRange = jumpFixupPtr->exceptIndex; + lastRange = (envPtr->exceptArrayNext - 1); + for (k = firstRange; k <= lastRange; k++) { + ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]); + rangePtr->codeOffset += 3; + + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + rangePtr->breakOffset += 3; + if (rangePtr->continueOffset != -1) { + rangePtr->continueOffset += 3; } - varListStart++; - varListEnd--; + break; + case CATCH_EXCEPTION_RANGE: + rangePtr->catchOffset += 3; + break; + default: + panic("TclFixupForwardJump: bad ExceptionRange type %d\n", + rangePtr->type); } - - /* - * NOTE: THIS NEEDS TO BE CONVERTED TO AN OBJECT LIST. - */ - - savedChar = *(varListEnd+1); - *(varListEnd+1) = '\0'; - result = Tcl_SplitList(interp, varListStart, - &varcList[i], &varvList[i]); - *(varListEnd+1) = savedChar; - if (result != TCL_OK) { - goto done; - } - - /* - * Check that each variable name has no substitutions and that - * it is a local scalar name. - */ - - numVars = varcList[i]; - for (j = 0; j < numVars; j++) { - char *varName = varvList[i][j]; - if (!IsLocalScalar(varName, (int) strlen(varName))) { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - } - } - - /* - *==== At this point we believe we can compile the foreach command ==== - */ - - /* - * Create and initialize a ExceptionRange record to hold information - * about this loop. This is used to implement break and continue. - */ - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); - - /* - * Reserve (numLists + 1) temporary variables: - * - numLists temps for each value list - * - a temp for the "next value" index into each value list - * At this time we don't try to reuse temporaries; if there are two - * nonoverlapping foreach loops, they don't share any temps. - */ - - for (i = 0; i < numLists; i++) { - tmpIndex = LookupCompiledLocal(NULL, /*nameChars*/ 0, - /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr); - if (i == 0) { - firstListTmp = tmpIndex; - } - } - loopIterNumTmp = LookupCompiledLocal(NULL, /*nameChars*/ 0, - /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr); - - /* - * Create and initialize the ForeachInfo and ForeachVarList data - * structures describing this command. Then create a AuxData record - * pointing to the ForeachInfo structure in the compilation environment. - */ - - infoPtr = (ForeachInfo *) ckalloc((unsigned) - (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); - infoPtr->numLists = numLists; - infoPtr->firstListTmp = firstListTmp; - infoPtr->loopIterNumTmp = loopIterNumTmp; - for (i = 0; i < numLists; i++) { - ForeachVarList *varListPtr; - numVars = varcList[i]; - varListPtr = (ForeachVarList *) ckalloc((unsigned) - sizeof(ForeachVarList) + numVars*sizeof(int)); - varListPtr->numVars = numVars; - for (j = 0; j < numVars; j++) { - char *varName = varvList[i][j]; - int nameChars = strlen(varName); - varListPtr->varIndexes[j] = LookupCompiledLocal(varName, - nameChars, /*createIfNew*/ 1, - /*flagsIfCreated*/ VAR_SCALAR, procPtr); - } - infoPtr->varLists[i] = varListPtr; } - infoIndex = TclCreateAuxData((ClientData) infoPtr, - &tclForeachInfoType, envPtr); + return 1; /* the jump was grown */ +} + +/* + *---------------------------------------------------------------------- + * + * TclGetInstructionTable -- + * + * Returns a pointer to the table describing Tcl bytecode instructions. + * This procedure is defined so that clients can access the pointer from + * outside the TCL DLLs. + * + * Results: + * Returns a pointer to the global instruction table, same as the + * expression (&instructionTable[0]). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - /* - * Emit code to store each value list into the associated temporary. - */ +InstructionDesc * +TclGetInstructionTable() +{ + return &instructionTable[0]; +} + +/* + *-------------------------------------------------------------- + * + * TclRegisterAuxDataType -- + * + * This procedure is called to register a new AuxData type + * in the table of all AuxData types supported by Tcl. + * + * Results: + * None. + * + * Side effects: + * The type is registered in the AuxData type table. If there was already + * a type with the same name as in typePtr, it is replaced with the + * new type. + * + *-------------------------------------------------------------- + */ - for (i = 0; i < numLists; i++) { - valueListStart = argInfo.startArray[2*i + 1]; - envPtr->pushSimpleWords = 1; - result = CompileWord(interp, valueListStart, lastChar, flags, - envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); +void +TclRegisterAuxDataType(typePtr) + AuxDataType *typePtr; /* Information about object type; + * storage must be statically + * allocated (must live forever). */ +{ + register Tcl_HashEntry *hPtr; + int new; - tmpIndex = (firstListTmp + i); - if (tmpIndex <= 255) { - TclEmitInstUInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstUInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); + Tcl_MutexLock(&tableMutex); + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); } /* - * Emit the instruction to initialize the foreach loop's index temp var. - */ - - TclEmitInstUInt4(INST_FOREACH_START4, infoIndex, envPtr); - - /* - * Emit the top of loop code that assigns each loop variable and checks - * whether to terminate the loop. - */ - - envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset(); - TclEmitInstUInt4(INST_FOREACH_STEP4, infoIndex, envPtr); - - /* - * Emit the ifFalse jump that terminates the foreach if all value lists - * are exhausted. We emit a one byte (relative) jump here, and replace - * it later with a four byte jump if the jump target is more than - * 127 bytes away. - */ - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); - - /* - * Compile the loop body word inline. Also register the loop body's - * starting PC offset and byte length in the ExceptionRange record. + * If there's already a type with the given name, remove it. */ - bodyStart = argInfo.startArray[numWords - 1]; - bodyEnd = argInfo.endArray[numWords - 1]; - savedChar = *(bodyEnd+1); - *(bodyEnd+1) = '\0'; - envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); - result = CompileCmdWordInline(interp, bodyStart, bodyEnd+1, flags, - envPtr); - *(bodyEnd+1) = savedChar; - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"foreach\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); + if (hPtr != (Tcl_HashEntry *) NULL) { + Tcl_DeleteHashEntry(hPtr); } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->excRangeArrayPtr[range].numCodeBytes = - TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; - - /* - * Discard the loop body's result. - */ - TclEmitOpcode(INST_POP, envPtr); - /* - * Emit the unconditional jump back to the test at the top of the - * loop. We generate a four byte jump if the distance to the to of - * the foreach is greater than 120 bytes. This is conservative and - * ensures that we won't have to replace this unconditional jump if - * we later need to replace the ifFalse jump with a four-byte jump. + * Now insert the new object type. */ - jumpBackOffset = TclCurrCodeOffset(); - jumpBackDist = - (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset); - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr); + hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new); + if (new) { + Tcl_SetHashValue(hPtr, typePtr); } + Tcl_MutexUnlock(&tableMutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAuxDataType -- + * + * This procedure looks up an Auxdata type by name. + * + * Results: + * If an AuxData type with name matching "typeName" is found, a pointer + * to its AuxDataType structure is returned; otherwise, NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - /* - * Now that we know the target of the jumpFalse after the foreach_step - * test, update it with the correct distance. If the distance is too - * great (more than 127 bytes), replace that jump with a four byte - * instruction and move the instructions after the jump down. - */ - - jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { - /* - * Update the loop body's starting PC offset since it moved down. - */ - - envPtr->excRangeArrayPtr[range].codeOffset += 3; - - /* - * Update the distance for the unconditional jump back to the test - * at the top of the loop since it moved down 3 bytes too. - */ +AuxDataType * +TclGetAuxDataType(typeName) + char *typeName; /* Name of AuxData type to look up. */ +{ + register Tcl_HashEntry *hPtr; + AuxDataType *typePtr = NULL; - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - if (jumpBackDist > 120) { - jumpBackDist += 3; - TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist, - jumpPc); - } else { - jumpBackDist += 3; - TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist, - jumpPc); - } + Tcl_MutexLock(&tableMutex); + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); } - /* - * The current PC offset (after the loop's body) is the loop's - * break target. - */ - - envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset(); - - /* - * Push an empty string object as the foreach command's result. - */ - - objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, - envPtr); - TclEmitPush(objIndex, envPtr); - if (maxDepth == 0) { - maxDepth = 1; + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); + if (hPtr != (Tcl_HashEntry *) NULL) { + typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); } + Tcl_MutexUnlock(&tableMutex); - done: - for (i = 0; i < numLists; i++) { - if (varvList[i] != (char **) NULL) { - ckfree((char *) varvList[i]); - } - } - if (varcList != varcListStaticSpace) { - ckfree((char *) varcList); - ckfree((char *) varvList); - } - envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->maxStackDepth = maxDepth; - if (range != -1) { - envPtr->excRangeDepth--; - } - FreeArgInfo(&argInfo); - return result; + return typePtr; } /* - *---------------------------------------------------------------------- + *-------------------------------------------------------------- * - * DupForeachInfo -- + * TclInitAuxDataTypeTable -- * - * This procedure duplicates a ForeachInfo structure created as - * auxiliary data during the compilation of a foreach command. + * This procedure is invoked to perform once-only initialization of + * the AuxData type table. It also registers the AuxData types defined in + * this file. * * Results: - * A pointer to a newly allocated copy of the existing ForeachInfo - * structure is returned. + * None. * * Side effects: - * Storage for the copied ForeachInfo record is allocated. If the - * original ForeachInfo structure pointed to any ForeachVarList - * records, these structures are also copied and pointers to them - * are stored in the new ForeachInfo record. + * Initializes the table of defined AuxData types "auxDataTypeTable" with + * builtin AuxData types defined in this file. * - *---------------------------------------------------------------------- + *-------------------------------------------------------------- */ -static ClientData -DupForeachInfo(clientData) - ClientData clientData; /* The foreach command's compilation - * auxiliary data to duplicate. */ +void +TclInitAuxDataTypeTable() { - register ForeachInfo *srcPtr = (ForeachInfo *) clientData; - ForeachInfo *dupPtr; - register ForeachVarList *srcListPtr, *dupListPtr; - int numLists = srcPtr->numLists; - int numVars, i, j; - - dupPtr = (ForeachInfo *) ckalloc((unsigned) - (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); - dupPtr->numLists = numLists; - dupPtr->firstListTmp = srcPtr->firstListTmp; - dupPtr->loopIterNumTmp = srcPtr->loopIterNumTmp; - - for (i = 0; i < numLists; i++) { - srcListPtr = srcPtr->varLists[i]; - numVars = srcListPtr->numVars; - dupListPtr = (ForeachVarList *) ckalloc((unsigned) - sizeof(ForeachVarList) + numVars*sizeof(int)); - dupListPtr->numVars = numVars; - for (j = 0; j < numVars; j++) { - dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; - } - dupPtr->varLists[i] = dupListPtr; - } - return (ClientData) dupPtr; + /* + * The table mutex must already be held before this routine is invoked. + */ + + auxDataTypeTableInitialized = 1; + Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); + + /* + * There is only one AuxData type at this time, so register it here. + */ + + TclRegisterAuxDataType(&tclForeachInfoType); } /* *---------------------------------------------------------------------- * - * FreeForeachInfo -- + * TclFinalizeAuxDataTypeTable -- * - * Procedure to free a ForeachInfo structure created as auxiliary data - * during the compilation of a foreach command. + * This procedure is called by Tcl_Finalize after all exit handlers + * have been run to free up storage associated with the table of AuxData + * types. This procedure is called by TclFinalizeExecution() which + * is called by Tcl_Finalize(). * * Results: * None. * * Side effects: - * Storage for the ForeachInfo structure pointed to by the ClientData - * argument is freed as is any ForeachVarList record pointed to by the - * ForeachInfo structure. + * Deletes all entries in the hash table of AuxData types. * *---------------------------------------------------------------------- */ -static void -FreeForeachInfo(clientData) - ClientData clientData; /* The foreach command's compilation - * auxiliary data to free. */ +void +TclFinalizeAuxDataTypeTable() { - register ForeachInfo *infoPtr = (ForeachInfo *) clientData; - register ForeachVarList *listPtr; - int numLists = infoPtr->numLists; - register int i; - - for (i = 0; i < numLists; i++) { - listPtr = infoPtr->varLists[i]; - ckfree((char *) listPtr); + Tcl_MutexLock(&tableMutex); + if (auxDataTypeTableInitialized) { + Tcl_DeleteHashTable(&auxDataTypeTable); + auxDataTypeTableInitialized = 0; } - ckfree((char *) infoPtr); + Tcl_MutexUnlock(&tableMutex); } /* *---------------------------------------------------------------------- * - * TclCompileIfCmd -- + * GetCmdLocEncodingSize -- * - * Procedure called to compile the "if" command. + * Computes the total number of bytes needed to encode the command + * location information for some compiled code. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. + * The byte count needed to encode the compiled location information. * * Side effects: - * Instructions are added to envPtr to evaluate the "if" command - * at runtime. + * None. * *---------------------------------------------------------------------- */ -int -TclCompileIfCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +static int +GetCmdLocEncodingSize(envPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ { - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - JumpFixupArray jumpFalseFixupArray; - /* Used to fix up the ifFalse jump after - * each "if"/"elseif" test when its target - * PC is determined. */ - JumpFixupArray jumpEndFixupArray; - /* Used to fix up the unconditional jump - * after each "then" command to the end of - * the "if" when that PC is determined. */ - char *testSrcStart; - int jumpDist, jumpFalseDist, jumpIndex, objIndex, j, result; - unsigned char *ifFalsePc; - unsigned char opCode; - int savePushSimpleWords = envPtr->pushSimpleWords; - - /* - * Loop compiling "expr then body" clauses after an "if" or "elseif". - */ - - TclInitJumpFixupArray(&jumpFalseFixupArray); - TclInitJumpFixupArray(&jumpEndFixupArray); - while (1) { - /* - * At this point in the loop, we have an expression to test, either - * the main expression or an expression following an "elseif". - * The arguments after the expression must be "then" (optional) and - * a script to execute if the expression is true. - */ - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no expression after \"if\" argument", -1); - result = TCL_ERROR; - goto done; - } + register CmdLocation *mapPtr = envPtr->cmdMapPtr; + int numCmds = envPtr->numCommands; + int codeDelta, codeLen, srcDelta, srcLen; + int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; + /* The offsets in their respective byte + * sequences where the next encoded offset + * or length should go. */ + int prevCodeOffset, prevSrcOffset, i; - /* - * Compile the "if"/"elseif" test expression. - */ - - testSrcStart = src; - envPtr->pushSimpleWords = 1; - result = CompileExprWord(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"if\" test expression)", -1); - } - goto done; + codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; + prevCodeOffset = prevSrcOffset = 0; + for (i = 0; i < numCmds; i++) { + codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); + if (codeDelta < 0) { + panic("GetCmdLocEncodingSize: bad code offset"); + } else if (codeDelta <= 127) { + codeDeltaNext++; + } else { + codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - src += envPtr->termOffset; + prevCodeOffset = mapPtr[i].codeOffset; - /* - * Emit the ifFalse jump around the "then" part if the test was - * false. We emit a one byte (relative) jump here, and replace it - * later with a four byte jump if the jump target is more than 127 - * bytes away. - */ - - if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { - TclExpandJumpFixupArray(&jumpFalseFixupArray); - } - jumpIndex = jumpFalseFixupArray.next; - jumpFalseFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &(jumpFalseFixupArray.fixup[jumpIndex])); - - /* - * Skip over the optional "then" before the then clause. - */ - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - char buf[100]; - sprintf(buf, "wrong # args: no script following \"%.20s\" argument", testSrcStart); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - result = TCL_ERROR; - goto done; - } - if ((*src == 't') && (strncmp(src, "then", 4) == 0)) { - type = CHAR_TYPE(src+4, lastChar); - if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { - src += 4; - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no script following \"then\" argument", -1); - result = TCL_ERROR; - goto done; - } - } - } - - /* - * Compile the "then" command word inline. - */ - - result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"if\" then script line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - src += envPtr->termOffset; - - /* - * Emit an unconditional jump to the end of the "if" command. We - * emit a one byte jump here, and replace it later with a four byte - * jump if the jump target is more than 127 bytes away. Note that - * both the jumpFalseFixupArray and the jumpEndFixupArray are - * indexed by the same index, "jumpIndex". - */ - - if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { - TclExpandJumpFixupArray(&jumpEndFixupArray); - } - jumpEndFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &(jumpEndFixupArray.fixup[jumpIndex])); - - /* - * Now that we know the target of the jumpFalse after the if test, - * update it with the correct distance. We generate a four byte - * jump if the distance is greater than 120 bytes. This is - * conservative, and ensures that we won't have to replace this - * jump if we later also need to replace the preceeding - * unconditional jump to the end of the "if" with a four-byte jump. - */ - - jumpDist = (TclCurrCodeOffset() - jumpFalseFixupArray.fixup[jumpIndex].codeOffset); - if (TclFixupForwardJump(envPtr, - &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) { - /* - * Adjust the code offset for the unconditional jump at the end - * of the last "then" clause. - */ - - jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; - } - - /* - * Check now for a "elseif" word. If we find one, keep looping. - */ - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if ((type != TCL_COMMAND_END) - && ((*src == 'e') && (strncmp(src, "elseif", 6) == 0))) { - type = CHAR_TYPE(src+6, lastChar); - if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { - src += 6; - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no expression after \"elseif\" argument", -1); - result = TCL_ERROR; - goto done; - } - continue; /* continue the "expr then body" loop */ - } - } - break; - } /* end of the "expr then body" loop */ - - /* - * No more "elseif expr then body" clauses. Check now for an "else" - * clause. If there is another word, we are at its start. - */ - - if (type != TCL_COMMAND_END) { - if ((*src == 'e') && (strncmp(src, "else", 4) == 0)) { - type = CHAR_TYPE(src+4, lastChar); - if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { - src += 4; - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no script following \"else\" argument", -1); - result = TCL_ERROR; - goto done; - } - } + codeLen = mapPtr[i].numCodeBytes; + if (codeLen < 0) { + panic("GetCmdLocEncodingSize: bad code length"); + } else if (codeLen <= 127) { + codeLengthNext++; + } else { + codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ } - /* - * Compile the "else" command word inline. - */ - - result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"if\" else script line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - src += envPtr->termOffset; - - /* - * Skip over white space until the end of the command. - */ - - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: extra words after \"else\" clause in \"if\" command", -1); - result = TCL_ERROR; - goto done; - } + srcDelta = (mapPtr[i].srcOffset - prevSrcOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { + srcDeltaNext++; + } else { + srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ } - } else { - /* - * The "if" command has no "else" clause: push an empty string - * object as its result. - */ - - objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - maxDepth = TclMax(1, maxDepth); - } - - /* - * Now that we know the target of the unconditional jumps to the end of - * the "if" command, update them with the correct distance. If the - * distance is too great (> 127 bytes), replace the jump with a four - * byte instruction and move instructions after the jump down. - */ - - for (j = jumpEndFixupArray.next; j > 0; j--) { - jumpIndex = (j - 1); /* i.e. process the closest jump first */ - jumpDist = (TclCurrCodeOffset() - jumpEndFixupArray.fixup[jumpIndex].codeOffset); - if (TclFixupForwardJump(envPtr, - &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) { - /* - * Adjust the jump distance for the "ifFalse" jump that - * immediately preceeds this jump. We've moved it's target - * (just after this unconditional jump) three bytes down. - */ + prevSrcOffset = mapPtr[i].srcOffset; - ifFalsePc = (envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset); - opCode = *ifFalsePc; - if (opCode == INST_JUMP_FALSE1) { - jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else if (opCode == INST_JUMP_FALSE4) { - jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else { - panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump"); - } + srcLen = mapPtr[i].numSrcBytes; + if (srcLen < 0) { + panic("GetCmdLocEncodingSize: bad source length"); + } else if (srcLen <= 127) { + srcLengthNext++; + } else { + srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ } } - - /* - * Free the jumpFixupArray array if malloc'ed storage was used. - */ - done: - TclFreeJumpFixupArray(&jumpFalseFixupArray); - TclFreeJumpFixupArray(&jumpEndFixupArray); - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; + return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext); } /* *---------------------------------------------------------------------- * - * TclCompileIncrCmd -- + * EncodeCmdLocMap -- * - * Procedure called to compile the "incr" command. + * Encode the command location information for some compiled code into + * a ByteCode structure. The encoded command location map is stored as + * three adjacent byte sequences. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "incr" command. + * Pointer to the first byte after the encoded command location + * information. * * Side effects: - * Instructions are added to envPtr to evaluate the "incr" command - * at runtime. + * The encoded information is stored into the block of memory headed + * by codePtr. Also records pointers to the start of the four byte + * sequences in fields in codePtr's ByteCode header structure. * *---------------------------------------------------------------------- */ -int -TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +static unsigned char * +EncodeCmdLocMap(envPtr, codePtr, startPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ + ByteCode *codePtr; /* ByteCode in which to encode envPtr's + * command location information. */ + unsigned char *startPtr; /* Points to the first byte in codePtr's + * memory block where the location + * information is to be stored. */ { - Proc *procPtr = envPtr->procPtr; - /* Points to structure describing procedure - * containing incr command, else NULL. */ - register char *src = string; - /* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int simpleVarName; /* 1 if name is just sequence of chars with - * an optional element name in parens. */ - char *name = NULL; /* If simpleVarName, points to first char of - * variable name and nameChars is length. - * Otherwise NULL. */ - char *elName = NULL; /* If simpleVarName, points to first char of - * element name and elNameChars is length. - * Otherwise NULL. */ - int nameChars = 0; /* Length of the var name. Initialized to - * avoid a compiler warning. */ - int elNameChars = 0; /* Length of array's element name, if any. - * Initialized to avoid a compiler - * warning. */ - int incrementGiven; /* 1 if an increment amount was given. */ - int isImmIncrValue = 0; /* 1 if increment amount is a literal - * integer in [-127..127]. */ - int immIncrValue = 0; /* if isImmIncrValue is 1, the immediate - * integer value. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - int localIndex = -1; /* Index of the variable in the current - * procedure's array of local variables. - * Otherwise -1 if not in a procedure or - * the variable wasn't found. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null char - * during name processing. */ - int objIndex; /* The object array index for a pushed - * object holding a name part. */ - int savePushSimpleWords = envPtr->pushSimpleWords; - char *p; - int i, result; - + register CmdLocation *mapPtr = envPtr->cmdMapPtr; + int numCmds = envPtr->numCommands; + register unsigned char *p = startPtr; + int codeDelta, codeLen, srcDelta, srcLen, prevOffset; + register int i; + /* - * Parse the next word: the variable name. If it is "simple" (requires - * no substitutions at runtime), divide it up into a simple "name" plus - * an optional "elName". Otherwise, if not simple, just push the name. + * Encode the code offset for each command as a sequence of deltas. */ - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - badArgs: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"incr varName ?increment?\"", -1); - result = TCL_ERROR; - goto done; - } - - envPtr->pushSimpleWords = 0; - result = CompileWord(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - simpleVarName = envPtr->wordIsSimple; - if (simpleVarName) { - name = src; - nameChars = envPtr->numSimpleWordChars; - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - name++; - } - elName = NULL; - elNameChars = 0; - p = name; - for (i = 0; i < nameChars; i++) { - if (*p == '(') { - char *openParen = p; - p = (src + nameChars-1); - if (*p == ')') { /* last char is ')' => array reference */ - nameChars = (openParen - name); - elName = openParen+1; - elNameChars = (p - elName); - } - break; - } + codePtr->codeDeltaStart = p; + prevOffset = 0; + for (i = 0; i < numCmds; i++) { + codeDelta = (mapPtr[i].codeOffset - prevOffset); + if (codeDelta < 0) { + panic("EncodeCmdLocMap: bad code offset"); + } else if (codeDelta <= 127) { + TclStoreInt1AtPtr(codeDelta, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); p++; + TclStoreInt4AtPtr(codeDelta, p); + p += 4; } - } else { - maxDepth = envPtr->maxStackDepth; - } - src += envPtr->termOffset; - - /* - * See if there is a next word. If so, we are incrementing the variable - * by that value (which must be an integer). - */ - - incrementGiven = 0; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - incrementGiven = (type != TCL_COMMAND_END); + prevOffset = mapPtr[i].codeOffset; } /* - * Non-simple names have already been pushed. If this is a simple - * variable, either push its name (if a global or an unknown local - * variable) or look up the variable's local frame index. If a local is - * not found, push its name and do the lookup at runtime. If this is an - * array reference, also push the array element. + * Encode the code length for each command. */ - if (simpleVarName) { - if (procPtr == NULL) { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; + codePtr->codeLengthStart = p; + for (i = 0; i < numCmds; i++) { + codeLen = mapPtr[i].numCodeBytes; + if (codeLen < 0) { + panic("EncodeCmdLocMap: bad code length"); + } else if (codeLen <= 127) { + TclStoreInt1AtPtr(codeLen, p); + p++; } else { - localIndex = LookupCompiledLocal(name, nameChars, - /*createIfNew*/ 0, /*flagsIfCreated*/ 0, - envPtr->procPtr); - if ((localIndex < 0) || (localIndex > 255)) { - if (localIndex > 255) { /* we'll push the name */ - localIndex = -1; - } - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } else { - maxDepth = 0; - } - } - - if (elName != NULL) { - /* - * Parse and push the array element's name. Perform - * substitutions on it, just as is done for quoted strings. - */ - - savedChar = elName[elNameChars]; - elName[elNameChars] = '\0'; - envPtr->pushSimpleWords = 1; - result = TclCompileQuotes(interp, elName, elName+elNameChars, - 0, flags, envPtr); - elName[elNameChars] = savedChar; - if (result != TCL_OK) { - char msg[200]; - sprintf(msg, "\n (parsing index for array \"%.*s\")", - TclMin(nameChars, 100), name); - Tcl_AddObjErrorInfo(interp, msg, -1); - goto done; - } - maxDepth += envPtr->maxStackDepth; + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(codeLen, p); + p += 4; } } /* - * If an increment was given, push the new value. - */ - - if (incrementGiven) { - type = CHAR_TYPE(src, lastChar); - envPtr->pushSimpleWords = 0; - result = CompileWord(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (increment expression)", -1); - } - goto done; - } - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; - } - if (envPtr->wordIsSimple) { - /* - * See if the word represents an integer whose formatted - * representation is the same as the word (e.g., this is - * true for 123 and -1 but not for 00005). If so, just - * push an integer object. - */ - - int isCompilableInt = 0; - int numChars = envPtr->numSimpleWordChars; - char savedChar = src[numChars]; - char buf[40]; - Tcl_Obj *objPtr; - long n; - - src[numChars] = '\0'; - if (TclLooksLikeInt(src)) { - int code = TclGetLong(interp, src, &n); - if (code == TCL_OK) { - if ((-127 <= n) && (n <= 127)) { - isCompilableInt = 1; - isImmIncrValue = 1; - immIncrValue = n; - } else { - TclFormatInt(buf, n); - if (strcmp(src, buf) == 0) { - isCompilableInt = 1; - isImmIncrValue = 0; - objIndex = TclObjIndexForString(src, numChars, - /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = n; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); - maxDepth += 1; - } - } - } else { - Tcl_ResetResult(interp); - } - } - if (!isCompilableInt) { - objIndex = TclObjIndexForString(src, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - maxDepth += 1; - } - src[numChars] = savedChar; - } else { - maxDepth += envPtr->maxStackDepth; - } - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src += (envPtr->termOffset - 1); /* already advanced 1 above */ - } else { - src += envPtr->termOffset; - } - } else { /* no incr amount given so use 1 */ - isImmIncrValue = 1; - immIncrValue = 1; - } - - /* - * Now emit instructions to increment the variable. + * Encode the source offset for each command as a sequence of deltas. */ - if (simpleVarName) { - if (elName == NULL) { /* scalar */ - if (localIndex >= 0) { - if (isImmIncrValue) { - TclEmitInstUInt1(INST_INCR_SCALAR1_IMM, localIndex, - envPtr); - TclEmitInt1(immIncrValue, envPtr); - } else { - TclEmitInstUInt1(INST_INCR_SCALAR1, localIndex, envPtr); - } - } else { - if (isImmIncrValue) { - TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immIncrValue, - envPtr); - } else { - TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); - } - } - } else { /* array */ - if (localIndex >= 0) { - if (isImmIncrValue) { - TclEmitInstUInt1(INST_INCR_ARRAY1_IMM, localIndex, - envPtr); - TclEmitInt1(immIncrValue, envPtr); - } else { - TclEmitInstUInt1(INST_INCR_ARRAY1, localIndex, envPtr); - } - } else { - if (isImmIncrValue) { - TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immIncrValue, - envPtr); - } else { - TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); - } - } - } - } else { /* non-simple variable name */ - if (isImmIncrValue) { - TclEmitInstInt1(INST_INCR_STK_IMM, immIncrValue, envPtr); + codePtr->srcDeltaStart = p; + prevOffset = 0; + for (i = 0; i < numCmds; i++) { + srcDelta = (mapPtr[i].srcOffset - prevOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { + TclStoreInt1AtPtr(srcDelta, p); + p++; } else { - TclEmitOpcode(INST_INCR_STK, envPtr); + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(srcDelta, p); + p += 4; } + prevOffset = mapPtr[i].srcOffset; } - + /* - * Skip over white space until the end of the command. + * Encode the source length for each command. */ - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - goto badArgs; + codePtr->srcLengthStart = p; + for (i = 0; i < numCmds; i++) { + srcLen = mapPtr[i].numSrcBytes; + if (srcLen < 0) { + panic("EncodeCmdLocMap: bad source length"); + } else if (srcLen <= 127) { + TclStoreInt1AtPtr(srcLen, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(srcLen, p); + p += 4; } } - - done: - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; + + return p; } +#ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * - * TclCompileSetCmd -- + * TclPrintByteCodeObj -- * - * Procedure called to compile the "set" command. + * This procedure prints ("disassembles") the instructions of a + * bytecode object to stdout. * * Results: - * The return value is a standard Tcl result, which is normally TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. If - * complation fails because the set command requires a second level of - * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the - * set command should be compiled "out of line" by emitting code to - * invoke its command procedure (Tcl_SetCmd) at runtime. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the incr command. + * None. * * Side effects: - * Instructions are added to envPtr to evaluate the "set" command - * at runtime. + * None. * *---------------------------------------------------------------------- */ -int -TclCompileSetCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +void +TclPrintByteCodeObj(interp, objPtr) + Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */ + Tcl_Obj *objPtr; /* The bytecode object to disassemble. */ { - Proc *procPtr = envPtr->procPtr; - /* Points to structure describing procedure - * containing the set command, else NULL. */ - ArgInfo argInfo; /* Structure holding information about the - * start and end of each argument word. */ - int simpleVarName; /* 1 if name is just sequence of chars with - * an optional element name in parens. */ - char *elName = NULL; /* If simpleVarName, points to first char of - * element name and elNameChars is length. - * Otherwise NULL. */ - int isAssignment; /* 1 if assigning value to var, else 0. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - int localIndex = -1; /* Index of the variable in the current - * procedure's array of local variables. - * Otherwise -1 if not in a procedure, the - * name contains "::"s, or the variable - * wasn't found. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null char - * during name processing. */ - int objIndex = -1; /* The object array index for a pushed - * object holding a name part. Initialized - * to avoid a compiler warning. */ - char *wordStart, *p; - int numWords, isCompilableInt, i, result; - Tcl_Obj *objPtr; - int savePushSimpleWords = envPtr->pushSimpleWords; - - /* - * Scan the words of the command and record the start and finish of - * each argument word. - */ + ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + unsigned char *codeStart, *codeLimit, *pc; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; + Interp *iPtr = (Interp *) *codePtr->interpHandle; - InitArgInfo(&argInfo); - result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); - numWords = argInfo.numArgs; /* i.e., the # after the command name */ - if (result != TCL_OK) { - goto done; - } - if ((numWords < 1) || (numWords > 2)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"set varName ?newValue?\"", -1); - result = TCL_ERROR; - goto done; + if (codePtr->refCount <= 0) { + return; /* already freed */ } - isAssignment = (numWords == 2); + + codeStart = codePtr->codeStart; + codeLimit = (codeStart + codePtr->numCodeBytes); + numCmds = codePtr->numCommands; /* - * Parse the next word: the variable name. If the name is enclosed in - * quotes or braces, we return TCL_OUT_LINE_COMPILE and call the set - * command procedure at runtime since this makes sure that a second - * round of substitutions is done properly. + * Print header lines describing the ByteCode. */ - wordStart = argInfo.startArray[0]; /* start of 1st arg word: varname */ - if ((*wordStart == '{') || (*wordStart == '"')) { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - + fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", + (unsigned int) codePtr, codePtr->refCount, + codePtr->compileEpoch, (unsigned int) iPtr, + iPtr->compileEpoch); + fprintf(stdout, " Source "); + TclPrintSource(stdout, codePtr->source, + TclMin(codePtr->numSrcBytes, 55)); + fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, + codePtr->numLitObjects, codePtr->numAuxDataItems, + codePtr->maxStackDepth, +#ifdef TCL_COMPILE_STATS + (codePtr->numSrcBytes? + ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); +#else + 0.0); +#endif +#ifdef TCL_COMPILE_STATS + fprintf(stdout, + " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", + codePtr->structureSize, + (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), + codePtr->numCodeBytes, + (codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (codePtr->numExceptRanges * sizeof(ExceptionRange)), + (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); +#endif /* TCL_COMPILE_STATS */ + /* - * Check whether the name is "simple": requires no substitutions at - * runtime. + * If the ByteCode is the compiled body of a Tcl procedure, print + * information about that procedure. Note that we don't know the + * procedure's name since ByteCode's can be shared among procedures. */ - envPtr->pushSimpleWords = 0; - result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1, - flags, envPtr); - if (result != TCL_OK) { - goto done; - } - simpleVarName = envPtr->wordIsSimple; - - if (!simpleVarName) { - /* - * The name isn't simple. CompileWord already pushed it. - */ - - maxDepth = envPtr->maxStackDepth; - } else { - char *name; /* If simpleVarName, points to first char of - * variable name and nameChars is length. - * Otherwise NULL. */ - int nameChars; /* Length of the var name. */ - int nameHasNsSeparators = 0; - /* Set 1 if name contains "::"s. */ - int elNameChars; /* Length of array's element name if any. */ - - /* - * A simple name. First divide it up into "name" plus "elName" - * for an array element name, if any. - */ - - name = wordStart; - nameChars = envPtr->numSimpleWordChars; - elName = NULL; - elNameChars = 0; - - p = name; - for (i = 0; i < nameChars; i++) { - if (*p == '(') { - char *openParen = p; - p = (name + nameChars-1); - if (*p == ')') { /* last char is ')' => array reference */ - nameChars = (openParen - name); - elName = openParen+1; - elNameChars = (p - elName); + if (codePtr->procPtr != NULL) { + Proc *procPtr = codePtr->procPtr; + int numCompiledLocals = procPtr->numCompiledLocals; + fprintf(stdout, + " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", + (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, + numCompiledLocals); + if (numCompiledLocals > 0) { + CompiledLocal *localPtr = procPtr->firstLocalPtr; + for (i = 0; i < numCompiledLocals; i++) { + fprintf(stdout, " slot %d%s%s%s%s%s%s", i, + ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), + ((localPtr->flags & VAR_ARRAY)? ", array" : ""), + ((localPtr->flags & VAR_LINK)? ", link" : ""), + ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""), + ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""), + ((localPtr->flags & VAR_RESOLVED)? ", resolved" : "")); + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "\n"); + } else { + fprintf(stdout, ", \"%s\"\n", localPtr->name); } - break; + localPtr = localPtr->nextPtr; } - p++; } + } - /* - * Determine if name has any namespace separators (::'s). - */ + /* + * Print the ExceptionRange array. + */ - p = name; - for (i = 0; i < nameChars; i++) { - if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { - nameHasNsSeparators = 1; + if (codePtr->numExceptRanges > 0) { + fprintf(stdout, " Exception ranges %d, depth %d:\n", + codePtr->numExceptRanges, codePtr->maxExceptDepth); + for (i = 0; i < codePtr->numExceptRanges; i++) { + ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); + fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", + i, rangePtr->nestingLevel, + ((rangePtr->type == LOOP_EXCEPTION_RANGE) + ? "loop" : "catch"), + rangePtr->codeOffset, + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + fprintf(stdout, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); break; + case CATCH_EXCEPTION_RANGE: + fprintf(stdout, "catch %d\n", rangePtr->catchOffset); + break; + default: + panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n", + rangePtr->type); } - p++; - } - - /* - * Now either push the name or determine its index in the array of - * local variables in a procedure frame. Note that if we are - * compiling a procedure the variable must be local unless its - * name has namespace separators ("::"s). Note also that global - * variables are implemented by a local variable that "points" to - * the real global. There are two cases: - * 1) We are not compiling a procedure body. Push the global - * variable's name and do the lookup at runtime. - * 2) We are compiling a procedure and the name has "::"s. - * Push the namespace variable's name and do the lookup at - * runtime. - * 3) We are compiling a procedure and the name has no "::"s. - * If the variable has already been allocated an local index, - * just look it up. If the variable is unknown and we are - * doing an assignment, allocate a new index. Otherwise, - * push the name and try to do the lookup at runtime. - */ - - if ((procPtr == NULL) || nameHasNsSeparators) { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } else { - localIndex = LookupCompiledLocal(name, nameChars, - /*createIfNew*/ isAssignment, - /*flagsIfCreated*/ - ((elName == NULL)? VAR_SCALAR : VAR_ARRAY), - envPtr->procPtr); - if (localIndex >= 0) { - maxDepth = 0; - } else { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } - } - - /* - * If we are dealing with a reference to an array element, push the - * array element. Perform substitutions on it, just as is done - * for quoted strings. - */ - - if (elName != NULL) { - savedChar = elName[elNameChars]; - elName[elNameChars] = '\0'; - envPtr->pushSimpleWords = 1; - result = TclCompileQuotes(interp, elName, elName+elNameChars, - 0, flags, envPtr); - elName[elNameChars] = savedChar; - if (result != TCL_OK) { - char msg[200]; - sprintf(msg, "\n (parsing index for array \"%.*s\")", - TclMin(nameChars, 100), name); - Tcl_AddObjErrorInfo(interp, msg, -1); - goto done; - } - maxDepth += envPtr->maxStackDepth; } } - + /* - * If we are doing an assignment, push the new value. + * If there were no commands (e.g., an expression or an empty string + * was compiled), just print all instructions and return. */ - - if (isAssignment) { - wordStart = argInfo.startArray[1]; /* start of 2nd arg word */ - envPtr->pushSimpleWords = 0; /* we will handle simple words */ - result = CompileWord(interp, wordStart, argInfo.endArray[1] + 1, - flags, envPtr); - if (result != TCL_OK) { - goto done; - } - if (!envPtr->wordIsSimple) { - /* - * The value isn't simple. CompileWord already pushed it. - */ - - maxDepth += envPtr->maxStackDepth; - } else { - /* - * The value is simple. See if the word represents an integer - * whose formatted representation is the same as the word (e.g., - * this is true for 123 and -1 but not for 00005). If so, just - * push an integer object. - */ - - char buf[40]; - long n; - p = wordStart; - if ((*wordStart == '"') || (*wordStart == '{')) { - p++; - } - savedChar = p[envPtr->numSimpleWordChars]; - p[envPtr->numSimpleWordChars] = '\0'; - isCompilableInt = 0; - if (TclLooksLikeInt(p)) { - int code = TclGetLong(interp, p, &n); - if (code == TCL_OK) { - TclFormatInt(buf, n); - if (strcmp(p, buf) == 0) { - isCompilableInt = 1; - objIndex = TclObjIndexForString(p, - envPtr->numSimpleWordChars, - /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = n; - objPtr->typePtr = &tclIntType; - } - } else { - Tcl_ResetResult(interp); - } - } - if (!isCompilableInt) { - objIndex = TclObjIndexForString(p, - envPtr->numSimpleWordChars, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); - } - p[envPtr->numSimpleWordChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth += 1; + if (numCmds == 0) { + pc = codeStart; + while (pc < codeLimit) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); } + return; } /* - * Now emit instructions to set/retrieve the variable. + * Print table showing the code offset, source offset, and source + * length for each command. These are encoded as a sequence of bytes. */ - if (simpleVarName) { - if (elName == NULL) { /* scalar */ - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstUInt1((isAssignment? - INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), - localIndex, envPtr); - } else { - TclEmitInstUInt4((isAssignment? - INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), - localIndex, envPtr); - } - } else { - TclEmitOpcode((isAssignment? - INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), - envPtr); - } - } else { /* array */ - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstUInt1((isAssignment? - INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), - localIndex, envPtr); - } else { - TclEmitInstUInt4((isAssignment? - INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), - localIndex, envPtr); - } - } else { - TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), - envPtr); - } + fprintf(stdout, " Commands %d:", numCmds); + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; } - } else { /* non-simple variable name */ - TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); - } - done: - if (numWords == 0) { - envPtr->termOffset = 0; - } else { - envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); - } - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->maxStackDepth = maxDepth; - FreeArgInfo(&argInfo); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileWhileCmd -- - * - * Procedure called to compile the "while" command. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If compilation failed because the command is too - * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned - * indicating that the while command should be compiled "out of line" - * by emitting code to invoke its command procedure at runtime. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "while" command. - * - * Side effects: - * Instructions are added to envPtr to evaluate the "while" command - * at runtime. - * - *---------------------------------------------------------------------- - */ + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; -int -TclCompileWhileCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - int range = -1; /* Index in the ExceptionRange array of the - * ExceptionRange record for this loop. */ - JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse - * jump after test when its target PC is - * determined. */ - unsigned char *jumpPc; - int jumpDist, jumpBackDist, jumpBackOffset, objIndex, result; - int savePushSimpleWords = envPtr->pushSimpleWords; - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - badArgs: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"while test command\"", -1); - result = TCL_ERROR; - goto done; + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d", + ((i % 2)? " " : "\n "), + (i+1), codeOffset, (codeOffset + codeLen - 1), + srcOffset, (srcOffset + srcLen - 1)); } - - /* - * If the test expression is not enclosed in braces, don't compile - * the while inline. As a result of Tcl's two level substitution - * semantics for expressions, the expression might have a constant - * value that results in the loop never executing, or executing forever. - * Consider "set x 0; whie "$x > 5" {incr x}": the loop body - * should never be executed. - * NOTE: This is an overly aggressive test, since there are legitimate - * literals that could be compiled but aren't in braces. However, until - * the parser is integrated in 8.1, this is the simplest implementation. - */ - - if (*src != '{') { - result = TCL_OUT_LINE_COMPILE; - goto done; + if (numCmds > 0) { + fprintf(stdout, "\n"); } - + /* - * Create and initialize a ExceptionRange record to hold information - * about this loop. This is used to implement break and continue. + * Print each instruction. If the instruction corresponds to the start + * of a command, print the command's source. Note that we don't need + * the code length here. */ - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - - range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); - envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset(); + codeDeltaNext = codePtr->codeDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + pc = codeStart; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; - /* - * Compile the next word: the test expression. - */ + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; - envPtr->pushSimpleWords = 1; - result = CompileExprWord(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"while\" test expression)", -1); - } - goto done; - } - maxDepth = envPtr->maxStackDepth; - src += envPtr->termOffset; - - /* - * Emit the ifFalse jump that terminates the while if the test was - * false. We emit a one byte (relative) jump here, and replace it - * later with a four byte jump if the jump target is more than - * 127 bytes away. - */ - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); - - /* - * Compile the loop body word inline. Also register the loop body's - * starting PC offset and byte length in the its ExceptionRange record. - */ - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - goto badArgs; - } - - envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); - result = CompileCmdWordInline(interp, src, lastChar, - flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"while\" body line %d)", interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - src += envPtr->termOffset; - envPtr->excRangeArrayPtr[range].numCodeBytes = - (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset); - - /* - * Discard the loop body's result. - */ - - TclEmitOpcode(INST_POP, envPtr); - - /* - * Emit the unconditional jump back to the test at the top of the - * loop. We generate a four byte jump if the distance to the while's - * test is greater than 120 bytes. This is conservative, and ensures - * that we won't have to replace this unconditional jump if we later - * need to replace the ifFalse jump with a four-byte jump. - */ - - jumpBackOffset = TclCurrCodeOffset(); - jumpBackDist = - (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset); - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr); - } - - /* - * Now that we know the target of the jumpFalse after the test, update - * it with the correct distance. If the distance is too great (more - * than 127 bytes), replace that jump with a four byte instruction and - * move the instructions after the jump down. - */ - - jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { - /* - * Update the loop body's starting PC offset since it moved down. - */ - - envPtr->excRangeArrayPtr[range].codeOffset += 3; - - /* - * Update the distance for the unconditional jump back to the test - * at the top of the loop since it moved down 3 bytes too. - */ - - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - if (jumpBackDist > 120) { - jumpBackDist += 3; - TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist, - jumpPc); + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; } else { - jumpBackDist += 3; - TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist, - jumpPc); - } - } - - /* - * The current PC offset (after the loop's body) is the loop's - * break target. - */ - - envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset(); - - /* - * Push an empty string object as the while command's result. - */ - - objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, - envPtr); - TclEmitPush(objIndex, envPtr); - if (maxDepth == 0) { - maxDepth = 1; - } - - /* - * Skip over white space until the end of the command. - */ - - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - goto badArgs; - } - } - - done: - envPtr->termOffset = (src - string); - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->maxStackDepth = maxDepth; - if (range != -1) { - envPtr->excRangeDepth--; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileExprWord -- - * - * Procedure that compiles a Tcl expression in a command word. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while compiling string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "expr" word. - * - * Side effects: - * Instructions are added to envPtr to evaluate the expression word - * at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileExprWord(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int nestedCmd = (flags & TCL_BRACKET_TERM); - /* 1 if script being compiled is a nested - * command and is terminated by a ']'; - * otherwise 0. */ - char *first, *last; /* Points to the first and last significant - * characters of the word. */ - char savedChar; /* Holds the character termporarily replaced - * by a null character during compilation - * of the expression. */ - int inlineCode; /* 1 if inline "optimistic" code is - * emitted for the expression; else 0. */ - int range = -1; /* If we inline compile an un-{}'d - * expression, the index for its catch range - * record in the ExceptionRange array. - * Initialized to enable proper cleanup. */ - JumpFixup jumpFixup; /* Used to emit the "success" jump after - * the inline expression code. */ - char *p; - char c; - int savePushSimpleWords = envPtr->pushSimpleWords; - int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; - int saveExprIsComparison = envPtr->exprIsComparison; - int numChars, result; - - /* - * Skip over leading white space. - */ - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - badArgs: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "malformed expression word", -1); - result = TCL_ERROR; - goto done; - } - - /* - * If the word is enclosed in {}s, we may strip them off and safely - * compile the expression into an inline sequence of instructions using - * TclCompileExpr. We know these instructions will have the right Tcl7.x - * expression semantics. - * - * Otherwise, if the word is not enclosed in {}s, we may need to call - * the expr command (Tcl_ExprObjCmd) at runtime. This recompiles the - * expression each time (typically) and so is slow. However, there are - * some circumstances where we can still compile inline instructions - * "optimistically" and check, during their execution, for double - * substitutions (these appear as nonnumeric operands). We check for any - * backslash or command substitutions. If none appear, and only variable - * substitutions are found, we generate inline instructions. - * - * For now, if the expression is not enclosed in {}s, we call the expr - * command at runtime if either command or backslash substitutions - * appear (but not if only variable substitutions appear). - */ - - if (*src == '{') { - /* - * Inline compile the expression inside {}s. - */ - - first = src+1; - src = TclWordEnd(src, lastChar, nestedCmd, NULL); - if (*src == 0) { - goto badArgs; - } - if (*src != '}') { - goto badArgs; + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; } - last = (src-1); - - numChars = (last - first + 1); - savedChar = first[numChars]; - first[numChars] = '\0'; - result = TclCompileExpr(interp, first, first+numChars, - flags, envPtr); - first[numChars] = savedChar; - src++; - maxDepth = envPtr->maxStackDepth; - } else { /* - * No braces. If the expression is enclosed in '"'s, call the expr - * cmd at runtime. Otherwise, scan the word's characters looking for - * any '['s or (for now) '\'s. If any are found, just call expr cmd - * at runtime. + * Print instructions before command i. */ - - first = src; - last = TclWordEnd(first, lastChar, nestedCmd, NULL); - if (*last == 0) { /* word doesn't end properly. */ - src = last; - goto badArgs; - } - - inlineCode = 1; - if ((*first == '"') && (*last == '"')) { - inlineCode = 0; - } else { - for (p = first; p <= last; p++) { - c = *p; - if ((c == '[') || (c == '\\')) { - inlineCode = 0; - break; - } - } - } - if (inlineCode) { - /* - * Inline compile the expression inside a "catch" so that a - * runtime error will back off to make a (slow) call on expr. - */ - - int startCodeOffset = (envPtr->codeNext - envPtr->codeStart); - int startRangeNext = envPtr->excRangeArrayNext; - - /* - * Create a ExceptionRange record to hold information about - * the "catch" range for the expression's inline code. Also - * emit the instruction to mark the start of the range. - */ - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr); - - /* - * Inline compile the expression. - */ - - envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); - numChars = (last - first + 1); - savedChar = first[numChars]; - first[numChars] = '\0'; - result = TclCompileExpr(interp, first, first + numChars, - flags, envPtr); - first[numChars] = savedChar; - - envPtr->excRangeArrayPtr[range].numCodeBytes = - TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; - - if ((result != TCL_OK) || (envPtr->exprIsJustVarRef) - || (envPtr->exprIsComparison)) { - /* - * We must call the expr command at runtime. Either there - * was a compilation error or the inline code might fail to - * give the correct 2 level substitution semantics. - * - * The latter can happen if the expression consisted of just - * a single variable reference or if the top-level operator - * in the expr is a comparison (which might operate on - * strings). In the latter case, the expression's code might - * execute (apparently) successfully but produce the wrong - * result. We depend on its execution failing if a second - * level of substitutions is required. This causes the - * "catch" code we generate around the inline code to back - * off to a call on the expr command at runtime, and this - * always gives the right 2 level substitution semantics. - * - * We delete the inline code by backing up the code pc and - * catch index. Note that if there was a compilation error, - * we can't report the error yet since the expression might - * be valid after the second round of substitutions. - */ - - envPtr->codeNext = (envPtr->codeStart + startCodeOffset); - envPtr->excRangeArrayNext = startRangeNext; - inlineCode = 0; - } else { - TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset(); - TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */ - } - } - - /* - * Arrange to call expr at runtime with the (already substituted - * once) expression word on the stack. - */ - - envPtr->pushSimpleWords = 1; - result = CompileWord(interp, first, lastChar, flags, envPtr); - src += envPtr->termOffset; - maxDepth = envPtr->maxStackDepth; - if (result == TCL_OK) { - TclEmitOpcode(INST_EXPR_STK, envPtr); + while ((pc-codeStart) < codeOffset) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); } - /* - * If emitting inline code for this non-{}'d expression, update - * the target of the jump after that inline code. - */ - - if (inlineCode) { - int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - /* - * Update the inline expression code's catch ExceptionRange - * target since it, being after the jump, also moved down. - */ - - envPtr->excRangeArrayPtr[range].catchOffset += 3; - } - } - } /* if expression isn't in {}s */ - - done: - if (range != -1) { - envPtr->excRangeDepth--; + fprintf(stdout, " Command %d: ", (i+1)); + TclPrintSource(stdout, (codePtr->source + srcOffset), + TclMin(srcLen, 55)); + fprintf(stdout, "\n"); } - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->exprIsJustVarRef = saveExprIsJustVarRef; - envPtr->exprIsComparison = saveExprIsComparison; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileCmdWordInline -- - * - * Procedure that compiles a Tcl command word inline. If the word is - * enclosed in quotes or braces, we call TclCompileString to compile it - * after stripping them off. Otherwise, we normally push the word's - * value and call eval at runtime, but if the word is just a sequence - * of alphanumeric characters, we emit an invoke instruction - * directly. This procedure assumes that string points to the start of - * the word to compile. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while compiling string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. - * - * Side effects: - * Instructions are added to envPtr to execute the command word - * at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileCmdWordInline(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - Interp *iPtr = (Interp *) interp; - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - char *termPtr; /* Points to char that terminated braced - * string. */ - char savedChar; /* Holds the character termporarily replaced - * by a null character during compilation - * of the command. */ - int savePushSimpleWords = envPtr->pushSimpleWords; - int objIndex; - int result = TCL_OK; - register char c; - - type = CHAR_TYPE(src, lastChar); - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; - envPtr->pushSimpleWords = 0; - if (type == TCL_QUOTE) { - result = TclCompileQuotes(interp, src, lastChar, - '"', flags, envPtr); - } else { - result = CompileBraces(interp, src, lastChar, flags, envPtr); - } - if (result != TCL_OK) { - goto done; - } - - /* - * Make sure the terminating character is the end of word. - */ - - termPtr = (src + envPtr->termOffset); - c = *termPtr; - if ((c == '\\') && (*(termPtr+1) == '\n')) { - /* - * Line is continued on next line; the backslash-newline turns - * into space, which terminates the word. - */ - } else { - type = CHAR_TYPE(termPtr, lastChar); - if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) { - Tcl_ResetResult(interp); - if (*(src-1) == '"') { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-quote", -1); - } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-brace", -1); - } - result = TCL_ERROR; - goto done; - } - } - - if (envPtr->wordIsSimple) { - /* - * A simple word enclosed in "" or {}s. Call TclCompileString to - * compile it inline. Add a null character after the end of the - * quoted or braced string: i.e., at the " or }. Turn the - * flag bit TCL_BRACKET_TERM off since the recursively - * compiled subcommand is now terminated by a null character. - */ - char *closeCharPos = (termPtr - 1); - - savedChar = *closeCharPos; - *closeCharPos = '\0'; - result = TclCompileString(interp, src, closeCharPos, - (flags & ~TCL_BRACKET_TERM), envPtr); - *closeCharPos = savedChar; - if (result != TCL_OK) { - goto done; - } - } else { - /* - * The braced string contained a backslash-newline. Call eval - * at runtime. - */ - TclEmitOpcode(INST_EVAL_STK, envPtr); - } - src = termPtr; - maxDepth = envPtr->maxStackDepth; - } else { + if (pc < codeLimit) { /* - * Not a braced or quoted string. We normally push the word's - * value and call eval at runtime. However, if the word is just - * a sequence of alphanumeric characters, we call its compile - * procedure, if any, or otherwise just emit an invoke instruction. - */ - - char *p = src; - c = *p; - while (isalnum(UCHAR(c)) || (c == '_')) { - p++; - c = *p; - } - type = CHAR_TYPE(p, lastChar); - if ((p > src) && (type == TCL_COMMAND_END)) { - /* - * Look for a compile procedure and call it. Otherwise emit an - * invoke instruction to call the command at runtime. - */ - - Tcl_Command cmd; - Command *cmdPtr = NULL; - int wasCompiled = 0; - - savedChar = *p; - *p = '\0'; - - cmd = Tcl_FindCommand(interp, src, (Tcl_Namespace *) NULL, - /*flags*/ 0); - if (cmd != (Tcl_Command) NULL) { - cmdPtr = (Command *) cmd; - } - if (cmdPtr != NULL && cmdPtr->compileProc != NULL) { - *p = savedChar; - src = p; - iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS - | ERROR_CODE_SET); - result = (*(cmdPtr->compileProc))(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - wasCompiled = 1; - src += envPtr->termOffset; - maxDepth = envPtr->maxStackDepth; - } - if (!wasCompiled) { - objIndex = TclObjIndexForString(src, p-src, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - *p = savedChar; - TclEmitPush(objIndex, envPtr); - TclEmitInstUInt1(INST_INVOKE_STK1, 1, envPtr); - src = p; - maxDepth = 1; - } - } else { - /* - * Push the word and call eval at runtime. - */ - - envPtr->pushSimpleWords = 1; - result = CompileWord(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - TclEmitOpcode(INST_EVAL_STK, envPtr); - src += envPtr->termOffset; - maxDepth = envPtr->maxStackDepth; - } - } - - done: - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * LookupCompiledLocal -- - * - * This procedure is called at compile time to look up and optionally - * allocate an entry ("slot") for a variable in a procedure's array of - * local variables. If the variable's name is NULL, a new temporary - * variable is always created. (Such temporary variables can only be - * referenced using their slot index.) - * - * Results: - * If createIfNew is 0 (false) and the name is non-NULL, then if the - * variable is found, the index of its entry in the procedure's array - * of local variables is returned; otherwise -1 is returned. - * If name is NULL, the index of a new temporary variable is returned. - * Finally, if createIfNew is 1 and name is non-NULL, the index of a - * new entry is returned. - * - * Side effects: - * Creates and registers a new local variable if createIfNew is 1 and - * the variable is unknown, or if the name is NULL. - * - *---------------------------------------------------------------------- - */ - -static int -LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr) - register char *name; /* Points to first character of the name of - * a scalar or array variable. If NULL, a - * temporary var should be created. */ - int nameChars; /* The length of the name excluding the - * terminating null character. */ - int createIfNew; /* 1 to allocate a local frame entry for the - * variable if it is new. */ - int flagsIfCreated; /* Flag bits for the compiled local if - * created. Only VAR_SCALAR, VAR_ARRAY, and - * VAR_LINK make sense. */ - register Proc *procPtr; /* Points to structure describing procedure - * containing the variable reference. */ -{ - register CompiledLocal *localPtr; - int localIndex = -1; - register int i; - int localCt; - - /* - * If not creating a temporary, does a local variable of the specified - * name already exist? - */ - - if (name != NULL) { - localCt = procPtr->numCompiledLocals; - localPtr = procPtr->firstLocalPtr; - for (i = 0; i < localCt; i++) { - if (!TclIsVarTemporary(localPtr)) { - char *localName = localPtr->name; - if ((name[0] == localName[0]) - && (nameChars == localPtr->nameLength) - && (strncmp(name, localName, (unsigned) nameChars) == 0)) { - return i; - } - } - localPtr = localPtr->nextPtr; - } - } - - /* - * Create a new variable if appropriate. - */ - - if (createIfNew || (name == NULL)) { - localIndex = procPtr->numCompiledLocals; - localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameChars+1)); - if (procPtr->firstLocalPtr == NULL) { - procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; - } else { - procPtr->lastLocalPtr->nextPtr = localPtr; - procPtr->lastLocalPtr = localPtr; - } - localPtr->nextPtr = NULL; - localPtr->nameLength = nameChars; - localPtr->frameIndex = localIndex; - localPtr->flags = flagsIfCreated; - if (name == NULL) { - localPtr->flags |= VAR_TEMPORARY; - } - localPtr->defValuePtr = NULL; - localPtr->resolveInfo = NULL; - - if (name != NULL) { - memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars); - } - localPtr->name[nameChars] = '\0'; - procPtr->numCompiledLocals++; - } - return localIndex; -} - -/* - *---------------------------------------------------------------------- - * - * TclInitCompiledLocals -- - * - * This routine is invoked in order to initialize the compiled - * locals table for a new call frame. - * - * Results: - * None. - * - * Side effects: - * May invoke various name resolvers in order to determine which - * variables are being referenced at runtime. - * - *---------------------------------------------------------------------- - */ - -void -TclInitCompiledLocals(interp, framePtr, nsPtr) - Tcl_Interp *interp; /* Current interpreter. */ - CallFrame *framePtr; /* Call frame to initialize. */ - Namespace *nsPtr; /* Pointer to current namespace. */ -{ - register CompiledLocal *localPtr; - Interp *iPtr = (Interp*) interp; - Tcl_ResolvedVarInfo *vinfo, *resVarInfo; - Var *varPtr = framePtr->compiledLocals; - Var *resolvedVarPtr; - ResolverScheme *resPtr; - int result; - - /* - * Initialize the array of local variables stored in the call frame. - * Some variables may have special resolution rules. In that case, - * we call their "resolver" procs to get our hands on the variable, - * and we make the compiled local a link to the real variable. - */ - - for (localPtr = framePtr->procPtr->firstLocalPtr; - localPtr != NULL; - localPtr = localPtr->nextPtr) { - - /* - * Check to see if this local is affected by namespace or - * interp resolvers. The resolver to use is cached for the - * next invocation of the procedure. - */ - - if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED)) - && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) { - resPtr = iPtr->resolverPtr; - - if (nsPtr->compiledVarResProc) { - result = (*nsPtr->compiledVarResProc)(nsPtr->interp, - localPtr->name, localPtr->nameLength, - (Tcl_Namespace *) nsPtr, &vinfo); - } else { - result = TCL_CONTINUE; - } - - while ((result == TCL_CONTINUE) && resPtr) { - if (resPtr->compiledVarResProc) { - result = (*resPtr->compiledVarResProc)(nsPtr->interp, - localPtr->name, localPtr->nameLength, - (Tcl_Namespace *) nsPtr, &vinfo); - } - resPtr = resPtr->nextPtr; - } - if (result == TCL_OK) { - localPtr->resolveInfo = vinfo; - localPtr->flags |= VAR_RESOLVED; - } - } - - /* - * Now invoke the resolvers to determine the exact variables that - * should be used. - */ - - resVarInfo = localPtr->resolveInfo; - resolvedVarPtr = NULL; - - if (resVarInfo && resVarInfo->fetchProc) { - resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, - resVarInfo); - } - - if (resolvedVarPtr) { - varPtr->name = localPtr->name; /* will be just '\0' if temp var */ - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = 0; - TclSetVarLink(varPtr); - varPtr->value.linkPtr = resolvedVarPtr; - resolvedVarPtr->refCount++; - } else { - varPtr->value.objPtr = NULL; - varPtr->name = localPtr->name; /* will be just '\0' if temp var */ - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = (localPtr->flags | VAR_UNDEFINED); - } - varPtr++; - } -} - -/* - *---------------------------------------------------------------------- - * - * AdvanceToNextWord -- - * - * This procedure is called to skip over any leading white space at the - * start of a word. Note that a backslash-newline is treated as a - * space. - * - * Results: - * None. - * - * Side effects: - * Updates envPtr->termOffset with the offset of the first - * character in "string" that was not white space or a - * backslash-newline. This might be the offset of the character that - * ends the command: a newline, null, semicolon, or close-bracket. - * - *---------------------------------------------------------------------- - */ - -static void -AdvanceToNextWord(string, envPtr) - char *string; /* The source string to compile. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - register char *src; /* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - - src = string; - type = CHAR_TYPE(src, src+1); - while (type & (TCL_SPACE | TCL_BACKSLASH)) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; /* exit loop; no longer white space */ - } - } else { - src++; - } - type = CHAR_TYPE(src, src+1); - } - envPtr->termOffset = (src - string); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Backslash -- - * - * Figure out how to handle a backslash sequence. - * - * Results: - * The return value is the character that should be substituted - * in place of the backslash sequence that starts at src. If - * readPtr isn't NULL then it is filled in with a count of the - * number of characters in the backslash sequence. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char -Tcl_Backslash(src, readPtr) - CONST char *src; /* Points to the backslash character of - * a backslash sequence. */ - int *readPtr; /* Fill in with number of characters read - * from src, unless NULL. */ -{ - CONST char *p = src + 1; - char result; - int count; - - count = 2; - - switch (*p) { - /* - * Note: in the conversions below, use absolute values (e.g., - * 0xa) rather than symbolic values (e.g. \n) that get converted - * by the compiler. It's possible that compilers on some - * platforms will do the symbolic conversions differently, which - * could result in non-portable Tcl scripts. - */ - - case 'a': - result = 0x7; - break; - case 'b': - result = 0x8; - break; - case 'f': - result = 0xc; - break; - case 'n': - result = 0xa; - break; - case 'r': - result = 0xd; - break; - case 't': - result = 0x9; - break; - case 'v': - result = 0xb; - break; - case 'x': - if (isxdigit(UCHAR(p[1]))) { - char *end; - - result = (char) strtoul(p+1, &end, 16); - count = end - src; - } else { - count = 2; - result = 'x'; - } - break; - case '\n': - do { - p++; - } while ((*p == ' ') || (*p == '\t')); - result = ' '; - count = p - src; - break; - case 0: - result = '\\'; - count = 1; - break; - default: - if (isdigit(UCHAR(*p))) { - result = (char)(*p - '0'); - p++; - if (!isdigit(UCHAR(*p))) { - break; - } - count = 3; - result = (char)((result << 3) + (*p - '0')); - p++; - if (!isdigit(UCHAR(*p))) { - break; - } - count = 4; - result = (char)((result << 3) + (*p - '0')); - break; - } - result = *p; - count = 2; - break; - } - - if (readPtr != NULL) { - *readPtr = count; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclObjIndexForString -- - * - * Procedure to find, or if necessary create, an object in a - * CompileEnv's object array that has a string representation - * matching the argument string. - * - * Results: - * The index in the CompileEnv's object array of an object with a - * string representation matching the argument "string". The object is - * created if necessary. If inHeap is 1, then string is heap allocated - * and ownership of the string is passed to TclObjIndexForString; - * otherwise, the string is owned by the caller and must not be - * modified or freed by TclObjIndexForString. Typically, a caller sets - * inHeap 1 if string is an already heap-allocated buffer holding the - * result of backslash substitutions. - * - * Side effects: - * A new Tcl object will be created if no existing object matches the - * input string. If allocStrRep is 1 then if a new object is created, - * its string representation is allocated in the heap, else it is left - * NULL. If inHeap is 1, this procedure is given ownership of the - * string: if an object is created and allocStrRep is 1 then its - * string representation is set directly from string, otherwise - * the string is freed. - * - *---------------------------------------------------------------------- - */ - -int -TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr) - register char *string; /* Points to string for which an object is - * found or created in CompileEnv's object - * array. */ - int length; /* Length of string. */ - int allocStrRep; /* If 1 then the object's string rep should - * be allocated in the heap. */ - int inHeap; /* If 1 then string is heap allocated and - * its ownership is passed to - * TclObjIndexForString. */ - CompileEnv *envPtr; /* Points to the CompileEnv in whose object - * array an object is found or created. */ -{ - register Tcl_Obj *objPtr; /* Points to the object created for - * the string, if one was created. */ - int objIndex; /* Index of matching object. */ - Tcl_HashEntry *hPtr; - int strLength, new; - - /* - * Look up the string in the code's object hashtable. If found, just - * return the associated object array index. Note that if the string - * has embedded nulls, we don't create a hash table entry. This - * should be fixed, but we need to update hash tables, first. - */ - - strLength = strlen(string); - if (length == -1) { - length = strLength; - } - if (strLength != length) { - hPtr = NULL; - } else { - hPtr = Tcl_CreateHashEntry(&envPtr->objTable, string, &new); - if (!new) { /* already in object table and array */ - objIndex = (int) Tcl_GetHashValue(hPtr); - if (inHeap) { - ckfree(string); - } - return objIndex; - } - } - - /* - * Create a new object holding the string, add it to the object array, - * and register its index in the object hashtable. - */ - - objPtr = Tcl_NewObj(); - if (allocStrRep) { - if (inHeap) { /* use input string for obj's string rep */ - objPtr->bytes = string; - } else { - if (length > 0) { - objPtr->bytes = ckalloc((unsigned) length + 1); - memcpy((VOID *) objPtr->bytes, (VOID *) string, - (size_t) length); - objPtr->bytes[length] = '\0'; - } - } - objPtr->length = length; - } else { /* leave the string rep NULL */ - if (inHeap) { - ckfree(string); - } - } - - if (envPtr->objArrayNext >= envPtr->objArrayEnd) { - ExpandObjectArray(envPtr); - } - objIndex = envPtr->objArrayNext; - envPtr->objArrayPtr[objIndex] = objPtr; - Tcl_IncrRefCount(objPtr); - envPtr->objArrayNext++; - - if (hPtr) { - Tcl_SetHashValue(hPtr, objIndex); - } - return objIndex; -} - -/* - *---------------------------------------------------------------------- - * - * TclExpandCodeArray -- - * - * Procedure that uses malloc to allocate more storage for a - * CompileEnv's code array. - * - * Results: - * None. - * - * Side effects: - * The byte code array in *envPtr is reallocated to a new array of - * double the size, and if envPtr->mallocedCodeArray is non-zero the - * old array is freed. Byte codes are copied from the old array to the - * new one. - * - *---------------------------------------------------------------------- - */ - -void -TclExpandCodeArray(envPtr) - CompileEnv *envPtr; /* Points to the CompileEnv whose code array - * must be enlarged. */ -{ - /* - * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined - * code bytes are stored between envPtr->codeStart and - * (envPtr->codeNext - 1) [inclusive]. - */ - - size_t currBytes = TclCurrCodeOffset(); - size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); - unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); - - /* - * Copy from old code array to new, free old code array if needed, and - * mark new code array as malloced. - */ - - memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes); - if (envPtr->mallocedCodeArray) { - ckfree((char *) envPtr->codeStart); - } - envPtr->codeStart = newPtr; - envPtr->codeNext = (newPtr + currBytes); - envPtr->codeEnd = (newPtr + newBytes); - envPtr->mallocedCodeArray = 1; -} - -/* - *---------------------------------------------------------------------- - * - * ExpandObjectArray -- - * - * Procedure that uses malloc to allocate more storage for a - * CompileEnv's object array. - * - * Results: - * None. - * - * Side effects: - * The object array in *envPtr is reallocated to a new array of - * double the size, and if envPtr->mallocedObjArray is non-zero the - * old array is freed. Tcl_Obj pointers are copied from the old array - * to the new one. - * - *---------------------------------------------------------------------- - */ - -static void -ExpandObjectArray(envPtr) - CompileEnv *envPtr; /* Points to the CompileEnv whose object - * array must be enlarged. */ -{ - /* - * envPtr->objArrayNext is equal to envPtr->objArrayEnd. The currently - * allocated Tcl_Obj pointers are stored between elements - * 0 and (envPtr->objArrayNext - 1) [inclusive] in the object array - * pointed to by objArrayPtr. - */ - - size_t currBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *); - int newElems = 2*envPtr->objArrayEnd; - size_t newBytes = newElems * sizeof(Tcl_Obj *); - Tcl_Obj **newPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); - - /* - * Copy from old object array to new, free old object array if needed, - * and mark new object array as malloced. - */ - - memcpy((VOID *) newPtr, (VOID *) envPtr->objArrayPtr, currBytes); - if (envPtr->mallocedObjArray) { - ckfree((char *) envPtr->objArrayPtr); - } - envPtr->objArrayPtr = (Tcl_Obj **) newPtr; - envPtr->objArrayEnd = newElems; - envPtr->mallocedObjArray = 1; -} - -/* - *---------------------------------------------------------------------- - * - * EnterCmdStartData -- - * - * Registers the starting source and bytecode location of a - * command. This information is used at runtime to map between - * instruction pc and source locations. - * - * Results: - * None. - * - * Side effects: - * Inserts source and code location information into the compilation - * environment envPtr for the command at index cmdIndex. The - * compilation environment's CmdLocation array is grown if necessary. - * - *---------------------------------------------------------------------- - */ - -static void -EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) - CompileEnv *envPtr; /* Points to the compilation environment - * structure in which to enter command - * location information. */ - int cmdIndex; /* Index of the command whose start data - * is being set. */ - int srcOffset; /* Offset of first char of the command. */ - int codeOffset; /* Offset of first byte of command code. */ -{ - CmdLocation *cmdLocPtr; - - if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { - panic("EnterCmdStartData: bad command index %d\n", cmdIndex); - } - - if (cmdIndex >= envPtr->cmdMapEnd) { - /* - * Expand the command location array by allocating more storage from - * the heap. The currently allocated CmdLocation entries are stored - * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive). - */ - - size_t currElems = envPtr->cmdMapEnd; - size_t newElems = 2*currElems; - size_t currBytes = currElems * sizeof(CmdLocation); - size_t newBytes = newElems * sizeof(CmdLocation); - CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); - - /* - * Copy from old command location array to new, free old command - * location array if needed, and mark new array as malloced. - */ - - memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes); - if (envPtr->mallocedCmdMap) { - ckfree((char *) envPtr->cmdMapPtr); - } - envPtr->cmdMapPtr = (CmdLocation *) newPtr; - envPtr->cmdMapEnd = newElems; - envPtr->mallocedCmdMap = 1; - } - - if (cmdIndex > 0) { - if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { - panic("EnterCmdStartData: cmd map table not sorted by code offset"); - } - } - - cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); - cmdLocPtr->codeOffset = codeOffset; - cmdLocPtr->srcOffset = srcOffset; - cmdLocPtr->numSrcChars = -1; - cmdLocPtr->numCodeBytes = -1; -} - -/* - *---------------------------------------------------------------------- - * - * EnterCmdExtentData -- - * - * Registers the source and bytecode length for a command. This - * information is used at runtime to map between instruction pc and - * source locations. - * - * Results: - * None. - * - * Side effects: - * Inserts source and code length information into the compilation - * environment envPtr for the command at index cmdIndex. Starting - * source and bytecode information for the command must already - * have been registered. - * - *---------------------------------------------------------------------- - */ - -static void -EnterCmdExtentData(envPtr, cmdIndex, numSrcChars, numCodeBytes) - CompileEnv *envPtr; /* Points to the compilation environment - * structure in which to enter command - * location information. */ - int cmdIndex; /* Index of the command whose source and - * code length data is being set. */ - int numSrcChars; /* Number of command source chars. */ - int numCodeBytes; /* Offset of last byte of command code. */ -{ - CmdLocation *cmdLocPtr; - - if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { - panic("EnterCmdStartData: bad command index %d\n", cmdIndex); - } - - if (cmdIndex > envPtr->cmdMapEnd) { - panic("EnterCmdStartData: no start data registered for command with index %d\n", cmdIndex); - } - - cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); - cmdLocPtr->numSrcChars = numSrcChars; - cmdLocPtr->numCodeBytes = numCodeBytes; -} - -/* - *---------------------------------------------------------------------- - * - * InitArgInfo -- - * - * Initializes a ArgInfo structure to hold information about - * some number of argument words in a command. - * - * Results: - * None. - * - * Side effects: - * The ArgInfo structure is initialized. - * - *---------------------------------------------------------------------- - */ - -static void -InitArgInfo(argInfoPtr) - register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure - * to initialize. */ -{ - argInfoPtr->numArgs = 0; - argInfoPtr->startArray = argInfoPtr->staticStartSpace; - argInfoPtr->endArray = argInfoPtr->staticEndSpace; - argInfoPtr->allocArgs = ARGINFO_INIT_ENTRIES; - argInfoPtr->mallocedArrays = 0; -} - -/* - *---------------------------------------------------------------------- - * - * CollectArgInfo -- - * - * Procedure to scan the argument words of a command and record the - * start and finish of each argument word in a ArgInfo structure. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while scanning string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * Side effects: - * If necessary, the argument start and end arrays in *argInfoPtr - * are grown and reallocated to a new arrays of double the size, and - * if argInfoPtr->mallocedArray is non-zero the old arrays are freed. - * - *---------------------------------------------------------------------- - */ - -static int -CollectArgInfo(interp, string, lastChar, flags, argInfoPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source command string to scan. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - register ArgInfo *argInfoPtr; - /* Points to the ArgInfo structure in which - * to record the arg word information. */ -{ - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int nestedCmd = (flags & TCL_BRACKET_TERM); - /* 1 if string being scanned is a nested - * command and is terminated by a ']'; - * otherwise 0. */ - int scanningArgs; /* 1 if still scanning argument words to - * determine their start and end. */ - char *wordStart, *wordEnd; /* Points to the first and last significant - * characters of each word. */ - CompileEnv tempCompEnv; /* Only used to hold the termOffset field - * updated by AdvanceToNextWord. */ - char *prev; - - argInfoPtr->numArgs = 0; - scanningArgs = 1; - while (scanningArgs) { - AdvanceToNextWord(src, &tempCompEnv); - src += tempCompEnv.termOffset; - type = CHAR_TYPE(src, lastChar); - - if ((type == TCL_COMMAND_END) && ((*src != ']') || nestedCmd)) { - break; /* done collecting argument words */ - } else if (*src == '"') { - wordStart = src; - src = TclWordEnd(src, lastChar, nestedCmd, NULL); - if (src == lastChar) { - badStringTermination: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "quoted string doesn't terminate properly", -1); - return TCL_ERROR; - } - prev = (src-1); - if (*src == '"') { - wordEnd = src; - src++; - } else if ((*src == ';') && (*prev == '"')) { - scanningArgs = 0; - wordEnd = prev; - } else { - goto badStringTermination; - } - } else if (*src == '{') { - wordStart = src; - src = TclWordEnd(src, lastChar, nestedCmd, NULL); - if (src == lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-brace", -1); - return TCL_ERROR; - } - prev = (src-1); - if (*src == '}') { - wordEnd = src; - src++; - } else if ((*src == ';') && (*prev == '}')) { - scanningArgs = 0; - wordEnd = prev; - } else { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "argument word in braces doesn't terminate properly", -1); - return TCL_ERROR; - } - } else { - wordStart = src; - src = TclWordEnd(src, lastChar, nestedCmd, NULL); - prev = (src-1); - if (src == lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-bracket or close-brace", -1); - return TCL_ERROR; - } else if (*src == ';') { - scanningArgs = 0; - wordEnd = prev; - } else { - wordEnd = src; - src++; - if ((src == lastChar) || (*src == '\n') - || ((*src == ']') && nestedCmd)) { - scanningArgs = 0; - } - } - } /* end of test on each kind of word */ - - if (argInfoPtr->numArgs == argInfoPtr->allocArgs) { - int newArgs = 2*argInfoPtr->numArgs; - size_t currBytes = argInfoPtr->numArgs * sizeof(char *); - size_t newBytes = newArgs * sizeof(char *); - char **newStartArrayPtr = - (char **) ckalloc((unsigned) newBytes); - char **newEndArrayPtr = - (char **) ckalloc((unsigned) newBytes); - - /* - * Copy from the old arrays to the new, free the old arrays if - * needed, and mark the new arrays as malloc'ed. - */ - - memcpy((VOID *) newStartArrayPtr, - (VOID *) argInfoPtr->startArray, currBytes); - memcpy((VOID *) newEndArrayPtr, - (VOID *) argInfoPtr->endArray, currBytes); - if (argInfoPtr->mallocedArrays) { - ckfree((char *) argInfoPtr->startArray); - ckfree((char *) argInfoPtr->endArray); - } - argInfoPtr->startArray = newStartArrayPtr; - argInfoPtr->endArray = newEndArrayPtr; - argInfoPtr->allocArgs = newArgs; - argInfoPtr->mallocedArrays = 1; - } - argInfoPtr->startArray[argInfoPtr->numArgs] = wordStart; - argInfoPtr->endArray[argInfoPtr->numArgs] = wordEnd; - argInfoPtr->numArgs++; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * FreeArgInfo -- - * - * Free any storage allocated in a ArgInfo structure. - * - * Results: - * None. - * - * Side effects: - * Allocated storage in the ArgInfo structure is freed. - * - *---------------------------------------------------------------------- - */ - -static void -FreeArgInfo(argInfoPtr) - register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure - * to free. */ -{ - if (argInfoPtr->mallocedArrays) { - ckfree((char *) argInfoPtr->startArray); - ckfree((char *) argInfoPtr->endArray); - } -} - -/* - *---------------------------------------------------------------------- - * - * CreateExceptionRange -- - * - * Procedure that allocates and initializes a new ExceptionRange - * structure of the specified kind in a CompileEnv's ExceptionRange - * array. - * - * Results: - * Returns the index for the newly created ExceptionRange. - * - * Side effects: - * If there is not enough room in the CompileEnv's ExceptionRange - * array, the array in expanded: a new array of double the size is - * allocated, if envPtr->mallocedExcRangeArray is non-zero the old - * array is freed, and ExceptionRange entries are copied from the old - * array to the new one. - * - *---------------------------------------------------------------------- - */ - -static int -CreateExceptionRange(type, envPtr) - ExceptionRangeType type; /* The kind of ExceptionRange desired. */ - register CompileEnv *envPtr;/* Points to the CompileEnv for which a new - * loop ExceptionRange structure is to be - * allocated. */ -{ - int index; /* Index for the newly-allocated - * ExceptionRange structure. */ - register ExceptionRange *rangePtr; - /* Points to the new ExceptionRange - * structure */ - - index = envPtr->excRangeArrayNext; - if (index >= envPtr->excRangeArrayEnd) { - /* - * Expand the ExceptionRange array. The currently allocated entries - * are stored between elements 0 and (envPtr->excRangeArrayNext - 1) - * [inclusive]. - */ - - size_t currBytes = - envPtr->excRangeArrayNext * sizeof(ExceptionRange); - int newElems = 2*envPtr->excRangeArrayEnd; - size_t newBytes = newElems * sizeof(ExceptionRange); - ExceptionRange *newPtr = (ExceptionRange *) - ckalloc((unsigned) newBytes); - - /* - * Copy from old ExceptionRange array to new, free old - * ExceptionRange array if needed, and mark the new ExceptionRange - * array as malloced. - */ - - memcpy((VOID *) newPtr, (VOID *) envPtr->excRangeArrayPtr, - currBytes); - if (envPtr->mallocedExcRangeArray) { - ckfree((char *) envPtr->excRangeArrayPtr); - } - envPtr->excRangeArrayPtr = (ExceptionRange *) newPtr; - envPtr->excRangeArrayEnd = newElems; - envPtr->mallocedExcRangeArray = 1; - } - envPtr->excRangeArrayNext++; - - rangePtr = &(envPtr->excRangeArrayPtr[index]); - rangePtr->type = type; - rangePtr->nestingLevel = envPtr->excRangeDepth; - rangePtr->codeOffset = -1; - rangePtr->numCodeBytes = -1; - rangePtr->breakOffset = -1; - rangePtr->continueOffset = -1; - rangePtr->catchOffset = -1; - return index; -} - -/* - *---------------------------------------------------------------------- - * - * TclCreateAuxData -- - * - * Procedure that allocates and initializes a new AuxData structure in - * a CompileEnv's array of compilation auxiliary data records. These - * AuxData records hold information created during compilation by - * CompileProcs and used by instructions during execution. - * - * Results: - * Returns the index for the newly created AuxData structure. - * - * Side effects: - * If there is not enough room in the CompileEnv's AuxData array, - * the AuxData array in expanded: a new array of double the size - * is allocated, if envPtr->mallocedAuxDataArray is non-zero - * the old array is freed, and AuxData entries are copied from - * the old array to the new one. - * - *---------------------------------------------------------------------- - */ - -int -TclCreateAuxData(clientData, typePtr, envPtr) - ClientData clientData; /* The compilation auxiliary data to store - * in the new aux data record. */ - AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */ - register CompileEnv *envPtr;/* Points to the CompileEnv for which a new - * aux data structure is to be allocated. */ -{ - int index; /* Index for the new AuxData structure. */ - register AuxData *auxDataPtr; - /* Points to the new AuxData structure */ - - index = envPtr->auxDataArrayNext; - if (index >= envPtr->auxDataArrayEnd) { - /* - * Expand the AuxData array. The currently allocated entries are - * stored between elements 0 and (envPtr->auxDataArrayNext - 1) - * [inclusive]. - */ - - size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); - int newElems = 2*envPtr->auxDataArrayEnd; - size_t newBytes = newElems * sizeof(AuxData); - AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); - - /* - * Copy from old AuxData array to new, free old AuxData array if - * needed, and mark the new AuxData array as malloced. - */ - - memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, - currBytes); - if (envPtr->mallocedAuxDataArray) { - ckfree((char *) envPtr->auxDataArrayPtr); - } - envPtr->auxDataArrayPtr = newPtr; - envPtr->auxDataArrayEnd = newElems; - envPtr->mallocedAuxDataArray = 1; - } - envPtr->auxDataArrayNext++; - - auxDataPtr = &(envPtr->auxDataArrayPtr[index]); - auxDataPtr->type = typePtr; - auxDataPtr->clientData = clientData; - return index; -} - -/* - *---------------------------------------------------------------------- - * - * TclInitJumpFixupArray -- - * - * Initializes a JumpFixupArray structure to hold some number of - * jump fixup entries. - * - * Results: - * None. - * - * Side effects: - * The JumpFixupArray structure is initialized. - * - *---------------------------------------------------------------------- - */ - -void -TclInitJumpFixupArray(fixupArrayPtr) - register JumpFixupArray *fixupArrayPtr; - /* Points to the JumpFixupArray structure - * to initialize. */ -{ - fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; - fixupArrayPtr->next = 0; - fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1); - fixupArrayPtr->mallocedArray = 0; -} - -/* - *---------------------------------------------------------------------- - * - * TclExpandJumpFixupArray -- - * - * Procedure that uses malloc to allocate more storage for a - * jump fixup array. - * - * Results: - * None. - * - * Side effects: - * The jump fixup array in *fixupArrayPtr is reallocated to a new array - * of double the size, and if fixupArrayPtr->mallocedArray is non-zero - * the old array is freed. Jump fixup structures are copied from the - * old array to the new one. - * - *---------------------------------------------------------------------- - */ - -void -TclExpandJumpFixupArray(fixupArrayPtr) - register JumpFixupArray *fixupArrayPtr; - /* Points to the JumpFixupArray structure - * to enlarge. */ -{ - /* - * The currently allocated jump fixup entries are stored from fixup[0] - * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume - * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd. - */ - - size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); - int newElems = 2*(fixupArrayPtr->end + 1); - size_t newBytes = newElems * sizeof(JumpFixup); - JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); - - /* - * Copy from the old array to new, free the old array if needed, - * and mark the new array as malloced. - */ - - memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes); - if (fixupArrayPtr->mallocedArray) { - ckfree((char *) fixupArrayPtr->fixup); - } - fixupArrayPtr->fixup = (JumpFixup *) newPtr; - fixupArrayPtr->end = newElems; - fixupArrayPtr->mallocedArray = 1; -} - -/* - *---------------------------------------------------------------------- - * - * TclFreeJumpFixupArray -- - * - * Free any storage allocated in a jump fixup array structure. - * - * Results: - * None. - * - * Side effects: - * Allocated storage in the JumpFixupArray structure is freed. - * - *---------------------------------------------------------------------- - */ - -void -TclFreeJumpFixupArray(fixupArrayPtr) - register JumpFixupArray *fixupArrayPtr; - /* Points to the JumpFixupArray structure - * to free. */ -{ - if (fixupArrayPtr->mallocedArray) { - ckfree((char *) fixupArrayPtr->fixup); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclEmitForwardJump -- - * - * Procedure to emit a two-byte forward jump of kind "jumpType". Since - * the jump may later have to be grown to five bytes if the jump target - * is more than, say, 127 bytes away, this procedure also initializes a - * JumpFixup record with information about the jump. - * - * Results: - * None. - * - * Side effects: - * The JumpFixup record pointed to by "jumpFixupPtr" is initialized - * with information needed later if the jump is to be grown. Also, - * a two byte jump of the designated type is emitted at the current - * point in the bytecode stream. - * - *---------------------------------------------------------------------- - */ - -void -TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr) - CompileEnv *envPtr; /* Points to the CompileEnv structure that - * holds the resulting instruction. */ - TclJumpType jumpType; /* Indicates the kind of jump: if true or - * false or unconditional. */ - JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to - * initialize with information about this - * forward jump. */ -{ - /* - * Initialize the JumpFixup structure: - * - codeOffset is offset of first byte of jump below - * - cmdIndex is index of the command after the current one - * - excRangeIndex is the index of the first ExceptionRange after - * the current one. - */ - - jumpFixupPtr->jumpType = jumpType; - jumpFixupPtr->codeOffset = TclCurrCodeOffset(); - jumpFixupPtr->cmdIndex = envPtr->numCommands; - jumpFixupPtr->excRangeIndex = envPtr->excRangeArrayNext; - - switch (jumpType) { - case TCL_UNCONDITIONAL_JUMP: - TclEmitInstInt1(INST_JUMP1, /*offset*/ 0, envPtr); - break; - case TCL_TRUE_JUMP: - TclEmitInstInt1(INST_JUMP_TRUE1, /*offset*/ 0, envPtr); - break; - default: - TclEmitInstInt1(INST_JUMP_FALSE1, /*offset*/ 0, envPtr); - break; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclFixupForwardJump -- - * - * Procedure that updates a previously-emitted forward jump to jump - * a specified number of bytes, "jumpDist". If necessary, the jump is - * grown from two to five bytes; this is done if the jump distance is - * greater than "distThreshold" (normally 127 bytes). The jump is - * described by a JumpFixup record previously initialized by - * TclEmitForwardJump. - * - * Results: - * 1 if the jump was grown and subsequent instructions had to be moved; - * otherwise 0. This result is returned to allow callers to update - * any additional code offsets they may hold. - * - * Side effects: - * The jump may be grown and subsequent instructions moved. If this - * happens, the code offsets for any commands and any ExceptionRange - * records between the jump and the current code address will be - * updated to reflect the moved code. Also, the bytecode instruction - * array in the CompileEnv structure may be grown and reallocated. - * - *---------------------------------------------------------------------- - */ - -int -TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) - CompileEnv *envPtr; /* Points to the CompileEnv structure that - * holds the resulting instruction. */ - JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that - * describes the forward jump. */ - int jumpDist; /* Jump distance to set in jump - * instruction. */ - int distThreshold; /* Maximum distance before the two byte - * jump is grown to five bytes. */ -{ - unsigned char *jumpPc, *p; - int firstCmd, lastCmd, firstRange, lastRange, k; - unsigned int numBytes; - - if (jumpDist <= distThreshold) { - jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); - switch (jumpFixupPtr->jumpType) { - case TCL_UNCONDITIONAL_JUMP: - TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); - break; - case TCL_TRUE_JUMP: - TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc); - break; - default: - TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc); - break; - } - return 0; - } - - /* - * We must grow the jump then move subsequent instructions down. - */ - - TclEnsureCodeSpace(3, envPtr); /* NB: might change code addresses! */ - jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); - for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1; - numBytes > 0; numBytes--, p--) { - p[3] = p[0]; - } - envPtr->codeNext += 3; - jumpDist += 3; - switch (jumpFixupPtr->jumpType) { - case TCL_UNCONDITIONAL_JUMP: - TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc); - break; - case TCL_TRUE_JUMP: - TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc); - break; - default: - TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); - break; - } - - /* - * Adjust the code offsets for any commands and any ExceptionRange - * records between the jump and the current code address. - */ - - firstCmd = jumpFixupPtr->cmdIndex; - lastCmd = (envPtr->numCommands - 1); - if (firstCmd < lastCmd) { - for (k = firstCmd; k <= lastCmd; k++) { - (envPtr->cmdMapPtr[k]).codeOffset += 3; - } - } - - firstRange = jumpFixupPtr->excRangeIndex; - lastRange = (envPtr->excRangeArrayNext - 1); - for (k = firstRange; k <= lastRange; k++) { - ExceptionRange *rangePtr = &(envPtr->excRangeArrayPtr[k]); - rangePtr->codeOffset += 3; - - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - rangePtr->breakOffset += 3; - if (rangePtr->continueOffset != -1) { - rangePtr->continueOffset += 3; - } - break; - case CATCH_EXCEPTION_RANGE: - rangePtr->catchOffset += 3; - break; - default: - panic("TclFixupForwardJump: unrecognized ExceptionRange type %d\n", rangePtr->type); + * Print instructions after the last command. + */ + + while (pc < codeLimit) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); } } - return 1; /* the jump was grown */ } +#endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- * - * TclGetInstructionTable -- + * TclPrintInstruction -- * - * Returns a pointer to the table describing Tcl bytecode instructions. - * This procedure is defined so that clients can access the pointer from - * outside the TCL DLLs. + * This procedure prints ("disassembles") one instruction from a + * bytecode object to stdout. * * Results: - * Returns a pointer to the global instruction table, same as the expression - * (&instructionTable[0]). + * Returns the length in bytes of the current instruiction. * * Side effects: * None. @@ -7942,150 +3205,248 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) *---------------------------------------------------------------------- */ -InstructionDesc * -TclGetInstructionTable() +int +TclPrintInstruction(codePtr, pc) + ByteCode* codePtr; /* Bytecode containing the instruction. */ + unsigned char *pc; /* Points to first byte of instruction. */ { - return &instructionTable[0]; + Proc *procPtr = codePtr->procPtr; + unsigned char opCode = *pc; + register InstructionDesc *instDesc = &instructionTable[opCode]; + unsigned char *codeStart = codePtr->codeStart; + unsigned int pcOffset = (pc - codeStart); + int opnd, i, j; + + fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); + for (i = 0; i < instDesc->numOperands; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + opnd = TclGetInt1AtPtr(pc+1+i); + if ((i == 0) && ((opCode == INST_JUMP1) + || (opCode == INST_JUMP_TRUE1) + || (opCode == INST_JUMP_FALSE1))) { + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); + } else { + fprintf(stdout, "%d", opnd); + } + break; + case OPERAND_INT4: + opnd = TclGetInt4AtPtr(pc+1+i); + if ((i == 0) && ((opCode == INST_JUMP4) + || (opCode == INST_JUMP_TRUE4) + || (opCode == INST_JUMP_FALSE4))) { + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); + } else { + fprintf(stdout, "%d", opnd); + } + break; + case OPERAND_UINT1: + opnd = TclGetUInt1AtPtr(pc+1+i); + if ((i == 0) && (opCode == INST_PUSH1)) { + fprintf(stdout, "%u # ", (unsigned int) opnd); + TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); + } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1) + || (opCode == INST_LOAD_ARRAY1) + || (opCode == INST_STORE_SCALAR1) + || (opCode == INST_STORE_ARRAY1))) { + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + if (opnd >= localCt) { + panic("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) opnd, localCt); + return instDesc->numBytes; + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "%u # temp var %u", + (unsigned int) opnd, (unsigned int) opnd); + } else { + fprintf(stdout, "%u # var ", (unsigned int) opnd); + TclPrintSource(stdout, localPtr->name, 40); + } + } else { + fprintf(stdout, "%u ", (unsigned int) opnd); + } + break; + case OPERAND_UINT4: + opnd = TclGetUInt4AtPtr(pc+1+i); + if (opCode == INST_PUSH4) { + fprintf(stdout, "%u # ", opnd); + TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); + } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4) + || (opCode == INST_LOAD_ARRAY4) + || (opCode == INST_STORE_SCALAR4) + || (opCode == INST_STORE_ARRAY4))) { + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + if (opnd >= localCt) { + panic("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) opnd, localCt); + return instDesc->numBytes; + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "%u # temp var %u", + (unsigned int) opnd, (unsigned int) opnd); + } else { + fprintf(stdout, "%u # var ", (unsigned int) opnd); + TclPrintSource(stdout, localPtr->name, 40); + } + } else { + fprintf(stdout, "%u ", (unsigned int) opnd); + } + break; + case OPERAND_NONE: + default: + break; + } + } + fprintf(stdout, "\n"); + return instDesc->numBytes; } /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- * - * TclRegisterAuxDataType -- + * TclPrintObject -- * - * This procedure is called to register a new AuxData type - * in the table of all AuxData types supported by Tcl. + * This procedure prints up to a specified number of characters from + * the argument Tcl object's string representation to a specified file. * * Results: * None. * * Side effects: - * The type is registered in the AuxData type table. If there was already - * a type with the same name as in typePtr, it is replaced with the - * new type. + * Outputs characters to the specified file. * - *-------------------------------------------------------------- + *---------------------------------------------------------------------- */ void -TclRegisterAuxDataType(typePtr) - AuxDataType *typePtr; /* Information about object type; - * storage must be statically - * allocated (must live forever). */ +TclPrintObject(outFile, objPtr, maxChars) + FILE *outFile; /* The file to print the source to. */ + Tcl_Obj *objPtr; /* Points to the Tcl object whose string + * representation should be printed. */ + int maxChars; /* Maximum number of chars to print. */ { - register Tcl_HashEntry *hPtr; - int new; - - if (!auxDataTypeTableInitialized) { - TclInitAuxDataTypeTable(); - } - - /* - * If there's already a type with the given name, remove it. - */ - - hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); - if (hPtr != (Tcl_HashEntry *) NULL) { - Tcl_DeleteHashEntry(hPtr); - } - - /* - * Now insert the new object type. - */ - - hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new); - if (new) { - Tcl_SetHashValue(hPtr, typePtr); - } + char *bytes; + int length; + + bytes = Tcl_GetStringFromObj(objPtr, &length); + TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } /* *---------------------------------------------------------------------- * - * TclGetAuxDataType -- + * TclPrintSource -- * - * This procedure looks up an Auxdata type by name. + * This procedure prints up to a specified number of characters from + * the argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. * * Results: - * If an AuxData type with name matching "typeName" is found, a pointer - * to its AuxDataType structure is returned; otherwise, NULL is returned. + * None. * * Side effects: - * None. + * Outputs characters to the specified file. * *---------------------------------------------------------------------- */ -AuxDataType * -TclGetAuxDataType(typeName) - char *typeName; /* Name of AuxData type to look up. */ +void +TclPrintSource(outFile, string, maxChars) + FILE *outFile; /* The file to print the source to. */ + char *string; /* The string to print. */ + int maxChars; /* Maximum number of chars to print. */ { - register Tcl_HashEntry *hPtr; - AuxDataType *typePtr = NULL; + register char *p; + register int i = 0; - if (!auxDataTypeTableInitialized) { - TclInitAuxDataTypeTable(); + if (string == NULL) { + fprintf(outFile, "\"\""); + return; } - hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); - if (hPtr != (Tcl_HashEntry *) NULL) { - typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); + fprintf(outFile, "\""); + p = string; + for (; (*p != '\0') && (i < maxChars); p++, i++) { + switch (*p) { + case '"': + fprintf(outFile, "\\\""); + continue; + case '\f': + fprintf(outFile, "\\f"); + continue; + case '\n': + fprintf(outFile, "\\n"); + continue; + case '\r': + fprintf(outFile, "\\r"); + continue; + case '\t': + fprintf(outFile, "\\t"); + continue; + case '\v': + fprintf(outFile, "\\v"); + continue; + default: + fprintf(outFile, "%c", *p); + continue; + } } - - return typePtr; -} - -/* - *-------------------------------------------------------------- - * - * TclInitAuxDataTypeTable -- - * - * This procedure is invoked to perform once-only initialization of - * the AuxData type table. It also registers the AuxData types defined in - * this file. - * - * Results: - * None. - * - * Side effects: - * Initializes the table of defined AuxData types "auxDataTypeTable" with - * builtin AuxData types defined in this file. - * - *-------------------------------------------------------------- - */ - -void -TclInitAuxDataTypeTable() -{ - auxDataTypeTableInitialized = 1; - - Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); - TclRegisterAuxDataType(&tclForeachInfoType); + fprintf(outFile, "\""); } +#ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * - * TclFinalizeAuxDataTypeTable -- + * RecordByteCodeStats -- * - * This procedure is called by Tcl_Finalize after all exit handlers - * have been run to free up storage associated with the table of AuxData - * types. + * Accumulates various compilation-related statistics for each newly + * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is + * compiled with the -DTCL_COMPILE_STATS flag * * Results: * None. * * Side effects: - * Deletes all entries in the hash table of AuxData types, "auxDataTypeTable". + * Accumulates aggregate code-related statistics in the interpreter's + * ByteCodeStats structure. Records statistics specific to a ByteCode + * in its ByteCode structure. * *---------------------------------------------------------------------- */ void -TclFinalizeAuxDataTypeTable() +RecordByteCodeStats(codePtr) + ByteCode *codePtr; /* Points to ByteCode structure with info + * to add to accumulated statistics. */ { - if (auxDataTypeTableInitialized) { - Tcl_DeleteHashTable(&auxDataTypeTable); - auxDataTypeTableInitialized = 0; - } + Interp *iPtr = (Interp *) *codePtr->interpHandle; + register ByteCodeStats *statsPtr = &(iPtr->stats); + + statsPtr->numCompilations++; + statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; + statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; + + statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; + statsPtr->byteCodeCount[TclLog2(codePtr->structureSize)]++; + + statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; + statsPtr->currentLitBytes += + (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); + statsPtr->currentExceptBytes += + (double) (codePtr->numExceptRanges * sizeof(ExceptionRange)); + statsPtr->currentAuxBytes += + (double) (codePtr->numAuxDataItems * sizeof(AuxData)); + statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes; } +#endif /* TCL_COMPILE_STATS */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 44eac12..4a718fd 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1,12 +1,12 @@ /* * tclCompile.h -- * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * Copyright (c) 1996-1998 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: tclCompile.h,v 1.9 1999/03/10 05:52:47 stanton Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.10 1999/04/16 00:46:45 stanton Exp $ */ #ifndef _TCLCOMPILATION @@ -60,32 +60,6 @@ extern int tclTraceCompile; extern int tclTraceExec; /* - * The number of bytecode compilations and various other compilation-related - * statistics. The tclByteCodeCount and tclSourceCount arrays are used to - * hold the count of ByteCodes and sources whose sizes fall into various - * binary decades; e.g., tclByteCodeCount[5] is a count of the ByteCodes - * with size larger than 2**4 and less than or equal to 2**5. - */ - -#ifdef TCL_COMPILE_STATS -extern long tclNumCompilations; -extern double tclTotalSourceBytes; -extern double tclTotalCodeBytes; - -extern double tclTotalInstBytes; -extern double tclTotalObjBytes; -extern double tclTotalExceptBytes; -extern double tclTotalAuxBytes; -extern double tclTotalCmdMapBytes; - -extern double tclCurrentSourceBytes; -extern double tclCurrentCodeBytes; - -extern int tclSourceCount[32]; -extern int tclByteCodeCount[32]; -#endif /* TCL_COMPILE_STATS */ - -/* *------------------------------------------------------------------------ * Data structures related to compilation. *------------------------------------------------------------------------ @@ -108,12 +82,12 @@ extern int tclByteCodeCount[32]; */ typedef enum { - LOOP_EXCEPTION_RANGE, /* Code range is part of a loop command. - * break and continue "exceptions" cause + LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop. + * Break and continue "exceptions" cause * jumps to appropriate PC offsets. */ - CATCH_EXCEPTION_RANGE /* Code range is controlled by a catch - * command. Errors in the range cause a - * jump to a particular PC offset. */ + CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a + * catch command. Errors in the range cause + * a jump to a catch PC offset. */ } ExceptionRangeType; typedef struct ExceptionRange { @@ -124,16 +98,14 @@ typedef struct ExceptionRange { int codeOffset; /* Offset of the first instruction byte of * the code range. */ int numCodeBytes; /* Number of bytes in the code range. */ - int breakOffset; /* If a LOOP_EXCEPTION_RANGE, the target - * PC offset for a break command in the - * range. */ - int continueOffset; /* If a LOOP_EXCEPTION_RANGE and not -1, - * the target PC offset for a continue - * command in the code range. Otherwise, - * ignore this range when processing a - * continue command. */ + int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC + * offset for a break command in the range. */ + int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the + * target PC offset for a continue command in + * the code range. Otherwise, ignore this range + * when processing a continue command. */ int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC - * offset for an "exception" in range. */ + * offset for any "exception" in range. */ } ExceptionRange; /* @@ -148,17 +120,69 @@ typedef struct CmdLocation { int codeOffset; /* Offset of first byte of command code. */ int numCodeBytes; /* Number of bytes for command's code. */ int srcOffset; /* Offset of first char of the command. */ - int numSrcChars; /* Number of command source chars. */ + int numSrcBytes; /* Number of command source chars. */ } CmdLocation; /* + * CompileProcs need the ability to record information during compilation + * that can be used by bytecode instructions during execution. The AuxData + * structure provides this "auxiliary data" mechanism. An arbitrary number + * of these structures can be stored in the ByteCode record (during + * compilation they are stored in a CompileEnv structure). Each AuxData + * record holds one word of client-specified data (often a pointer) and is + * given an index that instructions can later use to look up the structure + * and its data. + * + * The following definitions declare the types of procedures that are called + * to duplicate or free this auxiliary data when the containing ByteCode + * objects are duplicated and freed. Pointers to these procedures are kept + * in the AuxData structure. + */ + +typedef ClientData (AuxDataDupProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData)); + +/* + * We define a separate AuxDataType struct to hold type-related information + * for the AuxData structure. This separation makes it possible for clients + * outside of the TCL core to manipulate (in a limited fashion!) AuxData; + * for example, it makes it possible to pickle and unpickle AuxData structs. + */ + +typedef struct AuxDataType { + char *name; /* the name of the type. Types can be + * registered and found by name */ + AuxDataDupProc *dupProc; /* Callback procedure to invoke when the + * aux data is duplicated (e.g., when the + * ByteCode structure containing the aux + * data is duplicated). NULL means just + * copy the source clientData bits; no + * proc need be called. */ + AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the + * aux data is freed. NULL means no + * proc need be called. */ +} AuxDataType; + +/* + * The definition of the AuxData structure that holds information created + * during compilation by CompileProcs and used by instructions during + * execution. + */ + +typedef struct AuxData { + AuxDataType *type; /* pointer to the AuxData type associated with + * this ClientData. */ + ClientData clientData; /* The compilation data itself. */ +} AuxData; + +/* * Structure defining the compilation environment. After compilation, fields * describing bytecode instructions are copied out into the more compact * ByteCode structure defined below. */ #define COMPILEENV_INIT_CODE_BYTES 250 -#define COMPILEENV_INIT_NUM_OBJECTS 40 +#define COMPILEENV_INIT_NUM_OBJECTS 60 #define COMPILEENV_INIT_EXCEPT_RANGES 5 #define COMPILEENV_INIT_CMD_MAP_SIZE 40 #define COMPILEENV_INIT_AUX_DATA_SIZE 5 @@ -173,36 +197,25 @@ typedef struct CompileEnv { * SetByteCodeFromAny. This pointer is not * owned by the CompileEnv and must not be * freed or changed by it. */ + int numSrcBytes; /* Number of bytes in source. */ Proc *procPtr; /* If a procedure is being compiled, a * pointer to its Proc structure; otherwise * NULL. Used to compile local variables. * Set from information provided by * ObjInterpProc in tclProc.c. */ int numCommands; /* Number of commands compiled. */ - int excRangeDepth; /* Current exception range nesting level; + int exceptDepth; /* Current exception range nesting level; * -1 if not in any range currently. */ - int maxExcRangeDepth; /* Max nesting level of exception ranges; + int maxExceptDepth; /* Max nesting level of exception ranges; * -1 if no ranges have been compiled. */ int maxStackDepth; /* Maximum number of stack elements needed * to execute the code. Set by compilation * procedures before returning. */ - Tcl_HashTable objTable; /* Contains all Tcl objects referenced by - * the compiled code. Indexed by the string - * representations of the objects. Used to + LiteralTable localLitTable; /* Contains LiteralEntry's describing + * all Tcl objects referenced by this + * compiled code. Indexed by the string + * representations of the literals. Used to * avoid creating duplicate objects. */ - int pushSimpleWords; /* Set 1 by callers of compilation routines - * if they should emit instructions to push - * "simple" command words (those that are - * just a sequence of characters). If 0, the - * callers are responsible for compiling - * simple words. */ - int wordIsSimple; /* Set 1 by compilation procedures before - * returning if the previous command word - * was just a sequence of characters, - * otherwise 0. Used to help determine the - * command being compiled. */ - int numSimpleWordChars; /* If wordIsSimple is 1 then the number of - * characters in the simple word, else 0. */ int exprIsJustVarRef; /* Set 1 if the expression last compiled by * TclCompileExpr consisted of just a * variable reference as in the expression @@ -215,31 +228,29 @@ typedef struct CompileEnv { * might be strings, the expr is compiled * out-of-line to implement expr's 2 level * substitution semantics properly. */ - int termOffset; /* Offset of character just after the last - * one compiled. Set by compilation - * procedures before returning. */ unsigned char *codeStart; /* Points to the first byte of the code. */ unsigned char *codeNext; /* Points to next code array byte to use. */ unsigned char *codeEnd; /* Points just after the last allocated * code array byte. */ int mallocedCodeArray; /* Set 1 if code array was expanded * and codeStart points into the heap.*/ - Tcl_Obj **objArrayPtr; /* Points to start of object array. */ - int objArrayNext; /* Index of next free object array entry. */ - int objArrayEnd; /* Index just after last obj array entry. */ - int mallocedObjArray; /* 1 if object array was expanded and + LiteralEntry *literalArrayPtr; + /* Points to start of LiteralEntry array. */ + int literalArrayNext; /* Index of next free object array entry. */ + int literalArrayEnd; /* Index just after last obj array entry. */ + int mallocedLiteralArray; /* 1 if object array was expanded and * objArray points into the heap, else 0. */ - ExceptionRange *excRangeArrayPtr; + ExceptionRange *exceptArrayPtr; /* Points to start of the ExceptionRange * array. */ - int excRangeArrayNext; /* Next free ExceptionRange array index. - * excRangeArrayNext is the number of ranges - * and (excRangeArrayNext-1) is the index of + int exceptArrayNext; /* Next free ExceptionRange array index. + * exceptArrayNext is the number of ranges + * and (exceptArrayNext-1) is the index of * the current range's array entry. */ - int excRangeArrayEnd; /* Index after the last ExceptionRange + int exceptArrayEnd; /* Index after the last ExceptionRange * array entry. */ - int mallocedExcRangeArray; /* 1 if ExceptionRange array was expanded - * and excRangeArrayPtr points in heap, + int mallocedExceptArray; /* 1 if ExceptionRange array was expanded + * and exceptArrayPtr points in heap, * else 0. */ CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. * numCommands is the index of the next @@ -258,9 +269,9 @@ typedef struct CompileEnv { * auxDataArrayPtr points in heap else 0. */ unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; /* Initial storage for code. */ - Tcl_Obj *staticObjArraySpace[COMPILEENV_INIT_NUM_OBJECTS]; - /* Initial storage for object array. */ - ExceptionRange staticExcRangeArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; + LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; + /* Initial storage of LiteralEntry array. */ + ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial ExceptionRange array storage. */ CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; /* Initial storage for cmd location map. */ @@ -272,8 +283,8 @@ typedef struct CompileEnv { * The structure defining the bytecode instructions resulting from compiling * a Tcl script. Note that this structure is variable length: a single heap * object is allocated to hold the ByteCode structure immediately followed - * by the code bytes, the object array, the ExceptionRange array, the - * CmdLocation map, and the compilation AuxData array. + * by the code bytes, the literal object array, the ExceptionRange array, + * the CmdLocation map, and the compilation AuxData array. */ /* @@ -283,10 +294,10 @@ typedef struct CompileEnv { #define TCL_BYTECODE_PRECOMPILED 0x0001 typedef struct ByteCode { - Interp *iPtr; /* Interpreter containing the code being - * compiled. Commands and their compile - * procs are specific to an interpreter so - * the code emitted will depend on the + TclHandle interpHandle; /* Handle for interpreter containing the + * compiled code. Commands and their compile + * procs are specific to an interpreter so the + * code emitted will depend on the * interpreter. */ int compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate @@ -315,29 +326,30 @@ typedef struct ByteCode { * procedure body, this is a pointer to its * Proc structure; otherwise NULL. This * pointer is also not owned by the ByteCode - * and must not be freed by it. Used for - * debugging. */ - size_t totalSize; /* Total number of bytes required for this - * ByteCode structure including the storage - * for Tcl objects in its object array. */ + * and must not be freed by it. */ + size_t structureSize; /* Number of bytes in the ByteCode structure + * itself. Does not include heap space for + * literal Tcl objects or storage referenced + * by AuxData entries. */ int numCommands; /* Number of commands compiled. */ - int numSrcChars; /* Number of source chars compiled. */ + int numSrcBytes; /* Number of source bytes compiled. */ int numCodeBytes; /* Number of code bytes. */ - int numObjects; /* Number of Tcl objects in object array. */ - int numExcRanges; /* Number of ExceptionRange array elems. */ + int numLitObjects; /* Number of objects in literal array. */ + int numExceptRanges; /* Number of ExceptionRange array elems. */ int numAuxDataItems; /* Number of AuxData items. */ int numCmdLocBytes; /* Number of bytes needed for encoded * command location information. */ - int maxExcRangeDepth; /* Maximum nesting level of ExceptionRanges; + int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; * -1 if no ranges were compiled. */ int maxStackDepth; /* Maximum number of stack elements needed * to execute the code. */ unsigned char *codeStart; /* Points to the first byte of the code. * This is just after the final ByteCode * member cmdMapPtr. */ - Tcl_Obj **objArrayPtr; /* Points to the start of the object array. - * This is just after the last code byte. */ - ExceptionRange *excRangeArrayPtr; + Tcl_Obj **objArrayPtr; /* Points to the start of the literal + * object array. This is just after the + * last code byte. */ + ExceptionRange *exceptArrayPtr; /* Points to the start of the ExceptionRange * array. This is just after the last * object in the object array. */ @@ -378,106 +390,111 @@ typedef struct ByteCode { * are always positive. This sequence is * just after the last byte in the source * delta sequence. */ +#ifdef TCL_COMPILE_STATS + Tcl_Time createTime; /* Absolute time when the ByteCode was + * created. */ +#endif /* TCL_COMPILE_STATS */ } ByteCode; /* - * Opcodes for the Tcl bytecode instructions. These opcodes must correspond - * to the entries in the table of instruction descriptions in tclCompile.c. - * Also, the order and number of the expression opcodes (e.g., INST_LOR) - * must match the entries in the array operatorStrings in tclExecute.c. + * Opcodes for the Tcl bytecode instructions. These must correspond to the + * entries in the table of instruction descriptions, instructionTable, in + * tclCompile.c. Also, the order and number of the expression opcodes + * (e.g., INST_LOR) must match the entries in the array operatorStrings in + * tclExecute.c. */ /* Opcodes 0 to 9 */ #define INST_DONE 0 -#define INST_PUSH1 (INST_DONE + 1) -#define INST_PUSH4 (INST_DONE + 2) -#define INST_POP (INST_DONE + 3) -#define INST_DUP (INST_DONE + 4) -#define INST_CONCAT1 (INST_DONE + 5) -#define INST_INVOKE_STK1 (INST_DONE + 6) -#define INST_INVOKE_STK4 (INST_DONE + 7) -#define INST_EVAL_STK (INST_DONE + 8) -#define INST_EXPR_STK (INST_DONE + 9) +#define INST_PUSH1 1 +#define INST_PUSH4 2 +#define INST_POP 3 +#define INST_DUP 4 +#define INST_CONCAT1 5 +#define INST_INVOKE_STK1 6 +#define INST_INVOKE_STK4 7 +#define INST_EVAL_STK 8 +#define INST_EXPR_STK 9 /* Opcodes 10 to 23 */ -#define INST_LOAD_SCALAR1 (INST_EXPR_STK + 1) -#define INST_LOAD_SCALAR4 (INST_LOAD_SCALAR1 + 1) -#define INST_LOAD_SCALAR_STK (INST_LOAD_SCALAR1 + 2) -#define INST_LOAD_ARRAY1 (INST_LOAD_SCALAR1 + 3) -#define INST_LOAD_ARRAY4 (INST_LOAD_SCALAR1 + 4) -#define INST_LOAD_ARRAY_STK (INST_LOAD_SCALAR1 + 5) -#define INST_LOAD_STK (INST_LOAD_SCALAR1 + 6) -#define INST_STORE_SCALAR1 (INST_LOAD_SCALAR1 + 7) -#define INST_STORE_SCALAR4 (INST_LOAD_SCALAR1 + 8) -#define INST_STORE_SCALAR_STK (INST_LOAD_SCALAR1 + 9) -#define INST_STORE_ARRAY1 (INST_LOAD_SCALAR1 + 10) -#define INST_STORE_ARRAY4 (INST_LOAD_SCALAR1 + 11) -#define INST_STORE_ARRAY_STK (INST_LOAD_SCALAR1 + 12) -#define INST_STORE_STK (INST_LOAD_SCALAR1 + 13) +#define INST_LOAD_SCALAR1 10 +#define INST_LOAD_SCALAR4 11 +#define INST_LOAD_SCALAR_STK 12 +#define INST_LOAD_ARRAY1 13 +#define INST_LOAD_ARRAY4 14 +#define INST_LOAD_ARRAY_STK 15 +#define INST_LOAD_STK 16 +#define INST_STORE_SCALAR1 17 +#define INST_STORE_SCALAR4 18 +#define INST_STORE_SCALAR_STK 19 +#define INST_STORE_ARRAY1 20 +#define INST_STORE_ARRAY4 21 +#define INST_STORE_ARRAY_STK 22 +#define INST_STORE_STK 23 /* Opcodes 24 to 33 */ -#define INST_INCR_SCALAR1 (INST_STORE_STK + 1) -#define INST_INCR_SCALAR_STK (INST_INCR_SCALAR1 + 1) -#define INST_INCR_ARRAY1 (INST_INCR_SCALAR1 + 2) -#define INST_INCR_ARRAY_STK (INST_INCR_SCALAR1 + 3) -#define INST_INCR_STK (INST_INCR_SCALAR1 + 4) -#define INST_INCR_SCALAR1_IMM (INST_INCR_SCALAR1 + 5) -#define INST_INCR_SCALAR_STK_IMM (INST_INCR_SCALAR1 + 6) -#define INST_INCR_ARRAY1_IMM (INST_INCR_SCALAR1 + 7) -#define INST_INCR_ARRAY_STK_IMM (INST_INCR_SCALAR1 + 8) -#define INST_INCR_STK_IMM (INST_INCR_SCALAR1 + 9) +#define INST_INCR_SCALAR1 24 +#define INST_INCR_SCALAR_STK 25 +#define INST_INCR_ARRAY1 26 +#define INST_INCR_ARRAY_STK 27 +#define INST_INCR_STK 28 +#define INST_INCR_SCALAR1_IMM 29 +#define INST_INCR_SCALAR_STK_IMM 30 +#define INST_INCR_ARRAY1_IMM 31 +#define INST_INCR_ARRAY_STK_IMM 32 +#define INST_INCR_STK_IMM 33 /* Opcodes 34 to 39 */ -#define INST_JUMP1 (INST_INCR_STK_IMM + 1) -#define INST_JUMP4 (INST_JUMP1 + 1) -#define INST_JUMP_TRUE1 (INST_JUMP1 + 2) -#define INST_JUMP_TRUE4 (INST_JUMP1 + 3) -#define INST_JUMP_FALSE1 (INST_JUMP1 + 4) -#define INST_JUMP_FALSE4 (INST_JUMP1 + 5) +#define INST_JUMP1 34 +#define INST_JUMP4 35 +#define INST_JUMP_TRUE1 36 +#define INST_JUMP_TRUE4 37 +#define INST_JUMP_FALSE1 38 +#define INST_JUMP_FALSE4 39 /* Opcodes 40 to 64 */ -#define INST_LOR (INST_JUMP_FALSE4 + 1) -#define INST_LAND (INST_LOR + 1) -#define INST_BITOR (INST_LOR + 2) -#define INST_BITXOR (INST_LOR + 3) -#define INST_BITAND (INST_LOR + 4) -#define INST_EQ (INST_LOR + 5) -#define INST_NEQ (INST_LOR + 6) -#define INST_LT (INST_LOR + 7) -#define INST_GT (INST_LOR + 8) -#define INST_LE (INST_LOR + 9) -#define INST_GE (INST_LOR + 10) -#define INST_LSHIFT (INST_LOR + 11) -#define INST_RSHIFT (INST_LOR + 12) -#define INST_ADD (INST_LOR + 13) -#define INST_SUB (INST_LOR + 14) -#define INST_MULT (INST_LOR + 15) -#define INST_DIV (INST_LOR + 16) -#define INST_MOD (INST_LOR + 17) -#define INST_UPLUS (INST_LOR + 18) -#define INST_UMINUS (INST_LOR + 19) -#define INST_BITNOT (INST_LOR + 20) -#define INST_LNOT (INST_LOR + 21) -#define INST_CALL_BUILTIN_FUNC1 (INST_LOR + 22) -#define INST_CALL_FUNC1 (INST_LOR + 23) -#define INST_TRY_CVT_TO_NUMERIC (INST_LOR + 24) +#define INST_LOR 40 +#define INST_LAND 41 +#define INST_BITOR 42 +#define INST_BITXOR 43 +#define INST_BITAND 44 +#define INST_EQ 45 +#define INST_NEQ 46 +#define INST_LT 47 +#define INST_GT 48 +#define INST_LE 49 +#define INST_GE 50 +#define INST_LSHIFT 51 +#define INST_RSHIFT 52 +#define INST_ADD 53 +#define INST_SUB 54 +#define INST_MULT 55 +#define INST_DIV 56 +#define INST_MOD 57 +#define INST_UPLUS 58 +#define INST_UMINUS 59 +#define INST_BITNOT 60 +#define INST_LNOT 61 +#define INST_CALL_BUILTIN_FUNC1 62 +#define INST_CALL_FUNC1 63 +#define INST_TRY_CVT_TO_NUMERIC 64 /* Opcodes 65 to 66 */ -#define INST_BREAK (INST_TRY_CVT_TO_NUMERIC + 1) -#define INST_CONTINUE (INST_BREAK + 1) +#define INST_BREAK 65 +#define INST_CONTINUE 66 /* Opcodes 67 to 68 */ -#define INST_FOREACH_START4 (INST_CONTINUE + 1) -#define INST_FOREACH_STEP4 (INST_FOREACH_START4 + 1) +#define INST_FOREACH_START4 67 +#define INST_FOREACH_STEP4 68 /* Opcodes 69 to 72 */ -#define INST_BEGIN_CATCH4 (INST_FOREACH_STEP4 + 1) -#define INST_END_CATCH (INST_BEGIN_CATCH4 + 1) -#define INST_PUSH_RESULT (INST_BEGIN_CATCH4 + 2) -#define INST_PUSH_RETURN_CODE (INST_BEGIN_CATCH4 + 3) +#define INST_BEGIN_CATCH4 69 +#define INST_END_CATCH 70 +#define INST_PUSH_RESULT 71 +#define INST_PUSH_RETURN_CODE 72 /* The last opcode */ -#define LAST_INST_OPCODE INST_PUSH_RETURN_CODE +#define LAST_INST_OPCODE 72 /* * Table describing the Tcl bytecode instructions: their name (for @@ -542,7 +559,7 @@ extern InstructionDesc instructionTable[]; #define BUILTIN_FUNC_ROUND 23 #define BUILTIN_FUNC_SRAND 24 -#define LAST_BUILTIN_FUNC BUILTIN_FUNC_SRAND +#define LAST_BUILTIN_FUNC 24 /* * Table describing the built-in math functions. Entries in this table are @@ -566,30 +583,6 @@ typedef struct { extern BuiltinFunc builtinFuncTable[]; /* - * The structure used to hold information about the start and end of each - * argument word in a command. - */ - -#define ARGINFO_INIT_ENTRIES 5 - -typedef struct ArgInfo { - int numArgs; /* Number of argument words in command. */ - char **startArray; /* Array of pointers to the first character - * of each argument word. */ - char **endArray; /* Array of pointers to the last character - * of each argument word. */ - int allocArgs; /* Number of array entries currently - * allocated. */ - int mallocedArrays; /* 1 if the arrays were expanded and - * wordStartArray/wordEndArray point into - * the heap, else 0. */ - char *staticStartSpace[ARGINFO_INIT_ENTRIES]; - /* Initial storage for word start array. */ - char *staticEndSpace[ARGINFO_INIT_ENTRIES]; - /* Initial storage for word end array. */ -} ArgInfo; - -/* * Compilation of some Tcl constructs such as if commands and the logical or * (||) and logical and (&&) operators in expressions requires the * generation of forward jumps. Since the PC target of these jumps isn't @@ -617,7 +610,7 @@ typedef struct JumpFixup { * update the code offsets for subsequent * commands if the two-byte jump at jumpPc * must be replaced with a five-byte one. */ - int excRangeIndex; /* Index of the first range entry in the + int exceptIndex; /* Index of the first range entry in the * ExceptionRange array after the current * one. This field is used to adjust the * code offsets in subsequent ExceptionRange @@ -664,12 +657,12 @@ typedef struct ForeachVarList { typedef struct ForeachInfo { int numLists; /* The number of both the variable and value * lists of the foreach command. */ - int firstListTmp; /* The slot number of the first temporary - * variable holding the lists themselves. */ - int loopIterNumTmp; /* The slot number of the temp var holding - * the count of times the loop body has been - * executed. This is used to determine which - * list element to assign each loop var. */ + int firstValueTemp; /* Index of the first temp var in a proc + * frame used to point to a value list. */ + int loopCtTemp; /* Index of temp var in a proc frame + * holding the loop's iteration count. Used + * to determine next value list element to + * assign each loop var. */ ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large @@ -677,6 +670,8 @@ typedef struct ForeachInfo { * THE LAST FIELD IN THE STRUCTURE! */ } ForeachInfo; +extern AuxDataType tclForeachInfoType; + /* * Structure containing a cached pointer to a command that is the result * of resolving the command's name in some namespace. It is the internal @@ -720,24 +715,32 @@ typedef struct ResolvedCmdName { */ EXTERN void TclCleanupByteCode _ANSI_ARGS_((ByteCode *codePtr)); +EXTERN int TclCompileCmdWord _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *tokenPtr, int count, + CompileEnv *envPtr)); EXTERN int TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, + char *script, int numBytes, CompileEnv *envPtr)); -EXTERN int TclCompileQuotes _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int termChar, - int flags, CompileEnv *envPtr)); -EXTERN int TclCompileString _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, +EXTERN int TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr)); -EXTERN int TclCompileDollarVar _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, +EXTERN int TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp, + char *script, int numBytes, int nested, + CompileEnv *envPtr)); +EXTERN int TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *tokenPtr, int count, CompileEnv *envPtr)); EXTERN int TclCreateAuxData _ANSI_ARGS_((ClientData clientData, - AuxDataType *typePtr, CompileEnv *envPtr)); + AuxDataType *typePtr, CompileEnv *envPtr)); +EXTERN int TclCreateExceptRange _ANSI_ARGS_(( + ExceptionRangeType type, CompileEnv *envPtr)); EXTERN ExecEnv * TclCreateExecEnv _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void TclDeleteExecEnv _ANSI_ARGS_((ExecEnv *eePtr)); +EXTERN void TclDeleteLiteralTable _ANSI_ARGS_(( + Tcl_Interp *interp, LiteralTable *tablePtr)); EXTERN void TclEmitForwardJump _ANSI_ARGS_((CompileEnv *envPtr, TclJumpType jumpType, JumpFixup *jumpFixupPtr)); +EXTERN AuxDataType *TclGetAuxDataType _ANSI_ARGS_((char *typeName)); EXTERN ExceptionRange * TclGetExceptionRangeForPc _ANSI_ARGS_(( unsigned char *pc, int catchOnly, ByteCode* codePtr)); @@ -745,10 +748,15 @@ EXTERN InstructionDesc * TclGetInstructionTable _ANSI_ARGS_(()); EXTERN int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, ByteCode *codePtr)); EXTERN void TclExpandCodeArray _ANSI_ARGS_(( - CompileEnv *envPtr)); + CompileEnv *envPtr)); EXTERN void TclExpandJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); EXTERN void TclFinalizeAuxDataTypeTable _ANSI_ARGS_((void)); +EXTERN int TclFindCompiledLocal _ANSI_ARGS_((char *name, + int nameChars, int create, int flags, + Proc *procPtr)); +EXTERN LiteralEntry * TclLookupLiteralEntry _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr)); EXTERN int TclFixupForwardJump _ANSI_ARGS_(( CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, int distThreshold)); @@ -758,21 +766,42 @@ EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_(( EXTERN void TclInitAuxDataTypeTable _ANSI_ARGS_((void)); EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr, CompileEnv *envPtr)); +EXTERN void TclInitCompilation _ANSI_ARGS_((void)); EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, - CompileEnv *envPtr, char *string)); + CompileEnv *envPtr, char *string, + int numBytes)); EXTERN void TclInitJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); +EXTERN void TclInitLiteralTable _ANSI_ARGS_(( + LiteralTable *tablePtr)); #ifdef TCL_COMPILE_STATS +EXTERN char * TclLiteralStats _ANSI_ARGS_(( + LiteralTable *tablePtr)); EXTERN int TclLog2 _ANSI_ARGS_((int value)); -#endif /*TCL_COMPILE_STATS*/ -EXTERN int TclObjIndexForString _ANSI_ARGS_((char *start, - int length, int allocStrRep, int inHeap, - CompileEnv *envPtr)); +#endif +#ifdef TCL_COMPILE_DEBUG +EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +#endif EXTERN int TclPrintInstruction _ANSI_ARGS_((ByteCode* codePtr, unsigned char *pc)); +EXTERN void TclPrintObject _ANSI_ARGS_((FILE *outFile, + Tcl_Obj *objPtr, int maxChars)); EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, char *string, int maxChars)); EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); +EXTERN int TclRegisterLiteral _ANSI_ARGS_((CompileEnv *envPtr, + char *bytes, int length, int onHeap)); +EXTERN void TclReleaseLiteral _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +EXTERN void TclSetCmdNameObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, Command *cmdPtr)); +#ifdef TCL_COMPILE_DEBUG +EXTERN void TclVerifyGlobalLiteralTable _ANSI_ARGS_(( + Interp *iPtr)); +EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_(( + CompileEnv *envPtr)); +#endif /* *---------------------------------------------------------------- @@ -782,23 +811,6 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); */ /* - * Macros to ensure there is enough room in a CompileEnv's code array. - * The ANSI C "prototypes" for these macros are: - * - * EXTERN void TclEnsureCodeSpace1 _ANSI_ARGS_((CompileEnv *envPtr)); - * EXTERN void TclEnsureCodeSpace _ANSI_ARGS_((int nBytes, - * CompileEnv *envPtr)); - */ - -#define TclEnsureCodeSpace1(envPtr) \ - if ((envPtr)->codeNext == (envPtr)->codeEnd) \ - TclExpandCodeArray(envPtr) - -#define TclEnsureCodeSpace(nBytes, envPtr) \ - if (((envPtr)->codeNext + nBytes) > (envPtr)->codeEnd) \ - TclExpandCodeArray(envPtr) - -/* * Macro to emit an opcode byte into a CompileEnv's code array. * The ANSI C "prototype" for this macro is: * @@ -807,55 +819,45 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); */ #define TclEmitOpcode(op, envPtr) \ - TclEnsureCodeSpace1(envPtr); \ + if ((envPtr)->codeNext == (envPtr)->codeEnd) \ + TclExpandCodeArray(envPtr); \ *(envPtr)->codeNext++ = (unsigned char) (op) /* - * Macros to emit a (signed or unsigned) int operand. The two variants - * depend on the number of bytes needed for the int. Four byte integers - * are stored in "big-endian" order with the high order byte stored at - * the lowest address. The ANSI C "prototypes" for these macros are: + * Macro to emit an integer operand. + * The ANSI C "prototype" for this macro is: * * EXTERN void TclEmitInt1 _ANSI_ARGS_((int i, CompileEnv *envPtr)); - * EXTERN void TclEmitInt4 _ANSI_ARGS_((int i, CompileEnv *envPtr)); */ #define TclEmitInt1(i, envPtr) \ - TclEnsureCodeSpace(1, (envPtr)); \ + if ((envPtr)->codeNext == (envPtr)->codeEnd) \ + TclExpandCodeArray(envPtr); \ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)) -#define TclEmitInt4(i, envPtr) \ - TclEnsureCodeSpace(4, (envPtr)); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 24); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 16); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 8); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) ) - /* - * Macros to emit an instruction with signed or unsigned int operands. + * Macros to emit an instruction with signed or unsigned integer operands. + * Four byte integers are stored in "big-endian" order with the high order + * byte stored at the lowest address. * The ANSI C "prototypes" for these macros are: * * EXTERN void TclEmitInstInt1 _ANSI_ARGS_((unsigned char op, int i, * CompileEnv *envPtr)); * EXTERN void TclEmitInstInt4 _ANSI_ARGS_((unsigned char op, int i, * CompileEnv *envPtr)); - * EXTERN void TclEmitInstUInt1 _ANSI_ARGS_((unsigned char op, - * unsigned int i, CompileEnv *envPtr)); - * EXTERN void TclEmitInstUInt4 _ANSI_ARGS_((unsigned char op, - * unsigned int i, CompileEnv *envPtr)); */ #define TclEmitInstInt1(op, i, envPtr) \ - TclEnsureCodeSpace(2, (envPtr)); \ + if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)) #define TclEmitInstInt4(op, i, envPtr) \ - TclEnsureCodeSpace(5, (envPtr)); \ + if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) >> 24); \ @@ -866,12 +868,6 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) ) -#define TclEmitInstUInt1(op, i, envPtr) \ - TclEmitInstInt1((op), (i), (envPtr)) - -#define TclEmitInstUInt4(op, i, envPtr) \ - TclEmitInstInt4((op), (i), (envPtr)) - /* * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the * object's one or four byte array index into the CompileEnv's code @@ -883,9 +879,9 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); #define TclEmitPush(objIndex, envPtr) \ if ((objIndex) <= 255) { \ - TclEmitInstUInt1(INST_PUSH1, (objIndex), (envPtr)); \ + TclEmitInstInt1(INST_PUSH1, (objIndex), (envPtr)); \ } else { \ - TclEmitInstUInt4(INST_PUSH4, (objIndex), (envPtr)); \ + TclEmitInstInt4(INST_PUSH4, (objIndex), (envPtr)); \ } /* @@ -979,22 +975,6 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); #define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) #define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) -/* - * Macro used to compute the offset of the current instruction in the - * bytecode instruction stream. The ANSI C "prototypes" for this macro is: - * - * EXTERN int TclCurrCodeOffset _ANSI_ARGS_((void)); - */ - -#define TclCurrCodeOffset() ((envPtr)->codeNext - (envPtr)->codeStart) - -/* - * Upper bound for legal jump distances. Checked during compilation if - * debugging. - */ - -#define MAX_JUMP_DIST 5000 - # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLIMPORT diff --git a/generic/tclDate.c b/generic/tclDate.c index eb87b76..cdbcfe8 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -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: tclDate.c,v 1.3 1999/03/10 05:52:47 stanton Exp $ + * RCS: @(#) $Id: tclDate.c,v 1.4 1999/04/16 00:46:45 stanton Exp $ */ #include "tclInt.h" @@ -537,11 +537,8 @@ LookupWord(buff) /* * Make it lowercase. */ - for (p = buff; *p; p++) { - if (isupper(UCHAR(*p))) { - *p = (char) tolower(UCHAR(*p)); - } - } + + Tcl_UtfToLower(buff); if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) { TclDatelval.Meridian = MERam; @@ -614,7 +611,8 @@ LookupWord(buff) /* * Military timezones. */ - if (buff[1] == '\0' && isalpha(UCHAR(*buff))) { + if (buff[1] == '\0' && !(*buff & 0x80) + && isalpha(UCHAR(*buff))) { /* INTL: ISO only */ for (tp = MilitaryTable; tp->name; tp++) { if (strcmp(buff, tp->name) == 0) { TclDatelval.Number = tp->value; @@ -660,10 +658,10 @@ TclDatelex() TclDateInput++; } - if (isdigit(c = *TclDateInput) || c == '-' || c == '+') { + if (isdigit(c = *TclDateInput) || c == '-' || c == '+') { /* INTL: digit */ if (c == '-' || c == '+') { sign = c == '-' ? -1 : 1; - if (!isdigit(*++TclDateInput)) { + if (!isdigit(*++TclDateInput)) { /* INTL: digit */ /* * skip the '-' sign */ @@ -672,7 +670,8 @@ TclDatelex() } else { sign = 0; } - for (TclDatelval.Number = 0; isdigit(c = *TclDateInput++); ) { + for (TclDatelval.Number = 0; + isdigit(c = *TclDateInput++); ) { /* INTL: digit */ TclDatelval.Number = 10 * TclDatelval.Number + c - '0'; } TclDateInput--; @@ -681,8 +680,9 @@ TclDatelex() } return sign ? tSNUMBER : tUNUMBER; } - if (isalpha(UCHAR(c))) { - for (p = buff; isalpha(c = *TclDateInput++) || c == '.'; ) { + if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */ + for (p = buff; isalpha(c = *TclDateInput++) /* INTL: ISO only. */ + || c == '.'; ) { if (p < &buff[sizeof buff - 1]) { *p++ = c; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 70bdf2a..f07ff56 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -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.6 1999/03/11 02:49:34 stanton Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.7 1999/04/16 00:46:45 stanton Exp $ */ #ifndef _TCLDECLS @@ -35,7 +35,7 @@ EXTERN char * Tcl_PkgRequireEx _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 2 */ -EXTERN void panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); +EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); /* 3 */ EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size)); /* 4 */ @@ -109,7 +109,7 @@ EXTERN Tcl_Obj * Tcl_DbNewLongObj _ANSI_ARGS_((long longValue, /* 27 */ EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((char * file, int line)); /* 28 */ -EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((char * bytes, +EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((CONST char * bytes, int length, char * file, int line)); /* 29 */ EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj * objPtr)); @@ -117,7 +117,7 @@ EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj * objPtr)); EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 31 */ EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int * boolPtr)); + char * str, int * boolPtr)); /* 32 */ EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, @@ -127,7 +127,7 @@ EXTERN unsigned char * Tcl_GetByteArrayFromObj _ANSI_ARGS_(( Tcl_Obj * objPtr, int * lengthPtr)); /* 34 */ EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp * interp, - char * string, double * doublePtr)); + char * str, double * doublePtr)); /* 35 */ EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, @@ -138,7 +138,7 @@ EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp * interp, char * msg, int flags, int * indexPtr)); /* 37 */ EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int * intPtr)); + char * str, int * intPtr)); /* 38 */ EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); @@ -193,7 +193,7 @@ EXTERN Tcl_Obj * Tcl_NewLongObj _ANSI_ARGS_((long longValue)); /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj _ANSI_ARGS_((void)); /* 56 */ -EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((char * bytes, +EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((CONST char * bytes, int length)); /* 57 */ EXTERN void Tcl_SetBooleanObj _ANSI_ARGS_((Tcl_Obj * objPtr, @@ -224,15 +224,15 @@ EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj * objPtr, char * bytes, int length)); /* 66 */ EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp * interp, - char * message)); + CONST char * message)); /* 67 */ EXTERN void Tcl_AddObjErrorInfo _ANSI_ARGS_((Tcl_Interp * interp, - char * message, int length)); + CONST char * message, int length)); /* 68 */ EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp * interp)); /* 69 */ EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, - char * string)); + CONST char * string)); /* 70 */ EXTERN void Tcl_AppendResult _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 71 */ @@ -391,7 +391,7 @@ EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); /* 117 */ EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString * dsPtr, - CONST char * string, int length)); + CONST char * str, int length)); /* 118 */ EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_(( Tcl_DString * dsPtr, CONST char * string)); @@ -440,19 +440,19 @@ EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp * interp, char * hiddenCmdToken, char * cmdName)); /* 135 */ EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int * ptr)); + 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 * string, double * ptr)); + 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 * string, long * ptr)); + char * str, long * ptr)); /* 140 */ EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); @@ -465,7 +465,7 @@ EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp * interp, /* 143 */ EXTERN void Tcl_Finalize _ANSI_ARGS_((void)); /* 144 */ -EXTERN void Tcl_FindExecutable _ANSI_ARGS_((char * argv0)); +EXTERN void Tcl_FindExecutable _ANSI_ARGS_((CONST char * argv0)); /* 145 */ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_(( Tcl_HashTable * tablePtr, @@ -534,7 +534,7 @@ EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 167 */ EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int write, int checkUsage, + char * str, int write, int checkUsage, ClientData * filePtr)); #endif /* UNIX */ /* 168 */ @@ -665,11 +665,11 @@ EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 213 */ EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_RegExp regexp, char * string, - char * start)); + Tcl_RegExp regexp, CONST char * str, + CONST char * start)); /* 214 */ EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp * interp, - char * string, char * pattern)); + char * str, char * pattern)); /* 215 */ EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, int index, char ** startPtr, char ** endPtr)); @@ -678,12 +678,11 @@ EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData)); /* 217 */ EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp * interp)); /* 218 */ -EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char * string, +EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 219 */ -EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_(( - CONST char * string, int length, - int * flagPtr)); +EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char * str, + int length, int * flagPtr)); /* 220 */ EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); @@ -719,7 +718,7 @@ EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_(( Tcl_Interp * interp, int depth)); /* 232 */ EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp * interp, - char * string, Tcl_FreeProc * freeProc)); + char * str, Tcl_FreeProc * freeProc)); /* 233 */ EXTERN int Tcl_SetServiceMode _ANSI_ARGS_((int mode)); /* 234 */ @@ -746,9 +745,10 @@ EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp * interp)); /* 242 */ EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp * interp, - char * list, int * argcPtr, char *** argvPtr)); + CONST char * listStr, int * argcPtr, + char *** argvPtr)); /* 243 */ -EXTERN void Tcl_SplitPath _ANSI_ARGS_((char * path, +EXTERN void Tcl_SplitPath _ANSI_ARGS_((CONST char * path, int * argcPtr, char *** argvPtr)); /* 244 */ EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp * interp, @@ -756,8 +756,8 @@ EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp * interp, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 245 */ -EXTERN int Tcl_StringMatch _ANSI_ARGS_((char * string, - char * pattern)); +EXTERN int Tcl_StringMatch _ANSI_ARGS_((CONST char * str, + CONST char * pattern)); /* 246 */ EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan)); /* 247 */ @@ -844,7 +844,7 @@ EXTERN void Tcl_AppendStringsToObjVA _ANSI_ARGS_(( EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 270 */ EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, - char * string, char ** termPtr)); + char * str, char ** termPtr)); /* 271 */ EXTERN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact)); @@ -868,10 +868,256 @@ EXTERN int Tcl_VarEvalVA _ANSI_ARGS_((Tcl_Interp * interp, EXTERN Tcl_Pid Tcl_WaitPid _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 278 */ -EXTERN void panicVA _ANSI_ARGS_((char * format, va_list argList)); +EXTERN void Tcl_PanicVA _ANSI_ARGS_((char * format, + va_list argList)); /* 279 */ EXTERN void Tcl_GetVersion _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); +/* 280 */ +EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp * interp)); +/* Slot 281 is reserved */ +/* Slot 282 is reserved */ +/* Slot 283 is reserved */ +/* Slot 284 is reserved */ +/* Slot 285 is reserved */ +/* 286 */ +EXTERN void Tcl_AppendObjToObj _ANSI_ARGS_((Tcl_Obj * objPtr, + Tcl_Obj * appendObjPtr)); +/* 287 */ +EXTERN Tcl_Encoding Tcl_CreateEncoding _ANSI_ARGS_(( + Tcl_EncodingType * typePtr)); +/* 288 */ +EXTERN void Tcl_CreateThreadExitHandler _ANSI_ARGS_(( + Tcl_ExitProc * proc, ClientData clientData)); +/* 289 */ +EXTERN void Tcl_DeleteThreadExitHandler _ANSI_ARGS_(( + Tcl_ExitProc * proc, ClientData clientData)); +/* 290 */ +EXTERN void Tcl_DiscardResult _ANSI_ARGS_(( + Tcl_SavedResult * statePtr)); +/* 291 */ +EXTERN int Tcl_EvalEx _ANSI_ARGS_((Tcl_Interp * interp, + char * script, int numBytes, int flags)); +/* 292 */ +EXTERN int Tcl_EvalObjv _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[], int flags)); +/* 293 */ +EXTERN int Tcl_EvalObjEx _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * objPtr, int flags)); +/* 294 */ +EXTERN void Tcl_ExitThread _ANSI_ARGS_((int status)); +/* 295 */ +EXTERN int Tcl_ExternalToUtf _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Encoding encoding, CONST char * src, + int srcLen, int flags, + Tcl_EncodingState * statePtr, char * dst, + int dstLen, int * srcReadPtr, + int * dstWrotePtr, int * dstCharsPtr)); +/* 296 */ +EXTERN char * Tcl_ExternalToUtfDString _ANSI_ARGS_(( + Tcl_Encoding encoding, CONST char * src, + int srcLen, Tcl_DString * dsPtr)); +/* 297 */ +EXTERN void Tcl_FinalizeThread _ANSI_ARGS_((void)); +/* 298 */ +EXTERN void Tcl_FinalizeNotifier _ANSI_ARGS_(( + ClientData clientData)); +/* 299 */ +EXTERN void Tcl_FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); +/* 300 */ +EXTERN Tcl_ThreadId Tcl_GetCurrentThread _ANSI_ARGS_((void)); +/* 301 */ +EXTERN Tcl_Encoding Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * name)); +/* 302 */ +EXTERN char * Tcl_GetEncodingName _ANSI_ARGS_(( + Tcl_Encoding encoding)); +/* 303 */ +EXTERN void Tcl_GetEncodingNames _ANSI_ARGS_(( + Tcl_Interp * interp)); +/* 304 */ +EXTERN int Tcl_GetIndexFromObjStruct _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * objPtr, + char ** tablePtr, int offset, char * msg, + int flags, int * indexPtr)); +/* 305 */ +EXTERN VOID * Tcl_GetThreadData _ANSI_ARGS_(( + Tcl_ThreadDataKey * keyPtr, int size)); +/* 306 */ +EXTERN Tcl_Obj * Tcl_GetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, + char * part1, char * part2, int flags)); +/* 307 */ +EXTERN ClientData Tcl_InitNotifier _ANSI_ARGS_((void)); +/* 308 */ +EXTERN void Tcl_MutexLock _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); +/* 309 */ +EXTERN void Tcl_MutexUnlock _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); +/* 310 */ +EXTERN void Tcl_ConditionNotify _ANSI_ARGS_(( + Tcl_Condition * condPtr)); +/* 311 */ +EXTERN void Tcl_ConditionWait _ANSI_ARGS_(( + Tcl_Condition * condPtr, + Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); +/* 312 */ +EXTERN int Tcl_NumUtfChars _ANSI_ARGS_((CONST char * src, + int len)); +/* 313 */ +EXTERN int Tcl_ReadChars _ANSI_ARGS_((Tcl_Channel channel, + Tcl_Obj * objPtr, int charsToRead, + int appendFlag)); +/* 314 */ +EXTERN void Tcl_RestoreResult _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_SavedResult * statePtr)); +/* 315 */ +EXTERN void Tcl_SaveResult _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_SavedResult * statePtr)); +/* 316 */ +EXTERN int Tcl_SetSystemEncoding _ANSI_ARGS_(( + Tcl_Interp * interp, CONST char * name)); +/* 317 */ +EXTERN Tcl_Obj * Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, + char * part1, char * part2, + Tcl_Obj * newValuePtr, int flags)); +/* 318 */ +EXTERN void Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId)); +/* 319 */ +EXTERN void Tcl_ThreadQueueEvent _ANSI_ARGS_(( + Tcl_ThreadId threadId, Tcl_Event* evPtr, + Tcl_QueuePosition position)); +/* 320 */ +EXTERN Tcl_UniChar Tcl_UniCharAtIndex _ANSI_ARGS_((CONST char * src, + int index)); +/* 321 */ +EXTERN Tcl_UniChar Tcl_UniCharToLower _ANSI_ARGS_((int ch)); +/* 322 */ +EXTERN Tcl_UniChar Tcl_UniCharToTitle _ANSI_ARGS_((int ch)); +/* 323 */ +EXTERN Tcl_UniChar Tcl_UniCharToUpper _ANSI_ARGS_((int ch)); +/* 324 */ +EXTERN int Tcl_UniCharToUtf _ANSI_ARGS_((int ch, char * buf)); +/* 325 */ +EXTERN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src, + int index)); +/* 326 */ +EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, + int len)); +/* 327 */ +EXTERN int Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src, + int * readPtr, char * dst)); +/* 328 */ +EXTERN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char * src, + int ch)); +/* 329 */ +EXTERN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char * src, + int ch)); +/* 330 */ +EXTERN char * Tcl_UtfNext _ANSI_ARGS_((CONST char * src)); +/* 331 */ +EXTERN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char * src, + CONST char * start)); +/* 332 */ +EXTERN int Tcl_UtfToExternal _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Encoding encoding, CONST char * src, + int srcLen, int flags, + Tcl_EncodingState * statePtr, char * dst, + int dstLen, int * srcReadPtr, + int * dstWrotePtr, int * dstCharsPtr)); +/* 333 */ +EXTERN char * Tcl_UtfToExternalDString _ANSI_ARGS_(( + Tcl_Encoding encoding, CONST char * src, + int srcLen, Tcl_DString * dsPtr)); +/* 334 */ +EXTERN int Tcl_UtfToLower _ANSI_ARGS_((char * src)); +/* 335 */ +EXTERN int Tcl_UtfToTitle _ANSI_ARGS_((char * src)); +/* 336 */ +EXTERN int Tcl_UtfToUniChar _ANSI_ARGS_((CONST char * src, + Tcl_UniChar * chPtr)); +/* 337 */ +EXTERN int Tcl_UtfToUpper _ANSI_ARGS_((char * src)); +/* 338 */ +EXTERN int Tcl_WriteChars _ANSI_ARGS_((Tcl_Channel chan, + CONST char * src, int srcLen)); +/* 339 */ +EXTERN int Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan, + Tcl_Obj * objPtr)); +/* 340 */ +EXTERN char * Tcl_GetString _ANSI_ARGS_((Tcl_Obj * objPtr)); +/* 341 */ +EXTERN char * Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void)); +/* 342 */ +EXTERN void Tcl_SetDefaultEncodingDir _ANSI_ARGS_((char * path)); +/* 343 */ +EXTERN void Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData)); +/* 344 */ +EXTERN void Tcl_ServiceModeHook _ANSI_ARGS_((int mode)); +/* 345 */ +EXTERN int Tcl_UniCharIsAlnum _ANSI_ARGS_((int ch)); +/* 346 */ +EXTERN int Tcl_UniCharIsAlpha _ANSI_ARGS_((int ch)); +/* 347 */ +EXTERN int Tcl_UniCharIsDigit _ANSI_ARGS_((int ch)); +/* 348 */ +EXTERN int Tcl_UniCharIsLower _ANSI_ARGS_((int ch)); +/* 349 */ +EXTERN int Tcl_UniCharIsSpace _ANSI_ARGS_((int ch)); +/* 350 */ +EXTERN int Tcl_UniCharIsUpper _ANSI_ARGS_((int ch)); +/* 351 */ +EXTERN int Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch)); +/* 352 */ +EXTERN int Tcl_UniCharLen _ANSI_ARGS_((Tcl_UniChar * str)); +/* 353 */ +EXTERN int Tcl_UniCharNcmp _ANSI_ARGS_((const Tcl_UniChar * cs, + const Tcl_UniChar * ct, size_t n)); +/* 354 */ +EXTERN char * Tcl_UniCharToUtfDString _ANSI_ARGS_(( + CONST Tcl_UniChar * string, int numChars, + Tcl_DString * dsPtr)); +/* 355 */ +EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString _ANSI_ARGS_(( + CONST char * string, int length, + Tcl_DString * dsPtr)); +/* 356 */ +EXTERN Tcl_RegExp Tcl_GetRegExpFromObj _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * patObj, + int flags)); +/* 357 */ +EXTERN Tcl_Obj * Tcl_EvalTokens _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Token * tokenPtr, int count)); +/* 358 */ +EXTERN void Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse * parsePtr)); +/* 359 */ +EXTERN void Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, + char * script, char * command, int length)); +/* 360 */ +EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, + char * string, int numBytes, + Tcl_Parse * parsePtr, int append, + char ** termPtr)); +/* 361 */ +EXTERN int Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp, + char * string, int numBytes, int nested, + Tcl_Parse * parsePtr)); +/* 362 */ +EXTERN int Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp, + char * string, int numBytes, + Tcl_Parse * parsePtr)); +/* 363 */ +EXTERN int Tcl_ParseQuotedString _ANSI_ARGS_(( + Tcl_Interp * interp, char * string, + int numBytes, Tcl_Parse * parsePtr, + int append, char ** termPtr)); +/* 364 */ +EXTERN int Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp, + char * string, int numBytes, + Tcl_Parse * parsePtr, int append)); +/* 365 */ +EXTERN char * Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_DString * cwdPtr)); +/* 366 */ +EXTERN int Tcl_Chdir _ANSI_ARGS_((CONST char * dirName)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -885,7 +1131,7 @@ typedef struct TclStubs { int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, ClientData clientData)); /* 0 */ char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 1 */ - void (*panic) _ANSI_ARGS_(TCL_VARARGS(char *,format)); /* 2 */ + void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(char *,format)); /* 2 */ char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */ void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */ char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */ @@ -927,16 +1173,16 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[], char * file, int line)); /* 25 */ Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, char * file, int line)); /* 26 */ Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((char * file, int line)); /* 27 */ - Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((char * bytes, int length, char * file, int line)); /* 28 */ + Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, char * file, int line)); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 29 */ void (*tclFreeObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 30 */ - int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int * boolPtr)); /* 31 */ + int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * boolPtr)); /* 31 */ int (*tcl_GetBooleanFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * boolPtr)); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 33 */ - int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * string, double * doublePtr)); /* 34 */ + int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * str, double * doublePtr)); /* 34 */ int (*tcl_GetDoubleFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); /* 35 */ int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, char ** tablePtr, char * msg, int flags, int * indexPtr)); /* 36 */ - int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int * intPtr)); /* 37 */ + int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * intPtr)); /* 37 */ int (*tcl_GetIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); /* 38 */ int (*tcl_GetLongFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr)); /* 39 */ Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((char * typeName)); /* 40 */ @@ -955,7 +1201,7 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 53 */ Tcl_Obj * (*tcl_NewLongObj) _ANSI_ARGS_((long longValue)); /* 54 */ Tcl_Obj * (*tcl_NewObj) _ANSI_ARGS_((void)); /* 55 */ - Tcl_Obj * (*tcl_NewStringObj) _ANSI_ARGS_((char * bytes, int length)); /* 56 */ + Tcl_Obj * (*tcl_NewStringObj) _ANSI_ARGS_((CONST char * bytes, int length)); /* 56 */ void (*tcl_SetBooleanObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int boolValue)); /* 57 */ unsigned char * (*tcl_SetByteArrayLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 58 */ void (*tcl_SetByteArrayObj) _ANSI_ARGS_((Tcl_Obj * objPtr, unsigned char * bytes, int length)); /* 59 */ @@ -965,10 +1211,10 @@ typedef struct TclStubs { void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */ void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */ void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj * objPtr, char * bytes, int length)); /* 65 */ - void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * message)); /* 66 */ - void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * message, int length)); /* 67 */ + void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */ + void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */ void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */ - void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 69 */ + void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 69 */ void (*tcl_AppendResult) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 70 */ Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */ void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */ @@ -1016,7 +1262,7 @@ typedef struct TclStubs { void (*tcl_DontCallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 114 */ int (*tcl_DoOneEvent) _ANSI_ARGS_((int flags)); /* 115 */ void (*tcl_DoWhenIdle) _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); /* 116 */ - char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * string, int length)); /* 117 */ + char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * str, int length)); /* 117 */ char * (*tcl_DStringAppendElement) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * string)); /* 118 */ void (*tcl_DStringEndSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 119 */ void (*tcl_DStringFree) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 120 */ @@ -1034,16 +1280,16 @@ typedef struct TclStubs { 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 * string, int * ptr)); /* 135 */ + int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, 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 * string, double * ptr)); /* 137 */ + int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, 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 * string, long * ptr)); /* 139 */ + int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, 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 */ void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */ - void (*tcl_FindExecutable) _ANSI_ARGS_((char * argv0)); /* 144 */ + void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */ Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */ int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */ void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */ @@ -1067,7 +1313,7 @@ typedef struct TclStubs { CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ - int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int write, int checkUsage, ClientData * filePtr)); /* 167 */ + int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int write, int checkUsage, ClientData * filePtr)); /* 167 */ #endif /* UNIX */ #ifdef __WIN32__ void *reserved167; @@ -1120,13 +1366,13 @@ typedef struct TclStubs { void (*tcl_RegisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 210 */ void (*tcl_RegisterObjType) _ANSI_ARGS_((Tcl_ObjType * typePtr)); /* 211 */ Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 212 */ - int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, char * string, char * start)); /* 213 */ - int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char * pattern)); /* 214 */ + int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * str, CONST char * start)); /* 213 */ + int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * pattern)); /* 214 */ void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, char ** startPtr, char ** endPtr)); /* 215 */ void (*tcl_Release) _ANSI_ARGS_((ClientData clientData)); /* 216 */ void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 217 */ - int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * string, int * flagPtr)); /* 218 */ - int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * string, int length, int * flagPtr)); /* 219 */ + int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 218 */ + int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 219 */ 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 */ @@ -1139,7 +1385,7 @@ typedef struct TclStubs { void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */ void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */ int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */ - void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * string, Tcl_FreeProc * freeProc)); /* 232 */ + void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * str, Tcl_FreeProc * freeProc)); /* 232 */ int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */ void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */ void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */ @@ -1149,10 +1395,10 @@ typedef struct TclStubs { char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */ char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */ void (*tcl_SourceRCFile) _ANSI_ARGS_((Tcl_Interp * interp)); /* 241 */ - int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, char * list, int * argcPtr, char *** argvPtr)); /* 242 */ - void (*tcl_SplitPath) _ANSI_ARGS_((char * path, int * argcPtr, char *** argvPtr)); /* 243 */ + int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, char *** argvPtr)); /* 242 */ + void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, char *** argvPtr)); /* 243 */ void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */ - int (*tcl_StringMatch) _ANSI_ARGS_((char * string, char * pattern)); /* 245 */ + int (*tcl_StringMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 245 */ int (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */ int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */ int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */ @@ -1177,7 +1423,7 @@ typedef struct TclStubs { void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */ void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj * objPtr, va_list argList)); /* 268 */ char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */ - char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char ** termPtr)); /* 270 */ + char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char ** termPtr)); /* 270 */ char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact)); /* 271 */ char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 272 */ int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version)); /* 273 */ @@ -1185,8 +1431,95 @@ typedef struct TclStubs { void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */ int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */ Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 277 */ - void (*panicVA) _ANSI_ARGS_((char * format, va_list argList)); /* 278 */ + void (*tcl_PanicVA) _ANSI_ARGS_((char * format, va_list argList)); /* 278 */ void (*tcl_GetVersion) _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); /* 279 */ + void (*tcl_InitMemory) _ANSI_ARGS_((Tcl_Interp * interp)); /* 280 */ + void *reserved281; + void *reserved282; + void *reserved283; + void *reserved284; + void *reserved285; + void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_Obj * appendObjPtr)); /* 286 */ + Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType * typePtr)); /* 287 */ + void (*tcl_CreateThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 288 */ + void (*tcl_DeleteThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 289 */ + void (*tcl_DiscardResult) _ANSI_ARGS_((Tcl_SavedResult * statePtr)); /* 290 */ + int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp * interp, char * script, int numBytes, int flags)); /* 291 */ + int (*tcl_EvalObjv) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 292 */ + int (*tcl_EvalObjEx) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 293 */ + void (*tcl_ExitThread) _ANSI_ARGS_((int status)); /* 294 */ + int (*tcl_ExternalToUtf) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 295 */ + char * (*tcl_ExternalToUtfDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 296 */ + void (*tcl_FinalizeThread) _ANSI_ARGS_((void)); /* 297 */ + void (*tcl_FinalizeNotifier) _ANSI_ARGS_((ClientData clientData)); /* 298 */ + void (*tcl_FreeEncoding) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 299 */ + Tcl_ThreadId (*tcl_GetCurrentThread) _ANSI_ARGS_((void)); /* 300 */ + Tcl_Encoding (*tcl_GetEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 301 */ + char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */ + void (*tcl_GetEncodingNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 303 */ + int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, char ** tablePtr, int offset, char * msg, int flags, int * indexPtr)); /* 304 */ + VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, int size)); /* 305 */ + Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags)); /* 306 */ + ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */ + void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */ + void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */ + void (*tcl_ConditionNotify) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 310 */ + void (*tcl_ConditionWait) _ANSI_ARGS_((Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); /* 311 */ + int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char * src, int len)); /* 312 */ + int (*tcl_ReadChars) _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj * objPtr, int charsToRead, int appendFlag)); /* 313 */ + void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */ + void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */ + int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */ + Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */ + void (*tcl_ThreadAlert) _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 318 */ + void (*tcl_ThreadQueueEvent) _ANSI_ARGS_((Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position)); /* 319 */ + Tcl_UniChar (*tcl_UniCharAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 320 */ + Tcl_UniChar (*tcl_UniCharToLower) _ANSI_ARGS_((int ch)); /* 321 */ + Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */ + Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */ + int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char * buf)); /* 324 */ + char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */ + int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int len)); /* 326 */ + int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */ + char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */ + char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */ + char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */ + char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */ + int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 332 */ + char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 333 */ + int (*tcl_UtfToLower) _ANSI_ARGS_((char * src)); /* 334 */ + int (*tcl_UtfToTitle) _ANSI_ARGS_((char * src)); /* 335 */ + int (*tcl_UtfToUniChar) _ANSI_ARGS_((CONST char * src, Tcl_UniChar * chPtr)); /* 336 */ + int (*tcl_UtfToUpper) _ANSI_ARGS_((char * src)); /* 337 */ + int (*tcl_WriteChars) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 338 */ + int (*tcl_WriteObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 339 */ + char * (*tcl_GetString) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 340 */ + char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */ + void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((char * path)); /* 342 */ + void (*tcl_AlertNotifier) _ANSI_ARGS_((ClientData clientData)); /* 343 */ + void (*tcl_ServiceModeHook) _ANSI_ARGS_((int mode)); /* 344 */ + int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */ + int (*tcl_UniCharIsAlpha) _ANSI_ARGS_((int ch)); /* 346 */ + int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */ + int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */ + int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */ + int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */ + int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */ + int (*tcl_UniCharLen) _ANSI_ARGS_((Tcl_UniChar * str)); /* 352 */ + int (*tcl_UniCharNcmp) _ANSI_ARGS_((const Tcl_UniChar * cs, const Tcl_UniChar * ct, size_t n)); /* 353 */ + char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */ + Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */ + Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */ + Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */ + void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */ + void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * script, char * command, int length)); /* 359 */ + int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 360 */ + int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */ + int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */ + int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 363 */ + int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */ + char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */ + int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */ } TclStubs; extern TclStubs *tclStubsPtr; @@ -1198,1127 +1531,1460 @@ extern TclStubs *tclStubsPtr; */ #ifndef Tcl_PkgProvideEx -#define Tcl_PkgProvideEx(interp, name, version, clientData) \ - (tclStubsPtr->tcl_PkgProvideEx)(interp, name, version, clientData) /* 0 */ +#define Tcl_PkgProvideEx \ + (tclStubsPtr->tcl_PkgProvideEx) /* 0 */ #endif #ifndef Tcl_PkgRequireEx -#define Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) \ - (tclStubsPtr->tcl_PkgRequireEx)(interp, name, version, exact, clientDataPtr) /* 1 */ +#define Tcl_PkgRequireEx \ + (tclStubsPtr->tcl_PkgRequireEx) /* 1 */ #endif -#ifndef panic -#define panic \ - (tclStubsPtr->panic) /* 2 */ +#ifndef Tcl_Panic +#define Tcl_Panic \ + (tclStubsPtr->tcl_Panic) /* 2 */ #endif #ifndef Tcl_Alloc -#define Tcl_Alloc(size) \ - (tclStubsPtr->tcl_Alloc)(size) /* 3 */ +#define Tcl_Alloc \ + (tclStubsPtr->tcl_Alloc) /* 3 */ #endif #ifndef Tcl_Free -#define Tcl_Free(ptr) \ - (tclStubsPtr->tcl_Free)(ptr) /* 4 */ +#define Tcl_Free \ + (tclStubsPtr->tcl_Free) /* 4 */ #endif #ifndef Tcl_Realloc -#define Tcl_Realloc(ptr, size) \ - (tclStubsPtr->tcl_Realloc)(ptr, size) /* 5 */ +#define Tcl_Realloc \ + (tclStubsPtr->tcl_Realloc) /* 5 */ #endif #ifndef Tcl_DbCkalloc -#define Tcl_DbCkalloc(size, file, line) \ - (tclStubsPtr->tcl_DbCkalloc)(size, file, line) /* 6 */ +#define Tcl_DbCkalloc \ + (tclStubsPtr->tcl_DbCkalloc) /* 6 */ #endif #ifndef Tcl_DbCkfree -#define Tcl_DbCkfree(ptr, file, line) \ - (tclStubsPtr->tcl_DbCkfree)(ptr, file, line) /* 7 */ +#define Tcl_DbCkfree \ + (tclStubsPtr->tcl_DbCkfree) /* 7 */ #endif #ifndef Tcl_DbCkrealloc -#define Tcl_DbCkrealloc(ptr, size, file, line) \ - (tclStubsPtr->tcl_DbCkrealloc)(ptr, size, file, line) /* 8 */ +#define Tcl_DbCkrealloc \ + (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ #endif #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_CreateFileHandler -#define Tcl_CreateFileHandler(fd, mask, proc, clientData) \ - (tclStubsPtr->tcl_CreateFileHandler)(fd, mask, proc, clientData) /* 9 */ +#define Tcl_CreateFileHandler \ + (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ #endif #endif /* UNIX */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_DeleteFileHandler -#define Tcl_DeleteFileHandler(fd) \ - (tclStubsPtr->tcl_DeleteFileHandler)(fd) /* 10 */ +#define Tcl_DeleteFileHandler \ + (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ #endif #endif /* UNIX */ #ifndef Tcl_SetTimer -#define Tcl_SetTimer(timePtr) \ - (tclStubsPtr->tcl_SetTimer)(timePtr) /* 11 */ +#define Tcl_SetTimer \ + (tclStubsPtr->tcl_SetTimer) /* 11 */ #endif #ifndef Tcl_Sleep -#define Tcl_Sleep(ms) \ - (tclStubsPtr->tcl_Sleep)(ms) /* 12 */ +#define Tcl_Sleep \ + (tclStubsPtr->tcl_Sleep) /* 12 */ #endif #ifndef Tcl_WaitForEvent -#define Tcl_WaitForEvent(timePtr) \ - (tclStubsPtr->tcl_WaitForEvent)(timePtr) /* 13 */ +#define Tcl_WaitForEvent \ + (tclStubsPtr->tcl_WaitForEvent) /* 13 */ #endif #ifndef Tcl_AppendAllObjTypes -#define Tcl_AppendAllObjTypes(interp, objPtr) \ - (tclStubsPtr->tcl_AppendAllObjTypes)(interp, objPtr) /* 14 */ +#define Tcl_AppendAllObjTypes \ + (tclStubsPtr->tcl_AppendAllObjTypes) /* 14 */ #endif #ifndef Tcl_AppendStringsToObj #define Tcl_AppendStringsToObj \ (tclStubsPtr->tcl_AppendStringsToObj) /* 15 */ #endif #ifndef Tcl_AppendToObj -#define Tcl_AppendToObj(objPtr, bytes, length) \ - (tclStubsPtr->tcl_AppendToObj)(objPtr, bytes, length) /* 16 */ +#define Tcl_AppendToObj \ + (tclStubsPtr->tcl_AppendToObj) /* 16 */ #endif #ifndef Tcl_ConcatObj -#define Tcl_ConcatObj(objc, objv) \ - (tclStubsPtr->tcl_ConcatObj)(objc, objv) /* 17 */ +#define Tcl_ConcatObj \ + (tclStubsPtr->tcl_ConcatObj) /* 17 */ #endif #ifndef Tcl_ConvertToType -#define Tcl_ConvertToType(interp, objPtr, typePtr) \ - (tclStubsPtr->tcl_ConvertToType)(interp, objPtr, typePtr) /* 18 */ +#define Tcl_ConvertToType \ + (tclStubsPtr->tcl_ConvertToType) /* 18 */ #endif #ifndef Tcl_DbDecrRefCount -#define Tcl_DbDecrRefCount(objPtr, file, line) \ - (tclStubsPtr->tcl_DbDecrRefCount)(objPtr, file, line) /* 19 */ +#define Tcl_DbDecrRefCount \ + (tclStubsPtr->tcl_DbDecrRefCount) /* 19 */ #endif #ifndef Tcl_DbIncrRefCount -#define Tcl_DbIncrRefCount(objPtr, file, line) \ - (tclStubsPtr->tcl_DbIncrRefCount)(objPtr, file, line) /* 20 */ +#define Tcl_DbIncrRefCount \ + (tclStubsPtr->tcl_DbIncrRefCount) /* 20 */ #endif #ifndef Tcl_DbIsShared -#define Tcl_DbIsShared(objPtr, file, line) \ - (tclStubsPtr->tcl_DbIsShared)(objPtr, file, line) /* 21 */ +#define Tcl_DbIsShared \ + (tclStubsPtr->tcl_DbIsShared) /* 21 */ #endif #ifndef Tcl_DbNewBooleanObj -#define Tcl_DbNewBooleanObj(boolValue, file, line) \ - (tclStubsPtr->tcl_DbNewBooleanObj)(boolValue, file, line) /* 22 */ +#define Tcl_DbNewBooleanObj \ + (tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */ #endif #ifndef Tcl_DbNewByteArrayObj -#define Tcl_DbNewByteArrayObj(bytes, length, file, line) \ - (tclStubsPtr->tcl_DbNewByteArrayObj)(bytes, length, file, line) /* 23 */ +#define Tcl_DbNewByteArrayObj \ + (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */ #endif #ifndef Tcl_DbNewDoubleObj -#define Tcl_DbNewDoubleObj(doubleValue, file, line) \ - (tclStubsPtr->tcl_DbNewDoubleObj)(doubleValue, file, line) /* 24 */ +#define Tcl_DbNewDoubleObj \ + (tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */ #endif #ifndef Tcl_DbNewListObj -#define Tcl_DbNewListObj(objc, objv, file, line) \ - (tclStubsPtr->tcl_DbNewListObj)(objc, objv, file, line) /* 25 */ +#define Tcl_DbNewListObj \ + (tclStubsPtr->tcl_DbNewListObj) /* 25 */ #endif #ifndef Tcl_DbNewLongObj -#define Tcl_DbNewLongObj(longValue, file, line) \ - (tclStubsPtr->tcl_DbNewLongObj)(longValue, file, line) /* 26 */ +#define Tcl_DbNewLongObj \ + (tclStubsPtr->tcl_DbNewLongObj) /* 26 */ #endif #ifndef Tcl_DbNewObj -#define Tcl_DbNewObj(file, line) \ - (tclStubsPtr->tcl_DbNewObj)(file, line) /* 27 */ +#define Tcl_DbNewObj \ + (tclStubsPtr->tcl_DbNewObj) /* 27 */ #endif #ifndef Tcl_DbNewStringObj -#define Tcl_DbNewStringObj(bytes, length, file, line) \ - (tclStubsPtr->tcl_DbNewStringObj)(bytes, length, file, line) /* 28 */ +#define Tcl_DbNewStringObj \ + (tclStubsPtr->tcl_DbNewStringObj) /* 28 */ #endif #ifndef Tcl_DuplicateObj -#define Tcl_DuplicateObj(objPtr) \ - (tclStubsPtr->tcl_DuplicateObj)(objPtr) /* 29 */ +#define Tcl_DuplicateObj \ + (tclStubsPtr->tcl_DuplicateObj) /* 29 */ #endif #ifndef TclFreeObj -#define TclFreeObj(objPtr) \ - (tclStubsPtr->tclFreeObj)(objPtr) /* 30 */ +#define TclFreeObj \ + (tclStubsPtr->tclFreeObj) /* 30 */ #endif #ifndef Tcl_GetBoolean -#define Tcl_GetBoolean(interp, string, boolPtr) \ - (tclStubsPtr->tcl_GetBoolean)(interp, string, boolPtr) /* 31 */ +#define Tcl_GetBoolean \ + (tclStubsPtr->tcl_GetBoolean) /* 31 */ #endif #ifndef Tcl_GetBooleanFromObj -#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - (tclStubsPtr->tcl_GetBooleanFromObj)(interp, objPtr, boolPtr) /* 32 */ +#define Tcl_GetBooleanFromObj \ + (tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */ #endif #ifndef Tcl_GetByteArrayFromObj -#define Tcl_GetByteArrayFromObj(objPtr, lengthPtr) \ - (tclStubsPtr->tcl_GetByteArrayFromObj)(objPtr, lengthPtr) /* 33 */ +#define Tcl_GetByteArrayFromObj \ + (tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */ #endif #ifndef Tcl_GetDouble -#define Tcl_GetDouble(interp, string, doublePtr) \ - (tclStubsPtr->tcl_GetDouble)(interp, string, doublePtr) /* 34 */ +#define Tcl_GetDouble \ + (tclStubsPtr->tcl_GetDouble) /* 34 */ #endif #ifndef Tcl_GetDoubleFromObj -#define Tcl_GetDoubleFromObj(interp, objPtr, doublePtr) \ - (tclStubsPtr->tcl_GetDoubleFromObj)(interp, objPtr, doublePtr) /* 35 */ +#define Tcl_GetDoubleFromObj \ + (tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */ #endif #ifndef Tcl_GetIndexFromObj -#define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \ - (tclStubsPtr->tcl_GetIndexFromObj)(interp, objPtr, tablePtr, msg, flags, indexPtr) /* 36 */ +#define Tcl_GetIndexFromObj \ + (tclStubsPtr->tcl_GetIndexFromObj) /* 36 */ #endif #ifndef Tcl_GetInt -#define Tcl_GetInt(interp, string, intPtr) \ - (tclStubsPtr->tcl_GetInt)(interp, string, intPtr) /* 37 */ +#define Tcl_GetInt \ + (tclStubsPtr->tcl_GetInt) /* 37 */ #endif #ifndef Tcl_GetIntFromObj -#define Tcl_GetIntFromObj(interp, objPtr, intPtr) \ - (tclStubsPtr->tcl_GetIntFromObj)(interp, objPtr, intPtr) /* 38 */ +#define Tcl_GetIntFromObj \ + (tclStubsPtr->tcl_GetIntFromObj) /* 38 */ #endif #ifndef Tcl_GetLongFromObj -#define Tcl_GetLongFromObj(interp, objPtr, longPtr) \ - (tclStubsPtr->tcl_GetLongFromObj)(interp, objPtr, longPtr) /* 39 */ +#define Tcl_GetLongFromObj \ + (tclStubsPtr->tcl_GetLongFromObj) /* 39 */ #endif #ifndef Tcl_GetObjType -#define Tcl_GetObjType(typeName) \ - (tclStubsPtr->tcl_GetObjType)(typeName) /* 40 */ +#define Tcl_GetObjType \ + (tclStubsPtr->tcl_GetObjType) /* 40 */ #endif #ifndef Tcl_GetStringFromObj -#define Tcl_GetStringFromObj(objPtr, lengthPtr) \ - (tclStubsPtr->tcl_GetStringFromObj)(objPtr, lengthPtr) /* 41 */ +#define Tcl_GetStringFromObj \ + (tclStubsPtr->tcl_GetStringFromObj) /* 41 */ #endif #ifndef Tcl_InvalidateStringRep -#define Tcl_InvalidateStringRep(objPtr) \ - (tclStubsPtr->tcl_InvalidateStringRep)(objPtr) /* 42 */ +#define Tcl_InvalidateStringRep \ + (tclStubsPtr->tcl_InvalidateStringRep) /* 42 */ #endif #ifndef Tcl_ListObjAppendList -#define Tcl_ListObjAppendList(interp, listPtr, elemListPtr) \ - (tclStubsPtr->tcl_ListObjAppendList)(interp, listPtr, elemListPtr) /* 43 */ +#define Tcl_ListObjAppendList \ + (tclStubsPtr->tcl_ListObjAppendList) /* 43 */ #endif #ifndef Tcl_ListObjAppendElement -#define Tcl_ListObjAppendElement(interp, listPtr, objPtr) \ - (tclStubsPtr->tcl_ListObjAppendElement)(interp, listPtr, objPtr) /* 44 */ +#define Tcl_ListObjAppendElement \ + (tclStubsPtr->tcl_ListObjAppendElement) /* 44 */ #endif #ifndef Tcl_ListObjGetElements -#define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) \ - (tclStubsPtr->tcl_ListObjGetElements)(interp, listPtr, objcPtr, objvPtr) /* 45 */ +#define Tcl_ListObjGetElements \ + (tclStubsPtr->tcl_ListObjGetElements) /* 45 */ #endif #ifndef Tcl_ListObjIndex -#define Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr) \ - (tclStubsPtr->tcl_ListObjIndex)(interp, listPtr, index, objPtrPtr) /* 46 */ +#define Tcl_ListObjIndex \ + (tclStubsPtr->tcl_ListObjIndex) /* 46 */ #endif #ifndef Tcl_ListObjLength -#define Tcl_ListObjLength(interp, listPtr, intPtr) \ - (tclStubsPtr->tcl_ListObjLength)(interp, listPtr, intPtr) /* 47 */ +#define Tcl_ListObjLength \ + (tclStubsPtr->tcl_ListObjLength) /* 47 */ #endif #ifndef Tcl_ListObjReplace -#define Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv) \ - (tclStubsPtr->tcl_ListObjReplace)(interp, listPtr, first, count, objc, objv) /* 48 */ +#define Tcl_ListObjReplace \ + (tclStubsPtr->tcl_ListObjReplace) /* 48 */ #endif #ifndef Tcl_NewBooleanObj -#define Tcl_NewBooleanObj(boolValue) \ - (tclStubsPtr->tcl_NewBooleanObj)(boolValue) /* 49 */ +#define Tcl_NewBooleanObj \ + (tclStubsPtr->tcl_NewBooleanObj) /* 49 */ #endif #ifndef Tcl_NewByteArrayObj -#define Tcl_NewByteArrayObj(bytes, length) \ - (tclStubsPtr->tcl_NewByteArrayObj)(bytes, length) /* 50 */ +#define Tcl_NewByteArrayObj \ + (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ #endif #ifndef Tcl_NewDoubleObj -#define Tcl_NewDoubleObj(doubleValue) \ - (tclStubsPtr->tcl_NewDoubleObj)(doubleValue) /* 51 */ +#define Tcl_NewDoubleObj \ + (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ #endif #ifndef Tcl_NewIntObj -#define Tcl_NewIntObj(intValue) \ - (tclStubsPtr->tcl_NewIntObj)(intValue) /* 52 */ +#define Tcl_NewIntObj \ + (tclStubsPtr->tcl_NewIntObj) /* 52 */ #endif #ifndef Tcl_NewListObj -#define Tcl_NewListObj(objc, objv) \ - (tclStubsPtr->tcl_NewListObj)(objc, objv) /* 53 */ +#define Tcl_NewListObj \ + (tclStubsPtr->tcl_NewListObj) /* 53 */ #endif #ifndef Tcl_NewLongObj -#define Tcl_NewLongObj(longValue) \ - (tclStubsPtr->tcl_NewLongObj)(longValue) /* 54 */ +#define Tcl_NewLongObj \ + (tclStubsPtr->tcl_NewLongObj) /* 54 */ #endif #ifndef Tcl_NewObj -#define Tcl_NewObj() \ - (tclStubsPtr->tcl_NewObj)() /* 55 */ +#define Tcl_NewObj \ + (tclStubsPtr->tcl_NewObj) /* 55 */ #endif #ifndef Tcl_NewStringObj -#define Tcl_NewStringObj(bytes, length) \ - (tclStubsPtr->tcl_NewStringObj)(bytes, length) /* 56 */ +#define Tcl_NewStringObj \ + (tclStubsPtr->tcl_NewStringObj) /* 56 */ #endif #ifndef Tcl_SetBooleanObj -#define Tcl_SetBooleanObj(objPtr, boolValue) \ - (tclStubsPtr->tcl_SetBooleanObj)(objPtr, boolValue) /* 57 */ +#define Tcl_SetBooleanObj \ + (tclStubsPtr->tcl_SetBooleanObj) /* 57 */ #endif #ifndef Tcl_SetByteArrayLength -#define Tcl_SetByteArrayLength(objPtr, length) \ - (tclStubsPtr->tcl_SetByteArrayLength)(objPtr, length) /* 58 */ +#define Tcl_SetByteArrayLength \ + (tclStubsPtr->tcl_SetByteArrayLength) /* 58 */ #endif #ifndef Tcl_SetByteArrayObj -#define Tcl_SetByteArrayObj(objPtr, bytes, length) \ - (tclStubsPtr->tcl_SetByteArrayObj)(objPtr, bytes, length) /* 59 */ +#define Tcl_SetByteArrayObj \ + (tclStubsPtr->tcl_SetByteArrayObj) /* 59 */ #endif #ifndef Tcl_SetDoubleObj -#define Tcl_SetDoubleObj(objPtr, doubleValue) \ - (tclStubsPtr->tcl_SetDoubleObj)(objPtr, doubleValue) /* 60 */ +#define Tcl_SetDoubleObj \ + (tclStubsPtr->tcl_SetDoubleObj) /* 60 */ #endif #ifndef Tcl_SetIntObj -#define Tcl_SetIntObj(objPtr, intValue) \ - (tclStubsPtr->tcl_SetIntObj)(objPtr, intValue) /* 61 */ +#define Tcl_SetIntObj \ + (tclStubsPtr->tcl_SetIntObj) /* 61 */ #endif #ifndef Tcl_SetListObj -#define Tcl_SetListObj(objPtr, objc, objv) \ - (tclStubsPtr->tcl_SetListObj)(objPtr, objc, objv) /* 62 */ +#define Tcl_SetListObj \ + (tclStubsPtr->tcl_SetListObj) /* 62 */ #endif #ifndef Tcl_SetLongObj -#define Tcl_SetLongObj(objPtr, longValue) \ - (tclStubsPtr->tcl_SetLongObj)(objPtr, longValue) /* 63 */ +#define Tcl_SetLongObj \ + (tclStubsPtr->tcl_SetLongObj) /* 63 */ #endif #ifndef Tcl_SetObjLength -#define Tcl_SetObjLength(objPtr, length) \ - (tclStubsPtr->tcl_SetObjLength)(objPtr, length) /* 64 */ +#define Tcl_SetObjLength \ + (tclStubsPtr->tcl_SetObjLength) /* 64 */ #endif #ifndef Tcl_SetStringObj -#define Tcl_SetStringObj(objPtr, bytes, length) \ - (tclStubsPtr->tcl_SetStringObj)(objPtr, bytes, length) /* 65 */ +#define Tcl_SetStringObj \ + (tclStubsPtr->tcl_SetStringObj) /* 65 */ #endif #ifndef Tcl_AddErrorInfo -#define Tcl_AddErrorInfo(interp, message) \ - (tclStubsPtr->tcl_AddErrorInfo)(interp, message) /* 66 */ +#define Tcl_AddErrorInfo \ + (tclStubsPtr->tcl_AddErrorInfo) /* 66 */ #endif #ifndef Tcl_AddObjErrorInfo -#define Tcl_AddObjErrorInfo(interp, message, length) \ - (tclStubsPtr->tcl_AddObjErrorInfo)(interp, message, length) /* 67 */ +#define Tcl_AddObjErrorInfo \ + (tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */ #endif #ifndef Tcl_AllowExceptions -#define Tcl_AllowExceptions(interp) \ - (tclStubsPtr->tcl_AllowExceptions)(interp) /* 68 */ +#define Tcl_AllowExceptions \ + (tclStubsPtr->tcl_AllowExceptions) /* 68 */ #endif #ifndef Tcl_AppendElement -#define Tcl_AppendElement(interp, string) \ - (tclStubsPtr->tcl_AppendElement)(interp, string) /* 69 */ +#define Tcl_AppendElement \ + (tclStubsPtr->tcl_AppendElement) /* 69 */ #endif #ifndef Tcl_AppendResult #define Tcl_AppendResult \ (tclStubsPtr->tcl_AppendResult) /* 70 */ #endif #ifndef Tcl_AsyncCreate -#define Tcl_AsyncCreate(proc, clientData) \ - (tclStubsPtr->tcl_AsyncCreate)(proc, clientData) /* 71 */ +#define Tcl_AsyncCreate \ + (tclStubsPtr->tcl_AsyncCreate) /* 71 */ #endif #ifndef Tcl_AsyncDelete -#define Tcl_AsyncDelete(async) \ - (tclStubsPtr->tcl_AsyncDelete)(async) /* 72 */ +#define Tcl_AsyncDelete \ + (tclStubsPtr->tcl_AsyncDelete) /* 72 */ #endif #ifndef Tcl_AsyncInvoke -#define Tcl_AsyncInvoke(interp, code) \ - (tclStubsPtr->tcl_AsyncInvoke)(interp, code) /* 73 */ +#define Tcl_AsyncInvoke \ + (tclStubsPtr->tcl_AsyncInvoke) /* 73 */ #endif #ifndef Tcl_AsyncMark -#define Tcl_AsyncMark(async) \ - (tclStubsPtr->tcl_AsyncMark)(async) /* 74 */ +#define Tcl_AsyncMark \ + (tclStubsPtr->tcl_AsyncMark) /* 74 */ #endif #ifndef Tcl_AsyncReady -#define Tcl_AsyncReady() \ - (tclStubsPtr->tcl_AsyncReady)() /* 75 */ +#define Tcl_AsyncReady \ + (tclStubsPtr->tcl_AsyncReady) /* 75 */ #endif #ifndef Tcl_BackgroundError -#define Tcl_BackgroundError(interp) \ - (tclStubsPtr->tcl_BackgroundError)(interp) /* 76 */ +#define Tcl_BackgroundError \ + (tclStubsPtr->tcl_BackgroundError) /* 76 */ #endif #ifndef Tcl_Backslash -#define Tcl_Backslash(src, readPtr) \ - (tclStubsPtr->tcl_Backslash)(src, readPtr) /* 77 */ +#define Tcl_Backslash \ + (tclStubsPtr->tcl_Backslash) /* 77 */ #endif #ifndef Tcl_BadChannelOption -#define Tcl_BadChannelOption(interp, optionName, optionList) \ - (tclStubsPtr->tcl_BadChannelOption)(interp, optionName, optionList) /* 78 */ +#define Tcl_BadChannelOption \ + (tclStubsPtr->tcl_BadChannelOption) /* 78 */ #endif #ifndef Tcl_CallWhenDeleted -#define Tcl_CallWhenDeleted(interp, proc, clientData) \ - (tclStubsPtr->tcl_CallWhenDeleted)(interp, proc, clientData) /* 79 */ +#define Tcl_CallWhenDeleted \ + (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */ #endif #ifndef Tcl_CancelIdleCall -#define Tcl_CancelIdleCall(idleProc, clientData) \ - (tclStubsPtr->tcl_CancelIdleCall)(idleProc, clientData) /* 80 */ +#define Tcl_CancelIdleCall \ + (tclStubsPtr->tcl_CancelIdleCall) /* 80 */ #endif #ifndef Tcl_Close -#define Tcl_Close(interp, chan) \ - (tclStubsPtr->tcl_Close)(interp, chan) /* 81 */ +#define Tcl_Close \ + (tclStubsPtr->tcl_Close) /* 81 */ #endif #ifndef Tcl_CommandComplete -#define Tcl_CommandComplete(cmd) \ - (tclStubsPtr->tcl_CommandComplete)(cmd) /* 82 */ +#define Tcl_CommandComplete \ + (tclStubsPtr->tcl_CommandComplete) /* 82 */ #endif #ifndef Tcl_Concat -#define Tcl_Concat(argc, argv) \ - (tclStubsPtr->tcl_Concat)(argc, argv) /* 83 */ +#define Tcl_Concat \ + (tclStubsPtr->tcl_Concat) /* 83 */ #endif #ifndef Tcl_ConvertElement -#define Tcl_ConvertElement(src, dst, flags) \ - (tclStubsPtr->tcl_ConvertElement)(src, dst, flags) /* 84 */ +#define Tcl_ConvertElement \ + (tclStubsPtr->tcl_ConvertElement) /* 84 */ #endif #ifndef Tcl_ConvertCountedElement -#define Tcl_ConvertCountedElement(src, length, dst, flags) \ - (tclStubsPtr->tcl_ConvertCountedElement)(src, length, dst, flags) /* 85 */ +#define Tcl_ConvertCountedElement \ + (tclStubsPtr->tcl_ConvertCountedElement) /* 85 */ #endif #ifndef Tcl_CreateAlias -#define Tcl_CreateAlias(slave, slaveCmd, target, targetCmd, argc, argv) \ - (tclStubsPtr->tcl_CreateAlias)(slave, slaveCmd, target, targetCmd, argc, argv) /* 86 */ +#define Tcl_CreateAlias \ + (tclStubsPtr->tcl_CreateAlias) /* 86 */ #endif #ifndef Tcl_CreateAliasObj -#define Tcl_CreateAliasObj(slave, slaveCmd, target, targetCmd, objc, objv) \ - (tclStubsPtr->tcl_CreateAliasObj)(slave, slaveCmd, target, targetCmd, objc, objv) /* 87 */ +#define Tcl_CreateAliasObj \ + (tclStubsPtr->tcl_CreateAliasObj) /* 87 */ #endif #ifndef Tcl_CreateChannel -#define Tcl_CreateChannel(typePtr, chanName, instanceData, mask) \ - (tclStubsPtr->tcl_CreateChannel)(typePtr, chanName, instanceData, mask) /* 88 */ +#define Tcl_CreateChannel \ + (tclStubsPtr->tcl_CreateChannel) /* 88 */ #endif #ifndef Tcl_CreateChannelHandler -#define Tcl_CreateChannelHandler(chan, mask, proc, clientData) \ - (tclStubsPtr->tcl_CreateChannelHandler)(chan, mask, proc, clientData) /* 89 */ +#define Tcl_CreateChannelHandler \ + (tclStubsPtr->tcl_CreateChannelHandler) /* 89 */ #endif #ifndef Tcl_CreateCloseHandler -#define Tcl_CreateCloseHandler(chan, proc, clientData) \ - (tclStubsPtr->tcl_CreateCloseHandler)(chan, proc, clientData) /* 90 */ +#define Tcl_CreateCloseHandler \ + (tclStubsPtr->tcl_CreateCloseHandler) /* 90 */ #endif #ifndef Tcl_CreateCommand -#define Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) \ - (tclStubsPtr->tcl_CreateCommand)(interp, cmdName, proc, clientData, deleteProc) /* 91 */ +#define Tcl_CreateCommand \ + (tclStubsPtr->tcl_CreateCommand) /* 91 */ #endif #ifndef Tcl_CreateEventSource -#define Tcl_CreateEventSource(setupProc, checkProc, clientData) \ - (tclStubsPtr->tcl_CreateEventSource)(setupProc, checkProc, clientData) /* 92 */ +#define Tcl_CreateEventSource \ + (tclStubsPtr->tcl_CreateEventSource) /* 92 */ #endif #ifndef Tcl_CreateExitHandler -#define Tcl_CreateExitHandler(proc, clientData) \ - (tclStubsPtr->tcl_CreateExitHandler)(proc, clientData) /* 93 */ +#define Tcl_CreateExitHandler \ + (tclStubsPtr->tcl_CreateExitHandler) /* 93 */ #endif #ifndef Tcl_CreateInterp -#define Tcl_CreateInterp() \ - (tclStubsPtr->tcl_CreateInterp)() /* 94 */ +#define Tcl_CreateInterp \ + (tclStubsPtr->tcl_CreateInterp) /* 94 */ #endif #ifndef Tcl_CreateMathFunc -#define Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) \ - (tclStubsPtr->tcl_CreateMathFunc)(interp, name, numArgs, argTypes, proc, clientData) /* 95 */ +#define Tcl_CreateMathFunc \ + (tclStubsPtr->tcl_CreateMathFunc) /* 95 */ #endif #ifndef Tcl_CreateObjCommand -#define Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) \ - (tclStubsPtr->tcl_CreateObjCommand)(interp, cmdName, proc, clientData, deleteProc) /* 96 */ +#define Tcl_CreateObjCommand \ + (tclStubsPtr->tcl_CreateObjCommand) /* 96 */ #endif #ifndef Tcl_CreateSlave -#define Tcl_CreateSlave(interp, slaveName, isSafe) \ - (tclStubsPtr->tcl_CreateSlave)(interp, slaveName, isSafe) /* 97 */ +#define Tcl_CreateSlave \ + (tclStubsPtr->tcl_CreateSlave) /* 97 */ #endif #ifndef Tcl_CreateTimerHandler -#define Tcl_CreateTimerHandler(milliseconds, proc, clientData) \ - (tclStubsPtr->tcl_CreateTimerHandler)(milliseconds, proc, clientData) /* 98 */ +#define Tcl_CreateTimerHandler \ + (tclStubsPtr->tcl_CreateTimerHandler) /* 98 */ #endif #ifndef Tcl_CreateTrace -#define Tcl_CreateTrace(interp, level, proc, clientData) \ - (tclStubsPtr->tcl_CreateTrace)(interp, level, proc, clientData) /* 99 */ +#define Tcl_CreateTrace \ + (tclStubsPtr->tcl_CreateTrace) /* 99 */ #endif #ifndef Tcl_DeleteAssocData -#define Tcl_DeleteAssocData(interp, name) \ - (tclStubsPtr->tcl_DeleteAssocData)(interp, name) /* 100 */ +#define Tcl_DeleteAssocData \ + (tclStubsPtr->tcl_DeleteAssocData) /* 100 */ #endif #ifndef Tcl_DeleteChannelHandler -#define Tcl_DeleteChannelHandler(chan, proc, clientData) \ - (tclStubsPtr->tcl_DeleteChannelHandler)(chan, proc, clientData) /* 101 */ +#define Tcl_DeleteChannelHandler \ + (tclStubsPtr->tcl_DeleteChannelHandler) /* 101 */ #endif #ifndef Tcl_DeleteCloseHandler -#define Tcl_DeleteCloseHandler(chan, proc, clientData) \ - (tclStubsPtr->tcl_DeleteCloseHandler)(chan, proc, clientData) /* 102 */ +#define Tcl_DeleteCloseHandler \ + (tclStubsPtr->tcl_DeleteCloseHandler) /* 102 */ #endif #ifndef Tcl_DeleteCommand -#define Tcl_DeleteCommand(interp, cmdName) \ - (tclStubsPtr->tcl_DeleteCommand)(interp, cmdName) /* 103 */ +#define Tcl_DeleteCommand \ + (tclStubsPtr->tcl_DeleteCommand) /* 103 */ #endif #ifndef Tcl_DeleteCommandFromToken -#define Tcl_DeleteCommandFromToken(interp, command) \ - (tclStubsPtr->tcl_DeleteCommandFromToken)(interp, command) /* 104 */ +#define Tcl_DeleteCommandFromToken \ + (tclStubsPtr->tcl_DeleteCommandFromToken) /* 104 */ #endif #ifndef Tcl_DeleteEvents -#define Tcl_DeleteEvents(proc, clientData) \ - (tclStubsPtr->tcl_DeleteEvents)(proc, clientData) /* 105 */ +#define Tcl_DeleteEvents \ + (tclStubsPtr->tcl_DeleteEvents) /* 105 */ #endif #ifndef Tcl_DeleteEventSource -#define Tcl_DeleteEventSource(setupProc, checkProc, clientData) \ - (tclStubsPtr->tcl_DeleteEventSource)(setupProc, checkProc, clientData) /* 106 */ +#define Tcl_DeleteEventSource \ + (tclStubsPtr->tcl_DeleteEventSource) /* 106 */ #endif #ifndef Tcl_DeleteExitHandler -#define Tcl_DeleteExitHandler(proc, clientData) \ - (tclStubsPtr->tcl_DeleteExitHandler)(proc, clientData) /* 107 */ +#define Tcl_DeleteExitHandler \ + (tclStubsPtr->tcl_DeleteExitHandler) /* 107 */ #endif #ifndef Tcl_DeleteHashEntry -#define Tcl_DeleteHashEntry(entryPtr) \ - (tclStubsPtr->tcl_DeleteHashEntry)(entryPtr) /* 108 */ +#define Tcl_DeleteHashEntry \ + (tclStubsPtr->tcl_DeleteHashEntry) /* 108 */ #endif #ifndef Tcl_DeleteHashTable -#define Tcl_DeleteHashTable(tablePtr) \ - (tclStubsPtr->tcl_DeleteHashTable)(tablePtr) /* 109 */ +#define Tcl_DeleteHashTable \ + (tclStubsPtr->tcl_DeleteHashTable) /* 109 */ #endif #ifndef Tcl_DeleteInterp -#define Tcl_DeleteInterp(interp) \ - (tclStubsPtr->tcl_DeleteInterp)(interp) /* 110 */ +#define Tcl_DeleteInterp \ + (tclStubsPtr->tcl_DeleteInterp) /* 110 */ #endif #ifndef Tcl_DetachPids -#define Tcl_DetachPids(numPids, pidPtr) \ - (tclStubsPtr->tcl_DetachPids)(numPids, pidPtr) /* 111 */ +#define Tcl_DetachPids \ + (tclStubsPtr->tcl_DetachPids) /* 111 */ #endif #ifndef Tcl_DeleteTimerHandler -#define Tcl_DeleteTimerHandler(token) \ - (tclStubsPtr->tcl_DeleteTimerHandler)(token) /* 112 */ +#define Tcl_DeleteTimerHandler \ + (tclStubsPtr->tcl_DeleteTimerHandler) /* 112 */ #endif #ifndef Tcl_DeleteTrace -#define Tcl_DeleteTrace(interp, trace) \ - (tclStubsPtr->tcl_DeleteTrace)(interp, trace) /* 113 */ +#define Tcl_DeleteTrace \ + (tclStubsPtr->tcl_DeleteTrace) /* 113 */ #endif #ifndef Tcl_DontCallWhenDeleted -#define Tcl_DontCallWhenDeleted(interp, proc, clientData) \ - (tclStubsPtr->tcl_DontCallWhenDeleted)(interp, proc, clientData) /* 114 */ +#define Tcl_DontCallWhenDeleted \ + (tclStubsPtr->tcl_DontCallWhenDeleted) /* 114 */ #endif #ifndef Tcl_DoOneEvent -#define Tcl_DoOneEvent(flags) \ - (tclStubsPtr->tcl_DoOneEvent)(flags) /* 115 */ +#define Tcl_DoOneEvent \ + (tclStubsPtr->tcl_DoOneEvent) /* 115 */ #endif #ifndef Tcl_DoWhenIdle -#define Tcl_DoWhenIdle(proc, clientData) \ - (tclStubsPtr->tcl_DoWhenIdle)(proc, clientData) /* 116 */ +#define Tcl_DoWhenIdle \ + (tclStubsPtr->tcl_DoWhenIdle) /* 116 */ #endif #ifndef Tcl_DStringAppend -#define Tcl_DStringAppend(dsPtr, string, length) \ - (tclStubsPtr->tcl_DStringAppend)(dsPtr, string, length) /* 117 */ +#define Tcl_DStringAppend \ + (tclStubsPtr->tcl_DStringAppend) /* 117 */ #endif #ifndef Tcl_DStringAppendElement -#define Tcl_DStringAppendElement(dsPtr, string) \ - (tclStubsPtr->tcl_DStringAppendElement)(dsPtr, string) /* 118 */ +#define Tcl_DStringAppendElement \ + (tclStubsPtr->tcl_DStringAppendElement) /* 118 */ #endif #ifndef Tcl_DStringEndSublist -#define Tcl_DStringEndSublist(dsPtr) \ - (tclStubsPtr->tcl_DStringEndSublist)(dsPtr) /* 119 */ +#define Tcl_DStringEndSublist \ + (tclStubsPtr->tcl_DStringEndSublist) /* 119 */ #endif #ifndef Tcl_DStringFree -#define Tcl_DStringFree(dsPtr) \ - (tclStubsPtr->tcl_DStringFree)(dsPtr) /* 120 */ +#define Tcl_DStringFree \ + (tclStubsPtr->tcl_DStringFree) /* 120 */ #endif #ifndef Tcl_DStringGetResult -#define Tcl_DStringGetResult(interp, dsPtr) \ - (tclStubsPtr->tcl_DStringGetResult)(interp, dsPtr) /* 121 */ +#define Tcl_DStringGetResult \ + (tclStubsPtr->tcl_DStringGetResult) /* 121 */ #endif #ifndef Tcl_DStringInit -#define Tcl_DStringInit(dsPtr) \ - (tclStubsPtr->tcl_DStringInit)(dsPtr) /* 122 */ +#define Tcl_DStringInit \ + (tclStubsPtr->tcl_DStringInit) /* 122 */ #endif #ifndef Tcl_DStringResult -#define Tcl_DStringResult(interp, dsPtr) \ - (tclStubsPtr->tcl_DStringResult)(interp, dsPtr) /* 123 */ +#define Tcl_DStringResult \ + (tclStubsPtr->tcl_DStringResult) /* 123 */ #endif #ifndef Tcl_DStringSetLength -#define Tcl_DStringSetLength(dsPtr, length) \ - (tclStubsPtr->tcl_DStringSetLength)(dsPtr, length) /* 124 */ +#define Tcl_DStringSetLength \ + (tclStubsPtr->tcl_DStringSetLength) /* 124 */ #endif #ifndef Tcl_DStringStartSublist -#define Tcl_DStringStartSublist(dsPtr) \ - (tclStubsPtr->tcl_DStringStartSublist)(dsPtr) /* 125 */ +#define Tcl_DStringStartSublist \ + (tclStubsPtr->tcl_DStringStartSublist) /* 125 */ #endif #ifndef Tcl_Eof -#define Tcl_Eof(chan) \ - (tclStubsPtr->tcl_Eof)(chan) /* 126 */ +#define Tcl_Eof \ + (tclStubsPtr->tcl_Eof) /* 126 */ #endif #ifndef Tcl_ErrnoId -#define Tcl_ErrnoId() \ - (tclStubsPtr->tcl_ErrnoId)() /* 127 */ +#define Tcl_ErrnoId \ + (tclStubsPtr->tcl_ErrnoId) /* 127 */ #endif #ifndef Tcl_ErrnoMsg -#define Tcl_ErrnoMsg(err) \ - (tclStubsPtr->tcl_ErrnoMsg)(err) /* 128 */ +#define Tcl_ErrnoMsg \ + (tclStubsPtr->tcl_ErrnoMsg) /* 128 */ #endif #ifndef Tcl_Eval -#define Tcl_Eval(interp, string) \ - (tclStubsPtr->tcl_Eval)(interp, string) /* 129 */ +#define Tcl_Eval \ + (tclStubsPtr->tcl_Eval) /* 129 */ #endif #ifndef Tcl_EvalFile -#define Tcl_EvalFile(interp, fileName) \ - (tclStubsPtr->tcl_EvalFile)(interp, fileName) /* 130 */ +#define Tcl_EvalFile \ + (tclStubsPtr->tcl_EvalFile) /* 130 */ #endif #ifndef Tcl_EvalObj -#define Tcl_EvalObj(interp, objPtr) \ - (tclStubsPtr->tcl_EvalObj)(interp, objPtr) /* 131 */ +#define Tcl_EvalObj \ + (tclStubsPtr->tcl_EvalObj) /* 131 */ #endif #ifndef Tcl_EventuallyFree -#define Tcl_EventuallyFree(clientData, freeProc) \ - (tclStubsPtr->tcl_EventuallyFree)(clientData, freeProc) /* 132 */ +#define Tcl_EventuallyFree \ + (tclStubsPtr->tcl_EventuallyFree) /* 132 */ #endif #ifndef Tcl_Exit -#define Tcl_Exit(status) \ - (tclStubsPtr->tcl_Exit)(status) /* 133 */ +#define Tcl_Exit \ + (tclStubsPtr->tcl_Exit) /* 133 */ #endif #ifndef Tcl_ExposeCommand -#define Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) \ - (tclStubsPtr->tcl_ExposeCommand)(interp, hiddenCmdToken, cmdName) /* 134 */ +#define Tcl_ExposeCommand \ + (tclStubsPtr->tcl_ExposeCommand) /* 134 */ #endif #ifndef Tcl_ExprBoolean -#define Tcl_ExprBoolean(interp, string, ptr) \ - (tclStubsPtr->tcl_ExprBoolean)(interp, string, ptr) /* 135 */ +#define Tcl_ExprBoolean \ + (tclStubsPtr->tcl_ExprBoolean) /* 135 */ #endif #ifndef Tcl_ExprBooleanObj -#define Tcl_ExprBooleanObj(interp, objPtr, ptr) \ - (tclStubsPtr->tcl_ExprBooleanObj)(interp, objPtr, ptr) /* 136 */ +#define Tcl_ExprBooleanObj \ + (tclStubsPtr->tcl_ExprBooleanObj) /* 136 */ #endif #ifndef Tcl_ExprDouble -#define Tcl_ExprDouble(interp, string, ptr) \ - (tclStubsPtr->tcl_ExprDouble)(interp, string, ptr) /* 137 */ +#define Tcl_ExprDouble \ + (tclStubsPtr->tcl_ExprDouble) /* 137 */ #endif #ifndef Tcl_ExprDoubleObj -#define Tcl_ExprDoubleObj(interp, objPtr, ptr) \ - (tclStubsPtr->tcl_ExprDoubleObj)(interp, objPtr, ptr) /* 138 */ +#define Tcl_ExprDoubleObj \ + (tclStubsPtr->tcl_ExprDoubleObj) /* 138 */ #endif #ifndef Tcl_ExprLong -#define Tcl_ExprLong(interp, string, ptr) \ - (tclStubsPtr->tcl_ExprLong)(interp, string, ptr) /* 139 */ +#define Tcl_ExprLong \ + (tclStubsPtr->tcl_ExprLong) /* 139 */ #endif #ifndef Tcl_ExprLongObj -#define Tcl_ExprLongObj(interp, objPtr, ptr) \ - (tclStubsPtr->tcl_ExprLongObj)(interp, objPtr, ptr) /* 140 */ +#define Tcl_ExprLongObj \ + (tclStubsPtr->tcl_ExprLongObj) /* 140 */ #endif #ifndef Tcl_ExprObj -#define Tcl_ExprObj(interp, objPtr, resultPtrPtr) \ - (tclStubsPtr->tcl_ExprObj)(interp, objPtr, resultPtrPtr) /* 141 */ +#define Tcl_ExprObj \ + (tclStubsPtr->tcl_ExprObj) /* 141 */ #endif #ifndef Tcl_ExprString -#define Tcl_ExprString(interp, string) \ - (tclStubsPtr->tcl_ExprString)(interp, string) /* 142 */ +#define Tcl_ExprString \ + (tclStubsPtr->tcl_ExprString) /* 142 */ #endif #ifndef Tcl_Finalize -#define Tcl_Finalize() \ - (tclStubsPtr->tcl_Finalize)() /* 143 */ +#define Tcl_Finalize \ + (tclStubsPtr->tcl_Finalize) /* 143 */ #endif #ifndef Tcl_FindExecutable -#define Tcl_FindExecutable(argv0) \ - (tclStubsPtr->tcl_FindExecutable)(argv0) /* 144 */ +#define Tcl_FindExecutable \ + (tclStubsPtr->tcl_FindExecutable) /* 144 */ #endif #ifndef Tcl_FirstHashEntry -#define Tcl_FirstHashEntry(tablePtr, searchPtr) \ - (tclStubsPtr->tcl_FirstHashEntry)(tablePtr, searchPtr) /* 145 */ +#define Tcl_FirstHashEntry \ + (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #endif #ifndef Tcl_Flush -#define Tcl_Flush(chan) \ - (tclStubsPtr->tcl_Flush)(chan) /* 146 */ +#define Tcl_Flush \ + (tclStubsPtr->tcl_Flush) /* 146 */ #endif #ifndef Tcl_FreeResult -#define Tcl_FreeResult(interp) \ - (tclStubsPtr->tcl_FreeResult)(interp) /* 147 */ +#define Tcl_FreeResult \ + (tclStubsPtr->tcl_FreeResult) /* 147 */ #endif #ifndef Tcl_GetAlias -#define Tcl_GetAlias(interp, slaveCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) \ - (tclStubsPtr->tcl_GetAlias)(interp, slaveCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) /* 148 */ +#define Tcl_GetAlias \ + (tclStubsPtr->tcl_GetAlias) /* 148 */ #endif #ifndef Tcl_GetAliasObj -#define Tcl_GetAliasObj(interp, slaveCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) \ - (tclStubsPtr->tcl_GetAliasObj)(interp, slaveCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) /* 149 */ +#define Tcl_GetAliasObj \ + (tclStubsPtr->tcl_GetAliasObj) /* 149 */ #endif #ifndef Tcl_GetAssocData -#define Tcl_GetAssocData(interp, name, procPtr) \ - (tclStubsPtr->tcl_GetAssocData)(interp, name, procPtr) /* 150 */ +#define Tcl_GetAssocData \ + (tclStubsPtr->tcl_GetAssocData) /* 150 */ #endif #ifndef Tcl_GetChannel -#define Tcl_GetChannel(interp, chanName, modePtr) \ - (tclStubsPtr->tcl_GetChannel)(interp, chanName, modePtr) /* 151 */ +#define Tcl_GetChannel \ + (tclStubsPtr->tcl_GetChannel) /* 151 */ #endif #ifndef Tcl_GetChannelBufferSize -#define Tcl_GetChannelBufferSize(chan) \ - (tclStubsPtr->tcl_GetChannelBufferSize)(chan) /* 152 */ +#define Tcl_GetChannelBufferSize \ + (tclStubsPtr->tcl_GetChannelBufferSize) /* 152 */ #endif #ifndef Tcl_GetChannelHandle -#define Tcl_GetChannelHandle(chan, direction, handlePtr) \ - (tclStubsPtr->tcl_GetChannelHandle)(chan, direction, handlePtr) /* 153 */ +#define Tcl_GetChannelHandle \ + (tclStubsPtr->tcl_GetChannelHandle) /* 153 */ #endif #ifndef Tcl_GetChannelInstanceData -#define Tcl_GetChannelInstanceData(chan) \ - (tclStubsPtr->tcl_GetChannelInstanceData)(chan) /* 154 */ +#define Tcl_GetChannelInstanceData \ + (tclStubsPtr->tcl_GetChannelInstanceData) /* 154 */ #endif #ifndef Tcl_GetChannelMode -#define Tcl_GetChannelMode(chan) \ - (tclStubsPtr->tcl_GetChannelMode)(chan) /* 155 */ +#define Tcl_GetChannelMode \ + (tclStubsPtr->tcl_GetChannelMode) /* 155 */ #endif #ifndef Tcl_GetChannelName -#define Tcl_GetChannelName(chan) \ - (tclStubsPtr->tcl_GetChannelName)(chan) /* 156 */ +#define Tcl_GetChannelName \ + (tclStubsPtr->tcl_GetChannelName) /* 156 */ #endif #ifndef Tcl_GetChannelOption -#define Tcl_GetChannelOption(interp, chan, optionName, dsPtr) \ - (tclStubsPtr->tcl_GetChannelOption)(interp, chan, optionName, dsPtr) /* 157 */ +#define Tcl_GetChannelOption \ + (tclStubsPtr->tcl_GetChannelOption) /* 157 */ #endif #ifndef Tcl_GetChannelType -#define Tcl_GetChannelType(chan) \ - (tclStubsPtr->tcl_GetChannelType)(chan) /* 158 */ +#define Tcl_GetChannelType \ + (tclStubsPtr->tcl_GetChannelType) /* 158 */ #endif #ifndef Tcl_GetCommandInfo -#define Tcl_GetCommandInfo(interp, cmdName, infoPtr) \ - (tclStubsPtr->tcl_GetCommandInfo)(interp, cmdName, infoPtr) /* 159 */ +#define Tcl_GetCommandInfo \ + (tclStubsPtr->tcl_GetCommandInfo) /* 159 */ #endif #ifndef Tcl_GetCommandName -#define Tcl_GetCommandName(interp, command) \ - (tclStubsPtr->tcl_GetCommandName)(interp, command) /* 160 */ +#define Tcl_GetCommandName \ + (tclStubsPtr->tcl_GetCommandName) /* 160 */ #endif #ifndef Tcl_GetErrno -#define Tcl_GetErrno() \ - (tclStubsPtr->tcl_GetErrno)() /* 161 */ +#define Tcl_GetErrno \ + (tclStubsPtr->tcl_GetErrno) /* 161 */ #endif #ifndef Tcl_GetHostName -#define Tcl_GetHostName() \ - (tclStubsPtr->tcl_GetHostName)() /* 162 */ +#define Tcl_GetHostName \ + (tclStubsPtr->tcl_GetHostName) /* 162 */ #endif #ifndef Tcl_GetInterpPath -#define Tcl_GetInterpPath(askInterp, slaveInterp) \ - (tclStubsPtr->tcl_GetInterpPath)(askInterp, slaveInterp) /* 163 */ +#define Tcl_GetInterpPath \ + (tclStubsPtr->tcl_GetInterpPath) /* 163 */ #endif #ifndef Tcl_GetMaster -#define Tcl_GetMaster(interp) \ - (tclStubsPtr->tcl_GetMaster)(interp) /* 164 */ +#define Tcl_GetMaster \ + (tclStubsPtr->tcl_GetMaster) /* 164 */ #endif #ifndef Tcl_GetNameOfExecutable -#define Tcl_GetNameOfExecutable() \ - (tclStubsPtr->tcl_GetNameOfExecutable)() /* 165 */ +#define Tcl_GetNameOfExecutable \ + (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #endif #ifndef Tcl_GetObjResult -#define Tcl_GetObjResult(interp) \ - (tclStubsPtr->tcl_GetObjResult)(interp) /* 166 */ +#define Tcl_GetObjResult \ + (tclStubsPtr->tcl_GetObjResult) /* 166 */ #endif #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_GetOpenFile -#define Tcl_GetOpenFile(interp, string, write, checkUsage, filePtr) \ - (tclStubsPtr->tcl_GetOpenFile)(interp, string, write, checkUsage, filePtr) /* 167 */ +#define Tcl_GetOpenFile \ + (tclStubsPtr->tcl_GetOpenFile) /* 167 */ #endif #endif /* UNIX */ #ifndef Tcl_GetPathType -#define Tcl_GetPathType(path) \ - (tclStubsPtr->tcl_GetPathType)(path) /* 168 */ +#define Tcl_GetPathType \ + (tclStubsPtr->tcl_GetPathType) /* 168 */ #endif #ifndef Tcl_Gets -#define Tcl_Gets(chan, dsPtr) \ - (tclStubsPtr->tcl_Gets)(chan, dsPtr) /* 169 */ +#define Tcl_Gets \ + (tclStubsPtr->tcl_Gets) /* 169 */ #endif #ifndef Tcl_GetsObj -#define Tcl_GetsObj(chan, objPtr) \ - (tclStubsPtr->tcl_GetsObj)(chan, objPtr) /* 170 */ +#define Tcl_GetsObj \ + (tclStubsPtr->tcl_GetsObj) /* 170 */ #endif #ifndef Tcl_GetServiceMode -#define Tcl_GetServiceMode() \ - (tclStubsPtr->tcl_GetServiceMode)() /* 171 */ +#define Tcl_GetServiceMode \ + (tclStubsPtr->tcl_GetServiceMode) /* 171 */ #endif #ifndef Tcl_GetSlave -#define Tcl_GetSlave(interp, slaveName) \ - (tclStubsPtr->tcl_GetSlave)(interp, slaveName) /* 172 */ +#define Tcl_GetSlave \ + (tclStubsPtr->tcl_GetSlave) /* 172 */ #endif #ifndef Tcl_GetStdChannel -#define Tcl_GetStdChannel(type) \ - (tclStubsPtr->tcl_GetStdChannel)(type) /* 173 */ +#define Tcl_GetStdChannel \ + (tclStubsPtr->tcl_GetStdChannel) /* 173 */ #endif #ifndef Tcl_GetStringResult -#define Tcl_GetStringResult(interp) \ - (tclStubsPtr->tcl_GetStringResult)(interp) /* 174 */ +#define Tcl_GetStringResult \ + (tclStubsPtr->tcl_GetStringResult) /* 174 */ #endif #ifndef Tcl_GetVar -#define Tcl_GetVar(interp, varName, flags) \ - (tclStubsPtr->tcl_GetVar)(interp, varName, flags) /* 175 */ +#define Tcl_GetVar \ + (tclStubsPtr->tcl_GetVar) /* 175 */ #endif #ifndef Tcl_GetVar2 -#define Tcl_GetVar2(interp, part1, part2, flags) \ - (tclStubsPtr->tcl_GetVar2)(interp, part1, part2, flags) /* 176 */ +#define Tcl_GetVar2 \ + (tclStubsPtr->tcl_GetVar2) /* 176 */ #endif #ifndef Tcl_GlobalEval -#define Tcl_GlobalEval(interp, command) \ - (tclStubsPtr->tcl_GlobalEval)(interp, command) /* 177 */ +#define Tcl_GlobalEval \ + (tclStubsPtr->tcl_GlobalEval) /* 177 */ #endif #ifndef Tcl_GlobalEvalObj -#define Tcl_GlobalEvalObj(interp, objPtr) \ - (tclStubsPtr->tcl_GlobalEvalObj)(interp, objPtr) /* 178 */ +#define Tcl_GlobalEvalObj \ + (tclStubsPtr->tcl_GlobalEvalObj) /* 178 */ #endif #ifndef Tcl_HideCommand -#define Tcl_HideCommand(interp, cmdName, hiddenCmdToken) \ - (tclStubsPtr->tcl_HideCommand)(interp, cmdName, hiddenCmdToken) /* 179 */ +#define Tcl_HideCommand \ + (tclStubsPtr->tcl_HideCommand) /* 179 */ #endif #ifndef Tcl_Init -#define Tcl_Init(interp) \ - (tclStubsPtr->tcl_Init)(interp) /* 180 */ +#define Tcl_Init \ + (tclStubsPtr->tcl_Init) /* 180 */ #endif #ifndef Tcl_InitHashTable -#define Tcl_InitHashTable(tablePtr, keyType) \ - (tclStubsPtr->tcl_InitHashTable)(tablePtr, keyType) /* 181 */ +#define Tcl_InitHashTable \ + (tclStubsPtr->tcl_InitHashTable) /* 181 */ #endif #ifndef Tcl_InputBlocked -#define Tcl_InputBlocked(chan) \ - (tclStubsPtr->tcl_InputBlocked)(chan) /* 182 */ +#define Tcl_InputBlocked \ + (tclStubsPtr->tcl_InputBlocked) /* 182 */ #endif #ifndef Tcl_InputBuffered -#define Tcl_InputBuffered(chan) \ - (tclStubsPtr->tcl_InputBuffered)(chan) /* 183 */ +#define Tcl_InputBuffered \ + (tclStubsPtr->tcl_InputBuffered) /* 183 */ #endif #ifndef Tcl_InterpDeleted -#define Tcl_InterpDeleted(interp) \ - (tclStubsPtr->tcl_InterpDeleted)(interp) /* 184 */ +#define Tcl_InterpDeleted \ + (tclStubsPtr->tcl_InterpDeleted) /* 184 */ #endif #ifndef Tcl_IsSafe -#define Tcl_IsSafe(interp) \ - (tclStubsPtr->tcl_IsSafe)(interp) /* 185 */ +#define Tcl_IsSafe \ + (tclStubsPtr->tcl_IsSafe) /* 185 */ #endif #ifndef Tcl_JoinPath -#define Tcl_JoinPath(argc, argv, resultPtr) \ - (tclStubsPtr->tcl_JoinPath)(argc, argv, resultPtr) /* 186 */ +#define Tcl_JoinPath \ + (tclStubsPtr->tcl_JoinPath) /* 186 */ #endif #ifndef Tcl_LinkVar -#define Tcl_LinkVar(interp, varName, addr, type) \ - (tclStubsPtr->tcl_LinkVar)(interp, varName, addr, type) /* 187 */ +#define Tcl_LinkVar \ + (tclStubsPtr->tcl_LinkVar) /* 187 */ #endif /* Slot 188 is reserved */ #ifndef Tcl_MakeFileChannel -#define Tcl_MakeFileChannel(handle, mode) \ - (tclStubsPtr->tcl_MakeFileChannel)(handle, mode) /* 189 */ +#define Tcl_MakeFileChannel \ + (tclStubsPtr->tcl_MakeFileChannel) /* 189 */ #endif #ifndef Tcl_MakeSafe -#define Tcl_MakeSafe(interp) \ - (tclStubsPtr->tcl_MakeSafe)(interp) /* 190 */ +#define Tcl_MakeSafe \ + (tclStubsPtr->tcl_MakeSafe) /* 190 */ #endif #ifndef Tcl_MakeTcpClientChannel -#define Tcl_MakeTcpClientChannel(tcpSocket) \ - (tclStubsPtr->tcl_MakeTcpClientChannel)(tcpSocket) /* 191 */ +#define Tcl_MakeTcpClientChannel \ + (tclStubsPtr->tcl_MakeTcpClientChannel) /* 191 */ #endif #ifndef Tcl_Merge -#define Tcl_Merge(argc, argv) \ - (tclStubsPtr->tcl_Merge)(argc, argv) /* 192 */ +#define Tcl_Merge \ + (tclStubsPtr->tcl_Merge) /* 192 */ #endif #ifndef Tcl_NextHashEntry -#define Tcl_NextHashEntry(searchPtr) \ - (tclStubsPtr->tcl_NextHashEntry)(searchPtr) /* 193 */ +#define Tcl_NextHashEntry \ + (tclStubsPtr->tcl_NextHashEntry) /* 193 */ #endif #ifndef Tcl_NotifyChannel -#define Tcl_NotifyChannel(channel, mask) \ - (tclStubsPtr->tcl_NotifyChannel)(channel, mask) /* 194 */ +#define Tcl_NotifyChannel \ + (tclStubsPtr->tcl_NotifyChannel) /* 194 */ #endif #ifndef Tcl_ObjGetVar2 -#define Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) \ - (tclStubsPtr->tcl_ObjGetVar2)(interp, part1Ptr, part2Ptr, flags) /* 195 */ +#define Tcl_ObjGetVar2 \ + (tclStubsPtr->tcl_ObjGetVar2) /* 195 */ #endif #ifndef Tcl_ObjSetVar2 -#define Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) \ - (tclStubsPtr->tcl_ObjSetVar2)(interp, part1Ptr, part2Ptr, newValuePtr, flags) /* 196 */ +#define Tcl_ObjSetVar2 \ + (tclStubsPtr->tcl_ObjSetVar2) /* 196 */ #endif #ifndef Tcl_OpenCommandChannel -#define Tcl_OpenCommandChannel(interp, argc, argv, flags) \ - (tclStubsPtr->tcl_OpenCommandChannel)(interp, argc, argv, flags) /* 197 */ +#define Tcl_OpenCommandChannel \ + (tclStubsPtr->tcl_OpenCommandChannel) /* 197 */ #endif #ifndef Tcl_OpenFileChannel -#define Tcl_OpenFileChannel(interp, fileName, modeString, permissions) \ - (tclStubsPtr->tcl_OpenFileChannel)(interp, fileName, modeString, permissions) /* 198 */ +#define Tcl_OpenFileChannel \ + (tclStubsPtr->tcl_OpenFileChannel) /* 198 */ #endif #ifndef Tcl_OpenTcpClient -#define Tcl_OpenTcpClient(interp, port, address, myaddr, myport, async) \ - (tclStubsPtr->tcl_OpenTcpClient)(interp, port, address, myaddr, myport, async) /* 199 */ +#define Tcl_OpenTcpClient \ + (tclStubsPtr->tcl_OpenTcpClient) /* 199 */ #endif #ifndef Tcl_OpenTcpServer -#define Tcl_OpenTcpServer(interp, port, host, acceptProc, callbackData) \ - (tclStubsPtr->tcl_OpenTcpServer)(interp, port, host, acceptProc, callbackData) /* 200 */ +#define Tcl_OpenTcpServer \ + (tclStubsPtr->tcl_OpenTcpServer) /* 200 */ #endif #ifndef Tcl_Preserve -#define Tcl_Preserve(data) \ - (tclStubsPtr->tcl_Preserve)(data) /* 201 */ +#define Tcl_Preserve \ + (tclStubsPtr->tcl_Preserve) /* 201 */ #endif #ifndef Tcl_PrintDouble -#define Tcl_PrintDouble(interp, value, dst) \ - (tclStubsPtr->tcl_PrintDouble)(interp, value, dst) /* 202 */ +#define Tcl_PrintDouble \ + (tclStubsPtr->tcl_PrintDouble) /* 202 */ #endif #ifndef Tcl_PutEnv -#define Tcl_PutEnv(string) \ - (tclStubsPtr->tcl_PutEnv)(string) /* 203 */ +#define Tcl_PutEnv \ + (tclStubsPtr->tcl_PutEnv) /* 203 */ #endif #ifndef Tcl_PosixError -#define Tcl_PosixError(interp) \ - (tclStubsPtr->tcl_PosixError)(interp) /* 204 */ +#define Tcl_PosixError \ + (tclStubsPtr->tcl_PosixError) /* 204 */ #endif #ifndef Tcl_QueueEvent -#define Tcl_QueueEvent(evPtr, position) \ - (tclStubsPtr->tcl_QueueEvent)(evPtr, position) /* 205 */ +#define Tcl_QueueEvent \ + (tclStubsPtr->tcl_QueueEvent) /* 205 */ #endif #ifndef Tcl_Read -#define Tcl_Read(chan, bufPtr, toRead) \ - (tclStubsPtr->tcl_Read)(chan, bufPtr, toRead) /* 206 */ +#define Tcl_Read \ + (tclStubsPtr->tcl_Read) /* 206 */ #endif #ifndef Tcl_ReapDetachedProcs -#define Tcl_ReapDetachedProcs() \ - (tclStubsPtr->tcl_ReapDetachedProcs)() /* 207 */ +#define Tcl_ReapDetachedProcs \ + (tclStubsPtr->tcl_ReapDetachedProcs) /* 207 */ #endif #ifndef Tcl_RecordAndEval -#define Tcl_RecordAndEval(interp, cmd, flags) \ - (tclStubsPtr->tcl_RecordAndEval)(interp, cmd, flags) /* 208 */ +#define Tcl_RecordAndEval \ + (tclStubsPtr->tcl_RecordAndEval) /* 208 */ #endif #ifndef Tcl_RecordAndEvalObj -#define Tcl_RecordAndEvalObj(interp, cmdPtr, flags) \ - (tclStubsPtr->tcl_RecordAndEvalObj)(interp, cmdPtr, flags) /* 209 */ +#define Tcl_RecordAndEvalObj \ + (tclStubsPtr->tcl_RecordAndEvalObj) /* 209 */ #endif #ifndef Tcl_RegisterChannel -#define Tcl_RegisterChannel(interp, chan) \ - (tclStubsPtr->tcl_RegisterChannel)(interp, chan) /* 210 */ +#define Tcl_RegisterChannel \ + (tclStubsPtr->tcl_RegisterChannel) /* 210 */ #endif #ifndef Tcl_RegisterObjType -#define Tcl_RegisterObjType(typePtr) \ - (tclStubsPtr->tcl_RegisterObjType)(typePtr) /* 211 */ +#define Tcl_RegisterObjType \ + (tclStubsPtr->tcl_RegisterObjType) /* 211 */ #endif #ifndef Tcl_RegExpCompile -#define Tcl_RegExpCompile(interp, string) \ - (tclStubsPtr->tcl_RegExpCompile)(interp, string) /* 212 */ +#define Tcl_RegExpCompile \ + (tclStubsPtr->tcl_RegExpCompile) /* 212 */ #endif #ifndef Tcl_RegExpExec -#define Tcl_RegExpExec(interp, regexp, string, start) \ - (tclStubsPtr->tcl_RegExpExec)(interp, regexp, string, start) /* 213 */ +#define Tcl_RegExpExec \ + (tclStubsPtr->tcl_RegExpExec) /* 213 */ #endif #ifndef Tcl_RegExpMatch -#define Tcl_RegExpMatch(interp, string, pattern) \ - (tclStubsPtr->tcl_RegExpMatch)(interp, string, pattern) /* 214 */ +#define Tcl_RegExpMatch \ + (tclStubsPtr->tcl_RegExpMatch) /* 214 */ #endif #ifndef Tcl_RegExpRange -#define Tcl_RegExpRange(regexp, index, startPtr, endPtr) \ - (tclStubsPtr->tcl_RegExpRange)(regexp, index, startPtr, endPtr) /* 215 */ +#define Tcl_RegExpRange \ + (tclStubsPtr->tcl_RegExpRange) /* 215 */ #endif #ifndef Tcl_Release -#define Tcl_Release(clientData) \ - (tclStubsPtr->tcl_Release)(clientData) /* 216 */ +#define Tcl_Release \ + (tclStubsPtr->tcl_Release) /* 216 */ #endif #ifndef Tcl_ResetResult -#define Tcl_ResetResult(interp) \ - (tclStubsPtr->tcl_ResetResult)(interp) /* 217 */ +#define Tcl_ResetResult \ + (tclStubsPtr->tcl_ResetResult) /* 217 */ #endif #ifndef Tcl_ScanElement -#define Tcl_ScanElement(string, flagPtr) \ - (tclStubsPtr->tcl_ScanElement)(string, flagPtr) /* 218 */ +#define Tcl_ScanElement \ + (tclStubsPtr->tcl_ScanElement) /* 218 */ #endif #ifndef Tcl_ScanCountedElement -#define Tcl_ScanCountedElement(string, length, flagPtr) \ - (tclStubsPtr->tcl_ScanCountedElement)(string, length, flagPtr) /* 219 */ +#define Tcl_ScanCountedElement \ + (tclStubsPtr->tcl_ScanCountedElement) /* 219 */ #endif #ifndef Tcl_Seek -#define Tcl_Seek(chan, offset, mode) \ - (tclStubsPtr->tcl_Seek)(chan, offset, mode) /* 220 */ +#define Tcl_Seek \ + (tclStubsPtr->tcl_Seek) /* 220 */ #endif #ifndef Tcl_ServiceAll -#define Tcl_ServiceAll() \ - (tclStubsPtr->tcl_ServiceAll)() /* 221 */ +#define Tcl_ServiceAll \ + (tclStubsPtr->tcl_ServiceAll) /* 221 */ #endif #ifndef Tcl_ServiceEvent -#define Tcl_ServiceEvent(flags) \ - (tclStubsPtr->tcl_ServiceEvent)(flags) /* 222 */ +#define Tcl_ServiceEvent \ + (tclStubsPtr->tcl_ServiceEvent) /* 222 */ #endif #ifndef Tcl_SetAssocData -#define Tcl_SetAssocData(interp, name, proc, clientData) \ - (tclStubsPtr->tcl_SetAssocData)(interp, name, proc, clientData) /* 223 */ +#define Tcl_SetAssocData \ + (tclStubsPtr->tcl_SetAssocData) /* 223 */ #endif #ifndef Tcl_SetChannelBufferSize -#define Tcl_SetChannelBufferSize(chan, sz) \ - (tclStubsPtr->tcl_SetChannelBufferSize)(chan, sz) /* 224 */ +#define Tcl_SetChannelBufferSize \ + (tclStubsPtr->tcl_SetChannelBufferSize) /* 224 */ #endif #ifndef Tcl_SetChannelOption -#define Tcl_SetChannelOption(interp, chan, optionName, newValue) \ - (tclStubsPtr->tcl_SetChannelOption)(interp, chan, optionName, newValue) /* 225 */ +#define Tcl_SetChannelOption \ + (tclStubsPtr->tcl_SetChannelOption) /* 225 */ #endif #ifndef Tcl_SetCommandInfo -#define Tcl_SetCommandInfo(interp, cmdName, infoPtr) \ - (tclStubsPtr->tcl_SetCommandInfo)(interp, cmdName, infoPtr) /* 226 */ +#define Tcl_SetCommandInfo \ + (tclStubsPtr->tcl_SetCommandInfo) /* 226 */ #endif #ifndef Tcl_SetErrno -#define Tcl_SetErrno(err) \ - (tclStubsPtr->tcl_SetErrno)(err) /* 227 */ +#define Tcl_SetErrno \ + (tclStubsPtr->tcl_SetErrno) /* 227 */ #endif #ifndef Tcl_SetErrorCode #define Tcl_SetErrorCode \ (tclStubsPtr->tcl_SetErrorCode) /* 228 */ #endif #ifndef Tcl_SetMaxBlockTime -#define Tcl_SetMaxBlockTime(timePtr) \ - (tclStubsPtr->tcl_SetMaxBlockTime)(timePtr) /* 229 */ +#define Tcl_SetMaxBlockTime \ + (tclStubsPtr->tcl_SetMaxBlockTime) /* 229 */ #endif #ifndef Tcl_SetPanicProc -#define Tcl_SetPanicProc(panicProc) \ - (tclStubsPtr->tcl_SetPanicProc)(panicProc) /* 230 */ +#define Tcl_SetPanicProc \ + (tclStubsPtr->tcl_SetPanicProc) /* 230 */ #endif #ifndef Tcl_SetRecursionLimit -#define Tcl_SetRecursionLimit(interp, depth) \ - (tclStubsPtr->tcl_SetRecursionLimit)(interp, depth) /* 231 */ +#define Tcl_SetRecursionLimit \ + (tclStubsPtr->tcl_SetRecursionLimit) /* 231 */ #endif #ifndef Tcl_SetResult -#define Tcl_SetResult(interp, string, freeProc) \ - (tclStubsPtr->tcl_SetResult)(interp, string, freeProc) /* 232 */ +#define Tcl_SetResult \ + (tclStubsPtr->tcl_SetResult) /* 232 */ #endif #ifndef Tcl_SetServiceMode -#define Tcl_SetServiceMode(mode) \ - (tclStubsPtr->tcl_SetServiceMode)(mode) /* 233 */ +#define Tcl_SetServiceMode \ + (tclStubsPtr->tcl_SetServiceMode) /* 233 */ #endif #ifndef Tcl_SetObjErrorCode -#define Tcl_SetObjErrorCode(interp, errorObjPtr) \ - (tclStubsPtr->tcl_SetObjErrorCode)(interp, errorObjPtr) /* 234 */ +#define Tcl_SetObjErrorCode \ + (tclStubsPtr->tcl_SetObjErrorCode) /* 234 */ #endif #ifndef Tcl_SetObjResult -#define Tcl_SetObjResult(interp, resultObjPtr) \ - (tclStubsPtr->tcl_SetObjResult)(interp, resultObjPtr) /* 235 */ +#define Tcl_SetObjResult \ + (tclStubsPtr->tcl_SetObjResult) /* 235 */ #endif #ifndef Tcl_SetStdChannel -#define Tcl_SetStdChannel(channel, type) \ - (tclStubsPtr->tcl_SetStdChannel)(channel, type) /* 236 */ +#define Tcl_SetStdChannel \ + (tclStubsPtr->tcl_SetStdChannel) /* 236 */ #endif #ifndef Tcl_SetVar -#define Tcl_SetVar(interp, varName, newValue, flags) \ - (tclStubsPtr->tcl_SetVar)(interp, varName, newValue, flags) /* 237 */ +#define Tcl_SetVar \ + (tclStubsPtr->tcl_SetVar) /* 237 */ #endif #ifndef Tcl_SetVar2 -#define Tcl_SetVar2(interp, part1, part2, newValue, flags) \ - (tclStubsPtr->tcl_SetVar2)(interp, part1, part2, newValue, flags) /* 238 */ +#define Tcl_SetVar2 \ + (tclStubsPtr->tcl_SetVar2) /* 238 */ #endif #ifndef Tcl_SignalId -#define Tcl_SignalId(sig) \ - (tclStubsPtr->tcl_SignalId)(sig) /* 239 */ +#define Tcl_SignalId \ + (tclStubsPtr->tcl_SignalId) /* 239 */ #endif #ifndef Tcl_SignalMsg -#define Tcl_SignalMsg(sig) \ - (tclStubsPtr->tcl_SignalMsg)(sig) /* 240 */ +#define Tcl_SignalMsg \ + (tclStubsPtr->tcl_SignalMsg) /* 240 */ #endif #ifndef Tcl_SourceRCFile -#define Tcl_SourceRCFile(interp) \ - (tclStubsPtr->tcl_SourceRCFile)(interp) /* 241 */ +#define Tcl_SourceRCFile \ + (tclStubsPtr->tcl_SourceRCFile) /* 241 */ #endif #ifndef Tcl_SplitList -#define Tcl_SplitList(interp, list, argcPtr, argvPtr) \ - (tclStubsPtr->tcl_SplitList)(interp, list, argcPtr, argvPtr) /* 242 */ +#define Tcl_SplitList \ + (tclStubsPtr->tcl_SplitList) /* 242 */ #endif #ifndef Tcl_SplitPath -#define Tcl_SplitPath(path, argcPtr, argvPtr) \ - (tclStubsPtr->tcl_SplitPath)(path, argcPtr, argvPtr) /* 243 */ +#define Tcl_SplitPath \ + (tclStubsPtr->tcl_SplitPath) /* 243 */ #endif #ifndef Tcl_StaticPackage -#define Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) \ - (tclStubsPtr->tcl_StaticPackage)(interp, pkgName, initProc, safeInitProc) /* 244 */ +#define Tcl_StaticPackage \ + (tclStubsPtr->tcl_StaticPackage) /* 244 */ #endif #ifndef Tcl_StringMatch -#define Tcl_StringMatch(string, pattern) \ - (tclStubsPtr->tcl_StringMatch)(string, pattern) /* 245 */ +#define Tcl_StringMatch \ + (tclStubsPtr->tcl_StringMatch) /* 245 */ #endif #ifndef Tcl_Tell -#define Tcl_Tell(chan) \ - (tclStubsPtr->tcl_Tell)(chan) /* 246 */ +#define Tcl_Tell \ + (tclStubsPtr->tcl_Tell) /* 246 */ #endif #ifndef Tcl_TraceVar -#define Tcl_TraceVar(interp, varName, flags, proc, clientData) \ - (tclStubsPtr->tcl_TraceVar)(interp, varName, flags, proc, clientData) /* 247 */ +#define Tcl_TraceVar \ + (tclStubsPtr->tcl_TraceVar) /* 247 */ #endif #ifndef Tcl_TraceVar2 -#define Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) \ - (tclStubsPtr->tcl_TraceVar2)(interp, part1, part2, flags, proc, clientData) /* 248 */ +#define Tcl_TraceVar2 \ + (tclStubsPtr->tcl_TraceVar2) /* 248 */ #endif #ifndef Tcl_TranslateFileName -#define Tcl_TranslateFileName(interp, name, bufferPtr) \ - (tclStubsPtr->tcl_TranslateFileName)(interp, name, bufferPtr) /* 249 */ +#define Tcl_TranslateFileName \ + (tclStubsPtr->tcl_TranslateFileName) /* 249 */ #endif #ifndef Tcl_Ungets -#define Tcl_Ungets(chan, str, len, atHead) \ - (tclStubsPtr->tcl_Ungets)(chan, str, len, atHead) /* 250 */ +#define Tcl_Ungets \ + (tclStubsPtr->tcl_Ungets) /* 250 */ #endif #ifndef Tcl_UnlinkVar -#define Tcl_UnlinkVar(interp, varName) \ - (tclStubsPtr->tcl_UnlinkVar)(interp, varName) /* 251 */ +#define Tcl_UnlinkVar \ + (tclStubsPtr->tcl_UnlinkVar) /* 251 */ #endif #ifndef Tcl_UnregisterChannel -#define Tcl_UnregisterChannel(interp, chan) \ - (tclStubsPtr->tcl_UnregisterChannel)(interp, chan) /* 252 */ +#define Tcl_UnregisterChannel \ + (tclStubsPtr->tcl_UnregisterChannel) /* 252 */ #endif #ifndef Tcl_UnsetVar -#define Tcl_UnsetVar(interp, varName, flags) \ - (tclStubsPtr->tcl_UnsetVar)(interp, varName, flags) /* 253 */ +#define Tcl_UnsetVar \ + (tclStubsPtr->tcl_UnsetVar) /* 253 */ #endif #ifndef Tcl_UnsetVar2 -#define Tcl_UnsetVar2(interp, part1, part2, flags) \ - (tclStubsPtr->tcl_UnsetVar2)(interp, part1, part2, flags) /* 254 */ +#define Tcl_UnsetVar2 \ + (tclStubsPtr->tcl_UnsetVar2) /* 254 */ #endif #ifndef Tcl_UntraceVar -#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \ - (tclStubsPtr->tcl_UntraceVar)(interp, varName, flags, proc, clientData) /* 255 */ +#define Tcl_UntraceVar \ + (tclStubsPtr->tcl_UntraceVar) /* 255 */ #endif #ifndef Tcl_UntraceVar2 -#define Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) \ - (tclStubsPtr->tcl_UntraceVar2)(interp, part1, part2, flags, proc, clientData) /* 256 */ +#define Tcl_UntraceVar2 \ + (tclStubsPtr->tcl_UntraceVar2) /* 256 */ #endif #ifndef Tcl_UpdateLinkedVar -#define Tcl_UpdateLinkedVar(interp, varName) \ - (tclStubsPtr->tcl_UpdateLinkedVar)(interp, varName) /* 257 */ +#define Tcl_UpdateLinkedVar \ + (tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */ #endif #ifndef Tcl_UpVar -#define Tcl_UpVar(interp, frameName, varName, localName, flags) \ - (tclStubsPtr->tcl_UpVar)(interp, frameName, varName, localName, flags) /* 258 */ +#define Tcl_UpVar \ + (tclStubsPtr->tcl_UpVar) /* 258 */ #endif #ifndef Tcl_UpVar2 -#define Tcl_UpVar2(interp, frameName, part1, part2, localName, flags) \ - (tclStubsPtr->tcl_UpVar2)(interp, frameName, part1, part2, localName, flags) /* 259 */ +#define Tcl_UpVar2 \ + (tclStubsPtr->tcl_UpVar2) /* 259 */ #endif #ifndef Tcl_VarEval #define Tcl_VarEval \ (tclStubsPtr->tcl_VarEval) /* 260 */ #endif #ifndef Tcl_VarTraceInfo -#define Tcl_VarTraceInfo(interp, varName, flags, procPtr, prevClientData) \ - (tclStubsPtr->tcl_VarTraceInfo)(interp, varName, flags, procPtr, prevClientData) /* 261 */ +#define Tcl_VarTraceInfo \ + (tclStubsPtr->tcl_VarTraceInfo) /* 261 */ #endif #ifndef Tcl_VarTraceInfo2 -#define Tcl_VarTraceInfo2(interp, part1, part2, flags, procPtr, prevClientData) \ - (tclStubsPtr->tcl_VarTraceInfo2)(interp, part1, part2, flags, procPtr, prevClientData) /* 262 */ +#define Tcl_VarTraceInfo2 \ + (tclStubsPtr->tcl_VarTraceInfo2) /* 262 */ #endif #ifndef Tcl_Write -#define Tcl_Write(chan, s, slen) \ - (tclStubsPtr->tcl_Write)(chan, s, slen) /* 263 */ +#define Tcl_Write \ + (tclStubsPtr->tcl_Write) /* 263 */ #endif #ifndef Tcl_WrongNumArgs -#define Tcl_WrongNumArgs(interp, objc, objv, message) \ - (tclStubsPtr->tcl_WrongNumArgs)(interp, objc, objv, message) /* 264 */ +#define Tcl_WrongNumArgs \ + (tclStubsPtr->tcl_WrongNumArgs) /* 264 */ #endif #ifndef Tcl_DumpActiveMemory -#define Tcl_DumpActiveMemory(fileName) \ - (tclStubsPtr->tcl_DumpActiveMemory)(fileName) /* 265 */ +#define Tcl_DumpActiveMemory \ + (tclStubsPtr->tcl_DumpActiveMemory) /* 265 */ #endif #ifndef Tcl_ValidateAllMemory -#define Tcl_ValidateAllMemory(file, line) \ - (tclStubsPtr->tcl_ValidateAllMemory)(file, line) /* 266 */ +#define Tcl_ValidateAllMemory \ + (tclStubsPtr->tcl_ValidateAllMemory) /* 266 */ #endif #ifndef Tcl_AppendResultVA -#define Tcl_AppendResultVA(interp, argList) \ - (tclStubsPtr->tcl_AppendResultVA)(interp, argList) /* 267 */ +#define Tcl_AppendResultVA \ + (tclStubsPtr->tcl_AppendResultVA) /* 267 */ #endif #ifndef Tcl_AppendStringsToObjVA -#define Tcl_AppendStringsToObjVA(objPtr, argList) \ - (tclStubsPtr->tcl_AppendStringsToObjVA)(objPtr, argList) /* 268 */ +#define Tcl_AppendStringsToObjVA \ + (tclStubsPtr->tcl_AppendStringsToObjVA) /* 268 */ #endif #ifndef Tcl_HashStats -#define Tcl_HashStats(tablePtr) \ - (tclStubsPtr->tcl_HashStats)(tablePtr) /* 269 */ +#define Tcl_HashStats \ + (tclStubsPtr->tcl_HashStats) /* 269 */ #endif #ifndef Tcl_ParseVar -#define Tcl_ParseVar(interp, string, termPtr) \ - (tclStubsPtr->tcl_ParseVar)(interp, string, termPtr) /* 270 */ +#define Tcl_ParseVar \ + (tclStubsPtr->tcl_ParseVar) /* 270 */ #endif #ifndef Tcl_PkgPresent -#define Tcl_PkgPresent(interp, name, version, exact) \ - (tclStubsPtr->tcl_PkgPresent)(interp, name, version, exact) /* 271 */ +#define Tcl_PkgPresent \ + (tclStubsPtr->tcl_PkgPresent) /* 271 */ #endif #ifndef Tcl_PkgPresentEx -#define Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) \ - (tclStubsPtr->tcl_PkgPresentEx)(interp, name, version, exact, clientDataPtr) /* 272 */ +#define Tcl_PkgPresentEx \ + (tclStubsPtr->tcl_PkgPresentEx) /* 272 */ #endif #ifndef Tcl_PkgProvide -#define Tcl_PkgProvide(interp, name, version) \ - (tclStubsPtr->tcl_PkgProvide)(interp, name, version) /* 273 */ +#define Tcl_PkgProvide \ + (tclStubsPtr->tcl_PkgProvide) /* 273 */ #endif #ifndef Tcl_PkgRequire -#define Tcl_PkgRequire(interp, name, version, exact) \ - (tclStubsPtr->tcl_PkgRequire)(interp, name, version, exact) /* 274 */ +#define Tcl_PkgRequire \ + (tclStubsPtr->tcl_PkgRequire) /* 274 */ #endif #ifndef Tcl_SetErrorCodeVA -#define Tcl_SetErrorCodeVA(interp, argList) \ - (tclStubsPtr->tcl_SetErrorCodeVA)(interp, argList) /* 275 */ +#define Tcl_SetErrorCodeVA \ + (tclStubsPtr->tcl_SetErrorCodeVA) /* 275 */ #endif #ifndef Tcl_VarEvalVA -#define Tcl_VarEvalVA(interp, argList) \ - (tclStubsPtr->tcl_VarEvalVA)(interp, argList) /* 276 */ +#define Tcl_VarEvalVA \ + (tclStubsPtr->tcl_VarEvalVA) /* 276 */ #endif #ifndef Tcl_WaitPid -#define Tcl_WaitPid(pid, statPtr, options) \ - (tclStubsPtr->tcl_WaitPid)(pid, statPtr, options) /* 277 */ +#define Tcl_WaitPid \ + (tclStubsPtr->tcl_WaitPid) /* 277 */ #endif -#ifndef panicVA -#define panicVA(format, argList) \ - (tclStubsPtr->panicVA)(format, argList) /* 278 */ +#ifndef Tcl_PanicVA +#define Tcl_PanicVA \ + (tclStubsPtr->tcl_PanicVA) /* 278 */ #endif #ifndef Tcl_GetVersion -#define Tcl_GetVersion(major, minor, patchLevel, type) \ - (tclStubsPtr->tcl_GetVersion)(major, minor, patchLevel, type) /* 279 */ +#define Tcl_GetVersion \ + (tclStubsPtr->tcl_GetVersion) /* 279 */ +#endif +#ifndef Tcl_InitMemory +#define Tcl_InitMemory \ + (tclStubsPtr->tcl_InitMemory) /* 280 */ +#endif +/* Slot 281 is reserved */ +/* Slot 282 is reserved */ +/* Slot 283 is reserved */ +/* Slot 284 is reserved */ +/* Slot 285 is reserved */ +#ifndef Tcl_AppendObjToObj +#define Tcl_AppendObjToObj \ + (tclStubsPtr->tcl_AppendObjToObj) /* 286 */ +#endif +#ifndef Tcl_CreateEncoding +#define Tcl_CreateEncoding \ + (tclStubsPtr->tcl_CreateEncoding) /* 287 */ +#endif +#ifndef Tcl_CreateThreadExitHandler +#define Tcl_CreateThreadExitHandler \ + (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */ +#endif +#ifndef Tcl_DeleteThreadExitHandler +#define Tcl_DeleteThreadExitHandler \ + (tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */ +#endif +#ifndef Tcl_DiscardResult +#define Tcl_DiscardResult \ + (tclStubsPtr->tcl_DiscardResult) /* 290 */ +#endif +#ifndef Tcl_EvalEx +#define Tcl_EvalEx \ + (tclStubsPtr->tcl_EvalEx) /* 291 */ +#endif +#ifndef Tcl_EvalObjv +#define Tcl_EvalObjv \ + (tclStubsPtr->tcl_EvalObjv) /* 292 */ +#endif +#ifndef Tcl_EvalObjEx +#define Tcl_EvalObjEx \ + (tclStubsPtr->tcl_EvalObjEx) /* 293 */ +#endif +#ifndef Tcl_ExitThread +#define Tcl_ExitThread \ + (tclStubsPtr->tcl_ExitThread) /* 294 */ +#endif +#ifndef Tcl_ExternalToUtf +#define Tcl_ExternalToUtf \ + (tclStubsPtr->tcl_ExternalToUtf) /* 295 */ +#endif +#ifndef Tcl_ExternalToUtfDString +#define Tcl_ExternalToUtfDString \ + (tclStubsPtr->tcl_ExternalToUtfDString) /* 296 */ +#endif +#ifndef Tcl_FinalizeThread +#define Tcl_FinalizeThread \ + (tclStubsPtr->tcl_FinalizeThread) /* 297 */ +#endif +#ifndef Tcl_FinalizeNotifier +#define Tcl_FinalizeNotifier \ + (tclStubsPtr->tcl_FinalizeNotifier) /* 298 */ +#endif +#ifndef Tcl_FreeEncoding +#define Tcl_FreeEncoding \ + (tclStubsPtr->tcl_FreeEncoding) /* 299 */ +#endif +#ifndef Tcl_GetCurrentThread +#define Tcl_GetCurrentThread \ + (tclStubsPtr->tcl_GetCurrentThread) /* 300 */ +#endif +#ifndef Tcl_GetEncoding +#define Tcl_GetEncoding \ + (tclStubsPtr->tcl_GetEncoding) /* 301 */ +#endif +#ifndef Tcl_GetEncodingName +#define Tcl_GetEncodingName \ + (tclStubsPtr->tcl_GetEncodingName) /* 302 */ +#endif +#ifndef Tcl_GetEncodingNames +#define Tcl_GetEncodingNames \ + (tclStubsPtr->tcl_GetEncodingNames) /* 303 */ +#endif +#ifndef Tcl_GetIndexFromObjStruct +#define Tcl_GetIndexFromObjStruct \ + (tclStubsPtr->tcl_GetIndexFromObjStruct) /* 304 */ +#endif +#ifndef Tcl_GetThreadData +#define Tcl_GetThreadData \ + (tclStubsPtr->tcl_GetThreadData) /* 305 */ +#endif +#ifndef Tcl_GetVar2Ex +#define Tcl_GetVar2Ex \ + (tclStubsPtr->tcl_GetVar2Ex) /* 306 */ +#endif +#ifndef Tcl_InitNotifier +#define Tcl_InitNotifier \ + (tclStubsPtr->tcl_InitNotifier) /* 307 */ +#endif +#ifndef Tcl_MutexLock +#define Tcl_MutexLock \ + (tclStubsPtr->tcl_MutexLock) /* 308 */ +#endif +#ifndef Tcl_MutexUnlock +#define Tcl_MutexUnlock \ + (tclStubsPtr->tcl_MutexUnlock) /* 309 */ +#endif +#ifndef Tcl_ConditionNotify +#define Tcl_ConditionNotify \ + (tclStubsPtr->tcl_ConditionNotify) /* 310 */ +#endif +#ifndef Tcl_ConditionWait +#define Tcl_ConditionWait \ + (tclStubsPtr->tcl_ConditionWait) /* 311 */ +#endif +#ifndef Tcl_NumUtfChars +#define Tcl_NumUtfChars \ + (tclStubsPtr->tcl_NumUtfChars) /* 312 */ +#endif +#ifndef Tcl_ReadChars +#define Tcl_ReadChars \ + (tclStubsPtr->tcl_ReadChars) /* 313 */ +#endif +#ifndef Tcl_RestoreResult +#define Tcl_RestoreResult \ + (tclStubsPtr->tcl_RestoreResult) /* 314 */ +#endif +#ifndef Tcl_SaveResult +#define Tcl_SaveResult \ + (tclStubsPtr->tcl_SaveResult) /* 315 */ +#endif +#ifndef Tcl_SetSystemEncoding +#define Tcl_SetSystemEncoding \ + (tclStubsPtr->tcl_SetSystemEncoding) /* 316 */ +#endif +#ifndef Tcl_SetVar2Ex +#define Tcl_SetVar2Ex \ + (tclStubsPtr->tcl_SetVar2Ex) /* 317 */ +#endif +#ifndef Tcl_ThreadAlert +#define Tcl_ThreadAlert \ + (tclStubsPtr->tcl_ThreadAlert) /* 318 */ +#endif +#ifndef Tcl_ThreadQueueEvent +#define Tcl_ThreadQueueEvent \ + (tclStubsPtr->tcl_ThreadQueueEvent) /* 319 */ +#endif +#ifndef Tcl_UniCharAtIndex +#define Tcl_UniCharAtIndex \ + (tclStubsPtr->tcl_UniCharAtIndex) /* 320 */ +#endif +#ifndef Tcl_UniCharToLower +#define Tcl_UniCharToLower \ + (tclStubsPtr->tcl_UniCharToLower) /* 321 */ +#endif +#ifndef Tcl_UniCharToTitle +#define Tcl_UniCharToTitle \ + (tclStubsPtr->tcl_UniCharToTitle) /* 322 */ +#endif +#ifndef Tcl_UniCharToUpper +#define Tcl_UniCharToUpper \ + (tclStubsPtr->tcl_UniCharToUpper) /* 323 */ +#endif +#ifndef Tcl_UniCharToUtf +#define Tcl_UniCharToUtf \ + (tclStubsPtr->tcl_UniCharToUtf) /* 324 */ +#endif +#ifndef Tcl_UtfAtIndex +#define Tcl_UtfAtIndex \ + (tclStubsPtr->tcl_UtfAtIndex) /* 325 */ +#endif +#ifndef Tcl_UtfCharComplete +#define Tcl_UtfCharComplete \ + (tclStubsPtr->tcl_UtfCharComplete) /* 326 */ +#endif +#ifndef Tcl_UtfBackslash +#define Tcl_UtfBackslash \ + (tclStubsPtr->tcl_UtfBackslash) /* 327 */ +#endif +#ifndef Tcl_UtfFindFirst +#define Tcl_UtfFindFirst \ + (tclStubsPtr->tcl_UtfFindFirst) /* 328 */ +#endif +#ifndef Tcl_UtfFindLast +#define Tcl_UtfFindLast \ + (tclStubsPtr->tcl_UtfFindLast) /* 329 */ +#endif +#ifndef Tcl_UtfNext +#define Tcl_UtfNext \ + (tclStubsPtr->tcl_UtfNext) /* 330 */ +#endif +#ifndef Tcl_UtfPrev +#define Tcl_UtfPrev \ + (tclStubsPtr->tcl_UtfPrev) /* 331 */ +#endif +#ifndef Tcl_UtfToExternal +#define Tcl_UtfToExternal \ + (tclStubsPtr->tcl_UtfToExternal) /* 332 */ +#endif +#ifndef Tcl_UtfToExternalDString +#define Tcl_UtfToExternalDString \ + (tclStubsPtr->tcl_UtfToExternalDString) /* 333 */ +#endif +#ifndef Tcl_UtfToLower +#define Tcl_UtfToLower \ + (tclStubsPtr->tcl_UtfToLower) /* 334 */ +#endif +#ifndef Tcl_UtfToTitle +#define Tcl_UtfToTitle \ + (tclStubsPtr->tcl_UtfToTitle) /* 335 */ +#endif +#ifndef Tcl_UtfToUniChar +#define Tcl_UtfToUniChar \ + (tclStubsPtr->tcl_UtfToUniChar) /* 336 */ +#endif +#ifndef Tcl_UtfToUpper +#define Tcl_UtfToUpper \ + (tclStubsPtr->tcl_UtfToUpper) /* 337 */ +#endif +#ifndef Tcl_WriteChars +#define Tcl_WriteChars \ + (tclStubsPtr->tcl_WriteChars) /* 338 */ +#endif +#ifndef Tcl_WriteObj +#define Tcl_WriteObj \ + (tclStubsPtr->tcl_WriteObj) /* 339 */ +#endif +#ifndef Tcl_GetString +#define Tcl_GetString \ + (tclStubsPtr->tcl_GetString) /* 340 */ +#endif +#ifndef Tcl_GetDefaultEncodingDir +#define Tcl_GetDefaultEncodingDir \ + (tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */ +#endif +#ifndef Tcl_SetDefaultEncodingDir +#define Tcl_SetDefaultEncodingDir \ + (tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */ +#endif +#ifndef Tcl_AlertNotifier +#define Tcl_AlertNotifier \ + (tclStubsPtr->tcl_AlertNotifier) /* 343 */ +#endif +#ifndef Tcl_ServiceModeHook +#define Tcl_ServiceModeHook \ + (tclStubsPtr->tcl_ServiceModeHook) /* 344 */ +#endif +#ifndef Tcl_UniCharIsAlnum +#define Tcl_UniCharIsAlnum \ + (tclStubsPtr->tcl_UniCharIsAlnum) /* 345 */ +#endif +#ifndef Tcl_UniCharIsAlpha +#define Tcl_UniCharIsAlpha \ + (tclStubsPtr->tcl_UniCharIsAlpha) /* 346 */ +#endif +#ifndef Tcl_UniCharIsDigit +#define Tcl_UniCharIsDigit \ + (tclStubsPtr->tcl_UniCharIsDigit) /* 347 */ +#endif +#ifndef Tcl_UniCharIsLower +#define Tcl_UniCharIsLower \ + (tclStubsPtr->tcl_UniCharIsLower) /* 348 */ +#endif +#ifndef Tcl_UniCharIsSpace +#define Tcl_UniCharIsSpace \ + (tclStubsPtr->tcl_UniCharIsSpace) /* 349 */ +#endif +#ifndef Tcl_UniCharIsUpper +#define Tcl_UniCharIsUpper \ + (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ +#endif +#ifndef Tcl_UniCharIsWordChar +#define Tcl_UniCharIsWordChar \ + (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ +#endif +#ifndef Tcl_UniCharLen +#define Tcl_UniCharLen \ + (tclStubsPtr->tcl_UniCharLen) /* 352 */ +#endif +#ifndef Tcl_UniCharNcmp +#define Tcl_UniCharNcmp \ + (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ +#endif +#ifndef Tcl_UniCharToUtfDString +#define Tcl_UniCharToUtfDString \ + (tclStubsPtr->tcl_UniCharToUtfDString) /* 354 */ +#endif +#ifndef Tcl_UtfToUniCharDString +#define Tcl_UtfToUniCharDString \ + (tclStubsPtr->tcl_UtfToUniCharDString) /* 355 */ +#endif +#ifndef Tcl_GetRegExpFromObj +#define Tcl_GetRegExpFromObj \ + (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */ +#endif +#ifndef Tcl_EvalTokens +#define Tcl_EvalTokens \ + (tclStubsPtr->tcl_EvalTokens) /* 357 */ +#endif +#ifndef Tcl_FreeParse +#define Tcl_FreeParse \ + (tclStubsPtr->tcl_FreeParse) /* 358 */ +#endif +#ifndef Tcl_LogCommandInfo +#define Tcl_LogCommandInfo \ + (tclStubsPtr->tcl_LogCommandInfo) /* 359 */ +#endif +#ifndef Tcl_ParseBraces +#define Tcl_ParseBraces \ + (tclStubsPtr->tcl_ParseBraces) /* 360 */ +#endif +#ifndef Tcl_ParseCommand +#define Tcl_ParseCommand \ + (tclStubsPtr->tcl_ParseCommand) /* 361 */ +#endif +#ifndef Tcl_ParseExpr +#define Tcl_ParseExpr \ + (tclStubsPtr->tcl_ParseExpr) /* 362 */ +#endif +#ifndef Tcl_ParseQuotedString +#define Tcl_ParseQuotedString \ + (tclStubsPtr->tcl_ParseQuotedString) /* 363 */ +#endif +#ifndef Tcl_ParseVarName +#define Tcl_ParseVarName \ + (tclStubsPtr->tcl_ParseVarName) /* 364 */ +#endif +#ifndef Tcl_GetCwd +#define Tcl_GetCwd \ + (tclStubsPtr->tcl_GetCwd) /* 365 */ +#endif +#ifndef Tcl_Chdir +#define Tcl_Chdir \ + (tclStubsPtr->tcl_Chdir) /* 366 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c new file mode 100644 index 0000000..40ded74 --- /dev/null +++ b/generic/tclEncoding.c @@ -0,0 +1,2685 @@ +/* + * tclEncoding.c -- + * + * Contains the implementation of the encoding conversion package. + * + * Copyright (c) 1996-1998 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: tclEncoding.c,v 1.2 1999/04/16 00:46:45 stanton Exp $ + */ + +#include "tclInt.h" +#include "tclPort.h" + +typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src)); + +/* + * The following data structure represents an encoding, which describes how + * to convert between various character sets and UTF-8. + */ + +typedef struct Encoding { + char *name; /* Name of encoding. Malloced because (1) + * hash table entry that owns this encoding + * may be freed prior to this encoding being + * freed, (2) string passed in the + * Tcl_EncodingType structure may not be + * persistent. */ + Tcl_EncodingConvertProc *toUtfProc; + /* Procedure to convert from external + * encoding into UTF-8. */ + Tcl_EncodingConvertProc *fromUtfProc; + /* Procedure to convert from UTF-8 into + * external encoding. */ + Tcl_EncodingFreeProc *freeProc; + /* If non-NULL, procedure to call when this + * encoding is deleted. */ + int nullSize; /* Number of 0x00 bytes that signify + * end-of-string in this encoding. This + * number is used to determine the source + * string length when the srcLen argument is + * negative. This number can be 1 or 2. */ + ClientData clientData; /* Arbitrary value associated with encoding + * type. Passed to conversion procedures. */ + LengthProc *lengthProc; /* Function to compute length of + * null-terminated strings in this encoding. + * If nullSize is 1, this is strlen; if + * nullSize is 2, this is a function that + * returns the number of bytes in a 0x0000 + * terminated string. */ + int refCount; /* Number of uses of this structure. */ + Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */ +} Encoding; + +/* + * The following structure is the clientData for a dynamically-loaded, + * table-driven encoding created by LoadTableEncoding(). It maps between + * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only) + * encoding. + */ + +typedef struct TableEncodingData { + int fallback; /* Character (in this encoding) to + * substitute when this encoding cannot + * represent a UTF-8 character. */ + char prefixBytes[256]; /* If a byte in the input stream is a lead + * byte for a 2-byte sequence, the + * corresponding entry in this array is 1, + * otherwise it is 0. */ + unsigned short **toUnicode; /* Two dimensional sparse matrix to map + * characters from the encoding to Unicode. + * Each element of the toUnicode array points + * to an array of 256 shorts. If there is no + * corresponding character in Unicode, the + * value in the matrix is 0x0000. malloc'd. */ + unsigned short **fromUnicode; + /* Two dimensional sparse matrix to map + * characters from Unicode to the encoding. + * Each element of the fromUnicode array + * points to an array of 256 shorts. If there + * is no corresponding character the encoding, + * the value in the matrix is 0x0000. + * malloc'd. */ +} TableEncodingData; + +/* + * The following structures is the clientData for a dynamically-loaded, + * escape-driven encoding that is itself comprised of other simpler + * encodings. An example is "iso-2022-jp", which uses escape sequences to + * switch between ascii, jis0208, jis0212, gb2312, and ksc5601. Note that + * "escape-driven" does not necessarily mean that the ESCAPE character is + * the character used for switching character sets. + */ + +typedef struct EscapeSubTable { + unsigned int sequenceLen; /* Length of following string. */ + char sequence[16]; /* Escape code that marks this encoding. */ + char name[32]; /* Name for encoding. */ + Encoding *encodingPtr; /* Encoding loaded using above name, or NULL + * if this sub-encoding has not been needed + * yet. */ +} EscapeSubTable; + +typedef struct EscapeEncodingData { + int fallback; /* Character (in this encoding) to + * substitute when this encoding cannot + * represent a UTF-8 character. */ + unsigned int initLen; /* Length of following string. */ + char init[16]; /* String to emit or expect before first char + * in conversion. */ + unsigned int finalLen; /* Length of following string. */ + char final[16]; /* String to emit or expect after last char + * in conversion. */ + char prefixBytes[256]; /* If a byte in the input stream is the + * first character of one of the escape + * sequences in the following array, the + * corresponding entry in this array is 1, + * otherwise it is 0. */ + int numSubTables; /* Length of following array. */ + EscapeSubTable subTables[1];/* Information about each EscapeSubTable + * used by this encoding type. The actual + * size will be as large as necessary to + * hold all EscapeSubTables. */ +} EscapeEncodingData; + +/* + * Constants used when loading an encoding file to identify the type of the + * file. + */ + +#define ENCODING_SINGLEBYTE 0 +#define ENCODING_DOUBLEBYTE 1 +#define ENCODING_MULTIBYTE 2 +#define ENCODING_ESCAPE 3 + +/* + * Initialize the default encoding directory. If this variable contains + * a non NULL value, it will be the first path used to locate the + * system encoding files. + */ + +char *tclDefaultEncodingDir = NULL; + +/* + * Hash table that keeps track of all loaded Encodings. Keys are + * the string names that represent the encoding, values are (Encoding *). + */ + +static Tcl_HashTable encodingTable; +TCL_DECLARE_MUTEX(encodingMutex) + +/* + * The following are used to hold the default and current system encodings. + * If NULL is passed to one of the conversion routines, the current setting + * of the system encoding will be used to perform the conversion. + */ + +static Tcl_Encoding defaultEncoding; +static Tcl_Encoding systemEncoding; + +/* + * The following variable is used in the sparse matrix code for a + * TableEncoding to represent a page in the table that has no entries. + */ + +static unsigned short emptyPage[256]; + +/* + * Procedures used only in this module. + */ + +static int BinaryProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static void EscapeFreeProc _ANSI_ARGS_((ClientData clientData)); +static int EscapeFromUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static int EscapeToUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static void FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); +static Encoding * GetTableEncoding _ANSI_ARGS_(( + EscapeEncodingData *dataPtr, int state)); +static Tcl_Encoding LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *name)); +static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *name, int type, Tcl_Channel chan)); +static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name, + Tcl_Channel chan)); +static Tcl_Channel OpenEncodingFile _ANSI_ARGS_((CONST char *dir, + CONST char *name)); +static void TableFreeProc _ANSI_ARGS_((ClientData clientData)); +static int TableFromUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static int TableToUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static size_t unilen _ANSI_ARGS_((CONST char *src)); +static int UnicodeToUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static int UtfToUnicodeProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static int UtfToUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); + + +/* + *--------------------------------------------------------------------------- + * + * TclInitEncodingSubsystem -- + * + * Initialize all resources used by this subsystem on a per-process + * basis. + * + * Results: + * None. + * + * Side effects: + * Depends on the memory, object, and IO subsystems. + * + *--------------------------------------------------------------------------- + */ + +void +TclInitEncodingSubsystem() +{ + Tcl_EncodingType type; + + Tcl_MutexLock(&encodingMutex); + Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS); + Tcl_MutexUnlock(&encodingMutex); + + /* + * Create a few initial encodings. Note that the UTF-8 to UTF-8 + * translation is not a no-op, because it will turn a stream of + * improperly formed UTF-8 into a properly formed stream. + */ + + type.encodingName = "identity"; + type.toUtfProc = BinaryProc; + type.fromUtfProc = BinaryProc; + type.freeProc = NULL; + type.nullSize = 1; + type.clientData = NULL; + + defaultEncoding = Tcl_CreateEncoding(&type); + systemEncoding = Tcl_GetEncoding(NULL, type.encodingName); + + type.encodingName = "utf-8"; + type.toUtfProc = UtfToUtfProc; + type.fromUtfProc = UtfToUtfProc; + type.freeProc = NULL; + type.nullSize = 1; + type.clientData = NULL; + Tcl_CreateEncoding(&type); + + type.encodingName = "unicode"; + type.toUtfProc = UnicodeToUtfProc; + type.fromUtfProc = UtfToUnicodeProc; + type.freeProc = NULL; + type.nullSize = 2; + type.clientData = NULL; + Tcl_CreateEncoding(&type); +} + + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeEncodingSubsystem -- + * + * Release the state associated with the encoding subsystem. + * + * Results: + * None. + * + * Side effects: + * Frees all of the encodings. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeEncodingSubsystem() +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + Encoding *encodingPtr; + + Tcl_MutexLock(&encodingMutex); + hPtr = Tcl_FirstHashEntry(&encodingTable, &search); + while (hPtr != NULL) { + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); + if (encodingPtr->freeProc != NULL) { + (*encodingPtr->freeProc)(encodingPtr->clientData); + } + ckfree((char *) encodingPtr->name); + ckfree((char *) encodingPtr); + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_DeleteHashTable(&encodingTable); + Tcl_MutexUnlock(&encodingMutex); +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_GetDefaultEncodingDir -- + * + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +char * +Tcl_GetDefaultEncodingDir() +{ + return tclDefaultEncodingDir; +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_SetDefaultEncodingDir -- + * + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +void +Tcl_SetDefaultEncodingDir(path) + char *path; +{ + tclDefaultEncodingDir = (char *)ckalloc((unsigned) strlen(path) + 1); + strcpy(tclDefaultEncodingDir, path); +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_GetEncoding -- + * + * Given the name of a encoding, find the corresponding Tcl_Encoding + * token. If the encoding did not already exist, Tcl attempts to + * dynamically load an encoding by that name. + * + * Results: + * Returns a token that represents the encoding. If the name didn't + * refer to any known or loadable encoding, NULL is returned. If + * NULL was returned, an error message is left in interp's result + * object, unless interp was NULL. + * + * Side effects: + * The new encoding type is entered into a table visible to all + * interpreters, keyed off the encoding's name. For each call to + * this procedure, there should eventually be a call to + * Tcl_FreeEncoding, so that the database can be cleaned up when + * encodings aren't needed anymore. + * + *------------------------------------------------------------------------- + */ + +Tcl_Encoding +Tcl_GetEncoding(interp, name) + Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ + CONST char *name; /* The name of the desired encoding. */ +{ + Tcl_HashEntry *hPtr; + Encoding *encodingPtr; + + Tcl_MutexLock(&encodingMutex); + if (name == NULL) { + encodingPtr = (Encoding *) systemEncoding; + encodingPtr->refCount++; + Tcl_MutexUnlock(&encodingMutex); + return systemEncoding; + } + + hPtr = Tcl_FindHashEntry(&encodingTable, name); + if (hPtr != NULL) { + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); + encodingPtr->refCount++; + Tcl_MutexUnlock(&encodingMutex); + return (Tcl_Encoding) encodingPtr; + } + Tcl_MutexUnlock(&encodingMutex); + return LoadEncodingFile(interp, name); +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FreeEncoding -- + * + * This procedure is called to release an encoding allocated by + * Tcl_CreateEncoding() or Tcl_GetEncoding(). + * + * Results: + * None. + * + * Side effects: + * The reference count associated with the encoding is decremented + * and the encoding may be deleted if nothing is using it anymore. + * + *--------------------------------------------------------------------------- + */ + +void +Tcl_FreeEncoding(encoding) + Tcl_Encoding encoding; +{ + Tcl_MutexLock(&encodingMutex); + FreeEncoding(encoding); + Tcl_MutexUnlock(&encodingMutex); +} + +/* + *---------------------------------------------------------------------- + * + * FreeEncoding -- + * + * This procedure is called to release an encoding by procedures + * that already have the encodingMutex. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with the encoding is decremented + * and the encoding may be deleted if nothing is using it anymore. + * + *---------------------------------------------------------------------- + */ + +static void +FreeEncoding(encoding) + Tcl_Encoding encoding; +{ + Encoding *encodingPtr; + + encodingPtr = (Encoding *) encoding; + if (encodingPtr == NULL) { + return; + } + encodingPtr->refCount--; + if (encodingPtr->refCount == 0) { + if (encodingPtr->freeProc != NULL) { + (*encodingPtr->freeProc)(encodingPtr->clientData); + } + if (encodingPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(encodingPtr->hPtr); + } + ckfree((char *) encodingPtr->name); + ckfree((char *) encodingPtr); + } +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_GetEncodingName -- + * + * Given an encoding, return the name that was used to constuct + * the encoding. + * + * Results: + * The name of the encoding. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +char * +Tcl_GetEncodingName(encoding) + Tcl_Encoding encoding; /* The encoding whose name to fetch. */ +{ + Encoding *encodingPtr; + + if (encoding == NULL) { + encoding = systemEncoding; + } + encodingPtr = (Encoding *) encoding; + return encodingPtr->name; +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_GetEncodingNames -- + * + * Get the list of all known encodings, including the ones stored + * as files on disk in the encoding path. + * + * Results: + * Modifies interp's result object to hold a list of all the available + * encodings. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +void +Tcl_GetEncodingNames(interp) + Tcl_Interp *interp; /* Interp to hold result. */ +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + Tcl_Obj *pathPtr, *resultPtr; + int dummy; + + Tcl_HashTable table; + + Tcl_MutexLock(&encodingMutex); + Tcl_InitHashTable(&table, TCL_STRING_KEYS); + hPtr = Tcl_FirstHashEntry(&encodingTable, &search); + while (hPtr != NULL) { + Encoding *encodingPtr; + + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); + Tcl_CreateHashEntry(&table, encodingPtr->name, &dummy); + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_MutexUnlock(&encodingMutex); + + pathPtr = TclGetLibraryPath(); + if (pathPtr != NULL) { + int i, objc; + Tcl_Obj **objv; + Tcl_DString pwdString; + char globArgString[10]; + + objc = 0; + Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); + + Tcl_GetCwd(interp, &pwdString); + + for (i = 0; i < objc; i++) { + char *string; + int j, objc2, length; + Tcl_Obj **objv2; + + string = Tcl_GetStringFromObj(objv[i], NULL); + Tcl_ResetResult(interp); + + /* + * TclGlob() changes the contents of globArgString, which causes + * a segfault if we pass in a pointer to non-writeable memory. + * TclGlob() puts its results directly into interp. + */ + + strcpy(globArgString, "*.enc"); + if ((Tcl_Chdir(string) == 0) + && (Tcl_Chdir("encoding") == 0) + && (TclGlob(interp, globArgString, 0) == TCL_OK)) { + objc2 = 0; + + Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2, + &objv2); + + for (j = 0; j < objc2; j++) { + string = Tcl_GetStringFromObj(objv2[j], &length); + length -= 4; + if (length > 0) { + string[length] = '\0'; + Tcl_CreateHashEntry(&table, string, &dummy); + string[length] = '.'; + } + } + } + Tcl_Chdir(Tcl_DStringValue(&pwdString)); + } + Tcl_DStringFree(&pwdString); + } + + /* + * Clear any values placed in the result by globbing. + */ + + Tcl_ResetResult(interp); + resultPtr = Tcl_GetObjResult(interp); + + hPtr = Tcl_FirstHashEntry(&table, &search); + while (hPtr != NULL) { + Tcl_Obj *strPtr; + + strPtr = Tcl_NewStringObj(Tcl_GetHashKey(&table, hPtr), -1); + Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_DeleteHashTable(&table); +} + +/* + *------------------------------------------------------------------------ + * + * Tcl_SetSystemEncoding -- + * + * Sets the default encoding that should be used whenever the user + * passes a NULL value in to one of the conversion routines. + * If the supplied name is NULL, the system encoding is reset to the + * default system encoding. + * + * Results: + * The return value is TCL_OK if the system encoding was successfully + * set to the encoding specified by name, TCL_ERROR otherwise. If + * TCL_ERROR is returned, an error message is left in interp's result + * object, unless interp was NULL. + * + * Side effects: + * The reference count of the new system encoding is incremented. + * The reference count of the old system encoding is decremented and + * it may be freed. + * + *------------------------------------------------------------------------ + */ + +int +Tcl_SetSystemEncoding(interp, name) + Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ + CONST char *name; /* The name of the desired encoding, or NULL + * to reset to default encoding. */ +{ + Tcl_Encoding encoding; + Encoding *encodingPtr; + + if (name == NULL) { + Tcl_MutexLock(&encodingMutex); + encoding = defaultEncoding; + encodingPtr = (Encoding *) encoding; + encodingPtr->refCount++; + Tcl_MutexUnlock(&encodingMutex); + } else { + encoding = Tcl_GetEncoding(interp, name); + if (encoding == NULL) { + return TCL_ERROR; + } + } + + Tcl_MutexLock(&encodingMutex); + FreeEncoding(systemEncoding); + systemEncoding = encoding; + Tcl_MutexUnlock(&encodingMutex); + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_CreateEncoding -- + * + * This procedure is called to define a new encoding and the procedures + * that are used to convert between the specified encoding and Unicode. + * + * Results: + * Returns a token that represents the encoding. If an encoding with + * the same name already existed, the old encoding token remains + * valid and continues to behave as it used to, and will eventually + * be garbage collected when the last reference to it goes away. Any + * subsequent calls to Tcl_GetEncoding with the specified name will + * retrieve the most recent encoding token. + * + * Side effects: + * The new encoding type is entered into a table visible to all + * interpreters, keyed off the encoding's name. For each call to + * this procedure, there should eventually be a call to + * Tcl_FreeEncoding, so that the database can be cleaned up when + * encodings aren't needed anymore. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Encoding +Tcl_CreateEncoding(typePtr) + Tcl_EncodingType *typePtr; /* The encoding type. */ +{ + Tcl_HashEntry *hPtr; + int new; + Encoding *encodingPtr; + char *name; + + Tcl_MutexLock(&encodingMutex); + hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &new); + if (new == 0) { + /* + * Remove old encoding from hash table, but don't delete it until + * last reference goes away. + */ + + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); + encodingPtr->hPtr = NULL; + } + + name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1); + + encodingPtr = (Encoding *) ckalloc(sizeof(Encoding)); + encodingPtr->name = strcpy(name, typePtr->encodingName); + encodingPtr->toUtfProc = typePtr->toUtfProc; + encodingPtr->fromUtfProc = typePtr->fromUtfProc; + encodingPtr->freeProc = typePtr->freeProc; + encodingPtr->nullSize = typePtr->nullSize; + encodingPtr->clientData = typePtr->clientData; + if (typePtr->nullSize == 1) { + encodingPtr->lengthProc = strlen; + } else { + encodingPtr->lengthProc = unilen; + } + encodingPtr->refCount = 1; + encodingPtr->hPtr = hPtr; + Tcl_SetHashValue(hPtr, encodingPtr); + + Tcl_MutexUnlock(&encodingMutex); + + return (Tcl_Encoding) encodingPtr; +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_ExternalToUtfDString -- + * + * Convert a source buffer from the specified encoding into UTF-8. + * If any of the bytes in the source buffer are invalid or cannot + * be represented in the target encoding, a default fallback + * character will be substituted. + * + * Results: + * The converted bytes are stored in the DString, which is then NULL + * terminated. The return value is a pointer to the value stored + * in the DString. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +char * +Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr) + Tcl_Encoding encoding; /* The encoding for the source string, or + * NULL for the default system encoding. */ + CONST char *src; /* Source string in specified encoding. */ + int srcLen; /* Source string length in bytes, or < 0 for + * encoding-specific string length. */ + Tcl_DString *dstPtr; /* Uninitialized or free DString in which + * the converted string is stored. */ +{ + char *dst; + Tcl_EncodingState state; + Encoding *encodingPtr; + int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; + + Tcl_DStringInit(dstPtr); + dst = Tcl_DStringValue(dstPtr); + dstLen = dstPtr->spaceAvl - 1; + + if (encoding == NULL) { + encoding = systemEncoding; + } + encodingPtr = (Encoding *) encoding; + + if (src == NULL) { + srcLen = 0; + } else if (srcLen < 0) { + srcLen = (*encodingPtr->lengthProc)(src); + } + flags = TCL_ENCODING_START | TCL_ENCODING_END; + while (1) { + result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, + srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, + &dstChars); + soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + if (result != TCL_CONVERT_NOSPACE) { + Tcl_DStringSetLength(dstPtr, soFar); + return Tcl_DStringValue(dstPtr); + } + flags &= ~TCL_ENCODING_START; + src += srcRead; + srcLen -= srcRead; + if (Tcl_DStringLength(dstPtr) == 0) { + Tcl_DStringSetLength(dstPtr, dstLen); + } + Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); + dst = Tcl_DStringValue(dstPtr) + soFar; + dstLen = Tcl_DStringLength(dstPtr) - soFar - 1; + } +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_ExternalToUtf -- + * + * Convert a source buffer from the specified encoding into UTF-8, + * + * Results: + * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, + * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, + * as documented in tcl.h. + * + * Side effects: + * The converted bytes are stored in the output buffer. + * + *------------------------------------------------------------------------- + */ + +int +Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, + dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) + Tcl_Interp *interp; /* Interp for error return, if not NULL. */ + Tcl_Encoding encoding; /* The encoding for the source string, or + * NULL for the default system encoding. */ + CONST char *src; /* Source string in specified encoding. */ + int srcLen; /* Source string length in bytes, or < 0 for + * encoding-specific string length. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + Encoding *encodingPtr; + int result, srcRead, dstWrote, dstChars; + Tcl_EncodingState state; + + if (encoding == NULL) { + encoding = systemEncoding; + } + encodingPtr = (Encoding *) encoding; + + if (src == NULL) { + srcLen = 0; + } else if (srcLen < 0) { + srcLen = (*encodingPtr->lengthProc)(src); + } + if (statePtr == NULL) { + flags |= TCL_ENCODING_START | TCL_ENCODING_END; + statePtr = &state; + } + if (srcReadPtr == NULL) { + srcReadPtr = &srcRead; + } + if (dstWrotePtr == NULL) { + dstWrotePtr = &dstWrote; + } + if (dstCharsPtr == NULL) { + dstCharsPtr = &dstChars; + } + + /* + * If there are any null characters in the middle of the buffer, they will + * converted to the UTF-8 null character (\xC080). To get the actual + * \0 at the end of the destination buffer, we need to append it manually. + */ + + dstLen--; + result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen, + flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, + dstCharsPtr); + dst[*dstWrotePtr] = '\0'; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_UtfToExternalDString -- + * + * Convert a source buffer from UTF-8 into the specified encoding. + * If any of the bytes in the source buffer are invalid or cannot + * be represented in the target encoding, a default fallback + * character will be substituted. + * + * Results: + * The converted bytes are stored in the DString, which is then + * NULL terminated in an encoding-specific manner. The return value + * is a pointer to the value stored in the DString. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +char * +Tcl_UtfToExternalDString(encoding, src, srcLen, dstPtr) + Tcl_Encoding encoding; /* The encoding for the converted string, + * or NULL for the default system encoding. */ + CONST char *src; /* Source string in UTF-8. */ + int srcLen; /* Source string length in bytes, or < 0 for + * strlen(). */ + Tcl_DString *dstPtr; /* Uninitialized or free DString in which + * the converted string is stored. */ +{ + char *dst; + Tcl_EncodingState state; + Encoding *encodingPtr; + int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; + + Tcl_DStringInit(dstPtr); + dst = Tcl_DStringValue(dstPtr); + dstLen = dstPtr->spaceAvl - 1; + + if (encoding == NULL) { + encoding = systemEncoding; + } + encodingPtr = (Encoding *) encoding; + + if (src == NULL) { + srcLen = 0; + } else if (srcLen < 0) { + srcLen = strlen(src); + } + flags = TCL_ENCODING_START | TCL_ENCODING_END; + while (1) { + result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, + srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, + &dstChars); + soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + if (result != TCL_CONVERT_NOSPACE) { + if (encodingPtr->nullSize == 2) { + Tcl_DStringSetLength(dstPtr, soFar + 1); + } + Tcl_DStringSetLength(dstPtr, soFar); + return Tcl_DStringValue(dstPtr); + } + flags &= ~TCL_ENCODING_START; + src += srcRead; + srcLen -= srcRead; + if (Tcl_DStringLength(dstPtr) == 0) { + Tcl_DStringSetLength(dstPtr, dstLen); + } + Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); + dst = Tcl_DStringValue(dstPtr) + soFar; + dstLen = Tcl_DStringLength(dstPtr) - soFar - 1; + } +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_UtfToExternal -- + * + * Convert a buffer from UTF-8 into the specified encoding. + * + * Results: + * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, + * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, + * as documented in tcl.h. + * + * Side effects: + * The converted bytes are stored in the output buffer. + * + *------------------------------------------------------------------------- + */ + +int +Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, + dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) + Tcl_Interp *interp; /* Interp for error return, if not NULL. */ + Tcl_Encoding encoding; /* The encoding for the converted string, + * or NULL for the default system encoding. */ + CONST char *src; /* Source string in UTF-8. */ + int srcLen; /* Source string length in bytes, or < 0 for + * strlen(). */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + Encoding *encodingPtr; + int result, srcRead, dstWrote, dstChars; + Tcl_EncodingState state; + + if (encoding == NULL) { + encoding = systemEncoding; + } + encodingPtr = (Encoding *) encoding; + + if (src == NULL) { + srcLen = 0; + } else if (srcLen < 0) { + srcLen = strlen(src); + } + if (statePtr == NULL) { + flags |= TCL_ENCODING_START | TCL_ENCODING_END; + statePtr = &state; + } + if (srcReadPtr == NULL) { + srcReadPtr = &srcRead; + } + if (dstWrotePtr == NULL) { + dstWrotePtr = &dstWrote; + } + if (dstCharsPtr == NULL) { + dstCharsPtr = &dstChars; + } + + dstLen -= encodingPtr->nullSize; + result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen, + flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, + dstCharsPtr); + if (encodingPtr->nullSize == 2) { + dst[*dstWrotePtr + 1] = '\0'; + } + dst[*dstWrotePtr] = '\0'; + + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FindExecutable -- + * + * This procedure computes the absolute path name of the current + * application, given its argv[0] value. + * + * Results: + * None. + * + * Side effects: + * The variable tclExecutableName gets filled in with the file + * name for the application, if we figured it out. If we couldn't + * figure it out, tclExecutableName is set to NULL. + * + *--------------------------------------------------------------------------- + */ + +void +Tcl_FindExecutable(argv0) + CONST char *argv0; /* The value of the application's argv[0] + * (native). */ +{ + CONST char *name; + Tcl_DString buffer, nameString; + + TclInitSubsystems(argv0); + + if (argv0 == NULL) { + goto done; + } + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + if ((name = TclpFindExecutable(argv0)) == NULL) { + goto done; + } + + /* + * The value returned from TclpNameOfExecutable is a UTF string that + * is possibly dirty depending on when it was initialized. To assure + * that the UTF string is a properly encoded native string for this + * system, convert the UTF string to the default native encoding + * before the default encoding is initialized. Then, convert it back + * to UTF after the system encoding is loaded. + */ + + Tcl_UtfToExternalDString(NULL, name, -1, &buffer); + TclFindEncodings(argv0); + + /* + * Now it is OK to convert the native string back to UTF and set + * the value of the tclExecutableName. + */ + + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buffer), -1, &nameString); + tclExecutableName = (char *) + ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1)); + strcpy(tclExecutableName, Tcl_DStringValue(&nameString)); + + Tcl_DStringFree(&buffer); + Tcl_DStringFree(&nameString); + return; + + done: + TclFindEncodings(argv0); +} + +/* + *--------------------------------------------------------------------------- + * + * LoadEncodingFile -- + * + * Read a file that describes an encoding and create a new Encoding + * from the data. + * + * Results: + * The return value is the newly loaded Encoding, or NULL if + * the file didn't exist of was in the incorrect format. If NULL was + * returned, an error message is left in interp's result object, + * unless interp was NULL. + * + * Side effects: + * File read from disk. + * + *--------------------------------------------------------------------------- + */ + +static Tcl_Encoding +LoadEncodingFile(interp, name) + Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ + CONST char *name; /* The name of the encoding file on disk + * and also the name for new encoding. */ +{ + int objc, i, ch; + Tcl_Obj **objv; + Tcl_Obj *pathPtr; + Tcl_Channel chan; + Tcl_Encoding encoding; + + pathPtr = TclGetLibraryPath(); + if (pathPtr == NULL) { + goto unknown; + } + objc = 0; + Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); + + chan = NULL; + for (i = 0; i < objc; i++) { + chan = OpenEncodingFile(Tcl_GetString(objv[i]), name); + if (chan != NULL) { + break; + } + } + + if (chan == NULL) { + goto unknown; + } + + Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); + + while (1) { + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_Gets(chan, &ds); + ch = Tcl_DStringValue(&ds)[0]; + Tcl_DStringFree(&ds); + if (ch != '#') { + break; + } + } + + encoding = NULL; + switch (ch) { + case 'S': { + encoding = LoadTableEncoding(interp, name, ENCODING_SINGLEBYTE, + chan); + break; + } + case 'D': { + encoding = LoadTableEncoding(interp, name, ENCODING_DOUBLEBYTE, + chan); + break; + } + case 'M': { + encoding = LoadTableEncoding(interp, name, ENCODING_MULTIBYTE, + chan); + break; + } + case 'E': { + encoding = LoadEscapeEncoding(name, chan); + break; + } + } + if ((encoding == NULL) && (interp != NULL)) { + Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL); + } + Tcl_Close(NULL, chan); + return encoding; + + unknown: + if (interp != NULL) { + Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * OpenEncodingFile -- + * + * Look for the file encoding/.enc in the specified + * directory. + * + * Results: + * Returns an open file channel if the file exists. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Channel +OpenEncodingFile(dir, name) + CONST char *dir; + CONST char *name; + +{ + char *argv[3]; + Tcl_DString pathString; + char *path; + Tcl_Channel chan; + + argv[0] = (char *) dir; + argv[1] = "encoding"; + argv[2] = (char *) name; + + Tcl_DStringInit(&pathString); + Tcl_JoinPath(3, argv, &pathString); + path = Tcl_DStringAppend(&pathString, ".enc", -1); + chan = Tcl_OpenFileChannel(NULL, path, "r", 0); + Tcl_DStringFree(&pathString); + + return chan; +} + +/* + *------------------------------------------------------------------------- + * + * LoadTableEncoding -- + * + * Helper function for LoadEncodingTable(). Loads a table to that + * converts between Unicode and some other encoding and creates an + * encoding (using a TableEncoding structure) from that information. + * + * File contains binary data, but begins with a marker to indicate + * byte-ordering, so that same binary file can be read on either + * endian platforms. + * + * Results: + * The return value is the new encoding, or NULL if the encoding + * could not be created (because the file contained invalid data). + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Encoding +LoadTableEncoding(interp, name, type, chan) + Tcl_Interp *interp; /* Interp for temporary obj while reading. */ + CONST char *name; /* Name for new encoding. */ + int type; /* Type of encoding (ENCODING_?????). */ + Tcl_Channel chan; /* File containing new encoding. */ +{ + Tcl_DString lineString; + Tcl_Obj *objPtr; + char *line; + int i, hi, lo, numPages, symbol, fallback; + unsigned char used[256]; + unsigned int size; + TableEncodingData *dataPtr; + unsigned short *pageMemPtr; + Tcl_EncodingType encType; + char *hex; + static char staticHex[] = { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, 0, + 10, 11, 12, 13, 14, 15 + }; + + hex = staticHex - '0'; + + Tcl_DStringInit(&lineString); + Tcl_Gets(chan, &lineString); + line = Tcl_DStringValue(&lineString); + + fallback = (int) strtol(line, &line, 16); + symbol = (int) strtol(line, &line, 10); + numPages = (int) strtol(line, &line, 10); + Tcl_DStringFree(&lineString); + + if (numPages < 0) { + numPages = 0; + } else if (numPages > 256) { + numPages = 256; + } + + memset(used, 0, sizeof(used)); + +#undef PAGESIZE +#define PAGESIZE (256 * sizeof(unsigned short)) + + dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData)); + memset(dataPtr, 0, sizeof(TableEncodingData)); + + dataPtr->fallback = fallback; + + /* + * Read the table that maps characters to Unicode. Performs a single + * malloc to get the memory for the array and all the pages needed by + * the array. + */ + + size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; + dataPtr->toUnicode = (unsigned short **) ckalloc(size); + memset(dataPtr->toUnicode, 0, size); + pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256); + + if (interp == NULL) { + objPtr = Tcl_NewObj(); + } else { + objPtr = Tcl_GetObjResult(interp); + } + for (i = 0; i < numPages; i++) { + int ch; + char *p; + + Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0); + p = Tcl_GetString(objPtr); + hi = (hex[(int)p[0]] << 4) + hex[(int)p[1]]; + dataPtr->toUnicode[hi] = pageMemPtr; + p += 2; + for (lo = 0; lo < 256; lo++) { + if ((lo & 0x0f) == 0) { + p++; + } + ch = (hex[(int)p[0]] << 12) + (hex[(int)p[1]] << 8) + + (hex[(int)p[2]] << 4) + hex[(int)p[3]]; + if (ch != 0) { + used[ch >> 8] = 1; + } + *pageMemPtr = (unsigned short) ch; + pageMemPtr++; + p += 4; + } + } + if (interp == NULL) { + Tcl_DecrRefCount(objPtr); + } else { + Tcl_ResetResult(interp); + } + + if (type == ENCODING_DOUBLEBYTE) { + memset(dataPtr->prefixBytes, 1, sizeof(dataPtr->prefixBytes)); + } else { + for (hi = 1; hi < 256; hi++) { + if (dataPtr->toUnicode[hi] != NULL) { + dataPtr->prefixBytes[hi] = 1; + } + } + } + + /* + * Invert toUnicode array to produce the fromUnicode array. Performs a + * single malloc to get the memory for the array and all the pages + * needed by the array. While reading in the toUnicode array, we + * remembered what pages that would be needed for the fromUnicode array. + */ + + if (symbol) { + used[0] = 1; + } + numPages = 0; + for (hi = 0; hi < 256; hi++) { + if (used[hi]) { + numPages++; + } + } + size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; + dataPtr->fromUnicode = (unsigned short **) ckalloc(size); + memset(dataPtr->fromUnicode, 0, size); + pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256); + + for (hi = 0; hi < 256; hi++) { + if (dataPtr->toUnicode[hi] == NULL) { + dataPtr->toUnicode[hi] = emptyPage; + } else { + for (lo = 0; lo < 256; lo++) { + int ch; + + ch = dataPtr->toUnicode[hi][lo]; + if (ch != 0) { + unsigned short *page; + + page = dataPtr->fromUnicode[ch >> 8]; + if (page == NULL) { + page = pageMemPtr; + pageMemPtr += 256; + dataPtr->fromUnicode[ch >> 8] = page; + } + page[ch & 0xff] = (unsigned short) ((hi << 8) + lo); + } + } + } + } + if (type == ENCODING_MULTIBYTE) { + /* + * If multibyte encodings don't have a backslash character, define + * one. Otherwise, on Windows, native file names won't work because + * the backslash in the file name will map to the unknown character + * (question mark) when converting from UTF-8 to external encoding. + */ + + if (dataPtr->fromUnicode[0] != NULL) { + if (dataPtr->fromUnicode[0]['\\'] == '\0') { + dataPtr->fromUnicode[0]['\\'] = '\\'; + } + } + } + if (symbol) { + unsigned short *page; + + /* + * Make a special symbol encoding that not only maps the symbol + * characters from their Unicode code points down into page 0, but + * also ensure that the characters on page 0 map to themselves. + * This is so that a symbol font can be used to display a simple + * string like "abcd" and have alpha, beta, chi, delta show up, + * rather than have "unknown" chars show up because strictly + * speaking the symbol font doesn't have glyphs for those low ascii + * chars. + */ + + page = dataPtr->fromUnicode[0]; + if (page == NULL) { + page = pageMemPtr; + dataPtr->fromUnicode[0] = page; + } + for (lo = 0; lo < 256; lo++) { + if (dataPtr->toUnicode[0][lo] != 0) { + page[lo] = (unsigned short) lo; + } + } + } + for (hi = 0; hi < 256; hi++) { + if (dataPtr->fromUnicode[hi] == NULL) { + dataPtr->fromUnicode[hi] = emptyPage; + } + } + encType.encodingName = name; + encType.toUtfProc = TableToUtfProc; + encType.fromUtfProc = TableFromUtfProc; + encType.freeProc = TableFreeProc; + encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1; + encType.clientData = (ClientData) dataPtr; + return Tcl_CreateEncoding(&encType); + +} + +/* + *------------------------------------------------------------------------- + * + * LoadEscapeEncoding -- + * + * Helper function for LoadEncodingTable(). Loads a state machine + * that converts between Unicode and some other encoding. + * + * File contains text data that describes the escape sequences that + * are used to choose an encoding and the associated names for the + * sub-encodings. + * + * Results: + * The return value is the new encoding, or NULL if the encoding + * could not be created (because the file contained invalid data). + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Encoding +LoadEscapeEncoding(name, chan) + CONST char *name; /* Name for new encoding. */ + Tcl_Channel chan; /* File containing new encoding. */ +{ + int i; + unsigned int size; + Tcl_DString escapeData; + char init[16], final[16]; + EscapeEncodingData *dataPtr; + Tcl_EncodingType type; + + init[0] = '\0'; + final[0] = '\0'; + Tcl_DStringInit(&escapeData); + + while (1) { + int argc; + char **argv; + char *line; + Tcl_DString lineString; + + Tcl_DStringInit(&lineString); + if (Tcl_Gets(chan, &lineString) < 0) { + break; + } + line = Tcl_DStringValue(&lineString); + if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) { + continue; + } + if (argc >= 2) { + if (strcmp(argv[0], "name") == 0) { + ; + } else if (strcmp(argv[0], "init") == 0) { + strncpy(init, argv[1], sizeof(init)); + init[sizeof(init) - 1] = '\0'; + } else if (strcmp(argv[0], "final") == 0) { + strncpy(final, argv[1], sizeof(final)); + final[sizeof(final) - 1] = '\0'; + } else { + EscapeSubTable est; + + strncpy(est.sequence, argv[1], sizeof(est.sequence)); + est.sequence[sizeof(est.sequence) - 1] = '\0'; + est.sequenceLen = strlen(est.sequence); + + strncpy(est.name, argv[0], sizeof(est.name)); + est.name[sizeof(est.name) - 1] = '\0'; + + est.encodingPtr = NULL; + Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); + } + } + ckfree((char *) argv); + Tcl_DStringFree(&lineString); + } + + size = sizeof(EscapeEncodingData) + - sizeof(EscapeSubTable) + Tcl_DStringLength(&escapeData); + dataPtr = (EscapeEncodingData *) ckalloc(size); + dataPtr->initLen = strlen(init); + strcpy(dataPtr->init, init); + dataPtr->finalLen = strlen(final); + strcpy(dataPtr->final, final); + dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable); + memcpy((VOID *) dataPtr->subTables, (VOID *) Tcl_DStringValue(&escapeData), + (size_t) Tcl_DStringLength(&escapeData)); + Tcl_DStringFree(&escapeData); + + memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes)); + for (i = 0; i < dataPtr->numSubTables; i++) { + dataPtr->prefixBytes[UCHAR(dataPtr->subTables[i].sequence[0])] = 1; + } + if (dataPtr->init[0] != '\0') { + dataPtr->prefixBytes[UCHAR(dataPtr->init[0])] = 1; + } + if (dataPtr->final[0] != '\0') { + dataPtr->prefixBytes[UCHAR(dataPtr->final[0])] = 1; + } + + type.encodingName = name; + type.toUtfProc = EscapeToUtfProc; + type.fromUtfProc = EscapeFromUtfProc; + type.freeProc = EscapeFreeProc; + type.nullSize = 1; + type.clientData = (ClientData) dataPtr; + + return Tcl_CreateEncoding(&type); +} + +/* + *------------------------------------------------------------------------- + * + * BinaryProc -- + * + * The default conversion when no other conversion is specified. + * No translation is done; source bytes are copied directly to + * destination bytes. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +BinaryProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* Not used. */ + CONST char *src; /* Source string (unknown encoding). */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + int result; + + result = TCL_OK; + dstLen -= TCL_UTF_MAX - 1; + if (dstLen < 0) { + dstLen = 0; + } + if (srcLen > dstLen) { + srcLen = dstLen; + result = TCL_CONVERT_NOSPACE; + } + + *srcReadPtr = srcLen; + *dstWrotePtr = srcLen; + *dstCharsPtr = srcLen; + for ( ; --srcLen >= 0; ) { + *dst++ = *src++; + } + return result; +} + +/* + *------------------------------------------------------------------------- + * + * UtfToUtfProc -- + * + * Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 + * translation is not a no-op, because it will turn a stream of + * improperly formed UTF-8 into a properly formed stream. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* Not used. */ + CONST char *src; /* Source string in UTF-8. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + CONST char *srcStart, *srcEnd, *srcClose; + char *dstStart, *dstEnd; + int result, numChars; + Tcl_UniChar ch; + + result = TCL_OK; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + dstStart = dst; + dstEnd = dst + dstLen - TCL_UTF_MAX; + + for (numChars = 0; src < srcEnd; numChars++) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + src += Tcl_UtfToUniChar(src, &ch); + dst += Tcl_UniCharToUtf(ch, dst); + } + + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * UnicodeToUtfProc -- + * + * Convert from Unicode to UTF-8. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* Not used. */ + CONST char *src; /* Source string in Unicode. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + CONST Tcl_UniChar *wSrc, *wSrcStart, *wSrcEnd; + char *dstEnd, *dstStart; + int result, numChars; + + result = TCL_OK; + if ((srcLen % sizeof(Tcl_UniChar)) != 0) { + result = TCL_CONVERT_MULTIBYTE; + srcLen /= sizeof(Tcl_UniChar); + srcLen *= sizeof(Tcl_UniChar); + } + + wSrc = (Tcl_UniChar *) src; + + wSrcStart = (Tcl_UniChar *) src; + wSrcEnd = (Tcl_UniChar *) (src + srcLen); + + dstStart = dst; + dstEnd = dst + dstLen - TCL_UTF_MAX; + + for (numChars = 0; wSrc < wSrcEnd; numChars++) { + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + dst += Tcl_UniCharToUtf(*wSrc, dst); + wSrc++; + } + + *srcReadPtr = (char *) wSrc - (char *) wSrcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * UtfToUnicodeProc -- + * + * Convert from UTF-8 to Unicode. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* TableEncodingData that specifies encoding. */ + CONST char *src; /* Source string in UTF-8. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + CONST char *srcStart, *srcEnd, *srcClose; + Tcl_UniChar *wDst, *wDstStart, *wDstEnd; + int result, numChars; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + wDst = (Tcl_UniChar *) dst; + wDstStart = (Tcl_UniChar *) dst; + wDstEnd = (Tcl_UniChar *) (dst + dstLen - sizeof(Tcl_UniChar)); + + result = TCL_OK; + for (numChars = 0; src < srcEnd; numChars++) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + if (wDst > wDstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + src += Tcl_UtfToUniChar(src, wDst); + wDst++; + } + *srcReadPtr = src - srcStart; + *dstWrotePtr = (char *) wDst - (char *) wDstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * TableToUtfProc -- + * + * Convert from the encoding specified by the TableEncodingData into + * UTF-8. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* TableEncodingData that specifies + * encoding. */ + CONST char *src; /* Source string in specified encoding. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + CONST char *srcStart, *srcEnd; + char *dstEnd, *dstStart, *prefixBytes; + int result, byte, numChars; + Tcl_UniChar ch; + unsigned short **toUnicode; + unsigned short *pageZero; + TableEncodingData *dataPtr; + + srcStart = src; + srcEnd = src + srcLen; + + dstStart = dst; + dstEnd = dst + dstLen - TCL_UTF_MAX; + + dataPtr = (TableEncodingData *) clientData; + toUnicode = dataPtr->toUnicode; + prefixBytes = dataPtr->prefixBytes; + pageZero = toUnicode[0]; + + result = TCL_OK; + for (numChars = 0; src < srcEnd; numChars++) { + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + byte = *((unsigned char *) src); + if (prefixBytes[byte]) { + src++; + if (src >= srcEnd) { + src--; + result = TCL_CONVERT_MULTIBYTE; + break; + } + ch = toUnicode[byte][*((unsigned char *) src)]; + } else { + ch = pageZero[byte]; + } + if ((ch == 0) && (byte != 0)) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_SYNTAX; + break; + } + if (prefixBytes[byte]) { + src--; + } + ch = (Tcl_UniChar) byte; + } + dst += Tcl_UniCharToUtf(ch, dst); + src++; + } + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * TableFromUtfProc -- + * + * Convert from UTF-8 into the encoding specified by the + * TableEncodingData. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* TableEncodingData that specifies + * encoding. */ + CONST char *src; /* Source string in UTF-8. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + CONST char *srcStart, *srcEnd, *srcClose; + char *dstStart, *dstEnd, *prefixBytes; + Tcl_UniChar ch; + int result, len, word, numChars; + TableEncodingData *dataPtr; + unsigned short **fromUnicode; + + result = TCL_OK; + + dataPtr = (TableEncodingData *) clientData; + prefixBytes = dataPtr->prefixBytes; + fromUnicode = dataPtr->fromUnicode; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + dstStart = dst; + dstEnd = dst + dstLen - 1; + + for (numChars = 0; src < srcEnd; numChars++) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + len = Tcl_UtfToUniChar(src, &ch); + word = fromUnicode[(ch >> 8)][ch & 0xff]; + if ((word == 0) && (ch != 0)) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_UNKNOWN; + break; + } + word = dataPtr->fallback; + } + if (prefixBytes[(word >> 8)] != 0) { + if (dst + 1 > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + dst[0] = (char) (word >> 8); + dst[1] = (char) word; + dst += 2; + } else { + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + dst[0] = (char) word; + dst++; + } + src += len; + } + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TableFreeProc -- + * + * This procedure is invoked when an encoding is deleted. It deletes + * the memory used by the TableEncodingData. + * + * Results: + * None. + * + * Side effects: + * Memory freed. + * + *--------------------------------------------------------------------------- + */ + +static void +TableFreeProc(clientData) + ClientData clientData; /* TableEncodingData that specifies + * encoding. */ +{ + TableEncodingData *dataPtr; + + dataPtr = (TableEncodingData *) clientData; + ckfree((char *) dataPtr->toUnicode); + ckfree((char *) dataPtr->fromUnicode); + ckfree((char *) dataPtr); +} + +/* + *------------------------------------------------------------------------- + * + * EscapeToUtfProc -- + * + * Convert from the encoding specified by the EscapeEncodingData into + * UTF-8. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* EscapeEncodingData that specifies + * encoding. */ + CONST char *src; /* Source string in specified encoding. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + EscapeEncodingData *dataPtr; + char *prefixBytes, *tablePrefixBytes; + unsigned short **tableToUnicode; + Encoding *encodingPtr; + int state, result, numChars; + CONST char *srcStart, *srcEnd; + char *dstStart, *dstEnd; + + result = TCL_OK; + + tablePrefixBytes = NULL; /* lint. */ + tableToUnicode = NULL; /* lint. */ + + dataPtr = (EscapeEncodingData *) clientData; + prefixBytes = dataPtr->prefixBytes; + encodingPtr = NULL; + + srcStart = src; + srcEnd = src + srcLen; + + dstStart = dst; + dstEnd = dst + dstLen - TCL_UTF_MAX; + + state = (int) *statePtr; + if (flags & TCL_ENCODING_START) { + state = 0; + } + + for (numChars = 0; src < srcEnd; ) { + int byte, hi, lo, ch; + + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + byte = *((unsigned char *) src); + if (prefixBytes[byte]) { + unsigned int left, len, longest; + int checked, i; + EscapeSubTable *subTablePtr; + + /* + * Saw the beginning of an escape sequence. + */ + + left = srcEnd - src; + len = dataPtr->initLen; + longest = len; + checked = 0; + if (len <= left) { + checked++; + if ((len > 0) && + (memcmp(src, dataPtr->init, len) == 0)) { + /* + * If we see initialization string, skip it, even if we're + * not at the beginning of the buffer. + */ + + src += len; + continue; + } + } + len = dataPtr->finalLen; + if (len > longest) { + longest = len; + } + if (len <= left) { + checked++; + if ((len > 0) && + (memcmp(src, dataPtr->final, len) == 0)) { + /* + * If we see finalization string, skip it, even if we're + * not at the end of the buffer. + */ + + src += len; + continue; + } + } + subTablePtr = dataPtr->subTables; + for (i = 0; i < dataPtr->numSubTables; i++) { + len = subTablePtr->sequenceLen; + if (len > longest) { + longest = len; + } + if (len <= left) { + checked++; + if ((len > 0) && + (memcmp(src, subTablePtr->sequence, len) == 0)) { + state = i; + encodingPtr = NULL; + subTablePtr = NULL; + src += len; + break; + } + } + subTablePtr++; + } + if (subTablePtr == NULL) { + /* + * A match was found, the escape sequence was consumed, and + * the state was updated. + */ + + continue; + } + + /* + * We have a split-up or unrecognized escape sequence. If we + * checked all the sequences, then it's a syntax error, + * otherwise we need more bytes to determine a match. + */ + + if ((checked == dataPtr->numSubTables + 2) + || (flags & TCL_ENCODING_END)) { + if ((flags & TCL_ENCODING_STOPONERROR) == 0) { + /* + * Skip the unknown escape sequence. + */ + + src += longest; + continue; + } + result = TCL_CONVERT_SYNTAX; + } else { + result = TCL_CONVERT_MULTIBYTE; + } + break; + } + + if (encodingPtr == NULL) { + TableEncodingData *tableDataPtr; + + encodingPtr = GetTableEncoding(dataPtr, state); + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; + tablePrefixBytes = tableDataPtr->prefixBytes; + tableToUnicode = tableDataPtr->toUnicode; + } + if (tablePrefixBytes[byte]) { + src++; + if (src >= srcEnd) { + src--; + result = TCL_CONVERT_MULTIBYTE; + break; + } + hi = byte; + lo = *((unsigned char *) src); + } else { + hi = 0; + lo = byte; + } + ch = tableToUnicode[hi][lo]; + dst += Tcl_UniCharToUtf(ch, dst); + src++; + numChars++; + } + + *statePtr = (Tcl_EncodingState) state; + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * EscapeFromUtfProc -- + * + * Convert from UTF-8 into the encoding specified by the + * EscapeEncodingData. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* EscapeEncodingData that specifies + * encoding. */ + CONST char *src; /* Source string in UTF-8. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + EscapeEncodingData *dataPtr; + Encoding *encodingPtr; + CONST char *srcStart, *srcEnd, *srcClose; + char *dstStart, *dstEnd; + int state, result, numChars; + TableEncodingData *tableDataPtr; + char *tablePrefixBytes; + unsigned short **tableFromUnicode; + + result = TCL_OK; + + dataPtr = (EscapeEncodingData *) clientData; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + dstStart = dst; + dstEnd = dst + dstLen - 1; + + if (flags & TCL_ENCODING_START) { + unsigned int len; + + state = 0; + len = dataPtr->subTables[0].sequenceLen; + if (dst + dataPtr->initLen + len > dstEnd) { + *srcReadPtr = 0; + *dstWrotePtr = 0; + return TCL_CONVERT_NOSPACE; + } + memcpy((VOID *) dst, (VOID *) dataPtr->init, + (size_t) dataPtr->initLen); + dst += dataPtr->initLen; + memcpy((VOID *) dst, (VOID *) dataPtr->subTables[0].sequence, + (size_t) len); + dst += len; + } else { + state = (int) *statePtr; + } + + encodingPtr = GetTableEncoding(dataPtr, state); + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; + tablePrefixBytes = tableDataPtr->prefixBytes; + tableFromUnicode = tableDataPtr->fromUnicode; + + for (numChars = 0; src < srcEnd; numChars++) { + unsigned int len; + int word; + Tcl_UniChar ch; + + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + len = Tcl_UtfToUniChar(src, &ch); + word = tableFromUnicode[(ch >> 8)][ch & 0xff]; + + if ((word == 0) && (ch != 0)) { + int oldState; + EscapeSubTable *subTablePtr; + + oldState = state; + for (state = 0; state < dataPtr->numSubTables; state++) { + encodingPtr = GetTableEncoding(dataPtr, state); + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; + word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff]; + if (word != 0) { + break; + } + } + + if (word == 0) { + state = oldState; + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_UNKNOWN; + break; + } + encodingPtr = GetTableEncoding(dataPtr, state); + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; + word = tableDataPtr->fallback; + } + + tablePrefixBytes = tableDataPtr->prefixBytes; + tableFromUnicode = tableDataPtr->fromUnicode; + + subTablePtr = &dataPtr->subTables[state]; + if (dst + subTablePtr->sequenceLen > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + memcpy((VOID *) dst, (VOID *) subTablePtr->sequence, + (size_t) subTablePtr->sequenceLen); + dst += subTablePtr->sequenceLen; + } + + if (tablePrefixBytes[(word >> 8)] != 0) { + if (dst + 1 > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + dst[0] = (char) (word >> 8); + dst[1] = (char) word; + dst += 2; + } else { + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + dst[0] = (char) word; + dst++; + } + src += len; + } + + if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) { + if (dst + dataPtr->finalLen > dstEnd) { + result = TCL_CONVERT_NOSPACE; + } else { + memcpy((VOID *) dst, (VOID *) dataPtr->final, + (size_t) dataPtr->finalLen); + dst += dataPtr->finalLen; + } + } + + *statePtr = (Tcl_EncodingState) state; + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * EscapeFreeProc -- + * + * This procedure is invoked when an EscapeEncodingData encoding is + * deleted. It deletes the memory used by the encoding. + * + * Results: + * None. + * + * Side effects: + * Memory freed. + * + *--------------------------------------------------------------------------- + */ + +static void +EscapeFreeProc(clientData) + ClientData clientData; /* EscapeEncodingData that specifies encoding. */ +{ + EscapeEncodingData *dataPtr; + EscapeSubTable *subTablePtr; + int i; + + dataPtr = (EscapeEncodingData *) clientData; + if (dataPtr == NULL) { + return; + } + subTablePtr = dataPtr->subTables; + for (i = 0; i < dataPtr->numSubTables; i++) { + FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr); + subTablePtr++; + } + ckfree((char *) dataPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * GetTableEncoding -- + * + * Helper function for the EscapeEncodingData conversions. Gets the + * encoding (of type TextEncodingData) that represents the specified + * state. + * + * Results: + * The return value is the encoding. + * + * Side effects: + * If the encoding that represents the specified state has not + * already been used by this EscapeEncoding, it will be loaded + * and cached in the dataPtr. + * + *--------------------------------------------------------------------------- + */ + +static Encoding * +GetTableEncoding(dataPtr, state) + EscapeEncodingData *dataPtr;/* Contains names of encodings. */ + int state; /* Index in dataPtr of desired Encoding. */ +{ + EscapeSubTable *subTablePtr; + Encoding *encodingPtr; + + subTablePtr = &dataPtr->subTables[state]; + encodingPtr = subTablePtr->encodingPtr; + if (encodingPtr == NULL) { + encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name); + if ((encodingPtr == NULL) + || (encodingPtr->toUtfProc != TableToUtfProc)) { + panic("EscapeToUtfProc: invalid sub table"); + } + subTablePtr->encodingPtr = encodingPtr; + } + return encodingPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * unilen -- + * + * A helper function for the Tcl_ExternalToUtf functions. This + * function is similar to strlen for double-byte characters: it + * returns the number of bytes in a 0x0000 terminated string. + * + * Results: + * As above. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static size_t +unilen(src) + CONST char *src; +{ + unsigned short *p; + + p = (unsigned short *) src; + while (*p != 0x0000) { + p++; + } + return (char *) p - src; +} + + diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 52d68ae..4e5854e 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -7,34 +7,18 @@ * the "env" arrays in sync with the system environment variables. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 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: tclEnv.c,v 1.3 1999/02/02 23:01:59 stanton Exp $ + * RCS: @(#) $Id: tclEnv.c,v 1.4 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" -/* - * The structure below is used to keep track of all of the interpereters - * for which we're managing the "env" array. It's needed so that they - * can all be updated whenever an environment variable is changed - * anywhere. - */ - -typedef struct EnvInterp { - Tcl_Interp *interp; /* Interpreter for which we're managing - * the env array. */ - struct EnvInterp *nextPtr; /* Next in list of all such interpreters, - * or zero. */ -} EnvInterp; - -static EnvInterp *firstInterpPtr = NULL; - /* First in list of all managed interpreters, - * or NULL if none. */ +TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ */ static int cacheSize = 0; /* Number of env strings in environCache. */ static char **environCache = NULL; @@ -56,13 +40,12 @@ static int environSize = 0; /* Non-zero means that the environ array was static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); -static int FindVariable _ANSI_ARGS_((CONST char *name, - int *lengthPtr)); static void ReplaceString _ANSI_ARGS_((CONST char *oldStr, char *newStr)); void TclSetEnv _ANSI_ARGS_((CONST char *name, CONST char *value)); void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); + /* *---------------------------------------------------------------------- @@ -80,7 +63,7 @@ void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); * The interpreter is added to a list of interpreters managed * by us, so that its view of envariables can be kept consistent * with the view in other interpreters. If this is the first - * call to Tcl_SetupEnv, then additional initialization happens, + * call to TclSetupEnv, then additional initialization happens, * such as copying the environment to dynamically-allocated space * for ease of management. * @@ -92,73 +75,59 @@ TclSetupEnv(interp) Tcl_Interp *interp; /* Interpreter whose "env" array is to be * managed. */ { - EnvInterp *eiPtr; - char *p, *p2; - Tcl_DString ds; - int i, sz; - -#ifdef MAC_TCL - if (environ == NULL) { - environSize = TclMacCreateEnv(); - } -#endif + Tcl_DString envString; + char *p1, *p2; + int i; /* - * Next, initialize the DString we are going to use for copying - * the names of the environment variables. + * Synchronize the values in the environ array with the contents + * of the Tcl "env" variable. To do this: + * 1) Remove the trace that fires when the "env" var is unset. + * 2) Unset the "env" variable. + * 3) If there are no environ variables, create an empty "env" + * array. Otherwise populate the array with current values. + * 4) Add a trace that synchronizes the "env" array. */ - - Tcl_DStringInit(&ds); - /* - * Next, add the interpreter to the list of those that we manage. - */ - - eiPtr = (EnvInterp *) ckalloc(sizeof(EnvInterp)); - eiPtr->interp = interp; - eiPtr->nextPtr = firstInterpPtr; - firstInterpPtr = eiPtr; - - /* - * Store the environment variable values into the interpreter's - * "env" array, and arrange for us to be notified on future - * writes and unsets to that array. - */ - - (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); - for (i = 0; ; i++) { - p = environ[i]; - if (p == NULL) { - break; - } - for (p2 = p; *p2 != '='; p2++) { - if (*p2 == 0) { + Tcl_UntraceVar2(interp, "env", (char *) NULL, + TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, + (ClientData) NULL); + + Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); + + if (environ[0] == NULL) { + Tcl_Obj *varNamePtr; + + varNamePtr = Tcl_NewStringObj("env", -1); + Tcl_IncrRefCount(varNamePtr); + TclArraySet(interp, varNamePtr, NULL); + Tcl_DecrRefCount(varNamePtr); + } else { + Tcl_MutexLock(&envMutex); + for (i = 0; environ[i] != NULL; i++) { + p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString); + p2 = strchr(p1, '='); + if (p2 == NULL) { /* - * This condition doesn't seem like it should ever happen, - * but it does seem to happen occasionally under some + * This condition seem to happen occasionally under some * versions of Solaris; ignore the entry. */ - - goto nextEntry; + + continue; } + p2++; + p2[-1] = '\0'; + Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); + Tcl_DStringFree(&envString); } - sz = p2 - p; - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, p, sz); - (void) Tcl_SetVar2(interp, "env", Tcl_DStringValue(&ds), - p2+1, TCL_GLOBAL_ONLY); - nextEntry: - continue; + Tcl_MutexUnlock(&envMutex); } - Tcl_TraceVar2(interp, "env", (char *) NULL, - TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, - EnvTraceProc, (ClientData) NULL); - /* - * Finally clean up the DString. - */ - - Tcl_DStringFree(&ds); + Tcl_TraceVar2(interp, "env", (char *) NULL, + TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, + (ClientData) NULL); } /* @@ -177,8 +146,7 @@ TclSetupEnv(interp) * None. * * Side effects: - * The environ array gets updated, as do all of the interpreters - * that we manage. + * The environ array gets updated. * *---------------------------------------------------------------------- */ @@ -186,47 +154,45 @@ TclSetupEnv(interp) void TclSetEnv(name, value) CONST char *name; /* Name of variable whose value is to be - * set. */ - CONST char *value; /* New value for variable. */ + * set (UTF-8). */ + CONST char *value; /* New value for variable (UTF-8). */ { + Tcl_DString envString; int index, length, nameLength; - char *p, *oldValue; - EnvInterp *eiPtr; - -#ifdef MAC_TCL - if (environ == NULL) { - environSize = TclMacCreateEnv(); - } -#endif + char *p, *p2, *oldValue; /* * Figure out where the entry is going to go. If the name doesn't - * already exist, enlarge the array if necessary to make room. If - * the name exists, free its old entry. + * already exist, enlarge the array if necessary to make room. If the + * name exists, free its old entry. */ - index = FindVariable(name, &length); + Tcl_MutexLock(&envMutex); + index = TclpFindVariable(name, &length); + if (index == -1) { #ifndef USE_PUTENV - if ((length+2) > environSize) { + if ((length + 2) > environSize) { char **newEnviron; newEnviron = (char **) ckalloc((unsigned) - ((length+5) * sizeof(char *))); + ((length + 5) * sizeof(char *))); memcpy((VOID *) newEnviron, (VOID *) environ, length*sizeof(char *)); if (environSize != 0) { ckfree((char *) environ); } environ = newEnviron; - environSize = length+5; + environSize = length + 5; } index = length; - environ[index+1] = NULL; + environ[index + 1] = NULL; #endif oldValue = NULL; nameLength = strlen(name); } else { + char *env; + /* * Compare the new value to the existing value. If they're * the same then quit immediately (e.g. don't rewrite the @@ -235,47 +201,63 @@ TclSetEnv(name, value) * of the same value among the interpreters. */ - if (strcmp(value, environ[index]+length+1) == 0) { + env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString); + if (strcmp(value, (env + length + 1)) == 0) { + Tcl_DStringFree(&envString); + Tcl_MutexUnlock(&envMutex); return; } + Tcl_DStringFree(&envString); + oldValue = environ[index]; nameLength = length; } /* - * Create a new entry. + * Create a new entry. Build a complete UTF string that contains + * a "name=value" pattern. Then convert the string to the native + * encoding, and set the environ array value. */ p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2)); strcpy(p, name); p[nameLength] = '='; strcpy(p+nameLength+1, value); + p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString); + ckfree(p); + +#ifdef USE_PUTENV /* * Update the system environment. */ -#ifdef USE_PUTENV - putenv(p); + putenv(p2); + index = TclpFindVariable(name, &length); #else - environ[index] = p; -#endif - /* - * Replace the old value with the new value in the cache. + * Copy the native string to heap memory. */ - - ReplaceString(oldValue, p); + + p = (char *) ckalloc((unsigned) (strlen(p2) + 1)); + strcpy(p, p2); + environ[index] = p; +#endif /* - * Update all of the interpreters. + * Watch out for versions of putenv that copy the string (e.g. VC++). + * In this case we need to free the string immediately. Otherwise + * update the string in the cache. */ - for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { - (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name, - (char *) value, TCL_GLOBAL_ONLY); + if (environ[index] != p) { + Tcl_DStringFree(&envString); + } else { + ReplaceString(oldValue, p); } + + Tcl_MutexUnlock(&envMutex); } /* @@ -304,8 +286,9 @@ TclSetEnv(name, value) int Tcl_PutEnv(string) CONST char *string; /* Info about environment variable in the - * form NAME=value. */ + * form NAME=value. (native) */ { + Tcl_DString nameString; int nameLength; char *name, *value; @@ -314,23 +297,24 @@ Tcl_PutEnv(string) } /* - * Separate the string into name and value parts, then call - * TclSetEnv to do all of the real work. + * First convert the native string to UTF. Then separate the + * string into name and value parts, and call TclSetEnv to do + * all of the real work. */ - value = strchr(string, '='); + name = Tcl_ExternalToUtfDString(NULL, string, -1, &nameString); + value = strchr(name, '='); if (value == NULL) { return 0; } - nameLength = value - string; + nameLength = value - name; if (nameLength == 0) { return 0; } - name = (char *) ckalloc((unsigned) nameLength+1); - memcpy((VOID *) name, (VOID *) string, (size_t) nameLength); - name[nameLength] = 0; + + value[0] = '\0'; TclSetEnv(name, value+1); - ckfree(name); + Tcl_DStringFree(&nameString); return 0; } @@ -356,24 +340,19 @@ Tcl_PutEnv(string) void TclUnsetEnv(name) - CONST char *name; /* Name of variable to remove. */ + CONST char *name; /* Name of variable to remove (UTF-8). */ { - EnvInterp *eiPtr; char *oldValue; int length, index; #ifdef USE_PUTENV + Tcl_DString envString; char *string; #else char **envPtr; #endif -#ifdef MAC_TCL - if (environ == NULL) { - environSize = TclMacCreateEnv(); - } -#endif - - index = FindVariable(name, &length); + Tcl_MutexLock(&envMutex); + index = TclpFindVariable(name, &length); /* * First make sure that the environment variable exists to avoid @@ -381,6 +360,7 @@ TclUnsetEnv(name) */ if (index == -1) { + Tcl_MutexUnlock(&envMutex); return; } /* @@ -399,8 +379,23 @@ TclUnsetEnv(name) memcpy((VOID *) string, (VOID *) name, (size_t) length); string[length] = '='; string[length+1] = '\0'; - putenv(string); + + Tcl_UtfToExternalDString(NULL, string, -1, &envString); ckfree(string); + string = Tcl_DStringValue(&envString); + putenv(string); + + /* + * Watch out for versions of putenv that copy the string (e.g. VC++). + * In this case we need to free the string immediately. Otherwise + * update the string in the cache. + */ + + if (environ[index] != string) { + Tcl_DStringFree(&envString); + } else { + ReplaceString(oldValue, string); + } #else for (envPtr = environ+index+1; ; envPtr++) { envPtr[-1] = *envPtr; @@ -408,34 +403,25 @@ TclUnsetEnv(name) break; } } -#endif - - /* - * Replace the old value in the cache. - */ - ReplaceString(oldValue, NULL); +#endif - /* - * Update all of the interpreters. - */ - - for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { - (void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name, - TCL_GLOBAL_ONLY); - } + Tcl_MutexUnlock(&envMutex); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TclGetEnv -- * * Retrieve the value of an environment variable. * * Results: - * Returns a pointer to a static string in the environment, - * or NULL if the value was not found. + * The result is a pointer to a string specifying the value of the + * environment variable, or NULL if that environment variable does + * not exist. Storage for the result string is allocated in valuePtr; + * the caller must call Tcl_DStringFree() when the result is no + * longer needed. * * Side effects: * None. @@ -444,23 +430,36 @@ TclUnsetEnv(name) */ char * -TclGetEnv(name) - CONST char *name; /* Name of variable to find. */ +TclGetEnv(name, valuePtr) + CONST char *name; /* Name of environment variable to find + * (UTF-8). */ + Tcl_DString *valuePtr; /* Uninitialized or free DString in which + * the value of the environment variable is + * stored. */ { int length, index; + char *result; -#ifdef MAC_TCL - if (environ == NULL) { - environSize = TclMacCreateEnv(); - } -#endif - - index = FindVariable(name, &length); - if ((index != -1) && (*(environ[index]+length) == '=')) { - return environ[index]+length+1; - } else { - return NULL; + Tcl_MutexLock(&envMutex); + index = TclpFindVariable(name, &length); + result = NULL; + if (index != -1) { + Tcl_DString envStr; + + result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr); + result += length; + if (*result == '=') { + result++; + Tcl_DStringInit(valuePtr); + Tcl_DStringAppend(valuePtr, result, -1); + result = Tcl_DStringValue(valuePtr); + } else { + result = NULL; + } + Tcl_DStringFree(&envStr); } + Tcl_MutexUnlock(&envMutex); + return result; } /* @@ -469,9 +468,8 @@ TclGetEnv(name) * EnvTraceProc -- * * This procedure is invoked whenever an environment variable - * is modified or deleted. It propagates the change to the - * "environ" array and to any other interpreters for whom - * we're managing an "env" array. + * is read, modified or deleted. It propagates the change to the global + * "environ" array. * * Results: * Always returns NULL to indicate success. @@ -492,38 +490,24 @@ EnvTraceProc(clientData, interp, name1, name2, flags) Tcl_Interp *interp; /* Interpreter whose "env" variable is * being modified. */ char *name1; /* Better be "env". */ - char *name2; /* Name of variable being modified, or - * NULL if whole array is being deleted. */ + char *name2; /* Name of variable being modified, or NULL + * if whole array is being deleted (UTF-8). */ int flags; /* Indicates what's happening. */ { /* - * First see if the whole "env" variable is being deleted. If - * so, just forget about this interpreter. + * For array traces, let TclSetupEnv do all the work. */ - if (name2 == NULL) { - register EnvInterp *eiPtr, *prevPtr; + if (flags & TCL_TRACE_ARRAY) { + TclSetupEnv(interp); + return NULL; + } - if ((flags & (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) - != (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) { - panic("EnvTraceProc called with confusing arguments"); - } - eiPtr = firstInterpPtr; - if (eiPtr->interp == interp) { - firstInterpPtr = eiPtr->nextPtr; - } else { - for (prevPtr = eiPtr, eiPtr = eiPtr->nextPtr; ; - prevPtr = eiPtr, eiPtr = eiPtr->nextPtr) { - if (eiPtr == NULL) { - panic("EnvTraceProc couldn't find interpreter"); - } - if (eiPtr->interp == interp) { - prevPtr->nextPtr = eiPtr->nextPtr; - break; - } - } - } - ckfree((char *) eiPtr); + /* + * If name2 is NULL, then return and do nothing. + */ + + if (name2 == NULL) { return NULL; } @@ -532,9 +516,32 @@ EnvTraceProc(clientData, interp, name1, name2, flags) */ if (flags & TCL_TRACE_WRITES) { - TclSetEnv(name2, Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY)); + char *value; + + value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); + TclSetEnv(name2, value); } + /* + * If a value is being read, call TclGetEnv to do all of the work. + */ + + if (flags & TCL_TRACE_READS) { + Tcl_DString valueString; + char *value; + + value = TclGetEnv(name2, &valueString); + if (value == NULL) { + return "no such variable"; + } + Tcl_SetVar2(interp, name1, name2, value, 0); + Tcl_DStringFree(&valueString); + } + + /* + * For unset traces, let TclUnsetEnv do all the work. + */ + if (flags & TCL_TRACE_UNSETS) { TclUnsetEnv(name2); } @@ -603,7 +610,7 @@ ReplaceString(oldStr, newStr) * We need to grow the cache in order to hold the new string. */ - newCache = (char **) ckalloc((size_t) allocatedSize); + newCache = (char **) ckalloc((unsigned) allocatedSize); (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize); if (environCache) { @@ -621,50 +628,6 @@ ReplaceString(oldStr, newStr) /* *---------------------------------------------------------------------- * - * FindVariable -- - * - * Locate the entry in environ for a given name. - * - * Results: - * The return value is the index in environ of an entry with the - * name "name", or -1 if there is no such entry. The integer at - * *lengthPtr is filled in with the length of name (if a matching - * entry is found) or the length of the environ array (if no matching - * entry is found). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -FindVariable(name, lengthPtr) - CONST char *name; /* Name of desired environment variable. */ - int *lengthPtr; /* Used to return length of name (for - * successful searches) or number of non-NULL - * entries in environ (for unsuccessful - * searches). */ -{ - int i; - register CONST char *p1, *p2; - - for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) { - for (p2 = name; *p2 == *p1; p1++, p2++) { - /* NULL loop body. */ - } - if ((*p1 == '=') && (*p2 == '\0')) { - *lengthPtr = p2-name; - return i; - } - } - *lengthPtr = i; - return -1; -} - -/* - *---------------------------------------------------------------------- - * * TclFinalizeEnvironment -- * * This function releases any storage allocated by this module @@ -700,3 +663,7 @@ TclFinalizeEnvironment() #endif } } + + + + diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 162af15..7499577 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -6,12 +6,12 @@ * command procedures. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 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: tclEvent.c,v 1.3 1998/09/14 18:39:58 stanton Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.4 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -28,8 +28,9 @@ typedef struct BgError { Tcl_Interp *interp; /* Interpreter in which error occurred. NULL * means this error report has been cancelled * (a previous report generated a break). */ - char *errorMsg; /* The error message (interp->result when - * the error occurred). Malloc-ed. */ + char *errorMsg; /* Copy of the error message (the interp's + * result when the error occurred). + * Malloc-ed. */ char *errorInfo; /* Value of the errorInfo variable * (malloc-ed). */ char *errorCode; /* Value of the errorCode variable @@ -66,27 +67,38 @@ typedef struct ExitHandler { * this application, or NULL for end of list. */ } ExitHandler; -static ExitHandler *firstExitPtr = NULL; - /* First in list of all exit handlers for - * application. */ - /* - * The following variable is a "secret" indication to Tcl_Exit that - * it should dump out the state of memory before exiting. If the - * value is non-NULL, it gives the name of the file in which to - * dump memory usage information. + * There is both per-process and per-thread exit handlers. + * The first list is controlled by a mutex. The other is in + * thread local storage. */ -char *tclMemDumpFileName = NULL; +static ExitHandler *firstExitPtr = NULL; + /* First in list of all exit handlers for + * application. */ +TCL_DECLARE_MUTEX(exitMutex) /* - * This variable is set to 1 when Tcl_Exit is called, and at the end of + * This variable is set to 1 when Tcl_Finalize is called, and at the end of * its work, it is reset to 0. The variable is checked by TclInExit() to * allow different behavior for exit-time processing, e.g. in closing of * files and pipes. */ -static int tclInExit = 0; +static int inFinalize = 0; +static int subsystemsInitialized = 0; +static int encodingsInitialized = 0; + +static Tcl_Obj *tclLibraryPath = NULL; + +typedef struct ThreadSpecificData { + ExitHandler *firstExitPtr; /* First in list of all exit handlers for + * this thread. */ + int inExit; /* True when this thread is exiting. This + * is used as a hack to decide to close + * the standard channels. */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; /* * Prototypes for procedures referenced only in this file: @@ -127,6 +139,7 @@ Tcl_BackgroundError(interp) BgError *errPtr; char *errResult, *varValue; ErrAssocData *assocPtr; + int length; /* * The Tcl_AddErrorInfo call below (with an empty string) ensures that @@ -138,12 +151,12 @@ Tcl_BackgroundError(interp) Tcl_AddErrorInfo(interp, ""); - errResult = TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL); + errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); errPtr = (BgError *) ckalloc(sizeof(BgError)); errPtr->interp = interp; - errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(errResult) + 1)); - strcpy(errPtr->errorMsg, errResult); + errPtr->errorMsg = (char *) ckalloc((unsigned) (length + 1)); + memcpy(errPtr->errorMsg, errResult, (size_t) (length + 1)); varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (varValue == NULL) { varValue = errPtr->errorMsg; @@ -206,7 +219,6 @@ HandleBgErrors(clientData) ClientData clientData; /* Pointer to ErrAssocData structure. */ { Tcl_Interp *interp; - char *command; char *argv[2]; int code; BgError *errPtr; @@ -237,11 +249,10 @@ HandleBgErrors(clientData) argv[0] = "bgerror"; argv[1] = assocPtr->firstBgPtr->errorMsg; - command = Tcl_Merge(2, argv); + Tcl_AllowExceptions(interp); Tcl_Preserve((ClientData) interp); - code = Tcl_GlobalEval(interp, command); - ckfree(command); + code = TclGlobalInvoke(interp, 2, argv, 0); if (code == TCL_ERROR) { /* @@ -256,29 +267,11 @@ HandleBgErrors(clientData) */ if (Tcl_IsSafe(interp)) { - Tcl_HashTable *hTblPtr; - Tcl_HashEntry *hPtr; - - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclHiddenCmds", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - goto doneWithInterp; - } - hPtr = Tcl_FindHashEntry(hTblPtr, "bgerror"); - if (hPtr == (Tcl_HashEntry *) NULL) { - goto doneWithInterp; - } - - /* - * OK, the hidden command "bgerror" exists, invoke it. - */ - - argv[0] = "bgerror"; - argv[1] = ckalloc((unsigned) - strlen(assocPtr->firstBgPtr->errorMsg)); - strcpy(argv[1], assocPtr->firstBgPtr->errorMsg); - (void) TclInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN); - ckfree(argv[1]); + Tcl_SavedResult save; + + Tcl_SaveResult(interp, &save); + TclGlobalInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN); + Tcl_RestoreResult(interp, &save); goto doneWithInterp; } @@ -290,22 +283,24 @@ HandleBgErrors(clientData) errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel != (Tcl_Channel) NULL) { - if (strcmp(interp->result, - "\"bgerror\" is an invalid command name or ambiguous abbreviation") - == 0) { - Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1); - Tcl_Write(errChannel, "\n", -1); + char *string; + int len; + + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len); + if (strcmp(string, "\"bgerror\" is an invalid command name or ambiguous abbreviation") == 0) { + Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1); + Tcl_WriteChars(errChannel, "\n", -1); } else { - Tcl_Write(errChannel, + Tcl_WriteChars(errChannel, "bgerror failed to handle background error.\n", -1); - Tcl_Write(errChannel, " Original error: ", -1); - Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg, + Tcl_WriteChars(errChannel, " Original error: ", -1); + Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg, -1); - Tcl_Write(errChannel, "\n", -1); - Tcl_Write(errChannel, " Error in bgerror: ", -1); - Tcl_Write(errChannel, interp->result, -1); - Tcl_Write(errChannel, "\n", -1); + Tcl_WriteChars(errChannel, "\n", -1); + Tcl_WriteChars(errChannel, " Error in bgerror: ", -1); + Tcl_WriteChars(errChannel, string, len); + Tcl_WriteChars(errChannel, "\n", -1); } Tcl_Flush(errChannel); } @@ -416,8 +411,10 @@ Tcl_CreateExitHandler(proc, clientData) exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; + Tcl_MutexLock(&exitMutex); exitPtr->nextPtr = firstExitPtr; firstExitPtr = exitPtr; + Tcl_MutexUnlock(&exitMutex); } /* @@ -446,6 +443,7 @@ Tcl_DeleteExitHandler(proc, clientData) { ExitHandler *exitPtr, *prevPtr; + Tcl_MutexLock(&exitMutex); for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { if ((exitPtr->proc == proc) @@ -455,6 +453,82 @@ Tcl_DeleteExitHandler(proc, clientData) } else { prevPtr->nextPtr = exitPtr->nextPtr; } + Tcl_MutexUnlock(&exitMutex); + ckfree((char *) exitPtr); + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateThreadExitHandler -- + * + * Arrange for a given procedure to be invoked just before the + * current thread exits. + * + * Results: + * None. + * + * Side effects: + * Proc will be invoked with clientData as argument when the + * application exits. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateThreadExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); + exitPtr->proc = proc; + exitPtr->clientData = clientData; + exitPtr->nextPtr = tsdPtr->firstExitPtr; + tsdPtr->firstExitPtr = exitPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteThreadExitHandler -- + * + * This procedure cancels an existing exit handler matching proc + * and clientData, if such a handler exits. + * + * Results: + * None. + * + * Side effects: + * If there is an exit handler corresponding to proc and clientData + * then it is cancelled; if no such handler exists then nothing + * happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteThreadExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure that was previously registered. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr, *prevPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; + prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { + if ((exitPtr->proc == proc) + && (exitPtr->clientData == clientData)) { + if (prevPtr == NULL) { + tsdPtr->firstExitPtr = exitPtr->nextPtr; + } else { + prevPtr->nextPtr = exitPtr->nextPtr; + } ckfree((char *) exitPtr); return; } @@ -484,12 +558,242 @@ Tcl_Exit(status) * 0 for normal return, 1 for error return. */ { Tcl_Finalize(); -#ifdef TCL_MEM_DEBUG - if (tclMemDumpFileName != NULL) { - Tcl_DumpActiveMemory(tclMemDumpFileName); + TclpExit(status); +} + +/* + *------------------------------------------------------------------------- + * + * TclSetLibraryPath -- + * + * Set the path that will be used for searching for init.tcl and + * encodings when an interp is being created. + * + * Results: + * None. + * + * Side effects: + * Changing the library path will affect what directories are + * examined when looking for encodings for all interps from that + * point forward. + * + * The refcount of the new library path is incremented and the + * refcount of the old path is decremented. + * + *------------------------------------------------------------------------- + */ + +void +TclSetLibraryPath(pathPtr) + Tcl_Obj *pathPtr; /* A Tcl list object whose elements are + * the new library path. */ +{ + Tcl_MutexLock(&exitMutex); + if (pathPtr != NULL) { + Tcl_IncrRefCount(pathPtr); + } + if (tclLibraryPath != NULL) { + Tcl_DecrRefCount(tclLibraryPath); + } + tclLibraryPath = pathPtr; + Tcl_MutexUnlock(&exitMutex); +} + +/* + *------------------------------------------------------------------------- + * + * TclGetLibraryPath -- + * + * Return a Tcl list object whose elements are the library path. + * The caller should not modify the contents of the returned object. + * + * Results: + * As above. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetLibraryPath() +{ + return tclLibraryPath; +} + +/* + *------------------------------------------------------------------------- + * + * TclInitSubsystems -- + * + * Initialize various subsytems in Tcl. This should be called the + * first time an interp is created, or before any of the subsystems + * are used. This function ensures an order for the initialization + * of subsystems: + * + * 1. that cannot be initialized in lazy order because they are + * mutually dependent. + * + * 2. so that they can be finalized in a known order w/o causing + * the subsequent re-initialization of a subsystem in the act of + * shutting down another. + * + * Results: + * None. + * + * Side effects: + * Varied, see the respective initialization routines. + * + *------------------------------------------------------------------------- + */ + +void +TclInitSubsystems(argv0) + CONST char *argv0; /* Name of executable from argv[0] to main() + * in native multi-byte encoding. */ +{ + ThreadSpecificData *tsdPtr; + + if (inFinalize != 0) { + panic("TclInitSubsystems called while finalizing"); } + + /* + * Grab the thread local storage pointer before doing anything because + * the initialization routines will be registering exit handlers. + * We use this pointer to detect if this is the first time this + * thread has created an interpreter. + */ + + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + if (subsystemsInitialized == 0) { + /* + * Double check inside the mutex. There are definitly calls + * back into this routine from some of the procedures below. + */ + + TclpInitLock(); + if (subsystemsInitialized == 0) { + /* + * Have to set this bit here to avoid deadlock with the + * routines below us that call into TclInitSubsystems. + */ + + subsystemsInitialized = 1; + + tclExecutableName = NULL; + + /* + * Initialize locks used by the memory allocators before anything + * interesting happens so we can use the allocators in the + * implementation of self-initializing locks. + */ +#if USE_TCLALLOC + TclInitAlloc(); +#endif +#ifdef TCL_MEM_DEBUG + TclInitDbCkalloc(); #endif - TclPlatformExit(status); + + TclpInitPlatform(); + TclInitObjSubsystem(); + TclInitIOSubsystem(); + TclInitEncodingSubsystem(); + TclInitNamespaceSubsystem(); + } + TclpInitUnlock(); + } + + if (tsdPtr == NULL) { + /* + * First time this thread has created an interpreter. + * We fetch the key again just in case no exit handlers were + * registered by this point. + */ + + (void) TCL_TSD_INIT(&dataKey); + TclInitNotifier(); + } +} + +/* + *------------------------------------------------------------------------- + * + * TclFindEncodings -- + * + * Find and load the encoding file for this operating system. + * Before this is called, Tcl makes assumptions about the + * native string representation, but the true encoding is not + * assured. + * + * Results: + * None. + * + * Side effects: + * Varied, see the respective initialization routines. + * + *------------------------------------------------------------------------- + */ + +void +TclFindEncodings(argv0) + CONST char *argv0; /* Name of executable from argv[0] to main() + * in native multi-byte encoding. */ +{ + char *native; + Tcl_Obj *pathPtr; + Tcl_DString libPath, buffer; + + if (encodingsInitialized == 0) { + /* + * Double check inside the mutex. There may be calls + * back into this routine from some of the procedures below. + */ + + TclpInitLock(); + if (encodingsInitialized == 0) { + /* + * Have to set this bit here to avoid deadlock with the + * routines below us that call into TclInitSubsystems. + */ + + encodingsInitialized = 1; + + native = TclpFindExecutable(argv0); + TclpInitLibraryPath(native); + + /* + * The library path was set in the TclpInitLibraryPath routine. + * The string set is a dirty UTF string. To preserve the value + * convert the UTF string back to native before setting the new + * default encoding. + */ + + pathPtr = TclGetLibraryPath(); + if (pathPtr != NULL) { + Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), -1, + &libPath); + } + + TclpSetInitialEncodings(); + + /* + * Now convert the native sting back to native string back to UTF. + */ + + if (pathPtr != NULL) { + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&libPath), -1, + &buffer); + pathPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1); + TclSetLibraryPath(pathPtr); + + Tcl_DStringFree(&libPath); + Tcl_DStringFree(&buffer); + } + } + TclpInitUnlock(); + } } /* @@ -497,16 +801,16 @@ Tcl_Exit(status) * * Tcl_Finalize -- * - * Runs the exit handlers to allow Tcl to clean up its state prior - * to being unloaded. Called by Tcl_Exit and when Tcl was dynamically - * loaded and is now being unloaded. + * Shut down Tcl. First calls registered exit handlers, then + * carefully shuts down various subsystems. + * Called by Tcl_Exit or when the Tcl shared library is being + * unloaded. * * Results: * None. * * Side effects: - * Whatever the exit handlers do. Also frees up storage associated - * with the Tcl object type table. + * Varied, see the respective finalization routines. * *---------------------------------------------------------------------- */ @@ -515,34 +819,150 @@ void Tcl_Finalize() { ExitHandler *exitPtr; + + TclpInitLock(); + if (subsystemsInitialized != 0) { + subsystemsInitialized = 0; + encodingsInitialized = 0; + + /* + * Invoke exit handlers first. + */ + + Tcl_MutexLock(&exitMutex); + inFinalize = 1; + for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { + /* + * Be careful to remove the handler from the list before + * invoking its callback. This protects us against + * double-freeing if the callback should call + * Tcl_DeleteExitHandler on itself. + */ + + firstExitPtr = exitPtr->nextPtr; + Tcl_MutexUnlock(&exitMutex); + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); + Tcl_MutexLock(&exitMutex); + } + firstExitPtr = NULL; + Tcl_MutexUnlock(&exitMutex); + + /* + * Clean up after the current thread now, after exit handlers. + * In particular, the testexithandler command sets up something + * that writes to standard output, which gets closed. + * Note that there is no thread-local storage after this call. + */ - /* - * Invoke exit handler first. - */ + Tcl_FinalizeThread(); + + /* + * Now finalize the Tcl execution environment. Note that this + * must be done after the exit handlers, because there are + * order dependencies. + */ + + TclFinalizeCompExecEnv(); + TclFinalizeEnvironment(); + + TclFinalizeEncodingSubsystem(); + + if (tclLibraryPath != NULL) { + Tcl_DecrRefCount(tclLibraryPath); + tclLibraryPath = NULL; + } + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + if (tclNativeExecutableName != NULL) { + ckfree(tclNativeExecutableName); + tclNativeExecutableName = NULL; + } + if (tclDefaultEncodingDir != NULL) { + ckfree(tclDefaultEncodingDir); + tclDefaultEncodingDir = NULL; + } + + Tcl_SetPanicProc(NULL); + + /* + * Free synchronization objects. There really should only be one + * thread alive at this moment. + */ + + TclFinalizeSynchronization(); + + /* + * We defer unloading of packages until very late + * to avoid memory access issues. Both exit callbacks and + * synchronization variables may be stored in packages. + */ + + TclFinalizeLoad(); - tclInExit = 1; - for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { /* - * Be careful to remove the handler from the list before invoking - * its callback. This protects us against double-freeing if the - * callback should call Tcl_DeleteExitHandler on itself. + * There shouldn't be any malloc'ed memory after this. */ - firstExitPtr = exitPtr->nextPtr; - (*exitPtr->proc)(exitPtr->clientData); - ckfree((char *) exitPtr); + TclFinalizeMemorySubsystem(); + inFinalize = 0; } + TclpInitUnlock(); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FinalizeThread -- + * + * Runs the exit handlers to allow Tcl to clean up its state + * about a particular thread. + * + * Results: + * None. + * + * Side effects: + * Varied, see the respective finalization routines. + * + *---------------------------------------------------------------------- + */ - /* - * Now finalize the Tcl execution environment. Note that this must be done - * after the exit handlers, because there are order dependencies. - */ - - TclFinalizeCompExecEnv(); - TclFinalizeEnvironment(); - TclpFinalize(); - firstExitPtr = NULL; - tclInExit = 0; +void +Tcl_FinalizeThread() +{ + ExitHandler *exitPtr; + ThreadSpecificData *tsdPtr = + (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + + if (tsdPtr != NULL) { + /* + * Invoke thread exit handlers first. + */ + + tsdPtr->inExit = 1; + for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; + exitPtr = tsdPtr->firstExitPtr) { + /* + * Be careful to remove the handler from the list before invoking + * its callback. This protects us against double-freeing if the + * callback should call Tcl_DeleteThreadExitHandler on itself. + */ + + tsdPtr->firstExitPtr = exitPtr->nextPtr; + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); + } + TclFinalizeIOSubsystem(); + TclFinalizeNotifier(); + + /* + * Blow away all thread local storage blocks. + */ + + TclFinalizeThreadData(); + } } /* @@ -564,13 +984,14 @@ Tcl_Finalize() int TclInExit() { - return tclInExit; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + return tsdPtr->inExit; } /* *---------------------------------------------------------------------- * - * Tcl_VwaitCmd -- + * Tcl_VwaitObjCmd -- * * This procedure is invoked to process the "vwait" Tcl command. * See the user documentation for details on what it does. @@ -586,20 +1007,21 @@ TclInExit() /* ARGSUSED */ int -Tcl_VwaitCmd(clientData, interp, argc, argv) +Tcl_VwaitObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int done, foundEvent; + char *nameString; - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " name\"", (char *) NULL); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - if (Tcl_TraceVar(interp, argv[1], + nameString = Tcl_GetString(objv[1]); + if (Tcl_TraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done) != TCL_OK) { return TCL_ERROR; @@ -609,7 +1031,7 @@ Tcl_VwaitCmd(clientData, interp, argc, argv) while (!done && foundEvent) { foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); } - Tcl_UntraceVar(interp, argv[1], + Tcl_UntraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done); @@ -620,7 +1042,7 @@ Tcl_VwaitCmd(clientData, interp, argc, argv) Tcl_ResetResult(interp); if (!foundEvent) { - Tcl_AppendResult(interp, "can't wait for variable \"", argv[1], + Tcl_AppendResult(interp, "can't wait for variable \"", nameString, "\": would wait forever", (char *) NULL); return TCL_ERROR; } @@ -645,7 +1067,7 @@ VwaitVarProc(clientData, interp, name1, name2, flags) /* *---------------------------------------------------------------------- * - * Tcl_UpdateCmd -- + * Tcl_UpdateObjCmd -- * * This procedure is invoked to process the "update" Tcl command. * See the user documentation for details on what it does. @@ -661,29 +1083,38 @@ VwaitVarProc(clientData, interp, name1, name2, flags) /* ARGSUSED */ int -Tcl_UpdateCmd(clientData, interp, argc, argv) +Tcl_UpdateObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int flags; + int optionIndex; + int flags = 0; /* Initialized to avoid compiler warning. */ + static char *updateOptions[] = {"idletasks", (char *) NULL}; + enum updateOptions {REGEXP_IDLETASKS}; - if (argc == 1) { + if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; - } else if (argc == 2) { - if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be idletasks", (char *) NULL); + } else if (objc == 2) { + if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, + "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + switch ((enum updateOptions) optionIndex) { + case REGEXP_IDLETASKS: { + flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + break; + } + default: { + panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); + } + } } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ?idletasks?\"", (char *) NULL); + Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); return TCL_ERROR; } - + while (Tcl_DoOneEvent(flags) != 0) { /* Empty loop body */ } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b899085..4378d34 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -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: tclExecute.c,v 1.5 1998/11/19 20:10:51 stanton Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.6 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -48,6 +48,7 @@ int errno; */ static int execInitialized = 0; +TCL_DECLARE_MUTEX(execMutex) /* * Variable that controls whether execution tracing is enabled and, if so, @@ -61,14 +62,19 @@ static int execInitialized = 0; int tclTraceExec = 0; -/* - * The following global variable is use to signal matherr that Tcl - * is responsible for the arithmetic, so errors can be handled in a - * fashion appropriate for Tcl. Zero means no Tcl math is in - * progress; non-zero means Tcl is doing math. - */ +typedef struct ThreadSpecificData { + /* + * The following global variable is use to signal matherr that Tcl + * is responsible for the arithmetic, so errors can be handled in a + * fashion appropriate for Tcl. Zero means no Tcl math is in + * progress; non-zero means Tcl is doing math. + */ + + int mathInProgress; + +} ThreadSpecificData; -int tcl_MathInProgress = 0; +static Tcl_ThreadDataKey dataKey; /* * The variable below serves no useful purpose except to generate @@ -84,12 +90,6 @@ int (*tclMatherrPtr)() = matherr; #endif /* - * Array of instruction names. - */ - -static char *opName[256]; - -/* * Mapping from expression instruction opcodes to strings; used for error * messages. Note that these entries must match the order and number of the * expression opcodes (e.g., INST_LOR) in tclCompile.h. @@ -110,18 +110,7 @@ static char *operatorStrings[] = { static char *resultStrings[] = { "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" }; -#endif /* TCL_COMPILE_DEBUG */ - -/* - * The following are statistics-related variables that record information - * about the bytecode compiler and interpreter's operation. This includes - * an array that records for each instruction how often it is executed. - */ - -#ifdef TCL_COMPILE_STATS -static long numExecutions = 0; -static int instructionCount[256]; -#endif /* TCL_COMPILE_STATS */ +#endif /* * Macros for testing floating-point values for certain special cases. Test @@ -142,7 +131,8 @@ static int instructionCount[256]; */ #define ADJUST_PC(instBytes) \ - pc += instBytes; continue + pc += (instBytes); \ + continue /* * Macros used to cache often-referenced Tcl evaluation stack information @@ -168,85 +158,47 @@ static int instructionCount[256]; * decremented before the caller had a chance to, e.g., store it in a * variable. It is the caller's responsibility to decrement the ref count * when it is finished with an object. - */ - -#define STK_ITEM(offset) (stackPtr[stackTop + (offset)]) -#define STK_OBJECT(offset) (STK_ITEM(offset).o) -#define STK_INT(offset) (STK_ITEM(offset).i) -#define STK_POINTER(offset) (STK_ITEM(offset).p) - -/* + * * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT * macro. The actual parameter might be an expression with side effects, * and this ensures that it will be executed only once. */ #define PUSH_OBJECT(objPtr) \ - Tcl_IncrRefCount(stackPtr[++stackTop].o = (objPtr)) + Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr)) #define POP_OBJECT() \ - (stackPtr[stackTop--].o) + (stackPtr[stackTop--]) /* * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. * O2S is only used in TRACE* calls to get a string from an object. - * - * NOTE THAT CLIENTS OF O2S ARE LIKELY TO FAIL IF THE OBJECT'S - * STRING REP CONTAINS NULLS. */ #ifdef TCL_COMPILE_DEBUG - -#define O2S(objPtr) \ - Tcl_GetStringFromObj((objPtr), &length) - -#ifdef TCL_COMPILE_STATS #define TRACE(a) \ if (traceInstructions) { \ - fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \ - stackTop, (tclObjsAlloced - tclObjsFreed), \ - (unsigned int)(pc - codePtr->codeStart)); \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ + (unsigned int)(pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ printf a; \ - fflush(stdout); \ } #define TRACE_WITH_OBJ(a, objPtr) \ if (traceInstructions) { \ - fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \ - stackTop, (tclObjsAlloced - tclObjsFreed), \ - (unsigned int)(pc - codePtr->codeStart)); \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ + (unsigned int)(pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ printf a; \ - bytes = Tcl_GetStringFromObj((objPtr), &length); \ - TclPrintSource(stdout, bytes, TclMin(length, 30)); \ + TclPrintObject(stdout, (objPtr), 30); \ fprintf(stdout, "\n"); \ - fflush(stdout); \ - } -#else /* not TCL_COMPILE_STATS */ -#define TRACE(a) \ - if (traceInstructions) { \ - fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \ - (unsigned int)(pc - codePtr->codeStart)); \ - printf a; \ - fflush(stdout); \ } -#define TRACE_WITH_OBJ(a, objPtr) \ - if (traceInstructions) { \ - fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \ - (unsigned int)(pc - codePtr->codeStart)); \ - printf a; \ - bytes = Tcl_GetStringFromObj((objPtr), &length); \ - TclPrintSource(stdout, bytes, TclMin(length, 30)); \ - fprintf(stdout, "\n"); \ - fflush(stdout); \ - } -#endif /* TCL_COMPILE_STATS */ - -#else /* not TCL_COMPILE_DEBUG */ - +#define O2S(objPtr) \ + Tcl_GetString(objPtr) +#else #define TRACE(a) #define TRACE_WITH_OBJ(a, objPtr) #define O2S(objPtr) - #endif /* TCL_COMPILE_DEBUG */ /* @@ -280,32 +232,34 @@ static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, #ifdef TCL_COMPILE_STATS static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -#endif /* TCL_COMPILE_STATS */ +#endif static void FreeCmdNameInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); +#ifdef TCL_COMPILE_DEBUG +static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc)); +#endif +static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc, + int catchOnly, ByteCode* codePtr)); static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, ByteCode* codePtr, int *lengthPtr)); static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); static void IllegalExprOperandType _ANSI_ARGS_(( - Tcl_Interp *interp, unsigned int opCode, + Tcl_Interp *interp, unsigned char *pc, Tcl_Obj *opndPtr)); static void InitByteCodeExecution _ANSI_ARGS_(( Tcl_Interp *interp)); +#ifdef TCL_COMPILE_DEBUG static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); -static void RecordTracebackInfo _ANSI_ARGS_((Tcl_Interp *interp, - unsigned char *pc, ByteCode *codePtr)); +#endif static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); #ifdef TCL_COMPILE_DEBUG static char * StringForResultCode _ANSI_ARGS_((int result)); -#endif /* TCL_COMPILE_DEBUG */ -static void UpdateStringOfCmdName _ANSI_ARGS_((Tcl_Obj *objPtr)); -#ifdef TCL_COMPILE_DEBUG static void ValidatePcAndStackTop _ANSI_ARGS_(( ByteCode *codePtr, unsigned char *pc, int stackTop, int stackLowerBound, int stackUpperBound)); -#endif /* TCL_COMPILE_DEBUG */ +#endif /* * Table describing the built-in math functions. Entries in this table are @@ -356,7 +310,7 @@ Tcl_ObjType tclCmdNameType = { "cmdName", /* name */ FreeCmdNameInternalRep, /* freeIntRepProc */ DupCmdNameInternalRep, /* dupIntRepProc */ - UpdateStringOfCmdName, /* updateStringProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ SetCmdNameFromAny /* setFromAnyProc */ }; @@ -388,28 +342,16 @@ InitByteCodeExecution(interp) * "tcl_traceExec" is linked to control * instruction tracing. */ { - int i; - Tcl_RegisterObjType(&tclCmdNameType); - - (VOID *) memset(opName, 0, sizeof(opName)); - for (i = 0; instructionTable[i].name != NULL; i++) { - opName[i] = instructionTable[i].name; + if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, + TCL_LINK_INT) != TCL_OK) { + panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); } #ifdef TCL_COMPILE_STATS - (VOID *) memset(instructionCount, 0, sizeof(instructionCount)); - (VOID *) memset(tclByteCodeCount, 0, sizeof(tclByteCodeCount)); - (VOID *) memset(tclSourceCount, 0, sizeof(tclSourceCount)); - Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); #endif /* TCL_COMPILE_STATS */ - - if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, - TCL_LINK_INT) != TCL_OK) { - panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); - } } /* @@ -443,16 +385,18 @@ TclCreateExecEnv(interp) { ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); - eePtr->stackPtr = (StackItem *) - ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(StackItem))); + eePtr->stackPtr = (Tcl_Obj **) + ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *))); eePtr->stackTop = -1; eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1); + Tcl_MutexLock(&execMutex); if (!execInitialized) { - TclInitAuxDataTypeTable(); - InitByteCodeExecution(interp); - execInitialized = 1; + TclInitAuxDataTypeTable(); + InitByteCodeExecution(interp); + execInitialized = 1; } + Tcl_MutexUnlock(&execMutex); return eePtr; } @@ -486,7 +430,7 @@ TclDeleteExecEnv(eePtr) /* *---------------------------------------------------------------------- * - * TclFinalizeExecEnv -- + * TclFinalizeExecution -- * * Finalizes the execution environment setup so that it can be * later reinitialized. @@ -502,9 +446,11 @@ TclDeleteExecEnv(eePtr) */ void -TclFinalizeExecEnv() +TclFinalizeExecution() { + Tcl_MutexLock(&execMutex); execInitialized = 0; + Tcl_MutexUnlock(&execMutex); TclFinalizeAuxDataTypeTable(); } @@ -536,9 +482,9 @@ GrowEvaluationStack(eePtr) int currElems = (eePtr->stackEnd + 1); int newElems = 2*currElems; - int currBytes = currElems * sizeof(StackItem); + int currBytes = currElems * sizeof(Tcl_Obj *); int newBytes = 2*currBytes; - StackItem *newStackPtr = (StackItem *) ckalloc((unsigned) newBytes); + Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); /* * Copy the existing stack items to the new stack space, free the old @@ -580,15 +526,12 @@ TclExecuteByteCode(interp, codePtr) Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; /* Points to the execution environment. */ - register StackItem *stackPtr = eePtr->stackPtr; + register Tcl_Obj **stackPtr = eePtr->stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop = eePtr->stackTop; /* Cached top index of evaluation stack. */ - Tcl_Obj **objArrayPtr = codePtr->objArrayPtr; - /* Points to the ByteCode's object array. */ - unsigned char *pc = codePtr->codeStart; + register unsigned char *pc = codePtr->codeStart; /* The current program counter. */ - unsigned char opCode; /* The current instruction code. */ int opnd; /* Current instruction's operand byte. */ int pcAdjustment; /* Hold pc adjustment after instruction. */ int initStackTop = stackTop;/* Stack top at start of execution. */ @@ -598,13 +541,10 @@ TclExecuteByteCode(interp, codePtr) * process break, continue, and errors. */ int result = TCL_OK; /* Return code returned after execution. */ int traceInstructions = (tclTraceExec == 3); - Tcl_Obj *valuePtr, *value2Ptr, *namePtr, *objPtr; + Tcl_Obj *valuePtr, *value2Ptr, *objPtr; char *bytes; int length; long i; - Tcl_DString command; /* Used for debugging. If tclTraceExec >= 2 - * holds a string representing the last - * command invoked. */ /* * This procedure uses a stack to hold information about catch commands. @@ -613,29 +553,22 @@ TclExecuteByteCode(interp, codePtr) * allocated space but uses dynamically-allocated storage if needed. */ -#define STATIC_CATCH_STACK_SIZE 5 +#define STATIC_CATCH_STACK_SIZE 4 int (catchStackStorage[STATIC_CATCH_STACK_SIZE]); int *catchStackPtr = catchStackStorage; int catchTop = -1; - /* - * THIS PROC FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. - */ - +#ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { PrintByteCodeInfo(codePtr); -#ifdef TCL_COMPILE_STATS - fprintf(stdout, " Starting stack top=%d, system objects=%ld\n", - eePtr->stackTop, (tclObjsAlloced - tclObjsFreed)); -#else fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop); -#endif /* TCL_COMPILE_STATS */ fflush(stdout); } - +#endif + #ifdef TCL_COMPILE_STATS - numExecutions++; -#endif /* TCL_COMPILE_STATS */ + iPtr->stats.numExecutions++; +#endif /* * Make sure the catch stack is large enough to hold the maximum number @@ -643,9 +576,9 @@ TclExecuteByteCode(interp, codePtr) * will be no more than the exception range array's depth. */ - if (codePtr->maxExcRangeDepth > STATIC_CATCH_STACK_SIZE) { + if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) { catchStackPtr = (int *) - ckalloc(codePtr->maxExcRangeDepth * sizeof(int)); + ckalloc(codePtr->maxExceptDepth * sizeof(int)); } /* @@ -658,13 +591,6 @@ TclExecuteByteCode(interp, codePtr) } /* - * Initialize the buffer that holds a string containing the name and - * arguments for the last invoked command. - */ - - Tcl_DStringInit(&command); - - /* * Loop executing instructions until a "done" instruction, a TCL_RETURN, * or some error. */ @@ -674,24 +600,17 @@ TclExecuteByteCode(interp, codePtr) ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop, eePtr->stackEnd); #else /* not TCL_COMPILE_DEBUG */ - if (traceInstructions) { -#ifdef TCL_COMPILE_STATS - fprintf(stdout, "%d: %d,%ld ", iPtr->numLevels, stackTop, - (tclObjsAlloced - tclObjsFreed)); -#else /* TCL_COMPILE_STATS */ - fprintf(stdout, "%d: %d ", iPtr->numLevels, stackTop); -#endif /* TCL_COMPILE_STATS */ - TclPrintInstruction(codePtr, pc); - fflush(stdout); - } + if (traceInstructions) { + fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop); + TclPrintInstruction(codePtr, pc); + fflush(stdout); + } #endif /* TCL_COMPILE_DEBUG */ - opCode = *pc; #ifdef TCL_COMPILE_STATS - instructionCount[opCode]++; -#endif /* TCL_COMPILE_STATS */ - - switch (opCode) { + iPtr->stats.instructionCount[*pc]++; +#endif + switch (*pc) { case INST_DONE: /* * Pop the topmost object from the stack, set the interpreter's @@ -705,38 +624,43 @@ TclExecuteByteCode(interp, codePtr) (unsigned int)(pc - codePtr->codeStart), (unsigned int) stackTop, (unsigned int) initStackTop); - fprintf(stderr, " Source: "); - TclPrintSource(stderr, codePtr->source, 150); panic("TclExecuteByteCode execution failure: end stack top != start stack top"); } - TRACE_WITH_OBJ(("done => return code=%d, result is ", result), + TRACE_WITH_OBJ(("=> return code=%d, result=", result), iPtr->objResultPtr); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, "\n"); + } +#endif goto done; case INST_PUSH1: - valuePtr = objArrayPtr[TclGetUInt1AtPtr(pc+1)]; +#ifdef TCL_COMPILE_DEBUG + valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]; PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPtr(pc+1)), - valuePtr); + TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr); +#else + PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); +#endif /* TCL_COMPILE_DEBUG */ ADJUST_PC(2); case INST_PUSH4: - valuePtr = objArrayPtr[TclGetUInt4AtPtr(pc+1)]; + valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPtr(pc+1)), - valuePtr); + TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr); ADJUST_PC(5); case INST_POP: valuePtr = POP_OBJECT(); - TRACE_WITH_OBJ(("pop => discarding "), valuePtr); + TRACE_WITH_OBJ(("=> discarding "), valuePtr); TclDecrRefCount(valuePtr); /* finished with pop'ed object. */ ADJUST_PC(1); case INST_DUP: - valuePtr = stackPtr[stackTop].o; + valuePtr = stackPtr[stackTop]; PUSH_OBJECT(Tcl_DuplicateObj(valuePtr)); - TRACE_WITH_OBJ(("dup => "), valuePtr); + TRACE_WITH_OBJ(("=> "), valuePtr); ADJUST_PC(1); case INST_CONCAT1: @@ -752,8 +676,7 @@ TclExecuteByteCode(interp, codePtr) */ for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { - valuePtr = stackPtr[i].o; - bytes = TclGetStringFromObj(valuePtr, &length); + bytes = Tcl_GetStringFromObj(stackPtr[i], &length); if (bytes != NULL) { totalLen += length; } @@ -770,8 +693,8 @@ TclExecuteByteCode(interp, codePtr) concatObjPtr->bytes = p; concatObjPtr->length = totalLen; for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { - valuePtr = stackPtr[i].o; - bytes = TclGetStringFromObj(valuePtr, &length); + valuePtr = stackPtr[i]; + bytes = Tcl_GetStringFromObj(valuePtr, &length); if (bytes != NULL) { memcpy((VOID *) p, (VOID *) bytes, (size_t) length); @@ -782,14 +705,13 @@ TclExecuteByteCode(interp, codePtr) *p = '\0'; } else { for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { - valuePtr = stackPtr[i].o; - Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(stackPtr[i]); } } stackTop -= opnd; PUSH_OBJECT(concatObjPtr); - TRACE_WITH_OBJ(("concat %u => ", opnd), concatObjPtr); + TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr); ADJUST_PC(2); } @@ -804,19 +726,13 @@ TclExecuteByteCode(interp, codePtr) doInvocation: { - char *cmdName; - Command *cmdPtr; /* Points to command's Command struct. */ - int objc = opnd; /* The number of arguments. */ - Tcl_Obj **objv; /* The array of argument objects. */ - Tcl_Obj *objv0Ptr; /* Holds objv[0], the command name. */ - int newPcOffset = 0; - /* Instruction offset computed during - * break, continue, error processing. - * Init. to avoid compiler warning. */ - Tcl_Command cmd; + int objc = opnd; /* The number of arguments. */ + Tcl_Obj **objv; /* The array of argument objects. */ + Command *cmdPtr; /* Points to command's Command struct. */ + int newPcOffset; /* New inst offset for break, continue. */ #ifdef TCL_COMPILE_DEBUG int isUnknownCmd = 0; - char cmdNameBuf[30]; + char cmdNameBuf[21]; #endif /* TCL_COMPILE_DEBUG */ /* @@ -834,49 +750,31 @@ TclExecuteByteCode(interp, codePtr) goto checkForCatch; } - objv = &(stackPtr[stackTop - (objc-1)].o); - objv0Ptr = objv[0]; - cmdName = TclGetStringFromObj(objv0Ptr, (int *) NULL); - /* - * Find the procedure to execute this command. If there - * isn't one, then see if there is a command "unknown". If - * so, invoke it, passing it the original command words as - * arguments. - * - * We convert the objv[0] object to be a CmdName object. - * This caches a pointer to the Command structure for the - * command; this pointer is held in a ResolvedCmdName - * structure the object's internal rep. points to. - */ - - cmd = Tcl_GetCommandFromObj(interp, objv0Ptr); - cmdPtr = (Command *) cmd; - - /* - * If the command is still not found, handle it with the - * "unknown" proc. + * Find the procedure to execute this command. If the + * command is not found, handle it with the "unknown" proc. */ + objv = &(stackPtr[stackTop - (objc-1)]); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); if (cmdPtr == NULL) { - cmd = Tcl_FindCommand(interp, "unknown", - (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); - if (cmd == (Tcl_Command) NULL) { + cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown", + (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); + if (cmdPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", cmdName, "\"", + "invalid command name \"", + Tcl_GetString(objv[0]), "\"", (char *) NULL); - TRACE(("%s %u => unknown proc not found: ", - opName[opCode], objc)); + TRACE(("%u => unknown proc not found: ", objc)); result = TCL_ERROR; goto checkForCatch; } - cmdPtr = (Command *) cmd; #ifdef TCL_COMPILE_DEBUG isUnknownCmd = 1; #endif /*TCL_COMPILE_DEBUG*/ stackTop++; /* need room for new inserted objv[0] */ - for (i = objc; i >= 0; i--) { + for (i = objc-1; i >= 0; i--) { objv[i+1] = objv[i]; } objc++; @@ -916,38 +814,28 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_ResetResult(interp); - if (tclTraceExec >= 2) { - char buffer[50]; - - sprintf(buffer, "%d: (%u) invoking ", iPtr->numLevels, - (unsigned int)(pc - codePtr->codeStart)); - Tcl_DStringAppend(&command, buffer, -1); - #ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { /* tclTraceExec == 3 */ - strncpy(cmdNameBuf, cmdName, 20); - TRACE(("%s %u => call ", opName[opCode], - (isUnknownCmd? objc-1 : objc))); + if (traceInstructions) { + strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20); + TRACE(("%u => call ", (isUnknownCmd? objc-1:objc))); } else { - fprintf(stdout, "%s", buffer); + fprintf(stdout, "%d: (%u) invoking ", + iPtr->numLevels, + (unsigned int)(pc - codePtr->codeStart)); } -#else /* TCL_COMPILE_DEBUG */ - fprintf(stdout, "%s", buffer); -#endif /*TCL_COMPILE_DEBUG*/ - for (i = 0; i < objc; i++) { - bytes = TclGetStringFromObj(objv[i], &length); - TclPrintSource(stdout, bytes, TclMin(length, 15)); + TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); - - sprintf(buffer, "\"%.*s\" ", TclMin(length, 15), bytes); - Tcl_DStringAppend(&command, buffer, -1); } fprintf(stdout, "\n"); fflush(stdout); - - Tcl_DStringFree(&command); +#else /* TCL_COMPILE_DEBUG */ + fprintf(stdout, "%d: (%u) invoking %s\n", + iPtr->numLevels, + (unsigned int)(pc - codePtr->codeStart), + Tcl_GetString(objv[0])); +#endif /*TCL_COMPILE_DEBUG*/ } iPtr->cmdCount++; @@ -975,14 +863,12 @@ TclExecuteByteCode(interp, codePtr) * Pop the objc top stack elements and decrement their ref * counts. */ - - i = (stackTop - (objc-1)); - while (i <= stackTop) { - valuePtr = stackPtr[i].o; + + for (i = 0; i < objc; i++) { + valuePtr = stackPtr[stackTop]; TclDecrRefCount(valuePtr); - i++; + stackTop--; } - stackTop -= objc; /* * Process the result of the Tcl_ObjCmdProc call. @@ -995,9 +881,8 @@ TclExecuteByteCode(interp, codePtr) * with the next instruction. */ PUSH_OBJECT(Tcl_GetObjResult(interp)); - TRACE_WITH_OBJ(("%s %u => ...after \"%.20s\", result=", - opName[opCode], objc, cmdNameBuf), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); ADJUST_PC(pcAdjustment); case TCL_BREAK: @@ -1011,38 +896,39 @@ TclExecuteByteCode(interp, codePtr) * catchOffset. If no enclosing range is found, stop * execution and return the TCL_BREAK or TCL_CONTINUE. */ - rangePtr = TclGetExceptionRangeForPc(pc, - /*catchOnly*/ 0, codePtr); + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, + codePtr); if (rangePtr == NULL) { - TRACE(("%s %u => ... after \"%.20s\", no encl. loop or catch, returning %s\n", - opName[opCode], objc, cmdNameBuf, + TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n", + objc, cmdNameBuf, StringForResultCode(result))); goto abnormalReturn; /* no catch exists to check */ } + newPcOffset = 0; switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: if (result == TCL_BREAK) { newPcOffset = rangePtr->breakOffset; } else if (rangePtr->continueOffset == -1) { - TRACE(("%s %u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n", - opName[opCode], objc, cmdNameBuf, + TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n", + objc, cmdNameBuf, StringForResultCode(result))); goto checkForCatch; } else { newPcOffset = rangePtr->continueOffset; } - TRACE(("%s %u => ... after \"%.20s\", %s, range at %d, new pc %d\n", - opName[opCode], objc, cmdNameBuf, + TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n", + objc, cmdNameBuf, StringForResultCode(result), rangePtr->codeOffset, newPcOffset)); break; case CATCH_EXCEPTION_RANGE: - TRACE(("%s %u => ... after \"%.20s\", %s...\n", - opName[opCode], objc, cmdNameBuf, + TRACE(("%u => ... after \"%.20s\", %s...\n", + objc, cmdNameBuf, StringForResultCode(result))); goto processCatch; /* it will use rangePtr */ default: - panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); + panic("TclExecuteByteCode: bad ExceptionRange type\n"); } result = TCL_OK; pc = (codePtr->codeStart + newPcOffset); @@ -1053,9 +939,8 @@ TclExecuteByteCode(interp, codePtr) * The invoked command returned an error. Look for an * enclosing catch exception range, if any. */ - TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", TCL_ERROR ", - opName[opCode], objc, cmdNameBuf), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); goto checkForCatch; case TCL_RETURN: @@ -1064,30 +949,29 @@ TclExecuteByteCode(interp, codePtr) * procedure stop execution and return. First check * for an enclosing catch exception range, if any. */ - TRACE(("%s %u => ... after \"%.20s\", TCL_RETURN\n", - opName[opCode], objc, cmdNameBuf)); + TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n", + objc, cmdNameBuf)); goto checkForCatch; default: - TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", OTHER RETURN CODE %d ", - opName[opCode], objc, cmdNameBuf, result), + TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ", + objc, cmdNameBuf, result), Tcl_GetObjResult(interp)); goto checkForCatch; - } /* end of switch on result from invoke instruction */ + } } case INST_EVAL_STK: objPtr = POP_OBJECT(); DECACHE_STACK_INFO(); - result = Tcl_EvalObj(interp, objPtr); + result = Tcl_EvalObjEx(interp, objPtr, 0); CACHE_STACK_INFO(); if (result == TCL_OK) { /* * Normal return; push the eval's object result. */ - PUSH_OBJECT(Tcl_GetObjResult(interp)); - TRACE_WITH_OBJ(("evalStk \"%.30s\" => ", O2S(objPtr)), + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), Tcl_GetObjResult(interp)); TclDecrRefCount(objPtr); ADJUST_PC(1); @@ -1105,10 +989,10 @@ TclExecuteByteCode(interp, codePtr) * continue, error processing. Init. * to avoid compiler warning. */ - rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); if (rangePtr == NULL) { - TRACE(("evalStk \"%.30s\" => no encl. loop or catch, returning %s\n", + TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n", O2S(objPtr), StringForResultCode(result))); Tcl_DecrRefCount(objPtr); goto abnormalReturn; /* no catch exists to check */ @@ -1118,7 +1002,7 @@ TclExecuteByteCode(interp, codePtr) if (result == TCL_BREAK) { newPcOffset = rangePtr->breakOffset; } else if (rangePtr->continueOffset == -1) { - TRACE(("evalStk \"%.30s\" => %s, loop w/o continue, checking for catch\n", + TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n", O2S(objPtr), StringForResultCode(result))); Tcl_DecrRefCount(objPtr); goto checkForCatch; @@ -1126,12 +1010,12 @@ TclExecuteByteCode(interp, codePtr) newPcOffset = rangePtr->continueOffset; } result = TCL_OK; - TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s, range at %d, new pc %d ", + TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ", O2S(objPtr), StringForResultCode(result), rangePtr->codeOffset, newPcOffset), valuePtr); break; case CATCH_EXCEPTION_RANGE: - TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s ", + TRACE_WITH_OBJ(("\"%.30s\" => %s ", O2S(objPtr), StringForResultCode(result)), valuePtr); Tcl_DecrRefCount(objPtr); @@ -1143,7 +1027,7 @@ TclExecuteByteCode(interp, codePtr) pc = (codePtr->codeStart + newPcOffset); continue; /* restart outer instruction loop at pc */ } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */ - TRACE_WITH_OBJ(("evalStk \"%.30s\" => ERROR: ", O2S(objPtr)), + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(objPtr); goto checkForCatch; @@ -1156,57 +1040,75 @@ TclExecuteByteCode(interp, codePtr) result = Tcl_ExprObj(interp, objPtr, &valuePtr); CACHE_STACK_INFO(); if (result != TCL_OK) { - TRACE_WITH_OBJ(("exprStk \"%.30s\" => ERROR: ", + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(objPtr); goto checkForCatch; } - stackPtr[++stackTop].o = valuePtr; /* already has right refct */ - TRACE_WITH_OBJ(("exprStk \"%.30s\" => ", O2S(objPtr)), valuePtr); + stackPtr[++stackTop] = valuePtr; /* already has right refct */ + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); TclDecrRefCount(objPtr); ADJUST_PC(1); - case INST_LOAD_SCALAR4: - opnd = TclGetInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doLoadScalar; - case INST_LOAD_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doLoadScalar: +#ifdef TCL_COMPILE_DEBUG + opnd = TclGetInt1AtPtr(pc+1); + DECACHE_STACK_INFO(); + valuePtr = TclGetIndexedScalar(interp, opnd, + /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("%u => ERROR: ", opnd), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("%u => ", opnd), valuePtr); +#else /* TCL_COMPILE_DEBUG */ + DECACHE_STACK_INFO(); + valuePtr = TclGetIndexedScalar(interp, TclGetInt1AtPtr(pc+1), + /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); +#endif /* TCL_COMPILE_DEBUG */ + ADJUST_PC(2); + + case INST_LOAD_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); DECACHE_STACK_INFO(); valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1); CACHE_STACK_INFO(); if (valuePtr == NULL) { - TRACE_WITH_OBJ(("%s %u => ERROR: ", opName[opCode], opnd), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u => ERROR: ", opnd), + Tcl_GetObjResult(interp)); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("%s %u => ", opName[opCode], opnd), valuePtr); - ADJUST_PC(pcAdjustment); + TRACE_WITH_OBJ(("%u => ", opnd), valuePtr); + ADJUST_PC(5); case INST_LOAD_SCALAR_STK: - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* scalar name */ DECACHE_STACK_INFO(); - valuePtr = Tcl_ObjGetVar2(interp, namePtr, (Tcl_Obj *) NULL, - TCL_LEAVE_ERR_MSG); + valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { - TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ERROR: ", - O2S(namePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(objPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ", - O2S(namePtr)), valuePtr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); + TclDecrRefCount(objPtr); ADJUST_PC(1); case INST_LOAD_ARRAY4: @@ -1227,16 +1129,15 @@ TclExecuteByteCode(interp, codePtr) elemPtr, /*leaveErrorMsg*/ 1); CACHE_STACK_INFO(); if (valuePtr == NULL) { - TRACE_WITH_OBJ(("%s %u \"%.30s\" => ERROR: ", - opName[opCode], opnd, O2S(elemPtr)), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ", + opnd, O2S(elemPtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("%s %u \"%.30s\" => ", - opName[opCode], opnd, O2S(elemPtr)), valuePtr); + TRACE_WITH_OBJ(("%u \"%.30s\" => ", + opnd, O2S(elemPtr)),valuePtr); TclDecrRefCount(elemPtr); } ADJUST_PC(pcAdjustment); @@ -1245,45 +1146,43 @@ TclExecuteByteCode(interp, codePtr) { Tcl_Obj *elemPtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ DECACHE_STACK_INFO(); - valuePtr = Tcl_ObjGetVar2(interp, namePtr, elemPtr, + valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { - TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ERROR: ", - O2S(namePtr), O2S(elemPtr)), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ", + O2S(objPtr), O2S(elemPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ", - O2S(namePtr), O2S(elemPtr)), valuePtr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ", + O2S(objPtr), O2S(elemPtr)), valuePtr); + TclDecrRefCount(objPtr); TclDecrRefCount(elemPtr); } ADJUST_PC(1); case INST_LOAD_STK: - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* variable name */ DECACHE_STACK_INFO(); - valuePtr = Tcl_ObjGetVar2(interp, namePtr, NULL, - TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); + valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { - TRACE_WITH_OBJ(("loadStk \"%.30s\" => ERROR: ", - O2S(namePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", + O2S(objPtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(objPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("loadStk \"%.30s\" => ", O2S(namePtr)), - valuePtr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); + TclDecrRefCount(objPtr); ADJUST_PC(1); case INST_STORE_SCALAR4: @@ -1299,46 +1198,41 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); DECACHE_STACK_INFO(); value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr, - /*leaveErrorMsg*/ 1); + /*leaveErrorMsg*/ 1); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ERROR: ", - opName[opCode], opnd, O2S(valuePtr)), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", + opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ", - opName[opCode], opnd, O2S(valuePtr)), value2Ptr); + TRACE_WITH_OBJ(("%u <- \"%.30s\" => ", + opnd, O2S(valuePtr)), value2Ptr); TclDecrRefCount(valuePtr); ADJUST_PC(pcAdjustment); case INST_STORE_SCALAR_STK: valuePtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* scalar name */ DECACHE_STACK_INFO(); - value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr, - TCL_LEAVE_ERR_MSG); + value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ( - ("storeScalarStk \"%.30s\" <- \"%.30s\" => ERROR: ", - O2S(namePtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ( - ("storeScalarStk \"%.30s\" <- \"%.30s\" => ", - O2S(namePtr), - O2S(valuePtr)), - value2Ptr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", + O2S(objPtr), O2S(valuePtr)), value2Ptr); + TclDecrRefCount(objPtr); TclDecrRefCount(valuePtr); ADJUST_PC(1); @@ -1362,19 +1256,17 @@ TclExecuteByteCode(interp, codePtr) elemPtr, valuePtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ( - ("%s %u \"%.30s\" <- \"%.30s\" => ERROR: ", - opName[opCode], opnd, O2S(elemPtr), - O2S(valuePtr)), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ", + opnd, O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%s %u \"%.30s\" <- \"%.30s\" => ", - opName[opCode], opnd, O2S(elemPtr), O2S(valuePtr)), - value2Ptr); + TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ", + opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr); TclDecrRefCount(elemPtr); TclDecrRefCount(valuePtr); } @@ -1386,26 +1278,26 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); elemPtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ DECACHE_STACK_INFO(); - value2Ptr = Tcl_ObjSetVar2(interp, namePtr, elemPtr, - valuePtr, TCL_LEAVE_ERR_MSG); + value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", - O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ", - O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(namePtr); + TclDecrRefCount(objPtr); TclDecrRefCount(elemPtr); TclDecrRefCount(valuePtr); } @@ -1413,24 +1305,24 @@ TclExecuteByteCode(interp, codePtr) case INST_STORE_STK: valuePtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* variable name */ DECACHE_STACK_INFO(); - value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr, - TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); + value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ERROR: ", - O2S(namePtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ", - O2S(namePtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", + O2S(objPtr), O2S(valuePtr)), value2Ptr); + TclDecrRefCount(objPtr); TclDecrRefCount(valuePtr); ADJUST_PC(1); @@ -1440,7 +1332,7 @@ TclExecuteByteCode(interp, codePtr) if (valuePtr->typePtr != &tclIntType) { result = tclIntType.setFromAnyProc(interp, valuePtr); if (result != TCL_OK) { - TRACE_WITH_OBJ(("incrScalar1 %u (by %s) => ERROR converting increment amount to int: ", + TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(valuePtr); goto checkForCatch; @@ -1451,51 +1343,49 @@ TclExecuteByteCode(interp, codePtr) value2Ptr = TclIncrIndexedScalar(interp, opnd, i); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ERROR: ", - opnd, i), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ", opnd, i), - value2Ptr); + TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr); TclDecrRefCount(valuePtr); ADJUST_PC(2); case INST_INCR_SCALAR_STK: case INST_INCR_STK: valuePtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* scalar name */ if (valuePtr->typePtr != &tclIntType) { result = tclIntType.setFromAnyProc(interp, valuePtr); if (result != TCL_OK) { - TRACE_WITH_OBJ(("%s \"%.30s\" (by %s) => ERROR converting increment amount to int: ", - opName[opCode], O2S(namePtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ", + O2S(objPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } i = valuePtr->internalRep.longValue; DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i, - /*part1NotParsed*/ (opCode == INST_INCR_STK)); + value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ERROR: ", - opName[opCode], O2S(namePtr), i), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ", + O2S(objPtr), i), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ", - opName[opCode], O2S(namePtr), i), value2Ptr); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i), + value2Ptr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(valuePtr); ADJUST_PC(1); @@ -1509,7 +1399,7 @@ TclExecuteByteCode(interp, codePtr) if (valuePtr->typePtr != &tclIntType) { result = tclIntType.setFromAnyProc(interp, valuePtr); if (result != TCL_OK) { - TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", + TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", opnd, O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); @@ -1523,7 +1413,7 @@ TclExecuteByteCode(interp, codePtr) elemPtr, i); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ERROR: ", + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", opnd, O2S(elemPtr), i), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); @@ -1532,7 +1422,7 @@ TclExecuteByteCode(interp, codePtr) goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ", + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", opnd, O2S(elemPtr), i), value2Ptr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); @@ -1545,14 +1435,14 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); elemPtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ if (valuePtr->typePtr != &tclIntType) { result = tclIntType.setFromAnyProc(interp, valuePtr); if (result != TCL_OK) { - TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", - O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); goto checkForCatch; @@ -1560,23 +1450,23 @@ TclExecuteByteCode(interp, codePtr) } i = valuePtr->internalRep.longValue; DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i, - /*part1NotParsed*/ 0); + value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ERROR: ", - O2S(namePtr), O2S(elemPtr), i), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", + O2S(objPtr), O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ", - O2S(namePtr), O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", + O2S(objPtr), O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); } @@ -1589,36 +1479,34 @@ TclExecuteByteCode(interp, codePtr) value2Ptr = TclIncrIndexedScalar(interp, opnd, i); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ERROR: ", - opnd, i), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i), + Tcl_GetObjResult(interp)); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ", opnd, i), - value2Ptr); + TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr); ADJUST_PC(3); case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* variable name */ i = TclGetInt1AtPtr(pc+1); DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i, - /*part1NotParsed*/ (opCode == INST_INCR_STK_IMM)); + value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ERROR: ", - opName[opCode], O2S(namePtr), i), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ", + O2S(objPtr), i), Tcl_GetObjResult(interp)); result = TCL_ERROR; - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ", - opName[opCode], O2S(namePtr), i), value2Ptr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i), + value2Ptr); + TclDecrRefCount(objPtr); ADJUST_PC(2); case INST_INCR_ARRAY1_IMM: @@ -1633,7 +1521,7 @@ TclExecuteByteCode(interp, codePtr) elemPtr, i); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ERROR: ", + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", opnd, O2S(elemPtr), i), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); @@ -1641,7 +1529,7 @@ TclExecuteByteCode(interp, codePtr) goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ", + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", opnd, O2S(elemPtr), i), value2Ptr); Tcl_DecrRefCount(elemPtr); } @@ -1653,37 +1541,42 @@ TclExecuteByteCode(interp, codePtr) i = TclGetInt1AtPtr(pc+1); elemPtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i, - /*part1NotParsed*/ 0); + value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ERROR: ", - O2S(namePtr), O2S(elemPtr), i), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", + O2S(objPtr), O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ", - O2S(namePtr), O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", + O2S(objPtr), O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); } ADJUST_PC(2); case INST_JUMP1: +#ifdef TCL_COMPILE_DEBUG opnd = TclGetInt1AtPtr(pc+1); - TRACE(("jump1 %d => new pc %u\n", opnd, + TRACE(("%d => new pc %u\n", opnd, (unsigned int)(pc + opnd - codePtr->codeStart))); - ADJUST_PC(opnd); + pc += opnd; +#else + pc += TclGetInt1AtPtr(pc+1); +#endif /* TCL_COMPILE_DEBUG */ + continue; case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); - TRACE(("jump4 %d => new pc %u\n", opnd, + TRACE(("%d => new pc %u\n", opnd, (unsigned int)(pc + opnd - codePtr->codeStart))); ADJUST_PC(opnd); @@ -1708,21 +1601,20 @@ TclExecuteByteCode(interp, codePtr) } else { result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); if (result != TCL_OK) { - TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode], - opnd), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } if (b) { - TRACE(("%s %d => %.20s true, new pc %u\n", - opName[opCode], opnd, O2S(valuePtr), + TRACE(("%d => %.20s true, new pc %u\n", + opnd, O2S(valuePtr), (unsigned int)(pc+opnd - codePtr->codeStart))); TclDecrRefCount(valuePtr); ADJUST_PC(opnd); } else { - TRACE(("%s %d => %.20s false\n", opName[opCode], opnd, - O2S(valuePtr))); + TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr))); TclDecrRefCount(valuePtr); ADJUST_PC(pcAdjustment); } @@ -1749,20 +1641,19 @@ TclExecuteByteCode(interp, codePtr) } else { result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); if (result != TCL_OK) { - TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode], - opnd), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } if (b) { - TRACE(("%s %d => %.20s true\n", opName[opCode], opnd, - O2S(valuePtr))); + TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr))); TclDecrRefCount(valuePtr); ADJUST_PC(pcAdjustment); } else { - TRACE(("%s %d => %.20s false, new pc %u\n", - opName[opCode], opnd, O2S(valuePtr), + TRACE(("%d => %.20s false, new pc %u\n", + opnd, O2S(valuePtr), (unsigned int)(pc + opnd - codePtr->codeStart))); TclDecrRefCount(valuePtr); ADJUST_PC(opnd); @@ -1791,9 +1682,9 @@ TclExecuteByteCode(interp, codePtr) i1 = (valuePtr->internalRep.longValue != 0); } else if (t1Ptr == &tclDoubleType) { i1 = (valuePtr->internalRep.doubleValue != 0.0); - } else { /* FAILS IF NULL STRING REP */ - s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); - if (TclLooksLikeInt(s)) { + } else { + s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); i1 = (i != 0); @@ -1803,10 +1694,10 @@ TclExecuteByteCode(interp, codePtr) i1 = (i1 != 0); } if (result != TCL_OK) { - TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", - opName[opCode], O2S(valuePtr), + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", + O2S(valuePtr), (t1Ptr? t1Ptr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + IllegalExprOperandType(interp, pc, valuePtr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -1817,22 +1708,21 @@ TclExecuteByteCode(interp, codePtr) i2 = (value2Ptr->internalRep.longValue != 0); } else if (t2Ptr == &tclDoubleType) { i2 = (value2Ptr->internalRep.doubleValue != 0.0); - } else { /* FAILS IF NULL STRING REP */ - s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL); - if (TclLooksLikeInt(s)) { + } else { + s = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i); i2 = (i != 0); } else { result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); - i2 = (i2 != 0); } if (result != TCL_OK) { - TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", - opName[opCode], O2S(value2Ptr), + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", + O2S(value2Ptr), (t2Ptr? t2Ptr->name : "null"))); - IllegalExprOperandType(interp, opCode, value2Ptr); + IllegalExprOperandType(interp, pc, value2Ptr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -1843,19 +1733,18 @@ TclExecuteByteCode(interp, codePtr) * Reuse the valuePtr object already on stack if possible. */ - if (opCode == INST_LOR) { + if (*pc == INST_LOR) { iResult = (i1 || i2); } else { iResult = (i1 && i2); } if (Tcl_IsShared(valuePtr)) { PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%s %.20s %.20s => %d\n", opName[opCode], + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ - TRACE(("%s %.20s %.20s => %d\n", - opName[opCode], /* NB: stack top is off by 1 */ + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); Tcl_SetLongObj(valuePtr, iResult); ++stackTop; /* valuePtr now on stk top has right r.c. */ @@ -1891,7 +1780,7 @@ TclExecuteByteCode(interp, codePtr) if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) { s1 = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s1)) { /* FAILS IF NULLS */ + if (TclLooksLikeInt(s1, length)) { (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -1902,7 +1791,7 @@ TclExecuteByteCode(interp, codePtr) } if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) { s2 = Tcl_GetStringFromObj(value2Ptr, &length); - if (TclLooksLikeInt(s2)) { /* FAILS IF NULLS */ + if (TclLooksLikeInt(s2, length)) { (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); } else { @@ -1916,13 +1805,12 @@ TclExecuteByteCode(interp, codePtr) || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) { /* * One operand is not numeric. Compare as strings. - * THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS. */ int cmpValue; - s1 = TclGetStringFromObj(valuePtr, &length); - s2 = TclGetStringFromObj(value2Ptr, &length); + s1 = Tcl_GetString(valuePtr); + s2 = Tcl_GetString(value2Ptr); cmpValue = strcmp(s1, s2); - switch (opCode) { + switch (*pc) { case INST_EQ: iResult = (cmpValue == 0); break; @@ -1958,7 +1846,7 @@ TclExecuteByteCode(interp, codePtr) d1 = valuePtr->internalRep.longValue; d2 = value2Ptr->internalRep.doubleValue; } - switch (opCode) { + switch (*pc) { case INST_EQ: iResult = d1 == d2; break; @@ -1984,7 +1872,7 @@ TclExecuteByteCode(interp, codePtr) */ i = valuePtr->internalRep.longValue; i2 = value2Ptr->internalRep.longValue; - switch (opCode) { + switch (*pc) { case INST_EQ: iResult = i == i2; break; @@ -2012,13 +1900,12 @@ TclExecuteByteCode(interp, codePtr) if (Tcl_IsShared(valuePtr)) { PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%s %.20s %.20s => %ld\n", opName[opCode], - O2S(valuePtr), O2S(value2Ptr), iResult)); + TRACE(("%.20s %.20s => %ld\n", + O2S(valuePtr), O2S(value2Ptr), iResult)); TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ - TRACE(("%s %.20s %.20s => %ld\n", - opName[opCode], /* NB: stack top is off by 1 */ - O2S(valuePtr), O2S(value2Ptr), iResult)); + TRACE(("%.20s %.20s => %ld\n", + O2S(valuePtr), O2S(value2Ptr), iResult)); Tcl_SetLongObj(valuePtr, iResult); ++stackTop; /* valuePtr now on stk top has right r.c. */ } @@ -2048,11 +1935,11 @@ TclExecuteByteCode(interp, codePtr) result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); if (result != TCL_OK) { - TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n", - opName[opCode], O2S(valuePtr), O2S(value2Ptr), + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", + O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + IllegalExprOperandType(interp, pc, valuePtr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -2064,18 +1951,18 @@ TclExecuteByteCode(interp, codePtr) result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); if (result != TCL_OK) { - TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n", - opName[opCode], O2S(valuePtr), O2S(value2Ptr), + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, opCode, value2Ptr); + IllegalExprOperandType(interp, pc, value2Ptr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; } } - switch (opCode) { + switch (*pc) { case INST_MOD: /* * This code is tricky: C doesn't guarantee much about @@ -2084,7 +1971,7 @@ TclExecuteByteCode(interp, codePtr) * a smaller absolute value. */ if (i2 == 0) { - TRACE(("mod %ld %ld => DIVIDE BY ZERO\n", i, i2)); + TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto divideByZero; @@ -2136,12 +2023,10 @@ TclExecuteByteCode(interp, codePtr) if (Tcl_IsShared(valuePtr)) { PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2, - iResult)); + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ - TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2, - iResult)); /* NB: stack top is off by 1 */ + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); Tcl_SetLongObj(valuePtr, iResult); ++stackTop; /* valuePtr now on stk top has right r.c. */ } @@ -2173,11 +2058,18 @@ TclExecuteByteCode(interp, codePtr) if (t1Ptr == &tclIntType) { i = valuePtr->internalRep.longValue; - } else if (t1Ptr == &tclDoubleType) { + } else if ((t1Ptr == &tclDoubleType) + && (valuePtr->bytes == NULL)) { + /* + * We can only use the internal rep directly if there is + * no string rep. Otherwise the string rep might actually + * look like an integer, which is preferred. + */ + d1 = valuePtr->internalRep.doubleValue; - } else { /* try to convert; FAILS IF NULLS */ + } else { char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -2185,11 +2077,11 @@ TclExecuteByteCode(interp, codePtr) valuePtr, &d1); } if (result != TCL_OK) { - TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n", - opName[opCode], s, O2S(value2Ptr), + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", + s, O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + IllegalExprOperandType(interp, pc, valuePtr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -2199,11 +2091,18 @@ TclExecuteByteCode(interp, codePtr) if (t2Ptr == &tclIntType) { i2 = value2Ptr->internalRep.longValue; - } else if (t2Ptr == &tclDoubleType) { + } else if ((t2Ptr == &tclDoubleType) + && (value2Ptr->bytes == NULL)) { + /* + * We can only use the internal rep directly if there is + * no string rep. Otherwise the string rep might actually + * look like an integer, which is preferred. + */ + d2 = value2Ptr->internalRep.doubleValue; - } else { /* try to convert; FAILS IF NULLS */ + } else { char *s = Tcl_GetStringFromObj(value2Ptr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); } else { @@ -2211,11 +2110,11 @@ TclExecuteByteCode(interp, codePtr) value2Ptr, &d2); } if (result != TCL_OK) { - TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n", - opName[opCode], O2S(valuePtr), s, + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(value2Ptr), s, (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, opCode, value2Ptr); + IllegalExprOperandType(interp, pc, value2Ptr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -2233,7 +2132,7 @@ TclExecuteByteCode(interp, codePtr) } else if (t2Ptr == &tclIntType) { d2 = i2; /* promote value 2 to double */ } - switch (opCode) { + switch (*pc) { case INST_ADD: dResult = d1 + d2; break; @@ -2245,8 +2144,7 @@ TclExecuteByteCode(interp, codePtr) break; case INST_DIV: if (d2 == 0.0) { - TRACE(("div %.6g %.6g => DIVIDE BY ZERO\n", - d1, d2)); + TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto divideByZero; @@ -2260,8 +2158,8 @@ TclExecuteByteCode(interp, codePtr) */ if (IS_NAN(dResult) || IS_INF(dResult)) { - TRACE(("%s %.20s %.20s => IEEE FLOATING PT ERROR\n", - opName[opCode], O2S(valuePtr), O2S(value2Ptr))); + TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", + O2S(valuePtr), O2S(value2Ptr))); TclExprFloatError(interp, dResult); result = TCL_ERROR; Tcl_DecrRefCount(valuePtr); @@ -2272,7 +2170,7 @@ TclExecuteByteCode(interp, codePtr) /* * Do integer arithmetic. */ - switch (opCode) { + switch (*pc) { case INST_ADD: iResult = i + i2; break; @@ -2290,8 +2188,7 @@ TclExecuteByteCode(interp, codePtr) * divisor and a smaller absolute value. */ if (i2 == 0) { - TRACE(("div %ld %ld => DIVIDE BY ZERO\n", - i, i2)); + TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto divideByZero; @@ -2317,22 +2214,18 @@ TclExecuteByteCode(interp, codePtr) if (Tcl_IsShared(valuePtr)) { if (doDouble) { PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); - TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode], - d1, d2, dResult)); + TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); } else { PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%s %ld %ld => %ld\n", opName[opCode], - i, i2, iResult)); + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); } TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ if (doDouble) { /* NB: stack top is off by 1 */ - TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode], - d1, d2, dResult)); + TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); Tcl_SetDoubleObj(valuePtr, dResult); } else { - TRACE(("%s %ld %ld => %ld\n", opName[opCode], - i, i2, iResult)); + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); Tcl_SetLongObj(valuePtr, iResult); } ++stackTop; /* valuePtr now on stk top has right r.c. */ @@ -2350,11 +2243,12 @@ TclExecuteByteCode(interp, codePtr) double d; Tcl_ObjType *tPtr; - valuePtr = stackPtr[stackTop].o; + valuePtr = stackPtr[stackTop]; tPtr = valuePtr->typePtr; - if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); - if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -2362,14 +2256,39 @@ TclExecuteByteCode(interp, codePtr) valuePtr, &d); } if (result != TCL_OK) { - TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", - opName[opCode], s, - (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", + s, (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } + tPtr = valuePtr->typePtr; + } + + /* + * Ensure that the operand's string rep is the same as the + * formatted version of its internal rep. This makes sure + * that "expr +000123" yields "83", not "000123". We + * implement this by _discarding_ the string rep since we + * know it will be regenerated, if needed later, by + * formatting the internal rep's value. + */ + + if (Tcl_IsShared(valuePtr)) { + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + objPtr = Tcl_NewLongObj(i); + } else { + d = valuePtr->internalRep.doubleValue; + objPtr = Tcl_NewDoubleObj(d); + } + Tcl_IncrRefCount(objPtr); + Tcl_DecrRefCount(valuePtr); + valuePtr = objPtr; + stackPtr[stackTop] = valuePtr; + } else { + Tcl_InvalidateStringRep(valuePtr); } - TRACE_WITH_OBJ(("uplus %s => ", O2S(valuePtr)), valuePtr); + TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr); } ADJUST_PC(1); @@ -2388,9 +2307,10 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); tPtr = valuePtr->typePtr; - if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); - if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -2398,10 +2318,9 @@ TclExecuteByteCode(interp, codePtr) valuePtr, &d); } if (result != TCL_OK) { - TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s\n", - opName[opCode], s, - (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", + s, (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); Tcl_DecrRefCount(valuePtr); goto checkForCatch; } @@ -2415,12 +2334,11 @@ TclExecuteByteCode(interp, codePtr) if (tPtr == &tclIntType) { i = valuePtr->internalRep.longValue; objPtr = Tcl_NewLongObj( - (opCode == INST_UMINUS)? -i : !i); - TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i), - objPtr); /* NB: stack top is off by 1 */ + (*pc == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%ld => ", i), objPtr); } else { d = valuePtr->internalRep.doubleValue; - if (opCode == INST_UMINUS) { + if (*pc == INST_UMINUS) { objPtr = Tcl_NewDoubleObj(-d); } else { /* @@ -2429,8 +2347,7 @@ TclExecuteByteCode(interp, codePtr) */ objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); } - TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d), - objPtr); /* NB: stack top is off by 1 */ + TRACE_WITH_OBJ(("%.6g => ", d), objPtr); } PUSH_OBJECT(objPtr); TclDecrRefCount(valuePtr); @@ -2441,12 +2358,11 @@ TclExecuteByteCode(interp, codePtr) if (tPtr == &tclIntType) { i = valuePtr->internalRep.longValue; Tcl_SetLongObj(valuePtr, - (opCode == INST_UMINUS)? -i : !i); - TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i), - valuePtr); /* NB: stack top is off by 1 */ + (*pc == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%ld => ", i), valuePtr); } else { d = valuePtr->internalRep.doubleValue; - if (opCode == INST_UMINUS) { + if (*pc == INST_UMINUS) { Tcl_SetDoubleObj(valuePtr, -d); } else { /* @@ -2455,8 +2371,7 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0); } - TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d), - valuePtr); /* NB: stack top is off by 1 */ + TRACE_WITH_OBJ(("%.6g => ", d), valuePtr); } ++stackTop; /* valuePtr now on stk top has right r.c. */ } @@ -2480,9 +2395,9 @@ TclExecuteByteCode(interp, codePtr) result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); if (result != TCL_OK) { /* try to convert to double */ - TRACE(("bitnot \"%.20s\" => ILLEGAL TYPE %s\n", + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + IllegalExprOperandType(interp, pc, valuePtr); Tcl_DecrRefCount(valuePtr); goto checkForCatch; } @@ -2491,7 +2406,7 @@ TclExecuteByteCode(interp, codePtr) i = valuePtr->internalRep.longValue; if (Tcl_IsShared(valuePtr)) { PUSH_OBJECT(Tcl_NewLongObj(~i)); - TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i)); + TRACE(("0x%lx => (%lu)\n", i, ~i)); TclDecrRefCount(valuePtr); } else { /* @@ -2499,7 +2414,7 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_SetLongObj(valuePtr, ~i); ++stackTop; /* valuePtr now on stk top has right r.c. */ - TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i)); + TRACE(("0x%lx => (%lu)\n", i, ~i)); } } ADJUST_PC(1); @@ -2512,6 +2427,7 @@ TclExecuteByteCode(interp, codePtr) */ BuiltinFunc *mathFuncPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); @@ -2519,16 +2435,15 @@ TclExecuteByteCode(interp, codePtr) } mathFuncPtr = &(builtinFuncTable[opnd]); DECACHE_STACK_INFO(); - tcl_MathInProgress++; + tsdPtr->mathInProgress++; result = (*mathFuncPtr->proc)(interp, eePtr, mathFuncPtr->clientData); - tcl_MathInProgress--; + tsdPtr->mathInProgress--; CACHE_STACK_INFO(); if (result != TCL_OK) { goto checkForCatch; } - TRACE_WITH_OBJ(("callBuiltinFunc1 %d => ", opnd), - stackPtr[stackTop].o); + TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]); } ADJUST_PC(2); @@ -2544,18 +2459,18 @@ TclExecuteByteCode(interp, codePtr) * is the 0-th argument. */ Tcl_Obj **objv; /* The array of arguments. The function * name is objv[0]. */ - - objv = &(stackPtr[stackTop - (objc-1)].o); /* "objv[0]" */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */ DECACHE_STACK_INFO(); - tcl_MathInProgress++; + tsdPtr->mathInProgress++; result = ExprCallMathFunc(interp, eePtr, objc, objv); - tcl_MathInProgress--; + tsdPtr->mathInProgress--; CACHE_STACK_INFO(); if (result != TCL_OK) { goto checkForCatch; } - TRACE_WITH_OBJ(("callFunc1 %d => ", objc), - stackPtr[stackTop].o); + TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]); ADJUST_PC(2); } @@ -2573,12 +2488,13 @@ TclExecuteByteCode(interp, codePtr) Tcl_ObjType *tPtr; int converted, shared; - valuePtr = stackPtr[stackTop].o; + valuePtr = stackPtr[stackTop]; tPtr = valuePtr->typePtr; converted = 0; - if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { - s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); - if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -2617,31 +2533,29 @@ TclExecuteByteCode(interp, codePtr) Tcl_IncrRefCount(objPtr); TclDecrRefCount(valuePtr); valuePtr = objPtr; + stackPtr[stackTop] = valuePtr; tPtr = valuePtr->typePtr; } else { Tcl_InvalidateStringRep(valuePtr); } - stackPtr[stackTop].o = valuePtr; if (tPtr == &tclDoubleType) { d = valuePtr->internalRep.doubleValue; if (IS_NAN(d) || IS_INF(d)) { - TRACE(("tryCvtToNumeric \"%.20s\" => IEEE FLOATING PT ERROR\n", + TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", O2S(valuePtr))); TclExprFloatError(interp, d); result = TCL_ERROR; goto checkForCatch; } } - shared = shared; /* lint, shared not used. */ - converted = converted; /* lint, converted not used. */ - TRACE(("tryCvtToNumeric \"%.20s\" => numeric, %s, %s\n", - O2S(valuePtr), + shared = shared; /* lint, shared not used. */ + converted = converted; /* lint, converted not used. */ + TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr), (converted? "converted" : "not converted"), (shared? "shared" : "not shared"))); } else { - TRACE(("tryCvtToNumeric \"%.20s\" => not numeric\n", - O2S(valuePtr))); + TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); } } ADJUST_PC(1); @@ -2656,22 +2570,21 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_ResetResult(interp); - rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, - codePtr); + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); if (rangePtr == NULL) { - TRACE(("break => no encl. loop or catch, returning TCL_BREAK\n")); + TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n")); result = TCL_BREAK; goto abnormalReturn; /* no catch exists to check */ } switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: result = TCL_OK; - TRACE(("break => range at %d, new pc %d\n", + TRACE(("=> range at %d, new pc %d\n", rangePtr->codeOffset, rangePtr->breakOffset)); break; case CATCH_EXCEPTION_RANGE: result = TCL_BREAK; - TRACE(("break => ...\n")); + TRACE(("=> ...\n")); goto processCatch; /* it will use rangePtr */ default: panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); @@ -2689,27 +2602,26 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_ResetResult(interp); - rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, - codePtr); + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); if (rangePtr == NULL) { - TRACE(("continue => no encl. loop or catch, returning TCL_CONTINUE\n")); + TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n")); result = TCL_CONTINUE; goto abnormalReturn; } switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: if (rangePtr->continueOffset == -1) { - TRACE(("continue => loop w/o continue, checking for catch\n")); + TRACE(("=> loop w/o continue, checking for catch\n")); goto checkForCatch; } else { result = TCL_OK; - TRACE(("continue => range at %d, new pc %d\n", + TRACE(("=> range at %d, new pc %d\n", rangePtr->codeOffset, rangePtr->continueOffset)); } break; case CATCH_EXCEPTION_RANGE: result = TCL_CONTINUE; - TRACE(("continue => ...\n")); + TRACE(("=> ...\n")); goto processCatch; /* it will use rangePtr */ default: panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); @@ -2727,14 +2639,11 @@ TclExecuteByteCode(interp, codePtr) ForeachInfo *infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - int iterTmpIndex = infoPtr->loopIterNumTmp; - CallFrame *varFramePtr = iPtr->varFramePtr; - Var *compiledLocals = varFramePtr->compiledLocals; - Var *iterVarPtr; - Tcl_Obj *oldValuePtr; - - iterVarPtr = &(compiledLocals[iterTmpIndex]); - oldValuePtr = iterVarPtr->value.objPtr; + int iterTmpIndex = infoPtr->loopCtTemp; + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Var *iterVarPtr = &(compiledLocals[iterTmpIndex]); + Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr; + if (oldValuePtr == NULL) { iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); @@ -2743,7 +2652,7 @@ TclExecuteByteCode(interp, codePtr) } TclSetVarScalar(iterVarPtr); TclClearVarUndefined(iterVarPtr); - TRACE(("foreach_start4 %u => loop iter count temp %d\n", + TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); } ADJUST_PC(5); @@ -2757,43 +2666,41 @@ TclExecuteByteCode(interp, codePtr) */ ForeachInfo *infoPtr = (ForeachInfo *) - codePtr->auxDataArrayPtr[opnd].clientData; + codePtr->auxDataArrayPtr[opnd].clientData; ForeachVarList *varListPtr; int numLists = infoPtr->numLists; - int iterTmpIndex = infoPtr->loopIterNumTmp; - CallFrame *varFramePtr = iPtr->varFramePtr; - Var *compiledLocals = varFramePtr->compiledLocals; - int iterNum, listTmpIndex, listLen, numVars; - int varIndex, valIndex, j; - Tcl_Obj *listPtr, *elemPtr, *oldValuePtr; + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Tcl_Obj *listPtr; List *listRepPtr; Var *iterVarPtr, *listVarPtr; - int continueLoop = 0; + int iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, continueLoop, j; /* * Increment the temp holding the loop iteration number. */ - iterVarPtr = &(compiledLocals[iterTmpIndex]); - oldValuePtr = iterVarPtr->value.objPtr; - iterNum = (oldValuePtr->internalRep.longValue + 1); - Tcl_SetLongObj(oldValuePtr, iterNum); + iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); + valuePtr = iterVarPtr->value.objPtr; + iterNum = (valuePtr->internalRep.longValue + 1); + Tcl_SetLongObj(valuePtr, iterNum); /* * Check whether all value lists are exhausted and we should * stop the loop. */ - listTmpIndex = infoPtr->firstListTmp; + continueLoop = 0; + listTmpIndex = infoPtr->firstValueTemp; for (i = 0; i < numLists; i++) { varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; - + listVarPtr = &(compiledLocals[listTmpIndex]); listPtr = listVarPtr->value.objPtr; result = Tcl_ListObjLength(interp, listPtr, &listLen); if (result != TCL_OK) { - TRACE_WITH_OBJ(("foreach_step4 %u => ERROR converting list %ld, \"%s\": ", + TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); goto checkForCatch; @@ -2812,15 +2719,14 @@ TclExecuteByteCode(interp, codePtr) */ if (continueLoop) { - listTmpIndex = infoPtr->firstListTmp; + listTmpIndex = infoPtr->firstValueTemp; for (i = 0; i < numLists; i++) { varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; listVarPtr = &(compiledLocals[listTmpIndex]); listPtr = listVarPtr->value.objPtr; - listRepPtr = (List *) - listPtr->internalRep.otherValuePtr; + listRepPtr = (List *) listPtr->internalRep.otherValuePtr; listLen = listRepPtr->elemCount; valIndex = (iterNum * numVars); @@ -2828,22 +2734,22 @@ TclExecuteByteCode(interp, codePtr) int setEmptyStr = 0; if (valIndex >= listLen) { setEmptyStr = 1; - elemPtr = Tcl_NewObj(); + valuePtr = Tcl_NewObj(); } else { - elemPtr = listRepPtr->elements[valIndex]; + valuePtr = listRepPtr->elements[valIndex]; } varIndex = varListPtr->varIndexes[j]; DECACHE_STACK_INFO(); value2Ptr = TclSetIndexedScalar(interp, - varIndex, elemPtr, /*leaveErrorMsg*/ 1); + varIndex, valuePtr, /*leaveErrorMsg*/ 1); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("foreach_step4 %u => ERROR init. index temp %d: ", + TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", opnd, varIndex), Tcl_GetObjResult(interp)); if (setEmptyStr) { - Tcl_DecrRefCount(elemPtr); /* unneeded */ + Tcl_DecrRefCount(valuePtr); } result = TCL_ERROR; goto checkForCatch; @@ -2855,13 +2761,12 @@ TclExecuteByteCode(interp, codePtr) } /* - * Now push a "1" object if at least one value list had a - * remaining element and the loop should continue. - * Otherwise push "0". + * Push 1 if at least one value list had a remaining element + * and the loop should continue. Otherwise push 0. */ PUSH_OBJECT(Tcl_NewLongObj(continueLoop)); - TRACE(("foreach_step4 %u => %d lists, iter %d, %s loop\n", + TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, iterNum, (continueLoop? "continue" : "exit"))); } @@ -2874,29 +2779,28 @@ TclExecuteByteCode(interp, codePtr) * special catch stack. */ catchStackPtr[++catchTop] = stackTop; - TRACE(("beginCatch4 %u => catchTop=%d, stackTop=%d\n", + TRACE(("%u => catchTop=%d, stackTop=%d\n", TclGetUInt4AtPtr(pc+1), catchTop, stackTop)); ADJUST_PC(5); case INST_END_CATCH: catchTop--; result = TCL_OK; - TRACE(("endCatch => catchTop=%d\n", catchTop)); + TRACE(("=> catchTop=%d\n", catchTop)); ADJUST_PC(1); case INST_PUSH_RESULT: PUSH_OBJECT(Tcl_GetObjResult(interp)); - TRACE_WITH_OBJ(("pushResult => "), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp)); ADJUST_PC(1); case INST_PUSH_RETURN_CODE: PUSH_OBJECT(Tcl_NewLongObj(result)); - TRACE(("pushReturnCode => %u\n", result)); + TRACE(("=> %u\n", result)); ADJUST_PC(1); default: - TRACE(("UNRECOGNIZED INSTRUCTION %u\n", opCode)); - panic("TclExecuteByteCode: unrecognized opCode %u", opCode); + panic("TclExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ /* @@ -2921,12 +2825,20 @@ TclExecuteByteCode(interp, codePtr) checkForCatch: if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - RecordTracebackInfo(interp, pc, codePtr); + bytes = GetSrcInfoForPc(pc, codePtr, &length); + if (bytes != NULL) { + Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); + iPtr->flags |= ERR_ALREADY_LOGGED; + } } - rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr); + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); if (rangePtr == NULL) { - TRACE((" ... no enclosing catch, returning %s\n", - StringForResultCode(result))); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... no enclosing catch, returning %s\n", + StringForResultCode(result)); + } +#endif goto abnormalReturn; } @@ -2944,9 +2856,13 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } - TRACE((" ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", rangePtr->codeOffset, catchTop, catchStackPtr[catchTop], - (unsigned int)(rangePtr->catchOffset))); + (unsigned int)(rangePtr->catchOffset)); + } +#endif pc = (codePtr->codeStart + rangePtr->catchOffset); continue; /* restart the execution loop at pc */ } /* end of infinite loop dispatching on instructions */ @@ -2975,6 +2891,7 @@ TclExecuteByteCode(interp, codePtr) #undef STATIC_CATCH_STACK_SIZE } +#ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * @@ -2999,45 +2916,44 @@ PrintByteCodeInfo(codePtr) * to stdout. */ { Proc *procPtr = codePtr->procPtr; - int numCmds = codePtr->numCommands; - int numObjs = codePtr->numObjects; - int objBytes, i; - - objBytes = (numObjs * sizeof(Tcl_Obj)); - for (i = 0; i < numObjs; i++) { - Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i]; - if (litObjPtr->bytes != NULL) { - objBytes += litObjPtr->length; - } - } - - fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n", + Interp *iPtr = (Interp *) *codePtr->interpHandle; + + fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", (unsigned int) codePtr, codePtr->refCount, - codePtr->compileEpoch, (unsigned int) codePtr->iPtr, - codePtr->iPtr->compileEpoch); + codePtr->compileEpoch, (unsigned int) iPtr, + iPtr->compileEpoch); fprintf(stdout, " Source: "); - TclPrintSource(stdout, codePtr->source, 70); + TclPrintSource(stdout, codePtr->source, 60); - fprintf(stdout, "\n Cmds %d, chars %d, inst %u, objs %u, aux %d, stk depth %u, code/src %.2fn", - numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs, + fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + codePtr->numCommands, codePtr->numSrcBytes, + codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, - (codePtr->numSrcChars? - ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0)); - - fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n", - codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes, - objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)), +#ifdef TCL_COMPILE_STATS + (codePtr->numSrcBytes? + ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); +#else + 0.0); +#endif +#ifdef TCL_COMPILE_STATS + fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", + codePtr->structureSize, + (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), + codePtr->numCodeBytes, + (codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (codePtr->numExceptRanges * sizeof(ExceptionRange)), (codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); - +#endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, - " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n", + " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, procPtr->numCompiledLocals); } } +#endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- @@ -3060,7 +2976,8 @@ PrintByteCodeInfo(codePtr) #ifdef TCL_COMPILE_DEBUG static void -ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound) +ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, + stackUpperBound) register ByteCode *codePtr; /* The bytecode whose summary is printed * to stdout. */ unsigned char *pc; /* Points to first byte of a bytecode @@ -3116,8 +3033,7 @@ ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound) * * Used by TclExecuteByteCode to add an error message to errorInfo * when an illegal operand type is detected by an expression - * instruction. The argument opCode holds the failing instruction's - * opcode and opndPtr holds the operand object in error. + * instruction. The argument opndPtr holds the operand object in error. * * Results: * None. @@ -3129,23 +3045,39 @@ ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound) */ static void -IllegalExprOperandType(interp, opCode, opndPtr) +IllegalExprOperandType(interp, pc, opndPtr) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ - unsigned int opCode; /* The instruction opcode being executed + unsigned char *pc; /* Points to the instruction being executed * when the illegal type was found. */ Tcl_Obj *opndPtr; /* Points to the operand holding the value * with the illegal type. */ { + unsigned char opCode = *pc; + int isDouble; + Tcl_ResetResult(interp); if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use empty string as operand of \"", operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); } else { + isDouble = 1; + if (opndPtr->typePtr != &tclDoubleType) { + /* + * See if the operand can be interpreted as a double in order to + * improve the error message. + */ + + char *s = Tcl_GetString(opndPtr); + double d; + + if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) != TCL_OK) { + isDouble = 0; + } + } Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", - ((opndPtr->typePtr == &tclDoubleType) ? - "floating-point value" : "non-numeric string"), + (isDouble? "floating-point value" : "non-numeric string"), " as operand of \"", operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); } @@ -3192,7 +3124,6 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) * Get the string rep from the objv argument objects and place their * pointers in argv. First make sure argv is large enough to hold the * objc args plus 1 extra word for the zero end-of-argv word. - * THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS. */ argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); @@ -3223,76 +3154,6 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) /* *---------------------------------------------------------------------- * - * RecordTracebackInfo -- - * - * Procedure called by TclExecuteByteCode to record information - * about what was being executed when the error occurred. - * - * Results: - * None. - * - * Side effects: - * Appends information about the command being executed to the - * "errorInfo" variable. Sets the errorLine field in the interpreter - * to the line number of that command. Sets the ERR_ALREADY_LOGGED - * bit in the interpreter's execution flags. - * - *---------------------------------------------------------------------- - */ - -static void -RecordTracebackInfo(interp, pc, codePtr) - Tcl_Interp *interp; /* The interpreter in which the error - * occurred. */ - unsigned char *pc; /* The program counter value where the error * occurred. This points to a bytecode - * instruction in codePtr's code. */ - ByteCode *codePtr; /* The bytecode sequence being executed. */ -{ - register Interp *iPtr = (Interp *) interp; - char *cmd, *ellipsis; - char buf[200]; - register char *p; - int numChars; - - /* - * Record the command in errorInfo (up to a certain number of - * characters, or up to the first newline). - */ - - iPtr->errorLine = 1; - cmd = GetSrcInfoForPc(pc, codePtr, &numChars); - if (cmd != NULL) { - for (p = codePtr->source; p != cmd; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - for ( ; (isspace(UCHAR(*p)) || (*p == ';')); p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - ellipsis = ""; - if (numChars > 150) { - numChars = 150; - ellipsis = "..."; - } - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - sprintf(buf, "\n while executing\n\"%.*s%s\"", - numChars, cmd, ellipsis); - } else { - sprintf(buf, "\n invoked from within\n\"%.*s%s\"", - numChars, cmd, ellipsis); - } - Tcl_AddObjErrorInfo(interp, buf, -1); - iPtr->flags |= ERR_ALREADY_LOGGED; - } -} - -/* - *---------------------------------------------------------------------- - * * GetSrcInfoForPc -- * * Given a program counter value, finds the closest command in the @@ -3415,10 +3276,10 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr) /* *---------------------------------------------------------------------- * - * TclGetExceptionRangeForPc -- + * GetExceptRangeForPc -- * - * Procedure that given a program counter value, returns the closest - * enclosing ExceptionRange that matches the kind requested. + * Given a program counter value, return the closest enclosing + * ExceptionRange. * * Results: * In the normal case, catchOnly is 0 (false) and this procedure @@ -3426,7 +3287,7 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr) * structure regardless of whether it is a loop or catch exception * range. This is appropriate when processing a TCL_BREAK or * TCL_CONTINUE, which will be "handled" either by a loop exception - * range or a closer catch range. If catchOnly is nonzero (true), this + * range or a closer catch range. If catchOnly is nonzero, this * procedure ignores loop exception ranges and returns a pointer to the * closest catch range. If no matching ExceptionRange is found that * encloses pc, a NULL is returned. @@ -3437,37 +3298,37 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr) *---------------------------------------------------------------------- */ -ExceptionRange * -TclGetExceptionRangeForPc(pc, catchOnly, codePtr) +static ExceptionRange * +GetExceptRangeForPc(pc, catchOnly, codePtr) unsigned char *pc; /* The program counter value for which to * search for a closest enclosing exception * range. This points to a bytecode * instruction in codePtr's code. */ int catchOnly; /* If 0, consider either loop or catch - * ExceptionRanges in search. Otherwise + * ExceptionRanges in search. If nonzero * consider only catch ranges (and ignore * any closer loop ranges). */ ByteCode* codePtr; /* Points to the ByteCode in which to search * for the enclosing ExceptionRange. */ { ExceptionRange *rangeArrayPtr; - int numRanges = codePtr->numExcRanges; + int numRanges = codePtr->numExceptRanges; register ExceptionRange *rangePtr; - int codeOffset = (pc - codePtr->codeStart); + int pcOffset = (pc - codePtr->codeStart); register int i, level; if (numRanges == 0) { return NULL; } - rangeArrayPtr = codePtr->excRangeArrayPtr; + rangeArrayPtr = codePtr->exceptArrayPtr; - for (level = codePtr->maxExcRangeDepth; level >= 0; level--) { + for (level = codePtr->maxExceptDepth; level >= 0; level--) { for (i = 0; i < numRanges; i++) { rangePtr = &(rangeArrayPtr[i]); if (rangePtr->nestingLevel == level) { int start = rangePtr->codeOffset; int end = (start + rangePtr->numCodeBytes); - if ((start <= codeOffset) && (codeOffset < end)) { + if ((start <= pcOffset) && (pcOffset < end)) { if ((!catchOnly) || (rangePtr->type == CATCH_EXCEPTION_RANGE)) { return rangePtr; @@ -3482,6 +3343,36 @@ TclGetExceptionRangeForPc(pc, catchOnly, codePtr) /* *---------------------------------------------------------------------- * + * GetOpcodeName -- + * + * This procedure is called by the TRACE and TRACE_WITH_OBJ macros + * used in TclExecuteByteCode when debugging. It returns the name of + * the bytecode instruction at a specified instruction pc. + * + * Results: + * A character string for the instruction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_COMPILE_DEBUG +static char * +GetOpcodeName(pc) + unsigned char *pc; /* Points to the instruction whose name + * should be returned. */ +{ + unsigned char opCode = *pc; + + return instructionTable[opCode].name; +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * * Math Functions -- * * This page contains the procedures that implement all of the @@ -3508,13 +3399,13 @@ ExprUnaryFunc(interp, eePtr, clientData) * takes one double argument and returns a * double result. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; Tcl_ObjType *tPtr; double d, dResult; long i; - int result = TCL_OK; + int length, result; double (*func) _ANSI_ARGS_((double)) = (double (*)_ANSI_ARGS_((double))) clientData; @@ -3522,7 +3413,8 @@ ExprUnaryFunc(interp, eePtr, clientData) /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3537,10 +3429,10 @@ ExprUnaryFunc(interp, eePtr, clientData) d = (double) valuePtr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); d = (double) valuePtr->internalRep.longValue; } else { @@ -3588,14 +3480,14 @@ ExprBinaryFunc(interp, eePtr, clientData) * takes two double arguments and * returns a double result. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr, *value2Ptr; Tcl_ObjType *tPtr; double d1, d2, dResult; long i; char *s; - int result = TCL_OK; + int length, result; double (*func) _ANSI_ARGS_((double, double)) = (double (*)_ANSI_ARGS_((double, double))) clientData; @@ -3603,7 +3495,8 @@ ExprBinaryFunc(interp, eePtr, clientData) /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3619,9 +3512,9 @@ ExprBinaryFunc(interp, eePtr, clientData) d1 = (double) valuePtr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d1 = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); - if (TclLooksLikeInt(s)) { + } else { + s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); d1 = (double) valuePtr->internalRep.longValue; } else { @@ -3641,9 +3534,9 @@ ExprBinaryFunc(interp, eePtr, clientData) d2 = value2Ptr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d2 = value2Ptr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL); - if (TclLooksLikeInt(s)) { + } else { + s = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i); d2 = (double) value2Ptr->internalRep.longValue; } else { @@ -3687,18 +3580,19 @@ ExprAbsFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; Tcl_ObjType *tPtr; long i, iResult; double d, dResult; - int result = TCL_OK; + int length, result; /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3712,10 +3606,10 @@ ExprAbsFunc(interp, eePtr, clientData) i = valuePtr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); @@ -3781,17 +3675,18 @@ ExprDoubleFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; double dResult; long i; - int result = TCL_OK; + int length, result; /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3803,10 +3698,10 @@ ExprDoubleFunc(interp, eePtr, clientData) dResult = (double) valuePtr->internalRep.longValue; } else if (valuePtr->typePtr == &tclDoubleType) { dResult = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); dResult = (double) valuePtr->internalRep.longValue; } else { @@ -3845,19 +3740,20 @@ ExprIntFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; Tcl_ObjType *tPtr; long i = 0; /* Initialized to avoid compiler warning. */ long iResult; double d; - int result = TCL_OK; + int length, result; /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3871,10 +3767,10 @@ ExprIntFunc(interp, eePtr, clientData) i = valuePtr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); @@ -3938,7 +3834,7 @@ ExprRandFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ Interp *iPtr = (Interp *) interp; double dResult; @@ -4026,19 +3922,20 @@ ExprRoundFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ Tcl_Obj *valuePtr; Tcl_ObjType *tPtr; long i = 0; /* Initialized to avoid compiler warning. */ long iResult; double d, temp; - int result = TCL_OK; + int length, result; /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -4052,10 +3949,10 @@ ExprRoundFunc(interp, eePtr, clientData) i = valuePtr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); @@ -4122,13 +4019,13 @@ ExprSrandFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ Interp *iPtr = (Interp *) interp; Tcl_Obj *valuePtr; Tcl_ObjType *tPtr; long i = 0; /* Initialized to avoid compiler warning. */ - int result; + int isDouble, result; /* * Set stackPtr and stackTop from eePtr. @@ -4146,12 +4043,27 @@ ExprSrandFunc(interp, eePtr, clientData) if (tPtr == &tclIntType) { i = valuePtr->internalRep.longValue; - } else { /* FAILS IF STRING REP HAS NULLS */ + } else { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); if (result != TCL_OK) { + /* + * See if the operand can be interpreted as a double in order to + * improve the error message. + */ + + isDouble = 1; + if (valuePtr->typePtr != &tclDoubleType) { + char *s = Tcl_GetString(valuePtr); + double d; + + if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) != TCL_OK) { + isDouble = 0; + } + } + Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", - ((tPtr == &tclDoubleType)? "floating-point value" : "non-numeric string"), + (isDouble? "floating-point value":"non-numeric string"), " as argument to srand", (char *) NULL); Tcl_DecrRefCount(valuePtr); DECACHE_STACK_INFO(); @@ -4212,7 +4124,7 @@ ExprCallMathFunc(interp, eePtr, objc, objv) * is objv[0]. */ { Interp *iPtr = (Interp *) interp; - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ char *funcName; Tcl_HashEntry *hPtr; @@ -4223,10 +4135,11 @@ ExprCallMathFunc(interp, eePtr, objc, objv) Tcl_ObjType *tPtr; long i; double d; - int j, k, result; - + int j, k, length, result; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_ResetResult(interp); - + /* * Set stackPtr and stackTop from eePtr. */ @@ -4235,10 +4148,9 @@ ExprCallMathFunc(interp, eePtr, objc, objv) /* * Look up the MathFunc record for the function. - * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS NULLS. */ - funcName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + funcName = Tcl_GetString(objv[0]); hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -4271,12 +4183,11 @@ ExprCallMathFunc(interp, eePtr, objc, objv) } else { /* * Try to convert to int first then double. - * FAILS IF STRING REP HAS NULLS. */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, @@ -4318,10 +4229,10 @@ ExprCallMathFunc(interp, eePtr, objc, objv) * Invoke the function and copy its result back into valuePtr. */ - tcl_MathInProgress++; + tsdPtr->mathInProgress++; result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, &funcResult); - tcl_MathInProgress--; + tsdPtr->mathInProgress--; if (result != TCL_OK) { goto done; } @@ -4332,7 +4243,7 @@ ExprCallMathFunc(interp, eePtr, objc, objv) i = (stackTop - (objc-1)); while (i <= stackTop) { - valuePtr = stackPtr[i].o; + valuePtr = stackPtr[i]; Tcl_DecrRefCount(valuePtr); i++; } @@ -4404,8 +4315,8 @@ TclExprFloatError(interp, value) Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); } - } else { /* FAILS IF STRING REP CONTAINS NULLS */ - char msg[100]; + } else { + char msg[64 + TCL_INTEGER_SPACE]; sprintf(msg, "unknown floating-point error, errno = %d", errno); Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1); @@ -4413,6 +4324,30 @@ TclExprFloatError(interp, value) } } +/* + *---------------------------------------------------------------------- + * + * TclMathInProgress -- + * + * This procedure is called to find out if Tcl is doing math + * in this thread. + * + * Results: + * 0 or 1. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMathInProgress() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + return tsdPtr->mathInProgress; +} + #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- @@ -4471,120 +4406,355 @@ EvalStatsCmd(unused, interp, argc, argv) int argc; /* The number of arguments. */ char **argv; /* The argument strings. */ { - register double total = 0.0; - register int i; - int maxSizeDecade = 0; - double totalHeaderBytes = (tclNumCompilations * sizeof(ByteCode)); - + Interp *iPtr = (Interp *) interp; + LiteralTable *globalTablePtr = &(iPtr->literalTable); + ByteCodeStats *statsPtr = &(iPtr->stats); + double totalCodeBytes, currentCodeBytes; + double totalLiteralBytes, currentLiteralBytes; + double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; + double strBytesSharedMultX, strBytesSharedOnce; + double numInstructions, currentHeaderBytes; + long numCurrentByteCodes, numByteCodeLits; + long refCountSum, literalMgmtBytes, sum; + int numSharedMultX, numSharedOnce; + int decadeHigh, minSizeDecade, maxSizeDecade, length, i; + char *litTableStats; + LiteralEntry *entryPtr; + + numInstructions = 0.0; for (i = 0; i < 256; i++) { - if (instructionCount[i] != 0) { - total += instructionCount[i]; + if (statsPtr->instructionCount[i] != 0) { + numInstructions += statsPtr->instructionCount[i]; } } - for (i = 31; i >= 0; i--) { - if ((tclSourceCount[i] > 0) && (tclByteCodeCount[i] > 0)) { - maxSizeDecade = i; - break; - } - } - - fprintf(stdout, "\nNumber of compilations %ld\n", - tclNumCompilations); - fprintf(stdout, "Number of executions %ld\n", - numExecutions); - fprintf(stdout, "Average executions/compilation %.0f\n", - ((float) numExecutions/tclNumCompilations)); - - fprintf(stdout, "\nInstructions executed %.0f\n", - total); - fprintf(stdout, "Average instructions/compile %.0f\n", - total/tclNumCompilations); - fprintf(stdout, "Average instructions/execution %.0f\n", - total/numExecutions); + totalLiteralBytes = sizeof(LiteralTable) + + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *) + + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)) + + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)) + + statsPtr->totalLitStringBytes; + totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes; + + numCurrentByteCodes = + statsPtr->numCompilations - statsPtr->numByteCodesFreed; + currentHeaderBytes = numCurrentByteCodes + * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))); + literalMgmtBytes = sizeof(LiteralTable) + + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) + + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); + currentLiteralBytes = literalMgmtBytes + + iPtr->literalTable.numEntries * sizeof(Tcl_Obj) + + statsPtr->currentLitStringBytes; + currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes; - fprintf(stdout, "\nTotal source bytes %.6g\n", - tclTotalSourceBytes); - fprintf(stdout, "Total code bytes %.6g\n", - tclTotalCodeBytes); - fprintf(stdout, "Average code/compilation %.0f\n", - tclTotalCodeBytes/tclNumCompilations); - fprintf(stdout, "Average code/source %.2f\n", - tclTotalCodeBytes/tclTotalSourceBytes); - fprintf(stdout, "Current source bytes %.6g\n", - tclCurrentSourceBytes); - fprintf(stdout, "Current code bytes %.6g\n", - tclCurrentCodeBytes); - fprintf(stdout, "Current code/source %.2f\n", - tclCurrentCodeBytes/tclCurrentSourceBytes); + /* + * Summary statistics, total and current source and ByteCode sizes. + */ + + fprintf(stdout, "\n----------------------------------------------------------------\n"); + fprintf(stdout, + "Compilation and execution statistics for interpreter 0x%x\n", + (unsigned int) iPtr); + + fprintf(stdout, "\nNumber ByteCodes executed %ld\n", + statsPtr->numExecutions); + fprintf(stdout, "Number ByteCodes compiled %ld\n", + statsPtr->numCompilations); + fprintf(stdout, " Mean executions/compile %.1f\n", + ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations)); - fprintf(stdout, "\nTotal objects allocated %ld\n", + fprintf(stdout, "\nInstructions executed %.0f\n", + numInstructions); + fprintf(stdout, " Mean inst/compile %.0f\n", + numInstructions / statsPtr->numCompilations); + fprintf(stdout, " Mean inst/execution %.0f\n", + numInstructions / statsPtr->numExecutions); + + fprintf(stdout, "\nTotal ByteCodes %ld\n", + statsPtr->numCompilations); + fprintf(stdout, " Source bytes %.6g\n", + statsPtr->totalSrcBytes); + fprintf(stdout, " Code bytes %.6g\n", + totalCodeBytes); + fprintf(stdout, " ByteCode bytes %.6g\n", + statsPtr->totalByteCodeBytes); + fprintf(stdout, " Literal bytes %.6g\n", + totalLiteralBytes); + fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n", + sizeof(LiteralTable), + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + statsPtr->numLiteralsCreated * sizeof(LiteralEntry), + statsPtr->numLiteralsCreated * sizeof(Tcl_Obj), + statsPtr->totalLitStringBytes); + fprintf(stdout, " Mean code/compile %.1f\n", + totalCodeBytes / statsPtr->numCompilations); + fprintf(stdout, " Mean code/source %.1f\n", + totalCodeBytes / statsPtr->totalSrcBytes); + + fprintf(stdout, "\nCurrent ByteCodes %ld\n", + numCurrentByteCodes); + fprintf(stdout, " Source bytes %.6g\n", + statsPtr->currentSrcBytes); + fprintf(stdout, " Code bytes %.6g\n", + currentCodeBytes); + fprintf(stdout, " ByteCode bytes %.6g\n", + statsPtr->currentByteCodeBytes); + fprintf(stdout, " Literal bytes %.6g\n", + currentLiteralBytes); + fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", + sizeof(LiteralTable), + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + iPtr->literalTable.numEntries * sizeof(LiteralEntry), + iPtr->literalTable.numEntries * sizeof(Tcl_Obj), + statsPtr->currentLitStringBytes); + fprintf(stdout, " Mean code/source %.1f\n", + currentCodeBytes / statsPtr->currentSrcBytes); + fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n", + (currentCodeBytes + statsPtr->currentSrcBytes), + (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); + + /* + * Literal table statistics. + */ + + numByteCodeLits = 0; + refCountSum = 0; + numSharedMultX = 0; + numSharedOnce = 0; + objBytesIfUnshared = 0.0; + strBytesIfUnshared = 0.0; + strBytesSharedMultX = 0.0; + strBytesSharedOnce = 0.0; + for (i = 0; i < globalTablePtr->numBuckets; i++) { + for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; + entryPtr = entryPtr->nextPtr) { + if (entryPtr->objPtr->typePtr == &tclByteCodeType) { + numByteCodeLits++; + } + (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); + refCountSum += entryPtr->refCount; + objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); + strBytesIfUnshared += (entryPtr->refCount * (length+1)); + if (entryPtr->refCount > 1) { + numSharedMultX++; + strBytesSharedMultX += (length+1); + } else { + numSharedOnce++; + strBytesSharedOnce += (length+1); + } + } + } + sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) + - currentLiteralBytes; + + fprintf(stdout, "\nTotal objects (all interps) %ld\n", tclObjsAlloced); - fprintf(stdout, "Total objects freed %ld\n", - tclObjsFreed); - fprintf(stdout, "Current objects: %ld\n", + fprintf(stdout, "Current objects %ld\n", (tclObjsAlloced - tclObjsFreed)); + fprintf(stdout, "Total literal objects %ld\n", + statsPtr->numLiteralsCreated); + + fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", + globalTablePtr->numEntries, + (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed)); + fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n", + numByteCodeLits, + (numByteCodeLits * 100.0) / globalTablePtr->numEntries); + fprintf(stdout, " Literals reused > 1x %d\n", + numSharedMultX); + fprintf(stdout, " Mean reference count %.2f\n", + ((double) refCountSum) / globalTablePtr->numEntries); + fprintf(stdout, " Mean len, str reused >1x %.2f\n", + (numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0)); + fprintf(stdout, " Mean len, str used 1x %.2f\n", + (numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0)); + fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n", + sharingBytesSaved, + (sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared)); + fprintf(stdout, " Bytes with sharing %.6g\n", + currentLiteralBytes); + fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", + sizeof(LiteralTable), + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + iPtr->literalTable.numEntries * sizeof(LiteralEntry), + iPtr->literalTable.numEntries * sizeof(Tcl_Obj), + statsPtr->currentLitStringBytes); + fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n", + (objBytesIfUnshared + strBytesIfUnshared), + objBytesIfUnshared, strBytesIfUnshared); + fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", + (strBytesIfUnshared - statsPtr->currentLitStringBytes), + strBytesIfUnshared, statsPtr->currentLitStringBytes); + fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n", + literalMgmtBytes, + (literalMgmtBytes * 100.0) / currentLiteralBytes); + fprintf(stdout, " table %d + buckets %d + entries %d\n", + sizeof(LiteralTable), + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + iPtr->literalTable.numEntries * sizeof(LiteralEntry)); - fprintf(stdout, "\nBreakdown of code byte requirements:\n"); - fprintf(stdout, " Total bytes Pct of Avg per\n"); - fprintf(stdout, " all code compile\n"); - fprintf(stdout, "Total code %12.6g 100%% %8.2f\n", - tclTotalCodeBytes, tclTotalCodeBytes/tclNumCompilations); - fprintf(stdout, "Header %12.6g %8.2f%% %8.2f\n", - totalHeaderBytes, - ((totalHeaderBytes * 100.0) / tclTotalCodeBytes), - totalHeaderBytes/tclNumCompilations); - fprintf(stdout, "Instructions %12.6g %8.2f%% %8.2f\n", - tclTotalInstBytes, - ((tclTotalInstBytes * 100.0) / tclTotalCodeBytes), - tclTotalInstBytes/tclNumCompilations); - fprintf(stdout, "Objects %12.6g %8.2f%% %8.2f\n", - tclTotalObjBytes, - ((tclTotalObjBytes * 100.0) / tclTotalCodeBytes), - tclTotalObjBytes/tclNumCompilations); - fprintf(stdout, "Exception table %12.6g %8.2f%% %8.2f\n", - tclTotalExceptBytes, - ((tclTotalExceptBytes * 100.0) / tclTotalCodeBytes), - tclTotalExceptBytes/tclNumCompilations); - fprintf(stdout, "Auxiliary data %12.6g %8.2f%% %8.2f\n", - tclTotalAuxBytes, - ((tclTotalAuxBytes * 100.0) / tclTotalCodeBytes), - tclTotalAuxBytes/tclNumCompilations); - fprintf(stdout, "Command map %12.6g %8.2f%% %8.2f\n", - tclTotalCmdMapBytes, - ((tclTotalCmdMapBytes * 100.0) / tclTotalCodeBytes), - tclTotalCmdMapBytes/tclNumCompilations); + /* + * Breakdown of current ByteCode space requirements. + */ + + fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); + fprintf(stdout, " Bytes Pct of Avg per\n"); + fprintf(stdout, " total ByteCode\n"); + fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", + statsPtr->currentByteCodeBytes, + statsPtr->currentByteCodeBytes / numCurrentByteCodes); + fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", + currentHeaderBytes, + ((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes), + currentHeaderBytes / numCurrentByteCodes); + fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n", + statsPtr->currentInstBytes, + ((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes), + statsPtr->currentInstBytes / numCurrentByteCodes); + fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n", + statsPtr->currentLitBytes, + ((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes), + statsPtr->currentLitBytes / numCurrentByteCodes); + fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n", + statsPtr->currentExceptBytes, + ((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes), + statsPtr->currentExceptBytes / numCurrentByteCodes); + fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n", + statsPtr->currentAuxBytes, + ((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes), + statsPtr->currentAuxBytes / numCurrentByteCodes); + fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n", + statsPtr->currentCmdMapBytes, + ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes), + statsPtr->currentCmdMapBytes / numCurrentByteCodes); + + /* + * Detailed literal statistics. + */ - fprintf(stdout, "\nSource and ByteCode size distributions:\n"); - fprintf(stdout, " binary decade source code\n"); + fprintf(stdout, "\nLiteral string sizes:\n"); + fprintf(stdout, " Up to length Percentage\n"); + maxSizeDecade = 0; + for (i = 31; i >= 0; i--) { + if (statsPtr->literalCount[i] > 0) { + maxSizeDecade = i; + break; + } + } + sum = 0; for (i = 0; i <= maxSizeDecade; i++) { - int decadeLow, decadeHigh; + decadeHigh = (1 << (i+1)) - 1; + sum += statsPtr->literalCount[i]; + fprintf(stdout, " %10d %8.0f%%\n", + decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated); + } - if (i == 0) { - decadeLow = 0; - } else { - decadeLow = 1 << i; - } + litTableStats = TclLiteralStats(globalTablePtr); + fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", + litTableStats); + ckfree((char *) litTableStats); + + /* + * Source and ByteCode size distributions. + */ + + fprintf(stdout, "\nSource sizes:\n"); + fprintf(stdout, " Up to size Percentage\n"); + minSizeDecade = maxSizeDecade = 0; + for (i = 0; i < 31; i++) { + if (statsPtr->srcCount[i] > 0) { + minSizeDecade = i; + break; + } + } + for (i = 31; i >= 0; i--) { + if (statsPtr->srcCount[i] > 0) { + maxSizeDecade = i; + break; + } + } + sum = 0; + for (i = minSizeDecade; i <= maxSizeDecade; i++) { + decadeHigh = (1 << (i+1)) - 1; + sum += statsPtr->srcCount[i]; + fprintf(stdout, " %10d %8.0f%%\n", + decadeHigh, (sum * 100.0) / statsPtr->numCompilations); + } + + fprintf(stdout, "\nByteCode sizes:\n"); + fprintf(stdout, " Up to size Percentage\n"); + minSizeDecade = maxSizeDecade = 0; + for (i = 0; i < 31; i++) { + if (statsPtr->byteCodeCount[i] > 0) { + minSizeDecade = i; + break; + } + } + for (i = 31; i >= 0; i--) { + if (statsPtr->byteCodeCount[i] > 0) { + maxSizeDecade = i; + break; + } + } + sum = 0; + for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; - fprintf(stdout, " %6d -%6d %6d %6d\n", - decadeLow, decadeHigh, - tclSourceCount[i], tclByteCodeCount[i]); + sum += statsPtr->byteCodeCount[i]; + fprintf(stdout, " %10d %8.0f%%\n", + decadeHigh, (sum * 100.0) / statsPtr->numCompilations); } + fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n"); + fprintf(stdout, " Up to ms Percentage\n"); + minSizeDecade = maxSizeDecade = 0; + for (i = 0; i < 31; i++) { + if (statsPtr->lifetimeCount[i] > 0) { + minSizeDecade = i; + break; + } + } + for (i = 31; i >= 0; i--) { + if (statsPtr->lifetimeCount[i] > 0) { + maxSizeDecade = i; + break; + } + } + sum = 0; + for (i = minSizeDecade; i <= maxSizeDecade; i++) { + decadeHigh = (1 << (i+1)) - 1; + sum += statsPtr->lifetimeCount[i]; + fprintf(stdout, " %12.3f %8.0f%%\n", + decadeHigh / 1000.0, + (sum * 100.0) / statsPtr->numByteCodesFreed); + } + + /* + * Instruction counts. + */ + fprintf(stdout, "\nInstruction counts:\n"); - for (i = 0; i < 256; i++) { - if (instructionCount[i]) { - fprintf(stdout, "%20s %8d %6.2f%%\n", - opName[i], instructionCount[i], - (instructionCount[i] * 100.0)/total); + for (i = 0; i <= LAST_INST_OPCODE; i++) { + if (statsPtr->instructionCount[i]) { + fprintf(stdout, "%20s %8ld %6.1f%%\n", + instructionTable[i].name, + statsPtr->instructionCount[i], + (statsPtr->instructionCount[i]*100.0) / numInstructions); + } + } + + fprintf(stdout, "\nInstructions NEVER executed:\n"); + for (i = 0; i <= LAST_INST_OPCODE; i++) { + if (statsPtr->instructionCount[i] == 0) { + fprintf(stdout, "%20s\n", + instructionTable[i].name); } } #ifdef TCL_MEM_DEBUG fprintf(stdout, "\nHeap Statistics:\n"); TclDumpMemoryInfo(stdout); -#endif /* TCL_MEM_DEBUG */ - +#endif + fprintf(stdout, "\n----------------------------------------------------------------\n"); return TCL_OK; } #endif /* TCL_COMPILE_STATS */ @@ -4680,11 +4850,72 @@ Tcl_GetCommandFromObj(interp, objPtr) cmdPtr = resPtr->cmdPtr; } } + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetCmdNameObj -- + * + * Modify an object to be an CmdName object that refers to the argument + * Command structure. + * + * Results: + * None. + * + * Side effects: + * The object's old internal rep is freed. It's string rep is not + * changed. The refcount in the Command structure is incremented to + * keep it from being freed if the command is later deleted until + * TclExecuteByteCode has a chance to recognize that it was deleted. + * + *---------------------------------------------------------------------- + */ - if (cmdPtr == NULL) { - return (Tcl_Command) NULL; +void +TclSetCmdNameObj(interp, objPtr, cmdPtr) + Tcl_Interp *interp; /* Points to interpreter containing command + * that should be cached in objPtr. */ + register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to + * a CmdName object. */ + Command *cmdPtr; /* Points to Command structure that the + * CmdName object should refer to. */ +{ + Interp *iPtr = (Interp *) interp; + register ResolvedCmdName *resPtr; + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + register Namespace *currNsPtr; + + if (oldTypePtr == &tclCmdNameType) { + return; } - return (Tcl_Command) cmdPtr; + + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } /* @@ -4812,7 +5043,7 @@ SetCmdNameFromAny(interp, objPtr) name = objPtr->bytes; if (name == NULL) { - name = Tcl_GetStringFromObj(objPtr, (int *) NULL); + name = Tcl_GetString(objPtr); } /* @@ -4867,34 +5098,6 @@ SetCmdNameFromAny(interp, objPtr) return TCL_OK; } -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfCmdName -- - * - * Update the string representation for an cmdName object. - * - * Results: - * None. - * - * Side effects: - * Generates a panic. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfCmdName(objPtr) - Tcl_Obj *objPtr; /* CmdName obj to update string rep. */ -{ - /* - * This procedure is never invoked since the internal representation of - * a cmdName object is never modified. - */ - - panic("UpdateStringOfCmdName should never be invoked"); -} - #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- @@ -4922,7 +5125,7 @@ StringForResultCode(result) int result; /* The Tcl result code for which to * generate a string. */ { - static char buf[20]; + static char buf[TCL_INTEGER_SPACE]; if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { return resultStrings[result]; diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 1d4ae62..b69358b 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -4,12 +4,12 @@ * This file implements the generic portion of file manipulation * subcommands of the "file" command. * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * Copyright (c) 1996-1998 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: tclFCmd.c,v 1.3 1998/09/14 18:39:59 stanton Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.4 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -141,12 +141,12 @@ FileCopyRename(interp, argc, argv, copyFlag) result = TCL_OK; /* - * Call TclStat() so that if target is a symlink that points to a + * Call TclpStat() so that if target is a symlink that points to a * directory we will put the sources in that directory instead of * overwriting the symlink. */ - if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { + if ((TclpStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { if ((argc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); @@ -253,12 +253,12 @@ TclFileMakeDirsCmd(interp, argc, argv) char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer); /* - * Call TclStat() so that if target is a symlink that points + * Call TclpStat() so that if target is a symlink that points * to a directory we will create subdirectories in that * directory. */ - if (TclStat(target, &statBuf) == 0) { + if (TclpStat(target, &statBuf) == 0) { if (!S_ISDIR(statBuf.st_mode)) { errno = EEXIST; errfile = target; @@ -350,7 +350,7 @@ TclFileDeleteCmd(interp, argc, argv) * Call lstat() to get info so can delete symbolic link itself. */ - if (lstat(name, &statBuf) != 0) { + if (TclpLstat(name, &statBuf) != 0) { /* * Trying to delete a file that does not exist is not * considered an error, just a no-op @@ -454,11 +454,11 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * target. */ - if (lstat(sourceName, &sourceStatBuf) != 0) { + if (TclpLstat(sourceName, &sourceStatBuf) != 0) { errfile = source; goto done; } - if (lstat(targetName, &targetStatBuf) != 0) { + if (TclpLstat(targetName, &targetStatBuf) != 0) { if (errno != ENOENT) { errfile = target; goto done; @@ -606,8 +606,8 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * Results: * The return value is how many arguments from argv were consumed * by this function, or -1 if there was an error parsing the - * options. If an error occurred, an error message is left in - * interp->result. + * options. If an error occurred, an error message is left in the + * interp's result. * * Side effects: * None. @@ -620,7 +620,7 @@ FileForceOption(interp, argc, argv, forcePtr) Tcl_Interp *interp; /* Interp, for error return. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. First command line - option, if it exists, begins at */ + * option, if it exists, begins at 0. */ int *forcePtr; /* If the "-force" was specified, *forcePtr * is filled with 1, otherwise with 0. */ { @@ -751,66 +751,91 @@ TclFileAttrsCmd(interp, objc, objv) int objc; /* Number of command line arguments. */ Tcl_Obj *CONST objv[]; /* The command line objects. */ { - Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); char *fileName; - int length, index; - Tcl_Obj *listObjPtr; - Tcl_Obj *elementObjPtr; + int result; Tcl_DString buffer; - if ((objc > 2) && ((objc % 2) == 0)) { - Tcl_AppendStringsToObj(resultPtr, - "wrong # args: must be \"file attributes name ?option? ?value? ?option value? ...\"", - (char *) NULL); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, + "name ?option? ?value? ?option value ...?"); return TCL_ERROR; } - fileName = Tcl_GetStringFromObj(objv[0], &length); - if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) { + fileName = Tcl_GetString(objv[2]); + fileName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (fileName == NULL) { return TCL_ERROR; } - fileName = Tcl_DStringValue(&buffer); - if (objc == 1) { - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - + objc -= 3; + objv += 3; + result = TCL_ERROR; + + if (objc == 0) { + /* + * Get all attributes. + */ + + int index; + Tcl_Obj *listPtr, *objPtr; + + listPtr = Tcl_NewListObj(0, NULL); for (index = 0; tclpFileAttrStrings[index] != NULL; index++) { - elementObjPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1); - Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr); + objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, - &elementObjPtr) != TCL_OK) { - Tcl_DecrRefCount(listObjPtr); - return TCL_ERROR; + &objPtr) != TCL_OK) { + Tcl_DecrRefCount(listPtr); + goto end; } - Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); } - Tcl_SetObjResult(interp, listObjPtr); - } else if (objc == 2) { - if (Tcl_GetIndexFromObj(interp, objv[1], tclpFileAttrStrings, "option", - 0, &index) != TCL_OK) { - return TCL_ERROR; + Tcl_SetObjResult(interp, listPtr); + } else if (objc == 1) { + /* + * Get one attribute. + */ + + int index; + Tcl_Obj *objPtr; + + if (Tcl_GetIndexFromObj(interp, objv[0], tclpFileAttrStrings, + "option", 0, &index) != TCL_OK) { + goto end; } if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, - &elementObjPtr) != TCL_OK) { - return TCL_ERROR; + &objPtr) != TCL_OK) { + goto end; } - Tcl_SetObjResult(interp, elementObjPtr); + Tcl_SetObjResult(interp, objPtr); } else { - int i; + /* + * Set option/value pairs. + */ + + int i, index; - for (i = 1; i < objc ; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, "option", - 0, &index) != TCL_OK) { - return TCL_ERROR; + for (i = 0; i < objc ; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, + "option", 0, &index) != TCL_OK) { + goto end; } + if (i + 1 == objc) { + Tcl_AppendResult(interp, "value for \"", + Tcl_GetString(objv[i]), "\" missing", + (char *) NULL); + goto end; + } if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName, objv[i + 1]) != TCL_OK) { - return TCL_ERROR; + goto end; } } } - + result = TCL_OK; + + end: Tcl_DStringFree(&buffer); - - return TCL_OK; + return result; } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 7be9c0e..06e83a3 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -4,12 +4,13 @@ * This file contains routines for converting file names betwen * native and network form. * - * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * Copyright (c) 1995-1998 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: tclFileName.c,v 1.5 1999/03/10 05:52:48 stanton Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.6 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -17,19 +18,12 @@ #include "tclRegexp.h" /* - * This variable indicates whether the cleanup procedure has been - * registered for this file yet. - */ - -static int initialized = 0; - -/* * The following regular expression matches the root portion of a Windows * absolute or volume relative path. It will match both UNC and drive relative * paths. */ -#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\][/\\]+([^/\\]+)[/\\]+([^/\\]+)|([/\\]))([/\\])*" +#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\\\][/\\\\]+([^/\\\\]+)[/\\\\]+([^/\\\\]+)|([/\\\\]))([/\\\\])*" /* * The following regular expression matches the root portion of a Macintosh @@ -44,8 +38,13 @@ static int initialized = 0; * for use in filename matching. */ -static regexp *winRootPatternPtr = NULL; -static regexp *macRootPatternPtr = NULL; +typedef struct ThreadSpecificData { + int initialized; + Tcl_Obj *winRootPatternPtr; + Tcl_Obj *macRootPatternPtr; +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; /* * The following variable is set in the TclPlatformInit call to one @@ -59,22 +58,51 @@ TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; */ static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, - char *user, Tcl_DString *resultPtr)); -static char * ExtractWinRoot _ANSI_ARGS_((char *path, + CONST char *user, Tcl_DString *resultPtr)); +static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path, Tcl_DString *resultPtr, int offset)); static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); +static void FileNameInit _ANSI_ARGS_((void)); static int SkipToChar _ANSI_ARGS_((char **stringPtr, char *match)); -static char * SplitMacPath _ANSI_ARGS_((char *path, +static char * SplitMacPath _ANSI_ARGS_((CONST char *path, Tcl_DString *bufPtr)); -static char * SplitWinPath _ANSI_ARGS_((char *path, +static char * SplitWinPath _ANSI_ARGS_((CONST char *path, Tcl_DString *bufPtr)); -static char * SplitUnixPath _ANSI_ARGS_((char *path, +static char * SplitUnixPath _ANSI_ARGS_((CONST char *path, Tcl_DString *bufPtr)); /* *---------------------------------------------------------------------- * + * FileNameInit -- + * + * This procedure initializes the patterns used by this module. + * + * Results: + * None. + * + * Side effects: + * Compiles the regular expressions. + * + *---------------------------------------------------------------------- + */ + +static void +FileNameInit() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + if (!tsdPtr->initialized) { + tsdPtr->initialized = 1; + tsdPtr->winRootPatternPtr = Tcl_NewStringObj(WIN_ROOT_PATTERN, -1); + tsdPtr->macRootPatternPtr = Tcl_NewStringObj(MAC_ROOT_PATTERN, -1); + Tcl_CreateThreadExitHandler(FileNameCleanup, NULL); + } +} + +/* + *---------------------------------------------------------------------- + * * FileNameCleanup -- * * This procedure is a Tcl_ExitProc used to clean up the static @@ -93,15 +121,10 @@ static void FileNameCleanup(clientData) ClientData clientData; /* Not used. */ { - if (winRootPatternPtr != NULL) { - ckfree((char *)winRootPatternPtr); - winRootPatternPtr = (regexp *) NULL; - } - if (macRootPatternPtr != NULL) { - ckfree((char *)macRootPatternPtr); - macRootPatternPtr = (regexp *) NULL; - } - initialized = 0; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_DecrRefCount(tsdPtr->winRootPatternPtr); + Tcl_DecrRefCount(tsdPtr->macRootPatternPtr); + tsdPtr->initialized = 0; } /* @@ -124,55 +147,59 @@ FileNameCleanup(clientData) *---------------------------------------------------------------------- */ -static char * +static CONST char * ExtractWinRoot(path, resultPtr, offset) - char *path; /* Path to parse. */ + CONST char *path; /* Path to parse. */ Tcl_DString *resultPtr; /* Buffer to hold result. */ int offset; /* Offset in buffer where result should be * stored. */ { int length; + Tcl_RegExp re; + char *dummy, *tail, *drive, *hostStart, *hostEnd, *shareStart, + *shareEnd, *lastSlash; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Initialize the path name parser for Windows path names. */ - if (winRootPatternPtr == NULL) { - winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } + FileNameInit(); + + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->winRootPatternPtr, REG_ADVANCED); /* * Match the root portion of a Windows path name. */ - if (!TclRegExec(winRootPatternPtr, path, path)) { + if (!Tcl_RegExpExec(NULL, re, path, path)) { return path; } Tcl_DStringSetLength(resultPtr, offset); - if (winRootPatternPtr->startp[2] != NULL) { - Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[2], 2); - if (winRootPatternPtr->startp[6] != NULL) { + Tcl_RegExpRange(re, 0, &dummy, &tail); + Tcl_RegExpRange(re, 2, &drive, &dummy); + Tcl_RegExpRange(re, 3, &hostStart, &hostEnd); + Tcl_RegExpRange(re, 4, &shareStart, &shareEnd); + Tcl_RegExpRange(re, 6, &lastSlash, &dummy); + + if (drive != NULL) { + Tcl_DStringAppend(resultPtr, drive, 2); + if (lastSlash != NULL) { Tcl_DStringAppend(resultPtr, "/", 1); } - } else if (winRootPatternPtr->startp[4] != NULL) { + } else if (shareStart != NULL) { Tcl_DStringAppend(resultPtr, "//", 2); - length = winRootPatternPtr->endp[3] - - winRootPatternPtr->startp[3]; - Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[3], length); + length = hostEnd - hostStart; + Tcl_DStringAppend(resultPtr, hostStart, length); Tcl_DStringAppend(resultPtr, "/", 1); - length = winRootPatternPtr->endp[4] - - winRootPatternPtr->startp[4]; - Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[4], length); + length = shareEnd - shareStart; + Tcl_DStringAppend(resultPtr, shareStart, length); } else { Tcl_DStringAppend(resultPtr, "/", 1); } - return winRootPatternPtr->endp[0]; + return tail; } /* @@ -197,7 +224,9 @@ Tcl_PathType Tcl_GetPathType(path) char *path; { + ThreadSpecificData *tsdPtr; Tcl_PathType type = TCL_PATH_ABSOLUTE; + Tcl_RegExp re; switch (tclPlatform) { case TCL_PLATFORM_UNIX: @@ -214,45 +243,51 @@ Tcl_GetPathType(path) if (path[0] == ':') { type = TCL_PATH_RELATIVE; } else if (path[0] != '~') { + tsdPtr = TCL_TSD_INIT(&dataKey); /* * Since we have eliminated the easy cases, use the * root pattern to look for the other types. */ - if (!macRootPatternPtr) { - macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } - if (!TclRegExec(macRootPatternPtr, path, path) - || (macRootPatternPtr->startp[2] != NULL)) { + FileNameInit(); + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, + REG_ADVANCED); + + if (!Tcl_RegExpExec(NULL, re, path, path)) { type = TCL_PATH_RELATIVE; + } else { + char *unixRoot, *dummy; + + Tcl_RegExpRange(re, 2, &unixRoot, &dummy); + if (unixRoot) { + type = TCL_PATH_RELATIVE; + } } } break; case TCL_PLATFORM_WINDOWS: if (path[0] != '~') { + tsdPtr = TCL_TSD_INIT(&dataKey); /* * Since we have eliminated the easy cases, check for * drive relative paths using the regular expression. */ - if (!winRootPatternPtr) { - winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } - if (TclRegExec(winRootPatternPtr, path, path)) { - if (winRootPatternPtr->startp[5] - || (winRootPatternPtr->startp[2] - && !(winRootPatternPtr->startp[6]))) { + FileNameInit(); + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->winRootPatternPtr, + REG_ADVANCED); + + if (Tcl_RegExpExec(NULL, re, path, path)) { + char *drive, *dummy, *unixRoot, *lastSlash; + + Tcl_RegExpRange(re, 2, &drive, &dummy); + Tcl_RegExpRange(re, 5, &unixRoot, &dummy); + Tcl_RegExpRange(re, 6, &lastSlash, &dummy); + + if (unixRoot || (drive && !lastSlash)) { type = TCL_PATH_VOLUME_RELATIVE; } } else { @@ -292,7 +327,7 @@ Tcl_GetPathType(path) void Tcl_SplitPath(path, argcPtr, argvPtr) - char *path; /* Pointer to string containing a path. */ + CONST char *path; /* Pointer to string containing a path. */ int *argcPtr; /* Pointer to location to fill in with * the number of elements in the path. */ char ***argvPtr; /* Pointer to place to store pointer to array @@ -301,6 +336,7 @@ Tcl_SplitPath(path, argcPtr, argvPtr) int i, size; char *p; Tcl_DString buffer; + Tcl_DStringInit(&buffer); /* @@ -385,11 +421,11 @@ Tcl_SplitPath(path, argcPtr, argvPtr) static char * SplitUnixPath(path, bufPtr) - char *path; /* Pointer to string containing a path. */ + CONST char *path; /* Pointer to string containing a path. */ Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int length; - char *p, *elementStart; + CONST char *p, *elementStart; /* * Deal with the root directory as a special case. @@ -447,11 +483,11 @@ SplitUnixPath(path, bufPtr) static char * SplitWinPath(path, bufPtr) - char *path; /* Pointer to string containing a path. */ + CONST char *path; /* Pointer to string containing a path. */ Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int length; - char *p, *elementStart; + CONST char *p, *elementStart; p = ExtractWinRoot(path, bufPtr, 0); @@ -505,88 +541,98 @@ SplitWinPath(path, bufPtr) static char * SplitMacPath(path, bufPtr) - char *path; /* Pointer to string containing a path. */ + CONST char *path; /* Pointer to string containing a path. */ Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */ int i, length; - char *p, *elementStart; + CONST char *p, *elementStart; + Tcl_RegExp re; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Initialize the path name parser for Macintosh path names. */ - if (macRootPatternPtr == NULL) { - macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } + FileNameInit(); /* * Match the root portion of a Mac path name. */ i = 0; /* Needed only to prevent gcc warnings. */ - if (TclRegExec(macRootPatternPtr, path, path) == 1) { + + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, REG_ADVANCED); + + if (Tcl_RegExpExec(NULL, re, path, path) == 1) { + char *start, *end; + /* * Treat degenerate absolute paths like / and /../.. as * Mac relative file names for lack of anything else to do. */ - if (macRootPatternPtr->startp[2] != NULL) { + Tcl_RegExpRange(re, 2, &start, &end); + if (start) { Tcl_DStringAppend(bufPtr, ":", 1); - Tcl_DStringAppend(bufPtr, path, macRootPatternPtr->endp[0] - - macRootPatternPtr->startp[0] + 1); + Tcl_RegExpRange(re, 0, &start, &end); + Tcl_DStringAppend(bufPtr, path, end - start + 1); return Tcl_DStringValue(bufPtr); } - if (macRootPatternPtr->startp[5] != NULL) { - + Tcl_RegExpRange(re, 5, &start, &end); + if (start) { /* * Unix-style tilde prefixed paths. */ isMac = 0; i = 5; - } else if (macRootPatternPtr->startp[7] != NULL) { - - /* - * Mac-style tilde prefixed paths. - */ + } else { + Tcl_RegExpRange(re, 7, &start, &end); + if (start) { + /* + * Mac-style tilde prefixed paths. + */ - isMac = 1; - i = 7; - } else if (macRootPatternPtr->startp[10] != NULL) { + isMac = 1; + i = 7; + } else { + Tcl_RegExpRange(re, 10, &start, &end); + if (start) { - /* - * Normal Unix style paths. - */ + /* + * Normal Unix style paths. + */ - isMac = 0; - i = 10; - } else if (macRootPatternPtr->startp[12] != NULL) { + isMac = 0; + i = 10; + } else { + Tcl_RegExpRange(re, 12, &start, &end); + if (start) { - /* - * Normal Mac style paths. - */ + /* + * Normal Mac style paths. + */ - isMac = 1; - i = 12; + isMac = 1; + i = 12; + } + } + } } - length = macRootPatternPtr->endp[i] - - macRootPatternPtr->startp[i]; + Tcl_RegExpRange(re, i, &start, &end); + length = end - start; /* * Append the element and terminate it with a : and a null. Note that * we are forcing the DString to contain an extra null at the end. */ - Tcl_DStringAppend(bufPtr, macRootPatternPtr->startp[i], length); + Tcl_DStringAppend(bufPtr, start, length); Tcl_DStringAppend(bufPtr, ":", 2); - p = macRootPatternPtr->endp[i]; + p = end; } else { isMac = (strchr(path, ':') != NULL); p = path; @@ -690,7 +736,8 @@ Tcl_JoinPath(argc, argv, resultPtr) { int oldLength, length, i, needsSep; Tcl_DString buffer; - char *p, c, *dest; + char c, *dest; + CONST char *p; Tcl_DStringInit(&buffer); oldLength = Tcl_DStringLength(resultPtr); @@ -884,25 +931,27 @@ Tcl_JoinPath(argc, argv, resultPtr) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system - * interfaces. If the name starts with a tilde, it will produce - * a name where the tilde and following characters have been - * replaced by the home directory location for the named user. + * interfaces. If the name starts with a tilde, it will produce a + * name where the tilde and following characters have been replaced + * by the home directory location for the named user. * * Results: - * The result is a pointer to a static string containing - * the new name. If there was an error in processing the - * name, then an error message is left in interp->result - * and the return value is NULL. The result will be stored - * in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr) - * to free the name if the return value was not NULL. + * The return value is a pointer to a string containing the name + * after tilde substitution. If there was no tilde substitution, + * the return value is a pointer to a copy of the original string. + * If there was an error in processing the name, then an error + * message is left in the interp's result (if interp was not NULL) + * and the return value is NULL. Space for the return value is + * allocated in bufferPtr; the caller must call Tcl_DStringFree() + * to free the space if the return value was not NULL. * * Side effects: - * Information may be left in bufferPtr. + * None. * *---------------------------------------------------------------------- */ @@ -911,13 +960,12 @@ char * Tcl_TranslateFileName(interp, name, bufferPtr) Tcl_Interp *interp; /* Interpreter in which to store error * message (if necessary). */ - char *name; /* File name, which may begin with "~" - * (to indicate current user's home directory) - * or "~" (to indicate any user's - * home directory). */ - Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold - * anything at the time of the call, and need - * not even be initialized. */ + char *name; /* File name, which may begin with "~" (to + * indicate current user's home directory) or + * "~" (to indicate any user's home + * directory). */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled + * with name after tilde substitution. */ { register char *p; @@ -933,8 +981,8 @@ Tcl_TranslateFileName(interp, name, bufferPtr) Tcl_SplitPath(name, &argc, &argv); /* - * Strip the trailing ':' off of a Mac path - * before passing the user name to DoTildeSubst. + * Strip the trailing ':' off of a Mac path before passing the user + * name to DoTildeSubst. */ if (tclPlatform == TCL_PLATFORM_MAC) { @@ -1051,9 +1099,10 @@ TclGetExtension(name) * Results: * The result is a pointer to a static string containing the home * directory in native format. If there was an error in processing - * the substitution, then an error message is left in interp->result - * and the return value is NULL. On success, the results are appended - * to resultPtr, and the contents of resultPtr are returned. + * the substitution, then an error message is left in the interp's + * result and the return value is NULL. On success, the results + * are appended to resultPtr, and the contents of resultPtr are + * returned. * * Side effects: * Information may be left in resultPtr. @@ -1065,16 +1114,17 @@ static char * DoTildeSubst(interp, user, resultPtr) Tcl_Interp *interp; /* Interpreter in which to store error * message (if necessary). */ - char *user; /* Name of user whose home directory should be + CONST char *user; /* Name of user whose home directory should be * substituted, or "" for current user. */ - Tcl_DString *resultPtr; /* May be used to hold result. Must not hold - * anything at the time of the call, and need - * not even be initialized. */ + Tcl_DString *resultPtr; /* Initialized DString filled with name + * after tilde substitution. */ { char *dir; if (*user == '\0') { - dir = TclGetEnv("HOME"); + Tcl_DString dirString; + + dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { Tcl_ResetResult(interp); @@ -1084,13 +1134,16 @@ DoTildeSubst(interp, user, resultPtr) return NULL; } Tcl_JoinPath(1, &dir, resultPtr); - } else if (TclGetUserHome(user, resultPtr) == NULL) { - if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", - (char *) NULL); + Tcl_DStringFree(&dirString); + } else { + if (TclpGetUserHome(user, resultPtr) == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", + (char *) NULL); + } + return NULL; } - return NULL; } return resultPtr->string; } @@ -1098,7 +1151,7 @@ DoTildeSubst(interp, user, resultPtr) /* *---------------------------------------------------------------------- * - * Tcl_GlobCmd -- + * Tcl_GlobObjCmd -- * * This procedure is invoked to process the "glob" Tcl command. * See the user documentation for details on what it does. @@ -1114,42 +1167,104 @@ DoTildeSubst(interp, user, resultPtr) /* ARGSUSED */ int -Tcl_GlobCmd(dummy, interp, argc, argv) +Tcl_GlobObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int i, noComplain, firstArg; - char c; - int result = TCL_OK; - Tcl_DString buffer; - char *separators, *head, *tail; + int index, i, noComplain, skip, length; + char *string; + static char *options[] = {"-nocomplain", "--", NULL}; + enum options {GLOB_NOCOMPLAIN, GLOB_LAST}; noComplain = 0; - for (firstArg = 1; (firstArg < argc) && (argv[firstArg][0] == '-'); - firstArg++) { - if (strcmp(argv[firstArg], "-nocomplain") == 0) { - noComplain = 1; - } else if (strcmp(argv[firstArg], "--") == 0) { - firstArg++; + for (skip = 1; skip < objc; skip++) { + string = Tcl_GetString(objv[skip]); + if (string[0] != '-') { break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argv[firstArg], - "\": must be -nocomplain or --", (char *) NULL); + } + if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", + TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } + if (index == GLOB_NOCOMPLAIN) { + noComplain = 1; + } else { + skip++; + break; + } } - if (firstArg >= argc) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? name ?name ...?\"", (char *) NULL); + if (skip >= objc) { + Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?"); return TCL_ERROR; } - Tcl_DStringInit(&buffer); - separators = NULL; /* Needed only to prevent gcc warnings. */ - for (i = firstArg; i < argc; i++) { - switch (tclPlatform) { + for (i = skip; i < objc; i++) { + string = Tcl_GetString(objv[i]); + if (TclGlob(interp, string, noComplain) != TCL_OK) { + return TCL_ERROR; + } + } + if (noComplain == 0) { + Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + if (length == 0) { + char *sep = ""; + + Tcl_AppendResult(interp, "no files matched glob pattern", + (objc == 2) ? " \"" : "s \"", (char *) NULL); + for (i = skip; i < objc; i++) { + string = Tcl_GetString(objv[i]); + Tcl_AppendResult(interp, sep, string, (char *) NULL); + sep = " "; + } + Tcl_AppendResult(interp, "\"", (char *) NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGlob -- + * + * This procedure prepares arguments for the TclDoGlob call. + * It sets the separator string based on the platform, performs + * tilde substitution, and calls TclDoGlob. + * + * Results: + * The return value is a standard Tcl result indicating whether + * an error occurred in globbing. After a normal return the + * result in interp (set by TclDoGlob) holds all of the file names + * given by the dir and rem arguments. After an error the + * result in interp will hold an error message. + * + * Side effects: + * The currentArgString is written to. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclGlob(interp, pattern, noComplain) + Tcl_Interp *interp; /* Interpreter for returning error message + * or appending list of matching file names. */ + char *pattern; /* Glob pattern to match. Must not refer + * to a static string. */ + int noComplain; /* Flag to turn off storing error messages + * in interp. */ +{ + char *separators; + char *head, *tail; + char c; + int result; + Tcl_DString buffer; + + separators = NULL; /* lint. */ + switch (tclPlatform) { case TCL_PLATFORM_UNIX: separators = "/"; break; @@ -1157,102 +1272,84 @@ Tcl_GlobCmd(dummy, interp, argc, argv) separators = "/\\:"; break; case TCL_PLATFORM_MAC: - separators = (strchr(argv[i], ':') == NULL) ? "/" : ":"; + separators = (strchr(pattern, ':') == NULL) + ? "/" : ":"; break; - } + } - Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringInit(&buffer); - /* - * Perform tilde substitution, if needed. - */ + /* + * Perform tilde substitution, if needed. + */ - if (argv[i][0] == '~') { - char *p; + if (pattern[0] == '~') { + char *p; - /* - * Find the first path separator after the tilde. - */ + /* + * Find the first path separator after the tilde. + */ - for (tail = argv[i]; *tail != '\0'; tail++) { - if (*tail == '\\') { - if (strchr(separators, tail[1]) != NULL) { - break; - } - } else if (strchr(separators, *tail) != NULL) { + for (tail = pattern; *tail != '\0'; tail++) { + if (*tail == '\\') { + if (strchr(separators, tail[1]) != NULL) { break; } + } else if (strchr(separators, *tail) != NULL) { + break; } + } - /* - * Determine the home directory for the specified user. Note that - * we don't allow special characters in the user name. - */ - - c = *tail; - *tail = '\0'; - p = strpbrk(argv[i]+1, "\\[]*?{}"); - if (p == NULL) { - head = DoTildeSubst(interp, argv[i]+1, &buffer); - } else { - if (!noComplain) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "globbing characters not ", - "supported in user names", (char *) NULL); - } - head = NULL; - } - *tail = c; - if (head == NULL) { - if (noComplain) { - Tcl_ResetResult(interp); - continue; - } else { - result = TCL_ERROR; - goto done; - } - } - if (head != Tcl_DStringValue(&buffer)) { - Tcl_DStringAppend(&buffer, head, -1); - } + /* + * Determine the home directory for the specified user. Note that + * we don't allow special characters in the user name. + */ + + c = *tail; + *tail = '\0'; + p = strpbrk(pattern+1, "\\[]*?{}"); + if (p == NULL) { + head = DoTildeSubst(interp, pattern+1, &buffer); } else { - tail = argv[i]; + if (!noComplain) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "globbing characters not ", + "supported in user names", (char *) NULL); + } + head = NULL; } - - result = TclDoGlob(interp, separators, &buffer, tail); - if (result != TCL_OK) { + *tail = c; + if (head == NULL) { if (noComplain) { /* * We should in fact pass down the nocomplain flag - * or save the interp result or use another mecanism + * or save the interp result or use another mechanism * so the interp result is not mangled on errors in that case. * but that would a bigger change than reasonable for a patch * release. * (see fileName.test 15.2-15.4 for expected behaviour) */ Tcl_ResetResult(interp); - result = TCL_OK; - continue; + return TCL_OK; } else { - goto done; + return TCL_ERROR; } } + if (head != Tcl_DStringValue(&buffer)) { + Tcl_DStringAppend(&buffer, head, -1); + } + } else { + tail = pattern; } - if ((*interp->result == 0) && !noComplain) { - char *sep = ""; - - Tcl_AppendResult(interp, "no files matched glob pattern", - (argc == 2) ? " \"" : "s \"", (char *) NULL); - for (i = firstArg; i < argc; i++) { - Tcl_AppendResult(interp, sep, argv[i], (char *) NULL); - sep = " "; + result = TclDoGlob(interp, separators, &buffer, tail); + Tcl_DStringFree(&buffer); + if (result != TCL_OK) { + if (noComplain) { + Tcl_ResetResult(interp); + return TCL_OK; } - Tcl_AppendResult(interp, "\"", (char *) NULL); - result = TCL_ERROR; } -done: - Tcl_DStringFree(&buffer); return result; } @@ -1339,11 +1436,12 @@ TclDoGlob(interp, separators, headPtr, tail) * that should be used to identify globbing * boundaries. */ Tcl_DString *headPtr; /* Completely expanded prefix. */ - char *tail; /* The unexpanded remainder of the path. */ + char *tail; /* The unexpanded remainder of the path. + * Must not be a pointer to a static string. */ { int baseLength, quoted, count; int result = TCL_OK; - char *p, *openBrace, *closeBrace, *name, *firstSpecialChar, savedChar; + char *name, *p, *openBrace, *closeBrace, *firstSpecialChar, savedChar; char lastChar = 0; int length = Tcl_DStringLength(headPtr); @@ -1515,6 +1613,12 @@ TclDoGlob(interp, separators, headPtr, tail) */ if (*p != '\0') { + + /* + * Note that we are modifying the string in place. This won't work + * if the string is a static. + */ + savedChar = *p; *p = '\0'; firstSpecialChar = strpbrk(tail, "*[]?\\"); @@ -1528,11 +1632,11 @@ TclDoGlob(interp, separators, headPtr, tail) * Look for matching files in the current directory. The * implementation of this function is platform specific, but may * recursively call TclDoGlob. For each file that matches, it will - * add the match onto the interp->result, or call TclDoGlob if there + * add the match onto the interp's result, or call TclDoGlob if there * are more characters to be processed. */ - return TclMatchFiles(interp, separators, headPtr, tail, p); + return TclpMatchFiles(interp, separators, headPtr, tail, p); } Tcl_DStringAppend(headPtr, tail, p-tail); if (*p != '\0') { @@ -1546,21 +1650,23 @@ TclDoGlob(interp, separators, headPtr, tail) */ switch (tclPlatform) { - case TCL_PLATFORM_MAC: + case TCL_PLATFORM_MAC: { if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) { Tcl_DStringAppend(headPtr, ":", 1); } name = Tcl_DStringValue(headPtr); - if (TclAccess(name, F_OK) == 0) { + if (TclpAccess(name, F_OK) == 0) { if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) { - Tcl_AppendElement(interp, name+1); + Tcl_AppendElement(interp, name + 1); } else { Tcl_AppendElement(interp, name); } } break; + } case TCL_PLATFORM_WINDOWS: { int exists; + /* * We need to convert slashes to backslashes before checking * for the existence of the file. Once we are done, we need @@ -1582,7 +1688,8 @@ TclDoGlob(interp, separators, headPtr, tail) } } name = Tcl_DStringValue(headPtr); - exists = (TclAccess(name, F_OK) == 0); + exists = (TclpAccess(name, F_OK) == 0); + for (p = name; *p != '\0'; p++) { if (*p == '\\') { *p = '/'; @@ -1593,7 +1700,7 @@ TclDoGlob(interp, separators, headPtr, tail) } break; } - case TCL_PLATFORM_UNIX: + case TCL_PLATFORM_UNIX: { if (Tcl_DStringLength(headPtr) == 0) { if ((*name == '\\' && name[1] == '/') || (*name == '/')) { Tcl_DStringAppend(headPtr, "/", 1); @@ -1602,10 +1709,11 @@ TclDoGlob(interp, separators, headPtr, tail) } } name = Tcl_DStringValue(headPtr); - if (TclAccess(name, F_OK) == 0) { + if (TclpAccess(name, F_OK) == 0) { Tcl_AppendElement(interp, name); } break; + } } return TCL_OK; diff --git a/generic/tclGet.c b/generic/tclGet.c index e236741..27e49cc 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -6,12 +6,12 @@ * booleans, doing syntax checking along the way. * * Copyright (c) 1990-1993 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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: tclGet.c,v 1.2 1998/09/14 18:39:59 stanton Exp $ + * RCS: @(#) $Id: tclGet.c,v 1.3 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -29,7 +29,7 @@ * The return value is normally TCL_OK; in this case *intPtr * will be set to the integer value equivalent to string. If * string is improperly formed then TCL_ERROR is returned and - * an error message will be left in interp->result. + * an error message will be left in the interp's result. * * Side effects: * None. @@ -54,17 +54,17 @@ Tcl_GetInt(interp, string, intPtr) */ errno = 0; - for (p = string; isspace(UCHAR(*p)); p++) { + for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ /* Empty loop body. */ } if (*p == '-') { p++; - i = -((long)strtoul(p, &end, 0)); + i = -((long)strtoul(p, &end, 0)); /* INTL: Tcl source. */ } else if (*p == '+') { p++; - i = strtoul(p, &end, 0); + i = strtoul(p, &end, 0); /* INTL: Tcl source. */ } else { - i = strtoul(p, &end, 0); + i = strtoul(p, &end, 0); /* INTL: Tcl source. */ } if (end == p) { badInteger: @@ -86,11 +86,11 @@ Tcl_GetInt(interp, string, intPtr) Tcl_SetResult(interp, "integer value too large to represent", TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - interp->result, (char *) NULL); + Tcl_GetStringResult(interp), (char *) NULL); } return TCL_ERROR; } - while ((*end != '\0') && isspace(UCHAR(*end))) { + while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */ end++; } if (*end != 0) { @@ -113,7 +113,8 @@ Tcl_GetInt(interp, string, intPtr) * The return value is normally TCL_OK; in this case *longPtr * will be set to the long integer value equivalent to string. If * string is improperly formed then TCL_ERROR is returned and - * an error message will be left in interp->result. + * an error message will be left in the interp's result if interp + * is non-NULL. * * Side effects: * None. @@ -123,7 +124,8 @@ Tcl_GetInt(interp, string, intPtr) int TclGetLong(interp, string, longPtr) - Tcl_Interp *interp; /* Interpreter used for error reporting. */ + Tcl_Interp *interp; /* Interpreter used for error reporting + * if not NULL. */ char *string; /* String containing a (possibly signed) * long integer in a form acceptable to * strtoul. */ @@ -138,17 +140,17 @@ TclGetLong(interp, string, longPtr) */ errno = 0; - for (p = string; isspace(UCHAR(*p)); p++) { + for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ /* Empty loop body. */ } if (*p == '-') { p++; - i = -(int)strtoul(p, &end, 0); + i = -(int)strtoul(p, &end, 0); /* INTL: Tcl source. */ } else if (*p == '+') { p++; - i = strtoul(p, &end, 0); + i = strtoul(p, &end, 0); /* INTL: Tcl source. */ } else { - i = strtoul(p, &end, 0); + i = strtoul(p, &end, 0); /* INTL: Tcl source. */ } if (end == p) { badInteger: @@ -163,11 +165,11 @@ TclGetLong(interp, string, longPtr) Tcl_SetResult(interp, "integer value too large to represent", TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - interp->result, (char *) NULL); + Tcl_GetStringResult(interp), (char *) NULL); } return TCL_ERROR; } - while ((*end != '\0') && isspace(UCHAR(*end))) { + while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */ end++; } if (*end != 0) { @@ -189,7 +191,7 @@ TclGetLong(interp, string, longPtr) * The return value is normally TCL_OK; in this case *doublePtr * will be set to the double-precision value equivalent to string. * If string is improperly formed then TCL_ERROR is returned and - * an error message will be left in interp->result. + * an error message will be left in the interp's result. * * Side effects: * None. @@ -208,7 +210,7 @@ Tcl_GetDouble(interp, string, doublePtr) double d; errno = 0; - d = strtod(string, &end); + d = strtod(string, &end); /* INTL: Tcl source. */ if (end == string) { badDouble: if (interp != (Tcl_Interp *) NULL) { @@ -220,22 +222,11 @@ Tcl_GetDouble(interp, string, doublePtr) } if (errno != 0) { if (interp != (Tcl_Interp *) NULL) { - TclExprFloatError(interp, d); /* sets interp->objResult */ - - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. - */ - - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), - TCL_VOLATILE); + TclExprFloatError(interp, d); } return TCL_ERROR; } - while ((*end != 0) && isspace(UCHAR(*end))) { + while ((*end != 0) && isspace(UCHAR(*end))) { /* INTL: ISO space. */ end++; } if (*end != 0) { @@ -257,7 +248,7 @@ Tcl_GetDouble(interp, string, doublePtr) * The return value is normally TCL_OK; in this case *boolPtr * will be set to the 0/1 value equivalent to string. If * string is improperly formed then TCL_ERROR is returned and - * an error message will be left in interp->result. + * an error message will be left in the interp's result. * * Side effects: * None. @@ -279,7 +270,8 @@ Tcl_GetBoolean(interp, string, boolPtr) size_t length; /* - * Convert the input string to all lower-case. + * Convert the input string to all lower-case. + * INTL: This code will work on UTF strings. */ for (i = 0; i < 9; i++) { diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 66e43e1..2f519dce 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -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: tclGetDate.y,v 1.3 1999/03/10 05:52:48 stanton Exp $ + * RCS: @(#) $Id: tclGetDate.y,v 1.4 1999/04/16 00:46:46 stanton Exp $ */ %{ @@ -692,11 +692,8 @@ LookupWord(buff) /* * Make it lowercase. */ - for (p = buff; *p; p++) { - if (isupper(UCHAR(*p))) { - *p = (char) tolower(UCHAR(*p)); - } - } + + Tcl_UtfToLower(buff); if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) { yylval.Meridian = MERam; @@ -769,7 +766,8 @@ LookupWord(buff) /* * Military timezones. */ - if (buff[1] == '\0' && isalpha(UCHAR(*buff))) { + if (buff[1] == '\0' && !(*buff & 0x80) + && isalpha(UCHAR(*buff))) { /* INTL: ISO only */ for (tp = MilitaryTable; tp->name; tp++) { if (strcmp(buff, tp->name) == 0) { yylval.Number = tp->value; @@ -815,10 +813,10 @@ yylex() yyInput++; } - if (isdigit(c = *yyInput) || c == '-' || c == '+') { + if (isdigit(c = *yyInput) || c == '-' || c == '+') { /* INTL: digit */ if (c == '-' || c == '+') { sign = c == '-' ? -1 : 1; - if (!isdigit(*++yyInput)) { + if (!isdigit(*++yyInput)) { /* INTL: digit */ /* * skip the '-' sign */ @@ -827,7 +825,8 @@ yylex() } else { sign = 0; } - for (yylval.Number = 0; isdigit(c = *yyInput++); ) { + for (yylval.Number = 0; + isdigit(c = *yyInput++); ) { /* INTL: digit */ yylval.Number = 10 * yylval.Number + c - '0'; } yyInput--; @@ -836,8 +835,9 @@ yylex() } return sign ? tSNUMBER : tUNUMBER; } - if (isalpha(UCHAR(c))) { - for (p = buff; isalpha(c = *yyInput++) || c == '.'; ) { + if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */ + for (p = buff; isalpha(c = *yyInput++) /* INTL: ISO only. */ + || c == '.'; ) { if (p < &buff[sizeof buff - 1]) { *p++ = c; } diff --git a/generic/tclHash.c b/generic/tclHash.c index 85596c3..973c003 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -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: tclHash.c,v 1.2 1998/09/14 18:39:59 stanton Exp $ + * RCS: @(#) $Id: tclHash.c,v 1.3 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -83,6 +83,11 @@ Tcl_InitHashTable(tablePtr, keyType) * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, * or an integer >= 2. */ { +#if (TCL_SMALL_HASH_TABLE != 4) + panic("Tcl_InitHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", + TCL_SMALL_HASH_TABLE); +#endif + tablePtr->buckets = tablePtr->staticBuckets; tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; diff --git a/generic/tclHistory.c b/generic/tclHistory.c index 495880f..5f2a9f2 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -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: tclHistory.c,v 1.2 1998/09/14 18:39:59 stanton Exp $ + * RCS: @(#) $Id: tclHistory.c,v 1.3 1999/04/16 00:46:47 stanton Exp $ */ #include "tclInt.h" @@ -57,20 +57,16 @@ Tcl_RecordAndEval(interp, cmd, flags) * Call Tcl_RecordAndEvalObj to do the actual work. */ - TclNewObj(cmdPtr); - TclInitStringRep(cmdPtr, cmd, length); + cmdPtr = Tcl_NewStringObj(cmd, length); Tcl_IncrRefCount(cmdPtr); - result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); /* @@ -116,11 +112,10 @@ Tcl_RecordAndEvalObj(interp, cmdPtr, flags) * record and execute. */ int flags; /* Additional flags. TCL_NO_EVAL means * record only: don't execute the command. - * TCL_EVAL_GLOBAL means use - * Tcl_GlobalEvalObj instead of - * Tcl_EvalObj. */ + * TCL_EVAL_GLOBAL means evaluate the + * script in global variable context instead + * of the current procedure. */ { - Interp *iPtr = (Interp *) interp; int result; Tcl_Obj *list[3]; register Tcl_Obj *objPtr; @@ -135,7 +130,7 @@ Tcl_RecordAndEvalObj(interp, cmdPtr, flags) objPtr = Tcl_NewListObj(3, list); Tcl_IncrRefCount(objPtr); - (void) Tcl_GlobalEvalObj(interp, objPtr); + (void) Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(objPtr); /* @@ -144,12 +139,7 @@ Tcl_RecordAndEvalObj(interp, cmdPtr, flags) result = TCL_OK; if (!(flags & TCL_NO_EVAL)) { - iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL); - if (flags & TCL_EVAL_GLOBAL) { - result = Tcl_GlobalEvalObj(interp, cmdPtr); - } else { - result = Tcl_EvalObj(interp, cmdPtr); - } + result = Tcl_EvalObjEx(interp, cmdPtr, flags & TCL_EVAL_GLOBAL); } return result; } diff --git a/generic/tclIO.c b/generic/tclIO.c index 9725902..32c844e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,11 +10,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.5 1998/10/30 00:38:38 welch Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.6 1999/04/16 00:46:47 stanton Exp $ */ -#include "tclInt.h" -#include "tclPort.h" +#include "tclInt.h" +#include "tclPort.h" /* * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not @@ -65,7 +65,7 @@ typedef struct ChannelBuffer { * will be put in the buffer. */ int nextRemoved; /* Position of next byte to be removed * from the buffer. */ - int bufSize; /* How big is the buffer? */ + int bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; /* Next buffer in chain. */ char buf[4]; /* Placeholder for real buffer. The real @@ -77,6 +77,14 @@ typedef struct ChannelBuffer { #define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) /* + * How much extra space to allocate in buffer to hold bytes from previous + * buffer (when converting to UTF-8) or to hold bytes that will go to + * next buffer (when converting from UTF-8). + */ + +#define BUFFER_PADDING 16 + +/* * The following defines the *default* buffer size for channels. */ @@ -105,7 +113,7 @@ typedef struct EventScriptRecord { * registered. This is used only when an * error occurs during evaluation of the * script, to delete the handler. */ - char *script; /* Script to invoke. */ + Tcl_Obj *scriptPtr; /* Script to invoke. */ Tcl_Interp *interp; /* In what interpreter to invoke script? */ int mask; /* Events must overlap current mask for the * stored script to be invoked. */ @@ -128,6 +136,25 @@ typedef struct Channel { * code, is dynamically allocated. */ int flags; /* ORed combination of the flags defined * below. */ + Tcl_Encoding encoding; /* Encoding to apply when reading or writing + * data on this channel. NULL means no + * encoding is applied to data. */ + Tcl_EncodingState inputEncodingState; + /* Current encoding state, used when converting + * input data bytes to UTF-8. */ + int inputEncodingFlags; /* Encoding flags to pass to conversion + * routine when converting input data bytes to + * UTF-8. May be TCL_ENCODING_START before + * converting first byte and TCL_ENCODING_END + * when EOF is seen. */ + Tcl_EncodingState outputEncodingState; + /* Current encoding state, used when converting + * UTF-8 to output data bytes. */ + int outputEncodingFlags; /* Encoding flags to pass to conversion + * routine when converting UTF-8 to output + * data bytes. May be TCL_ENCODING_START + * before converting first byte and + * TCL_ENCODING_END when EOF is seen. */ Tcl_EolTranslation inputTranslation; /* What translation to apply for end of line * sequences on input? */ @@ -142,12 +169,17 @@ typedef struct Channel { int unreportedError; /* Non-zero if an error report was deferred * because it happened in the background. The * value is the POSIX error code. */ - ClientData instanceData; /* Instance specific data. */ + ClientData instanceData; /* Instance-specific data provided by + * creator of channel. */ + Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ int refCount; /* How many interpreters hold references to * this IO channel? */ CloseCallback *closeCbPtr; /* Callbacks registered to be called when the * channel is closed. */ + char *outputStage; /* Temporary staging buffer used when + * translating EOL before converting from + * UTF-8 to external form. */ ChannelBuffer *curOutPtr; /* Current output buffer being filled. */ ChannelBuffer *outQueueHead;/* Points at first buffer in output queue. */ ChannelBuffer *outQueueTail;/* Points at last buffer in output queue. */ @@ -210,6 +242,9 @@ typedef struct Channel { #define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input * translation mode and the last * byte seen was a "\r". */ +#define INPUT_NEED_NL (1<<15) /* Saw a '\r' at end of last buffer, + * and there should be a '\n' at + * beginning of next buffer. */ #define CHANNEL_DEAD (1<<13) /* The channel has been closed by * the exit handler (on exit) but * not deallocated. When any IO @@ -217,11 +252,15 @@ typedef struct Channel { * channel, it does not call driver * level functions to avoid referring * to deallocated data. */ -#define CHANNEL_GETS_BLOCKED (1<<14) /* The last input operation was a gets - * that failed to get a comlete line. +#define CHANNEL_NEED_MORE_DATA (1<<14) /* The last input operation failed + * because there was not enough data + * to complete the operation. This + * flag is set when gets fails to + * get a complete line or when read + * fails to get a complete character. * When set, file events will not be - * delivered for buffered data unless - * an EOL is present. */ + * delivered for buffered data until + * the state of the channel changes. */ /* * For each channel handler registered in a call to Tcl_CreateChannelHandler, @@ -264,23 +303,6 @@ typedef struct NextChannelHandler { * ChannelHandlerEventProc. */ } NextChannelHandler; -/* - * This variable holds the list of nested ChannelHandlerEventProc invocations. - */ - -static NextChannelHandler *nestedHandlerPtr = (NextChannelHandler *) NULL; - -/* - * List of all channels currently open. - */ - -static Channel *firstChanPtr = (Channel *) NULL; - -/* - * Has a channel exit handler been created yet? - */ - -static int channelExitHandlerCreated = 0; /* * The following structure describes the event that is added to the Tcl @@ -294,31 +316,106 @@ typedef struct ChannelHandlerEvent { } ChannelHandlerEvent; /* - * Static variables to hold channels for stdin, stdout and stderr. + * The following structure is used by Tcl_GetsObj() to encapsulates the + * state for a "gets" operation. + */ + +typedef struct GetsState { + Tcl_Obj *objPtr; /* The object to which UTF-8 characters + * will be appended. */ + char **dstPtr; /* Pointer into objPtr's string rep where + * next character should be stored. */ + Tcl_Encoding encoding; /* The encoding to use to convert raw bytes + * to UTF-8. */ + ChannelBuffer *bufPtr; /* The current buffer of raw bytes being + * emptied. */ + Tcl_EncodingState state; /* The encoding state just before the last + * external to UTF-8 conversion in + * FilterInputBytes(). */ + int rawRead; /* The number of bytes removed from bufPtr + * in the last call to FilterInputBytes(). */ + int bytesWrote; /* The number of bytes of UTF-8 data + * appended to objPtr during the last call to + * FilterInputBytes(). */ + int charsWrote; /* The corresponding number of UTF-8 + * characters appended to objPtr during the + * last call to FilterInputBytes(). */ + int totalChars; /* The total number of UTF-8 characters + * appended to objPtr so far, just before the + * last call to FilterInputBytes(). */ +} GetsState; + +/* + * All static variables used in this file are collected into a single + * instance of the following structure. For multi-threaded implementations, + * there is one instance of this structure for each thread. + * + * Notice that different structures with the same name appear in other + * files. The structure defined below is used in this file only. */ -static Tcl_Channel stdinChannel = NULL; -static int stdinInitialized = 0; -static Tcl_Channel stdoutChannel = NULL; -static int stdoutInitialized = 0; -static Tcl_Channel stderrChannel = NULL; -static int stderrInitialized = 0; +typedef struct ThreadSpecificData { + + /* + * This variable holds the list of nested ChannelHandlerEventProc + * invocations. + */ + NextChannelHandler *nestedHandlerPtr; + + /* + * List of all channels currently open. + */ + Channel *firstChanPtr; +#ifdef oldcode + /* + * Has a channel exit handler been created yet? + */ + int channelExitHandlerCreated; + + /* + * Has the channel event source been created and registered with the + * notifier? + */ + int channelEventSourceCreated; +#endif + /* + * Static variables to hold channels for stdin, stdout and stderr. + */ + Tcl_Channel stdinChannel; + int stdinInitialized; + Tcl_Channel stdoutChannel; + int stdoutInitialized; + Tcl_Channel stderrChannel; + int stderrInitialized; + +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + /* * Static functions in this file: */ +static ChannelBuffer * AllocChannelBuffer _ANSI_ARGS_((int length)); static void ChannelEventScriptInvoker _ANSI_ARGS_(( ClientData clientData, int flags)); static void ChannelTimerProc _ANSI_ARGS_(( ClientData clientData)); +static int CheckChannelErrors _ANSI_ARGS_((Channel *chanPtr, + int direction)); +static int CheckFlush _ANSI_ARGS_((Channel *chanPtr, + ChannelBuffer *bufPtr, int newlineFlag)); +static int CheckForDeadChannel _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chan)); static void CheckForStdChannelsBeingClosed _ANSI_ARGS_(( Tcl_Channel chan)); static void CleanupChannelHandlers _ANSI_ARGS_(( Tcl_Interp *interp, Channel *chanPtr)); static int CloseChannel _ANSI_ARGS_((Tcl_Interp *interp, Channel *chanPtr, int errorCode)); -static void CloseChannelsOnExit _ANSI_ARGS_((ClientData data)); +static void CommonGetsCleanup _ANSI_ARGS_((Channel *chanPtr, + Tcl_Encoding encoding)); static int CopyAndTranslateBuffer _ANSI_ARGS_(( Channel *chanPtr, char *result, int space)); static int CopyData _ANSI_ARGS_((CopyState *csPtr, int mask)); @@ -326,7 +423,7 @@ static void CopyEventProc _ANSI_ARGS_((ClientData clientData, int mask)); static void CreateScriptRecord _ANSI_ARGS_(( Tcl_Interp *interp, Channel *chanPtr, - int mask, char *script)); + int mask, Tcl_Obj *scriptPtr)); static void DeleteChannelTable _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, @@ -337,73 +434,162 @@ static void DiscardOutputQueued _ANSI_ARGS_(( Channel *chanPtr)); static int DoRead _ANSI_ARGS_((Channel *chanPtr, char *srcPtr, int slen)); -static int DoWrite _ANSI_ARGS_((Channel *chanPtr, char *srcPtr, - int slen)); +static int DoWrite _ANSI_ARGS_((Channel *chanPtr, char *src, + int srcLen)); +static int FilterInputBytes _ANSI_ARGS_((Channel *chanPtr, + GetsState *statePtr)); static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush)); -static Tcl_HashTable *GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp)); -static int GetEOL _ANSI_ARGS_((Channel *chanPtr)); +static Tcl_HashTable * GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp)); static int GetInput _ANSI_ARGS_((Channel *chanPtr)); +static void PeekAhead _ANSI_ARGS_((Channel *chanPtr, + char **dstEndPtr, GetsState *gsPtr)); +static int ReadBytes _ANSI_ARGS_((Channel *chanPtr, + Tcl_Obj *objPtr, int charsLeft, int *offsetPtr)); +static int ReadChars _ANSI_ARGS_((Channel *chanPtr, + Tcl_Obj *objPtr, int charsLeft, int *offsetPtr, + int *factorPtr)); static void RecycleBuffer _ANSI_ARGS_((Channel *chanPtr, ChannelBuffer *bufPtr, int mustDiscard)); -static int ScanBufferForEOL _ANSI_ARGS_((Channel *chanPtr, - ChannelBuffer *bufPtr, - Tcl_EolTranslation translation, int eofChar, - int *bytesToEOLPtr, int *crSeenPtr)); -static int ScanInputForEOL _ANSI_ARGS_((Channel *chanPtr, - int *bytesQueuedPtr)); static int SetBlockMode _ANSI_ARGS_((Tcl_Interp *interp, Channel *chanPtr, int mode)); static void StopCopy _ANSI_ARGS_((CopyState *csPtr)); +static int TranslateInputEOL _ANSI_ARGS_((Channel *chanPtr, + char *dst, CONST char *src, int *dstLenPtr, + int *srcLenPtr)); +static int TranslateOutputEOL _ANSI_ARGS_((Channel *chanPtr, + char *dst, CONST char *src, int *dstLenPtr, + int *srcLenPtr)); static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr)); -static int CheckForDeadChannel _ANSI_ARGS_((Tcl_Interp *interp, - Channel *chan)); +static int WriteBytes _ANSI_ARGS_((Channel *chanPtr, + CONST char *src, int srcLen)); +static int WriteChars _ANSI_ARGS_((Channel *chanPtr, + CONST char *src, int srcLen)); + /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * SetBlockMode -- + * TclInitIOSubsystem -- * - * This function sets the blocking mode for a channel and updates - * the state flags. + * Initialize all resources used by this subsystem on a per-process + * basis. * * Results: - * A standard Tcl result. + * None. * * Side effects: - * Modifies the blocking mode of the channel and possibly generates - * an error. + * Depends on the memory subsystems. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -static int -SetBlockMode(interp, chanPtr, mode) - Tcl_Interp *interp; /* Interp for error reporting. */ - Channel *chanPtr; /* Channel to modify. */ - int mode; /* One of TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ +void +TclInitIOSubsystem() { - int result = 0; - if (chanPtr->typePtr->blockModeProc != NULL) { - result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, - mode); - } - if (result != 0) { - Tcl_SetErrno(result); - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "error setting blocking mode: ", - Tcl_PosixError(interp), (char *) NULL); - } - return TCL_ERROR; - } - if (mode == TCL_MODE_BLOCKING) { - chanPtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED)); - } else { - chanPtr->flags |= CHANNEL_NONBLOCKING; + /* + * By fetching thread local storage we take care of + * allocating it for each thread. + */ + (void) TCL_TSD_INIT(&dataKey); +} + +/* + *------------------------------------------------------------------------- + * + * TclFinalizeIOSubsystem -- + * + * Releases all resources used by this subsystem on a per-process + * basis. Closes all extant channels that have not already been + * closed because they were not owned by any interp. + * + * Results: + * None. + * + * Side effects: + * Depends on encoding and memory subsystems. + * + *------------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TclFinalizeIOSubsystem() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Channel *chanPtr; /* Iterates over open channels. */ + Channel *nextChanPtr; /* Iterates over open channels. */ + + + for (chanPtr = tsdPtr->firstChanPtr; chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + + /* + * Set the channel back into blocking mode to ensure that we wait + * for all data to flush out. + */ + + (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, + "-blocking", "on"); + + if ((chanPtr == (Channel *) tsdPtr->stdinChannel) || + (chanPtr == (Channel *) tsdPtr->stdoutChannel) || + (chanPtr == (Channel *) tsdPtr->stderrChannel)) { + + /* + * Decrement the refcount which was earlier artificially bumped + * up to keep the channel from being closed. + */ + + chanPtr->refCount--; + } + + if (chanPtr->refCount <= 0) { + + /* + * Close it only if the refcount indicates that the channel is not + * referenced from any interpreter. If it is, that interpreter will + * close the channel when it gets destroyed. + */ + + (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + + } else { + + /* + * The refcount is greater than zero, so flush the channel. + */ + + Tcl_Flush((Tcl_Channel) chanPtr); + + /* + * Call the device driver to actually close the underlying + * device for this channel. + */ + + if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { + (chanPtr->typePtr->closeProc)(chanPtr->instanceData, + (Tcl_Interp *) NULL); + } else { + (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, + (Tcl_Interp *) NULL, 0); + } + + /* + * Finally, we clean up the fields in the channel data structure + * since all of them have been deleted already. We mark the + * channel with CHANNEL_DEAD to prevent any further IO operations + * on it. + */ + + chanPtr->instanceData = (ClientData) NULL; + chanPtr->flags |= CHANNEL_DEAD; + } } - return TCL_OK; } + + /* *---------------------------------------------------------------------- @@ -427,18 +613,19 @@ Tcl_SetStdChannel(channel, type) Tcl_Channel channel; int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); switch (type) { case TCL_STDIN: - stdinInitialized = 1; - stdinChannel = channel; + tsdPtr->stdinInitialized = 1; + tsdPtr->stdinChannel = channel; break; case TCL_STDOUT: - stdoutInitialized = 1; - stdoutChannel = channel; + tsdPtr->stdoutInitialized = 1; + tsdPtr->stdoutChannel = channel; break; case TCL_STDERR: - stderrInitialized = 1; - stderrChannel = channel; + tsdPtr->stderrInitialized = 1; + tsdPtr->stderrChannel = channel; break; } } @@ -459,28 +646,25 @@ Tcl_SetStdChannel(channel, type) * *---------------------------------------------------------------------- */ - Tcl_Channel Tcl_GetStdChannel(type) int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ { Tcl_Channel channel = NULL; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * If the channels were not created yet, create them now and - * store them in the static variables. Note that we need to set - * stdinInitialized before calling TclGetDefaultStdChannel in order - * to avoid recursive loops when TclGetDefaultStdChannel calls - * Tcl_CreateChannel. + * store them in the static variables. */ switch (type) { case TCL_STDIN: - if (!stdinInitialized) { - stdinChannel = TclGetDefaultStdChannel(TCL_STDIN); - stdinInitialized = 1; + if (!tsdPtr->stdinInitialized) { + tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN); + tsdPtr->stdinInitialized = 1; - /* + /* * Artificially bump the refcount to ensure that the channel * is only closed on exit. * @@ -489,58 +673,39 @@ Tcl_GetStdChannel(type) * to the standard input. */ - if (stdinChannel != (Tcl_Channel) NULL) { + if (tsdPtr->stdinChannel != (Tcl_Channel) NULL) { (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - stdinChannel); + tsdPtr->stdinChannel); } } - channel = stdinChannel; + channel = tsdPtr->stdinChannel; break; case TCL_STDOUT: - if (!stdoutInitialized) { - stdoutChannel = TclGetDefaultStdChannel(TCL_STDOUT); - stdoutInitialized = 1; - - /* - * Artificially bump the refcount to ensure that the channel - * is only closed on exit. - * - * NOTE: Must only do this if stdoutChannel is not NULL. It - * can be NULL in situations where Tcl is unable to connect - * to the standard output. - */ - - if (stdoutChannel != (Tcl_Channel) NULL) { + if (!tsdPtr->stdoutInitialized) { + tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT); + tsdPtr->stdoutInitialized = 1; + if (tsdPtr->stdoutChannel != (Tcl_Channel) NULL) { (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - stdoutChannel); + tsdPtr->stdoutChannel); } } - channel = stdoutChannel; + channel = tsdPtr->stdoutChannel; break; case TCL_STDERR: - if (!stderrInitialized) { - stderrChannel = TclGetDefaultStdChannel(TCL_STDERR); - stderrInitialized = 1; - - /* - * Artificially bump the refcount to ensure that the channel - * is only closed on exit. - * - * NOTE: Must only do this if stderrChannel is not NULL. It - * can be NULL in situations where Tcl is unable to connect - * to the standard error. - */ - - if (stderrChannel != (Tcl_Channel) NULL) { + if (!tsdPtr->stderrInitialized) { + tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); + tsdPtr->stderrInitialized = 1; + if (tsdPtr->stderrChannel != (Tcl_Channel) NULL) { (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - stderrChannel); + tsdPtr->stderrChannel); } } - channel = stderrChannel; + channel = tsdPtr->stderrChannel; break; } return channel; } + /* *---------------------------------------------------------------------- @@ -632,109 +797,6 @@ Tcl_DeleteCloseHandler(chan, proc, clientData) /* *---------------------------------------------------------------------- * - * CloseChannelsOnExit -- - * - * Closes all the existing channels, on exit. This routine is called - * during exit processing. - * - * Results: - * None. - * - * Side effects: - * Closes all channels. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -CloseChannelsOnExit(clientData) - ClientData clientData; /* NULL - unused. */ -{ - Channel *chanPtr; /* Iterates over open channels. */ - Channel *nextChanPtr; /* Iterates over open channels. */ - - - for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL; - chanPtr = nextChanPtr) { - nextChanPtr = chanPtr->nextChanPtr; - - /* - * Set the channel back into blocking mode to ensure that we wait - * for all data to flush out. - */ - - (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, - "-blocking", "on"); - - if ((chanPtr == (Channel *) stdinChannel) || - (chanPtr == (Channel *) stdoutChannel) || - (chanPtr == (Channel *) stderrChannel)) { - - /* - * Decrement the refcount which was earlier artificially bumped - * up to keep the channel from being closed. - */ - - chanPtr->refCount--; - } - - if (chanPtr->refCount <= 0) { - - /* - * Close it only if the refcount indicates that the channel is not - * referenced from any interpreter. If it is, that interpreter will - * close the channel when it gets destroyed. - */ - - (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - - } else { - - /* - * The refcount is greater than zero, so flush the channel. - */ - - Tcl_Flush((Tcl_Channel) chanPtr); - - /* - * Call the device driver to actually close the underlying - * device for this channel. - */ - - (chanPtr->typePtr->closeProc) (chanPtr->instanceData, - (Tcl_Interp *) NULL); - - /* - * Finally, we clean up the fields in the channel data structure - * since all of them have been deleted already. We mark the - * channel with CHANNEL_DEAD to prevent any further IO operations - * on it. - */ - - chanPtr->instanceData = (ClientData) NULL; - chanPtr->flags |= CHANNEL_DEAD; - } - } - - /* - * Reinitialize all the variables to the initial state: - */ - - firstChanPtr = (Channel *) NULL; - nestedHandlerPtr = (NextChannelHandler *) NULL; - channelExitHandlerCreated = 0; - stdinChannel = NULL; - stdinInitialized = 0; - stdoutChannel = NULL; - stdoutInitialized = 0; - stderrChannel = NULL; - stderrInitialized = 0; -} - -/* - *---------------------------------------------------------------------- - * * GetChannelTable -- * * Gets and potentially initializes the channel table for an @@ -859,7 +921,7 @@ DeleteChannelTable(clientData, interp) Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, ChannelEventScriptInvoker, (ClientData) sPtr); - ckfree(sPtr->script); + Tcl_DecrRefCount(sPtr->scriptPtr); ckfree((char *) sPtr); } else { prevPtr = sPtr; @@ -912,23 +974,24 @@ CheckForStdChannelsBeingClosed(chan) Tcl_Channel chan; { Channel *chanPtr = (Channel *) chan; - - if ((chan == stdinChannel) && (stdinInitialized)) { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if ((chan == tsdPtr->stdinChannel) && (tsdPtr->stdinInitialized)) { if (chanPtr->refCount < 2) { chanPtr->refCount = 0; - stdinChannel = NULL; + tsdPtr->stdinChannel = NULL; return; } - } else if ((chan == stdoutChannel) && (stdoutInitialized)) { + } else if ((chan == tsdPtr->stdoutChannel) && (tsdPtr->stdoutInitialized)) { if (chanPtr->refCount < 2) { chanPtr->refCount = 0; - stdoutChannel = NULL; + tsdPtr->stdoutChannel = NULL; return; } - } else if ((chan == stderrChannel) && (stderrInitialized)) { + } else if ((chan == tsdPtr->stderrChannel) && (tsdPtr->stderrInitialized)) { if (chanPtr->refCount < 2) { chanPtr->refCount = 0; - stderrChannel = NULL; + tsdPtr->stderrChannel = NULL; return; } } @@ -937,6 +1000,54 @@ CheckForStdChannelsBeingClosed(chan) /* *---------------------------------------------------------------------- * + * Tcl_RegisterChannel -- + * + * Adds an already-open channel to the channel table of an interpreter. + * If the interpreter passed as argument is NULL, it only increments + * the channel refCount. + * + * Results: + * None. + * + * Side effects: + * May increment the reference count of a channel. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_RegisterChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which to add the channel. */ + Tcl_Channel chan; /* The channel to add to this interpreter + * channel table. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + int new; /* Is the hash entry new or does it exist? */ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + + if (chanPtr->channelName == (char *) NULL) { + panic("Tcl_RegisterChannel: channel without name"); + } + if (interp != (Tcl_Interp *) NULL) { + hTblPtr = GetChannelTable(interp); + hPtr = Tcl_CreateHashEntry(hTblPtr, chanPtr->channelName, &new); + if (new == 0) { + if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { + return; + } + panic("Tcl_RegisterChannel: duplicate channel names"); + } + Tcl_SetHashValue(hPtr, (ClientData) chanPtr); + } + chanPtr->refCount++; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_UnregisterChannel -- * * Deletes the hash entry for a channel associated with an interpreter. @@ -1027,55 +1138,7 @@ Tcl_UnregisterChannel(interp, chan) } /* - *---------------------------------------------------------------------- - * - * Tcl_RegisterChannel -- - * - * Adds an already-open channel to the channel table of an interpreter. - * If the interpreter passed as argument is NULL, it only increments - * the channel refCount. - * - * Results: - * None. - * - * Side effects: - * May increment the reference count of a channel. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_RegisterChannel(interp, chan) - Tcl_Interp *interp; /* Interpreter in which to add the channel. */ - Tcl_Channel chan; /* The channel to add to this interpreter - * channel table. */ -{ - Tcl_HashTable *hTblPtr; /* Hash table of channels. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - int new; /* Is the hash entry new or does it exist? */ - Channel *chanPtr; /* The actual channel. */ - - chanPtr = (Channel *) chan; - - if (chanPtr->channelName == (char *) NULL) { - panic("Tcl_RegisterChannel: channel without name"); - } - if (interp != (Tcl_Interp *) NULL) { - hTblPtr = GetChannelTable(interp); - hPtr = Tcl_CreateHashEntry(hTblPtr, chanPtr->channelName, &new); - if (new == 0) { - if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { - return; - } - panic("Tcl_RegisterChannel: duplicate channel names"); - } - Tcl_SetHashValue(hPtr, (ClientData) chanPtr); - } - chanPtr->refCount++; -} - -/* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_GetChannel -- * @@ -1084,14 +1147,14 @@ Tcl_RegisterChannel(interp, chan) * channel-type-specific functions. * * Results: - * A Tcl_Channel or NULL on failure. If failed, interp->result - * contains an error message. It also returns, in modePtr, the - * modes in which the channel is opened. + * A Tcl_Channel or NULL on failure. If failed, interp's result + * object contains an error message. *modePtr is filled with the + * modes in which the channel was opened. * * Side effects: * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ Tcl_Channel @@ -1175,6 +1238,8 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) * if the channel is readable, writable. */ { Channel *chanPtr; /* The channel structure newly created. */ + CONST char *name; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); @@ -1188,6 +1253,20 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) chanPtr->flags = mask; /* + * Set the channel to system default encoding. + */ + + chanPtr->encoding = NULL; + name = Tcl_GetEncodingName(NULL); + if (strcmp(name, "binary") != 0) { + chanPtr->encoding = Tcl_GetEncoding(NULL, name); + } + chanPtr->inputEncodingState = NULL; + chanPtr->inputEncodingFlags = TCL_ENCODING_START; + chanPtr->outputEncodingState = NULL; + chanPtr->outputEncodingFlags = TCL_ENCODING_START; + + /* * Set the channel up initially in AUTO input translation mode to * accept "\n", "\r" and "\r\n". Output translation mode is set to * a platform specific default value. The eofChar is set to 0 for both @@ -1218,32 +1297,33 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) chanPtr->timer = NULL; chanPtr->csPtr = NULL; + chanPtr->outputStage = NULL; + if ((chanPtr->encoding != NULL) && (chanPtr->flags & TCL_WRITABLE)) { + chanPtr->outputStage = (char *) + ckalloc((unsigned) (chanPtr->bufSize + 2)); + } + /* * Link the channel into the list of all channels; create an on-exit * handler if there is not one already, to close off all the channels * in the list on exit. */ - chanPtr->nextChanPtr = firstChanPtr; - firstChanPtr = chanPtr; + chanPtr->nextChanPtr = tsdPtr->firstChanPtr; + tsdPtr->firstChanPtr = chanPtr; - if (!channelExitHandlerCreated) { - channelExitHandlerCreated = 1; - Tcl_CreateExitHandler(CloseChannelsOnExit, (ClientData) NULL); - } - /* * Install this channel in the first empty standard channel slot, if * the channel was previously closed explicitly. */ - if ((stdinChannel == NULL) && (stdinInitialized == 1)) { + if ((tsdPtr->stdinChannel == NULL) && (tsdPtr->stdinInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDIN); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - } else if ((stdoutChannel == NULL) && (stdoutInitialized == 1)) { + } else if ((tsdPtr->stdoutChannel == NULL) && (tsdPtr->stdoutInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDOUT); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - } else if ((stderrChannel == NULL) && (stderrInitialized == 1)) { + } else if ((tsdPtr->stderrChannel == NULL) && (tsdPtr->stderrInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDERR); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); } @@ -1395,6 +1475,47 @@ Tcl_GetChannelInstanceData(chan) } /* + *--------------------------------------------------------------------------- + * + * AllocChannelBuffer -- + * + * A channel buffer has BUFFER_PADDING bytes extra at beginning to + * hold any bytes of a native-encoding character that got split by + * the end of the previous buffer and need to be moved to the + * beginning of the next buffer to make a contiguous string so it + * can be converted to UTF-8. + * + * A channel buffer has BUFFER_PADDING bytes extra at the end to + * hold any bytes of a native-encoding character (generated from a + * UTF-8 character) that overflow past the end of the buffer and + * need to be moved to the next buffer. + * + * Results: + * A newly allocated channel buffer. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static ChannelBuffer * +AllocChannelBuffer(length) + int length; /* Desired length of channel buffer. */ +{ + ChannelBuffer *bufPtr; + int n; + + n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING; + bufPtr = (ChannelBuffer *) ckalloc((unsigned) n); + bufPtr->nextAdded = BUFFER_PADDING; + bufPtr->nextRemoved = BUFFER_PADDING; + bufPtr->bufLength = length + BUFFER_PADDING; + bufPtr->nextPtr = (ChannelBuffer *) NULL; + return bufPtr; +} + +/* *---------------------------------------------------------------------- * * RecycleBuffer -- @@ -1465,8 +1586,8 @@ RecycleBuffer(chanPtr, bufPtr, mustDiscard) return; keepit: - bufPtr->nextRemoved = 0; - bufPtr->nextAdded = 0; + bufPtr->nextRemoved = BUFFER_PADDING; + bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextPtr = (ChannelBuffer *) NULL; } @@ -1570,9 +1691,10 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) * buffer available to be written. */ int written; /* Amount of output data actually * written in current round. */ - int errorCode; /* Stores POSIX error codes from + int errorCode = 0; /* Stores POSIX error codes from * channel driver operations. */ - errorCode = 0; + int wroteSome = 0; /* Set to one if any data was + * written to the driver. */ /* * Prevent writing on a dead channel -- a channel that has been closed @@ -1597,7 +1719,7 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) */ if (((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && - (chanPtr->curOutPtr->nextAdded == chanPtr->curOutPtr->bufSize)) + (chanPtr->curOutPtr->nextAdded == chanPtr->curOutPtr->bufLength)) || ((chanPtr->flags & BUFFER_READY) && (chanPtr->outQueueHead == (ChannelBuffer *) NULL))) { chanPtr->flags &= (~(BUFFER_READY)); @@ -1636,7 +1758,8 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) toWrite = bufPtr->nextAdded - bufPtr->nextRemoved; written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData, - bufPtr->buf + bufPtr->nextRemoved, toWrite, &errorCode); + (char *) bufPtr->buf + bufPtr->nextRemoved, toWrite, + &errorCode); /* * If the write failed completely attempt to start the asynchronous @@ -1696,7 +1819,9 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) DiscardOutputQueued(chanPtr); continue; - } + } else { + wroteSome = 1; + } bufPtr->nextRemoved += written; @@ -1712,17 +1837,22 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) RecycleBuffer(chanPtr, bufPtr, 0); } } /* Closes "while (1)". */ - + /* - * If the queue became empty and we have the asynchronous flushing - * mechanism active, cancel the asynchronous flushing. + * If we wrote some data while flushing in the background, we are done. + * We can't finish the background flush until we run out of data and + * the channel becomes writable again. This ensures that all of the + * pending data has been flushed at the system level. */ - if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && - (chanPtr->flags & BG_FLUSH_SCHEDULED)) { - chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); - (chanPtr->typePtr->watchProc)(chanPtr->instanceData, - chanPtr->interestMask); + if (chanPtr->flags & BG_FLUSH_SCHEDULED) { + if (wroteSome) { + return errorCode; + } else if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + (chanPtr->typePtr->watchProc)(chanPtr->instanceData, + chanPtr->interestMask); + } } /* @@ -1769,7 +1899,8 @@ CloseChannel(interp, chanPtr, errorCode) Channel *prevChanPtr; /* Preceding channel in list of * all channels - used to splice a * channel out of the list on close. */ - + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + if (chanPtr == NULL) { return result; } @@ -1825,10 +1956,10 @@ CloseChannel(interp, chanPtr, errorCode) * Splice this channel out of the list of all channels. */ - if (chanPtr == firstChanPtr) { - firstChanPtr = chanPtr->nextChanPtr; + if (chanPtr == tsdPtr->firstChanPtr) { + tsdPtr->firstChanPtr = chanPtr->nextChanPtr; } else { - for (prevChanPtr = firstChanPtr; + for (prevChanPtr = tsdPtr->firstChanPtr; (prevChanPtr != (Channel *) NULL) && (prevChanPtr->nextChanPtr != chanPtr); prevChanPtr = prevChanPtr->nextChanPtr) { @@ -1841,14 +1972,23 @@ CloseChannel(interp, chanPtr, errorCode) } /* - * OK, close the channel itself. + * Close and free the channel driver state. */ - - result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp); + + if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { + result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, interp); + } else { + result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp, + 0); + } if (chanPtr->channelName != (char *) NULL) { ckfree(chanPtr->channelName); } + Tcl_FreeEncoding(chanPtr->encoding); + if (chanPtr->outputStage != NULL) { + ckfree((char *) chanPtr->outputStage); + } /* * If we are being called synchronously, report either @@ -1918,6 +2058,7 @@ Tcl_Close(interp, chan) EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */ Channel *chanPtr; /* The real IO channel. */ int result; /* Of calling FlushChannel. */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); NextChannelHandler *nhPtr; if (chan == (Tcl_Channel) NULL) { @@ -1944,7 +2085,7 @@ Tcl_Close(interp, chan) * may be about to be invoked. */ - for (nhPtr = nestedHandlerPtr; + for (nhPtr = tsdPtr->nestedHandlerPtr; nhPtr != (NextChannelHandler *) NULL; nhPtr = nhPtr->nestedHandlerPtr) { if (nhPtr->nextHandlerPtr && @@ -1990,7 +2131,7 @@ Tcl_Close(interp, chan) ePtr != (EventScriptRecord *) NULL; ePtr = eNextPtr) { eNextPtr = ePtr->nextPtr; - ckfree(ePtr->script); + Tcl_DecrRefCount(ePtr->scriptPtr); ckfree((char *) ePtr); } chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; @@ -2016,17 +2157,27 @@ Tcl_Close(interp, chan) } /* + * If this channel supports it, close the read side, since we don't need it + * anymore and this will help avoid deadlocks on some channel types. + */ + + if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) { + result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp, + TCL_CLOSE_READ); + } else { + result = 0; + } + + /* * The call to FlushChannel will flush any queued output and invoke * the close function of the channel driver, or it will set up the * channel to be flushed and closed asynchronously. */ - + chanPtr->flags |= CHANNEL_CLOSED; - result = FlushChannel(interp, chanPtr, 0); - if (result != 0) { + if ((FlushChannel(interp, chanPtr, 0) != 0) || (result != 0)) { return TCL_ERROR; } - return TCL_OK; } @@ -2035,7 +2186,7 @@ Tcl_Close(interp, chan) * * Tcl_Write -- * - * Puts a sequence of characters into an output buffer, may queue the + * Puts a sequence of bytes into an output buffer, may queue the * buffer for output if it gets full, and also remembers whether the * current buffer is ready e.g. if it contains a newline and we are in * line buffering mode. @@ -2052,61 +2203,133 @@ Tcl_Close(interp, chan) */ int -Tcl_Write(chan, srcPtr, slen) +Tcl_Write(chan, src, srcLen) Tcl_Channel chan; /* The channel to buffer output for. */ - char *srcPtr; /* Output to buffer. */ - int slen; /* Its length. Negative means - * the output is null terminated - * and we must compute its length. */ + char *src; /* Data to queue in output buffer. */ + int srcLen; /* Length of data in bytes, or < 0 for + * strlen(). */ { - Channel *chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ + Channel *chanPtr; - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) { + return -1; } - - /* - * If the channel is not open for writing punt. - */ - - if (!(chanPtr->flags & TCL_WRITABLE)) { - Tcl_SetErrno(EACCES); - return -1; + if (srcLen < 0) { + srcLen = strlen(src); } - - /* - * If the channel is in the middle of a background copy, fail. - */ + return DoWrite(chanPtr, src, srcLen); +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_WriteChars -- + * + * Takes a sequence of UTF-8 characters and converts them for output + * using the channel's current encoding, may queue the buffer for + * output if it gets full, and also remembers whether the current + * buffer is ready e.g. if it contains a newline and we are in + * line buffering mode. + * + * Results: + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. + * + * Side effects: + * May buffer up output and may cause output to be produced on the + * channel. + * + *---------------------------------------------------------------------- + */ - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); +int +Tcl_WriteChars(chan, src, len) + Tcl_Channel chan; /* The channel to buffer output for. */ + CONST char *src; /* UTF-8 characters to queue in output buffer. */ + int len; /* Length of string in bytes, or < 0 for + * strlen(). */ +{ + Channel *chanPtr; + + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) { return -1; } + if (len < 0) { + len = strlen(src); + } + if (chanPtr->encoding == NULL) { + /* + * Inefficient way to convert UTF-8 to byte-array, but the + * code parallels the way it is done for objects. + */ - /* - * If length passed is negative, assume that the output is null terminated - * and compute its length. - */ - - if (slen < 0) { - slen = strlen(srcPtr); + Tcl_Obj *objPtr; + int result; + + objPtr = Tcl_NewStringObj(src, len); + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); + result = WriteBytes(chanPtr, src, len); + Tcl_DecrRefCount(objPtr); + return result; } + return WriteChars(chanPtr, src, len); +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_WriteObj -- + * + * Takes the Tcl object and queues its contents for output. If the + * encoding of the channel is NULL, takes the byte-array representation + * of the object and queues those bytes for output. Otherwise, takes + * the characters in the UTF-8 (string) representation of the object + * and converts them for output using the channel's current encoding. + * May flush internal buffers to output if one becomes full or is ready + * for some other reason, e.g. if it contains a newline and the channel + * is in line buffering mode. + * + * Results: + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno() will return the error code. + * + * Side effects: + * May buffer up output and may cause output to be produced on the + * channel. + * + *---------------------------------------------------------------------- + */ - return DoWrite(chanPtr, srcPtr, slen); +int +Tcl_WriteObj(chan, objPtr) + Tcl_Channel chan; /* The channel to buffer output for. */ + Tcl_Obj *objPtr; /* The object to write. */ +{ + Channel *chanPtr; + char *src; + int srcLen; + + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) { + return -1; + } + if (chanPtr->encoding == NULL) { + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen); + return WriteBytes(chanPtr, src, srcLen); + } else { + src = Tcl_GetStringFromObj(objPtr, &srcLen); + return WriteChars(chanPtr, src, srcLen); + } } /* *---------------------------------------------------------------------- * - * DoWrite -- + * WriteBytes -- * - * Puts a sequence of characters into an output buffer, may queue the + * Write a sequence of bytes into an output buffer, may queue the * buffer for output if it gets full, and also remembers whether the * current buffer is ready e.g. if it contains a newline and we are in * line buffering mode. @@ -2123,919 +2346,1090 @@ Tcl_Write(chan, srcPtr, slen) */ static int -DoWrite(chanPtr, srcPtr, slen) - Channel *chanPtr; /* The channel to buffer output for. */ - char *srcPtr; /* Data to write. */ - int slen; /* Number of bytes to write. */ +WriteBytes(chanPtr, src, srcLen) + Channel *chanPtr; /* The channel to buffer output for. */ + CONST char *src; /* Bytes to write. */ + int srcLen; /* Number of bytes to write. */ { - ChannelBuffer *outBufPtr; /* Current output buffer. */ - int foundNewline; /* Did we find a newline in output? */ - char *dPtr, *sPtr; /* Search variables for newline. */ - int crsent; /* In CRLF eol translation mode, - * remember the fact that a CR was - * output to the channel without - * its following NL. */ - int i; /* Loop index for newline search. */ - int destCopied; /* How many bytes were used in this - * destination buffer to hold the - * output? */ - int totalDestCopied; /* How many bytes total were - * copied to the channel buffer? */ - int srcCopied; /* How many bytes were copied from - * the source string? */ - char *destPtr; /* Where in line to copy to? */ + ChannelBuffer *bufPtr; + char *dst; + int dstLen, dstMax, sawLF, savedLF, total, toWrite; + + total = 0; + sawLF = 0; + savedLF = 0; /* - * If we are in network (or windows) translation mode, record the fact - * that we have not yet sent a CR to the channel. + * Loop over all bytes in src, storing them in output buffer with + * proper EOL translation. */ - crsent = 0; - - /* - * Loop filling buffers and flushing them until all output has been - * consumed. - */ + while (srcLen + savedLF > 0) { + bufPtr = chanPtr->curOutPtr; + if (bufPtr == NULL) { + bufPtr = AllocChannelBuffer(chanPtr->bufSize); + chanPtr->curOutPtr = bufPtr; + } + dst = bufPtr->buf + bufPtr->nextAdded; + dstMax = bufPtr->bufLength - bufPtr->nextAdded; + dstLen = dstMax; - srcCopied = 0; - totalDestCopied = 0; - - while (slen > 0) { - - /* - * Make sure there is a current output buffer to accept output. - */ - - if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { - chanPtr->curOutPtr = (ChannelBuffer *) ckalloc((unsigned) - (CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); - chanPtr->curOutPtr->nextAdded = 0; - chanPtr->curOutPtr->nextRemoved = 0; - chanPtr->curOutPtr->bufSize = chanPtr->bufSize; - chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; - } - - outBufPtr = chanPtr->curOutPtr; - - destCopied = outBufPtr->bufSize - outBufPtr->nextAdded; - if (destCopied > slen) { - destCopied = slen; - } - - destPtr = outBufPtr->buf + outBufPtr->nextAdded; - switch (chanPtr->outputTranslation) { - case TCL_TRANSLATE_LF: - srcCopied = destCopied; - memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); - break; - case TCL_TRANSLATE_CR: - srcCopied = destCopied; - memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); - for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { - if (*dPtr == '\n') { - *dPtr = '\r'; - } - } - break; - case TCL_TRANSLATE_CRLF: - for (srcCopied = 0, dPtr = destPtr, sPtr = srcPtr; - dPtr < destPtr + destCopied; - dPtr++, sPtr++, srcCopied++) { - if (*sPtr == '\n') { - if (crsent) { - *dPtr = '\n'; - crsent = 0; - } else { - *dPtr = '\r'; - crsent = 1; - sPtr--, srcCopied--; - } - } else { - *dPtr = *sPtr; - } - } - break; - case TCL_TRANSLATE_AUTO: - panic("Tcl_Write: AUTO output translation mode not supported"); - default: - panic("Tcl_Write: unknown output translation mode"); - } - - /* - * The current buffer is ready for output if it is full, or if it - * contains a newline and this channel is line-buffered, or if it - * contains any output and this channel is unbuffered. - */ + toWrite = dstLen; + if (toWrite > srcLen) { + toWrite = srcLen; + } - outBufPtr->nextAdded += destCopied; - if (!(chanPtr->flags & BUFFER_READY)) { - if (outBufPtr->nextAdded == outBufPtr->bufSize) { - chanPtr->flags |= BUFFER_READY; - } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) { - for (sPtr = srcPtr, i = 0, foundNewline = 0; - (i < srcCopied) && (!foundNewline); - i++, sPtr++) { - if (*sPtr == '\n') { - foundNewline = 1; - break; - } - } - if (foundNewline) { - chanPtr->flags |= BUFFER_READY; - } - } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { - chanPtr->flags |= BUFFER_READY; - } - } - - totalDestCopied += srcCopied; - srcPtr += srcCopied; - slen -= srcCopied; + if (savedLF) { + /* + * A '\n' was left over from last call to TranslateOutputEOL() + * and we need to store it in this buffer. If the channel is + * line-based, we will need to flush it. + */ - if (chanPtr->flags & BUFFER_READY) { - if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; - } - } - } /* Closes "while" */ + *dst++ = '\n'; + dstLen--; + sawLF++; + } + sawLF += TranslateOutputEOL(chanPtr, dst, src, &dstLen, &toWrite); + dstLen += savedLF; + savedLF = 0; - return totalDestCopied; + if (dstLen > dstMax) { + savedLF = 1; + dstLen = dstMax; + } + bufPtr->nextAdded += dstLen; + if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { + return -1; + } + total += dstLen; + src += toWrite; + srcLen -= toWrite; + sawLF = 0; + } + return total; } /* *---------------------------------------------------------------------- * - * Tcl_Flush -- + * WriteChars -- * - * Flushes output data on a channel. + * Convert UTF-8 bytes to the channel's external encoding and + * write the produced bytes into an output buffer, may queue the + * buffer for output if it gets full, and also remembers whether the + * current buffer is ready e.g. if it contains a newline and we are in + * line buffering mode. * * Results: - * A standard Tcl result. + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. * * Side effects: - * May flush output queued on this channel. + * May buffer up output and may cause output to be produced on the + * channel. * *---------------------------------------------------------------------- */ -int -Tcl_Flush(chan) - Tcl_Channel chan; /* The Channel to flush. */ +static int +WriteChars(chanPtr, src, srcLen) + Channel *chanPtr; /* The channel to buffer output for. */ + CONST char *src; /* UTF-8 string to write. */ + int srcLen; /* Length of UTF-8 string in bytes. */ { - int result; /* Of calling FlushChannel. */ - Channel *chanPtr; /* The actual channel. */ - - chanPtr = (Channel *) chan; + ChannelBuffer *bufPtr; + char *dst, *stage; + int saved, savedLF, sawLF, total, toWrite, flags; + int dstWrote, dstLen, stageLen, stageMax, stageRead; + Tcl_Encoding encoding; + char safe[BUFFER_PADDING]; + + total = 0; + sawLF = 0; + savedLF = 0; + saved = 0; + encoding = chanPtr->encoding; /* - * Check for unreported error. + * Loop over all UTF-8 characters in src, storing them in staging buffer + * with proper EOL translation. */ - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return TCL_ERROR; - } + while (srcLen + savedLF > 0) { + stage = chanPtr->outputStage; + stageMax = chanPtr->bufSize; + stageLen = stageMax; - /* - * If the channel is not open for writing punt. - */ + toWrite = stageLen; + if (toWrite > srcLen) { + toWrite = srcLen; + } - if (!(chanPtr->flags & TCL_WRITABLE)) { - Tcl_SetErrno(EACCES); - return TCL_ERROR; - } - - /* - * If the channel is in the middle of a background copy, fail. - */ + if (savedLF) { + /* + * A '\n' was left over from last call to TranslateOutputEOL() + * and we need to store it in the staging buffer. If the + * channel is line-based, we will need to flush the output + * buffer (after translating the staging buffer). + */ + + *stage++ = '\n'; + stageLen--; + sawLF++; + } + sawLF += TranslateOutputEOL(chanPtr, stage, src, &stageLen, &toWrite); - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; - } + stage -= savedLF; + stageLen += savedLF; + savedLF = 0; - /* - * Force current output buffer to be output also. - */ - - if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && - (chanPtr->curOutPtr->nextAdded > 0)) { - chanPtr->flags |= BUFFER_READY; - } - - result = FlushChannel(NULL, chanPtr, 0); - if (result != 0) { - return TCL_ERROR; - } + if (stageLen > stageMax) { + savedLF = 1; + stageLen = stageMax; + } + src += toWrite; + srcLen -= toWrite; - return TCL_OK; + flags = chanPtr->outputEncodingFlags; + if (srcLen == 0) { + flags |= TCL_ENCODING_END; + } + + /* + * Loop over all UTF-8 characters in staging buffer, converting them + * to external encoding, storing them in output buffer. + */ + + while (stageLen + saved > 0) { + bufPtr = chanPtr->curOutPtr; + if (bufPtr == NULL) { + bufPtr = AllocChannelBuffer(chanPtr->bufSize); + chanPtr->curOutPtr = bufPtr; + } + dst = bufPtr->buf + bufPtr->nextAdded; + dstLen = bufPtr->bufLength - bufPtr->nextAdded; + + if (saved != 0) { + /* + * Here's some translated bytes left over from the last + * buffer that we need to stick at the beginning of this + * buffer. + */ + + memcpy((VOID *) dst, (VOID *) safe, (size_t) saved); + bufPtr->nextAdded += saved; + dst += saved; + dstLen -= saved; + saved = 0; + } + + Tcl_UtfToExternal(NULL, encoding, stage, stageLen, flags, + &chanPtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL); + if (stageRead + dstWrote == 0) { + /* + * We have an incomplete UTF-8 character at the end of the + * staging buffer. It will get moved to the beginning of the + * staging buffer followed by more bytes from src. + */ + + src -= stageLen; + srcLen += stageLen; + stageLen = 0; + savedLF = 0; + break; + } + bufPtr->nextAdded += dstWrote; + if (bufPtr->nextAdded > bufPtr->bufLength) { + /* + * When translating from UTF-8 to external encoding, we + * allowed the translation to produce a character that + * crossed the end of the output buffer, so that we would + * get a completely full buffer before flushing it. The + * extra bytes will be moved to the beginning of the next + * buffer. + */ + + saved = bufPtr->nextAdded - bufPtr->bufLength; + memcpy((VOID *) safe, (VOID *) (dst + dstLen), (size_t) saved); + bufPtr->nextAdded = bufPtr->bufLength; + } + if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { + return -1; + } + + total += dstWrote; + stage += stageRead; + stageLen -= stageRead; + sawLF = 0; + } + } + return total; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * DiscardInputQueued -- + * TranslateOutputEOL -- * - * Discards any input read from the channel but not yet consumed - * by Tcl reading commands. + * Helper function for WriteBytes() and WriteChars(). Converts the + * '\n' characters in the source buffer into the appropriate EOL + * form specified by the output translation mode. + * + * EOL translation stops either when the source buffer is empty + * or the output buffer is full. + * + * When converting to CRLF mode and there is only 1 byte left in + * the output buffer, this routine stores the '\r' in the last + * byte and then stores the '\n' in the byte just past the end of the + * buffer. The caller is responsible for passing in a buffer that + * is large enough to hold the extra byte. * * Results: - * None. + * The return value is 1 if a '\n' was translated from the source + * buffer, or 0 otherwise -- this can be used by the caller to + * decide to flush a line-based channel even though the channel + * buffer is not full. + * + * *dstLenPtr is filled with how many bytes of the output buffer + * were used. As mentioned above, this can be one more that + * the output buffer's specified length if a CRLF was stored. + * + * *srcLenPtr is filled with how many bytes of the source buffer + * were consumed. * * Side effects: - * May discard input from the channel. If discardLastBuffer is zero, - * leaves one buffer in place for back-filling. + * It may be obvious, but bears mentioning that when converting + * in CRLF mode (which requires two bytes of storage in the output + * buffer), the number of bytes consumed from the source buffer + * will be less than the number of bytes stored in the output buffer. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -static void -DiscardInputQueued(chanPtr, discardSavedBuffers) - Channel *chanPtr; /* Channel on which to discard - * the queued input. */ - int discardSavedBuffers; /* If non-zero, discard all buffers including - * last one. */ +static int +TranslateOutputEOL(chanPtr, dst, src, dstLenPtr, srcLenPtr) + Channel *chanPtr; /* Channel being read, for translation and + * buffering modes. */ + char *dst; /* Output buffer filled with UTF-8 chars by + * applying appropriate EOL translation to + * source characters. */ + CONST char *src; /* Source UTF-8 characters. */ + int *dstLenPtr; /* On entry, the maximum length of output + * buffer in bytes. On exit, the number of + * bytes actually used in output buffer. */ + int *srcLenPtr; /* On entry, the length of source buffer. + * On exit, the number of bytes read from + * the source buffer. */ { - ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */ + char *dstEnd; + int srcLen, newlineFound; + + newlineFound = 0; + srcLen = *srcLenPtr; + + switch (chanPtr->outputTranslation) { + case TCL_TRANSLATE_LF: { + for (dstEnd = dst + srcLen; dst < dstEnd; ) { + if (*src == '\n') { + newlineFound = 1; + } + *dst++ = *src++; + } + *dstLenPtr = srcLen; + break; + } + case TCL_TRANSLATE_CR: { + for (dstEnd = dst + srcLen; dst < dstEnd;) { + if (*src == '\n') { + *dst++ = '\r'; + newlineFound = 1; + src++; + } else { + *dst++ = *src++; + } + } + *dstLenPtr = srcLen; + break; + } + case TCL_TRANSLATE_CRLF: { + /* + * Since this causes the number of bytes to grow, we + * start off trying to put 'srcLen' bytes into the + * output buffer, but allow it to store more bytes, as + * long as there's still source bytes and room in the + * output buffer. + */ - bufPtr = chanPtr->inQueueHead; - chanPtr->inQueueHead = (ChannelBuffer *) NULL; - chanPtr->inQueueTail = (ChannelBuffer *) NULL; - for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) { - nxtPtr = bufPtr->nextPtr; - RecycleBuffer(chanPtr, bufPtr, discardSavedBuffers); - } + char *dstStart, *dstMax; + CONST char *srcStart; + + dstStart = dst; + dstMax = dst + *dstLenPtr; - /* - * If discardSavedBuffers is nonzero, must also discard any previously - * saved buffer in the saveInBufPtr field. - */ - - if (discardSavedBuffers) { - if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { - ckfree((char *) chanPtr->saveInBufPtr); - chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; - } + srcStart = src; + + if (srcLen < *dstLenPtr) { + dstEnd = dst + srcLen; + } else { + dstEnd = dst + *dstLenPtr; + } + while (dst < dstEnd) { + if (*src == '\n') { + if (dstEnd < dstMax) { + dstEnd++; + } + *dst++ = '\r'; + newlineFound = 1; + } + *dst++ = *src++; + } + *srcLenPtr = src - srcStart; + *dstLenPtr = dst - dstStart; + break; + } + default: { + break; + } } + return newlineFound; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * GetInput -- + * CheckFlush -- * - * Reads input data from a device or file into an input buffer. + * Helper function for WriteBytes() and WriteChars(). If the + * channel buffer is ready to be flushed, flush it. * * Results: - * A Posix error code or 0. + * The return value is -1 if there was a problem flushing the + * channel buffer, or 0 otherwise. * * Side effects: - * Reads from the underlying device. + * The buffer will be recycled if it is flushed. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ static int -GetInput(chanPtr) - Channel *chanPtr; /* Channel to read input from. */ +CheckFlush(chanPtr, bufPtr, newlineFlag) + Channel *chanPtr; /* Channel being read, for buffering mode. */ + ChannelBuffer *bufPtr; /* Channel buffer to possibly flush. */ + int newlineFlag; /* Non-zero if a the channel buffer + * contains a newline. */ { - int toRead; /* How much to read? */ - int result; /* Of calling driver. */ - int nread; /* How much was read from channel? */ - ChannelBuffer *bufPtr; /* New buffer to add to input queue. */ - - /* - * Prevent reading from a dead channel -- a channel that has been closed - * but not yet deallocated, which can happen if the exit handler for - * channel cleanup has run but the channel is still registered in some - * interpreter. - */ - - if (CheckForDeadChannel(NULL,chanPtr)) return EINVAL; - /* - * See if we can fill an existing buffer. If we can, read only - * as much as will fit in it. Otherwise allocate a new buffer, - * add it to the input queue and attempt to fill it to the max. + * The current buffer is ready for output: + * 1. if it is full. + * 2. if it contains a newline and this channel is line-buffered. + * 3. if it contains any output and this channel is unbuffered. */ - if ((chanPtr->inQueueTail != (ChannelBuffer *) NULL) && - (chanPtr->inQueueTail->nextAdded < chanPtr->inQueueTail->bufSize)) { - bufPtr = chanPtr->inQueueTail; - toRead = bufPtr->bufSize - bufPtr->nextAdded; - } else { - if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { - bufPtr = chanPtr->saveInBufPtr; - chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; - } else { - bufPtr = (ChannelBuffer *) ckalloc( - ((unsigned) CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); - bufPtr->bufSize = chanPtr->bufSize; + if ((chanPtr->flags & BUFFER_READY) == 0) { + if (bufPtr->nextAdded == bufPtr->bufLength) { + chanPtr->flags |= BUFFER_READY; + } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + if (newlineFlag != 0) { + chanPtr->flags |= BUFFER_READY; + } + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + chanPtr->flags |= BUFFER_READY; } - bufPtr->nextRemoved = 0; - bufPtr->nextAdded = 0; - toRead = bufPtr->bufSize; - if (chanPtr->inQueueTail == (ChannelBuffer *) NULL) { - chanPtr->inQueueHead = bufPtr; - } else { - chanPtr->inQueueTail->nextPtr = bufPtr; - } - chanPtr->inQueueTail = bufPtr; - bufPtr->nextPtr = (ChannelBuffer *) NULL; - } - - /* - * If EOF is set, we should avoid calling the driver because on some - * platforms it is impossible to read from a device after EOF. - */ - - if (chanPtr->flags & CHANNEL_EOF) { - return 0; } - - nread = (chanPtr->typePtr->inputProc) (chanPtr->instanceData, - bufPtr->buf + bufPtr->nextAdded, toRead, &result); - - if (nread == 0) { - chanPtr->flags |= CHANNEL_EOF; - } else if (nread < 0) { - if ((result == EWOULDBLOCK) || (result == EAGAIN)) { - chanPtr->flags |= CHANNEL_BLOCKED; - result = EAGAIN; - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - Tcl_SetErrno(result); - } else { - panic("Blocking channel driver did not block on input"); - } - } else { - Tcl_SetErrno(result); - } - return result; - } else { - bufPtr->nextAdded += nread; - - /* - * If we get a short read, signal up that we may be BLOCKED. We - * should avoid calling the driver because on some platforms we - * will block in the low level reading code even though the - * channel is set into nonblocking mode. - */ - - if (nread < toRead) { - chanPtr->flags |= CHANNEL_BLOCKED; + if (chanPtr->flags & BUFFER_READY) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; } } return 0; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * CopyAndTranslateBuffer -- + * Tcl_Gets -- * - * Copy at most one buffer of input to the result space, doing - * eol translations according to mode in effect currently. + * Reads a complete line of input from the channel into a Tcl_DString. * * Results: - * Number of characters (as opposed to bytes) copied. May return - * zero if no input is available to be translated. + * Length of line read (in characters) or -1 if error, EOF, or blocked. + * If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the + * error or condition that occurred. * * Side effects: - * Consumes buffered input. May deallocate one buffer. + * May flush output on the channel. May cause input to be consumed + * from the channel. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -static int -CopyAndTranslateBuffer(chanPtr, result, space) - Channel *chanPtr; /* The channel from which to read input. */ - char *result; /* Where to store the copied input. */ - int space; /* How many bytes are available in result - * to store the copied input? */ +int +Tcl_Gets(chan, lineRead) + Tcl_Channel chan; /* Channel from which to read. */ + Tcl_DString *lineRead; /* The line read will be appended to this + * DString as UTF-8 characters. The caller + * must have initialized it and is responsible + * for managing the storage. */ { - int bytesInBuffer; /* How many bytes are available to be - * copied in the current input buffer? */ - int copied; /* How many characters were already copied - * into the destination space? */ - ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ - char curByte; /* The byte we are currently translating. */ - int i; /* Iterates over the copied input looking - * for the input eofChar. */ - - /* - * If there is no input at all, return zero. The invariant is that either - * there is no buffer in the queue, or if the first buffer is empty, it - * is also the last buffer (and thus there is no input in the queue). - * Note also that if the buffer is empty, we leave it in the queue. - */ - - if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { - return 0; + Tcl_Obj *objPtr; + int charsStored, length; + char *string; + + objPtr = Tcl_NewObj(); + charsStored = Tcl_GetsObj(chan, objPtr); + if (charsStored > 0) { + string = Tcl_GetStringFromObj(objPtr, &length); + Tcl_DStringAppend(lineRead, string, length); + } + Tcl_DecrRefCount(objPtr); + return charsStored; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_GetsObj -- + * + * Accumulate input from the input channel until end-of-line or + * end-of-file has been seen. Bytes read from the input channel + * are converted to UTF-8 using the encoding specified by the + * channel. + * + * Results: + * Number of characters accumulated in the object or -1 if error, + * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the + * POSIX error code for the error or condition that occurred. + * + * Side effects: + * Consumes input from the channel. + * + * On reading EOF, leave channel pointing at EOF char. + * On reading EOL, leave channel pointing after EOL, but don't + * return EOL in dst buffer. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_GetsObj(chan, objPtr) + Tcl_Channel chan; /* Channel from which to read. */ + Tcl_Obj *objPtr; /* The line read will be appended to this + * object as UTF-8 characters. */ +{ + GetsState gs; + Channel *chanPtr; + int inEofChar, skip, copiedTotal; + ChannelBuffer *bufPtr; + Tcl_Encoding encoding; + char *dst, *dstEnd, *eol, *eof; + Tcl_EncodingState oldState; + int oldLength, oldFlags, oldRemoved; + + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { + copiedTotal = -1; + goto done; } + bufPtr = chanPtr->inQueueHead; - bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; - if (bytesInBuffer < space) { - space = bytesInBuffer; + encoding = chanPtr->encoding; + + /* + * Preserved so we can restore the channel's state in case we don't + * find a newline in the available input. + */ + + Tcl_GetStringFromObj(objPtr, &oldLength); + oldFlags = chanPtr->inputEncodingFlags; + oldState = chanPtr->inputEncodingState; + oldRemoved = BUFFER_PADDING; + if (bufPtr != NULL) { + oldRemoved = bufPtr->nextRemoved; } - copied = 0; - switch (chanPtr->inputTranslation) { - case TCL_TRANSLATE_LF: - if (space == 0) { - return 0; - } - - /* - * Copy the current chunk into the result buffer. - */ + /* + * If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't + * produce ByteArray objects. To avoid circularity problems, + * "iso8859-1" is builtin to Tcl. + */ - memcpy((VOID *) result, - (VOID *)(bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - break; + if (encoding == NULL) { + encoding = Tcl_GetEncoding(NULL, "iso8859-1"); + } - case TCL_TRANSLATE_CR: + /* + * Object used by FilterInputBytes to keep track of how much data has + * been consumed from the channel buffers. + */ - if (space == 0) { - return 0; - } + gs.objPtr = objPtr; + gs.dstPtr = &dst; + gs.encoding = encoding; + gs.bufPtr = bufPtr; + gs.state = oldState; + gs.rawRead = 0; + gs.bytesWrote = 0; + gs.charsWrote = 0; + gs.totalChars = 0; - /* - * Copy the current chunk into the result buffer, then - * replace all \r with \n. - */ + dst = objPtr->bytes + oldLength; + dstEnd = dst; - memcpy((VOID *) result, - (VOID *)(bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - for (copied = 0; copied < space; copied++) { - if (result[copied] == '\r') { - result[copied] = '\n'; - } - } - break; + skip = 0; + eof = NULL; + inEofChar = chanPtr->inEofChar; - case TCL_TRANSLATE_CRLF: + while (1) { + if (dst >= dstEnd) { + if (FilterInputBytes(chanPtr, &gs) != 0) { + goto restore; + } + dstEnd = dst + gs.bytesWrote; + } + + /* + * Remember if EOF char is seen, then look for EOL anyhow, because + * the EOL might be before the EOF char. + */ - /* - * If there is a held-back "\r" at EOF, produce it now. - */ - - if (space == 0) { - if ((chanPtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == - (INPUT_SAW_CR | CHANNEL_EOF)) { - result[0] = '\r'; - chanPtr->flags &= (~(INPUT_SAW_CR)); - return 1; - } - return 0; - } + if (inEofChar != '\0') { + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == inEofChar) { + dstEnd = eol; + eof = eol; + break; + } + } + } - /* - * Copy the current chunk and replace "\r\n" with "\n" - * (but not standalone "\r"!). - */ + /* + * On EOL, leave current file position pointing after the EOL, but + * don't store the EOL in the output string. + */ - for (copied = 0; - (copied < space) && - (bufPtr->nextRemoved < bufPtr->nextAdded); - copied++) { - curByte = bufPtr->buf[bufPtr->nextRemoved]; - bufPtr->nextRemoved++; - if (curByte == '\r') { - if (chanPtr->flags & INPUT_SAW_CR) { - result[copied] = '\r'; - } else { - chanPtr->flags |= INPUT_SAW_CR; - copied--; - } - } else if (curByte == '\n') { - chanPtr->flags &= (~(INPUT_SAW_CR)); - result[copied] = '\n'; - } else { - if (chanPtr->flags & INPUT_SAW_CR) { - chanPtr->flags &= (~(INPUT_SAW_CR)); - result[copied] = '\r'; - bufPtr->nextRemoved--; - } else { - result[copied] = curByte; - } - } - } - break; - - case TCL_TRANSLATE_AUTO: - - if (space == 0) { - return 0; - } + eol = dst; + switch (chanPtr->inputTranslation) { + case TCL_TRANSLATE_LF: { + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\n') { + skip = 1; + goto goteol; + } + } + break; + } + case TCL_TRANSLATE_CR: { + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + skip = 1; + goto goteol; + } + } + break; + } + case TCL_TRANSLATE_CRLF: { + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + eol++; + if (eol >= dstEnd) { + int offset; + + offset = eol - objPtr->bytes; + dst = dstEnd; + if (FilterInputBytes(chanPtr, &gs) != 0) { + goto restore; + } + dstEnd = dst + gs.bytesWrote; + eol = objPtr->bytes + offset; + if (eol >= dstEnd) { + skip = 0; + goto goteol; + } + } + if (*eol == '\n') { + eol--; + skip = 2; + goto goteol; + } + } + } + break; + } + case TCL_TRANSLATE_AUTO: { + skip = 1; + if (chanPtr->flags & INPUT_SAW_CR) { + chanPtr->flags &= ~INPUT_SAW_CR; + if (*eol == '\n') { + /* + * Skip the raw bytes that make up the '\n'. + */ - /* - * Loop over the current buffer, converting "\r" and "\r\n" - * to "\n". - */ + char tmp[1 + TCL_UTF_MAX]; + int rawRead; + + bufPtr = gs.bufPtr; + Tcl_ExternalToUtf(NULL, gs.encoding, + bufPtr->buf + bufPtr->nextRemoved, + gs.rawRead, chanPtr->inputEncodingFlags, + &gs.state, tmp, 1 + TCL_UTF_MAX, &rawRead, + NULL, NULL); + bufPtr->nextRemoved += rawRead; + gs.rawRead -= rawRead; + gs.bytesWrote--; + gs.charsWrote--; + memmove(dst, dst + 1, (size_t) (dstEnd - dst)); + dstEnd--; + } + } + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + eol++; + if (eol == dstEnd) { + /* + * If buffer ended on \r, peek ahead to see if a + * \n is available. + */ + + int offset; + + offset = eol - objPtr->bytes; + dst = dstEnd; + PeekAhead(chanPtr, &dstEnd, &gs); + eol = objPtr->bytes + offset; + if (eol >= dstEnd) { + eol--; + chanPtr->flags |= INPUT_SAW_CR; + goto goteol; + } + } + if (*eol == '\n') { + skip++; + } + eol--; + goto goteol; + } else if (*eol == '\n') { + goto goteol; + } + } + } + } + if (eof != NULL) { + /* + * EOF character was seen. On EOF, leave current file position + * pointing at the EOF character, but don't store the EOF + * character in the output string. + */ - for (copied = 0; - (copied < space) && - (bufPtr->nextRemoved < bufPtr->nextAdded); ) { - curByte = bufPtr->buf[bufPtr->nextRemoved]; - bufPtr->nextRemoved++; - if (curByte == '\r') { - result[copied] = '\n'; - copied++; - if (bufPtr->nextRemoved < bufPtr->nextAdded) { - if (bufPtr->buf[bufPtr->nextRemoved] == '\n') { - bufPtr->nextRemoved++; - } - chanPtr->flags &= (~(INPUT_SAW_CR)); - } else { - chanPtr->flags |= INPUT_SAW_CR; - } - } else { - if (curByte == '\n') { - if (!(chanPtr->flags & INPUT_SAW_CR)) { - result[copied] = '\n'; - copied++; - } - } else { - result[copied] = curByte; - copied++; - } - chanPtr->flags &= (~(INPUT_SAW_CR)); - } - } - break; + dstEnd = eof; + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + chanPtr->inputEncodingFlags |= TCL_ENCODING_END; + } + if (chanPtr->flags & CHANNEL_EOF) { + skip = 0; + eol = dstEnd; + if (eol == objPtr->bytes) { + /* + * If we didn't produce any bytes before encountering EOF, + * caller needs to see -1. + */ - default: - panic("unknown eol translation mode"); + Tcl_SetObjLength(objPtr, 0); + CommonGetsCleanup(chanPtr, encoding); + copiedTotal = -1; + goto done; + } + goto goteol; + } + dst = dstEnd; } /* - * If an in-stream EOF character is set for this channel,, check that - * the input we copied so far does not contain the EOF char. If it does, - * copy only up to and excluding that character. + * Found EOL or EOF, but the output buffer may now contain too many + * UTF-8 characters. We need to know how many raw bytes correspond to + * the number of UTF-8 characters we want, plus how many raw bytes + * correspond to the character(s) making up EOL (if any), so we can + * remove the correct number of bytes from the channel buffer. */ - - if (chanPtr->inEofChar != 0) { - for (i = 0; i < copied; i++) { - if (result[i] == (char) chanPtr->inEofChar) { - break; - } - } - if (i < copied) { + + goteol: + bufPtr = gs.bufPtr; + chanPtr->inputEncodingState = gs.state; + Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved, + gs.rawRead, chanPtr->inputEncodingFlags, + &chanPtr->inputEncodingState, dst, eol - dst + skip + TCL_UTF_MAX, + &gs.rawRead, NULL, &gs.charsWrote); + bufPtr->nextRemoved += gs.rawRead; - /* - * Set sticky EOF so that no further input is presented - * to the caller. - */ - - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + /* + * Recycle all the emptied buffers. + */ - /* - * Reset the start of valid data in the input buffer to the - * position of the eofChar, so that subsequent reads will - * encounter it immediately. First we set it to the position - * of the last byte consumed if all result bytes were the - * product of one input byte; since it is possible that "\r\n" - * contracted to "\n" in the result, we have to search back - * from that position until we find the eofChar, because it - * is possible that its actual position in the buffer is n - * bytes further back (n is the number of "\r\n" sequences - * that were contracted to "\n" in the result). - */ - - bufPtr->nextRemoved -= (copied - i); - while ((bufPtr->nextRemoved > 0) && - (bufPtr->buf[bufPtr->nextRemoved] != - (char) chanPtr->inEofChar)) { - bufPtr->nextRemoved--; - } - copied = i; - } - } + Tcl_SetObjLength(objPtr, eol - objPtr->bytes); + CommonGetsCleanup(chanPtr, encoding); + chanPtr->flags &= ~CHANNEL_BLOCKED; + copiedTotal = gs.totalChars + gs.charsWrote - skip; + goto done; /* - * If the current buffer is empty recycle it. + * Couldn't get a complete line. This only happens if we get a error + * reading from the channel or we are non-blocking and there wasn't + * an EOL or EOF in the data available. */ - if (bufPtr->nextRemoved == bufPtr->nextAdded) { - chanPtr->inQueueHead = bufPtr->nextPtr; - if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { - chanPtr->inQueueTail = (ChannelBuffer *) NULL; - } - RecycleBuffer(chanPtr, bufPtr, 0); + restore: + bufPtr = chanPtr->inQueueHead; + bufPtr->nextRemoved = oldRemoved; + + for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { + bufPtr->nextRemoved = BUFFER_PADDING; } + CommonGetsCleanup(chanPtr, encoding); + + chanPtr->inputEncodingState = oldState; + chanPtr->inputEncodingFlags = oldFlags; + Tcl_SetObjLength(objPtr, oldLength); /* - * Return the number of characters copied into the result buffer. - * This may be different from the number of bytes consumed, because - * of EOL translations. + * We didn't get a complete line so we need to indicate to UpdateInterest + * that the gets blocked. It will wait for more data instead of firing + * a timer, avoiding a busy wait. This is where we are assuming that the + * next operation is a gets. No more file events will be delivered on + * this channel until new data arrives or some operation is performed + * on the channel (e.g. gets, read, fconfigure) that changes the blocking + * state. Note that this means a file event will not be delivered even + * though a read would be able to consume the buffered data. */ - return copied; + chanPtr->flags |= CHANNEL_NEED_MORE_DATA; + copiedTotal = -1; + + done: + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); + return copiedTotal; } - + /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- + * + * FilterInputBytes -- * - * ScanBufferForEOL -- + * Helper function for Tcl_GetsObj. Produces UTF-8 characters from + * raw bytes read from the channel. * - * Scans one buffer for EOL according to the specified EOL - * translation mode. If it sees the input eofChar for the channel - * it stops also. + * Consumes available bytes from channel buffers. When channel + * buffers are exhausted, reads more bytes from channel device into + * a new channel buffer. It is the caller's responsibility to + * free the channel buffers that have been exhausted. * * Results: - * TRUE if EOL is found, FALSE otherwise. Also sets output parameter - * bytesToEOLPtr to the number of bytes so far to EOL, and crSeenPtr - * to whether a "\r" was seen. + * The return value is -1 if there was an error reading from the + * channel, 0 otherwise. * * Side effects: - * None. + * Status object keeps track of how much data from channel buffers + * has been consumed and where UTF-8 bytes should be stored. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ - + static int -ScanBufferForEOL(chanPtr, bufPtr, translation, eofChar, bytesToEOLPtr, - crSeenPtr) - Channel *chanPtr; - ChannelBuffer *bufPtr; /* Buffer to scan for EOL. */ - Tcl_EolTranslation translation; /* Translation mode to use. */ - int eofChar; /* EOF char to look for. */ - int *bytesToEOLPtr; /* Running counter. */ - int *crSeenPtr; /* Has "\r" been seen? */ +FilterInputBytes(chanPtr, gsPtr) + Channel *chanPtr; /* Channel to read. */ + GetsState *gsPtr; /* Current state of gets operation. */ { - char *rPtr; /* Iterates over input string. */ - char *sPtr; /* Where to stop search? */ - int EOLFound; - int bytesToEOL; - - for (EOLFound = 0, rPtr = bufPtr->buf + bufPtr->nextRemoved, - sPtr = bufPtr->buf + bufPtr->nextAdded, - bytesToEOL = *bytesToEOLPtr; - (!EOLFound) && (rPtr < sPtr); - rPtr++) { - switch (translation) { - case TCL_TRANSLATE_AUTO: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else if (*rPtr == '\n') { + ChannelBuffer *bufPtr; + char *raw, *rawStart, *rawEnd; + char *dst; + int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length; + Tcl_Obj *objPtr; +#define ENCODING_LINESIZE 30 /* Lower bound on how many bytes to convert + * at a time. Since we don't know a priori + * how many bytes of storage this many source + * bytes will use, we actually need at least + * ENCODING_LINESIZE * TCL_MAX_UTF bytes of + * room. */ + + objPtr = gsPtr->objPtr; - /* - * CopyAndTranslateBuffer wants to know the length - * of the result, not the input. The input is one - * larger because "\r\n" shrinks to "\n". - */ - - if (!(*crSeenPtr)) { - bytesToEOL++; - EOLFound = 1; - } else { + /* + * Subtract the number of bytes that were removed from channel buffer + * during last call. + */ - /* - * This is a lf at the begining of a buffer - * where the previous buffer ended in a cr. - * Consume this lf because we've already emitted - * the newline for this crlf sequence. ALSO, if - * bytesToEOL is 0 (which means that we are at the - * first character of the scan), unset the - * INPUT_SAW_CR flag in the channel, because we - * already handled it; leaving it set would cause - * CopyAndTranslateBuffer to potentially consume - * another lf if one follows the current byte. - */ + bufPtr = gsPtr->bufPtr; + if (bufPtr != NULL) { + bufPtr->nextRemoved += gsPtr->rawRead; + if (bufPtr->nextRemoved >= bufPtr->nextAdded) { + bufPtr = bufPtr->nextPtr; + } + } + gsPtr->totalChars += gsPtr->charsWrote; - bufPtr->nextRemoved++; - *crSeenPtr = 0; - chanPtr->flags &= (~(INPUT_SAW_CR)); - } - } else if (*rPtr == '\r') { - bytesToEOL++; - EOLFound = 1; - } else { - *crSeenPtr = 0; - bytesToEOL++; - } - break; - case TCL_TRANSLATE_LF: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else { - if (*rPtr == '\n') { - EOLFound = 1; - } - bytesToEOL++; - } - break; - case TCL_TRANSLATE_CR: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else { - if (*rPtr == '\r') { - EOLFound = 1; - } - bytesToEOL++; - } - break; - case TCL_TRANSLATE_CRLF: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else if (*rPtr == '\n') { - - /* - * CopyAndTranslateBuffer wants to know the length - * of the result, not the input. The input is one - * larger because crlf shrinks to lf. - */ - - if (*crSeenPtr) { - EOLFound = 1; - } else { - bytesToEOL++; - } - } else { - if (*rPtr == '\r') { - *crSeenPtr = 1; - } else { - *crSeenPtr = 0; - } - bytesToEOL++; - } - break; - default: - panic("unknown eol translation mode"); + if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { + /* + * All channel buffers were exhausted and the caller still hasn't + * seen EOL. Need to read more bytes from the channel device. + * Side effect is to allocate another channel buffer. + */ + + read: + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; + } + chanPtr->flags &= ~CHANNEL_BLOCKED; } + if (GetInput(chanPtr) != 0) { + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; + } + bufPtr = chanPtr->inQueueTail; + gsPtr->bufPtr = bufPtr; + } + + /* + * Convert some of the bytes from the channel buffer to UTF-8. Space in + * objPtr's string rep is used to hold the UTF-8 characters. Grow the + * string rep if we need more space. + */ + + rawStart = bufPtr->buf + bufPtr->nextRemoved; + raw = rawStart; + rawEnd = bufPtr->buf + bufPtr->nextAdded; + rawLen = rawEnd - rawStart; + + dst = *gsPtr->dstPtr; + offset = dst - objPtr->bytes; + toRead = ENCODING_LINESIZE; + if (toRead > rawLen) { + toRead = rawLen; + } + dstNeeded = toRead * TCL_UTF_MAX + 1; + spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1; + if (dstNeeded > spaceLeft) { + length = offset * 2; + if (offset < dstNeeded) { + length = offset + dstNeeded; + } + length += TCL_UTF_MAX + 1; + Tcl_SetObjLength(objPtr, length); + spaceLeft = length - offset; + dst = objPtr->bytes + offset; + *gsPtr->dstPtr = dst; + } + gsPtr->state = chanPtr->inputEncodingState; + result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen, + chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState, + dst, spaceLeft, &gsPtr->rawRead, &gsPtr->bytesWrote, + &gsPtr->charsWrote); + if (result == TCL_CONVERT_MULTIBYTE) { + /* + * The last few bytes in this channel buffer were the start of a + * multibyte sequence. If this buffer was full, then move them to + * the next buffer so the bytes will be contiguous. + */ + + ChannelBuffer *nextPtr; + int extra; + + nextPtr = bufPtr->nextPtr; + if (bufPtr->nextAdded < bufPtr->bufLength) { + if (gsPtr->rawRead > 0) { + /* + * Some raw bytes were converted to UTF-8. Fall through, + * returning those UTF-8 characters because a EOL might be + * present in them. + */ + } else if (chanPtr->flags & CHANNEL_EOF) { + /* + * There was a partial character followed by EOF on the + * device. Fall through, returning that nothing was found. + */ + + bufPtr->nextRemoved = bufPtr->nextAdded; + } else { + /* + * There are no more cached raw bytes left. See if we can + * get some more. + */ + + goto read; + } + } else { + if (nextPtr == NULL) { + nextPtr = AllocChannelBuffer(chanPtr->bufSize); + bufPtr->nextPtr = nextPtr; + chanPtr->inQueueTail = nextPtr; + } + extra = rawLen - gsPtr->rawRead; + memcpy((VOID *) (nextPtr->buf + BUFFER_PADDING - extra), + (VOID *) (raw + gsPtr->rawRead), (size_t) extra); + nextPtr->nextRemoved -= extra; + bufPtr->nextAdded -= extra; + } } - *bytesToEOLPtr = bytesToEOL; - return EOLFound; + gsPtr->bufPtr = bufPtr; + return 0; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * ScanInputForEOL -- + * PeekAhead -- * - * Scans queued input for chanPtr for an end of line (according to the - * current EOL translation mode) and returns the number of bytes - * upto and including the end of line, or -1 if none was found. + * Helper function used by Tcl_GetsObj(). Called when we've seen a + * \r at the end of the UTF-8 string and want to look ahead one + * character to see if it is a \n. * * Results: - * Count of bytes upto and including the end of line if one is present - * or -1 if none was found. Also returns in an output parameter the - * number of bytes queued if no end of line was found. + * *gsPtr->dstPtr is filled with a pointer to the start of the range of + * UTF-8 characters that were found by peeking and *dstEndPtr is filled + * with a pointer to the bytes just after the end of the range. * * Side effects: - * None. + * If no more raw bytes were available in one of the channel buffers, + * tries to perform a non-blocking read to get more bytes from the + * channel device. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -static int -ScanInputForEOL(chanPtr, bytesQueuedPtr) - Channel *chanPtr; /* Channel for which to scan queued - * input for end of line. */ - int *bytesQueuedPtr; /* Where to store the number of bytes - * currently queued if no end of line - * was found. */ +static void +PeekAhead(chanPtr, dstEndPtr, gsPtr) + Channel *chanPtr; /* The channel to read. */ + char **dstEndPtr; /* Filled with pointer to end of new range + * of UTF-8 characters. */ + GetsState *gsPtr; /* Current state of gets operation. */ { - ChannelBuffer *bufPtr; /* Iterates over queued buffers. */ - int bytesToEOL; /* How many bytes to end of line? */ - int EOLFound; /* Did we find an end of line? */ - int crSeen; /* Did we see a "\r" in CRLF mode? */ - - *bytesQueuedPtr = 0; - bytesToEOL = 0; - EOLFound = 0; - for (bufPtr = chanPtr->inQueueHead, - crSeen = (chanPtr->flags & INPUT_SAW_CR) ? 1 : 0; - (!EOLFound) && (bufPtr != (ChannelBuffer *) NULL); - bufPtr = bufPtr->nextPtr) { - EOLFound = ScanBufferForEOL(chanPtr, bufPtr, chanPtr->inputTranslation, - chanPtr->inEofChar, &bytesToEOL, &crSeen); - } - - if (EOLFound == 0) { - *bytesQueuedPtr = bytesToEOL; - return -1; + ChannelBuffer *bufPtr; + Tcl_DriverBlockModeProc *blockModeProc; + int bytesLeft; + + bufPtr = gsPtr->bufPtr; + + /* + * If there's any more raw input that's still buffered, we'll peek into + * that. Otherwise, only get more data from the channel driver if it + * looks like there might actually be more data. The assumption is that + * if the channel buffer is filled right up to the end, then there + * might be more data to read. + */ + + blockModeProc = NULL; + if (bufPtr->nextPtr == NULL) { + bytesLeft = bufPtr->nextAdded - (bufPtr->nextRemoved + gsPtr->rawRead); + if (bytesLeft == 0) { + if (bufPtr->nextAdded < bufPtr->bufLength) { + /* + * Don't peek ahead if last read was short read. + */ + + goto cleanup; + } + if ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) { + blockModeProc = chanPtr->typePtr->blockModeProc; + if (blockModeProc == NULL) { + /* + * Don't peek ahead if cannot set non-blocking mode. + */ + + goto cleanup; + } + (*blockModeProc)(chanPtr->instanceData, TCL_MODE_NONBLOCKING); + } + } + } + if (FilterInputBytes(chanPtr, gsPtr) == 0) { + *dstEndPtr = *gsPtr->dstPtr + gsPtr->bytesWrote; + } + if (blockModeProc != NULL) { + (*blockModeProc)(chanPtr->instanceData, TCL_MODE_BLOCKING); } - return bytesToEOL; + return; + + cleanup: + bufPtr->nextRemoved += gsPtr->rawRead; + gsPtr->rawRead = 0; + gsPtr->totalChars += gsPtr->charsWrote; + gsPtr->bytesWrote = 0; + gsPtr->charsWrote = 0; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * GetEOL -- + * CommonGetsCleanup -- * - * Accumulate input into the channel input buffer queue until an - * end of line has been seen. + * Helper function for Tcl_GetsObj() to restore the channel after + * a "gets" operation. * * Results: - * Number of bytes buffered (at least 1) or -1 on failure. + * None. * * Side effects: - * Consumes input from the channel. + * Encoding may be freed. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ - -static int -GetEOL(chanPtr) - Channel *chanPtr; /* Channel to queue input on. */ + +static void +CommonGetsCleanup(chanPtr, encoding) + Channel *chanPtr; + Tcl_Encoding encoding; { - int bytesToEOL; /* How many bytes in buffer up to and - * including the end of line? */ - int bytesQueued; /* How many bytes are queued currently - * in the input chain of the channel? */ - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; - } - - /* - * Punt if the channel is not opened for reading. - */ - - if (!(chanPtr->flags & TCL_READABLE)) { - Tcl_SetErrno(EACCES); - return -1; - } - - /* - * If the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; - } - - /* - * If we have not encountered a sticky EOF, clear the EOF bit - * (sticky EOF is set if we have seen the input eofChar, to prevent - * reading beyond the eofChar). Also, always clear the BLOCKED bit. - * We want to discover these conditions anew in each operation. - */ + ChannelBuffer *bufPtr, *nextPtr; - if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { - chanPtr->flags &= (~(CHANNEL_EOF)); + bufPtr = chanPtr->inQueueHead; + for ( ; bufPtr != NULL; bufPtr = nextPtr) { + nextPtr = bufPtr->nextPtr; + if (bufPtr->nextRemoved < bufPtr->nextAdded) { + break; + } + RecycleBuffer(chanPtr, bufPtr, 0); } - chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_GETS_BLOCKED)); - - while (1) { - bytesToEOL = ScanInputForEOL(chanPtr, &bytesQueued); - if (bytesToEOL > 0) { - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - return bytesToEOL; - } - if (chanPtr->flags & CHANNEL_EOF) { - /* - * Boundary case where cr was at the end of the previous buffer - * and this buffer just has a newline. At EOF our caller wants - * to see -1 for the line length. - */ - return (bytesQueued == 0) ? -1 : bytesQueued ; - } - if (chanPtr->flags & CHANNEL_BLOCKED) { - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - goto blocked; - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - } - if (GetInput(chanPtr) != 0) { - goto blocked; - } + chanPtr->inQueueHead = bufPtr; + if (bufPtr == NULL) { + chanPtr->inQueueTail = NULL; + } else { + /* + * If any multi-byte characters were split across channel buffer + * boundaries, the split-up bytes were moved to the next channel + * buffer by FilterInputBytes(). Move the bytes back to their + * original buffer because the caller could change the channel's + * encoding which could change the interpretation of whether those + * bytes really made up multi-byte characters after all. + */ + + nextPtr = bufPtr->nextPtr; + for ( ; nextPtr != NULL; nextPtr = bufPtr->nextPtr) { + int extra; + + extra = bufPtr->bufLength - bufPtr->nextAdded; + if (extra > 0) { + memcpy((VOID *) (bufPtr->buf + bufPtr->nextAdded), + (VOID *) (nextPtr->buf + BUFFER_PADDING - extra), + (size_t) extra); + bufPtr->nextAdded += extra; + nextPtr->nextRemoved = BUFFER_PADDING; + } + bufPtr = nextPtr; + } + } + if (chanPtr->encoding == NULL) { + Tcl_FreeEncoding(encoding); } - - blocked: - - /* - * We didn't get a complete line so we need to indicate to UpdateInterest - * that the gets blocked. It will wait for more data instead of firing - * a timer, avoiding a busy wait. This is where we are assuming that the - * next operation is a gets. No more file events will be delivered on - * this channel until new data arrives or some operation is performed - * on the channel (e.g. gets, read, fconfigure) that changes the blocking - * state. Note that this means a file event will not be delivered even - * though a read would be able to consume the buffered data. - */ - - chanPtr->flags |= CHANNEL_GETS_BLOCKED; - return -1; } /* @@ -3043,10 +3437,15 @@ GetEOL(chanPtr) * * Tcl_Read -- * - * Reads a given number of characters from a channel. + * Reads a given number of bytes from a channel. EOL and EOF + * translation is done on the bytes being read, so the the number + * of bytes consumed from the channel may not be equal to the + * number of bytes stored in the destination buffer. + * + * No encoding conversions are applied to the bytes being read. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() + * The number of bytes read, or -1 on error. Use Tcl_GetErrno() * to retrieve the error code for the error that occurred. * * Side effects: @@ -3056,52 +3455,32 @@ GetEOL(chanPtr) */ int -Tcl_Read(chan, bufPtr, toRead) +Tcl_Read(chan, dst, bytesToRead) Tcl_Channel chan; /* The channel from which to read. */ - char *bufPtr; /* Where to store input read. */ - int toRead; /* Maximum number of characters to read. */ + char *dst; /* Where to store input read. */ + int bytesToRead; /* Maximum number of bytes to read. */ { - Channel *chanPtr; /* The real IO channel. */ + Channel *chanPtr; chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; - } - - /* - * Punt if the channel is not opened for reading. - */ - - if (!(chanPtr->flags & TCL_READABLE)) { - Tcl_SetErrno(EACCES); - return -1; - } - - /* - * If the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); + if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { return -1; } - return DoRead(chanPtr, bufPtr, toRead); + return DoRead(chanPtr, dst, bytesToRead); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * DoRead -- + * Tcl_ReadChars -- * - * Reads a given number of characters from a channel. + * Reads from the channel until the requested number of characters + * have been seen, EOF is seen, or the channel would block. EOL + * and EOF translation is done. If reading binary data, the raw + * bytes are wrapped in a Tcl byte array object. Otherwise, the raw + * bytes are converted to UTF-8 using the channel's current encoding + * and stored in a Tcl string object. * * Results: * The number of characters read, or -1 on error. Use Tcl_GetErrno() @@ -3110,212 +3489,606 @@ Tcl_Read(chan, bufPtr, toRead) * Side effects: * May cause input to be buffered. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ + +int +Tcl_ReadChars(chan, objPtr, toRead, appendFlag) + Tcl_Channel chan; /* The channel to read. */ + Tcl_Obj *objPtr; /* Input data is stored in this object. */ + int toRead; /* Maximum number of characters to store, + * or -1 to read all available data (up to EOF + * or when channel blocks). */ + int appendFlag; /* If non-zero, data read from the channel + * will be appended to the object. Otherwise, + * the data will replace the existing contents + * of the object. */ -static int -DoRead(chanPtr, bufPtr, toRead) - Channel *chanPtr; /* The channel from which to read. */ - char *bufPtr; /* Where to store input read. */ - int toRead; /* Maximum number of characters to read. */ { - int copied; /* How many characters were copied into - * the result string? */ - int copiedNow; /* How many characters were copied from - * the current input buffer? */ - int result; /* Of calling GetInput. */ - - /* - * If we have not encountered a sticky EOF, clear the EOF bit. Either - * way clear the BLOCKED bit. We want to discover these anew during - * each operation. - */ - - if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { - chanPtr->flags &= (~(CHANNEL_EOF)); - } - chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_GETS_BLOCKED)); + Channel *chanPtr; + int offset, factor, copied, copiedNow, result; + ChannelBuffer *bufPtr; + Tcl_Encoding encoding; +#define UTF_EXPANSION_FACTOR 1024 - for (copied = 0; copied < toRead; copied += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied, - toRead - copied); - if (copiedNow == 0) { - if (chanPtr->flags & CHANNEL_EOF) { - goto done; - } - if (chanPtr->flags & CHANNEL_BLOCKED) { - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - goto done; - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - } - result = GetInput(chanPtr); - if (result != 0) { - if (result != EAGAIN) { - copied = -1; - } - goto done; - } - } + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { + copied = -1; + goto done; } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - - done: - /* - * Update the notifier state so we don't block while there is still - * data in the buffers. - */ + encoding = chanPtr->encoding; + factor = UTF_EXPANSION_FACTOR; - UpdateInterest(chanPtr); + if (appendFlag == 0) { + if (encoding == NULL) { + Tcl_SetByteArrayLength(objPtr, 0); + } else { + Tcl_SetObjLength(objPtr, 0); + } + offset = 0; + } else { + if (encoding == NULL) { + Tcl_GetByteArrayFromObj(objPtr, &offset); + } else { + Tcl_GetStringFromObj(objPtr, &offset); + } + } + + for (copied = 0; (unsigned) toRead > 0; ) { + copiedNow = -1; + if (chanPtr->inQueueHead != NULL) { + if (encoding == NULL) { + copiedNow = ReadBytes(chanPtr, objPtr, toRead, &offset); + } else { + copiedNow = ReadChars(chanPtr, objPtr, toRead, &offset, + &factor); + } + + /* + * If the current buffer is empty recycle it. + */ + + bufPtr = chanPtr->inQueueHead; + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + ChannelBuffer *nextPtr; + + nextPtr = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, 0); + chanPtr->inQueueHead = nextPtr; + if (nextPtr == NULL) { + chanPtr->inQueueTail = nextPtr; + } + } + } + if (copiedNow < 0) { + if (chanPtr->flags & CHANNEL_EOF) { + break; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + break; + } + chanPtr->flags &= ~CHANNEL_BLOCKED; + } + result = GetInput(chanPtr); + if (result != 0) { + if (result == EAGAIN) { + break; + } + copied = -1; + goto done; + } + } else { + copied += copiedNow; + toRead -= copiedNow; + } + } + chanPtr->flags &= ~CHANNEL_BLOCKED; + if (encoding == NULL) { + Tcl_SetByteArrayLength(objPtr, offset); + } else { + Tcl_SetObjLength(objPtr, offset); + } + + done: + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); return copied; } +/* + *--------------------------------------------------------------------------- + * + * ReadBytes -- + * + * Reads from the channel until the requested number of bytes have + * been seen, EOF is seen, or the channel would block. Bytes from + * the channel are stored in objPtr as a ByteArray object. EOL + * and EOF translation are done. + * + * 'bytesToRead' can safely be a very large number because + * space is only allocated to hold data read from the channel + * as needed. + * + * Results: + * The return value is the number of bytes appended to the object + * and *offsetPtr is filled with the total number of bytes in the + * object (greater than the return value if there were already bytes + * in the object). + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +ReadBytes(chanPtr, objPtr, bytesToRead, offsetPtr) + Channel *chanPtr; /* The channel to read. */ + int bytesToRead; /* Maximum number of characters to store, + * or < 0 to get all available characters. + * Characters are obtained from the first + * buffer in the queue -- even if this number + * is larger than the number of characters + * available in the first buffer, only the + * characters from the first buffer are + * returned. */ + Tcl_Obj *objPtr; /* Input data is appended to this ByteArray + * object. Its length is how much space + * has been allocated to hold data, not how + * many bytes of data have been stored in the + * object. */ + int *offsetPtr; /* On input, contains how many bytes of + * objPtr have been used to hold data. On + * output, filled with how many bytes are now + * being used. */ +{ + int toRead, srcLen, srcRead, dstWrote, offset, length; + ChannelBuffer *bufPtr; + char *src, *dst; + + offset = *offsetPtr; + + bufPtr = chanPtr->inQueueHead; + src = bufPtr->buf + bufPtr->nextRemoved; + srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; + + toRead = bytesToRead; + if ((unsigned) toRead > (unsigned) srcLen) { + toRead = srcLen; + } + + dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length); + if (toRead > length - offset - 1) { + /* + * Double the existing size of the object or make enough room to + * hold all the characters we may get from the source buffer, + * whichever is larger. + */ + + length = offset * 2; + if (offset < toRead) { + length = offset + toRead + 1; + } + dst = (char *) Tcl_SetByteArrayLength(objPtr, length); + } + dst += offset; + + if (chanPtr->flags & INPUT_NEED_NL) { + chanPtr->flags &= ~INPUT_NEED_NL; + if ((srcLen == 0) || (*src != '\n')) { + *dst = '\r'; + *offsetPtr += 1; + return 1; + } + *dst++ = '\n'; + src++; + srcLen--; + toRead--; + } + + srcRead = srcLen; + dstWrote = toRead; + if (TranslateInputEOL(chanPtr, dst, src, &dstWrote, &srcRead) != 0) { + if (dstWrote == 0) { + return -1; + } + } + bufPtr->nextRemoved += srcRead; + *offsetPtr += dstWrote; + return dstWrote; +} /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * Tcl_Gets -- + * ReadChars -- * - * Reads a complete line of input from the channel into a - * Tcl_DString. + * Reads from the channel until the requested number of UTF-8 + * characters have been seen, EOF is seen, or the channel would + * block. Raw bytes from the channel are converted to UTF-8 + * and stored in objPtr. EOL and EOF translation is done. + * + * 'charsToRead' can safely be a very large number because + * space is only allocated to hold data read from the channel + * as needed. * * Results: - * Length of line read or -1 if error, EOF or blocked. If -1, use - * Tcl_GetErrno() to retrieve the POSIX error code for the - * error or condition that occurred. + * The return value is the number of characters appended to + * the object, *offsetPtr is filled with the number of bytes that + * were appended, and *factorPtr is filled with the expansion + * factor used to guess how many bytes of UTF-8 to allocate to + * hold N source bytes. * * Side effects: - * May flush output on the channel. May cause input to be - * consumed from the channel. + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -int -Tcl_Gets(chan, lineRead) - Tcl_Channel chan; /* Channel from which to read. */ - Tcl_DString *lineRead; /* The characters of the line read - * (excluding the terminating newline if - * present) will be appended to this - * DString. The caller must have initialized - * it and is responsible for managing the - * storage. */ +static int +ReadChars(chanPtr, objPtr, charsToRead, offsetPtr, factorPtr) + Channel *chanPtr; /* The channel to read. */ + int charsToRead; /* Maximum number of characters to store, + * or -1 to get all available characters. + * Characters are obtained from the first + * buffer in the queue -- even if this number + * is larger than the number of characters + * available in the first buffer, only the + * characters from the first buffer are + * returned. */ + Tcl_Obj *objPtr; /* Input data is appended to this object. + * objPtr->length is how much space has been + * allocated to hold data, not how many bytes + * of data have been stored in the object. */ + int *offsetPtr; /* On input, contains how many bytes of + * objPtr have been used to hold data. On + * output, filled with how many bytes are now + * being used. */ + int *factorPtr; /* On input, contains a guess of how many + * bytes need to be allocated to hold the + * result of converting N source bytes to + * UTF-8. On output, contains another guess + * based on the data seen so far. */ { - Channel *chanPtr; /* The channel to read from. */ - char *buf; /* Points into DString where data - * will be stored. */ - int offset; /* Offset from start of DString at - * which to append the line just read. */ - int copiedTotal; /* Accumulates total length of input copied. */ - int copiedNow; /* How many bytes were copied from the - * current input buffer? */ - int lineLen; /* Length of line read, including the - * translated newline. If this is zero - * and neither EOF nor BLOCKED is set, - * the current line is empty. */ - - chanPtr = (Channel *) chan; + int toRead, factor, offset, spaceLeft, length; + int srcLen, srcRead, dstNeeded, dstRead, dstWrote, numChars; + ChannelBuffer *bufPtr; + char *src, *dst; + Tcl_EncodingState oldState; - lineLen = GetEOL(chanPtr); - if (lineLen < 0) { - copiedTotal = -1; - goto done; + factor = *factorPtr; + offset = *offsetPtr; + + bufPtr = chanPtr->inQueueHead; + src = bufPtr->buf + bufPtr->nextRemoved; + srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; + + toRead = charsToRead; + if ((unsigned) toRead > (unsigned) srcLen) { + toRead = srcLen; + } + + /* + * 'factor' is how much we guess that the bytes in the source buffer + * will expand when converted to UTF-8 chars. This guess comes from + * analyzing how many characters were produced by the previous + * pass. + */ + + dstNeeded = toRead * factor / UTF_EXPANSION_FACTOR; + spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1; + + if (dstNeeded > spaceLeft) { + /* + * Double the existing size of the object or make enough room to + * hold all the characters we want from the source buffer, + * whichever is larger. + */ + + length = offset * 2; + if (offset < dstNeeded) { + length = offset + dstNeeded; + } + spaceLeft = length - offset; + length += TCL_UTF_MAX + 1; + Tcl_SetObjLength(objPtr, length); } - offset = Tcl_DStringLength(lineRead); - Tcl_DStringSetLength(lineRead, lineLen + offset); - buf = Tcl_DStringValue(lineRead) + offset; + if (toRead == srcLen) { + /* + * Want to convert the whole buffer in one pass. If we have + * enough space, convert it using all available space in object + * rather than using the factor. + */ - for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, - lineLen - copiedTotal); + dstNeeded = spaceLeft; } - if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { - copiedTotal--; + dst = objPtr->bytes + offset; + + oldState = chanPtr->inputEncodingState; + if (chanPtr->flags & INPUT_NEED_NL) { + /* + * We want a '\n' because the last character we saw was '\r'. + */ + + chanPtr->flags &= ~INPUT_NEED_NL; + Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen, + chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState, + dst, TCL_UTF_MAX + 1, &srcRead, &dstWrote, &numChars); + if ((dstWrote > 0) && (*dst == '\n')) { + /* + * The next char was a '\n'. Consume it and produce a '\n'. + */ + + bufPtr->nextRemoved += srcRead; + } else { + /* + * The next char was not a '\n'. Produce a '\r'. + */ + + *dst = '\r'; + } + chanPtr->inputEncodingFlags &= ~TCL_ENCODING_START; + *offsetPtr += 1; + return 1; } - Tcl_DStringSetLength(lineRead, copiedTotal + offset); - done: + Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen, + chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState, dst, + dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); + if (srcRead == 0) { + /* + * Not enough bytes in src buffer to make a complete char. Copy + * the bytes to the next buffer to make a new contiguous string, + * then tell the caller to fill the buffer with more bytes. + */ + + ChannelBuffer *nextPtr; + + nextPtr = bufPtr->nextPtr; + if (nextPtr == NULL) { + /* + * There isn't enough data in the buffers to complete the next + * character, so we need to wait for more data before the next + * file event can be delivered. + */ + + chanPtr->flags |= CHANNEL_NEED_MORE_DATA; + return -1; + } + nextPtr->nextRemoved -= srcLen; + memcpy((VOID *) (nextPtr->buf + nextPtr->nextRemoved), (VOID *) src, + (size_t) srcLen); + RecycleBuffer(chanPtr, bufPtr, 0); + chanPtr->inQueueHead = nextPtr; + return ReadChars(chanPtr, objPtr, charsToRead, offsetPtr, factorPtr); + } + + dstRead = dstWrote; + if (TranslateInputEOL(chanPtr, dst, dst, &dstWrote, &dstRead) != 0) { + /* + * Hit EOF char. How many bytes of src correspond to where the + * EOF was located in dst? + */ + + if (dstWrote == 0) { + return -1; + } + chanPtr->inputEncodingState = oldState; + Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen, + chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState, + dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); + TranslateInputEOL(chanPtr, dst, dst, &dstWrote, &dstRead); + } + /* - * Update the notifier state so we don't block while there is still - * data in the buffers. + * The number of characters that we got may be less than the number + * that we started with because "\r\n" sequences may have been + * turned into just '\n' in dst. */ - UpdateInterest(chanPtr); - return copiedTotal; + numChars -= (dstRead - dstWrote); + + if ((unsigned) numChars > (unsigned) toRead) { + /* + * Got too many chars. + */ + + char *eof; + + eof = Tcl_UtfAtIndex(dst, toRead); + chanPtr->inputEncodingState = oldState; + Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen, + chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState, + dst, eof - dst + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); + dstRead = dstWrote; + TranslateInputEOL(chanPtr, dst, dst, &dstWrote, &dstRead); + numChars -= (dstRead - dstWrote); + } + chanPtr->inputEncodingFlags &= ~TCL_ENCODING_START; + + bufPtr->nextRemoved += srcRead; + if (dstWrote > srcRead + 1) { + *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; + } + *offsetPtr += dstWrote; + return numChars; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * Tcl_GetsObj -- + * TranslateInputEOL -- * - * Reads a complete line of input from the channel into a - * string object. + * Perform input EOL and EOF translation on the source buffer, + * leaving the translated result in the destination buffer. * * Results: - * Length of line read or -1 if error, EOF or blocked. If -1, use - * Tcl_GetErrno() to retrieve the POSIX error code for the - * error or condition that occurred. + * The return value is 1 if the EOF character was found when copying + * bytes to the destination buffer, 0 otherwise. * * Side effects: - * May flush output on the channel. May cause input to be - * consumed from the channel. + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -int -Tcl_GetsObj(chan, objPtr) - Tcl_Channel chan; /* Channel from which to read. */ - Tcl_Obj *objPtr; /* The characters of the line read - * (excluding the terminating newline if - * present) will be appended to this - * object. The caller must have initialized - * it and is responsible for managing the - * storage. */ +static int +TranslateInputEOL(chanPtr, dstStart, srcStart, dstLenPtr, srcLenPtr) + Channel *chanPtr; /* Channel being read, for EOL translation + * and EOF character. */ + char *dstStart; /* Output buffer filled with chars by + * applying appropriate EOL translation to + * source characters. */ + CONST char *srcStart; /* Source characters. */ + int *dstLenPtr; /* On entry, the maximum length of output + * buffer in bytes; must be <= *srcLenPtr. On + * exit, the number of bytes actually used in + * output buffer. */ + int *srcLenPtr; /* On entry, the length of source buffer. + * On exit, the number of bytes read from + * the source buffer. */ { - Channel *chanPtr; /* The channel to read from. */ - char *buf; /* Points into DString where data - * will be stored. */ - int offset; /* Offset from start of DString at - * which to append the line just read. */ - int copiedTotal; /* Accumulates total length of input copied. */ - int copiedNow; /* How many bytes were copied from the - * current input buffer? */ - int lineLen; /* Length of line read, including the - * translated newline. If this is zero - * and neither EOF nor BLOCKED is set, - * the current line is empty. */ - - chanPtr = (Channel *) chan; + int dstLen, srcLen, inEofChar; + CONST char *eof; - lineLen = GetEOL(chanPtr); - if (lineLen < 0) { - copiedTotal = -1; - goto done; - } + dstLen = *dstLenPtr; + + eof = NULL; + inEofChar = chanPtr->inEofChar; + if (inEofChar != '\0') { + /* + * Find EOF in translated buffer then compress out the EOL. The + * source buffer may be much longer than the destination buffer -- + * we only want to return EOF if the EOF has been copied to the + * destination buffer. + */ - (void) Tcl_GetStringFromObj(objPtr, &offset); - Tcl_SetObjLength(objPtr, lineLen + offset); - buf = Tcl_GetStringFromObj(objPtr, NULL) + offset; + CONST char *src, *srcMax; - for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, - lineLen - copiedTotal); + srcMax = srcStart + *srcLenPtr; + for (src = srcStart; src < srcMax; src++) { + if (*src == inEofChar) { + eof = src; + srcLen = src - srcStart; + if (srcLen < dstLen) { + dstLen = srcLen; + } + *srcLenPtr = srcLen; + break; + } + } } - if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { - copiedTotal--; + switch (chanPtr->inputTranslation) { + case TCL_TRANSLATE_LF: { + if (dstStart != srcStart) { + memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); + } + srcLen = dstLen; + break; + } + case TCL_TRANSLATE_CR: { + char *dst, *dstEnd; + + if (dstStart != srcStart) { + memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); + } + dstEnd = dstStart + dstLen; + for (dst = dstStart; dst < dstEnd; dst++) { + if (*dst == '\r') { + *dst = '\n'; + } + } + srcLen = dstLen; + break; + } + case TCL_TRANSLATE_CRLF: { + char *dst; + CONST char *src, *srcEnd, *srcMax; + + dst = dstStart; + src = srcStart; + srcEnd = srcStart + dstLen; + srcMax = srcStart + *srcLenPtr; + + for ( ; src < srcEnd; ) { + if (*src == '\r') { + src++; + if (src >= srcMax) { + chanPtr->flags |= INPUT_NEED_NL; + } else if (*src == '\n') { + *dst++ = *src++; + } else { + *dst++ = '\r'; + } + } else { + *dst++ = *src++; + } + } + srcLen = src - srcStart; + dstLen = dst - dstStart; + break; + } + case TCL_TRANSLATE_AUTO: { + char *dst; + CONST char *src, *srcEnd, *srcMax; + + dst = dstStart; + src = srcStart; + srcEnd = srcStart + dstLen; + srcMax = srcStart + *srcLenPtr; + + if ((chanPtr->flags & INPUT_SAW_CR) && (src < srcMax)) { + if (*src == '\n') { + src++; + } + chanPtr->flags &= ~INPUT_SAW_CR; + } + for ( ; src < srcEnd; ) { + if (*src == '\r') { + src++; + if (src >= srcMax) { + chanPtr->flags |= INPUT_SAW_CR; + } else if (*src == '\n') { + if (srcEnd < srcMax) { + srcEnd++; + } + src++; + } + *dst++ = '\n'; + } else { + *dst++ = *src++; + } + } + srcLen = src - srcStart; + dstLen = dst - dstStart; + break; + } + default: { /* lint. */ + return 0; + } } - Tcl_SetObjLength(objPtr, copiedTotal + offset); + *dstLenPtr = dstLen; - done: - /* - * Update the notifier state so we don't block while there is still - * data in the buffers. - */ + if ((eof != NULL) && (srcStart + srcLen >= eof)) { + /* + * EOF character was seen in EOL translated range. Leave current + * file position pointing at the EOF character, but don't store the + * EOF character in the output string. + */ - UpdateInterest(chanPtr); - return copiedTotal; + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + chanPtr->inputEncodingFlags |= TCL_ENCODING_END; + chanPtr->flags &= ~(INPUT_SAW_CR | INPUT_NEED_NL); + return 1; + } + + *srcLenPtr = srcLen; + return 0; } /* @@ -3345,37 +4118,20 @@ Tcl_Ungets(chan, str, len, atEnd) { Channel *chanPtr; /* The real IO channel. */ ChannelBuffer *bufPtr; /* Buffer to contain the data. */ - int i; + int i, flags; chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; - } - - /* - * Punt if the channel is not opened for reading. - */ - - if (!(chanPtr->flags & TCL_READABLE)) { - Tcl_SetErrno(EACCES); - return -1; - } - + /* - * If the channel is in the middle of a background copy, fail. + * CheckChannelErrors clears too many flag bits in this one case. */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; + + flags = chanPtr->flags; + if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { + len = -1; + goto done; } + chanPtr->flags = flags; /* * If we have encountered a sticky EOF, just punt without storing. @@ -3386,18 +4142,15 @@ Tcl_Ungets(chan, str, len, atEnd) */ if (chanPtr->flags & CHANNEL_STICKY_EOF) { - return len; + goto done; } chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF)); - bufPtr = (ChannelBuffer *) ckalloc((unsigned) - (CHANNELBUFFER_HEADER_SIZE + len)); + bufPtr = AllocChannelBuffer(len); for (i = 0; i < len; i++) { bufPtr->buf[i] = str[i]; } - bufPtr->bufSize = len; - bufPtr->nextAdded = len; - bufPtr->nextRemoved = 0; + bufPtr->nextAdded += len; if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { bufPtr->nextPtr = (ChannelBuffer *) NULL; @@ -3412,6 +4165,7 @@ Tcl_Ungets(chan, str, len, atEnd) chanPtr->inQueueHead = bufPtr; } + done: /* * Update the notifier state so we don't block while there is still * data in the buffers. @@ -3424,64 +4178,233 @@ Tcl_Ungets(chan, str, len, atEnd) /* *---------------------------------------------------------------------- * - * Tcl_Seek -- + * Tcl_Flush -- * - * Implements seeking on Tcl Channels. This is a public function - * so that other C facilities may be implemented on top of it. + * Flushes output data on a channel. * * Results: - * The new access point or -1 on error. If error, use Tcl_GetErrno() - * to retrieve the POSIX error code for the error that occurred. + * A standard Tcl result. * * Side effects: - * May flush output on the channel. May discard queued input. + * May flush output queued on this channel. * *---------------------------------------------------------------------- */ int -Tcl_Seek(chan, offset, mode) - Tcl_Channel chan; /* The channel on which to seek. */ - int offset; /* Offset to seek to. */ - int mode; /* Relative to which location to seek? */ +Tcl_Flush(chan) + Tcl_Channel chan; /* The Channel to flush. */ { - Channel *chanPtr; /* The real IO channel. */ - ChannelBuffer *bufPtr; - int inputBuffered, outputBuffered; - int result; /* Of device driver operations. */ - int curPos; /* Position on the device. */ - int wasAsync; /* Was the channel nonblocking before the - * seek operation? If so, must restore to - * nonblocking mode after the seek. */ + int result; /* Of calling FlushChannel. */ + Channel *chanPtr; /* The actual channel. */ chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) { + return -1; + } /* - * Check for unreported error. + * Force current output buffer to be output also. */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; + + if ((chanPtr->curOutPtr != NULL) + && (chanPtr->curOutPtr->nextAdded > 0)) { + chanPtr->flags |= BUFFER_READY; + } + + result = FlushChannel(NULL, chanPtr, 0); + if (result != 0) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DiscardInputQueued -- + * + * Discards any input read from the channel but not yet consumed + * by Tcl reading commands. + * + * Results: + * None. + * + * Side effects: + * May discard input from the channel. If discardLastBuffer is zero, + * leaves one buffer in place for back-filling. + * + *---------------------------------------------------------------------- + */ + +static void +DiscardInputQueued(chanPtr, discardSavedBuffers) + Channel *chanPtr; /* Channel on which to discard + * the queued input. */ + int discardSavedBuffers; /* If non-zero, discard all buffers including + * last one. */ +{ + ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */ + + bufPtr = chanPtr->inQueueHead; + chanPtr->inQueueHead = (ChannelBuffer *) NULL; + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) { + nxtPtr = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, discardSavedBuffers); } /* - * Disallow seek on channels that are open for neither writing nor - * reading (e.g. socket server channels). + * If discardSavedBuffers is nonzero, must also discard any previously + * saved buffer in the saveInBufPtr field. */ + + if (discardSavedBuffers) { + if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { + ckfree((char *) chanPtr->saveInBufPtr); + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + } + } +} + +/* + *--------------------------------------------------------------------------- + * + * GetInput -- + * + * Reads input data from a device into a channel buffer. + * + * Results: + * The return value is the Posix error code if an error occurred while + * reading from the file, or 0 otherwise. + * + * Side effects: + * Reads from the underlying device. + * + *--------------------------------------------------------------------------- + */ - if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { - Tcl_SetErrno(EACCES); - return -1; +static int +GetInput(chanPtr) + Channel *chanPtr; /* Channel to read input from. */ +{ + int toRead; /* How much to read? */ + int result; /* Of calling driver. */ + int nread; /* How much was read from channel? */ + ChannelBuffer *bufPtr; /* New buffer to add to input queue. */ + + /* + * Prevent reading from a dead channel -- a channel that has been closed + * but not yet deallocated, which can happen if the exit handler for + * channel cleanup has run but the channel is still registered in some + * interpreter. + */ + + if (CheckForDeadChannel(NULL, chanPtr)) { + return EINVAL; } /* - * If the channel is in the middle of a background copy, fail. + * See if we can fill an existing buffer. If we can, read only + * as much as will fit in it. Otherwise allocate a new buffer, + * add it to the input queue and attempt to fill it to the max. */ - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); + bufPtr = chanPtr->inQueueTail; + if ((bufPtr != NULL) && (bufPtr->nextAdded < bufPtr->bufLength)) { + toRead = bufPtr->bufLength - bufPtr->nextAdded; + } else { + bufPtr = chanPtr->saveInBufPtr; + chanPtr->saveInBufPtr = NULL; + if (bufPtr == NULL) { + bufPtr = AllocChannelBuffer(chanPtr->bufSize); + } + bufPtr->nextPtr = (ChannelBuffer *) NULL; + + toRead = chanPtr->bufSize; + if (chanPtr->inQueueTail == NULL) { + chanPtr->inQueueHead = bufPtr; + } else { + chanPtr->inQueueTail->nextPtr = bufPtr; + } + chanPtr->inQueueTail = bufPtr; + } + + /* + * If EOF is set, we should avoid calling the driver because on some + * platforms it is impossible to read from a device after EOF. + */ + + if (chanPtr->flags & CHANNEL_EOF) { + return 0; + } + + nread = (*chanPtr->typePtr->inputProc)(chanPtr->instanceData, + bufPtr->buf + bufPtr->nextAdded, toRead, &result); + + if (nread > 0) { + bufPtr->nextAdded += nread; + + /* + * If we get a short read, signal up that we may be BLOCKED. We + * should avoid calling the driver because on some platforms we + * will block in the low level reading code even though the + * channel is set into nonblocking mode. + */ + + if (nread < toRead) { + chanPtr->flags |= CHANNEL_BLOCKED; + } + } else if (nread == 0) { + chanPtr->flags |= CHANNEL_EOF; + chanPtr->inputEncodingFlags |= TCL_ENCODING_END; + } else if (nread < 0) { + if ((result == EWOULDBLOCK) || (result == EAGAIN)) { + chanPtr->flags |= CHANNEL_BLOCKED; + result = EAGAIN; + } + Tcl_SetErrno(result); + return result; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Seek -- + * + * Implements seeking on Tcl Channels. This is a public function + * so that other C facilities may be implemented on top of it. + * + * Results: + * The new access point or -1 on error. If error, use Tcl_GetErrno() + * to retrieve the POSIX error code for the error that occurred. + * + * Side effects: + * May flush output on the channel. May discard queued input. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Seek(chan, offset, mode) + Tcl_Channel chan; /* The channel on which to seek. */ + int offset; /* Offset to seek to. */ + int mode; /* Relative to which location to seek? */ +{ + Channel *chanPtr; /* The real IO channel. */ + ChannelBuffer *bufPtr; + int inputBuffered, outputBuffered; + int result; /* Of device driver operations. */ + int curPos; /* Position on the device. */ + int wasAsync; /* Was the channel nonblocking before the + * seek operation? If so, must restore to + * nonblocking mode after the seek. */ + + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_WRITABLE | TCL_READABLE) != 0) { return -1; } @@ -3657,15 +4580,8 @@ Tcl_Tell(chan) int curPos; /* Position on device. */ chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; + if (CheckChannelErrors(chanPtr, TCL_WRITABLE | TCL_READABLE) != 0) { + return -1; } /* @@ -3675,24 +4591,7 @@ Tcl_Tell(chan) * registered in an interpreter. */ - if (CheckForDeadChannel(NULL,chanPtr)) return -1; - - /* - * Disallow tell on channels that are open for neither - * writing nor reading (e.g. socket server channels). - */ - - if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { - Tcl_SetErrno(EACCES); - return -1; - } - - /* - * If the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); + if (CheckForDeadChannel(NULL,chanPtr)) { return -1; } @@ -3751,6 +4650,75 @@ Tcl_Tell(chan) } /* + *--------------------------------------------------------------------------- + * + * CheckChannelErrors -- + * + * See if the channel is in an ready state and can perform the + * desired operation. + * + * Results: + * The return value is 0 if the channel is OK, otherwise the + * return value is -1 and errno is set to indicate the error. + * + * Side effects: + * May clear the EOF and/or BLOCKED bits if reading from channel. + * + *--------------------------------------------------------------------------- + */ + +static int +CheckChannelErrors(chanPtr, direction) + Channel *chanPtr; /* Channel to check. */ + int direction; /* Test if channel supports desired operation: + * TCL_READABLE, TCL_WRITABLE. */ +{ + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Fail if the channel is not opened for desired operation. + */ + + if ((chanPtr->flags & direction) == 0) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * Fail if the channel is in the middle of a background copy. + */ + + if (chanPtr->csPtr != NULL) { + Tcl_SetErrno(EBUSY); + return -1; + } + + if (direction == TCL_READABLE) { + /* + * If we have not encountered a sticky EOF, clear the EOF bit + * (sticky EOF is set if we have seen the input eofChar, to prevent + * reading beyond the eofChar). Also, always clear the BLOCKED bit. + * We want to discover these conditions anew in each operation. + */ + + if ((chanPtr->flags & CHANNEL_STICKY_EOF) == 0) { + chanPtr->flags &= ~CHANNEL_EOF; + } + chanPtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA); + } + + return 0; +} + +/* *---------------------------------------------------------------------- * * Tcl_Eof -- @@ -3878,6 +4846,15 @@ Tcl_SetChannelBufferSize(chan, sz) chanPtr = (Channel *) chan; chanPtr->bufSize = sz; + + if (chanPtr->outputStage != NULL) { + ckfree((char *) chanPtr->outputStage); + chanPtr->outputStage = NULL; + } + if ((chanPtr->encoding != NULL) && (chanPtr->flags & TCL_WRITABLE)) { + chanPtr->outputStage = (char *) + ckalloc((unsigned) (chanPtr->bufSize + 2)); + } } /* @@ -4082,7 +5059,23 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr) } } if ((len == 0) || - ((len > 1) && (optionName[1] == 'e') && + ((len > 2) && (optionName[1] == 'e') && + (strncmp(optionName, "-encoding", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-encoding"); + } + if (chanPtr->encoding == NULL) { + Tcl_DStringAppendElement(dsPtr, "binary"); + } else { + Tcl_DStringAppendElement(dsPtr, + Tcl_GetEncodingName(chanPtr->encoding)); + } + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || + ((len > 2) && (optionName[1] == 'e') && (strncmp(optionName, "-eofchar", len) == 0))) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-eofchar"); @@ -4180,20 +5173,20 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_SetChannelOption -- * * Sets an option on a channel. * * Results: - * A standard Tcl result. Also sets interp->result on error if - * interp is not NULL. + * A standard Tcl result. On error, sets interp's result object + * if interp is not NULL. * * Side effects: * May modify an option on a device. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -4247,9 +5240,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) newMode = TCL_MODE_NONBLOCKING; } return SetBlockMode(interp, chanPtr, newMode); - } - - if ((len > 7) && (optionName[1] == 'b') && + } else if ((len > 7) && (optionName[1] == 'b') && (strncmp(optionName, "-buffering", len) == 0)) { len = strlen(newValue); if ((newValue[0] == 'f') && (strncmp(newValue, "full", len) == 0)) { @@ -4271,19 +5262,34 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) return TCL_ERROR; } } - return TCL_OK; - } - - if ((len > 7) && (optionName[1] == 'b') && + return TCL_OK; + } else if ((len > 7) && (optionName[1] == 'b') && (strncmp(optionName, "-buffersize", len) == 0)) { - chanPtr->bufSize = atoi(newValue); + chanPtr->bufSize = atoi(newValue); /* INTL: "C", UTF safe. */ if ((chanPtr->bufSize < 10) || (chanPtr->bufSize > (1024 * 1024))) { chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; } - return TCL_OK; - } - - if ((len > 1) && (optionName[1] == 'e') && + } else if ((len > 2) && (optionName[1] == 'e') && + (strncmp(optionName, "-encoding", len) == 0)) { + Tcl_Encoding encoding; + + if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) { + encoding = NULL; + } else { + encoding = Tcl_GetEncoding(interp, newValue); + if (encoding == NULL) { + return TCL_ERROR; + } + } + Tcl_FreeEncoding(chanPtr->encoding); + chanPtr->encoding = encoding; + chanPtr->inputEncodingState = NULL; + chanPtr->inputEncodingFlags = TCL_ENCODING_START; + chanPtr->outputEncodingState = NULL; + chanPtr->outputEncodingFlags = TCL_ENCODING_START; + chanPtr->flags &= ~CHANNEL_NEED_MORE_DATA; + UpdateInterest(chanPtr); + } else if ((len > 2) && (optionName[1] == 'e') && (strncmp(optionName, "-eofchar", len) == 0)) { if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; @@ -4317,10 +5323,8 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) if (argv != (char **) NULL) { ckfree((char *) argv); } - return TCL_OK; - } - - if ((len > 1) && (optionName[1] == 't') && + return TCL_OK; + } else if ((len > 1) && (optionName[1] == 't') && (strncmp(optionName, "-translation", len) == 0)) { char *readMode, *writeMode; @@ -4350,8 +5354,10 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } else if (strcmp(readMode, "auto") == 0) { newMode = TCL_TRANSLATE_AUTO; } else if (strcmp(readMode, "binary") == 0) { - chanPtr->inEofChar = 0; newMode = TCL_TRANSLATE_LF; + chanPtr->inEofChar = 0; + Tcl_FreeEncoding(chanPtr->encoding); + chanPtr->encoding = NULL; } else if (strcmp(readMode, "lf") == 0) { newMode = TCL_TRANSLATE_LF; } else if (strcmp(readMode, "cr") == 0) { @@ -4380,7 +5386,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) if (newMode != chanPtr->inputTranslation) { chanPtr->inputTranslation = (Tcl_EolTranslation) newMode; chanPtr->flags &= ~(INPUT_SAW_CR); - chanPtr->flags &= ~(CHANNEL_GETS_BLOCKED); + chanPtr->flags &= ~(CHANNEL_NEED_MORE_DATA); UpdateInterest(chanPtr); } } @@ -4403,6 +5409,8 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } else if (strcmp(writeMode, "binary") == 0) { chanPtr->outEofChar = 0; chanPtr->outputTranslation = TCL_TRANSLATE_LF; + Tcl_FreeEncoding(chanPtr->encoding); + chanPtr->encoding = NULL; } else if (strcmp(writeMode, "lf") == 0) { chanPtr->outputTranslation = TCL_TRANSLATE_LF; } else if (strcmp(writeMode, "cr") == 0) { @@ -4424,14 +5432,44 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } ckfree((char *) argv); return TCL_OK; + } else if (chanPtr->typePtr->setOptionProc != NULL) { + return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData, + interp, optionName, newValue); + } else { + return Tcl_BadChannelOption(interp, optionName, (char *) NULL); } - if (chanPtr->typePtr->setOptionProc != (Tcl_DriverSetOptionProc *) NULL) { - return (chanPtr->typePtr->setOptionProc) (chanPtr->instanceData, - interp, optionName, newValue); + /* + * If bufsize changes, need to get rid of old utility buffer. + */ + + if (chanPtr->saveInBufPtr != NULL) { + RecycleBuffer(chanPtr, chanPtr->saveInBufPtr, 1); + chanPtr->saveInBufPtr = NULL; + } + if (chanPtr->inQueueHead != NULL) { + if ((chanPtr->inQueueHead->nextPtr == NULL) + && (chanPtr->inQueueHead->nextAdded == + chanPtr->inQueueHead->nextRemoved)) { + RecycleBuffer(chanPtr, chanPtr->inQueueHead, 1); + chanPtr->inQueueHead = NULL; + chanPtr->inQueueTail = NULL; + } } - - return Tcl_BadChannelOption(interp, optionName, (char *) NULL); + + /* + * If encoding or bufsize changes, need to update output staging buffer. + */ + + if (chanPtr->outputStage != NULL) { + ckfree((char *) chanPtr->outputStage); + chanPtr->outputStage = NULL; + } + if ((chanPtr->encoding != NULL) && (chanPtr->flags & TCL_WRITABLE)) { + chanPtr->outputStage = (char *) + ckalloc((unsigned) (chanPtr->bufSize + 2)); + } + return TCL_OK; } /* @@ -4481,7 +5519,7 @@ CleanupChannelHandlers(interp, chanPtr) Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, ChannelEventScriptInvoker, (ClientData) sPtr); - ckfree(sPtr->script); + Tcl_DecrRefCount(sPtr->scriptPtr); ckfree((char *) sPtr); } else { prevPtr = sPtr; @@ -4517,6 +5555,7 @@ Tcl_NotifyChannel(channel, mask) { Channel *chanPtr = (Channel *) channel; ChannelHandler *chPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); NextChannelHandler nh; /* @@ -4543,8 +5582,8 @@ Tcl_NotifyChannel(channel, mask) */ nh.nextHandlerPtr = (ChannelHandler *) NULL; - nh.nestedHandlerPtr = nestedHandlerPtr; - nestedHandlerPtr = &nh; + nh.nestedHandlerPtr = tsdPtr->nestedHandlerPtr; + tsdPtr->nestedHandlerPtr = &nh; for (chPtr = chanPtr->chPtr; chPtr != (ChannelHandler *) NULL; ) { @@ -4573,7 +5612,7 @@ Tcl_NotifyChannel(channel, mask) Tcl_Release((ClientData) channel); - nestedHandlerPtr = nh.nestedHandlerPtr; + tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; } /* @@ -4609,14 +5648,14 @@ UpdateInterest(chanPtr) } /* - * If there is data in the input queue, and we aren't blocked waiting for - * an EOL, then we need to schedule a timer so we don't block in the + * If there is data in the input queue, and we aren't waiting for more + * data, then we need to schedule a timer so we don't block in the * notifier. Also, cancel the read interest so we don't get duplicate * events. */ if (mask & TCL_READABLE) { - if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED) + if (!(chanPtr->flags & CHANNEL_NEED_MORE_DATA) && (chanPtr->inQueueHead != (ChannelBuffer *) NULL) && (chanPtr->inQueueHead->nextRemoved < chanPtr->inQueueHead->nextAdded)) { @@ -4653,7 +5692,7 @@ ChannelTimerProc(clientData) { Channel *chanPtr = (Channel *) clientData; - if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED) + if (!(chanPtr->flags & CHANNEL_NEED_MORE_DATA) && (chanPtr->interestMask & TCL_READABLE) && (chanPtr->inQueueHead != (ChannelBuffer *) NULL) && (chanPtr->inQueueHead->nextRemoved < @@ -4789,6 +5828,7 @@ Tcl_DeleteChannelHandler(chan, proc, clientData) { ChannelHandler *chPtr, *prevChPtr; Channel *chanPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); NextChannelHandler *nhPtr; chanPtr = (Channel *) chan; @@ -4820,7 +5860,7 @@ Tcl_DeleteChannelHandler(chan, proc, clientData) * process the next one instead - we are going to delete *this* one. */ - for (nhPtr = nestedHandlerPtr; + for (nhPtr = tsdPtr->nestedHandlerPtr; nhPtr != (NextChannelHandler *) NULL; nhPtr = nhPtr->nestedHandlerPtr) { if (nhPtr->nextHandlerPtr == chPtr) { @@ -4841,7 +5881,8 @@ Tcl_DeleteChannelHandler(chan, proc, clientData) /* * Recompute the interest list for the channel, so that infinite loops - * will not result if Tcl_DeleteChanelHandler is called inside an event. + * will not result if Tcl_DeleteChannelHandler is called inside an + * event. */ chanPtr->interestMask = 0; @@ -4896,7 +5937,7 @@ DeleteScriptRecord(interp, chanPtr, mask) Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, ChannelEventScriptInvoker, (ClientData) esPtr); - ckfree(esPtr->script); + Tcl_DecrRefCount(esPtr->scriptPtr); ckfree((char *) esPtr); break; @@ -4922,15 +5963,14 @@ DeleteScriptRecord(interp, chanPtr, mask) */ static void -CreateScriptRecord(interp, chanPtr, mask, script) +CreateScriptRecord(interp, chanPtr, mask, scriptPtr) Tcl_Interp *interp; /* Interpreter in which to execute * the stored script. */ Channel *chanPtr; /* Channel for which script is to * be stored. */ int mask; /* Set of events for which script * will be invoked. */ - char *script; /* A copy of this script is stored - * in the newly created record. */ + Tcl_Obj *scriptPtr; /* Pointer to script object. */ { EventScriptRecord *esPtr; @@ -4938,8 +5978,8 @@ CreateScriptRecord(interp, chanPtr, mask, script) esPtr != (EventScriptRecord *) NULL; esPtr = esPtr->nextPtr) { if ((esPtr->interp == interp) && (esPtr->mask == mask)) { - ckfree(esPtr->script); - esPtr->script = (char *) NULL; + Tcl_DecrRefCount(esPtr->scriptPtr); + esPtr->scriptPtr = (Tcl_Obj *) NULL; break; } } @@ -4954,8 +5994,8 @@ CreateScriptRecord(interp, chanPtr, mask, script) esPtr->chanPtr = chanPtr; esPtr->interp = interp; esPtr->mask = mask; - esPtr->script = ckalloc((unsigned) (strlen(script) + 1)); - strcpy(esPtr->script, script); + Tcl_IncrRefCount(scriptPtr); + esPtr->scriptPtr = scriptPtr; } /* @@ -4984,7 +6024,6 @@ ChannelEventScriptInvoker(clientData, mask) Tcl_Interp *interp; /* Interpreter in which to eval the script. */ Channel *chanPtr; /* The channel for which this handler is * registered. */ - char *script; /* Script to eval. */ EventScriptRecord *esPtr; /* The event script + interpreter to eval it * in. */ int result; /* Result of call to eval script. */ @@ -4994,8 +6033,7 @@ ChannelEventScriptInvoker(clientData, mask) chanPtr = esPtr->chanPtr; mask = esPtr->mask; interp = esPtr->interp; - script = esPtr->script; - + /* * We must preserve the interpreter so we can report errors on it * later. Note that we do not need to preserve the channel because @@ -5003,7 +6041,7 @@ ChannelEventScriptInvoker(clientData, mask) */ Tcl_Preserve((ClientData) interp); - result = Tcl_GlobalEval(interp, script); + result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL); /* * On error, cause a background error and remove the channel handler @@ -5025,7 +6063,7 @@ ChannelEventScriptInvoker(clientData, mask) /* *---------------------------------------------------------------------- * - * Tcl_FileEventCmd -- + * Tcl_FileEventObjCmd -- * * This procedure implements the "fileevent" Tcl command. See the * user documentation for details on what it does. This command is @@ -5043,46 +6081,38 @@ ChannelEventScriptInvoker(clientData, mask) /* ARGSUSED */ int -Tcl_FileEventCmd(clientData, interp, argc, argv) +Tcl_FileEventObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter in which the channel * for which to create the handler * is found. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Channel *chanPtr; /* The channel to create * the handler for. */ Tcl_Channel chan; /* The opaque type for the channel. */ - int c; /* First char of mode argument. */ - int mask; /* Mask for events of interest. */ - size_t length; /* Length of mode argument. */ - - /* - * Parse arguments. - */ + char *chanName; + int modeIndex; /* Index of mode argument. */ + int mask; + static char *modeOptions[] = {"readable", "writable", NULL}; + static int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: must be \"", argv[0], - " channelId event ?script?", (char *) NULL); + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?"); return TCL_ERROR; } - c = argv[2][0]; - length = strlen(argv[2]); - if ((c == 'r') && (strncmp(argv[2], "readable", length) == 0)) { - mask = TCL_READABLE; - } else if ((c == 'w') && (strncmp(argv[2], "writable", length) == 0)) { - mask = TCL_WRITABLE; - } else { - Tcl_AppendResult(interp, "bad event name \"", argv[2], - "\": must be readable or writable", (char *) NULL); + if (Tcl_GetIndexFromObj(interp, objv[2], modeOptions, "event name", 0, + &modeIndex) != TCL_OK) { return TCL_ERROR; } - chan = Tcl_GetChannel(interp, argv[1], NULL); + mask = maskArray[modeIndex]; + + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } - chanPtr = (Channel *) chan; if ((chanPtr->flags & mask) == 0) { Tcl_AppendResult(interp, "channel is not ", @@ -5095,13 +6125,13 @@ Tcl_FileEventCmd(clientData, interp, argc, argv) * If we are supposed to return the script, do so. */ - if (argc == 3) { + if (objc == 3) { EventScriptRecord *esPtr; for (esPtr = chanPtr->scriptRecordPtr; esPtr != (EventScriptRecord *) NULL; esPtr = esPtr->nextPtr) { if ((esPtr->interp == interp) && (esPtr->mask == mask)) { - Tcl_SetResult(interp, esPtr->script, TCL_STATIC); + Tcl_SetObjResult(interp, esPtr->scriptPtr); break; } } @@ -5112,7 +6142,7 @@ Tcl_FileEventCmd(clientData, interp, argc, argv) * If we are supposed to delete a stored script, do so. */ - if (argv[3][0] == 0) { + if (*(Tcl_GetString(objv[3])) == '\0') { DeleteScriptRecord(interp, chanPtr, mask); return TCL_OK; } @@ -5123,7 +6153,7 @@ Tcl_FileEventCmd(clientData, interp, argc, argv) * will evaluate the script in the supplied interpreter. */ - CreateScriptRecord(interp, chanPtr, mask, argv[3]); + CreateScriptRecord(interp, chanPtr, mask, objv[3]); return TCL_OK; } @@ -5164,7 +6194,7 @@ TclTestChannelCmd(clientData, interp, argc, argv) size_t len; /* Length of subcommand string. */ int IOQueued; /* How much IO is queued inside channel? */ ChannelBuffer *bufPtr; /* For iterating over queued IO. */ - char buf[128]; /* For sprintf. */ + char buf[TCL_INTEGER_SPACE];/* For sprintf. */ if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -5175,6 +6205,7 @@ TclTestChannelCmd(clientData, interp, argc, argv) len = strlen(cmdName); chanPtr = (Channel *) NULL; + if (argc > 2) { chan = Tcl_GetChannel(interp, argv[2], NULL); if (chan == (Tcl_Channel) NULL) { @@ -5182,7 +6213,8 @@ TclTestChannelCmd(clientData, interp, argc, argv) } chanPtr = (Channel *) chan; } - + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -5301,7 +6333,7 @@ TclTestChannelCmd(clientData, interp, argc, argv) bufPtr = bufPtr->nextPtr) { IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; } - sprintf(buf, "%d", IOQueued); + TclFormatInt(buf, IOQueued); Tcl_AppendResult(interp, buf, (char *) NULL); return TCL_OK; } @@ -5367,7 +6399,7 @@ TclTestChannelCmd(clientData, interp, argc, argv) bufPtr = bufPtr->nextPtr) { IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); } - sprintf(buf, "%d", IOQueued); + TclFormatInt(buf, IOQueued); Tcl_AppendResult(interp, buf, (char *) NULL); return TCL_OK; } @@ -5409,7 +6441,7 @@ TclTestChannelCmd(clientData, interp, argc, argv) return TCL_ERROR; } - sprintf(buf, "%d", chanPtr->refCount); + TclFormatInt(buf, chanPtr->refCount); Tcl_AppendResult(interp, buf, (char *) NULL); return TCL_OK; } @@ -5473,6 +6505,7 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { + Tcl_Obj *resultListPtr; Channel *chanPtr; EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr; char *cmd; @@ -5515,8 +6548,8 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) esPtr->chanPtr = chanPtr; esPtr->interp = interp; esPtr->mask = mask; - esPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); - strcpy(esPtr->script, argv[4]); + esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1); + Tcl_IncrRefCount(esPtr->scriptPtr); Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, ChannelEventScriptInvoker, (ClientData) esPtr); @@ -5564,7 +6597,7 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, ChannelEventScriptInvoker, (ClientData) esPtr); - ckfree(esPtr->script); + Tcl_DecrRefCount(esPtr->scriptPtr); ckfree((char *) esPtr); return TCL_OK; @@ -5576,19 +6609,20 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) " channelName list\"", (char *) NULL); return TCL_ERROR; } + resultListPtr = Tcl_GetObjResult(interp); for (esPtr = chanPtr->scriptRecordPtr; esPtr != (EventScriptRecord *) NULL; esPtr = esPtr->nextPtr) { - char *event; if (esPtr->mask) { - event = ((esPtr->mask == TCL_READABLE) - ? "readable" : "writable"); - } else { - event = "none"; + Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( + (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1)); + } else { + Tcl_ListObjAppendElement(interp, resultListPtr, + Tcl_NewStringObj("none", -1)); } - Tcl_AppendElement(interp, event); - Tcl_AppendElement(interp, esPtr->script); + Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr); } + Tcl_SetObjResult(interp, resultListPtr); return TCL_OK; } @@ -5604,7 +6638,7 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) nextEsPtr = esPtr->nextPtr; Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, ChannelEventScriptInvoker, (ClientData) esPtr); - ckfree(esPtr->script); + Tcl_DecrRefCount(esPtr->scriptPtr); ckfree((char *) esPtr); } chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; @@ -5655,7 +6689,6 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ", "add, delete, list, set, or removeall", (char *) NULL); return TCL_ERROR; - } /* @@ -5869,100 +6902,571 @@ CopyData(csPtr, mask) * Now write the buffer out. */ - size = DoWrite(csPtr->writePtr, csPtr->buffer, size); - if (size < 0) { - writeError: - errObj = Tcl_NewObj(); - Tcl_AppendStringsToObj(errObj, "error writing \"", - Tcl_GetChannelName(outChan), "\": ", - Tcl_PosixError(interp), (char *) NULL); - break; - } + size = DoWrite(csPtr->writePtr, csPtr->buffer, size); + if (size < 0) { + writeError: + errObj = Tcl_NewObj(); + Tcl_AppendStringsToObj(errObj, "error writing \"", + Tcl_GetChannelName(outChan), "\": ", + Tcl_PosixError(interp), (char *) NULL); + break; + } + + /* + * Check to see if the write is happening in the background. If so, + * stop copying and wait for the channel to become writable again. + */ + + if (csPtr->writePtr->flags & BG_FLUSH_SCHEDULED) { + if (!(mask & TCL_WRITABLE)) { + if (mask & TCL_READABLE) { + Tcl_DeleteChannelHandler(outChan, CopyEventProc, + (ClientData) csPtr); + } + Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, + CopyEventProc, (ClientData) csPtr); + } + return TCL_OK; + } + + /* + * Update the current byte count if we care. + */ + + if (csPtr->toRead != -1) { + csPtr->toRead -= size; + } + csPtr->total += size; + + /* + * For background copies, we only do one buffer per invocation so + * we don't starve the rest of the system. + */ + + if (cmdPtr) { + /* + * The first time we enter this code, there won't be a + * channel handler established yet, so do it here. + */ + + if (mask == 0) { + Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, + CopyEventProc, (ClientData) csPtr); + } + return TCL_OK; + } + } + + /* + * Make the callback or return the number of bytes transferred. + * The local total is used because StopCopy frees csPtr. + */ + + total = csPtr->total; + if (cmdPtr) { + /* + * Get a private copy of the command so we can mutate it + * by adding arguments. Note that StopCopy frees our saved + * reference to the original command obj. + */ + + cmdPtr = Tcl_DuplicateObj(cmdPtr); + Tcl_IncrRefCount(cmdPtr); + StopCopy(csPtr); + Tcl_Preserve((ClientData) interp); + + Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(total)); + if (errObj) { + Tcl_ListObjAppendElement(interp, cmdPtr, errObj); + } + if (Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) { + Tcl_BackgroundError(interp); + result = TCL_ERROR; + } + Tcl_DecrRefCount(cmdPtr); + Tcl_Release((ClientData) interp); + } else { + StopCopy(csPtr); + if (errObj) { + Tcl_SetObjResult(interp, errObj); + result = TCL_ERROR; + } else { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), total); + } + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DoRead -- + * + * Reads a given number of bytes from a channel. + * + * Results: + * The number of characters read, or -1 on error. Use Tcl_GetErrno() + * to retrieve the error code for the error that occurred. + * + * Side effects: + * May cause input to be buffered. + * + *---------------------------------------------------------------------- + */ + +static int +DoRead(chanPtr, bufPtr, toRead) + Channel *chanPtr; /* The channel from which to read. */ + char *bufPtr; /* Where to store input read. */ + int toRead; /* Maximum number of bytes to read. */ +{ + int copied; /* How many characters were copied into + * the result string? */ + int copiedNow; /* How many characters were copied from + * the current input buffer? */ + int result; /* Of calling GetInput. */ + + /* + * If we have not encountered a sticky EOF, clear the EOF bit. Either + * way clear the BLOCKED bit. We want to discover these anew during + * each operation. + */ + + if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { + chanPtr->flags &= ~CHANNEL_EOF; + } + chanPtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA); + + for (copied = 0; copied < toRead; copied += copiedNow) { + copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied, + toRead - copied); + if (copiedNow == 0) { + if (chanPtr->flags & CHANNEL_EOF) { + goto done; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + goto done; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + } + result = GetInput(chanPtr); + if (result != 0) { + if (result != EAGAIN) { + copied = -1; + } + goto done; + } + } + } + + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + + done: + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * CopyAndTranslateBuffer -- + * + * Copy at most one buffer of input to the result space, doing + * eol translations according to mode in effect currently. + * + * Results: + * Number of bytes stored in the result buffer (as opposed to the + * number of bytes read from the channel). May return + * zero if no input is available to be translated. + * + * Side effects: + * Consumes buffered input. May deallocate one buffer. + * + *---------------------------------------------------------------------- + */ + +static int +CopyAndTranslateBuffer(chanPtr, result, space) + Channel *chanPtr; /* The channel from which to read input. */ + char *result; /* Where to store the copied input. */ + int space; /* How many bytes are available in result + * to store the copied input? */ +{ + int bytesInBuffer; /* How many bytes are available to be + * copied in the current input buffer? */ + int copied; /* How many characters were already copied + * into the destination space? */ + ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ + int i; /* Iterates over the copied input looking + * for the input eofChar. */ + + /* + * If there is no input at all, return zero. The invariant is that either + * there is no buffer in the queue, or if the first buffer is empty, it + * is also the last buffer (and thus there is no input in the queue). + * Note also that if the buffer is empty, we leave it in the queue. + */ + + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + return 0; + } + bufPtr = chanPtr->inQueueHead; + bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; + + copied = 0; + switch (chanPtr->inputTranslation) { + case TCL_TRANSLATE_LF: { + if (bytesInBuffer == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer. + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, + (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + break; + } + case TCL_TRANSLATE_CR: { + char *end; + + if (bytesInBuffer == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer, then + * replace all \r with \n. + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, + (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + + for (end = result + copied; result < end; result++) { + if (*result == '\r') { + *result = '\n'; + } + } + break; + } + case TCL_TRANSLATE_CRLF: { + char *src, *end, *dst; + int curByte; + + /* + * If there is a held-back "\r" at EOF, produce it now. + */ + + if (bytesInBuffer == 0) { + if ((chanPtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == + (INPUT_SAW_CR | CHANNEL_EOF)) { + result[0] = '\r'; + chanPtr->flags &= ~INPUT_SAW_CR; + return 1; + } + return 0; + } + + /* + * Copy the current chunk and replace "\r\n" with "\n" + * (but not standalone "\r"!). + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, + (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + + end = result + copied; + dst = result; + for (src = result; src < end; src++) { + curByte = *src; + if (curByte == '\n') { + chanPtr->flags &= ~INPUT_SAW_CR; + } else if (chanPtr->flags & INPUT_SAW_CR) { + chanPtr->flags &= ~INPUT_SAW_CR; + *dst = '\r'; + dst++; + } + if (curByte == '\r') { + chanPtr->flags |= INPUT_SAW_CR; + } else { + *dst = (char) curByte; + dst++; + } + } + copied = dst - result; + break; + } + case TCL_TRANSLATE_AUTO: { + char *src, *end, *dst; + int curByte; + + if (bytesInBuffer == 0) { + return 0; + } + + /* + * Loop over the current buffer, converting "\r" and "\r\n" + * to "\n". + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, + (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + + end = result + copied; + dst = result; + for (src = result; src < end; src++) { + curByte = *src; + if (curByte == '\r') { + chanPtr->flags |= INPUT_SAW_CR; + *dst = '\n'; + dst++; + } else { + if ((curByte != '\n') || + !(chanPtr->flags & INPUT_SAW_CR)) { + *dst = (char) curByte; + dst++; + } + chanPtr->flags &= ~INPUT_SAW_CR; + } + } + copied = dst - result; + break; + } + default: { + panic("unknown eol translation mode"); + } + } + + /* + * If an in-stream EOF character is set for this channel, check that + * the input we copied so far does not contain the EOF char. If it does, + * copy only up to and excluding that character. + */ + + if (chanPtr->inEofChar != 0) { + for (i = 0; i < copied; i++) { + if (result[i] == (char) chanPtr->inEofChar) { + /* + * Set sticky EOF so that no further input is presented + * to the caller. + */ + + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + chanPtr->inputEncodingFlags |= TCL_ENCODING_END; + copied = i; + break; + } + } + } + + /* + * If the current buffer is empty recycle it. + */ + + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + chanPtr->inQueueHead = bufPtr->nextPtr; + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + } + RecycleBuffer(chanPtr, bufPtr, 0); + } + + /* + * Return the number of characters copied into the result buffer. + * This may be different from the number of bytes consumed, because + * of EOL translations. + */ + + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * DoWrite -- + * + * Puts a sequence of characters into an output buffer, may queue the + * buffer for output if it gets full, and also remembers whether the + * current buffer is ready e.g. if it contains a newline and we are in + * line buffering mode. + * + * Results: + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. + * + * Side effects: + * May buffer up output and may cause output to be produced on the + * channel. + * + *---------------------------------------------------------------------- + */ + +static int +DoWrite(chanPtr, src, srcLen) + Channel *chanPtr; /* The channel to buffer output for. */ + char *src; /* Data to write. */ + int srcLen; /* Number of bytes to write. */ +{ + ChannelBuffer *outBufPtr; /* Current output buffer. */ + int foundNewline; /* Did we find a newline in output? */ + char *dPtr; + char *sPtr; /* Search variables for newline. */ + int crsent; /* In CRLF eol translation mode, + * remember the fact that a CR was + * output to the channel without + * its following NL. */ + int i; /* Loop index for newline search. */ + int destCopied; /* How many bytes were used in this + * destination buffer to hold the + * output? */ + int totalDestCopied; /* How many bytes total were + * copied to the channel buffer? */ + int srcCopied; /* How many bytes were copied from + * the source string? */ + char *destPtr; /* Where in line to copy to? */ - /* - * Check to see if the write is happening in the background. If so, - * stop copying and wait for the channel to become writable again. - */ + /* + * If we are in network (or windows) translation mode, record the fact + * that we have not yet sent a CR to the channel. + */ - if (csPtr->writePtr->flags & BG_FLUSH_SCHEDULED) { - if (!(mask & TCL_WRITABLE)) { - if (mask & TCL_READABLE) { - Tcl_DeleteChannelHandler(outChan, CopyEventProc, - (ClientData) csPtr); - } - Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, - CopyEventProc, (ClientData) csPtr); - } - return TCL_OK; - } + crsent = 0; + + /* + * Loop filling buffers and flushing them until all output has been + * consumed. + */ - /* - * Update the current byte count if we care. - */ + srcCopied = 0; + totalDestCopied = 0; - if (csPtr->toRead != -1) { - csPtr->toRead -= size; - } - csPtr->total += size; + while (srcLen > 0) { + + /* + * Make sure there is a current output buffer to accept output. + */ - /* - * For background copies, we only do one buffer per invocation so - * we don't starve the rest of the system. - */ + if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { + chanPtr->curOutPtr = AllocChannelBuffer(chanPtr->bufSize); + } - if (cmdPtr) { - /* - * The first time we enter this code, there won't be a - * channel handler established yet, so do it here. - */ + outBufPtr = chanPtr->curOutPtr; - if (mask == 0) { - Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, - CopyEventProc, (ClientData) csPtr); - } - return TCL_OK; - } - } + destCopied = outBufPtr->bufLength - outBufPtr->nextAdded; + if (destCopied > srcLen) { + destCopied = srcLen; + } + + destPtr = outBufPtr->buf + outBufPtr->nextAdded; + switch (chanPtr->outputTranslation) { + case TCL_TRANSLATE_LF: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); + break; + case TCL_TRANSLATE_CR: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); + for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { + if (*dPtr == '\n') { + *dPtr = '\r'; + } + } + break; + case TCL_TRANSLATE_CRLF: + for (srcCopied = 0, dPtr = destPtr, sPtr = src; + dPtr < destPtr + destCopied; + dPtr++, sPtr++, srcCopied++) { + if (*sPtr == '\n') { + if (crsent) { + *dPtr = '\n'; + crsent = 0; + } else { + *dPtr = '\r'; + crsent = 1; + sPtr--, srcCopied--; + } + } else { + *dPtr = *sPtr; + } + } + break; + case TCL_TRANSLATE_AUTO: + panic("Tcl_Write: AUTO output translation mode not supported"); + default: + panic("Tcl_Write: unknown output translation mode"); + } - /* - * Make the callback or return the number of bytes transferred. - * The local total is used because StopCopy frees csPtr. - */ + /* + * The current buffer is ready for output if it is full, or if it + * contains a newline and this channel is line-buffered, or if it + * contains any output and this channel is unbuffered. + */ - total = csPtr->total; - if (cmdPtr) { - /* - * Get a private copy of the command so we can mutate it - * by adding arguments. Note that StopCopy frees our saved - * reference to the original command obj. - */ + outBufPtr->nextAdded += destCopied; + if (!(chanPtr->flags & BUFFER_READY)) { + if (outBufPtr->nextAdded == outBufPtr->bufLength) { + chanPtr->flags |= BUFFER_READY; + } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + for (sPtr = src, i = 0, foundNewline = 0; + (i < srcCopied) && (!foundNewline); + i++, sPtr++) { + if (*sPtr == '\n') { + foundNewline = 1; + break; + } + } + if (foundNewline) { + chanPtr->flags |= BUFFER_READY; + } + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + chanPtr->flags |= BUFFER_READY; + } + } + + totalDestCopied += srcCopied; + src += srcCopied; + srcLen -= srcCopied; - cmdPtr = Tcl_DuplicateObj(cmdPtr); - Tcl_IncrRefCount(cmdPtr); - StopCopy(csPtr); - Tcl_Preserve((ClientData) interp); + if (chanPtr->flags & BUFFER_READY) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } + } + } /* Closes "while" */ - Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(total)); - if (errObj) { - Tcl_ListObjAppendElement(interp, cmdPtr, errObj); - } - if (Tcl_GlobalEvalObj(interp, cmdPtr) != TCL_OK) { - Tcl_BackgroundError(interp); - result = TCL_ERROR; - } - Tcl_DecrRefCount(cmdPtr); - Tcl_Release((ClientData) interp); - } else { - StopCopy(csPtr); - if (errObj) { - Tcl_SetObjResult(interp, errObj); - result = TCL_ERROR; - } else { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), total); - } - } - return result; + return totalDestCopied; } /* @@ -6051,3 +7555,49 @@ StopCopy(csPtr) csPtr->writePtr->csPtr = NULL; ckfree((char*) csPtr); } + +/* + *---------------------------------------------------------------------- + * + * SetBlockMode -- + * + * This function sets the blocking mode for a channel and updates + * the state flags. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Modifies the blocking mode of the channel and possibly generates + * an error. + * + *---------------------------------------------------------------------- + */ + +static int +SetBlockMode(interp, chanPtr, mode) + Tcl_Interp *interp; /* Interp for error reporting. */ + Channel *chanPtr; /* Channel to modify. */ + int mode; /* One of TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + int result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + mode); + } + if (result != 0) { + Tcl_SetErrno(result); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "error setting blocking mode: ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + if (mode == TCL_MODE_BLOCKING) { + chanPtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED)); + } else { + chanPtr->flags |= CHANNEL_NONBLOCKING; + } + return TCL_OK; +} diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index b1ed0c8..f88840b 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -3,22 +3,16 @@ * * Contains the definitions of most of the Tcl commands relating to IO. * - * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * Copyright (c) 1995-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: tclIOCmd.c,v 1.4 1999/02/02 22:25:42 stanton Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.5 1999/04/16 00:46:47 stanton Exp $ */ -#include "tclInt.h" -#include "tclPort.h" - -/* - * Return at most this number of bytes in one call to Tcl_Read: - */ - -#define TCL_READ_CHUNK_SIZE 4096 +#include "tclInt.h" +#include "tclPort.h" /* * Callback structure for accept callback in a TCP server. @@ -76,12 +70,10 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) int mode; /* Mode in which channel is opened. */ char *arg; int length; - Tcl_Obj *resultPtr; i = 1; newline = 1; - if ((objc >= 2) && (strcmp(Tcl_GetStringFromObj(objv[1], NULL), - "-nonewline") == 0)) { + if ((objc >= 2) && (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0)) { newline = 0; i++; } @@ -95,53 +87,46 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) * form of the command that is no longer recommended or documented. */ - resultPtr = Tcl_NewObj(); if (i == (objc-3)) { - arg = Tcl_GetStringFromObj(objv[i+2], &length); + arg = Tcl_GetStringFromObj(objv[i + 2], &length); if (strncmp(arg, "nonewline", (size_t) length) != 0) { - Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg, + Tcl_AppendResult(interp, "bad argument \"", arg, "\": should be \"nonewline\"", (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); return TCL_ERROR; } newline = 0; } - if (i == (objc-1)) { + if (i == (objc - 1)) { channelId = "stdout"; } else { - channelId = Tcl_GetStringFromObj(objv[i], NULL); + channelId = Tcl_GetString(objv[i]); i++; } chan = Tcl_GetChannel(interp, channelId, &mode); if (chan == (Tcl_Channel) NULL) { - Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendStringsToObj(resultPtr, "channel \"", channelId, + Tcl_AppendResult(interp, "channel \"", channelId, "\" wasn't opened for writing", (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[i], &length); - result = Tcl_Write(chan, arg, length); + result = Tcl_WriteObj(chan, objv[i]); if (result < 0) { goto error; } if (newline != 0) { - result = Tcl_Write(chan, "\n", 1); + result = Tcl_WriteChars(chan, "\n", 1); if (result < 0) { goto error; } } - Tcl_SetObjResult(interp, resultPtr); return TCL_OK; -error: - Tcl_AppendStringsToObj(resultPtr, "error writing \"", - Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), - (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); + + error: + Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -171,31 +156,27 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to flush on. */ - char *arg; - Tcl_Obj *resultPtr; + char *channelId; int mode; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[1], NULL); - chan = Tcl_GetChannel(interp, arg, &mode); + channelId = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, channelId, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - resultPtr = Tcl_GetObjResult(interp); if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendStringsToObj(resultPtr, "channel \"", - Tcl_GetStringFromObj(objv[1], NULL), - "\" wasn't opened for writing", (char *) NULL); + Tcl_AppendResult(interp, "channel \"", channelId, + "\" wasn't opened for writing", (char *) NULL); return TCL_ERROR; } if (Tcl_Flush(chan) != TCL_OK) { - Tcl_AppendStringsToObj(resultPtr, "error flushing \"", - Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), - (char *) NULL); + Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -229,51 +210,56 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) Tcl_Channel chan; /* The channel to read from. */ int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ - char *arg; - Tcl_Obj *resultPtr, *objPtr; + char *name; + Tcl_Obj *resultPtr, *linePtr; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[1], NULL); - chan = Tcl_GetChannel(interp, arg, &mode); + name = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, name, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - resultPtr = Tcl_NewObj(); if ((mode & TCL_READABLE) == 0) { - Tcl_AppendStringsToObj(resultPtr, "channel \"", arg, - "\" wasn't opened for reading", (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); + Tcl_AppendResult(interp, "channel \"", name, + "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } - lineLen = Tcl_GetsObj(chan, resultPtr); + resultPtr = Tcl_GetObjResult(interp); + linePtr = resultPtr; + if (objc == 3) { + /* + * Variable gets line, interp get bytecount. + */ + + linePtr = Tcl_NewObj(); + } + + lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { - Tcl_SetObjLength(resultPtr, 0); - Tcl_AppendStringsToObj(resultPtr, "error reading \"", - Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), - (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); + if (linePtr != resultPtr) { + Tcl_DecrRefCount(linePtr); + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } lineLen = -1; } if (objc == 3) { - Tcl_ResetResult(interp); - objPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, - resultPtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); - if (objPtr == NULL) { - Tcl_DecrRefCount(resultPtr); + if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(linePtr); return TCL_ERROR; } - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), lineLen); + Tcl_SetIntObj(resultPtr, lineLen); return TCL_OK; } - Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -302,32 +288,25 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to read from. */ - int newline, i; /* Discard newline at end? */ - int toRead; /* How many bytes to read? */ - int toReadNow; /* How many bytes to attempt to - * read in the current iteration? */ - int charactersRead; /* How many characters were read? */ - int charactersReadNow; /* How many characters were read - * in this iteration? */ - int mode; /* Mode in which channel is opened. */ - int bufSize; /* Channel buffer size; used to decide - * in what chunk sizes to read from - * the channel. */ - char *arg; + Tcl_Channel chan; /* The channel to read from. */ + int newline, i; /* Discard newline at end? */ + int toRead; /* How many bytes to read? */ + int charactersRead; /* How many characters were read? */ + int mode; /* Mode in which channel is opened. */ + char *name; Tcl_Obj *resultPtr; if ((objc != 2) && (objc != 3)) { -argerror: + argerror: Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numBytes?"); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " or \"", - Tcl_GetStringFromObj(objv[0], NULL), + Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]), " ?-nonewline? channelId\"", (char *) NULL); return TCL_ERROR; } + i = 1; newline = 0; - if (strcmp(Tcl_GetStringFromObj(objv[1], NULL), "-nonewline") == 0) { + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { newline = 1; i++; } @@ -336,18 +315,16 @@ argerror: goto argerror; } - arg = Tcl_GetStringFromObj(objv[i], NULL); - chan = Tcl_GetChannel(interp, arg, &mode); + name = Tcl_GetString(objv[i]); + chan = Tcl_GetChannel(interp, name, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - resultPtr = Tcl_GetObjResult(interp); - Tcl_AppendStringsToObj(resultPtr, "channel \"", arg, + Tcl_AppendResult(interp, "channel \"", name, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } - i++; /* Consumed channel name. */ /* @@ -355,112 +332,53 @@ argerror: * newline should be dropped. */ - toRead = INT_MAX; + toRead = -1; if (i < objc) { - arg = Tcl_GetStringFromObj(objv[i], NULL); - if (isdigit((unsigned char) (arg[0]))) { + char *arg; + + arg = Tcl_GetString(objv[i]); + if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { return TCL_ERROR; } - Tcl_ResetResult(interp); } else if (strcmp(arg, "nonewline") == 0) { newline = 1; } else { - resultPtr = Tcl_GetObjResult(interp); - Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg, + Tcl_AppendResult(interp, "bad argument \"", arg, "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; } } - /* - * Create a new object and use that instead of the interpreter - * result. We cannot use the interpreter's result object because - * it may get smashed at any time by recursive calls. - */ - - resultPtr = Tcl_NewObj(); - - bufSize = Tcl_GetChannelBufferSize(chan); - - /* - * If the caller specified a maximum length to read, then that is - * a good size to preallocate. - */ - - if ((toRead != INT_MAX) && (toRead > bufSize)) { - Tcl_SetObjLength(resultPtr, toRead); - } - - for (charactersRead = 0; charactersRead < toRead; ) { - toReadNow = toRead - charactersRead; - if (toReadNow > bufSize) { - toReadNow = bufSize; - } - - /* - * NOTE: This is a NOOP if we set the size (above) to the - * number of bytes we expect to read. In the degenerate - * case, however, it will grow the buffer by the channel - * buffersize, which is 4K in most cases. This will result - * in inefficient copying for large files. This will be - * fixed in a future release. - */ - - Tcl_SetObjLength(resultPtr, charactersRead + toReadNow); - charactersReadNow = - Tcl_Read(chan, Tcl_GetStringFromObj(resultPtr, NULL) - + charactersRead, toReadNow); - if (charactersReadNow < 0) { - Tcl_SetObjLength(resultPtr, 0); - Tcl_AppendStringsToObj(resultPtr, "error reading \"", - Tcl_GetChannelName(chan), "\": ", - Tcl_PosixError(interp), (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); - - return TCL_ERROR; - } - - /* - * If we had a short read it means that we have either EOF - * or BLOCKED on the channel, so break out. - */ - - charactersRead += charactersReadNow; - - /* - * Do not call the driver again if we got a short read - */ - - if (charactersReadNow < toReadNow) { - break; /* Out of "for" loop. */ - } + resultPtr = Tcl_GetObjResult(interp); + charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); + if (charactersRead < 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; } /* * If requested, remove the last newline in the channel if at EOF. */ - if ((charactersRead > 0) && (newline) && - (Tcl_GetStringFromObj(resultPtr, NULL)[charactersRead-1] == '\n')) { - charactersRead--; - } - Tcl_SetObjLength(resultPtr, charactersRead); - - /* - * Now set the object into the interpreter result and release our - * hold on it by decrrefing it. - */ + if ((charactersRead > 0) && (newline != 0)) { + char *result; + int length; - Tcl_SetObjResult(interp, resultPtr); - + result = Tcl_GetStringFromObj(resultPtr, &length); + if (result[length - 1] == '\n') { + Tcl_SetObjLength(resultPtr, length - 1); + } + } return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_SeekCmd -- + * Tcl_SeekObjCmd -- * * This procedure is invoked to process the Tcl "seek" command. See * the user documentation for details on what it does. @@ -477,53 +395,45 @@ argerror: /* ARGSUSED */ int -Tcl_SeekCmd(clientData, interp, argc, argv) +Tcl_SeekObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ int offset, mode; /* Where to seek? */ int result; /* Of calling Tcl_Seek. */ + char *chanName; + int optionIndex; + static char *originOptions[] = {"start", "current", "end", (char *) NULL}; + static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId offset ?origin?\"", (char *) NULL); + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?"); return TCL_ERROR; } - chan = Tcl_GetChannel(interp, argv[1], NULL); + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[2], &offset) != TCL_OK) { return TCL_ERROR; } mode = SEEK_SET; - if (argc == 4) { - size_t length; - int c; - - length = strlen(argv[3]); - c = argv[3][0]; - if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) { - mode = SEEK_SET; - } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) { - mode = SEEK_CUR; - } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) { - mode = SEEK_END; - } else { - Tcl_AppendResult(interp, "bad origin \"", argv[3], - "\": should be start, current, or end", (char *) NULL); + if (objc == 4) { + if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0, + &optionIndex) != TCL_OK) { return TCL_ERROR; } + mode = modeArray[optionIndex]; } result = Tcl_Seek(chan, offset, mode); if (result == -1) { Tcl_AppendResult(interp, "error during seek on \"", - Tcl_GetChannelName(chan), "\": ", - Tcl_PosixError(interp), (char *) NULL); + chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -532,7 +442,7 @@ Tcl_SeekCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * - * Tcl_TellCmd -- + * Tcl_TellObjCmd -- * * This procedure is invoked to process the Tcl "tell" command. * See the user documentation for details on what it does. @@ -548,18 +458,17 @@ Tcl_SeekCmd(clientData, interp, argc, argv) /* ARGSUSED */ int -Tcl_TellCmd(clientData, interp, argc, argv) +Tcl_TellObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ - char buf[40]; + char *chanName; - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId\"", (char *) NULL); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } /* @@ -567,12 +476,12 @@ Tcl_TellCmd(clientData, interp, argc, argv) * the IO channel table of this interpreter. */ - chan = Tcl_GetChannel(interp, argv[1], NULL); + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - TclFormatInt(buf, Tcl_Tell(chan)); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan)); return TCL_OK; } @@ -602,7 +511,6 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to close. */ - int len; /* Length of error output. */ char *arg; if (objc != 2) { @@ -610,7 +518,7 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[1], NULL); + arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; @@ -620,7 +528,7 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) /* * If there is an error message and it ends with a newline, remove * the newline. This is done for command pipeline channels where the - * error output from the subprocesses is stored in interp->result. + * error output from the subprocesses is stored in interp's result. * * NOTE: This is likely to not have any effect on regular error * messages produced by drivers during the closing of a channel, @@ -628,11 +536,15 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) * have a terminating newline. */ - len = strlen(interp->result); - if ((len > 0) && (interp->result[len - 1] == '\n')) { - interp->result[len - 1] = '\0'; + Tcl_Obj *resultPtr; + char *string; + int len; + + resultPtr = Tcl_GetObjResult(interp); + string = Tcl_GetStringFromObj(resultPtr, &len); + if ((len > 0) && (string[len - 1] == '\n')) { + Tcl_SetObjLength(resultPtr, len - 1); } - return TCL_ERROR; } @@ -642,7 +554,7 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_FconfigureCmd -- + * Tcl_FconfigureObjCmd -- * * This procedure is invoked to process the Tcl "fconfigure" command. * See the user documentation for details on what it does. @@ -658,28 +570,29 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) /* ARGSUSED */ int -Tcl_FconfigureCmd(clientData, interp, argc, argv) +Tcl_FconfigureObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { + char *chanName, *optionName, *valueName; Tcl_Channel chan; /* The channel to set a mode on. */ int i; /* Iterate over arg-value pairs. */ Tcl_DString ds; /* DString to hold result of * calling Tcl_GetChannelOption. */ - if ((argc < 2) || (((argc % 2) == 1) && (argc != 3))) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId ?optionName? ?value? ?optionName value?...\"", - (char *) NULL); + if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { + Tcl_WrongNumArgs(interp, 1, objv, + "channelId ?optionName? ?value? ?optionName value?..."); return TCL_ERROR; } - chan = Tcl_GetChannel(interp, argv[1], NULL); + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - if (argc == 2) { + if (objc == 2) { Tcl_DStringInit(&ds); if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) { Tcl_DStringFree(&ds); @@ -688,17 +601,21 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv) Tcl_DStringResult(interp, &ds); return TCL_OK; } - if (argc == 3) { + if (objc == 3) { Tcl_DStringInit(&ds); - if (Tcl_GetChannelOption(interp, chan, argv[2], &ds) != TCL_OK) { + optionName = Tcl_GetString(objv[2]); + if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { Tcl_DStringFree(&ds); return TCL_ERROR; } Tcl_DStringResult(interp, &ds); return TCL_OK; } - for (i = 3; i < argc; i += 2) { - if (Tcl_SetChannelOption(interp, chan, argv[i-1], argv[i]) != TCL_OK) { + for (i = 3; i < objc; i += 2) { + optionName = Tcl_GetString(objv[i-1]); + valueName = Tcl_GetString(objv[i]); + if (Tcl_SetChannelOption(interp, chan, optionName, valueName) + != TCL_OK) { return TCL_ERROR; } } @@ -706,7 +623,7 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_EofObjCmd -- * @@ -717,10 +634,10 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv) * A standard Tcl result. * * Side effects: - * Sets interp->result to "0" or "1" depending on whether the - * specified channel has an EOF condition. + * Sets interp's result to boolean true or false depending on whether + * the specified channel has an EOF condition. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ /* ARGSUSED */ @@ -731,9 +648,8 @@ Tcl_EofObjCmd(unused, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to query for EOF. */ - int mode; /* Mode in which channel is opened. */ - char buf[40]; + Tcl_Channel chan; + int dummy; char *arg; if (objc != 2) { @@ -741,21 +657,20 @@ Tcl_EofObjCmd(unused, interp, objc, objv) return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[1], NULL); - chan = Tcl_GetChannel(interp, arg, &mode); - if (chan == (Tcl_Channel) NULL) { + arg = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, arg, &dummy); + if (chan == NULL) { return TCL_ERROR; } - TclFormatInt(buf, Tcl_Eof(chan) ? 1 : 0); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_Eof(chan)); return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_ExecCmd -- + * Tcl_ExecObjCmd -- * * This procedure is invoked to process the "exec" Tcl command. * See the user documentation for details on what it does. @@ -771,44 +686,63 @@ Tcl_EofObjCmd(unused, interp, objc, objv) /* ARGSUSED */ int -Tcl_ExecCmd(dummy, interp, argc, argv) +Tcl_ExecObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { #ifdef MAC_TCL + Tcl_AppendResult(interp, "exec not implemented under Mac OS", (char *)NULL); return TCL_ERROR; + #else /* !MAC_TCL */ - int keepNewline, firstWord, background, length, result; + + /* + * This procedure generates an argv array for the string arguments. It + * starts out with stack-allocated space but uses dynamically-allocated + * storage if needed. + */ + +#define NUM_ARGS 20 + Tcl_Obj *resultPtr; + char **argv; + char *string; Tcl_Channel chan; - Tcl_DString ds; - int readSoFar, readNow, bufSize; + char *argStorage[NUM_ARGS]; + int argc, background, i, index, keepNewline, result, skip, length; + static char *options[] = { + "-keepnewline", "--", NULL + }; + enum options { + EXEC_KEEPNEWLINE, EXEC_LAST + }; /* * Check for a leading "-keepnewline" argument. */ keepNewline = 0; - for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-'); - firstWord++) { - if (strcmp(argv[firstWord], "-keepnewline") == 0) { - keepNewline = 1; - } else if (strcmp(argv[firstWord], "--") == 0) { - firstWord++; + for (skip = 1; skip < objc; skip++) { + string = Tcl_GetString(objv[skip]); + if (string[0] != '-') { break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argv[firstWord], - "\": must be -keepnewline or --", (char *) NULL); + } + if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", + TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } + if (index == EXEC_KEEPNEWLINE) { + keepNewline = 1; + } else { + skip++; + break; + } } - - if (argc <= firstWord) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? arg ?arg ...?\"", (char *) NULL); + if (objc <= skip) { + Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?"); return TCL_ERROR; } @@ -817,84 +751,100 @@ Tcl_ExecCmd(dummy, interp, argc, argv) */ background = 0; - if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) { - argc--; - argv[argc] = NULL; + string = Tcl_GetString(objv[objc - 1]); + if ((string[0] == '&') && (string[1] == '\0')) { + objc--; background = 1; } - - chan = Tcl_OpenCommandChannel(interp, argc-firstWord, - argv+firstWord, - (background ? 0 : TCL_STDOUT | TCL_STDERR)); + + /* + * Create the string argument array "argv". Make sure argv is large + * enough to hold the argc arguments plus 1 extra for the zero + * end-of-argv word. + */ + + argv = argStorage; + argc = objc - skip; + if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) { + argv = (char **) ckalloc((unsigned)(argc + 1) * sizeof(char *)); + } + + /* + * Copy the string conversions of each (post option) object into the + * argument vector. + */ + + for (i = 0; i < argc; i++) { + argv[i] = Tcl_GetString(objv[i + skip]); + } + argv[argc] = NULL; + chan = Tcl_OpenCommandChannel(interp, argc, argv, + (background ? 0 : TCL_STDOUT | TCL_STDERR)); + + /* + * Free the argv array if malloc'ed storage was used. + */ + + if (argv != argStorage) { + ckfree((char *)argv); + } if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } if (background) { - /* - * Get the list of PIDs from the pipeline into interp->result and - * detach the PIDs (instead of waiting for them). - */ + * Store the list of PIDs from the pipeline in interp's result and + * detach the PIDs (instead of waiting for them). + */ TclGetAndDetachPids(interp, chan); - if (Tcl_Close(interp, chan) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } - return TCL_OK; + return TCL_OK; } + resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { -#define EXEC_BUFFER_SIZE 4096 - - Tcl_DStringInit(&ds); - readSoFar = 0; bufSize = 0; - while (1) { - bufSize += EXEC_BUFFER_SIZE; - Tcl_DStringSetLength(&ds, bufSize); - readNow = Tcl_Read(chan, Tcl_DStringValue(&ds) + readSoFar, - EXEC_BUFFER_SIZE); - if (readNow < 0) { - Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, - "error reading output from command: ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - readSoFar += readNow; - if (readNow < EXEC_BUFFER_SIZE) { - break; /* Out of "while (1)" loop. */ - } - } - Tcl_DStringSetLength(&ds, readSoFar); - Tcl_DStringResult(interp, &ds); + if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading output from command: ", + Tcl_PosixError(interp), (char *) NULL); + Tcl_DecrRefCount(resultPtr); + return TCL_ERROR; + } } + /* + * If the process produced anything on stderr, it will have been + * returned in the interpreter result. It needs to be appended to + * the result string. + */ result = Tcl_Close(interp, chan); + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + Tcl_AppendToObj(resultPtr, string, length); /* - * If the last character of interp->result is a newline, then remove - * the newline character (the newline would just confuse things). - * Special hack: must replace the old terminating null character - * as a signal to Tcl_AppendResult et al. that we've mucked with - * the string. + * If the last character of the result is a newline, then remove + * the newline character. */ - length = strlen(interp->result); - if (!keepNewline && (length > 0) && - (interp->result[length-1] == '\n')) { - interp->result[length-1] = '\0'; - interp->result[length] = 'x'; + if (keepNewline == 0) { + string = Tcl_GetStringFromObj(resultPtr, &length); + if ((length > 0) && (string[length - 1] == '\n')) { + Tcl_SetObjLength(resultPtr, length - 1); + } } + Tcl_SetObjResult(interp, resultPtr); return result; #endif /* !MAC_TCL */ } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_FblockedObjCmd -- * @@ -905,10 +855,10 @@ Tcl_ExecCmd(dummy, interp, argc, argv) * A standard Tcl result. * * Side effects: - * Sets interp->result to "0" or "1" depending on whether the - * a preceding input operation on the channel would have blocked. + * Sets interp's result to boolean true or false depending on whether + * the preceeding input operation on the channel would have blocked. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ /* ARGSUSED */ @@ -919,9 +869,8 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to query for blocked. */ - int mode; /* Mode in which channel was opened. */ - char buf[40]; + Tcl_Channel chan; + int mode; char *arg; if (objc != 2) { @@ -929,20 +878,18 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[1], NULL); + arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, &mode); - if (chan == (Tcl_Channel) NULL) { + if (chan == NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", - Tcl_GetStringFromObj(objv[1], NULL), - "\" wasn't opened for reading", (char *) NULL); + arg, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } - TclFormatInt(buf, Tcl_InputBlocked(chan) ? 1 : 0); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_InputBlocked(chan)); return TCL_OK; } @@ -965,35 +912,35 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) /* ARGSUSED */ int -Tcl_OpenObjCmd(notUsed, interp, argc, objv) +Tcl_OpenObjCmd(notUsed, interp, objc, objv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - Tcl_Obj * CONST objv[]; /* Argument objects. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int pipeline, prot; - char *modeString, *arg1; + char *modeString, *what; Tcl_Channel chan; - if ((argc < 2) || (argc > 4)) { + if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?"); return TCL_ERROR; } prot = 0666; - if (argc == 2) { + if (objc == 2) { modeString = "r"; } else { - modeString = Tcl_GetStringFromObj(objv[2], NULL); - if (argc == 4) { + modeString = Tcl_GetString(objv[2]); + if (objc == 4) { if (Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) { return TCL_ERROR; } } } - arg1 = Tcl_GetStringFromObj(objv[1], NULL); pipeline = 0; - if (arg1[0] == '|') { + what = Tcl_GetString(objv[1]); + if (what[0] == '|') { pipeline = 1; } @@ -1002,18 +949,18 @@ Tcl_OpenObjCmd(notUsed, interp, argc, objv) */ if (!pipeline) { - chan = Tcl_OpenFileChannel(interp, arg1, modeString, prot); + chan = Tcl_OpenFileChannel(interp, what, modeString, prot); } else { #ifdef MAC_TCL - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tcl_AppendResult(interp, "command pipelines not supported on Macintosh OS", (char *)NULL); return TCL_ERROR; #else - int mode, seekFlag, cmdArgc; + int mode, seekFlag, cmdObjc; char **cmdArgv; - if (Tcl_SplitList(interp, arg1+1, &cmdArgc, &cmdArgv) != TCL_OK) { + if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { return TCL_ERROR; } @@ -1036,7 +983,7 @@ Tcl_OpenObjCmd(notUsed, interp, argc, objv) panic("Tcl_OpenCmd: invalid mode value"); break; } - chan = Tcl_OpenCommandChannel(interp, cmdArgc, cmdArgv, flags); + chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); } ckfree((char *) cmdArgv); #endif @@ -1045,8 +992,7 @@ Tcl_OpenObjCmd(notUsed, interp, argc, objv) return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - Tcl_GetChannelName(chan), (char *) NULL); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); return TCL_OK; } @@ -1218,7 +1164,7 @@ AcceptCallbackProc(callbackData, chan, address, port) AcceptCallback *acceptCallbackPtr; Tcl_Interp *interp; char *script; - char portBuf[10]; + char portBuf[TCL_INTEGER_SPACE]; int result; acceptCallbackPtr = (AcceptCallback *) callbackData; @@ -1315,7 +1261,7 @@ TcpServerCloseProc(callbackData) /* *---------------------------------------------------------------------- * - * Tcl_SocketCmd -- + * Tcl_SocketObjCmd -- * * This procedure is invoked to process the "socket" Tcl command. * See the user documentation for details on what it does. @@ -1330,13 +1276,19 @@ TcpServerCloseProc(callbackData) */ int -Tcl_SocketCmd(notUsed, interp, argc, argv) +Tcl_SocketObjCmd(notUsed, interp, objc, objv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int a, server, port; + static char *socketOptions[] = { + "-async", "-myaddr", "-myport","-server", (char *) NULL + }; + enum socketOptions { + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + }; + int optionIndex, a, server, port; char *arg, *copyScript, *host, *script; char *myaddr = NULL; int myport = 0; @@ -1347,66 +1299,78 @@ Tcl_SocketCmd(notUsed, interp, argc, argv) server = 0; script = NULL; - if (TclHasSockets(interp) != TCL_OK) { + if (TclpHasSockets(interp) != TCL_OK) { return TCL_ERROR; } - for (a = 1; a < argc; a++) { - arg = argv[a]; - if (arg[0] == '-') { - if (strcmp(arg, "-server") == 0) { - if (async == 1) { + for (a = 1; a < objc; a++) { + arg = Tcl_GetString(objv[a]); + if (arg[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, + "option", TCL_EXACT, &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum socketOptions) optionIndex) { + case SKT_ASYNC: { + if (server == 1) { Tcl_AppendResult(interp, "cannot set -async option for server sockets", (char *) NULL); return TCL_ERROR; } - server = 1; - a++; - if (a >= argc) { - Tcl_AppendResult(interp, - "no argument given for -server option", - (char *) NULL); - return TCL_ERROR; - } - script = argv[a]; - } else if (strcmp(arg, "-myaddr") == 0) { + async = 1; + break; + } + case SKT_MYADDR: { a++; - if (a >= argc) { + if (a >= objc) { Tcl_AppendResult(interp, "no argument given for -myaddr option", (char *) NULL); return TCL_ERROR; } - myaddr = argv[a]; - } else if (strcmp(arg, "-myport") == 0) { + myaddr = Tcl_GetString(objv[a]); + break; + } + case SKT_MYPORT: { + char *myPortName; a++; - if (a >= argc) { + if (a >= objc) { Tcl_AppendResult(interp, "no argument given for -myport option", (char *) NULL); return TCL_ERROR; } - if (TclSockGetPort(interp, argv[a], "tcp", &myport) - != TCL_OK) { + myPortName = Tcl_GetString(objv[a]); + if (TclSockGetPort(interp, myPortName, "tcp", &myport) + != TCL_OK) { return TCL_ERROR; } - } else if (strcmp(arg, "-async") == 0) { - if (server == 1) { + break; + } + case SKT_SERVER: { + if (async == 1) { Tcl_AppendResult(interp, "cannot set -async option for server sockets", (char *) NULL); return TCL_ERROR; } - async = 1; - } else { - Tcl_AppendResult(interp, "bad option \"", arg, - "\", must be -async, -myaddr, -myport, or -server", - (char *) NULL); - return TCL_ERROR; + server = 1; + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -server option", + (char *) NULL); + return TCL_ERROR; + } + script = Tcl_GetString(objv[a]); + break; + } + default: { + panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } - } else { - break; } } if (server) { @@ -1416,22 +1380,23 @@ Tcl_SocketCmd(notUsed, interp, argc, argv) NULL); return TCL_ERROR; } - } else if (a < argc) { - host = argv[a]; + } else if (a < objc) { + host = Tcl_GetString(objv[a]); a++; } else { wrongNumArgs: Tcl_AppendResult(interp, "wrong # args: should be either:\n", - argv[0], + Tcl_GetString(objv[0]), " ?-myaddr addr? ?-myport myport? ?-async? host port\n", - argv[0], + Tcl_GetString(objv[0]), " -server command ?-myaddr addr? port", (char *) NULL); return TCL_ERROR; } - if (a == argc-1) { - if (TclSockGetPort(interp, argv[a], "tcp", &port) != TCL_OK) { + if (a == objc-1) { + if (TclSockGetPort(interp, Tcl_GetString(objv[a]), + "tcp", &port) != TCL_OK) { return TCL_ERROR; } } else { @@ -1510,10 +1475,10 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) Tcl_Channel inChan, outChan; char *arg; int mode, i; - int toRead; + int toRead, index; Tcl_Obj *cmdPtr; static char* switches[] = { "-size", "-command", NULL }; - enum { FcopySize, FcopyCommand } index; + enum { FcopySize, FcopyCommand }; if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1526,25 +1491,25 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) * or writable, as appropriate. */ - arg = Tcl_GetStringFromObj(objv[1], NULL); + arg = Tcl_GetString(objv[1]); inChan = Tcl_GetChannel(interp, arg, &mode); if (inChan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", - Tcl_GetStringFromObj(objv[1], NULL), + Tcl_GetString(objv[1]), "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[2], NULL); + arg = Tcl_GetString(objv[2]); outChan = Tcl_GetChannel(interp, arg, &mode); if (outChan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", - Tcl_GetStringFromObj(objv[1], NULL), + Tcl_GetString(objv[1]), "\" wasn't opened for writing", (char *) NULL); return TCL_ERROR; } diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 1f0be9e..3fb9e8d 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -3,19 +3,19 @@ * * Common routines used by all socket based channel types. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright (c) 1995-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: tclIOSock.c,v 1.2 1998/09/14 18:39:59 stanton Exp $ + * RCS: @(#) $Id: tclIOSock.c,v 1.3 1999/04/16 00:46:47 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TclSockGetPort -- * @@ -24,14 +24,14 @@ * registered service names to port numbers. * * Results: - * A standard Tcl result. On success, the port number is - * returned in portPtr. On failure, an error message is left in - * interp->result. + * A standard Tcl result. On success, the port number is returned + * in portPtr. On failure, an error message is left in the interp's + * result. * * Side effects: * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -42,14 +42,21 @@ TclSockGetPort(interp, string, proto, portPtr) int *portPtr; /* Return port number */ { struct servent *sp; /* Protocol info for named services */ - if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { - sp = getservbyname(string, proto); + Tcl_DString ds; + char *native; + + if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) { + /* + * Don't bother translating 'proto' to native. + */ + + native = Tcl_UtfToExternalDString(NULL, string, -1, &ds); + sp = getservbyname(native, proto); /* INTL: Native. */ + Tcl_DStringFree(&ds); if (sp != NULL) { *portPtr = ntohs((unsigned short) sp->s_port); - Tcl_ResetResult(interp); /* clear error message */ return TCL_OK; } - return TCL_ERROR; } if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { return TCL_ERROR; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index c02738e..6a00e54 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -8,12 +8,12 @@ * Lehenbauer, Mark Diekhans and Peter da Silva. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * 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: tclIOUtil.c,v 1.5 1998/09/14 18:40:00 stanton Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.6 1999/04/16 00:46:47 stanton Exp $ */ #include "tclInt.h" @@ -54,7 +54,9 @@ typedef struct OpenFileChannelProc { * these statically declared list entry cannot be inadvertently removed. * * This method avoids the need to call any sort of "initialization" - * function + * function. + * + * All three lists are protected by a global hookMutex. */ static StatProc defaultStatProc = { @@ -72,9 +74,11 @@ static OpenFileChannelProc defaultOpenFileChannelProc = { }; static OpenFileChannelProc *openFileChannelProcList = &defaultOpenFileChannelProc; + +TCL_DECLARE_MUTEX(hookMutex) /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TclGetOpenMode -- * @@ -85,8 +89,8 @@ static OpenFileChannelProc *openFileChannelProcList = * * Results: * On success, returns mode to pass to "open". If an error occurs, the - * returns -1 and if interp is not NULL, sets interp->result to an - * error message. + * return value is -1 and if interp is not NULL, sets interp's result + * object to an error message. * * Side effects: * Sets the integer referenced by seekFlagPtr to 1 to tell the caller @@ -96,7 +100,7 @@ static OpenFileChannelProc *openFileChannelProcList = * This code is based on a prototype implementation contributed * by Mark Diekhans. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -121,7 +125,14 @@ TclGetOpenMode(interp, string, seekFlagPtr) *seekFlagPtr = 0; mode = 0; - if (islower(UCHAR(string[0]))) { + + /* + * Guard against international characters before using byte oriented + * routines. + */ + + if (!(string[0] & 0x80) + && islower(UCHAR(string[0]))) { /* INTL: ISO only. */ switch (string[0]) { case 'r': mode = O_RDONLY; @@ -265,82 +276,57 @@ Tcl_EvalFile(interp, fileName) char *fileName; /* Name of file to process. Tilde-substitution * will be performed on this name. */ { - int result; + int result, length; struct stat statBuf; - char *cmdBuffer = (char *) NULL; char *oldScriptFile; - Interp *iPtr = (Interp *) interp; - Tcl_DString buffer; - char *nativeName; + Interp *iPtr; + Tcl_DString nameString; + char *name, *string; Tcl_Channel chan; - Tcl_Obj *cmdObjPtr; + Tcl_Obj *objPtr; - Tcl_ResetResult(interp); - oldScriptFile = iPtr->scriptFile; - iPtr->scriptFile = fileName; - Tcl_DStringInit(&buffer); - nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (nativeName == NULL) { - goto error; + name = Tcl_TranslateFileName(interp, fileName, &nameString); + if (name == NULL) { + return TCL_ERROR; } - /* - * If Tcl_TranslateFileName didn't already copy the file name, do it - * here. This way we don't depend on fileName staying constant - * throughout the execution of the script (e.g., what if it happens - * to point to a Tcl variable that the script could change?). - */ + result = TCL_ERROR; + objPtr = Tcl_NewObj(); - if (nativeName != Tcl_DStringValue(&buffer)) { - Tcl_DStringSetLength(&buffer, 0); - Tcl_DStringAppend(&buffer, nativeName, -1); - nativeName = Tcl_DStringValue(&buffer); - } - if (TclStat(nativeName, &statBuf) == -1) { + if (TclStat(name, &statBuf) == -1) { Tcl_SetErrno(errno); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); - goto error; + goto end; } - chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644); + chan = Tcl_OpenFileChannel(interp, name, "r", 0644); if (chan == (Tcl_Channel) NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); - goto error; + goto end; } - cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1); - result = Tcl_Read(chan, cmdBuffer, statBuf.st_size); - if (result < 0) { + if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { Tcl_Close(interp, chan); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); - goto error; + goto end; } - cmdBuffer[result] = 0; if (Tcl_Close(interp, chan) != TCL_OK) { - goto error; + goto end; } - /* - * Transfer the buffer memory allocated above to the object system. - * Tcl_EvalObj will own this new string object if needed, - * so past the Tcl_EvalObj point, we must not ckfree(cmdBuffer) - * but rather use the reference counting mechanism. - * (Nb: and we must not thus not use goto error after this point) - */ - cmdObjPtr = Tcl_NewObj(); - cmdObjPtr->bytes = cmdBuffer; - cmdObjPtr->length = result; - - Tcl_IncrRefCount(cmdObjPtr); - result = Tcl_EvalObj(interp, cmdObjPtr); - Tcl_DecrRefCount(cmdObjPtr); + iPtr = (Interp *) interp; + oldScriptFile = iPtr->scriptFile; + iPtr->scriptFile = fileName; + string = Tcl_GetStringFromObj(objPtr, &length); + result = Tcl_EvalEx(interp, string, length, 0); + iPtr->scriptFile = oldScriptFile; if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { - char msg[200]; + char msg[200 + TCL_INTEGER_SPACE]; /* * Record information telling where the error occurred. @@ -350,17 +336,11 @@ Tcl_EvalFile(interp, fileName) interp->errorLine); Tcl_AddErrorInfo(interp, msg); } - iPtr->scriptFile = oldScriptFile; - Tcl_DStringFree(&buffer); - return result; -error: - if (cmdBuffer != (char *) NULL) { - ckfree(cmdBuffer); - } - iPtr->scriptFile = oldScriptFile; - Tcl_DStringFree(&buffer); - return TCL_ERROR; + end: + Tcl_DecrRefCount(objPtr); + Tcl_DStringFree(&nameString); + return result; } /* @@ -468,7 +448,7 @@ TclStat(path, buf) CONST char *path; /* Path of file to stat (in current CP). */ TclStat_ *buf; /* Filled with results of stat call. */ { - StatProc *statProcPtr = statProcList; + StatProc *statProcPtr; int retVal = -1; /* @@ -476,10 +456,13 @@ TclStat(path, buf) * value of -1 indicates the particular function has succeeded. */ + Tcl_MutexLock(&hookMutex); + statProcPtr = statProcList; while ((retVal == -1) && (statProcPtr != NULL)) { retVal = (*statProcPtr->proc)(path, buf); statProcPtr = statProcPtr->nextPtr; } + Tcl_MutexUnlock(&hookMutex); return (retVal); } @@ -508,7 +491,7 @@ TclAccess(path, mode) CONST char *path; /* Path of file to access (in current CP). */ int mode; /* Permission setting. */ { - AccessProc *accessProcPtr = accessProcList; + AccessProc *accessProcPtr; int retVal = -1; /* @@ -516,10 +499,13 @@ TclAccess(path, mode) * value of -1 indicates the particular function has succeeded. */ + Tcl_MutexLock(&hookMutex); + accessProcPtr = accessProcList; while ((retVal == -1) && (accessProcPtr != NULL)) { retVal = (*accessProcPtr->proc)(path, mode); accessProcPtr = accessProcPtr->nextPtr; } + Tcl_MutexUnlock(&hookMutex); return (retVal); } @@ -555,7 +541,7 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions) * file, with what modes to create * it? */ { - OpenFileChannelProc *openFileChannelProcPtr = openFileChannelProcList; + OpenFileChannelProc *openFileChannelProcPtr; Tcl_Channel retVal = NULL; /* @@ -564,11 +550,14 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions) * succeeded. */ + Tcl_MutexLock(&hookMutex); + openFileChannelProcPtr = openFileChannelProcList; while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { retVal = (*openFileChannelProcPtr->proc)(interp, fileName, modeString, permissions); openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; } + Tcl_MutexUnlock(&hookMutex); return (retVal); } @@ -608,8 +597,10 @@ TclStatInsertProc (proc) if (newStatProcPtr != NULL) { newStatProcPtr->proc = proc; + Tcl_MutexLock(&hookMutex); newStatProcPtr->nextPtr = statProcList; statProcList = newStatProcPtr; + Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } @@ -642,9 +633,11 @@ TclStatDeleteProc (proc) TclStatProc_ *proc; { int retVal = TCL_ERROR; - StatProc *tmpStatProcPtr = statProcList; + StatProc *tmpStatProcPtr; StatProc *prevStatProcPtr = NULL; + Tcl_MutexLock(&hookMutex); + tmpStatProcPtr = statProcList; /* * Traverse the 'statProcList' looking for the particular node * whose 'proc' member matches 'proc' and remove that one from @@ -668,6 +661,7 @@ TclStatDeleteProc (proc) } } + Tcl_MutexUnlock(&hookMutex); return (retVal); } @@ -706,8 +700,10 @@ TclAccessInsertProc(proc) if (newAccessProcPtr != NULL) { newAccessProcPtr->proc = proc; + Tcl_MutexLock(&hookMutex); newAccessProcPtr->nextPtr = accessProcList; accessProcList = newAccessProcPtr; + Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } @@ -740,7 +736,7 @@ TclAccessDeleteProc(proc) TclAccessProc_ *proc; { int retVal = TCL_ERROR; - AccessProc *tmpAccessProcPtr = accessProcList; + AccessProc *tmpAccessProcPtr; AccessProc *prevAccessProcPtr = NULL; /* @@ -749,6 +745,8 @@ TclAccessDeleteProc(proc) * the list. Ensure that the "default" node cannot be removed. */ + Tcl_MutexLock(&hookMutex); + tmpAccessProcPtr = accessProcList; while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) { if (tmpAccessProcPtr->proc == proc) { if (prevAccessProcPtr == NULL) { @@ -765,6 +763,7 @@ TclAccessDeleteProc(proc) tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; } } + Tcl_MutexUnlock(&hookMutex); return (retVal); } @@ -806,8 +805,10 @@ TclOpenFileChannelInsertProc(proc) if (newOpenFileChannelProcPtr != NULL) { newOpenFileChannelProcPtr->proc = proc; + Tcl_MutexLock(&hookMutex); newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; openFileChannelProcList = newOpenFileChannelProcPtr; + Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } @@ -849,6 +850,8 @@ TclOpenFileChannelDeleteProc(proc) * the list. Ensure that the "default" node cannot be removed. */ + Tcl_MutexLock(&hookMutex); + tmpOpenFileChannelProcPtr = openFileChannelProcList; while ((retVal == TCL_ERROR) && (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) { if (tmpOpenFileChannelProcPtr->proc == proc) { @@ -867,6 +870,7 @@ TclOpenFileChannelDeleteProc(proc) tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; } } + Tcl_MutexUnlock(&hookMutex); return (retVal); } diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 2dc0d85..5acb6c5 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -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: tclIndexObj.c,v 1.2 1998/09/14 18:40:00 stanton Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.3 1999/04/16 00:46:47 stanton Exp $ */ #include "tclInt.h" @@ -19,11 +19,8 @@ * Prototypes for procedures defined later in this file: */ -static void DupIndexInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); -static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr)); /* * The structure below defines the index Tcl object type by means of @@ -33,10 +30,17 @@ static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr)); Tcl_ObjType tclIndexType = { "index", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - DupIndexInternalRep, /* dupIntRepProc */ - UpdateStringOfIndex, /* updateStringProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ SetIndexFromAny /* setFromAnyProc */ }; + +/* + * Boolean flag indicating whether or not the tclIndexType object + * type has been registered with the Tcl compiler. + */ + +static int indexTypeInitialized = 0; /* *---------------------------------------------------------------------- @@ -47,7 +51,7 @@ Tcl_ObjType tclIndexType = { * and returns the index of the matching string, if any. * * Results: - + * * If the value of objPtr is identical to or a unique abbreviation * for one of the entries in objPtr, then the return value is * TCL_OK and the index of the matching entry is stored at @@ -76,6 +80,67 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { + + /* + * See if there is a valid cached result from a previous lookup + * (doing the check here saves the overhead of calling + * Tcl_GetIndexFromObjStruct in the common case where the result + * is cached). + */ + + if ((objPtr->typePtr == &tclIndexType) + && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) { + *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2; + return TCL_OK; + } + return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), + msg, flags, indexPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetIndexFromObjStruct -- + * + * This procedure looks up an object's value given a starting + * string and an offset for the amount of space between strings. + * This is useful when the strings are embedded in some other + * kind of array. + * + * Results: + * + * If the value of objPtr is identical to or a unique abbreviation + * for one of the entries in objPtr, then the return value is + * TCL_OK and the index of the matching entry is stored at + * *indexPtr. If there isn't a proper match, then TCL_ERROR is + * returned and an error message is left in interp's result (unless + * interp is NULL). The msg argument is used in the error + * message; for example, if msg has the value "option" then the + * error message will say something flag 'bad option "foo": must be + * ...' + * + * Side effects: + * The result of the lookup is cached as the internal rep of + * objPtr, so that repeated lookups can be done quickly. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, + indexPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* Object containing the string to lookup. */ + char **tablePtr; /* The first string in the table. The second + * string will be at this address plus the + * offset, the third plus the offset again, + * etc. The last entry must be NULL + * and there must not be duplicate entries. */ + int offset; /* The number of bytes between entries */ + char *msg; /* Identifying word to use in error messages. */ + int flags; /* 0 or TCL_EXACT */ + int *indexPtr; /* Place to store resulting integer index. */ +{ int index, length, i, numAbbrev; char *key, *p1, *p2, **entryPtr; Tcl_Obj *resultPtr; @@ -95,10 +160,21 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) * abbreviations unless TCL_EXACT is set in flags. */ + if (!indexTypeInitialized) { + /* + * This is the first time we've done a lookup. Register the + * tclIndexType. + */ + + Tcl_RegisterObjType(&tclIndexType); + indexTypeInitialized = 1; + } + key = Tcl_GetStringFromObj(objPtr, &length); index = -1; numAbbrev = 0; - for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, i++) { + for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; + entryPtr = (char **) ((long) entryPtr + offset), i++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { if (*p1 == 0) { index = i; @@ -135,13 +211,17 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) error: if (interp != NULL) { + int count; resultPtr = Tcl_GetObjResult(interp); Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", key, "\": must be ", *tablePtr, (char *) NULL); - for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) { - if (entryPtr[1] == NULL) { - Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr, + for (entryPtr = (char **) ((long) tablePtr + offset), count = 0; + *entryPtr != NULL; + entryPtr = (char **) ((long) entryPtr + offset), count++) { + if ((*((char **) ((long) entryPtr + offset))) == NULL) { + Tcl_AppendStringsToObj(resultPtr, + (count > 0) ? ", or " : " or ", *entryPtr, (char *) NULL); } else { Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, @@ -155,36 +235,6 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) /* *---------------------------------------------------------------------- * - * DupIndexInternalRep -- - * - * Copy the internal representation of an index Tcl_Obj from one - * object to another. - * - * Results: - * None. - * - * Side effects: - * "copyPtr"s internal rep is set to same value as "srcPtr"s - * internal rep. - * - *---------------------------------------------------------------------- - */ - -static void -DupIndexInternalRep(srcPtr, copyPtr) - register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ -{ - copyPtr->internalRep.twoPtrValue.ptr1 - = srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->internalRep.twoPtrValue.ptr2 - = srcPtr->internalRep.twoPtrValue.ptr2; - copyPtr->typePtr = &tclIndexType; -} - -/* - *---------------------------------------------------------------------- - * * SetIndexFromAny -- * * This procedure is called to convert a Tcl object to index @@ -216,31 +266,6 @@ SetIndexFromAny(interp, objPtr) /* *---------------------------------------------------------------------- * - * UpdateStringOfIndex -- - * - * This procedure is called to update the string representation for - * an index object. It should never be called, because we never - * invalidate the string representation for an index object. - * - * Results: - * None. - * - * Side effects: - * A panic is added - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfIndex(objPtr) - register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ -{ - panic("UpdateStringOfIndex should never be invoked"); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_WrongNumArgs -- * * This procedure generates a "wrong # args" error message in an @@ -293,8 +318,7 @@ Tcl_WrongNumArgs(interp, objc, objv, message) tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2], (char *) NULL); } else { - Tcl_AppendStringsToObj(objPtr, - Tcl_GetStringFromObj(objv[i], (int *) NULL), + Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]), (char *) NULL); } if (i < (objc - 1)) { diff --git a/generic/tclInitScript.h b/generic/tclInitScript.h index 25ce3a9..a1da091 100644 --- a/generic/tclInitScript.h +++ b/generic/tclInitScript.h @@ -3,106 +3,41 @@ * * This file contains Unix & Windows common init script * It is not used on the Mac. (the mac init script is in tclMacInit.c) - * This file should only be included once in the entire set of C - * source files for Tcl (by the respective platform initialization - * C source file, tclUnixInit.c and tclWinInit.c) and thus the - * presence of the routine, TclSetPreInitScript, below, should be - * harmless. * * Copyright (c) 1998 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: tclInitScript.h,v 1.8 1998/10/23 22:22:15 welch Exp $ + * RCS: @(#) $Id: tclInitScript.h,v 1.9 1999/04/16 00:46:47 stanton Exp $ */ /* - * In order to find init.tcl during initialization, the following script - * is invoked by Tcl_Init(). It looks in several different directories: - * - * $tcl_library - can specify a primary location, if set - * no other locations will be checked - * - * $env(TCL_LIBRARY) - highest priority so user can always override - * the search path unless the application has - * specified an exact directory above - * - * $tclDefaultLibrary - this value is initialized by TclPlatformInit - * from a static C variable that was set at - * compile time - * - * /../lib/tcl$tcl_version - * - look for a lib/tcl in a sibling of - * the bin directory (e.g. install hierarchy) - * - * /../../lib/tcl$tcl_version - * - look for a lib/tcl in a sibling of - * the bin/arch directory - * - * /../library - * - look in build directory - * - * /../../library - * - look in build directory from unix/arch - * - * /../../tcl$tcl_patchLevel/library - * - look for tcl build directory relative - * to a parallel build directory (e.g. Tk) - * - * /../../../tcl$tcl_patchLevel/library - * - look for tcl build directory relative - * to a parallel build directory from - * down inside unix/arch directory - * - * The first directory on this path that contains a valid init.tcl script - * will be set as the value of tcl_library. - * - * Note that this entire search mechanism can be bypassed by defining an - * alternate tclInit procedure before calling Tcl_Init(). + * The following string is the startup script executed in new + * interpreters. It looks on disk in several different directories + * for a script "init.tcl" that is compatible with this version + * of Tcl. The init.tcl script does all of the real work of + * initialization. */ static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\ proc tclInit {} {\n\ - global tcl_library tcl_version tcl_patchLevel errorInfo\n\ - global env tclDefaultLibrary\n\ + global tcl_libPath tcl_library errorInfo\n\ rename tclInit {}\n\ set errors {}\n\ - set dirs {}\n\ - if {[info exists tcl_library]} {\n\ - lappend dirs $tcl_library\n\ - } else {\n\ - if {[info exists env(TCL_LIBRARY)]} {\n\ - lappend dirs $env(TCL_LIBRARY)\n\ - }\n\ - lappend dirs $tclDefaultLibrary\n\ - unset tclDefaultLibrary\n\ - set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\ - lappend dirs [file join $parentDir lib tcl$tcl_version]\n\ - lappend dirs [file join [file dirname $parentDir] lib tcl$tcl_version]\n\ - lappend dirs [file join $parentDir library]\n\ - lappend dirs [file join [file dirname $parentDir] library]\n\ - if {[string match {*[ab]*} $tcl_patchLevel]} {\n\ - set ver $tcl_patchLevel\n\ - } else {\n\ - set ver $tcl_version\n\ - }\n\ - lappend dirs [file join [file dirname $parentDir] tcl$ver library]\n\ - lappend dirs [file join [file dirname [file dirname $parentDir]] tcl$ver library]\n\ - }\n\ - foreach i $dirs {\n\ + foreach i $tcl_libPath {\n\ set tcl_library $i\n\ set tclfile [file join $i init.tcl]\n\ if {[file exists $tclfile]} {\n\ - if {![catch {uplevel #0 [list source $tclfile]} msg]} {\n\ - return\n\ + if {[catch {uplevel #0 [list source $tclfile]} msg] != 1} {\n\ + return\n\ } else {\n\ append errors \"$tclfile: $msg\n$errorInfo\n\"\n\ }\n\ }\n\ }\n\ set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ - append msg \" $dirs\n\n\"\n\ + append msg \" $tcl_libPath\n\n\"\n\ append msg \"$errors\n\n\"\n\ append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ error $msg\n\ @@ -110,6 +45,7 @@ static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\ }\n\ tclInit"; + /* * A pointer to a string that holds an initialization script that if non-NULL * is evaluated in Tcl_Init() prior to the the built-in initialization script diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 29f755e..b2d1b44 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -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.4 1999/03/11 00:19:23 stanton Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.5 1999/04/16 00:46:47 stanton Exp $ library tcl @@ -35,9 +35,10 @@ declare 2 generic { declare 3 generic { void TclAllocateFreeObjects(void) } -declare 4 generic { - int TclChdir(Tcl_Interp *interp, char *dirName) -} +# Replaced by TclpChdir in 8.1: +# declare 4 generic { +# int TclChdir(Tcl_Interp *interp, char *dirName) +# } declare 5 generic { int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, \ Tcl_Channel errorChan) @@ -46,7 +47,7 @@ declare 6 generic { void TclCleanupCommand(Command *cmdPtr) } declare 7 generic { - int TclCopyAndCollapse(int count, char *src, char *dst) + int TclCopyAndCollapse(int count, CONST char *src, char *dst) } declare 8 generic { int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, \ @@ -77,9 +78,10 @@ declare 13 generic { declare 14 generic { void TclDumpMemoryInfo(FILE *outFile) } -declare 15 generic { - void TclExpandParseValue(ParseValue *pvPtr, int needed) -} +# Removed in 8.1: +# declare 15 generic { +# void TclExpandParseValue(ParseValue *pvPtr, int needed) +# } declare 16 generic { void TclExprFloatError(Tcl_Interp *interp, double value) } @@ -99,8 +101,9 @@ declare 21 generic { int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv) } declare 22 generic { - int TclFindElement(Tcl_Interp *interp, char *list, int listLength, \ - char **elementPtr, char **nextPtr, int *sizePtr, int *bracePtr) + int TclFindElement(Tcl_Interp *interp, CONST char *listStr, \ + int listLength, CONST char **elementPtr, CONST char **nextPtr, \ + int *sizePtr, int *bracePtr) } declare 23 generic { Proc * TclFindProc(Interp *iPtr, char *procName) @@ -111,28 +114,30 @@ declare 24 generic { declare 25 generic { void TclFreePackageInfo(Interp *iPtr) } -declare 26 generic { - char * TclGetCwd(Tcl_Interp *interp) -} +# Removed in 8.1: +# declare 26 generic { +# char * TclGetCwd(Tcl_Interp *interp) +# } declare 27 generic { int TclGetDate(char *p, unsigned long now, long zone, \ unsigned long *timePtr) } declare 28 generic { - Tcl_Channel TclGetDefaultStdChannel(int type) + Tcl_Channel TclpGetDefaultStdChannel(int type) } declare 29 generic { Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, \ int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg) } -declare 30 generic { - char * TclGetEnv(CONST char *name) -} +# Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1: +# declare 30 generic { +# char * TclGetEnv(CONST char *name) +# } declare 31 generic { char * TclGetExtension(char *name) } declare 32 generic { - int TclGetFrame(Tcl_Interp *interp, char *string, CallFrame **framePtrPtr) + int TclGetFrame(Tcl_Interp *interp, char *str, CallFrame **framePtrPtr) } declare 33 generic { TclCmdProcType TclGetInterpProc(void) @@ -146,7 +151,7 @@ declare 35 generic { int leaveErrorMsg) } declare 36 generic { - int TclGetLong(Tcl_Interp *interp, char *string, long *longPtr) + int TclGetLong(Tcl_Interp *interp, char *str, long *longPtr) } declare 37 generic { int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName) @@ -161,13 +166,13 @@ declare 39 generic { TclObjCmdProcType TclGetObjInterpProc(void) } declare 40 generic { - int TclGetOpenMode(Tcl_Interp *interp, char *string, int *seekFlagPtr) + int TclGetOpenMode(Tcl_Interp *interp, char *str, int *seekFlagPtr) } declare 41 generic { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 generic { - char * TclGetUserHome(char *name, Tcl_DString *bufferPtr) + char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr) } declare 43 generic { int TclGlobalInvoke(Tcl_Interp *interp, int argc, char **argv, int flags) @@ -214,21 +219,23 @@ declare 54 generic { declare 55 generic { Proc * TclIsProc(Command *cmdPtr) } -declare 56 generic { - int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ - char *sym2, Tcl_PackageInitProc **proc1Ptr, \ - Tcl_PackageInitProc **proc2Ptr) -} -declare 57 generic { - int TclLooksLikeInt(char *p) -} +# Replaced with TclpLoadFile in 8.1: +# declare 56 generic { +# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ +# char *sym2, Tcl_PackageInitProc **proc1Ptr, \ +# Tcl_PackageInitProc **proc2Ptr) +# } +# Signature changed to take a length in 8.1: +# declare 57 generic { +# int TclLooksLikeInt(char *p) +# } declare 58 generic { Var * TclLookupVar(Tcl_Interp *interp, char *part1, char *part2, \ int flags, char *msg, int createPart1, int createPart2, \ Var **arrayPtrPtr) } declare 59 generic { - int TclMatchFiles(Tcl_Interp *interp, char *separators, \ + int TclpMatchFiles(Tcl_Interp *interp, char *separators, \ Tcl_DString *dirPtr, char *pattern, char *tail) } declare 60 generic { @@ -265,16 +272,17 @@ declare 69 generic { char * TclpAlloc(unsigned int size) } declare 70 generic { - int TclpCopyFile(char *source, char *dest) + int TclpCopyFile(CONST char *source, CONST char *dest) } declare 71 generic { - int TclpCopyDirectory(char *source, char *dest, Tcl_DString *errorPtr) + int TclpCopyDirectory(CONST char *source, CONST char *dest, \ + Tcl_DString *errorPtr) } declare 72 generic { - int TclpCreateDirectory(char *path) + int TclpCreateDirectory(CONST char *path) } declare 73 generic { - int TclpDeleteFile(char *path) + int TclpDeleteFile(CONST char *path) } declare 74 generic { void TclpFree(char *ptr) @@ -302,26 +310,28 @@ declare 81 generic { char * TclpRealloc(char *ptr, unsigned int size) } declare 82 generic { - int TclpRemoveDirectory(char *path, int recursive, Tcl_DString *errorPtr) + int TclpRemoveDirectory(CONST char *path, int recursive, \ + Tcl_DString *errorPtr) } declare 83 generic { - int TclpRenameFile(char *source, char *dest) -} -declare 84 generic { - int TclParseBraces(Tcl_Interp *interp, char *string, char **termPtr, \ - ParseValue *pvPtr) -} -declare 85 generic { - int TclParseNestedCmd(Tcl_Interp *interp, char *string, int flags, \ - char **termPtr, ParseValue *pvPtr) -} -declare 86 generic { - int TclParseQuotes(Tcl_Interp *interp, char *string, int termChar, \ - int flags, char **termPtr, ParseValue *pvPtr) -} -declare 87 generic { - void TclPlatformInit(Tcl_Interp *interp) -} + int TclpRenameFile(CONST char *source, CONST char *dest) +} +# Removed in 8.1: +# declare 84 generic { +# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, \ +# ParseValue *pvPtr) +# } +# declare 85 generic { +# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, \ +# char **termPtr, ParseValue *pvPtr) +# } +# declare 86 generic { +# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, \ +# int flags, char **termPtr, ParseValue *pvPtr) +# } +# declare 87 generic { +# void TclPlatformInit(Tcl_Interp *interp) +# } declare 88 generic { char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, \ char *name1, char *name2, int flags) @@ -330,9 +340,10 @@ declare 89 generic { int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, \ Tcl_Command cmd) } -declare 90 generic { - void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -} +# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG): +# declare 90 generic { +# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +# } declare 91 generic { void TclProcCleanupProc(Proc *procPtr) } @@ -368,14 +379,15 @@ declare 100 generic { Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, \ Tcl_Obj *objPtr, int leaveErrorMsg) } -declare 101 generic { - char * TclSetPreInitScript(char *string) -} +# TODO: needs to be implemented +# declare 101 generic { +# char * TclSetPreInitScript(char *string) +# } declare 102 generic { void TclSetupEnv(Tcl_Interp *interp) } declare 103 generic { - int TclSockGetPort(Tcl_Interp *interp, char *string, char *proto, \ + int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto, \ int *portPtr) } declare 104 generic { @@ -396,9 +408,10 @@ declare 108 generic { declare 109 generic { int TclUpdateReturnInfo(Interp *iPtr) } -declare 110 generic { - char * TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr) -} +# Removed in 8.1: +# declare 110 generic { +# char * TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr) +# } # Procedures used in conjunction with Tcl namespaces. They are # defined here instead of in tcl.decls since they are not stable yet. @@ -484,19 +497,39 @@ declare 131 generic { Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 132 generic { - int TclHasSockets(Tcl_Interp *interp) + int TclpHasSockets(Tcl_Interp *interp) } declare 133 generic { struct tm * TclpGetDate(TclpTime_t time, int useGMT) } declare 134 generic { - size_t TclStrftime(char *s, size_t maxsize, const char *format, \ - const struct tm *t) + size_t TclpStrftime(char *s, size_t maxsize, CONST char *format, \ + CONST struct tm *t) } declare 135 generic { int TclpCheckStackSpace(void) } +# Added in 8.1: + +declare 137 generic { + int TclpChdir(CONST char *dirName) +} +declare 138 generic { + char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) +} +declare 139 generic { + int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ + char *sym2, Tcl_PackageInitProc **proc1Ptr, \ + Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr) +} +declare 140 generic { + int TclLooksLikeInt(char *bytes, int length) +} + +declare 141 generic { + char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) +} ############################################################################## # Define the platform specific internal Tcl interface. These functions are @@ -517,7 +550,7 @@ declare 2 mac { VOID * TclpSysRealloc(VOID *cp, unsigned int size) } declare 3 mac { - void TclPlatformExit(int status) + void TclpExit(int status) } # Prototypes for functions found in the tclMacUtil.c compatability library. @@ -541,15 +574,15 @@ declare 7 mac { # however. The first set are from the MoreFiles package. declare 8 mac { - pascal OSErr FSpGetDirectoryID(const FSSpec *spec, long *theDirID, \ + pascal OSErr FSpGetDirectoryID(CONST FSSpec *spec, long *theDirID, \ Boolean *isDirectory) } declare 9 mac { - pascal short FSpOpenResFileCompat(const FSSpec *spec, \ + pascal short FSpOpenResFileCompat(CONST FSSpec *spec, \ SignedByte permission) } declare 10 mac { - pascal void FSpCreateResFileCompat(const FSSpec *spec, OSType creator, \ + pascal void FSpCreateResFileCompat(CONST FSSpec *spec, OSType creator, \ OSType fileType, ScriptCode scriptTag) } @@ -598,16 +631,16 @@ declare 22 mac { int TclMacCreateEnv(void) } declare 23 mac { - FILE * TclMacFOpenHack(const char *path, const char *mode) -} -declare 24 mac { - int TclMacReadlink(char *path, char *buf, int size) + FILE * TclMacFOpenHack(CONST char *path, CONST char *mode) } +# Replaced in 8.1 by TclpReadLink: +# declare 24 mac { +# int TclMacReadlink(char *path, char *buf, int size) +# } declare 25 mac { int TclMacChmod(char *path, int mode) } - ############################ # Windows specific internals @@ -618,8 +651,8 @@ declare 1 win { void TclWinConvertWSAError(DWORD errCode) } declare 2 win { - struct servent * TclWinGetServByName(const char *nm, \ - const char *proto) + struct servent * TclWinGetServByName(CONST char *nm, \ + CONST char *proto) } declare 3 win { int TclWinGetSockOpt(SOCKET s, int level, int optname, \ @@ -628,15 +661,16 @@ declare 3 win { declare 4 win { HINSTANCE TclWinGetTclInstance(void) } -declare 5 win { - HINSTANCE TclWinLoadLibrary(char *name) -} +# Removed in 8.1: +# declare 5 win { +# HINSTANCE TclWinLoadLibrary(char *name) +# } declare 6 win { u_short TclWinNToHS(u_short ns) } declare 7 win { int TclWinSetSockOpt(SOCKET s, int level, int optname, \ - const char FAR * optval, int optlen) + CONST char FAR * optval, int optlen) } declare 8 win { unsigned long TclpGetPid(Tcl_Pid pid) @@ -668,18 +702,18 @@ declare 15 win { TclFile inputFile, TclFile outputFile, TclFile errorFile, \ Tcl_Pid *pidPtr) } -declare 16 win { - TclFile TclpCreateTempFile(char *contents, - Tcl_DString *namePtr) -} -declare 17 win { - char * TclpGetTZName(void) -} +# Signature changed in 8.1: +# declare 16 win { +# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) +# } +# declare 17 win { +# char * TclpGetTZName(void) +# } declare 18 win { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 19 win { - TclFile TclpOpenFile(char *fname, int mode) + TclFile TclpOpenFile(CONST char *fname, int mode) } declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) @@ -688,6 +722,17 @@ declare 21 win { void TclpAsyncMark(Tcl_AsyncHandler async) } +# Added in 8.1: +declare 22 win { + TclFile TclpCreateTempFile(CONST char *contents) +} +declare 23 win { + char * TclpGetTZName(int isdst) +} +declare 24 win { + char * TclWinNoBackslash(char *path) +} + ######################### # Unix specific internals @@ -711,16 +756,23 @@ declare 4 unix { TclFile inputFile, TclFile outputFile, TclFile errorFile, \ Tcl_Pid *pidPtr) } -declare 5 unix { - TclFile TclpCreateTempFile(char *contents, - Tcl_DString *namePtr) -} +# Signature changed in 8.1: +# declare 5 unix { +# TclFile TclpCreateTempFile(char *contents, +# Tcl_DString *namePtr) +# } declare 6 unix { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 7 unix { - TclFile TclpOpenFile(char *fname, int mode) + TclFile TclpOpenFile(CONST char *fname, int mode) } declare 8 unix { int TclUnixWaitForFile(int fd, int mask, int timeout) } + +# Added in 8.1: + +declare 9 unix { + TclFile TclpCreateTempFile(CONST char *contents) +} diff --git a/generic/tclInt.h b/generic/tclInt.h index 65ec24a..0590bc5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4,14 +4,14 @@ * Declarations of things used internally by the Tcl interpreter. * * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1993-1997 Lucent Technologies. + * Copyright (c) 1994-1998 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: tclInt.h,v 1.24 1999/03/10 05:52:48 stanton Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.25 1999/04/16 00:46:48 stanton Exp $ */ #ifndef _TCLINT @@ -32,9 +32,6 @@ #ifndef _TCL #include "tcl.h" #endif -#ifndef _REGEXP -#include "tclRegexp.h" -#endif #include #ifdef NO_LIMITS_H @@ -101,8 +98,8 @@ 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, - Tcl_Command *rPtr)); + char* name, Tcl_Namespace *context, int flags, + Tcl_Command *rPtr)); typedef struct Tcl_ResolverInfo { Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name @@ -266,8 +263,8 @@ typedef struct VarTrace { ClientData clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * interested in: OR-ed combination of - * TCL_TRACE_READS, TCL_TRACE_WRITES, and - * TCL_TRACE_UNSETS. */ + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */ struct VarTrace *nextPtr; /* Next in list of traces associated with * a particular variable. */ } VarTrace; @@ -696,6 +693,21 @@ typedef struct CallFrame { /* *---------------------------------------------------------------- + * Data structures and procedures related to TclHandles, which + * are a very lightweight method of preserving enough information + * to determine if an arbitrary malloc'd block has been deleted. + *---------------------------------------------------------------- + */ + +typedef VOID **TclHandle; + +TclHandle TclHandleCreate _ANSI_ARGS_((VOID *ptr)); +void TclHandleFree _ANSI_ARGS_((TclHandle handle)); +TclHandle TclHandlePreserve _ANSI_ARGS_((TclHandle handle)); +void TclHandleRelease _ANSI_ARGS_((TclHandle handle)); + +/* + *---------------------------------------------------------------- * Data structures related to history. These are used primarily * in tclHistory.c *---------------------------------------------------------------- @@ -764,6 +776,27 @@ typedef struct MathFunc { } MathFunc; /* + * These are a thin layer over TclpThreadKeyDataGet and TclpThreadKeyDataSet + * when threads are used, or an emulation if there are no threads. These + * are really internal and Tcl clients should use Tcl_GetThreadData. + */ + +EXTERN VOID *TclThreadDataKeyGet _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr)); +EXTERN void TclThreadDataKeySet _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr, VOID *data)); + +/* + * This is a convenience macro used to initialize a thread local storage ptr. + */ +#define TCL_TSD_INIT(keyPtr) (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) + + +#ifdef MAC_TCL +typedef pascal void *(Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); +#else +typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); +#endif + +/* *---------------------------------------------------------------- * Data structures related to bytecode compilation and execution. * These are used primarily in tclCompile.c, tclExecute.c, and @@ -772,11 +805,12 @@ typedef struct MathFunc { */ /* - * Forward declaration to prevent an error when the forward reference to - * CompileEnv is encountered in the procedure type CompileProc declared - * below. + * Forward declaration to prevent errors when the forward references to + * Tcl_Parse and CompileEnv are encountered in the procedure type + * CompileProc declared below. */ +struct Tcl_Parse; struct CompileEnv; /* @@ -798,8 +832,8 @@ struct CompileEnv; #define TCL_OUT_LINE_COMPILE (TCL_CONTINUE + 1) -typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, char *string, - char *lastChar, int compileFlags, struct CompileEnv *compEnvPtr)); +typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, + struct Tcl_Parse *parsePtr, struct CompileEnv *compEnvPtr)); /* * The data structure defining the execution environment for ByteCode's. @@ -811,14 +845,8 @@ typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, char *string, * returns. */ -typedef union StackItem { - Tcl_Obj *o; /* Stack item as a pointer to a Tcl_Obj. */ - int i; /* Stack item as an integer. */ - VOID *p; /* Stack item as an arbitrary pointer. */ -} StackItem; - typedef struct ExecEnv { - StackItem *stackPtr; /* Points to the first item in the + 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. */ @@ -826,56 +854,91 @@ typedef struct ExecEnv { } ExecEnv; /* - * CompileProcs need the ability to record information during compilation - * that can be used by bytecode instructions during execution. The AuxData - * structure provides this "auxiliary data" mechanism. An arbitrary number - * of these structures can be stored in the ByteCode record (during - * compilation they are stored in a CompileEnv structure). Each AuxData - * record holds one word of client-specified data (often a pointer) and is - * given an index that instructions can later use to look up the structure - * and its data. + * The definitions for the LiteralTable and LiteralEntry structures. Each + * interpreter contains a LiteralTable. It is used to reduce the storage + * needed for all the Tcl objects that hold the literals of scripts compiled + * by the interpreter. A literal's object is shared by all the ByteCodes + * that refer to the literal. Each distinct literal has one LiteralEntry + * entry in the LiteralTable. A literal table is a specialized hash table + * that is indexed by the literal's string representation, which may contain + * null characters. * - * The following definitions declare the types of procedures that are called - * to duplicate or free this auxiliary data when the containing ByteCode - * objects are duplicated and freed. Pointers to these procedures are kept - * in the AuxData structure. - */ - -typedef ClientData (AuxDataDupProc) _ANSI_ARGS_((ClientData clientData)); -typedef void (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData)); - -/* - * We define a separate AuxDataType struct to hold type-related information - * for the AuxData structure. This separation makes it possible for clients - * outside of the TCL core to manipulate (in a limited fashion!) AuxData; - * for example, it makes it possible to pickle and unpickle AuxData structs. - */ - -typedef struct AuxDataType { - char *name; /* the name of the type. Types can be - * registered and found by name */ - AuxDataDupProc *dupProc; /* Callback procedure to invoke when the - * aux data is duplicated (e.g., when the - * ByteCode structure containing the aux - * data is duplicated). NULL means just - * copy the source clientData bits; no - * proc need be called. */ - AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the - * aux data is freed. NULL means no - * proc need be called. */ -} AuxDataType; - -/* - * The definition of the AuxData structure that holds information created - * during compilation by CompileProcs and used by instructions during - * execution. + * Note that we reduce the space needed for literals by sharing literal + * objects both within a ByteCode (each ByteCode contains a local + * LiteralTable) and across all an interpreter's ByteCodes (with the + * interpreter's global LiteralTable). + */ + +typedef struct LiteralEntry { + struct LiteralEntry *nextPtr; /* Points to next entry in this + * hash bucket or NULL if end of + * chain. */ + Tcl_Obj *objPtr; /* Points to Tcl object that + * holds the literal's bytes and + * length. */ + int refCount; /* If in an interpreter's global + * literal table, the number of + * ByteCode structures that share + * the literal object; the literal + * entry can be freed when refCount + * drops to 0. If in a local literal + * table, -1. */ +} LiteralEntry; + +typedef struct LiteralTable { + LiteralEntry **buckets; /* Pointer to bucket array. Each + * element points to first entry in + * bucket's hash chain, or NULL. */ + LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; + /* Bucket array used for small + * tables to avoid mallocs and + * frees. */ + int numBuckets; /* Total number of buckets allocated + * at **buckets. */ + int numEntries; /* Total number of entries present + * in table. */ + int rebuildSize; /* Enlarge table when numEntries + * gets to be this large. */ + int mask; /* Mask value used in hashing + * function. */ +} LiteralTable; + +/* + * The following structure defines for each Tcl interpreter various + * statistics-related information about the bytecode compiler and + * interpreter's operation in that interpreter. */ -typedef struct AuxData { - AuxDataType *type; /* pointer to the AuxData type associated with - * this ClientData. */ - ClientData clientData; /* The compilation data itself. */ -} AuxData; +#ifdef TCL_COMPILE_STATS +typedef struct ByteCodeStats { + long numExecutions; /* Number of ByteCodes executed. */ + long numCompilations; /* Number of ByteCodes created. */ + long numByteCodesFreed; /* Number of ByteCodes destroyed. */ + long instructionCount[256]; /* Number of times each instruction was + * executed. */ + + double totalSrcBytes; /* Total source bytes ever compiled. */ + double totalByteCodeBytes; /* Total bytes for all ByteCodes. */ + double currentSrcBytes; /* Src bytes for all current ByteCodes. */ + double currentByteCodeBytes; /* Code bytes in all current ByteCodes. */ + + long srcCount[32]; /* Source size distribution: # of srcs of + * size [2**(n-1)..2**n), n in [0..32). */ + long byteCodeCount[32]; /* ByteCode size distribution. */ + long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ + + double currentInstBytes; /* Instruction bytes-current ByteCodes. */ + double currentLitBytes; /* Current literal bytes. */ + double currentExceptBytes; /* Current exception table bytes. */ + double currentAuxBytes; /* Current auxiliary information bytes. */ + double currentCmdMapBytes; /* Current src<->code map bytes. */ + + long numLiteralsCreated; /* Total literal objects ever compiled. */ + double totalLitStringBytes; /* Total string bytes in all literals. */ + double currentLitStringBytes; /* String bytes in current literals. */ + long literalCount[32]; /* Distribution of literal string sizes. */ +} ByteCodeStats; +#endif /* TCL_COMPILE_STATS */ /* *---------------------------------------------------------------- @@ -1049,12 +1112,25 @@ typedef struct Interp { * to a buckets array in a hash table. We * therefore have to do some careful checking * before we can use this. */ + + TclHandle handle; /* Handle used to keep track of when this + * interp is deleted. */ + Namespace *globalNsPtr; /* The interpreter's global namespace. */ + Tcl_HashTable *hiddenCmdTablePtr; + /* Hash table used by tclBasic.c to keep + * track of hidden commands on a per-interp + * basis. */ + ClientData interpInfo; /* Information used by tclInterp.c to keep + * track of master/slave interps on + * a per-interp basis. */ Tcl_HashTable mathFuncTable;/* Contains all the math functions currently * defined for the interpreter. Indexed by * strings (function names); values have * type (MathFunc *). */ + + /* * Information related to procedures and variables. See tclProc.c * and tclvar.c for usage. @@ -1101,7 +1177,10 @@ typedef struct Interp { /* * A cache of compiled regular expressions. See Tcl_RegExpCompile - * in tclUtil.c for details. + * in tclUtil.c for details. THIS CACHE IS OBSOLETE and is only + * retained for backward compatibility with Tcl_RegExpCompile. + * New code should use the object interface so the Tcl_Obj caches + * the compiled expression. */ #define NUM_REGEXPS 5 @@ -1112,7 +1191,7 @@ typedef struct Interp { int patLengths[NUM_REGEXPS];/* Number of non-null characters in * corresponding entry in patterns. * -1 means entry isn't used. */ - regexp *regexps[NUM_REGEXPS]; + struct TclRegexp *regexps[NUM_REGEXPS]; /* Compiled forms of above strings. Also * malloc-ed, or NULL if not in use yet. */ @@ -1141,6 +1220,12 @@ typedef struct Interp { * values. */ int termOffset; /* Offset of character just after last one * compiled or executed by Tcl_EvalObj. */ + LiteralTable literalTable; /* Contains LiteralEntry's describing all + * Tcl objects holding literals of scripts + * compiled by the interpreter. Indexed by + * the string representations of literals. + * Used to avoid creating duplicate + * objects. */ int compileEpoch; /* Holds the current "compilation epoch" * for this interpreter. This is * incremented to invalidate existing @@ -1155,7 +1240,7 @@ typedef struct Interp { /* Linked list of name resolution schemes * added to this interpreter. Schemes * are added/removed by calling - * Tcl_AddInterpResolver and + * Tcl_AddInterpResolvers and * Tcl_RemoveInterpResolver. */ char *scriptFile; /* NULL means there is no nested source * command active; otherwise this points to @@ -1180,6 +1265,17 @@ typedef struct Interp { Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ + Tcl_ThreadId threadId; /* ID of thread that owns the interpreter */ + + /* + * Statistical information about the bytecode compiler and interpreter's + * operation. + */ + +#ifdef TCL_COMPILE_STATS + ByteCodeStats stats; /* Holds compilation and execution + * statistics for this interpreter. */ +#endif /* TCL_COMPILE_STATS */ } Interp; /* @@ -1225,16 +1321,21 @@ typedef struct Interp { * SAFE_INTERP: Non zero means that the current interp is a * safe interp (ie it has only the safe commands * installed, less priviledge than a regular interp). + * USE_EVAL_DIRECT: Non-zero means don't use the compiler or byte-code + * interpreter; instead, have Tcl_EvalObj call + * Tcl_EvalEx. Used primarily for testing the + * new parser. */ -#define DELETED 1 -#define ERR_IN_PROGRESS 2 -#define ERR_ALREADY_LOGGED 4 -#define ERROR_CODE_SET 8 -#define EXPR_INITIALIZED 0x10 -#define DONT_COMPILE_CMDS_INLINE 0x20 -#define RAND_SEED_INITIALIZED 0x40 -#define SAFE_INTERP 0x80 +#define DELETED 1 +#define ERR_IN_PROGRESS 2 +#define ERR_ALREADY_LOGGED 4 +#define ERROR_CODE_SET 8 +#define EXPR_INITIALIZED 0x10 +#define DONT_COMPILE_CMDS_INLINE 0x20 +#define RAND_SEED_INITIALIZED 0x40 +#define SAFE_INTERP 0x80 +#define USE_EVAL_DIRECT 0x100 /* *---------------------------------------------------------------- @@ -1266,48 +1367,6 @@ typedef struct ParseValue { * expandProc. */ } ParseValue; -/* - * A table used to classify input characters to assist in parsing - * Tcl commands. The table should be indexed with a signed character - * using the CHAR_TYPE macro. The character may have a negative - * value. The CHAR_TYPE macro takes a pointer to a signed character - * and a pointer to the last character in the source string. If the - * src pointer is pointing at the terminating null of the string, - * CHAR_TYPE returns TCL_COMMAND_END. - */ - -extern unsigned char tclTypeTable[]; -#define CHAR_TYPE(src,last) \ - (((src)==(last))?TCL_COMMAND_END:(tclTypeTable)[(int)(*(src) + 128)]) - -/* - * Possible values returned by CHAR_TYPE. Note that except for TCL_DOLLAR, - * these are all one byte values with a single bit set 1. This means these - * values may be bit-or'ed together (except for TCL_DOLLAR) to quickly test - * whether a character is one of several different kinds of characters. - * - * TCL_NORMAL - All characters that don't have special significance - * to the Tcl language. - * TCL_SPACE - Character is space, tab, or return. - * TCL_COMMAND_END - Character is newline or semicolon or close-bracket - * or terminating null. - * TCL_QUOTE - Character is a double-quote. - * TCL_OPEN_BRACKET - Character is a "[". - * TCL_OPEN_BRACE - Character is a "{". - * TCL_CLOSE_BRACE - Character is a "}". - * TCL_BACKSLASH - Character is a "\". - * TCL_DOLLAR - Character is a "$". - */ - -#define TCL_NORMAL 0x01 -#define TCL_SPACE 0x02 -#define TCL_COMMAND_END 0x04 -#define TCL_QUOTE 0x08 -#define TCL_OPEN_BRACKET 0x10 -#define TCL_OPEN_BRACE 0x20 -#define TCL_CLOSE_BRACE 0x40 -#define TCL_BACKSLASH 0x80 -#define TCL_DOLLAR 0x00 /* * Maximum number of levels of nesting permitted in Tcl commands (used @@ -1359,10 +1418,15 @@ typedef enum { * Only has an effect if invoking an exposed * command, i.e. if TCL_INVOKE_HIDDEN is not * also set. + * TCL_INVOKE_NO_TRACEBACK Does not record traceback information if + * the invoked command returns an error. Used + * if the caller plans on recording its own + * traceback information. */ #define TCL_INVOKE_HIDDEN (1<<0) #define TCL_INVOKE_NO_UNKNOWN (1<<1) +#define TCL_INVOKE_NO_TRACEBACK (1<<2) /* * The structure used as the internal representation of Tcl list @@ -1379,6 +1443,7 @@ typedef struct List { Tcl_Obj **elements; /* Array of pointers to element objects. */ } List; + /* * The following types are used for getting and storing platform-specific * file attributes in tclFCmd.c and the various platform-versions of @@ -1388,11 +1453,9 @@ typedef struct List { */ typedef int (TclGetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj **attrObjPtrPtr)); + int objIndex, CONST char *fileName, Tcl_Obj **attrObjPtrPtr)); typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj *attrObjPtr)); + int objIndex, CONST char *fileName, Tcl_Obj *attrObjPtr)); typedef struct TclFileAttrProcs { TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */ @@ -1440,6 +1503,8 @@ typedef struct TclpTime_t_ *TclpTime_t; extern Tcl_Time tclBlockTime; extern int tclBlockTimeSet; extern char * tclExecutableName; +extern char * tclNativeExecutableName; +extern char * tclDefaultEncodingDir; extern Tcl_ChannelType tclFileChannelType; extern char * tclMemDumpFileName; extern TclPlatformType tclPlatform; @@ -1481,46 +1546,283 @@ extern char * tclEmptyStringRep; /* *---------------------------------------------------------------- - * Declarations of procedures that are not accessible by way of - * the stubs tables. + * Procedures shared among Tcl modules but not used by the outside + * world: *---------------------------------------------------------------- */ -EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); -EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void)); -EXTERN void TclFinalizeExecEnv _ANSI_ARGS_((void)); -EXTERN void TclInitNamespaces _ANSI_ARGS_((void)); -EXTERN void TclpFinalize _ANSI_ARGS_((void)); +EXTERN int TclAccess _ANSI_ARGS_((CONST char *path, + int mode)); +EXTERN int TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc)); +EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc)); +EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); +EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj)); +EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, + int numPids, Tcl_Pid *pidPtr, + Tcl_Channel errorChan)); +EXTERN void TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr)); +EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel inChan, Tcl_Channel outChan, + int toRead, Tcl_Obj *cmdPtr)); +/* + * TclCreatePipeline unofficially exported for use by BLT. + */ +EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, Tcl_Pid **pidArrayPtr, + TclFile *inPipePtr, TclFile *outPipePtr, + TclFile *errFilePtr)); +EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp *interp, + Namespace *nsPtr, char *procName, + Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, + Proc **procPtrPtr)); +EXTERN void TclDeleteCompiledLocalVars _ANSI_ARGS_(( + Interp *iPtr, CallFrame *framePtr)); +EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, + Tcl_HashTable *tablePtr)); +EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *headPtr, + char *tail)); +EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile)); +EXTERN void TclExpandTokenArray _ANSI_ARGS_(( + Tcl_Parse *parsePtr)); +EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, + double value)); +EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void)); +EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); +EXTERN void TclFinalizeCondition _ANSI_ARGS_(( + Tcl_Condition *condPtr)); +EXTERN void TclFinalizeCompilation _ANSI_ARGS_((void)); +EXTERN void TclFinalizeEncodingSubsystem _ANSI_ARGS_((void)); +EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void)); +EXTERN void TclFinalizeExecution _ANSI_ARGS_((void)); +EXTERN void TclFinalizeIOSubsystem _ANSI_ARGS_((void)); +EXTERN void TclFinalizeLoad _ANSI_ARGS_((void)); +EXTERN void TclFinalizeMemorySubsystem _ANSI_ARGS_((void)); +EXTERN void TclFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutex)); +EXTERN void TclFinalizeNotifier _ANSI_ARGS_((void)); +EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void)); +EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void)); +EXTERN void TclFindEncodings _ANSI_ARGS_((CONST char *argv0)); +EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, + char *procName)); +EXTERN int TclFormatInt _ANSI_ARGS_((char *buffer, long n)); +EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr)); +EXTERN int TclGetDate _ANSI_ARGS_((char *p, + unsigned long now, long zone, + unsigned long *timePtr)); +EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( + Tcl_Interp *interp, int localIndex, + Tcl_Obj *elemPtr, int leaveErrorMsg)); +EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); +EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, + char *string, CallFrame **framePtrPtr)); +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)); +EXTERN Tcl_Obj * TclGetLibraryPath _ANSI_ARGS_((void)); +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, + Namespace *cxtNsPtr, int flags, + Namespace **nsPtrPtr, Namespace **altNsPtrPtr, + Namespace **actualCxtPtrPtr, + char **simpleNamePtr)); +EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void)); +EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *seekFlagPtr)); +EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( + Tcl_Command command)); +EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, + char *pattern, int noComplain)); +EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int flags)); +EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName, + Tcl_DString *bufPtr)); +EXTERN int TclHideUnsafeCommands _ANSI_ARGS_(( + Tcl_Interp *interp)); +EXTERN int TclInExit _ANSI_ARGS_((void)); +EXTERN Tcl_Obj * TclIncrElementOfIndexedArray _ANSI_ARGS_(( + Tcl_Interp *interp, int localIndex, + Tcl_Obj *elemPtr, long incrAmount)); +EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_(( + Tcl_Interp *interp, int localIndex, + long incrAmount)); +EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + long incrAmount, int flags)); +EXTERN void TclInitAlloc _ANSI_ARGS_((void)); +EXTERN void TclInitCompiledLocals _ANSI_ARGS_(( + Tcl_Interp *interp, CallFrame *framePtr, + Namespace *nsPtr)); +EXTERN void TclInitDbCkalloc _ANSI_ARGS_((void)); +EXTERN void TclInitEncodingSubsystem _ANSI_ARGS_((void)); +EXTERN void TclInitIOSubsystem _ANSI_ARGS_((void)); +EXTERN void TclInitNamespaceSubsystem _ANSI_ARGS_((void)); +EXTERN void TclInitNotifier _ANSI_ARGS_((void)); +EXTERN void TclInitObjSubsystem _ANSI_ARGS_((void)); +EXTERN void TclInitSubsystems _ANSI_ARGS_((CONST char *argv0)); +EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int flags)); +EXTERN int TclInvokeObjectCommand _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +EXTERN int TclInvokeStringCommand _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +EXTERN int TclIsLocalScalar _ANSI_ARGS_((CONST char *src, + int len)); +EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); +EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, char *msg, + int createPart1, int createPart2, + Var **arrayPtrPtr)); +EXTERN int TclMathInProgress _ANSI_ARGS_((void)); +EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); +EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr)); +EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr)); +EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], int flags)); +EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], int flags)); +EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_(( + TclOpenFileChannelProc_ *proc)); +EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( + TclOpenFileChannelProc_ *proc)); +EXTERN int TclpAccess _ANSI_ARGS_((CONST char *filename, + int mode)); +EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); +EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); +EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char *source, + CONST char *dest)); +EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char *source, + CONST char *dest, Tcl_DString *errorPtr)); +EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char *path)); +EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path)); +EXTERN void TclpExit _ANSI_ARGS_((int status)); +EXTERN void TclpFinalizeCondition _ANSI_ARGS_(( + Tcl_Condition *condPtr)); +EXTERN void TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr)); +EXTERN void TclpFinalizeThreadData _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr)); +EXTERN void TclpFinalizeThreadDataKey _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr)); +EXTERN char * TclpFindExecutable _ANSI_ARGS_(( + CONST char *argv0)); +EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name, + int *lengthPtr)); +EXTERN void TclpFree _ANSI_ARGS_((char *ptr)); +EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void)); +EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type)); +EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void)); +EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time)); +EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time)); +EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char *name, + Tcl_DString *bufferPtr)); +EXTERN int TclpHasSockets _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0)); +EXTERN void TclpInitLock _ANSI_ARGS_((void)); +EXTERN void TclpInitPlatform _ANSI_ARGS_((void)); +EXTERN void TclpInitUnlock _ANSI_ARGS_((void)); +EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void TclpMasterLock _ANSI_ARGS_((void)); +EXTERN void TclpMasterUnlock _ANSI_ARGS_((void)); +EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *dirPtr, + char *pattern, char *tail)); +EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *modeString, + int permissions)); +EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName, + Tcl_DString *linkPtr)); +EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, + unsigned int size)); +EXTERN void TclpReleaseFile _ANSI_ARGS_((TclFile file)); +EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char *path, + int recursive, Tcl_DString *errorPtr)); +EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char *source, + CONST char *dest)); +EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void)); +EXTERN void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); +EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr)); +EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp, + unsigned int size)); +EXTERN void TclpUnloadFile _ANSI_ARGS_((ClientData clientData)); +EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *cmdInterp, Tcl_Command cmd)); +EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc *procPtr)); +EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp, + Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, + CONST char *description, CONST char *procName)); +EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData)); +EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclpThreadCreate _ANSI_ARGS_((Tcl_ThreadId *idPtr, + Tcl_ThreadCreateProc proc, ClientData clientData)); +EXTERN VOID * TclpThreadDataKeyGet _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr)); +EXTERN void TclpThreadDataKeyInit _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr)); +EXTERN void TclpThreadDataKeySet _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr, VOID *data)); +EXTERN void TclpThreadExit _ANSI_ARGS_((int status)); +EXTERN void TclRememberCondition _ANSI_ARGS_((Tcl_Condition *mutex)); +EXTERN void TclRememberDataKey _ANSI_ARGS_((Tcl_ThreadDataKey *mutex)); +EXTERN void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex)); +EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *oldName, char *newName)) ; +EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_(( + Tcl_Interp *interp, Command *newCmdPtr)); +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)); +EXTERN void TclSetLibraryPath _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, + int localIndex, Tcl_Obj *objPtr, + int leaveErrorMsg)); +EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char *string)); +EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *proto, int *portPtr)); +EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, + int size)); +EXTERN int TclStat _ANSI_ARGS_((CONST char *path, + TclStat_ *buf)); +EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc)); +EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc)); +EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr)); +EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclTestChannelEventCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp, + int result, Tcl_Interp *targetInterp)); +EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); /* *---------------------------------------------------------------- @@ -1536,8 +1838,8 @@ EXTERN int Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_BinaryObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_BreakObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_CaseObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData, @@ -1550,34 +1852,36 @@ EXTERN int Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ContinueObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_EncodingObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ErrorObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_EvalObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ExecObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FconfigureObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_FcopyObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_FileObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_FileEventCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FileEventObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_FlushObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ForObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ForeachObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_FormatObjCmd _ANSI_ARGS_((ClientData dummy, @@ -1586,16 +1890,16 @@ EXTERN int Tcl_GetsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_GlobalObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_GlobObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_IfObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_IncrObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_InfoObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_InterpObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_JoinObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_LappendObjCmd _ANSI_ARGS_((ClientData clientData, @@ -1608,8 +1912,8 @@ EXTERN int Tcl_LlengthObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ListObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_LoadCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LoadObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_LrangeObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_LreplaceObjCmd _ANSI_ARGS_((ClientData clientData, @@ -1622,64 +1926,64 @@ EXTERN int Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_OpenObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_PackageCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PackageObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_PidObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ProcObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_PutsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_PwdCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PwdObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ReadObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_RegexpCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_RegsubCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RegexpObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_RegsubObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_RenameObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ReturnObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ScanCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ScanObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_SeekObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_SetObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_SplitObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_SocketCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SocketObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_SourceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_StringObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_SubstCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SubstObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_SwitchObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_TellCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_TellObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_TimeObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_TraceObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_UnsetObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_UpdateCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UpdateObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_UplevelObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_UpvarObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_VariableObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_VwaitCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_VwaitObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_WhileObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /* *---------------------------------------------------------------- @@ -1688,29 +1992,44 @@ EXTERN int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData, */ #ifdef MAC_TCL -EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LsCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); #endif - /* *---------------------------------------------------------------- - * Command procedures used for testing. + * Compilation procedures for commands in the generic core: *---------------------------------------------------------------- */ -EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +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 TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); /* *---------------------------------------------------------------- @@ -1742,12 +2061,14 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, #ifdef TCL_MEM_DEBUG # define TclNewObj(objPtr) \ - (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \ + (objPtr) = (Tcl_Obj *) \ + Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TclIncrObjsAllocated() + # define TclDbNewObj(objPtr, file, line) \ (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ (objPtr)->refCount = 0; \ @@ -1755,24 +2076,32 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TclIncrObjsAllocated() + # define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ - if ((objPtr)->refCount < -1) \ - panic("Reference count for %lx was negative: %s line %d", \ + if ((objPtr)->refCount < -1) \ + panic("Reference count for %lx was negative: %s line %d", \ (objPtr), __FILE__, __LINE__); \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ ckfree((char *) (objPtr)->bytes); \ - } \ - if (((objPtr)->typePtr != NULL) \ - && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ + } \ + if (((objPtr)->typePtr != NULL) \ + && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ (objPtr)->typePtr->freeIntRepProc(objPtr); \ - } \ - ckfree((char *) (objPtr)); \ - TclIncrObjsFreed(); \ + } \ + ckfree((char *) (objPtr)); \ + TclIncrObjsFreed(); \ } + #else /* not TCL_MEM_DEBUG */ + +#ifdef TCL_THREADS +extern Tcl_Mutex tclObjMutex; +#endif + # define TclNewObj(objPtr) \ + Tcl_MutexLock(&tclObjMutex); \ if (tclFreeObjList == NULL) { \ TclAllocateFreeObjects(); \ } \ @@ -1783,20 +2112,24 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ - TclIncrObjsAllocated() + TclIncrObjsAllocated(); \ + Tcl_MutexUnlock(&tclObjMutex) + # define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ ckfree((char *) (objPtr)->bytes); \ - } \ - if (((objPtr)->typePtr != NULL) \ - && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ + } \ + if (((objPtr)->typePtr != NULL) \ + && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ (objPtr)->typePtr->freeIntRepProc(objPtr); \ - } \ - (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ - tclFreeObjList = (objPtr); \ - TclIncrObjsFreed(); \ + } \ + Tcl_MutexLock(&tclObjMutex); \ + (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ + tclFreeObjList = (objPtr); \ + TclIncrObjsFreed(); \ + Tcl_MutexUnlock(&tclObjMutex); \ } #endif /* TCL_MEM_DEBUG */ @@ -1816,12 +2149,12 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ - (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ } else { \ (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ memcpy((VOID *) (objPtr)->bytes, (VOID *) (bytePtr), \ - (unsigned) (len)); \ + (unsigned) (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ } @@ -1829,64 +2162,18 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, /* *---------------------------------------------------------------- * Macro used by the Tcl core to get the string representation's - * byte array pointer and length from a Tcl_Obj. This is an inline - * version of Tcl_GetStringFromObj(). "lengthPtr" must be the - * address of an integer variable or NULL; If non-NULL, that variable - * will be set to the string rep's length. The macro's expression - * result is the string rep's byte pointer which might be NULL. - * Note that the bytes referenced by this pointer must not be modified - * by the caller. The ANSI C "prototype" for this macro is: + * byte array pointer from a Tcl_Obj. This is an inline version + * of Tcl_GetString(). The macro's expression result is the string + * rep's byte pointer which might be NULL. The bytes referenced by + * this pointer must not be modified by the caller. + * The ANSI C "prototype" for this macro is: * - * EXTERN char * TclGetStringFromObj _ANSI_ARGS_((Tcl_Obj *objPtr, - * int *lengthPtr)); + * EXTERN char * TclGetString _ANSI_ARGS_((Tcl_Obj *objPtr)); *---------------------------------------------------------------- */ -#define TclGetStringFromObj(objPtr, lengthPtr) \ - ((objPtr)->bytes? \ - ((lengthPtr)? \ - ((*(lengthPtr) = (objPtr)->length), (objPtr)->bytes) : \ - (objPtr)->bytes) : \ - Tcl_GetStringFromObj((objPtr), (lengthPtr))) - -/* - *---------------------------------------------------------------- - * Macro used by the Tcl core to reset an interpreter's Tcl object - * result to an unshared empty string object with ref count one. - * This does not clear any error information for the interpreter. - * The ANSI C "prototype" for this macro is: - * - * EXTERN void TclResetObjResult _ANSI_ARGS_((Tcl_Interp *interp)); - *--------------------------------------------------------------- - */ - -#define TclResetObjResult(interp) \ - { \ - register Tcl_Obj *objResultPtr = ((Interp *) interp)->objResultPtr; \ - if (Tcl_IsShared(objResultPtr)) { \ - TclDecrRefCount(objResultPtr); \ - TclNewObj(objResultPtr); \ - Tcl_IncrRefCount(objResultPtr); \ - ((Interp *) interp)->objResultPtr = objResultPtr; \ - } else { \ - if ((objResultPtr->bytes != NULL) \ - && (objResultPtr->bytes != tclEmptyStringRep)) { \ - ckfree((char *) objResultPtr->bytes); \ - } \ - objResultPtr->bytes = tclEmptyStringRep; \ - objResultPtr->length = 0; \ - if ((objResultPtr->typePtr != NULL) \ - && (objResultPtr->typePtr->freeIntRepProc != NULL)) { \ - objResultPtr->typePtr->freeIntRepProc(objResultPtr); \ - } \ - objResultPtr->typePtr = (Tcl_ObjType *) NULL; \ - } \ - } - -/* - * Include the declarations for functions that are accessible via - * the stubs table. - */ +#define TclGetString(objPtr) \ + ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr))) #include "tclIntDecls.h" diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index ec8b39a..a2b2ac2 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -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.3 1999/03/10 05:52:48 stanton Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.4 1999/04/16 00:46:48 stanton Exp $ */ #ifndef _TCLINTDECLS @@ -39,9 +39,7 @@ EXTERN int TclAccessInsertProc _ANSI_ARGS_(( TclAccessProc_ * proc)); /* 3 */ EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); -/* 4 */ -EXTERN int TclChdir _ANSI_ARGS_((Tcl_Interp * interp, - char * dirName)); +/* Slot 4 is reserved */ /* 5 */ EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, @@ -50,7 +48,7 @@ EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp, EXTERN void TclCleanupCommand _ANSI_ARGS_((Command * cmdPtr)); /* 7 */ EXTERN int TclCopyAndCollapse _ANSI_ARGS_((int count, - char * src, char * dst)); + CONST char * src, char * dst)); /* 8 */ EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, @@ -77,9 +75,7 @@ EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp * interp, char * tail)); /* 14 */ EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE * outFile)); -/* 15 */ -EXTERN void TclExpandParseValue _ANSI_ARGS_((ParseValue * pvPtr, - int needed)); +/* Slot 15 is reserved */ /* 16 */ EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp * interp, double value)); @@ -100,9 +96,10 @@ EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 22 */ EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp * interp, - char * list, int listLength, - char ** elementPtr, char ** nextPtr, - int * sizePtr, int * bracePtr)); + CONST char * listStr, int listLength, + CONST char ** elementPtr, + CONST char ** nextPtr, int * sizePtr, + int * bracePtr)); /* 23 */ EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr, char * procName)); @@ -110,24 +107,22 @@ EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr, EXTERN int TclFormatInt _ANSI_ARGS_((char * buffer, long n)); /* 25 */ EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr)); -/* 26 */ -EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp * interp)); +/* Slot 26 is reserved */ /* 27 */ EXTERN int TclGetDate _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 28 */ -EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type)); +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)); -/* 30 */ -EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name)); +/* Slot 30 is reserved */ /* 31 */ EXTERN char * TclGetExtension _ANSI_ARGS_((char * name)); /* 32 */ EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp * interp, - char * string, CallFrame ** framePtrPtr)); + char * str, CallFrame ** framePtrPtr)); /* 33 */ EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void)); /* 34 */ @@ -139,7 +134,7 @@ EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int leaveErrorMsg)); /* 36 */ EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp * interp, - char * string, long * longPtr)); + char * str, long * longPtr)); /* 37 */ EXTERN int TclGetLoadedPackages _ANSI_ARGS_(( Tcl_Interp * interp, char * targetName)); @@ -155,12 +150,12 @@ EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_(( EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void)); /* 40 */ EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int * seekFlagPtr)); + char * str, int * seekFlagPtr)); /* 41 */ EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( Tcl_Command command)); /* 42 */ -EXTERN char * TclGetUserHome _ANSI_ARGS_((char * name, +EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 43 */ EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp * interp, @@ -204,20 +199,15 @@ EXTERN int TclInvokeStringCommand _ANSI_ARGS_(( int objc, Tcl_Obj *CONST objv[])); /* 55 */ EXTERN Proc * TclIsProc _ANSI_ARGS_((Command * cmdPtr)); -/* 56 */ -EXTERN int TclLoadFile _ANSI_ARGS_((Tcl_Interp * interp, - char * fileName, char * sym1, char * sym2, - Tcl_PackageInitProc ** proc1Ptr, - Tcl_PackageInitProc ** proc2Ptr)); -/* 57 */ -EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * p)); +/* Slot 56 is reserved */ +/* Slot 57 is reserved */ /* 58 */ EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 59 */ -EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp * interp, +EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 60 */ @@ -247,14 +237,15 @@ EXTERN int TclpAccess _ANSI_ARGS_((CONST char * path, int mode)); /* 69 */ EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); /* 70 */ -EXTERN int TclpCopyFile _ANSI_ARGS_((char * source, char * dest)); +EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char * source, + CONST char * dest)); /* 71 */ -EXTERN int TclpCopyDirectory _ANSI_ARGS_((char * source, - char * dest, Tcl_DString * errorPtr)); +EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char * source, + CONST char * dest, Tcl_DString * errorPtr)); /* 72 */ -EXTERN int TclpCreateDirectory _ANSI_ARGS_((char * path)); +EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char * path)); /* 73 */ -EXTERN int TclpDeleteFile _ANSI_ARGS_((char * path)); +EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char * path)); /* 74 */ EXTERN void TclpFree _ANSI_ARGS_((char * ptr)); /* 75 */ @@ -275,25 +266,15 @@ EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp, EXTERN char * TclpRealloc _ANSI_ARGS_((char * ptr, unsigned int size)); /* 82 */ -EXTERN int TclpRemoveDirectory _ANSI_ARGS_((char * path, +EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char * path, int recursive, Tcl_DString * errorPtr)); /* 83 */ -EXTERN int TclpRenameFile _ANSI_ARGS_((char * source, - char * dest)); -/* 84 */ -EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp * interp, - char * string, char ** termPtr, - ParseValue * pvPtr)); -/* 85 */ -EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int flags, char ** termPtr, - ParseValue * pvPtr)); -/* 86 */ -EXTERN int TclParseQuotes _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int termChar, int flags, - char ** termPtr, ParseValue * pvPtr)); -/* 87 */ -EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp * interp)); +EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char * source, + CONST char * dest)); +/* Slot 84 is reserved */ +/* Slot 85 is reserved */ +/* Slot 86 is reserved */ +/* Slot 87 is reserved */ /* 88 */ EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, char * name1, @@ -301,9 +282,7 @@ EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, /* 89 */ EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); -/* 90 */ -EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Obj * objPtr)); +/* Slot 90 is reserved */ /* 91 */ EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc * procPtr)); /* 92 */ @@ -336,13 +315,12 @@ EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_(( EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int leaveErrorMsg)); -/* 101 */ -EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string)); +/* Slot 101 is reserved */ /* 102 */ EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp * interp)); /* 103 */ EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp * interp, - char * string, char * proto, int * portPtr)); + char * str, char * proto, int * portPtr)); /* 104 */ EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, int size)); @@ -357,9 +335,7 @@ EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ * proc)); EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace * nsPtr)); /* 109 */ EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp * iPtr)); -/* 110 */ -EXTERN char * TclWordEnd _ANSI_ARGS_((char * start, - char * lastChar, int nested, int * semiPtr)); +/* Slot 110 is reserved */ /* 111 */ EXTERN void Tcl_AddInterpResolvers _ANSI_ARGS_(( Tcl_Interp * interp, char * name, @@ -441,14 +417,32 @@ EXTERN void Tcl_SetNamespaceResolvers _ANSI_ARGS_(( Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 132 */ -EXTERN int TclHasSockets _ANSI_ARGS_((Tcl_Interp * interp)); +EXTERN int TclpHasSockets _ANSI_ARGS_((Tcl_Interp * interp)); /* 133 */ EXTERN struct tm * TclpGetDate _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 134 */ -EXTERN size_t TclStrftime _ANSI_ARGS_((char * s, size_t maxsize, - const char * format, const struct tm * t)); +EXTERN size_t TclpStrftime _ANSI_ARGS_((char * s, size_t maxsize, + CONST char * format, CONST struct tm * t)); /* 135 */ EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); +/* Slot 136 is reserved */ +/* 137 */ +EXTERN int TclpChdir _ANSI_ARGS_((CONST char * dirName)); +/* 138 */ +EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name, + Tcl_DString * valuePtr)); +/* 139 */ +EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp * interp, + char * fileName, char * sym1, char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + ClientData * clientDataPtr)); +/* 140 */ +EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * bytes, + int length)); +/* 141 */ +EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_DString * cwdPtr)); typedef struct TclIntStubs { int magic; @@ -458,10 +452,10 @@ typedef struct TclIntStubs { int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */ int (*tclAccessInsertProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 2 */ void (*tclAllocateFreeObjects) _ANSI_ARGS_((void)); /* 3 */ - int (*tclChdir) _ANSI_ARGS_((Tcl_Interp * interp, char * dirName)); /* 4 */ + void *reserved4; int (*tclCleanupChildren) _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); /* 5 */ void (*tclCleanupCommand) _ANSI_ARGS_((Command * cmdPtr)); /* 6 */ - int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, char * src, char * dst)); /* 7 */ + int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, CONST char * src, char * dst)); /* 7 */ int (*tclCopyChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj * cmdPtr)); /* 8 */ int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */ int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */ @@ -469,34 +463,34 @@ typedef struct TclIntStubs { void (*tclDeleteVars) _ANSI_ARGS_((Interp * iPtr, Tcl_HashTable * tablePtr)); /* 12 */ int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail)); /* 13 */ void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */ - void (*tclExpandParseValue) _ANSI_ARGS_((ParseValue * pvPtr, int needed)); /* 15 */ + void *reserved15; void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */ int (*tclFileAttrsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 17 */ int (*tclFileCopyCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 18 */ int (*tclFileDeleteCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 19 */ int (*tclFileMakeDirsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 20 */ int (*tclFileRenameCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 21 */ - int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, char * list, int listLength, char ** elementPtr, char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */ + int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */ Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, char * procName)); /* 23 */ int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */ void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */ - char * (*tclGetCwd) _ANSI_ARGS_((Tcl_Interp * interp)); /* 26 */ + void *reserved26; int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */ - Tcl_Channel (*tclGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */ + Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */ Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int leaveErrorMsg)); /* 29 */ - char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name)); /* 30 */ + void *reserved30; char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */ - int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, char * string, CallFrame ** framePtrPtr)); /* 32 */ + 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 */ - int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, char * string, long * longPtr)); /* 36 */ + 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 */ TclObjCmdProcType (*tclGetObjInterpProc) _ANSI_ARGS_((void)); /* 39 */ - int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int * seekFlagPtr)); /* 40 */ + int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * seekFlagPtr)); /* 40 */ Tcl_Command (*tclGetOriginalCommand) _ANSI_ARGS_((Tcl_Command command)); /* 41 */ - char * (*tclGetUserHome) _ANSI_ARGS_((char * name, Tcl_DString * bufferPtr)); /* 42 */ + char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */ int (*tclGlobalInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 43 */ int (*tclGuessPackageName) _ANSI_ARGS_((char * fileName, Tcl_DString * bufPtr)); /* 44 */ int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */ @@ -510,10 +504,10 @@ typedef struct TclIntStubs { int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 53 */ int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */ Proc * (*tclIsProc) _ANSI_ARGS_((Command * cmdPtr)); /* 55 */ - int (*tclLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr)); /* 56 */ - int (*tclLooksLikeInt) _ANSI_ARGS_((char * p)); /* 57 */ + void *reserved56; + void *reserved57; Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */ - int (*tclMatchFiles) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 59 */ + int (*tclpMatchFiles) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 59 */ int (*tclNeedSpace) _ANSI_ARGS_((char * start, char * end)); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */ int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */ @@ -524,10 +518,10 @@ typedef struct TclIntStubs { int (*tclOpenFileChannelInsertProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 67 */ int (*tclpAccess) _ANSI_ARGS_((CONST char * path, int mode)); /* 68 */ char * (*tclpAlloc) _ANSI_ARGS_((unsigned int size)); /* 69 */ - int (*tclpCopyFile) _ANSI_ARGS_((char * source, char * dest)); /* 70 */ - int (*tclpCopyDirectory) _ANSI_ARGS_((char * source, char * dest, Tcl_DString * errorPtr)); /* 71 */ - int (*tclpCreateDirectory) _ANSI_ARGS_((char * path)); /* 72 */ - int (*tclpDeleteFile) _ANSI_ARGS_((char * path)); /* 73 */ + int (*tclpCopyFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 70 */ + int (*tclpCopyDirectory) _ANSI_ARGS_((CONST char * source, CONST char * dest, Tcl_DString * errorPtr)); /* 71 */ + int (*tclpCreateDirectory) _ANSI_ARGS_((CONST char * path)); /* 72 */ + int (*tclpDeleteFile) _ANSI_ARGS_((CONST char * path)); /* 73 */ void (*tclpFree) _ANSI_ARGS_((char * ptr)); /* 74 */ unsigned long (*tclpGetClicks) _ANSI_ARGS_((void)); /* 75 */ unsigned long (*tclpGetSeconds) _ANSI_ARGS_((void)); /* 76 */ @@ -536,15 +530,15 @@ typedef struct TclIntStubs { int (*tclpListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 79 */ Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * modeString, int permissions)); /* 80 */ char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */ - int (*tclpRemoveDirectory) _ANSI_ARGS_((char * path, int recursive, Tcl_DString * errorPtr)); /* 82 */ - int (*tclpRenameFile) _ANSI_ARGS_((char * source, char * dest)); /* 83 */ - int (*tclParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char ** termPtr, ParseValue * pvPtr)); /* 84 */ - int (*tclParseNestedCmd) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int flags, char ** termPtr, ParseValue * pvPtr)); /* 85 */ - int (*tclParseQuotes) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int termChar, int flags, char ** termPtr, ParseValue * pvPtr)); /* 86 */ - void (*tclPlatformInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 87 */ + int (*tclpRemoveDirectory) _ANSI_ARGS_((CONST char * path, int recursive, Tcl_DString * errorPtr)); /* 82 */ + int (*tclpRenameFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 83 */ + void *reserved84; + void *reserved85; + void *reserved86; + void *reserved87; char * (*tclPrecTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, char * name1, char * name2, int flags)); /* 88 */ int (*tclPreventAliasLoop) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* 89 */ - void (*tclPrintByteCodeObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 90 */ + void *reserved90; void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */ int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */ void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */ @@ -555,16 +549,16 @@ typedef struct TclIntStubs { 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 */ - char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */ + void *reserved101; void (*tclSetupEnv) _ANSI_ARGS_((Tcl_Interp * interp)); /* 102 */ - int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char * proto, int * portPtr)); /* 103 */ + int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * proto, int * portPtr)); /* 103 */ int (*tclSockMinimumBuffers) _ANSI_ARGS_((int sock, int size)); /* 104 */ int (*tclStat) _ANSI_ARGS_((CONST char * path, TclStat_ * buf)); /* 105 */ int (*tclStatDeleteProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 106 */ int (*tclStatInsertProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 107 */ void (*tclTeardownNamespace) _ANSI_ARGS_((Namespace * nsPtr)); /* 108 */ int (*tclUpdateReturnInfo) _ANSI_ARGS_((Interp * iPtr)); /* 109 */ - char * (*tclWordEnd) _ANSI_ARGS_((char * start, char * lastChar, int nested, int * semiPtr)); /* 110 */ + 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 */ @@ -586,10 +580,16 @@ typedef struct TclIntStubs { int (*tcl_PushCallFrame) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 129 */ int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name)); /* 130 */ void (*tcl_SetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 131 */ - int (*tclHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */ + int (*tclpHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */ struct tm * (*tclpGetDate) _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 133 */ - size_t (*tclStrftime) _ANSI_ARGS_((char * s, size_t maxsize, const char * format, const struct tm * t)); /* 134 */ + size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t)); /* 134 */ int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */ + void *reserved136; + int (*tclpChdir) _ANSI_ARGS_((CONST char * dirName)); /* 137 */ + char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */ + int (*tclpLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr)); /* 139 */ + int (*tclLooksLikeInt) _ANSI_ARGS_((char * bytes, int length)); /* 140 */ + char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */ } TclIntStubs; extern TclIntStubs *tclIntStubsPtr; @@ -601,548 +601,530 @@ extern TclIntStubs *tclIntStubsPtr; */ #ifndef TclAccess -#define TclAccess(path, mode) \ - (tclIntStubsPtr->tclAccess)(path, mode) /* 0 */ +#define TclAccess \ + (tclIntStubsPtr->tclAccess) /* 0 */ #endif #ifndef TclAccessDeleteProc -#define TclAccessDeleteProc(proc) \ - (tclIntStubsPtr->tclAccessDeleteProc)(proc) /* 1 */ +#define TclAccessDeleteProc \ + (tclIntStubsPtr->tclAccessDeleteProc) /* 1 */ #endif #ifndef TclAccessInsertProc -#define TclAccessInsertProc(proc) \ - (tclIntStubsPtr->tclAccessInsertProc)(proc) /* 2 */ +#define TclAccessInsertProc \ + (tclIntStubsPtr->tclAccessInsertProc) /* 2 */ #endif #ifndef TclAllocateFreeObjects -#define TclAllocateFreeObjects() \ - (tclIntStubsPtr->tclAllocateFreeObjects)() /* 3 */ -#endif -#ifndef TclChdir -#define TclChdir(interp, dirName) \ - (tclIntStubsPtr->tclChdir)(interp, dirName) /* 4 */ +#define TclAllocateFreeObjects \ + (tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */ #endif +/* Slot 4 is reserved */ #ifndef TclCleanupChildren -#define TclCleanupChildren(interp, numPids, pidPtr, errorChan) \ - (tclIntStubsPtr->tclCleanupChildren)(interp, numPids, pidPtr, errorChan) /* 5 */ +#define TclCleanupChildren \ + (tclIntStubsPtr->tclCleanupChildren) /* 5 */ #endif #ifndef TclCleanupCommand -#define TclCleanupCommand(cmdPtr) \ - (tclIntStubsPtr->tclCleanupCommand)(cmdPtr) /* 6 */ +#define TclCleanupCommand \ + (tclIntStubsPtr->tclCleanupCommand) /* 6 */ #endif #ifndef TclCopyAndCollapse -#define TclCopyAndCollapse(count, src, dst) \ - (tclIntStubsPtr->tclCopyAndCollapse)(count, src, dst) /* 7 */ +#define TclCopyAndCollapse \ + (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */ #endif #ifndef TclCopyChannel -#define TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) \ - (tclIntStubsPtr->tclCopyChannel)(interp, inChan, outChan, toRead, cmdPtr) /* 8 */ +#define TclCopyChannel \ + (tclIntStubsPtr->tclCopyChannel) /* 8 */ #endif #ifndef TclCreatePipeline -#define TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr) \ - (tclIntStubsPtr->tclCreatePipeline)(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr) /* 9 */ +#define TclCreatePipeline \ + (tclIntStubsPtr->tclCreatePipeline) /* 9 */ #endif #ifndef TclCreateProc -#define TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) \ - (tclIntStubsPtr->tclCreateProc)(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) /* 10 */ +#define TclCreateProc \ + (tclIntStubsPtr->tclCreateProc) /* 10 */ #endif #ifndef TclDeleteCompiledLocalVars -#define TclDeleteCompiledLocalVars(iPtr, framePtr) \ - (tclIntStubsPtr->tclDeleteCompiledLocalVars)(iPtr, framePtr) /* 11 */ +#define TclDeleteCompiledLocalVars \ + (tclIntStubsPtr->tclDeleteCompiledLocalVars) /* 11 */ #endif #ifndef TclDeleteVars -#define TclDeleteVars(iPtr, tablePtr) \ - (tclIntStubsPtr->tclDeleteVars)(iPtr, tablePtr) /* 12 */ +#define TclDeleteVars \ + (tclIntStubsPtr->tclDeleteVars) /* 12 */ #endif #ifndef TclDoGlob -#define TclDoGlob(interp, separators, headPtr, tail) \ - (tclIntStubsPtr->tclDoGlob)(interp, separators, headPtr, tail) /* 13 */ +#define TclDoGlob \ + (tclIntStubsPtr->tclDoGlob) /* 13 */ #endif #ifndef TclDumpMemoryInfo -#define TclDumpMemoryInfo(outFile) \ - (tclIntStubsPtr->tclDumpMemoryInfo)(outFile) /* 14 */ -#endif -#ifndef TclExpandParseValue -#define TclExpandParseValue(pvPtr, needed) \ - (tclIntStubsPtr->tclExpandParseValue)(pvPtr, needed) /* 15 */ +#define TclDumpMemoryInfo \ + (tclIntStubsPtr->tclDumpMemoryInfo) /* 14 */ #endif +/* Slot 15 is reserved */ #ifndef TclExprFloatError -#define TclExprFloatError(interp, value) \ - (tclIntStubsPtr->tclExprFloatError)(interp, value) /* 16 */ +#define TclExprFloatError \ + (tclIntStubsPtr->tclExprFloatError) /* 16 */ #endif #ifndef TclFileAttrsCmd -#define TclFileAttrsCmd(interp, objc, objv) \ - (tclIntStubsPtr->tclFileAttrsCmd)(interp, objc, objv) /* 17 */ +#define TclFileAttrsCmd \ + (tclIntStubsPtr->tclFileAttrsCmd) /* 17 */ #endif #ifndef TclFileCopyCmd -#define TclFileCopyCmd(interp, argc, argv) \ - (tclIntStubsPtr->tclFileCopyCmd)(interp, argc, argv) /* 18 */ +#define TclFileCopyCmd \ + (tclIntStubsPtr->tclFileCopyCmd) /* 18 */ #endif #ifndef TclFileDeleteCmd -#define TclFileDeleteCmd(interp, argc, argv) \ - (tclIntStubsPtr->tclFileDeleteCmd)(interp, argc, argv) /* 19 */ +#define TclFileDeleteCmd \ + (tclIntStubsPtr->tclFileDeleteCmd) /* 19 */ #endif #ifndef TclFileMakeDirsCmd -#define TclFileMakeDirsCmd(interp, argc, argv) \ - (tclIntStubsPtr->tclFileMakeDirsCmd)(interp, argc, argv) /* 20 */ +#define TclFileMakeDirsCmd \ + (tclIntStubsPtr->tclFileMakeDirsCmd) /* 20 */ #endif #ifndef TclFileRenameCmd -#define TclFileRenameCmd(interp, argc, argv) \ - (tclIntStubsPtr->tclFileRenameCmd)(interp, argc, argv) /* 21 */ +#define TclFileRenameCmd \ + (tclIntStubsPtr->tclFileRenameCmd) /* 21 */ #endif #ifndef TclFindElement -#define TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, bracePtr) \ - (tclIntStubsPtr->tclFindElement)(interp, list, listLength, elementPtr, nextPtr, sizePtr, bracePtr) /* 22 */ +#define TclFindElement \ + (tclIntStubsPtr->tclFindElement) /* 22 */ #endif #ifndef TclFindProc -#define TclFindProc(iPtr, procName) \ - (tclIntStubsPtr->tclFindProc)(iPtr, procName) /* 23 */ +#define TclFindProc \ + (tclIntStubsPtr->tclFindProc) /* 23 */ #endif #ifndef TclFormatInt -#define TclFormatInt(buffer, n) \ - (tclIntStubsPtr->tclFormatInt)(buffer, n) /* 24 */ +#define TclFormatInt \ + (tclIntStubsPtr->tclFormatInt) /* 24 */ #endif #ifndef TclFreePackageInfo -#define TclFreePackageInfo(iPtr) \ - (tclIntStubsPtr->tclFreePackageInfo)(iPtr) /* 25 */ -#endif -#ifndef TclGetCwd -#define TclGetCwd(interp) \ - (tclIntStubsPtr->tclGetCwd)(interp) /* 26 */ +#define TclFreePackageInfo \ + (tclIntStubsPtr->tclFreePackageInfo) /* 25 */ #endif +/* Slot 26 is reserved */ #ifndef TclGetDate -#define TclGetDate(p, now, zone, timePtr) \ - (tclIntStubsPtr->tclGetDate)(p, now, zone, timePtr) /* 27 */ +#define TclGetDate \ + (tclIntStubsPtr->tclGetDate) /* 27 */ #endif -#ifndef TclGetDefaultStdChannel -#define TclGetDefaultStdChannel(type) \ - (tclIntStubsPtr->tclGetDefaultStdChannel)(type) /* 28 */ +#ifndef TclpGetDefaultStdChannel +#define TclpGetDefaultStdChannel \ + (tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */ #endif #ifndef TclGetElementOfIndexedArray -#define TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) \ - (tclIntStubsPtr->tclGetElementOfIndexedArray)(interp, localIndex, elemPtr, leaveErrorMsg) /* 29 */ -#endif -#ifndef TclGetEnv -#define TclGetEnv(name) \ - (tclIntStubsPtr->tclGetEnv)(name) /* 30 */ +#define TclGetElementOfIndexedArray \ + (tclIntStubsPtr->tclGetElementOfIndexedArray) /* 29 */ #endif +/* Slot 30 is reserved */ #ifndef TclGetExtension -#define TclGetExtension(name) \ - (tclIntStubsPtr->tclGetExtension)(name) /* 31 */ +#define TclGetExtension \ + (tclIntStubsPtr->tclGetExtension) /* 31 */ #endif #ifndef TclGetFrame -#define TclGetFrame(interp, string, framePtrPtr) \ - (tclIntStubsPtr->tclGetFrame)(interp, string, framePtrPtr) /* 32 */ +#define TclGetFrame \ + (tclIntStubsPtr->tclGetFrame) /* 32 */ #endif #ifndef TclGetInterpProc -#define TclGetInterpProc() \ - (tclIntStubsPtr->tclGetInterpProc)() /* 33 */ +#define TclGetInterpProc \ + (tclIntStubsPtr->tclGetInterpProc) /* 33 */ #endif #ifndef TclGetIntForIndex -#define TclGetIntForIndex(interp, objPtr, endValue, indexPtr) \ - (tclIntStubsPtr->tclGetIntForIndex)(interp, objPtr, endValue, indexPtr) /* 34 */ +#define TclGetIntForIndex \ + (tclIntStubsPtr->tclGetIntForIndex) /* 34 */ #endif #ifndef TclGetIndexedScalar -#define TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) \ - (tclIntStubsPtr->tclGetIndexedScalar)(interp, localIndex, leaveErrorMsg) /* 35 */ +#define TclGetIndexedScalar \ + (tclIntStubsPtr->tclGetIndexedScalar) /* 35 */ #endif #ifndef TclGetLong -#define TclGetLong(interp, string, longPtr) \ - (tclIntStubsPtr->tclGetLong)(interp, string, longPtr) /* 36 */ +#define TclGetLong \ + (tclIntStubsPtr->tclGetLong) /* 36 */ #endif #ifndef TclGetLoadedPackages -#define TclGetLoadedPackages(interp, targetName) \ - (tclIntStubsPtr->tclGetLoadedPackages)(interp, targetName) /* 37 */ +#define TclGetLoadedPackages \ + (tclIntStubsPtr->tclGetLoadedPackages) /* 37 */ #endif #ifndef TclGetNamespaceForQualName -#define TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) \ - (tclIntStubsPtr->tclGetNamespaceForQualName)(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) /* 38 */ +#define TclGetNamespaceForQualName \ + (tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */ #endif #ifndef TclGetObjInterpProc -#define TclGetObjInterpProc() \ - (tclIntStubsPtr->tclGetObjInterpProc)() /* 39 */ +#define TclGetObjInterpProc \ + (tclIntStubsPtr->tclGetObjInterpProc) /* 39 */ #endif #ifndef TclGetOpenMode -#define TclGetOpenMode(interp, string, seekFlagPtr) \ - (tclIntStubsPtr->tclGetOpenMode)(interp, string, seekFlagPtr) /* 40 */ +#define TclGetOpenMode \ + (tclIntStubsPtr->tclGetOpenMode) /* 40 */ #endif #ifndef TclGetOriginalCommand -#define TclGetOriginalCommand(command) \ - (tclIntStubsPtr->tclGetOriginalCommand)(command) /* 41 */ +#define TclGetOriginalCommand \ + (tclIntStubsPtr->tclGetOriginalCommand) /* 41 */ #endif -#ifndef TclGetUserHome -#define TclGetUserHome(name, bufferPtr) \ - (tclIntStubsPtr->tclGetUserHome)(name, bufferPtr) /* 42 */ +#ifndef TclpGetUserHome +#define TclpGetUserHome \ + (tclIntStubsPtr->tclpGetUserHome) /* 42 */ #endif #ifndef TclGlobalInvoke -#define TclGlobalInvoke(interp, argc, argv, flags) \ - (tclIntStubsPtr->tclGlobalInvoke)(interp, argc, argv, flags) /* 43 */ +#define TclGlobalInvoke \ + (tclIntStubsPtr->tclGlobalInvoke) /* 43 */ #endif #ifndef TclGuessPackageName -#define TclGuessPackageName(fileName, bufPtr) \ - (tclIntStubsPtr->tclGuessPackageName)(fileName, bufPtr) /* 44 */ +#define TclGuessPackageName \ + (tclIntStubsPtr->tclGuessPackageName) /* 44 */ #endif #ifndef TclHideUnsafeCommands -#define TclHideUnsafeCommands(interp) \ - (tclIntStubsPtr->tclHideUnsafeCommands)(interp) /* 45 */ +#define TclHideUnsafeCommands \ + (tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */ #endif #ifndef TclInExit -#define TclInExit() \ - (tclIntStubsPtr->tclInExit)() /* 46 */ +#define TclInExit \ + (tclIntStubsPtr->tclInExit) /* 46 */ #endif #ifndef TclIncrElementOfIndexedArray -#define TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) \ - (tclIntStubsPtr->tclIncrElementOfIndexedArray)(interp, localIndex, elemPtr, incrAmount) /* 47 */ +#define TclIncrElementOfIndexedArray \ + (tclIntStubsPtr->tclIncrElementOfIndexedArray) /* 47 */ #endif #ifndef TclIncrIndexedScalar -#define TclIncrIndexedScalar(interp, localIndex, incrAmount) \ - (tclIntStubsPtr->tclIncrIndexedScalar)(interp, localIndex, incrAmount) /* 48 */ +#define TclIncrIndexedScalar \ + (tclIntStubsPtr->tclIncrIndexedScalar) /* 48 */ #endif #ifndef TclIncrVar2 -#define TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) \ - (tclIntStubsPtr->tclIncrVar2)(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) /* 49 */ +#define TclIncrVar2 \ + (tclIntStubsPtr->tclIncrVar2) /* 49 */ #endif #ifndef TclInitCompiledLocals -#define TclInitCompiledLocals(interp, framePtr, nsPtr) \ - (tclIntStubsPtr->tclInitCompiledLocals)(interp, framePtr, nsPtr) /* 50 */ +#define TclInitCompiledLocals \ + (tclIntStubsPtr->tclInitCompiledLocals) /* 50 */ #endif #ifndef TclInterpInit -#define TclInterpInit(interp) \ - (tclIntStubsPtr->tclInterpInit)(interp) /* 51 */ +#define TclInterpInit \ + (tclIntStubsPtr->tclInterpInit) /* 51 */ #endif #ifndef TclInvoke -#define TclInvoke(interp, argc, argv, flags) \ - (tclIntStubsPtr->tclInvoke)(interp, argc, argv, flags) /* 52 */ +#define TclInvoke \ + (tclIntStubsPtr->tclInvoke) /* 52 */ #endif #ifndef TclInvokeObjectCommand -#define TclInvokeObjectCommand(clientData, interp, argc, argv) \ - (tclIntStubsPtr->tclInvokeObjectCommand)(clientData, interp, argc, argv) /* 53 */ +#define TclInvokeObjectCommand \ + (tclIntStubsPtr->tclInvokeObjectCommand) /* 53 */ #endif #ifndef TclInvokeStringCommand -#define TclInvokeStringCommand(clientData, interp, objc, objv) \ - (tclIntStubsPtr->tclInvokeStringCommand)(clientData, interp, objc, objv) /* 54 */ +#define TclInvokeStringCommand \ + (tclIntStubsPtr->tclInvokeStringCommand) /* 54 */ #endif #ifndef TclIsProc -#define TclIsProc(cmdPtr) \ - (tclIntStubsPtr->tclIsProc)(cmdPtr) /* 55 */ -#endif -#ifndef TclLoadFile -#define TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) \ - (tclIntStubsPtr->tclLoadFile)(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) /* 56 */ -#endif -#ifndef TclLooksLikeInt -#define TclLooksLikeInt(p) \ - (tclIntStubsPtr->tclLooksLikeInt)(p) /* 57 */ +#define TclIsProc \ + (tclIntStubsPtr->tclIsProc) /* 55 */ #endif +/* Slot 56 is reserved */ +/* Slot 57 is reserved */ #ifndef TclLookupVar -#define TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr) \ - (tclIntStubsPtr->tclLookupVar)(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr) /* 58 */ +#define TclLookupVar \ + (tclIntStubsPtr->tclLookupVar) /* 58 */ #endif -#ifndef TclMatchFiles -#define TclMatchFiles(interp, separators, dirPtr, pattern, tail) \ - (tclIntStubsPtr->tclMatchFiles)(interp, separators, dirPtr, pattern, tail) /* 59 */ +#ifndef TclpMatchFiles +#define TclpMatchFiles \ + (tclIntStubsPtr->tclpMatchFiles) /* 59 */ #endif #ifndef TclNeedSpace -#define TclNeedSpace(start, end) \ - (tclIntStubsPtr->tclNeedSpace)(start, end) /* 60 */ +#define TclNeedSpace \ + (tclIntStubsPtr->tclNeedSpace) /* 60 */ #endif #ifndef TclNewProcBodyObj -#define TclNewProcBodyObj(procPtr) \ - (tclIntStubsPtr->tclNewProcBodyObj)(procPtr) /* 61 */ +#define TclNewProcBodyObj \ + (tclIntStubsPtr->tclNewProcBodyObj) /* 61 */ #endif #ifndef TclObjCommandComplete -#define TclObjCommandComplete(cmdPtr) \ - (tclIntStubsPtr->tclObjCommandComplete)(cmdPtr) /* 62 */ +#define TclObjCommandComplete \ + (tclIntStubsPtr->tclObjCommandComplete) /* 62 */ #endif #ifndef TclObjInterpProc -#define TclObjInterpProc(clientData, interp, objc, objv) \ - (tclIntStubsPtr->tclObjInterpProc)(clientData, interp, objc, objv) /* 63 */ +#define TclObjInterpProc \ + (tclIntStubsPtr->tclObjInterpProc) /* 63 */ #endif #ifndef TclObjInvoke -#define TclObjInvoke(interp, objc, objv, flags) \ - (tclIntStubsPtr->tclObjInvoke)(interp, objc, objv, flags) /* 64 */ +#define TclObjInvoke \ + (tclIntStubsPtr->tclObjInvoke) /* 64 */ #endif #ifndef TclObjInvokeGlobal -#define TclObjInvokeGlobal(interp, objc, objv, flags) \ - (tclIntStubsPtr->tclObjInvokeGlobal)(interp, objc, objv, flags) /* 65 */ +#define TclObjInvokeGlobal \ + (tclIntStubsPtr->tclObjInvokeGlobal) /* 65 */ #endif #ifndef TclOpenFileChannelDeleteProc -#define TclOpenFileChannelDeleteProc(proc) \ - (tclIntStubsPtr->tclOpenFileChannelDeleteProc)(proc) /* 66 */ +#define TclOpenFileChannelDeleteProc \ + (tclIntStubsPtr->tclOpenFileChannelDeleteProc) /* 66 */ #endif #ifndef TclOpenFileChannelInsertProc -#define TclOpenFileChannelInsertProc(proc) \ - (tclIntStubsPtr->tclOpenFileChannelInsertProc)(proc) /* 67 */ +#define TclOpenFileChannelInsertProc \ + (tclIntStubsPtr->tclOpenFileChannelInsertProc) /* 67 */ #endif #ifndef TclpAccess -#define TclpAccess(path, mode) \ - (tclIntStubsPtr->tclpAccess)(path, mode) /* 68 */ +#define TclpAccess \ + (tclIntStubsPtr->tclpAccess) /* 68 */ #endif #ifndef TclpAlloc -#define TclpAlloc(size) \ - (tclIntStubsPtr->tclpAlloc)(size) /* 69 */ +#define TclpAlloc \ + (tclIntStubsPtr->tclpAlloc) /* 69 */ #endif #ifndef TclpCopyFile -#define TclpCopyFile(source, dest) \ - (tclIntStubsPtr->tclpCopyFile)(source, dest) /* 70 */ +#define TclpCopyFile \ + (tclIntStubsPtr->tclpCopyFile) /* 70 */ #endif #ifndef TclpCopyDirectory -#define TclpCopyDirectory(source, dest, errorPtr) \ - (tclIntStubsPtr->tclpCopyDirectory)(source, dest, errorPtr) /* 71 */ +#define TclpCopyDirectory \ + (tclIntStubsPtr->tclpCopyDirectory) /* 71 */ #endif #ifndef TclpCreateDirectory -#define TclpCreateDirectory(path) \ - (tclIntStubsPtr->tclpCreateDirectory)(path) /* 72 */ +#define TclpCreateDirectory \ + (tclIntStubsPtr->tclpCreateDirectory) /* 72 */ #endif #ifndef TclpDeleteFile -#define TclpDeleteFile(path) \ - (tclIntStubsPtr->tclpDeleteFile)(path) /* 73 */ +#define TclpDeleteFile \ + (tclIntStubsPtr->tclpDeleteFile) /* 73 */ #endif #ifndef TclpFree -#define TclpFree(ptr) \ - (tclIntStubsPtr->tclpFree)(ptr) /* 74 */ +#define TclpFree \ + (tclIntStubsPtr->tclpFree) /* 74 */ #endif #ifndef TclpGetClicks -#define TclpGetClicks() \ - (tclIntStubsPtr->tclpGetClicks)() /* 75 */ +#define TclpGetClicks \ + (tclIntStubsPtr->tclpGetClicks) /* 75 */ #endif #ifndef TclpGetSeconds -#define TclpGetSeconds() \ - (tclIntStubsPtr->tclpGetSeconds)() /* 76 */ +#define TclpGetSeconds \ + (tclIntStubsPtr->tclpGetSeconds) /* 76 */ #endif #ifndef TclpGetTime -#define TclpGetTime(time) \ - (tclIntStubsPtr->tclpGetTime)(time) /* 77 */ +#define TclpGetTime \ + (tclIntStubsPtr->tclpGetTime) /* 77 */ #endif #ifndef TclpGetTimeZone -#define TclpGetTimeZone(time) \ - (tclIntStubsPtr->tclpGetTimeZone)(time) /* 78 */ +#define TclpGetTimeZone \ + (tclIntStubsPtr->tclpGetTimeZone) /* 78 */ #endif #ifndef TclpListVolumes -#define TclpListVolumes(interp) \ - (tclIntStubsPtr->tclpListVolumes)(interp) /* 79 */ +#define TclpListVolumes \ + (tclIntStubsPtr->tclpListVolumes) /* 79 */ #endif #ifndef TclpOpenFileChannel -#define TclpOpenFileChannel(interp, fileName, modeString, permissions) \ - (tclIntStubsPtr->tclpOpenFileChannel)(interp, fileName, modeString, permissions) /* 80 */ +#define TclpOpenFileChannel \ + (tclIntStubsPtr->tclpOpenFileChannel) /* 80 */ #endif #ifndef TclpRealloc -#define TclpRealloc(ptr, size) \ - (tclIntStubsPtr->tclpRealloc)(ptr, size) /* 81 */ +#define TclpRealloc \ + (tclIntStubsPtr->tclpRealloc) /* 81 */ #endif #ifndef TclpRemoveDirectory -#define TclpRemoveDirectory(path, recursive, errorPtr) \ - (tclIntStubsPtr->tclpRemoveDirectory)(path, recursive, errorPtr) /* 82 */ +#define TclpRemoveDirectory \ + (tclIntStubsPtr->tclpRemoveDirectory) /* 82 */ #endif #ifndef TclpRenameFile -#define TclpRenameFile(source, dest) \ - (tclIntStubsPtr->tclpRenameFile)(source, dest) /* 83 */ -#endif -#ifndef TclParseBraces -#define TclParseBraces(interp, string, termPtr, pvPtr) \ - (tclIntStubsPtr->tclParseBraces)(interp, string, termPtr, pvPtr) /* 84 */ -#endif -#ifndef TclParseNestedCmd -#define TclParseNestedCmd(interp, string, flags, termPtr, pvPtr) \ - (tclIntStubsPtr->tclParseNestedCmd)(interp, string, flags, termPtr, pvPtr) /* 85 */ -#endif -#ifndef TclParseQuotes -#define TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr) \ - (tclIntStubsPtr->tclParseQuotes)(interp, string, termChar, flags, termPtr, pvPtr) /* 86 */ -#endif -#ifndef TclPlatformInit -#define TclPlatformInit(interp) \ - (tclIntStubsPtr->tclPlatformInit)(interp) /* 87 */ +#define TclpRenameFile \ + (tclIntStubsPtr->tclpRenameFile) /* 83 */ #endif +/* Slot 84 is reserved */ +/* Slot 85 is reserved */ +/* Slot 86 is reserved */ +/* Slot 87 is reserved */ #ifndef TclPrecTraceProc -#define TclPrecTraceProc(clientData, interp, name1, name2, flags) \ - (tclIntStubsPtr->tclPrecTraceProc)(clientData, interp, name1, name2, flags) /* 88 */ +#define TclPrecTraceProc \ + (tclIntStubsPtr->tclPrecTraceProc) /* 88 */ #endif #ifndef TclPreventAliasLoop -#define TclPreventAliasLoop(interp, cmdInterp, cmd) \ - (tclIntStubsPtr->tclPreventAliasLoop)(interp, cmdInterp, cmd) /* 89 */ -#endif -#ifndef TclPrintByteCodeObj -#define TclPrintByteCodeObj(interp, objPtr) \ - (tclIntStubsPtr->tclPrintByteCodeObj)(interp, objPtr) /* 90 */ +#define TclPreventAliasLoop \ + (tclIntStubsPtr->tclPreventAliasLoop) /* 89 */ #endif +/* Slot 90 is reserved */ #ifndef TclProcCleanupProc -#define TclProcCleanupProc(procPtr) \ - (tclIntStubsPtr->tclProcCleanupProc)(procPtr) /* 91 */ +#define TclProcCleanupProc \ + (tclIntStubsPtr->tclProcCleanupProc) /* 91 */ #endif #ifndef TclProcCompileProc -#define TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) \ - (tclIntStubsPtr->tclProcCompileProc)(interp, procPtr, bodyPtr, nsPtr, description, procName) /* 92 */ +#define TclProcCompileProc \ + (tclIntStubsPtr->tclProcCompileProc) /* 92 */ #endif #ifndef TclProcDeleteProc -#define TclProcDeleteProc(clientData) \ - (tclIntStubsPtr->tclProcDeleteProc)(clientData) /* 93 */ +#define TclProcDeleteProc \ + (tclIntStubsPtr->tclProcDeleteProc) /* 93 */ #endif #ifndef TclProcInterpProc -#define TclProcInterpProc(clientData, interp, argc, argv) \ - (tclIntStubsPtr->tclProcInterpProc)(clientData, interp, argc, argv) /* 94 */ +#define TclProcInterpProc \ + (tclIntStubsPtr->tclProcInterpProc) /* 94 */ #endif #ifndef TclpStat -#define TclpStat(path, buf) \ - (tclIntStubsPtr->tclpStat)(path, buf) /* 95 */ +#define TclpStat \ + (tclIntStubsPtr->tclpStat) /* 95 */ #endif #ifndef TclRenameCommand -#define TclRenameCommand(interp, oldName, newName) \ - (tclIntStubsPtr->tclRenameCommand)(interp, oldName, newName) /* 96 */ +#define TclRenameCommand \ + (tclIntStubsPtr->tclRenameCommand) /* 96 */ #endif #ifndef TclResetShadowedCmdRefs -#define TclResetShadowedCmdRefs(interp, newCmdPtr) \ - (tclIntStubsPtr->tclResetShadowedCmdRefs)(interp, newCmdPtr) /* 97 */ +#define TclResetShadowedCmdRefs \ + (tclIntStubsPtr->tclResetShadowedCmdRefs) /* 97 */ #endif #ifndef TclServiceIdle -#define TclServiceIdle() \ - (tclIntStubsPtr->tclServiceIdle)() /* 98 */ +#define TclServiceIdle \ + (tclIntStubsPtr->tclServiceIdle) /* 98 */ #endif #ifndef TclSetElementOfIndexedArray -#define TclSetElementOfIndexedArray(interp, localIndex, elemPtr, objPtr, leaveErrorMsg) \ - (tclIntStubsPtr->tclSetElementOfIndexedArray)(interp, localIndex, elemPtr, objPtr, leaveErrorMsg) /* 99 */ +#define TclSetElementOfIndexedArray \ + (tclIntStubsPtr->tclSetElementOfIndexedArray) /* 99 */ #endif #ifndef TclSetIndexedScalar -#define TclSetIndexedScalar(interp, localIndex, objPtr, leaveErrorMsg) \ - (tclIntStubsPtr->tclSetIndexedScalar)(interp, localIndex, objPtr, leaveErrorMsg) /* 100 */ -#endif -#ifndef TclSetPreInitScript -#define TclSetPreInitScript(string) \ - (tclIntStubsPtr->tclSetPreInitScript)(string) /* 101 */ +#define TclSetIndexedScalar \ + (tclIntStubsPtr->tclSetIndexedScalar) /* 100 */ #endif +/* Slot 101 is reserved */ #ifndef TclSetupEnv -#define TclSetupEnv(interp) \ - (tclIntStubsPtr->tclSetupEnv)(interp) /* 102 */ +#define TclSetupEnv \ + (tclIntStubsPtr->tclSetupEnv) /* 102 */ #endif #ifndef TclSockGetPort -#define TclSockGetPort(interp, string, proto, portPtr) \ - (tclIntStubsPtr->tclSockGetPort)(interp, string, proto, portPtr) /* 103 */ +#define TclSockGetPort \ + (tclIntStubsPtr->tclSockGetPort) /* 103 */ #endif #ifndef TclSockMinimumBuffers -#define TclSockMinimumBuffers(sock, size) \ - (tclIntStubsPtr->tclSockMinimumBuffers)(sock, size) /* 104 */ +#define TclSockMinimumBuffers \ + (tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */ #endif #ifndef TclStat -#define TclStat(path, buf) \ - (tclIntStubsPtr->tclStat)(path, buf) /* 105 */ +#define TclStat \ + (tclIntStubsPtr->tclStat) /* 105 */ #endif #ifndef TclStatDeleteProc -#define TclStatDeleteProc(proc) \ - (tclIntStubsPtr->tclStatDeleteProc)(proc) /* 106 */ +#define TclStatDeleteProc \ + (tclIntStubsPtr->tclStatDeleteProc) /* 106 */ #endif #ifndef TclStatInsertProc -#define TclStatInsertProc(proc) \ - (tclIntStubsPtr->tclStatInsertProc)(proc) /* 107 */ +#define TclStatInsertProc \ + (tclIntStubsPtr->tclStatInsertProc) /* 107 */ #endif #ifndef TclTeardownNamespace -#define TclTeardownNamespace(nsPtr) \ - (tclIntStubsPtr->tclTeardownNamespace)(nsPtr) /* 108 */ +#define TclTeardownNamespace \ + (tclIntStubsPtr->tclTeardownNamespace) /* 108 */ #endif #ifndef TclUpdateReturnInfo -#define TclUpdateReturnInfo(iPtr) \ - (tclIntStubsPtr->tclUpdateReturnInfo)(iPtr) /* 109 */ -#endif -#ifndef TclWordEnd -#define TclWordEnd(start, lastChar, nested, semiPtr) \ - (tclIntStubsPtr->tclWordEnd)(start, lastChar, nested, semiPtr) /* 110 */ +#define TclUpdateReturnInfo \ + (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ #endif +/* Slot 110 is reserved */ #ifndef Tcl_AddInterpResolvers -#define Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc) \ - (tclIntStubsPtr->tcl_AddInterpResolvers)(interp, name, cmdProc, varProc, compiledVarProc) /* 111 */ +#define Tcl_AddInterpResolvers \ + (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ #endif #ifndef Tcl_AppendExportList -#define Tcl_AppendExportList(interp, nsPtr, objPtr) \ - (tclIntStubsPtr->tcl_AppendExportList)(interp, nsPtr, objPtr) /* 112 */ +#define Tcl_AppendExportList \ + (tclIntStubsPtr->tcl_AppendExportList) /* 112 */ #endif #ifndef Tcl_CreateNamespace -#define Tcl_CreateNamespace(interp, name, clientData, deleteProc) \ - (tclIntStubsPtr->tcl_CreateNamespace)(interp, name, clientData, deleteProc) /* 113 */ +#define Tcl_CreateNamespace \ + (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */ #endif #ifndef Tcl_DeleteNamespace -#define Tcl_DeleteNamespace(nsPtr) \ - (tclIntStubsPtr->tcl_DeleteNamespace)(nsPtr) /* 114 */ +#define Tcl_DeleteNamespace \ + (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */ #endif #ifndef Tcl_Export -#define Tcl_Export(interp, nsPtr, pattern, resetListFirst) \ - (tclIntStubsPtr->tcl_Export)(interp, nsPtr, pattern, resetListFirst) /* 115 */ +#define Tcl_Export \ + (tclIntStubsPtr->tcl_Export) /* 115 */ #endif #ifndef Tcl_FindCommand -#define Tcl_FindCommand(interp, name, contextNsPtr, flags) \ - (tclIntStubsPtr->tcl_FindCommand)(interp, name, contextNsPtr, flags) /* 116 */ +#define Tcl_FindCommand \ + (tclIntStubsPtr->tcl_FindCommand) /* 116 */ #endif #ifndef Tcl_FindNamespace -#define Tcl_FindNamespace(interp, name, contextNsPtr, flags) \ - (tclIntStubsPtr->tcl_FindNamespace)(interp, name, contextNsPtr, flags) /* 117 */ +#define Tcl_FindNamespace \ + (tclIntStubsPtr->tcl_FindNamespace) /* 117 */ #endif #ifndef Tcl_GetInterpResolvers -#define Tcl_GetInterpResolvers(interp, name, resInfo) \ - (tclIntStubsPtr->tcl_GetInterpResolvers)(interp, name, resInfo) /* 118 */ +#define Tcl_GetInterpResolvers \ + (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #endif #ifndef Tcl_GetNamespaceResolvers -#define Tcl_GetNamespaceResolvers(namespacePtr, resInfo) \ - (tclIntStubsPtr->tcl_GetNamespaceResolvers)(namespacePtr, resInfo) /* 119 */ +#define Tcl_GetNamespaceResolvers \ + (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #endif #ifndef Tcl_FindNamespaceVar -#define Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) \ - (tclIntStubsPtr->tcl_FindNamespaceVar)(interp, name, contextNsPtr, flags) /* 120 */ +#define Tcl_FindNamespaceVar \ + (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ #endif #ifndef Tcl_ForgetImport -#define Tcl_ForgetImport(interp, nsPtr, pattern) \ - (tclIntStubsPtr->tcl_ForgetImport)(interp, nsPtr, pattern) /* 121 */ +#define Tcl_ForgetImport \ + (tclIntStubsPtr->tcl_ForgetImport) /* 121 */ #endif #ifndef Tcl_GetCommandFromObj -#define Tcl_GetCommandFromObj(interp, objPtr) \ - (tclIntStubsPtr->tcl_GetCommandFromObj)(interp, objPtr) /* 122 */ +#define Tcl_GetCommandFromObj \ + (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */ #endif #ifndef Tcl_GetCommandFullName -#define Tcl_GetCommandFullName(interp, command, objPtr) \ - (tclIntStubsPtr->tcl_GetCommandFullName)(interp, command, objPtr) /* 123 */ +#define Tcl_GetCommandFullName \ + (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */ #endif #ifndef Tcl_GetCurrentNamespace -#define Tcl_GetCurrentNamespace(interp) \ - (tclIntStubsPtr->tcl_GetCurrentNamespace)(interp) /* 124 */ +#define Tcl_GetCurrentNamespace \ + (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */ #endif #ifndef Tcl_GetGlobalNamespace -#define Tcl_GetGlobalNamespace(interp) \ - (tclIntStubsPtr->tcl_GetGlobalNamespace)(interp) /* 125 */ +#define Tcl_GetGlobalNamespace \ + (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */ #endif #ifndef Tcl_GetVariableFullName -#define Tcl_GetVariableFullName(interp, variable, objPtr) \ - (tclIntStubsPtr->tcl_GetVariableFullName)(interp, variable, objPtr) /* 126 */ +#define Tcl_GetVariableFullName \ + (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ #endif #ifndef Tcl_Import -#define Tcl_Import(interp, nsPtr, pattern, allowOverwrite) \ - (tclIntStubsPtr->tcl_Import)(interp, nsPtr, pattern, allowOverwrite) /* 127 */ +#define Tcl_Import \ + (tclIntStubsPtr->tcl_Import) /* 127 */ #endif #ifndef Tcl_PopCallFrame -#define Tcl_PopCallFrame(interp) \ - (tclIntStubsPtr->tcl_PopCallFrame)(interp) /* 128 */ +#define Tcl_PopCallFrame \ + (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #endif #ifndef Tcl_PushCallFrame -#define Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame) \ - (tclIntStubsPtr->tcl_PushCallFrame)(interp, framePtr, nsPtr, isProcCallFrame) /* 129 */ +#define Tcl_PushCallFrame \ + (tclIntStubsPtr->tcl_PushCallFrame) /* 129 */ #endif #ifndef Tcl_RemoveInterpResolvers -#define Tcl_RemoveInterpResolvers(interp, name) \ - (tclIntStubsPtr->tcl_RemoveInterpResolvers)(interp, name) /* 130 */ +#define Tcl_RemoveInterpResolvers \ + (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */ #endif #ifndef Tcl_SetNamespaceResolvers -#define Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc) \ - (tclIntStubsPtr->tcl_SetNamespaceResolvers)(namespacePtr, cmdProc, varProc, compiledVarProc) /* 131 */ +#define Tcl_SetNamespaceResolvers \ + (tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */ #endif -#ifndef TclHasSockets -#define TclHasSockets(interp) \ - (tclIntStubsPtr->tclHasSockets)(interp) /* 132 */ +#ifndef TclpHasSockets +#define TclpHasSockets \ + (tclIntStubsPtr->tclpHasSockets) /* 132 */ #endif #ifndef TclpGetDate -#define TclpGetDate(time, useGMT) \ - (tclIntStubsPtr->tclpGetDate)(time, useGMT) /* 133 */ +#define TclpGetDate \ + (tclIntStubsPtr->tclpGetDate) /* 133 */ #endif -#ifndef TclStrftime -#define TclStrftime(s, maxsize, format, t) \ - (tclIntStubsPtr->tclStrftime)(s, maxsize, format, t) /* 134 */ +#ifndef TclpStrftime +#define TclpStrftime \ + (tclIntStubsPtr->tclpStrftime) /* 134 */ #endif #ifndef TclpCheckStackSpace -#define TclpCheckStackSpace() \ - (tclIntStubsPtr->tclpCheckStackSpace)() /* 135 */ +#define TclpCheckStackSpace \ + (tclIntStubsPtr->tclpCheckStackSpace) /* 135 */ +#endif +/* Slot 136 is reserved */ +#ifndef TclpChdir +#define TclpChdir \ + (tclIntStubsPtr->tclpChdir) /* 137 */ +#endif +#ifndef TclGetEnv +#define TclGetEnv \ + (tclIntStubsPtr->tclGetEnv) /* 138 */ +#endif +#ifndef TclpLoadFile +#define TclpLoadFile \ + (tclIntStubsPtr->tclpLoadFile) /* 139 */ +#endif +#ifndef TclLooksLikeInt +#define TclLooksLikeInt \ + (tclIntStubsPtr->tclLooksLikeInt) /* 140 */ +#endif +#ifndef TclpGetCwd +#define TclpGetCwd \ + (tclIntStubsPtr->tclpGetCwd) /* 141 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ @@ -1150,4 +1132,3 @@ extern TclIntStubs *tclIntStubsPtr; /* !END!: Do not edit above this line. */ #endif /* _TCLINTDECLS */ - diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index bfb3cf7..628a03b 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -9,7 +9,7 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.4 1999/03/11 00:19:23 stanton Exp $ + * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.5 1999/04/16 00:46:48 stanton Exp $ */ #ifndef _TCLINTPLATDECLS @@ -46,17 +46,19 @@ EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); -/* 5 */ -EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((char * contents, - Tcl_DString * namePtr)); +/* Slot 5 is reserved */ /* 6 */ EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 7 */ -EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char * fname, int mode)); +EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char * fname, + int mode)); /* 8 */ EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask, int timeout)); +/* 9 */ +EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_(( + CONST char * contents)); #endif /* UNIX */ #ifdef __WIN32__ /* 0 */ @@ -64,21 +66,20 @@ EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode)); /* 1 */ EXTERN void TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode)); /* 2 */ -EXTERN struct servent * TclWinGetServByName _ANSI_ARGS_((const char * nm, - const char * proto)); +EXTERN struct servent * TclWinGetServByName _ANSI_ARGS_((CONST char * nm, + CONST char * proto)); /* 3 */ EXTERN int TclWinGetSockOpt _ANSI_ARGS_((SOCKET s, int level, int optname, char FAR * optval, int FAR * optlen)); /* 4 */ EXTERN HINSTANCE TclWinGetTclInstance _ANSI_ARGS_((void)); -/* 5 */ -EXTERN HINSTANCE TclWinLoadLibrary _ANSI_ARGS_((char * name)); +/* Slot 5 is reserved */ /* 6 */ EXTERN u_short TclWinNToHS _ANSI_ARGS_((u_short ns)); /* 7 */ EXTERN int TclWinSetSockOpt _ANSI_ARGS_((SOCKET s, int level, - int optname, const char FAR * optval, + int optname, CONST char FAR * optval, int optlen)); /* 8 */ EXTERN unsigned long TclpGetPid _ANSI_ARGS_((Tcl_Pid pid)); @@ -105,21 +106,26 @@ EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); -/* 16 */ -EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((char * contents, - Tcl_DString * namePtr)); -/* 17 */ -EXTERN char * TclpGetTZName _ANSI_ARGS_((void)); +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ /* 18 */ EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 19 */ -EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char * fname, int mode)); +EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char * fname, + int mode)); /* 20 */ EXTERN void TclWinAddProcess _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 21 */ EXTERN void TclpAsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async)); +/* 22 */ +EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_(( + CONST char * contents)); +/* 23 */ +EXTERN char * TclpGetTZName _ANSI_ARGS_((int isdst)); +/* 24 */ +EXTERN char * TclWinNoBackslash _ANSI_ARGS_((char * path)); #endif /* __WIN32__ */ #ifdef MAC_TCL /* 0 */ @@ -130,7 +136,7 @@ EXTERN void TclpSysFree _ANSI_ARGS_((VOID * ptr)); EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID * cp, unsigned int size)); /* 3 */ -EXTERN void TclPlatformExit _ANSI_ARGS_((int status)); +EXTERN void TclpExit _ANSI_ARGS_((int status)); /* 4 */ EXTERN int FSpGetDefaultDir _ANSI_ARGS_((FSSpecPtr theSpec)); /* 5 */ @@ -142,14 +148,14 @@ EXTERN OSErr FSpFindFolder _ANSI_ARGS_((short vRefNum, /* 7 */ EXTERN void GetGlobalMouse _ANSI_ARGS_((Point * mouse)); /* 8 */ -EXTERN pascal OSErr FSpGetDirectoryID _ANSI_ARGS_((const FSSpec * spec, +EXTERN pascal OSErr FSpGetDirectoryID _ANSI_ARGS_((CONST FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 9 */ EXTERN pascal short FSpOpenResFileCompat _ANSI_ARGS_(( - const FSSpec * spec, SignedByte permission)); + CONST FSSpec * spec, SignedByte permission)); /* 10 */ EXTERN pascal void FSpCreateResFileCompat _ANSI_ARGS_(( - const FSSpec * spec, OSType creator, + CONST FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 11 */ EXTERN int FSpLocationFromPath _ANSI_ARGS_((int length, @@ -182,11 +188,9 @@ EXTERN short TclMacUnRegisterResourceFork _ANSI_ARGS_(( /* 22 */ EXTERN int TclMacCreateEnv _ANSI_ARGS_((void)); /* 23 */ -EXTERN FILE * TclMacFOpenHack _ANSI_ARGS_((const char * path, - const char * mode)); -/* 24 */ -EXTERN int TclMacReadlink _ANSI_ARGS_((char * path, char * buf, - int size)); +EXTERN FILE * TclMacFOpenHack _ANSI_ARGS_((CONST char * path, + CONST char * mode)); +/* Slot 24 is reserved */ /* 25 */ EXTERN int TclMacChmod _ANSI_ARGS_((char * path, int mode)); #endif /* MAC_TCL */ @@ -201,20 +205,21 @@ typedef struct TclIntPlatStubs { Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 2 */ int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 3 */ int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */ - TclFile (*tclpCreateTempFile) _ANSI_ARGS_((char * contents, Tcl_DString * namePtr)); /* 5 */ + void *reserved5; TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */ - TclFile (*tclpOpenFile) _ANSI_ARGS_((char * fname, int mode)); /* 7 */ + TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 7 */ int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */ + TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 9 */ #endif /* UNIX */ #ifdef __WIN32__ void (*tclWinConvertError) _ANSI_ARGS_((DWORD errCode)); /* 0 */ void (*tclWinConvertWSAError) _ANSI_ARGS_((DWORD errCode)); /* 1 */ - struct servent * (*tclWinGetServByName) _ANSI_ARGS_((const char * nm, const char * proto)); /* 2 */ + struct servent * (*tclWinGetServByName) _ANSI_ARGS_((CONST char * nm, CONST char * proto)); /* 2 */ int (*tclWinGetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, char FAR * optval, int FAR * optlen)); /* 3 */ HINSTANCE (*tclWinGetTclInstance) _ANSI_ARGS_((void)); /* 4 */ - HINSTANCE (*tclWinLoadLibrary) _ANSI_ARGS_((char * name)); /* 5 */ + void *reserved5; u_short (*tclWinNToHS) _ANSI_ARGS_((u_short ns)); /* 6 */ - int (*tclWinSetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, const char FAR * optval, int optlen)); /* 7 */ + int (*tclWinSetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, CONST char FAR * optval, int optlen)); /* 7 */ unsigned long (*tclpGetPid) _ANSI_ARGS_((Tcl_Pid pid)); /* 8 */ int (*tclWinGetPlatformId) _ANSI_ARGS_((void)); /* 9 */ int (*tclWinSynchSpawn) _ANSI_ARGS_((void * args, int type, void ** trans, Tcl_Pid * pidPtr)); /* 10 */ @@ -223,25 +228,28 @@ typedef struct TclIntPlatStubs { Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 13 */ int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 14 */ int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 15 */ - TclFile (*tclpCreateTempFile) _ANSI_ARGS_((char * contents, Tcl_DString * namePtr)); /* 16 */ - char * (*tclpGetTZName) _ANSI_ARGS_((void)); /* 17 */ + void *reserved16; + void *reserved17; TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 18 */ - TclFile (*tclpOpenFile) _ANSI_ARGS_((char * fname, int mode)); /* 19 */ + TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 19 */ void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */ void (*tclpAsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 21 */ + TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */ + char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */ + char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */ #endif /* __WIN32__ */ #ifdef MAC_TCL VOID * (*tclpSysAlloc) _ANSI_ARGS_((long size, int isBin)); /* 0 */ void (*tclpSysFree) _ANSI_ARGS_((VOID * ptr)); /* 1 */ VOID * (*tclpSysRealloc) _ANSI_ARGS_((VOID * cp, unsigned int size)); /* 2 */ - void (*tclPlatformExit) _ANSI_ARGS_((int status)); /* 3 */ + void (*tclpExit) _ANSI_ARGS_((int status)); /* 3 */ int (*fSpGetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 4 */ int (*fSpSetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 5 */ OSErr (*fSpFindFolder) _ANSI_ARGS_((short vRefNum, OSType folderType, Boolean createFolder, FSSpec * spec)); /* 6 */ void (*getGlobalMouse) _ANSI_ARGS_((Point * mouse)); /* 7 */ - pascal OSErr (*fSpGetDirectoryID) _ANSI_ARGS_((const FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 8 */ - pascal short (*fSpOpenResFileCompat) _ANSI_ARGS_((const FSSpec * spec, SignedByte permission)); /* 9 */ - pascal void (*fSpCreateResFileCompat) _ANSI_ARGS_((const FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 10 */ + pascal OSErr (*fSpGetDirectoryID) _ANSI_ARGS_((CONST FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 8 */ + pascal short (*fSpOpenResFileCompat) _ANSI_ARGS_((CONST FSSpec * spec, SignedByte permission)); /* 9 */ + pascal void (*fSpCreateResFileCompat) _ANSI_ARGS_((CONST FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 10 */ int (*fSpLocationFromPath) _ANSI_ARGS_((int length, CONST char * path, FSSpecPtr theSpec)); /* 11 */ OSErr (*fSpPathFromLocation) _ANSI_ARGS_((FSSpecPtr theSpec, int * length, Handle * fullPath)); /* 12 */ void (*tclMacExitHandler) _ANSI_ARGS_((void)); /* 13 */ @@ -254,8 +262,8 @@ typedef struct TclIntPlatStubs { int (*tclMacRegisterResourceFork) _ANSI_ARGS_((short fileRef, Tcl_Obj * tokenPtr, int insert)); /* 20 */ short (*tclMacUnRegisterResourceFork) _ANSI_ARGS_((char * tokenPtr, Tcl_Obj * resultPtr)); /* 21 */ int (*tclMacCreateEnv) _ANSI_ARGS_((void)); /* 22 */ - FILE * (*tclMacFOpenHack) _ANSI_ARGS_((const char * path, const char * mode)); /* 23 */ - int (*tclMacReadlink) _ANSI_ARGS_((char * path, char * buf, int size)); /* 24 */ + FILE * (*tclMacFOpenHack) _ANSI_ARGS_((CONST char * path, CONST char * mode)); /* 23 */ + void *reserved24; int (*tclMacChmod) _ANSI_ARGS_((char * path, int mode)); /* 25 */ #endif /* MAC_TCL */ } TclIntPlatStubs; @@ -270,236 +278,237 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef TclGetAndDetachPids -#define TclGetAndDetachPids(interp, chan) \ - (tclIntPlatStubsPtr->tclGetAndDetachPids)(interp, chan) /* 0 */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #endif #ifndef TclpCloseFile -#define TclpCloseFile(file) \ - (tclIntPlatStubsPtr->tclpCloseFile)(file) /* 1 */ +#define TclpCloseFile \ + (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #endif #ifndef TclpCreateCommandChannel -#define TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel)(readFile, writeFile, errorFile, numPids, pidPtr) /* 2 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #endif #ifndef TclpCreatePipe -#define TclpCreatePipe(readPipe, writePipe) \ - (tclIntPlatStubsPtr->tclpCreatePipe)(readPipe, writePipe) /* 3 */ +#define TclpCreatePipe \ + (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #endif #ifndef TclpCreateProcess -#define TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) \ - (tclIntPlatStubsPtr->tclpCreateProcess)(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) /* 4 */ -#endif -#ifndef TclpCreateTempFile -#define TclpCreateTempFile(contents, namePtr) \ - (tclIntPlatStubsPtr->tclpCreateTempFile)(contents, namePtr) /* 5 */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ #endif +/* Slot 5 is reserved */ #ifndef TclpMakeFile -#define TclpMakeFile(channel, direction) \ - (tclIntPlatStubsPtr->tclpMakeFile)(channel, direction) /* 6 */ +#define TclpMakeFile \ + (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #endif #ifndef TclpOpenFile -#define TclpOpenFile(fname, mode) \ - (tclIntPlatStubsPtr->tclpOpenFile)(fname, mode) /* 7 */ +#define TclpOpenFile \ + (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #endif #ifndef TclUnixWaitForFile -#define TclUnixWaitForFile(fd, mask, timeout) \ - (tclIntPlatStubsPtr->tclUnixWaitForFile)(fd, mask, timeout) /* 8 */ +#define TclUnixWaitForFile \ + (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ +#endif +#ifndef TclpCreateTempFile +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef TclWinConvertError -#define TclWinConvertError(errCode) \ - (tclIntPlatStubsPtr->tclWinConvertError)(errCode) /* 0 */ +#define TclWinConvertError \ + (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #endif #ifndef TclWinConvertWSAError -#define TclWinConvertWSAError(errCode) \ - (tclIntPlatStubsPtr->tclWinConvertWSAError)(errCode) /* 1 */ +#define TclWinConvertWSAError \ + (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */ #endif #ifndef TclWinGetServByName -#define TclWinGetServByName(nm, proto) \ - (tclIntPlatStubsPtr->tclWinGetServByName)(nm, proto) /* 2 */ +#define TclWinGetServByName \ + (tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */ #endif #ifndef TclWinGetSockOpt -#define TclWinGetSockOpt(s, level, optname, optval, optlen) \ - (tclIntPlatStubsPtr->tclWinGetSockOpt)(s, level, optname, optval, optlen) /* 3 */ +#define TclWinGetSockOpt \ + (tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */ #endif #ifndef TclWinGetTclInstance -#define TclWinGetTclInstance() \ - (tclIntPlatStubsPtr->tclWinGetTclInstance)() /* 4 */ -#endif -#ifndef TclWinLoadLibrary -#define TclWinLoadLibrary(name) \ - (tclIntPlatStubsPtr->tclWinLoadLibrary)(name) /* 5 */ +#define TclWinGetTclInstance \ + (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #endif +/* Slot 5 is reserved */ #ifndef TclWinNToHS -#define TclWinNToHS(ns) \ - (tclIntPlatStubsPtr->tclWinNToHS)(ns) /* 6 */ +#define TclWinNToHS \ + (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */ #endif #ifndef TclWinSetSockOpt -#define TclWinSetSockOpt(s, level, optname, optval, optlen) \ - (tclIntPlatStubsPtr->tclWinSetSockOpt)(s, level, optname, optval, optlen) /* 7 */ +#define TclWinSetSockOpt \ + (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */ #endif #ifndef TclpGetPid -#define TclpGetPid(pid) \ - (tclIntPlatStubsPtr->tclpGetPid)(pid) /* 8 */ +#define TclpGetPid \ + (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ #endif #ifndef TclWinGetPlatformId -#define TclWinGetPlatformId() \ - (tclIntPlatStubsPtr->tclWinGetPlatformId)() /* 9 */ +#define TclWinGetPlatformId \ + (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */ #endif #ifndef TclWinSynchSpawn -#define TclWinSynchSpawn(args, type, trans, pidPtr) \ - (tclIntPlatStubsPtr->tclWinSynchSpawn)(args, type, trans, pidPtr) /* 10 */ +#define TclWinSynchSpawn \ + (tclIntPlatStubsPtr->tclWinSynchSpawn) /* 10 */ #endif #ifndef TclGetAndDetachPids -#define TclGetAndDetachPids(interp, chan) \ - (tclIntPlatStubsPtr->tclGetAndDetachPids)(interp, chan) /* 11 */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ #endif #ifndef TclpCloseFile -#define TclpCloseFile(file) \ - (tclIntPlatStubsPtr->tclpCloseFile)(file) /* 12 */ +#define TclpCloseFile \ + (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */ #endif #ifndef TclpCreateCommandChannel -#define TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel)(readFile, writeFile, errorFile, numPids, pidPtr) /* 13 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ #endif #ifndef TclpCreatePipe -#define TclpCreatePipe(readPipe, writePipe) \ - (tclIntPlatStubsPtr->tclpCreatePipe)(readPipe, writePipe) /* 14 */ +#define TclpCreatePipe \ + (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ #endif #ifndef TclpCreateProcess -#define TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) \ - (tclIntPlatStubsPtr->tclpCreateProcess)(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) /* 15 */ -#endif -#ifndef TclpCreateTempFile -#define TclpCreateTempFile(contents, namePtr) \ - (tclIntPlatStubsPtr->tclpCreateTempFile)(contents, namePtr) /* 16 */ -#endif -#ifndef TclpGetTZName -#define TclpGetTZName() \ - (tclIntPlatStubsPtr->tclpGetTZName)() /* 17 */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ #endif +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ #ifndef TclpMakeFile -#define TclpMakeFile(channel, direction) \ - (tclIntPlatStubsPtr->tclpMakeFile)(channel, direction) /* 18 */ +#define TclpMakeFile \ + (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ #endif #ifndef TclpOpenFile -#define TclpOpenFile(fname, mode) \ - (tclIntPlatStubsPtr->tclpOpenFile)(fname, mode) /* 19 */ +#define TclpOpenFile \ + (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ #endif #ifndef TclWinAddProcess -#define TclWinAddProcess(hProcess, id) \ - (tclIntPlatStubsPtr->tclWinAddProcess)(hProcess, id) /* 20 */ +#define TclWinAddProcess \ + (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ #endif #ifndef TclpAsyncMark -#define TclpAsyncMark(async) \ - (tclIntPlatStubsPtr->tclpAsyncMark)(async) /* 21 */ +#define TclpAsyncMark \ + (tclIntPlatStubsPtr->tclpAsyncMark) /* 21 */ +#endif +#ifndef TclpCreateTempFile +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ +#endif +#ifndef TclpGetTZName +#define TclpGetTZName \ + (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */ +#endif +#ifndef TclWinNoBackslash +#define TclWinNoBackslash \ + (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ #endif #endif /* __WIN32__ */ #ifdef MAC_TCL #ifndef TclpSysAlloc -#define TclpSysAlloc(size, isBin) \ - (tclIntPlatStubsPtr->tclpSysAlloc)(size, isBin) /* 0 */ +#define TclpSysAlloc \ + (tclIntPlatStubsPtr->tclpSysAlloc) /* 0 */ #endif #ifndef TclpSysFree -#define TclpSysFree(ptr) \ - (tclIntPlatStubsPtr->tclpSysFree)(ptr) /* 1 */ +#define TclpSysFree \ + (tclIntPlatStubsPtr->tclpSysFree) /* 1 */ #endif #ifndef TclpSysRealloc -#define TclpSysRealloc(cp, size) \ - (tclIntPlatStubsPtr->tclpSysRealloc)(cp, size) /* 2 */ +#define TclpSysRealloc \ + (tclIntPlatStubsPtr->tclpSysRealloc) /* 2 */ #endif -#ifndef TclPlatformExit -#define TclPlatformExit(status) \ - (tclIntPlatStubsPtr->tclPlatformExit)(status) /* 3 */ +#ifndef TclpExit +#define TclpExit \ + (tclIntPlatStubsPtr->tclpExit) /* 3 */ #endif #ifndef FSpGetDefaultDir -#define FSpGetDefaultDir(theSpec) \ - (tclIntPlatStubsPtr->fSpGetDefaultDir)(theSpec) /* 4 */ +#define FSpGetDefaultDir \ + (tclIntPlatStubsPtr->fSpGetDefaultDir) /* 4 */ #endif #ifndef FSpSetDefaultDir -#define FSpSetDefaultDir(theSpec) \ - (tclIntPlatStubsPtr->fSpSetDefaultDir)(theSpec) /* 5 */ +#define FSpSetDefaultDir \ + (tclIntPlatStubsPtr->fSpSetDefaultDir) /* 5 */ #endif #ifndef FSpFindFolder -#define FSpFindFolder(vRefNum, folderType, createFolder, spec) \ - (tclIntPlatStubsPtr->fSpFindFolder)(vRefNum, folderType, createFolder, spec) /* 6 */ +#define FSpFindFolder \ + (tclIntPlatStubsPtr->fSpFindFolder) /* 6 */ #endif #ifndef GetGlobalMouse -#define GetGlobalMouse(mouse) \ - (tclIntPlatStubsPtr->getGlobalMouse)(mouse) /* 7 */ +#define GetGlobalMouse \ + (tclIntPlatStubsPtr->getGlobalMouse) /* 7 */ #endif #ifndef FSpGetDirectoryID -#define FSpGetDirectoryID(spec, theDirID, isDirectory) \ - (tclIntPlatStubsPtr->fSpGetDirectoryID)(spec, theDirID, isDirectory) /* 8 */ +#define FSpGetDirectoryID \ + (tclIntPlatStubsPtr->fSpGetDirectoryID) /* 8 */ #endif #ifndef FSpOpenResFileCompat -#define FSpOpenResFileCompat(spec, permission) \ - (tclIntPlatStubsPtr->fSpOpenResFileCompat)(spec, permission) /* 9 */ +#define FSpOpenResFileCompat \ + (tclIntPlatStubsPtr->fSpOpenResFileCompat) /* 9 */ #endif #ifndef FSpCreateResFileCompat -#define FSpCreateResFileCompat(spec, creator, fileType, scriptTag) \ - (tclIntPlatStubsPtr->fSpCreateResFileCompat)(spec, creator, fileType, scriptTag) /* 10 */ +#define FSpCreateResFileCompat \ + (tclIntPlatStubsPtr->fSpCreateResFileCompat) /* 10 */ #endif #ifndef FSpLocati