compile.asm

   1 ;;; Words for adding words
   2
   3         WORD p_here,'HERE',dovariable
   4         ;; The heap
   5         dq heap_start
   6
   7         WORD p_create,'CREATE',fasm
   8         ;; CREATE ( chars* n -- tfa )
   9         ;; Add the pstring as a new word in the current wordlist.
  10         pushr rsi
  11         mov rax,qword [p_wordlist_DFA] ; Current word list
  12         mov rax,[rax]           ; last word of current wordlist
  13         mov rbx,qword [p_here_DFA]
  14         mov [rbx],rax           ; TFA of new word
  15         mov qword [rbx+16],0    ; flags field
  16         ;; copy pname
  17         pop rcx                 ; n
  18         mov qword [rbx+24],rcx  ; PFA (length)
  19         pop rsi                 ; chars* (source)
  20         lea rdi,[rbx+32]        ; (dest)
  21         ;; clear DF
  22 p_create_COPY:
  23         movsb
  24         dec rcx
  25         jge p_create_COPY
  26         mov byte [rdi],0        ; extra NUL
  27         inc rdi
  28         mov qword [rdi],rbx     ; pTFA
  29         add rdi,8
  30         mov qword [rdi],rbx     ; OFF
  31         add rdi,8
  32         mov qword [rbx+8],rdi   ; pCFA
  33         add rdi,8
  34         mov qword [rdi],dovalue ;CFA
  35         add rdi,8
  36         mov qword [rax],rbx     ; Install new word
  37         mov qword [p_here_DFA],rdi ; allocate the space
  38         push rbx
  39         popr rsi
  40         next
  41
  42         WORD p_allot,'ALLOT',fasm
  43         ;; ( n -- )
  44         ;; Allocate n bytes on the heap
  45         pop rax
  46         add rax,qword [p_here_DFA]
  47         mov qword [p_here_DFA],rax
  48         next
  49
  50         WORD p_comma,',',fasm
  51         ;; ( v -- )
  52         ;; Put cell value onto the heap and advance "HERE"
  53         mov rax,qword [p_here_DFA]
  54         pop rbx
  55         mov qword [rax],rbx
  56         add rax,8
  57         mov qword [p_here_DFA],rax
  58         next
  59
  60         WORD p_Ccomma,'C,',fasm
  61         ;; ( c -- )
  62         ;; Put byte value onto the heap and advance "HERE"
  63         mov rax,qword [p_here_DFA]
  64         pop rbx
  65         mov byte [rax],bl
  66         inc rax
  67         mov qword [p_here_DFA],rax
  68         next
  69
  70         WORD p_does,'DOES>',fasm,IMMEDIATE
  71         ;; ( -- )
  72         ;; Change the "DOES offset" of latest compilation and assign
  73         ;; it the "dodoes" execution semantics,
  74         mov rax,qword [p_wordlist_DFA]
  75         mov rax,[rax]           ; last word of current wordlist
  76         tfa2does rax            ; *rax is the DOES offset field
  77         ;; offset = qword [p_here_DFA]) - (rax+2*8)
  78         mov rbx,qword [p_here_DFA]
  79         sub rbx,rax
  80         sub rbx,16
  81         mov qword [rax],rbx
  82         mov qword [rax+8],dodoes
  83         next
  84
  85         WORD p_literal,'LIT',fasm
  86         ;; ( -- v )
  87         ;; Push the value of successor cell onto stack, and skip it
  88         push qword [rsi]
  89         add rsi,8
  90         next
  91
  92         WORD p_literal_string,'S"',fasm ;; " (fool emacs)
  93         ;; Compilation: ( "..." -- )
  94         ;; Interpretation: ( -- char* n )
  95         ;; Save string on heap to make available at interpretation
  96         cmp qword [p_state_DFA],0
  97         je p_literal_string_interpret
  98         ;; compilation mode: read stream until \" onto the heap
  99         pushr rsi
 100         mov rdi,[p_here_DFA]
 101         lea rbx,[p_literal_string_CFA]
 102         mov qword [rdi],rbx
 103         add rdi,8
 104         pop rbx
 105         mov qword [rdi],rbx
 106         add rdi,8
 107         cmp rbx,0
 108         je p_literal_string_end
 109         lea rsi,[p_pad_DFA]
 110 p_literal_string_copy:
 111         lodsb
 112         stosb
 113         dec rbx
 114         jg p_literal_string_copy
 115 p_literal_string_end:
 116         mov qword [p_here_DFA],rdi
 117         popr rsi
 118         next
 119
 120 p_literal_string_interpret:
 121         mov rax,qword [rsi]
 122         add rsi,8
 123         push rsi
 124         push rax
 125         add rsi,rax
 126         next
 127
 128 ;;; ========================================
 129 ;;; The text interpreter
 130
 131         WORD p_state,'STATE',dovariable
 132         ;; Interpretation state (0=interpreting, 1=compiling)
 133         dq 0
 134
 135         WORD p_left_bracket,'[',fasm,IMMEDIATE
 136         ;; ( -- )
 137         ;; Change state to interpretation state.
 138         mov qword[p_state_DFA],0
 139         next
 140
 141         WORD p_right_bracket,']',fasm
 142         ;; ( -- )
 143         ;; Change state to compilation state.
 144         mov qword[p_state_DFA],1
 145         next
 146
 147         WORD p_base,'BASE',dovariable
 148         dq 10
 149
 150         WORD p_decimal,'DECIMAL',fasm
 151         ;; ( -- )
 152         ;; Set BASE to 10
 153         mov qword [p_base_DFA],10
 154         next
 155
 156         WORD p_hex,'HEX',fasm
 157         ;; ( -- )
 158         ;; Set BASE to 16
 159         mov qword [p_base_DFA],16
 160         next
 161
 162         WORD p_number,'NUMBER',fasm
 163         ;; ( chars* n -- [ 0 ]/[ v 1 ] )
 164         pushr rsi
 165         pop rcx                 ; ( -- chars* )
 166         pop rsi                 ; ( -- )
 167         xor rdi,rdi             ; value
 168         mov rbx,1               ; sign (byte 0=0 means negative)
 169         cmp qword [p_base_DFA],10
 170         jne p_number_LOOP
 171         cmp byte [rsi],'-'
 172         jne p_number_LOOP
 173         mov rbx,0
 174         inc rsi
 175         dec rcx
 176         jle p_number_BAD
 177 p_number_LOOP:
 178         dec rcx
 179         jl p_number_DONE
 180         xor rax,rax             ; clearing
 181         lodsb
 182         cmp al,'0'
 183         jl p_number_BAD
 184         cmp al,'9'
 185         jg p_number_ALPHA
 186         sub al,'0'
 187 p_number_CONSUME:
 188         mov r8,rax
 189         mov rax,rdi
 190         mul qword [p_base_DFA]  ; uses rdx:rax
 191         add rax,r8
 192         mov rdi,rax
 193         jmp p_number_LOOP
 194 p_number_ALPHA:
 195         cmp al,'A'
 196         jl p_number_BAD
 197         cmp al,'Z'
 198         jg p_number_alpha
 199         sub al,'A'-10
 200         jmp p_number_CONSUME
 201 p_number_alpha:
 202         cmp al,'a'
 203         jl p_number_BAD
 204         cmp al,'z'
 205         jg p_number_BAD
 206         sub al,'a'-10
 207         jmp p_number_CONSUME
 208 p_number_BAD:
 209         push qword 0
 210         popr rsi
 211         next
 212 p_number_DONE:
 213         cmp rbx,0
 214         jne p_numper_POSITIVE
 215         neg rdi
 216 p_numper_POSITIVE:
 217         push rdi
 218         push qword 1
 219         popr rsi
 220         next
 221
 222         WORD p_this_word,'THIS-WORD',dovariable
 223         dq 0,0                  ; ( n chars* )
 224
 225         WORD p_evaluate_stream,'EVALUATE-STREAM'
 226         ;; ( stream* -- *?* flag )
 227         ;; Execute the words from the given stream
 228         ;; returns 1 if stream ends and 0 if an unknown word is found
 229         dq p_ltR                ; Keep the stream on the return stack.
 230 p_evaluate_stream_PROMPT:
 231         dq p_depth, p_dot, p_literal_string
 232         STRING ' > '
 233         dq p_tell, p_Rget, p_clear_stream
 234 p_evaluate_stream_LOOP:
 235         dq p_Rget, p_read_word, p_dup
 236         BRANCH 0,p_evaluate_stream_END ; branch if 0 on TOP
 237         dq p_2dup, p_this_word, p_2put, p_find, p_dup
 238         BRANCH 0,p_evaluate_stream_NOTWORD ; branch if 0 on TOP
 239         dq p_state, p_get
 240         BRANCH 0,p_evaluate_stream_INTERPRET
 241         dq p_comma
 242         BRANCH ,p_evaluate_stream_AFTER
 243 p_evaluate_stream_INTERPRET:
 244         dq p_execute
 245         BRANCH ,p_evaluate_stream_AFTER
 246 p_evaluate_stream_NOTWORD:
 247         dq p_drop, p_number
 248         BRANCH 0,p_evaluate_stream_BAD ; branch if 0
 249 p_evaluate_stream_AFTER:
 250         dq p_Rget,p_stream_nchars
 251         BRANCH 0,p_evaluate_stream_PROMPT
 252         BRANCH ,p_evaluate_stream_LOOP
 253 p_evaluate_stream_END:
 254         dq p_2drop, p_literal, 1
 255 p_evaluate_stream_BAD:
 256         dq p_Rgt, p_drop, p_exit