1.15 anton 1: \ A powerful locals implementation 2: 1.59 anton 3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2007 87: require search.fs 1.14 anton 88: require float.fs 1.47 jwilke 89: require extend.fs \ for case 1.1 anton 90: 1.62 ! anton 91: : save-mem-dict ( addr1 u -- addr2 u ) ! 92: here swap dup allot ( addr1 addr2 u ) ! 93: 2dup 2>r move 2r> ; ! 94: 1.14 anton 95: : compile-@local ( n -- ) \ gforth compile-fetch-local 1.3 anton 96: case 1.7 pazsan 97: 0 of postpone @local0 endof 98: 1 cells of postpone @local1 endof 99: 2 cells of postpone @local2 endof 100: 3 cells of postpone @local3 endof 1.3 anton 101: ( otherwise ) dup postpone @local# , 102: endcase ; 103: 1.14 anton 104: : compile-f@local ( n -- ) \ gforth compile-f-fetch-local 1.3 anton 105: case 1.7 pazsan 106: 0 of postpone f@local0 endof 107: 1 floats of postpone f@local1 endof 1.3 anton 108: ( otherwise ) dup postpone f@local# , 109: endcase ; 110: 1.27 pazsan: 1.1 anton: 1.5 anton 133: slowvoc @ 134: slowvoc on \ we want a linked list for the vocabulary locals 1.1 anton 135: vocabulary locals \ this contains the local variables 1.37 pazsan 136: ' locals >body wordlist-id ' locals-list >body ! 1.5 anton 137: slowvoc ! 1.1 anton 138: 1.62 ! anton 139: variable locals-mem-list \ linked list of all locals name memory in ! 140: 0 locals-mem-list ! \ the current (outer-level) definition 1.1 anton 141: 1.62 ! anton 1.1 anton 155: 156: : alignlp-w ( n1 -- n2 ) 157: \ cell-align size and generate the corresponding code for aligning lp 1.3 anton 158: aligned dup adjust-locals-size ; 1.1 anton 159: 160: : alignlp-f ( n1 -- n2 ) 1.3 anton 161: faligned dup adjust-locals-size ; 1.1 anton: 1.27 pazsan 1.36 pazsan 201: \ size of the locals frame represented by list 202: 0 ( list n ) 203: begin 204: over 0<> 205: while 206: over 207: ((name>)) >body @ max 208: swap @ swap ( get next ) 209: repeat 210: faligned nip ; 1.27 pazsan 211: 212: : set-locals-size-list ( list -- ) 1.37 pazsan 213: dup locals-list ! 1.36 pazsan 214: list-size locals-size ! ; 1.27 pazsan 215: 216: : check-begin ( list -- ) 217: \ warn if list is not a sublist of locals-list 1.37 pazsan 218: locals-list @ sub-list? 0= if 1.27 pazsan 219: \ !! print current position 220: ." compiler was overly optimistic about locals at a BEGIN" cr 221: \ !! print assumption and reality 222: then ; 223: 1.1 anton -- ) 1.3 anton 235: -1 chars compile-lp+! 1.1 anton 236: locals-size @ swap ! 237: postpone lp@ postpone c! ; 238: 1.62 ! anton: 1.1 anton 270: : create-local ( " name" -- a-addr ) 1.9 anton 271: \ defines the local "name"; the offset of the local shall be 272: \ stored in a-addr 1.62 ! anton 273: locals-name-size allocate throw ! 274: dup locals-mem-list prepend-list ! 275: locals-name-size cell /string over + ['] create-local1 dict-execute ; ! 276: ! 277: variable locals-dp \ so here's the special dp for locals. 1.1 anton 278: 1.3 anton 279: : lp-offset ( n1 -- n2 ) 280: \ converts the offset from the frame start to an offset from lp and 281: \ i.e., the address of the local is lp+locals_size-offset 282: locals-size @ swap - ; 283: 1.1 anton 284: : lp-offset, ( n -- ) 285: \ converts the offset from the frame start to an offset from lp and 286: \ adds it as inline argument to a preceding locals primitive 1.3 anton 287: lp-offset , ; 1.1 anton 288: 289: vocabulary locals-types \ this contains all the type specifyers, -- and } 290: locals-types definitions 291: 1.14 anton 292: : W: ( "name" -- a-addr xt ) \ gforth w-colon 293: create-local 1.1 anton 294: \ xt produces the appropriate locals pushing code when executed 295: ['] compile-pushlocal-w 296: does> ( Compilation: -- ) ( Run-time: -- w ) 297: \ compiles a local variable access 1.3 anton 298: @ lp-offset compile-@local ; 1.1 anton 299: 1.14 anton 300: : W^ ( "name" -- a-addr xt ) \ gforth w-caret 301: create-local 1.1 anton 302: ['] compile-pushlocal-w 303: does> ( Compilation: -- ) ( Run-time: -- w ) 304: postpone laddr# @ lp-offset, ; 305: 1.14 anton 306: : F: ( "name" -- a-addr xt ) \ gforth f-colon 307: create-local 1.1 anton 308: ['] compile-pushlocal-f 309: does> ( Compilation: -- ) ( Run-time: -- w ) 1.3 anton 310: @ lp-offset compile-f@local ; 1.1 anton 311: 1.14 anton 312: : F^ ( "name" -- a-addr xt ) \ gforth f-caret 313: create-local 1.1 anton 314: ['] compile-pushlocal-f 315: does> ( Compilation: -- ) ( Run-time: -- w ) 316: postpone laddr# @ lp-offset, ; 317: 1.14 anton 318: : D: ( "name" -- a-addr xt ) \ gforth d-colon 319: create-local 1.1 anton 320: ['] compile-pushlocal-d 321: does> ( Compilation: -- ) ( Run-time: -- w ) 322: postpone laddr# @ lp-offset, postpone 2@ ; 323: 1.14 anton 324: : D^ ( "name" -- a-addr xt ) \ gforth d-caret 325: create-local 1.1 anton 326: ['] compile-pushlocal-d 327: does> ( Compilation: -- ) ( Run-time: -- w ) 328: postpone laddr# @ lp-offset, ; 329: 1.14 anton 330: : C: ( "name" -- a-addr xt ) \ gforth c-colon 331: create-local 1.1 anton 332: ['] compile-pushlocal-c 333: does> ( Compilation: -- ) ( Run-time: -- w ) 334: postpone laddr# @ lp-offset, postpone c@ ; 335: 1.14 anton 336: : C^ ( "name" -- a-addr xt ) \ gforth c-caret 337: create-local 1.1 anton 338: ['] compile-pushlocal-c 339: does> ( Compilation: -- ) ( Run-time: -- w ) 340: postpone laddr# @ lp-offset, ; 341: 342: \ you may want to make comments in a locals definitions group: 1.44 anton 343: ' \ alias \ ( compilation 'ccc<newline>' -- ; run-time -- ) \ core-ext,block-ext backslash 1.42 an 1.39 crook 349: 350: ' ( alias ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren 1.42 anton. 1.39 crook 357: immediate 1.1 anton 358: 359: forth definitions 1.54 anton 360: also locals-types 361: 362: \ these "locals" are used for comparison in TO 363: c: some-clocal 2drop 364: d: some-dlocal 2drop 365: f: some-flocal 2drop 366: w: some-wlocal 2drop 1.62 ! anton 367: ! 368: ' dict-execute1 is dict-execute \ now the real thing 1.54 anton 369: 1.1 anton 1.3 anton 381: drop nextname 1.43 anton 382: ['] W: >head-noprim ; 1.1 anton 383: 384: previous 385: 386: : new-locals-reveal ( -- ) 387: true abort" this should not happen: new-locals-reveal" ; 388: 1.22 anton 389: create new-locals-map ( -- wordlist-map ) 1.29 anton 390: ' new-locals-find A, 391: ' new-locals-reveal A, 392: ' drop A, \ rehash method 1.34 jwilke 393: ' drop A, 1.1 anton 394: 1.41 jwilke 395: new-locals-map mappedwordlist Constant new-locals-wl 396: 397: \ slowvoc @ 398: \ slowvoc on 399: \ vocabulary new-locals 400: \ slowvoc ! 401: \ new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words 1.1 anton 402: 403: \ and now, finally, the user interface words 1.53 anton 404: : { ( -- latestxt wid 0 ) \ gforth open-brace 405: latestxt get-current 1.41 jwilke 406: get-order new-locals-wl swap 1+ set-order 1.32 anton 407: also locals definitions locals-types 1.1 anton 408: 0 TO locals-wordlist 409: 0 postpone [ ; immediate 410: 411: locals-types definitions 412: 1.53 anton 413: : } ( latestxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace 1.1 anton 414: \ ends locals definitions 1.61 anton 415: ] 1.1 anton 416: begin 417: dup 418: while 419: execute 420: repeat 421: drop 422: locals-size @ alignlp-f locals-size ! \ the strictest alignment 423: previous previous 1.32 anton 424: set-current lastcfa ! 1.37 pazsan 425: locals-list 0 wordlist-id - TO locals-wordlist ; 1.1 anton 426: 1.14 anton 427: : -- ( addr wid 0 ... -- ) \ gforth dash-dash 1.1 anton 428: } 1.9 anton 429: [char] } parse 2drop ; 1.1 anton: 1.28 anton 521: \ Implementation: 1.1 anton 522: 1.3 anton 523: \ explicit scoping 1.1 anton 524: 1.14 anton 525: : scope ( compilation -- scope ; run-time -- ) \ gforth 1.36 pazsan 526: cs-push-part scopestart ; immediate 527: 528: : adjust-locals-list ( wid -- ) 1.37 pazsan 529: locals-list @ common-list 1.36 pazsan 530: dup list-size adjust-locals-size 1.37 pazsan 531: locals-list ! ; 1.3 anton 532: 1.14 anton 533: : endscope ( compilation scope -- ; run-time -- ) \ gforth 1.36 pazsan 534: scope? 535: drop adjust-locals-list ; immediate 1.1 anton 536: 1.3 anton 537: \ adapt the hooks 1.1 anton 538: 1.3 anton 539: : locals-:-hook ( sys -- sys addr xt n ) 540: \ addr is the nfa of the defined word, xt its xt 1.1 anton 541: DEFERS :-hook 1.53 anton 542: latest latestxt 1.1 anton 543: clear-leave-stack 544: 0 locals-size ! 1.62 ! anton 545: locals-mem-list @ free-list ! 546: 0 locals-mem-list ! 1.37 pazsan 547: 0 locals-list ! 1.3 anton 548: dead-code off 549: defstart ; 1.1 anton 550: 1.3 anton 551: : locals-;-hook ( sys addr xt sys -- sys ) 552: def? 1.1 anton 553: 0 TO locals-wordlist 1.3 anton 554: 0 adjust-locals-size ( not every def ends with an exit ) 1.1 anton 555: lastcfa ! last ! 556: DEFERS ;-hook ; 557: 1.28 anton: 1.30 anton 571: : (then-like) ( orig -- ) 572: dead-orig = 1.27 pazsan 573: if 1.30 anton 574: >resolve drop 1.27 pazsan 575: else 576: dead-code @ 577: if 1.30 anton 578: >resolve set-locals-size-list dead-code off 1.27 pazsan 579: else \ both live 1.30 anton 580: over list-size adjust-locals-size 581: >resolve 1.36 pazsan 582: adjust-locals-list 1.27 pazsan: 1.1 anton 627: ' locals-:-hook IS :-hook 628: ' locals-;-hook IS ;-hook 1.27 pazsan 629: 630: ' (then-like) IS then-like 631: ' (begin-like) IS begin-like 632: ' (again-like) IS again-like 633: ' (until-like) IS until-like 634: ' (exit-like) IS exit-like 1.1 anton 635: 636: \ The words in the locals dictionary space are not deleted until the end 637: \ of the current word. This is a bit too conservative, but very simple. 638: 639: \ There are a few cases to consider: (see above) 640: 641: \ after AGAIN, AHEAD, EXIT (the current control flow is dead): 642: \ We have to special-case the above cases against that. In this case the 643: \ things above are not control flow joins. Everything should be taken 644: \ over from the live flow. No lp+!# is generated. 645: 646: \: 1.14 anton 675: : (local) ( addr u -- ) \ local paren-local-paren 1.3 anton 676: \ a little space-inefficient, but well deserved ;-) 677: \ In exchange, there are no restrictions whatsoever on using (local) 1.4 anton 678: \ as long as you use it in a definition 1.3 anton 679: dup 680: if 681: nextname POSTPONE { [ also locals-types ] W: } [ previous ] 682: else 683: 2drop 684: endif ; 1.1 anton 685: 1.56 anton 686: : >definer ( xt -- definer ) \ gforth 1.48 anton!}. 1.30 anton 691: dup >does-code 692: ?dup-if 693: nip 1 or 1.4 anton 694: else 695: >code-address 696: then ; 697: 1.56 anton 698: : definer! ( definer xt -- ) \ gforth 1.48 anton 699: \G The word represented by @var{xt} changes its behaviour to the 700: \G behaviour associated with @var{definer}. 1.4 anton 701: over 1 and if 1.13 anton 702: swap [ 1 invert ] literal and does-code! 1.4 anton 703: else 704: code-address! 705: then ; 706: 1.23 pazsan 707: :noname 1.31 anton 708: ' dup >definer [ ' locals-wordlist ] literal >definer = 1.23 pazsan 709: if 710: >body ! 711: else 712: -&32 throw 713: endif ; 714: :noname 1.28 anton 715: comp' drop dup >definer 1.21 anton 716: case 1.30 anton 717: [ ' locals-wordlist ] literal >definer \ value 1.21 anton 718: OF >body POSTPONE Aliteral POSTPONE ! ENDOF 1.35 anton 719: \ !! dependent on c: etc. being does>-defining words 720: \ this works, because >definer uses >does-code in this case, 721: \ which produces a relocatable address 1.54 anton 722: [ comp' some-clocal drop ] literal >definer 1.21 anton 723: OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF 1.54 anton 724: [ comp' some-wlocal drop ] literal >definer 1.21 anton 725: OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF 1.54 anton 726: [ comp' some-dlocal drop ] literal >definer 1.21 anton 727: OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF 1.54 anton 728: [ comp' some-flocal drop ] literal >definer 1.21 anton 729: OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF 730: -&32 throw 1.23 pazsan 731: endcase ; 1.24 anton 732: interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local 1.1 anton 733: 1.58 anton 734: : locals| ( ... "name ..." -- ) \ local-ext locals-bar 1.14 anton 735: \ don't use 'locals|'! use '{'! A portable and free '{' 1.21 anton 736: \ implementation is compat/anslocals.fs 1.8 anton 737: BEGIN 1.49 anton 738: name 2dup s" |" str= 0= 1.8 anton 739: WHILE 740: (local) 741: REPEAT 1.14 anton 742: drop 0 (local) ; immediate restrict