meta/meta-50-tc-imm-10-colon-var.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 ;; colon, semicolon, variable, etc.
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 : tc-(  [compile] ( ;
  11 : tc-\  ( -- )  [compile] \ ;
  12 : tc-(*  ( -- )  [compile] (* ;  ;; *)
  13 [DEFINED] (( [IF]
  14 : tc-((  ( -- )  [compile] (( ;  ;; ))
  15 [ELSE]
  16 : tc-((  ( -- )  forth:skip-comment-multiline-nested ;  ;; ))
  17 [ENDIF]
  18 : tc-;;  ( -- )  [compile] ;; ;
  19 : tc-//  ( -- )  [compile] ;; ;
  20
  21
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 : tc-start-compile-forth-word  ( -- )
  24   tc-(dbginfo-reset)
  25   true to tc-(dbginfo-active?)
  26     \ endcr ."   START FORTH AT 0x" tc-here .hex8 cr
  27   tc-rva-doforth tc-compile-do-call
  28     \ endcr ."   FORTH PFA AT 0x" tc-here .hex8 cr
  29   tc-state 1!
  30   tc-jstack-init
  31 ; (hidden)
  32
  33 : tc-end-compile-forth-word  ( -- )
  34   tc-create;
  35   tc-smudge tc-state 0!
  36   ;; save debug info (this also resets and deactivates it)
  37   tc-(dbginfo-finalize-and-copy)
  38   tc-optimiser:optimise-jumps
  39 ; (hidden)
  40
  41
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 : tc-:
  44   tc-?exec
  45   tc-(dbginfo-reset)
  46   tc-create-header
  47   tc-start-compile-forth-word
  48   ( tc-!csp)
  49   tc-(ctlid-colon)
  50 ;
  51
  52 (* i didn't decided how i should implement macros yet
  53 : tc-macro:
  54   tc-?exec tc-!csp
  55   tc-(dbginfo-reset)
  56   tc-create-header
  57   tc-start-compile-forth-word
  58   tc-!csp
  59   tc-set-macro
  60 ;
  61 *)
  62
  63 ;; this is barely usable now, so it is commented out
  64 ;; it is barely usable because target compiler doesn't fully interpret the source,
  65 ;; so target CFA cannot be used in any meaningful way yet
  66 (*
  67 : tc-:NONAME
  68   tc-?exec
  69   tc-(dbginfo-reset)
  70   NullString tc-(create-header-nocheck) tc-hidden
  71   tc-start-compile-forth-word
  72   tc-latest-cfa
  73   tc-!csp
  74 ;
  75 *)
  76
  77 : tc-;
  78   tc-?comp ( tc-?csp)
  79   tc-(ctlid-colon) tc-(ctlid-does) tc-?any-pair
  80   tc-compile exit
  81   tc-end-compile-forth-word
  82 ;
  83
  84 : tc-DOES>  ( -- pfa )
  85   tc-?comp tc-?non-macro
  86   \ tc-(ctlid-colon) tc-?pairs ( tc-?csp)  ;; make sure that all our conditionals are complete
  87   tc-(ctlid-colon) tc-(ctlid-does) tc-?any-pair
  88   tc-compile latest-cfa
  89   tc-compile (does>)  ;; and compile the real word
  90   tc-align-pfa if tc-check-align-here endif
  91   tc-optimiser:optimise-jumps
  92   tc-jstack-init
  93   tc-(ctlid-does)
  94 ;
  95
  96 : tc-recurse  ( -- )
  97   tc-?comp tc-?non-macro
  98   tc-latest-cfa
  99   tc-compile,
 100 ;
 101
 102
 103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 104 : tc-[:
 105   tc-?comp tc-?non-macro
 106     \ endcr ."   CBLOCK START AT 0x" tc-here .hex8 cr
 107   tc-align-pfa if tc-check-align-here endif
 108   ;; compiling
 109   tc-compile LITCBLOCK
 110     \ endcr ."   CBLOCK AFTER-LIT AT 0x" tc-here .hex8 cr
 111   tc-(mark-j>)
 112   tc-(CTLID-CBLOCK)
 113     \ endcr ."   CBLOCK CODE AT 0x" tc-here .hex8 cr
 114   tc-rva-doforth tc-compile-do-call
 115   tc-jstack-subinit
 116 ;
 117
 118 : tc-;]
 119   tc-?comp
 120   ;; inside a word
 121   tc-(CTLID-CBLOCK) tc-?pairs
 122   tc-compile exit
 123   tc-optimiser:optimise-jumps
 124   tc-(resolve-j>)
 125 ;
 126
 127
 128 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 129 : tc-to  ( value -- )  \ name
 130   " LITTO!" tc-compile,-(str)
 131   parse-name tc-cfa,-(str-raw)
 132 ;
 133
 134 : tc-+to  ( value -- )  \ name
 135   " LIT+TO!" tc-compile,-(str)
 136   parse-name tc-cfa,-(str-raw)
 137 ;
 138
 139 : tc--to  ( value -- )  \ name
 140   " LIT-TO!" tc-compile,-(str)
 141   parse-name tc-cfa,-(str-raw)
 142 ;
 143
 144 : tc-to^  ( -- addr )  \ name
 145   " LIT^TO" tc-compile,-(str)
 146   parse-name tc-cfa,-(str-raw)
 147 ;
 148
 149
 150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 151 ;; scattering colon implementation
 152 ;; based on the idea by M.L. Gassanenko ( mlg@forth.org )
 153 ;; written from scratch by Ketmar Dark
 154 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 155
 156 ;; placeholder for scattered colon
 157 ;; it will compile two branches:
 158 ;; the first branch will jump to the first "..:" word (or over the two branches)
 159 ;; the second branch is never taken, and works as a pointer to the latest branch addr in the list
 160 ;; this way, each extension word will simply fix the last branch address, and update list tail
 161 ;; at the creation time, second branch points to the first branch
 162 : tc-...  ( -- )
 163   tc-?comp tc-?non-macro
 164   tc-latest-cfa \ FIXME: dup word-type? word-type-forth <> ERR-ELLIPSIS-FORTH ?error
 165   tc-cfa->pfa tc-here <> ?abort" ellipsis must be the first word"
 166   tc-compile branch tc-(<j-mark) tc-(mark-j>)
 167   tc-compile branch swap tc-(<j-resolve)
 168   tc-(resolve-j>)
 169   tc-set-scolon
 170 ;
 171
 172
 173 ;; start scattered colon extension code
 174 ;; TODO: better error checking!
 175 ;; this does very simple sanity check, and remembers the address of the tail pointer
 176 : tc-..:  ( -- )  \ word
 177   tc-?exec tc-?non-macro
 178   parse-name x-tc-xcfind-must \ FIXME: dup word-type? word-type-forth <> ERR-ELLIPSIS-FORTH ?error
 179   dup tc-cfa-scolon? not-?abort" scattered colon word expected"
 180   \ FIXME: make check and patch more independed from codegen internals
 181   tc-cfa->pfa \ FIXME: dup @ ['] branch <> ERR-ELLIPSIS-FIRST ?error
 182   2 +cells \ FIXME: dup @ ['] branch <> ERR-ELLIPSIS-FIRST ?error
 183   cell+  ;; pointer to the tail pointer
 184   NullString tc-(create-header-nocheck) tc-hidden tc-start-compile-forth-word tc-latest-cfa \ [compile] :noname
 185   tc-cfa->pfa  ;; :noname leaves our cfa
 186   ( tc-!csp)
 187   tc-(CTLID-SC-COLON)  ;; pttp ourcfa flag
 188 ;
 189
 190 ;; this ends the extension code
 191 ;; it patches jump at which list tail points to jump to our pfa, then
 192 ;; it compiles jump right after the list tail, and then
 193 ;; it updates the tail to point at that jump address
 194 : tc-;..  ( -- )  \ word
 195   tc-?comp tc-?non-macro
 196   tc-(CTLID-SC-COLON) tc-?pairs ( tc-?csp)
 197   ;; ( pttp ourcfa )
 198   over tc-(branch-addr@) tc-(branch-addr!)
 199   >r tc-compile branch tc-here 0 tc-, r@ cell+ swap tc-(branch-addr!)
 200   tc-here cell- r> tc-(branch-addr!)
 201   ;; we're done here
 202   tc-end-compile-forth-word
 203 ;
 204
 205 ;; this ends the extension code
 206 ;; makes the code first in the jump list
 207 ;; jumps to the destination of the first jump
 208 ;; patches the first jump so it points to our nonamed code
 209 ;; patches tail pointer so it points to our jump
 210 : tc-<;..  ( -- )
 211   tc-?comp tc-?non-macro
 212   tc-(CTLID-SC-COLON) tc-?pairs ( tc-?csp)
 213   >r  ;; ( pttp | ourcfa )
 214   ;; get first jump destination
 215   tc-compile branch tc-here 0 tc-,  ;; ( pttp jpatchaddr )
 216   over 2 -cells tc-(branch-addr@) over tc-(branch-addr!)  ;; fix our jump
 217   over 2 -cells r> swap tc-(branch-addr!)  ;; fix first jump
 218   ;; patch original jump if there are no items in scattered chain yet
 219     \ endcr ." pptp:" over .hex8 ."  jpa:" dup .hex8 over compiler:(branch-addr@) ."  pptp-j:" .hex8 cr
 220   over dup tc-(branch-addr@) 2 +cells = if
 221       \ endcr ." !!!patch!\n"
 222     swap tc-(branch-addr!)
 223   else 2drop endif
 224   \ 2drop \ swap compiler:(branch-addr!)
 225   ;; we're done here
 226   tc-end-compile-forth-word
 227 ;