mirror of
https://github.com/hsoft/collapseos.git
synced 2024-12-26 04:48:05 +11:00
forth: add words "CREATE", "@", "!", "HERE", "QUIT"
This commit is contained in:
parent
6f9d28b325
commit
e7cd3182d0
@ -2,14 +2,14 @@
|
|||||||
; - 8b name (zero-padded)
|
; - 8b name (zero-padded)
|
||||||
; - 2b prev pointer
|
; - 2b prev pointer
|
||||||
; - 2b code pointer
|
; - 2b code pointer
|
||||||
; - Parameter field area (PFA)
|
; - Parameter field (PF)
|
||||||
;
|
;
|
||||||
; The code pointer point to "word routines". These routines expect to be called
|
; The code pointer point to "word routines". These routines expect to be called
|
||||||
; with IY pointing to the PFA. They themselves are expected to end by jumping
|
; with IY pointing to the PF. They themselves are expected to end by jumping
|
||||||
; to the address at the top of the Return Stack. They will usually do so with
|
; to the address at the top of the Return Stack. They will usually do so with
|
||||||
; "jp exit".
|
; "jp exit".
|
||||||
|
|
||||||
; Execute a word containing native code at its PFA
|
; Execute a word containing native code at its PF address (PFA)
|
||||||
nativeWord:
|
nativeWord:
|
||||||
jp (iy)
|
jp (iy)
|
||||||
|
|
||||||
@ -30,6 +30,18 @@ compiledWord:
|
|||||||
; IY points to code link
|
; IY points to code link
|
||||||
jp executeCodeLink
|
jp executeCodeLink
|
||||||
|
|
||||||
|
; Pushes the PFA directly
|
||||||
|
cellWord:
|
||||||
|
push iy
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; Pushes the address in the first word of the PF
|
||||||
|
sysvarWord:
|
||||||
|
ld l, (iy)
|
||||||
|
ld h, (iy+1)
|
||||||
|
push hl
|
||||||
|
jp exit
|
||||||
|
|
||||||
; ( R:I -- )
|
; ( R:I -- )
|
||||||
EXIT:
|
EXIT:
|
||||||
.db "EXIT", 0, 0, 0, 0
|
.db "EXIT", 0, 0, 0, 0
|
||||||
@ -45,10 +57,20 @@ exit:
|
|||||||
push hl \ pop iy
|
push hl \ pop iy
|
||||||
jp compiledWord
|
jp compiledWord
|
||||||
|
|
||||||
|
; ( R:I -- )
|
||||||
|
QUIT:
|
||||||
|
.db "QUIT", 0, 0, 0, 0
|
||||||
|
.dw EXIT
|
||||||
|
.dw nativeWord
|
||||||
|
quit:
|
||||||
|
ld hl, FLAGS
|
||||||
|
set FLAG_QUITTING, (hl)
|
||||||
|
jp exit
|
||||||
|
|
||||||
BYE:
|
BYE:
|
||||||
.db "BYE"
|
.db "BYE"
|
||||||
.fill 5
|
.fill 5
|
||||||
.dw EXIT
|
.dw QUIT
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
ld hl, FLAGS
|
ld hl, FLAGS
|
||||||
set FLAG_ENDPGM, (hl)
|
set FLAG_ENDPGM, (hl)
|
||||||
@ -83,7 +105,8 @@ executeCodeLink:
|
|||||||
|
|
||||||
; ( -- c )
|
; ( -- c )
|
||||||
KEY:
|
KEY:
|
||||||
.db "KEY", 0, 0, 0, 0, 0
|
.db "KEY"
|
||||||
|
.fill 5
|
||||||
.dw EXECUTE
|
.dw EXECUTE
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
call stdioGetC
|
call stdioGetC
|
||||||
@ -97,36 +120,86 @@ INTERPRET:
|
|||||||
.dw KEY
|
.dw KEY
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
interpret:
|
interpret:
|
||||||
call pad
|
|
||||||
push hl \ pop iy
|
|
||||||
call stdioReadLine
|
|
||||||
ld (INPUTPOS), hl
|
|
||||||
.loop:
|
|
||||||
call readword
|
call readword
|
||||||
jp nz, .loopend
|
jp nz, quit
|
||||||
|
ld iy, COMPBUF
|
||||||
call compile
|
call compile
|
||||||
jr nz, .notfound
|
jp nz, .notfound
|
||||||
jr .loop
|
ld hl, EXIT+CODELINK_OFFSET
|
||||||
.loopend:
|
ld (iy), l
|
||||||
call compileExit
|
ld (iy+1), h
|
||||||
call pad
|
ld iy, COMPBUF
|
||||||
push hl \ pop iy
|
|
||||||
jp compiledWord
|
jp compiledWord
|
||||||
.notfound:
|
.notfound:
|
||||||
ld hl, .msg
|
ld hl, .msg
|
||||||
call printstr
|
call printstr
|
||||||
jp exit
|
jp quit
|
||||||
.msg:
|
.msg:
|
||||||
.db "not found", 0
|
.db "not found", 0
|
||||||
|
|
||||||
|
CREATE:
|
||||||
|
.db "CREATE", 0, 0
|
||||||
|
.dw INTERPRET
|
||||||
|
.dw nativeWord
|
||||||
|
call readword
|
||||||
|
jp nz, exit
|
||||||
|
ld de, (HERE)
|
||||||
|
call strcpy
|
||||||
|
ex de, hl ; (HERE) now in HL
|
||||||
|
ld de, (CURRENT)
|
||||||
|
ld (CURRENT), hl
|
||||||
|
ld a, NAMELEN
|
||||||
|
call addHL
|
||||||
|
ld (hl), e
|
||||||
|
inc hl
|
||||||
|
ld (hl), d
|
||||||
|
inc hl
|
||||||
|
ld de, cellWord
|
||||||
|
ld (hl), e
|
||||||
|
inc hl
|
||||||
|
ld (hl), d
|
||||||
|
inc hl
|
||||||
|
ld (HERE), hl
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
HERE_: ; Caution: conflicts with actual variable name
|
||||||
|
.db "HERE"
|
||||||
|
.fill 4
|
||||||
|
.dw CREATE
|
||||||
|
.dw sysvarWord
|
||||||
|
.dw HERE
|
||||||
|
|
||||||
; ( n -- )
|
; ( n -- )
|
||||||
DOT:
|
DOT:
|
||||||
.db "."
|
.db "."
|
||||||
.fill 7
|
.fill 7
|
||||||
.dw INTERPRET
|
.dw HERE_
|
||||||
.dw nativeWord
|
.dw nativeWord
|
||||||
pop de
|
pop de
|
||||||
call pad
|
call pad
|
||||||
call fmtDecimalS
|
call fmtDecimalS
|
||||||
call printstr
|
call printstr
|
||||||
jp exit
|
jp exit
|
||||||
|
|
||||||
|
; ( n a -- )
|
||||||
|
STORE:
|
||||||
|
.db "!"
|
||||||
|
.fill 7
|
||||||
|
.dw DOT
|
||||||
|
.dw nativeWord
|
||||||
|
pop iy
|
||||||
|
pop hl
|
||||||
|
ld (iy), l
|
||||||
|
ld (iy+1), h
|
||||||
|
jp exit
|
||||||
|
|
||||||
|
; ( a -- n )
|
||||||
|
FETCH:
|
||||||
|
.db "@"
|
||||||
|
.fill 7
|
||||||
|
.dw STORE
|
||||||
|
.dw nativeWord
|
||||||
|
pop hl
|
||||||
|
call intoHL
|
||||||
|
push hl
|
||||||
|
jp exit
|
||||||
|
@ -2,9 +2,15 @@ Stack notation: "<stack before> -- <stack after>". Rightmost is top of stack
|
|||||||
(TOS). For example, in "a b -- c d", b is TOS before, d is TOS
|
(TOS). For example, in "a b -- c d", b is TOS before, d is TOS
|
||||||
after. "R:" means that the Return Stack is modified.
|
after. "R:" means that the Return Stack is modified.
|
||||||
|
|
||||||
|
. n -- Print n in its decimal form
|
||||||
|
@ a -- n Set n to value at address a
|
||||||
|
! n a -- Store n in address a
|
||||||
|
CREATE x -- Create cell named x
|
||||||
EMIT c -- Spit char c to stdout
|
EMIT c -- Spit char c to stdout
|
||||||
EXECUTE a -- Execute word at addr a
|
EXECUTE a -- Execute word at addr a
|
||||||
EXIT R:I -- Exit a colon definition
|
EXIT R:I -- Exit a colon definition
|
||||||
|
HERE -- a Push HERE's address
|
||||||
|
QUIT R:drop -- Return to interpreter promp immediately
|
||||||
KEY -- c Get char c from stdin
|
KEY -- c Get char c from stdin
|
||||||
INTERPRET -- Get a line from stdin, compile it in tmp memory,
|
INTERPRET -- Get a line from stdin, compile it in tmp memory,
|
||||||
then execute the compiled contents.
|
then execute the compiled contents.
|
||||||
|
@ -2,6 +2,7 @@
|
|||||||
jp forthMain
|
jp forthMain
|
||||||
|
|
||||||
.inc "core.asm"
|
.inc "core.asm"
|
||||||
|
.inc "lib/util.asm"
|
||||||
.inc "lib/ari.asm"
|
.inc "lib/ari.asm"
|
||||||
.inc "lib/fmt.asm"
|
.inc "lib/fmt.asm"
|
||||||
.equ FORTH_RAMSTART RAMSTART
|
.equ FORTH_RAMSTART RAMSTART
|
||||||
|
@ -3,9 +3,14 @@
|
|||||||
.equ RS_ADDR 0xf000
|
.equ RS_ADDR 0xf000
|
||||||
; Number of bytes we keep as a padding between HERE and the scratchpad
|
; Number of bytes we keep as a padding between HERE and the scratchpad
|
||||||
.equ PADDING 0x20
|
.equ PADDING 0x20
|
||||||
|
; Max length of dict entry names
|
||||||
|
.equ NAMELEN 8
|
||||||
; 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 10
|
.equ CODELINK_OFFSET 10
|
||||||
; When set, the interpret should quit
|
; When set, the interpreter should abort parsing of current line and return to
|
||||||
|
; prompt.
|
||||||
|
.equ FLAG_QUITTING 0
|
||||||
|
; When set, the interpreter should quit
|
||||||
.equ FLAG_ENDPGM 1
|
.equ FLAG_ENDPGM 1
|
||||||
|
|
||||||
; *** Variables ***
|
; *** Variables ***
|
||||||
@ -14,7 +19,9 @@
|
|||||||
.equ HERE @+2
|
.equ HERE @+2
|
||||||
.equ INPUTPOS @+2
|
.equ INPUTPOS @+2
|
||||||
.equ FLAGS @+2
|
.equ FLAGS @+2
|
||||||
.equ FORTH_RAMEND @+1
|
; Buffer where we compile the current input line. Same size as STDIO_BUFSIZE.
|
||||||
|
.equ COMPBUF @+1
|
||||||
|
.equ FORTH_RAMEND @+0x40
|
||||||
|
|
||||||
; *** Code ***
|
; *** Code ***
|
||||||
MAIN:
|
MAIN:
|
||||||
@ -28,22 +35,34 @@ CHKEND:
|
|||||||
ld hl, FLAGS
|
ld hl, FLAGS
|
||||||
bit FLAG_ENDPGM, (hl)
|
bit FLAG_ENDPGM, (hl)
|
||||||
jr nz, .endpgm
|
jr nz, .endpgm
|
||||||
; not quitting, loop
|
; not quitting program, are we supposed to continue parsing line?
|
||||||
jr forthLoop
|
ld hl, FLAGS
|
||||||
|
bit FLAG_QUITTING, (hl)
|
||||||
|
jr nz, forthRdLine
|
||||||
|
; Not quitting line either.
|
||||||
|
jr forthInterpret
|
||||||
.endpgm:
|
.endpgm:
|
||||||
ld sp, (INITIAL_SP)
|
ld sp, (INITIAL_SP)
|
||||||
xor a
|
xor a
|
||||||
ret
|
ret
|
||||||
|
|
||||||
forthMain:
|
forthMain:
|
||||||
xor a
|
|
||||||
ld (FLAGS), a
|
|
||||||
ld (INITIAL_SP), sp
|
ld (INITIAL_SP), sp
|
||||||
ld hl, DOT ; last entry in hardcoded dict
|
ld hl, FETCH ; last entry in hardcoded dict
|
||||||
ld (CURRENT), hl
|
ld (CURRENT), hl
|
||||||
ld hl, FORTH_RAMEND
|
ld hl, FORTH_RAMEND
|
||||||
ld (HERE), hl
|
ld (HERE), hl
|
||||||
forthLoop:
|
forthRdLine:
|
||||||
|
xor a
|
||||||
|
ld (FLAGS), a
|
||||||
|
ld hl, msgOk
|
||||||
|
call printstr
|
||||||
|
call printcrlf
|
||||||
|
call stdioReadLine
|
||||||
|
ld (INPUTPOS), hl
|
||||||
|
forthInterpret:
|
||||||
ld ix, RS_ADDR
|
ld ix, RS_ADDR
|
||||||
ld iy, MAIN
|
ld iy, MAIN
|
||||||
jp executeCodeLink
|
jp executeCodeLink
|
||||||
|
msgOk:
|
||||||
|
.db " ok", 0
|
||||||
|
@ -2,8 +2,7 @@
|
|||||||
pad:
|
pad:
|
||||||
ld hl, (HERE)
|
ld hl, (HERE)
|
||||||
ld a, PADDING
|
ld a, PADDING
|
||||||
call addHL
|
jp addHL
|
||||||
ret
|
|
||||||
|
|
||||||
; Read word from (INPUTPOS) and return, in HL, a null-terminated word.
|
; Read word from (INPUTPOS) and return, in HL, a null-terminated word.
|
||||||
; Advance (INPUTPOS) to the character following the whitespace ending the
|
; Advance (INPUTPOS) to the character following the whitespace ending the
|
||||||
@ -48,7 +47,7 @@ readword:
|
|||||||
; Z is set if DE point to 0 (no entry). NZ if not.
|
; Z is set if DE point to 0 (no entry). NZ if not.
|
||||||
prev:
|
prev:
|
||||||
push hl ; --> lvl 1
|
push hl ; --> lvl 1
|
||||||
ld hl, 8 ; prev field offset
|
ld hl, NAMELEN ; prev field offset
|
||||||
add hl, de
|
add hl, de
|
||||||
ex de, hl
|
ex de, hl
|
||||||
pop hl ; <-- lvl 1
|
pop hl ; <-- lvl 1
|
||||||
@ -66,7 +65,7 @@ prev:
|
|||||||
find:
|
find:
|
||||||
ld de, (CURRENT)
|
ld de, (CURRENT)
|
||||||
.inner:
|
.inner:
|
||||||
ld a, 8
|
ld a, NAMELEN
|
||||||
call strncmp
|
call strncmp
|
||||||
ret z ; found
|
ret z ; found
|
||||||
call prev
|
call prev
|
||||||
@ -75,7 +74,7 @@ find:
|
|||||||
inc a
|
inc a
|
||||||
ret
|
ret
|
||||||
|
|
||||||
; Compile word string at (HL) and write down its compiled version in IY,
|
; Compile word at (DE) and write down its compiled version in IY,
|
||||||
; advancing IY to the byte next to the last written byte.
|
; advancing IY to the byte next to the last written byte.
|
||||||
; Set Z on success, unset on failure.
|
; Set Z on success, unset on failure.
|
||||||
compile:
|
compile:
|
||||||
@ -90,12 +89,3 @@ compile:
|
|||||||
inc iy
|
inc iy
|
||||||
xor a ; set Z
|
xor a ; set Z
|
||||||
ret
|
ret
|
||||||
|
|
||||||
compileExit:
|
|
||||||
ld hl, EXIT+CODELINK_OFFSET
|
|
||||||
ld (iy), l
|
|
||||||
inc iy
|
|
||||||
ld (iy), h
|
|
||||||
inc iy
|
|
||||||
ret
|
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user