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