smolforth/core.fth at main · fstiewitz/smolforth · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
: NIP >R DROP R> ;
: TUCK ( a b c -- a c b c ) DUP ROT SWAP ;

0 S" EMBEDDED" ENVIRONMENT? AND [IF] DROP
: 2>R R> ROT >R SWAP >R >R ;
: 2R> R> R> R> SWAP ROT >R ;
: 2R@ 2R> 2DUP 2>R ;
[ELSE]
: 2>R POSTPONE SWAP POSTPONE >R POSTPONE >R ; IMMEDIATE
: 2R> POSTPONE R> POSTPONE R> POSTPONE SWAP ; IMMEDIATE
: 2R@ POSTPONE R> POSTPONE R> POSTPONE 2DUP POSTPONE >R POSTPONE >R POSTPONE SWAP ; IMMEDIATE
[THEN]

: 0<> 0 <> ;
: 0> 0 > ;

: U>
    2DUP U< INVERT >R
    = INVERT R> AND
;

: ROLL DUP 0= IF DROP EXIT THEN SWAP >R 1- RECURSE R> SWAP ;

: WITHIN ( a l u -- flag )
    OVER - >R - R> U< ;
;

: VALUETO
    IF
        CELL+ !
    ELSE
        CELL+ @
    THEN
;

0 S" EMBEDDED" ENVIRONMENT? AND INVERT [IF]

: BUFFER: CREATE ALLOT ;

: VALUE CREATE ['] VALUETO , , DOES> DUP 0 ROT @ EXECUTE ;
0 VALUE SYS:VALUE0

: TO! >BODY DUP 1 SWAP @ EXECUTE ;

: TO
    STATE @ IF
        POSTPONE ['] POSTPONE TO!
    ELSE
        ' TO!
    THEN
; IMMEDIATE

[ELSE] DROP [THEN]

: HOLDS
    BEGIN
        DUP
    WHILE
        1- 2DUP + C@ HOLD
    REPEAT
    2DROP
;

: . DUP ABS 0 <# #S ROT SIGN #> TYPE SPACE ;

: ? @ . ;