urflibs/init/bootstrap/01-colon-semicolon.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 ;; colon and semicolon
  10 ;;
  11
  12 ;; some compiler helpers
  13
  14 ;; LATEST-CFA
  15 ;; ( -- latest-lfa )
  16 " LATEST-LFA" COMPILER:(WFLAG-PROTECTED) COMPILER:(CREATE-WORD-HEADER)
  17 COMPILER:(CFAIDX-DO-FORTH) , ]
  18   CURRENT @ COMPILER:(VOCOFS-LATEST) + @ FORTH:(EXIT)
  19 [  ;; return to interpreter mode (we don't have a semicolon yet)
  20
  21 ;; NOOP
  22 ;; ( -- )
  23 " NOOP" COMPILER:(WFLAG-PROTECTED) COMPILER:(CREATE-WORD-HEADER)
  24 COMPILER:(CFAIDX-DO-FORTH) , ]
  25   FORTH:(EXIT)
  26 [  ;; return to interpreter mode (we don't have a semicolon yet)
  27 ;; we need it's address
  28 LATEST-LFA LFA->CFA
  29
  30
  31 ;; define in COMPILER
  32 COMPILER FORTH:CONTEXT FORTH:@ FORTH:CURRENT FORTH:!
  33
  34 FORTH:" (CTLID-COLON)" COMPILER:(WFLAG-PROTECTED) COMPILER:(CREATE-WORD-HEADER)
  35 COMPILER:(CFAIDX-DO-CONST) FORTH:, 0xdeadfeed FORTH:,
  36
  37
  38 FORTH:DROP  ;; drop "NOOP" CFA
  39
  40
  41 ;; define in FORTH again
  42 FORTH:FORTH FORTH:CONTEXT FORTH:@ FORTH:CURRENT FORTH:!
  43
  44
  45 ;; define tick (we'll need it later)
  46 ;; ( -- cfa )  \ name
  47 " '" COMPILER:(WFLAG-PROTECTED) COMPILER:(CREATE-WORD-HEADER)
  48 COMPILER:(CFAIDX-DO-FORTH) , ]
  49   PARSE-NAME 2DUP FIND-WORD FORTH:(TBRANCH) [ HERE 0 , ]
  50     ;; not found
  51     ENDCR SPACE TYPE " ? -- wut?\n" TYPE  " word not found" ERROR
  52   [ HERE SWAP ! ]
  53   NROT 2DROP
  54   FORTH:(EXIT)
  55 [  ;; return to interpreter mode (we don't have a semicolon yet)
  56
  57 ;; define colon
  58 " :" COMPILER:(WFLAG-PROTECTED) COMPILER:(CREATE-WORD-HEADER)
  59 COMPILER:(CFAIDX-DO-FORTH) , ]
  60   COMPILER:?EXEC PARSE-NAME
  61   ;; sanitise default word flags
  62   FORTH:(NEW-WORD-FLAGS) @  COMPILER:(WFLAG-HIDDEN) COMPILER:(WFLAG-PROTECTED) OR AND
  63   ;; create smudged words
  64   COMPILER:(WFLAG-SMUDGE) OR  COMPILER:(CREATE-WORD-HEADER)
  65   ;; set CFA
  66   COMPILER:(CFAIDX-DO-FORTH) FORTH:,
  67   ;; push flag for semicolon
  68   COMPILER:(CTLID-COLON)
  69   ;; turn on the compiler
  70   ]
  71   ;; we're done
  72   FORTH:(EXIT)
  73 [  ;; return to interpreter mode (we don't have a semicolon yet)
  74
  75 ;; define semicolon
  76 " ;" COMPILER:(WFLAG-PROTECTED) COMPILER:(WFLAG-IMMEDIATE) OR COMPILER:(CREATE-WORD-HEADER)
  77 COMPILER:(CFAIDX-DO-FORTH) , ]
  78   COMPILER:?COMP COMPILER:(CTLID-COLON) <> " primary imbalance" ?ERROR
  79   ;; call "EXIT"
  80   [ ' FORTH:EXIT , ]  ;; because it is immediate
  81   ;; fix smudge
  82   LATEST-LFA LFA->NFA  DUP @ COMPILER:(WFLAG-SMUDGE) BITNOT AND SWAP !
  83   ;; compile "[" (it is immediate)
  84   [ ' [ , ]
  85   ;; we're done
  86   FORTH:(EXIT)
  87 [  ;; return to interpreter mode (we don't have a semicolon yet)
  88
  89 ;; <protected-words>
  90 (NEW-WORD-FLAGS) @ COMPILER:(WFLAG-PROTECTED) OR (NEW-WORD-FLAGS) !
  91
  92 : ALIAS  ( -- )  \ oldword newword
  93   FORTH:' >R  ;; we'll need CFA later
  94   ;; create new word
  95   PARSE-NAME
  96   R@ CFA->NFA @ 0xffff_00_00 AND  ;; get word flags
  97   COMPILER:(CREATE-WORD-HEADER)
  98   ;; set CFA
  99   COMPILER:(CFAIDX-DO-FORTH) FORTH:,
 100   ;; execute original CFA, as tail-call
 101   [ ' FORTH:(LITCFA) , ' FORTH:(LITCFA) , ] FORTH:, R> FORTH:,
 102   [ ' FORTH:(LITCFA) , ' EXECUTE-TAIL , ] FORTH:,
 103 ;
 104
 105 \ : LATEST-LFA  ( -- lfa )  CURRENT @ COMPILER:(VOCOFS-LATEST) + @ ;
 106 : LATEST-CFA  ( -- cfa )  LATEST-LFA LFA->CFA ;
 107 : LATEST-PFA  ( -- pfa )  LATEST-LFA LFA->PFA ;
 108 : LATEST-NFA  ( -- nfa )  LATEST-LFA LFA->NFA ;
 109
 110 : ~AND  ( a b -- a&~b )  BITNOT AND ;
 111
 112 : SWAP!  ( addr value -- )  SWAP ! ;
 113 : OR!    ( value addr -- )  DUP @ ROT OR SWAP! ;
 114 : ~AND!  ( value addr -- )  DUP @ ROT ~AND SWAP! ;
 115 : XOR!   ( value addr -- )  DUP @ ROT XOR SWAP! ;
 116
 117 : IMMEDIATE  ( -- )  COMPILER:(WFLAG-IMMEDIATE) LATEST-NFA XOR! ;
 118 : (HIDDEN)  ( -- )  COMPILER:(WFLAG-HIDDEN) LATEST-NFA OR! ;
 119 : (PUBLIC)  ( -- )  COMPILER:(WFLAG-HIDDEN) LATEST-NFA ~AND! ;
 120
 121 ;; now we can define words with the usual mechanics
 122 ALIAS ' -FIND-REQUIRED
 123
 124 : PARSE-SKIP-COMMENTS  ( -- )  TRUE (PARSE-SKIP-COMMENTS) ;
 125 ;; only single-line
 126 : PARSE-SKIP-LINE-COMMENTS  ( -- )  FALSE (PARSE-SKIP-COMMENTS) ;
 127
 128
 129 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 130 ;; wordlist utils
 131 ;;
 132
 133 : (SET-DEF-WORD-FLAGS)   ( flg -- )  (NEW-WORD-FLAGS) @ OR (NEW-WORD-FLAGS) ! ; (HIDDEN)
 134 : (RESET-DEF-WORD-FLAGS) ( flg -- )  (NEW-WORD-FLAGS) @ SWAP BITNOT AND (NEW-WORD-FLAGS) ! ; (HIDDEN)
 135
 136 : <PUBLIC-WORDS>  ( -- )  COMPILER:(WFLAG-HIDDEN) FORTH:(RESET-DEF-WORD-FLAGS) ;
 137 : <HIDDEN-WORDS>  ( -- )  COMPILER:(WFLAG-HIDDEN) FORTH:(SET-DEF-WORD-FLAGS) ;
 138 : <UNPROTECTED-WORDS>  ( -- )  COMPILER:(WFLAG-PROTECTED) FORTH:(RESET-DEF-WORD-FLAGS) ;
 139 : <PROTECTED-WORDS>  ( -- )  COMPILER:(WFLAG-PROTECTED) FORTH:(SET-DEF-WORD-FLAGS) ;
 140
 141 : ONLY  ( -- )  0 (VSP!) ;
 142 : ALSO  ( -- )  CONTEXT @ (VSP@) (VSP-AT!) (VSP@) 1 + (VSP!) ;
 143 : PREVIOUS  ( -- )  (VSP@) 1 - DUP (VSP!)  (VSP-AT@) CONTEXT ! ;
 144 : DEFINITIONS  ( -- )  CONTEXT @ CURRENT ! <PUBLIC-WORDS> ;
 145
 146
 147 ALSO DEBUG DEFINITIONS
 148
 149 : DECOMPILE  ( -- )  \ wordname
 150   -FIND-REQUIRED (DECOMPILE-CFA)
 151 ;
 152
 153 PREVIOUS DEFINITIONS
 154
 155 \ DEBUG:DECOMPILE DEBUG:DECOMPILE
 156
 157
 158 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 159 ;; we need a way to compile an immediate string literal
 160 ;;
 161
 162 : IMM-STRLITERAL  STRLITERAL ; IMMEDIATE
 163
 164 ;; for NFAs
 165 : ID-COUNT ( addr -- addr count )  DUP C@ SWAP 4 + SWAP  ;