mirror of
https://github.com/hsoft/collapseos.git
synced 2024-12-26 05:18: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)
|
||||
; - 2b prev pointer
|
||||
; - 2b code pointer
|
||||
; - Parameter field area (PFA)
|
||||
; - Parameter field (PF)
|
||||
;
|
||||
; 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
|
||||
; "jp exit".
|
||||
|
||||
; Execute a word containing native code at its PFA
|
||||
; Execute a word containing native code at its PF address (PFA)
|
||||
nativeWord:
|
||||
jp (iy)
|
||||
|
||||
@ -30,6 +30,18 @@ compiledWord:
|
||||
; IY points to code link
|
||||
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 -- )
|
||||
EXIT:
|
||||
.db "EXIT", 0, 0, 0, 0
|
||||
@ -45,10 +57,20 @@ exit:
|
||||
push hl \ pop iy
|
||||
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:
|
||||
.db "BYE"
|
||||
.fill 5
|
||||
.dw EXIT
|
||||
.dw QUIT
|
||||
.dw nativeWord
|
||||
ld hl, FLAGS
|
||||
set FLAG_ENDPGM, (hl)
|
||||
@ -83,7 +105,8 @@ executeCodeLink:
|
||||
|
||||
; ( -- c )
|
||||
KEY:
|
||||
.db "KEY", 0, 0, 0, 0, 0
|
||||
.db "KEY"
|
||||
.fill 5
|
||||
.dw EXECUTE
|
||||
.dw nativeWord
|
||||
call stdioGetC
|
||||
@ -97,36 +120,86 @@ INTERPRET:
|
||||
.dw KEY
|
||||
.dw nativeWord
|
||||
interpret:
|
||||
call pad
|
||||
push hl \ pop iy
|
||||
call stdioReadLine
|
||||
ld (INPUTPOS), hl
|
||||
.loop:
|
||||
call readword
|
||||
jp nz, .loopend
|
||||
jp nz, quit
|
||||
ld iy, COMPBUF
|
||||
call compile
|
||||
jr nz, .notfound
|
||||
jr .loop
|
||||
.loopend:
|
||||
call compileExit
|
||||
call pad
|
||||
push hl \ pop iy
|
||||
jp nz, .notfound
|
||||
ld hl, EXIT+CODELINK_OFFSET
|
||||
ld (iy), l
|
||||
ld (iy+1), h
|
||||
ld iy, COMPBUF
|
||||
jp compiledWord
|
||||
.notfound:
|
||||
ld hl, .msg
|
||||
call printstr
|
||||
jp exit
|
||||
jp quit
|
||||
.msg:
|
||||
.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 -- )
|
||||
DOT:
|
||||
.db "."
|
||||
.fill 7
|
||||
.dw INTERPRET
|
||||
.dw HERE_
|
||||
.dw nativeWord
|
||||
pop de
|
||||
call pad
|
||||
call fmtDecimalS
|
||||
call printstr
|
||||
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
|
||||
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
|
||||
EXECUTE a -- Execute word at addr a
|
||||
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
|
||||
INTERPRET -- Get a line from stdin, compile it in tmp memory,
|
||||
then execute the compiled contents.
|
||||
|
@ -2,6 +2,7 @@
|
||||
jp forthMain
|
||||
|
||||
.inc "core.asm"
|
||||
.inc "lib/util.asm"
|
||||
.inc "lib/ari.asm"
|
||||
.inc "lib/fmt.asm"
|
||||
.equ FORTH_RAMSTART RAMSTART
|
||||
|
@ -3,9 +3,14 @@
|
||||
.equ RS_ADDR 0xf000
|
||||
; Number of bytes we keep as a padding between HERE and the scratchpad
|
||||
.equ PADDING 0x20
|
||||
; Max length of dict entry names
|
||||
.equ NAMELEN 8
|
||||
; Offset of the code link relative to the beginning of the word
|
||||
.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
|
||||
|
||||
; *** Variables ***
|
||||
@ -14,7 +19,9 @@
|
||||
.equ HERE @+2
|
||||
.equ INPUTPOS @+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 ***
|
||||
MAIN:
|
||||
@ -28,22 +35,34 @@ CHKEND:
|
||||
ld hl, FLAGS
|
||||
bit FLAG_ENDPGM, (hl)
|
||||
jr nz, .endpgm
|
||||
; not quitting, loop
|
||||
jr forthLoop
|
||||
; not quitting program, are we supposed to continue parsing line?
|
||||
ld hl, FLAGS
|
||||
bit FLAG_QUITTING, (hl)
|
||||
jr nz, forthRdLine
|
||||
; Not quitting line either.
|
||||
jr forthInterpret
|
||||
.endpgm:
|
||||
ld sp, (INITIAL_SP)
|
||||
xor a
|
||||
ret
|
||||
|
||||
forthMain:
|
||||
xor a
|
||||
ld (FLAGS), a
|
||||
ld (INITIAL_SP), sp
|
||||
ld hl, DOT ; last entry in hardcoded dict
|
||||
ld hl, FETCH ; last entry in hardcoded dict
|
||||
ld (CURRENT), hl
|
||||
ld hl, FORTH_RAMEND
|
||||
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 iy, MAIN
|
||||
jp executeCodeLink
|
||||
msgOk:
|
||||
.db " ok", 0
|
||||
|
@ -2,8 +2,7 @@
|
||||
pad:
|
||||
ld hl, (HERE)
|
||||
ld a, PADDING
|
||||
call addHL
|
||||
ret
|
||||
jp addHL
|
||||
|
||||
; Read word from (INPUTPOS) and return, in HL, a null-terminated word.
|
||||
; 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.
|
||||
prev:
|
||||
push hl ; --> lvl 1
|
||||
ld hl, 8 ; prev field offset
|
||||
ld hl, NAMELEN ; prev field offset
|
||||
add hl, de
|
||||
ex de, hl
|
||||
pop hl ; <-- lvl 1
|
||||
@ -66,7 +65,7 @@ prev:
|
||||
find:
|
||||
ld de, (CURRENT)
|
||||
.inner:
|
||||
ld a, 8
|
||||
ld a, NAMELEN
|
||||
call strncmp
|
||||
ret z ; found
|
||||
call prev
|
||||
@ -75,7 +74,7 @@ find:
|
||||
inc a
|
||||
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.
|
||||
; Set Z on success, unset on failure.
|
||||
compile:
|
||||
@ -90,12 +89,3 @@ compile:
|
||||
inc iy
|
||||
xor a ; set Z
|
||||
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