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 rdx,qword [p_wordlist_DFA] ; Current word list
  12         mov rbx,qword [p_here_DFA]
  13         mov rax,qword [rdx]     ; set up tfa linking to previous word
  14         mov qword [rbx],rax     ;
  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         jg 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],0       ; OFF
  31         add rdi,8
  32         mov qword [rbx+8],rdi   ; pCFA
  33         add rdi,8
  34         mov qword [rdi],dovariable ; CFA
  35         add rdi,8
  36         mov qword [p_here_DFA],rdi ; allocate the space
  37         mov qword [rdx],rbx     ; Install new word (rdx still wordlist ptr)
  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 qword [p_here_DFA],rax
  47         next
  48
  49         WORD p_quote,"'",fasm
  50         ;; ( "word" -- cfa )
  51         ;; Find the following word and push its cfa, or 0
  52         pushr rsi
  53         DOFORTH p_stdin, p_read_word, p_find
  54         cmp qword[rsp],0
  55         jne p_quote_tfa
  56         add rsp,16
  57         mov qword[rsp],0
  58         jmp p_quote_end
  59 p_quote_tfa:
  60         mov rax,qword [rsp]
  61         tfa2cfa rax
  62         mov qword [rsp],rax
  63 p_quote_end:
  64         popr rsi
  65         next
  66
  67         WORD p_bracketed_quote,"[']",doforth,IMMEDIATE
  68         ;; Compilation ( "word" -- cfa )
  69         ;; Find the following word and push its cfa, or 0
  70         dq p_literal
  71         dq p_literal
  72         dq p_comma
  73         dq p_quote
  74         dq p_comma
  75         dq p_exit
  76
  77         WORD p_comma,',',fasm
  78         ;; ( v -- )
  79         ;; Put cell value onto the heap and advance "HERE"
  80         mov rax,qword [p_here_DFA]
  81         pop rbx
  82         mov qword [rax],rbx
  83         add rax,8
  84         mov qword [p_here_DFA],rax
  85         next
  86
  87         WORD p_Ccomma,'C,',fasm
  88         ;; ( c -- )
  89         ;; Put byte value onto the heap and advance "HERE"
  90         mov rax,qword [p_here_DFA]
  91         pop rbx
  92         mov byte [rax],bl
  93         inc rax
  94         mov qword [p_here_DFA],rax
  95         next
  96
  97         WORD p_does,"DOES>",fasm,IMMEDIATE
  98         ;; ( -- )
  99         ;; Change the "DOES offset" of most recent word and assign it
 100         ;; the "dodoes" execution semantics that follows.
 101         mov rax,qword [rsp]
 102         mov rbx,rax
 103         tfa2does rax            ; *rax is the DOES offset field
 104         tfa2dfa rbx
 105         mov rcx,qword [p_here_DFA]
 106         sub rcx,rbx
 107         mov qword [rax],rcx ; save offset from DFA to HERE
 108         mov qword [rax+8],dodoes
 109         next
 110
 111         WORD p_literal,'LIT',fasm
 112         ;; ( -- v )
 113         ;; Push the value of successor cell onto stack, and skip it.
 114         ;; not for interactive use!!
 115         push qword [rsi]
 116         add rsi,8
 117         next
 118
 119         WORD p_literal_string,'S"',fasm ;; " (fool emacs)
 120         ;; ( -- char* n )
 121         ;; Save string on heap to make available at interpretation
 122         ;; not for interactive use!!
 123         mov rax,qword [rsi]
 124         add rsi,8
 125         push rsi
 126         push rax
 127         add rsi,rax
 128         next
 129
 130         WORD p_state,'STATE',dovariable
 131         ;; Interpretation state (0=interpreting, 1=compiling)
 132         dq 0
 133
 134         WORD p_left_bracket,'[',fasm,IMMEDIATE
 135         ;; ( -- )
 136         ;; Change state to interpreting state.
 137         mov qword[p_state_DFA],0
 138         next
 139
 140         WORD p_right_bracket,']',fasm
 141         ;; ( -- )
 142         ;; Change state to compilation state.
 143         mov qword[p_state_DFA],1
 144         next
 145
 146         WORD p_base,'BASE',dovariable
 147         dq 10
 148
 149         WORD p_decimal,'DECIMAL',fasm
 150         ;; ( -- )
 151         ;; Set BASE to 10
 152         mov qword [p_base_DFA],10
 153         next
 154
 155         WORD p_hex,'HEX',fasm
 156         ;; ( -- )
 157         ;; Set BASE to 16
 158         mov qword [p_base_DFA],16
 159         next
 160
 161         WORD p_number,'NUMBER',fasm
 162         ;; ( chars* n -- [ 0 ]/[ v 1 ] )
 163         pushr rsi
 164         pop rcx                 ; ( -- chars* )
 165         pop rsi                 ; ( -- )
 166         xor rdi,rdi             ; value
 167         mov rbx,1               ; sign (byte 0=0 means negative)
 168         cmp qword [p_base_DFA],10
 169         jne p_number_LOOP
 170         cmp byte [rsi],'-'
 171         jne p_number_LOOP
 172         mov rbx,0
 173         inc rsi
 174         dec rcx
 175         jle p_number_BAD
 176 p_number_LOOP:
 177         dec rcx
 178         jl p_number_DONE
 179         xor rax,rax             ; clearing
 180         lodsb
 181         cmp al,'0'
 182         jl p_number_BAD
 183         cmp al,'9'
 184         jg p_number_ALPHA
 185         sub al,'0'
 186 p_number_CONSUME:
 187         mov r8,rax
 188         mov rax,rdi
 189         mul qword [p_base_DFA]  ; uses rdx:rax
 190         add rax,r8
 191         mov rdi,rax
 192         jmp p_number_LOOP
 193 p_number_ALPHA:
 194         cmp al,'A'
 195         jl p_number_BAD
 196         cmp al,'Z'
 197         jg p_number_alpha
 198         sub al,'A'-10
 199         jmp p_number_CONSUME
 200 p_number_alpha:
 201         cmp al,'a'
 202         jl p_number_BAD
 203         cmp al,'z'
 204         jg p_number_BAD
 205         sub al,'a'-10
 206         jmp p_number_CONSUME
 207 p_number_BAD:
 208         push qword 0
 209         popr rsi
 210         next
 211 p_number_DONE:
 212         cmp rbx,0
 213         jne p_numper_POSITIVE
 214         neg rdi
 215 p_numper_POSITIVE:
 216         push rdi
 217         push qword 1
 218         popr rsi
 219         next
 220
 221         WORD p_this_word,'THIS-WORD',dovariable
 222         dq 0,0                  ; ( n chars* )
 223
 224         WORD p_evaluate_stream,'EVALUATE-STREAM'
 225         ;; ( stream* -- *?* flag )
 226         ;; Execute the words from the given stream
 227         ;; returns 1 if stream ends and 0 if an unknown word is found
 228         dq p_gtR                ; Keep the stream on the return stack.
 229 p_evaluate_stream_PROMPT:
 230         dq p_depth
 231         dq p_dot
 232         dq p_literal_string
 233         STRING '> '
 234         dq p_tell
 235         dq p_Rget
 236         dq p_clear_stream
 237 p_evaluate_stream_LOOP:
 238         dq p_Rget
 239         dq p_read_word
 240         dq p_dup
 241         BRANCH 0,p_evaluate_stream_END ; branch if 0 on TOP
 242         dq p_2dup
 243         dq p_this_word
 244         dq p_2put
 245         dq p_find
 246         dq p_dup
 247         BRANCH 0,p_evaluate_stream_NOTWORD ; branch if 0 on TOP
 248         dq p_state
 249         dq p_get
 250         BRANCH 0,p_evaluate_stream_INTERPRET
 251         dq p_dup
 252         dq p_cfa2flags_get
 253         dq p_literal, 1
 254         dq p_and
 255         dq p_not
 256         BRANCH 0,p_evaluate_stream_INTERPRET
 257         dq p_comma
 258         BRANCH ,p_evaluate_stream_AFTER
 259 p_evaluate_stream_INTERPRET:
 260         dq p_execute
 261         BRANCH ,p_evaluate_stream_AFTER
 262 p_evaluate_stream_NOTWORD:
 263         dq p_drop
 264         dq p_number
 265         BRANCH 0,p_evaluate_stream_BAD ; branch if 0
 266         dq p_state
 267         dq p_get
 268         BRANCH 0,p_evaluate_stream_AFTER ; branch if 0
 269         dq p_literal, p_literal
 270         dq p_comma, p_comma
 271 p_evaluate_stream_AFTER:
 272         dq p_Rget
 273         dq p_stream_nchars
 274         BRANCH 0,p_evaluate_stream_PROMPT
 275         BRANCH ,p_evaluate_stream_LOOP
 276 p_evaluate_stream_END:
 277         dq p_2drop
 278         dq p_literal, 1
 279 p_evaluate_stream_BAD:
 280         dq p_Rgt
 281         dq p_drop
 282         dq p_exit
 283
 284         WORD p_colon,':'
 285         ;; ( -- )
 286         ;; Read next word as a new word into current wordlist, set it
 287         ;; to be a doforth word, and set compiling mode.
 288         dq p_literal, doforth
 289         dq p_stdin
 290         dq p_read_word
 291         dq p_create
 292         dq p_tfa2cfa
 293         dq p_put
 294         dq p_right_bracket
 295         dq p_exit
 296
 297         WORD p_semicolon,';'
 298         ;; ( -- )
 299         ;; Lay out p_exit, and set interpreting mode
 300         dq p_left_bracket
 301         dq p_literal, p_exit
 302         dq p_comma
 303
 304         WORD p_immediate,'IMMEDIATE',fasm,IMMEDIATE
 305         ;; ( -- )
 306         ;; Set "immediate flag" of the word being defined
 307         mov rax,qword [p_wordlist_DFA]
 308         mov rax,qword [rax]     ; tfa of most recent word
 309         mov qword [rax+16],1    ; set the flags field to 1
 310         next