level1/78_compiler_sc_colon.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; scattering colon implementation
   7 ;; based on the idea by M.L. Gassanenko ( mlg@forth.org )
   8 ;; written from scratch by Ketmar Dark
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 ;; placeholder for scattered colon
  12 ;; it will compile two branches:
  13 ;; the first branch will jump to the first "..:" word (or over the two branches)
  14 ;; the second branch is never taken, and works as a pointer to the latest branch addr in the list
  15 ;; this way, each extension word will simply fix the last branch address, and update list tail
  16 ;; at the creation time, second branch points to the first branch
  17 : ...  ( -- )
  18   compiler:?comp compiler:?non-macro
  19   latest-cfa dup word-type? word-type-forth <> ERR-ELLIPSIS-FORTH ?error
  20   cfa->pfa here <> ERR-ELLIPSIS-FIRST ?error
  21   compile branch compiler:(<j-mark) compiler:(mark-j>)
  22   compile branch swap compiler:(<j-resolve)
  23   compiler:(resolve-j>)
  24   (set-scolon)
  25 ; immediate
  26
  27
  28 ;; start scattered colon extension code
  29 ;; TODO: better error checking!
  30 ;; this does very simple sanity check, and remembers the address of the tail pointer
  31 : ..:  ( -- )  \ word
  32   compiler:?exec compiler:?non-macro
  33   -find-required dup word-type? word-type-forth <> ERR-ELLIPSIS-FORTH ?error dup >r
  34   dup cfa-scolon? ERR-ELLIPSIS-FIRST not-?error
  35   ;; more sanity checks, just in case
  36   cfa->pfa dup @ ['] branch <> ERR-ELLIPSIS-FIRST ?error
  37   2 +cells dup @ ['] branch <> ERR-ELLIPSIS-FIRST ?error
  38   cell+  ;; pointer to the tail pointer
  39   ;; create "named noname" for debugger
  40   r> cfa->nfa id-count (:noname-named)
  41   \ [compile] :noname
  42   cfa->pfa ;; :noname leaves our cfa
  43   compiler:!csp
  44   compiler:(CTLID-SC-COLON)  ;; pttp ourpfa flag
  45 ;
  46
  47 ;; this ends the extension code
  48 ;; it patches jump at which list tail points to jump to our pfa, then
  49 ;; it compiles jump right after the list tail, and then
  50 ;; it updates the tail to point at that jump address
  51 : ;..  ( -- )
  52   compiler:?comp compiler:?non-macro
  53   compiler:(CTLID-SC-COLON) compiler:?pairs compiler:?csp
  54   ( pttp ourpfa )  over forth:(dp-protected?) >r
  55   over compiler:(branch-addr@) compiler:(branch-addr!)
  56   >r compile branch here 0 , r@ cell+ swap compiler:(branch-addr!)
  57   here cell- r> compiler:(branch-addr!)
  58   ;; we're done here
  59   compiler:end-compile-forth-word
  60   r> if here forth:(dp-protect) endif
  61 ; immediate
  62
  63
  64 ;; this ends the extension code
  65 ;; makes the code first in the jump list
  66 ;; jumps to the destination of the first jump
  67 ;; patches the first jump so it points to our nonamed code
  68 ;; patches tail pointer so it points to our jump
  69 : <;..  ( -- )
  70   compiler:?comp compiler:?non-macro
  71   compiler:(CTLID-SC-COLON) compiler:?pairs compiler:?csp
  72   ( pttp ourpfa )  over forth:(dp-protected?) >r
  73   >r  ( pttp | ourpfa )
  74   ;; get first jump destination
  75   compile branch here 0 ,  ;; ( pttp jpatchaddr )
  76   over 2 -cells compiler:(branch-addr@) over compiler:(branch-addr!)  ;; fix our jump
  77   over 2 -cells r> swap compiler:(branch-addr!)  ;; fix first jump
  78   ;; patch original jump if there are no items in scattered chain yet
  79     \ endcr ." pptp:" over .hex8 ."  jpa:" dup .hex8 over compiler:(branch-addr@) ."  pptp-j:" .hex8 cr
  80   over dup compiler:(branch-addr@) 2 +cells = if
  81       \ endcr ." !!!patch!\n"
  82     swap compiler:(branch-addr!)
  83   else 2drop endif
  84   \ 2drop \ swap compiler:(branch-addr!)
  85   ;; we're done here
  86   compiler:end-compile-forth-word
  87   r> if here forth:(dp-protect) endif
  88 ; immediate