level0/urforth0.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 include "k8utils.inca"
  17
  18 format ELF executable 3
  19 entry urforth_entry_point
  20
  21 segment interpreter readable
  22   db "/lib/ld-linux.so.2",0
  23
  24
  25 segment dynamic readable
  26 ; the only thing we need is .so management functions, so we'll create
  27 ; a very simple import table for "libdl.so", with 3 imports:
  28 ; "dlopen", "dlclose", "dlsym"
  29
  30   DT_NULL    = 0
  31   DT_NEEDED  = 1
  32   DT_HASH    = 4
  33   DT_STRTAB  = 5
  34   DT_SYMTAB  = 6
  35   DT_STRSZ   = 10
  36   DT_SYMENT  = 11
  37   DT_REL     = 17
  38   DT_RELSZ   = 18
  39   DT_RELENT  = 19
  40
  41   ELF32_SYM_SIZE = 4+4+4+1+1+2
  42   ELF32_REL_SIZE = 4+4
  43
  44 ; create minimalistic Elf header with libdl.so import
  45   dd DT_NEEDED,elfhead_str_libdl-elfhead_strtab
  46   dd DT_STRTAB,elfhead_strtab
  47   dd DT_STRSZ,elfhead_strsz
  48   dd DT_SYMTAB,elfhead_symtab
  49   dd DT_SYMENT,ELF32_SYM_SIZE
  50   dd DT_REL,elfhead_rel
  51   dd DT_RELSZ,elfhead_relsz
  52   dd DT_RELENT,ELF32_REL_SIZE
  53   dd DT_HASH,elfhead_hash
  54   dd DT_NULL,0
  55
  56 segment executable readable writeable
  57 urforth_code_base_addr = $$ and 0xfffff000
  58
  59 elfhead_symtab:
  60   ; NULL import, should always be here
  61     dd elfhead_str_null-elfhead_strtab
  62     dd 0     ; value
  63     dd 0     ; size
  64     db 0x12  ; (STB_GLOBAL<<4)|STT_FUNC
  65     db 0     ; other
  66     dw 0     ; shndx
  67   ; import "dlopen"
  68     dd elfhead_str_dlopen-elfhead_strtab
  69     dd 0     ; value
  70     dd 0     ; size
  71     db 0x12  ; (STB_GLOBAL<<4)|STT_FUNC
  72     db 0     ; other
  73     dw 0     ; shndx
  74   ; import "dlclose"
  75     dd elfhead_str_dlclose-elfhead_strtab
  76     dd 0     ; value
  77     dd 0     ; size
  78     db 0x12  ; (STB_GLOBAL<<4)|STT_FUNC
  79     db 0     ; other
  80     dw 0     ; shndx
  81   ; import "dlsym"
  82     dd elfhead_str_dlsym-elfhead_strtab
  83     dd 0     ; value
  84     dd 0     ; size
  85     db 0x12  ; (STB_GLOBAL<<4)|STT_FUNC
  86     db 0     ; other
  87     dw 0     ; shndx
  88
  89 elfhead_strtab:
  90   elfhead_str_null db 0
  91   elfhead_str_libdl db "libdl.so",0
  92   elfhead_str_dlopen db "dlopen",0
  93   elfhead_str_dlclose db "dlclose",0
  94   elfhead_str_dlsym db "dlsym",0
  95 elfhead_strsz = $-elfhead_strtab
  96
  97   ; importer will use this to fix relocations
  98 elfhead_rel:
  99   ; dlopen
 100     dd elfimp_dlopen
 101     dd 0x0101   ; high bit is symbol index, low bit is R_386_32
 102   ; dlclose
 103     dd elfimp_dlclose
 104     dd 0x0201   ; high bit is symbol index, low bit is R_386_32
 105   ; dlsym
 106     dd elfimp_dlsym
 107     dd 0x0301   ; high bit is symbol index, low bit is R_386_32
 108 elfhead_relsz = $-elfhead_rel
 109
 110   ; fake import hash table with one bucket
 111 elfhead_hash:
 112   dd 1,4       ; size of bucket and size of chain
 113   dd 0         ; fake bucket, just one hash value
 114   times 4 dd % ; chain for all symbol table entries
 115
 116
 117 elfhead_size = $-urforth_code_base_addr
 118 ;display_hex elfhead_size
 119 ;display 10
 120
 121 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 122 ;; Forth system wants it like this
 123 ;segment readable writeable executable
 124 ; ld.so will add import symbol offsets here
 125 elfhead_impstart = $
 126 elfimp_dlopen dd 0
 127 elfimp_dlclose dd 0
 128 elfimp_dlsym dd 0
 129 elfhead_impend = $
 130 elfhead_implen = elfhead_impend-elfhead_impstart
 131
 132 db 'Alice!'
 133
 134
 135 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 136 include "urforth_dprint.asm"
 137
 138
 139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 140 URFORTH_DEBUG = 0
 141 ;; use `urcall urforth_bp` or `ur_bp` for manual breakpoint
 142
 143 URFORTH_EXTRA_STACK_CHECKS = 0
 144
 145
 146 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 147 URFORTH_ALIGN_HEADERS = 0
 148
 149 WLIST_HASH_BITS = 6
 150
 151 ; size in items
 152 DSTACK_SIZE = 65536
 153 RSTACK_SIZE = 65536
 154
 155 TTYLOW_ALLOW_BUFFERED = 0
 156
 157
 158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 159 ;; register usage:
 160 ;;   ebp: return stack
 161 ;;   esp: data stack
 162 ;;   esi: instruction pointer
 163 ;;   ecx: TOS
 164 ;;
 165 ;; direction flag must NOT be set!
 166
 167
 168 ;; WARNING! simply changing this definitions won't work!
 169 ;;          they are here just to make the code looks better!
 170 TOS equ ecx
 171 EIP equ esi
 172 ERP equ ebp
 173 FREEREG equ edx
 174
 175
 176 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 177 if WLIST_HASH_BITS < 0
 178   err "invalid WLIST_HASH_BITS: should be [0..8]"
 179 end if
 180
 181 if WLIST_HASH_BITS > 8
 182   err "invalid WLIST_HASH_BITS: should be [0..8]"
 183 end if
 184
 185 WLIST_HASH_CELLS = 1 shl WLIST_HASH_BITS
 186 WLIST_HASH_BYTES = WLIST_HASH_CELLS*4
 187 WLIST_HASH_MASK = (1 shl WLIST_HASH_BITS)-1
 188
 189 include "urforth0_mac.asm"
 190 include "urforth0_mac_hlconds.asm"
 191
 192 ;; TIB buffer is placed after the main memory allocated with BRK
 193 ;; so we will overallocate a little
 194 ;;;
 195 ;;;urword_var "(TIB-BUFFER)",par_tib_buffer
 196 ;;;urword_hidden
 197 ;;;; for debug, i'll put counter here
 198 ;;;; this also used as compile-time structured stack
 199 ;;;  dd  ?
 200 ;;;fdata_tib:
 201 ;;;  db  1024 dup(?)
 202 ;;;fdata_tib_end = $
 203 ;;;  db  ?
 204 ;;;  db  ?
 205 ;;;urfhi_csp = fdata_tib_end
 206 ;;;urword_end_array
 207
 208 urword_const "(ELF-EP)",par_elf_ep,urforth_entry_point
 209 urword_hidden
 210
 211
 212 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 213 urword_code "(URFORTH-SEGFAULT-CODEBLOCK)",par_urforth_nocall_segfault
 214 urword_hidden
 215 urword_codeblock
 216 include "urforth0_segfault.asm"
 217 urword_end
 218
 219 if URFORTH_DEBUG
 220 urword_code "(URFORTH-DEBUGGER-CODEBLOCK)",par_urforth_nocall_debugger
 221 urword_hidden
 222 urword_codeblock
 223   include "urforth0_dbg.asm"
 224   ; breakpoint
 225 urforth_next_ptr: dd urforth_next_normal
 226   ; normal next
 227 urforth_next_normal:
 228   jp    eax
 229 urword_end
 230 end if
 231
 232
 233 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 234 urword_code "(URFORTH-STARTUP-CODEBLOCK)",par_urforth_nocall_startup
 235 urword_hidden
 236 urword_codeblock
 237 urforth_entry_point:
 238   ; save argc
 239   ld    ecx,[esp]
 240   ld    [fval_argc_data],ecx
 241   ; save argv
 242   ld    eax,esp
 243   add   eax,4
 244   ld    [fconst_argv_data],eax
 245   ; calc envp address
 246   inc   ecx    ; skip final 0 argument
 247   shl   ecx,2
 248   add   eax,ecx
 249   ; store envp
 250   ld    [fconst_envp_data],eax
 251
 252   xor   eax,eax
 253   ; push several values for safety (so data stack underflow won't destroy cli args and such)
 254   ld    ecx,64
 255 @@:
 256   push  eax
 257   loop  @b
 258
 259  if 0
 260   ; allocate memory for dictionary
 261   ; binary size should be equal to DP
 262   ld    eax,[fval_init_mem_size_data]
 263   call  .brkalloc
 264   ;; EAX: start address
 265   ;; EBX: end address
 266   ld    [fvar_dpend_data],ebx
 267  end if
 268
 269   ; allocate memory for TIB
 270   ld    eax,[fval_par_default_tib_size_data]
 271   ; some more bytes for safety
 272   add   eax,128
 273   call  .brkalloc
 274   ;; EAX: start address
 275   ;; EBX: end address
 276   add   eax,32  ; reserve some TIB memory for various needs
 277   ld    [fval_par_default_tib_data],eax
 278
 279   ; allocate memory for PAD
 280   ld    eax,[fconst_pad_area_resv_size_data]
 281   add   eax,[fconst_pad_area_size_data]
 282   call  .brkalloc
 283   ;; EAX: start address
 284   ;; EBX: end address
 285   add   eax,[fconst_pad_area_resv_size_data]
 286   ld    [fvar_pad_area_data],eax
 287
 288   ; allocate memory for debug buffer
 289   ld    eax,[fval_dbuf_size_data]
 290   call  .brkalloc
 291   ;; EAX: start address
 292   ;; EBX: end address
 293   ld    [fval_dbuf_addr_data],eax
 294
 295   ; allocate memory for tty buffer
 296   if TTYLOW_ALLOW_BUFFERED
 297   ld    dword [fval_par_ttylow_buffer_pos_data],0
 298   ld    dword [fval_par_ttylow_buffer_addr_data],0
 299   cp    dword [fval_par_ttylow_use_buffer_data],1
 300   jr    c,@f
 301   ld    eax,[fval_par_ttylow_buffer_size_data]
 302   or    eax,eax
 303   jr    z,@f
 304   call  .brkalloc
 305   ;; EAX: start address
 306   ;; EBX: end address
 307   ld    [fval_par_ttylow_buffer_addr_data],eax
 308   end if
 309
 310   ; allocate memory for current file we are interpreting
 311   ld    eax,[fconst_par_tib_curr_fname_size_data]
 312   call  .brkalloc
 313   ;; EAX: start address
 314   ;; EBX: end address
 315   ld    [fval_par_tib_curr_fname_data],eax
 316   ld    dword [eax],0  ; no file
 317
 318   ; allocate memory for debugger/segfault stack
 319   ld    eax,1024
 320   call  .brkalloc
 321   ;; EAX: start address
 322   ;; EBX: end address
 323   ;; align it
 324   and   ebx,0xfffffff0
 325   ld    [urfsegfault_stack_bottom],ebx
 326
 327   ; prepare data stack (use "push" to trigger stack pages allocation)
 328   mov   edx,esp   ; save current stack pointer
 329   xor   eax,eax
 330
 331   mov   ecx,DSTACK_SIZE
 332 .dstack_clear_loop:
 333   push  eax
 334   loop  .dstack_clear_loop
 335
 336   ; prepare return stack (use "push" to trigger stack pages allocation)
 337   mov   ERP,esp   ; setup initial return stack pointer
 338   mov   ecx,RSTACK_SIZE
 339 .rstack_clear_loop:
 340   push  eax
 341   loop  .rstack_clear_loop
 342
 343   ; restore stack
 344   mov   esp,edx
 345
 346   ; save stack bottoms
 347   mov   [fvar_sp0_data],esp
 348   mov   [fvar_rp0_data],ERP
 349
 350   call  urforth_setup_segfault_handler
 351
 352   ; and start execution
 353   jmp   fword_cold_firsttime
 354
 355 ;; allocate memory via BRK
 356 ;; IN:
 357 ;;   EAX: size
 358 ;; OUT:
 359 ;;   EAX: start address (first byte)
 360 ;;   EBX: end address (*after* the last byte)
 361 ;;   other registers and flags are dead (except ESP)
 362 .brkalloc:
 363   ; save size (overallocate a little, for safety)
 364   add   eax,64
 365   push  eax
 366
 367   ; get current BRK address
 368   ld    eax,45       ; brk
 369   xor   ebx,ebx
 370   syscall
 371   push  eax
 372   ; [esp]: start address
 373   ; [esp+4]: alloc size
 374
 375   ; allocate
 376   ld    ebx,eax
 377   add   ebx,[esp+4]
 378   ld    eax,45       ; brk
 379   syscall
 380   ld    ebx,eax      ; EBX=end address
 381   ; check for OOM
 382   ld    eax,[esp]    ; start address
 383   add   eax,[esp+4]  ; alloc size
 384   cp    ebx,eax
 385   jp    c,.startup_oom
 386   ; start address
 387   pop   eax
 388   ; calc end address, to be precise
 389   pop   ebx
 390   ; remove overallocated safety margin from end address
 391   sub   ebx,64
 392   add   ebx,eax
 393   ret
 394
 395 .startup_oom:
 396   ; print error and exit
 397   mov   eax,4     ; write
 398   mov   ebx,2     ; stderr
 399   mov   ecx,.fatal_oom_msg
 400   mov   edx,.fatal_oom_msg_len
 401   syscall
 402
 403   mov   eax,1     ; exit
 404   mov   ebx,1
 405   syscall
 406
 407 .fatal_oom_msg: db "FATAL: out of memory!",10
 408 .fatal_oom_msg_len = $-.fatal_oom_msg
 409 urword_end
 410
 411
 412 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 413 urword_code "(URFORTH-DOFORTH-CODEBLOCK)",par_urforth_nocall_doforth
 414 urword_hidden
 415 urword_codeblock
 416 ;_doforth:
 417   rpush EIP
 418   pop   EIP
 419   urnext
 420 urword_end
 421
 422 urword_code "(URFORTH-DOCONST-CODEBLOCK)",par_urforth_nocall_doconst
 423 urword_hidden
 424 urword_codeblock
 425 ;_doconst:
 426   xchg  TOS,[esp]
 427   mov   TOS,[TOS]
 428   urnext
 429 urword_end
 430
 431 urword_code "(URFORTH-DOVAR-CODEBLOCK)",par_urforth_nocall_dovar
 432 urword_hidden
 433 urword_codeblock
 434 ;_dovar:
 435   xchg  TOS,[esp]
 436   urnext
 437 urword_end
 438
 439 urword_code "(URFORTH-DOVALUE-CODEBLOCK)",par_urforth_nocall_dovalue
 440 urword_hidden
 441 urword_codeblock
 442 ;_dovalue:
 443   ;jmp   _doconst
 444   xchg  TOS,[esp]
 445   mov   TOS,[TOS]
 446   urnext
 447 urword_end
 448
 449 urword_code "(URFORTH-DODEFER-CODEBLOCK)",par_urforth_nocall_dodefer
 450 urword_hidden
 451 urword_codeblock
 452 ;_dodefer:
 453   pop   eax
 454   mov   FREEREG,[eax]
 455   jmp   FREEREG
 456 urword_end
 457
 458 urword_code "(URFORTH-DODOES-CODEBLOCK)",par_urforth_nocall_dodoes
 459 urword_hidden
 460 urword_codeblock
 461 ;_dodoes:
 462   ; pfa is on the stack
 463   ; EAX is new VM IP
 464   xchg  TOS,[esp]
 465   rpush EIP
 466   mov   EIP,eax
 467   urnext
 468 urword_end
 469
 470 urword_code "(URFORTH-DOOVERRIDE-CODEBLOCK)",par_urforth_nocall_dooverride
 471 urword_hidden
 472 urword_codeblock
 473 ;_dooverride:
 474   rpush EIP
 475   pop   EIP
 476   xchg  TOS,[esp]
 477   urnext
 478 urword_end
 479
 480
 481 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 482 ;; use this subroutine to call a forth word from a machine code
 483 ;; EAX should point to the cfa
 484 ;; TOS and other things should be set accordingly
 485 ;; direction flag should be cleared
 486 ;; no registers are preserved
 487 ur_mc_fcall:
 488   ; move mc return address to rstack
 489   pop   FREEREG
 490   rpush FREEREG
 491   ; push current EIP to rstack
 492   rpush EIP
 493   ; set new EIP
 494   mov   EIP,ur_mc_fcall_justexit
 495   ; turn off debugger temporarily, because the debugger is using this
 496   if URFORTH_DEBUG
 497   ld    FREEREG,[urfdebug_active_flag]
 498   rpush FREEREG
 499   ; special flag, means "no breakpoint checks"
 500   ld    dword [urfdebug_active_flag],0xffffffff
 501   end if
 502   ; and execute the word
 503   jp    eax
 504 ur_mc_fcall_justexit:
 505   dd  ur_mc_fcall_fakeret_code
 506 ur_mc_fcall_fakeret_code:
 507   ; restore debugger state
 508   if URFORTH_DEBUG
 509   rpop  FREEREG
 510   ld    dword [urfdebug_active_flag],FREEREG
 511   end if
 512   ; restore EIP
 513   rpop  EIP
 514   ; restore return address
 515   rpop  eax
 516   ; and jump there
 517   jp    eax
 518
 519
 520 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 521 if URFORTH_DEBUG
 522 urword_code "(URFORTH-BP)",urforth_bp
 523 urword_hidden
 524   call  urfdebug_activate_it
 525   urnext
 526 urword_end
 527 end if
 528
 529 if URFORTH_DEBUG
 530 urword_alias "DBG",activate_debugger,urforth_bp
 531 else
 532 urword_code "DBG",activate_debugger
 533   urnext
 534 urword_end
 535 end if
 536
 537 if URFORTH_DEBUG
 538 urword_const "(HAS-DEBUGGER?)",par_has_debugger,1
 539 urword_const "(NEXT-REF-ADDR)",par_next_ref_addr,urforth_next_ptr
 540 else
 541 urword_const "(HAS-DEBUGGER?)",par_has_debugger,0
 542 ;; so i can avoid conditional compilation
 543 ;; it MUST be 0
 544 urword_const "(NEXT-REF-ADDR)",par_next_ref_addr,0
 545 end if
 546
 547
 548 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 549 include "urforth0_w_syscall.asm"
 550 include "urforth0_w_termio_low.asm"
 551
 552 urword_const "TRUE",true,1
 553 urword_const "FALSE",false,0
 554
 555 urword_const "CELL",cell,4
 556 urword_const "BL",bl,32
 557
 558 urword_value "(DEBUGGER-ON-STACK-UNDERFLOW)",par_dbg_on_sunder,0
 559
 560
 561 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 562 include "urforth0_w_litbase.asm"
 563 include "urforth0_w_stack.asm"
 564 include "urforth0_w_peekpoke.asm"
 565 include "urforth0_w_exceptions.asm"
 566 include "urforth0_w_math_base.asm"
 567 include "urforth0_w_math_muldiv.asm"
 568 include "urforth0_w_math_compare.asm"
 569 include "urforth0_w_math_dbl_min.asm"
 570
 571 include "urforth0_w_osface.asm"
 572
 573 include "urforth0_w_countstr.asm"
 574 include "urforth0_w_cstr_hash.asm"
 575
 576 include "urforth0_w_termio_high.asm"
 577
 578 include "urforth0_w_wordlist.asm"
 579
 580 include "urforth0_w_dp.asm"
 581 include "urforth0_w_temp_pool.asm"
 582 include "urforth0_w_dbginfo.asm"
 583
 584 include "urforth0_w_tib.asm"
 585
 586 include "urforth0_w_numbers.asm"
 587 include "urforth0_w_parse.asm"
 588
 589 include "urforth0_w_errors.asm"
 590
 591 include "urforth0_w_compiler_helpers.asm"
 592 include "urforth0_w_compiler_mid.asm"
 593
 594 include "urforth0_w_create_and_vocs.asm"
 595
 596 include "urforth0_w_save.asm"
 597
 598
 599 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 600 urword_forth "BRK-ALLOC",brk_alloc
 601 ;;  ( size -- addr )
 602 ;; throws OOM error
 603   UF dup 0less errid_out_of_memory qerror
 604   UF par_brkq  ;; ( size addr )
 605   UF swap qdup
 606   ur_if
 607     ;; ( addr size )
 608     UF over + dup par_sbrk
 609     UF uless errid_out_of_memory qerror
 610   ur_endif
 611 urword_end
 612
 613
 614 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 615 urword_forth "ARGV-STR",argv_str
 616 ;; ( argnum -- addr count )
 617   UF dup 0 less over argc greatequ or
 618   ur_if
 619     UF drop pad 0
 620   ur_else
 621     UF 4 umul argv + @ zcount
 622   ur_endif
 623 urword_end
 624
 625
 626 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 627 urword_forth "INTERPRET",interpret
 628   ur_begin
 629     UF par_spcheck
 630     ur_ifnot
 631       if URFORTH_DEBUG
 632       UF par_dbg_on_sunder
 633       ur_if
 634         ur_bp
 635       ur_endif
 636       end if
 637       UF errid_stack_underflow error
 638       UF 1 nbye  ;; just in case
 639     ur_endif
 640    if 0
 641     UF parse_name_ex
 642     ;; ( addr count )
 643     UF qdup
 644     ur_ifnot
 645       UF drop exit  ;; replace with "BREAK"
 646     ur_endif
 647    else
 648     ur_begin
 649       UF parse_name_ex
 650       ;; ( addr count )
 651       UF qdup
 652     ur_not_while
 653       UF drop
 654       ;; for default TIB (i.e. terminal session), "QUIT" will do it for us
 655       UF tib_is_default
 656       ur_if
 657         UF exit ;; replace with "BREAK"
 658       ur_endif
 659       UF refill
 660       ur_ifnot
 661         UF exit ;; replace with "BREAK"
 662       ur_endif
 663     ur_repeat
 664    end if
 665     ;; ( addr count )
 666     UF 2dup wfind_str
 667     ur_if
 668       ; i found her!
 669       UF nrot 2drop
 670       ; ( cfa )
 671       ; get flags
 672       UF dup cfa2nfa nfa2ffa ffapeek
 673       urlit FLAG_IMMEDIATE
 674       UF and
 675       UF state @ 0 equal  ; !0 means "compile"
 676       UF or
 677       ur_if
 678         ; execute
 679         UF execute
 680       ur_else
 681         ; compile
 682         UF compile_comma
 683       ur_endif
 684     ur_else
 685       ; unknown word, try to parse it as a number
 686       UF 2dup number
 687       ur_if
 688         UF nrot 2drop
 689         UF literal
 690       ur_else
 691         UF type errid_unknown_word error
 692       ur_endif
 693     ur_endif
 694   ur_again
 695 urword_end
 696
 697
 698 urword_forth ".OK",dotok
 699   UF par_spcheck
 700   ur_if
 701     UF pardottype "ok"
 702   ur_else
 703     UF errid_stack_underflow error_message
 704   ur_endif
 705   UF false rpush  ;; "bracket opened" flag
 706   ; show stack depth
 707   UF depth qdup
 708   ur_if
 709     UF rpop 1inc rpush
 710     UF pardottype " ("
 711     UF base @ rpush 0 dotr rpop base !
 712   ur_endif
 713   ; show BASE if it is not decimal
 714   UF base @ 10 nequ
 715   ur_if
 716     UF rpop
 717     ur_ifnot
 718       UF pardottype " ("
 719     ur_endif
 720     UF true rpush
 721     UF pardottype "; base:" base @ dup rpush decimal 0 dotr rpop base !
 722   ur_endif
 723   UF rpop
 724   ur_if
 725     UF 41 emit
 726   ur_endif
 727 urword_end
 728
 729 urword_forth "QUIT",quit
 730 urword_noreturn
 731   ur_begin
 732     UF rpset0
 733     ;UF state 0poke  ; nope, we want multiline definitions to work
 734     UF dotok cr
 735     UF tib_reset
 736     ; there is no reason to keep debug info activated
 737     UF debug_info_reset
 738     UF tload_verbose_default
 739     urto tload_verbose
 740     UF refill
 741     ur_ifnot
 742       UF bye
 743     ur_endif
 744     UF interpret
 745   ur_again
 746 urword_end
 747
 748
 749 urword_forth "EVALUATE",evaluate
 750 ;; ( addr count -- ... )
 751   UF dup 0 great
 752   ur_if
 753     UF par_tibstate_rpush
 754     UF tibsize !
 755     UF tib !
 756     UF inptr 0poke
 757     UF tiblineno 0poke
 758     UF interpret
 759     UF par_tibstate_rpop
 760   ur_else
 761     UF 2drop
 762   ur_endif
 763 urword_end
 764
 765
 766 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 767 urword_forth "(COLD-BUILD-RC-NAME)",par_cold_build_rc_name
 768 urword_hidden
 769   UF 0 argv_str str_extract_path qdup
 770   ur_ifnot
 771     UF drop strlit "./"
 772   ur_endif
 773   UF par_tload_fnpad c4s_copy_ac
 774   UF 0 argv_str str_extract_base_name par_tload_fnpad c4s_cat_ac
 775   UF strlit ".rc" par_tload_fnpad c4s_cat_ac
 776   UF par_tload_fnpad c4s_zterm
 777 urword_end
 778
 779
 780 urword_forth "(COLD-LOAD-RC)",par_cold_load_rc
 781 urword_hidden
 782   ;; check for "--naked"
 783   UF argc 1 great
 784   ur_if
 785     UF argc 1
 786     ur_do
 787       UF i argv_str strlit "--naked" strequ_ci
 788       ur_if
 789         UF unloop exit
 790       ur_endif
 791       UF 1  ;; argskip
 792       UF i argv_str strlit "--verbose-libs" strequ_ci
 793       ur_if
 794         UF 1
 795         urto tload_verbose_libs
 796       ur_endif
 797       UF i argv_str strlit "--quiet-libs" strequ_ci
 798       ur_if
 799         UF 0
 800         urto tload_verbose_libs
 801       ur_endif
 802       UF i argv_str strlit "--verbose-rc" strequ_ci
 803       ur_if
 804         UF 1
 805         urto tload_verbose_rc
 806       ur_endif
 807       UF i argv_str strlit "--quiet-rc" strequ_ci
 808       ur_if
 809         UF 0
 810         urto tload_verbose_rc
 811       ur_endif
 812       UF i argv_str strlit "--eval" strequ_ci
 813       ur_if
 814         UF drop 2
 815       ur_endif
 816       UF i argv_str strlit "-e" strequ_ci
 817       ur_if
 818         UF drop 2
 819       ur_endif
 820     ur_ploop
 821   ur_endif
 822   ;; no "--naked", load .rc
 823   UF par_cold_build_rc_name
 824   UF par_tload_fnpad count par_is_file
 825   ur_if
 826     UF tload_verbose rpush
 827     ;; be silent
 828     UF tload_verbose_rc
 829     urto tload_verbose
 830     UF par_cold_build_rc_name
 831     ;; copy it to HERE
 832     UF par_tload_fnpad here c4s_copy
 833     UF here count tload
 834     UF rpop
 835     urto tload_verbose
 836   ur_endif
 837 urword_end
 838
 839
 840 urword_forth "CLI-ARG-SKIP",arg_skip
 841   UF arg_next 1inc
 842   urto arg_next
 843 urword_end
 844
 845 urword_forth "(COLD-CLI)",par_cold_cli
 846 urword_hidden
 847   ;; load "urforth.rc" (if present)
 848   UF par_cold_load_rc
 849   ;; process CLI args
 850   ;; don't use DO ... LOOP here, use CLI-ARG-NEXT
 851   ur_begin
 852     UF arg_next argc less
 853     UF arg_next 0great and
 854   ur_while
 855     ;; empty arg?
 856     UF arg_next argv_str arg_skip
 857     UF qdup
 858     ur_ifnot
 859       UF drop
 860     ur_else
 861       ;; ( addr count )
 862       ;; "-..." args?
 863       UF over cpeek 45 equal
 864       ur_if
 865         ;; "-e" or "--eval" ?
 866         UF 2dup strlit "-e" strequ_ci rpush
 867         UF strlit "--eval" strequ_ci rpop or
 868         ;; note that argv is dropped here
 869         ur_if
 870           ;; set TIB and eval
 871           UF arg_next argv_str arg_skip evaluate
 872         ur_endif
 873         ;; unknown "-..." args are skipped
 874       ur_else
 875         ;; filename arg
 876         UF tload
 877       ur_endif
 878     ur_endif
 879   ur_repeat
 880 urword_end
 881
 882
 883 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 884 urword_forth "(.BANNER)",par_dot_banner
 885 urword_hidden
 886   UF pardottype "UrForth v0.0.1-beta" cr
 887 urword_end
 888
 889
 890 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 891 ;; called to print a banner after processing CLI args
 892 urword_defer ".BANNER",dot_banner,par_dot_banner
 893
 894 ;; called (once!) to process CLI args
 895 urword_defer "PROCESS-CLI-ARGS",process_cli_args,par_cold_cli
 896
 897 ;; main program loop, should never return
 898 urword_defer "MAIN-LOOP",main_loop,quit  ;; this word should never return
 899
 900 ;; default abort calls ABORT-CLEANUP, and then MAIN-LOOP
 901 urword_defer "ABORT-CLEANUP",abort_cleanup,par_abort_cleanup
 902
 903 ;; ye good olde ABORT, vectorized
 904 urword_defer "ABORT",abort,par_abort  ;; this word should never return
 905
 906 ;; called when the system needs to abort with error message
 907 ;; ( errcode )
 908 urword_defer "ERROR",error,par_error  ;; this word should never return
 909
 910
 911 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 912 urword_forth "(COLD-FIRSTTIME)",cold_firsttime
 913 urword_hidden
 914 urword_noreturn
 915   UF sys_gettickcount_init
 916   UF cold
 917   ;; just in case it returns
 918   UF bye
 919 urword_end
 920
 921
 922 urword_forth "COLD",cold
 923 urword_noreturn
 924   UF spset0 rpset0
 925   UF temp_pool_reset tib_reset
 926   UF tload_verbose_default
 927   urto tload_verbose
 928   UF dp_temp 0poke
 929   UF process_cli @
 930   ur_if
 931     UF process_cli 0poke  ; no more
 932     UF process_cli_args
 933   ur_endif
 934   UF dot_banner
 935   UF main_loop
 936   ;; just in case it returns
 937   UF bye
 938 urword_end
 939
 940
 941 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 942 urword_value "TLOAD-VERBOSE-LIBS",tload_verbose_libs,1
 943 urword_value "TLOAD-VERBOSE",tload_verbose,1
 944 urword_value "TLOAD-VERBOSE-DEFAULT",tload_verbose_default,1
 945 urword_value "TLOAD-VERBOSE-RC",tload_verbose_rc,0
 946
 947
 948 urword_forth "(TLOAD-FNPAD)",par_tload_fnpad
 949 urword_hidden
 950   UF pad 2048 +
 951 urword_end
 952
 953
 954 urword_forth "(TLOAD-OPEN-ADD-ALL)",par_tload_open_add_all
 955 urword_hidden
 956 ;; ( -- )
 957   UF par_tload_fnpad c4s_zterm
 958   UF par_tload_fnpad count par_is_dir
 959   ur_if
 960     ;; add trailing slash
 961     UF par_tload_fnpad count + 1dec cpeek 47 equal
 962     ur_ifnot
 963       UF strlit "/" par_tload_fnpad c4s_cat_ac
 964     ur_endif
 965     UF strlit "all.f" par_tload_fnpad c4s_cat_ac
 966     UF par_tload_fnpad c4s_zterm
 967   ur_endif
 968 urword_end
 969
 970 urword_forth "(TLOAD-OPEN)",par_tload_open
 971 urword_hidden
 972 ;; ( addr count -- fd )
 973 ;; also, leaves file name as c4str at PAD
 974   UF dup 0lessequ
 975   ur_if
 976     UF 2drop errid_file_not_found error
 977   ur_endif
 978
 979   ;; ! will be replaced with binary path
 980   UF over cpeek 33 equal
 981   ur_if
 982     UF 0 argv_str str_extract_path qdup
 983     ur_ifnot
 984       UF drop strlit "./"
 985     ur_endif
 986     UF par_tload_fnpad c4s_copy_ac
 987     UF 1dec swap 1inc swap
 988     UF par_tload_fnpad c4s_cat_ac
 989   ur_else
 990     UF par_last_tload_path
 991     ur_if
 992       UF 2dup 2rpush
 993       UF par_last_tload_path par_tload_fnpad c4s_copy
 994       ;; ( addr count | addr count )
 995       UF par_tload_fnpad c4s_cat_ac
 996       UF par_tload_open_add_all
 997       UF par_tload_fnpad count
 998       ;; ( addr count | addr count )
 999       UF o_rdonly 0 par_fopen
1000       UF dup 0greatequ
1001       ur_if
1002         UF rdrop rdrop exit
1003       ur_endif
1004       UF drop 2rpop
1005     ur_endif
1006     UF par_tload_fnpad c4s_copy_ac
1007     UF par_tload_open_add_all
1008   ur_endif
1009   UF par_tload_open_add_all
1010   UF par_tload_fnpad count o_rdonly 0 par_fopen
1011   UF dup 0less
1012   ur_if
1013     UF drop endcr pardottype "file: " par_tload_fnpad count type errid_file_not_found error
1014   ur_endif
1015 urword_end
1016
1017
1018 urword_forth "TLOAD",tload
1019 ;; ( addr count -- )
1020 ;; load forth source file
1021 ;; this loads the whole file into temp pool
1022   UF par_tload_open
1023   UF tload_verbose
1024   ur_if
1025     UF endcr pardottype "loading: " par_tload_fnpad count type cr
1026   ur_endif
1027   UF rpush
1028   ;; ( | fd )
1029   UF 0 seek_end rpeek par_lseek
1030   ;; ( size | fd )
1031   UF dup 0 less
1032   ur_if
1033     UF drop rpop par_fclose drop
1034     UF errid_file_read_error error
1035   ur_endif
1036   ; seek back to file start
1037   ;; ( size | fd )
1038   UF 0 seek_set rpeek par_lseek
1039   ur_if
1040     UF drop rpop par_fclose drop
1041     UF errid_file_read_error error
1042   ur_endif
1043   ; allocate temp pool space
1044   ; this will also take care about too big files
1045   ; FIXME: the file won't be closed if it is too big!
1046   UF rpop temp_pool_mark rpush rpush
1047   ;; ( size | poolmark fd )
1048   UF dup cellinc temp_pool_alloc
1049   ;; ( size addr | poolmark fd )
1050   ; write zeroes at the end (just in case)
1051   UF 2dup + 0poke
1052   ; load file
1053   UF 2dup swap rpeek par_fread
1054   ;; ( size addr readbytes | poolmark fd )
1055   ; close file
1056   UF rpop par_fclose drop
1057   ;; ( size addr readbytes | poolmark )
1058   ;; ( addr readbytes | poolmark )
1059   UF rot over - errid_file_read_error qerror
1060   ;; ( addr readbytes | poolmark )
1061   UF par_tibstate_rpush
1062   UF tibsize !
1063   UF tib !
1064   UF inptr 0poke
1065   UF 1 tiblineno poke
1066   ;; ( | poolmark tibstate... )
1067     ;; UF par_tload_fnpad count type cr
1068   ;; store file path
1069   UF par_tload_fnpad count str_extract_path
1070   UF qdup
1071   ur_ifnot
1072     UF drop strlit "./"
1073   ur_endif
1074     ;; UF 2dup type cr
1075   UF dup cellinc temp_pool_alloc
1076   UF par_last_tload_path rpush
1077   urto par_last_tload_path
1078   UF par_last_tload_path c4s_copy_ac
1079     ;; UF par_last_tload_path count type cr
1080   UF cell temp_pool_alloc rpop swap poke
1081   ;; save current file name, and replace it
1082   UF par_tib_curr_fname count_only cellinc temp_pool_alloc
1083   UF rpush  ;; old fname at rstack
1084   UF par_tib_curr_fname rpeek over count_only cellinc move
1085   UF par_tload_fnpad par_tib_curr_fname over count_only cellinc move
1086   ;; process it
1087   UF interpret
1088   ;; restore old fname
1089   UF rpop par_tib_curr_fname over count_only cellinc move
1090   ;; restore path
1091   UF par_last_tload_path celldec peek
1092   urto par_last_tload_path
1093   UF par_tibstate_rpop
1094   UF rpop temp_pool_release
1095   ;UF pardottype "done!" cr
1096   ;UF tib_reset
1097 urword_end
1098
1099
1100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1101 urword_code "NOOP",noop
1102   urnext
1103 urword_end
1104
1105
1106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1107 urword_const "WLIST-HASH-BITS",wlist_hash_bits,WLIST_HASH_BITS
1108
1109 urword_var "DP",dp,fdata_freespace
1110 urword_var "DP-END",dpend,fdata_freespace
1111 urword_var "DP-TEMP",dp_temp,0  ;; this is used to temporarily change HERE
1112 urword_var "SP0",sp0,0
1113 urword_var "RP0",rp0,0
1114
1115 ;; pad is allocated with BRK; "#PAD-AREA-RESV" is the space BEFORE "PAD-AREA"
1116 urword_var "PAD-AREA",pad_area,0  ;; will be set by startup code
1117 urword_const "#PAD-AREA-RESV",pad_area_resv_size,2048
1118 urword_const "#PAD-AREA",pad_area_size,4096
1119
1120 urword_value "(INIT-MEM-SIZE)",init_mem_size,1024*1024*2
1121 urword_hidden
1122
1123 urword_var "STATE",state,0
1124
1125 urword_value "ARGC",argc,0
1126 urword_const "ARGV",argv,0
1127 urword_const "ENVP",envp,0
1128
1129 urword_const "URFORTH-LEVEL",par_urforth_level,0
1130
1131 ;; index of the next CLI arg to process
1132 ;; set to 0, negative or ARGC to stop further processing
1133 urword_value "CLI-ARG-NEXT",arg_next,1
1134
1135 ;; this is so COLD will process CLI args only once
1136 urword_var "(PROCESS-CLI-ARGS)",process_cli,1
1137 urword_hidden
1138
1139 ; mostly controls number parsing for now: "#" prefix is decimal in shit2012
1140 ; bit0: allow 2012 number prefix idiocity and number signs
1141 ; bit1: use non-FIG VARIABLE
1142 urword_value "(SHIT-2012-IDIOCITY)",shit2012shit,0
1143 urword_hidden
1144
1145
1146 urword_const "(CODE-BASE-ADDR)",par_code_base_addr,urforth_code_base_addr
1147 urword_hidden
1148
1149 urword_const "(CODE-IMPORTS-ADDR)",par_code_imports_addr,elfhead_impstart
1150 urword_hidden
1151
1152 urword_const "(CODE-IMPORTS-SIZE)",par_code_imports_size,elfhead_implen
1153 urword_hidden
1154
1155 urword_const "(CODE-IMPORTS-END-ADDR)",par_code_imports_end_addr,elfhead_impend
1156 urword_hidden
1157
1158 urword_const "(CODE-ENTRY-ADDR)",par_code_entry_addr,urforth_entry_point
1159 urword_hidden
1160
1161 ; it should be here
1162 urforth_last_word_end_late = $
1163 ; it should be here
1164 urforth_last_word_lfa_late = urforth_last_word_lfa
1165
1166 db 'Miriel!'
1167
1168
1169 display "UrForth words: "
1170 display_dec urforth_word_count
1171 display 10
1172
1173 fdata_freespace = $
1174
1175
1176 ;; patch FORTH vocabulary hash table
1177 if WLIST_HASH_BITS
1178 fht_patch_count = 0
1179 fht_patch_dpos = forth_voc_hashtable
1180 fht_patch_v = 0
1181 while fht_patch_count < WLIST_HASH_BYTES
1182   load fht_patch_v dword from urforth_forth_hashtable:urforth_forth_hash_offset+fht_patch_count
1183   store dword fht_patch_v at fht_patch_dpos
1184   fht_patch_count = fht_patch_count+4
1185   fht_patch_dpos = fht_patch_dpos+4
1186 end while
1187 end if
1188
1189
1190 ;; reserve BSS space, because BRK is completely broken on "modern" distros
1191 rb  1024*1024*1
1192 end_dict = $
1193 store dword end_dict at fvar_dpend_data