1\ compiler definitions 14sep97jaw 2 3\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008 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\ \ Revisions-Log 21 22\ put in seperate file 14sep97jaw 23 24\ \ here allot , c, A, 17dec92py 25 26[IFUNDEF] allot 27[IFUNDEF] forthstart 28: allot ( n -- ) \ core 29 dup unused u> -8 and throw 30 dp +! ; 31[THEN] 32[THEN] 33 34\ we default to this version if we have nothing else 05May99jaw 35[IFUNDEF] allot 36: allot ( n -- ) \ core 37 \G Reserve @i{n} address units of data space without 38 \G initialization. @i{n} is a signed number, passing a negative 39 \G @i{n} releases memory. In ANS Forth you can only deallocate 40 \G memory from the current contiguous region in this way. In 41 \G Gforth you can deallocate anything in this way but named words. 42 \G The system does not check this restriction. 43 here + 44 dup 1- usable-dictionary-end forthstart within -8 and throw 45 dp ! ; 46[THEN] 47 48: c, ( c -- ) \ core c-comma 49 \G Reserve data space for one char and store @i{c} in the space. 50 here 1 chars allot [ has? flash [IF] ] flashc! [ [ELSE] ] c! [ [THEN] ] ; 51 52: , ( w -- ) \ core comma 53 \G Reserve data space for one cell and store @i{w} in the space. 54 here cell allot [ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] ; 55 56: 2, ( w1 w2 -- ) \ gforth 57 \G Reserve data space for two cells and store the double @i{w1 58 \G w2} there, @i{w2} first (lower address). 59 here 2 cells allot [ has? flash [IF] ] tuck flash! cell+ flash! 60 [ [ELSE] ] 2! [ [THEN] ] ; 61 62\ : aligned ( addr -- addr' ) \ core 63\ [ cell 1- ] Literal + [ -1 cells ] Literal and ; 64 65: align ( -- ) \ core 66 \G If the data-space pointer is not aligned, reserve enough space to align it. 67 here dup aligned swap ?DO bl c, LOOP ; 68 69\ : faligned ( addr -- f-addr ) \ float f-aligned 70\ [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; 71 72: falign ( -- ) \ float f-align 73 \G If the data-space pointer is not float-aligned, reserve 74 \G enough space to align it. 75 here dup faligned swap 76 ?DO 77 bl c, 78 LOOP ; 79 80: maxalign ( -- ) \ gforth 81 \G Align data-space pointer for all alignment requirements. 82 here dup maxaligned swap 83 ?DO 84 bl c, 85 LOOP ; 86 87\ the code field is aligned if its body is maxaligned 88' maxalign Alias cfalign ( -- ) \ gforth 89\G Align data-space pointer for code field requirements (i.e., such 90\G that the corresponding body is maxaligned). 91 92' , alias A, ( addr -- ) \ gforth 93 94' NOOP ALIAS const 95 96\ \ Header 23feb93py 97 98\ input-stream, nextname and noname are quite ugly (passing 99\ information through global variables), but they are useful for dealing 100\ with existing/independent defining words 101 102defer (header) 103defer header ( -- ) \ gforth 104' (header) IS header 105 106: string, ( c-addr u -- ) \ gforth 107 \G puts down string as cstring 108 dup [ has? rom [IF] ] $E0 [ [ELSE] ] alias-mask [ [THEN] ] or c, 109[ has? flash [IF] ] 110 bounds ?DO I c@ c, LOOP 111[ [ELSE] ] 112 here swap chars dup allot move 113[ [THEN] ] ; 114 115: longstring, ( c-addr u -- ) \ gforth 116 \G puts down string as longcstring 117 dup , here swap chars dup allot move ; 118 119: header, ( c-addr u -- ) \ gforth 120 name-too-long? 121 dup max-name-length @ max max-name-length ! 122 align here last ! 123[ has? ec [IF] ] 124 -1 A, 125[ [ELSE] ] 126 current @ 1 or A, \ link field; before revealing, it contains the 127 \ tagged reveal-into wordlist 128[ [THEN] ] 129[ has? f83headerstring [IF] ] 130 string, 131[ [ELSE] ] 132 longstring, alias-mask lastflags cset 133[ [THEN] ] 134 cfalign ; 135 136: input-stream-header ( "name" -- ) 137 parse-name name-too-short? header, ; 138 139: input-stream ( -- ) \ general 140 \G switches back to getting the name from the input stream ; 141 ['] input-stream-header IS (header) ; 142 143' input-stream-header IS (header) 144 1452variable nextname-string 146 147has? OS [IF] 148: nextname-header ( -- ) 149 nextname-string 2@ header, 150 nextname-string free-mem-var 151 input-stream ; 152[THEN] 153 154\ the next name is given in the string 155 156has? OS [IF] 157: nextname ( c-addr u -- ) \ gforth 158 \g The next defined word will have the name @var{c-addr u}; the 159 \g defining word will leave the input stream alone. 160 name-too-long? 161 nextname-string free-mem-var 162 save-mem nextname-string 2! 163 ['] nextname-header IS (header) ; 164[THEN] 165 166: noname-header ( -- ) 167 0 last ! cfalign 168 input-stream ; 169 170: noname ( -- ) \ gforth 171 \g The next defined word will be anonymous. The defining word will 172 \g leave the input stream alone. The xt of the defined word will 173 \g be given by @code{latestxt}. 174 ['] noname-header IS (header) ; 175 176: latestxt ( -- xt ) \ gforth 177 \G @i{xt} is the execution token of the last word defined. 178 \ The main purpose of this word is to get the xt of words defined using noname 179 lastcfa @ ; 180 181' latestxt alias lastxt \ gforth-obsolete 182\G old name for @code{latestxt}. 183 184: latest ( -- nt ) \ gforth 185\G @var{nt} is the name token of the last word defined; it is 0 if the 186\G last word has no name. 187 last @ ; 188 189\ \ literals 17dec92py 190 191: Literal ( compilation n -- ; run-time -- n ) \ core 192 \G Compilation semantics: compile the run-time semantics.@* 193 \G Run-time Semantics: push @i{n}.@* 194 \G Interpretation semantics: undefined. 195[ [IFDEF] lit, ] 196 lit, 197[ [ELSE] ] 198 postpone lit , 199[ [THEN] ] ; immediate restrict 200 201: 2Literal ( compilation w1 w2 -- ; run-time -- w1 w2 ) \ double two-literal 202 \G Compile appropriate code such that, at run-time, @i{w1 w2} are 203 \G placed on the stack. Interpretation semantics are undefined. 204 swap postpone Literal postpone Literal ; immediate restrict 205 206: ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth 207[ [IFDEF] alit, ] 208 alit, 209[ [ELSE] ] 210 postpone lit A, 211[ [THEN] ] ; immediate restrict 212 213Defer char@ ( addr u -- char addr' u' ) 214:noname over c@ -rot 1 /string ; IS char@ 215 216: char ( '<spaces>ccc' -- c ) \ core 217 \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the 218 \G display code representing the first character of @i{ccc}. 219 parse-name char@ 2drop ; 220 221: [char] ( compilation '<spaces>ccc' -- ; run-time -- c ) \ core bracket-char 222 \G Compilation: skip leading spaces. Parse the string 223 \G @i{ccc}. Run-time: return @i{c}, the display code 224 \G representing the first character of @i{ccc}. Interpretation 225 \G semantics for this word are undefined. 226 char postpone Literal ; immediate restrict 227 228\ \ threading 17mar93py 229 230: cfa, ( code-address -- ) \ gforth cfa-comma 231 here 232 dup lastcfa ! 233 [ has? rom [IF] ] 2 cells allot [ [ELSE] ] 0 A, 0 , [ [THEN] ] 234 code-address! ; 235 236[IFUNDEF] compile, 237defer compile, ( xt -- ) \ core-ext compile-comma 238\G Compile the word represented by the execution token @i{xt} 239\G into the current definition. 240 241' , is compile, 242[THEN] 243 244has? ec 0= [IF] 245defer basic-block-end ( -- ) 246 247:noname ( -- ) 248 0 compile-prim1 ; 249is basic-block-end 250[THEN] 251 252has? peephole [IF] 253 254\ dynamic only 255: peephole-compile, ( xt -- ) 256 \ compile xt, appending its code to the current dynamic superinstruction 257 here swap , compile-prim1 ; 258 259: compile-to-prims, ( xt -- ) 260 \G compile xt to use primitives (and their peephole optimization) 261 \G instead of ","-ing the xt. 262 \ !! all POSTPONEs here postpone primitives; this can be optimized 263 dup >does-code if 264 ['] does-exec peephole-compile, , EXIT 265 \ dup >body POSTPONE literal ['] call peephole-compile, >does-code , EXIT 266 then 267 dup >code-address CASE 268 dovalue: OF >body ['] lit@ peephole-compile, , EXIT ENDOF 269 docon: OF >body @ ['] lit peephole-compile, , EXIT ENDOF 270 \ docon: OF >body POSTPONE literal ['] @ peephole-compile, EXIT ENDOF 271 \ docon is also used by VALUEs, so don't @ at compile time 272 docol: OF >body ['] call peephole-compile, , EXIT ENDOF 273 dovar: OF >body ['] lit peephole-compile, , EXIT ENDOF 274 douser: OF >body @ ['] useraddr peephole-compile, , EXIT ENDOF 275 dodefer: OF >body ['] lit-perform peephole-compile, , EXIT ENDOF 276 dofield: OF >body @ ['] lit+ peephole-compile, , EXIT ENDOF 277 \ dofield: OF >body @ POSTPONE literal ['] + peephole-compile, EXIT ENDOF 278 \ code words and ;code-defined words (code words could be optimized): 279 dup in-dictionary? IF drop POSTPONE literal ['] execute peephole-compile, EXIT THEN 280 ENDCASE 281 peephole-compile, ; 282 283' compile-to-prims, IS compile, 284[ELSE] 285' , is compile, 286[THEN] 287 288: !does ( addr -- ) \ gforth store-does 289 latestxt does-code! ; 290 291\ !! unused, but ifdefed/gosted in some places 292: (does>) ( R: addr -- ) 293 r> cfaligned /does-handler + !does ; \ !! no gforth-native 294 295: (does>2) ( addr -- ) 296 cfaligned /does-handler + !does ; 297 298: dodoes, ( -- ) 299 cfalign here /does-handler allot does-handler! ; 300 301: (compile) ( -- ) \ gforth-obsolete: dummy 302 true abort" (compile) doesn't work, use POSTPONE instead" ; 303 304\ \ ticks 305 306: name>comp ( nt -- w xt ) \ gforth name-to-comp 307 \G @i{w xt} is the compilation token for the word @i{nt}. 308 (name>comp) 309 1 = if 310 ['] execute 311 else 312 ['] compile, 313 then ; 314 315: [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick 316 (') postpone ALiteral ; immediate restrict 317 318: ['] ( compilation. "name" -- ; run-time. -- xt ) \ core bracket-tick 319 \g @i{xt} represents @i{name}'s interpretation 320 \g semantics. Perform @code{-14 throw} if the word has no 321 \g interpretation semantics. 322 ' postpone ALiteral ; immediate restrict 323 324: COMP' ( "name" -- w xt ) \ gforth comp-tick 325 \g Compilation token @i{w xt} represents @i{name}'s compilation semantics. 326 (') name>comp ; 327 328: [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick 329 \g Compilation token @i{w xt} represents @i{name}'s compilation semantics. 330 COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict 331 332: postpone, ( w xt -- ) \ gforth postpone-comma 333 \g Compile the compilation semantics represented by the 334 \g compilation token @i{w xt}. 335 dup ['] execute = 336 if 337 drop compile, 338 else 339 swap POSTPONE aliteral compile, 340 then ; 341 342: POSTPONE ( "name" -- ) \ core 343 \g Compiles the compilation semantics of @i{name}. 344 COMP' postpone, ; immediate 345 346\ \ recurse 17may93jaw 347 348: recurse ( compilation -- ; run-time ?? -- ?? ) \ core 349 \g Call the current definition. 350 latestxt compile, ; immediate restrict 351 352\ \ compiler loop 353 354: compiler1 ( c-addr u -- ... xt ) 355 2dup find-name dup 356 if ( c-addr u nt ) 357 nip nip name>comp 358 else 359 drop 360 2dup 2>r snumber? dup 361 IF 362 0> 363 IF 364 ['] 2literal 365 ELSE 366 ['] literal 367 THEN 368 2rdrop 369 ELSE 370 drop 2r> compiler-notfound1 371 THEN 372 then ; 373 374: [ ( -- ) \ core left-bracket 375 \G Enter interpretation state. Immediate word. 376 ['] interpreter1 IS parser1 state off ; immediate 377 378: ] ( -- ) \ core right-bracket 379 \G Enter compilation state. 380 ['] compiler1 IS parser1 state on ; 381 382\ \ Strings 22feb93py 383 384: S, ( addr u -- ) 385 \ allot string as counted string 386[ has? flash [IF] ] 387 dup c, bounds ?DO I c@ c, LOOP 388[ [ELSE] ] 389 here over char+ allot place align 390[ [THEN] ] ; 391 392: mem, ( addr u -- ) 393 \ allot the memory block HERE (do alignment yourself) 394[ has? flash [IF] ] 395 bounds ?DO I c@ c, LOOP 396[ [ELSE] ] 397 here over allot swap move 398[ [THEN] ] ; 399 400: ," ( "string"<"> -- ) 401 [char] " parse s, ; 402 403\ \ Header states 23feb93py 404 405\ problematic only for big endian machines 406 407has? f83headerstring [IF] 408: cset ( bmask c-addr -- ) 409 tuck c@ or swap c! ; 410 411: creset ( bmask c-addr -- ) 412 tuck c@ swap invert and swap c! ; 413 414: ctoggle ( bmask c-addr -- ) 415 tuck c@ xor swap c! ; 416[ELSE] 417: cset ( bmask c-addr -- ) 418 tuck @ or swap ! ; 419 420: creset ( bmask c-addr -- ) 421 tuck @ swap invert and swap ! ; 422 423: ctoggle ( bmask c-addr -- ) 424 tuck @ xor swap ! ; 425[THEN] 426 427: lastflags ( -- c-addr ) 428 \ the address of the flags byte in the last header 429 \ aborts if the last defined word was headerless 430 latest dup 0= abort" last word was headerless" cell+ ; 431 432: immediate ( -- ) \ core 433 \G Make the compilation semantics of a word be to @code{execute} 434 \G the execution semantics. 435 immediate-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ; 436 437: restrict ( -- ) \ gforth 438 \G A synonym for @code{compile-only} 439 restrict-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ; 440 441' restrict alias compile-only ( -- ) \ gforth 442\G Remove the interpretation semantics of a word. 443 444\ \ Create Variable User Constant 17mar93py 445 446: Alias ( xt "name" -- ) \ gforth 447 Header reveal 448 alias-mask lastflags creset 449 dup A, lastcfa ! ; 450 451doer? :dovar [IF] 452 453: Create ( "name" -- ) \ core 454 Header reveal dovar: cfa, ; 455[ELSE] 456 457: Create ( "name" -- ) \ core 458 Header reveal here lastcfa ! 0 A, 0 , DOES> ; 459[THEN] 460 461has? flash [IF] 462 : (variable) dpp @ normal-dp = IF Create dpp @ 463 ELSE normal-dp @ Constant dpp @ ram THEN ; 464: Variable ( "name" -- ) \ core 465 (Variable) 0 , dpp ! ; 466 467: AVariable ( "name" -- ) \ gforth 468 (Variable) 0 A, dpp ! ; 469 470: 2Variable ( "name" -- ) \ double two-variable 471 (Variable) 0 , 0 , dpp ! ; 472[ELSE] 473: Variable ( "name" -- ) \ core 474 Create 0 , ; 475 476: AVariable ( "name" -- ) \ gforth 477 Create 0 A, ; 478 479: 2Variable ( "name" -- ) \ double two-variable 480 Create 0 , 0 , ; 481[THEN] 482 483has? no-userspace 0= [IF] 484: uallot ( n -- ) \ gforth 485 udp @ swap udp +! ; 486 487doer? :douser [IF] 488 489: User ( "name" -- ) \ gforth 490 Header reveal douser: cfa, cell uallot , ; 491 492: AUser ( "name" -- ) \ gforth 493 User ; 494[ELSE] 495 496: User Create cell uallot , DOES> @ up @ + ; 497 498: AUser User ; 499[THEN] 500[THEN] 501 502doer? :docon [IF] 503 : (Constant) Header reveal docon: cfa, ; 504[ELSE] 505 : (Constant) Create DOES> @ ; 506[THEN] 507 508doer? :dovalue [IF] 509 : (Value) Header reveal dovalue: cfa, ; 510[ELSE] 511 has? rom [IF] 512 : (Value) Create DOES> @ @ ; 513 [ELSE] 514 : (Value) Create DOES> @ ; 515 [THEN] 516[THEN] 517 518: Constant ( w "name" -- ) \ core 519 \G Define a constant @i{name} with value @i{w}. 520 \G 521 \G @i{name} execution: @i{-- w} 522 (Constant) , ; 523 524: AConstant ( addr "name" -- ) \ gforth 525 (Constant) A, ; 526 527has? flash [IF] 528: Value ( w "name" -- ) \ core-ext 529 (Value) dpp @ >r here cell allot >r 530 ram here >r , r> r> flash! r> dpp ! ; 531 532' Value alias AValue 533[ELSE] 534: Value ( w "name" -- ) \ core-ext 535 (Value) , ; 536 537: AValue ( w "name" -- ) \ core-ext 538 (Value) A, ; 539[THEN] 540 541: 2Constant ( w1 w2 "name" -- ) \ double two-constant 542 Create ( w1 w2 "name" -- ) 543 2, 544 DOES> ( -- w1 w2 ) 545 2@ ; 546 547doer? :dofield [IF] 548 : (Field) Header reveal dofield: cfa, ; 549[ELSE] 550 : (Field) Create DOES> @ + ; 551[THEN] 552 553\ \ interpret/compile: 554 555struct 556 >body 557 cell% field interpret/compile-int 558 cell% field interpret/compile-comp 559end-struct interpret/compile-struct 560 561: interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth 562 Create immediate swap A, A, 563DOES> 564 abort" executed primary cfa of an interpret/compile: word" ; 565\ state @ IF cell+ THEN perform ; 566 567\ IS Defer What's Defers TO 24feb93py 568 569defer defer-default ( -- ) 570' abort is defer-default 571\ default action for deferred words (overridden by a warning later) 572 573doer? :dodefer [IF] 574 575: Defer ( "name" -- ) \ gforth 576\G Define a deferred word @i{name}; its execution semantics can be 577\G set with @code{defer!} or @code{is} (and they have to, before first 578\G executing @i{name}. 579 Header Reveal dodefer: cfa, 580 [ has? rom [IF] ] here >r cell allot 581 dpp @ ram here r> flash! ['] defer-default A, dpp ! 582 [ [ELSE] ] ['] defer-default A, [ [THEN] ] ; 583 584[ELSE] 585 586 has? rom [IF] 587 : Defer ( "name" -- ) \ gforth 588 Create here >r cell allot 589 dpp @ ram here r> flash! ['] defer-default A, dpp ! 590 DOES> @ @ execute ; 591 [ELSE] 592 : Defer ( "name" -- ) \ gforth 593 Create ['] defer-default A, 594 DOES> @ execute ; 595 [THEN] 596[THEN] 597 598: defer@ ( xt-deferred -- xt ) \ gforth defer-fetch 599\G @i{xt} represents the word currently associated with the deferred 600\G word @i{xt-deferred}. 601 >body @ [ has? rom [IF] ] @ [ [THEN] ] ; 602 603: Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth 604 \G Compiles the present contents of the deferred word @i{name} 605 \G into the current definition. I.e., this produces static 606 \G binding as if @i{name} was not deferred. 607 ' defer@ compile, ; immediate 608 609:noname 610 dodoes, here !does ] 611 defstart :-hook ; 612:noname 613 ;-hook ?struc 614 [ has? xconds [IF] ] exit-like [ [THEN] ] 615 here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells + 616 postpone aliteral postpone (does>2) [compile] exit 617 [ has? peephole [IF] ] finish-code [ [THEN] ] dodoes, 618 defstart :-hook ; 619interpret/compile: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does 620 621: defer! ( xt xt-deferred -- ) \ gforth defer-store 622\G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}. 623 >body [ has? rom [IF] ] @ [ [THEN] ] ! ; 624 625: <IS> ( "name" xt -- ) \ gforth 626 \g Changes the @code{defer}red word @var{name} to execute @var{xt}. 627 ' defer! ; 628 629: [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is 630 \g At run-time, changes the @code{defer}red word @var{name} to 631 \g execute @var{xt}. 632 ' postpone ALiteral postpone defer! ; immediate restrict 633 634' <IS> 635' [IS] 636interpret/compile: IS ( compilation/interpretation "name-deferred" -- ; run-time xt -- ) \ gforth 637\G Changes the @code{defer}red word @var{name} to execute @var{xt}. 638\G Its compilation semantics parses at compile time. 639 640' <IS> 641' [IS] 642interpret/compile: TO ( w "name" -- ) \ core-ext 643 644: interpret/compile? ( xt -- flag ) 645 >does-code ['] DOES> >does-code = ; 646 647\ \ : ; 24feb93py 648 649defer :-hook ( sys1 -- sys2 ) 650 651defer ;-hook ( sys2 -- sys1 ) 652 6530 Constant defstart 654 655[IFDEF] docol, 656: (:noname) ( -- colon-sys ) 657 \ common factor of : and :noname 658 docol, ]comp 659[ELSE] 660: (:noname) ( -- colon-sys ) 661 \ common factor of : and :noname 662 docol: cfa, 663[THEN] 664 defstart ] :-hook ; 665 666: : ( "name" -- colon-sys ) \ core colon 667 Header (:noname) ; 668 669: :noname ( -- xt colon-sys ) \ core-ext colon-no-name 670 0 last ! 671 cfalign here (:noname) ; 672 673[IFDEF] fini, 674: ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon 675 ;-hook ?struc fini, comp[ reveal postpone [ ; immediate restrict 676[ELSE] 677: ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon 678 ;-hook ?struc [compile] exit 679 [ has? peephole [IF] ] finish-code [ [THEN] ] 680 reveal postpone [ ; immediate restrict 681[THEN] 682 683\ \ Search list handling: reveal words, recursive 23feb93py 684 685: last? ( -- false / nfa nfa ) 686 latest ?dup ; 687 688Variable warnings ( -- addr ) \ gforth 689G -1 warnings T ! 690 691has? ec [IF] 692: reveal ( -- ) \ gforth 693 last? 694 if \ the last word has a header 695 dup ( name>link ) @ -1 = 696 if \ it is still hidden 697 forth-wordlist dup >r @ over 698 [ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] r> ! 699 else 700 drop 701 then 702 then ; 703[ELSE] 704: (reveal) ( nt wid -- ) 705 wordlist-id dup >r 706 @ over ( name>link ) ! 707 r> ! ; 708 709\ make entry in wordlist-map 710' (reveal) f83search reveal-method ! 711 712: check-shadow ( addr count wid -- ) 713 \G prints a warning if the string is already present in the wordlist 714 >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if 715 >stderr 716 ." redefined " name>string 2dup type 717 str= 0= if 718 ." with " type 719 else 720 2drop 721 then 722 space space EXIT 723 then 724 2drop 2drop ; 725 726: reveal ( -- ) \ gforth 727 last? 728 if \ the last word has a header 729 dup ( name>link ) @ 1 and 730 if \ it is still hidden 731 dup ( name>link ) @ 1 xor ( nt wid ) 732 2dup >r name>string r> check-shadow ( nt wid ) 733 dup wordlist-map @ reveal-method perform 734 else 735 drop 736 then 737 then ; 738 739: rehash ( wid -- ) 740 dup wordlist-map @ rehash-method perform ; 741[THEN] 742 743' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth 744\g Make the current definition visible, enabling it to call itself 745\g recursively. 746 immediate restrict 747