meta/asm-metc.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Metacompiler
   4 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7 ;; metacompiling support
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 false to tload-verbose
  11
  12 " meta-00-compat.f" tload
  13 asmx86:asm-Labman-Reinit
  14
  15
  16 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17 only forth definitions
  18 vocabulary ur-meta
  19 also ur-meta definitions
  20
  21 enum{
  22   value tc-LINUX/X86
  23   value tc-WIN32
  24 }
  25
  26 tc-LINUX/X86 value tc-os
  27
  28 ;; 0: don't change case; 1: upcase; -1: locase
  29 0 value tc-create-case?
  30
  31 ;; align headers to dword?
  32 true value tc-align-headers
  33 true value tc-align-cfa
  34 true value tc-align-pfa
  35
  36 (*
  37 false to tc-align-cfa
  38 false to tc-align-pfa
  39 *)
  40
  41 0 value tc-align-headers-wasted
  42 0 value tc-align-cfa-wasted
  43 0 value tc-align-pfa-wasted
  44
  45 ;; set to `false` to create static ELF (`dlopen` will not be included)
  46 true value tc-dynamic-binary
  47
  48 ;; set to `false` to omit debugger (faster, but no debugger at all)
  49 ;; disable interactive debugger, i don't need it. the system is faster this way.
  50 false value tc-debugger-enabled
  51 ;; but enable debug info for backtraces
  52 true value tc-debug-info-enabled
  53
  54 false value tc-verbose
  55
  56 enum{
  57   value tc-nhash-elf    ;; use elf hash
  58   value tc-nhash-joaat  ;; use Bob Jenkins' One-At-A-Time for hashing word names?
  59   value tc-nhash-rot    ;; use rotating hash
  60 }
  61 \ tc-nhash-rot value tc-wordhash-type
  62 tc-nhash-joaat value tc-wordhash-type
  63
  64 enum{
  65   value tc-tls-none
  66   value tc-tls-fs
  67 }
  68 tc-tls-fs value tc-tls-type
  69
  70 ;; only words with headers
  71 0 value tc-created-words-count
  72
  73 240 value tc-max-word-name-length
  74
  75 ;; optimise chain of branches?
  76 ;; i.e. branch to branch to branch
  77 true value tc-opt-branches?
  78
  79 ;; set to `true` to enable optimising of aliases
  80 ;; please note that alias optimiser cannot optimise forward references (yet)
  81 false value tc-opt-aliases?
  82
  83 ;; 4096 constant tc-#userarea
  84 1024 constant tc-#userarea
  85 0 value tc-userarea-used
  86
  87 ;; total image size; as all so-called "modern" distros are broken, we have to reserve it in ELF header
  88 1024 1024 * 2 * value tc-image-vsize
  89
  90
  91 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92 ;; some debug toops
  93
  94 ;; dump Forth forward references?
  95 false value tc-dump-forwards?
  96
  97
  98 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99 " meta-01-helper-low.f" tload
 100
 101 0 value prev-include-buf
 102
 103 : tc-refill  ( -- flag )
 104   prev-include-buf ifnot false exit endif
 105   prev-include-buf dup @ to prev-include-buf
 106   cell+ tibstate-restore
 107   ;; restore file name
 108   forth:(tib-curr-fname) cell- @ to forth:(tib-curr-fname)
 109   ;; restore tload path
 110   @tc-tload-last-include-dir-c4s cell- @ !tc-tload-last-include-dir-c4s
 111   \ ." resuming: " forth:(tib-curr-fname) count type cr
 112   true
 113 ;
 114
 115
 116 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 117 : tc-token-check-comments  ( -- againflag )
 118   false
 119   tib-peekch dup 32 <= if
 120     ;; single-char comments
 121     drop
 122     asmx86:lexer:tkvalue case
 123       [char] ( of  ;; )
 124         [char] ) parse 2drop
 125         drop true
 126       endof
 127       [char] \ of
 128         parse-skip-to-eol
 129         drop true
 130       endof
 131     endcase
 132   else
 133     ;; multi-char comments
 134     8 lshift asmx86:lexer:tkvalue or
 135     case
 136       0x2828 of  ;; ((
 137         skip-comment-multiline-nested
 138         drop true
 139       endof
 140       0x2A28 of  ;; (*
 141         skip-comment-multiline
 142         drop true
 143       endof
 144       0x2F2F of  ;; //
 145         parse-skip-to-eol
 146         drop true
 147       endof
 148     endcase
 149   endif
 150 ;
 151
 152 : tc-fix-id  ( addr count -- )
 153   asmx86:lexer:tkvalue c4s:copy-counted
 154 ;
 155
 156 : tc-check-special-token  ( -- )
 157   \ asmx86:tk-id? ifnot exit endif
 158   asmx86:lexer:tkvalue count
 159   2dup s" CODE" s= if
 160     2drop
 161     tib-peekch [char] : = not-?abort" `:` expected"
 162     tib-getch drop
 163     ;; the next one should be blank
 164     tib-peekch 32 <= not-?abort" blank char expected"
 165     tib-getch drop
 166     " CODE:" tc-fix-id
 167     exit
 168   endif
 169   2dup s" END" s= if
 170     2drop
 171     tib-peekch [char] - = ifnot exit endif
 172     tib-getch drop
 173     tib-peekch upcase-char [char] C = not-?abort" end-code expected"
 174     asmx86:lexer:NextToken
 175     asmx86:tk-id? not-?abort" end-code expected"
 176     asmx86:lexer:tkvalue count " CODE" s= not-?abort" end-code expected"
 177     " ENDCODE" tc-fix-id
 178   endif
 179   2drop
 180 ;
 181
 182 ;; this skips more comments
 183 : tc-next-token-noread  ( -- )
 184   begin
 185     ;; check for EOL
 186     asmx86:lexer:tktype ifnot
 187       ;; EOL
 188       tib-peekch ?dup if
 189         10 = if tib-getch drop endif
 190       else
 191         tc-refill ifnot break endif
 192       endif
 193       asmx86:lexer:PrepareLineParser
 194       asmx86:lexer:NextToken
 195       continue
 196     endif
 197     ;; check for multiline comments
 198     asmx86:tk-delim? if
 199       tc-token-check-comments if
 200         asmx86:lexer:PrepareLineParser
 201         asmx86:lexer:NextToken
 202         continue
 203       endif
 204     else
 205       asmx86:tk-id? if tc-check-special-token endif
 206     endif
 207     break
 208   again
 209     \ endcr asmx86:lexer:(dump-current-token) cr
 210 ;
 211
 212 : tc-next-token  ( -- )
 213   asmx86:lexer:NextToken
 214   tc-next-token-noread
 215 ;
 216
 217
 218 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 219 : (file-error)  ( addr count msgaddr msgcount -- )
 220   endcr type space 34 emit type 34 emit space forth:error-line. cr
 221   \ abort
 222   1 n-bye
 223 ;
 224
 225 ;; please, don't write such huge words!
 226 : include-file  ( addr count -- )
 227   dup not-?abort" cannot include nothing"
 228   ;; save tib state
 229   #tib-save-buffer cell+ brk-alloc
 230   prev-include-buf over ! to prev-include-buf
 231   prev-include-buf cell+ tibstate-save
 232   ;; prepend current path (remember the original address, tho)
 233   2dup @tc-tload-last-include-dir-c4s count pad 1024 + c4s:copy-counted pad 1024 + c4s:cat-counted
 234   pad 1024 + count os:o-rdonly 0 os:open
 235   dup 0< if drop " cannot open file" (file-error) endif
 236   >r
 237   ;; ( addr count | fd )
 238   0 os:seek-end r@ os:lseek
 239   ;; ( addr count size | fd )
 240   dup 0< if
 241     drop r> os:close drop
 242     " cannot get size of file" (file-error)
 243   endif
 244   ;; seek back to file start
 245   ;; ( addr count size | fd )
 246   0 os:seek-set r@ os:lseek
 247   if
 248     drop r> os:close drop
 249     " cannot rewind file" (file-error)
 250   endif
 251   ;; allocate temp pool space
 252   \ TODO: free memory somehow
 253   ;; ( addr count size | fd )
 254   dup brk-alloc
 255   ;; ( addr count size bufaddr | fd )
 256   ;; load file
 257   2dup swap r@ os:read
 258   ;; ( addr count size bufaddr readbytes | fd )
 259   rot over = ifnot
 260     ;; ( addr count bufaddr readbytes | fd )
 261     drop 2drop r> os:close drop
 262     " cannot get size of file" (file-error)
 263   endif
 264   ;; close file
 265   r> os:close drop
 266   ;; ( addr count bufaddr readbytes )
 267   (tib-set-to)
 268   tib-line# 1!
 269   [DEFINED] (tib-last-read-char) [IF]
 270     bl (tib-last-read-char) !
 271   [ENDIF]
 272   ;; replace current file name (for error reporting)
 273   dup 2 +cells brk-alloc  ;; ( addr count namebuffaddr )
 274   forth:(tib-curr-fname) over ! cell+
 275   to forth:(tib-curr-fname)
 276   2dup forth:(tib-curr-fname) c4s:copy-counted
 277   ;; show message, and go with the new tib
 278   tc-verbose if endcr ." processing: " type cr else 2drop endif
 279   ;; replace current tload path (for relative loads)
 280   pad 1024 + count dup 2 +cells brk-alloc
 281   ;;  ( addr count newbuf )
 282   @tc-tload-last-include-dir-c4s over ! cell+
 283   dup !tc-tload-last-include-dir-c4s
 284   c4s:copy-counted
 285   ;; remove file name from the path
 286   @tc-tload-last-include-dir-c4s dup count str-extract-path nip swap !
 287   ;; done with bookkeeping
 288 ;
 289
 290
 291 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 292 " meta-02-mem.f" tload
 293 " meta-04-str-hash.f" tload
 294 " meta-10-asm-tc.f" tload
 295 " meta-14-asm-defconsts.f" tload
 296 " meta-20-elf.f" tload
 297
 298 ;; for "immediate (noop)" words; just a list
 299 vocabulary tc-imm-noops
 300
 301 " meta-40-tc-compiler-00-dbginfo.f" tload
 302 " meta-40-tc-compiler-04-low.f" tload
 303 " meta-40-tc-compiler-05-cfa-cvt.f" tload
 304 " meta-40-tc-compiler-07-opt-basic.f" tload
 305 " meta-40-tc-compiler-06-name-hash.f" tload
 306 " meta-40-tc-compiler-10-word-utils.f" tload
 307 " meta-40-tc-compiler-15-dbginfo.f" tload
 308 " meta-40-tc-compiler-20-create.f" tload
 309 " meta-40-tc-compiler-30-mid.f" tload
 310
 311 ;; later, we will create "tc-immediates" vocabulary, and populate it with words from "tc-immediates-src"
 312 ;; this is to avoid prepending "tc-" to immediate words (it is faster this way)
 313 nested-vocabulary tc-immediates-src
 314 also tc-immediates-src definitions
 315
 316 " meta-50-tc-imm-00-if-begin-do.f" tload
 317 " meta-50-tc-imm-10-colon-var.f" tload
 318 " meta-50-tc-imm-20-compile-tick.f" tload
 319 " meta-50-tc-imm-30-cond-comp.f" tload
 320 " meta-50-tc-imm-40-asm-misc.f" tload
 321
 322 previous definitions
 323
 324 ;; this creates "tc-immediates" vocabulary, and populates it
 325 " meta-50-tc-imm-99-populate.f" tload
 326
 327 \ also tc-immediates words previous
 328
 329
 330 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 331 also asmx86 definitions
 332 nested-vocabulary tc-instrs
 333 also tc-instrs definitions
 334 <public-words>
 335
 336 " meta-60-asm-commands.f" tload
 337 " meta-60-asm-commands-macros.f" tload
 338
 339 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 340 previous previous definitions
 341
 342 ;; now put our instructions into asmx86:instructions vocabulary
 343 vocid-of asmx86:tc-instrs asmx86:Register-Macros-From-VocId
 344
 345
 346 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 347 " meta-70-tc-interp-00-internal.f" tload
 348 nested-vocabulary tc-interp-words
 349 also tc-interp-words definitions
 350 " meta-70-tc-interp-05-vocab.f" tload
 351 " meta-70-tc-interp-10-comp-flags.f" tload
 352 " meta-70-tc-interp-20-mem.f" tload
 353 " meta-70-tc-interp-30-math.f" tload
 354 previous definitions
 355
 356
 357 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 358 : tc-find-interp  ( addr count -- addr count false // cfa true )
 359   vocid: tc-interp-words voc-search
 360 ;
 361
 362 : tc-find-imm  ( addr count -- addr count false // cfa true )
 363   vocid: tc-immediates voc-search
 364 ;
 365
 366 : tc-is-allowed-instr  ( addr count -- addr count flag )
 367   over c@ [char] $ = if true exit endif
 368   dup 2 = if
 369     2dup " DB" s=ci if true exit endif
 370     2dup " DW" s=ci if true exit endif
 371     2dup " DD" s=ci if true exit endif
 372     2dup " RB" s=ci if true exit endif
 373     2dup " RW" s=ci if true exit endif
 374     2dup " RD" s=ci if true exit endif
 375   endif
 376   false
 377 ;
 378
 379 : tc-find-tc-instr  ( addr count -- addr count false // cfa true )
 380   tc-is-allowed-instr ifnot false exit endif
 381   vocid: asmx86:instructions voc-search
 382 ;
 383
 384
 385 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 386 : tc-(code-word)  ( -- )
 387   ;; we won't create debug info for code words (yet)
 388   tc-(dbginfo-reset)
 389   tc-create-header
 390   parse-skip-to-eol
 391   asmx86:lexer:PrepareLineParser
 392   tc-next-token
 393   begin
 394     asmx86:tk-id? if
 395         \ lexer:tkvalue count endcr type cr
 396       asmx86:lexer:tkvalue count " ENDCODE" s= if break endif
 397     endif
 398     asmx86:(asm-tib) (sp-check) ifnot error-line. cr dbg endif
 399     tc-next-token-noread
 400     asmx86:lexer:tktype ifnot asmx86:ERRID_ASM_ENDCODE_EXPECTED asmx86:not-?asm-error endif
 401   again
 402   tc-create;
 403   ;; latest disasm-word
 404   asmx86:asm-Check-Undef-Labels
 405   tc-smudge
 406 ;
 407
 408 1024 constant #asm-line-buf
 409 #asm-line-buf 2+ brk-buffer: asm-line-buf
 410
 411 : tc-collect-asm-line  ( -- addr count )
 412   0  ;; length
 413   begin
 414     tib-getch dup 10 <>
 415   while
 416     over asm-line-buf + c!
 417     1+ dup #asm-line-buf >= ?abort" asm line too long"
 418   repeat
 419   drop
 420   asm-line-buf swap
 421   2dup + 0c!
 422 ;
 423
 424 : tc-(code-line)  ( -- )
 425   tc-collect-asm-line
 426   tibstate>r
 427   (tib-set-to)
 428   ;; we won't create debug info for code words (yet)
 429   tc-(dbginfo-reset)
 430   asmx86:lexer:PrepareLineParser
 431   tc-next-token
 432   begin
 433     asmx86:tk-eol?
 434   not-while
 435     asmx86:(asm-tib) (sp-check) ifnot error-line. cr dbg endif
 436     tc-next-token-noread
 437   repeat
 438   ;; latest disasm-word
 439   asmx86:asm-Check-Undef-Labels
 440   r>tibstate
 441 ;
 442
 443
 444 ;; also, skips it
 445 : next-equ?  ( -- flag )
 446   tibstate>r
 447   parse-name
 448   r>tibstate
 449   " EQU" s=ci if
 450     parse-name 2drop true
 451   else
 452     false
 453   endif
 454 ;
 455
 456 : tc-(equ) ( addr count -- )
 457   \ pad c4c-copy-a-c  ;; save constant name
 458   asmx86:lexer:PrepareLineParser
 459   tc-next-token
 460   asmx86:Reset-Instruction
 461   4 to asmx86:*OpSize
 462   ;; copy name to `*OffName`, it is not used by `Imm`
 463   asmx86:*OffName c1s:copy-counted
 464   asmx86:Imm
 465   ;; check if it is using only defined labels
 466   asmx86:*OpReloc if
 467     asmx86:*ImmForthType asmx86:ERRID_ASM_INVALID_FORWARD_REF asmx86:?asm-error
 468     asmx86:*ImmName c@ asmx86:ERRID_ASM_INVALID_FORWARD_REF asmx86:not-?asm-error
 469     \ *ImmName bcount asm-Label-Defined? ERRID_ASM_INVALID_FORWARD_REF not-?asm-error
 470     asmx86:*ImmLabelDefined asmx86:ERRID_ASM_INVALID_FORWARD_REF asmx86:not-?asm-error
 471   endif
 472   \ ." |" *OffName bcount type ." | " *Imm . cr
 473   asmx86:*OffName bcount asmx86:*Imm asmx86:asm-Make-Constant
 474 ;
 475
 476
 477 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 478 : tc-interp-find-tc-word  ( addr count -- rva-cfa flags true // false )
 479   x-tc-xcfind dup if over tc-cfa->nfa tc-nfa->ffa tc-ffa@ swap endif
 480 ;
 481
 482 : tc-interp-find-tc-word-no-imm  ( addr count -- rva-cfa true // false )
 483   2dup tc-interp-find-tc-word if
 484     tc-(wflag-immediate) and if drop
 485       ;; ignore (noop) words
 486       vocid: tc-imm-noops voc-search ifnot
 487         endcr ." ERROR: \`" type ." \` is immediate!\n"
 488         abort" no TC immediate words allowed"
 489       else drop 0 true endif  ;; 0 cfa won't be compiled
 490     else nrot 2drop true endif
 491   else 2drop false endif
 492 ;
 493
 494
 495 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 496 ;; main metacompiler loop
 497 : format  ( -- )
 498   parse-name " ELF" s=ci not-?abort" not an elf?"
 499   parse-name " executable" s=ci not-?abort" not an elf executable?"
 500   ;; parse-name s=ci " 3" not-?abort" not an x86 abi?"
 501   parse-skip-to-eol
 502   1 to asmx86:asm-Labman-Unresolved-As-Forwards?
 503   begin
 504       (sp-check) ifnot error-line. cr dbg endif
 505     \ tc-state @ ifnot break endif
 506     begin
 507       parse-name-ex  ;; ( addr count )
 508     ?dup not-while
 509       drop tc-refill ifnot
 510         tc-state @ ?abort" definition not finished"
 511         0 0 break
 512       endif
 513     repeat
 514     dup ifnot break endif
 515     ;; ( addr count )
 516       \ endcr ." TC: " 2dup type cr
 517     ;; here we'll do some hackery: for compiling mode, try "tc-immediates" vocab first
 518     tc-find-imm if execute continue endif
 519     tc-state @ if
 520       ;; compiling, try to find a tc word
 521       2dup tc-interp-find-tc-word-no-imm if  ;; ( addr count rva-cfa )
 522         ;; i found her!
 523         nrot 2drop  ?dup if tc-compile, endif  ;; compile it to the target area
 524       else
 525         ;; unknown word, try to parse it as a number
 526         2dup number if
 527           nrot 2drop
 528           tc-literal
 529         else
 530           ;; this should be a forward reference
 531           tc-dump-forwards? if
 532             ;; this seems to be a forward reference
 533             endcr ." forwardref to \`" 2dup type ." \`"
 534             [DEFINED] forth:(tib-fname>error-fname) [IF] forth:(tib-fname>error-fname) [ENDIF]
 535             ERROR-LINE.
 536           endif
 537           tc-compile,-(str)-nochecks
 538         endif
 539       endif
 540     else
 541       ;; interpreting
 542         \ endcr ." |" 2dup type ." | " tib-line# @ . cr
 543       tc-find-interp if execute continue endif
 544       tc-find-tc-instr if
 545           \ dup cfa->nfa id. cr
 546           \ tibstate>r parse-name r>tibstate endcr ." 000:<" type ." >\n"
 547         asmx86:lexer:PrepareLineParser
 548         tc-next-token
 549         execute
 550           \ tibstate>r parse-name r>tibstate endcr ." 001:<" type ." >\n"
 551         continue
 552       endif
 553       2dup " code:" s=ci if 2drop tc-(code-word) continue endif
 554       2dup " $asm" s=ci if 2drop tc-(code-line) continue endif
 555       ;; HACK! check if the next word is equ
 556       next-equ? if tc-(equ) continue endif
 557       ;; try to find a tc word -- this can be a constant, for example
 558       2dup tc-interp-find-tc-word-no-imm if
 559              dup tc-is-constant? if nrot 2drop tc-cfa->pfa tc-@
 560         else dup tc-is-value? if nrot 2drop tc-cfa->pfa tc-@
 561         else dup tc-is-variable? if nrot 2drop tc-cfa->pfa
 562         else drop endcr ." ERROR: uninterpretable tc word \`" type ." \`" abort" wut?!"
 563         endif endif endif
 564       else
 565         ;; try to parse it as a number
 566         2dup number ifnot endcr ." ERROR: unknown tc word \`" type ." \`" abort" wut?!" endif
 567         nrot 2drop
 568       endif
 569     endif
 570   again
 571   2drop
 572   asmx86:asm-Check-Undef-Labels
 573 ;
 574
 575 ;;previous
 576
 577
 578 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 579 : brk-alloc-c4str  ( addr count -- newaddr )
 580   dup 0< ERR-OUT-OF-MEMORY ?error
 581   dup cell+ 1+ brk-alloc  ;; ( addr count newaddr )
 582   dup >r
 583   2dup ! cell+            ;; ( addr count newaddr+4 | newaddr )
 584   2dup + 0c!
 585   swap 0 max cmove
 586   r>
 587 ;
 588
 589
 590 0 value input-file-name
 591 0 value output-file-name
 592
 593
 594 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 595 vocabulary cliargs
 596 also cliargs definitions
 597
 598 : (str-arg)  ( -- addr count true // false )
 599   cli-arg-next argc < ifnot false exit endif
 600   cli-arg-next argv-str cli-arg-skip true
 601 ; (hidden)
 602
 603 : --help  ( -- )
 604   ." known metacompiler cli args:\n"
 605   vocid: cliargs [: ( nfa -- stopflag )
 606     dup nfa->cfa cfa-hidden? ifnot
 607       id-count pad c4s:copy-counted
 608       pad count locase-str
 609       2 spaces pad count type cr
 610     else drop endif
 611     false
 612   ;] foreach-word drop
 613   bye
 614 ;
 615
 616 : --dump-forwards  ( -- ) true to tc-dump-forwards? ;
 617
 618 : --verbose  ( -- )  true to tc-verbose ;
 619 : --no-verbose  ( -- )  false to tc-verbose ;
 620 : --quiet  ( -- )  false to tc-verbose ;
 621
 622 : --tls-none  ( -- )  tc-tls-none to tc-tls-type ;
 623 : --tls-fs  ( -- )  tc-tls-fs to tc-tls-type ;
 624
 625 : --static  ( -- ) false to tc-dynamic-binary ;
 626 : --dynamic  ( -- ) true to tc-dynamic-binary ;
 627
 628 : --align  ( -- ) true to tc-align-headers true to tc-align-cfa true to tc-align-pfa ;
 629 : --no-align  ( -- ) false to tc-align-headers false to tc-align-cfa false to tc-align-pfa ;
 630
 631 : --align-headers  ( -- ) true to tc-align-headers ;
 632 : --no-align-headers  ( -- ) false to tc-align-headers ;
 633
 634 : --align-cfa  ( -- ) true to tc-align-cfa ;
 635 : --no-align-cfa  ( -- ) false to tc-align-cfa ;
 636
 637 : --align-pfa  ( -- ) true to tc-align-pfa ;
 638 : --no-align-pfa  ( -- ) false to tc-align-pfa ;
 639
 640 : --debug  ( -- ) true to tc-debugger-enabled ;
 641 : --no-debug  ( -- ) false to tc-debugger-enabled ;
 642
 643 : --debug-info  ( -- ) true to tc-debug-info-enabled ;
 644 : --no-debug-info  ( -- ) false to tc-debug-info-enabled ;
 645
 646 : --opt-alias  ( -- ) true to tc-opt-aliases? ;
 647 : --no-opt-alias  ( -- ) false to tc-opt-aliases? ;
 648
 649 : --opt-branch  ( -- ) true to tc-opt-branches? ;
 650 : --no-opt-branch  ( -- ) false to tc-opt-branches? ;
 651
 652 : --whash  ( -- )
 653   (str-arg) not-?abort" '--whash' requires hash name"
 654   2dup " elf" s=ci if 2drop tc-nhash-elf to tc-wordhash-type exit endif
 655   2dup " joaat" s=ci if 2drop tc-nhash-joaat to tc-wordhash-type exit endif
 656   2dup " rot" s=ci if 2drop tc-nhash-rot to tc-wordhash-type exit endif
 657   endcr ." \`" type ." \` doesn't look like a known hash name!\n"
 658   1 n-bye
 659 ;
 660
 661 : -i  ( -- )
 662   (str-arg) not-?abort" '-i' requires input file name"
 663   brk-alloc-c4str to input-file-name
 664 ;
 665
 666 : -o  ( -- )
 667   (str-arg) not-?abort" '-o' requires input file name"
 668   brk-alloc-c4str to output-file-name
 669 ;
 670
 671 previous definitions
 672
 673
 674 : parse-cli-args ( -- )
 675   begin cli-arg-next argc < while
 676     cli-arg-next argv-str
 677     vocid: cliargs voc-search if cli-arg-skip execute
 678     else endcr ." ERROR: invalid command line argument: \`" cli-arg-next argv-str type ." \`!\n" 1 n-bye
 679     endif
 680   repeat
 681   ;; set default names
 682   input-file-name ifnot " ../level1/urforth.f" brk-alloc-c4str to input-file-name endif
 683   output-file-name ifnot " urforth" brk-alloc-c4str to output-file-name endif
 684   ;; aligned PFA must be used with aligned CFA
 685   tc-align-pfa if true to tc-align-cfa endif
 686 ;
 687
 688
 689 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 690 parse-cli-args
 691
 692 endcr ." compiling to \`" output-file-name count type ." \`...\n"
 693
 694 ;; create ELF header
 695 elf-target-memory build-elf-header elf-target-memory - elf-base-rva + to elf-current-pc
 696
 697 previous definitions
 698 alias ur-meta:format format
 699
 700 ur-meta:tc-tls-type ur-meta:tc-tls-fs <> to asmx86:asm-ignore-ts
 701
 702 ur-meta:create-elf-tc-constants
 703 ur-meta:tc-define-config-constants
 704
 705 os:gettickcount
 706 ur-meta:input-file-name count tload
 707
 708 ;; set user area size label
 709 " ur_userarea_default_size" ur-meta:tc-userarea-used asmx86:asm-Make-Label
 710 ;; fix dictionary end address
 711 ur-meta:tc-image-vsize ur-meta:elf-reserve-bss
 712
 713
 714 \ asmx86:asm-Dump-Labels
 715 asmx86:asm-Check-Undef-Labels-Final
 716
 717 os:gettickcount swap - endcr ." build time: " . ." msecs, "
 718 ur-meta:tc-created-words-count . ." words defined, "
 719 ur-meta:tc-userarea-used . ." bytes of user area allocated.\n"
 720 [: ur-meta:tc-align-headers-wasted ?dup if . ." bytes wasted on aligned headers.\n" endif ;] execute
 721 [: ur-meta:tc-align-cfa-wasted ?dup if . ." bytes wasted on aligned CFA.\n" endif ;] execute
 722 [: ur-meta:tc-align-pfa-wasted ?dup if . ." bytes wasted on aligned PFA.\n" endif ;] execute
 723
 724 ur-meta:output-file-name count ur-meta:save-elf-binary
 725 [:
 726   endcr ." new " ur-meta:tc-dynamic-binary if ." dynamic" else ." static" endif
 727   ."  binary (using "
 728   ur-meta:tc-wordhash-type case
 729     ur-meta:tc-nhash-elf of ." ELF" endof
 730     ur-meta:tc-nhash-joaat of ." JOAAT" endof
 731     ur-meta:tc-nhash-rot of ." ROT" endof
 732     ." WUTAFUCK?"
 733   endcase
 734   ."  vochash) created: " ur-meta:output-file-name count type
 735   cr
 736 ;] execute
 737
 738 [DEFINED] asm-labman:(mem-allocated) [IF]
 739 asm-labman:(mem-allocated) @ . ." bytes used by assembler\n"
 740 [ENDIF]
 741 .stack
 742 bye