From e7cd3182d07c63bcaee33878f4cb2fa30bc5573a Mon Sep 17 00:00:00 2001 From: Virgil Dupras Date: Sat, 7 Mar 2020 17:09:45 -0500 Subject: [PATCH] forth: add words "CREATE", "@", "!", "HERE", "QUIT" --- apps/forth/dict.asm | 111 +++++++++++++++++++++++++++++++------- apps/forth/dictionary.txt | 6 +++ apps/forth/glue.asm | 1 + apps/forth/main.asm | 35 +++++++++--- apps/forth/util.asm | 18 ++----- 5 files changed, 130 insertions(+), 41 deletions(-) diff --git a/apps/forth/dict.asm b/apps/forth/dict.asm index 2b128d6..7430bfc 100644 --- a/apps/forth/dict.asm +++ b/apps/forth/dict.asm @@ -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 diff --git a/apps/forth/dictionary.txt b/apps/forth/dictionary.txt index 2599b02..b08ac78 100644 --- a/apps/forth/dictionary.txt +++ b/apps/forth/dictionary.txt @@ -2,9 +2,15 @@ Stack notation: " -- ". 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. diff --git a/apps/forth/glue.asm b/apps/forth/glue.asm index a88cc61..b907b59 100644 --- a/apps/forth/glue.asm +++ b/apps/forth/glue.asm @@ -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 diff --git a/apps/forth/main.asm b/apps/forth/main.asm index 98783e4..769e2ec 100644 --- a/apps/forth/main.asm +++ b/apps/forth/main.asm @@ -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 diff --git a/apps/forth/util.asm b/apps/forth/util.asm index 4835bf8..b77af0d 100644 --- a/apps/forth/util.asm +++ b/apps/forth/util.asm @@ -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 -