\
\ crimcomp.4th
\ 95 jun 26
\

\ words defined by crim.c:
\
\ CRIM-ENGINE
\ CRIM-STATE	( -- crim_state )
\ CRIM-STATE!	( crim_state -- )
\ CRIMRS	( -- RS )
\ CRIMSS	( -- SS )
\ CRIMRS!	( RS -- )
\ CRIMSS!	( SS -- )
\ CRIM-BEGMEM	( -- CRIM_BEGMEM )
\ CRIM-BEGMEM!	( CRIM_BEGMEM -- )
\ CRIM-STEPPER! ( crim_stepper_Xt -- )


DECIMAL

\
\ The Crim stacks (R-stack and S-stack)
\

128 ALLOT
  HERE CONSTANT RS0
128 ALLOT
  HERE CONSTANT SS0
128 ALLOT

: RSDEPTH ( -- rsdepth ) RS0 CRIMRS - 4 / ;
: RSDEPTH! ( rsdepth -- ) -4 * RS0 + CRIMRS! ;
: RSDEPTH+! ( n -- ) RSDEPTH + RSDEPTH! ;
: RSTOP ( -- rstop ) RS0 RSDEPTH 4 * - ;
: &RSPICK ( n -- adr ) 4 * RSTOP + ;
: >RS ( x -- ) 1 RSDEPTH+!   0 &RSPICK ! ;
: RS> ( -- x ) 0 &RSPICK @  -1 RSDEPTH+! ;

: SSDEPTH ( -- ssdepth ) SS0 CRIMSS - 4 / ;
: SSDEPTH! ( ssdepth -- ) -4 * SS0 + CRIMSS! ;
: SSDEPTH+! ( n -- ) SSDEPTH + SSDEPTH! ;
: SSTOP ( -- sstop ) SS0 SSDEPTH 4 * - ;
: &SSPICK ( n -- adr ) 4 * SSTOP + ;
: >S ( x -- ) 1 SSDEPTH+!   0 &SSPICK ! ;
: S> ( -- x ) 0 &SSPICK @  -1 SSDEPTH+! ;

: .STATENAME ( snum -- ) DUP
    CASE 0 OF ." crim" ENDOF
         1 OF ." (forth)" ENDOF
         2 OF ." (rsr)" ENDOF
         3 OF ." (value_1)" ENDOF
         4 OF ." (value_2)" ENDOF
         5 OF ." (value_3)" ENDOF
       256 OF ." head" ENDOF
       DUP . ENDCASE DROP ;

: SHOW-STACKS ( -- )
    RSDEPTH BEGIN 1- DUP 0>=
            WHILE DUP &RSPICK @ CRIM-BEGMEM - . REPEAT DROP ." /// "
    SSDEPTH BEGIN 1- DUP 0>= 
            WHILE DUP &SSPICK @ CRIM-BEGMEM - . REPEAT DROP ." // "
      DEPTH BEGIN 1- DUP 0>=
            WHILE DUP 1+ PICK . REPEAT DROP	\ shows Dstack
    ." :: " CRIM-STATE .STATENAME ;

: NOP ( -- ) ;
' NOP CRIM-STEPPER!				\ see autodoc.4th

: CLEAR-CRIM-STACKS ( -- ) 0 RSDEPTH!  0 SSDEPTH! ;	\ does not clear Dstack



\
\ Equivalents to HERE ALLOT , C, etc
\

DECIMAL
256 HERE 255 AND - ALLOT           \ align to a multiple of 256 (for DUMPs)
HERE CRIM-BEGMEM! 1024 ALLOT       \ 1024 bytes for programs
HERE 1024 ALLOT CONSTANT SHADOW-BEGMEM  \ the next 1024 are used as "shadow"

CRIM-BEGMEM VALUE CRIM-HERE
: CR-H ( -- cr-h ) CRIM-HERE CRIM-BEGMEM - ;

: XTRACTBYTE ( w 0..3 -- byte ) 8 * RSHIFT 255 AND ;
: FLIPBYTES ( 0xabcd -- 0xcdab ) DUP 255 AND 256 * SWAP 1 XTRACTBYTE + ;

: CRIM1, ( byte -- ) CRIM-HERE C! 1 +TO CRIM-HERE ;
: CRIM2, ( word -- ) 2 0 DO DUP I XTRACTBYTE CRIM1, LOOP DROP ;
: CRIM4, ( x -- ) 4 0 DO DUP I XTRACTBYTE CRIM1, LOOP DROP ;



\
\ Words for placing descriptions at the shadow
\ (for example, a two-byte Crim instruction appears as "l+" on a shadow dump;
\ heads appear as "h", short Crim instructions as "s", etc)
\

: $SH! ( $adr $len cr-h -- ) SHADOW-BEGMEM + SWAP MOVE ;
: SH, ( $adr $len -- ) CR-H $SH! ;



\
\ Words for dumping the Crim program space
\   CRIM-DUMP- - without shadow chars
\   CRIM-DUMP  - with shadow chars
\

: CRIM-DUMP- ( -- ) CRIM-BEGMEM CR-H DUMP ;
: CRIM-DUMP  ( -- ) SHADOW-BEGMEM CR-H DUMP CR CRIM-DUMP- ;



\
\ Basic creator words and modifiers (%' %2NDHEAD etc)
\

: HEAD: ( I: byte -- ) ( E: -- ) CREATE , DOES>  S" h" SH,  @ CRIM1, ;
: SHORT-CRIM: ( I: byte -- ) ( E: -- ) CREATE , DOES> S" s" SH,  @ CRIM1, ;

0 VALUE HEADDISPL
0 VALUE TICK?

: _CRIM2: ( I: cr-h -- ) ( E: -- | cr-h )
    CREATE , DOES>
      @  HEADDISPL +
      TICK? IF ( leave on stack ) 
            ELSE FLIPBYTES  S" l+" SH,  CRIM2, THEN
      0 TO HEADDISPL
      0 TO TICK? ;

: CRIM2: ( I: -- ) ( E: -- | cr-h ) CR-H _CRIM2: ;

: %2NDHEAD ( -- ) -1 +TO HEADDISPL ;
: %3RDHEAD ( -- ) -2 +TO HEADDISPL ; \ same as %2NDHEAD %2NDHEAD
: %' ( -- ) TRUE TO TICK? ;



\
\
\

0 HEAD: %H_CRIM
1 HEAD: %H_FORTH
2 HEAD: %H_RSR
3 HEAD: %H_VALUE_1
4 HEAD: %H_VALUE_2
5 HEAD: %H_VALUE_3

255 SHORT-CRIM: %EXIT
254 SHORT-CRIM: %SEXIT
253 SHORT-CRIM: %LIT4
252 SHORT-CRIM: %END_CRIM

: %: ( -- ;' ) CRIM2: %H_CRIM ;
: %; ( -- ) %EXIT ;
: %VALUE ( w -- ;' ) %H_VALUE_3 %H_VALUE_2 CRIM2: %H_VALUE_1
    S" 4..." SH,  CRIM4, ;
: %-> ( xt -- ;' ) CRIM2: %H_FORTH  S" f..." SH,  CRIM4, ;

: CLEAR-CRIM-SPACE ( -- )
    CRIM-BEGMEM 1024 BL FILL		\ (spaces look better than
    SHADOW-BEGMEM 1024 BL FILL		\  zeroes on DUMPs)
    CLEAR-CRIM-STACKS			\ empties RS and SS
    CRIM-BEGMEM TO CRIM-HERE		\ compilation starts at 0
    %END_CRIM %SEXIT ;			\ needed by CALL-CRIM and RSRs

: CALL-CRIM ( ... crim-tick-adr -- ... )
    CRIM-BEGMEM >RS				\ address of an END-CRIM
    CRIM-BEGMEM + >RS				\ address of some head
    256 CRIM-STATE!				\ start in state HEAD_STATE
    CRIM-ENGINE
    RS> DROP ;					\ discard the addr of %END_CRIM



\
\ Words needed for the second example
\

: %:RSR ( -- ;' ) CRIM2: %H_RSR ;

: %DISPL ( -- displ-adr ) CRIM-HERE  0  S" j" SH,  CRIM1, ;
: %JMP! ( dest displ-adr -- ) DUP >R  1+ -  R> C! ;
: %<M ( -- dest ) CRIM-HERE ;				\ mark>
: %<R ( dest -- ) %DISPL %JMP! ;			\ resolve>
: %M> ( -- displ-adr ) %DISPL ;				\ <mark
: %R> ( displ-adr -- ) CRIM-HERE SWAP %JMP! ;		\ <resolve

: S@U1, ( s // -- s+1 // s@u1 ) S> DUP C@ SWAP 1+ >S ;
: S@U2, ( s // -- s+2 // s@u2 ) S> DUP @ 65535 AND SWAP 2+ >S ;

: SIGN-EXTEND ( x bitvalue -- x|x-2*bitvalue )
    2DUP AND IF 2* - ELSE DROP THEN ;			\ weird, but works

: S@S1, ( s // -- s+1 // s@s1 ) S@U1, 128 SIGN-EXTEND ;
: S@S2, ( s // -- s+2 // s@s2 ) S@U2, 32768 SIGN-EXTEND ;

: CRIM$, ( adr len -- ) DUP >R  CRIM-HERE SWAP MOVE  R> +TO CRIM-HERE ;
: CRIMC$, ( adr len -- )			\ for counted strings
    DUP  S" $" SH,  CRIM1,			\ string lenght ("$")
    SHADOW-BEGMEM CR-H +  OVER  ASCII c  FILL	\ "c" for each char
    CRIM$, ;