From 02ef6e814ef0e6c61348c70bd310ba1f0df2506b Mon Sep 17 00:00:00 2001 From: Ralph Ronnquist Date: Wed, 19 May 2021 10:31:40 +1000 Subject: [PATCH] add EVALUATE-STREAM and stuff --- compile.asm | 128 +++++++++++++++++++++++++++++++++++++++++--------- logic.asm | 112 +++++++++++++++++++++++++++++++++++++++++++ machine.asm | 7 +++ rrqforth.asm | 29 ++++++++++++ wordlists.asm | 18 +++---- 5 files changed, 264 insertions(+), 30 deletions(-) create mode 100644 logic.asm diff --git a/compile.asm b/compile.asm index 1e76aee..be4f652 100644 --- a/compile.asm +++ b/compile.asm @@ -4,14 +4,10 @@ ;; The heap dq heap_start - ;; CREATE ( "[ \t\0]*([^ \t\0]+)" -- tfa ) - ;; Skip leading whitespace and scan following non-whitespace - ;; as being a "word" to add into the current vocabulary. Add - ;; that word header, which consisits of: WORD p_create,'CREATE',fasm + ;; CREATE ( chars* n -- tfa ) + ;; Add the pstring as a new word in the current wordlist. pushr rsi - push p_stdin_DFA ; ( -- stream ) - DOFORTH p_read_word ; ( -- chars* n ) read next word mov rax,qword [p_wordlist_DFA] ; Current word list mov rax,[rax] ; last word of current wordlist mov rbx,qword [p_here_DFA] @@ -51,26 +47,116 @@ p_create_COPY: mov qword [p_here_DFA],rax next - ;; DOES> ( -- ) - ;; Change DOES offset of latest compilation word to current - ;; compilation address. - ;; LATEST @ TFA>DOES HERE @ OVER - SWAP ! - WORD p_does,'DOES>',fasm + WORD p_comma,',',fasm + ;; ( v -- ) + ;; Put cell value onto the heap and advance "HERE" + mov rax,qword [p_here_DFA] + pop rbx + mov qword [rax],rbx + add rax,8 + mov qword [p_here_DFA],rax + next + + WORD p_Ccomma,'C,',fasm + ;; ( c -- ) + ;; Put byte value onto the heap and advance "HERE" + mov rax,qword [p_here_DFA] + pop rbx + mov byte [rax],bl + inc rax + mov qword [p_here_DFA],rax + next + + WORD p_does,'DOES>',fasm,IMMEDIATE + ;; ( -- ) + ;; Change the "DOES offset" of latest compilation and assign + ;; it the "dodoes" execution semantics, mov rax,qword [p_wordlist_DFA] mov rax,[rax] ; last word of current wordlist - add rax,8 - ;add rax,byte [rax] - add rax,1 - mov rbx,[p_here_DFA] + tfa2does rax ; *rax is the DOES offset field + ;; offset = qword [p_here_DFA]) - (rax+2*8) + mov rbx,qword [p_here_DFA] + sub rbx,rax + sub rbx,16 mov qword [rax],rbx mov qword [rax+8],dodoes next + + WORD p_literal,'LIT',fasm + ;; ( -- v ) + ;; Push the value of successor cell onto stack, and skip it + push qword [rsi] + add rsi,8 + next + + WORD p_literal_string,'S"',fasm + ;; " (fool emacs) + ;; ( -- chars* n ) + ;; Push the value of successor cell onto stack, and skip it + mov rax,qword [rsi] + add rsi,8 + push rsi + push rax + add rsi,rax + next + +;;; ======================================== +;;; The text interpreter + + WORD p_state,'STATE',dovariable + ;; Interpretation state (0=interpreting, 1=compiling) + dq 0 + + WORD p_left_bracket,'[',fasm,IMMEDIATE + ;; ( -- ) + ;; Change state to interpretation state. + mov qword[p_state_DFA],0 + next + + WORD p_right_bracket,']',fasm + ;; ( -- ) + ;; Change state to compilation state. + mov qword[p_state_DFA],1 + next + + WORD p_number,'NUMBER' + ;; ( chars* n -- [ 0 ]/[ v 1 ] ) + + WORD p_this_word,'THIS-WORD',dovariable + dq 0,0 ; ( n chars* ) + + WORD p_evaluate_stream,'EVALUATE-STREAM' + ;; ( stream -- *?* flag ) + ;; Execute the words from the given stream + ;; returns 1 if stream ends and 0 if an unknown word is found + +p_evaluate_stream_LOOP: + dq p_read_word ; ( -- chars* n ) + dq p_zero_branch + dq p_evaluate_stream_END - $ - 8 - WORD p_literal,'LIT',IMMEDIATE - dq p_create - dq p_does - dq p_get + dq p_2dup + dq p_this_word + dq p_2put + dq p_find + dq p_dup + dq p_zero_branch + dq p_evaluate_stream_NOTWORD - $ - 8 + dq p_execute + dq p_branch + dq p_evaluate_stream_LOOP - $ - 8 + +p_evaluate_stream_NOTWORD: + dq p_this_word + dq p_2get + dq p_number + dq p_not + dq p_zero_branch + dq p_evaluate_stream_LOOP - $ - 8 + + dq 0 dq p_exit - - WORD p_execute,'EXECUTE' +p_evaluate_stream_END: + dq 1 + dq p_exit diff --git a/logic.asm b/logic.asm new file mode 100644 index 0000000..a3b183d --- /dev/null +++ b/logic.asm @@ -0,0 +1,112 @@ +;;; Logic words + + WORD p_and, 'AND',fasm + ;; ( x1 x2 -- x3 ) + ;; x3 is the bit-by-bit logical "and" of x1 with x2. + pop rax + and qword [rsp], rax + next + + WORD p_or, 'OR',fasm + ;; ( x1 x2 -- x3 ) + ;; x3 is the bit-by-bit inclusive-or of x1 with x2. + pop rax + or qword [rsp],rax + next + + WORD p_xor, 'XOR',fasm + ;; ( x1 x2 -- x3 ) + ;; x3 is the bit-by-bit exclusive-or of x1 with x2. + pop rax + xor qword [rsp],rax + next + + WORD p_not, 'NOT',fasm + ;; ( x -- v ) + ;; v = 0 if x is non-zero and -1 otherwise + not qword [rsp] + next + + WORD p_false, 'FALSE',fasm + ;; ( -- 0 ) + ;; Push a false flag, 0. + push qword 0 + next + + WORD p_true, 'TRUE',fasm + ;; ( -- true ) + ;; Return a true flag, -1. (non-zero) + push qword -1 + next + + WORD p_within, 'WITHIN',fasm + ;; ( n1 n2 n3 -- flag ) + ;; Push true if n2 <= n1 and n1 < n3 and false otherwise. + xor rcx,rcx + pop rax + pop rbx + cmp qword [rsp],rbx + jl p_within_not + cmp qword [rsp],rax + jge p_within_not + not rcx +p_within_not: + next + + WORD p_0less, '0<',fasm + ;; ( n -- flag ) + ;; flag is true (non-zero) if and only if n is less than zero. + xor rax,rax + cmp qword [rsp],0 + jge p_0less.lt + not rax +p_0less.lt: + next + + WORD p_0equal, '0=',fasm + ;; ( x -- flag ) + ;; flag is true if x is equal to zero otherwise false. + xor rax,rax + cmp qword [rsp],0 + jne p_0equal.ne + not rax +p_0equal.ne: + next + + WORD p_lessthan, '<',fasm + ;; ( n1 n2 -- flag ) + ;; flag is true if and only if n1 is less than n2. + xor rax,rax + pop rbx + cmp qword [rsp], rbx + jge p_lessthan.ge + not rax +p_lessthan.ge: + mov qword [rsp], rax + next + + WORD p_equal, '=',fasm + ;; ( x1 x2 -- flag ) + ;; flag is true if and only if x1 is bit-for-bit the same as + ;; x2. + xor rax,rax + pop rbx + cmp qword [rsp], rbx + jne p_equal.ne + not rax +p_equal.ne: + mov qword [rsp], rax + next + + WORD p_greaterthan, '>',fasm + ;; ( n1 n2 -- flag ) + ;; flag is true if and only if n1 is greater than n2. + xor rax,rax + pop rbx + cmp qword [rsp], rbx + jle p_greaterthan.le + not rax +p_greaterthan.le: + mov qword [rsp], rax + next + diff --git a/machine.asm b/machine.asm index 8da016a..357b807 100644 --- a/machine.asm +++ b/machine.asm @@ -165,10 +165,17 @@ label#_DFA: macro tfa2cfa reg { mov reg,qword [reg+8] } +macro tfa2does reg { + tfa2cfa reg + sub reg,8 +} macro tfa2dfa reg { tfa2cfa reg add reg,8 } +macro tfa2flags reg { + add reg,16 +} macro tfa2pfa reg { add reg,24 } diff --git a/rrqforth.asm b/rrqforth.asm index 16dc7d6..3607ea8 100644 --- a/rrqforth.asm +++ b/rrqforth.asm @@ -62,6 +62,13 @@ DS_TOP: ; The initial rsp ;; exit to the calling definition via "jmp exit". jmp qword rsi + WORD p_execute,'EXECUTE',fasm + ;; ( tfa -- ) + ;; Execute the word + pop rax + tfa2cfa rax + jmp qword [rax] ; goto code of that FORTH word (64 bit jump) + WORD p_exit, 'EXIT',fasm ;; ( -- ) ( R: addr -- ) ;; Returns execution to the calling definition as per the @@ -78,6 +85,27 @@ terminate_special: mov eax,60 syscall + WORD p_branch,'BRANCH',fasm + ;; ( -- ) + ;; Using subsequent inline cell as branch offset, branch + ;; accordingly + add rsi,qword [rsi] + add rsi,8 + next + + WORD p_zero_branch,'0BRANCH',fasm + ;; ( v -- ) + ;; Using subsequent inline cell as branch offset, branch + ;; accordingly if the stacked value is zero, otherwise just + ;; skip over the branch offset + pop rax + cmp rax,0 + jne p_zero_branch_SKIP + add rsi,qword [rsi] +p_zero_branch_SKIP: + add rsi,8 + next + ;;; Execution semantics for FORTH defition word ;;; At entry, rsi points into the calling definition, at the cell ;;; following the cell indicating this word, rax points to the CFA of @@ -118,6 +146,7 @@ dostring: include 'memory.asm' include 'stack.asm' include 'math.asm' +include 'logic.asm' include 'stdio.asm' include 'compile.asm' diff --git a/wordlists.asm b/wordlists.asm index 4862dd1..c67e6c9 100644 --- a/wordlists.asm +++ b/wordlists.asm @@ -99,7 +99,7 @@ p_strncmp_end: next WORD p_find,'FIND' - ;; ( chars length -- [ chars 0 | cfa 1 ) + ;; ( chars length -- [ 0 ]|[ tfa ] ) ;; Search the current wordlists for the given pname pushr rsi mov rcx,[p_wordlist_DFA] @@ -108,10 +108,10 @@ p_strncmp_end: mov rax,[rsp+8] p_find_loop: cmp rcx,0 - je p_find_done + je p_find_notfound cmp rbx,qword [rcx+16] ; compare lengths jne p_find_nextword - push rcx + push rcx ; save tfa for later ;; check word push rax tfa2pname rcx @@ -119,18 +119,18 @@ p_find_loop: push rbx DOFORTH p_strncmp pop rax ; return value - pop rcx + pop rcx ; restore tfa cmp rax,0 - je p_find_done + je p_find_found mov rbx,[rsp] mov rax,[rsp+8] p_find_nextword: mov rcx,[rcx] jmp p_find_loop +p_find_notfound: + xor rcx,rcx p_find_found: - mov qword [rsp+8],rcx ; replace chars with tfa - mov rcx,1 -p_find_done: - push rcx + add rsp,8 + mov qword [rsp],rcx ; replace with tfa / 0 popr rsi next -- 2.39.2