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