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