1 ;; Native x86 GNU/Linux Forth System, Direct Threaded Code
3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
5 ;; This program is free software: you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation, version 3 of the License ONLY.
9 ;; This program is distributed in the hope that it will be useful,
10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;; GNU General Public License for more details.
14 ;; You should have received a copy of the GNU General Public License
15 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
29 jmp dword [urforth_next_ptr]
68 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
69 ;; word header format:
70 ;; note than name hash is ALWAYS calculated with ASCII-uppercased name
71 ;; bfa points to next bfa or to 0
72 ;; before nfa, we have such "hidden" fields
73 ;; dd dbgptr ; can be 0 if debug info is missing
74 ;; dd sfa ; points after the last word byte
75 ;; dd bfa ; next word in hashtable bucket; it is always here, even if hashtable is turned off
77 ;; dd lfa ; previous word LFA or 0 (lfa link points here)
78 ;; dd namehash ; it is always here, and always calculated, even if hashtable is turned off
80 ;; dd flags-and-name-len ; see below
81 ;; db name ; no terminating byte here
82 ;; db namelen ; yes, name length again, so CFA->NFA will work fast and stable
83 ;; machine code follows
84 ;; here we usually have CALL to word handler
85 ;; 0xE8, 4-byte displacement
86 ;; (displacement is calculated from here)
88 ;; first word cell contains combined name length (low byte), argtype and flags (other bytes)
94 ;; i.e. we have 16 bits for flags, and 256 possible argument types. why not.
107 ;; 2: cell-size numeric literal
108 ;; 3: cell-counted string
109 ;; 4: cfa of another word
112 FLAG_IMMEDIATE
= 0x0001
114 FLAG_NORETURN
= 0x0004
115 ; hidden words won't be shown by WORDS
116 ; also, hidden words won't be found unless current vocabulary is the top context one
118 ; code blocks are there because there should be no data without word header
119 ; for code block type, argtype contains real type (data/mc/etc)
120 FLAG_CODEBLOCK
= 0x0010
131 urforth_word_count
= 0
132 urforth_last_word_nfa
= 0
133 urforth_last_word_dfa
= 0
134 urforth_last_word_sfa
= 0
135 urforth_last_word_ffa
= 0 ; flags
136 urforth_last_word_tfa
= 0 ; argtypes
137 urforth_last_word_lfa
= 0
138 urforth_last_word_bfa
= 0
139 urforth_last_word_hash_fld
= 0
140 urforth_last_word_cfa
= 0
141 urforth_last_word_forth
= 0
142 urforth_last_word_name
equ ""
145 urforth_forth_hash_offset
= 0x100000
146 virtual at urforth_forth_hash_offset
147 urforth_forth_hashtable::
148 db WLIST_HASH_BYTES dup
(0)
153 ; creates word header
154 macro urword_header
name*,cfalabel
*,flags
{
158 ;; for hash calculation and hashtable update
159 local bpos,bcount,hash,high,b
162 ; check for proper word termination
163 if urforth_last_word_sfa <> 0
164 load tmp dword from urforth_last_word_sfa
167 display "*** UNTERMINATED WORD: "
168 display urforth_last_word_name
170 err "previous word wasn't properly terminated!"
174 ; align headers (because why not?)
175 if URFORTH_ALIGN_HEADERS
182 urforth_last_word_dfa = $
186 urforth_last_word_sfa = $
187 dd 0 ; word size in bytes (will be patched later)
190 urforth_last_word_bfa = $
194 dd urforth_last_word_lfa
195 urforth_last_word_lfa = $-4
197 ; name hash (elfhash)
198 urforth_last_word_hash_fld = $
199 dd 0 ; will be patched below
202 urforth_last_word_nfa = $
206 urforth_last_word_tfa = $
209 urforth_last_word_ffa = $
220 ; calculate name hash (elfhash)
225 load b byte from nstart+bpos
226 ;; uppercase it (this is how UrForth does it) -- this also distorts other chars, but who cares
230 hash = ((hash shl 4)+b) and 0xffffffff
231 high = hash and 0xf0000000
232 hash = hash xor (high shr 24)
233 hash = hash and (high xor 0xffffffff)
235 store dword hash at urforth_last_word_hash_fld
237 ;; link to FORTH hashtable
242 high = (hash shr 16) and 0xffff
243 hash = hash and 0xffff
244 hash = (hash+high) and 0xffff
246 high = (hash shr 8) and 0xff
248 hash = (hash+high) and 0xff
249 hash = hash and WLIST_HASH_MASK
255 load b dword from urforth_forth_hashtable:urforth_forth_hash_offset+hash
261 store dword urforth_last_word_bfa at urforth_forth_hashtable:urforth_forth_hash_offset+hash
262 store dword b at urforth_last_word_bfa
266 label fword_#cfalabel
267 urforth_last_word_cfa = $
269 urforth_word_count = urforth_word_count+1
270 urforth_last_word_name equ name
271 urforth_last_word_forth = 0
274 ; terminate array word with this
275 ; WARNING! no checks!
276 macro urword_end_array
{
278 ; check for proper word termination
279 if urforth_last_word_sfa
280 load tmp dword from urforth_last_word_sfa
281 store dword $ at urforth_last_word_sfa
283 err "tried to end nothing!"
285 ;store dword $ at urforth_last_word_sfa
288 ; terminate each word with this
291 ; check for proper word termination
292 if urforth_last_word_sfa
293 load tmp dword from urforth_last_word_sfa
296 display "*** DOUBLE-TERMINATED WORD: "
297 display urforth_last_word_name
299 err "previous word was already terminated!"
301 if urforth_last_word_forth
302 urforth_last_word_forth = 0
303 ;; do not add EXIT to noreturn words
304 load tmp word from urforth_last_word_ffa
305 if tmp and FLAG_NORETURN
307 ;display "*** NORETURN WORD '"
308 ;display urforth_last_word_name
311 load tmp dword from $-4
313 ;display "*** AUTOADDED EXIT TO '"
314 ;display urforth_last_word_name
320 store dword $ at urforth_last_word_sfa
323 err "tried to end nothing!"
325 ;store dword $ at urforth_last_word_sfa
328 ;; this macro will be used to tell which words
329 ;; are used by asm words
330 macro urword_uses
[wlist
] {
334 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
335 ; toggle IMMEDIATE flag on the last word
336 macro urword_toggle_flag flag
* {
338 load b word from urforth_last_word_ffa
340 store word b at urforth_last_word_ffa
343 macro urword_immediate
{ urword_toggle_flag FLAG_IMMEDIATE }
344 macro urword_smudge
{ urword_toggle_flag FLAG_SMUDGE }
345 macro urword_noreturn
{ urword_toggle_flag FLAG_NORETURN }
346 macro urword_hidden
{ urword_toggle_flag FLAG_HIDDEN }
347 macro urword_codeblock
{ urword_toggle_flag FLAG_CODEBLOCK }
348 macro urword_vocab
{ urword_toggle_flag FLAG_VOCAB }
350 macro urword_argtype atype
* {
351 store byte atype at urforth_last_word_tfa
354 macro urword_arg_branch
{ urword_argtype WARG_BRANCH }
355 macro urword_arg_lit
{ urword_argtype WARG_LIT }
356 macro urword_arg_c4strz
{ urword_argtype WARG_C4STRZ }
357 macro urword_arg_cfa
{ urword_argtype WARG_CFA }
358 macro urword_arg_cblock
{ urword_argtype WARG_CBLOCK }
361 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
371 macro urlit_cfa wname
{
376 macro urcompile wname
{
387 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
388 macro urword_code
name*,cfalabel
* {
389 urword_header name,cfalabel,0
392 macro urword_forth
name*,cfalabel
* {
393 urword_code name,cfalabel
394 call fword_par_urforth_nocall_doforth
395 urforth_last_word_forth = 1
398 macro urword_alias
name*,cfalabel
*,othername
* {
399 urword_header name,cfalabel,0
405 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
406 macro urword_const
name*,cfalabel
*,value
* {
407 urword_code name,cfalabel
408 call fword_par_urforth_nocall_doconst
409 label fconst_#cfalabel#_data
415 macro urword_var
name*,cfalabel
*,value
{
416 urword_code name,cfalabel
417 call fword_par_urforth_nocall_dovar
418 label fvar_#cfalabel#_data
428 macro urword_value
name*,cfalabel
*,value
{
429 urword_code name,cfalabel
430 call fword_par_urforth_nocall_dovalue
431 label fval_#cfalabel#_data
441 macro urword_defer
name*,cfalabel
*,wordlabel
* {
442 urword_code name,cfalabel
443 call fword_par_urforth_nocall_dodefer
444 label fdefer_#cfalabel#_data
450 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
465 macro urprint
[str] {
479 macro urprintnl
[str] {
495 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
496 macro urforth
[sequence
] {
497 common irps urfword, sequence
502 match =0 =, , status urfword \\{
506 match
=0 =.
, status urfword
\\{
510 match
=0 =+ , status urfword
\\{
514 match
=0 =- , status urfword
\\{
518 match
=0 =* , status urfword
\\{
522 match
=0 =/ , status urfword
\\{
526 ;match =0 == , status urfword \\{
530 match
=0 =@
, status urfword
\\{
534 match
=0 =! , status urfword
\\{
538 match
=0 =xxx_or
, status xxx_\#\urfword
\\{
542 match
=0 =xxx_and
, status xxx_\#\urfword
\\{
546 match
=0 =xxx_xor
, status xxx_\#\urfword
\\{
550 match
=0 =xxx_not
, status xxx_\#\urfword
\\{
554 match
=0 =xxx_c
! , status xxx_\#\urfword
\\{
558 match
=0 =xxx_c@
, status xxx_\#\urfword
\\{
562 match
=0 =xxx_recurse
, status xxx_\#\urfword
\\{
563 dd urforth_last_word_cfa
566 match
=0 =xxx_word
, status xxx_\#\urfword
\\{
567 err "`WORD` is obsolete!"
569 ;match =0 == , status urfword \\{
577 else if defined
(fword_\#\urfword
)
578 match
=0 other
, status urfword
\\{
582 else if urfword eqtype
0
583 ; compile numeric literal
587 match
=0 any
, status urfword
\\{
600 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;