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         cld
  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'
  42         ;; ( n -- )
  43         ;; Allocate n bytes on the heap
  44         dq p_here, p_put_plus, p_return
  45
  46         WORD p_quote,"'"
  47         ;; ( "word" -- cfa )
  48         ;; Find the following word and push its cfa, or 0
  49         dq p_input, p_get, p_read_word, p_find
  50         BRANCH 0,p_quote_end
  51         dq p_tfa2cfa
  52 p_quote_end:
  53         dq p_return
  54
  55         WORD p_bracketed_quote,"[']",doforth,IMMEDIATE
  56         ;; Compilation ( "word" -- cfa )
  57         ;; Compile down " LIT value "
  58         dq p_literal, p_literal, p_comma,p_quote, p_comma, p_return
  59
  60         WORD p_comma,','
  61         ;; ( v -- )
  62         ;; Put cell value onto the heap and advance "HERE"
  63         dq p_here, p_literal, 8, p_get_n_increment, p_put, p_return
  64
  65         WORD p_Ccomma,'C,'
  66         ;; ( c -- )
  67         ;; Put byte value onto the heap and advance "HERE"
  68         dq p_here, p_Cput, p_literal, 1, p_here, p_put_plus, p_return
  69
  70         WORD p_does,"DOES>",fasm,IMMEDIATE
  71         ;; ( -- )
  72         ;; Change the "DOES offset" of most recent word and assign it
  73         ;; the "dodoes" execution semantics that follows.
  74         mov rax,qword [rsp]
  75         mov rbx,rax
  76         tfa2does rax            ; *rax is the DOES offset field
  77         tfa2dfa rbx
  78         mov rcx,qword [p_here_DFA]
  79         sub rcx,rbx
  80         mov qword [rax],rcx ; save offset from DFA to HERE
  81         mov qword [rax+8],dodoes
  82         next
  83
  84         WORD p_literal,'LIT',fasm
  85         ;; ( -- v )
  86         ;; Push the value of successor cell onto stack, and skip it.
  87         ;; not for interactive use!!
  88         push qword [rsi]
  89         add rsi,8
  90         next
  91
  92         WORD p_literal_string,'LIT-STRING',fasm
  93         ;; ( -- char* n )
  94         ;; Save NUL string length and pointer on heap to make
  95         ;; available at interpretation. Not for interactive use!!
  96         mov rax,qword [rsi]
  97         add rsi,8
  98         push rsi
  99         add rsi,rax
 100         dec rax
 101         push rax
 102         next
 103
 104
 105         WORD p_literal_string_compile,'S"',fasm,IMMEDIATE ;; " (fool emacs)
 106         ;; ( "..." -- )
 107         ;; Lay out a LIT-STRING and a NUL string with length
 108         pushr rsi
 109         mov rdi,qword [p_here_DFA]
 110         mov qword [rdi],p_literal_string
 111         add rdi,8
 112         mov qword [p_here_DFA],rdi
 113         DOFORTH p_double_quote
 114         pop rcx
 115         pop rsi
 116         inc rcx                 ; include the terminating NUL in count
 117         mov rdi,qword [p_here_DFA]
 118         mov qword [rdi],rcx
 119         add rdi,8
 120         cld
 121 p_literal_string_copy:
 122         dec rcx
 123         jl p_literal_string_copied
 124         movsb
 125         jmp p_literal_string_copy
 126 p_literal_string_copied:
 127         mov qword [p_here_DFA],rdi
 128         popr rsi
 129         next
 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 interpreting 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         cmp rax,qword [p_base_DFA]
 201         jge p_number_BAD
 202         jmp p_number_CONSUME
 203 p_number_alpha:
 204         cmp al,'a'
 205         jl p_number_BAD
 206         cmp al,'z'
 207         jg p_number_BAD
 208         sub al,'a'-10
 209         cmp rax,qword [p_base_DFA]
 210         jge p_number_BAD
 211         jmp p_number_CONSUME
 212 p_number_BAD:
 213         push qword 0
 214         popr rsi
 215         next
 216 p_number_DONE:
 217         cmp rbx,0
 218         jne p_numper_POSITIVE
 219         neg rdi
 220 p_numper_POSITIVE:
 221         push rdi
 222         push qword 1
 223         popr rsi
 224         next
 225
 226         WORD p_input,'INPUT',dovariable
 227         ;; The current input stream for evaluate-stream
 228         dq 0
 229
 230         WORD p_this_word,'THIS-WORD',dovariable
 231         dq 0,0                  ; ( n chars* )
 232
 233         WORD p_evaluate_stream,'EVALUATE-STREAM'
 234         ;; ( stream* -- *?* flag )
 235         ;; Execute the words from the given stream
 236         ;; returns 1 if stream ends and 0 if an unknown word is found
 237         dq p_input, p_get, p_gtR ; save old stream on R-stack
 238         dq p_input, p_put
 239 p_evaluate_stream_PROMPT:
 240         dq p_verboseQ, p_get
 241         BRANCH 0,p_evaluate_stream_LOOP
 242         dq p_depth, p_dot
 243         dq p_literal_string
 244         STRING '> '
 245         dq p_tell
 246         dq p_input, p_get
 247         dq p_clear_stream
 248 p_evaluate_stream_LOOP:
 249         dq p_input, p_get
 250         dq p_read_word
 251         dq p_dup
 252         BRANCH 0,p_evaluate_stream_END ; branch if 0 on TOP
 253         dq p_2dup, p_this_word, p_2put
 254         dq p_find
 255         dq p_dup
 256         BRANCH 0,p_evaluate_stream_NOTWORD ; branch if 0 on TOP
 257         dq p_state
 258         dq p_get
 259         BRANCH 0,p_evaluate_stream_INTERPRET
 260         dq p_dup
 261         dq p_tfa2flags_get
 262         dq p_literal, 1 ; the immediate bit
 263         dq p_and
 264         BRANCH 0,p_evaluate_stream_COMPILE
 265 p_evaluate_stream_INTERPRET:
 266         dq p_tfa2cfa
 267         dq p_execute
 268         BRANCH ,p_evaluate_stream_AFTER
 269 p_evaluate_stream_COMPILE:
 270         dq p_tfa2cfa
 271         dq p_comma
 272         BRANCH ,p_evaluate_stream_AFTER
 273 p_evaluate_stream_NOTWORD:
 274         dq p_drop
 275         dq p_number
 276         dq p_dup
 277         BRANCH 0,p_evaluate_stream_BAD ; branch if 0
 278         dq p_drop
 279         dq p_state, p_get
 280         BRANCH 0,p_evaluate_stream_AFTER ; branch if 0
 281         dq p_literal, p_literal
 282         dq p_comma, p_comma
 283 p_evaluate_stream_AFTER:
 284         dq p_input, p_get
 285         dq p_stream_nchars
 286         BRANCH 0,p_evaluate_stream_PROMPT
 287         BRANCH ,p_evaluate_stream_LOOP
 288 p_evaluate_stream_END:
 289         dq p_2drop
 290         dq p_literal, 1
 291 p_evaluate_stream_BAD:
 292         dq p_Rgt, p_input, p_put ; restore previous stream
 293         dq p_literal,0, p_state, p_put ; set interactive mode
 294         dq p_return
 295
 296         WORD p_colon,':'
 297         ;; ( -- )
 298         ;; Read next word as a new word into current wordlist, set it
 299         ;; to be a doforth word, and set compiling mode.
 300         dq p_literal, doforth
 301         dq p_input, p_get
 302         dq p_read_word
 303         dq p_create
 304         dq p_tfa2cfa
 305         dq p_put
 306         dq p_right_bracket
 307         dq p_return
 308
 309         WORD p_semicolon,';',,IMMEDIATE
 310         ;; ( -- )
 311         ;; Lay out p_return, and set interpreting mode
 312         dq p_literal, p_return, p_comma, p_left_bracket, p_return
 313
 314         WORD p_immediate,'IMMEDIATE',fasm,IMMEDIATE
 315         ;; ( -- )
 316         ;; Set "immediate flag" of the word being defined
 317         mov rax,qword [p_wordlist_DFA]
 318         mov rax,qword [rax]     ; tfa of most recent word
 319         mov qword [rax+16],1    ; set the flags field to 1
 320         next
 321
 322         WORD p_load_buffer_size,'LOAD-BUFFER-SIZE',dovariable
 323         ;; ( -- a )
 324         ;; The buffer size (in bytes) used by LOAD-FILE
 325         dq 15000
 326
 327         WORD p_open_file,'OPEN-FILE',fasm
 328         ;; ( chaz* n -- fd )
 329         ;; Open the nominated file
 330         pushr rsi
 331         add rsp,8 ; drop n ... assuming NUL-ended string
 332         push qword 0
 333         push qword 0
 334         DOFORTH sys_open
 335         popr rsi
 336         next
 337
 338         WORD p_load_file,'LOAD-FILE'
 339         ;; ( chaz* n -- )
 340         dq p_open_file
 341         dq p_dup, p_0less
 342         BRANCH 1,p_load_file_badfile
 343         dq p_load_buffer_size, p_get
 344         dq p_stream, p_dup, p_gtR
 345         dq p_evaluate_stream
 346         dq p_Rgt, p_unstream
 347         BRANCH ,p_load_file_exit
 348 p_load_file_badfile:
 349         dq p_literal_string
 350         STRING '** open file error: '
 351         dq p_tell, p_dot, p_nl, p_emit
 352         dq p_literal,1
 353 p_load_file_exit:
 354         dq p_return