Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.15 | \ A powerful locals implementation |
| 2 : | |||
| 3 : | anton | 1.63 | \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2007,2011 Free Software Foundation, Inc. |
| 4 : | anton | 1.15 | |
| 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 : | anton | 1.60 | \ as published by the Free Software Foundation, either version 3 |
| 10 : | anton | 1.15 | \ 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 : | anton | 1.60 | \ along with this program. If not, see http://www.gnu.org/licenses/. |
| 19 : | anton | 1.15 | |
| 20 : | |||
| 21 : | anton | 1.16 | \ More documentation can be found in the manual and in |
| 22 : | \ http://www.complang.tuwien.ac.at/papers/ertl94l.ps.gz | ||
| 23 : | |||
| 24 : | anton | 1.1 | \ 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 : | anton | 1.33 | require search.fs |
| 83 : | anton | 1.14 | require float.fs |
| 84 : | jwilke | 1.47 | require extend.fs \ for case |
| 85 : | anton | 1.1 | |
| 86 : | anton | 1.14 | : compile-@local ( n -- ) \ gforth compile-fetch-local |
| 87 : | anton | 1.3 | case |
| 88 : | pazsan | 1.7 | 0 of postpone @local0 endof |
| 89 : | 1 cells of postpone @local1 endof | ||
| 90 : | 2 cells of postpone @local2 endof | ||
| 91 : | 3 cells of postpone @local3 endof | ||
| 92 : | anton | 1.3 | ( otherwise ) dup postpone @local# , |
| 93 : | endcase ; | ||
| 94 : | |||
| 95 : | anton | 1.14 | : compile-f@local ( n -- ) \ gforth compile-f-fetch-local |
| 96 : | anton | 1.3 | case |
| 97 : | pazsan | 1.7 | 0 of postpone f@local0 endof |
| 98 : | 1 floats of postpone f@local1 endof | ||
| 99 : | anton | 1.3 | ( otherwise ) dup postpone f@local# , |
| 100 : | endcase ; | ||
| 101 : | |||
| 102 : | pazsan | 1.27 | \ locals stuff needed for control structures |
| 103 : | |||
| 104 : | : compile-lp+! ( n -- ) \ gforth compile-l-p-plus-store | ||
| 105 : | dup negate locals-size +! | ||
| 106 : | 0 over = if | ||
| 107 : | else -1 cells over = if postpone lp- | ||
| 108 : | else 1 floats over = if postpone lp+ | ||
| 109 : | else 2 floats over = if postpone lp+2 | ||
| 110 : | else postpone lp+!# dup , | ||
| 111 : | then then then then drop ; | ||
| 112 : | |||
| 113 : | : adjust-locals-size ( n -- ) \ gforth | ||
| 114 : | \ sets locals-size to n and generates an appropriate lp+! | ||
| 115 : | locals-size @ swap - compile-lp+! ; | ||
| 116 : | |||
| 117 : | anton | 1.1 | \ the locals stack grows downwards (see primitives) |
| 118 : | \ of the local variables of a group (in braces) the leftmost is on top, | ||
| 119 : | \ i.e. by going onto the locals stack the order is reversed. | ||
| 120 : | \ there are alignment gaps if necessary. | ||
| 121 : | \ lp must have the strictest alignment (usually float) across calls; | ||
| 122 : | \ for simplicity we align it strictly for every group. | ||
| 123 : | |||
| 124 : | anton | 1.5 | slowvoc @ |
| 125 : | slowvoc on \ we want a linked list for the vocabulary locals | ||
| 126 : | anton | 1.1 | vocabulary locals \ this contains the local variables |
| 127 : | pazsan | 1.37 | ' locals >body wordlist-id ' locals-list >body ! |
| 128 : | anton | 1.5 | slowvoc ! |
| 129 : | anton | 1.1 | |
| 130 : | anton | 1.62 | variable locals-mem-list \ linked list of all locals name memory in |
| 131 : | 0 locals-mem-list ! \ the current (outer-level) definition | ||
| 132 : | anton | 1.1 | |
| 133 : | anton | 1.62 | : free-list ( addr -- ) |
| 134 : | \ free all members of a linked list (link field is first) | ||
| 135 : | begin | ||
| 136 : | dup while | ||
| 137 : | dup @ swap free throw | ||
| 138 : | repeat | ||
| 139 : | drop ; | ||
| 140 : | |||
| 141 : | : prepend-list ( addr1 addr2 -- ) | ||
| 142 : | \ addr1 is the address of a list element, addr2 is the address of | ||
| 143 : | \ the cell containing the address of the first list element | ||
| 144 : | 2dup @ swap ! \ store link to next element | ||
| 145 : | ! ; \ store pointer to new first element | ||
| 146 : | anton | 1.1 | |
| 147 : | : alignlp-w ( n1 -- n2 ) | ||
| 148 : | \ cell-align size and generate the corresponding code for aligning lp | ||
| 149 : | anton | 1.3 | aligned dup adjust-locals-size ; |
| 150 : | anton | 1.1 | |
| 151 : | : alignlp-f ( n1 -- n2 ) | ||
| 152 : | anton | 1.3 | faligned dup adjust-locals-size ; |
| 153 : | anton | 1.1 | |
| 154 : | \ a local declaration group (the braces stuff) is compiled by calling | ||
| 155 : | \ the appropriate compile-pushlocal for the locals, starting with the | ||
| 156 : | \ righmost local; the names are already created earlier, the | ||
| 157 : | \ compile-pushlocal just inserts the offsets from the frame base. | ||
| 158 : | |||
| 159 : | : compile-pushlocal-w ( a-addr -- ) ( run-time: w -- ) | ||
| 160 : | \ compiles a push of a local variable, and adjusts locals-size | ||
| 161 : | \ stores the offset of the local variable to a-addr | ||
| 162 : | locals-size @ alignlp-w cell+ dup locals-size ! | ||
| 163 : | swap ! | ||
| 164 : | postpone >l ; | ||
| 165 : | |||
| 166 : | pazsan | 1.27 | \ locals list operations |
| 167 : | |||
| 168 : | anton | 1.66 | : list-length ( list -- u ) |
| 169 : | 0 swap begin ( u1 list1 ) | ||
| 170 : | dup while | ||
| 171 : | @ swap 1+ swap | ||
| 172 : | repeat | ||
| 173 : | drop ; | ||
| 174 : | |||
| 175 : | : /list ( list1 u -- list2 ) | ||
| 176 : | \ list2 is list1 with the first u elements removed | ||
| 177 : | 0 ?do | ||
| 178 : | @ | ||
| 179 : | loop ; | ||
| 180 : | |||
| 181 : | : common-list ( list1 list2 -- list3 ) | ||
| 182 : | \ list3 is the largest common tail of both lists. | ||
| 183 : | over list-length over list-length - dup 0< if | ||
| 184 : | negate >r swap r> | ||
| 185 : | then ( long short u ) | ||
| 186 : | rot swap /list begin ( list3 list4 ) | ||
| 187 : | 2dup u<> while | ||
| 188 : | @ swap @ | ||
| 189 : | repeat | ||
| 190 : | drop ; | ||
| 191 : | |||
| 192 : | : sub-list? ( list1 list2 -- f ) | ||
| 193 : | \ true iff list1 is a sublist of list2 | ||
| 194 : | over list-length over list-length swap - 0 max /list = ; | ||
| 195 : | |||
| 196 : | \ : ocommon-list ( list1 list2 -- list3 ) \ gforth-internal | ||
| 197 : | \ \ list1 and list2 are lists, where the heads are at higher addresses than | ||
| 198 : | \ \ the tail. list3 is the largest sublist of both lists. | ||
| 199 : | \ begin | ||
| 200 : | \ 2dup u<> | ||
| 201 : | \ while | ||
| 202 : | \ 2dup u> | ||
| 203 : | \ if | ||
| 204 : | \ swap | ||
| 205 : | \ then | ||
| 206 : | \ @ | ||
| 207 : | \ repeat | ||
| 208 : | \ drop ; | ||
| 209 : | |||
| 210 : | \ : osub-list? ( list1 list2 -- f ) \ gforth-internal | ||
| 211 : | \ \ true iff list1 is a sublist of list2 | ||
| 212 : | \ begin | ||
| 213 : | \ 2dup u< | ||
| 214 : | \ while | ||
| 215 : | \ @ | ||
| 216 : | \ repeat | ||
| 217 : | \ = ; | ||
| 218 : | |||
| 219 : | \ defer common-list | ||
| 220 : | \ defer sub-list? | ||
| 221 : | |||
| 222 : | \ ' ocommon-list is common-list | ||
| 223 : | \ ' osub-list? is sub-list? | ||
| 224 : | pazsan | 1.27 | |
| 225 : | : list-size ( list -- u ) \ gforth-internal | ||
| 226 : | pazsan | 1.36 | \ size of the locals frame represented by list |
| 227 : | 0 ( list n ) | ||
| 228 : | begin | ||
| 229 : | over 0<> | ||
| 230 : | while | ||
| 231 : | over | ||
| 232 : | ((name>)) >body @ max | ||
| 233 : | swap @ swap ( get next ) | ||
| 234 : | repeat | ||
| 235 : | faligned nip ; | ||
| 236 : | pazsan | 1.27 | |
| 237 : | : set-locals-size-list ( list -- ) | ||
| 238 : | pazsan | 1.37 | dup locals-list ! |
| 239 : | pazsan | 1.36 | list-size locals-size ! ; |
| 240 : | pazsan | 1.27 | |
| 241 : | : check-begin ( list -- ) | ||
| 242 : | \ warn if list is not a sublist of locals-list | ||
| 243 : | pazsan | 1.37 | locals-list @ sub-list? 0= if |
| 244 : | pazsan | 1.27 | \ !! print current position |
| 245 : | pazsan | 1.64 | >stderr ." compiler was overly optimistic about locals at a BEGIN" cr |
| 246 : | pazsan | 1.27 | \ !! print assumption and reality |
| 247 : | then ; | ||
| 248 : | |||
| 249 : | anton | 1.1 | : compile-pushlocal-f ( a-addr -- ) ( run-time: f -- ) |
| 250 : | locals-size @ alignlp-f float+ dup locals-size ! | ||
| 251 : | swap ! | ||
| 252 : | postpone f>l ; | ||
| 253 : | |||
| 254 : | : compile-pushlocal-d ( a-addr -- ) ( run-time: w1 w2 -- ) | ||
| 255 : | locals-size @ alignlp-w cell+ cell+ dup locals-size ! | ||
| 256 : | swap ! | ||
| 257 : | postpone swap postpone >l postpone >l ; | ||
| 258 : | |||
| 259 : | : compile-pushlocal-c ( a-addr -- ) ( run-time: w -- ) | ||
| 260 : | anton | 1.3 | -1 chars compile-lp+! |
| 261 : | anton | 1.1 | locals-size @ swap ! |
| 262 : | postpone lp@ postpone c! ; | ||
| 263 : | |||
| 264 : | anton | 1.62 | 7 cells 32 + constant locals-name-size \ 32-char name + fields + wiggle room |
| 265 : | |||
| 266 : | : create-local1 ( "name" -- a-addr ) | ||
| 267 : | create | ||
| 268 : | immediate restrict | ||
| 269 : | here 0 , ( place for the offset ) ; | ||
| 270 : | |||
| 271 : | variable dict-execute-dp \ the special dp for DICT-EXECUTE | ||
| 272 : | |||
| 273 : | 0 value dict-execute-ude \ USABLE-DICTIONARY-END during DICT-EXECUTE | ||
| 274 : | |||
| 275 : | : dict-execute1 ( ... addr1 addr2 xt -- ... ) | ||
| 276 : | \ execute xt with HERE set to addr1 and USABLE-DICTIONARY-END set to addr2 | ||
| 277 : | dict-execute-dp @ dp 2>r | ||
| 278 : | dict-execute-ude ['] usable-dictionary-end defer@ 2>r | ||
| 279 : | swap to dict-execute-ude | ||
| 280 : | ['] dict-execute-ude is usable-dictionary-end | ||
| 281 : | swap to dict-execute-dp | ||
| 282 : | dict-execute-dp dpp ! | ||
| 283 : | catch | ||
| 284 : | 2r> is usable-dictionary-end to dict-execute-ude | ||
| 285 : | 2r> dpp ! dict-execute-dp ! | ||
| 286 : | throw ; | ||
| 287 : | |||
| 288 : | defer dict-execute ( ... addr1 addr2 xt -- ... ) | ||
| 289 : | |||
| 290 : | :noname ( ... addr1 addr2 xt -- ... ) | ||
| 291 : | \ first have a dummy routine, for SOME-CLOCAL etc. below | ||
| 292 : | nip nip execute ; | ||
| 293 : | is dict-execute | ||
| 294 : | |||
| 295 : | anton | 1.1 | : create-local ( " name" -- a-addr ) |
| 296 : | anton | 1.9 | \ defines the local "name"; the offset of the local shall be |
| 297 : | \ stored in a-addr | ||
| 298 : | anton | 1.62 | locals-name-size allocate throw |
| 299 : | dup locals-mem-list prepend-list | ||
| 300 : | locals-name-size cell /string over + ['] create-local1 dict-execute ; | ||
| 301 : | |||
| 302 : | variable locals-dp \ so here's the special dp for locals. | ||
| 303 : | anton | 1.1 | |
| 304 : | anton | 1.3 | : lp-offset ( n1 -- n2 ) |
| 305 : | \ converts the offset from the frame start to an offset from lp and | ||
| 306 : | \ i.e., the address of the local is lp+locals_size-offset | ||
| 307 : | locals-size @ swap - ; | ||
| 308 : | |||
| 309 : | anton | 1.1 | : lp-offset, ( n -- ) |
| 310 : | \ converts the offset from the frame start to an offset from lp and | ||
| 311 : | \ adds it as inline argument to a preceding locals primitive | ||
| 312 : | anton | 1.3 | lp-offset , ; |
| 313 : | anton | 1.1 | |
| 314 : | vocabulary locals-types \ this contains all the type specifyers, -- and } | ||
| 315 : | locals-types definitions | ||
| 316 : | |||
| 317 : | anton | 1.14 | : W: ( "name" -- a-addr xt ) \ gforth w-colon |
| 318 : | create-local | ||
| 319 : | anton | 1.1 | \ xt produces the appropriate locals pushing code when executed |
| 320 : | ['] compile-pushlocal-w | ||
| 321 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 322 : | \ compiles a local variable access | ||
| 323 : | anton | 1.3 | @ lp-offset compile-@local ; |
| 324 : | anton | 1.1 | |
| 325 : | anton | 1.14 | : W^ ( "name" -- a-addr xt ) \ gforth w-caret |
| 326 : | create-local | ||
| 327 : | anton | 1.1 | ['] compile-pushlocal-w |
| 328 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 329 : | postpone laddr# @ lp-offset, ; | ||
| 330 : | |||
| 331 : | anton | 1.14 | : F: ( "name" -- a-addr xt ) \ gforth f-colon |
| 332 : | create-local | ||
| 333 : | anton | 1.1 | ['] compile-pushlocal-f |
| 334 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 335 : | anton | 1.3 | @ lp-offset compile-f@local ; |
| 336 : | anton | 1.1 | |
| 337 : | anton | 1.14 | : F^ ( "name" -- a-addr xt ) \ gforth f-caret |
| 338 : | create-local | ||
| 339 : | anton | 1.1 | ['] compile-pushlocal-f |
| 340 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 341 : | postpone laddr# @ lp-offset, ; | ||
| 342 : | |||
| 343 : | anton | 1.14 | : D: ( "name" -- a-addr xt ) \ gforth d-colon |
| 344 : | create-local | ||
| 345 : | anton | 1.1 | ['] compile-pushlocal-d |
| 346 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 347 : | postpone laddr# @ lp-offset, postpone 2@ ; | ||
| 348 : | |||
| 349 : | anton | 1.14 | : D^ ( "name" -- a-addr xt ) \ gforth d-caret |
| 350 : | create-local | ||
| 351 : | anton | 1.1 | ['] compile-pushlocal-d |
| 352 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 353 : | postpone laddr# @ lp-offset, ; | ||
| 354 : | |||
| 355 : | anton | 1.14 | : C: ( "name" -- a-addr xt ) \ gforth c-colon |
| 356 : | create-local | ||
| 357 : | anton | 1.1 | ['] compile-pushlocal-c |
| 358 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 359 : | postpone laddr# @ lp-offset, postpone c@ ; | ||
| 360 : | |||
| 361 : | anton | 1.14 | : C^ ( "name" -- a-addr xt ) \ gforth c-caret |
| 362 : | create-local | ||
| 363 : | anton | 1.1 | ['] compile-pushlocal-c |
| 364 : | does> ( Compilation: -- ) ( Run-time: -- w ) | ||
| 365 : | postpone laddr# @ lp-offset, ; | ||
| 366 : | |||
| 367 : | \ you may want to make comments in a locals definitions group: | ||
| 368 : | anton | 1.44 | ' \ alias \ ( compilation 'ccc<newline>' -- ; run-time -- ) \ core-ext,block-ext backslash |
| 369 : | anton | 1.42 | \G Comment till the end of the line if @code{BLK} contains 0 (i.e., |
| 370 : | \G while not loading a block), parse and discard the remainder of the | ||
| 371 : | \G parse area. Otherwise, parse and discard all subsequent characters | ||
| 372 : | \G in the parse area corresponding to the current line. | ||
| 373 : | immediate | ||
| 374 : | crook | 1.39 | |
| 375 : | ' ( alias ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren | ||
| 376 : | anton | 1.42 | \G Comment, usually till the next @code{)}: parse and discard all |
| 377 : | \G subsequent characters in the parse area until ")" is | ||
| 378 : | \G encountered. During interactive input, an end-of-line also acts as | ||
| 379 : | \G a comment terminator. For file input, it does not; if the | ||
| 380 : | \G end-of-file is encountered whilst parsing for the ")" delimiter, | ||
| 381 : | \G Gforth will generate a warning. | ||
| 382 : | crook | 1.39 | immediate |
| 383 : | anton | 1.1 | |
| 384 : | forth definitions | ||
| 385 : | anton | 1.54 | also locals-types |
| 386 : | |||
| 387 : | \ these "locals" are used for comparison in TO | ||
| 388 : | c: some-clocal 2drop | ||
| 389 : | d: some-dlocal 2drop | ||
| 390 : | f: some-flocal 2drop | ||
| 391 : | w: some-wlocal 2drop | ||
| 392 : | anton | 1.62 | |
| 393 : | ' dict-execute1 is dict-execute \ now the real thing | ||
| 394 : | anton | 1.54 | |
| 395 : | anton | 1.1 | \ the following gymnastics are for declaring locals without type specifier. |
| 396 : | \ we exploit a feature of our dictionary: every wordlist | ||
| 397 : | \ has it's own methods for finding words etc. | ||
| 398 : | \ So we create a vocabulary new-locals, that creates a 'w:' local named x | ||
| 399 : | \ when it is asked if it contains x. | ||
| 400 : | |||
| 401 : | : new-locals-find ( caddr u w -- nfa ) | ||
| 402 : | \ this is the find method of the new-locals vocabulary | ||
| 403 : | \ make a new local with name caddr u; w is ignored | ||
| 404 : | \ the returned nfa denotes a word that produces what W: produces | ||
| 405 : | \ !! do the whole thing without nextname | ||
| 406 : | anton | 1.3 | drop nextname |
| 407 : | anton | 1.43 | ['] W: >head-noprim ; |
| 408 : | anton | 1.1 | |
| 409 : | previous | ||
| 410 : | |||
| 411 : | : new-locals-reveal ( -- ) | ||
| 412 : | true abort" this should not happen: new-locals-reveal" ; | ||
| 413 : | |||
| 414 : | anton | 1.22 | create new-locals-map ( -- wordlist-map ) |
| 415 : | anton | 1.29 | ' new-locals-find A, |
| 416 : | ' new-locals-reveal A, | ||
| 417 : | ' drop A, \ rehash method | ||
| 418 : | jwilke | 1.34 | ' drop A, |
| 419 : | anton | 1.1 | |
| 420 : | jwilke | 1.41 | new-locals-map mappedwordlist Constant new-locals-wl |
| 421 : | |||
| 422 : | \ slowvoc @ | ||
| 423 : | \ slowvoc on | ||
| 424 : | \ vocabulary new-locals | ||
| 425 : | \ slowvoc ! | ||
| 426 : | \ new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words | ||
| 427 : | anton | 1.1 | |
| 428 : | \ and now, finally, the user interface words | ||
| 429 : | anton | 1.53 | : { ( -- latestxt wid 0 ) \ gforth open-brace |
| 430 : | latestxt get-current | ||
| 431 : | jwilke | 1.41 | get-order new-locals-wl swap 1+ set-order |
| 432 : | anton | 1.32 | also locals definitions locals-types |
| 433 : | anton | 1.1 | 0 TO locals-wordlist |
| 434 : | 0 postpone [ ; immediate | ||
| 435 : | |||
| 436 : | locals-types definitions | ||
| 437 : | |||
| 438 : | anton | 1.53 | : } ( latestxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace |
| 439 : | anton | 1.1 | \ ends locals definitions |
| 440 : | anton | 1.61 | ] |
| 441 : | anton | 1.1 | begin |
| 442 : | dup | ||
| 443 : | while | ||
| 444 : | execute | ||
| 445 : | repeat | ||
| 446 : | drop | ||
| 447 : | locals-size @ alignlp-f locals-size ! \ the strictest alignment | ||
| 448 : | previous previous | ||
| 449 : | anton | 1.32 | set-current lastcfa ! |
| 450 : | pazsan | 1.37 | locals-list 0 wordlist-id - TO locals-wordlist ; |
| 451 : | anton | 1.1 | |
| 452 : | anton | 1.14 | : -- ( addr wid 0 ... -- ) \ gforth dash-dash |
| 453 : | anton | 1.1 | } |
| 454 : | anton | 1.9 | [char] } parse 2drop ; |
| 455 : | anton | 1.1 | |
| 456 : | forth definitions | ||
| 457 : | |||
| 458 : | \ A few thoughts on automatic scopes for locals and how they can be | ||
| 459 : | \ implemented: | ||
| 460 : | |||
| 461 : | \ We have to combine locals with the control structures. My basic idea | ||
| 462 : | \ was to start the life of a local at the declaration point. The life | ||
| 463 : | \ would end at any control flow join (THEN, BEGIN etc.) where the local | ||
| 464 : | \ is lot live on both input flows (note that the local can still live in | ||
| 465 : | \ other, later parts of the control flow). This would make a local live | ||
| 466 : | \ as long as you expected and sometimes longer (e.g. a local declared in | ||
| 467 : | \ a BEGIN..UNTIL loop would still live after the UNTIL). | ||
| 468 : | |||
| 469 : | \ The following example illustrates the problems of this approach: | ||
| 470 : | |||
| 471 : | \ { z } | ||
| 472 : | \ if | ||
| 473 : | \ { x } | ||
| 474 : | \ begin | ||
| 475 : | \ { y } | ||
| 476 : | \ [ 1 cs-roll ] then | ||
| 477 : | \ ... | ||
| 478 : | \ until | ||
| 479 : | |||
| 480 : | \ x lives only until the BEGIN, but the compiler does not know this | ||
| 481 : | \ until it compiles the UNTIL (it can deduce it at the THEN, because at | ||
| 482 : | \ that point x lives in no thread, but that does not help much). This is | ||
| 483 : | \ solved by optimistically assuming at the BEGIN that x lives, but | ||
| 484 : | \ warning at the UNTIL that it does not. The user is then responsible | ||
| 485 : | \ for checking that x is only used where it lives. | ||
| 486 : | |||
| 487 : | \ The produced code might look like this (leaving out alignment code): | ||
| 488 : | |||
| 489 : | \ >l ( z ) | ||
| 490 : | \ ?branch <then> | ||
| 491 : | \ >l ( x ) | ||
| 492 : | \ <begin>: | ||
| 493 : | \ >l ( y ) | ||
| 494 : | \ lp+!# 8 ( RIP: x,y ) | ||
| 495 : | \ <then>: | ||
| 496 : | \ ... | ||
| 497 : | \ lp+!# -4 ( adjust lp to <begin> state ) | ||
| 498 : | \ ?branch <begin> | ||
| 499 : | \ lp+!# 4 ( undo adjust ) | ||
| 500 : | |||
| 501 : | \ The BEGIN problem also has another incarnation: | ||
| 502 : | |||
| 503 : | \ AHEAD | ||
| 504 : | \ BEGIN | ||
| 505 : | \ x | ||
| 506 : | \ [ 1 CS-ROLL ] THEN | ||
| 507 : | \ { x } | ||
| 508 : | \ ... | ||
| 509 : | \ UNTIL | ||
| 510 : | |||
| 511 : | \ should be legal: The BEGIN is not a control flow join in this case, | ||
| 512 : | \ since it cannot be entered from the top; therefore the definition of x | ||
| 513 : | \ dominates the use. But the compiler processes the use first, and since | ||
| 514 : | \ it does not look ahead to notice the definition, it will complain | ||
| 515 : | \ about it. Here's another variation of this problem: | ||
| 516 : | |||
| 517 : | \ IF | ||
| 518 : | \ { x } | ||
| 519 : | \ ELSE | ||
| 520 : | \ ... | ||
| 521 : | \ AHEAD | ||
| 522 : | \ BEGIN | ||
| 523 : | \ x | ||
| 524 : | \ [ 2 CS-ROLL ] THEN | ||
| 525 : | \ ... | ||
| 526 : | \ UNTIL | ||
| 527 : | |||
| 528 : | \ In this case x is defined before the use, and the definition dominates | ||
| 529 : | \ the use, but the compiler does not know this until it processes the | ||
| 530 : | \ UNTIL. So what should the compiler assume does live at the BEGIN, if | ||
| 531 : | \ the BEGIN is not a control flow join? The safest assumption would be | ||
| 532 : | \ the intersection of all locals lists on the control flow | ||
| 533 : | \ stack. However, our compiler assumes that the same variables are live | ||
| 534 : | \ as on the top of the control flow stack. This covers the following case: | ||
| 535 : | |||
| 536 : | \ { x } | ||
| 537 : | \ AHEAD | ||
| 538 : | \ BEGIN | ||
| 539 : | \ x | ||
| 540 : | \ [ 1 CS-ROLL ] THEN | ||
| 541 : | \ ... | ||
| 542 : | \ UNTIL | ||
| 543 : | |||
| 544 : | \ If this assumption is too optimistic, the compiler will warn the user. | ||
| 545 : | |||
| 546 : | anton | 1.28 | \ Implementation: |
| 547 : | anton | 1.1 | |
| 548 : | anton | 1.3 | \ explicit scoping |
| 549 : | anton | 1.1 | |
| 550 : | anton | 1.14 | : scope ( compilation -- scope ; run-time -- ) \ gforth |
| 551 : | pazsan | 1.36 | cs-push-part scopestart ; immediate |
| 552 : | |||
| 553 : | : adjust-locals-list ( wid -- ) | ||
| 554 : | pazsan | 1.37 | locals-list @ common-list |
| 555 : | pazsan | 1.36 | dup list-size adjust-locals-size |
| 556 : | pazsan | 1.37 | locals-list ! ; |
| 557 : | anton | 1.3 | |
| 558 : | anton | 1.14 | : endscope ( compilation scope -- ; run-time -- ) \ gforth |
| 559 : | pazsan | 1.36 | scope? |
| 560 : | drop adjust-locals-list ; immediate | ||
| 561 : | anton | 1.1 | |
| 562 : | anton | 1.3 | \ adapt the hooks |
| 563 : | anton | 1.1 | |
| 564 : | anton | 1.3 | : locals-:-hook ( sys -- sys addr xt n ) |
| 565 : | \ addr is the nfa of the defined word, xt its xt | ||
| 566 : | anton | 1.1 | DEFERS :-hook |
| 567 : | anton | 1.53 | latest latestxt |
| 568 : | anton | 1.1 | clear-leave-stack |
| 569 : | 0 locals-size ! | ||
| 570 : | pazsan | 1.37 | 0 locals-list ! |
| 571 : | anton | 1.3 | dead-code off |
| 572 : | defstart ; | ||
| 573 : | anton | 1.1 | |
| 574 : | pazsan | 1.68 | [IFDEF] free-old-local-names |
| 575 : | anton | 1.67 | :noname ( -- ) |
| 576 : | locals-mem-list @ free-list | ||
| 577 : | 0 locals-mem-list ! ; | ||
| 578 : | is free-old-local-names | ||
| 579 : | pazsan | 1.68 | [THEN] |
| 580 : | anton | 1.67 | |
| 581 : | anton | 1.3 | : locals-;-hook ( sys addr xt sys -- sys ) |
| 582 : | def? | ||
| 583 : | anton | 1.1 | 0 TO locals-wordlist |
| 584 : | anton | 1.3 | 0 adjust-locals-size ( not every def ends with an exit ) |
| 585 : | anton | 1.1 | lastcfa ! last ! |
| 586 : | DEFERS ;-hook ; | ||
| 587 : | |||
| 588 : | anton | 1.28 | \ THEN (another control flow from before joins the current one): |
| 589 : | \ The new locals-list is the intersection of the current locals-list and | ||
| 590 : | \ the orig-local-list. The new locals-size is the (alignment-adjusted) | ||
| 591 : | \ size of the new locals-list. The following code is generated: | ||
| 592 : | \ lp+!# (current-locals-size - orig-locals-size) | ||
| 593 : | \ <then>: | ||
| 594 : | \ lp+!# (orig-locals-size - new-locals-size) | ||
| 595 : | |||
| 596 : | \ Of course "lp+!# 0" is not generated. Still this is admittedly a bit | ||
| 597 : | \ inefficient, e.g. if there is a locals declaration between IF and | ||
| 598 : | \ ELSE. However, if ELSE generates an appropriate "lp+!#" before the | ||
| 599 : | \ branch, there will be none after the target <then>. | ||
| 600 : | |||
| 601 : | anton | 1.30 | : (then-like) ( orig -- ) |
| 602 : | dead-orig = | ||
| 603 : | pazsan | 1.27 | if |
| 604 : | anton | 1.30 | >resolve drop |
| 605 : | pazsan | 1.27 | else |
| 606 : | dead-code @ | ||
| 607 : | if | ||
| 608 : | anton | 1.30 | >resolve set-locals-size-list dead-code off |
| 609 : | pazsan | 1.27 | else \ both live |
| 610 : | anton | 1.30 | over list-size adjust-locals-size |
| 611 : | >resolve | ||
| 612 : | pazsan | 1.36 | adjust-locals-list |
| 613 : | pazsan | 1.27 | then |
| 614 : | then ; | ||
| 615 : | |||
| 616 : | : (begin-like) ( -- ) | ||
| 617 : | dead-code @ if | ||
| 618 : | \ set up an assumption of the locals visible here. if the | ||
| 619 : | \ users want something to be visible, they have to declare | ||
| 620 : | \ that using ASSUME-LIVE | ||
| 621 : | backedge-locals @ set-locals-size-list | ||
| 622 : | then | ||
| 623 : | dead-code off ; | ||
| 624 : | |||
| 625 : | \ AGAIN (the current control flow joins another, earlier one): | ||
| 626 : | \ If the dest-locals-list is not a subset of the current locals-list, | ||
| 627 : | \ issue a warning (see below). The following code is generated: | ||
| 628 : | \ lp+!# (current-local-size - dest-locals-size) | ||
| 629 : | \ branch <begin> | ||
| 630 : | |||
| 631 : | : (again-like) ( dest -- addr ) | ||
| 632 : | over list-size adjust-locals-size | ||
| 633 : | swap check-begin POSTPONE unreachable ; | ||
| 634 : | |||
| 635 : | \ UNTIL (the current control flow may join an earlier one or continue): | ||
| 636 : | \ Similar to AGAIN. The new locals-list and locals-size are the current | ||
| 637 : | \ ones. The following code is generated: | ||
| 638 : | \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size) | ||
| 639 : | |||
| 640 : | : (until-like) ( list addr xt1 xt2 -- ) | ||
| 641 : | \ list and addr are a fragment of a cs-item | ||
| 642 : | \ xt1 is the conditional branch without lp adjustment, xt2 is with | ||
| 643 : | >r >r | ||
| 644 : | locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment ) | ||
| 645 : | r> drop r> compile, | ||
| 646 : | swap <resolve ( list adjustment ) , | ||
| 647 : | else ( list dest-addr adjustment ) | ||
| 648 : | drop | ||
| 649 : | r> compile, <resolve | ||
| 650 : | r> drop | ||
| 651 : | then ( list ) | ||
| 652 : | check-begin ; | ||
| 653 : | |||
| 654 : | : (exit-like) ( -- ) | ||
| 655 : | 0 adjust-locals-size ; | ||
| 656 : | |||
| 657 : | anton | 1.1 | ' locals-:-hook IS :-hook |
| 658 : | ' locals-;-hook IS ;-hook | ||
| 659 : | pazsan | 1.27 | |
| 660 : | anton | 1.67 | |
| 661 : | pazsan | 1.27 | ' (then-like) IS then-like |
| 662 : | ' (begin-like) IS begin-like | ||
| 663 : | ' (again-like) IS again-like | ||
| 664 : | ' (until-like) IS until-like | ||
| 665 : | ' (exit-like) IS exit-like | ||
| 666 : | anton | 1.1 | |
| 667 : | \ The words in the locals dictionary space are not deleted until the end | ||
| 668 : | \ of the current word. This is a bit too conservative, but very simple. | ||
| 669 : | |||
| 670 : | \ There are a few cases to consider: (see above) | ||
| 671 : | |||
| 672 : | \ after AGAIN, AHEAD, EXIT (the current control flow is dead): | ||
| 673 : | \ We have to special-case the above cases against that. In this case the | ||
| 674 : | \ things above are not control flow joins. Everything should be taken | ||
| 675 : | \ over from the live flow. No lp+!# is generated. | ||
| 676 : | |||
| 677 : | \ About warning against uses of dead locals. There are several options: | ||
| 678 : | |||
| 679 : | \ 1) Do not complain (After all, this is Forth;-) | ||
| 680 : | |||
| 681 : | \ 2) Additional restrictions can be imposed so that the situation cannot | ||
| 682 : | \ arise; the programmer would have to introduce explicit scoping | ||
| 683 : | \ declarations in cases like the above one. I.e., complain if there are | ||
| 684 : | \ locals that are live before the BEGIN but not before the corresponding | ||
| 685 : | \ AGAIN (replace DO etc. for BEGIN and UNTIL etc. for AGAIN). | ||
| 686 : | |||
| 687 : | \ 3) The real thing: i.e. complain, iff a local lives at a BEGIN, is | ||
| 688 : | \ used on a path starting at the BEGIN, and does not live at the | ||
| 689 : | \ corresponding AGAIN. This is somewhat hard to implement. a) How does | ||
| 690 : | \ the compiler know when it is working on a path starting at a BEGIN | ||
| 691 : | \ (consider "{ x } if begin [ 1 cs-roll ] else x endif again")? b) How | ||
| 692 : | \ is the usage info stored? | ||
| 693 : | |||
| 694 : | \ For now I'll resort to alternative 2. When it produces warnings they | ||
| 695 : | \ will often be spurious, but warnings should be rare. And better | ||
| 696 : | \ spurious warnings now and then than days of bug-searching. | ||
| 697 : | |||
| 698 : | \ Explicit scoping of locals is implemented by cs-pushing the current | ||
| 699 : | \ locals-list and -size (and an unused cell, to make the size equal to | ||
| 700 : | \ the other entries) at the start of the scope, and restoring them at | ||
| 701 : | \ the end of the scope to the intersection, like THEN does. | ||
| 702 : | |||
| 703 : | |||
| 704 : | \ And here's finally the ANS standard stuff | ||
| 705 : | |||
| 706 : | anton | 1.14 | : (local) ( addr u -- ) \ local paren-local-paren |
| 707 : | anton | 1.3 | \ a little space-inefficient, but well deserved ;-) |
| 708 : | \ In exchange, there are no restrictions whatsoever on using (local) | ||
| 709 : | anton | 1.4 | \ as long as you use it in a definition |
| 710 : | anton | 1.3 | dup |
| 711 : | if | ||
| 712 : | nextname POSTPONE { [ also locals-types ] W: } [ previous ] | ||
| 713 : | else | ||
| 714 : | 2drop | ||
| 715 : | endif ; | ||
| 716 : | anton | 1.1 | |
| 717 : | anton | 1.56 | : >definer ( xt -- definer ) \ gforth |
| 718 : | anton | 1.48 | \G @var{Definer} is a unique identifier for the way the @var{xt} |
| 719 : | \G was defined. Words defined with different @code{does>}-codes | ||
| 720 : | \G have different definers. The definer can be used for | ||
| 721 : | \G comparison and in @code{definer!}. | ||
| 722 : | anton | 1.30 | dup >does-code |
| 723 : | ?dup-if | ||
| 724 : | nip 1 or | ||
| 725 : | anton | 1.4 | else |
| 726 : | >code-address | ||
| 727 : | then ; | ||
| 728 : | |||
| 729 : | anton | 1.56 | : definer! ( definer xt -- ) \ gforth |
| 730 : | anton | 1.48 | \G The word represented by @var{xt} changes its behaviour to the |
| 731 : | \G behaviour associated with @var{definer}. | ||
| 732 : | anton | 1.4 | over 1 and if |
| 733 : | anton | 1.13 | swap [ 1 invert ] literal and does-code! |
| 734 : | anton | 1.4 | else |
| 735 : | code-address! | ||
| 736 : | then ; | ||
| 737 : | |||
| 738 : | pazsan | 1.23 | :noname |
| 739 : | anton | 1.31 | ' dup >definer [ ' locals-wordlist ] literal >definer = |
| 740 : | pazsan | 1.23 | if |
| 741 : | >body ! | ||
| 742 : | else | ||
| 743 : | -&32 throw | ||
| 744 : | endif ; | ||
| 745 : | :noname | ||
| 746 : | anton | 1.28 | comp' drop dup >definer |
| 747 : | anton | 1.21 | case |
| 748 : | anton | 1.30 | [ ' locals-wordlist ] literal >definer \ value |
| 749 : | anton | 1.21 | OF >body POSTPONE Aliteral POSTPONE ! ENDOF |
| 750 : | anton | 1.35 | \ !! dependent on c: etc. being does>-defining words |
| 751 : | \ this works, because >definer uses >does-code in this case, | ||
| 752 : | \ which produces a relocatable address | ||
| 753 : | anton | 1.54 | [ comp' some-clocal drop ] literal >definer |
| 754 : | anton | 1.21 | OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF |
| 755 : | anton | 1.54 | [ comp' some-wlocal drop ] literal >definer |
| 756 : | anton | 1.21 | OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF |
| 757 : | anton | 1.54 | [ comp' some-dlocal drop ] literal >definer |
| 758 : | anton | 1.21 | OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF |
| 759 : | anton | 1.54 | [ comp' some-flocal drop ] literal >definer |
| 760 : | anton | 1.21 | OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF |
| 761 : | -&32 throw | ||
| 762 : | pazsan | 1.23 | endcase ; |
| 763 : | anton | 1.24 | interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local |
| 764 : | anton | 1.1 | |
| 765 : | anton | 1.58 | : locals| ( ... "name ..." -- ) \ local-ext locals-bar |
| 766 : | anton | 1.14 | \ don't use 'locals|'! use '{'! A portable and free '{' |
| 767 : | anton | 1.21 | \ implementation is compat/anslocals.fs |
| 768 : | anton | 1.8 | BEGIN |
| 769 : | anton | 1.49 | name 2dup s" |" str= 0= |
| 770 : | anton | 1.8 | WHILE |
| 771 : | (local) | ||
| 772 : | REPEAT | ||
| 773 : | anton | 1.14 | drop 0 (local) ; immediate restrict |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |