urflibs/init/bootstrap/25-scolon.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrForth/C Forth Engine!
   4 ;; Copyright (C) 2023 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7 ;; scattered colon implementation
   8 ;; based on the idea by M.L.Gassanenko ( mlg@forth.org )
   9 ;; written from scratch by Ketmar Dark
  10 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11
  12 (*
  13   : word  ... other-forth-code ;
  14
  15   ..: word  more forth code  ;..
  16   ..: word  more forth code  ;..
  17
  18   each "..:" will be executed when "word" is executed, starting
  19   from the last defined. to append as the last one instead the
  20   first one, use "..: word  code  <;..".
  21
  22   note that "..." must always be the first word in a definition.
  23   you cannot use local variables with such words.
  24 *)
  25
  26 also compiler definitions
  27 0xcafef00d constant (ctlid-sc-colon)
  28
  29 : ?cfa-scolon  ( cfa -- )
  30   dup forth-word? " forth word expected" ?not-error
  31   cfa->pfa
  32   dup @ ['] forth:(branch) <> " s-colon word expected" ?error
  33   2 +cells @ ['] forth:(branch) <> " s-colon word expected" ?error
  34 ;
  35
  36 previous definitions
  37 also compiler
  38
  39
  40 ;; placeholder for scattered colon
  41 ;; it will compile two branches:
  42 ;; the first branch will jump to the first "..:" word (or over the two branches)
  43 ;; the second branch is never taken, and works as a pointer to the latest branch addr in the list
  44 ;; this way, each extension word will simply fix the last branch address, and update list tail
  45 ;; at the creation time, second branch points to the first branch
  46 : ...  ( -- )
  47   ?comp
  48   latest-cfa forth-word? " forth word expected" ?not-error
  49   latest-pfa here <> " scattered colon must be first" ?error
  50   \ compiler:colon-word
  51   compile forth:(branch) (<j-mark) (mark-j>)
  52   compile forth:(branch) swap (<j-resolve)
  53   (resolve-j>)
  54   \ (set-scolon)
  55 ; immediate
  56
  57
  58 ;; start scattered colon extension code
  59 ;; TODO: better error checking!
  60 ;; this does very simple sanity check, and remembers the address of the tail pointer
  61 : ..:  ( -- pptp ourpfa compid )  \ word
  62   ?exec
  63   -find-required dup ?cfa-scolon ;; sanity check
  64   cfa->pfa 3 +cells  ;; pointer to the tail pointer
  65   (create-nameless)
  66   cfa->pfa ;; :noname leaves our cfa
  67   (ctlid-sc-colon)  ;; pttp ourpfa flag
  68   [compile] ]   ;; start compilation
  69 ;
  70
  71 ;; s-colon words starts with:
  72 ;; BRANCH xaddr
  73 ;; BRANCH taddr
  74 ;; pptp points to the second branch argument
  75 ;; tadds initially points to the first branch argument
  76
  77 ;; this ends the extension code
  78 ;; it patches jump at which list tail points to jump to our pfa, then
  79 ;; it compiles jump right after the list tail, and then
  80 ;; it updates the tail to point at that jump address
  81 : ;..  ( pptp ourpfa compid -- )
  82   ?comp
  83   (ctlid-sc-colon) ?pairs
  84   ( pptp ourpfa )  \ over forth:(dp-protected?) >r
  85   ;; first: patch first s-colon jump to point to our pfa
  86   over (branch-addr@) (branch-addr!)
  87   ;; second: compile jump to the original word
  88   >r compile forth:(branch) here 0 , ;; branch and its argument
  89   r@ cell+ swap (branch-addr!) ;; patch branch we just compiled
  90   ;; update tail pointer
  91   here cell- r> (branch-addr!)
  92   ;; we're done here
  93   compiler:end-compile-forth-word
  94   \ r> if here forth:(dp-protect) endif
  95 ; immediate
  96
  97
  98 ;; this ends the extension code
  99 ;; makes the code first in the jump list
 100 ;; jumps to the destination of the first jump
 101 ;; patches the first jump so it points to our nonamed code
 102 ;; patches tail pointer so it points to our jump
 103 : <;..  ( pptp ourpfa compid -- )
 104   ?comp
 105   (ctlid-sc-colon) ?pairs
 106   ( pttp ourpfa )  \ over forth:(dp-protected?) >r
 107   >r  ( pttp | ourpfa )
 108   ;; get first jump destination
 109   compile (branch) here 0 ,  ( pttp jpatchaddr )
 110   over 2 -cells (branch-addr@) over (branch-addr!)  ;; fix our jump
 111   over 2 -cells r> swap (branch-addr!)  ;; fix first jump
 112   ;; patch original jump if there are no items in scattered chain yet
 113   over dup (branch-addr@) 2 +cells =  FORTH:(0BRANCH) [ (MARK-J>) ] ;; if
 114     swap (branch-addr!)
 115   FORTH:(BRANCH) [ (MARK-J>) SWAP (RESOLVE-J>) ] ;; else
 116     2drop
 117   [ (RESOLVE-J>) ] ;; endif
 118   ;; we're done here
 119   compiler:end-compile-forth-word
 120   \ r> if here forth:(dp-protect) endif
 121 ; immediate
 122
 123 previous