meta/meta-50-tc-imm-20-compile-tick.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 ;; some compilers
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 : tc-compile  ( -- )  \ word
  11   parse-name tc-cfa,-(str)
  12   " COMPILE," tc-compile,-(str)
  13 ;
  14
  15 : tc-[compile]  ( -- )  \ word
  16   parse-name tc-compile,-(str)
  17 ;
  18
  19 : tc-[']  ( -- )  \ word
  20   parse-name tc-cfa,-(str)
  21 ;
  22
  23 : tc-[execute-tail]  ( -- )  \ word
  24   tc-state @ not-?abort" [execute-tail] is compile-time only!"
  25   " LIT-EXECTAIL" tc-compile,-(str)
  26   parse-name tc-cfa,-(str-raw)
  27 ;
  28
  29 : tc-[char]  ( -- )  \ char
  30   parse-name 1 = not-?abort" character expected"
  31   c@ tc-literal
  32 ;
  33
  34 : tc-(parse-unescape-str)  ( -- addr count )
  35   34 parse 2dup here swap move nip here swap str-unescape
  36 ;
  37
  38 : tc-"  ( -- )  ;; "
  39   tc-(parse-unescape-str)
  40   tc-SLITERAL
  41 ;
  42
  43 alias tc-" tc-s"
  44
  45 : tc-."  ( -- )  ;; "
  46   tc-state @ not-?abort" tc-.\`: compile-time only!"
  47   " (.\`)" tc-compile,-(str)
  48   tc-(parse-unescape-str)
  49   tc-(c1strz)
  50 ;
  51
  52 : tc-vocid:  ( -- ) // ( -- vocid )  \ vocname
  53   tc-state @ not-?abort" tc-.\`: compile-time only!"
  54   parse-name x-tc-xcfind-must
  55   dup tc-cfa->ffa tc-ffa@ tc-(wflag-vocab) and not-?abort" not a vocabulary"
  56   tc-voc-cfa->vocid tc-literal
  57 ;
  58
  59
  60 : tc-TRUE   ( -- 1 ) tc-state @ if " FORTH:LIT-TRUE" tc-compile,-(str) else true endif ;
  61 : tc-FALSE  ( -- 1 ) tc-state @ if " FORTH:LIT-FALSE" tc-compile,-(str) else false endif ;
  62
  63 : tc-[  tc-state 0! ;
  64
  65 : tc-LITERAL  ( -- ) [compile] tc-literal ;