forth_combinator/base.lua

base_fth = [[
: HEX 16 BASE ! ;
: DEC 10 BASE ! ;
: OCT 8 BASE ! ;
: BIN 2 BASE ! ;

: C! SWAP 255 AND SWAP ! ;
: C@ @ 255 AND ;
: C,
    HERE @ C!
    1 HERE +!
;

: LITERAL IMMEDIATE
    COMP' LIT ,
    ,
;
: CHAR BL WORD 1+ C@ ;

: '"' [ CHAR " ] LITERAL ;
: '[' [ CHAR [ ] LITERAL ;
: ']' [ CHAR ] ] LITERAL ;
: '(' [ CHAR ( ] LITERAL ;
: ')' [ CHAR ) ] LITERAL ;
: ':' [ CHAR : ] LITERAL ;
: ';' [ CHAR ; ] LITERAL ;
: '0' [ CHAR 0 ] LITERAL ;
: 'A' [ CHAR A ] LITERAL ;
: '-' [ CHAR - ] LITERAL ;
: '.' [ CHAR . ] LITERAL ;

: CR 10 EMIT ;
: SPACE 32 EMIT ;

: ' BL WORD FIND >CFA ;
: [COMPILE] IMMEDIATE ' , ;
: ['] IMMEDIATE ' [COMPILE] LITERAL ;
: LIT, ['] LIT , , ;

: / /MOD SWAP DROP ;
: MOD /MOD DROP ;

: U/ UM/MOD SWAP DROP ;
: UMOD UM/MOD DROP ;

: NOT 0= ;

: RECURSE IMMEDIATE
    LATEST @
    >CFA ,
;

: IF IMMEDIATE
    ['] 0BRANCH ,
    HERE @
    0 ,
;
: THEN IMMEDIATE
    DUP
    HERE @ SWAP -
    SWAP !
;
: ELSE IMMEDIATE
    ['] BRANCH ,
    HERE @
    0 ,
    SWAP
    DUP HERE @ SWAP -
    SWAP !
;

: ?HIDDEN 1+ C@ F_HIDDEN AND ;
: ?IMMEDIATE 1+ C@ F_IMMED AND ;

: EXECUTE-COMPILING
    STATE @ IF EXECUTE EXIT THEN
    ] EXECUTE [
;

: POSTPONE IMMEDIATE
    BL WORD FIND
    DUP ?IMMEDIATE
    SWAP >CFA LIT,
    IF ['] EXECUTE-COMPILING ELSE ['] , THEN ,
;

: BEGIN IMMEDIATE HERE @ ;
: UNTIL IMMEDIATE
    POSTPONE 0BRANCH
    HERE @ - ,
;
: AGAIN IMMEDIATE
    POSTPONE BRANCH
    HERE @ - ,
;
: WHILE IMMEDIATE
    POSTPONE 0BRANCH
    HERE @
    0 ,
;
: REPEAT IMMEDIATE
    POSTPONE BRANCH
    SWAP HERE @ - ,
    DUP HERE @ SWAP - SWAP !
;
: UNLESS IMMEDIATE
    POSTPONE NOT
    POSTPONE IF
;

: ( IMMEDIATE
    1
    BEGIN
        KEY DUP '(' = IF
            DROP
            1+
        ELSE
            ')' = IF
                1-
            THEN
        THEN
    DUP 0= UNTIL
    DROP
;

: NIP ( x y -- y ) SWAP DROP ;
: TUCK ( x y -- y x y ) SWAP OVER ;
: PICK ( xn ... x1 x0 n -- xn ... x1 x0 xn )
    1+ 1 CELLS * DSP@ + @
;

( Print many of a character )
: MANY ( n c -- )
    SWAP
    BEGIN
        DUP 0>
    WHILE
        OVER EMIT
        1-
    REPEAT
    2DROP
;

: SPACES ( n -- )
    BL MANY
;

: ZEROS ( n -- )
    '0' MANY
;

: U.  ( u -- )
    BASE @ UM/MOD     ( base rem quot )
    ?DUP IF
        RECURSE
    THEN

    DUP 10 < IF
        '0'
    ELSE
        10 -
        'A'
    THEN
    + EMIT
;

( Get number of chars in an unsigend number )
: UWIDTH  ( u -- width )
    BASE @ U/    ( rem quot)
    ?DUP IF     ( if quot <> 0 )
        RECURSE 1+
    ELSE
        1
    THEN
;

( Get number of chars in an unsigend number )
: SWIDTH  ( u -- width )
    DUP 0< IF NEGATE THEN
    BASE @ /    ( rem quot)
    ?DUP IF     ( if quot <> 0 )
        RECURSE 1+
    ELSE
        1
    THEN
;

( Left pad number )
: U.R  ( u width -- )
    SWAP
    DUP
    UWIDTH
    ROT
    SWAP -
    SPACES
    U.
;

( Zero pad number )
: U.0R  ( u width -- )
    SWAP
    DUP
    UWIDTH
    ROT
    SWAP -
    ZEROS
    U.
;

( Print left padded signed number )
: .R
    SWAP
    DUP 0< IF
        NEGATE
        1
        SWAP
        ROT
        1-
    ELSE
        0
        SWAP
        ROT
    THEN
    SWAP
    DUP
    SWIDTH
    ROT
    SWAP -

    SPACES
    SWAP

    IF
        '-' EMIT
    THEN

    U.
;

( Print zero padded signed number )
: .0R
    SWAP
    DUP 0< IF
        NEGATE
        1
        SWAP
        ROT
        1-
    ELSE
        0
        SWAP
        ROT
    THEN
    SWAP
    DUP
    SWIDTH
    ROT
    SWAP -

    ZEROS
    SWAP

    IF
        '-' EMIT
    THEN

    U.
;

: . 0 .R SPACE ;
: U. U. SPACE ;

: .S  ( Print the stack )
    DSP@ S0 @
    BEGIN
        2DUP <
    WHILE
        1-
        DUP @ .
        SPACE
    REPEAT
    2DROP
    CR
;

( Print number at address )
: ? ( addr -- ) @ . ;

: WITHIN
    -ROT OVER
    <= IF
        > IF
            TRUE
        ELSE
            FALSE
        THEN
    ELSE
        2DROP
        FALSE
    THEN
;

( Returns depth of stack )
: DEPTH  ( -- n )
    S0 @ DSP@ -
    1-
;

: S" IMMEDIATE
    STATE @ IF
        POSTPONE LITSTRING
        HERE @
        0 ,
        BEGIN
            KEY
            DUP '"' <>
        WHILE
            C,
        REPEAT
        DROP
        DUP
        HERE @ SWAP -
        1-
        SWAP !
    ELSE
        HERE @
        BEGIN
            KEY
            DUP '"' <>
        WHILE
            OVER C!
            1+
        REPEAT
        DROP
        HERE @ -
        HERE @
        SWAP
    THEN
;

: ." IMMEDIATE
    STATE @ IF
        POSTPONE S"
        POSTPONE TELL
    ELSE
        BEGIN
            KEY
            DUP '"' = IF
                DROP
                EXIT
            THEN
            EMIT
        AGAIN
    THEN
;

: DOES>
    STATE @ IF
        POSTPONE (DOES>)
    ELSE
        HERE @          ( HERE )
        LATEST @ >CFA   ( HERE CFA )
        DUP [ ' DODOES @ ] LITERAL SWAP !  ( Write CW of DODOES to CFA )
        1+ !            ( Write HERE to >DOES )
        LATEST @ HIDDEN
        ]
    THEN
; IMMEDIATE

: VARIABLE CREATE 0 , ;
: CONSTANT CREATE , DOES> @ ;

: VALUE ( n -- )
    CREATE ,
    DOES> ( -- n )
    @
;

: TO ( n "name" -- )
    ' >BODY !
;

: +TO ( n "name" -- )
    ' >BODY +!
;

0 VALUE I
: SETI [ ' I >BODY ] LITERAL ! ;

: DO IMMEDIATE  ( C: -- HERE ) ( LIMIT I -- )
    SETI
    R>       ( r: -- LIMIT )
    HERE @      ( C: -- HERE )
;

: (LOOP)
    I 1+ DUP SETI
    R@ >
    0BRANCH
;

: (UNLOOP)
    >R DROP
;

: LOOP IMMEDIATE
    POSTPONE (LOOP)
    HERE @ - ,
    POSTPONE (UNLOOP)
;

: ID.
    1+                  ( Skip link pointer )
    DUP C@              ( entry flags )
    F_LENMASK AND       ( entry len)

    BEGIN
        DUP 0>          ( entry len len>0? )
    WHILE
        SWAP 1+         ( len entry+1 )
        DUP C@ EMIT
        SWAP 1-         ( entry+1 len-1 )
    REPEAT
    2DROP               ( entry len -- )
;

: WORDS
    LATEST @
    BEGIN
        ?DUP
    WHILE
        DUP ?HIDDEN IF
            ." (H)"
        THEN
        DUP ?IMMEDIATE IF
            ." (I)"
        THEN
        DUP ID. SPACE
        @
    REPEAT
    CR
;

: HIDE
    BL WORD FIND
    HIDDEN
;

: FORGET
    BL WORD FIND
    DUP @ LATEST !
    HERE !
;

: DUMP  ( addr len -- )
    ( Save BASE )
    BASE @ -ROT

    BEGIN
        ?DUP
    WHILE
        HEX
        OVER 8 U.0R
        4 SPACES

        ( Print hex )
        2DUP
        1- 15 AND 1+
        BEGIN
            ?DUP
        WHILE
            SWAP
            DUP
            5 PICK DEC 10 = IF
                @ 0 DEC
            ELSE
                C@ 2 HEX
            THEN
            .0R SPACE
            1+ SWAP 1-
        REPEAT
        DROP

        3 SPACES

        ( Print ascii )
        2DUP
        1- 15 AND 1+
        BEGIN
            ?DUP
        WHILE
            SWAP
            DUP C@
            DUP 32 128 WITHIN IF
                EMIT
            ELSE
                DROP '.' EMIT
            THEN
            1+ SWAP 1-
        REPEAT
        DROP
        CR

        DUP 1- 15 AND 1+
        TUCK
        -
        >R + R>
    REPEAT

    DROP
    BASE !
;

: CASE IMMEDIATE
    0
;

: OF IMMEDIATE
    POSTPONE OVER
    POSTPONE =
    POSTPONE IF
    POSTPONE DROP
;

: ENDOF IMMEDIATE
    POSTPONE ELSE
;

: ENDCASE IMMEDIATE
    POSTPONE DROP

    ( Compile THEN's for each ELSE )
    BEGIN
        ?DUP
    WHILE
        POSTPONE THEN
    REPEAT
;

: CFA>
    LATEST @
    BEGIN
        ?DUP
    WHILE
        2DUP SWAP
        < IF
            NIP
            EXIT
        THEN
        @
    REPEAT
    DROP
    0
;

: SEE
    BL WORD FIND

    HERE @
    LATEST @
    BEGIN
        2 PICK
        OVER
        <>
    WHILE
        NIP
        DUP @
    REPEAT

    DROP SWAP

    ':' EMIT SPACE DUP ID. CR
    DUP ?IMMEDIATE IF ." IMMEDIATE " THEN

    >DFA

    BEGIN
        2DUP >
    WHILE
        DUP @

        CASE
        ['] LIT OF
            CELL+ DUP @
            . CR
        ENDOF
        ['] LITSTRING OF
            [ CHAR S ] LITERAL EMIT '"' EMIT SPACE
            CELL+
            COUNT 2DUP TELL
            '"' EMIT CR
            +
            CELL-
        ENDOF
        ['] 0BRANCH OF
            ." 0BRANCH("
            CELL+ DUP @ 0 .R
            ." ) " CR
        ENDOF
        ['] BRANCH OF
            ." BRANCH("
            CELL+ DUP @ 0 .R
            ." ) " CR
        ENDOF
        ['] ' OF
            [ CHAR ' ] LITERAL EMIT SPACE
            CELL+ @
            CFA> ID. CR
        ENDOF
        ['] EXIT OF
            2DUP CELL+
            <> IF
                ." EXIT " CR
            THEN
        ENDOF
            DUP
            CFA>
            ID. CR
        ENDCASE

        CELL+
    REPEAT

    ';' EMIT CR

    2DROP
;

: :NONAME
    HERE @
    LATEST @ ,
    LATEST !
    0 ,
    HERE @
    [ ' DOCOL @ ] LITERAL ,
    0 ,
    ]
;

( Colors )
DEC
: ESC[ 27 EMIT '[' EMIT ;
0 CONSTANT RESET
1 CONSTANT BRIGHT
2 CONSTANT DIM
4 CONSTANT UNSERSCORE
5 CONSTANT BLINK
7 CONSTANT REVERSE
8 CONSTANT HIDDEN

: FG> 30 + ;
: BG> 40 + ;

0 CONSTANT <BLK
1 CONSTANT <RED
2 CONSTANT <GRN
3 CONSTANT <YEL
4 CONSTANT <BLU
5 CONSTANT <MAG
6 CONSTANT <CYN
7 CONSTANT <WHT

: <COLOR> ESC[ 0 .R ';' EMIT 0 .R ." m" ;
: <ATTRIB> ESC[ 0 .R ';' EMIT ." ;m" ;
]]