src/lib.4th

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