urflibs/init/bootstrap/50-defer_value.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrAsm Forth Engine!
   4 ;; GPLv3 ONLY
   5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;; DEFER, VALUE, TO
   9 ;;
  10 : VALUE  ( value -- )  COMPILER:(CFAIDX-DO-VALUE) COMPILER:(MK-CONST-VAR) ;
  11 : VALUE?  ( cfa -- bool )  @ COMPILER:(CFAIDX-DO-VALUE) = ;
  12 : VALUE@  ( cfa -- value )  DUP VALUE? " non-value CFA" ?NOT-ERROR  CFA->PFA @ ;
  13 : VALUE!  ( value cfa -- )  DUP VALUE? " non-value CFA" ?NOT-ERROR  CFA->PFA ! ;
  14
  15 : DEFER  ( -- )  ['] NOOP COMPILER:(CFAIDX-DO-DEFER) COMPILER:(MK-CONST-VAR) ;
  16 : DEFER?  ( cfa -- bool )  @ COMPILER:(CFAIDX-DO-DEFER) = ;
  17 : DEFER@  ( cfa -- value )  DUP DEFER? " non-defer CFA" ?NOT-ERROR  CFA->PFA @ ;
  18 : DEFER!  ( value cfa -- )  DUP DEFER? " non-defer CFA" ?NOT-ERROR  CFA->PFA ! ;
  19
  20
  21 ;; ( addr count FALSE -- addr count FALSE / TRUE )
  22 : (TO-EXTENDER) ... ; (HIDDEN)
  23
  24
  25 : (TO-DEFER)  ( n cfa -- )  CFA->PFA ! ; (HIDDEN)
  26 ALIAS FORTH:(TO-DEFER) (TO-VALUE)
  27
  28 : TO  ( n -- )
  29   PARSE-SKIP-COMMENTS PARSE-NAME  DUP " word name expected" ?NOT-ERROR
  30   FALSE (TO-EXTENDER)
  31   IFNOT
  32     2DUP FIND-WORD  ( addr count cfa TRUE / addr count FALSE )
  33     IFNOT  ;; not found
  34       ENDCR SPACE TYPE ." ? -- wut?\n" " word not found" ERROR
  35     ENDIF NROT 2DROP
  36     DUP VALUE? IF
  37       STATE @ IF  ( cfa )
  38         CFALITERAL COMPILE FORTH:(TO-VALUE)
  39       ELSE FORTH:(TO-VALUE)
  40       ENDIF
  41     ELSE
  42       DUP DEFER? IF
  43         STATE @ IF  ( cfa )
  44           CFALITERAL COMPILE FORTH:(TO-DEFER)
  45         ELSE FORTH:(TO-DEFER)
  46         ENDIF
  47       ELSE " 'TO' with non-defer and non-value" ERROR
  48       ENDIF
  49     ENDIF
  50   ENDIF
  51 ; IMMEDIATE
  52
  53
  54 : (TO-READ)  ( -- val )  \ name
  55   PARSE-SKIP-COMMENTS
  56   >IN @ >R -FIND-REQUIRED
  57   STATE @ IF COMPILE, ELSE EXECUTE ENDIF
  58   R> >IN !
  59 ;
  60
  61 : -TO  ( n -- )
  62   (TO-READ)
  63   STATE @ IF COMPILE SWAP COMPILE - ELSE SWAP - ENDIF
  64   [COMPILE] TO
  65 ; IMMEDIATE
  66
  67 : +TO  ( n -- )
  68   (TO-READ)
  69   STATE @ IF COMPILE + ELSE + ENDIF
  70   [COMPILE] TO
  71 ; IMMEDIATE
  72
  73 : +1-TO  ( -- )
  74   1 LITERAL [COMPILE] +TO
  75 ; IMMEDIATE
  76
  77 : -1-TO  ( -- )
  78   -1 LITERAL [COMPILE] +TO
  79 ; IMMEDIATE
  80
  81 : 0-TO  ( -- )
  82   0 STATE @ IF LITERAL ENDIF
  83   [COMPILE] TO
  84 ; IMMEDIATE
  85
  86
  87 ;; 2012 crap
  88 : IS ( defer-cfa -- )  \ name
  89   STATE @ IF  [COMPILE] ['] COMPILE DEFER!
  90   ELSE ' DEFER!
  91   ENDIF
  92 ; IMMEDIATE
  93
  94 : ACTION-OF ( -- cfa )  \ name
  95   STATE @ IF  [COMPILE] ['] COMPILE DEFER@
  96   ELSE ' DEFER@
  97   ENDIF
  98 ; IMMEDIATE
  99
 100
 101 \ .( +++ test VALUEs +++\n)
 102 \ 69 VALUE vtest
 103 \ vtest . cr
 104 \ 666 TO vtest
 105 \ vtest . cr
 106
 107 \ : vtxc  69 TO vtest ;
 108 \ DEBUG:DECOMPILE vtxc
 109 \ vtxc
 110 \ vtest . cr