Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ A powerful locals implementation |
| 2 : | |||
| 3 : | \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2007 Free Software Foundation, Inc. | ||
| 4 : | |||
| 5 : | \ This file is part of Gforth. | ||
| 6 : | |||
| 7 : | \ Gforth is free software; you can redistribute it and/or | ||
| 8 : | \ modify it under the terms of the GNU General Public License | ||
| 9 : | \ as published by the Free Software Foundation, either version 3 | ||
| 10 : | \ of the License, or (at your option) any later version. | ||
| 11 : | |||
| 12 : | \ This program is distributed in the hope that it will be useful, | ||
| 13 : | \ but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 14 : | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 15 : | \ GNU General Public License for more details. | ||
| 16 : | |||
| 17 : | \ You should have received a copy of the GNU General Public License | ||
| 18 : | \ along with this program. If not, see http://www.gnu.org/licenses/. | ||
| 19 : | |||
| 20 : | |||
| 21 : | \ More documentation can be found in the manual and in | ||
| 22 : | \ http://www.complang.tuwien.ac.at/papers/ertl94l.ps.gz | ||
| 23 : | |||
| 24 : | \ Local variables are quite important for writing readable programs, but | ||
| 25 : | \ IMO (anton) they are the worst part of the standard. There they are very | ||
| 26 : | \ restricted and have an ugly interface. | ||
| 27 : | |||
| 28 : | \ So, we implement the locals wordset, but do not recommend using | ||
| 29 : | \ locals-ext (which is a really bad user interface for locals). | ||
| 30 : | |||
| 31 : | \ We also have a nice and powerful user-interface for locals: locals are | ||
| 32 : | \ defined with | ||
| 33 : | |||
| 34 : | \ { local1 local2 ... } | ||
| 35 : | \ or | ||
| 36 : | \ { local1 local2 ... -- ... } | ||
| 37 : | \ (anything after the -- is just a comment) | ||
| 38 : | |||
| 39 : | \ Every local in this list consists of an optional type specification | ||
| 40 : | \ and a name. If there is only the name, it stands for a cell-sized | ||
| 41 : | \ value (i.e., you get the value of the local variable, not it's | ||
| 42 : | \ address). The following type specifiers stand before the name: | ||
| 43 : | |||
| 44 : | \ Specifier Type Access | ||
| 45 : | \ W: Cell value | ||
| 46 : | \ W^ Cell address | ||
| 47 : | \ D: Double value | ||
| 48 : | \ D^ Double address | ||
| 49 : | \ F: Float value | ||
| 50 : | \ F^ Float address | ||
| 51 : | \ C: Char value | ||
| 52 : | \ C^ Char address | ||
| 53 : | |||
| 54 : | \ The local variables are initialized with values from the appropriate | ||
| 55 : | \ stack. In contrast to the examples in the standard document our locals | ||
| 56 : | \ take the arguments in the expected way: The last local gets the top of | ||
| 57 : | \ stack, the second last gets the second stack item etc. An example: | ||
| 58 : | |||
| 59 : | \ : CX* { F: Ar F: Ai F: Br F: Bi -- Cr Ci } | ||
| 60 : | \ \ complex multiplication | ||
| 61 : | \ Ar Br f* Ai Bi f* f- | ||
| 62 : | \ Ar Bi f* Ai Br f* f+ ; | ||
| 63 : | |||
| 64 : | \ There will also be a way to add user types, but it is not yet decided, | ||
| 65 : | \ how. Ideas are welcome. | ||
| 66 : | |||
| 67 : | \ Locals defined in this manner live until (!! see below). | ||
| 68 : | \ Their names can be used during this time to get | ||
| 69 : | \ their value or address; The addresses produced in this way become | ||
| 70 : | \ invalid at the end of the lifetime. | ||
| 71 : | |||
| 72 : | \ Values can be changed with TO, but this is not recomended (TO is a | ||
| 73 : | \ kludge and words lose the single-assignment property, which makes them | ||
| 74 : | \ harder to analyse). | ||
| 75 : | |||
| 76 : | \ As for the internals, we use a special locals stack. This eliminates | ||
| 77 : | \ the problems and restrictions of reusing the return stack and allows | ||
| 78 : | \ to store floats as locals: the return stack is not guaranteed to be | ||
| 79 : | \ aligned correctly, but our locals stack must be float-aligned between | ||
| 80 : | \ words. | ||
| 81 : | |||
| 82 : | \ Other things about the internals are pretty unclear now. | ||
| 83 : | |||
| 84 : | \ Currently locals may only be | ||
| 85 : | \ defined at the outer level and TO is not supported. | ||
| 86 : | |||
| 87 : | require search.fs | ||
| 88 : | require float.fs | ||
| 89 : | require extend.fs \ for case | ||
| 90 : | |||
| 91 : | : compile-@local ( n -- ) \ gforth compile-fetch-local | ||
| 92 : | case | ||
| 93 : | 0 of postpone @local0 endof | ||
| 94 : | 1 cells of postpone @local1 endof | ||
| 95 : | 2 cells of postpone @local2 endof | ||
| 96 : | 3 cells of postpone @local3 endof | ||
| 97 : | ( otherwise ) dup postpone @local# , | ||
| 98 : | endcase ; | ||
| 99 : | |||
| 100 : | : compile-f@local ( n -- ) \ gforth compile-f-fetch-local | ||
| 101 : | case | ||
| 102 : | 0 of postpone f@local0 endof | ||
| 103 : | 1 floats of postpone f@local1 endof | ||
| 104 : | ( otherwise ) dup postpone f@local# , | ||
| 105 : | endcase ; | ||
| 106 : | |||
| 107 : | \ locals stuff needed for control structures | ||
| 108 : | |||
| 109 : | : compile-lp+! ( n -- ) \ gforth compile-l-p-plus-store | ||
| 110 : | dup negate locals-size +! | ||
| 111 : | 0 over = if | ||
| 112 : | else -1 cells over = if postpone lp- | ||
| 113 : | else 1 floats over = if postpone lp+ | ||
| 114 : | else 2 floats over = if postpone lp+2 | ||
| 115 : | else postpone lp+!# dup , | ||
| 116 : | then then then then drop ; | ||
| 117 : | |||
| 118 : | : adjust-locals-size ( n -- ) \ gforth | ||
| 119 : | \ sets locals-size to n and generates an appropriate lp+! | ||
| 120 : | locals-size @ swap - compile-lp+! ; | ||
| 121 : | |||
| 122 : | \ the locals stack grows downwards (see primitives) | ||
| 123 : | \ of the local variables of a group (in braces) the leftmost is on top, | ||
| 124 : | \ i.e. by going onto the locals stack the order is reversed. | ||
| 125 : | \ there are alignment gaps if necessary. | ||
| 126 : | \ lp must have the strictest alignment (usually float) across calls; | ||
| 127 : | \ for simplicity we align it strictly for every group. | ||
| 128 : | |||
| 129 : | slowvoc @ | ||
| 130 : | slowvoc on \ we want a linked list for the vocabulary locals | ||
| 131 : | vocabulary locals \ this contains the local variables | ||
| 132 : | ' locals >body wordlist-id ' locals-list >body ! | ||
| 133 : | slowvoc ! | ||
| 134 : | |||
| 135 : | create locals-buffer 1000 allot \ !! limited and unsafe | ||
| 136 : | \ here the names of the local variables are stored | ||
| 137 : | \ we would have problems storing them at the normal dp | ||
| 138 : | |||
| 139 : | variable locals-dp \ so here's the special dp for locals. | ||
| 140 : | |||
| 141 : | : alignlp-w ( n1 -- n2 ) | ||
| 142 : | \ cell-align size and generate the corresponding code for aligning lp | ||
| 143 : | aligned dup adjust-locals-size ; | ||
| 144 : | |||
| 145 : | : alignlp-f ( n1 -- n2 ) | ||
| 146 : | faligned dup adjust-locals-size ; | ||
| 147 : | |||
| 148 : | \ a local declaration group (the braces stuff) is compiled by calling | ||
| 149 : | \ the appropriate compile-pushlocal for the locals, starting with the | ||
| 150 : | \ righmost local; the names are already created earlier, the | ||
| 151 : | \ compile-pushlocal just inserts the offsets from the frame base. | ||
| 152 : | |||
| 153 : | : compile-pushlocal-w ( a-addr -- ) ( run-time: w -- ) | ||
| 154 : | \ compiles a push of a local variable, and adjusts locals-size | ||
| 155 : | \ stores the offset of the local variable to a-addr | ||
| 156 : | locals-size @ alignlp-w cell+ dup locals-size ! | ||
| 157 : | swap ! | ||
| 158 : | postpone >l ; | ||
| 159 : | |||
| 160 : | \ locals list operations | ||
| 161 : | |||
| 162 : | : common-list ( list1 list2 -- list3 ) \ gforth-internal | ||
| 163 : | \ list1 and list2 are lists, where the heads are at higher addresses than | ||
| 164 : | \ the tail. list3 is the largest sublist of both lists. | ||
| 165 : | begin | ||
| 166 : | 2dup u<> | ||
| 167 : | while | ||
| 168 : | 2dup u> | ||
| 169 : | if | ||
| 170 : | swap | ||
| 171 : | then | ||
| 172 : | @ | ||
| 173 : | repeat | ||
| 174 : | drop ; | ||
| 175 : | |||
| 176 : | : sub-list? ( list1 list2 -- f ) \ gforth-internal | ||
| 177 : | \ true iff list1 is a sublist of list2 | ||
| 178 : | begin | ||
| 179 : | 2dup u< | ||
| 180 : | while | ||
| 181 : | @ | ||
| 182 : | repeat | ||
| 183 : | = ; | ||
| 184 : | |||
| 185 : | : list-size ( list -- u ) \ gforth-internal | ||
| 186 : | \ size of the locals frame represented by list | ||
| 187 : | 0 ( list n ) | ||
| 188 : | begin | ||
| 189 : | over 0<> | ||
| 190 : | while | ||
| 191 : | over | ||
| 192 : | ((name>)) >body @ max | ||
| 193 : | swap @ swap ( get next ) | ||
| 194 : | repeat | ||
| 195 : | faligned nip ; | ||
| 196 : | |||
| 197 : | : set-locals-size-list ( list -- ) | ||
| 198 : | dup locals-list ! | ||
| 199 : | list-size locals-size ! ; | ||
| 200 : | |||
| 201 : | : check-begin ( list -- ) | ||
| 202 : | \ warn if list is not a sublist of locals-list | ||
| 203 : | locals-list @ sub-list? 0= if | ||
| 204 : | \ !! print current position | ||
| 205 : | ." compiler was overly optimistic about locals at a BEGIN" cr | ||
| 206 : | \ !! print assumption and reality | ||
| 207 : | then ; | ||
| 208 : | |||
| 209 : | : compile-pushlocal-f ( a-addr -- ) ( run-time: f -- ) | ||
| 210 : | locals-size @ alignlp-f float+ dup locals-size ! | ||
| 211 : | swap ! | ||
| 212 : | postpone f>l ; | ||
| 213 : | |||
| 214 : | : compile-pushlocal-d ( a-addr -- ) ( run-time: w1 w2 -- ) | ||
| 215 : | locals-size @ alignlp-w cell+ cell+ dup locals-size ! | ||
| 216 : | swap ! | ||
| 217 : | postpone swap postpone >l postpone >l ; | ||
| 218 : | |||
| 219 : | : compile-pushlocal-c ( a-addr -- ) ( run-time: w -- ) | ||
| 220 : | -1 chars compile-lp+! | ||
| 221 : | locals-size @ swap ! | ||
| 222 : | postpone lp@ postpone c! ; | ||
| 223 : | |||
| 224 : | : create-local ( " name" -- a-addr ) | ||
| 225 : | \ defines the local "name"; the offset of the local shall be | ||
| 226 : | \ stored in a-addr | ||
| 227 : | create | ||
| 228 : | immediate restrict | ||
| 229 : | here 0 , ( place for the offset ) ; | ||
| 230 : | |||
| 231 : | : lp-offset ( n1 -- n2 ) | ||
| 232 : | \ converts the offset from the frame start to an offset from lp and | ||
| 233 : | \ i.e., the address of the local is lp+locals_size-offset | ||
| 234 : | locals-size @ swap - ; | ||
| 235 : | |||
| 236 : | : lp-offset, ( n -- ) | ||
| 237 : | \ converts the offset from the frame start to an offset from lp and | ||
| 238 : | \ adds it as inline argument to a preceding locals primitive | ||
| 239 : | lp-offset , ; | ||
| 240 : | |||
| 241 : | vocabulary locals-types \ this contains all the type specifyers, -- and } | ||
| 242 : | locals-types definitions | ||
| 243 : | |||
| 244 : | : W: ( "name" -- a-addr xt ) \ gforth w-colon | ||
| 245 : | create-local | ||
| 246 : | \ xt produces the appropriate locals pushing code when executed | ||
| 247 : | ['] compile-pushlocal-w | ||
| 248 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 249 : | \ compiles a local variable access | ||
| 250 : | @ lp-offset compile-@local ; | ||
| 251 : | |||
| 252 : | : W^ ( "name" -- a-addr xt ) \ gforth w-caret | ||
| 253 : | create-local | ||
| 254 : | ['] compile-pushlocal-w | ||
| 255 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 256 : | postpone laddr# @ lp-offset, ; | ||
| 257 : | |||
| 258 : | : F: ( "name" -- a-addr xt ) \ gforth f-colon | ||
| 259 : | create-local | ||
| 260 : | ['] compile-pushlocal-f | ||
| 261 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 262 : | @ lp-offset compile-f@local ; | ||
| 263 : | |||
| 264 : | : F^ ( "name" -- a-addr xt ) \ gforth f-caret | ||
| 265 : | create-local | ||
| 266 : | ['] compile-pushlocal-f | ||
| 267 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 268 : | postpone laddr# @ lp-offset, ; | ||
| 269 : | |||
| 270 : | : D: ( "name" -- a-addr xt ) \ gforth d-colon | ||
| 271 : | create-local | ||
| 272 : | ['] compile-pushlocal-d | ||
| 273 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 274 : | postpone laddr# @ lp-offset, postpone 2@ ; | ||
| 275 : | |||
| 276 : | : D^ ( "name" -- a-addr xt ) \ gforth d-caret | ||
| 277 : | create-local | ||
| 278 : | ['] compile-pushlocal-d | ||
| 279 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 280 : | postpone laddr# @ lp-offset, ; | ||
| 281 : | |||
| 282 : | : C: ( "name" -- a-addr xt ) \ gforth c-colon | ||
| 283 : | create-local | ||
| 284 : | ['] compile-pushlocal-c | ||
| 285 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 286 : | postpone laddr# @ lp-offset, postpone c@ ; | ||
| 287 : | |||
| 288 : | : C^ ( "name" -- a-addr xt ) \ gforth c-caret | ||
| 289 : | create-local | ||
| 290 : | ['] compile-pushlocal-c | ||
| 291 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 292 : | postpone laddr# @ lp-offset, ; | ||
| 293 : | |||
| 294 : | \ you may want to make comments in a locals definitions group: | ||
| 295 : | ' \ alias \ ( compilation 'ccc<newline>' -- ; run-time -- ) \ core-ext,block-ext backslash | ||
| 296 : | \G Comment till the end of the line if @code{BLK} contains 0 (i.e., | ||
| 297 : | \G while not loading a block), parse and discard the remainder of the | ||
| 298 : | \G parse area. Otherwise, parse and discard all subsequent characters | ||
| 299 : | \G in the parse area corresponding to the current line. | ||
| 300 : | immediate | ||
| 301 : | |||
| 302 : | ' ( alias ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren | ||
| 303 : | \G Comment, usually till the next @code{)}: parse and discard all | ||
| 304 : | \G subsequent characters in the parse area until ")" is | ||
| 305 : | \G encountered. During interactive input, an end-of-line also acts as | ||
| 306 : | \G a comment terminator. For file input, it does not; if the | ||
| 307 : | \G end-of-file is encountered whilst parsing for the ")" delimiter, | ||
| 308 : | \G Gforth will generate a warning. | ||
| 309 : | immediate | ||
| 310 : | |||
| 311 : | forth definitions | ||
| 312 : | also locals-types | ||
| 313 : | |||
| 314 : | \ these "locals" are used for comparison in TO | ||
| 315 : | |||
| 316 : | c: some-clocal 2drop | ||
| 317 : | d: some-dlocal 2drop | ||
| 318 : | f: some-flocal 2drop | ||
| 319 : | w: some-wlocal 2drop | ||
| 320 : | |||
| 321 : | \ the following gymnastics are for declaring locals without type specifier. | ||
| 322 : | \ we exploit a feature of our dictionary: every wordlist | ||
| 323 : | \ has it's own methods for finding words etc. | ||
| 324 : | \ So we create a vocabulary new-locals, that creates a 'w:' local named x | ||
| 325 : | \ when it is asked if it contains x. | ||
| 326 : | |||
| 327 : | : new-locals-find ( caddr u w -- nfa ) | ||
| 328 : | \ this is the find method of the new-locals vocabulary | ||
| 329 : | \ make a new local with name caddr u; w is ignored | ||
| 330 : | \ the returned nfa denotes a word that produces what W: produces | ||
| 331 : | \ !! do the whole thing without nextname | ||
| 332 : | drop nextname | ||
| 333 : | ['] W: >head-noprim ; | ||
| 334 : | |||
| 335 : | previous | ||
| 336 : | |||
| 337 : | : new-locals-reveal ( -- ) | ||
| 338 : | true abort" this should not happen: new-locals-reveal" ; | ||
| 339 : | |||
| 340 : | create new-locals-map ( -- wordlist-map ) | ||
| 341 : | ' new-locals-find A, | ||
| 342 : | ' new-locals-reveal A, | ||
| 343 : | ' drop A, \ rehash method | ||
| 344 : | ' drop A, | ||
| 345 : | |||
| 346 : | new-locals-map mappedwordlist Constant new-locals-wl | ||
| 347 : | |||
| 348 : | \ slowvoc @ | ||
| 349 : | \ slowvoc on | ||
| 350 : | \ vocabulary new-locals | ||
| 351 : | \ slowvoc ! | ||
| 352 : | \ new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words | ||
| 353 : | |||
| 354 : | variable old-dpp | ||
| 355 : | |||
| 356 : | \ and now, finally, the user interface words | ||
| 357 : | : { ( -- latestxt wid 0 ) \ gforth open-brace | ||
| 358 : | dp old-dpp ! | ||
| 359 : | locals-dp dpp ! | ||
| 360 : | latestxt get-current | ||
| 361 : | get-order new-locals-wl swap 1+ set-order | ||
| 362 : | also locals definitions locals-types | ||
| 363 : | 0 TO locals-wordlist | ||
| 364 : | 0 postpone [ ; immediate | ||
| 365 : | |||
| 366 : | locals-types definitions | ||
| 367 : | |||
| 368 : | : } ( latestxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace | ||
| 369 : | \ ends locals definitions | ||
| 370 : | ] old-dpp @ dpp ! | ||
| 371 : | begin | ||
| 372 : | dup | ||
| 373 : | while | ||
| 374 : | execute | ||
| 375 : | repeat | ||
| 376 : | drop | ||
| 377 : | locals-size @ alignlp-f locals-size ! \ the strictest alignment | ||
| 378 : | previous previous | ||
| 379 : | set-current lastcfa ! | ||
| 380 : | locals-list 0 wordlist-id - TO locals-wordlist ; | ||
| 381 : | |||
| 382 : | : -- ( addr wid 0 ... -- ) \ gforth dash-dash | ||
| 383 : | } | ||
| 384 : | [char] } parse 2drop ; | ||
| 385 : | |||
| 386 : | forth definitions | ||
| 387 : | |||
| 388 : | \ A few thoughts on automatic scopes for locals and how they can be | ||
| 389 : | \ implemented: | ||
| 390 : | |||
| 391 : | \ We have to combine locals with the control structures. My basic idea | ||
| 392 : | \ was to start the life of a local at the declaration point. The life | ||
| 393 : | \ would end at any control flow join (THEN, BEGIN etc.) where the local | ||
| 394 : | \ is lot live on both input flows (note that the local can still live in | ||
| 395 : | \ other, later parts of the control flow). This would make a local live | ||
| 396 : | \ as long as you expected and sometimes longer (e.g. a local declared in | ||
| 397 : | \ a BEGIN..UNTIL loop would still live after the UNTIL). | ||
| 398 : | |||
| 399 : | \ The following example illustrates the problems of this approach: | ||
| 400 : | |||
| 401 : | \ { z } | ||
| 402 : | \ if | ||
| 403 : | \ { x } | ||
| 404 : | \ begin | ||
| 405 : | \ { y } | ||
| 406 : | \ [ 1 cs-roll ] then | ||
| 407 : | \ ... | ||
| 408 : | \ until | ||
| 409 : | |||
| 410 : | \ x lives only until the BEGIN, but the compiler does not know this | ||
| 411 : | \ until it compiles the UNTIL (it can deduce it at the THEN, because at | ||
| 412 : | \ that point x lives in no thread, but that does not help much). This is | ||
| 413 : | \ solved by optimistically assuming at the BEGIN that x lives, but | ||
| 414 : | \ warning at the UNTIL that it does not. The user is then responsible | ||
| 415 : | \ for checking that x is only used where it lives. | ||
| 416 : | |||
| 417 : | \ The produced code might look like this (leaving out alignment code): | ||
| 418 : | |||
| 419 : | \ >l ( z ) | ||
| 420 : | \ ?branch <then> | ||
| 421 : | \ >l ( x ) | ||
| 422 : | \ <begin>: | ||
| 423 : | \ >l ( y ) | ||
| 424 : | \ lp+!# 8 ( RIP: x,y ) | ||
| 425 : | \ <then>: | ||
| 426 : | \ ... | ||
| 427 : | \ lp+!# -4 ( adjust lp to <begin> state ) | ||
| 428 : | \ ?branch <begin> | ||
| 429 : | \ lp+!# 4 ( undo adjust ) | ||
| 430 : | |||
| 431 : | \ The BEGIN problem also has another incarnation: | ||
| 432 : | |||
| 433 : | \ AHEAD | ||
| 434 : | \ BEGIN | ||
| 435 : | \ x | ||
| 436 : | \ [ 1 CS-ROLL ] THEN | ||
| 437 : | \ { x } | ||
| 438 : | \ ... | ||
| 439 : | \ UNTIL | ||
| 440 : | |||
| 441 : | \ should be legal: The BEGIN is not a control flow join in this case, | ||
| 442 : | \ since it cannot be entered from the top; therefore the definition of x | ||
| 443 : | \ dominates the use. But the compiler processes the use first, and since | ||
| 444 : | \ it does not look ahead to notice the definition, it will complain | ||
| 445 : | \ about it. Here's another variation of this problem: | ||
| 446 : | |||
| 447 : | \ IF | ||
| 448 : | \ { x } | ||
| 449 : | \ ELSE | ||
| 450 : | \ ... | ||
| 451 : | \ AHEAD | ||
| 452 : | \ BEGIN | ||
| 453 : | \ x | ||
| 454 : | \ [ 2 CS-ROLL ] THEN | ||
| 455 : | \ ... | ||
| 456 : | \ UNTIL | ||
| 457 : | |||
| 458 : | \ In this case x is defined before the use, and the definition dominates | ||
| 459 : | \ the use, but the compiler does not know this until it processes the | ||
| 460 : | \ UNTIL. So what should the compiler assume does live at the BEGIN, if | ||
| 461 : | \ the BEGIN is not a control flow join? The safest assumption would be | ||
| 462 : | \ the intersection of all locals lists on the control flow | ||
| 463 : | \ stack. However, our compiler assumes that the same variables are live | ||
| 464 : | \ as on the top of the control flow stack. This covers the following case: | ||
| 465 : | |||
| 466 : | \ { x } | ||
| 467 : | \ AHEAD | ||
| 468 : | \ BEGIN | ||
| 469 : | \ x | ||
| 470 : | \ [ 1 CS-ROLL ] THEN | ||
| 471 : | \ ... | ||
| 472 : | \ UNTIL | ||
| 473 : | |||
| 474 : | \ If this assumption is too optimistic, the compiler will warn the user. | ||
| 475 : | |||
| 476 : | \ Implementation: | ||
| 477 : | |||
| 478 : | \ explicit scoping | ||
| 479 : | |||
| 480 : | : scope ( compilation -- scope ; run-time -- ) \ gforth | ||
| 481 : | cs-push-part scopestart ; immediate | ||
| 482 : | |||
| 483 : | : adjust-locals-list ( wid -- ) | ||
| 484 : | locals-list @ common-list | ||
| 485 : | dup list-size adjust-locals-size | ||
| 486 : | locals-list ! ; | ||
| 487 : | |||
| 488 : | : endscope ( compilation scope -- ; run-time -- ) \ gforth | ||
| 489 : | scope? | ||
| 490 : | drop adjust-locals-list ; immediate | ||
| 491 : | |||
| 492 : | \ adapt the hooks | ||
| 493 : | |||
| 494 : | : locals-:-hook ( sys -- sys addr xt n ) | ||
| 495 : | \ addr is the nfa of the defined word, xt its xt | ||
| 496 : | DEFERS :-hook | ||
| 497 : | latest latestxt | ||
| 498 : | clear-leave-stack | ||
| 499 : | 0 locals-size ! | ||
| 500 : | locals-buffer locals-dp ! | ||
| 501 : | 0 locals-list ! | ||
| 502 : | dead-code off | ||
| 503 : | defstart ; | ||
| 504 : | |||
| 505 : | : locals-;-hook ( sys addr xt sys -- sys ) | ||
| 506 : | def? | ||
| 507 : | 0 TO locals-wordlist | ||
| 508 : | 0 adjust-locals-size ( not every def ends with an exit ) | ||
| 509 : | lastcfa ! last ! | ||
| 510 : | DEFERS ;-hook ; | ||
| 511 : | |||
| 512 : | \ THEN (another control flow from before joins the current one): | ||
| 513 : | \ The new locals-list is the intersection of the current locals-list and | ||
| 514 : | \ the orig-local-list. The new locals-size is the (alignment-adjusted) | ||
| 515 : | \ size of the new locals-list. The following code is generated: | ||
| 516 : | \ lp+!# (current-locals-size - orig-locals-size) | ||
| 517 : | \ <then>: | ||
| 518 : | \ lp+!# (orig-locals-size - new-locals-size) | ||
| 519 : | |||
| 520 : | \ Of course "lp+!# 0" is not generated. Still this is admittedly a bit | ||
| 521 : | \ inefficient, e.g. if there is a locals declaration between IF and | ||
| 522 : | \ ELSE. However, if ELSE generates an appropriate "lp+!#" before the | ||
| 523 : | \ branch, there will be none after the target <then>. | ||
| 524 : | |||
| 525 : | : (then-like) ( orig -- ) | ||
| 526 : | dead-orig = | ||
| 527 : | if | ||
| 528 : | >resolve drop | ||
| 529 : | else | ||
| 530 : | dead-code @ | ||
| 531 : | if | ||
| 532 : | >resolve set-locals-size-list dead-code off | ||
| 533 : | else \ both live | ||
| 534 : | over list-size adjust-locals-size | ||
| 535 : | >resolve | ||
| 536 : | adjust-locals-list | ||
| 537 : | then | ||
| 538 : | then ; | ||
| 539 : | |||
| 540 : | : (begin-like) ( -- ) | ||
| 541 : | dead-code @ if | ||
| 542 : | \ set up an assumption of the locals visible here. if the | ||
| 543 : | \ users want something to be visible, they have to declare | ||
| 544 : | \ that using ASSUME-LIVE | ||
| 545 : | backedge-locals @ set-locals-size-list | ||
| 546 : | then | ||
| 547 : | dead-code off ; | ||
| 548 : | |||
| 549 : | \ AGAIN (the current control flow joins another, earlier one): | ||
| 550 : | \ If the dest-locals-list is not a subset of the current locals-list, | ||
| 551 : | \ issue a warning (see below). The following code is generated: | ||
| 552 : | \ lp+!# (current-local-size - dest-locals-size) | ||
| 553 : | \ branch <begin> | ||
| 554 : | |||
| 555 : | : (again-like) ( dest -- addr ) | ||
| 556 : | over list-size adjust-locals-size | ||
| 557 : | swap check-begin POSTPONE unreachable ; | ||
| 558 : | |||
| 559 : | \ UNTIL (the current control flow may join an earlier one or continue): | ||
| 560 : | \ Similar to AGAIN. The new locals-list and locals-size are the current | ||
| 561 : | \ ones. The following code is generated: | ||
| 562 : | \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size) | ||
| 563 : | |||
| 564 : | : (until-like) ( list addr xt1 xt2 -- ) | ||
| 565 : | \ list and addr are a fragment of a cs-item | ||
| 566 : | \ xt1 is the conditional branch without lp adjustment, xt2 is with | ||
| 567 : | >r >r | ||
| 568 : | locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment ) | ||
| 569 : | r> drop r> compile, | ||
| 570 : | swap <resolve ( list adjustment ) , | ||
| 571 : | else ( list dest-addr adjustment ) | ||
| 572 : | drop | ||
| 573 : | r> compile, <resolve | ||
| 574 : | r> drop | ||
| 575 : | then ( list ) | ||
| 576 : | check-begin ; | ||
| 577 : | |||
| 578 : | : (exit-like) ( -- ) | ||
| 579 : | 0 adjust-locals-size ; | ||
| 580 : | |||
| 581 : | ' locals-:-hook IS :-hook | ||
| 582 : | ' locals-;-hook IS ;-hook | ||
| 583 : | |||
| 584 : | ' (then-like) IS then-like | ||
| 585 : | ' (begin-like) IS begin-like | ||
| 586 : | ' (again-like) IS again-like | ||
| 587 : | ' (until-like) IS until-like | ||
| 588 : | ' (exit-like) IS exit-like | ||
| 589 : | |||
| 590 : | \ The words in the locals dictionary space are not deleted until the end | ||
| 591 : | \ of the current word. This is a bit too conservative, but very simple. | ||
| 592 : | |||
| 593 : | \ There are a few cases to consider: (see above) | ||
| 594 : | |||
| 595 : | \ after AGAIN, AHEAD, EXIT (the current control flow is dead): | ||
| 596 : | \ We have to special-case the above cases against that. In this case the | ||
| 597 : | \ things above are not control flow joins. Everything should be taken | ||
| 598 : | \ over from the live flow. No lp+!# is generated. | ||
| 599 : | |||
| 600 : | \ About warning against uses of dead locals. There are several options: | ||
| 601 : | |||
| 602 : | \ 1) Do not complain (After all, this is Forth;-) | ||
| 603 : | |||
| 604 : | \ 2) Additional restrictions can be imposed so that the situation cannot | ||
| 605 : | \ arise; the programmer would have to introduce explicit scoping | ||
| 606 : | \ declarations in cases like the above one. I.e., complain if there are | ||
| 607 : | \ locals that are live before the BEGIN but not before the corresponding | ||
| 608 : | \ AGAIN (replace DO etc. for BEGIN and UNTIL etc. for AGAIN). | ||
| 609 : | |||
| 610 : | \ 3) The real thing: i.e. complain, iff a local lives at a BEGIN, is | ||
| 611 : | \ used on a path starting at the BEGIN, and does not live at the | ||
| 612 : | \ corresponding AGAIN. This is somewhat hard to implement. a) How does | ||
| 613 : | \ the compiler know when it is working on a path starting at a BEGIN | ||
| 614 : | \ (consider "{ x } if begin [ 1 cs-roll ] else x endif again")? b) How | ||
| 615 : | \ is the usage info stored? | ||
| 616 : | |||
| 617 : | \ For now I'll resort to alternative 2. When it produces warnings they | ||
| 618 : | \ will often be spurious, but warnings should be rare. And better | ||
| 619 : | \ spurious warnings now and then than days of bug-searching. | ||
| 620 : | |||
| 621 : | \ Explicit scoping of locals is implemented by cs-pushing the current | ||
| 622 : | \ locals-list and -size (and an unused cell, to make the size equal to | ||
| 623 : | \ the other entries) at the start of the scope, and restoring them at | ||
| 624 : | \ the end of the scope to the intersection, like THEN does. | ||
| 625 : | |||
| 626 : | |||
| 627 : | \ And here's finally the ANS standard stuff | ||
| 628 : | |||
| 629 : | : (local) ( addr u -- ) \ local paren-local-paren | ||
| 630 : | \ a little space-inefficient, but well deserved ;-) | ||
| 631 : | \ In exchange, there are no restrictions whatsoever on using (local) | ||
| 632 : | \ as long as you use it in a definition | ||
| 633 : | dup | ||
| 634 : | if | ||
| 635 : | nextname POSTPONE { [ also locals-types ] W: } [ previous ] | ||
| 636 : | else | ||
| 637 : | 2drop | ||
| 638 : | endif ; | ||
| 639 : | |||
| 640 : | : >definer ( xt -- definer ) \ gforth | ||
| 641 : | \G @var{Definer} is a unique identifier for the way the @var{xt} | ||
| 642 : | \G was defined. Words defined with different @code{does>}-codes | ||
| 643 : | \G have different definers. The definer can be used for | ||
| 644 : | \G comparison and in @code{definer!}. | ||
| 645 : | dup >does-code | ||
| 646 : | ?dup-if | ||
| 647 : | nip 1 or | ||
| 648 : | else | ||
| 649 : | >code-address | ||
| 650 : | then ; | ||
| 651 : | |||
| 652 : | : definer! ( definer xt -- ) \ gforth | ||
| 653 : | \G The word represented by @var{xt} changes its behaviour to the | ||
| 654 : | \G behaviour associated with @var{definer}. | ||
| 655 : | over 1 and if | ||
| 656 : | swap [ 1 invert ] literal and does-code! | ||
| 657 : | else | ||
| 658 : | code-address! | ||
| 659 : | then ; | ||
| 660 : | |||
| 661 : | :noname | ||
| 662 : | ' dup >definer [ ' locals-wordlist ] literal >definer = | ||
| 663 : | if | ||
| 664 : | >body ! | ||
| 665 : | else | ||
| 666 : | -&32 throw | ||
| 667 : | endif ; | ||
| 668 : | :noname | ||
| 669 : | comp' drop dup >definer | ||
| 670 : | case | ||
| 671 : | [ ' locals-wordlist ] literal >definer \ value | ||
| 672 : | OF >body POSTPONE Aliteral POSTPONE ! ENDOF | ||
| 673 : | \ !! dependent on c: etc. being does>-defining words | ||
| 674 : | \ this works, because >definer uses >does-code in this case, | ||
| 675 : | \ which produces a relocatable address | ||
| 676 : | [ comp' some-clocal drop ] literal >definer | ||
| 677 : | OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF | ||
| 678 : | [ comp' some-wlocal drop ] literal >definer | ||
| 679 : | OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF | ||
| 680 : | [ comp' some-dlocal drop ] literal >definer | ||
| 681 : | OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF | ||
| 682 : | [ comp' some-flocal drop ] literal >definer | ||
| 683 : | OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF | ||
| 684 : | -&32 throw | ||
| 685 : | endcase ; | ||
| 686 : | interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local | ||
| 687 : | |||
| 688 : | : locals| ( ... "name ..." -- ) \ local-ext locals-bar | ||
| 689 : | \ don't use 'locals|'! use '{'! A portable and free '{' | ||
| 690 : | \ implementation is compat/anslocals.fs | ||
| 691 : | BEGIN | ||
| 692 : | name 2dup s" |" str= 0= | ||
| 693 : | WHILE | ||
| 694 : | (local) | ||
| 695 : | REPEAT | ||
| 696 : | drop 0 (local) ; immediate restrict |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |