meta/meta-40-tc-compiler-30-mid.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 ;; mid-level target compiler words
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 0 var tc-state
  11 0 var tc-(csp)
  12
  13 : tc-!CSP  ( -- )
  14   sp@ tc-(csp) !
  15 ;
  16
  17 : tc-?CSP  ( -- )
  18     \ endcr sp@ .hex8 space tc-(csp) @ .hex8 space  sp@ tc-(csp) @ - . cr
  19   sp@ tc-(csp) @ - err-unfinished-definition ?error
  20 ;
  21
  22 : tc-?COMP  ( -- )
  23   tc-state @ not err-compilation-only ?error
  24 ;
  25
  26 : tc-?NON-MACRO  ( -- )
  27   tc-latest-macro? err-nonmacro-only ?error
  28 ;
  29
  30 : tc-?EXEC  ( -- )
  31   tc-state @ err-execution-only ?error
  32 ;
  33
  34 ;; CSP check for loops
  35 : tc-csp-loop  ( -- )
  36   sp@ tc-(csp) @ u> err-unpaired-conditionals ?error
  37 ;
  38
  39 : tc-?pairs  ( n1 n2 -- )
  40   <> err-unpaired-conditionals ?error
  41 ;
  42
  43 : tc-?any-pair  ( id v0 v1 -- )
  44   >r over <>
  45   swap r> <>
  46   and err-unpaired-conditionals ?error
  47 ;
  48
  49 : tc-?pairs-any-keepid  ( id v0 v1 -- id )
  50   >r over <>  ;; ( id v0<>id | v1 )
  51   over r> <>  ;; ( id v0<>id v1<>id )
  52   and err-unpaired-conditionals ?error
  53 ;
  54
  55
  56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57 ;; usage:
  58 ;;  compile 0branch
  59 ;;  (mark>)
  60 ;;  ...
  61 ;;  (resolve>)
  62 ;;
  63 ;;  (<mark)
  64 ;;  ...
  65 ;;  compile branch
  66 ;;  (<resolve)
  67
  68 ;; write "branch to destaddr" address to addr
  69 : tc-(branch-addr!)  ( rva-destaddr rva-addr -- )  tc-! ;
  70 : tc-(branch-addr@)  ( rva-destaddr -- rva-addr )  tc-@ ;
  71
  72
  73 ;; reserve room for branch address, return addr suitable for "tc-(resolve-j>)"
  74 : tc-(mark-j>)  ( -- rva-addr )
  75   tc-here 0 tc-,
  76 ;
  77
  78 ;; compile "forward jump" from address to HERE
  79 ;; addr is the result of "tc-(mark-j>)"
  80 : tc-(resolve-j>)  ( rva-addr -- )
  81   tc-here swap tc-(branch-addr!)
  82 ;
  83
  84
  85 ;; return addr suitable for "tc-(<j-resolve)"
  86 : tc-(<j-mark)  ( -- rva-addr )
  87   tc-here
  88 ;
  89
  90 ;; patch "forward jump" address to HERE
  91 ;; addr is the result of "tc-(<j-mark)"
  92 : tc-(<j-resolve)  ( rva-addr -- )
  93   cell tc-n-allot tc-(branch-addr!)
  94 ;
  95
  96
  97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98 ;; each of these has one argument
  99 enum{
 100   1 set
 101   value tc-(ctlid-if)  (hidden)
 102   value tc-(ctlid-else)  (hidden)
 103
 104   value tc-(ctlid-begin)  (hidden)
 105   value tc-(ctlid-while)  (hidden)
 106
 107   value tc-(ctlid-case)  (hidden)
 108   value tc-(ctlid-of)  (hidden)
 109   value tc-(ctlid-endof)  (hidden)
 110   value tc-(ctlid-otherwise)  (hidden)
 111
 112   value tc-(ctlid-do)  (hidden)
 113   value tc-(ctlid-do-break)  (hidden)
 114   value tc-(ctlid-do-continue)  (hidden)
 115
 116   value tc-(ctlid-cblock)  (hidden)
 117   value tc-(ctlid-cblock-interp)  (hidden)
 118
 119   value tc-(ctlid-?do)  (hidden)
 120
 121   666 +set
 122   value tc-(CTLID-SC-COLON)  (hidden)
 123 }
 124
 125
 126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 127 ;; jumpcfa-type:
 128 enum{
 129   value tc-type-branch
 130   value tc-type-0branch
 131   value tc-type-tbranch
 132   value tc-type-+0branch
 133   value tc-type--0branch
 134 }
 135
 136 : tc-(compile-typed-branch)  ( jumpcfa-type  -- )
 137   case
 138     tc-type-branch of tc-compile branch endof
 139     tc-type-0branch of tc-compile 0branch endof
 140     tc-type-tbranch of tc-compile tbranch endof
 141     tc-type-+0branch of tc-compile +0branch endof
 142     tc-type--0branch of tc-compile -0branch endof
 143     abort" tc-(compile-typed-branch): wut?!"
 144   endcase
 145 ; (hidden)
 146
 147
 148 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 149 ;; this is NOT immediate!
 150 : tc-LITERAL  ( n -- )
 151   tc-state @ not-?abort" tc-LITERAL: compile-time only!"
 152     \ " FORTH:LIT" tc-compile,-(str) tc-, exit
 153   tc-align-pfa if
 154     dup case
 155        0 of drop " FORTH:LIT0" tc-compile,-(str) endof
 156        1 of drop " FORTH:LIT1" tc-compile,-(str) endof
 157       -1 of drop " FORTH:LIT-1" tc-compile,-(str) endof
 158       " FORTH:LIT" tc-compile,-(str) tc-,
 159     endcase
 160   else
 161     dup case
 162        0 of drop " FORTH:LIT0" tc-compile,-(str) endof
 163        1 of drop " FORTH:LIT1" tc-compile,-(str) endof
 164       -1 of drop " FORTH:LIT-1" tc-compile,-(str) endof
 165            0   256 within-of " FORTH:LITU8" tc-compile,-(str) tc-c, endof
 166         -128   128 within-of " FORTH:LITS8" tc-compile,-(str) tc-c, endof
 167            0 65536 within-of " FORTH:LITU16" tc-compile,-(str) tc-w, endof
 168       -32768 32768 within-of " FORTH:LITS16" tc-compile,-(str) tc-w, endof
 169       " FORTH:LIT" tc-compile,-(str) tc-,
 170     endcase
 171   endif
 172 ; ( immediate )
 173
 174 : tc-(putstrz)  ( addr count rva-dest )
 175   tc->real swap 2dup + >r move r> 0c!
 176 ;
 177
 178 ;; always align after string literals
 179 : tc-align-after-strlit  ( -- )
 180   begin tc-here 3 and while 0 tc-c, repeat
 181 ;
 182
 183 ;; this is NOT immediate!
 184 ;; addr is NOT rva!
 185 : tc-(c4strz)  ( addr count -- )
 186   dup cell+ 1+ tc-n-allot  ;; ( addr count rva-dest )
 187   2dup tc-! cell+
 188   tc-(putstrz) tc-align-after-strlit
 189 ; ( immediate )
 190
 191 ;; this is NOT immediate!
 192 ;; addr is NOT rva!
 193 : tc-(c1strz)  ( addr count -- )
 194   dup 0 255 bounds? not-?abort" invalid c1 string length"
 195   dup 2+ tc-n-allot  ;; ( addr count rva-dest )
 196   2dup tc-c! 1+
 197   tc-(putstrz) tc-align-after-strlit
 198 ; ( immediate )
 199
 200 ;; this is NOT immediate!
 201 ;; addr is NOT rva!
 202 : tc-C4SLITERAL  ( addr count -- )
 203   tc-state @ not-?abort" tc-C4sLITERAL: compile-time only!"
 204   " LITC4STR" tc-compile,-(str)
 205   tc-(c4strz) tc-align-after-strlit
 206 ; ( immediate )
 207
 208 ;; this is NOT immediate!
 209 ;; addr is NOT rva!
 210 ;; generate byte-counted string literal if possible
 211 : tc-SLITERAL  ( addr count -- )
 212   tc-state @ not-?abort" tc-SLITERAL: compile-time only!"
 213   dup 0 255 bounds? if
 214     " LITC1STR" tc-compile,-(str)
 215     tc-(c1strz)
 216   else
 217     " LITC4STR" tc-compile,-(str)
 218     tc-(c4strz)
 219   endif
 220 ; ( immediate )