izaya/collapseos
1
0
Fork 0
mirror of https://github.com/hsoft/collapseos.git synced 2024-11-23 18:18:07 +11:00
Code Issues Releases Wiki Activity

forth: implement readline in Forth

Browse Source 
The commit ended up being much bigger than anticipated. This was a long thread
of underlying complexities. This lead to the creation of interesting concepts
such as (sysv).
This commit is contained in:
Virgil Dupras 2020-03-20 13:35:02 -04:00
parent 2feb246334
commit c1ece95089
6 changed files with 396 additions and 315 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
emul/Makefile
View File

@ -7,7 +7,7 @@ AVRABIN = zasm/avra
SHELLAPPS = zasm ed SHELLAPPS = zasm ed
SHELLTGTS = ${SHELLAPPS:%=cfsin/%} SHELLTGTS = ${SHELLAPPS:%=cfsin/%}
# Those Forth source files are in a particular order # Those Forth source files are in a particular order
FORTHSRCS = core.fs str.fs parse.fs fmt.fs FORTHSRCS = core.fs str.fs parse.fs readln.fs fmt.fs
FORTHSRC_PATHS = ${FORTHSRCS:%=../forth/%} FORTHSRC_PATHS = ${FORTHSRCS:%=../forth/%}
CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h
OBJS = emul.o libz80/libz80.o OBJS = emul.o libz80/libz80.o

11
forth/core.fs
View File

@ -1,23 +1,20 @@
: H HERE @ ; : H HERE @ ;
: -^ SWAP - ; : -^ SWAP - ;
: +! SWAP OVER @ + SWAP ! ;
: ALLOT HERE +! ;
: C, H C! 1 ALLOT ;
: COMPILE ' LITN ['] , , ; IMMEDIATE : COMPILE ' LITN ['] , , ; IMMEDIATE
: BEGIN H ; IMMEDIATE : BEGIN H ; IMMEDIATE
: AGAIN COMPILE (bbr) H -^ C, ; IMMEDIATE : AGAIN COMPILE (bbr) H -^ C, ; IMMEDIATE
: UNTIL COMPILE SKIP? COMPILE (bbr) H -^ C, ; IMMEDIATE : UNTIL COMPILE SKIP? COMPILE (bbr) H -^ C, ; IMMEDIATE
: NOT 1 SWAP SKIP? EXIT 0 * ;
: ( BEGIN LITS ) WORD SCMP NOT UNTIL ; IMMEDIATE : ( BEGIN LITS ) WORD SCMP NOT UNTIL ; IMMEDIATE
( Hello, hello, krkrkrkr... do you hear me? ( Hello, hello, krkrkrkr... do you hear me?
Ah, voice at last! Some lines above need comments Ah, voice at last! Some lines above need comments
BTW: Forth lines limited to 64 cols because of default BTW: Forth lines limited to 64 cols because of default
input buffer size in Collapse OS input buffer size in Collapse OS
COMPILE; Tough one. Get addr of caller word (example above COMPILE: Tough one. Get addr of caller word (example above
(bbr)) and then call LITN on it. (bbr)) and then call LITN on it. )
NOT: a bit convulted because we don't have IF yet ) : +! SWAP OVER @ + SWAP ! ;
: ALLOT HERE +! ;
: IF ( -- a | a: br cell addr ) : IF ( -- a | a: br cell addr )
COMPILE SKIP? ( if true, don't branch ) COMPILE SKIP? ( if true, don't branch )

5
forth/dictionary.txt
View File

@ -32,7 +32,7 @@ directly, but as part of another word.
"*I*" in description indicates an IMMEDIATE word. "*I*" in description indicates an IMMEDIATE word.
*** Defining words *** *** Defining words ***
(find) x -- a f Read word x and find it in dict. If found, f=1 and (find) a -- a f Read at a and find it in dict. If found, f=1 and
a = wordref. If not found, f=0 and a = string addr. a = wordref. If not found, f=0 and a = string addr.
: x ... -- Define a new word : x ... -- Define a new word
; R:I -- Exit a colon definition ; R:I -- Exit a colon definition
@ -186,6 +186,7 @@ core.
." xxx" -- *I* Compiles string literal xxx followed by a call ." xxx" -- *I* Compiles string literal xxx followed by a call
to (print) to (print)
are never considered negative. "-1 .X -> ffff" are never considered negative. "-1 .X -> ffff"
C< -- c Read one char from buffered input.
EMIT c -- Spit char c to output stream EMIT c -- Spit char c to output stream
IN> -- a Address of variable containing current pos in input IN> -- a Address of variable containing current pos in input
buffer. buffer.
@ -195,6 +196,8 @@ 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 buffered input and push its addr
There are also ascii const emitters: There are also ascii const emitters:
BS
CR
LF LF
SPC SPC

613
forth/forth.asm
View File

@ -35,12 +35,11 @@
.equ NAMELEN 7 .equ NAMELEN 7
; Offset of the code link relative to the beginning of the word ; Offset of the code link relative to the beginning of the word
.equ CODELINK_OFFSET NAMELEN+3 .equ CODELINK_OFFSET NAMELEN+3
; Size of the readline buffer. If a typed line reaches this size, the line is
; flushed immediately (same as pressing return).
.equ INPT_BUFSIZE 0x40
; Buffer where WORD copies its read word to. It's significantly larger than ; Buffer where WORD copies its read word to. It's significantly larger than
; NAMELEN, but who knows, in a comment, we might have a very long word... ; NAMELEN, but who knows, in a comment, we might have a very long word...
.equ WORD_BUFSIZE 0x20 .equ WORD_BUFSIZE 0x20
; Allocated space for sysvars (see comment above SYSVCNT)
.equ SYSV_BUFSIZE 0x10
; Flags for the "flag field" of the word structure ; Flags for the "flag field" of the word structure
; IMMEDIATE word ; IMMEDIATE word
@ -54,16 +53,25 @@
.equ HERE @+2 .equ HERE @+2
; Interpreter pointer. See Execution model comment below. ; Interpreter pointer. See Execution model comment below.
.equ IP @+2 .equ IP @+2
; Pointer to where we currently are in the interpretation of the current line.
.equ INPUTPOS @+2
; Pointer to the system's number parsing function. It points to then entry that ; Pointer to the system's number parsing function. It points to then entry that
; had the "(parse)" name at startup. During stage0, it's out builtin PARSE, ; had the "(parse)" name at startup. During stage0, it's out builtin PARSE,
; but at stage1, it becomes "(parse)" from core.fs. It can also be changed at ; but at stage1, it becomes "(parse)" from core.fs. It can also be changed at
; runtime. ; runtime.
.equ PARSEPTR @+2 .equ PARSEPTR @+2
.equ INPTBUF @+2 ; Pointer to the word executed by "C<". During stage0, this points to KEY.
.equ WORDBUF @+INPT_BUFSIZE ; However, KEY ain't very interactive. This is why we implement a readline
.equ RAMEND @+WORD_BUFSIZE ; interface in Forth, which we plug in during init. If "(c<)" exists in the
; dict, CINPTR is set to it. Otherwise, we set KEY
.equ CINPTR @+2
.equ WORDBUF @+2
; Sys Vars are variables with their value living in the system RAM segment. We
; need this mechanisms for core Forth source needing variables. Because core
; Forth source is pre-compiled, it needs to be able to live in ROM, which means
; that we can't compile a regular variable in it. SYSVNXT points to the next
; free space in SYSVBUF. Then, at the word level, it's a regular sysvarWord.
.equ SYSVNXT @+WORD_BUFSIZE
.equ SYSVBUF @+2
.equ RAMEND @+SYSV_BUFSIZE
; (HERE) usually starts at RAMEND, but in certain situations, such as in stage0, ; (HERE) usually starts at RAMEND, but in certain situations, such as in stage0,
; (HERE) will begin at a strategic place. ; (HERE) will begin at a strategic place.
@ -107,6 +115,7 @@ forthMain:
; we check for stack underflow. ; we check for stack underflow.
push af \ push af \ push af push af \ push af \ push af
ld (INITIAL_SP), sp ld (INITIAL_SP), sp
ld ix, RS_ADDR
; LATEST is a *indirect* label to the latest entry of the dict. See ; LATEST is a *indirect* label to the latest entry of the dict. See
; default at the bottom of dict.asm. This indirection allows us to ; default at the bottom of dict.asm. This indirection allows us to
; override latest to a value set in a binary dict compiled separately, ; override latest to a value set in a binary dict compiled separately,
@ -116,53 +125,61 @@ forthMain:
ld (CURRENT), hl ld (CURRENT), hl
ld hl, HERE_INITIAL ld hl, HERE_INITIAL
ld (HERE), hl 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
; Set up PARSEPTR ; Set up PARSEPTR
ld hl, PARSE-CODELINK_OFFSET ld hl, PARSE-CODELINK_OFFSET
call find call find
ld (PARSEPTR), de ld (PARSEPTR), de
forthRdLine: ; Set up CINPTR
ld hl, msgOk ; do we have a C< impl?
call printstr ld hl, .cinName
forthRdLineNoOk: call find
; Setup return stack. After INTERPRET, we run forthExecLine jr z, .skip
ld ix, RS_ADDR ; no? then use KEY
ld hl, MAINLOOP ld de, KEY
.skip:
ld (CINPTR), de
; Set up SYSVNXT
ld hl, SYSVBUF
ld (SYSVNXT), hl
ld hl, BEGIN
push hl push hl
jp EXECUTE+2 jp EXECUTE+2
.cinName:
.db "C<", 0
forthLoop:
ld hl, INTERPRET
push hl
jp EXECUTE+2
BEGIN:
.dw compiledWord
.dw LIT
.db "(c<$)", 0
.dw FIND_
.dw NOT
.dw CSKIP
.dw EXECUTE
.dw INTERPRET
INTERPRET: INTERPRET:
.dw compiledWord .dw compiledWord
; BBR mark
.dw WORD
.dw FIND_ .dw FIND_
.dw CSKIP .dw CSKIP
.dw .maybeNum .dw FBR
.db 6
; It's a word, execute it ; It's a word, execute it
.dw EXECUTE .dw EXECUTE
.dw EXIT .dw BBR
.db 13
.maybeNum: ; FBR mark, try number
.dw compiledWord
.dw PARSEI .dw PARSEI
.dw R2P ; exit INTERPRET .dw BBR
.dw DROP .db 18
.dw EXIT ; infinite loop
MAINLOOP:
.dw compiledWord
.dw INTERPRET
.dw INP
.dw FETCH
.dw CFETCH
.dw CSKIP
.dw QUIT
.dw MAINLOOP
msgOk:
.db " ok", 0
; *** Collapse OS lib copy *** ; *** Collapse OS lib copy ***
; In the process of Forth-ifying Collapse OS, apps will be slowly rewritten to ; In the process of Forth-ifying Collapse OS, apps will be slowly rewritten to
@ -172,105 +189,6 @@ msgOk:
; give us an idea of Forth's compactness. ; give us an idea of Forth's compactness.
; These routines below are copy/paste from apps/lib and stdio. ; These routines below are copy/paste from apps/lib and stdio.
; print null-terminated string pointed to by HL
printstr:
push af
push hl
.loop:
ld a, (hl) ; load character to send
or a ; is it zero?
jr z, .end ; if yes, we're finished
call PUTC
inc hl
jr .loop
.end:
pop hl
pop af
ret
; Prints a line terminator. This routine is a bit of a misnomer because it's
; designed to be overridable to, for example, printlf, but we'll live with it
; for now...
printcrlf:
push af
ld a, CR
call PUTC
ld a, LF
call PUTC
pop af
ret
; Repeatedly calls stdioGetC until a whole line was read, that is, when CR or
; LF is read or if the buffer is full. Sets HL to the beginning of the read
; line, which is null-terminated.
;
; This routine also takes care of echoing received characters back to the TTY.
; It also manages backspaces properly.
readline:
call printcrlf
ld hl, INPTBUF
ld b, INPT_BUFSIZE-1
.loop:
; Let's wait until something is typed.
call GETC
; got it. Now, is it a CR or LF?
cp CR
jr z, .complete ; char is CR? buffer complete!
cp LF
jr z, .complete
cp DEL
jr z, .delchr
cp BS
jr z, .delchr
; Echo the received character right away so that we see what we type
call PUTC
; Ok, gotta add it do the buffer
ld (hl), a
inc hl
djnz .loop
; buffer overflow, complete line
.complete:
; The line in our buffer is complete.
; Let's null-terminate it and return.
xor a
ld (hl), a
ld hl, INPTBUF
ld (INPUTPOS), hl
ret
.delchr:
; Deleting is a tricky business. We have to decrease HL and increase B
; so that everything stays consistent. We also have to make sure that
; We don't do buffer underflows.
ld a, b
cp INPT_BUFSIZE-1
jr z, .loop ; beginning of line, nothing to delete
dec hl
inc b
; Char deleted in buffer, now send BS + space + BS for the terminal
; to clear its previous char
ld a, BS
call PUTC
ld a, ' '
call PUTC
ld a, BS
call PUTC
jr .loop
; Ensures that Z is unset (more complicated than it sounds...)
; There are often better inline alternatives, either replacing rets with
; appropriate jmps, or if an 8 bit register is known to not be 0, an inc
; then a dec. If a is nonzero, 'or a' is optimal.
unsetZ:
or a ;if a nonzero, Z reset
ret nz
cp 1 ;if a is zero, Z reset
ret
; copy (HL) into DE, then exchange the two, utilising the optimised HL instructions. ; copy (HL) into DE, then exchange the two, utilising the optimised HL instructions.
; ld must be done little endian, so least significant byte first. ; ld must be done little endian, so least significant byte first.
intoHL: intoHL:
@ -484,26 +402,6 @@ parseDecimal:
ret ret
; *** Support routines *** ; *** Support routines ***
; Advance (INPUTPOS) until a non-whitespace is met. If needed,
; call readline.
; Set HL to newly set (INPUTPOS)
toword:
ld hl, (INPUTPOS)
; skip leading whitespace
dec hl ; offset leading "inc hl"
.loop:
inc hl
ld a, (hl)
or a
; When at EOL, fetch a new line directly
jr z, .empty
cp ' '+1
jr c, .loop
ret
.empty:
call readline
jr toword
; Sets Z if (HL) == E and (HL+1) == D ; Sets Z if (HL) == E and (HL+1) == D
HLPointsDE: HLPointsDE:
ld a, (hl) ld a, (hl)
@ -555,24 +453,6 @@ find:
; Z will be set if DE is zero ; Z will be set if DE is zero
ret ret
; Spit name (in (HL)) + prev in (HERE) and adjust (HERE) and (CURRENT)
; HL points to new (HERE)
entryhead:
ld de, (HERE)
call strcpy
ex de, hl ; (HERE) now in HL
ld de, (CURRENT)
ld a, NAMELEN
call addHL
call DEinHL
; Set word flags: not IMMED, so it's 0
xor a
ld (hl), a
inc hl
ld (CURRENT), hl
ld (HERE), hl
ret
; Checks flags Z and S and sets BC to 0 if Z, 1 if C and -1 otherwise ; Checks flags Z and S and sets BC to 0 if Z, 1 if C and -1 otherwise
flagsToBC: flagsToBC:
ld bc, 0 ld bc, 0
@ -782,7 +662,8 @@ EXIT:
.db 0 .db 0
QUIT: QUIT:
.dw nativeWord .dw nativeWord
jp forthRdLine ld ix, RS_ADDR
jp forthLoop
.db "ABORT" .db "ABORT"
.fill 2 .fill 2
@ -790,25 +671,20 @@ QUIT:
.db 0 .db 0
ABORT: ABORT:
.dw nativeWord .dw nativeWord
abort: ; Reinitialize PS
; flush rest of input
ld hl, (INPUTPOS)
xor a
ld (hl), a
; Reinitialize PS (RS is reinitialized in forthInterpret)
ld sp, (INITIAL_SP) ld sp, (INITIAL_SP)
jp forthRdLineNoOk jp QUIT+2
; prints msg in (HL) then aborts
abortMsg:
call printstr
jr abort
abortUnderflow: abortUnderflow:
ld hl, .msg ld hl, .word
jr abortMsg push hl
.msg: jp EXECUTE+2
.word:
.dw compiledWord
.dw LIT
.db "stack underflow", 0 .db "stack underflow", 0
.dw PRINT
.dw ABORT
.db "ABORT", '"' .db "ABORT", '"'
.fill 1 .fill 1
@ -817,17 +693,11 @@ abortUnderflow:
ABORTI: ABORTI:
.dw compiledWord .dw compiledWord
.dw PRINTI .dw PRINTI
.dw .private .dw NUMBER
.dw ABORT
.dw WR
.dw EXIT .dw EXIT
.private:
.dw nativeWord
ld hl, (HERE)
ld de, ABORT
call DEinHL
ld (HERE), hl
jp next
.db "BYE" .db "BYE"
.fill 4 .fill 4
.dw ABORTI .dw ABORTI
@ -862,8 +732,13 @@ PRINT:
.dw nativeWord .dw nativeWord
pop hl pop hl
call chkPS call chkPS
call printstr .loop:
jp next ld a, (hl) ; load character to send
or a ; is it zero?
jp z, next ; if yes, we're finished
call PUTC
inc hl
jr .loop
.db '.', '"' .db '.', '"'
@ -871,34 +746,31 @@ PRINT:
.dw PRINT .dw PRINT
.db 1 ; IMMEDIATE .db 1 ; IMMEDIATE
PRINTI: PRINTI:
.dw nativeWord .dw compiledWord
ld hl, (HERE) .dw NUMBER
ld de, LIT .dw LIT
call DEinHL .dw WR
ex de, hl ; (HERE) now in DE ; BBR mark
ld hl, (INPUTPOS) .dw CIN
.loop: .dw DUP
ld a, (hl) .dw NUMBER
or a ; null? not cool .dw '"'
jp z, abort .dw CMP
cp '"' .dw CSKIP
jr z, .loopend .dw FBR
ld (de), a .db 6
inc hl .dw CWR
inc de .dw BBR
jr .loop .db 19
.loopend: ; FBR mark
inc hl ; inputpos to char afterwards ; null terminate string
ld (INPUTPOS), hl .dw NUMBER
; null-terminate LIT .dw 0
inc de .dw CWR
xor a .dw NUMBER
ld (de), a .dw PRINT
ex de, hl ; (HERE) in HL .dw WR
ld de, PRINT .dw EXIT
call DEinHL
ld (HERE), hl
jp next
; ( c port -- ) ; ( c port -- )
.db "PC!" .db "PC!"
@ -927,9 +799,24 @@ PFETCH:
push hl push hl
jp next jp next
.db "C,"
.fill 5
.dw PFETCH
.db 0
CWR:
.dw nativeWord
pop de
call chkPS
ld hl, (HERE)
ld (hl), e
inc hl
ld (HERE), hl
jp next
.db "," .db ","
.fill 6 .fill 6
.dw PFETCH .dw CWR
.db 0 .db 0
WR: WR:
.dw nativeWord .dw nativeWord
@ -963,6 +850,7 @@ EXECUTE:
.db 1 ; IMMEDIATE .db 1 ; IMMEDIATE
COMPILE: COMPILE:
.dw compiledWord .dw compiledWord
.dw WORD
.dw FIND_ .dw FIND_
.dw CSKIP .dw CSKIP
.dw .maybeNum .dw .maybeNum
@ -990,55 +878,37 @@ COMPILE:
.dw EXIT .dw EXIT
.db ":" .db ";"
.fill 6 .fill 6
.dw COMPILE .dw COMPILE
.db 1 ; IMMEDIATE .db 1 ; IMMEDIATE
ENDDEF:
.dw compiledWord
.dw NUMBER
.dw EXIT
.dw WR
.dw R2P ; exit COMPILE
.dw DROP
.dw R2P ; exit DEFINE
.dw DROP
.dw EXIT
.db ":"
.fill 6
.dw ENDDEF
.db 1 ; IMMEDIATE
DEFINE: DEFINE:
.dw compiledWord .dw compiledWord
.dw WORD .dw WORD
.dw .define .dw ENTRYHEAD
.dw EXIT .dw NUMBER
.dw compiledWord
.define: .dw WR
.dw nativeWord ; BBR branch mark
pop hl .dw COMPILE
call entryhead .dw BBR
ld de, compiledWord .db 4
call DEinHL ; no need for EXIT, ENDDEF takes care of taking us out
ld (HERE), hl
.loop:
; did we reach ";"?
call toword
ld a, (hl)
cp ';'
jr nz, .compile
inc hl
ld a, (hl)
cp ' '+1
jr c, .loopend ; whitespace, we have semicol. end
.compile:
ld hl, (IP)
call pushRS
ld hl, .retRef
ld (IP), hl
ld hl, COMPILE
push hl
jp EXECUTE+2
.loopend:
; Advance (INPUTPOS) to after semicol. HL is already there.
ld (INPUTPOS), hl
; write EXIT and return
ld hl, (HERE)
ld de, EXIT
call DEinHL
ld (HERE), hl
jp next
.retRef:
.dw $+2
.dw $+2
call popRSIP
jr .loop
.db "DOES>" .db "DOES>"
@ -1140,12 +1010,6 @@ LITS:
.dw LITS .dw LITS
.db 0 .db 0
FIND_: FIND_:
.dw compiledWord
.dw WORD
.dw .find
.dw EXIT
.find:
.dw nativeWord .dw nativeWord
pop hl pop hl
call find call find
@ -1167,6 +1031,7 @@ FIND_:
.db 0 .db 0
FIND: FIND:
.dw compiledWord .dw compiledWord
.dw WORD
.dw FIND_ .dw FIND_
.dw CSKIP .dw CSKIP
.dw FINDERR .dw FINDERR
@ -1178,6 +1043,7 @@ FIND:
.db 0b01 ; IMMEDIATE .db 0b01 ; IMMEDIATE
FINDI: FINDI:
.dw compiledWord .dw compiledWord
.dw WORD
.dw FIND_ .dw FIND_
.dw CSKIP .dw CSKIP
.dw FINDERR .dw FINDERR
@ -1205,18 +1071,106 @@ KEY:
push hl push hl
jp next jp next
; Read word from (INPUTPOS), copy to WORDBUF, null-terminate, and return, make ; This is an indirect word that can be redirected through "CINPTR"
; This is not a real word because it's not meant to be referred to in Forth
; code: it is replaced in readln.fs.
CIN:
.dw compiledWord
.dw NUMBER
.dw CINPTR
.dw FETCH
.dw EXECUTE
.dw EXIT
; ( c -- f )
; 33 CMP 1 + NOT
; The NOT is to normalize the negative/positive numbers to 1 or 0.
; Hadn't we wanted to normalize, we'd have written:
; 32 CMP 1 -
.db "WS?"
.fill 4
.dw KEY
.db 0
ISWS:
.dw compiledWord
.dw NUMBER
.dw 33
.dw CMP
.dw NUMBER
.dw 1
.dw PLUS
.dw NOT
.dw EXIT
.db "NOT"
.fill 4
.dw ISWS
.db 0
NOT:
.dw nativeWord
pop hl
call chkPS
ld a, l
or h
ld hl, 0
jr nz, .skip ; true, keep at 0
; false, make 1
inc hl
.skip:
push hl
jp next
; ( -- c )
; C< DUP 32 CMP 1 - SKIP? EXIT DROP TOWORD
.db "TOWORD"
.fill 1
.dw NOT
.db 0
TOWORD:
.dw compiledWord
.dw CIN
.dw DUP
.dw ISWS
.dw CSKIP
.dw EXIT
.dw DROP
.dw TOWORD
.dw EXIT
; Read word from C<, copy to WORDBUF, null-terminate, and return, make
; HL point to WORDBUF. ; HL point to WORDBUF.
; Advance (INPUTPOS) to the character following the last copied character.
; When we're at EOL, we call readline directly, so this call always returns
; a word.
.db "WORD" .db "WORD"
.fill 3 .fill 3
.dw KEY .dw TOWORD
.db 0 .db 0
WORD: WORD:
.dw nativeWord .dw compiledWord
call toword .dw WORDBUF_ ; ( a )
.dw TOWORD ; ( a c )
; branch mark
.dw OVER ; ( a c a )
.dw STORE ; ( a )
.dw NUMBER ; ( a 1 )
.dw 1
.dw PLUS ; ( a+1 )
.dw CIN ; ( a c )
.dw DUP ; ( a c c )
.dw ISWS ; ( a c f )
.dw CSKIP ; ( a c )
.dw BBR
.db 20 ; here - mark
; at this point, we have ( a WS )
.dw DROP
.dw NUMBER
.dw 0
.dw SWAP ; ( 0 a )
.dw STORE ; ()
.dw WORDBUF_
.dw EXIT
.wcpy:
.dw nativeWord
ld de, WORDBUF ld de, WORDBUF
push de ; we already have our result push de ; we already have our result
.loop: .loop:
@ -1231,7 +1185,6 @@ WORD:
; null-terminate the string. ; null-terminate the string.
xor a xor a
ld (de), a ld (de), a
ld (INPUTPOS), hl
jp next jp next
@ -1284,6 +1237,27 @@ PARSEI:
.dw EXIT .dw EXIT
; Spit name (in (HL)) + prev in (HERE) and adjust (HERE) and (CURRENT)
; HL points to new (HERE)
ENTRYHEAD:
.dw nativeWord
pop hl
ld de, (HERE)
call strcpy
ex de, hl ; (HERE) now in HL
ld de, (CURRENT)
ld a, NAMELEN
call addHL
call DEinHL
; Set word flags: not IMMED, so it's 0
xor a
ld (hl), a
inc hl
ld (CURRENT), hl
ld (HERE), hl
jp next
.db "CREATE" .db "CREATE"
.fill 1 .fill 1
.dw PARSE .dw PARSE
@ -1291,21 +1265,48 @@ PARSEI:
CREATE: CREATE:
.dw compiledWord .dw compiledWord
.dw WORD .dw WORD
.dw .create .dw ENTRYHEAD
.dw NUMBER
.dw cellWord
.dw WR
.dw EXIT
; WARNING: there are no limit checks. We must be cautious, in core code, not
; to create more than SYSV_BUFSIZE/2 sys vars.
; Also: SYSV shouldn't be used during runtime: SYSVNXT won't point at the
; right place. It should only be used during stage1 compilation. This is why
; this word is not documented in dictionary.txt
.db "(sysv)"
.fill 1
.dw CREATE
.db 0
SYSV:
.dw compiledWord
.dw WORD
.dw ENTRYHEAD
.dw NUMBER
.dw sysvarWord
.dw WR
.dw NUMBER
.dw SYSVNXT
.dw FETCH
.dw WR
; word written, now let's INC SYSVNXT
.dw NUMBER ; a
.dw SYSVNXT
.dw DUP ; a a
.dw FETCH ; a a@
.dw NUMBER ; a a@ 2
.dw 2
.dw PLUS ; a a@+2
.dw SWAP ; a@+2 a
.dw STORE
.dw EXIT .dw EXIT
.create:
.dw nativeWord
pop hl
call entryhead
ld de, cellWord
call DEinHL
ld (HERE), hl
jp next
.db "HERE" .db "HERE"
.fill 3 .fill 3
.dw CREATE .dw SYSV
.db 0 .db 0
HERE_: ; Caution: conflicts with actual variable name HERE_: ; Caution: conflicts with actual variable name
.dw sysvarWord .dw sysvarWord
@ -1325,18 +1326,18 @@ PARSEPTR_:
.dw sysvarWord .dw sysvarWord
.dw PARSEPTR .dw PARSEPTR
.db "IN>" .db "(wbuf)"
.fill 4 .fill 1
.dw PARSEPTR_ .dw PARSEPTR_
.db 0 .db 0
INP: WORDBUF_:
.dw sysvarWord .dw sysvarWord
.dw INPUTPOS .dw WORDBUF
; ( n a -- ) ; ( n a -- )
.db "!" .db "!"
.fill 6 .fill 6
.dw INP .dw WORDBUF_
.db 0 .db 0
STORE: STORE:
.dw nativeWord .dw nativeWord

78
forth/readln.fs Normal file
View File

@ -0,0 +1,78 @@
( requires core, parse )
( Managing variables in a core module is tricky. Sure, we
have (sysv), but here we need to allocate a big buffer, and
that cannot be done through (sysv). What we do is that we
allocate that buffer at runtime and use (sysv) to point to
it, a pointer that is set during the initialization
routine. )
64 CONSTANT INBUFSZ
( points to INBUF )
(sysv) IN(
( points to INBUF's end )
(sysv) IN)
( current position in INBUF )
(sysv) IN>
( flush input buffer )
( set IN> to IN( and set IN> @ to null )
: (infl) 0 IN( @ DUP IN> ! ! ;
( Initializes the readln subsystem )
: (c<$)
HERE @ IN( !
INBUFSZ ALLOT
HERE @ IN) !
(infl)
;
( handle backspace: go back one char in IN>, if possible, then
emit SPC + BS )
: (inbs)
( already at IN( ? )
IN> @ IN( @ = IF EXIT THEN
IN> @ 1 - IN> !
SPC BS
;
( read one char into input buffer and returns whether we
should continue, that is, whether newline was not met. )
: (rdlnc) ( -- f )
( buffer overflow? stop now )
IN> @ IN) @ = IF 0 EXIT THEN
( get and echo back )
KEY DUP ( c c )
( del? same as backspace )
DUP 0x7f = IF DROP DROP 0x8 DUP THEN
EMIT ( c )
( bacspace? handle and exit )
DUP 0x8 = IF (inbs) EXIT THEN
( write and advance )
DUP ( keep as result ) ( c c )
IN> @ ! 1 IN> +! ( c )
( not newline? exit now )
DUP 0xa = NOT IF EXIT THEN ( c )
( newline? make our result 0 and write it to indicate
EOL )
DROP 0
DUP IN> @ ! ( c )
;
( Read one line in input buffer and make IN> point to it )
: (rdln)
( TODO: don't emit prompt in middle of defs and comments )
LF '>' EMIT SPC
(infl)
BEGIN (rdlnc) NOT UNTIL
IN( @ IN> !
;
( And finally, implement a replacement for the C< routine )
: C<
IN> @ C@ ( c )
( not EOL? good, inc and return )
DUP IF 1 IN> +! EXIT THEN ( c )
( EOL ? readline. we still return typed char though )
(rdln) ( c )
;

2
forth/str.fs
View File

@ -6,5 +6,7 @@
AGAIN AGAIN
; ;
: BS 8 EMIT ;
: LF 10 EMIT ; : LF 10 EMIT ;
: CR 13 EMIT ;
: SPC 32 EMIT ; : SPC 32 EMIT ;