meta/meta-70-tc-interp-10-comp-flags.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
   8 : ALIAS  ( -- )
   9   parse-name x-tc-xcfind-must
  10   dup >r
  11   parse-name tc-create-header-named tc-smudge
  12   tc-(jmp,)
  13   ;; copy "hidden" and "immediate" flags
  14   r> tc-cfa->ffa tc-ffa@
  15   tc-(wflag-hidden) tc-(wflag-immediate) or and >r
  16   tc-latest-cfa tc-cfa->ffa
  17   dup tc-ffa@ tc-(wflag-hidden) tc-(wflag-immediate) or ~and r> or
  18   swap tc-ffa!
  19   tc-create;
  20 ;
  21
  22
  23 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24 : CREATE  ( -- )
  25   parse-name tc-(variable-header-str)
  26   tc-create;
  27 ;
  28
  29 : CREATE;  ( -- )
  30   tc-create;
  31 ;
  32
  33 : BUFFER:  ( size -- )
  34   parse-name tc-(variable-header-str)
  35   tc-n-allot drop
  36   tc-create;
  37 ;
  38
  39
  40 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41 : (HIDDEN)  ( -- )  tc-hidden ;
  42 : (PUBLIC)  ( -- )  tc-public ;
  43 : (NORETURN)  ( -- )  tc-noreturn ;
  44 : (CODEBLOCK)  ( -- )  tc-codeblock ;
  45 : IMMEDIATE  ( -- )  tc-immediate ;
  46
  47 : (ARG-NONE)    ( -- )  tc-arg-none ;
  48 : (ARG-BRANCH)  ( -- )  tc-arg-branch ;
  49 : (ARG-LIT)     ( -- )  tc-arg-lit ;
  50 : (ARG-C4STRZ)  ( -- )  tc-arg-c4strz ;
  51 : (ARG-CFA)     ( -- )  tc-arg-cfa ;
  52 : (ARG-CBLOCK)  ( -- )  tc-arg-cblock ;
  53 : (ARG-VOCID)   ( -- )  tc-arg-vocid ;
  54 : (ARG-C1STRZ)  ( -- )  tc-arg-c1strz ;
  55 : (ARG-U8)      ( -- )  tc-arg-u8 ;
  56 : (ARG-S8)      ( -- )  tc-arg-s8 ;
  57 : (ARG-U16)     ( -- )  tc-arg-u16 ;
  58 : (ARG-S16)     ( -- )  tc-arg-s16 ;
  59
  60
  61 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62 : error-table-msg,"  ( code -- )  \ msg"
  63   ;; UrForth level 0 uses byte for error code, UrForth level 1 uses 4
  64   tc-,  ;; store code
  65   34 parse dup tc-n-allot tc->real swap move
  66   0 tc-c, ;; terminating zero for the string
  67 ;
  68
  69 : error-table-end  ( -- )
  70   0 tc-,
  71   tc-create;
  72 ;
  73
  74
  75 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76 : ]
  77   tc-state 1!
  78 ;