level0/syssrc/create-and-voc-replace-override.f

   1 ;; Native x86 GNU/Linux Forth System, Direct Threaded Code
   2 ;; advanced vocabulary manipulation and creation words
   3 ;;
   4 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   5 ;;
   6 ;; This program is free software: you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation, version 3 of the License ONLY.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 ;; returns vocabulary latest-ptr
  20 : VOCID:  ( -- addr )  \ name
  21   -find-required
  22   dup word-type? WORD-TYPE-VOC <> ERR-VOCABULARY-EXPECTED ?error
  23   ;; ( cfa )
  24   state @ if
  25     [compile] cfaliteral
  26     compile voc-cfa->vocid
  27   else
  28     voc-cfa->vocid
  29   endif
  30 ; immediate
  31
  32
  33 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34 ;; word overriding mechanics
  35 ;; this is different from REPLACE -- you can call old word if you want to
  36
  37 ;; get xtoken for the previous override, to use in override chain
  38 ;; if the word is not overriden, returns 0
  39 : (GET-OVERRIDE-OLDCFA)  ( oldcfa -- xtoken // 0 )
  40   dup word-type? WORD-TYPE-OVERRIDEN =
  41   if
  42     1+ (disp32@) cfa->pfa
  43   else
  44     drop 0
  45   endif
  46 ;
  47
  48 : (OVERRIDE-OLDCFA-NEWCFA)  ( oldcfa newcfa -- )
  49   ;; check if newcfa is a Forth word
  50   dup word-type? WORD-TYPE-FORTH <> err-cannot-override ?error
  51   ;; check if oldcfa is a Forth word, or an overriden word
  52   ;; override chain works right for overriden words
  53   over word-type? dup WORD-TYPE-FORTH =
  54   ;; ( oldcfa newcfa wtype forth-flag )
  55   if
  56     drop
  57     ;; fix new word CFA to use par_urforth_nocall_dooverride
  58     ['] (URFORTH-DOOVERRIDE-CODEBLOCK) over (call!)
  59     ;; fix old word CFA so it will call new CFA instead
  60     swap (call!)
  61   else
  62     ;; override chain
  63     ;; ( oldcfa newcfa wtype )
  64     WORD-TYPE-OVERRIDEN <> err-cannot-override ?error
  65     ;; fix new word CFA to use par_urforth_nocall_dooverride
  66     ['] (URFORTH-DOOVERRIDE-CODEBLOCK) over (call!)
  67     ;; fix old word CFA so it will call new CFA instead
  68     swap (call!)
  69   endif
  70 ;
  71
  72 : OVERRIDE  ( -- )  \ oldword newword
  73   -find-required
  74   -find-required
  75   (override-oldcfa-newcfa)
  76 ;
  77
  78 ;; get xtoken for the previous override, to use in override chain
  79 ;; if the word is not overriden, returns 0
  80 : GET-OVERRIDE  ( -- xtoken // 0 )  \ oldword
  81   -find-required
  82   (get-override-oldcfa)
  83 ;