1
0
mirror of https://github.com/hsoft/collapseos.git synced 2024-12-26 05:28:05 +11:00

forth: Add word "("

Also, fix "RECURSE" in IMMEDIATE contexts.
This commit is contained in:
Virgil Dupras 2020-03-13 19:33:16 -04:00
parent d60ea4cb30
commit 5b1ca474d4
3 changed files with 32 additions and 17 deletions

View File

@ -1,17 +1,26 @@
: H HERE @ ; : H HERE @ ;
: -^ SWAP - ; : -^ SWAP - ;
: ? @ . ;
: +! SWAP OVER @ + SWAP ! ; : +! SWAP OVER @ + SWAP ! ;
: ALLOT HERE +! ; : ALLOT HERE +! ;
: VARIABLE CREATE 2 ALLOT ;
: CONSTANT CREATE H ! DOES> @ ;
: , H ! 2 ALLOT ; : , H ! 2 ALLOT ;
: C, H C! 1 ALLOT ; : C, H C! 1 ALLOT ;
: IF ['] (fbr?) , H 0 C, ; IMMEDIATE : IF ['] (fbr?) , H 1 ALLOT ; IMMEDIATE
: THEN DUP H -^ SWAP C! ; IMMEDIATE : THEN DUP H -^ SWAP C! ; IMMEDIATE
: ELSE ['] (fbr) , 0 C, DUP H -^ SWAP C! H 1 - ; IMMEDIATE : ELSE ['] (fbr) , 1 ALLOT DUP H -^ SWAP C! H 1 - ; IMMEDIATE
: RECURSE R> R> 2 - >R >R EXIT ;
: ( LIT@ ) WORD SCMP IF RECURSE THEN ; IMMEDIATE
( Hello, hello, krkrkrkr... do you hear me? )
( Ah, voice at last! Some lines above need comments )
( IF: write (fbr?) addr, push HERE, create cell )
( THEN: Subtract TOS from H to get offset to write to cell )
( in that same TOS's addr )
( ELSE: write (fbr) addr, allot, then same as THEN )
( RECURSE: RS TOS is for RECURSE itself, then we have to dig )
( one more level to get to RECURSE's parent's caller. )
: NOT IF 0 ELSE 1 THEN ; : NOT IF 0 ELSE 1 THEN ;
: ? @ . ;
: VARIABLE CREATE 2 ALLOT ;
: CONSTANT CREATE H ! DOES> @ ;
: = CMP NOT ; : = CMP NOT ;
: < CMP 0 1 - = ; : < CMP 0 1 - = ;
: > CMP 1 = ; : > CMP 1 = ;
: RECURSE R> R> 2 - >R >R EXIT ;

View File

@ -36,7 +36,9 @@ directly, but as part of another word.
; R:I -- Exit a colon definition ; R:I -- Exit a colon definition
, n -- Write n in HERE and advance it. , n -- Write n in HERE and advance it.
' x -- a Push addr of word x to a. ' x -- a Push addr of word x to a.
['] x -- *I* Like "'", but spits the addr as a number literal. ['] x -- *I* Like "'", but spits the addr as a number
literal.
( -- *I* Comment. Ignore rest of line until ")" is read.
ALLOT n -- Move HERE by n bytes ALLOT n -- Move HERE by n bytes
C, b -- Write byte b in HERE and advance it. C, b -- Write byte b in HERE and advance it.
CREATE x -- Create cell named x. Doesn't allocate a PF. CREATE x -- Create cell named x. Doesn't allocate a PF.

View File

@ -155,16 +155,25 @@ forthInterpret:
ld (HERE), de ld (HERE), de
jr forthInterpret jr forthInterpret
.immed: .immed:
push hl ; --> For EXECUTE ; For this IMMEDIATE word to be compatible with regular execution model,
ld hl, .retRef ; it needs to be compiled as an atom list. We need a temporary space for
ld (IP), hl ; this, let's use (OLDHERE) while it isn't used.
jp EXECUTE+2 ex de, hl ; atom to write in DE
ld hl, (OLDHERE)
call DEinHL
; Now, let's write the .retRef
ld de, .retRef
call DEinHL
ld iy, (OLDHERE)
jr .execIY
.execute: .execute:
ld de, QUIT ld de, QUIT
call .writeDE call .writeDE
; Compilation done, let's restore (HERE) and execute! ; Compilation done, let's restore (HERE) and execute!
ld hl, (OLDHERE) ld hl, (OLDHERE)
ld (HERE), hl ld (HERE), hl
ld iy, COMPBUF
.execIY:
; before we execute, let's play with our RS a bit: compiledWord is ; before we execute, let's play with our RS a bit: compiledWord is
; going to push (IP) on the RS, but we don't expect our compiled words ; going to push (IP) on the RS, but we don't expect our compiled words
; to ever return: it ends with QUIT. Let's set (IP) to ABORTREF and ; to ever return: it ends with QUIT. Let's set (IP) to ABORTREF and
@ -172,21 +181,16 @@ forthInterpret:
ld hl, ABORTREF ld hl, ABORTREF
ld (IP), hl ld (IP), hl
ld ix, RS_ADDR-2 ld ix, RS_ADDR-2
ld iy, COMPBUF
jp compiledWord jp compiledWord
.writeDE: .writeDE:
push hl push hl
ld hl, (HERE) ld hl, (HERE)
ld (hl), e call DEinHL
inc hl
ld (hl), d
inc hl
ld (HERE), hl ld (HERE), hl
pop hl pop hl
ret ret
.retRef: .retRef:
.dw $+2
.dw forthInterpret .dw forthInterpret
msgOk: msgOk: