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.371 |
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 | # The concatenated value as an LLVM value reference. method concat() {vector {name ""}} { my ExtractVector $vector my call ${tcl.concatenate} [list $len $ary] $name } | | | < | < | | | | | > > | > | | > > | > | | | | | | | < | | | | < < | | > > > | > | | | | | < | < | | | | 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 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 | # 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. # key - The key as an LLVM value reference. # value - The amount to increment by 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'). |
︙ | ︙ | |||
2358 2359 2360 2361 2362 2363 2364 | # Results: # The termination flag as an LLVM ZEROONE value reference. method dictIterDone {iter {name ""}} { my call ${tcl.dict.iterDone} [list $iter] $name } | | | | | | | | | | | > > > > > > > > > > > | > > > | > > > | > > > > > > > > > > > > > > > > > > > > | > > > > > | > > > > > > > > > > > > > | < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | | | > > | > | | | | | | < < < | | | | 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 | # 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 |
︙ | ︙ | |||
3044 3045 3046 3047 3048 3049 3050 | # None. method dropReference {value} { my Call tcl.dropReference $value return } | | | | | | | | 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 | # 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 |
︙ | ︙ | |||
4893 4894 4895 4896 4897 4898 4899 | } } else { set len [Const 0] } my call ${tcl.list.create} [list $len [my gep $objv 0 0]] $name } | | < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > | > > | > | | | | | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < | | < < | | < < < | | | > > | > | > > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < < < < < < < < < < < < < < < < < | | | > > > | | | | | | > > > > | | | | | > > > | | | | | | > > > | 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 | } } 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'). |
︙ | ︙ | |||
5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 | 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: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 | 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 | "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}] | < > > > | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 | "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] |
︙ | ︙ | |||
607 608 609 610 611 612 613 | my StoreResult $tgt $res $b clearVector $vector } if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode [$b maybe $res] } } | | > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 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}] |
︙ | ︙ | |||
1373 1374 1375 1376 1377 1378 1379 | 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] } | | | 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 | 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] } |
︙ | ︙ | |||
1512 1513 1514 1515 1516 1517 1518 | 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} { | > > > | > | 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 | 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 | 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 | | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | 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 |
︙ | ︙ | |||
687 688 689 690 691 692 693 | my assume [my eq $before $after] my ret $result } ##### Function tcl.isPureByteArray ##### ##### Closure Build:isByteArray ##### # | | | | 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 | 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: |
︙ | ︙ | |||
714 715 716 717 718 719 720 | my closure isByteArray {STRING {name ""}} { my call ${tcl.isPureByteArray} [list $STRING] $name } ##### Function tcl.isUnicodeString ##### ##### Closure Build:isUnicodeString ##### # | | | | | | | | | | 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 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 | 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" } unset -nocomplain valueObj ##### Function tcl.impl.getDouble ##### ##### 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"] |
︙ | ︙ | |||
1091 1092 1093 1094 1095 1096 1097 | 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 # | | | | 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 | 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 build { 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 |
︙ | ︙ | |||
1129 1130 1131 1132 1133 1134 1135 | my ret [Const true bool] label not: my ret [Const false bool] } ##### Function tcl.strclass ##### # | | | | 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 | 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]] |
︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 | my ret [Const false bool] } ##### Function tcl.impl.getIndex ##### ##### Closure Build:GetIndex ##### # # Type signature: interp:Interp* * objPtr:Tcl_Obj* * end:int | | | 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 | 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] |
︙ | ︙ | |||
1341 1342 1343 1344 1345 1346 1347 | # 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. | | | | | 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 | # 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: |
︙ | ︙ | |||
2041 2042 2043 2044 2045 2046 2047 | my ret $new label fail: my ret [my null STRING] } ##### Function tcl.isList ##### # | | | | | | | < | < | < < | < < < | | | | | < | | | < < | | | < < < | | < < < | | < | < | < < | < < | | < < < | | | 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 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 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 | 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] } ##### Function tcl.list.create ##### # # 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] my condBr [my eq $code $0] $ok $fail label ok: $api Tcl_IncrRefCount $value my ret [my ok $value] 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"] |
︙ | ︙ | |||
2286 2287 2288 2289 2290 2291 2292 | label error: my store $1 $ecvar my ret [my fail STRING] } ##### Function tcl.list.index1 ##### # | | | | < | < | < < | | < < < | | | < < < < < < | 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 | 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 |
︙ | ︙ | |||
2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 | [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 ##### # | > > > > | | < < < | | < < | 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 | [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}] \ |
︙ | ︙ | |||
2470 2471 2472 2473 2474 2475 2476 | label error: my store $1 $ecvar my ret [my fail STRING] } ##### Function tcl.list.range1 ##### # | | | < < < | | < | | < < | 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 | 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"] |
︙ | ︙ | |||
2549 2550 2551 2552 2553 2554 2555 | 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 | | < < < | | | | 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 | 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] |
︙ | ︙ | |||
2710 2711 2712 2713 2714 2715 2716 | # -> STRING? # # Core of quadcode implementation ('lset') # # Wrapper around TclListObjSetElement that exposes it to the general # instruction issuing code. | | < | < < | | > < < | | | | 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 2689 2690 2691 2692 2693 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 | # -> 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: set call [$api TclListObjSetElement {} $list $idx $elem] my br $done label done: my assume [my eq $rc [my refCount $list]] $api TclInvalidateStringRep $list 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*] |
︙ | ︙ | |||
2795 2796 2797 2798 2799 2800 2801 | $list [my load $argc] [my load $argv] $elem $ecvar] my dropReference $copy my ret $code } ##### Function tcl.list.in ##### # | | | | < | < < > | < < | | | | | < | | < < | | | 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 | $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 |
︙ | ︙ | |||
2862 2863 2864 2865 2866 2867 2868 | my addReference(STRING) $copy my ret $copy } ##### Function tcl.list.foreach.start.step ##### # # Type signature: | | | | < < | < < < < < < < < | 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 | 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 |
︙ | ︙ | |||
2943 2944 2945 2946 2947 2948 2949 | params pair build { my ret [my packInt32 [my extract $pair FOREACH.val]] } ##### Function tcl.list.foreach.mayStep ##### # | | | | 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 | 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] } |
︙ | ︙ | |||
2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 | # Thunk class). # # Results: # None. method DictionaryFunctions {api} { upvar 1 0 0 1 1 ##### Function tcl.dict.exists1 ##### # | > > > > > > > > > > > > > > > > > | | | < < | | | 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 | # 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 |
︙ | ︙ | |||
3047 3048 3049 3050 3051 3052 3053 | "exists"] label notOK: my ret [Const false bool] } ##### Function tcl.dict.size ##### # | | | < | | < | < | < < | < < < | | | | | < < < < | | | | | 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 | "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] |
︙ | ︙ | |||
3158 3159 3160 3161 3162 3163 3164 | label notOK: my store $1 $ecvar my ret [my fail STRING] } ##### Function tcl.dict.get1.empty ##### # | | | < | | | < | < | < < | | < < < | < | < | | < | < | < < | | < < < < | | 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 | 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] |
︙ | ︙ | |||
3250 3251 3252 3253 3254 3255 3256 | my Call obj.cleanup $dd my store $1 $ecvar my ret [my fail STRING] } ##### Function tcl.dict.unset1 ##### # | | | < | | < | < | < < | < < < < | | | | | < | < | < | < | | | | 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 | 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 condBr [my eq $result $0] $OK $notOK label OK: my ret [my ok $dict] label notOK: 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. |
︙ | ︙ | |||
3357 3358 3359 3360 3361 3362 3363 | label release: my Call tcl.dict.addIterReference [my unmaybe $value] my ret } ##### Function tcl.dict.iterStart ##### # | | < | | | < | | < < < | < < < < | 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 | 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 |
︙ | ︙ | |||
3513 3514 3515 3516 3517 3518 3519 | set obj [my phi [list $obj $new] [list $real $alloc] "obj"] my addReference(STRING) $obj my ret $obj } ##### Function tcl.dict.iterDone ##### # | | | | < | < | | < | | < < | < < < < | | < | | | < < | 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 3446 3447 3448 3449 3450 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 | 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 label directUpdate: $api Tcl_AppendObjToObj $dictVal $value $api TclInvalidateStringRep $dict my br $done label dupePut: 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 |
︙ | ︙ | |||
3619 3620 3621 3622 3623 3624 3625 | my Call obj.cleanup $dd my store $1 $ecvar my ret [my fail STRING] } ##### Function tcl.dict.lappend ##### # | | | | < | | < < | 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 | 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 |
︙ | ︙ | |||
3690 3691 3692 3693 3694 3695 3696 | # None. method StringComparisonFunctions {api} { upvar 1 sizeof sizeof 0 0 1 1 ##### Function tcl.streq ##### # | | | | 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 | # 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 |
︙ | ︙ | |||
3797 3798 3799 3800 3801 3802 3803 | 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 | | | | 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 | 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 |
︙ | ︙ | |||
3829 3830 3831 3832 3833 3834 3835 | $nocase] my ret [my neq $match $0] } ##### Function tcl.regexp ##### # # Type signature: flags:INT * regexp:STRING * string:STRING | | | | | 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 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 | $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]] my condBr [my nonnull $RE] $exec $err label exec "re.exec" 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 |
︙ | ︙ | |||
3968 3969 3970 3971 3972 3973 3974 | # 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. | | | | | 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 | # 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: |
︙ | ︙ | |||
4047 4048 4049 4050 4051 4052 4053 | my store [my or [my load $field] [Const 0x800]] $field my ret } ##### Function tcl.processReturn ##### # # Type signature: result:STRING * code:int * level:int | | | | 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 | 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*] |
︙ | ︙ | |||
4327 4328 4329 4330 4331 4332 4333 | my br $done label done: my ret } ##### Function tcl.booleanTest ##### # | | | | 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 | 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] } |
︙ | ︙ | |||
4469 4470 4471 4472 4473 4474 4475 | label fail: my store $code $ecvar my ret [my fail STRING $code] } ##### Function tcl.existsOrError ##### # | | | | | | | 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 | 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 2829 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} { append body2 { $} [lindex $f 0] } {{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 2835 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} { append body2 { $} [lindex $f 0] } {{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 | $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] } | > > | | 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 | 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 | | | 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 | 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] |
︙ | ︙ | |||
521 522 523 524 525 526 527 | 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] | | > | | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 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 | 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 key [list temp opnd1] 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]] |
︙ | ︙ | |||
819 820 821 822 823 824 825 826 827 828 829 830 | 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]] } | > < | > > > | > | > > > | > > > > > | > | 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 851 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 | 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 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 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 659 660 661 662 663 664 665 666 667 668 669 | eq - ge - gt - instanceOf - isBoolean - land - le - lor - lt - neq - strclass - streq - strmatch - strneq { return $ZEROONE } not { set t [typeOfOperand $types [lindex $q 2]] if {istype($t,$NUMERIC|$BOOLWORD)} { return $ZEROONE } else { puts "which might FAIL" return [expr {$ZEROONE | $FAIL}] } } | > | | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 | eq - ge - gt - instanceOf - isBoolean - land - le - listIn - lor - lt - neq - strclass - streq - strmatch - strneq { return $ZEROONE } not { set t [typeOfOperand $types [lindex $q 2]] 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 |
︙ | ︙ | |||
734 735 736 737 738 739 740 | extractCallFrame { # Trim the non-callframe part return $CALLFRAME } list - unshareList { return $LIST } | | > > | | > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | | | < < < | 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 | 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)}] } |
︙ | ︙ |