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
  93                                       ;; " (fool emacs)
  94         ;; ( -- chars* n )
  95         ;; Push the value of successor cell onto stack, and skip it
  96         mov rax,qword [rsi]
  97         add rsi,8
  98         push rsi
  99         push rax
 100         add rsi,rax
 101         next
 102
 103 ;;; ========================================
 104 ;;; The text interpreter
 105
 106         WORD p_state,'STATE',dovariable
 107         ;; Interpretation state (0=interpreting, 1=compiling)
 108         dq 0
 109
 110         WORD p_left_bracket,'[',fasm,IMMEDIATE
 111         ;; ( -- )
 112         ;; Change state to interpretation state.
 113         mov qword[p_state_DFA],0
 114         next
 115
 116         WORD p_right_bracket,']',fasm
 117         ;; ( -- )
 118         ;; Change state to compilation state.
 119         mov qword[p_state_DFA],1
 120         next
 121
 122         WORD p_base,'BASE',dovariable
 123         dq 10
 124
 125         WORD p_decimal,'DECIMAL',fasm
 126         ;; ( -- )
 127         ;; Set BASE to 10
 128         mov qword [p_base_DFA],10
 129         next
 130
 131         WORD p_hex,'HEX',fasm
 132         ;; ( -- )
 133         ;; Set BASE to 16
 134         mov qword [p_base_DFA],16
 135         next
 136
 137         WORD p_number,'NUMBER',fasm
 138         ;; ( chars* n -- [ 0 ]/[ v 1 ] )
 139         pushr rsi
 140         pop rcx                 ; ( -- chars* )
 141         pop rsi                 ; ( -- )
 142         xor rdi,rdi             ; value
 143         mov rbx,1               ; sign (byte 0=0 means negative)
 144         cmp qword [p_base_DFA],10
 145         jne p_number_LOOP
 146         cmp byte [rsi],'-'
 147         jne p_number_LOOP
 148         mov rbx,0
 149         inc rsi
 150         dec rcx
 151         jle p_number_BAD
 152 p_number_LOOP:
 153         dec rcx
 154         jl p_number_DONE
 155         xor rax,rax             ; clearing
 156         lodsb
 157         cmp al,'0'
 158         jl p_number_BAD
 159         cmp al,'9'
 160         jg p_number_ALPHA
 161         sub al,'0'
 162 p_number_CONSUME:
 163         mov r8,rax
 164         mov rax,rdi
 165         mul qword [p_base_DFA]  ; uses rdx:rax
 166         add rax,r8
 167         mov rdi,rax
 168         jmp p_number_LOOP
 169 p_number_ALPHA:
 170         cmp al,'A'
 171         jl p_number_BAD
 172         cmp al,'Z'
 173         jg p_number_alpha
 174         sub al,'A'-10
 175         jmp p_number_CONSUME
 176 p_number_alpha:
 177         cmp al,'a'
 178         jl p_number_BAD
 179         cmp al,'z'
 180         jg p_number_BAD
 181         sub al,'a'-10
 182         jmp p_number_CONSUME
 183 p_number_BAD:
 184         push qword 0
 185         popr rsi
 186         next
 187 p_number_DONE:
 188         cmp rbx,0
 189         jne p_numper_POSITIVE
 190         neg rdi
 191 p_numper_POSITIVE:
 192         push rdi
 193         push qword 1
 194         popr rsi
 195         next
 196
 197         WORD p_this_word,'THIS-WORD',dovariable
 198         dq 0,0                  ; ( n chars* )
 199
 200         WORD p_evaluate_stream,'EVALUATE-STREAM'
 201         ;; ( stream* -- *?* flag )
 202         ;; Execute the words from the given stream
 203         ;; returns 1 if stream ends and 0 if an unknown word is found
 204         dq p_ltR                ; Keep the stream on the return stack.
 205 p_evaluate_stream_LOOP:
 206         dq p_Rget               ; ( -- stream*
 207         dq p_read_word          ; ( -- chars* n )
 208         dq p_dup
 209         BRANCH 0,p_evaluate_stream_END ; branch if 0 on TOP
 210         dq p_2dup               ; ( -- chars* n chars* n )
 211         dq p_this_word          ; ( -- chars* n chars* n p )
 212         dq p_2put               ; ( -- chars* n )
 213         dq p_find               ; ( -- [ chars* n 0 ]/[ tfa ] )
 214         dq p_dup                ; ( -- [ chars* n 0 0 ]/[ tfa tfa ] )
 215         BRANCH 0,p_evaluate_stream_NOTWORD ; branch if 0 on TOP
 216         dq p_execute            ; consumes tfa
 217         BRANCH ,p_evaluate_stream_LOOP
 218 p_evaluate_stream_NOTWORD:
 219         dq p_drop               ; ( -- chars* n )
 220         dq p_number             ; ( -- [ 0 ]/[ v 1 ] )
 221         dq p_dup
 222         BRANCH 0,p_evaluate_stream_BAD ; branch if 0
 223         dq p_drop
 224         BRANCH ,p_evaluate_stream_LOOP
 225 p_evaluate_stream_END:
 226         dq p_2drop
 227         dq p_literal
 228         dq 1
 229 p_evaluate_stream_BAD:
 230         dq p_Rgt                ; Discard the stream from the return stack
 231         dq p_drop
 232         dq p_exit