
Mecrisp-Ice 1.8

  ok.
\ Definitions in high-level Forth that can be compiled by the small  ok.
\ nucleus itself. They are included into the bitstream for default.  ok.
  ok.
\ #######   CORE   ############################################  ok.
  ok.
: [']  ok.
    '  ok.
; immediate 0 foldable  ok.
  ok.
: [char]  ok.
    char  ok.
; immediate 0 foldable  ok.
  ok.
: (  ok.
    [char] ) parse 2drop  ok.
; immediate 0 foldable  ok.
  ok.
: u>= ( u1 u2 -- ? ) u< invert ; 2 foldable  ok.
: u<= ( u1 u2 -- ? ) u> invert ; 2 foldable  ok.
: >=  ( n1 n2 -- ? )  < invert ; 2 foldable  ok.
: <=  ( n1 n2 -- ? )  > invert ; 2 foldable  ok.

  ok.

: else  ok.

    postpone ahead  ok.

    swap  ok.

    postpone then  ok.

; immediate  ok.

  ok.

: while  ok.

    postpone if  ok.

    swap  ok.

; immediate  ok.

  ok.

: repeat  ok.

     postpone again  ok.

     postpone then  ok.

; immediate  ok.

  ok.

: create  ok.

    :  ok.

    here 4 + postpone literal  ok.

    postpone ;  ok.

;  ok.

  ok.

: >body  ok.

    @ 32767 and  ok.

;  ok.

  ok.

: m*  ok.

    2dup xor >r  ok.

    abs swap abs um*  ok.

    r> 0< if dnegate then  ok.

; 2 foldable  ok.

  ok.

: variable  ok.

    create ,  ok.

    0 foldable  ok.

;  ok.

  ok.

: constant  : postpone literal postpone ; 0 foldable ;  ok.

  ok.

: sgn ( u1 n1 -- n2 ) \ n2 is u1 with the sign of n1  ok.

    0< if negate then  ok.

; 2 foldable  ok.

  ok.

\ Divide d1 by n1, giving the symmetric quotient n3 and the remainder  ok.

\ n2.  ok.

: sm/rem ( d1 n1 -- n2 n3 )  ok.

    2dup xor >r     \ combined sign, for quotient  ok.

    over >r         \ sign of dividend, for remainder  ok.

    abs >r dabs r>  ok.

    um/mod          ( remainder quotient )  ok.

    swap r> sgn     \ apply to remainder  ok.

    swap r> sgn     \ apply to quotient  ok.

; 3 foldable  ok.

  ok.

\ Divide d1 by n1, giving the floored quotient n3 and the remainder n2.  ok.

\ Adapted from hForth  ok.

: fm/mod ( d1 n1 -- n2 n3 )  ok.

    dup >r 2dup xor >r  ok.

    >r dabs r@ abs  ok.

    um/mod  ok.

    r> 0< if  ok.

        swap negate swap  ok.

    then  ok.

    r> 0< if  ok.

        negate         \ negative quotient  ok.

        over if  ok.

            r@ rot - swap 1-  ok.

        then  ok.

    then  ok.

    r> drop  ok.

; 3 foldable  ok.

  ok.

: */mod     >r m* r> sm/rem ; 3 foldable  ok.

: */        */mod nip ; 3 foldable  ok.

  ok.

: spaces  ok.

    begin  ok.

        dup 0>  ok.

    while  ok.

        space 1-  ok.

    repeat  ok.

    drop  ok.

;  ok.

  ok.

( Pictured numeric output                    JCB 08:06 07/18/14)  ok.

\ Adapted from hForth  ok.

  ok.

\ "The size of the pictured numeric output string buffer shall  ok.

\ be at least (2*n) + 2 characters, where n is the number of  ok.

\ bits in a cell."  ok.

  ok.

create BUF0  ok.

16 cells 2 + 128 max  ok.

allot here constant BUF  ok.

  ok.

0 variable hld  ok.

  ok.

: <# ( -- )  ok.

    BUF hld !  ok.

;  ok.

  ok.

: hold ( c -- )  ok.

    hld @ 1- dup hld ! c!  ok.

;  ok.

  ok.

: sign ( n -- )  ok.

    0< if  ok.

        [char] - hold  ok.

    then  ok.

;  ok.

  ok.

: .digit ( u -- c )  ok.

  9 over <  ok.

  [char] A [char] 9 1 + -  ok.

  and +  ok.

  [char] 0 +  ok.

;  ok.

  ok.

: # ( ud -- ud* )  ok.

    0 base @ um/mod >r base @ um/mod swap  ok.

    .digit hold r>  ok.

;  ok.

  ok.

: #s ( ud -- 0 0 )  ok.

    begin  ok.

        #  ok.

        2dup d0=  ok.

    until  ok.

;  ok.

  ok.

: #> ( ud -- addr len )  ok.

    2drop hld @ BUF over -  ok.

;  ok.

  ok.

: (d.)  ok.

    dup >r dabs <# #s r> sign #>  ok.

;  ok.

  ok.

: ud. ( ud -- )  ok.

    <# #s #> type space  ok.

;  ok.

  ok.

: d. ( d -- )  ok.

    (d.) type space  ok.

;  ok.

  ok.

: . ( n -- )  ok.

    s>d d.  ok.

;  ok.

  ok.

: u. ( u -- )  ok.

    0 d.  ok.

;  ok.

  ok.

: rtype ( caddr u1 u2 -- ) \ display character string specified by caddr u1  ok.


                           \ in a field u2 characters wide.  ok.

  2dup u< if over - spaces else drop then  ok.

  type  ok.

;  ok.

  ok.

: d.r  ok.

    >r (d.)  ok.

    r> rtype  ok.

;  ok.

  ok.

: .r  ok.

    >r s>d r> d.r  ok.

;  ok.

  ok.

: u.r  ok.

    0 swap d.r  ok.

;  ok.

  ok.

( Memory operations                          JCB 18:02 05/31/15)  ok.

  ok.

: move \ ( addr1 addr2 u -- )  ok.

    >r 2dup u< if  ok.

        r> cmove>  ok.

    else  ok.

        r> cmove  ok.

    then  ok.

;  ok.

  ok.

: /mod      >r s>d r> sm/rem ; 2 foldable  ok.

: /         /mod nip ; 2 foldable  ok.

: mod       /mod drop ; 2 foldable  ok.

  ok.

: ."  ok.

    [char] " parse  ok.

    state @ if  ok.

        postpone sliteral  ok.

        postpone type  ok.

    else  ok.

        type  ok.

    then  ok.

; immediate 0 foldable  ok.

  ok.

\ #######   CORE EXT   ########################################  ok.

  ok.

: pad  ok.

    here aligned  ok.

;  ok.

  ok.

: within    over - >r - r> u< ; 3 foldable  ok.

  ok.

: s"  ok.

    [char] " parse  ok.

    state @ if  ok.

        postpone sliteral  ok.

    then  ok.

; immediate  ok.

  ok.

( CASE                                       JCB 09:15 07/18/14)  ok.

\ From ANS specification A.3.2.3.2  ok.

  ok.

: case 0 ; immediate  ( init count of ofs )  ok.

  ok.

: of  ( #of -- orig #of+1 / x -- )  ok.

    1+    ( count ofs )  ok.

    >r    ( move off the stack in case the control-flow )  ok.

          ( stack is the data stack. )  ok.

    postpone over  postpone = ( copy and test case value)  ok.

    postpone if    ( add orig to control flow stack )  ok.

    postpone drop  ( discards case value if = )  ok.

    r>             ( we can bring count back now )  ok.

; immediate  ok.

  ok.

: endof ( orig1 #of -- orig2 #of )  ok.

    >r   ( move off the stack in case the control-flow )  ok.

         ( stack is the data stack. )  ok.

    postpone else  ok.

    r>   ( we can bring count back now )  ok.

; immediate  ok.

  ok.

: endcase  ( orig1..orign #of -- )  ok.

    postpone drop  ( discard case value )  ok.

    0 ?do  ok.

      postpone then  ok.

    loop  ok.

; immediate  ok.

  ok.

\ #######   DICTIONARY   ######################################  ok.

  ok.

: cornerstone  ok.

  create  ok.

    forth 2@        \ preserve FORTH and DP after this  ok.

    , 2 cells + ,  ok.

  does>  ok.

    2@ forth 2! \ restore FORTH and DP  ok.

;  ok.

  ok.

\ #######   MEMORY   ##########################################  ok.

  ok.

: unused  ok.

    $4000 here -  ok.

;  ok.

  ok.

\ #######   IO   ##############################################  ok.

  ok.

\  ------------------------------------------------------------  ok.

\    Useful Low-Level IO definitions  ok.

\  ------------------------------------------------------------  ok.

\  ok.

\     Addr  Bit READ            WRITE  ok.

\  ok.

\     0001  0   Port A in  ok.

\     0002  1   Port A out      Port A out  ok.

\     0004  2   Port A dir      Port A dir  ok.

\     0008  3  ok.

\  ok.

\     0010  4   Port B in  ok.

\     0020  5   Port B out      Port B out  ok.

\     0040  6   Port B dir      Port B dir  ok.

\     0080  7  ok.

\  ok.

\     0100  8   Port C in  ok.

\     0200  9   Port C out      Port C out  ok.

\     0400  10  Port C dir      Port C dir  ok.

\     0800  11  ok.

\  ok.

\     1000  12  UART RX         UART TX  ok.

\     2000  13  misc.in  ok.

\     4000  14  ticks           set ticks  ok.

\     8000  15  ok.

\  ok.

\  ok.

\ Contents of misc.out and misc.in:  ok.

\  ok.

\  Bitmask Bit   misc.in  ok.

\  ok.

\    0001    0   UART Ready to Transmit  ok.

\    0002    1   UART Character received  ok.

\    0004    2  ok.

\    0008    3  ok.

\    0010    4  ok.

\    0020    5  ok.

\    0040    6  ok.

\    0080    7  ok.

\    0100    8  ok.

\    0200    9  ok.

\    0400   10  ok.

\    0800   11  ok.

\    1000   12  ok.

\    2000   13  ok.

\    4000   14  ok.

\    8000   15  ok.

\  ok.

  ok.

  ok.

  ok.

: now   ( -- ) 0 $4000 io! ;  ok.

: ticks ( -- u ) $4000 io@ ;  ok.

: delay ( u -- ) begin dup ticks u< until drop ;  ok.

  ok.

$608C $3FFE ! \ Location $3FFE is an interrupt vector ! Place ALU exit opcode he

re.  ok.

  ok.

\ -------------------------------------------------------------  ok.

\  Fixpoint output  ok.

\ -------------------------------------------------------------  ok.

  ok.

: hold< ( c -- ) \ Add a character at the end of the number string  ok.

  hld @   dup 1- dup hld !    BUF hld @ -  move  ok.

  BUF 1- c!  ok.

;  ok.

  ok.

: f# ( u -- u ) base @ um* .digit hold< ;  ok.

  ok.

: f.n ( f n -- ) ( f-Low f-High n -- ) \ Prints a s15.16 number  ok.

  ok.

  >r ( Low High R: n )  ok.

  ok.

  dup 0< if [char] - emit then  ok.

  dabs  ok.

  ( uLow uHigh )  ok.

  0 <# #s   ( uLow 0 0 )  ok.

  drop swap ( 0 uLow )  ok.

  ok.

  [char] , hold<  ok.

  r> 0 ?do f# loop  ok.

  ok.

  #> type space  ok.

;  ok.

  ok.

: f. ( f -- ) 16 f.n ;  ok.

  ok.

\ -------------------------------------------------------------  ok.

\  Fixpoint calculations  ok.

\ -------------------------------------------------------------  ok.

  ok.

: 2variable ( d -- ) create , , 0 foldable ;  ok.

\ : 2constant ( d -- ) create , , 0 foldable does> 2@ ;  ok.

: 2constant ( d -- ) swap : postpone literal postpone literal postpone ; 0 folda

ble ;  ok.

  ok.

: s>f ( n -- f ) 0 swap ; 1 foldable  \ Signed integer --> Fixpoint s15.16  ok.

\ : f>s ( f -- n ) nip    ; 2 foldable  \ Fixpoint s15.16 --> Signed integer  ok

.

  ok.

: f* ( f1 f2 -- f )  ok.

  ok.

        dup >r dabs  ok.

  2swap dup >r dabs  ok.

  ok.

            ( d c b a )  ok.

  swap >r   ( d c a R: b )  ok.

  2dup *    ( d c a ac R: b )  ok.

  >r        ( d c a R: b ac )  ok.

  >r        ( d c R: b ac a )  ok.

  over      ( d c d R: b ac a )  ok.

  r> um*    ( d c L H R: b ac )  ok.

  r> +      ( d c L H' R: b )  ok.

  rot       ( d L H' c R: b )  ok.

  r@        ( d L H' c b R: b )  ok.

  um* d+    ( d L' H'' R: b )  ok.

  rot       ( L' H'' d R: b )  ok.

  r>        ( L' H'' d b )  ok.

  um* nip 0 ( L' H'' db 0 )  ok.

  d+        ( L'' H''' )  ok.

  ok.

  r> r> xor 0< if dnegate then  ok.

  ok.

; 4 foldable  ok.

  ok.

0. 2variable Dividend  ok.

0. 2variable Shift  ok.

0. 2variable Divisor  ok.

0. 2variable Result  ok.

  ok.

: (ud/mod) ( -- )  ok.

  ok.

  32 0 do  ok.

  ok.

    Dividend 2@  ok.

      dup 15 rshift >r  ok.

      d2*  ok.

    Dividend 2!  ok.

  ok.

    Shift 2@  ok.

      d2* swap r> or swap  ok.

    2dup Shift 2!  ok.

  ok.

    \ Compare if shift register is greater or equal to dividend.  ok.

    Divisor 2@ d-  ok.

  ok.

    dup 0<  ok.

    if   \ Smaller: Don't subtract  ok.

      2drop  ok.

      0  \ Zero for result  ok.

    else \ Greater or Equal: Subtract !  ok.

      Shift 2!  ok.

      1  \ One for result  ok.

    then  ok.

  ok.

    Result 2@ d2* >r or r> Result 2!  ok.

  ok.

  loop  ok.

;  ok.

  ok.

: ud/mod ( ud1 ud2 -- ud-rem ud-div )  ok.

  ok.

     Divisor 2!  ok.

  0. Shift 2!  ok.

     Dividend 2!  ok.

  ok.

  (ud/mod)  ok.

  ok.

  Shift 2@  ok.

  Result 2@  ok.

  ok.

; 4 foldable  ok.

  ok.

: f/ ( f1 f2 -- f )  ok.

  ok.

  dup >r dabs  Divisor 2!  ok.

  dup >r dabs  0 Shift 2! 0 swap Dividend 2!  ok.

  ok.

  (ud/mod)  ok.

  ok.

  Result 2@  ok.

  r> r> xor 0< if dnegate then  ok.

  ok.

; 4 foldable  ok.

  ok.

\ -------------------------------------------------------------  ok.

\  Double tools  ok.

\ -------------------------------------------------------------  ok.

  ok.

: 2or  ( d1 d2 -- d ) >r swap >r or  r> r> or  ; 4 foldable  ok.

: 2and ( d1 d2 -- d ) >r swap >r and r> r> and ; 4 foldable  ok.

: 2xor ( d1 d2 -- d ) >r swap >r xor r> r> xor ; 4 foldable  ok.

  ok.

: d0<   ( d -- ? ) nip 0< ; 2 foldable  ok.

  ok.

: d= ( x0 x1 y0 y1 -- ? )  ok.

  ok.

  swap ( x0 x1 y1 y0 )  ok.

  >r   ( x0 x1 y1 R: y0 )  ok.

  =    ( x0 x1=y1 R: y0 )  ok.

  swap ( x1=y1 x0 R: y0 )  ok.

  r>   ( x1=y1 x0 y0 )  ok.

  =    ( x1=y1 x0=y0 )  ok.

  and  ok.

; 4 foldable  ok.

  ok.

: d<> d= not ; 4 foldable  ok.

  ok.

: d2/  ( x1 x2 -- x1' x2' ) >r 1 rshift r@ 15 lshift or r> 2/       ; 2 foldable

  ok.

: dshr ( x1 x2 -- x1' x2' ) >r 1 rshift r@ 15 lshift or r> 1 rshift ; 2 foldable

  ok.

  ok.

\ : 2lshift  ( ud u -- ud* ) begin dup while >r d2*  r> 1- repeat drop ; 3 folda

ble  ok.

\ : 2arshift (  d u --  d* ) begin dup while >r d2/  r> 1- repeat drop ; 3 folda

ble  ok.

\ : 2rshift  ( ud u -- ud* ) begin dup while >r dshr r> 1- repeat drop ; 3 folda

ble  ok.

  ok.

: 2lshift ( low high u -- )  ok.

  dup >r ( low high u R: u )  ok.

  lshift ( low high* )  ok.

  over 16 r@ - rshift or  ok.

  over r@ 16 - lshift or  ok.

  swap r> lshift swap  ok.

; 3 foldable  ok.

  ok.

: 2rshift ( low high u -- )  ok.

  >r swap ( high low R: u )  ok.

  r@ rshift  ok.

  over 16 r@ - lshift or  ok.

  over r@ 16 - rshift or  ok.

  swap  ok.

  r> rshift  ok.

; 3 foldable  ok.

  ok.

: 2arshift ( low high u -- )  ok.

  dup >r 16 u< ( low high R: u )  ok.

  if  ok.

    swap ( high low R: u )  ok.

    r@ rshift  ok.

    over 16 r@ - lshift or  ok.

  else  ok.

    nip dup r@ 16 - arshift  ok.

  then  ok.

  swap r> arshift  ok.

; 3 foldable  ok.

  ok.

: 2nip ( d1 d2 -- d2 )  ok.

  >r nip nip r>  ok.

; 4 foldable  ok.

  ok.

: 2rot ( d1 d2 d3 -- d2 d3 d1 )  ok.

  >r >r ( d1 d2 R: d3 )  ok.

  2swap ( d2 d1 R: d3 )  ok.

  r> r> ( d2 d1 d3 )  ok.

  2swap ( d2 d3 d1 )  ok.

; 6 foldable  ok.

  ok.

: d<            \ ( al ah bl bh -- flag )  ok.

    rot         \ al bl bh ah  ok.

    2dup =  ok.

    if  ok.

        2drop u<  ok.

    else  ok.

        > nip nip  ok.

    then  ok.

; 4 foldable  ok.

  ok.

: d>  ( d1 d2 -- ? ) 2swap d< ; 4 foldable  ok.

: d>= ( d1 d2 -- ? ) d< not   ; 4 foldable  ok.

: d<= ( d1 d2 -- ? ) d> not   ; 4 foldable  ok.

  ok.

: dmin ( d1 d2 -- d ) 2over 2over d< if 2drop else 2nip then ; 4 foldable  ok.

: dmax ( d1 d2 -- d ) 2over 2over d< if 2nip else 2drop then ; 4 foldable  ok.

  ok.

: du<           \ ( al ah bl bh -- flag )  ok.

    rot         \ al bl bh ah  ok.

    2dup =  ok.

    if  ok.

        2drop u<  ok.

    else  ok.

        u> nip nip  ok.

    then  ok.

; 4 foldable  ok.

  ok.

: du>  ( d1 d2 -- ? ) 2swap du< ; 4 foldable  ok.

: du>= ( d1 d2 -- ? ) du< not   ; 4 foldable  ok.

: du<= ( d1 d2 -- ? ) du> not   ; 4 foldable  ok.

  ok.

\ #######   DUMP   ############################################  ok.

  ok.

: dump  ok.

    ?dup  ok.

    if  ok.

        1- 4 rshift 1+  ok.

        0 do  ok.

            cr dup dup .x space space  ok.

            16 0 do  ok.

                dup c@ .x2 1+  ok.

            loop  ok.

            space swap  ok.

            16 0 do  ok.

                dup c@ dup bl 127 within invert if  ok.

                    drop [char] .  ok.

                then  ok.

                emit 1+  ok.

            loop  ok.

            drop  ok.

        loop  ok.

    then  ok.

    drop  ok.

;  ok.

  ok.

\ #######   INSIGHT   #########################################  ok.

  ok.

  ok.

( Deep insight into stack, dictionary and code )  ok.

( Matthias Koch )  ok.

  ok.

: .s ( -- )  ok.

  \ Save initial depth  ok.

  depth dup >r  ok.

  ok.

  \ Flush stack contents to temporary storage  ok.

  begin  ok.

    dup  ok.

  while  ok.

    1-  ok.

    swap  ok.

    over cells pad + !  ok.

  repeat  ok.

  drop  ok.

  ok.

  \ Print original depth  ok.

  ." [ "  ok.

  r@ .x2  ok.

  ." ] "  ok.

  ok.

  \ Print all elements in reverse order  ok.

  r@  ok.

  begin  ok.

    dup  ok.

  while  ok.

    r@ over - cells pad + @ .x  ok.

    1-  ok.

  repeat  ok.

  drop  ok.

  ok.

  \ Restore original stack  ok.

  0  ok.

  begin  ok.

    dup r@ u<  ok.

  while  ok.

    dup cells pad + @ swap  ok.

    1+  ok.

  repeat  ok.

  rdrop  ok.

  drop  ok.

;  ok.

  ok.

: insight ( -- )  ( Long listing of everything inside of the dictionary structur

e )  ok.

    base @ hex cr  ok.

    forth @  ok.

    begin  ok.

        dup  ok.

    while  ok.

         ." Addr: "     dup .x  ok.

        ."  Link: "     dup @ 2/ 2/ $3FFE and .x  ok.

        ."  Flags: "    dup 2 + c@ 128 and if ." I " else ." - " then  ok.

                        dup @ 7 and ?dup if 1- u. else ." - " then  ok.

        ."  Code: "     dup 2 + count 127 and + aligned .x  ok.

        space           dup 2 + count 127 and type  ok.

        @ 2/ 2/ $3FFE and cr  ok.

    repeat  ok.

    drop  ok.

    base !  ok.

;  ok.

  ok.

0 variable disasm-$    ( Current position for disassembling )  ok.

0 variable disasm-cont ( Continue up to this position )  ok.

  ok.

: name. ( Address -- )  ( If the address is Code-Start of a dictionary word, it 

gets named. )  ok.

  ok.

  dup ['] s, 24 + = \ Is this a string literal ?  ok.

  if  ok.

    ."   --> s" [char] " emit space  ok.

    disasm-$ @ count type  ok.

    [char] " emit  ok.

  ok.

    disasm-$ @ c@ 1+ aligned disasm-$ +!  ok.

    drop exit  ok.

  then  ok.

  ok.

  >r  ok.

  forth @  ok.

  begin  ok.

    dup  ok.

  while  ok.

    dup 2 + count 127 and + aligned ( Dictionary Codestart )  ok.

      r@ = if ."   --> " dup 2 + count 127 and type then  ok.

    @ 2/ 2/ $3FFE and  ok.

  repeat  ok.

  drop r>  ok.

  ok.

  $000C =                            \ A call to execute  ok.

  disasm-$ @ 4 - @ $C000 and $C000 =  \ after a literal which has bit $4000 set 

means:  ok.

  and                                  \ Memory fetch.  ok.

  if  ok.

    ."   --> " disasm-$ @ 4 - @ $3FFF and .x ." @"  ok.

  then  ok.

;  ok.

  ok.

: alu. ( Opcode -- ) ( If this opcode is from an one-opcode definition, it gets 

named. This way inlined ALUs get a proper descri  ok.

  ok.

  dup $6127 = if ." >r"    drop exit then  ok.

  dup $6B11 = if ." r@"    drop exit then  ok.

  dup $6B1D = if ." r>"    drop exit then  ok.

  dup $600C = if ." rdrop" drop exit then  ok.

  ok.

  $FF73 and  ok.

  >r  ok.

  forth @  ok.

  begin  ok.

    dup  ok.

  while  ok.

    dup 2 + count 127 and + aligned @ ( Dictionary First-Opcode )  ok.

        dup $E080 and $6080 =  ok.

        if  ok.

          $FF73 and r@ = if rdrop 2 + count 127 and type space exit then  ok.

        else  ok.

          drop  ok.

        then  ok.

  ok.

    @ 2/ 2/ $3FFE and  ok.

  repeat  ok.

  drop r> drop  ok.

;  ok.

  ok.

  ok.

: memstamp ( Addr -- ) dup .x ." : " @ .x ."   " ; ( Shows a memory location nic

ely )  ok.

  ok.

: disasm-step ( -- )  ok.

  disasm-$ @ memstamp  ok.

  disasm-$ @ @  ( Fetch next opcode )  ok.

  2 disasm-$ +! ( Increment position )  ok.

  ok.

  dup $8000 and         if ." Imm  " $7FFF and    dup .x 6 spaces               

       .x       exit then ( Immediate )  ok.

  dup $E000 and $0000 = if ." Jmp  " $1FFF and 2* dup                           

       .x name. exit then ( Branch )  ok.

  dup $E000 and $2000 = if ." JZ   " $1FFF and 2* disasm-cont @ over max disasm-

cont ! .x       exit then ( 0-Branch )  ok.

  dup $E000 and $4000 = if ." Call " $1FFF and 2* dup                           

       .x name. exit then ( Call )  ok.

                           ." Alu"   13 spaces dup alu. $80 and if ." exit" then

                          ( ALU )  ok.

;  ok.

  ok.

: seec ( -- ) ( Continues to see )  ok.

  base @ hex cr  ok.

  0 disasm-cont !  ok.

  begin  ok.

    disasm-$ @ @  ok.

    dup  $E080 and $6080 =           ( Loop terminates with ret )  ok.

    swap $E000 and 0= or             ( or when an unconditional jump is reached.

 )  ok.

    disasm-$ @ disasm-cont @ u>= and ( Do not stop when there has been a conditi

onal jump further )  ok.

  ok.

    disasm-step cr  ok.

  until  ok.

  ok.

  base !  ok.

;  ok.

  ok.

: see ( -- ) ( Takes name of definition and shows its contents from beginning to

 first ret )  ok.

  ' disasm-$ !  ok.

  seec  ok.

;  ok.

  ok.

cornerstone new  ok.

  ok.

