src/lib.4th

   1 : \ IMMEDIATE
   2         KEY
   3         10 = 0BRANCH [ -5 , ]
   4 ; \ We can now comment!
   5
   6 \ BASIC DEFINITIONS  ----------------------------------------------------------------------
   7
   8 : / /MOD SWAP DROP ;
   9 : MOD /MOD DROP ;
  10 : */ -ROT * SWAP / ;
  11
  12 : NEGATE 0 SWAP - ;
  13
  14 : TRUE -1 ;
  15 : FALSE 0 ;
  16 : NOT 0= ;
  17
  18 \ Translate a number of cells into memory units
  19 \ (in our case 1 cell = 1 memory unit)
  20 : CELLS ;
  21
  22 \ Since the smallest unit of memory in our system is 64 bits and since strings
  23 \ are stored as arrays of 64 bit integers, the character store/fetch words are
  24 \ just aliases of the standard store/fetch words.
  25 : C! ! ;
  26 : C@ @ ;
  27 : C, , ;
  28
  29 : DEPTH PSP@ PSP0 @ - ;
  30
  31 : '\n' 10 ;
  32 : BL 32 ;
  33
  34 : LITERAL IMMEDIATE ['] LIT , , ;
  35
  36 : [CHAR] IMMEDIATE
  37     CHAR
  38     ['] LIT , ,
  39 ;
  40
  41 : CR '\n' emit ;
  42 : SPACE BL emit ;
  43
  44 : [COMPILE] IMMEDIATE
  45         WORD            \ get the next word
  46         FIND            \ find it in the dictionary
  47         >CFA            \ get its codeword
  48         ,               \ and compile that
  49 ;
  50
  51 : RECURSE IMMEDIATE
  52         LATEST @        \ LATEST points to the word being compiled at the moment
  53         >CFA            \ get the codeword
  54         ,               \ compile it
  55 ;
  56
  57 : DEBUGON TRUE DEBUG ! ;
  58 : DEBUGOFF FALSE DEBUG ! ;
  59
  60 \ CONTROL STRUCTURES ----------------------------------------------------------------------
  61
  62 : IF IMMEDIATE
  63         ['] 0BRANCH ,     \ compile 0BRANCH
  64         HERE @          \ save location of the offset on the stack
  65         0 ,             \ compile a dummy offset
  66 ;
  67
  68 : THEN IMMEDIATE
  69         DUP
  70         HERE @ SWAP -   \ calculate the offset from the address saved on the stack
  71         SWAP !          \ store the offset in the back-filled location
  72 ;
  73
  74 : ELSE IMMEDIATE
  75         ['] BRANCH ,      \ definite branch to just over the false-part
  76         HERE @          \ save location of the offset on the stack
  77         0 ,             \ compile a dummy offset
  78         SWAP            \ now back-fill the original (IF) offset
  79         DUP             \ same as for THEN word above
  80         HERE @ SWAP -
  81         SWAP !
  82 ;
  83
  84 : BEGIN IMMEDIATE
  85         HERE @          \ save location on the stack
  86 ;
  87
  88 : UNTIL IMMEDIATE
  89         ['] 0BRANCH ,     \ compile 0BRANCH
  90         HERE @ -        \ calculate the offset from the address saved on the stack
  91         ,               \ compile the offset here
  92 ;
  93
  94 : AGAIN IMMEDIATE
  95         ['] BRANCH ,      \ compile BRANCH
  96         HERE @ -        \ calculate the offset back
  97         ,               \ compile the offset here
  98 ;
  99
 100 : WHILE IMMEDIATE
 101         ['] 0BRANCH ,     \ compile 0BRANCH
 102         HERE @          \ save location of the offset2 on the stack
 103         0 ,             \ compile a dummy offset2
 104 ;
 105
 106 : REPEAT IMMEDIATE
 107         ['] BRANCH ,      \ compile BRANCH
 108         SWAP            \ get the original offset (from BEGIN)
 109         HERE @ - ,      \ and compile it after BRANCH
 110         DUP
 111         HERE @ SWAP -   \ calculate the offset2
 112         SWAP !          \ and back-fill it in the original location
 113 ;
 114
 115 : UNLESS IMMEDIATE
 116         ['] NOT ,         \ compile NOT (to reverse the test)
 117         [COMPILE] IF    \ continue by calling the normal IF
 118 ;
 119
 120 : DO IMMEDIATE
 121         ['] LIT , -1 , [COMPILE] IF
 122         ['] >R , ['] >R ,
 123         ['] LIT , HERE @ 0 , ['] >R ,
 124         HERE @
 125 ;
 126
 127 : ?DO IMMEDIATE
 128         ['] 2DUP , ['] - , [COMPILE] IF
 129         ['] >R , ['] >R ,
 130         ['] LIT , HERE @ 0 , ['] >R ,
 131         HERE @
 132 ;
 133
 134 : I RSP@ 3 - @ ;
 135
 136 : J RSP@ 6 - @ ;
 137
 138 : ?LEAVE IMMEDIATE
 139         ['] 0BRANCH , 13 ,
 140         ['] R> , ['] RDROP , ['] RDROP ,
 141         ['] LIT ,  HERE @ 7 + , ['] DUP , ['] -ROT , ['] - , ['] SWAP , ['] ! ,
 142         ['] BRANCH ,
 143         0 ,
 144 ;
 145
 146 : LEAVE IMMEDIATE
 147         ['] LIT , -1 ,
 148         [COMPILE] ?LEAVE
 149 ;
 150
 151 : +LOOP IMMEDIATE
 152         ['] DUP , \ Store copy of increment
 153
 154         ['] R> , ['] SWAP , ['] R> , ['] SWAP , ['] R> , ['] SWAP , ['] + , ['] 2DUP , ['] - ,
 155         ['] SWAP , ['] >R , ['] SWAP , ['] >R , ['] SWAP , ['] >R ,
 156
 157         \ Condition differently depending on sign of increment
 158         ['] SWAP , ['] 0>= , [COMPILE] IF
 159             ['] 0<= ,
 160         [COMPILE] ELSE
 161             ['] 0> ,
 162         [COMPILE] THEN
 163
 164         \ Branch back to begining of loop kernel
 165         ['] 0BRANCH , HERE @ - ,
 166
 167         \ Clean up
 168         ['] RDROP , ['] RDROP , ['] RDROP ,
 169
 170         \ Record address of loop end for any LEAVEs to use
 171         HERE @ SWAP !
 172
 173         [COMPILE] ELSE
 174             ['] 2DROP , \ Clean up if loop was entirely skipped (?DO)
 175         [COMPILE] THEN
 176 ;
 177
 178 : LOOP IMMEDIATE
 179         ['] LIT , 1 ,
 180         [COMPILE] +LOOP
 181 ;
 182
 183
 184 \ CASE ------------------------------------------------------------------------
 185
 186 : CASE IMMEDIATE
 187         0               \ push 0 to mark the bottom of the stack
 188 ;
 189
 190 : OF IMMEDIATE
 191         ['] OVER ,        \ compile OVER
 192         ['] = ,           \ compile =
 193         [COMPILE] IF      \ compile IF
 194         ['] DROP ,        \ compile DROP
 195 ;
 196
 197 : ENDOF IMMEDIATE
 198         [COMPILE] ELSE    \ ENDOF is the same as ELSE
 199 ;
 200
 201 : ENDCASE IMMEDIATE
 202         ['] DROP ,        \ compile DROP
 203
 204         \ keep compiling THEN until we get to our zero marker
 205         BEGIN
 206                 ?DUP
 207         WHILE
 208                 [COMPILE] THEN
 209         REPEAT
 210 ;
 211
 212
 213 \ COMMENTS ----------------------------------------------------------------------
 214
 215 : ( IMMEDIATE
 216         1               \ allowed nested parens by keeping track of depth
 217         BEGIN
 218                 KEY             \ read next character
 219                 DUP [CHAR] ( = IF    \ open paren?
 220                         DROP            \ drop the open paren
 221                         1+              \ depth increases
 222                 ELSE
 223                         [CHAR] ) = IF        \ close paren?
 224                                 1-              \ depth decreases
 225                         THEN
 226                 THEN
 227         DUP 0= UNTIL            \ continue until we reach matching close paren, depth 0
 228         DROP            \ drop the depth counter
 229 ;
 230
 231 ( Some more complicated stack examples, showing the stack notation. )
 232 : NIP ( x y -- y ) SWAP DROP ;
 233 : TUCK ( x y -- y x y ) DUP -ROT ;
 234 : PICK ( x_u ... x_1 x_0 u -- x_u ... x_1 x_0 x_u )
 235         1+              ( add one because of 'u' on the stack )
 236         PSP@ SWAP -     ( add to the stack pointer )
 237         @               ( and fetch )
 238 ;
 239 : ROLL ( x_u x_u-1... x_0 u -- x_u-1 ... x_0 x_u )
 240         1+ DUP PICK SWAP    ( x_u x_u-1 ... x_0 x_u u+1 )
 241         PSP@ 1- SWAP - PSP@ 2- SWAP
 242         DO
 243             i 1+ @ i !
 244         LOOP
 245         SWAP DROP
 246 ;
 247
 248 ( With the looping constructs, we can now write SPACES, which writes n spaces to stdout. )
 249 : SPACES        ( n -- )
 250         DUP 0> IF
 251             0 DO SPACE LOOP
 252         ELSE
 253             DROP
 254         THEN
 255 ;
 256
 257 ( Standard words for manipulating BASE. )
 258 : DECIMAL ( -- ) 10 BASE ! ;
 259 : HEX ( -- ) 16 BASE ! ;
 260
 261 ( Compute absolute value. )
 262 : ABS           ( n -- |n| )
 263         dup 0< if
 264                 negate
 265         then
 266 ;
 267
 268 : MAX           ( n m -- max )
 269         2dup - 0< if
 270                 swap drop
 271         else
 272                 drop
 273         then
 274 ;
 275
 276 : MIN           ( n m -- max )
 277         2dup - 0> if
 278                 swap drop
 279         else
 280                 drop
 281         then
 282 ;
 283
 284 ( PRINTING NUMBERS ---------------------------------------------------------------------- )
 285
 286 ( This is the underlying recursive definition of U. )
 287 : U.            ( u -- )
 288         BASE @ /MOD     ( width rem quot )
 289         ?DUP IF                 ( if quotient <> 0 then )
 290                 RECURSE         ( print the quotient )
 291         THEN
 292
 293         ( print the remainder )
 294         DUP 10 < IF
 295                 [CHAR] 0             ( decimal digits 0..9 )
 296         ELSE
 297                 10 -            ( hex and beyond digits A..Z )
 298                 [CHAR] A
 299         THEN
 300         +
 301         EMIT
 302 ;
 303
 304 ( This word returns the width (in characters) of an unsigned number in the current base )
 305 : UWIDTH        ( u -- width )
 306         BASE @ /        ( rem quot )
 307         ?DUP IF         ( if quotient <> 0 then )
 308                 RECURSE 1+      ( return 1+recursive call )
 309         ELSE
 310                 1               ( return 1 )
 311         THEN
 312 ;
 313
 314 : U.R           ( u width -- )
 315         SWAP            ( width u )
 316         DUP             ( width u u )
 317         UWIDTH          ( width u uwidth )
 318         ROT            ( u uwidth width )
 319         SWAP -          ( u width-uwidth )
 320         ( At this point if the requested width is narrower, we'll have a negative number on the stack.
 321           Otherwise the number on the stack is the number of spaces to print.  But SPACES won't print
 322           a negative number of spaces anyway, so it's now safe to call SPACES ... )
 323         SPACES
 324         ( ... and then call the underlying implementation of U. )
 325         U.
 326 ;
 327
 328 : .R            ( n width -- )
 329         SWAP            ( width n )
 330         DUP 0< IF
 331                 NEGATE          ( width u )
 332                 1               ( save a flag to remember that it was negative | width n 1 )
 333                 -ROT             ( 1 width u )
 334                 SWAP            ( 1 u width )
 335                 1-              ( 1 u width-1 )
 336         ELSE
 337                 0               ( width u 0 )
 338                 -ROT             ( 0 width u )
 339                 SWAP            ( 0 u width )
 340         THEN
 341         SWAP            ( flag width u )
 342         DUP             ( flag width u u )
 343         UWIDTH          ( flag width u uwidth )
 344         ROT            ( flag u uwidth width )
 345         SWAP -          ( flag u width-uwidth )
 346
 347         SPACES          ( flag u )
 348         SWAP            ( u flag )
 349
 350         IF                      ( was it negative? print the - character )
 351                 [CHAR] - EMIT
 352         THEN
 353
 354         U.
 355 ;
 356
 357 : . 0 .R SPACE ;
 358
 359 : .S            ( -- )
 360         [CHAR] < EMIT DEPTH U. [CHAR] > EMIT SPACE
 361         PSP0 @ 1+
 362         BEGIN
 363                 DUP PSP@ 2 - <=
 364         WHILE
 365                 DUP @ .
 366                 1+
 367         REPEAT
 368         DROP
 369 ;
 370
 371 : U. U. SPACE ;
 372
 373 ( ? fetches the integer at an address and prints it. )
 374 : ? ( addr -- ) @ . ;
 375
 376 ( c a b WITHIN returns true if a <= c and c < b )
 377 : WITHIN
 378         -ROT             ( b c a )
 379         OVER            ( b c a c )
 380         <= IF
 381                 > IF            ( b c -- )
 382                         TRUE
 383                 ELSE
 384                         FALSE
 385                 THEN
 386         ELSE
 387                 2DROP           ( b c -- )
 388                 FALSE
 389         THEN
 390 ;
 391
 392
 393 ( STRINGS ---------------------------------------------------------------------- )
 394
 395
 396 ( Block copy, however, is important and novel: )
 397 : CMOVE ( src dest length -- )
 398
 399         DUP 0<= IF
 400                 EXIT
 401         THEN
 402
 403         -ROT OVER -         ( length src (dest-src) )
 404         -ROT DUP ROT + SWAP ( (dest-src) (src+length) src )
 405
 406         DO
 407                 I @         ( (dest-src) i@ )
 408                 OVER I +    ( (dest-src) i@ (dest-src+i) )
 409                 !           ( (dest-src) )
 410         LOOP
 411
 412         DROP
 413 ;
 414
 415 ( C, appends a byte to the current compiled word. )
 416 : C,
 417         HERE @ C!
 418         1 HERE +!
 419 ;
 420
 421 : S" IMMEDIATE          ( -- addr len )
 422         STATE @ IF      ( compiling? )
 423                 ['] LITSTRING ,   ( compile LITSTRING )
 424                 HERE @          ( save the address of the length word on the stack )
 425                 0 ,             ( dummy length - we don't know what it is yet )
 426                 KEY DROP
 427                 BEGIN
 428                         KEY             ( get next character of the string )
 429                         DUP [CHAR] " <>
 430                 WHILE
 431                         C,              ( copy character )
 432                 REPEAT
 433                 DROP            ( drop the double quote character at the end )
 434                 DUP             ( get the saved address of the length word )
 435                 HERE @ SWAP -   ( calculate the length )
 436                 1-              ( subtract 1 (because we measured from the start of the length word) )
 437                 SWAP !          ( and back-fill the length location )
 438         ELSE            ( immediate mode )
 439                 HERE @          ( get the start address of the temporary space )
 440                 KEY DROP
 441                 BEGIN
 442                         KEY
 443                         DUP [CHAR] " <>
 444                 WHILE
 445                         OVER C!         ( save next character )
 446                         1+              ( increment address )
 447                 REPEAT
 448                 DROP            ( drop the final " character )
 449                 HERE @ -        ( calculate the length )
 450                 HERE @          ( push the start address )
 451                 SWAP            ( addr len )
 452         THEN
 453 ;
 454
 455 : ." IMMEDIATE          ( -- )
 456         [COMPILE] S"    ( read the string, and compile LITSTRING, etc. )
 457         ['] TELL ,      ( compile the final TELL )
 458 ;
 459
 460 : .(
 461         KEY DROP
 462         BEGIN
 463                 KEY
 464                 DUP [CHAR] ) = IF
 465                         DROP    ( drop the double quote character )
 466                         EXIT    ( return from this function )
 467                 THEN
 468                 EMIT
 469         AGAIN
 470 ;
 471
 472
 473 ( CONSTANTS AND VARIABLES ------------------------------------------------------ )
 474
 475 : CONSTANT
 476         WORD HEADER     ( make dictionary entry (the name follows CONSTANT) )
 477         DOCOL ,         ( append DOCOL (the codeword field of this word) )
 478         ['] LIT ,       ( append the codeword LIT )
 479         ,               ( append the value on the top of the stack )
 480         ['] EXIT ,      ( append the codeword EXIT )
 481 ;
 482
 483 : ALLOT         ( n -- )
 484         HERE +!         ( adds n to HERE, after this the old value of HERE is still on the stack )
 485 ;
 486
 487 : VARIABLE
 488         CREATE
 489         1 CELLS ALLOT   ( allocate 1 cell of memory, push the pointer to this memory )
 490 ;
 491
 492
 493 : VALUE         ( n -- )
 494         WORD HEADER     ( make the dictionary entry (the name follows VALUE) )
 495         DOCOL ,         ( append DOCOL )
 496         ['] LIT ,       ( append the codeword LIT )
 497         ,               ( append the initial value )
 498         ['] EXIT ,      ( append the codeword EXIT )
 499 ;
 500
 501 : TO IMMEDIATE  ( n -- )
 502         WORD            ( get the name of the value )
 503         FIND            ( look it up in the dictionary )
 504         >DFA            ( get a pointer to the first data field (the 'LIT') )
 505         1+              ( increment to point at the value )
 506         STATE @ IF      ( compiling? )
 507                 ['] LIT ,         ( compile LIT )
 508                 ,               ( compile the address of the value )
 509                 ['] ! ,           ( compile ! )
 510         ELSE            ( immediate mode )
 511                 !               ( update it straightaway )
 512         THEN
 513 ;
 514
 515 ( x +TO VAL adds x to VAL )
 516 : +TO IMMEDIATE
 517         WORD            ( get the name of the value )
 518         FIND            ( look it up in the dictionary )
 519         >DFA            ( get a pointer to the first data field (the 'LIT') )
 520         1+              ( increment to point at the value )
 521         STATE @ IF      ( compiling? )
 522                 ['] LIT ,         ( compile LIT )
 523                 ,               ( compile the address of the value )
 524                 ['] +! ,          ( compile +! )
 525         ELSE            ( immediate mode )
 526                 +!              ( update it straightaway )
 527         THEN
 528 ;
 529
 530 ( Fill u ints, starting at a, with the value b )
 531 : FILL          ( a u b -- )
 532         -ROT OVER + SWAP ?DO
 533                 DUP I !
 534         LOOP
 535         DROP
 536 ;
 537
 538 : ERASE         ( a u -- )
 539         0 FILL
 540 ;
 541
 542 ( PRINTING THE DICTIONARY ------------------------------------------------------ )
 543
 544 : ID.
 545         1+              ( skip over the link pointer )
 546         DUP @           ( get the flags/length byte )
 547         F_LENMASK AND   ( mask out the flags - just want the length )
 548
 549         BEGIN
 550                 DUP 0>          ( length > 0? )
 551         WHILE
 552                 SWAP 1+         ( addr len -- len addr+1 )
 553                 DUP @           ( len addr -- len addr char | get the next character)
 554                 DUP 32 >= OVER 127 <= AND IF
 555                         EMIT    ( len addr char -- len addr | and print it)
 556                 ELSE
 557                         BASE @ SWAP HEX
 558                         ." \x" 0 .R
 559                         BASE !
 560                 THEN
 561                 SWAP 1-         ( len addr -- addr len-1    | subtract one from length )
 562         REPEAT
 563         2DROP           ( len addr -- )
 564 ;
 565
 566 : ?HIDDEN
 567         1+              ( skip over the link pointer )
 568         @               ( get the flags/length byte )
 569         F_HIDDEN AND    ( mask the F_HIDDEN flag and return it (as a truth value) )
 570 ;
 571 : ?IMMEDIATE
 572         1+              ( skip over the link pointer )
 573         @               ( get the flags/length byte )
 574         F_IMMED AND     ( mask the F_IMMED flag and return it (as a truth value) )
 575 ;
 576
 577 : WORDS
 578         LATEST @        ( start at LATEST dictionary entry )
 579         BEGIN
 580                 ?DUP            ( while link pointer is not null )
 581         WHILE
 582                 DUP ?HIDDEN NOT IF      ( ignore hidden words )
 583                         DUP ID.         ( but if not hidden, print the word )
 584                         SPACE
 585                 THEN
 586                 @               ( dereference the link pointer - go to previous word )
 587         REPEAT
 588         CR
 589 ;
 590
 591
 592 ( FORGET ---------------------------------------------------------------------- )
 593
 594 : FORGET
 595         WORD FIND       ( find the word, gets the dictionary entry address )
 596         DUP @ LATEST !  ( set LATEST to point to the previous word )
 597         HERE !          ( and store HERE with the dictionary address )
 598 ;
 599
 600 ( DUMP ------------------------------------------------------------------------ )
 601
 602 \ TODO!
 603
 604
 605 ( DECOMPILER ------------------------------------------------------------------ )
 606
 607 : CFA>
 608         LATEST @        ( start at LATEST dictionary entry )
 609         BEGIN
 610                 ?DUP            ( while link pointer is not null )
 611         WHILE
 612                 2DUP SWAP       ( cfa curr curr cfa )
 613                 < IF            ( current dictionary entry < cfa? )
 614                         NIP             ( leave curr dictionary entry on the stack )
 615                         EXIT
 616                 THEN
 617                 @               ( follow link pointer back )
 618         REPEAT
 619         DROP            ( restore stack )
 620         0               ( sorry, nothing found )
 621 ;
 622
 623 : SEE
 624         WORD FIND       ( find the dictionary entry to decompile )
 625
 626         ( Now we search again, looking for the next word in the dictionary.  This gives us
 627           the length of the word that we will be decompiling.  (Well, mostly it does). )
 628         HERE @          ( address of the end of the last compiled word )
 629         LATEST @        ( word last curr )
 630         BEGIN
 631                 2 PICK          ( word last curr word )
 632                 OVER            ( word last curr word curr )
 633                 <>              ( word last curr word<>curr? )
 634         WHILE                   ( word last curr )
 635                 NIP             ( word curr )
 636                 DUP @           ( word curr prev (which becomes: word last curr) )
 637         REPEAT
 638
 639         DROP            ( at this point, the stack is: start-of-word end-of-word )
 640         SWAP            ( end-of-word start-of-word )
 641
 642         DUP >CFA @ CASE
 643                 DOCOL OF
 644                         \ Colon definition
 645                         [CHAR] : EMIT SPACE DUP ID. SPACE
 646                         DUP ?IMMEDIATE IF ." IMMEDIATE " THEN CR
 647                 ENDOF
 648                 DOVAR OF
 649                         \ Variable definition
 650                         ." Variable " DUP ID. CR
 651                         2DROP EXIT
 652                 ENDOF
 653                 DOCON OF
 654                         \ Constant definition
 655                         ." Constant " DUP ID. CR
 656                         2DROP EXIT
 657                 ENDOF
 658
 659                 \ Unknown codeword
 660                 ." Primitive or word with unrecognized codeword." CR
 661                 DROP 2DROP EXIT
 662         ENDCASE
 663
 664         ( begin the definition with : NAME [IMMEDIATE] )
 665         ( [CHAR] : EMIT SPACE DUP ID. SPACE
 666         DUP ?IMMEDIATE IF ." IMMEDIATE " THEN CR 4 )
 667
 668         4 SPACES
 669
 670         >DFA            ( get the data address, ie. points after DOCOL | end-of-word start-of-data )
 671
 672         ( now we start decompiling until we hit the end of the word )
 673         BEGIN           ( end start )
 674                 2DUP >
 675         WHILE
 676                 DUP @           ( end start codeword )
 677
 678                 CASE
 679                 ['] LIT OF                ( is it LIT ? )
 680                         1+ DUP @                ( get next word which is the integer constant )
 681                         .                       ( and print it )
 682                 ENDOF
 683                 ['] LITSTRING OF          ( is it LITSTRING ? )
 684                         [CHAR] S EMIT [CHAR] " EMIT SPACE ( print S"<space> )
 685                         1+ DUP @                ( get the length word )
 686                         SWAP 1+ SWAP            ( end start+1 length )
 687                         2DUP TELL               ( print the string )
 688                         [CHAR] " EMIT SPACE          ( finish the string with a final quote )
 689                         +                       ( end start+1+len, aligned )
 690                         1-                     ( because we're about to add 4 below )
 691                 ENDOF
 692                 ['] 0BRANCH OF            ( is it 0BRANCH ? )
 693                         ." 0BRANCH ( "
 694                         1+ DUP @               ( print the offset )
 695                         .
 696                         ." ) "
 697                 ENDOF
 698                 ['] BRANCH OF             ( is it BRANCH ? )
 699                         ." BRANCH ( "
 700                         1+ DUP @               ( print the offset )
 701                         .
 702                         ." ) "
 703                 ENDOF
 704                 ['] ['] OF                  ( is it ['] ? )
 705                         ." ['] "
 706                         1+ DUP @               ( get the next codeword )
 707                         CFA>                    ( and force it to be printed as a dictionary entry )
 708                         ID. SPACE
 709                 ENDOF
 710                 ['] EXIT OF               ( is it EXIT? )
 711                         ( We expect the last word to be EXIT, and if it is then we don't print it
 712                           because EXIT is normally implied by ;.  EXIT can also appear in the middle
 713                           of words, and then it needs to be printed. )
 714                         2DUP                    ( end start end start )
 715                         1+                     ( end start end start+1 )
 716                         <> IF                   ( end start | we're not at the end )
 717                                 ." EXIT "
 718                         THEN
 719                 ENDOF
 720                                         ( default case: )
 721                         DUP                     ( in the default case we always need to DUP before using )
 722                         CFA>                    ( look up the codeword to get the dictionary entry )
 723                         ID. SPACE               ( and print it )
 724                 ENDCASE
 725
 726                 1+             ( end start+1 )
 727         REPEAT
 728
 729         [CHAR] ; EMIT CR
 730
 731         2DROP           ( restore stack )
 732 ;
 733
 734
 735 ( MEMORY  ------------------------------------------------------------------ )
 736
 737 : UNUSED  ( -- cells )
 738         MEMSIZE HERE @ - ;