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   dup cfa->nfa @ compiler:(wflag-scolon) and " s-colon word expected" ?not-error
  32   cfa->pfa
  33   dup @ ['] forth:(branch) <> " s-colon word expected" ?error
  34   2 +cells @ ['] forth:(branch) <> " s-colon word expected" ?error
  35 ;
  36
  37 previous definitions
  38 also compiler
  39
  40
  41 ;; placeholder for scattered colon
  42 ;; it will compile two branches:
  43 ;; the first branch will jump to the first "..:" word (or over the two branches)
  44 ;; the second branch is never taken, and works as a pointer to the latest branch addr in the list
  45 ;; this way, each extension word will simply fix the last branch address, and update list tail
  46 ;; at the creation time, second branch points to the first branch
  47 : ...  ( -- )
  48   ?comp
  49   latest-cfa forth-word? " forth word expected" ?not-error
  50   latest-pfa here <> " scattered colon must be first" ?error
  51   \ compiler:colon-word
  52   compile forth:(branch) (<j-mark) (mark-j>)
  53   compile forth:(branch) swap (<j-resolve)
  54   (resolve-j>)
  55   (wflag-scolon) or-wflags  \ (set-scolon)
  56 ; immediate
  57
  58
  59 ;; start scattered colon extension code
  60 ;; TODO: better error checking!
  61 ;; this does very simple sanity check, and remembers the address of the tail pointer
  62 : ..:  ( -- pptp ourpfa compid )  \ word
  63   ?exec
  64   -find-required dup ?cfa-scolon ;; sanity check
  65   cfa->pfa 3 +cells  ;; pointer to the tail pointer
  66   (create-nameless)
  67   cfa->pfa ;; :noname leaves our cfa
  68   compiler:(start-semi)  ;; pttp ourpfa flag
  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   compiler:(check-semi)
  83   ( pptp ourpfa )  \ over forth:(dp-protected?) >r
  84   ;; first: patch first s-colon jump to point to our pfa
  85   over (branch-addr@) (branch-addr!)
  86   ;; second: compile jump to the original word
  87   >r compile forth:(branch) here 0 , ;; branch and its argument
  88   r@ cell+ swap (branch-addr!) ;; patch branch we just compiled
  89   ;; update tail pointer
  90   here cell- r> (branch-addr!)
  91   ;; we're done here
  92   compiler:(finish)
  93   \ r> if here forth:(dp-protect) endif
  94 ; immediate
  95
  96
  97 ;; this ends the extension code
  98 ;; makes the code first in the jump list
  99 ;; jumps to the destination of the first jump
 100 ;; patches the first jump so it points to our nonamed code
 101 ;; patches tail pointer so it points to our jump
 102 : <;..  ( pptp ourpfa compid -- )
 103   compiler:(check-semi)
 104   ( pttp ourpfa )  \ over forth:(dp-protected?) >r
 105   >r  ( pttp | ourpfa )
 106   ;; get first jump destination
 107   compile (branch) here 0 ,  ( pttp jpatchaddr )
 108   over 2 -cells (branch-addr@) over (branch-addr!)  ;; fix our jump
 109   over 2 -cells r> swap (branch-addr!)  ;; fix first jump
 110   ;; patch original jump if there are no items in scattered chain yet
 111   over dup (branch-addr@) 2 +cells =  forth:(0branch) [ (mark-j>) ] ;; if
 112     swap (branch-addr!)
 113   forth:(branch) [ (mark-j>) swap (resolve-j>) ] ;; else
 114     2drop
 115   [ (resolve-j>) ] ;; endif
 116   ;; we're done here
 117   compiler:(finish)
 118   \ r> if here forth:(dp-protect) endif
 119 ; immediate
 120
 121 previous