meta/meta-70-tc-interp-20-mem.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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 : ,    ( n -- )  tc-, ;
  10 : w,   ( n -- )  tc-w, ;
  11 : c,   ( n -- )  tc-c, ;
  12
  13 ;; the following can be customized for special builds
  14 : reladdr, ( cfa -- )  tc-reladdr, ;
  15
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 : c@  ( addr -- value )  tc-c@ ;
  19 : w@  ( addr -- value )  tc-w@ ;
  20 : @  ( addr -- value )  tc-@ ;
  21
  22 : c!  ( value addr -- )  tc-c! ;
  23 : w!  ( value addr -- )  tc-w! ;
  24 : !  ( value addr -- )  tc-! ;
  25
  26 : +c!  ( value addr -- )  dup tc-c@ rot + swap tc-c! ;
  27 : +w!  ( value addr -- )  dup tc-w@ rot + swap tc-w! ;
  28 : +!  ( value addr -- )  dup tc-@ rot + swap tc-! ;
  29
  30 : -c!  ( value addr -- )  dup tc-c@ rot - swap tc-c! ;
  31 : -w!  ( value addr -- )  dup tc-w@ rot - swap tc-w! ;
  32 : -!  ( value addr -- )  dup tc-@ rot - swap tc-! ;
  33
  34
  35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36 ;; sorry for this hack!
  37
  38 : constant  ( val -- )  \ name
  39   tc-(?not-enum)
  40   parse-name tc-(constant-header-str) tc-, tc-create;
  41 ;
  42
  43 : var  ( val -- )  \ name
  44   tc-(?not-enum)
  45   parse-name tc-(variable-header-str) tc-, tc-create;
  46 ;
  47
  48 : variable  ( val -- )  \ name
  49   tc-(?not-enum)
  50   parse-name tc-(variable-header-str) 0 tc-, tc-create;
  51 ;
  52
  53 : value  ( val -- )  \ name
  54   parse-name tc-(enum-mode) if
  55     ( etype enextvalue addr count )
  56     tc-(constant-header-str)
  57     dup nrot  ;; for "tc-,"
  58     over ?dup if + else ?dup if 1 lshift else 1 endif endif  ;; advance current value
  59     rot
  60   else
  61     tc-(value-header-str)
  62   endif
  63   tc-, tc-create;
  64 ;
  65
  66
  67 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68 : }  ( etype evalue -- )
  69   tc-(?enum)
  70   2drop false to tc-(enum-mode)
  71 ;
  72
  73 : set      ( etype evalue newvalue -- etype newvalue )  tc-(?enum) nip ;
  74 : set-bit  ( etype evalue newbit -- etype 1<<newbit )  tc-(?enum) nip 1 swap lshift ;
  75 : -set     ( etype evalue delta -- etype evalue-delta ) tc-(?enum) - ;
  76 : +set     ( etype evalue delta -- etype evalue+delta ) tc-(?enum) + ;
  77
  78 : enum{  ( -- etype enextvalue )  tc-(?not-enum) 1 0 true to tc-(enum-mode) ;
  79 : bitenum{  ( -- etype enextvalue )  tc-(?not-enum) 0 1 true to tc-(enum-mode) ;