level0/urforth0_mac.asm

   1 ;; Native x86 GNU/Linux Forth System, Direct Threaded Code
   2 ;;
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;;
   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.
   8 ;;
   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.
  13 ;;
  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/>.
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 macro ur_bp {
  19   if URFORTH_DEBUG
  20     urcall urforth_bp
  21   end if
  22 }
  23
  24
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 macro urnext {
  27   lodsd
  28   if URFORTH_DEBUG
  29   jmp  dword [urforth_next_ptr]
  30   else
  31   jmp   eax
  32   end if
  33 }
  34
  35 macro rdrop {
  36   add   ERP,4
  37 }
  38
  39 macro rpush reg* {
  40   sub   ERP,4
  41   mov   dword [ERP],reg
  42 }
  43
  44 macro rpop reg* {
  45   mov   reg,dword [ERP]
  46   add   ERP,4
  47 }
  48
  49 macro rpeek reg* {
  50   mov   reg,dword [ERP]
  51 }
  52
  53
  54 ; *mem destroys EAX
  55 macro rpushmem reg {
  56   sub   ERP,4
  57   mov   eax,reg
  58   mov   [ERP],eax
  59 }
  60
  61 macro rpopmem reg {
  62   mov   eax,[ERP]
  63   mov   reg,eax
  64   add   ERP,4
  65 }
  66
  67
  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
  76 ;; lfa:
  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
  79 ;; nfa:
  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)
  87 ;;
  88 ;; first word cell contains combined name length (low byte), argtype and flags (other bytes)
  89 ;; layout:
  90 ;;   db namelen
  91 ;;   db argtype
  92 ;;   dw flags
  93 ;;
  94 ;; i.e. we have 16 bits for flags, and 256 possible argument types. why not.
  95 ;;
  96 ;; flags:
  97 ;;  bit 0: immediate
  98 ;;  bit 1: smudge
  99 ;;  bit 2: noreturn
 100 ;;  bit 3: hidden
 101 ;;  bit 4: codeblock
 102 ;;  bit 5: vocabulary
 103 ;;
 104 ;;  argument type:
 105 ;;    0: none
 106 ;;    1: branch address
 107 ;;    2: cell-size numeric literal
 108 ;;    3: cell-counted string
 109 ;;    4: cfa of another word
 110 ;;    5: cblock
 111
 112 FLAG_IMMEDIATE = 0x0001
 113 FLAG_SMUDGE    = 0x0002
 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
 117 FLAG_HIDDEN    = 0x0008
 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
 121 FLAG_VOCAB = 0x0020
 122
 123 WARG_NONE = 0
 124 WARG_BRANCH = 1
 125 WARG_LIT = 2
 126 WARG_C4STRZ = 3
 127 WARG_CFA = 4
 128 WARG_CBLOCK = 5
 129
 130
 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 ""
 143
 144 ;; hashatble buckets
 145 urforth_forth_hash_offset = 0x100000
 146 virtual at urforth_forth_hash_offset
 147 urforth_forth_hashtable::
 148   db  WLIST_HASH_BYTES dup(0)
 149   ;db  4096 dup(0)
 150 end virtual
 151
 152
 153 ; creates word header
 154 macro urword_header name*,cfalabel*,flags {
 155   local nlen
 156   local nstart
 157   local tmp
 158   ;; for hash calculation and hashtable update
 159   local bpos,bcount,hash,high,b
 160   local xbfa
 161
 162   ; check for proper word termination
 163   if urforth_last_word_sfa <> 0
 164     load tmp dword from urforth_last_word_sfa
 165     if tmp = 0
 166       display "***",10
 167       display "*** UNTERMINATED WORD: "
 168       display urforth_last_word_name
 169       display 10,"***",10
 170       err "previous word wasn't properly terminated!"
 171     end if
 172   end if
 173
 174   ; align headers (because why not?)
 175   if URFORTH_ALIGN_HEADERS
 176     while ($ and 3) <> 0
 177       db 0
 178     end while
 179   end if
 180
 181   ; dfa
 182   urforth_last_word_dfa = $
 183   dd  0  ; debuginfo ptr
 184
 185   ; sfa
 186   urforth_last_word_sfa = $
 187   dd  0  ; word size in bytes (will be patched later)
 188
 189   ; bfa
 190   urforth_last_word_bfa = $
 191   dd 0
 192
 193   ; lfa
 194   dd urforth_last_word_lfa
 195   urforth_last_word_lfa = $-4
 196
 197   ; name hash (elfhash)
 198   urforth_last_word_hash_fld = $
 199   dd 0  ; will be patched below
 200
 201   ; nfa
 202   urforth_last_word_nfa = $
 203   ; name length
 204   db  nlen
 205   ; argtype
 206   urforth_last_word_tfa = $
 207   db  0
 208   ; flags
 209   urforth_last_word_ffa = $
 210   if flags eq
 211     dw  0
 212   else
 213     dw  flags
 214   end if
 215   nstart = $
 216   db  name
 217   nlen = $-nstart
 218   db  nlen
 219
 220   ; calculate name hash (elfhash)
 221   hash = 0
 222   bpos = 0
 223   bcount = nlen
 224   while bcount <> 0
 225     load b byte from nstart+bpos
 226     ;; uppercase it (this is how UrForth does it) -- this also distorts other chars, but who cares
 227     b = b and 0xdf
 228     bpos = bpos+1
 229     bcount = bcount-1
 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)
 234   end while
 235   store dword hash at urforth_last_word_hash_fld
 236
 237   ;; link to FORTH hashtable
 238   if WLIST_HASH_BITS
 239       ;display_hex hash
 240       ;display " -> "
 241     ; fold hash: 32->16
 242     high = (hash shr 16) and 0xffff
 243     hash = hash and 0xffff
 244     hash = (hash+high) and 0xffff
 245     ; fold hash: 16->8
 246     high = (hash shr 8) and 0xff
 247     hash = hash and 0xff
 248     hash = (hash+high) and 0xff
 249     hash = hash and WLIST_HASH_MASK
 250       ;display_hex hash
 251       ;display "  ",name
 252       ;display 10
 253     ; update bfa
 254     hash = hash*4
 255     load b dword from urforth_forth_hashtable:urforth_forth_hash_offset+hash
 256       ;display "  ofs="
 257       ;display_hex hash
 258       ;display "; value="
 259       ;display_hex b
 260       ;display 10
 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
 263   end if
 264
 265   ; cfa
 266   label fword_#cfalabel
 267   urforth_last_word_cfa = $
 268
 269   urforth_word_count = urforth_word_count+1
 270   urforth_last_word_name equ name
 271   urforth_last_word_forth = 0
 272 }
 273
 274 ; terminate array word with this
 275 ; WARNING! no checks!
 276 macro urword_end_array {
 277   local tmp
 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
 282   else
 283     err "tried to end nothing!"
 284   end if
 285   ;store dword $ at urforth_last_word_sfa
 286 }
 287
 288 ; terminate each word with this
 289 macro urword_end {
 290   local tmp
 291   ; check for proper word termination
 292   if urforth_last_word_sfa
 293     load tmp dword from urforth_last_word_sfa
 294     if tmp <> 0
 295       display "***",10
 296       display "*** DOUBLE-TERMINATED WORD: "
 297       display urforth_last_word_name
 298       display 10,"***",10
 299       err "previous word was already terminated!"
 300     end if
 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
 306         ;; do nothing
 307         ;display "*** NORETURN WORD '"
 308         ;display urforth_last_word_name
 309         ;display "'",10
 310       else
 311         load tmp dword from $-4
 312         if tmp <> fword_exit
 313           ;display "*** AUTOADDED EXIT TO '"
 314           ;display urforth_last_word_name
 315           ;display "'",10
 316           dd fword_exit
 317         end if
 318       end if
 319     end if
 320     store dword $ at urforth_last_word_sfa
 321     urcond_check_balance
 322   else
 323     err "tried to end nothing!"
 324   end if
 325   ;store dword $ at urforth_last_word_sfa
 326 }
 327
 328 ;; this macro will be used to tell which words
 329 ;; are used by asm words
 330 macro urword_uses [wlist] {
 331 }
 332
 333
 334 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 335 ; toggle IMMEDIATE flag on the last word
 336 macro urword_toggle_flag flag* {
 337   local b
 338   load b word from urforth_last_word_ffa
 339   b = b xor flag
 340   store word b at urforth_last_word_ffa
 341 }
 342
 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 }
 349
 350 macro urword_argtype atype* {
 351   store byte atype at urforth_last_word_tfa
 352 }
 353
 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 }
 359
 360
 361 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 362 macro urcall wname {
 363   dd  fword_#wname
 364 }
 365
 366 macro urlit num {
 367   dd  fword_lit
 368   dd  num
 369 }
 370
 371 macro urlit_cfa wname {
 372   dd  fword_cfalit
 373   dd  fword_#wname
 374 }
 375
 376 macro urcompile wname {
 377   dd  fword_par_compile
 378   dd  fword_#wname
 379 }
 380
 381 macro urto wname {
 382   dd  fword_littopush
 383   dd  fword_#wname
 384 }
 385
 386
 387 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 388 macro urword_code name*,cfalabel* {
 389   urword_header name,cfalabel,0
 390 }
 391
 392 macro urword_forth name*,cfalabel* {
 393   urword_code name,cfalabel
 394   call   fword_par_urforth_nocall_doforth
 395   urforth_last_word_forth = 1
 396 }
 397
 398 macro urword_alias name*,cfalabel*,othername* {
 399   urword_header name,cfalabel,0
 400   jmp   fword_#othername
 401   urword_end
 402 }
 403
 404
 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
 410   dd  value
 411   urword_end
 412 }
 413
 414
 415 macro urword_var name*,cfalabel*,value {
 416   urword_code name,cfalabel
 417   call  fword_par_urforth_nocall_dovar
 418   label fvar_#cfalabel#_data
 419   if value eq
 420     ; do nothing
 421   else
 422     dd value
 423     urword_end
 424   end if
 425 }
 426
 427
 428 macro urword_value name*,cfalabel*,value {
 429   urword_code name,cfalabel
 430   call  fword_par_urforth_nocall_dovalue
 431   label fval_#cfalabel#_data
 432   if value eq
 433     ; do nothing
 434   else
 435     dd value
 436     urword_end
 437   end if
 438 }
 439
 440
 441 macro urword_defer name*,cfalabel*,wordlabel* {
 442   urword_code name,cfalabel
 443   call  fword_par_urforth_nocall_dodefer
 444   label fdefer_#cfalabel#_data
 445   dd  fword_#wordlabel
 446   urword_end
 447 }
 448
 449
 450 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 451 macro urcstr [str] {
 452 common
 453   local nlen
 454   local nstart
 455   dd  nlen
 456   nstart = $
 457 forward
 458   db  str
 459 common
 460   nlen = $-nstart
 461   db  0
 462 }
 463
 464
 465 macro urprint [str] {
 466   urcall  pardottype
 467 common
 468   local nlen
 469   local nstart
 470   dd    nlen
 471   nstart = $
 472 forward
 473   db    str
 474 common
 475   nlen = $-nstart
 476   db  0
 477 }
 478
 479 macro urprintnl [str] {
 480   urcall  pardottype
 481 common
 482   local nlen
 483   local nstart
 484   dd    nlen
 485   nstart = $
 486 forward
 487   db    str
 488   db    10
 489 common
 490   nlen = $-nstart
 491   db  0
 492 }
 493
 494
 495 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 496 macro urforth [sequence] {
 497   common irps urfword, sequence
 498   \{
 499     local status
 500     define status 0
 501     local nstart,nlen
 502     match =0 =, , status urfword \\{
 503       dd  fword_comma
 504       define status 1
 505     \\}
 506     match =0 =. , status urfword \\{
 507       dd  fword_dot
 508       define status 1
 509     \\}
 510     match =0 =+ , status urfword \\{
 511       dd  fword_add
 512       define status 1
 513     \\}
 514     match =0 =- , status urfword \\{
 515       dd  fword_sub
 516       define status 1
 517     \\}
 518     match =0 =* , status urfword \\{
 519       dd  fword_mul
 520       define status 1
 521     \\}
 522     match =0 =/ , status urfword \\{
 523       dd  fword_div
 524       define status 1
 525     \\}
 526     ;match =0 == , status urfword \\{
 527     ;  dd  fword_equal
 528     ;  define status 1
 529     ;\\}
 530     match =0 =@ , status urfword \\{
 531       dd  fword_peek
 532       define status 1
 533     \\}
 534     match =0 =! , status urfword \\{
 535       dd  fword_poke
 536       define status 1
 537     \\}
 538     match =0 =xxx_or , status xxx_\#\urfword \\{
 539       dd  fword_or
 540       define status 1
 541     \\}
 542     match =0 =xxx_and , status xxx_\#\urfword \\{
 543       dd  fword_and
 544       define status 1
 545     \\}
 546     match =0 =xxx_xor , status xxx_\#\urfword \\{
 547       dd  fword_xor
 548       define status 1
 549     \\}
 550     match =0 =xxx_not , status xxx_\#\urfword \\{
 551       dd  fword_not
 552       define status 1
 553     \\}
 554     match =0 =xxx_c! , status xxx_\#\urfword \\{
 555       dd  fword_cpoke
 556       define status 1
 557     \\}
 558     match =0 =xxx_c@ , status xxx_\#\urfword \\{
 559       dd  fword_cpeek
 560       define status 1
 561     \\}
 562     match =0 =xxx_recurse , status xxx_\#\urfword \\{
 563       dd  urforth_last_word_cfa
 564       define status 1
 565     \\}
 566     match =0 =xxx_word , status xxx_\#\urfword \\{
 567       err "`WORD` is obsolete!"
 568     \\}
 569     ;match =0 == , status urfword \\{
 570     ;  dd  fword_equal
 571     ;  define status 1
 572     ;\\}
 573     if status = 0
 574       if urfword eqtype ""
 575         ; compile string
 576         urcstr \urfword
 577       else if defined(fword_\#\urfword)
 578         match =0 other , status urfword \\{
 579           dd  fword_\#\urfword
 580           define status 1
 581         \\}
 582       else if urfword eqtype 0
 583         ; compile numeric literal
 584         dd  fword_lit
 585         dd  \urfword
 586       else
 587         match =0  any , status urfword \\{
 588           err "wtf?!" urfword
 589         \\}
 590       end if
 591     end if
 592   \}
 593 }
 594
 595 macro UF [args] {
 596   common urforth args
 597 }
 598
 599
 600 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 601 macro urbrn lbl {
 602   urcall  branch
 603   dd      lbl
 604 }
 605
 606 macro ur0brn lbl {
 607   urcall  0branch
 608   dd      lbl
 609 }
 610
 611 macro urtbrn lbl {
 612   urcall  tbranch
 613   dd      lbl
 614 }