collapseos/forth/core.fs
Virgil Dupras af39b37dd1 Replace the "> " prompt with the more traditional "ok" one
This is more than cosmetic, it's also highly usable. The presence
or absence of the "ok" message allows us to know whether the command
aborted. Previously, the "> " prompt appeared when the system expected
a prompt in the INTERPRET context, whether the previous command aborted
or not.

Also, this allows us to get rid of that ugly FLAGS global variable.
2020-04-24 12:10:07 -04:00

201 lines
4.5 KiB
Forth

: H@ HERE @ ;
: IMMEDIATE
CURRENT @ 1-
DUP C@ 128 OR SWAP C!
;
: [ INTERPRET ; IMMEDIATE
: ] R> DROP ;
: LITS 34 , SCPY ;
: LIT< WORD LITS ; IMMEDIATE
: LITA 36 , , ;
: '
WORD (find) (?br) [ 4 , ] EXIT
LIT< (wnf) (find) DROP EXECUTE
;
: ['] ' LITA ; IMMEDIATE
: COMPILE ' LITA ['] , , ; IMMEDIATE
: [COMPILE] ' , ; IMMEDIATE
: BEGIN H@ ; IMMEDIATE
: AGAIN COMPILE (br) H@ - , ; IMMEDIATE
: UNTIL COMPILE (?br) H@ - , ; IMMEDIATE
: ( BEGIN LIT< ) WORD S= UNTIL ; IMMEDIATE
( Hello, hello, krkrkrkr... do you hear me?
Ah, voice at last! Some lines above need comments
BTW: Forth lines limited to 64 cols because of default
input buffer size in Collapse OS
"_": words starting with "_" are meant to be "private",
that is, only used by their immediate surrondings.
LITS: 34 == litWord
LITA: 36 == addrWord
COMPILE: Tough one. Get addr of caller word (example above
(br)) and then call LITA on it. )
: +! SWAP OVER @ + SWAP ! ;
: -^ SWAP - ;
: ALLOT HERE +! ;
: IF ( -- a | a: br cell addr )
COMPILE (?br)
H@ ( push a )
2 ALLOT ( br cell allot )
; IMMEDIATE
: THEN ( a -- | a: br cell addr )
DUP H@ -^ SWAP ( a-H a )
!
; IMMEDIATE
: ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell )
COMPILE (br)
2 ALLOT
DUP H@ -^ SWAP ( a-H a )
!
H@ 2- ( push a. -2 for allot offset )
; IMMEDIATE
( During a CASE, the stack grows by 1 at each ENDOF so that
we can fill all those ENDOF branching addrs. So that we
know when to stop, we put a 0 on PSP. That's our stopgap. )
: CASE 0 COMPILE >R ; IMMEDIATE
: OF
COMPILE I COMPILE =
[COMPILE] IF
; IMMEDIATE
: ENDOF [COMPILE] ELSE ; IMMEDIATE
( At this point, we have something like "0 e1 e2 e3 val". We
want top drop val, and then call THEN as long as we don't
hit 0. )
: ENDCASE
BEGIN
DUP NOT IF
DROP COMPILE R> COMPILE DROP EXIT
THEN
[COMPILE] THEN
AGAIN
; IMMEDIATE
: CREATE
(entry) ( empty header with name )
11 ( 11 == cellWord )
C, ( write it )
;
( We run this when we're in an entry creation context. Many
things we need to do.
1. Change the code link to doesWord
2. Leave 2 bytes for regular cell variable.
3. Write down RS' RTOS to entry.
4. exit parent definition
)
: DOES>
( Overwrite cellWord in CURRENT )
( 43 == doesWord )
43 CURRENT @ C!
( When we have a DOES>, we forcefully place HERE to 4
bytes after CURRENT. This allows a DOES word to use ","
and "C," without messing everything up. )
CURRENT @ 3 + HERE !
( HERE points to where we should write R> )
R> ,
( We're done. Because we've popped RS, we'll exit parent
definition )
;
: VARIABLE CREATE 2 ALLOT ;
: CONSTANT CREATE , DOES> @ ;
: / /MOD SWAP DROP ;
: MOD /MOD DROP ;
( In addition to pushing H@ this compiles 2 >R so that loop
variables are sent to PS at runtime )
: DO
COMPILE SWAP COMPILE >R COMPILE >R
H@
; IMMEDIATE
( Increase loop counter and returns whether we should loop. )
: _
R> ( IP, keep for later )
R> 1+ ( ip i+1 )
DUP >R ( ip i )
I' = ( ip f )
SWAP >R ( f )
;
( One could think that we should have a sub word to avoid all
these COMPILE, but we can't because otherwise it messes with
the RS )
: LOOP
COMPILE _ COMPILE (?br)
H@ - ,
COMPILE R> COMPILE DROP COMPILE R> COMPILE DROP
; IMMEDIATE
: LEAVE R> R> DROP I 1- >R >R ;
: ROLL
DUP NOT IF EXIT THEN
1+ DUP PICK ( n val )
SWAP 2 * (roll) ( val )
SWAP DROP
;
: 2DUP OVER OVER ;
: 2OVER 3 PICK 3 PICK ;
: 2SWAP 3 ROLL 3 ROLL ;
( a1 a2 u -- )
: MOVE
( u ) 0 DO
SWAP DUP I + C@ ( a2 a1 x )
ROT SWAP OVER I + ( a1 a2 x a2 )
C! ( a1 a2 )
LOOP
2DROP
;
: DELW
1- 0 SWAP C!
;
: PREV
3 - DUP @ ( a o )
- ( a-o )
;
: WORD(
DUP 1- C@ ( name len field )
127 AND ( 0x7f. remove IMMEDIATE flag )
3 + ( fixed header len )
-
;
: FORGET
' DUP ( w w )
( HERE must be at the end of prev's word, that is, at the
beginning of w. )
WORD( HERE ! ( w )
PREV CURRENT !
;
: EMPTY
LIT< _sys (find) NOT IF ABORT THEN
DUP HERE ! CURRENT !
;
( Drop RSP until I-2 == INTERPRET. )
: EXIT!
['] INTERPRET ( I )
BEGIN ( I )
DUP ( I I )
R> DROP I 2- @ ( I I a )
= UNTIL
DROP
;
( a -- a+1 c )
: C@+ DUP C@ SWAP 1+ SWAP ;