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