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) compiler:(ctlid-colon) compiler:?pairs
  41   \ [compile] :noname
  42   cfa->pfa ;; :noname leaves our cfa
  43   compiler:(CTLID-SC-COLON)  ;; pttp ourpfa flag
  44 ;
  45
  46 ;; this ends the extension code
  47 ;; it patches jump at which list tail points to jump to our pfa, then
  48 ;; it compiles jump right after the list tail, and then
  49 ;; it updates the tail to point at that jump address
  50 : ;..  ( -- )
  51   compiler:?comp compiler:?non-macro
  52   compiler:(CTLID-SC-COLON) compiler:?pairs
  53   ( pttp ourpfa )  over forth:(dp-protected?) >r
  54   over compiler:(branch-addr@) compiler:(branch-addr!)
  55   >r compile branch here 0 , r@ cell+ swap compiler:(branch-addr!)
  56   here cell- r> compiler:(branch-addr!)
  57   ;; we're done here
  58   compiler:end-compile-forth-word
  59   r> if here forth:(dp-protect) endif
  60 ; immediate
  61
  62
  63 ;; this ends the extension code
  64 ;; makes the code first in the jump list
  65 ;; jumps to the destination of the first jump
  66 ;; patches the first jump so it points to our nonamed code
  67 ;; patches tail pointer so it points to our jump
  68 : <;..  ( -- )
  69   compiler:?comp compiler:?non-macro
  70   compiler:(CTLID-SC-COLON) compiler:?pairs
  71   ( pttp ourpfa )  over forth:(dp-protected?) >r
  72   >r  ( pttp | ourpfa )
  73   ;; get first jump destination
  74   compile branch here 0 ,  ;; ( pttp jpatchaddr )
  75   over 2 -cells compiler:(branch-addr@) over compiler:(branch-addr!)  ;; fix our jump
  76   over 2 -cells r> swap compiler:(branch-addr!)  ;; fix first jump
  77   ;; patch original jump if there are no items in scattered chain yet
  78     \ endcr ." pptp:" over .hex8 ."  jpa:" dup .hex8 over compiler:(branch-addr@) ."  pptp-j:" .hex8 cr
  79   over dup compiler:(branch-addr@) 2 +cells = if
  80       \ endcr ." !!!patch!\n"
  81     swap compiler:(branch-addr!)
  82   else 2drop endif
  83   \ 2drop \ swap compiler:(branch-addr!)
  84   ;; we're done here
  85   compiler:end-compile-forth-word
  86   r> if here forth:(dp-protect) endif
  87 ; immediate