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