forth.forth

   1 \ This program is free software: you can redistribute it and/or modify
   2 \ it under the terms of the GNU General Public License as published by
   3 \ the Free Software Foundation, either version 3 of the License, or
   4 \ (at your option) any later version.
   5 \
   6 \ This program is distributed in the hope that it will be useful,
   7 \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   8 \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   9 \ GNU General Public License for more details.
  10 \
  11 \ You should have received a copy of the GNU General Public License
  12 \ along with this program.  If not, see <http://www.gnu.org/licenses/>.
  13
  14 \ word EXECUTE 12 define
  15 16500 execute WORD 16500 29 execute
  16 word DEFINE 29 29 execute
  17 word RINIT 3 define
  18 word NOOP 13 define
  19 word MODE 14336 define
  20 word EXECUTE-WORD 16680 define
  21 word EXECUTE-NUM 16720 define
  22 word INTERPRET 16400 define
  23 word KEY 5 define
  24 word WORD-START 20 define
  25 word WORD-PUT 19 define
  26 word WORD-END 23 define
  27 word STRING-START 39 define
  28 word STRING-PUT 40 define
  29 word STRING-END 41 define
  30 word NUMBER 22 define
  31 word FIND 21 define
  32 word FIND-DOES 44 define
  33 word DEFINE-DOES 45 define
  34 word QUIT 16384 define
  35 word BYE 25 define
  36 word WORDS 27 define
  37 word CHANNEL-IN 35 define
  38 word CHANNEL-OUT 48 define
  39 word CHANNEL-OPEN 51 define
  40 word CHANNEL-AWAIT 50 define
  41 word !HERE 36 define
  42 word HERE 28 define
  43
  44 word STACKTRACE 46 define
  45 word FETCH 47 define
  46
  47 word ; 1 define
  48 word JZ: 14 define
  49 word JNZ: 15 define
  50 word J-1: 24 define
  51 word JMP: 18 define
  52 word , 33 define
  53 word + 7 define
  54 word - 34 define
  55 word =? 37 define
  56 word WS? 17 define
  57 word . 9 define
  58 word .S 38 define
  59 word @ 10 define
  60 word @8_u 53 define
  61 word @+ 42 define
  62 word ! 11 define
  63 word !+ 43 define
  64 word LIT 2 define
  65 word DUP 6 define
  66 word 2DUP 30 define
  67 word DROP 16 define
  68 word 2DROP 32 define
  69 word SWAP 26 define
  70 word ROT 31 define
  71
  72 \ ' "TICK" returns address of word's execution semantics
  73 word ' here define
  74 word word find , word find find , word ; find ,
  75
  76 \ : "COLON" sets execution semantics
  77 word : here define
  78 word : here define-does
  79 ' word , ' here , ' define , ' ; ,
  80
  81 \ :> "DOES" sets compilation semantics
  82 word :> here define-does
  83 : :> ' word , ' here , ' define-does , ' ; ,
  84
  85 \ ::> "COLON DOES" sets execution and compilation semantics
  86 word ::> here define-does
  87 word ::> here define
  88 ' word , ' 2dup , ' here , ' define-does , ' here , ' define , ' ; ,
  89
  90 \ write the execution semantics of a word to memory
  91 : MEMORIZE-WORD ' dup , ' JNZ: , here 12 + , ' 2drop , ' ; ,
  92 ' 2dup , ' find , ' dup , ' JZ: , here 16 + , ' , , ' 2drop , ' ; ,
  93 ' drop , ' lit , ' lit , ' , , ' execute-num , ' , , ' ; ,
  94
  95 \ change interpreter semantics to "memorize-word"
  96 ::> MEMORIZING ' lit , ' mode , ' lit , ' memorize-word , ' ! , ' ; ,
  97
  98 \ memorize the compiler
  99 \memorizing
 100 \: executing lit mode lit execute-word ! ;
 101 \: FINISH-" drop string-end ;
 102 \: BSLASH-" drop key string-put JMP: \here \8 \+ \,
 103 \: " string-start \: KLOOP key 92 =? JNZ: bslash-" 34 =? JNZ: finish-" string-put JMP: KLOOP
 104 \: DO"    \:> " " swap lit lit , , lit lit , , ;
 105 \: DOIF   \:> IF lit JZ: , here dup , ;
 106 \: DOELSE \:> ELSE lit JMP: , here dup , swap here ! ;
 107 \: DOTHEN \:> THEN here ! ;
 108 \: COMPILE-WORD dup
 109 \doif 2dup find-does dup
 110   \doif rot 2drop execute ;
 111   \dothen drop 2dup find dup
 112   \doif , 2drop ;
 113   \dothen drop lit lit , execute-num , ;
 114 \dothen 2drop \do" Compilation Error: null word" .s bye
 115 \: compiling lit mode lit compile-word ! ;
 116
 117 \ compile the rest of the compiler
 118 \compiling
 119
 120 \ ; "RET" compilation semantics: ends a function and returns to executing mode
 121 :> ; lit \' ; \, , lit \' ; \, , executing \' ; \,
 122
 123 \ ;; "SEMIRET" compilation semantics: simply writes a return instruction
 124 :> ;; lit \' ; \, , ;
 125
 126 \ <: "OVERLOAD COLON" extend previous execution semantics of word
 127 ::> <: \compiling word 2dup find dup if here swap , define else drop here define
 128 then compiling ;
 129
 130 \ <:> "OVERLOAD COLON DOES" extend previous compilation semantics of word
 131 ::> <:> \compiling word 2dup find-does dup if here swap , define-does else drop
 132 here define-does then compiling ;
 133
 134 \ execution semantics of COLON, DOES, and COLON DOES now extended to
 135 \ automatically switch to compilation mode
 136 <: : compiling ;
 137 <: :> compiling ;
 138 <: ::> compiling ;
 139
 140 \ Multi-line comments
 141 ::> ( key 41 =? swap -1 =? swap drop + if ;; then JMP: \' ( \, ;
 142
 143 (
 144   End of bootstrap process
 145   beyond this point, all hope is lost
 146 )
 147
 148 \ Set the number conversion base
 149 : BASE 14348 swap ! ;
 150 : BASE10 10 base ;
 151
 152 \ TICK compilation semantics
 153 :> ' lit lit , word find , ;
 154 \ "TICK DOES" (get compilation semantics execution token)
 155 : '> word find-does ;
 156 :> '> word find-does , ;
 157
 158 \ CHAR
 159 : CHAR: word drop @8_u ;
 160 :> CHAR: lit lit , ' char: execute , ;
 161
 162 \ JSON Compiler
 163 : JSON-CTRL-CHAR? char: { =? if 1 ;; then
 164                   char: } =? if 1 ;; then
 165                   char: [ =? if 1 ;; then
 166                   char: ] =? if 1 ;; then
 167                   0 ;
 168 : JSON-PARSE-V ;
 169 : JSON-PARSE-" ;
 170 : JSON-PARSE-[ ;
 171 : JSON-PARSE-{ ;
 172 : JSON-WORD word-start key JSON-CTRL-CHAR? if word-end ;; then ws?   ;
 173
 174 : JSON{ key ;
 175
 176 \ Include a remote file
 177 : REQUIRE" ' quit channel-open dup \' " \, fetch channel-await ;
 178
 179 \ Let's try it
 180 REQUIRE" { \"url\": \"forth/test-watfor.forth\" }"
 181
 182 \ Print intro string
 183 " watForth-32 Interactive CLI:
 184 " .s