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