Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Huge mess of half-converted code, with something horrible inside. Definitely buggy... |
|---|---|
| Timelines: | family | ancestors | descendants | both | list-and-dict-types |
| Files: | files | file ages | folders |
| SHA3-256: |
462eec7d433646d6e3a7a9fd7a1986bd |
| User & Date: | dkf 2018-12-06 21:14:15 |
Context
|
2018-12-08
| ||
| 17:56 | merge trunk check-in: 01fb4f7ffb user: dkf tags: list-and-dict-types | |
|
2018-12-06
| ||
| 21:14 | Huge mess of half-converted code, with something horrible inside. Definitely buggy... check-in: 462eec7d43 user: dkf tags: list-and-dict-types | |
|
2018-11-29
| ||
| 13:57 | merge trunk check-in: b0b8f8280b user: dkf tags: list-and-dict-types | |
Changes
Changes to codegen/build.tcl.
2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 .... 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 .... 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 .... 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 .... 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 .... 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 .... 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 .... 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 |
# The concatenated value as an LLVM value reference.
method concat() {vector {name ""}} {
my ExtractVector $vector
my call ${tcl.concatenate} [list $len $ary] $name
}
# Builder:dictAppend(STRING,STRING,STRING) --
#
# Append a value to a key in a dictionary. NOTE: this operation can fail
# (e.g., because it can be given an invalid dictionary) so it produces a
# STRING FAIL. Quadcode implementation ('dictAppend').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The value to append as an LLVM value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The resulting dictionary as an LLVM value reference, or a FAIL.
method dictAppend(STRING,STRING,STRING) {dict key value ec {name ""}} {
my call ${tcl.dict.append} [list $dict $key $value $ec] $name
}
# Builder:dictExists(STRING) --
#
# Find whether a key exists in a dictionary. This version uses a vector
# of values for the key path. Quadcode implementation ('dictExists').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# vector -
................................................................................
# The key path as an LLVM vector value reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# Whether the value exists as an LLVM ZEROONE value reference.
method dictExists(STRING) {dict vector {name ""}} {
my ExtractVector $vector
my call ${tcl.dict.exists} [list $dict $len $ary] $name
}
# Builder:dictExists(STRING,STRING) --
#
# Find whether a key exists in a dictionary. This version uses a single
# simple key. Quadcode implementation ('dictExists').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# Whether the value exists as an LLVM ZEROONE value reference.
method dictExists(STRING,STRING) {dict key {name ""}} {
my call ${tcl.dict.exists1} [list $dict $key] $name
}
# Builder:dictGet(STRING) --
#
# Retrieve a value from a dictionary. This version uses a vector as a
# key path. NOTE: this operation can fail (e.g., because it can be given
# an invalid dictionary) so it produces a STRING FAIL. Quadcode
# implementation ('dictGet').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# vector -
# The key path as an LLVM vector value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The retrieved value as an LLVM value reference, or a FAIL.
method dictGet(STRING) {dict vector ec {name ""}} {
my ExtractVector $vector
my call ${tcl.dict.get} [list $dict $len $ary $ec] $name
}
# Builder:dictGet(STRING,STRING) --
#
# Retrieve a value from a dictionary. This version uses a single simple
# key. NOTE: this operation can fail (e.g., because it can be given an
# invalid dictionary) so it produces a STRING FAIL. Quadcode
# implementation ('dictGet').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The retrieved value as an LLVM value reference, or a FAIL.
method dictGet(STRING,STRING) {dict key ec {name ""}} {
my call ${tcl.dict.get1} [list $dict $key $ec] $name
}
# Builder:dictGetOrNexist(STRING,STRING) --
#
# Retrieve a value from a dictionary, or NEXIST if the key doesn't map
# to a value in the dict. This version uses a single simple key. NOTE:
# this operation can fail (e.g., because it can be given an invalid
# dictionary) so it produces a FAIL NEXIST STRING. Quadcode
# implementation ('dictGetOrNexist').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The retrieved value as an LLVM value reference, or a NEXIST or FAIL.
method dictGetOrNexist(STRING,STRING) {dict key ec {name ""}} {
my call ${tcl.dict.get1.empty} [list $dict $key $ec] $name
}
# Builder:dictIncr(STRING,STRING,INT) --
#
# Increment the value for a key in a dictionary. NOTE: this operation
# can fail (e.g., because it can be given an invalid dictionary) so it
# produces a STRING FAIL. Quadcode implementation ('dictIncr').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
................................................................................
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The resulting dictionary as an LLVM value reference, or a FAIL.
method dictIncr(STRING,STRING,INT) {dict key value ec {name ""}} {
my call ${tcl.dict.incr} [list $dict $key $value $ec] $name
}
# Builder:dictIterStart(STRING) --
#
# Start iterating over a dictionary; other opcodes are used to retrieve
# what the state of the iteration is. NOTE: this operation can fail
# (e.g., because it can be given an invalid dictionary) so it produces a
# DICTITER FAIL. Quadcode implementation ('dictIterStart').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The iteration state as an LLVM DICTITER value reference, or a FAIL.
method dictIterStart(STRING) {dict ec {name ""}} {
my call ${tcl.dict.iterStart} [list $dict $ec] $name
}
# Builder:dictIterNext --
#
# Get the next step when iterating over a dictionary; other opcodes are
# used to retrieve what the state of the iteration is. Quadcode
# implementation ('dictIterNext').
................................................................................
# Results:
# The termination flag as an LLVM ZEROONE value reference.
method dictIterDone {iter {name ""}} {
my call ${tcl.dict.iterDone} [list $iter] $name
}
# Builder:dictLappend(STRING,STRING,STRING) --
#
# List-append a value to a key in a dictionary. NOTE: this operation can
# fail (e.g., because it can be given an invalid dictionary) so it
# produces a STRING FAIL. Quadcode implementation ('dictLappend').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The value to append as an LLVM value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The resulting dictionary as an LLVM value reference, or a FAIL.
method dictLappend(STRING,STRING,STRING) {dict key value ec {name ""}} {
my call ${tcl.dict.lappend} [list $dict $key $value $ec] $name
}
# Builder:dictSet(STRING,STRING) --
#
# Set or create a value in a dictionary. This version uses a vector as a
# dictionary key path. NOTE: this operation can fail (e.g., because it
# can be given an invalid dictionary) so it produces a STRING FAIL.
# Quadcode implementation ('dictSet').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# value - The value as an LLVM value reference.
# vector -
# The key path as an LLVM vector value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value.
method dictSet(STRING,STRING) {dict value vector ec {name ""}} {
my ExtractVector $vector
my call ${tcl.dict.set} [list $dict $len $ary $value $ec] $name
}
# Builder:dictSet(STRING,STRING,STRING) --
#
# Set or create a value in a dictionary. This version uses a single
# simple key. NOTE: this operation can fail (e.g., because it can be
# given an invalid dictionary) so it produces a STRING FAIL. Quadcode
# implementation ('dictSet').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The value as an LLVM value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value.
method dictSet(STRING,STRING,STRING) {dict key value ec {name ""}} {
my call ${tcl.dict.set1} [list $dict $key $value $ec] $name
}
# Builder:dictSetOrUnset(STRING,STRING,NEXIST) --
#
# Remove a value in a dictionary. This version uses a single simple key.
# NOTE: this operation can fail (e.g., because it can be given an
# invalid dictionary) so it produces a STRING FAIL. Quadcode
# implementation ('dictSetOrUnset').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The NEXIST value (actually ignored).
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value, or FAIL.
method dictSetOrUnset(STRING,STRING,NEXIST) {dict key value ec {name ""}} {
my call ${tcl.dict.set1.empty} [list $dict $key [my nothing STRING] $ec] $name
}
# Builder:dictSetOrUnset(STRING,STRING,NEXIST STRING) --
#
# Set, create or remove a value in a dictionary. This version uses a
# single simple key, and the value can be NEXIST to remove the key.
# NOTE: this operation can fail (e.g., because it can be given an
# invalid dictionary) so it produces a STRING FAIL. Quadcode
# implementation ('dictSetOrUnset').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The value as an LLVM value reference, or NEXIST.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value, or FAIL.
method dictSetOrUnset(STRING,STRING,NEXIST\040STRING) {dict key value ec {name ""}} {
my call ${tcl.dict.set1.empty} [list $dict $key $value $ec] $name
}
# Builder:dictSetOrUnset(STRING,STRING,NEXIST STRING) --
#
# Set or create a value in a dictionary. This version uses a single
# simple key. NOTE: this operation can fail (e.g., because it can be
# given an invalid dictionary) so it produces a STRING FAIL. Quadcode
# implementation ('dictSetOrUnset').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The value as an LLVM value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value, or FAIL.
method dictSetOrUnset(STRING,STRING,STRING) {dict key value ec {name ""}} {
my call ${tcl.dict.set1.empty} [list $dict $key [my just $value] $ec] $name
}
# Builder:dictSize(STRING) --
#
# Get the size of a dictionary, i.e., the number of key-value pairs.
#
# Parameters:
# value - The STRING LLVM value reference to a dict to get the size of.
# ecvar - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# An INT FAIL in an LLVM value reference.
method dictSize(STRING) {value ecvar {name ""}} {
my call ${tcl.dict.size} [list $value $ecvar] $name
}
# Builder:dictUnset(STRING) --
#
# Remove a key from a dictionary. This version uses a vector as a
# dictionary key path. NOTE: this operation can fail (e.g., because it
# can be given an invalid dictionary) so it produces a STRING FAIL.
# Quadcode implementation ('dictUnset').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# vector -
# The key path as an LLVM vector value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value.
method dictUnset(STRING) {dict vector ec {name ""}} {
my ExtractVector $vector
my call ${tcl.dict.unset} [list $dict $len $ary $ec] $name
}
# Builder:dictUnset(STRING,STRING) --
#
# Remove a key from a dictionary. This version uses a single simple
# key. NOTE: this operation can fail (e.g., because it can be given an
# invalid dictionary) so it produces a STRING FAIL. Quadcode
# implementation ('dictUnset').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value.
method dictUnset(STRING,STRING) {dict key ec {name ""}} {
my call ${tcl.dict.unset1} [list $dict $key $ec] $name
}
# Builder:directAppend(STRING,STRING) --
#
# Append a value to a variable, which should be referred to by a
# fully-qualified name. NOTE: this operation can fail because of traces
# so it produces a STRING FAIL. Quadcode implementation
................................................................................
# None.
method dropReference {value} {
my Call tcl.dropReference $value
return
}
# Builder:dropReference(IMPURE EMPTY DICT) --
#
# Generate code to decrement the reference count of a value and delete
# the value if it has ceased to be used.
#
# Parameters:
# value - The IMPURE EMPTY DICT LLVM value reference for the operand.
#
# Results:
# None.
method dropReference(IMPURE\040EMPTY\040DICT) {value} {
my Call tcl.dropReference $value
return
}
# Builder:dropReference(IMPURE EMPTY LIST) --
#
# Generate code to decrement the reference count of a value and delete
# the value if it has ceased to be used.
#
# Parameters:
# value - The IMPURE EMPTY LIST LLVM value reference for the operand.
#
# Results:
# None.
method dropReference(IMPURE\040EMPTY\040LIST) {value} {
my Call tcl.dropReference $value
return
}
# Builder:dropReference(STRING) --
#
# Generate code to decrement the reference count of a value and delete
................................................................................
}
} else {
set len [Const 0]
}
my call ${tcl.list.create} [list $len [my gep $objv 0 0]] $name
}
# Builder:listAppend(STRING,STRING) --
#
# Append an element to a list. NOTE: this operation can fail (e.g.,
# because it can be given an invalid list) so it produces a STRING FAIL.
# Quadcode implementation ('listAppend').
#
# Parameters:
# list - List value to get append to, in an LLVM STRING reference.
# value - The value to append as an LLVM STRING value reference.
# ec - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The element of the list, as an LLVM STRING FAIL reference.
method listAppend(STRING,STRING) {list value ec {name ""}} {
my call ${tcl.list.append} [list $list $value $ec] $name
}
# Builder:listConcat(STRING,STRING) --
#
# Append a list of elements to a list. NOTE: this operation can fail
# (e.g., because it can be given an invalid list) so it produces a
# STRING FAIL. Quadcode implementation ('listConcat').
#
# Parameters:
# list - List value to get append to, in an LLVM STRING reference.
# value - The list of values to append, as an LLVM STRING value
# reference.
# ec - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The element of the list, as an LLVM STRING FAIL reference.
method listConcat(STRING,STRING) {list value ec {name ""}} {
my call ${tcl.list.concat} [list $list $value $ec] $name
}
# Builder:listIn(STRING,STRING) --
#
# Determine if an element is present in a list by simple linear search.
# NOTE: this operation can fail (e.g., because it can be given an
# invalid list) so it produces an INT FAIL. Quadcode implementation
# ('listIn').
#
# Parameters:
# value - The value to check for, as an LLVM STRING value reference.
# list - List value to search, in an LLVM STRING reference.
# ec - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# If the element is present, as an LLVM INT FAIL reference.
method listIn(STRING,STRING) {value list ec {name ""}} {
my call ${tcl.list.in} [list $value $list $ec] $name
}
# Builder:listIndex(STRING) --
#
# Get an element of a list. NOTE: this operation can fail (e.g., because
# it can be given an invalid list) so it produces a STRING FAIL.
# Quadcode implementation ('listIndex').
#
# Parameters:
# value - List value to get the length of, in an LLVM STRING reference.
# vector -
# The indices as an LLVM vector value reference.
# errVar -
# Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The element of the list, as an LLVM STRING FAIL reference.
method listIndex(STRING) {value vector ec {name ""}} {
my ExtractVector $vector
my call ${tcl.list.index} [list $value $len $ary $ec] $name
}
# Builder:listIndex(STRING,INT) --
#
# Get an element of a list. NOTE: this operation can fail (e.g., because
# it can be given an invalid list) so it produces a STRING FAIL.
# Quadcode implementation ('listIndex').
#
# Parameters:
# value - List value to get the length of, in an LLVM STRING reference.
# index - Index value to use, in an LLVM INT reference.
# errVar -
# Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The element of the list, as an LLVM STRING FAIL reference.
method listIndex(STRING,INT) {value index ec {name ""}} {
my call ${tcl.list.index1} [list $value $index $ec] $name
}
# Builder:listIndex(STRING,STRING) --
#
# Get an element of a list. NOTE: this operation can fail (e.g., because
# it can be given an invalid list) so it produces a STRING FAIL.
# Quadcode implementation ('listIndex').
#
# Parameters:
# value - List value to get the length of, in an LLVM STRING reference.
# index - Index value to use, in an LLVM STRING reference.
# errVar -
# Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The element of the list, as an LLVM STRING FAIL reference.
method listIndex(STRING,STRING) {value index ec {name ""}} {
my call ${tcl.list.indexList} [list $value $index $ec] $name
}
# Builder:listLength(STRING) --
#
# Get the length of a list. NOTE: this operation can fail (e.g., because
# it can be given an invalid list) so it produces an INT FAIL. Quadcode
# implementation ('listLength').
#
# Parameters:
# value - List value to get the length of, in an LLVM STRING reference.
# errVar -
# Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The length of the list, as an LLVM INT FAIL reference.
method listLength(STRING) {value ec {name ""}} {
my call ${tcl.list.length} [list $value $ec] $name
}
# Builder:listRange(STRING,INT,INT) --
#
# Get a sublist of a list. NOTE: this operation can fail (e.g., because
# it can be given an invalid list) so it produces a STRING FAIL.
# Quadcode implementation ('listRange').
#
# Parameters:
# value - List value to get a substring of, in an LLVM STRING reference.
# from - Index of first element to return, in an LLVM INT reference.
# to - Index of last element to return, in an LLVM INT reference.
# errVar -
# Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The sublist, as an LLVM STRING FAIL reference.
method listRange(STRING,INT,INT) {value from to ec {name ""}} {
my call ${tcl.list.range1} [list $value $from $to $ec] $name
}
# Builder:listRange(STRING,STRING,STRING) --
#
# Get a sublist of a list. NOTE: this operation can fail (e.g., because
# it can be given an invalid list) so it produces a STRING FAIL.
# Quadcode implementation ('listRange').
#
# Parameters:
# value - List value to get a substring of, in an LLVM STRING reference.
# from - Index of first element to return, in an LLVM STRING reference.
# to - Index of last element to return, in an LLVM STRING reference.
# errVar -
# Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The sublist, as an LLVM STRING FAIL reference.
method listRange(STRING,STRING,STRING) {value from to ec {name ""}} {
my call ${tcl.list.range} [list $value $from $to $ec] $name
}
# Builder:listSet(STRING,STRING) --
#
# Update an element in a sublist of a list. NOTE: this operation can
# fail (e.g., because it can be given an invalid list) so it produces a
# STRING FAIL. Quadcode implementation ('listSet').
#
# Parameters:
# list - List value to get a substring of, in an LLVM STRING reference.
# elem - The value to write into the list, in an LLVM STRING reference.
# vector -
# The indices as an LLVM vector value reference.
# ecvar - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The updated list, as an LLVM STRING FAIL reference.
method listSet(STRING,STRING) {list elem vector ecvar {name ""}} {
my ExtractVector $vector
my call ${tcl.list.set} [list $list $len $ary $elem $ecvar] $name
}
# Builder:listSet(STRING,INT,STRING) --
#
# Update an element of a list. NOTE: this operation can fail (e.g.,
# because it can be given an invalid list) so it produces a STRING FAIL.
# Quadcode implementation ('listSet').
#
# Parameters:
# list - List value update, in an LLVM STRING reference.
# idx - The index into the list to set, in an LLVM INT reference.
# elem - The value to write into the list, in an LLVM STRING reference.
# ecvar - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The updated list, as an LLVM STRING FAIL reference.
method listSet(STRING,INT,STRING) {list idx elem ecvar {name ""}} {
my call ${tcl.list.set1} [list $list $idx $elem $ecvar] $name
}
# Builder:listSet(STRING,STRING,STRING) --
#
# Update an element of a list or sublist. NOTE: this operation can fail
# (e.g., because it can be given an invalid list) so it produces a
# STRING FAIL. Quadcode implementation ('listSet').
#
# Parameters:
# list - List value update, in an LLVM STRING reference.
# idx - The index into the list to set, in an LLVM STRING reference.
# elem - The value to write into the list, in an LLVM STRING reference.
# ecvar - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The updated list, as an LLVM STRING FAIL reference.
method listSet(STRING,STRING,STRING) {list idx elem ecvar {name ""}} {
my call ${tcl.list.setList} [list $list $idx $elem $ecvar] $name
}
# Builder:lor(INT,INT) --
#
# Generate code to compute the logical or of two INTs. Quadcode
# implementation ('lor').
................................................................................
if {[string match "* NEXIST" $type]} {
set type [string range $type 0 end-7]
} elseif {[string match "NEXIST *" $type]} {
set type [string range $type 7 end]
}
my insert [my undef $type!] [Const true bool] 0 $name
}
# Builder:narrowToType.LIST(STRING) --
#
# Generate code to parse the given STRING and extract a LIST. The
# STRING is already be known to contain a value of the right type (due
# to higher-level quadcode constraints). Quadcode implementation
# ('narrowToType').
................................................................................
#
# Parameters:
# value - The STRING LLVM value reference to parse.
# name (optional) -
# A name to give to the result value.
#
# Results:
# A DOUBLE LLVM value reference.
method narrowToType.LIST(STRING) {value {name ""}} {
return $value
}
method narrowToType.IMPURE_LIST(STRING) {value {name ""}} {
return $value
}
|
| | < | < | | | | | > > | > | | > > | > | | | | | | | < | | | | < < | | > > > | > | | | | | < | < | | | | | | | | | | | | | < < | < | | | < < | < | | | | < < | < | | | | < < | < | | | | < < | | | > > | > | | < > | | < < < | | | | | | | | | | | < < | < < | | | > > | > | | < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < | | < < | | < < < | | | > > | > | < < | | < | | | | | > > | > | | < | | | > > > | | | | | | > > > > | | | | | > > > | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | |
2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 .... 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 .... 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 .... 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 .... 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 .... 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 .... 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 .... 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 |
# The concatenated value as an LLVM value reference.
method concat() {vector {name ""}} {
my ExtractVector $vector
my call ${tcl.concatenate} [list $len $ary] $name
}
# Builder:dictAppend(DICT,STRING,STRING) --
#
# Append a value to a key in a dictionary. Quadcode implementation
# ('dictAppend').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The value to append as an LLVM value reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The resulting dictionary as an LLVM value reference.
method dictAppend(EMPTY\040DICT,STRING,STRING) {dict key value {name ""}} {
my call ${tcl.dict.append} [list $dict $key $value] $name
}
# Builder:dictExists(DICT) --
#
# Find whether a key exists in a dictionary. This version uses a vector
# of values for the key path. Quadcode implementation ('dictExists').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# vector -
................................................................................
# The key path as an LLVM vector value reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# Whether the value exists as an LLVM ZEROONE value reference.
method dictExists(EMPTY\040DICT) {dict vector {name ""}} {
my ExtractVector $vector
my call ${tcl.dict.exists} [list $dict $len $ary] $name
}
method dictExists(EMPTY) {dict vector {name ""}} {
Const 0 int1
}
# Builder:dictExists(DICT,STRING) --
#
# Find whether a key exists in a dictionary. This version uses a single
# simple key. Quadcode implementation ('dictExists').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# Whether the value exists as an LLVM ZEROONE value reference.
method dictExists(EMPTY\040DICT,STRING) {dict key {name ""}} {
my call ${tcl.dict.exists1} [list $dict $key] $name
}
method dictExists(EMPTY,STRING) {dict key {name ""}} {
Const 0 int1
}
# Builder:dictGet(DICT) --
#
# Retrieve a value from a dictionary. This version uses a vector as a
# key path. NOTE: this operation can fail (e.g., a key not present or an
# invalid dictionary inside a valid one) so it produces a STRING FAIL.
# Quadcode implementation ('dictGet').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# vector -
# The key path as an LLVM vector value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The retrieved value as an LLVM value reference, or a FAIL.
method dictGet(EMPTY\040DICT) {dict vector ec {name ""}} {
my ExtractVector $vector
my call ${tcl.dict.get} [list $dict $len $ary $ec] $name
}
# Builder:dictGet(DICT,STRING) --
#
# Retrieve a value from a dictionary. This version uses a single simple
# key. NOTE: this operation can fail so it produces a STRING FAIL.
# Quadcode implementation ('dictGet').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The retrieved value as an LLVM value reference, or a FAIL.
method dictGet(EMPTY\040DICT,STRING) {dict key ec {name ""}} {
my call ${tcl.dict.get1} [list $dict $key $ec] $name
}
# Builder:dictGetOrNexist(EMPTY DICT,STRING) --
#
# Retrieve a value from a dictionary, or NEXIST if the key doesn't map
# to a value in the dict. This version uses a single simple key.
# Quadcode implementation ('dictGetOrNexist').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The retrieved value as an LLVM value reference, or a NEXIST.
method dictGetOrNexist(EMPTY\040DICT,STRING) {dict key {name ""}} {
my call ${tcl.dict.get1.empty} [list $dict $key] $name
}
method dictGetOrNexist(EMPTY,STRING) {dict key {name ""}} {
# Should be possible to be efficient in this case!
my call ${tcl.dict.get1.empty} [list $dict $key] $name
}
# Builder:dictIncr(EMPTY DICT,STRING,INT) --
#
# Increment the value for a key in a dictionary. NOTE: this operation
# can fail (e.g., because it can be given an invalid dictionary) so it
# produces a STRING FAIL. Quadcode implementation ('dictIncr').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
................................................................................
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The resulting dictionary as an LLVM value reference, or a FAIL.
method dictIncr(EMPTY\040DICT,STRING,INT) {dict key value ec {name ""}} {
my call ${tcl.dict.incr} [list $dict $key $value $ec] $name
}
# Builder:dictIterStart(DICT) --
#
# Start iterating over a dictionary; other opcodes are used to retrieve
# what the state of the iteration is. Quadcode implementation
# ('dictIterStart').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The iteration state as an LLVM DICTITER value reference.
method dictIterStart(EMPTY\040DICT) {dict {name ""}} {
my call ${tcl.dict.iterStart} [list $dict] $name
}
# Builder:dictIterNext --
#
# Get the next step when iterating over a dictionary; other opcodes are
# used to retrieve what the state of the iteration is. Quadcode
# implementation ('dictIterNext').
................................................................................
# Results:
# The termination flag as an LLVM ZEROONE value reference.
method dictIterDone {iter {name ""}} {
my call ${tcl.dict.iterDone} [list $iter] $name
}
# Builder:dictLappend(DICT,STRING,STRING) --
#
# List-append a value to a key in a dictionary. NOTE: this operation can
# fail (e.g., because it can be given an invalid dictionary) so it
# produces a DICT FAIL. Quadcode implementation ('dictLappend').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The value to append as an LLVM value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The resulting dictionary as an LLVM value reference, or a FAIL.
method dictLappend(EMPTY\040DICT,STRING,STRING) {dict key value ec {name ""}} {
my call ${tcl.dict.lappend} [list $dict $key $value $ec] $name
}
# Builder:dictSet(DICT,STRING) --
#
# Set or create a value in a dictionary. This version uses a vector as a
# dictionary key path.. NOTE: this operation can fail (e.g., because
# there is an invalid dictionary nested inside) so it produces a DICT
# FAIL. Quadcode implementation ('dictSet').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# value - The value as an LLVM value reference.
# vector -
# The key path as an LLVM vector value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value or a FAIL.
method dictSet(EMPTY\040DICT,STRING) {dict value vector ec {name ""}} {
my ExtractVector $vector
my call ${tcl.dict.set} [list $dict $len $ary $value $ec] $name
}
# Builder:dictSet(DICT,STRING,STRING) --
#
# Set or create a value in a dictionary. This version uses a single
# simple key. Quadcode implementation ('dictSet').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The value as an LLVM value reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value.
method dictSet(EMPTY\040DICT,STRING,STRING) {dict key value {name ""}} {
my call ${tcl.dict.set1} [list $dict $key $value] $name
}
# Builder:dictSetOrUnset(DICT,STRING,NEXIST) --
#
# Remove a value in a dictionary. This version uses a single simple key.
# Quadcode implementation ('dictSetOrUnset').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The NEXIST value (actually ignored).
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value.
method dictSetOrUnset(EMPTY\040DICT,STRING,NEXIST) {dict key value {name ""}} {
my call ${tcl.dict.set1.empty} [list $dict $key [my nothing STRING]] $name
}
# Builder:dictSetOrUnset(DICT,STRING,NEXIST STRING) --
#
# Set, create or remove a value in a dictionary. This version uses a
# single simple key, and the value can be NEXIST to remove the key.
# Quadcode implementation ('dictSetOrUnset').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The value as an LLVM value reference, or NEXIST.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value.
method dictSetOrUnset(EMPTY\040DICT,STRING,NEXIST\040STRING) {dict key value {name ""}} {
my call ${tcl.dict.set1.empty} [list $dict $key $value] $name
}
# Builder:dictSetOrUnset(DICT,STRING,NEXIST STRING) --
#
# Set or create a value in a dictionary. This version uses a single
# simple key. Quadcode implementation ('dictSetOrUnset').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# value - The value as an LLVM value reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value.
method dictSetOrUnset(EMPTY\040DICT,STRING,STRING) {dict key value {name ""}} {
my call ${tcl.dict.set1.empty} [list $dict $key [my just $value]] $name
}
# Builder:dictSize(DICT) --
#
# Get the size of a dictionary, i.e., the number of key-value pairs.
#
# Parameters:
# value - The STRING LLVM value reference to a dict to get the size of.
# name (optional) -
# A name to give to the result value.
#
# Results:
# An INT in an LLVM value reference.
method dictSize(EMPTY\040DICT) {value {name ""}} {
my call ${tcl.dict.size} [list $value] $name
}
method dictSize(EMPTY) {value ecvar {name ""}} {
my packInt32 [Const 0] $name
}
# Builder:dictUnset(EMPTY DICT) --
#
# Remove a key from a dictionary. This version uses a vector as a
# dictionary key path. NOTE: this operation can fail (e.g., because of
# an invalid dictionary inside a valid one) so it produces a DICT FAIL.
# Quadcode implementation ('dictUnset').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# vector -
# The key path as an LLVM vector value reference.
# ec - Where to write the error code if an error happens.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value.
method dictUnset(EMPTY\040DICT) {dict vector ec {name ""}} {
my ExtractVector $vector
my call ${tcl.dict.unset} [list $dict $len $ary $ec] $name
}
# Builder:dictUnset(DICT,STRING) --
#
# Remove a key from a dictionary. Quadcode implementation ('dictUnset').
#
# Parameters:
# dict - The dictionary as an LLVM value reference.
# key - The key as an LLVM value reference.
# ec - Where to write the error code if an error happens. (Ignored)
# name (optional) -
# A name to give to the result value.
#
# Results:
# The new dictionary value.
method dictUnset(EMPTY\040DICT,STRING) {dict key ec {name ""}} {
my call ${tcl.dict.unset1} [list $dict $key] $name
}
# Builder:directAppend(STRING,STRING) --
#
# Append a value to a variable, which should be referred to by a
# fully-qualified name. NOTE: this operation can fail because of traces
# so it produces a STRING FAIL. Quadcode implementation
................................................................................
# None.
method dropReference {value} {
my Call tcl.dropReference $value
return
}
# Builder:dropReference(DICT) --
#
# Generate code to decrement the reference count of a value and delete
# the value if it has ceased to be used.
#
# Parameters:
# value - The DICT LLVM value reference for the operand.
#
# Results:
# None.
method dropReference(DICT) {value} {
my Call tcl.dropReference $value
return
}
# Builder:dropReference(LIST) --
#
# Generate code to decrement the reference count of a value and delete
# the value if it has ceased to be used.
#
# Parameters:
# value - The LIST LLVM value reference for the operand.
#
# Results:
# None.
method dropReference(LIST) {value} {
my Call tcl.dropReference $value
return
}
# Builder:dropReference(STRING) --
#
# Generate code to decrement the reference count of a value and delete
................................................................................
}
} else {
set len [Const 0]
}
my call ${tcl.list.create} [list $len [my gep $objv 0 0]] $name
}
# Builder:listAppend(LIST,STRING) --
#
# Append an element to a list. Quadcode implementation ('listAppend').
#
# Parameters:
# list - List value to get append to, in an LLVM STRING reference.
# value - The value to append as an LLVM STRING value reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The element of the list, as an LLVM LIST reference.
method listAppend(LIST,STRING) {list value {name ""}} {
my call ${tcl.list.append} [list $list $value] $name
}
method listAppend(EMPTY,STRING) {list value {name ""}} {
my call ${tcl.list.append} [list $list $value] $name
}
# Builder:listConcat(LIST,LIST) --
#
# Append a list of elements to a list. Quadcode implementation
# ('listConcat').
#
# Parameters:
# list - List value to get append to, in an LLVM LIST reference.
# value - The list of values to append, as an LLVM LIST reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The concatenated list, as an LLVM LIST reference.
method listConcat(LIST,LIST) {list value {name ""}} {
my call ${tcl.list.concat} [list $list $value] $name
}
method listConcat(LIST,EMPTY) {list value {name ""}} {
my call ${tcl.list.concat} [list $list $value] $name
}
method listConcat(EMPTY,LIST) {list value {name ""}} {
my call ${tcl.list.concat} [list $list $value] $name
}
method listConcat(EMPTY,EMPTY) {list value {name ""}} {
my call ${tcl.list.concat} [list $list $value] $name
}
# Builder:listIn(STRING,LIST) --
#
# Determine if an element is present in a list by simple linear search.
# Quadcode implementation ('listIn').
#
# Parameters:
# value - The value to check for, as an LLVM STRING value reference.
# list - List value to search, in an LLVM LIST value reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# If the element is present, as an LLVM ZEROOONE reference.
method listIn(STRING,LIST) {value list {name ""}} {
my call ${tcl.list.in} [list $value $list] $name
}
method listIn(STRING,EMPTY) {value list {name ""}} {
my call ${tcl.list.in} [list $value $list] $name
}
# Builder:listIndex(LIST) --
#
# Get an element of a list. NOTE: this operation can fail (e.g., because
# it can be given an invalid interior list) so it produces a STRING
# FAIL. Quadcode implementation ('listIndex').
#
# Parameters:
# value - List value to get the length of, in an LLVM LIST reference.
# vector -
# The indices as an LLVM vector value reference.
# ec - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The element of the list, as an LLVM STRING FAIL reference.
method listIndex(LIST) {value vector ec {name ""}} {
my ExtractVector $vector
my call ${tcl.list.index} [list $value $len $ary $ec] $name
}
method listIndex(EMPTY) {value vector ec {name ""}} {
my ExtractVector $vector
my call ${tcl.list.index} [list $value $len $ary $ec] $name
}
# Builder:listIndex(LIST,INT) --
#
# Get an element of a list. Quadcode implementation ('listIndex').
#
# Parameters:
# value - List value to get the length of, in an LLVM LIST reference.
# index - Index value to use, in an LLVM INT reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The element of the list, as an LLVM STRING reference.
method listIndex(LIST,INT) {value index {name ""}} {
my call ${tcl.list.index1} [list $value $index] $name
}
method listIndex(LIST,INT) {value index {name ""}} {
my call ${tcl.list.index1} [list $value $index] $name
}
# Builder:listIndex(LIST,STRING) --
#
# Get an element of a list. NOTE: this operation can fail (e.g., because
# it can be given an invalid index) so it produces a STRING FAIL.
# Quadcode implementation ('listIndex').
#
# Parameters:
# value - List value to index into, in an LLVM LIST reference.
# index - Index value to use, in an LLVM STRING reference.
# ec - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The element of the list, as an LLVM STRING FAIL reference.
method listIndex(LIST,STRING) {value index ec {name ""}} {
my call ${tcl.list.indexList} [list $value $index $ec] $name
}
method listIndex(EMPTY,STRING) {value index ec {name ""}} {
my call ${tcl.list.indexList} [list $value $index $ec] $name
}
# Builder:listLength(LIST) --
#
# Get the length of a list. Quadcode implementation ('listLength').
#
# Parameters:
# value - List value to get the length of, in an LLVM LIST reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The length of the list, as an LLVM INT reference.
method listLength(LIST) {value {name ""}} {
my call ${tcl.list.length} [list $value] $name
}
method listLength(EMPTY) {value {name ""}} {
my packInt32 [Const 0] $name
}
# Builder:listRange(LIST,INT,INT) --
#
# Get a sublist of a list. Quadcode implementation ('listRange').
#
# Parameters:
# value - List value to get a substring of, in an LLVM LIST reference.
# from - Index of first element to return, in an LLVM INT reference.
# to - Index of last element to return, in an LLVM INT reference.
# ec - Location to write the Tcl return code into, as an LLVM int*
# reference. (Ignored.)
# name (optional) -
# A name to give to the result value.
#
# Results:
# The sublist, as an LLVM LIST FAIL reference.
method listRange(LIST,INT,INT) {value from to ec {name ""}} {
my call ${tcl.list.range1} [list $value $from $to] $name
}
method listRange(EMPTY,INT,INT) {value from to c {name ""}} {
my call ${tcl.list.range1} [list $value $from $to] $name
}
# Builder:listRange(LIST,STRING,STRING) --
#
# Get a sublist of a list. NOTE: this operation can fail (e.g., because
# it can be given an invalid list) so it produces a STRING FAIL.
# Quadcode implementation ('listRange').
#
# Parameters:
# value - List value to get a substring of, in an LLVM LIST reference.
# from - Index of first element to return, in an LLVM STRING reference.
# to - Index of last element to return, in an LLVM STRING reference.
# ec - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The sublist, as an LLVM LIST FAIL reference.
method listRange(LIST,STRING,STRING) {value from to ec {name ""}} {
my call ${tcl.list.range} [list $value $from $to $ec] $name
}
method listRange(EMPTY,STRING,STRING) {value from to ec {name ""}} {
my call ${tcl.list.range} [list $value $from $to $ec] $name
}
# Builder:listSet(LIST,STRING) --
#
# Update an element in a sublist of a list. NOTE: this operation can
# fail (e.g., because it can be given an invalid index) so it produces a
# LIST FAIL. Quadcode implementation ('listSet').
#
# Parameters:
# list - List value to get a substring of, in an LLVM LIST reference.
# elem - The value to write into the list, in an LLVM STRING reference.
# vector -
# The indices as an LLVM vector value reference.
# ecvar - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The updated list, as an LLVM LIST FAIL reference.
method listSet(LIST,STRING) {list elem vector ecvar {name ""}} {
my ExtractVector $vector
my call ${tcl.list.set} [list $list $len $ary $elem $ecvar] $name
}
method listSet(EMPTY,STRING) {list elem vector ecvar {name ""}} {
my ExtractVector $vector
my call ${tcl.list.set} [list $list $len $ary $elem $ecvar] $name
}
# Builder:listSet(LIST,INT,STRING) --
#
# Update an element of a list. NOTE: this operation can fail (e.g.,
# because it can be given an invalid index) so it produces a LIST FAIL.
# Quadcode implementation ('listSet').
#
# Parameters:
# list - List value update, in an LLVM LIST reference.
# idx - The index into the list to set, in an LLVM INT reference.
# elem - The value to write into the list, in an LLVM STRING reference.
# ecvar - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The updated list, as an LLVM LIST FAIL reference.
method listSet(LIST,INT,STRING) {list idx elem ecvar {name ""}} {
my call ${tcl.list.set1} [list $list $idx $elem $ecvar] $name
}
method listSet(EMPTY,INT,STRING) {list idx elem ecvar {name ""}} {
my call ${tcl.list.set1} [list $list $idx $elem $ecvar] $name
}
# Builder:listSet(LIST,STRING,STRING) --
#
# Update an element of a list or sublist. NOTE: this operation can fail
# (e.g., because it can be given an invalid index) so it produces a LIST
# FAIL. Quadcode implementation ('listSet').
#
# Parameters:
# list - List value update, in an LLVM LIST reference.
# idx - The index into the list to set, in an LLVM STRING reference.
# elem - The value to write into the list, in an LLVM STRING reference.
# ecvar - Location to write the Tcl return code into, as an LLVM int*
# reference.
# name (optional) -
# A name to give to the result value.
#
# Results:
# The updated list, as an LLVM LIST FAIL reference.
method listSet(LIST,STRING,STRING) {list idx elem ecvar {name ""}} {
my call ${tcl.list.setList} [list $list $idx $elem $ecvar] $name
}
method listSet(EMPTY,STRING,STRING) {list idx elem ecvar {name ""}} {
my call ${tcl.list.setList} [list $list $idx $elem $ecvar] $name
}
# Builder:lor(INT,INT) --
#
# Generate code to compute the logical or of two INTs. Quadcode
# implementation ('lor').
................................................................................
if {[string match "* NEXIST" $type]} {
set type [string range $type 0 end-7]
} elseif {[string match "NEXIST *" $type]} {
set type [string range $type 7 end]
}
my insert [my undef $type!] [Const true bool] 0 $name
}
# Builder:narrowToType.DICT(STRING) --
#
# Generate code to parse the given STRING and extract a DICT. The
# STRING is already be known to contain a value of the right type (due
# to higher-level quadcode constraints). Quadcode implementation
# ('narrowToType').
#
# Parameters:
# value - The STRING LLVM value reference to parse.
# name (optional) -
# A name to give to the result value.
#
# Results:
# A DICT LLVM value reference.
method narrowToType.DICT(STRING) {value {name ""}} {
return $value
}
method narrowToType.IMPURE_DICT(STRING) {value {name ""}} {
return $value
}
method narrowToType.EMPTY_DICT(STRING) {value {name ""}} {
return $value
}
method narrowToType.IMPURE_EMPTY_DICT(STRING) {value {name ""}} {
return $value
}
# Builder:narrowToType.LIST(STRING) --
#
# Generate code to parse the given STRING and extract a LIST. The
# STRING is already be known to contain a value of the right type (due
# to higher-level quadcode constraints). Quadcode implementation
# ('narrowToType').
................................................................................
#
# Parameters:
# value - The STRING LLVM value reference to parse.
# name (optional) -
# A name to give to the result value.
#
# Results:
# A LIST LLVM value reference.
method narrowToType.LIST(STRING) {value {name ""}} {
return $value
}
method narrowToType.IMPURE_LIST(STRING) {value {name ""}} {
return $value
}
|
Changes to codegen/compile.tcl.
531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 ... 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 .... 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 .... 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 |
"dictAppend" - "dictIncr" - "dictLappend" - "dictSize" -
"div" - "expon" - "mod" - "verifyList" -
"dictGetOrNexist" - "dictSetOrUnset" {
set srcs [lassign $l opcode tgt]
set name [my LocalVarName $tgt]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
set res [$b $opcode {*}$srcs $errorCode $name]
if {"FAIL" in [my ValueTypes $tgt]} {
my SetErrorLine $errorCode [$b maybe $res]
}
my StoreResult $tgt $res
}
"listAppend" - "listConcat" - "listRange" {
set srcs [lassign $l opcode tgt]
set src1 [lindex $srcs 0]
set name [my LocalVarName $tgt]
................................................................................
my StoreResult $tgt $res
$b clearVector $vector
}
if {"FAIL" in [my ValueTypes $tgt]} {
my SetErrorLine $errorCode [$b maybe $res]
}
}
"dictSet" - "listSet" {
set srcs [lassign $l opcode tgt srcObj srcValue]
set name [my LocalVarName $tgt]
if {[llength $srcs] == 1} {
# Simple case
set srcs [list $srcObj {*}$srcs $srcValue]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
................................................................................
set t [lrange $tgttype 1 end]
set value [$b fail $t "" $name]
}
"NEXIST *" {
set t [lrange $tgttype 1 end]
set value [$b nothing $t $name]
}
"STRING" - "EMPTY" {
set value [my LoadOrLiteral "literal {}"]
}
default {
# Should be unreachable in practice
my Warn "widened void to %s; result is undef" $tgttype
set value [$b undef $tgttype]
}
................................................................................
set value [$b packNumericDouble $value $name]
} else {
set value [$b packNumericInt $value $name]
}
} elseif {$srctype eq "EMPTY" && $tgttype eq "STRING"} {
set value [Const "" STRING]
} elseif {$srctype ne $tgttype} {
my Warn "unimplemented convert from '%s' to '%s'" $srctype $tgttype
}
if {[Type $tgttype] eq [Type [TypeOf $value]?]} {
set value [$b ok $value]
} elseif {[Type $tgttype] eq [Type [TypeOf $value]!]} {
set value [$b just $value]
}
return $value
|
< > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > | > |
531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 ... 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 .... 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 .... 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 |
"dictAppend" - "dictIncr" - "dictLappend" - "dictSize" -
"div" - "expon" - "mod" - "verifyList" -
"dictGetOrNexist" - "dictSetOrUnset" {
set srcs [lassign $l opcode tgt]
set name [my LocalVarName $tgt]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
if {"FAIL" in [my ValueTypes $tgt]} {
set res [$b $opcode {*}$srcs $errorCode $name]
my SetErrorLine $errorCode [$b maybe $res]
} else {
set res [$b $opcode {*}$srcs $name]
}
my StoreResult $tgt $res
}
"listAppend" - "listConcat" - "listRange" {
set srcs [lassign $l opcode tgt]
set src1 [lindex $srcs 0]
set name [my LocalVarName $tgt]
................................................................................
my StoreResult $tgt $res
$b clearVector $vector
}
if {"FAIL" in [my ValueTypes $tgt]} {
my SetErrorLine $errorCode [$b maybe $res]
}
}
"dictSet" {
set srcs [lassign $l opcode tgt srcObj srcValue]
set name [my LocalVarName $tgt]
if {[llength $srcs] == 1} {
# Simple case
set srcs [list $srcObj {*}$srcs $srcValue]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
set res [$b $opcode {*}$srcs $name]
my StoreResult $tgt $res
} else {
# Need to construct the variadic path
set vectortypes [lmap s $srcs {my ValueTypes $s}]
set vector [$b buildVector $objv $vectortypes \
[lmap s $srcs {my LoadOrLiteral $s}]]
set srcs [list $srcObj $srcValue]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
set res [$b $opcode {*}$srcs $vector $errorCode $name]
my StoreResult $tgt $res
$b clearVector $vector
my SetErrorLine $errorCode [$b maybe $res]
}
}
"listSet" {
set srcs [lassign $l opcode tgt srcObj srcValue]
set name [my LocalVarName $tgt]
if {[llength $srcs] == 1} {
# Simple case
set srcs [list $srcObj {*}$srcs $srcValue]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
................................................................................
set t [lrange $tgttype 1 end]
set value [$b fail $t "" $name]
}
"NEXIST *" {
set t [lrange $tgttype 1 end]
set value [$b nothing $t $name]
}
"STRING" - "LIST" - "DICT" - "EMPTY" {
set value [my LoadOrLiteral "literal {}"]
}
default {
# Should be unreachable in practice
my Warn "widened void to %s; result is undef" $tgttype
set value [$b undef $tgttype]
}
................................................................................
set value [$b packNumericDouble $value $name]
} else {
set value [$b packNumericInt $value $name]
}
} elseif {$srctype eq "EMPTY" && $tgttype eq "STRING"} {
set value [Const "" STRING]
} elseif {$srctype ne $tgttype} {
if {("DICT" in $srctype || "LIST" in $srctype) && "LIST" in $tgttype} {
# Do nothing and hope!
} else {
my Warn "unimplemented convert from '%s' to '%s'" $srctype $tgttype
}
}
if {[Type $tgttype] eq [Type [TypeOf $value]?]} {
set value [$b ok $value]
} elseif {[Type $tgttype] eq [Type [TypeOf $value]!]} {
set value [$b just $value]
}
return $value
|
Changes to codegen/stdlib.tcl.
48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 ... 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 ... 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 ... 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 ... 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 ... 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 .... 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 .... 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 .... 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 .... 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 .... 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 .... 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 .... 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 .... 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 .... 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 .... 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 .... 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 .... 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 .... 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 .... 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 .... 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 .... 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 .... 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 .... 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 .... 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 .... 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 .... 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 .... 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 .... 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 .... 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 .... 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 .... 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 .... 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 .... 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 .... 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 .... 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 .... 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 .... 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 .... 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 .... 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 .... 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 .... 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 .... 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 |
variable tcl.dict.get1 tcl.dict.get tcl.dict.set1 tcl.dict.set
variable tcl.dict.exists1 tcl.dict.exists tcl.dict.unset1 tcl.dict.unset
variable tcl.dict.iterStart tcl.dict.iterNext tcl.dict.iterDone
variable tcl.dict.iterKey tcl.dict.iterValue tcl.dict.addIterReference
variable tcl.dict.addIterFailReference
variable tcl.dict.dropIterReference tcl.dict.dropIterFailReference
variable tcl.dict.append tcl.dict.lappend tcl.dict.incr tcl.dict.size
variable tcl.dict.get1.empty tcl.dict.set1.empty
variable tcl.maptoint
# Variables holding implementations of Tcl's exception-handling machinery
variable tcl.getresult tcl.getreturnopts tcl.initExceptionOptions
variable tcl.initExceptionSimple tcl.processReturn tcl.procedure.return
variable tcl.setErrorLine tcl.existsOrError tcl.logCommandInfo
variable tcl.handleExceptionResult tcl.invoke.command tcl.invoke.expanded
................................................................................
my assume [my eq $before $after]
my ret $result
}
##### Function tcl.isPureByteArray #####
##### Closure Build:isByteArray #####
#
# Type signature: objPtr:STRING -> int1
#
# Test if a STRING is actually a true byte array, that it can be
# processed as bytes and not as unicode characters.
set f [$m local "tcl.isPureByteArray" int1<-STRING readonly]
params objPtr
build {
nonnull $objPtr
set baType [$api tclByteArrayType]
set typePtr [my dereference $objPtr 0 Tcl_Obj.typePtr]
my condBr [my eq $baType $typePtr] $puretest $notBA
label puretest:
................................................................................
my closure isByteArray {STRING {name ""}} {
my call ${tcl.isPureByteArray} [list $STRING] $name
}
##### Function tcl.isUnicodeString #####
##### Closure Build:isUnicodeString #####
#
# Type signature: objPtr:STRING -> int1
#
# Test if a STRING is stored internally as a sequence of Tcl_UniChar
# (instead of as a sequence of Unicode characters encoded as UTF-8).
set f [$m local "tcl.isUnicodeString" int1<-STRING readonly]
params objPtr
build {
nonnull $objPtr
set strType [$api tclStringType]
set type [my dereference $objPtr 0 Tcl_Obj.typePtr]
my ret [my eq $type $strType]
}
................................................................................
my closure isUnicodeString {STRING {name ""}} {
my call ${tcl.isUnicodeString} [list $STRING] $name
}
##### Function tcl.impl.getBoolean #####
##### MAPPED CALL TO METHOD: Build:GetBoolean #####
#
# Type signature: valueObj:STRING -> int1*int1
set f [$m local "tcl.impl.getBoolean" struct{int1,int1}<-STRING]
params valueObj
build {
nonnull $valueObj
set boolVar [my alloc int32 "boolPtr"]
set str [$api Tcl_GetString $valueObj]
set code [$api Tcl_GetBooleanFromObj {} $valueObj $boolVar]
set res [my undef struct{int1,int1}]
set res [my insert $res [my eq $code [Const 0]] 0]
set res \
[my insert $res [my neq [my load $boolVar "bool"] [Const 0]] 1]
my ret $res
}
my closure GetBoolean {valueObj} {
my call ${tcl.impl.getBoolean} [list $valueObj] "result"
................................................................................
##### MAPPED CALL TO METHOD: Build:GetDouble #####
#
# Type signature: valueObj:STRING -> int * int8[]
#
# Gets the (pseudo-)UTF-8 version of a string. Wrapper around Tcl API
# to ensure that scope lifetime gets better understood.
set f [$m local "tcl.impl.getDouble" struct{int1,double}<-STRING]
my closure GetDouble {valueObj} {
my call ${tcl.impl.getDouble} [list $valueObj] "result"
}
params valueObj
build {
nonnull $valueObj
set dblVar [my alloc double "dblPtr"]
set code [$api Tcl_GetDoubleFromObj {} $valueObj $dblVar]
set res [my undef struct{int1,double}]
set res [my insert $res [my eq $code [Const 0]] 0]
set res [my insert $res [my load $dblVar "dbl"] 1]
my ret $res
}
unset -nocomplain valueObj
##### Function tcl.impl.getWide #####
................................................................................
##### MAPPED CALL TO METHOD: Build:GetWide #####
#
# Type signature: valueObj:STRING -> bool * int64
#
# Gets an int64 from a Tcl string. Wrapper around Tcl API to ensure
# that scope lifetime gets better understood.
set f [$m local "tcl.impl.getWide" struct{int1,int64}<-STRING]
my closure GetWide {valueObj {name "result"}} {
my call ${tcl.impl.getWide} [list $valueObj] $name
}
params valueObj
build {
nonnull $valueObj
set intVar [my alloc int64 "intPtr"]
................................................................................
set p5 [my phi [list $p2 $p4] [list $nextOuter $fixP] "p.5"]
my ret [my sub $numBytes1 [my cast(int) [my diff $p5 $bytes]]]
}
##### Function tcl.impl.isAscii #####
# Replacement for non-exposed UniCharIsAscii
#
# Type signature: ch:int16 -> int1
#
# Part of quadcode implementation ('strclass')
#
# Returns whether the character 'ch' is in the ASCII range.
set f [$m local "tcl.impl.isAscii" bool<-int16 readnone]
params ch
................................................................................
my ret [my and [my ge $ch [Const 0 int16]] \
[my lt $ch [Const 0x80 int16]]]
}
##### Function tcl.impl.isXdigit #####
# Replacement for non-exposed UniCharIsXdigit
#
# Type signature: ch:int16 -> int1
#
# Part of quadcode implementation ('strclass')
#
# Returns whether the character 'ch' is a hex digit.
set f [$m local "tcl.impl.isXdigit" bool<-int16 readnone]
params ch
................................................................................
my ret [Const true bool]
label not:
my ret [Const false bool]
}
##### Function tcl.strclass #####
#
# Type signature: objPtr:STRING * class:int32 -> ZEROONE
#
# Quadcode implementation ('strclass')
#
# Returns whether all the characters in the string 'objPtr' are in the
# character class given by 'class' (enumeration encoded as int32).
set f [$m local "tcl.strclass" ZEROONE<-STRING,int]
params objPtr class
build {
nonnull $objPtr
lassign [my GetUnicode $objPtr obj] length string
my condBr [my gt $length $0] $test $match
label test:
set end [my getelementptr $string [list $length]]
................................................................................
my ret [Const false bool]
}
##### Function tcl.impl.getIndex #####
##### Closure Build:GetIndex #####
#
# Type signature: interp:Interp* * objPtr:Tcl_Obj* * end:int
# -> int1 * int
#
# Converts an index string into an offset into something (i.e., a
# string or list). Returns a tuple of whether the conversion succeeded
# (a boolean) and the index.
set f [$m local "tcl.impl.getIndex" \
struct{bool,int}<-Interp*,Tcl_Obj*,int readonly]
................................................................................
# Type signatures: obj:STRING -> {STRING,bool}
# objdupe:{STRING,bool} -> void
#
# Helpers for the dictionary updating functions that reduce the amount
# of explicit branch management in the code by factoring out common
# patterns of reference handling.
set f [$m local "obj.dedup" struct{STRING,int1}<-STRING]
params obj
build {
set duped [my shared $obj]
SetValueName $duped "duped"
set res [my insert [my undef struct{STRING,int1}] $duped 1]
my condBr $duped $duplicated $unshared
label duplicated:
set dupe [$api Tcl_DuplicateObj $obj]
SetValueName $dupe "duplicateObj"
my ret [my insert $res $dupe 0]
label unshared:
my ret [my insert $res $obj 0]
................................................................................
my closure Dedup {varName} {
upvar 1 $varName var
set token [my Call obj.dedup $var]
set var [my extract $token 0 [GetValueName $var]]
return $token
}
set f [$m local "obj.cleanup" void<-struct{STRING,int1}]
params objdupe
build {
my condBr [my extract $objdupe 1] $duplicated $unshared
label duplicated:
my dropReference [my extract $objdupe 0]
my ret
label unshared:
................................................................................
my ret $new
label fail:
my ret [my null STRING]
}
##### Function tcl.isList #####
#
# Type signature: objPtr:STRING -> int1
#
# Part of quadcode implementation ('isInstance')
#
# Wrapper around Tcl_ListObjLength that uses it to do a list-ness
# check.
set f [$m local "tcl.isList" int1<-STRING]
params objPtr
build {
nonnull $objPtr
set var [my alloc int "length"]
set code [$api Tcl_ListObjLength {} $objPtr $var]
my ret [my eq $code $0]
}
................................................................................
# Type signature: objc:int * objv:STRING* -> STRING
#
# Core of quadcode implementation ('list')
#
# Wrapper around Tcl_NewListObj that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.create" STRING<-int,STRING*]
params objc objv
build {
nonnull $objv
set val [$api Tcl_NewListObj $objc $objv]
my addReference(STRING) $val
my ret $val
}
##### Function tcl.list.length #####
#
# Type signature: list:STRING * ecvar:int* -> INT?
#
# Core of quadcode implementation ('listLength')
#
# Wrapper around Tcl_ListObjLength that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.length" INT?<-STRING,int*]
params list ecvar
build {
noalias $list $ecvar
nonnull $list $ecvar
set var [my alloc int "length"]
set interp [$api tclInterp]
set code [$api Tcl_ListObjLength $interp $list $var]
my condBr [my eq $code $0] $ok $fail
label ok:
my ret [my ok [my packInt32 [my load $var]]]
label fail:
my store $1 $ecvar
my ret [my fail INT]
}
##### Function tcl.list.verify #####
#
# Type signature: value:STRING * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('verifyList')
#
# Wrapper around a list operation (Tcl_ListObjLength) that verifies
# that the value it is dealing with is a list; converting it to a FAIL
# if it is not.
set f [$m local "tcl.list.verify" STRING?<-STRING,int*]
params value ecvar
build {
noalias $value $ecvar
nonnull $value $ecvar
set var [my alloc int "length"]
set interp [$api tclInterp]
set code [$api Tcl_ListObjLength $interp $value $var]
................................................................................
label fail:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.append #####
#
# Type signature: list:STRING * value:STRING * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('listAppend')
#
# Wrapper around Tcl_ListObjLength that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.append" STRING?<-STRING,STRING,int*]
params list value ecvar
build {
noalias $ecvar
nonnull $list $value $ecvar
set interp [$api tclInterp]
my condBr [my shared $list] $sharedDupe $unshared
label sharedDupe "shared.duplicate"
set copy [my ListDupe $interp $list "copy"]
my condBr [my nonnull $copy] $shared $error
label shared:
$api Tcl_ListObjAppendElement {} $copy $value
my br $return
label unshared:
set code [$api Tcl_ListObjAppendElement $interp $list $value]
my condBr [my eq $code $0] $return $error
label return:
set list [my phi [list $copy $list] [list $shared $unshared] "list"]
$api TclInvalidateStringRep $list
my addReference(STRING) $list
my condBr [my shared $value] $exit $extraRef
label extraRef "add.extra.reference.to.value"
my addReference(STRING) $value
my br $exit
label exit:
my ret [my ok $list]
label error:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.concat #####
#
# Type signature: list:STRING * value:STRING * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('listConcat')
#
# Wrapper around Tcl_ListObjLength that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.concat" STRING?<-STRING,STRING,int*]
params list value ecvar
build {
noalias $ecvar
nonnull $list $value $ecvar
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set interp [$api tclInterp]
set code [$api Tcl_ListObjLength $interp $list $objc]
my condBr [my eq $code $0] $checkValue $error
label checkValue "check.value.for.listness"
set len [my load $objc "len"]
set code [$api Tcl_ListObjGetElements $interp $value $objc $objv]
my condBr [my eq $code $0] $checkDupe $error
label checkDupe "check.whether.to.duplicate"
my condBr [my shared $list] $dupe $concat
label dupe "duplicate"
set copy [my ListDupe {} $list "copy"]
my br $concat
label concat:
set working [my phi [list $list $copy] [list $checkDupe $dupe] "list"]
set objc [my load $objc "objc"]
set objv [my load $objv "objv"]
$api Tcl_ListObjReplace {} $working $len $0 $objc $objv
my addReference(STRING) $working
my ret [my ok $working]
label error:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.index #####
#
# Type signature: list:STRING * idxc:int * idxv:STRING* * ecvar:int*
# -> STRING?
#
# Core of quadcode implementation ('listIndex')
#
# Effectively an implementation of TclLindexFlat.
set f [$m local "tcl.list.index" STRING?<-STRING,int,STRING*,int*]
params list idxc idxv ecvar
build {
noalias $list $idxv $ecvar
nonnull $list $idxv $ecvar
set iPtr [my alloc int "&i"]
set listPtr [my alloc STRING "&list"]
set listLenPtr [my alloc int "&listLen"]
................................................................................
label error:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.index1 #####
#
# Type signature: list:STRING * index:INT * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('listIndex')
#
# Basic list indexing in the case where we know that the index is an
# integer, which avoids many of the failure modes.
set f [$m local "tcl.list.index1" STRING?<-STRING,INT,int*]
params list index ecvar
build {
noalias $list $ecvar
nonnull $list $ecvar
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set interp [$api tclInterp]
set idx [my getInt32 $index]
set code [$api Tcl_ListObjGetElements $interp $list $objc $objv]
my condBr [my eq $code $0] $ok $fail
label ok:
my condBr [my and [my ge $idx $0] [my lt $idx [my load $objc]]] \
$realIndex $outOfBounds
label realIndex "real.index"
set objv [my load $objv "objv"]
set obj [my load [my getelementptr $objv [list $idx]] "objPtr"]
my addReference(STRING) $obj
my ret [my ok $obj]
label outOfBounds "out.of.bounds"
set obj [$api Tcl_NewObj]
my addReference(STRING) $obj
my ret [my ok $obj]
label fail:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.indexList #####
#
# Type signature: list:STRING * index:STRING * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('listIndex')
#
# Effectively an implementation of TclLindexList.
set f [$m local "tcl.list.indexList" STRING?<-STRING,STRING,int*]
params list index ecvar
build {
noalias $ecvar
nonnull $list $index $ecvar
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set interp [$api tclInterp]
set code [$api Tcl_ListObjGetElements $interp $list $objc $objv]
my condBr [my eq $code $0] $checkType $notList
label notList:
# We're not a list and we know it right now
my store $1 $ecvar
my ret [my fail STRING]
label checkType:
my condBr [my neq [my dereference $index 0 Tcl_Obj.typePtr] \
[$api tclListType]] \
$checkIndex $slowPath
label checkIndex:
set len [my load $objc]
my condBr [my GetIndex {} $index $len idx] \
$immediateIndex $slowPath
................................................................................
[my gep $dupe 0 Tcl_Obj.internalRep 0] \
TclList*] "listRep"]
set result [my Call tcl.list.index \
$list [my dereference $listRep 0 TclList.elemCount] \
[my gep $listRep 0 TclList.elements] $ecvar]
my dropReference $dupe
my ret $result
}
##### Function tcl.list.range #####
#
# Type signature: list:STRING * from:STRING * to:STRING -> STRING?
#
# Core of quadcode implementation ('listRangeImm')
#
# Wrapper around Tcl_NewListObj that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.range" STRING?<-STRING,STRING,STRING,int*]
params list from to ecvar
build {
noalias $ecvar
nonnull $list $from $to $ecvar
set objcVar [my alloc int]
set objvVar [my alloc STRING*]
set interp [$api tclInterp]
set result [$api Tcl_ListObjLength $interp $list $objcVar]
my condBr [my eq $result $0] $getFrom $error
label getFrom:
set objc [my load $objcVar "objc"]
set endIndex [my sub $objc $1]
my condBr [my GetIndex $interp $from $endIndex from] $getTo $error
label getTo:
my condBr [my GetIndex $interp $to $endIndex to] $clamp $error
label clamp:
set from [my select [my lt $from ${-1}] \
................................................................................
label error:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.range1 #####
#
# Type signature: list:STRING * from:INT * to:INT -> STRING?
#
# Core of quadcode implementation ('listRangeImm')
#
# Wrapper around Tcl_NewListObj that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.range1" STRING?<-STRING,INT,INT,int*]
params list from to ecvar
build {
noalias $ecvar
nonnull $list $ecvar
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set interp [$api tclInterp]
set from [my getInt32 $from "from"]
set to [my getInt32 $to "to"]
set result [$api Tcl_ListObjGetElements $interp $list $objc $objv]
my condBr [my eq $result $0] $clamp $error
label clamp:
set objc [my load $objc]
set objv [my load $objv]
set from [my select [my lt $from ${-1}] \
[my add $from [my add $1 $objc]] \
[my min $objc $from] \
"from"]
set from [my max ${-1} $from "from"]
................................................................................
label empty:
set r2 [$api Tcl_NewObj]
my br $ok
label ok:
set sources [list $sublistInplaceDone $sublistNew $empty]
set result [my phi [list $list $r1 $r2] $sources "result"]
my addReference(STRING) $result
my ret [my ok $result]
label error:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.set #####
#
# Type signature: list:STRING * idxc:int * idxv:STRING* * elem:STRING
# * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('lset')
#
# Approximately equivalent to TclLsetFlat
set f [$m local "tcl.list.set" STRING?<-STRING,int,STRING*,STRING,int*]
params list idxc idxv elem ecvar
build {
noalias $idxv $ecvar
nonnull $list $idxv $elem $ecvar
set subList [my alloc STRING]
set chain [my alloc STRING]
set elemc [my alloc int]
................................................................................
# -> STRING?
#
# Core of quadcode implementation ('lset')
#
# Wrapper around TclListObjSetElement that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.set1" STRING?<-STRING,INT,STRING,int*]
params list idx elem ecvar
build {
noalias $ecvar
nonnull $list $elem $ecvar
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set idx [my getInt32 $idx "index"]
set interp [$api tclInterp]
set duped [my Dedup list]
set code [$api Tcl_ListObjGetElements $interp $list $objc $objv]
my condBr [my eq $code $1] $out $rangeCheck
label rangeCheck "range.check"
set objc [my load $objc]
my condBr [my or [my lt $idx $0] [my gt $idx $objc]] \
$outRange $checkOperation
label checkOperation "operation.check"
set rc [my refCount $list]
my condBr [my eq $idx $objc] $append $set
label append:
$api Tcl_ListObjAppendElement {} $list $elem
my br $done
label set:
................................................................................
my addReference(STRING) $list
my condBr [my shared $elem] $exit2 $exit3
label exit3 "exit"
my addReference(STRING) $elem
my br $exit2
label exit2 "exit"
my ret [my ok $list]
label outRange "failure.outOfRange"
$api Tcl_SetObjResult $interp \
[$api obj.constant "list index out of range"]
$api Tcl_SetObjErrorCode $interp \
[$api obj.constant {TCL OPERATION LSET BADINDEX}]
my br $out
label out "failure.exit"
my Call obj.cleanup $duped
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.setList #####
#
# Type signature: list:STRING * idxArg:STRING * elem:STRING
# * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('lset')
#
# Approximately equivalent to TclLsetList
set f [$m local "tcl.list.setList" STRING?<-STRING,STRING,STRING,int*]
params list idxArg elem ecvar
build {
noalias $ecvar
nonnull $list $idxArg $elem $ecvar
set ary [my alloc STRING]
set argc [my alloc int]
set argv [my alloc STRING*]
................................................................................
$list [my load $argc] [my load $argv] $elem $ecvar]
my dropReference $copy
my ret $code
}
##### Function tcl.list.in #####
#
# Type signature: value:STRING * list:STRING * ecVar:int* -> ZEROONE?
#
# Core of quadcode implementation ('listIn')
#
# Determines if the value is present in the list, using simple string
# comparison.
set f [$m local "tcl.list.in" ZEROONE?<-STRING,STRING,int*]
params value list ecVar
build {
noalias $ecVar
nonnull $value $list $ecVar
set interp [$api tclInterp]
lassign [my GetString $value "string"] len1 bytes1
set lenVar [my alloc int]
set objvVar [my alloc STRING*]
set code [$api Tcl_ListObjGetElements $interp $list $lenVar $objvVar]
my condBr [my eq $code $0] $realCheck $fail
label realCheck:
set objc [my load $lenVar "objc"]
set objv [my load $objvVar "objv"]
my condBr [my gt $objc $0] $loop $done
label loop:
set i [PHI [Type int32] {$0 $iLoop} {$realCheck $loopNext} "i"]
set obj [my load [my getelementptr $objv [list $i]] "obj"]
lassign [my GetString $obj "element"] len2 bytes2
my condBr [my eq $len1 $len2] $loopCompare $loopNext
label loopCompare:
my condBr [my eq [my memcmp $bytes1 $bytes2 $len1] $0] \
$done $loopNext
label loopNext:
set iLoop [set i [my add $i $1 "i"]]
my condBr [my lt $i $objc] $loop $done
label fail:
my store $1 $ecVar
my ret [my fail ZEROONE]
label done:
set flag [my phi [list [Const false bool] [Const false bool] [Const true bool]] \
[list $realCheck $loopNext $loopCompare] "flag"]
my ret [my ok $flag]
}
##### Function tcl.list.unshare #####
#
# Type signature: list:STRING -> STRING
#
# Core of quadcode implementation ('unshareList')
#
# Approximately equivalent to TclListObjCopy
set f [$m local "tcl.list.unshare" STRING<-STRING]
params list
................................................................................
my addReference(STRING) $copy
my ret $copy
}
##### Function tcl.list.foreach.start.step #####
#
# Type signature:
# nsteps:int?,list:STRING,stride:int->nsteps:int?
#
# Core of quadcode implementation ('foreachStart')
#
# Works with one pair of list and assignment pattern, making sure
# that the list is really a list, and updating the number of iterations
# according to the given stride.
set f [$m local "tcl.list.foreach.start.step" \
int?<-int?,STRING,int]
params steps_init list stride
build {
noalias $list
nonnull $list
set objcVar [my alloc int]
set interp [$api tclInterp]
my condBr [my maybe $steps_init] $earlierError $listLength
label earlierError:
my ret $steps_init
label listLength:
set code [$api Tcl_ListObjLength $interp $list $objcVar]
my condBr [my eq $code $0] $lengthOk $lengthBad
label lengthOk:
set steps_before [my unmaybe $steps_init]
set objc [my load $objcVar "objc"]
set count [my div [my add $objc [my sub $stride [Const 1 int]]] \
$stride "count"]
set stepsOk [my ok [my max $steps_before $count "steps"]]
my br $done
label lengthBad:
set stepsBad [my fail int]
my br $done
label done:
set steps [my phi [list $stepsOk $stepsBad] \
[list $lengthOk $lengthBad]]
my ret $steps
}
##### Function: tcl.list.foreach.start.finish #####
#
# Type signature: steps:int?,ecvar:int*->FAIL FOREACH
#
# After 'tcl.list.foreach.start.step' has run for each assignment
................................................................................
params pair
build {
my ret [my packInt32 [my extract $pair FOREACH.val]]
}
##### Function tcl.list.foreach.mayStep #####
#
# Type signature: pair:FOREACH -> ZEROONE
#
# Core of quadcode implementation ('foreachMayStep')
#
# Part of how lists are iterated over. This is broken up into several
# pieces because of the number of different things assigned to. This
# part gets whether the end of the iterations has been reached.
set f [$m local "tcl.list.foreach.mayStep" ZEROONE<-FOREACH readnone]
params pair
build {
set val [my extract $pair FOREACH.val]
set max [my extract $pair FOREACH.max]
my ret [my lt $val $max]
}
................................................................................
# Thunk class).
#
# Results:
# None.
method DictionaryFunctions {api} {
upvar 1 0 0 1 1
##### Function tcl.dict.exists1 #####
#
# Type signature: dict:STRING * key:STRING -> ZEROONE
#
# Tests if a key is in a dictionary.
set f [$m local "tcl.dict.exists1" ZEROONE<-STRING,STRING]
params dict key
build {
nonnull $dict $key
set resvar [my alloc STRING "valueVar"]
my store [my null STRING] $resvar
set result [$api Tcl_DictObjGet {} $dict $key $resvar]
my ret [my and [my eq $result $0] \
[my nonnull [my load $resvar "value"]] \
"exists"]
}
##### Function tcl.dict.exists #####
#
# Type signature: dict:STRING * pathlen:int * pathobjs:STRING*
# * ecvar:int32* -> ZEROONE
#
# Gets a value by key from a dictionary. Can fail if the "dict" is
# not a valid dictionary.
set f [$m local "tcl.dict.exists" ZEROONE<-STRING,int,STRING*]
params dict keyc keyv
build {
noalias $dict $keyv
nonnull $dict $keyv
set dummy [my alloc int "dummy"]
set resvar [my alloc STRING "valueVar"]
my condBr [my eq $keyc $0] $verify $exists
................................................................................
"exists"]
label notOK:
my ret [Const false bool]
}
##### Function tcl.dict.size #####
#
# Type signature: dict:STRING * ecvar:int32* -> INT?
#
# Gets the size of a dictionary. Can fail if the "dict" is not a valid
# dictionary.
set f [$m local "tcl.dict.size" INT?<-STRING,int*]
params dict ecvar
build {
noalias $ecvar
nonnull $dict $ecvar
set size [my alloc int "size"]
set interp [$api tclInterp]
set code [$api Tcl_DictObjSize $interp $dict $size]
my condBr [my eq $code $0] $ok $fail
label ok:
my ret [my ok [my packInt32 [my load $size]]]
label fail:
my store $1 $ecvar
my ret [my fail INT]
}
##### Function tcl.dict.get1 #####
#
# Type signature: dict:STRING * key:STRING * ecvar:int32* -> STRING?
#
# Gets a value by key from a dictionary. Can fail if the "dict" is
# not a valid dictionary.
set f [$m local "tcl.dict.get1" STRING?<-STRING,STRING,int*]
params dict key ecvar
build {
noalias $ecvar
nonnull $dict $key $ecvar
set resvar [my alloc STRING "valueVar"]
set interp [$api tclInterp]
set result [$api Tcl_DictObjGet $interp $dict $key $resvar]
my condBr [my eq $result $0] $OK $notOK
label OK:
set value [my load $resvar "value"]
my condBr [my nonnull $value] $return $fail
label return:
my addReference(STRING) $value
my ret [my ok $value]
label fail:
set keyval [$api Tcl_GetString $key]
................................................................................
$api Tcl_SetObjResult $interp \
[$api Tcl_ObjPrintf [my constString \
"key \"%s\" not known in dictionary"] \
$keyval]
$api Tcl_SetErrorCode $interp \
[my constString TCL] [my constString LOOKUP] \
[my constString DICT] $keyval {}
my br $notOK
label notOK:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.get #####
#
# Type signature: dict:STRING * pathlen:int * pathobjs:STRING*
# * ecvar:int32* -> STRING?
#
# Gets a value by key from a dictionary. Can fail if the "dict" is
# not a valid dictionary.
set f [$m local "tcl.dict.get" STRING?<-STRING,int,STRING*,int*]
params dict keyc keyv ecvar
build {
noalias $dict $keyv $ecvar
nonnull $dict $keyv $ecvar
set dummy [my alloc int "dummy"]
set resvar [my alloc STRING "valueVar"]
set interp [$api tclInterp]
................................................................................
label notOK:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.get1.empty #####
#
# Type signature: dict:STRING * key:STRING * ecvar:int32* -> STRING!?
#
# Gets a value by key from a dictionary. Can only fail if the "dict"
# is not a valid dictionary; an absent key in the terminal dictionary
# is reported as an NEXIST result.
set f [$m local "tcl.dict.get1.empty" STRING!?<-STRING,STRING,int*]
params dict key ecvar
build {
noalias $ecvar
nonnull $dict $key $ecvar
set resvar [my alloc STRING "valueVar"]
set interp [$api tclInterp]
set result [$api Tcl_DictObjGet $interp $dict $key $resvar]
my condBr [my eq $result $0] $OK $notOK
label OK:
set value [my load $resvar "value"]
my condBr [my nonnull $value] $return $empty
label return:
my addReference(STRING) $value
my ret [my ok [my just $value]]
label empty:
my ret [my ok [my nothing STRING]]
label notOK:
my store $1 $ecvar
my ret [my fail STRING!]
}
##### Function tcl.dict.set1 #####
#
# Type signature: dict:STRING * key:STRING * value:STRING
# * ecvar:int32* -> STRING?
#
# Sets a key in a dictionary to map to a value. Can fail if the
# "dict" is not a valid dictionary.
set f [$m local "tcl.dict.set1" STRING?<-STRING,STRING,STRING,int*]
params dict key value ecvar
build {
noalias $ecvar
nonnull $dict $key $value $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjPut $interp $dict $key $value]
my condBr [my eq $result $0] $OK $notOK
label OK:
my addReference(STRING) $dict
my condBr [my shared $value] $exit2 $exit3
label exit3 "exit"
my addReference(STRING) $value
my br $exit2
label exit2 "exit"
my ret [my ok $dict]
label notOK:
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.set #####
#
# Type signature: dict:STRING * pathlen:int * pathobjs:STRING*
# * value:STRING * ecvar:int32* -> STRING?
#
# Sets a key (or rather a key path) in a dictionary to map to a value.
# Can fail if the "dict" is not a valid dictionary.
set f [$m local "tcl.dict.set" STRING?<-STRING,int,STRING*,STRING,int*]
params dict pathlen pathobjs value ecvar
build {
noalias $pathobjs $ecvar
nonnull $dict $pathobjs $value $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjPutKeyList $interp $dict $pathlen $pathobjs $value]
................................................................................
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.unset1 #####
#
# Type signature: dict:STRING * key:STRING * ecvar:int32* -> STRING?
#
# Removes a key from a dictionary. Can fail if the "dict" is not a
# valid dictionary.
set f [$m local "tcl.dict.unset1" STRING?<-STRING,STRING,int*]
params dict key ecvar
build {
noalias $ecvar
nonnull $dict $key $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjRemove $interp $dict $key]
my condBr [my eq $result $0] $OK $notOK
label OK:
my addReference(STRING) $dict
my ret [my ok $dict]
label notOK:
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.unset #####
#
# Type signature: dict:STRING * pathlen:int * pathobjs:STRING*
# * ecvar:int32* -> STRING?
#
# Removes a key (or rather a key path) from a dictionary. Can fail if
# the "dict" is not a valid dictionary.
set f [$m local "tcl.dict.unset" STRING?<-STRING,int,STRING*,int*]
params dict pathlen pathobjs ecvar
build {
noalias $dict $pathobjs $ecvar
nonnull $dict $pathobjs $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjRemoveKeyList $interp $dict $pathlen $pathobjs]
................................................................................
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.set1.empty #####
#
# Type signature: dict:STRING * key:STRING * value:STRING!
# * ecvar:int32* -> STRING?
#
# Sets a key in a dictionary to map to a value, or removes the mapping
# if the value is NEXIST. Can fail if the "dict" is not a valid
# dictionary.
set f [$m local "tcl.dict.set1.empty" \
STRING?<-STRING,STRING,STRING!,int*]
params dict key value ecvar
build {
noalias $ecvar
nonnull $dict $key $ecvar
my condBr [my exists $value] $reallySet $reallyUnset
label reallySet "real.set"
set value [my unmaybe $value]
my ret [my Call tcl.dict.set1 $dict $key $value $ecvar]
label reallyUnset "real.unset"
my ret [my Call tcl.dict.unset1 $dict $key $ecvar]
}
##### Function tcl.dict.addIterReference #####
#
# Type signature: iter:DICTITER -> void
#
# Increments the reference count inside a dictionary iteration state.
................................................................................
label release:
my Call tcl.dict.addIterReference [my unmaybe $value]
my ret
}
##### Function tcl.dict.iterStart #####
#
# Type signature: dict:STRING * ecvar:int* -> DICTITER?
#
# Starts iterating over a dictionary. The current state of the
# iteration (assuming we don't get an error) is stored inside the
# returned iteration state value.
set f [$m local "tcl.dict.iterStart" DICTITER?<-STRING,int*]
params dict ecvar
build {
noalias $ecvar
nonnull $dict $ecvar
set done [my alloc int "done"]
set interp [$api tclInterp]
set iter [$api cknew DICTFOR]
set key [my gep $iter 0 DICTFOR.key]
SetValueName $key "keyPtr"
set value [my gep $iter 0 DICTFOR.value]
SetValueName $value "valuePtr"
set search [my gep $iter 0 DICTFOR.search]
set code [$api Tcl_DictObjFirst $interp $dict \
$search $key $value $done]
my condBr [my eq $code $0] $ok $failed
label ok:
my storeInStruct $iter DICTFOR.dict $dict
my storeInStruct $iter DICTFOR.ref $0
my storeInStruct $iter DICTFOR.done [my neq [my load $done] $0]
my addReference(STRING) $dict
my Call tcl.dict.addIterReference $iter
my ret [my ok $iter]
label failed:
$api ckfree $iter
my store $1 $ecvar
my ret [my fail DICTITER]
}
##### Function tcl.dict.iterNext #####
#
# Type signature: iter:DICTITER -> DICTITER
#
# Continues iterating over a dictionary. The current state of the
................................................................................
set obj [my phi [list $obj $new] [list $real $alloc] "obj"]
my addReference(STRING) $obj
my ret $obj
}
##### Function tcl.dict.iterDone #####
#
# Type signature: iter:DICTITER -> ZEROONE
#
# Gets whether this iteration of the dictionary has finished.
set f [$m local "tcl.dict.iterDone" ZEROONE<-DICTITER]
params iter
build {
nonnull $iter
my ret [my dereference $iter 0 DICTFOR.done]
}
##### Function tcl.dict.append #####
#
# Type signature: dict:STRING * key:STRING * value:STRING
# * ecvar:int32* -> STRING?
#
# Appends to value in a dictionary indicated by a key. Can fail if the
# "dict" is not a valid dictionary.
set f [$m local "tcl.dict.append" STRING?<-STRING,STRING,STRING,int*]
params dict key value ecvar
build {
noalias $ecvar
nonnull $dict $key $value $ecvar
set valuePtr [my alloc STRING "valuePtr"]
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjGet $interp $dict $key $valuePtr]
my condBr [my eq $result $0] $OK $notOK
label OK:
set dictVal [my load $valuePtr "value.in.dict"]
my condBr [my nonnull $dictVal] $append $set
label set:
$api Tcl_DictObjPut {} $dict $key $value
my br $done
label append:
my condBr [my shared $dictVal] $dupePut $directUpdate
................................................................................
set dictVal2 [$api Tcl_DuplicateObj $dictVal]
$api Tcl_AppendObjToObj $dictVal2 $value
set c [$api Tcl_DictObjPut {} $dict $key $dictVal2]
AddCallAttribute $c 3 nocapture
my br $done
label done:
my addReference(STRING) $dict
my ret [my ok $dict]
label notOK:
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.incr #####
#
# Type signature: dict:STRING * key:STRING * value:INT
# * ecvar:int32* -> STRING?
#
# Adds an integer to an integer in a dictionary indicated by a key.
# Can fail if the "dict" is not a valid dictionary or the value
# pointed to is not a valid integer.
set f [$m local "tcl.dict.incr" STRING?<-STRING,STRING,INT,int*]
params dict key value ecvar
build {
noalias $ecvar
nonnull $dict $key $ecvar
set valuePtr [my alloc STRING "valuePtr"]
set intVar [my alloc int64 "intPtr"]
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjGet $interp $dict $key $valuePtr]
my condBr [my eq $result $0] $OK $notOK
label OK:
set dictVal [my load $valuePtr "value.in.dict"]
my condBr [my nonnull $dictVal] $add $set
label set:
set strVal [my stringify(INT) $value "value"]
my br $done
label add:
# TODO: Revisit once we support bignums
................................................................................
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.lappend #####
#
# Type signature: dict:STRING * key:STRING * value:STRING
# * ecvar:int32* -> STRING?
#
# Appends to list in a dictionary indicated by a key. Can fail if the
# "dict" is not a valid dictionary or the value pointed to is not a
# valid list.
set f [$m local "tcl.dict.lappend" STRING?<-STRING,STRING,STRING,int*]
params dict key value ecvar
build {
noalias $ecvar
nonnull $dict $key $value $ecvar
set valuePtr [my alloc STRING "valuePtr"]
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjGet $interp $dict $key $valuePtr]
my condBr [my eq $result $0] $OK $notOK
label OK:
set dictVal [my load $valuePtr "value.in.dict"]
my condBr [my nonnull $dictVal] $append $set
label set:
my store $value $valuePtr
set newlist [$api Tcl_NewListObj $1 $valuePtr]
$api Tcl_DictObjPut {} $dict $key $newlist
my br $done
................................................................................
# None.
method StringComparisonFunctions {api} {
upvar 1 sizeof sizeof 0 0 1 1
##### Function tcl.streq #####
#
# Type signature: value1Ptr:STRING * value2Ptr:STRING -> ZEROONE
#
# Quadcode implementation ('streq')
#
# Returns whether the two string arguments are equal.
set f [$m local "tcl.streq" ZEROONE<-STRING,STRING]
params v1:value1Ptr v2:value2Ptr
build {
nonnull $v1 $v2
my condBr [my eq $v1 $v2] $identical $nexttest
label nexttest:
my condBr [my and [my isByteArray $v1] [my isByteArray $v2]] \
$cmpBA $nexttest2
................................................................................
set diff [my phi [list $diffBA $diffUni $diffUtf] $sources]
my ret [my select [my eq $match $0] $diff $match]
}
##### Function tcl.strmatch #####
#
# Type signature: nocase:INT * pattern:STRING * string:STRING
# -> ZEROONE
#
# Quadcode implementation ('strmatch')
#
# Returns whether the glob pattern in 'pattern' matches 'string'. If
# 'nocase' is non-zero, performs the match case-insensitively.
set f [$m local "tcl.strmatch" ZEROONE<-INT,STRING,STRING]
params nocaseInt:nocase patternObj:pattern stringObj:string
build {
nonnull $patternObj $stringObj
set nocase [my getInt32 $nocaseInt]
my condBr [my isUnicodeString $patternObj] $test2 $ordinary
label test2:
my condBr [my isUnicodeString $stringObj] $unicode $ordinary
................................................................................
$nocase]
my ret [my neq $match $0]
}
##### Function tcl.regexp #####
#
# Type signature: flags:INT * regexp:STRING * string:STRING
# * errVar:int* -> ZEROONE?
#
# Quadcode implementation ('regexp')
#
# Returns whether the regular expression in 'regexp' matches 'string'
# as a WRAPPED BOOLEAN. The 'flags' control things like whether we are
# matching case-insensitively. If the code fails (generally because of
# a bad regular expression) then the result is a Nothing. The variable
# pointed to by 'errVar' is set to the relevant Tcl result code.
set f [$m local "tcl.regexp" ZEROONE?<-INT,STRING,STRING,int*]
params flags patternObj:regexp stringObj:string errVar:errorCode
build {
noalias $errVar
nonnull $patternObj $stringObj $errVar
set interp [$api tclInterp]
set RE [$api Tcl_GetRegExpFromObj $interp $patternObj \
[my getInt32 $flags]]
................................................................................
set match [$api Tcl_RegExpExecObj $interp $RE $stringObj $0 $0 $0]
my condBr [my ge $match $0] $done $err
label done "re.done"
my store $0 $errVar
my ret [my ok [my gt $match $0]]
label err "re.error"
my store $1 $errVar
my ret [my fail ZEROONE]
}
}
# Builder:@apiFunctions --
#
# Generate the quadcode operator implementations that require access to
................................................................................
# Type signature: returnCode:INT -> STRING
#
# Quadcode implementation ('returnOptions')
#
# Returns the return options dictionary. Note that this requires the
# current Tcl result code in order to work correctly.
set f [$module local "tcl.getreturnopts" STRING<-INT]
params value:returnCode
build {
set code [my int.32 $value "code"]
set opts [$api Tcl_GetReturnOptions [$api tclInterp] $code]
SetValueName $opts "optionsObj"
my addReference(STRING) $opts
my ret $opts
}
##### Function tcl.initExceptionOptions #####
#
# Type signature: objPtr:STRING * dictPtr:STRING -> int
#
# Initialises the return options from what we know about an exception.
set f [$module local "tcl.initExceptionOptions" int<-STRING,STRING]
params result:objPtr opts:dictPtr
build {
nonnull $result $opts
set interp [$api tclInterp]
set code [$api Tcl_SetReturnOptions $interp $opts]
my switch $code $other 0 $ok 1 $error
label ok:
................................................................................
my store [my or [my load $field] [Const 0x800]] $field
my ret
}
##### Function tcl.processReturn #####
#
# Type signature: result:STRING * code:int * level:int
# * returnOpts:STRING -> int
#
# Initialises the return options from what we know about an exception.
# Analogous to TclProcessReturn, which isn't exposed.
#
# Note that returnOpts may be NULL; that's equivalent to an empty
# options dictionary, but is special-cased so it is handled more
# efficiently by the optimizer.
set f [$module local "tcl.processReturn" int<-STRING,int,int,STRING]
params result code level returnOpts
build {
nonnull $result
set valuePtr [my alloc STRING "valuePtr"]
set infoLen [my alloc int "infoLen"]
set objcPtr [my alloc int]
set objvPtr [my alloc STRING*]
................................................................................
my br $done
label done:
my ret
}
##### Function tcl.booleanTest #####
#
# Type signature: objPtr:Tcl_Obj* -> ZEROONE
#
# Part of quadcode implementation ('isBoolean')
#
# Returns whether the string 'objPtr' is a Boolean bareword
set f [$m local "tcl.booleanTest" ZEROONE<-Tcl_Obj*]
params objPtr
build {
nonnull $objPtr
set NULL [my null Interp*]
set code [my setFromAny [$api tclBooleanType] $NULL $objPtr]
my ret [my eq $code $0]
}
................................................................................
label fail:
my store $code $ecvar
my ret [my fail STRING $code]
}
##### Function tcl.existsOrError #####
#
# Type signature: exists:int1 * message:STRING * ecvar:int* -> int1
#
# Conditionally generates an error about a non-existing variable.
# Generated like this to avoid introducing extra basic blocks at the
# pre-optimized LLVM level.
set f [$module local "tcl.existsOrError" int1<-int1,STRING,STRING,int*]
params exists message exception ecvar
build {
noalias $message $ecvar
nonnull $message $exception $ecvar
my condBr $exists $doError $done
label doError:
my initException $exception $message $ecvar
................................................................................
my br $done
label done:
my ret $exists
}
##### Function tcl.not.string #####
#
# Type signature: value:STRING * ecvar:int* -> ZEROONE?
#
# Quadcode implementation ('not').
#
# Logical negation of 'value'.
set f [$m local "tcl.not.string" ZEROONE?<-STRING,int*]
params value ecvar
build {
noalias $ecvar
nonnull $value $ecvar
set bvar [my alloc int]
set interp [$api tclInterp]
set code [$api Tcl_GetBooleanFromObj $interp $value $bvar]
my condBr [my eq $code [Const 0]] $ok $fail
label fail:
my store [Const 1] $ecvar
my ret [my fail ZEROONE]
label ok:
my ret [my ok [my neq [my load $bvar "bool"] [Const 1]]]
}
my VariableHelperFunctions $api
my @variableFunctions $api
my @numericConverterFunctions $api
|
| | | | | | | | | | | | | | | | | | | | | | | | | < | < | < < | < < < | | | | | < | | | < < | | | < < < | | < < < | | < | < | < < | < < | | < < < | | | | | < | < | < < | | < < < | | | < < < < < < > > > > | | < < < | | < < | | < < < | | < | | < < | < < < | | | | < | < < | | > < < | | | | | | < | < < > | < < | | | | | | < | < < | | | | | < < | < < < < < < < < | | > > > > > > > > > > > > > > > > > | | | < < < > | | | < | | < | < | < < | < < < | | | | | < < < < | | | | | | < | | | < | < | < < | | < < < | < | < | | < | < | < < | | < < < < | | | < | | < | < | < < | < < < < | | | | | < | < | < | < | | | | < | | | < | | < < < | < < < < | | | < | < | | < | | < < | < < < < | | < | | | < < | | | < | | < < | | | | | | | | | | | | | | | | | | | |
48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 ... 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 ... 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 ... 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 ... 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 ... 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 .... 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 .... 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 .... 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 .... 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 .... 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 .... 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 .... 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 .... 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 .... 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 .... 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 .... 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 .... 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 .... 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 .... 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 .... 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 .... 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 .... 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 .... 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 .... 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 .... 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 .... 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 .... 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 .... 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 .... 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 .... 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 .... 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 .... 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 .... 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 .... 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 .... 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 .... 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 .... 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 .... 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 .... 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 .... 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 .... 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 .... 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 |
variable tcl.dict.get1 tcl.dict.get tcl.dict.set1 tcl.dict.set
variable tcl.dict.exists1 tcl.dict.exists tcl.dict.unset1 tcl.dict.unset
variable tcl.dict.iterStart tcl.dict.iterNext tcl.dict.iterDone
variable tcl.dict.iterKey tcl.dict.iterValue tcl.dict.addIterReference
variable tcl.dict.addIterFailReference
variable tcl.dict.dropIterReference tcl.dict.dropIterFailReference
variable tcl.dict.append tcl.dict.lappend tcl.dict.incr tcl.dict.size
variable tcl.dict.get1.empty tcl.dict.set1.empty tcl.isDict
variable tcl.maptoint
# Variables holding implementations of Tcl's exception-handling machinery
variable tcl.getresult tcl.getreturnopts tcl.initExceptionOptions
variable tcl.initExceptionSimple tcl.processReturn tcl.procedure.return
variable tcl.setErrorLine tcl.existsOrError tcl.logCommandInfo
variable tcl.handleExceptionResult tcl.invoke.command tcl.invoke.expanded
................................................................................
my assume [my eq $before $after]
my ret $result
}
##### Function tcl.isPureByteArray #####
##### Closure Build:isByteArray #####
#
# Type signature: objPtr:STRING -> bool
#
# Test if a STRING is actually a true byte array, that it can be
# processed as bytes and not as unicode characters.
set f [$m local "tcl.isPureByteArray" bool<-STRING readonly]
params objPtr
build {
nonnull $objPtr
set baType [$api tclByteArrayType]
set typePtr [my dereference $objPtr 0 Tcl_Obj.typePtr]
my condBr [my eq $baType $typePtr] $puretest $notBA
label puretest:
................................................................................
my closure isByteArray {STRING {name ""}} {
my call ${tcl.isPureByteArray} [list $STRING] $name
}
##### Function tcl.isUnicodeString #####
##### Closure Build:isUnicodeString #####
#
# Type signature: objPtr:STRING -> bool
#
# Test if a STRING is stored internally as a sequence of Tcl_UniChar
# (instead of as a sequence of Unicode characters encoded as UTF-8).
set f [$m local "tcl.isUnicodeString" bool<-STRING readonly]
params objPtr
build {
nonnull $objPtr
set strType [$api tclStringType]
set type [my dereference $objPtr 0 Tcl_Obj.typePtr]
my ret [my eq $type $strType]
}
................................................................................
my closure isUnicodeString {STRING {name ""}} {
my call ${tcl.isUnicodeString} [list $STRING] $name
}
##### Function tcl.impl.getBoolean #####
##### MAPPED CALL TO METHOD: Build:GetBoolean #####
#
# Type signature: valueObj:STRING -> bool*bool
set f [$m local "tcl.impl.getBoolean" struct{bool,bool}<-STRING]
params valueObj
build {
nonnull $valueObj
set boolVar [my alloc int32 "boolPtr"]
set str [$api Tcl_GetString $valueObj]
set code [$api Tcl_GetBooleanFromObj {} $valueObj $boolVar]
set res [my undef struct{bool,bool}]
set res [my insert $res [my eq $code [Const 0]] 0]
set res \
[my insert $res [my neq [my load $boolVar "bool"] [Const 0]] 1]
my ret $res
}
my closure GetBoolean {valueObj} {
my call ${tcl.impl.getBoolean} [list $valueObj] "result"
................................................................................
##### MAPPED CALL TO METHOD: Build:GetDouble #####
#
# Type signature: valueObj:STRING -> int * int8[]
#
# Gets the (pseudo-)UTF-8 version of a string. Wrapper around Tcl API
# to ensure that scope lifetime gets better understood.
set f [$m local "tcl.impl.getDouble" struct{bool,double}<-STRING]
my closure GetDouble {valueObj} {
my call ${tcl.impl.getDouble} [list $valueObj] "result"
}
params valueObj
build {
nonnull $valueObj
set dblVar [my alloc double "dblPtr"]
set code [$api Tcl_GetDoubleFromObj {} $valueObj $dblVar]
set res [my undef struct{bool,double}]
set res [my insert $res [my eq $code [Const 0]] 0]
set res [my insert $res [my load $dblVar "dbl"] 1]
my ret $res
}
unset -nocomplain valueObj
##### Function tcl.impl.getWide #####
................................................................................
##### MAPPED CALL TO METHOD: Build:GetWide #####
#
# Type signature: valueObj:STRING -> bool * int64
#
# Gets an int64 from a Tcl string. Wrapper around Tcl API to ensure
# that scope lifetime gets better understood.
set f [$m local "tcl.impl.getWide" struct{bool,int64}<-STRING]
my closure GetWide {valueObj {name "result"}} {
my call ${tcl.impl.getWide} [list $valueObj] $name
}
params valueObj
build {
nonnull $valueObj
set intVar [my alloc int64 "intPtr"]
................................................................................
set p5 [my phi [list $p2 $p4] [list $nextOuter $fixP] "p.5"]
my ret [my sub $numBytes1 [my cast(int) [my diff $p5 $bytes]]]
}
##### Function tcl.impl.isAscii #####
# Replacement for non-exposed UniCharIsAscii
#
# Type signature: ch:int16 -> bool
#
# Part of quadcode implementation ('strclass')
#
# Returns whether the character 'ch' is in the ASCII range.
set f [$m local "tcl.impl.isAscii" bool<-int16 readnone]
params ch
................................................................................
my ret [my and [my ge $ch [Const 0 int16]] \
[my lt $ch [Const 0x80 int16]]]
}
##### Function tcl.impl.isXdigit #####
# Replacement for non-exposed UniCharIsXdigit
#
# Type signature: ch:int16 -> bool
#
# Part of quadcode implementation ('strclass')
#
# Returns whether the character 'ch' is a hex digit.
set f [$m local "tcl.impl.isXdigit" bool<-int16 readnone]
params ch
................................................................................
my ret [Const true bool]
label not:
my ret [Const false bool]
}
##### Function tcl.strclass #####
#
# Type signature: objPtr:STRING * class:int32 -> bool
#
# Quadcode implementation ('strclass')
#
# Returns whether all the characters in the string 'objPtr' are in the
# character class given by 'class' (enumeration encoded as int32).
set f [$m local "tcl.strclass" bool<-STRING,int]
params objPtr class
build {
nonnull $objPtr
lassign [my GetUnicode $objPtr obj] length string
my condBr [my gt $length $0] $test $match
label test:
set end [my getelementptr $string [list $length]]
................................................................................
my ret [Const false bool]
}
##### Function tcl.impl.getIndex #####
##### Closure Build:GetIndex #####
#
# Type signature: interp:Interp* * objPtr:Tcl_Obj* * end:int
# -> bool * int
#
# Converts an index string into an offset into something (i.e., a
# string or list). Returns a tuple of whether the conversion succeeded
# (a boolean) and the index.
set f [$m local "tcl.impl.getIndex" \
struct{bool,int}<-Interp*,Tcl_Obj*,int readonly]
................................................................................
# Type signatures: obj:STRING -> {STRING,bool}
# objdupe:{STRING,bool} -> void
#
# Helpers for the dictionary updating functions that reduce the amount
# of explicit branch management in the code by factoring out common
# patterns of reference handling.
set f [$m local "obj.dedup" struct{STRING,bool}<-STRING]
params obj
build {
set duped [my shared $obj]
SetValueName $duped "duped"
set res [my insert [my undef struct{STRING,bool}] $duped 1]
my condBr $duped $duplicated $unshared
label duplicated:
set dupe [$api Tcl_DuplicateObj $obj]
SetValueName $dupe "duplicateObj"
my ret [my insert $res $dupe 0]
label unshared:
my ret [my insert $res $obj 0]
................................................................................
my closure Dedup {varName} {
upvar 1 $varName var
set token [my Call obj.dedup $var]
set var [my extract $token 0 [GetValueName $var]]
return $token
}
set f [$m local "obj.cleanup" void<-struct{STRING,bool}]
params objdupe
build {
my condBr [my extract $objdupe 1] $duplicated $unshared
label duplicated:
my dropReference [my extract $objdupe 0]
my ret
label unshared:
................................................................................
my ret $new
label fail:
my ret [my null STRING]
}
##### Function tcl.isList #####
#
# Type signature: objPtr:STRING -> bool
#
# Part of quadcode implementation ('isInstance')
#
# Wrapper around Tcl_ListObjLength that uses it to do a list-ness
# check.
set f [$m local "tcl.isList" bool<-STRING]
params objPtr
build {
nonnull $objPtr
set var [my alloc int "length"]
set code [$api Tcl_ListObjLength {} $objPtr $var]
my ret [my eq $code $0]
}
................................................................................
# Type signature: objc:int * objv:STRING* -> STRING
#
# Core of quadcode implementation ('list')
#
# Wrapper around Tcl_NewListObj that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.create" LIST<-int,STRING*]
params objc objv
build {
nonnull $objv
set val [$api Tcl_NewListObj $objc $objv]
my addReference(STRING) $val
my ret $val
}
##### Function tcl.list.length #####
#
# Type signature: list:LIST -> INT
#
# Core of quadcode implementation ('listLength')
#
# Wrapper around Tcl_ListObjLength that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.length" INT<-LIST]
params list
build {
nonnull $list
set var [my alloc int "length"]
$api Tcl_ListObjLength {} $list $var
my ret [my packInt32 [my load $var]]
}
##### Function tcl.list.verify #####
#
# Type signature: value:STRING * ecvar:int* -> LIST?
#
# Core of quadcode implementation ('verifyList')
#
# Wrapper around a list operation (Tcl_ListObjLength) that verifies
# that the value it is dealing with is a list; converting it to a FAIL
# if it is not.
set f [$m local "tcl.list.verify" LIST?<-STRING,int*]
params value ecvar
build {
noalias $value $ecvar
nonnull $value $ecvar
set var [my alloc int "length"]
set interp [$api tclInterp]
set code [$api Tcl_ListObjLength $interp $value $var]
................................................................................
label fail:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.append #####
#
# Type signature: list:LIST * value:STRING -> LIST
#
# Core of quadcode implementation ('listAppend')
#
# Wrapper around Tcl_ListObjLength that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.append" LIST<-LIST,STRING]
params list value
build {
nonnull $list $value
set interp [$api tclInterp]
my condBr [my shared $list] $shared $unshared
label shared "shared.duplicate"
set copy [my ListDupe $interp $list "copy"]
$api Tcl_ListObjAppendElement {} $copy $value
my br $return
label unshared:
$api Tcl_ListObjAppendElement {} $list $value
my br $return
label return:
set list [my phi [list $copy $list] [list $shared $unshared] "list"]
$api TclInvalidateStringRep $list
my addReference(STRING) $list
my condBr [my shared $value] $exit $extraRef
label extraRef "add.extra.reference.to.value"
my addReference(STRING) $value
my br $exit
label exit:
my ret $list
}
##### Function tcl.list.concat #####
#
# Type signature: list:LIST * value:LIST -> LIST
#
# Core of quadcode implementation ('listConcat')
set f [$m local "tcl.list.concat" LIST<-LIST,LIST]
params list value
build {
nonnull $list $value
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
$api Tcl_ListObjLength {} $list $objc
set len [my load $objc "len"]
$api Tcl_ListObjGetElements {} $value $objc $objv
my condBr [my shared $list] $dupe $concat
label dupe "duplicate"
set copy [my ListDupe {} $list "copy"]
my br $concat
label concat:
set working [PHI [Type LIST] {$list $copy} {$entry $dupe} "list"]
set objc [my load $objc "objc"]
set objv [my load $objv "objv"]
$api Tcl_ListObjReplace {} $working $len $0 $objc $objv
my addReference(STRING) $working
my ret $working
}
##### Function tcl.list.index #####
#
# Type signature: list:LIST * idxc:int * idxv:STRING* * ecvar:int*
# -> STRING?
#
# Core of quadcode implementation ('listIndex')
#
# Effectively an implementation of TclLindexFlat.
set f [$m local "tcl.list.index" STRING?<-LIST,int,STRING*,int*]
params list idxc idxv ecvar
build {
noalias $list $idxv $ecvar
nonnull $list $idxv $ecvar
set iPtr [my alloc int "&i"]
set listPtr [my alloc STRING "&list"]
set listLenPtr [my alloc int "&listLen"]
................................................................................
label error:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.index1 #####
#
# Type signature: list:LIST * index:INT -> STRING
#
# Core of quadcode implementation ('listIndex')
#
# Basic list indexing in the case where we know that the index is an
# integer, which avoids many of the failure modes.
set f [$m local "tcl.list.index1" STRING<-LIST,INT]
params list index
build {
nonnull $list
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set idx [my getInt32 $index]
$api Tcl_ListObjGetElements {} $list $objc $objv
my condBr [my and [my ge $idx $0] [my lt $idx [my load $objc]]] \
$realIndex $outOfBounds
label realIndex "real.index"
set objv [my load $objv "objv"]
set obj [my load [my getelementptr $objv [list $idx]] "objPtr"]
my addReference(STRING) $obj
my ret $obj
label outOfBounds "out.of.bounds"
set obj [$api Tcl_NewObj]
my addReference(STRING) $obj
my ret $obj
}
##### Function tcl.list.indexList #####
#
# Type signature: list:LIST * index:STRING * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('listIndex')
#
# Effectively an implementation of TclLindexList.
set f [$m local "tcl.list.indexList" STRING?<-LIST,STRING,int*]
params list index ecvar
build {
noalias $ecvar
nonnull $list $index $ecvar
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set interp [$api tclInterp]
$api Tcl_ListObjGetElements {} $list $objc $objv
my condBr [my neq [my dereference $index 0 Tcl_Obj.typePtr] \
[$api tclListType]] \
$checkIndex $slowPath
label checkIndex:
set len [my load $objc]
my condBr [my GetIndex {} $index $len idx] \
$immediateIndex $slowPath
................................................................................
[my gep $dupe 0 Tcl_Obj.internalRep 0] \
TclList*] "listRep"]
set result [my Call tcl.list.index \
$list [my dereference $listRep 0 TclList.elemCount] \
[my gep $listRep 0 TclList.elements] $ecvar]
my dropReference $dupe
my ret $result
label notList:
# We're not a list and we know it right now
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.range #####
#
# Type signature: list:LIST * from:STRING * to:STRING -> LIST?
#
# Core of quadcode implementation ('listRangeImm')
set f [$m local "tcl.list.range" LIST?<-LIST,STRING,STRING,int*]
params list from to ecvar
build {
noalias $ecvar
nonnull $list $from $to $ecvar
set objcVar [my alloc int]
set objvVar [my alloc STRING*]
set interp [$api tclInterp]
$api Tcl_ListObjLength {} $list $objcVar
set objc [my load $objcVar "objc"]
set endIndex [my sub $objc $1]
my condBr [my GetIndex $interp $from $endIndex from] $getTo $error
label getTo:
my condBr [my GetIndex $interp $to $endIndex to] $clamp $error
label clamp:
set from [my select [my lt $from ${-1}] \
................................................................................
label error:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.range1 #####
#
# Type signature: list:LIST * from:INT * to:INT -> LIST
#
# Core of quadcode implementation ('listRangeImm')
set f [$m local "tcl.list.range1" LIST<-LIST,INT,INT]
params list from to
build {
nonnull $list
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set interp [$api tclInterp]
set from [my getInt32 $from "from"]
set to [my getInt32 $to "to"]
$api Tcl_ListObjGetElements {} $list $objc $objv
set objc [my load $objc]
set objv [my load $objv]
set from [my select [my lt $from ${-1}] \
[my add $from [my add $1 $objc]] \
[my min $objc $from] \
"from"]
set from [my max ${-1} $from "from"]
................................................................................
label empty:
set r2 [$api Tcl_NewObj]
my br $ok
label ok:
set sources [list $sublistInplaceDone $sublistNew $empty]
set result [my phi [list $list $r1 $r2] $sources "result"]
my addReference(STRING) $result
my ret $result
}
##### Function tcl.list.set #####
#
# Type signature: list:LIST * idxc:int * idxv:STRING* * elem:STRING
# * ecvar:int* -> LIST?
#
# Core of quadcode implementation ('lset')
#
# Approximately equivalent to TclLsetFlat
set f [$m local "tcl.list.set" LIST?<-LIST,int,STRING*,STRING,int*]
params list idxc idxv elem ecvar
build {
noalias $idxv $ecvar
nonnull $list $idxv $elem $ecvar
set subList [my alloc STRING]
set chain [my alloc STRING]
set elemc [my alloc int]
................................................................................
# -> STRING?
#
# Core of quadcode implementation ('lset')
#
# Wrapper around TclListObjSetElement that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.set1" LIST?<-LIST,INT,STRING,int*]
params list idx elem ecvar
build {
noalias $ecvar
nonnull $list $elem $ecvar
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set idx [my getInt32 $idx "index"]
set duped [my Dedup list]
$api Tcl_ListObjGetElements {} $list $objc $objv
set objc [my load $objc]
my condBr [my or [my lt $idx $0] [my gt $idx $objc]] \
$error $checkOperation
label checkOperation "operation.check"
set rc [my refCount $list]
my condBr [my eq $idx $objc] $append $set
label append:
$api Tcl_ListObjAppendElement {} $list $elem
my br $done
label set:
................................................................................
my addReference(STRING) $list
my condBr [my shared $elem] $exit2 $exit3
label exit3 "exit"
my addReference(STRING) $elem
my br $exit2
label exit2 "exit"
my ret [my ok $list]
label error:
set interp [$api tclInterp]
$api Tcl_SetObjResult $interp \
[$api obj.constant "list index out of range"]
$api Tcl_SetObjErrorCode $interp \
[$api obj.constant {TCL OPERATION LSET BADINDEX}]
my Call obj.cleanup $duped
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.list.setList #####
#
# Type signature: list:LIST * idxArg:STRING * elem:STRING
# * ecvar:int* -> LIST?
#
# Core of quadcode implementation ('lset')
#
# Approximately equivalent to TclLsetList
set f [$m local "tcl.list.setList" LIST?<-LIST,STRING,STRING,int*]
params list idxArg elem ecvar
build {
noalias $ecvar
nonnull $list $idxArg $elem $ecvar
set ary [my alloc STRING]
set argc [my alloc int]
set argv [my alloc STRING*]
................................................................................
$list [my load $argc] [my load $argv] $elem $ecvar]
my dropReference $copy
my ret $code
}
##### Function tcl.list.in #####
#
# Type signature: value:STRING * list:LIST * ecVar:int* -> bool?
#
# Core of quadcode implementation ('listIn')
#
# Determines if the value is present in the list, using simple string
# comparison.
set f [$m local "tcl.list.in" bool<-STRING,LIST]
params value list
build {
nonnull $value $list
set lenVar [my alloc int]
set objvVar [my alloc STRING*]
lassign [my GetString $value "string"] len1 bytes1
$api Tcl_ListObjGetElements {} $list $lenVar $objvVar
set objc [my load $lenVar "objc"]
set objv [my load $objvVar "objv"]
my condBr [my gt $objc $0] $loop $notFound
label loop:
set i [PHI [Type int32] {$0 $iLoop} {$entry $loopNext} "i"]
set obj [my load [my getelementptr $objv [list $i]] "obj"]
lassign [my GetString $obj "element"] len2 bytes2
my condBr [my eq $len1 $len2] $loopCompare $loopNext
label loopCompare:
my condBr [my eq [my memcmp $bytes1 $bytes2 $len1] $0] \
$found $loopNext
label loopNext:
set iLoop [set i [my add $i $1 "i"]]
my condBr [my lt $i $objc] $loop $notFound
label notFound "not.found"
my ret [Const false bool]
label found:
my ret [Const true bool]
}
##### Function tcl.list.unshare #####
#
# Type signature: list:LIST -> LIST
#
# Core of quadcode implementation ('unshareList')
#
# Approximately equivalent to TclListObjCopy
set f [$m local "tcl.list.unshare" STRING<-STRING]
params list
................................................................................
my addReference(STRING) $copy
my ret $copy
}
##### Function tcl.list.foreach.start.step #####
#
# Type signature:
# nsteps:int? * list:LIST * stride:int -> nsteps:int?
#
# Core of quadcode implementation ('foreachStart')
#
# Works with one pair of list and assignment pattern, making sure
# that the list is really a list, and updating the number of iterations
# according to the given stride.
set f [$m local "tcl.list.foreach.start.step" \
int?<-int?,LIST,int]
params steps_init list stride
build {
noalias $list
nonnull $list
set objcVar [my alloc int]
set interp [$api tclInterp]
my condBr [my maybe $steps_init] $earlierError $listLength
label earlierError:
my ret $steps_init
label listLength:
$api Tcl_ListObjLength {} $list $objcVar
set steps_before [my unmaybe $steps_init]
set objc [my load $objcVar "objc"]
set count [my div [my add $objc [my sub $stride [Const 1 int]]] \
$stride "count"]
my ret [my ok [my max $steps_before $count "steps"]]
}
##### Function: tcl.list.foreach.start.finish #####
#
# Type signature: steps:int?,ecvar:int*->FAIL FOREACH
#
# After 'tcl.list.foreach.start.step' has run for each assignment
................................................................................
params pair
build {
my ret [my packInt32 [my extract $pair FOREACH.val]]
}
##### Function tcl.list.foreach.mayStep #####
#
# Type signature: pair:FOREACH -> bool
#
# Core of quadcode implementation ('foreachMayStep')
#
# Part of how lists are iterated over. This is broken up into several
# pieces because of the number of different things assigned to. This
# part gets whether the end of the iterations has been reached.
set f [$m local "tcl.list.foreach.mayStep" bool<-FOREACH readnone]
params pair
build {
set val [my extract $pair FOREACH.val]
set max [my extract $pair FOREACH.max]
my ret [my lt $val $max]
}
................................................................................
# Thunk class).
#
# Results:
# None.
method DictionaryFunctions {api} {
upvar 1 0 0 1 1
##### Function tcl.isDict #####
#
# Type signature: objPtr:STRING -> bool
#
# Part of quadcode implementation ('isInstance')
#
# Wrapper around Tcl_DictObjSize that uses it to do a dict-ness check.
set f [$m local "tcl.isDict" bool<-STRING]
params objPtr
build {
nonnull $objPtr
set var [my alloc int "length"]
set code [$api Tcl_DictObjSize {} $objPtr $var]
my ret [my eq $code $0]
}
##### Function tcl.dict.exists1 #####
#
# Type signature: dict:DICT * key:STRING -> bool
#
# Tests if a key is in a dictionary.
set f [$m local "tcl.dict.exists1" bool<-DICT,STRING]
params dict key
build {
nonnull $dict $key
set resvar [my alloc STRING "valueVar"]
my store [my null STRING] $resvar
set result [$api Tcl_DictObjGet {} $dict $key $resvar]
my ret [my and [my eq $result $0] \
[my nonnull [my load $resvar "value"]] \
"exists"]
}
##### Function tcl.dict.exists #####
#
# Type signature: dict:DICT * pathlen:int * pathobjs:STRING* -> bool
#
# Tests if a key is present in a dictionary. Never fails.
set f [$m local "tcl.dict.exists" bool<-DICT,int,STRING*]
params dict keyc keyv
build {
noalias $dict $keyv
nonnull $dict $keyv
set dummy [my alloc int "dummy"]
set resvar [my alloc STRING "valueVar"]
my condBr [my eq $keyc $0] $verify $exists
................................................................................
"exists"]
label notOK:
my ret [Const false bool]
}
##### Function tcl.dict.size #####
#
# Type signature: dict:DICT -> INT
#
# Gets the size of a dictionary.
set f [$m local "tcl.dict.size" INT<-DICT]
params dict
build {
nonnull $dict
set size [my alloc int "size"]
$api Tcl_DictObjSize {} $dict $size
my ret [my packInt32 [my load $size]]
}
##### Function tcl.dict.get1 #####
#
# Type signature: dict:DICT * key:STRING * ecvar:int32* -> STRING?
#
# Gets a value by key from a dictionary. Can fail if the key is
# absent.
set f [$m local "tcl.dict.get1" STRING?<-DICT,STRING,int*]
params dict key ecvar
build {
noalias $ecvar
nonnull $dict $key $ecvar
set resvar [my alloc STRING "valueVar"]
set interp [$api tclInterp]
$api Tcl_DictObjGet {} $dict $key $resvar
set value [my load $resvar "value"]
my condBr [my nonnull $value] $return $fail
label return:
my addReference(STRING) $value
my ret [my ok $value]
label fail:
set keyval [$api Tcl_GetString $key]
................................................................................
$api Tcl_SetObjResult $interp \
[$api Tcl_ObjPrintf [my constString \
"key \"%s\" not known in dictionary"] \
$keyval]
$api Tcl_SetErrorCode $interp \
[my constString TCL] [my constString LOOKUP] \
[my constString DICT] $keyval {}
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.get #####
#
# Type signature: dict:DICT * pathlen:int * pathobjs:STRING*
# * ecvar:int32* -> STRING?
#
# Gets a value by key from a dictionary. Can fail if a "dict" inside
# the dict is not a valid dictionary.
set f [$m local "tcl.dict.get" STRING?<-DICT,int,STRING*,int*]
params dict keyc keyv ecvar
build {
noalias $dict $keyv $ecvar
nonnull $dict $keyv $ecvar
set dummy [my alloc int "dummy"]
set resvar [my alloc STRING "valueVar"]
set interp [$api tclInterp]
................................................................................
label notOK:
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.get1.empty #####
#
# Type signature: dict:DICT * key:STRING -> STRING!
#
# Gets a value by key from a dictionary. An absent key in the terminal
# dictionary is reported as an NEXIST result.
set f [$m local "tcl.dict.get1.empty" STRING!<-DICT,STRING]
params dict key
build {
nonnull $dict $key
set resvar [my alloc STRING "valueVar"]
$api Tcl_DictObjGet {} $dict $key $resvar
set value [my load $resvar "value"]
my condBr [my nonnull $value] $return $empty
label return:
my addReference(STRING) $value
my ret [my just $value]
label empty:
my ret [my nothing STRING]
}
##### Function tcl.dict.set1 #####
#
# Type signature: dict:DICT * key:STRING * value:STRING -> DICT
#
# Sets a key in a dictionary to map to a value.
set f [$m local "tcl.dict.set1" DICT<-DICT,STRING,STRING]
params dict key value
build {
nonnull $dict $key $value
set dd [my Dedup dict]
$api Tcl_DictObjPut {} $dict $key $value
my addReference(STRING) $dict
my condBr [my shared $value] $exit2 $exit3
label exit3 "exit"
my addReference(STRING) $value
my ret $dict
label exit2 "exit"
my ret $dict
}
##### Function tcl.dict.set #####
#
# Type signature: dict:STRING * pathlen:int * pathobjs:STRING*
# * value:STRING * ecvar:int32* -> STRING?
#
# Sets a key (or rather a key path) in a dictionary to map to a value.
# Can fail if the "dict" is not a valid dictionary.
set f [$m local "tcl.dict.set" DICT?<-DICT,int,STRING*,STRING,int*]
params dict pathlen pathobjs value ecvar
build {
noalias $pathobjs $ecvar
nonnull $dict $pathobjs $value $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjPutKeyList $interp $dict $pathlen $pathobjs $value]
................................................................................
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.unset1 #####
#
# Type signature: dict:DICT * key:STRING -> DICT
#
# Removes a key from a dictionary.
set f [$m local "tcl.dict.unset1" DICT<-DICT,STRING]
params dict key
build {
nonnull $dict $key
set dd [my Dedup dict]
$api Tcl_DictObjRemove {} $dict $key
my addReference(STRING) $dict
my ret $dict
}
##### Function tcl.dict.unset #####
#
# Type signature: dict:DICT * pathlen:int * pathobjs:STRING*
# * ecvar:int32* -> DICT?
#
# Removes a key (or rather a key path) from a dictionary. Can fail if
# the dictionary contains a "dict" that is not a valid dictionary.
set f [$m local "tcl.dict.unset" DICT?<-DICT,int,STRING*,int*]
params dict pathlen pathobjs ecvar
build {
noalias $dict $pathobjs $ecvar
nonnull $dict $pathobjs $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjRemoveKeyList $interp $dict $pathlen $pathobjs]
................................................................................
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.set1.empty #####
#
# Type signature: dict:DICT * key:STRING * value:STRING! -> DICT
#
# Sets a key in a dictionary to map to a value, or removes the mapping
# if the value is NEXIST.
set f [$m local "tcl.dict.set1.empty" DICT<-DICT,STRING,STRING!]
params dict key value
build {
nonnull $dict $key
my condBr [my exists $value] $reallySet $reallyUnset
label reallySet "real.set"
set value [my unmaybe $value]
my ret [my Call tcl.dict.set1 $dict $key $value]
label reallyUnset "real.unset"
my ret [my Call tcl.dict.unset1 $dict $key]
}
##### Function tcl.dict.addIterReference #####
#
# Type signature: iter:DICTITER -> void
#
# Increments the reference count inside a dictionary iteration state.
................................................................................
label release:
my Call tcl.dict.addIterReference [my unmaybe $value]
my ret
}
##### Function tcl.dict.iterStart #####
#
# Type signature: dict:DICT -> DICTITER
#
# Starts iterating over a dictionary. The current state of the
# iteration is stored inside the returned iteration state value.
set f [$m local "tcl.dict.iterStart" DICTITER<-DICT]
params dict
build {
nonnull $dict
set done [my alloc int "done"]
set interp [$api tclInterp]
set iter [$api cknew DICTFOR]
set key [my gep $iter 0 DICTFOR.key]
SetValueName $key "keyPtr"
set value [my gep $iter 0 DICTFOR.value]
SetValueName $value "valuePtr"
set search [my gep $iter 0 DICTFOR.search]
$api Tcl_DictObjFirst $interp $dict $search $key $value $done
my storeInStruct $iter DICTFOR.dict $dict
my storeInStruct $iter DICTFOR.ref $0
my storeInStruct $iter DICTFOR.done [my neq [my load $done] $0]
my addReference(STRING) $dict
my Call tcl.dict.addIterReference $iter
my ret $iter
}
##### Function tcl.dict.iterNext #####
#
# Type signature: iter:DICTITER -> DICTITER
#
# Continues iterating over a dictionary. The current state of the
................................................................................
set obj [my phi [list $obj $new] [list $real $alloc] "obj"]
my addReference(STRING) $obj
my ret $obj
}
##### Function tcl.dict.iterDone #####
#
# Type signature: iter:DICTITER -> bool
#
# Gets whether this iteration of the dictionary has finished.
set f [$m local "tcl.dict.iterDone" bool<-DICTITER]
params iter
build {
nonnull $iter
my ret [my dereference $iter 0 DICTFOR.done]
}
##### Function tcl.dict.append #####
#
# Type signature: dict:DICT * key:STRING * value:STRING -> DICT
#
# Appends to value in a dictionary indicated by a key.
set f [$m local "tcl.dict.append" DICT<-DICT,STRING,STRING]
params dict key value
build {
nonnull $dict $key $value
set valuePtr [my alloc STRING "valuePtr"]
set interp [$api tclInterp]
set dd [my Dedup dict]
$api Tcl_DictObjGet {} $dict $key $valuePtr
set dictVal [my load $valuePtr "value.in.dict"]
my condBr [my nonnull $dictVal] $append $set
label set:
$api Tcl_DictObjPut {} $dict $key $value
my br $done
label append:
my condBr [my shared $dictVal] $dupePut $directUpdate
................................................................................
set dictVal2 [$api Tcl_DuplicateObj $dictVal]
$api Tcl_AppendObjToObj $dictVal2 $value
set c [$api Tcl_DictObjPut {} $dict $key $dictVal2]
AddCallAttribute $c 3 nocapture
my br $done
label done:
my addReference(STRING) $dict
my ret $dict
}
##### Function tcl.dict.incr #####
#
# Type signature: dict:DICT * key:STRING * value:INT
# * ecvar:int32* -> DICT?
#
# Adds an integer to an integer in a dictionary indicated by a key.
# Can fail if the value pointed to is not a valid integer.
set f [$m local "tcl.dict.incr" DICT?<-DICT,STRING,INT,int*]
params dict key value ecvar
build {
noalias $ecvar
nonnull $dict $key $ecvar
set valuePtr [my alloc STRING "valuePtr"]
set intVar [my alloc int64 "intPtr"]
set interp [$api tclInterp]
set dd [my Dedup dict]
$api Tcl_DictObjGet {} $dict $key $valuePtr
set dictVal [my load $valuePtr "value.in.dict"]
my condBr [my nonnull $dictVal] $add $set
label set:
set strVal [my stringify(INT) $value "value"]
my br $done
label add:
# TODO: Revisit once we support bignums
................................................................................
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my fail STRING]
}
##### Function tcl.dict.lappend #####
#
# Type signature: dict:DICT * key:STRING * value:STRING
# * ecvar:int32* -> DICT?
#
# Appends to list in a dictionary indicated by a key. Can fail if the
# value pointed to is not a valid list.
set f [$m local "tcl.dict.lappend" DICT?<-DICT,STRING,STRING,int*]
params dict key value ecvar
build {
noalias $ecvar
nonnull $dict $key $value $ecvar
set valuePtr [my alloc STRING "valuePtr"]
set interp [$api tclInterp]
set dd [my Dedup dict]
$api Tcl_DictObjGet {} $dict $key $valuePtr
set dictVal [my load $valuePtr "value.in.dict"]
my condBr [my nonnull $dictVal] $append $set
label set:
my store $value $valuePtr
set newlist [$api Tcl_NewListObj $1 $valuePtr]
$api Tcl_DictObjPut {} $dict $key $newlist
my br $done
................................................................................
# None.
method StringComparisonFunctions {api} {
upvar 1 sizeof sizeof 0 0 1 1
##### Function tcl.streq #####
#
# Type signature: value1Ptr:STRING * value2Ptr:STRING -> bool
#
# Quadcode implementation ('streq')
#
# Returns whether the two string arguments are equal.
set f [$m local "tcl.streq" bool<-STRING,STRING]
params v1:value1Ptr v2:value2Ptr
build {
nonnull $v1 $v2
my condBr [my eq $v1 $v2] $identical $nexttest
label nexttest:
my condBr [my and [my isByteArray $v1] [my isByteArray $v2]] \
$cmpBA $nexttest2
................................................................................
set diff [my phi [list $diffBA $diffUni $diffUtf] $sources]
my ret [my select [my eq $match $0] $diff $match]
}
##### Function tcl.strmatch #####
#
# Type signature: nocase:INT * pattern:STRING * string:STRING
# -> bool
#
# Quadcode implementation ('strmatch')
#
# Returns whether the glob pattern in 'pattern' matches 'string'. If
# 'nocase' is non-zero, performs the match case-insensitively.
set f [$m local "tcl.strmatch" bool<-INT,STRING,STRING]
params nocaseInt:nocase patternObj:pattern stringObj:string
build {
nonnull $patternObj $stringObj
set nocase [my getInt32 $nocaseInt]
my condBr [my isUnicodeString $patternObj] $test2 $ordinary
label test2:
my condBr [my isUnicodeString $stringObj] $unicode $ordinary
................................................................................
$nocase]
my ret [my neq $match $0]
}
##### Function tcl.regexp #####
#
# Type signature: flags:INT * regexp:STRING * string:STRING
# * errVar:int* -> bool?
#
# Quadcode implementation ('regexp')
#
# Returns whether the regular expression in 'regexp' matches 'string'
# as a WRAPPED BOOLEAN. The 'flags' control things like whether we are
# matching case-insensitively. If the code fails (generally because of
# a bad regular expression) then the result is a Nothing. The variable
# pointed to by 'errVar' is set to the relevant Tcl result code.
set f [$m local "tcl.regexp" bool?<-INT,STRING,STRING,int*]
params flags patternObj:regexp stringObj:string errVar:errorCode
build {
noalias $errVar
nonnull $patternObj $stringObj $errVar
set interp [$api tclInterp]
set RE [$api Tcl_GetRegExpFromObj $interp $patternObj \
[my getInt32 $flags]]
................................................................................
set match [$api Tcl_RegExpExecObj $interp $RE $stringObj $0 $0 $0]
my condBr [my ge $match $0] $done $err
label done "re.done"
my store $0 $errVar
my ret [my ok [my gt $match $0]]
label err "re.error"
my store $1 $errVar
my ret [my fail bool]
}
}
# Builder:@apiFunctions --
#
# Generate the quadcode operator implementations that require access to
................................................................................
# Type signature: returnCode:INT -> STRING
#
# Quadcode implementation ('returnOptions')
#
# Returns the return options dictionary. Note that this requires the
# current Tcl result code in order to work correctly.
set f [$module local "tcl.getreturnopts" DICT<-INT]
params value:returnCode
build {
set code [my int.32 $value "code"]
set opts [$api Tcl_GetReturnOptions [$api tclInterp] $code]
SetValueName $opts "optionsObj"
my addReference(STRING) $opts
my ret $opts
}
##### Function tcl.initExceptionOptions #####
#
# Type signature: objPtr:STRING * dictPtr:DICT -> int
#
# Initialises the return options from what we know about an exception.
set f [$module local "tcl.initExceptionOptions" int<-STRING,DICT]
params result:objPtr opts:dictPtr
build {
nonnull $result $opts
set interp [$api tclInterp]
set code [$api Tcl_SetReturnOptions $interp $opts]
my switch $code $other 0 $ok 1 $error
label ok:
................................................................................
my store [my or [my load $field] [Const 0x800]] $field
my ret
}
##### Function tcl.processReturn #####
#
# Type signature: result:STRING * code:int * level:int
# * returnOpts:DICT -> int
#
# Initialises the return options from what we know about an exception.
# Analogous to TclProcessReturn, which isn't exposed.
#
# Note that returnOpts may be NULL; that's equivalent to an empty
# options dictionary, but is special-cased so it is handled more
# efficiently by the optimizer.
set f [$module local "tcl.processReturn" int<-STRING,int,int,DICT]
params result code level returnOpts
build {
nonnull $result
set valuePtr [my alloc STRING "valuePtr"]
set infoLen [my alloc int "infoLen"]
set objcPtr [my alloc int]
set objvPtr [my alloc STRING*]
................................................................................
my br $done
label done:
my ret
}
##### Function tcl.booleanTest #####
#
# Type signature: objPtr:Tcl_Obj* -> bool
#
# Part of quadcode implementation ('isBoolean')
#
# Returns whether the string 'objPtr' is a Boolean bareword
set f [$m local "tcl.booleanTest" bool<-Tcl_Obj*]
params objPtr
build {
nonnull $objPtr
set NULL [my null Interp*]
set code [my setFromAny [$api tclBooleanType] $NULL $objPtr]
my ret [my eq $code $0]
}
................................................................................
label fail:
my store $code $ecvar
my ret [my fail STRING $code]
}
##### Function tcl.existsOrError #####
#
# Type signature: exists:bool * message:STRING * ecvar:int* -> bool
#
# Conditionally generates an error about a non-existing variable.
# Generated like this to avoid introducing extra basic blocks at the
# pre-optimized LLVM level.
set f [$module local "tcl.existsOrError" bool<-bool,STRING,STRING,int*]
params exists message exception ecvar
build {
noalias $message $ecvar
nonnull $message $exception $ecvar
my condBr $exists $doError $done
label doError:
my initException $exception $message $ecvar
................................................................................
my br $done
label done:
my ret $exists
}
##### Function tcl.not.string #####
#
# Type signature: value:STRING * ecvar:int* -> bool?
#
# Quadcode implementation ('not').
#
# Logical negation of 'value'.
set f [$m local "tcl.not.string" bool?<-STRING,int*]
params value ecvar
build {
noalias $ecvar
nonnull $value $ecvar
set bvar [my alloc int]
set interp [$api tclInterp]
set code [$api Tcl_GetBooleanFromObj $interp $value $bvar]
my condBr [my eq $code [Const 0]] $ok $fail
label fail:
my store [Const 1] $ecvar
my ret [my fail bool]
label ok:
my ret [my ok [my neq [my load $bvar "bool"] [Const 1]]]
}
my VariableHelperFunctions $api
my @variableFunctions $api
my @numericConverterFunctions $api
|
Changes to codegen/struct.tcl.
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
....
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
|
}
{{IMPURE DICT} STRING} {
append body2 { $} [lindex $f 0]
}
{{IMPURE EMPTY DICT} STRING} {
append body2 { $} [lindex $f 0]
}
{DICT STRING} {
append body2 { $} [lindex $f 0]
}
{{EMPTY DICT} STRING} {
append body2 { $} [lindex $f 0]
}
{{IMPURE LIST} STRING} {
................................................................................
}
{{IMPURE EMPTY LIST} STRING} {
append body2 { $} [lindex $f 0]
}
{{EMPTY LIST} STRING} {
append body2 { $} [lindex $f 0]
}
{LIST STRING} {
append body2 { $} [lindex $f 0]
}
{DICT LIST} {
append body2 { $} [lindex $f 0]
}
{{EMPTY DICT} {EMPTY LIST}} {
append body2 { $} [lindex $f 0]
}
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
....
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
|
}
{{IMPURE DICT} STRING} {
append body2 { $} [lindex $f 0]
}
{{IMPURE EMPTY DICT} STRING} {
append body2 { $} [lindex $f 0]
}
{{IMPURE EMPTY DICT} DICT} {
append body2 { $} [lindex $f 0]
}
{{EMPTY DICT} DICT} {
append body2 { $} [lindex $f 0]
}
{DICT STRING} {
append body2 { $} [lindex $f 0]
}
{{EMPTY DICT} STRING} {
append body2 { $} [lindex $f 0]
}
{{IMPURE LIST} STRING} {
................................................................................
}
{{IMPURE EMPTY LIST} STRING} {
append body2 { $} [lindex $f 0]
}
{{EMPTY LIST} STRING} {
append body2 { $} [lindex $f 0]
}
{EMPTY {EMPTY LIST}} {
append body2 { $} [lindex $f 0]
}
{EMPTY {EMPTY DICT}} {
append body2 { $} [lindex $f 0]
}
{LIST STRING} {
append body2 { $} [lindex $f 0]
}
{{IMPURE EMPTY LIST} LIST} {
append body2 { $} [lindex $f 0]
}
{{EMPTY LIST} LIST} {
append body2 { $} [lindex $f 0]
}
{DICT LIST} {
append body2 { $} [lindex $f 0]
}
{{EMPTY DICT} {EMPTY LIST}} {
append body2 { $} [lindex $f 0]
}
|
Changes to codegen/thunk.tcl.
470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
$b condBr [$b maybe $result] $isFail $next
$isFail build $b {
$b ret [$b extract $result 0]
}
$next build-in $b
set result [$b unmaybe $result]
}
set resultType [string map {{EMPTY STRING} STRING} [string map {DICT STRING LIST STRING} $resultType]]
if {[regexp "^IMPURE (.*)" $resultType -> payload]} {
if {$payload ne "STRING"} {
set result [$b impure.string $result]
SetValueName $result @result
}
set resultType STRING
}
|
> > | |
470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 |
$b condBr [$b maybe $result] $isFail $next
$isFail build $b {
$b ret [$b extract $result 0]
}
$next build-in $b
set result [$b unmaybe $result]
}
set resultType [string map {
{EMPTY STRING} STRING
} [string map {DICT STRING LIST STRING} $resultType]]
if {[regexp "^IMPURE (.*)" $resultType -> payload]} {
if {$payload ne "STRING"} {
set result [$b impure.string $result]
SetValueName $result @result
}
set resultType STRING
}
|
Changes to quadcode/translate.tcl.
487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 ... 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 ... 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 ... 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 ... 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 |
set value [list temp $depth]
set key [list temp [incr depth]]
set done [list temp [incr depth]]
my generate-scalar-check $pc $var {TCL WRITE VARNAME} \
"can't set \"%s\": variable is array"
my generate-dict-domain-check $pc [lindex $insn 0] $dict
my quads purify {temp opd0} $dict
my error-quads $pc dictIterStart $var {temp opd0}
my quads dictIterKey $key $var
my quads dictIterValue $value $var
my quads dictIterDone $done $var
}
dictNext {
set var [my index-to-var [lindex $insn 1]]
set value [list temp $depth]
................................................................................
set val [list temp [incr depth -1]]
set idx 0
foreach v [dict get $aux variables] {
set r [my index-to-var $v]
my generate-scalar-check $pc $r {TCL WRITE VARNAME} \
"can't set \"%s\": variable is array"
my error-quads $pc listIndex $mid $val [list literal $idx]
my error-quads $pc dictGetOrNexist $r $var $mid
incr idx
}
}
dictUpdateEnd {
set var [my index-to-var [lindex $insn 1]]
set auxNum [string range [lindex $insn 2] 1 end]
set aux [lindex [dict get $bytecode auxiliary] $auxNum]
................................................................................
set isary [list temp opnd2]
set mid [list temp opnd3]
set updating [list temp opnd4]
set val [list temp [incr depth -1]]
set idx 0
my generate-scalar-check $pc $var {TCL WRITE VARNAME} \
"can't write \"%s\": variable is array"
my quads copy $updating $var
foreach v [dict get $aux variables] {
set r [my index-to-var $v]
my error-quads $pc listIndex $key $val [list literal $idx]
incr idx
# Convert an ARRAY into a NEXIST here; ARRAY is unreadable
# so treat as NEXIST...
my quads arrayExists $isary $r
set n [llength $quads]
my quads jumpFalse [list pc [expr {$n + 3}]] $isary
my quads copy $mid Nothing
my quads jump [list pc [expr {$n + 4}]]
my quads extractScalar $mid $r
# Write the value to the right key of the dict
my error-quads $pc dictSetOrUnset $updating $updating $key $mid
}
my quads copy $var $updating
}
unsetScalar {
# TODO - This doesn't complain on unsetting a nonexistent
# variable, it ignores '-nocomplain'
set var [my index-to-var [lindex $insn 2]]
................................................................................
my quads purify {temp opd0} $val
my quads dictExists $r {temp opd0} {*}[lreverse $q]
}
dictSet {
set idxNum [expr [lindex $insn 1]]
set var [my index-to-var [lindex $insn 2]]
set val [list temp [incr depth -1]]
set q {}
for {set i 0} {$i < $idxNum} {incr i} {
# NOTE: Reversed
lappend q [list temp [incr depth -1]]
}
set r [list temp $depth]
my generate-scalar-check $pc $var {TCL READ VARNAME} \
"can't read \"%s\": variable is array"
my quads initIfNotExists $var $var {literal {}}
my generate-dict-domain-check $pc [lindex $insn 0] $var
my quads purify {temp opd0} $var
my error-quads $pc dictSet $r {temp opd0} $val {*}[lreverse $q]
my quads copy $var $r
}
dictUnset {
set idxNum [expr [lindex $insn 1]]
set var [my index-to-var [lindex $insn 2]]
set q {}
for {set i 0} {$i < $idxNum} {incr i} {
# NOTE: Reversed
................................................................................
}
set r [list temp $depth]
my generate-scalar-check $pc $var {TCL READ VARNAME} \
"can't read \"%s\": variable is array"
my quads initIfNotExists $var $var {literal {}}
my generate-dict-domain-check $pc [lindex $insn 0] $var
my quads purify {temp opd0} $var
my error-quads $pc dictUnset $r {temp opd0} {*}[lreverse $q]
my quads copy $var $r
}
dictAppend - dictLappend {
set var [my index-to-var [lindex $insn 1]]
set val [list temp [incr depth -1]]
set key [list temp [incr depth -1]]
set res [list temp $depth]
my generate-scalar-check $pc $var {TCL READ VARNAME} \
"can't read \"%s\": variable is array"
my quads initIfNotExists $var $var {literal {}}
my generate-dict-domain-check $pc [lindex $insn 0] $var
my quads purify {temp opd0} $var
my error-quads $pc [lindex $insn 0] $res {temp opd0} $key $val
my quads copy $var $res
}
dictIncrImm {
set delta [list literal [lindex $insn 1]]
set var [my index-to-var [lindex $insn 2]]
set key [list temp [incr depth -1]]
set res [list temp $depth]
|
| | > | | > < | > > > | > | > > > | > > > > > | > |
487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 ... 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 ... 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 ... 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 ... 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 |
set value [list temp $depth]
set key [list temp [incr depth]]
set done [list temp [incr depth]]
my generate-scalar-check $pc $var {TCL WRITE VARNAME} \
"can't set \"%s\": variable is array"
my generate-dict-domain-check $pc [lindex $insn 0] $dict
my quads purify {temp opd0} $dict
my quads dictIterStart $var {temp opd0}
my quads dictIterKey $key $var
my quads dictIterValue $value $var
my quads dictIterDone $done $var
}
dictNext {
set var [my index-to-var [lindex $insn 1]]
set value [list temp $depth]
................................................................................
set val [list temp [incr depth -1]]
set idx 0
foreach v [dict get $aux variables] {
set r [my index-to-var $v]
my generate-scalar-check $pc $r {TCL WRITE VARNAME} \
"can't set \"%s\": variable is array"
my error-quads $pc listIndex $mid $val [list literal $idx]
my quads dictGetOrNexist $r $var $mid
incr idx
}
}
dictUpdateEnd {
set var [my index-to-var [lindex $insn 1]]
set auxNum [string range [lindex $insn 2] 1 end]
set aux [lindex [dict get $bytecode auxiliary] $auxNum]
................................................................................
set isary [list temp opnd2]
set mid [list temp opnd3]
set updating [list temp opnd4]
set val [list temp [incr depth -1]]
set idx 0
my generate-scalar-check $pc $var {TCL WRITE VARNAME} \
"can't write \"%s\": variable is array"
my generate-dict-domain-check $pc [lindex $insn 0] $var
my quads purify $updating $var
foreach v [dict get $aux variables] {
set r [my index-to-var $v]
my error-quads $pc listIndex $key $val [list literal $idx]
incr idx
# Convert an ARRAY into a NEXIST here; ARRAY is unreadable
# so treat as NEXIST...
my quads arrayExists $isary $r
set n [llength $quads]
my quads jumpFalse [list pc [expr {$n + 3}]] $isary
my quads copy $mid Nothing
my quads jump [list pc [expr {$n + 4}]]
my quads extractScalar $mid $r
# Write the value to the right key of the dict
my quads dictSetOrUnset $updating $updating $key $mid
}
my quads copy $var $updating
}
unsetScalar {
# TODO - This doesn't complain on unsetting a nonexistent
# variable, it ignores '-nocomplain'
set var [my index-to-var [lindex $insn 2]]
................................................................................
my quads purify {temp opd0} $val
my quads dictExists $r {temp opd0} {*}[lreverse $q]
}
dictSet {
set idxNum [expr [lindex $insn 1]]
set var [my index-to-var [lindex $insn 2]]
set val [list temp [incr depth -1]]
set vartmp {temp opd0}
set q {}
for {set i 0} {$i < $idxNum} {incr i} {
# NOTE: Reversed
lappend q [list temp [incr depth -1]]
}
my generate-scalar-check $pc $var {TCL READ VARNAME} \
"can't read \"%s\": variable is array"
my quads initIfNotExists $var $var {literal {}}
my generate-dict-domain-check $pc [lindex $insn 0] $var
my quads purify $vartmp $var
if {[llength $q] == 1} {
my quads dictSet $vartmp $vartmp $val {*}$q
} else {
my error-quads $pc dictSet $vartmp $vartmp $val {*}[lreverse $q]
}
my quads copy $var $vartmp
}
dictUnset {
set idxNum [expr [lindex $insn 1]]
set var [my index-to-var [lindex $insn 2]]
set q {}
for {set i 0} {$i < $idxNum} {incr i} {
# NOTE: Reversed
................................................................................
}
set r [list temp $depth]
my generate-scalar-check $pc $var {TCL READ VARNAME} \
"can't read \"%s\": variable is array"
my quads initIfNotExists $var $var {literal {}}
my generate-dict-domain-check $pc [lindex $insn 0] $var
my quads purify {temp opd0} $var
if {[llength $q] == 1} {
my quads dictUnset $r {temp opd0} {*}$q
} else {
my error-quads $pc dictUnset $r {temp opd0} {*}[lreverse $q]
}
my quads copy $var $r
}
dictAppend - dictLappend {
set var [my index-to-var [lindex $insn 1]]
set val [list temp [incr depth -1]]
set key [list temp [incr depth -1]]
set res [list temp $depth]
my generate-scalar-check $pc $var {TCL READ VARNAME} \
"can't read \"%s\": variable is array"
my quads initIfNotExists $var $var {literal {}}
my generate-dict-domain-check $pc [lindex $insn 0] $var
my quads purify {temp opd0} $var
if {[lindex $insn 0] eq "dictAppend"} {
my quads [lindex $insn 0] $res {temp opd0} $key $val
} else {
# dictLappend can fail if value in dict is non-list
my error-quads $pc [lindex $insn 0] $res {temp opd0} $key $val
}
my quads copy $var $res
}
dictIncrImm {
set delta [list literal [lindex $insn 1]]
set var [my index-to-var [lindex $insn 2]]
set key [list temp [incr depth -1]]
set res [list temp $depth]
|
Changes to quadcode/types.tcl.
645 646 647 648 649 650 651 652 653 654 655 656 657 658 ... 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 ... 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 |
eq -
ge -
gt -
instanceOf -
isBoolean -
land -
le -
lor -
lt -
neq -
strclass -
streq -
strmatch -
strneq {
................................................................................
if {istype($t,$NUMERIC|$BOOLWORD)} {
return $ZEROONE
} else {
puts "which might FAIL"
return [expr {$ZEROONE | $FAIL}]
}
}
regexp - listIn {
return [expr {$ZEROONE | $FAIL}]
}
listLength - dictSize {
return [expr {$INT | $FAIL}]
}
phi {
set r 0
foreach {from operand} [lrange $q 2 end] {
set r [expr {$r | [typeOfOperand $types $operand]}]
}
return $r
................................................................................
extractCallFrame {
# Trim the non-callframe part
return $CALLFRAME
}
list - unshareList {
return $LIST
}
result - returnOptions -
dictIterKey - dictIterValue -
concat - strcat - strmap - strtrim - strcase {
return $STRING
}
foreachAdvance {
return $FOREACH
}
foreachStart {
return [expr {$FOREACH | $FAIL}]
}
listAppend - listConcat - listIndex - listRange - listSet {
return [expr {$LIST | $FAIL}]
}
strindex - strrange - strreplace - dictGet {
return [expr {$STRING | $FAIL}]
}
dictSet - dictSetOrUnset - dictUnset -
dictAppend - dictIncr - dictLappend {
return [expr {$DICT | $FAIL}]
}
dictGetOrNexist {
return [expr {$STRING | $FAIL | $NEXIST}]
}
arrayGet {
return [expr {$STRING | $NEXIST}]
}
arraySet - arrayUnset - initArray {
return $ARRAY
}
dictIterStart {
return [expr {$DICTITER | $FAIL}]
}
dictIterNext {
return $DICTITER
}
initIfNotExists {
set vartype [typeOfOperand $types [lindex $q 2]]
set deftype [typeOfOperand $types [lindex $q 3]]
return [expr {$deftype | ($vartype & ~$NEXIST)}]
}
|
> | | | > > | | > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | | | < < < |
645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 ... 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 ... 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 |
eq - ge - gt - instanceOf - isBoolean - land - le - listIn - lor - lt - neq - strclass - streq - strmatch - strneq { ................................................................................ if {istype($t,$NUMERIC|$BOOLWORD)} { return $ZEROONE } else { puts "which might FAIL" return [expr {$ZEROONE | $FAIL}] } } regexp { return [expr {$ZEROONE | $FAIL}] } listLength - dictSize { return $INT } phi { set r 0 foreach {from operand} [lrange $q 2 end] { set r [expr {$r | [typeOfOperand $types $operand]}] } return $r ................................................................................ extractCallFrame { # Trim the non-callframe part return $CALLFRAME } list - unshareList { return $LIST } returnOptions { return $DICT } result - dictIterKey - dictIterValue - concat - strcat - strmap - strtrim - strcase { return $STRING } foreachAdvance { return $FOREACH } foreachStart { return [expr {$FOREACH | $FAIL}] } listAppend - listConcat { return $LIST } listIndex { if {[llength $q] == 4} { set t2 [typeOfOperand $types [lindex $q 3]] if {istype($t2, $INT) || istype($t2, $ZEROONE)} { return $STRING } } elseif {[llength $q] == 3} { return [typeOfOperand $types [lindex $q 2]] } return [expr {$STRING | $FAIL}] } listRange { set t1 [typeOfOperand $types [lindex $q 3]] set t2 [typeOfOperand $types [lindex $q 3]] if {(istype($t1, $INT) || istype($t1, $ZEROONE)) && (istype($t2, $INT) || istype($t2, $ZEROONE))} { return $LIST } return [expr {$LIST | $FAIL}] } listSet { puts [format "DEBUG: %s : %s" [lindex $q 0] [lmap arg [lrange $q 2 end] {nameOfType [typeOfOperand $types $arg]}]] return [expr {$LIST | $FAIL}] } strindex - strrange - strreplace - dictGet { return [expr {$STRING | $FAIL}] } dictSetOrUnset - dictAppend { return $DICT } dictUnset { if {[llength $q] == 4} { return $DICT } else { return [expr {$DICT | $FAIL}] } } dictSet { if {[llength $q] == 5} { return $DICT } else { return [expr {$DICT | $FAIL}] } } dictIncr - dictLappend { return [expr {$DICT | $FAIL}] } dictGetOrNexist { return [expr {$STRING | $NEXIST}] } arrayGet { return [expr {$STRING | $NEXIST}] } arraySet - arrayUnset - initArray { return $ARRAY } dictIterStart - dictIterNext { return $DICTITER } initIfNotExists { set vartype [typeOfOperand $types [lindex $q 2]] set deftype [typeOfOperand $types [lindex $q 3]] return [expr {$deftype | ($vartype & ~$NEXIST)}] } |