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_swap, 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_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 qword [p_here_DFA]
  67         next
  68
  69         WORD p_Wcomma,'W,',fasm
  70         ;; ( c -- )
  71         ;; Put byte value onto the heap and advance "HERE"
  72         mov rax,qword [p_here_DFA]
  73         pop rbx
  74         mov word [rax],bx
  75         add qword [p_here_DFA],2
  76         next
  77
  78         WORD p_Dcomma,'D,',fasm
  79         ;; ( d -- )
  80         ;; Put byte value onto the heap and advance "HERE"
  81         mov rax,qword [p_here_DFA]
  82         pop rbx
  83         mov dword [rax],ebx
  84         add qword [p_here_DFA],4
  85         next
  86
  87         WORD p_comma,',',fasm
  88         ;; ( v -- )
  89         ;; Put byte value onto the heap and advance "HERE"
  90         mov rax,qword [p_here_DFA]
  91         pop rbx
  92         mov qword [rax],rbx
  93         add qword [p_here_DFA],8
  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,'LIT-STRING',fasm
 119         ;; ( -- char* n )
 120         ;; Save NUL string length and pointer on heap to make
 121         ;; available at interpretation. Not for interactive use!!
 122         mov rax,qword [rsi]
 123         add rsi,8
 124         push rsi
 125         add rsi,rax
 126         dec rax
 127         push rax
 128         next
 129
 130
 131         WORD p_literal_string_compile,'S"',fasm,IMMEDIATE ;; " (fool emacs)
 132         ;; ( "..." -- )
 133         ;; Lay out a LIT-STRING and a NUL string with length
 134         pushr rsi
 135         mov rdi,qword [p_here_DFA]
 136         mov qword [rdi],p_literal_string
 137         add rdi,8
 138         mov qword [p_here_DFA],rdi
 139         DOFORTH p_double_quote
 140         pop rcx
 141         pop rsi
 142         inc rcx                 ; include the terminating NUL in count
 143         mov rdi,qword [p_here_DFA]
 144         mov qword [rdi],rcx
 145         add rdi,8
 146         cld
 147 p_literal_string_copy:
 148         dec rcx
 149         jl p_literal_string_copied
 150         movsb
 151         jmp p_literal_string_copy
 152 p_literal_string_copied:
 153         mov qword [p_here_DFA],rdi
 154         popr rsi
 155         next
 156
 157         WORD p_state,'STATE',dovariable
 158         ;; Interpretation state (0=interpreting, 1=compiling)
 159         dq 0
 160
 161         WORD p_left_bracket,'[',fasm,IMMEDIATE
 162         ;; ( -- )
 163         ;; Change state to interpreting state.
 164         mov qword[p_state_DFA],0
 165         next
 166
 167         WORD p_right_bracket,']',fasm
 168         ;; ( -- )
 169         ;; Change state to compilation state.
 170         mov qword[p_state_DFA],1
 171         next
 172
 173         WORD p_base,'BASE',dovariable
 174         dq 10
 175
 176         WORD p_decimal,'DECIMAL',fasm
 177         ;; ( -- )
 178         ;; Set BASE to 10
 179         mov qword [p_base_DFA],10
 180         next
 181
 182         WORD p_hex,'HEX',fasm
 183         ;; ( -- )
 184         ;; Set BASE to 16
 185         mov qword [p_base_DFA],16
 186         next
 187
 188         WORD p_number,'NUMBER',fasm
 189         ;; ( chars* n -- [ 0 ]/[ v 1 ] )
 190         pushr rsi
 191         pop rcx                 ; ( -- chars* )
 192         pop rsi                 ; ( -- )
 193         xor rdi,rdi             ; value
 194         mov rbx,1               ; sign (byte 0=0 means negative)
 195         cmp qword [p_base_DFA],10
 196         jne p_number_LOOP
 197         cmp byte [rsi],'-'
 198         jne p_number_LOOP
 199         mov rbx,0
 200         inc rsi
 201         dec rcx
 202         jle p_number_BAD
 203 p_number_LOOP:
 204         dec rcx
 205         jl p_number_DONE
 206         xor rax,rax             ; clearing
 207         lodsb
 208         cmp al,'0'
 209         jl p_number_BAD
 210         cmp al,'9'
 211         jg p_number_ALPHA
 212         sub al,'0'
 213 p_number_CONSUME:
 214         mov r8,rax
 215         mov rax,rdi
 216         mul qword [p_base_DFA]  ; uses rdx:rax
 217         add rax,r8
 218         mov rdi,rax
 219         jmp p_number_LOOP
 220 p_number_ALPHA:
 221         cmp al,'A'
 222         jl p_number_BAD
 223         cmp al,'Z'
 224         jg p_number_alpha
 225         sub al,'A'-10
 226         cmp rax,qword [p_base_DFA]
 227         jge p_number_BAD
 228         jmp p_number_CONSUME
 229 p_number_alpha:
 230         cmp al,'a'
 231         jl p_number_BAD
 232         cmp al,'z'
 233         jg p_number_BAD
 234         sub al,'a'-10
 235         cmp rax,qword [p_base_DFA]
 236         jge p_number_BAD
 237         jmp p_number_CONSUME
 238 p_number_BAD:
 239         push qword 0
 240         popr rsi
 241         next
 242 p_number_DONE:
 243         cmp rbx,0
 244         jne p_numper_POSITIVE
 245         neg rdi
 246 p_numper_POSITIVE:
 247         push rdi
 248         push qword 1
 249         popr rsi
 250         next
 251
 252         WORD p_input,'INPUT',dovariable
 253         ;; The current input stream for evaluate-stream
 254         dq 0
 255
 256         WORD p_this_word,'THIS-WORD',dovariable
 257         dq 0,0                  ; ( n chars* )
 258
 259         WORD p_evaluate_stream,'EVALUATE-STREAM'
 260         ;; ( stream* -- *?* flag )
 261         ;; Execute the words from the given stream
 262         ;; returns 1 if stream ends and 0 if an unknown word is found
 263         dq p_input, p_get, p_gtR ; save old stream on R-stack
 264         dq p_input, p_put
 265 p_evaluate_stream_PROMPT:
 266         dq p_verboseQ, p_get
 267         BRANCH 0,p_evaluate_stream_LOOP
 268         dq p_depth, p_dot
 269         dq p_literal_string
 270         STRING '> '
 271         dq p_tell
 272         dq p_input, p_get
 273         dq p_clear_stream
 274 p_evaluate_stream_LOOP:
 275         dq p_input, p_get
 276         dq p_read_word
 277         dq p_dup
 278         BRANCH 0,p_evaluate_stream_END ; branch if 0 on TOP
 279         dq p_2dup, p_this_word, p_2put
 280         dq p_find
 281         dq p_dup
 282         BRANCH 0,p_evaluate_stream_NOTWORD ; branch if 0 on TOP
 283         dq p_state
 284         dq p_get
 285         BRANCH 0,p_evaluate_stream_INTERPRET
 286         dq p_dup
 287         dq p_tfa2flags_get
 288         dq p_literal, 1 ; the immediate bit
 289         dq p_and
 290         BRANCH 0,p_evaluate_stream_COMPILE
 291 p_evaluate_stream_INTERPRET:
 292         dq p_tfa2cfa
 293         dq p_execute
 294         BRANCH ,p_evaluate_stream_AFTER
 295 p_evaluate_stream_COMPILE:
 296         dq p_tfa2cfa
 297         dq p_comma
 298         BRANCH ,p_evaluate_stream_AFTER
 299 p_evaluate_stream_NOTWORD:
 300         dq p_drop
 301         dq p_number
 302         dq p_dup
 303         BRANCH 0,p_evaluate_stream_BAD ; branch if 0
 304         dq p_drop
 305         dq p_state, p_get
 306         BRANCH 0,p_evaluate_stream_AFTER ; branch if 0
 307         dq p_literal, p_literal
 308         dq p_comma, p_comma
 309 p_evaluate_stream_AFTER:
 310         dq p_input, p_get
 311         dq p_stream_nchars
 312         BRANCH 0,p_evaluate_stream_PROMPT
 313         BRANCH ,p_evaluate_stream_LOOP
 314 p_evaluate_stream_END:
 315         dq p_2drop
 316         dq p_literal, 1
 317 p_evaluate_stream_BAD:
 318         dq p_Rgt, p_input, p_put ; restore previous stream
 319         dq p_literal,0, p_state, p_put ; set interactive mode
 320         dq p_return
 321
 322         WORD p_colon,':'
 323         ;; ( -- )
 324         ;; Read next word as a new word into current wordlist, set it
 325         ;; to be a doforth word, and set compiling mode.
 326         dq p_literal, doforth
 327         dq p_input, p_get
 328         dq p_read_word
 329         dq p_create
 330         dq p_tfa2cfa
 331         dq p_put
 332         dq p_right_bracket
 333         dq p_return
 334
 335         WORD p_semicolon,';',,IMMEDIATE
 336         ;; ( -- )
 337         ;; Lay out p_return, and set interpreting mode
 338         dq p_literal, p_return, p_comma, p_left_bracket, p_return
 339
 340         WORD p_immediate,'IMMEDIATE',fasm,IMMEDIATE
 341         ;; ( -- )
 342         ;; Set "immediate flag" of the word being defined
 343         mov rax,qword [p_wordlist_DFA]
 344         mov rax,qword [rax]     ; tfa of most recent word
 345         mov qword [rax+16],1    ; set the flags field to 1
 346         next
 347
 348         WORD p_load_buffer_size,'LOAD-BUFFER-SIZE',dovariable
 349         ;; ( -- a )
 350         ;; The buffer size (in bytes) used by LOAD-FILE
 351         dq 15000
 352
 353         WORD p_open_file,'OPEN-FILE',fasm
 354         ;; ( chaz* n -- fd )
 355         ;; Open the nominated file
 356         pushr rsi
 357         add rsp,8 ; drop n ... assuming NUL-ended string
 358         push qword 0
 359         push qword 0
 360         DOFORTH sys_open
 361         popr rsi
 362         next
 363
 364         WORD p_load_file,'LOAD-FILE'
 365         ;; ( chaz* n -- )
 366         dq p_open_file
 367         dq p_dup, p_0less
 368         BRANCH 1,p_load_file_badfile
 369         dq p_load_buffer_size, p_get
 370         dq p_stream, p_dup, p_gtR
 371         dq p_evaluate_stream
 372         dq p_Rgt, p_unstream
 373         BRANCH ,p_load_file_exit
 374 p_load_file_badfile:
 375         dq p_literal_string
 376         STRING '** open file error: '
 377         dq p_tell, p_dot, p_nl, p_emit
 378         dq p_literal,1
 379 p_load_file_exit:
 380         dq p_return