2024-11-02 16:30:57 +11:00
5 changed files with 116 additions and 180 deletions
--- a/apps/forth/core.fth
+++ b/apps/forth/core.fth
@ -4,24 +4,20 @@
 : ALLOT HERE +! ;
 : , H ! 2 ALLOT ;
 : C, H C! 1 ALLOT ;
-: NOT 1 SWAP SKIP? EXIT 0 * ;
-: RECURSE R> R> 2 - >R >R EXIT ;
-: ( LIT@ ) WORD SCMP NOT SKIP? RECURSE ; 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
-  NOT: a bit convulted because we don't have IF yet
-  RECURSE: RS TOS is for RECURSE itself, then we have to dig
-  one more level to get to RECURSE's parent's caller.
-  IF true, skip following (fbr). Also, push br cell ref H,
-  to PS )
-: IF ['] SKIP? , ['] (fbr) , H 1 ALLOT ; IMMEDIATE
-( Subtract TOS from H to get offset to write to IF or ELSE's
-  br cell )
+: IF ['] (fbr?) , H 1 ALLOT ; IMMEDIATE
 : THEN DUP H -^ SWAP C! ; IMMEDIATE
-( write (fbr) addr, allot, then same as THEN )
 : 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 ;
 : ? @ . ;
 : VARIABLE CREATE 2 ALLOT ;
 : CONSTANT CREATE H ! DOES> @ ;
--- a/apps/forth/dict.asm
+++ b/apps/forth/dict.asm
@ -206,6 +206,7 @@ PFETCH:
 EXECUTE:
 	.dw nativeWord
 	pop	iy	; is a wordref
+executeCodeLink:
 	ld	l, (iy)
 	ld	h, (iy+1)
 	; HL points to code pointer
@ -215,68 +216,9 @@ EXECUTE:
 	jp	(hl)	; go!


-	.db	"COMPILE"
-	.dw	EXECUTE
-	.db	1		; IMMEDIATE
-COMPILE:
-	.dw	nativeWord
-	pop	hl		; word addr
-	call	find
-	jr	nz, .maybeNum
-	ex	de, hl
-	call	HLisIMMED
-	jr	z, .immed
-	ex	de, hl
-	call	.writeDE
-	jp	next
-.maybeNum:
-	push	hl		; --> lvl 1. save string addr
-	call	parseLiteral
-	pop	hl		; <-- lvl 1
-	jr	nz, .undef
-	; a valid number in DE!
-	ex	de, hl
-	ld	de, NUMBER
-	call	.writeDE
-	ex	de, hl		; number in DE
-	call	.writeDE
-	jp	next
-.undef:
-	; When encountering an undefined word during compilation, we spit a
-	; reference to litWord, followed by the null-terminated word.
-	; This way, if a preceding word expect a string literal, it will read it
-	; by calling readLIT, and if it doesn't, the routine will be
-	; called, triggering an abort.
-	ld	de, LIT
-	call	.writeDE
-	ld	de, (HERE)
-	call	strcpyM
-	ld	(HERE), de
-	jp	next
-.immed:
-	; For this IMMEDIATE word to be compatible with regular execution model,
-	; it needs to be compiled as an atom somewhere in memory.
-	; For example, RECURSE backtracks in RS and steps back 2 bytes. This
-	; can only work with our compiled atom being next to an EXIT atom.
-	ex	de, hl		; atom to write in DE
-	ld	hl, (OLDHERE)
-	push	hl \ pop iy
-	call	DEinHL
-	ld	de, EXIT
-	call	DEinHL
-	jp	compiledWord
-.writeDE:
-	push	hl
-	ld	hl, (HERE)
-	call	DEinHL
-	ld	(HERE), hl
-	pop	hl
-	ret
-
-
 	.db	";"
 	.fill	6
-	.dw	COMPILE
+	.dw	EXECUTE
 	.db	0
 ENDDEF:
 	.dw	nativeWord
@ -435,6 +377,7 @@ KEY:
 WORD:
 	.dw nativeWord
 	call	readword
+	jp	nz, abort
 	push	hl
 	jp	next

@ -468,18 +411,10 @@ CURRENT_:
 	.dw sysvarWord
 	.dw CURRENT

-	.db	"IN>"
-	.fill	4
-	.dw	CURRENT_
-	.db	0
-INP:
-	.dw	sysvarWord
-	.dw	INPUTPOS
-
 ; ( n -- )
 	.db "."
 	.fill 6
-	.dw INP
+	.dw CURRENT_
 	.db 0
 DOT:
 	.dw nativeWord
@ -552,20 +487,10 @@ LITFETCH:
 	push	hl
 	jp	next

-; ( a -- )
-	.db "DROP"
-	.fill 3
-	.dw LITFETCH
-	.db 0
-DROP:
-	.dw nativeWord
-	pop	hl
-	jp	next
-
 ; ( a b -- b a )
 	.db "SWAP"
 	.fill 3
-	.dw DROP
+	.dw LITFETCH
 	.db 0
 SWAP:
 	.dw nativeWord
@ -786,27 +711,12 @@ CMP:
 	push	bc
 	jp	next

-	.db	"SKIP?"
-	.fill	2
-	.dw	CMP
-	.db	0
-CSKIP:
-	.dw	nativeWord
-	pop	hl
-	ld	a, h
-	or	l
-	jp	z, next		; False, do nothing.
-	ld	hl, (IP)
-	call	compSkip
-	ld	(IP), hl
-	jp	next
-
 ; This word's atom is followed by 1b *relative* offset (to the cell's addr) to
 ; where to branch to. For example, The branching cell of "IF THEN" would
 ; contain 3. Add this value to RS.
 	.db	"(fbr)"
 	.fill	2
-	.dw	CSKIP
+	.dw	CMP
 	.db	0
 FBR:
 	.dw	nativeWord
@ -818,6 +728,23 @@ FBR:
 	pop	de
 	jp	next

-LATEST:
-	.dw FBR
+; Conditional branch, only branch if TOS is zero
+	.db	"(fbr?)"
+	.fill	1
+	.dw	FBR
+	.db	0
+FBRC:
+	.dw	nativeWord
+	pop	hl
+	ld	a, h
+	or	l
+	jr	z, FBR+2
+	; skip next byte in RS
+	ld	hl, (IP)
+	inc	hl
+	ld	(IP), hl
+	jp	next
+
+LATEST:
+	.dw FBRC

--- a/apps/forth/dictionary.txt
+++ b/apps/forth/dictionary.txt
@ -49,9 +49,10 @@ LITERAL     n --            *I* Inserts number from TOS as a literal
 VARIABLE c  --              Creates cell x with 2 bytes allocation.

 *** Flow ***
+(fbr?)      f --            Conditionally branches forward by the number
+                            specified in its atom's cell.
 (fbr)       --              Branches forward by the number specified in its
                            atom's cell.
-COMPILE     a --            Compile string word at addr a and spit it to HERE.
 ELSE        I:a --          *I* Compiles a (fbr) and set branching cell at a.
 EXECUTE     a --            Execute wordref at addr a
 IF          -- I:a          *I* Compiles a (fbr?) and pushes its cell's addr
@ -59,13 +60,9 @@ INTERPRET   --              Get a line from stdin, compile it in tmp memory,
                            then execute the compiled contents.
 QUIT        R:drop --       Return to interpreter promp immediately
 RECURSE     R:I -- R:I-2    Run the current word again.
-SKIP?       f --            If f is true, skip the execution of the next atom.
-                            Use this right before ";" and you're gonna have a
-                            bad time.
 THEN        I:a --          *I* Set branching cell at a.

 *** Parameter Stack ***
-DROP        a --
 DUP         a -- a a
 OVER        a b -- a b a
 SWAP        a b -- b a
@ -112,21 +109,10 @@ LIT@ x      -- a            Read following LIT and push its addr to a
 SCMP        a1 a2 -- n      Compare strings a1 and a2. See CMP

 *** I/O ***
-
-A little word about inputs. There are two kind of inputs: direct and buffered.
-As a general rule, we read line in a buffer, then feed words in it to the
-interpreter. That's what "WORD" does. If it's at the End Of Line, it blocks and
-wait until another line is entered.
-
-KEY input, however, is direct. Regardless of the input buffer's state, KEY will
-return the next typed key.
-
 .           n --            Print n in its decimal form
-EMIT        c --            Spit char c to output stream
-IN>         -- a            Address of variable containing current pos in input
-                            buffer.
-KEY         -- c            Get char c from direct input
+EMIT        c --            Spit char c to stdout
+KEY         -- c            Get char c from stdin
 PC!         c a --          Spit c to port a
 PC@         a -- c          Fetch c from port a
-WORD        -- a            Read one word from buffered input and push its addr
+WORD        -- a            Read one word from stdin and push its addr

--- a/apps/forth/main.asm
+++ b/apps/forth/main.asm
@ -69,7 +69,7 @@
 ; EXECUTING A WORD
 ;
 ; At it's core, executing a word is having the wordref in IY and call
-; EXECUTE. Then, we let the word do its things. Some words are special,
+; executeCodeLink. Then, we let the word do its things. Some words are special,
 ; but most of them are of the compiledWord type, and that's their execution that
 ; we describe here.
 ;
@ -102,16 +102,16 @@ forthMain:
 	ld	(CURRENT), hl
 	ld	hl, HERE_INITIAL
 	ld	(HERE), hl
-	; Set (INPUTPOS) to somewhere where there's a NULL so we consider
-	; ourselves EOL.
-	ld	(INPUTPOS), hl
-	xor	a
-	ld	(hl), a
 forthRdLine:
 	ld	hl, msgOk
 	call	printstr
 forthRdLineNoOk:
-	; Setup return stack. After INTERPRET, we run forthExecLine
+	call	printcrlf
+	call	stdioReadLine
+	ld	(INPUTPOS), hl
+	; Setup return stack. As a safety net, we set its bottom to ABORTREF.
+	ld	hl, ABORTREF
+	ld	(RS_ADDR), hl
 	ld	ix, RS_ADDR
 	; We're about to compile the line and possibly execute IMMEDIATE words.
 	; Let's save current (HERE) and temporarily set it to COMPBUF.
@ -119,24 +119,61 @@ forthRdLineNoOk:
 	ld	(OLDHERE), hl
 	ld	hl, COMPBUF
 	ld	(HERE), hl
-	ld	hl, .retRef
-	ld	(IP), hl
-	ld	hl, INTERPRET
-	push	hl
-	jp	EXECUTE+2
-.retRef:
-	.dw	$+2
-	.dw	forthExecLine
-
-forthExecLine:
-	ld	de, QUIT
-	ld	hl, (HERE)
+forthInterpret:
+	call	readword
+	jr	nz, .execute
+	call	find
+	jr	nz, .maybeNum
+	ex	de, hl
+	call	HLisIMMED
+	jr	z, .immed
+	ex	de, hl
+	call	.writeDE
+	jr	forthInterpret
+.maybeNum:
+	push	hl		; --> lvl 1. save string addr
+	call	parseLiteral
+	pop	hl		; <-- lvl 1
+	jr	nz, .undef
+	; a valid number in DE!
+	ex	de, hl
+	ld	de, NUMBER
+	call	.writeDE
+	ex	de, hl		; number in DE
+	call	.writeDE
+	jr	forthInterpret
+.undef:
+	; When encountering an undefined word during compilation, we spit a
+	; reference to litWord, followed by the null-terminated word.
+	; This way, if a preceding word expect a string literal, it will read it
+	; by calling readLIT, and if it doesn't, the routine will be
+	; called, triggering an abort.
+	ld	de, LIT
+	call	.writeDE
+	ld	de, (HERE)
+	call	strcpyM
+	ld	(HERE), de
+	jr	forthInterpret
+.immed:
+	; For this IMMEDIATE word to be compatible with regular execution model,
+	; it needs to be compiled as an atom list. We need a temporary space for
+	; this, let's use (OLDHERE) while it isn't used.
+	ex	de, hl		; atom to write in DE
+	ld	hl, (OLDHERE)
 	call	DEinHL
-	ld	(HERE), hl
+	; Now, let's write the .retRef
+	ld	de, .retRef
+	call	DEinHL
+	ld	iy, (OLDHERE)
+	jr	.execIY
+.execute:
+	ld	de, QUIT
+	call	.writeDE
 	; Compilation done, let's restore (HERE) and execute!
 	ld	hl, (OLDHERE)
 	ld	(HERE), hl
 	ld	iy, COMPBUF
+.execIY:
 	; 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
 	; to ever return: it ends with QUIT. Let's set (IP) to ABORTREF and
@ -145,22 +182,16 @@ forthExecLine:
 	ld	(IP), hl
 	ld	ix, RS_ADDR-2
 	jp	compiledWord
+.writeDE:
+	push	hl
+	ld	hl, (HERE)
+	call	DEinHL
+	ld	(HERE), hl
+	pop	hl
+	ret

-; (we don't have RECURSE here. Calling interpret makes us needlessly use our
-; RS stack, but it can take it, can't it? )
-; WORD COMPILE IN> @ C@ (to check if null) SKIP? (skip if not null) EXIT INTERPRET
-	.db	0b10		; UNWORD
-INTERPRET:
-	.dw	compiledWord
-	.dw	WORD
-	.dw	COMPILE
-	.dw	INP
-	.dw	FETCH
-	.dw	CFETCH
-	.dw	CSKIP
-	.dw	EXIT
-	.dw	INTERPRET
-	.dw	EXIT
+.retRef:
+	.dw	forthInterpret

 msgOk:
 	.db	" ok", 0
--- a/apps/forth/util.asm
+++ b/apps/forth/util.asm
@ -7,8 +7,7 @@ pad:
 ; Read word from (INPUTPOS) and return, in HL, a null-terminated word.
 ; Advance (INPUTPOS) to the character following the whitespace ending the
 ; word.
-; When we're at EOL, we call fetchline directly, so this call always returns
-; a word.
+; Z set of word was read, unset if end of line.
 readword:
 	ld	hl, (INPUTPOS)
 	; skip leading whitespace
@ -17,7 +16,6 @@ readword:
 	inc	hl
 	ld	a, (hl)
 	or	a
-	; When at EOL, fetch a new line directly
 	jr	z, .empty
 	cp	' '+1
 	jr	c, .loop1
@ -41,8 +39,9 @@ readword:
 	pop	hl		; <-- lvl 1. our result
 	ret	; Z set from XOR A
 .empty:
-	call	fetchline
-	jr	readword
+	ld	(hl), a
+	inc	a	; unset Z
+	ret

 ; Sets Z if (HL) == E and (HL+1) == D
 HLPointsDE:
@ -74,6 +73,10 @@ HLPointsBR:
 	push	de
 	ld	de, FBR
 	call	HLPointsDE
+	jr	z, .end
+	ld	de, FBRC
+	call	HLPointsDE
+.end:
 	pop	de
 	ret

@ -337,10 +340,3 @@ DEinHL:
 	ld	(hl), d
 	inc	hl
 	ret
-
-fetchline:
-	call	printcrlf
-	call	stdioReadLine
-	ld	(INPUTPOS), hl
-	ret
-