src/lib.4th

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