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     BL 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         BL 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                 >IN #TIB >= IF      \ End of TIB?
 224                         QUERY       \ Get next line
 225                 THEN
 226
 227                 >IN @ 1 >IN +!
 228                 DUP [CHAR] ( = IF    \ open paren?
 229                         DROP            \ drop the open paren
 230                         1+              \ depth increases
 231                 ELSE
 232                         [CHAR] ) = IF        \ close paren?
 233                                 1-              \ depth decreases
 234                         THEN
 235                 THEN
 236         DUP 0= UNTIL            \ continue until we reach matching close paren, depth 0
 237         DROP            \ drop the depth counter
 238 ;
 239
 240 ( Some more complicated stack examples, showing the stack notation. )
 241 : NIP ( x y -- y ) SWAP DROP ;
 242 : TUCK ( x y -- y x y ) DUP -ROT ;
 243 : PICK ( x_u ... x_1 x_0 u -- x_u ... x_1 x_0 x_u )
 244         1+              ( add one because of 'u' on the stack )
 245         PSP@ SWAP -     ( add to the stack pointer )
 246         @               ( and fetch )
 247 ;
 248 : ROLL ( x_u x_u-1... x_0 u -- x_u-1 ... x_0 x_u )
 249         1+ DUP PICK SWAP    ( x_u x_u-1 ... x_0 x_u u+1 )
 250         PSP@ 1- SWAP - PSP@ 2- SWAP
 251         DO
 252             i 1+ @ i !
 253         LOOP
 254         SWAP DROP
 255 ;
 256
 257 ( With the looping constructs, we can now write SPACES, which writes n spaces to stdout. )
 258 : SPACES        ( n -- )
 259         DUP 0> IF
 260             0 DO SPACE LOOP
 261         ELSE
 262             DROP
 263         THEN
 264 ;
 265
 266 ( Standard words for manipulating BASE. )
 267 : DECIMAL ( -- ) 10 BASE ! ;
 268 : HEX ( -- ) 16 BASE ! ;
 269
 270 ( Compute absolute value. )
 271 : ABS           ( n -- |n| )
 272         dup 0< if
 273                 negate
 274         then
 275 ;
 276
 277 : MAX           ( n m -- max )
 278         2dup - 0< if
 279                 swap drop
 280         else
 281                 drop
 282         then
 283 ;
 284
 285 : MIN           ( n m -- max )
 286         2dup - 0> if
 287                 swap drop
 288         else
 289                 drop
 290         then
 291 ;
 292
 293 ( PRINTING NUMBERS ---------------------------------------------------------------------- )
 294
 295 ( This is the underlying recursive definition of U. )
 296 : U.            ( u -- )
 297         BASE @ /MOD     ( width rem quot )
 298         ?DUP IF                 ( if quotient <> 0 then )
 299                 RECURSE         ( print the quotient )
 300         THEN
 301
 302         ( print the remainder )
 303         DUP 10 < IF
 304                 [CHAR] 0             ( decimal digits 0..9 )
 305         ELSE
 306                 10 -            ( hex and beyond digits A..Z )
 307                 [CHAR] A
 308         THEN
 309         +
 310         EMIT
 311 ;
 312
 313 ( This word returns the width (in characters) of an unsigned number in the current base )
 314 : UWIDTH        ( u -- width )
 315         BASE @ /        ( rem quot )
 316         ?DUP IF         ( if quotient <> 0 then )
 317                 RECURSE 1+      ( return 1+recursive call )
 318         ELSE
 319                 1               ( return 1 )
 320         THEN
 321 ;
 322
 323 : U.R           ( u width -- )
 324         SWAP            ( width u )
 325         DUP             ( width u u )
 326         UWIDTH          ( width u uwidth )
 327         ROT            ( u uwidth width )
 328         SWAP -          ( u width-uwidth )
 329         ( At this point if the requested width is narrower, we'll have a negative number on the stack.
 330           Otherwise the number on the stack is the number of spaces to print.  But SPACES won't print
 331           a negative number of spaces anyway, so it's now safe to call SPACES ... )
 332         SPACES
 333         ( ... and then call the underlying implementation of U. )
 334         U.
 335 ;
 336
 337 : .R            ( n width -- )
 338         SWAP            ( width n )
 339         DUP 0< IF
 340                 NEGATE          ( width u )
 341                 1               ( save a flag to remember that it was negative | width n 1 )
 342                 -ROT             ( 1 width u )
 343                 SWAP            ( 1 u width )
 344                 1-              ( 1 u width-1 )
 345         ELSE
 346                 0               ( width u 0 )
 347                 -ROT             ( 0 width u )
 348                 SWAP            ( 0 u width )
 349         THEN
 350         SWAP            ( flag width u )
 351         DUP             ( flag width u u )
 352         UWIDTH          ( flag width u uwidth )
 353         ROT            ( flag u uwidth width )
 354         SWAP -          ( flag u width-uwidth )
 355
 356         SPACES          ( flag u )
 357         SWAP            ( u flag )
 358
 359         IF                      ( was it negative? print the - character )
 360                 [CHAR] - EMIT
 361         THEN
 362
 363         U.
 364 ;
 365
 366 : . 0 .R SPACE ;
 367
 368 : .S            ( -- )
 369         [CHAR] < EMIT DEPTH U. [CHAR] > EMIT SPACE
 370         PSP0 @ 1+
 371         BEGIN
 372                 DUP PSP@ 2 - <=
 373         WHILE
 374                 DUP @ .
 375                 1+
 376         REPEAT
 377         DROP
 378 ;
 379
 380 : U. U. SPACE ;
 381
 382 ( ? fetches the integer at an address and prints it. )
 383 : ? ( addr -- ) @ . ;
 384
 385 ( c a b WITHIN returns true if a <= c and c < b )
 386 : WITHIN
 387         -ROT             ( b c a )
 388         OVER            ( b c a c )
 389         <= IF
 390                 > IF            ( b c -- )
 391                         TRUE
 392                 ELSE
 393                         FALSE
 394                 THEN
 395         ELSE
 396                 2DROP           ( b c -- )
 397                 FALSE
 398         THEN
 399 ;
 400
 401
 402 ( STRINGS ---------------------------------------------------------------------- )
 403
 404
 405 ( Block copy, however, is important and novel: )
 406 : CMOVE ( src dest length -- )
 407
 408         DUP 0<= IF
 409                 EXIT
 410         THEN
 411
 412         -ROT OVER -         ( length src (dest-src) )
 413         -ROT DUP ROT + SWAP ( (dest-src) (src+length) src )
 414
 415         DO
 416                 I @         ( (dest-src) i@ )
 417                 OVER I +    ( (dest-src) i@ (dest-src+i) )
 418                 !           ( (dest-src) )
 419         LOOP
 420
 421         DROP
 422 ;
 423
 424 ( C, appends a byte to the current compiled word. )
 425 : C,
 426         HERE @ C!
 427         1 HERE +!
 428 ;
 429
 430 : S" IMMEDIATE          ( -- addr len )
 431         STATE @ IF      ( compiling? )
 432                 ['] LITSTRING ,   ( compile LITSTRING )
 433                 HERE @          ( save the address of the length word on the stack )
 434                 0 ,             ( dummy length - we don't know what it is yet )
 435                 KEY DROP
 436                 BEGIN
 437                         KEY             ( get next character of the string )
 438                         DUP [CHAR] " <>
 439                 WHILE
 440                         C,              ( copy character )
 441                 REPEAT
 442                 DROP            ( drop the double quote character at the end )
 443                 DUP             ( get the saved address of the length word )
 444                 HERE @ SWAP -   ( calculate the length )
 445                 1-              ( subtract 1 (because we measured from the start of the length word) )
 446                 SWAP !          ( and back-fill the length location )
 447         ELSE            ( immediate mode )
 448                 HERE @          ( get the start address of the temporary space )
 449                 KEY DROP
 450                 BEGIN
 451                         KEY
 452                         DUP [CHAR] " <>
 453                 WHILE
 454                         OVER C!         ( save next character )
 455                         1+              ( increment address )
 456                 REPEAT
 457                 DROP            ( drop the final " character )
 458                 HERE @ -        ( calculate the length )
 459                 HERE @          ( push the start address )
 460                 SWAP            ( addr len )
 461         THEN
 462 ;
 463
 464 : ." IMMEDIATE          ( -- )
 465         [COMPILE] S"    ( read the string, and compile LITSTRING, etc. )
 466         ['] TYPE ,      ( compile the final TYPE )
 467 ;
 468
 469 : .(
 470         KEY DROP
 471         BEGIN
 472                 KEY
 473                 DUP [CHAR] ) = IF
 474                         DROP    ( drop the double quote character )
 475                         EXIT    ( return from this function )
 476                 THEN
 477                 EMIT
 478         AGAIN
 479 ;
 480
 481 ( Converts address of counted string into address of
 482   start of string and length of string. )
 483 : COUNT ( addr1 -- addr2 n )
 484         DUP 1+ SWAP @ ;
 485
 486
 487 ( CONSTANTS AND VARIABLES ------------------------------------------------------ )
 488
 489 : CONSTANT
 490         BL WORD HEADER  ( make dictionary entry (the name follows CONSTANT) )
 491         DOCOL ,         ( append DOCOL (the codeword field of this word) )
 492         ['] LIT ,       ( append the codeword LIT )
 493         ,               ( append the value on the top of the stack )
 494         ['] EXIT ,      ( append the codeword EXIT )
 495 ;
 496
 497 : ALLOT         ( n -- )
 498         HERE +!         ( adds n to HERE, after this the old value of HERE is still on the stack )
 499 ;
 500
 501 : VARIABLE
 502         CREATE
 503         1 CELLS ALLOT   ( allocate 1 cell of memory, push the pointer to this memory )
 504 ;
 505
 506
 507 : VALUE         ( n -- )
 508         BL WORD HEADER  ( make the dictionary entry (the name follows VALUE) )
 509         DOCOL ,         ( append DOCOL )
 510         ['] LIT ,       ( append the codeword LIT )
 511         ,               ( append the initial value )
 512         ['] EXIT ,      ( append the codeword EXIT )
 513 ;
 514
 515 : TO IMMEDIATE  ( n -- )
 516         BL WORD         ( get the name of the value )
 517         FIND            ( look it up in the dictionary )
 518         >PFA            ( get a pointer to the first data field (the 'LIT') )
 519         1+              ( increment to point at the value )
 520         STATE @ IF      ( compiling? )
 521                 ['] LIT ,         ( compile LIT )
 522                 ,               ( compile the address of the value )
 523                 ['] ! ,           ( compile ! )
 524         ELSE            ( immediate mode )
 525                 !               ( update it straightaway )
 526         THEN
 527 ;
 528
 529 ( x +TO VAL adds x to VAL )
 530 : +TO IMMEDIATE
 531         BL WORD         ( get the name of the value )
 532         FIND            ( look it up in the dictionary )
 533         >PFA            ( get a pointer to the first data field (the 'LIT') )
 534         1+              ( increment to point at the value )
 535         STATE @ IF      ( compiling? )
 536                 ['] LIT ,         ( compile LIT )
 537                 ,               ( compile the address of the value )
 538                 ['] +! ,          ( compile +! )
 539         ELSE            ( immediate mode )
 540                 +!              ( update it straightaway )
 541         THEN
 542 ;
 543
 544 ( Fill u ints, starting at a, with the value b )
 545 : FILL          ( a u b -- )
 546         -ROT OVER + SWAP ?DO
 547                 DUP I !
 548         LOOP
 549         DROP
 550 ;
 551
 552 : ERASE         ( a u -- )
 553         0 FILL
 554 ;
 555
 556 ( PRINTING THE DICTIONARY ------------------------------------------------------ )
 557
 558 : ID.
 559         1+              ( skip over the link pointer )
 560         DUP @           ( get the flags/length byte )
 561         F_LENMASK AND   ( mask out the flags - just want the length )
 562
 563         BEGIN
 564                 DUP 0>          ( length > 0? )
 565         WHILE
 566                 SWAP 1+         ( addr len -- len addr+1 )
 567                 DUP @           ( len addr -- len addr char | get the next character)
 568                 DUP 32 >= OVER 127 <= AND IF
 569                         EMIT    ( len addr char -- len addr | and print it)
 570                 ELSE
 571                         BASE @ SWAP HEX
 572                         ." \x" 0 .R
 573                         BASE !
 574                 THEN
 575                 SWAP 1-         ( len addr -- addr len-1    | subtract one from length )
 576         REPEAT
 577         2DROP           ( len addr -- )
 578 ;
 579
 580 : ?HIDDEN
 581         1+              ( skip over the link pointer )
 582         @               ( get the flags/length byte )
 583         F_HIDDEN AND    ( mask the F_HIDDEN flag and return it (as a truth value) )
 584 ;
 585 : ?IMMEDIATE
 586         1+              ( skip over the link pointer )
 587         @               ( get the flags/length byte )
 588         F_IMMED AND     ( mask the F_IMMED flag and return it (as a truth value) )
 589 ;
 590
 591 : WORDS
 592         LATEST @        ( start at LATEST dictionary entry )
 593         BEGIN
 594                 ?DUP            ( while link pointer is not null )
 595         WHILE
 596                 DUP ?HIDDEN NOT IF      ( ignore hidden words )
 597                         DUP ID.         ( but if not hidden, print the word )
 598                         SPACE
 599                 THEN
 600                 @               ( dereference the link pointer - go to previous word )
 601         REPEAT
 602         CR
 603 ;
 604
 605
 606 ( FORGET ---------------------------------------------------------------------- )
 607
 608 : FORGET
 609         BL WORD FIND    ( find the word, gets the dictionary entry address )
 610         DUP @ LATEST !  ( set LATEST to point to the previous word )
 611         HERE !          ( and store HERE with the dictionary address )
 612 ;
 613
 614 ( DUMP ------------------------------------------------------------------------ )
 615
 616 \ TODO!
 617
 618
 619 ( DECOMPILER ------------------------------------------------------------------ )
 620
 621 : CFA>
 622         LATEST @        ( start at LATEST dictionary entry )
 623         BEGIN
 624                 ?DUP            ( while link pointer is not null )
 625         WHILE
 626                 2DUP SWAP       ( cfa curr curr cfa )
 627                 < IF            ( current dictionary entry < cfa? )
 628                         NIP             ( leave curr dictionary entry on the stack )
 629                         EXIT
 630                 THEN
 631                 @               ( follow link pointer back )
 632         REPEAT
 633         DROP            ( restore stack )
 634         0               ( sorry, nothing found )
 635 ;
 636
 637 : SEE
 638         BL WORD 2DUP FIND     ( find the dictionary entry to decompile )
 639
 640         ?DUP 0= IF
 641                 ." Word '" TYPE ." ' not found in dictionary."
 642                 EXIT
 643         THEN
 644
 645         -ROT 2DROP
 646
 647         ( Now we search again, looking for the next word in the dictionary.  This gives us
 648           the length of the word that we will be decompiling.  (Well, mostly it does). )
 649         HERE @          ( address of the end of the last compiled word )
 650         LATEST @        ( word last curr )
 651         BEGIN
 652                 2 PICK          ( word last curr word )
 653                 OVER            ( word last curr word curr )
 654                 <>              ( word last curr word<>curr? )
 655         WHILE                   ( word last curr )
 656                 NIP             ( word curr )
 657                 DUP @           ( word curr prev (which becomes: word last curr) )
 658         REPEAT
 659
 660         DROP            ( at this point, the stack is: start-of-word end-of-word )
 661         SWAP            ( end-of-word start-of-word )
 662
 663         DUP >CFA @ CASE
 664                 DOCOL OF
 665                         \ Colon definition
 666                         [CHAR] : EMIT SPACE DUP ID. SPACE
 667                         DUP ?IMMEDIATE IF ." IMMEDIATE " THEN CR
 668                 ENDOF
 669                 DOVAR OF
 670                         \ Variable definition
 671                         ." Variable " DUP ID. CR
 672                         2DROP EXIT
 673                 ENDOF
 674                 DOCON OF
 675                         \ Constant definition
 676                         ." Constant " DUP ID. CR
 677                         2DROP EXIT
 678                 ENDOF
 679
 680                 \ Unknown codeword
 681                 ." Primitive or word with unrecognized codeword." CR
 682                 DROP 2DROP EXIT
 683         ENDCASE
 684
 685         ( begin the definition with : NAME [IMMEDIATE] )
 686         ( [CHAR] : EMIT SPACE DUP ID. SPACE
 687         DUP ?IMMEDIATE IF ." IMMEDIATE " THEN CR 4 )
 688
 689         4 SPACES
 690
 691         >PFA            ( get the data address, ie. points after DOCOL | end-of-word start-of-data )
 692
 693         ( now we start decompiling until we hit the end of the word )
 694         BEGIN           ( end start )
 695                 2DUP >
 696         WHILE
 697                 DUP @           ( end start codeword )
 698
 699                 CASE
 700                 ['] LIT OF                ( is it LIT ? )
 701                         1+ DUP @                ( get next word which is the integer constant )
 702                         .                       ( and print it )
 703                 ENDOF
 704                 ['] LITSTRING OF          ( is it LITSTRING ? )
 705                         [CHAR] S EMIT [CHAR] " EMIT SPACE ( print S"<space> )
 706                         1+ DUP @                ( get the length word )
 707                         SWAP 1+ SWAP            ( end start+1 length )
 708                         2DUP TYPE               ( print the string )
 709                         [CHAR] " EMIT SPACE          ( finish the string with a final quote )
 710                         +                       ( end start+1+len, aligned )
 711                         1-                     ( because we're about to add 4 below )
 712                 ENDOF
 713                 ['] 0BRANCH OF            ( is it 0BRANCH ? )
 714                         ." 0BRANCH ( "
 715                         1+ DUP @               ( print the offset )
 716                         .
 717                         ." ) "
 718                 ENDOF
 719                 ['] BRANCH OF             ( is it BRANCH ? )
 720                         ." BRANCH ( "
 721                         1+ DUP @               ( print the offset )
 722                         .
 723                         ." ) "
 724                 ENDOF
 725                 ['] ['] OF                  ( is it ['] ? )
 726                         ." ['] "
 727                         1+ DUP @               ( get the next codeword )
 728                         CFA>                    ( and force it to be printed as a dictionary entry )
 729                         ID. SPACE
 730                 ENDOF
 731                 ['] EXIT OF               ( is it EXIT? )
 732                         ( We expect the last word to be EXIT, and if it is then we don't print it
 733                           because EXIT is normally implied by ;.  EXIT can also appear in the middle
 734                           of words, and then it needs to be printed. )
 735                         2DUP                    ( end start end start )
 736                         1+                     ( end start end start+1 )
 737                         <> IF                   ( end start | we're not at the end )
 738                                 ." EXIT "
 739                         THEN
 740                 ENDOF
 741                                         ( default case: )
 742                         DUP                     ( in the default case we always need to DUP before using )
 743                         CFA>                    ( look up the codeword to get the dictionary entry )
 744                         ID. SPACE               ( and print it )
 745                 ENDCASE
 746
 747                 1+             ( end start+1 )
 748         REPEAT
 749
 750         [CHAR] ; EMIT CR
 751
 752         2DROP           ( restore stack )
 753 ;
 754
 755
 756 ( MEMORY  ------------------------------------------------------------------ )
 757
 758 : UNUSED  ( -- cells )
 759         MEMSIZE HERE @ - ;