urflibs/init/bootstrap/50-defer_value.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
   8 (*
   9 it is possible to extend "TO" for your own words. there are two scattered
  10 colon definitions for that.
  11
  12   ;; ( addr count FALSE -- addr count FALSE / TRUE )
  13   : (TO-EXTENDER) ... ; (HIDDEN)
  14
  15 this will be called before "TO" tried to find a word. if you processed
  16 everything by yourself, remove `addr` and `count`, and return TRUE.
  17 otherwise don't touch anything.
  18
  19 ;; ( cfa FALSE -- cfa FALSE / TRUE )
  20 : (TO-EXTENDER-FOUND) ... ; (HIDDEN)
  21
  22 this will be called after "TO" succesfully found a word.
  23
  24
  25 please, note that you have to start your extensions with code like this:
  26
  27   ?DUP IFNOT
  28     your code here
  29   ENDIF
  30
  31 i.e. don't do anything if some other extension already processed the
  32 request.
  33
  34 *)
  35
  36 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37 ;; DEFER, VALUE, TO
  38 ;;
  39 : VALUE  ( value -- )  COMPILER:(CFAIDX-DO-VALUE) COMPILER:(MK-CONST-VAR) ;
  40 : VALUE?  ( cfa -- bool )  @ COMPILER:(CFAIDX-DO-VALUE) = ;
  41 : VALUE@  ( cfa -- value )  DUP VALUE? " non-value CFA" ?NOT-ERROR  CFA->PFA @ ;
  42 : VALUE!  ( value cfa -- )  DUP VALUE? " non-value CFA" ?NOT-ERROR  CFA->PFA ! ;
  43
  44 : DEFER  ( -- )  ['] NOOP COMPILER:(CFAIDX-DO-DEFER) COMPILER:(MK-CONST-VAR) ;
  45 : DEFER?  ( cfa -- bool )  @ COMPILER:(CFAIDX-DO-DEFER) = ;
  46 : DEFER@  ( cfa -- value )  DUP DEFER? " non-defer CFA" ?NOT-ERROR  CFA->PFA @ ;
  47 : DEFER!  ( value cfa -- )  DUP DEFER? " non-defer CFA" ?NOT-ERROR  CFA->PFA ! ;
  48
  49
  50 ;; called before trying to find a word
  51 ;; ( addr count FALSE -- addr count FALSE / TRUE )
  52 : (TO-EXTENDER) ... ; (HIDDEN)
  53
  54 ;; called after the word was found
  55 ;; ( cfa FALSE -- cfa FALSE / TRUE )
  56 : (TO-EXTENDER-FOUND) ... ; (HIDDEN)
  57
  58
  59 : (TO-DEFER)  ( n cfa -- )  CFA->PFA ! ; (HIDDEN)
  60 ALIAS FORTH:(TO-DEFER) (TO-VALUE)
  61
  62 ;; "TO" for values
  63 ..: (TO-EXTENDER-FOUND)  ( cfa FALSE -- cfa FALSE / TRUE )
  64   ?DUP IFNOT
  65     DUP VALUE? IF
  66       STATE @ IF CFALITERAL COMPILE FORTH:(TO-VALUE)
  67       ELSE FORTH:(TO-VALUE)
  68       ENDIF
  69       TRUE
  70     ELSE FALSE
  71     ENDIF
  72   ENDIF
  73 ;..
  74
  75 ;; "TO" for defers
  76 ..: (TO-EXTENDER-FOUND)  ( cfa FALSE -- cfa FALSE / TRUE )
  77   ?DUP IFNOT
  78     DUP DEFER? IF
  79       STATE @ IF CFALITERAL COMPILE FORTH:(TO-DEFER)
  80       ELSE FORTH:(TO-DEFER)
  81       ENDIF
  82       TRUE
  83     ELSE FALSE
  84     ENDIF
  85   ENDIF
  86 ;..
  87
  88
  89 : TO  ( n -- )
  90   PARSE-SKIP-COMMENTS PARSE-NAME  DUP " word name expected" ?NOT-ERROR
  91   FALSE (TO-EXTENDER)
  92   IFNOT
  93     2DUP FIND-WORD  ( addr count cfa TRUE / addr count FALSE )
  94     IFNOT  ;; not found
  95       ENDCR SPACE TYPE ." ? -- wut?\n" " word not found" ERROR
  96     ENDIF NROT 2DROP
  97     FALSE (TO-EXTENDER-FOUND) " trying to use 'TO' with something strange" ?NOT-ERROR
  98   ENDIF
  99 ; IMMEDIATE
 100
 101
 102 : (TO-READ)  ( -- val )  \ name
 103   PARSE-SKIP-COMMENTS
 104   >IN @ >R -FIND-REQUIRED
 105   STATE @ IF COMPILE, ELSE EXECUTE ENDIF
 106   R> >IN !
 107 ;
 108
 109 : -TO  ( n -- )
 110   (TO-READ)
 111   STATE @ IF COMPILE SWAP COMPILE - ELSE SWAP - ENDIF
 112   [COMPILE] TO
 113 ; IMMEDIATE
 114
 115 : +TO  ( n -- )
 116   (TO-READ)
 117   STATE @ IF COMPILE + ELSE + ENDIF
 118   [COMPILE] TO
 119 ; IMMEDIATE
 120
 121 : +1-TO  ( -- )
 122   1 LITERAL [COMPILE] +TO
 123 ; IMMEDIATE
 124
 125 : -1-TO  ( -- )
 126   -1 LITERAL [COMPILE] +TO
 127 ; IMMEDIATE
 128
 129 : 0-TO  ( -- )
 130   0 STATE @ IF LITERAL ENDIF
 131   [COMPILE] TO
 132 ; IMMEDIATE
 133
 134
 135 ;; 2012 crap
 136 : IS ( defer-cfa -- )  \ name
 137   STATE @ IF  [COMPILE] ['] COMPILE DEFER!
 138   ELSE ' DEFER!
 139   ENDIF
 140 ; IMMEDIATE
 141
 142 : ACTION-OF ( -- cfa )  \ name
 143   STATE @ IF  [COMPILE] ['] COMPILE DEFER@
 144   ELSE ' DEFER@
 145   ENDIF
 146 ; IMMEDIATE
 147
 148
 149 \ .( +++ test VALUEs +++\n)
 150 \ 69 VALUE vtest
 151 \ vtest . cr
 152 \ 666 TO vtest
 153 \ vtest . cr
 154
 155 \ : vtxc  69 TO vtest ;
 156 \ DEBUG:DECOMPILE vtxc
 157 \ vtxc
 158 \ vtest . cr