blob: d7320bd6279ad6e1a7586d7b4363c3d2d1ffdc0f [file] [log] [blame]
;;; Dictionary manipulation & memory management words
;; ( addr len -- entry? )
DEFWORD_RAW FIND, 'FIND'
POP CX ; String length
POP DI ; Start pointer
MOV BX, WORD [VAR_LATEST]
.LOOP:
;; BX and DI are clobbered
PUSH BX
PUSH DI
CALL WORD_MATCHES
POP DI
POP BX
TEST AX, AX
JNZ .MATCH
MOV BX, WORD [BX] ; Offset 0 = *LINK
TEST BX, BX
JNZ .LOOP ; If BX is 0 (end) fall through
.MATCH:
PUSH BX ; BX holds dict entry
NEXT
;; BX - Word
;; CX - Length
;; DI - Name
;;
;; All three parameter registers may be clobbered.
;;
;; Return: AX - 0 or 1
WORD_MATCHES:
MOV AL, BYTE [BX + WORDSZ] ; Word length
AND AL, LENGTH_MASK | HIDDEN_BIT
CMP AL, CL
JE .EQUAL
XOR AX, AX
RET
.EQUAL:
PUSH SI
LEA SI, [BX + 3] ; Point to the dict entry name
.LOOP:
CMPSB
JNE .END
LOOP .LOOP
MOV AX, 1
POP SI
RET
.END:
XOR AX, AX
POP SI
RET
;; ( *addr -- value )
DEFWORD_RAW GET, '@'
POP BX
PUSH WORD [BX]
NEXT
;; ( value *addr -- )
DEFWORD_RAW SET, '!'
POP BX
POP AX
MOV WORD [BX], AX
NEXT
DEFWORD_RAW GETCHAR, 'C@'
POP BX
XOR AX, AX
MOV AL, BYTE [BX]
PUSH AX
NEXT
;; Code field address
DEFWORD_RAW CFA, '>CFA'
POP BX
ADD BX, 2
XOR CH, CH
MOV CL, BYTE [BX] ; String length
AND CL, LENGTH_MASK
ADD BX, CX ; Code field address
ADD BX, 2 ; 1 to round up, 1 to skip length
AND BX, (~1) ; Zero the last bit
PUSH BX
NEXT
DEFWORD_THREADED DFA, '>DFA'
DW CFA, ADD2, EXIT
DEFWORD_RAW CREATE, 'CREATE'
POP CX ; Length
POP BX ; String
CALL DO_CREATE
NEXT
;; CX = Length
;; BX = Address
;;
;; AX, BX, CX, DX, DI clobbered
DO_CREATE:
PUSH SI ; Save SI
MOV SI, BX
MOV DI, [VAR_HERE] ; Top of dictionary
MOV DX, DI ; New LATEST
MOV AX, [VAR_LATEST]
STOSW ; Link pointer
MOV AX, CX ; Length
STOSB
REP MOVSB ; Copy string
TEST DI, 1
JZ .DONE
INC DI ; Pad
.DONE:
MOV [VAR_HERE], DI
MOV [VAR_LATEST], DX
POP SI
RET
DEFWORD_RAW COMMA, ','
POP AX
MOV DI, [VAR_HERE]
STOSW
MOV [VAR_HERE], DI
NEXT
;; Switch to interpret mode
DEFWORD_RAW_IMMEDIATE LEFTBRACKET, '['
MOV WORD [VAR_STATE], 0
NEXT
DEFWORD_RAW_IMMEDIATE RIGHTBRACKET, ']'
MOV WORD [VAR_STATE], 1
NEXT
DEFWORD_RAW IMMEDIATE, 'IMMEDIATE'
MOV BX, [VAR_LATEST]
XOR BYTE [BX + 2], IMMEDIATE_BIT
NEXT
;; LATEST HIDDEN
DEFWORD_RAW HIDDEN, 'HIDDEN'
POP BX
XOR BYTE [BX + 2], HIDDEN_BIT
NEXT
;; HIDE DUP
DEFWORD_THREADED HIDE, 'HIDE'
DW _WORD, FIND, HIDDEN, EXIT
DEFWORD_THREADED_IMMED TICK, "'"
DW _WORD, FIND, CFA, EXIT
DEFWORD_RAW BRANCH, 'BRANCH'
LODSW
ADD SI, AX
NEXT
DEFWORD_RAW ZEROBRANCH, '0BRANCH'
POP DX
LODSW
TEST DX, DX
JNZ .NOTZERO
ADD SI, AX
.NOTZERO:
NEXT
DEFWORD_RAW LITSTRING, 'LITSTRING'
LODSW ; Length
PUSH SI
ADD SI, AX
INC SI ; Round up
AND SI, (~1)
PUSH AX
NEXT
DEFWORD_THREADED INTERPRET, 'INTERPRET'
DW _WORD ; ( addr len )
DW _2DUP, FIND ; ( addr len entry? )
DW DUP ; ( addr len entry? entry? )
DW ZEROBRANCH, 26 ; ( addr len entry? ); jump to .NUM if
; the entry was not found.
DW CFA ; ( addr len cfa )
DW SWAP, DROP ; ( addr cfa )
DW SWAP, DROP ; ( cfa )
DW STATE, GET ; ( cfa 0|1 )
DW ZEROBRANCH, 4
DW COMMA ; Add to HERE
DW EXIT
.WORD_IMMED:
DW EXECUTE ; ( )
DW EXIT
.NUM: ; ( addr len 0 )
DW DROP ; ( addr len )
DW NUMBER ; ( number unparsed )
DW ZEROBRANCH, 4 ; ( number ); jump to .NUMOK
DW BRANCH, 18 ; jump to .FAILED
.NUMOK:
;; ( number )
DW STATE, GET ; ( number STATE )
DW ZEROBRANCH, 8 ; ( number )
DW LITERAL, LITERAL ; ( number LITERAL )
DW COMMA, COMMA ; ( )
.NUM_IMMED: ; ( number )
DW EXIT
.FAILED: ; ( number )
INCLUDE_STRING $, 'Word is neither defined nor a number'
DW TYPE, CR ; ( number )
DW DROP, EXIT ; ( )
DEFWORD_RAW EXECUTE, 'EXECUTE'
POP AX
MOV BX, AX
JMP [BX]
;; TODO: await newline
DEFWORD_THREADED QUIT, 'QUIT'
DW INTERPRET
DW BRANCH, -6
DEFWORD_THREADED COLON, ':'
DW _WORD, CREATE
DW LITERAL, DOCOL, COMMA
DW LATEST, GET, HIDDEN
DW RIGHTBRACKET
DW EXIT
DEFWORD_THREADED_IMMED SEMICOLON, ';'
DW LITERAL, EXIT, COMMA
DW LATEST, GET, HIDDEN
DW LEFTBRACKET
DW EXIT
;; ( *entry -- len *string )
DEFWORD_THREADED ENTRY_NAME, ''
DW DUP ; ( *entry *entry )
DW LITERAL, 2, PLUS ; ( *entry *len )
DW GETCHAR ; ( *entry len )
DW SWAP ; ( len *entry )
DW LITERAL, 3, PLUS ; ( len *string )
DW SWAP
DW EXIT
DEFWORD_THREADED SHOW_DICT, '.d'
DW LATEST, GET ; ( *entry )
DW DUP, ENTRY_NAME ; ( *entry len *string)
DW TYPE, CR ; ( *entry )
DW GET ; ( *prev-entry )
DW DUP ; ( *prev-entry *prev-entry )
DW ZEROBRANCH, 2
DW BRANCH, -24 ; Back to start!
DW EXIT