├── README.md ├── .gitattributes ├── license.txt ├── TransForth.fsproj ├── .gitignore └── Program.fs /README.md: -------------------------------------------------------------------------------- 1 | TransForth 2 | ========== 3 | 4 | Forth interpreter in F# (the name inspired by [Transmeta](https://en.wikipedia.org/wiki/Transmeta) code morph abilities). 5 | 6 | See: https://docs.microsoft.com/en-us/archive/blogs/ashleyf/forth-love-if-honk-then 7 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp 6 | *.sln merge=union 7 | *.csproj merge=union 8 | *.vbproj merge=union 9 | *.fsproj merge=union 10 | *.dbproj merge=union 11 | 12 | # Standard to msysgit 13 | *.doc diff=astextplain 14 | *.DOC diff=astextplain 15 | *.docx diff=astextplain 16 | *.DOCX diff=astextplain 17 | *.dot diff=astextplain 18 | *.DOT diff=astextplain 19 | *.pdf diff=astextplain 20 | *.PDF diff=astextplain 21 | *.rtf diff=astextplain 22 | *.RTF diff=astextplain 23 | -------------------------------------------------------------------------------- /license.txt: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Ashley Nathan Feniello 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /TransForth.fsproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Debug 5 | x86 6 | 8.0.30703 7 | 2.0 8 | {e9ac3d3b-a874-4905-87c5-28af94de647b} 9 | Exe 10 | TransForth 11 | TransForth 12 | v4.0 13 | Client 14 | TransForth 15 | 16 | 17 | true 18 | full 19 | false 20 | false 21 | bin\Debug\ 22 | DEBUG;TRACE 23 | 3 24 | x86 25 | bin\Debug\TransForth.XML 26 | 27 | 28 | pdbonly 29 | true 30 | true 31 | bin\Release\ 32 | TRACE 33 | 3 34 | x86 35 | bin\Release\TransForth.XML 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 56 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ################# 2 | ## Eclipse 3 | ################# 4 | 5 | *.pydevproject 6 | .project 7 | .metadata 8 | bin/ 9 | tmp/ 10 | *.tmp 11 | *.bak 12 | *.swp 13 | *~.nib 14 | local.properties 15 | .classpath 16 | .settings/ 17 | .loadpath 18 | 19 | # External tool builders 20 | .externalToolBuilders/ 21 | 22 | # Locally stored "Eclipse launch configurations" 23 | *.launch 24 | 25 | # CDT-specific 26 | .cproject 27 | 28 | # PDT-specific 29 | .buildpath 30 | 31 | 32 | ################# 33 | ## Visual Studio 34 | ################# 35 | 36 | ## Ignore Visual Studio temporary files, build results, and 37 | ## files generated by popular Visual Studio add-ons. 38 | 39 | # User-specific files 40 | *.suo 41 | *.user 42 | *.sln.docstates 43 | 44 | # Build results 45 | 46 | [Dd]ebug/ 47 | [Rr]elease/ 48 | x64/ 49 | build/ 50 | [Bb]in/ 51 | [Oo]bj/ 52 | 53 | # MSTest test Results 54 | [Tt]est[Rr]esult*/ 55 | [Bb]uild[Ll]og.* 56 | 57 | *_i.c 58 | *_p.c 59 | *.ilk 60 | *.meta 61 | *.obj 62 | *.pch 63 | *.pdb 64 | *.pgc 65 | *.pgd 66 | *.rsp 67 | *.sbr 68 | *.tlb 69 | *.tli 70 | *.tlh 71 | *.tmp 72 | *.tmp_proj 73 | *.log 74 | *.vspscc 75 | *.vssscc 76 | .builds 77 | *.pidb 78 | *.log 79 | *.scc 80 | 81 | # Visual C++ cache files 82 | ipch/ 83 | *.aps 84 | *.ncb 85 | *.opensdf 86 | *.sdf 87 | *.cachefile 88 | 89 | # Visual Studio profiler 90 | *.psess 91 | *.vsp 92 | *.vspx 93 | 94 | # Guidance Automation Toolkit 95 | *.gpState 96 | 97 | # ReSharper is a .NET coding add-in 98 | _ReSharper*/ 99 | *.[Rr]e[Ss]harper 100 | 101 | # TeamCity is a build add-in 102 | _TeamCity* 103 | 104 | # DotCover is a Code Coverage Tool 105 | *.dotCover 106 | 107 | # NCrunch 108 | *.ncrunch* 109 | .*crunch*.local.xml 110 | 111 | # Installshield output folder 112 | [Ee]xpress/ 113 | 114 | # DocProject is a documentation generator add-in 115 | DocProject/buildhelp/ 116 | DocProject/Help/*.HxT 117 | DocProject/Help/*.HxC 118 | DocProject/Help/*.hhc 119 | DocProject/Help/*.hhk 120 | DocProject/Help/*.hhp 121 | DocProject/Help/Html2 122 | DocProject/Help/html 123 | 124 | # Click-Once directory 125 | publish/ 126 | 127 | # Publish Web Output 128 | *.Publish.xml 129 | *.pubxml 130 | 131 | # NuGet Packages Directory 132 | ## TODO: If you have NuGet Package Restore enabled, uncomment the next line 133 | #packages/ 134 | 135 | # Windows Azure Build Output 136 | csx 137 | *.build.csdef 138 | 139 | # Windows Store app package directory 140 | AppPackages/ 141 | 142 | # Others 143 | sql/ 144 | *.Cache 145 | ClientBin/ 146 | [Ss]tyle[Cc]op.* 147 | ~$* 148 | *~ 149 | *.dbmdl 150 | *.[Pp]ublish.xml 151 | *.pfx 152 | *.publishsettings 153 | 154 | # RIA/Silverlight projects 155 | Generated_Code/ 156 | 157 | # Backup & report files from converting an old project file to a newer 158 | # Visual Studio version. Backup files are not needed, because we have git ;-) 159 | _UpgradeReport_Files/ 160 | Backup*/ 161 | UpgradeLog*.XML 162 | UpgradeLog*.htm 163 | 164 | # SQL Server files 165 | App_Data/*.mdf 166 | App_Data/*.ldf 167 | 168 | ############# 169 | ## Windows detritus 170 | ############# 171 | 172 | # Windows image file caches 173 | Thumbs.db 174 | ehthumbs.db 175 | 176 | # Folder config file 177 | Desktop.ini 178 | 179 | # Recycle Bin used on file shares 180 | $RECYCLE.BIN/ 181 | 182 | # Mac crap 183 | .DS_Store 184 | 185 | 186 | ############# 187 | ## Python 188 | ############# 189 | 190 | *.py[co] 191 | 192 | # Packages 193 | *.egg 194 | *.egg-info 195 | dist/ 196 | build/ 197 | eggs/ 198 | parts/ 199 | var/ 200 | sdist/ 201 | develop-eggs/ 202 | .installed.cfg 203 | 204 | # Installer logs 205 | pip-log.txt 206 | 207 | # Unit test / coverage reports 208 | .coverage 209 | .tox 210 | 211 | #Translations 212 | *.mo 213 | 214 | #Mr Developer 215 | .mr.developer.cfg 216 | -------------------------------------------------------------------------------- /Program.fs: -------------------------------------------------------------------------------- 1 | open System 2 | open System.IO 3 | open System.Text 4 | 5 | let mem = Array.create 65536 0 6 | let s = 0 // data stack 7 | let r = 1 // return stack 8 | let h = 2 // dictionary pointer 9 | let l = 3 // latest pointer 10 | mem.[h] <- 0x0400 11 | mem.[s] <- 0xF000 12 | mem.[r] <- 0x10000 13 | mem.[l] <- mem.[h] 14 | let append v = mem.[mem.[h]] <- v; mem.[h] <- mem.[h] + 1 15 | let appendat v = let at = mem.[h] in append v; at 16 | 17 | let push' reg value = mem.[reg] <- mem.[reg] - 1; mem.[mem.[reg]] <- value 18 | let pop' reg () = mem.[reg] <- mem.[reg] + 1; mem.[mem.[reg] - 1] 19 | let push = push' s 20 | let pop = pop' s 21 | let rpush = push' r 22 | let rpop = pop' r 23 | 24 | let header (name : string) = 25 | let link = mem.[l] 26 | mem.[l] <- mem.[h] 27 | let len = name.Length 28 | append len 29 | for i in [0..2] do 30 | append (if len > i then int name.[i] else 0) 31 | append link 32 | let lnka addr = addr + 4 33 | let cfa addr = addr + 5 34 | let find (name : string) = 35 | let rec find' addr = 36 | if addr = 0x0400 // first cell is DOSEMI 37 | then -1 else 38 | let len = name.Length 39 | if mem.[addr] &&& 0x7FFFFFFF = len then 40 | if (len < 1 || mem.[addr + 1] = int name.[0]) && (len < 2 || mem.[addr + 2] = int name.[1]) && (len < 3 || mem.[addr + 3] = int name.[2]) 41 | then addr else find' mem.[lnka addr] 42 | else find' mem.[lnka addr] 43 | find' mem.[l] 44 | let immediate () = mem.[mem.[l]] <- mem.[mem.[l]] ||| 0x80000000 45 | let isimmediate addr = mem.[addr] &&& 0x80000000 = 0x80000000 46 | 47 | let convertbool b = if b then -1 else 0 48 | 49 | let dyadic fn = pop () |> fn (pop ()) |> push // applied in infix order 50 | let comp fn = dyadic (fun a b -> fn a b |> convertbool) 51 | 52 | let mutable (out : TextWriter) = null 53 | let print v = out.Write(v.ToString()); out.Write(' ') 54 | let dot = (pop >> print) 55 | 56 | let mutable (inp : TextReader) = null 57 | let token () = 58 | let isWhiteSpace = char >> Char.IsWhiteSpace 59 | while inp.Peek() |> isWhiteSpace do 60 | inp.Read() |> ignore 61 | let word = new StringBuilder() 62 | while inp.Peek() |> isWhiteSpace |> not && inp.Peek() <> -1 do 63 | word.Append(inp.Read() |> char) |> ignore 64 | word.ToString() 65 | 66 | let create () = token () |> header 67 | 68 | let load () = push mem.[pop ()] 69 | let store () = mem.[pop ()] <- pop () 70 | 71 | let mutable interactive = true 72 | let dointeractive () = interactive <- true 73 | let docompiling () = interactive <- false 74 | let isinteractive () = convertbool interactive |> push 75 | 76 | let comment term = 77 | while inp.Peek() |> char <> term do 78 | inp.Read() |> ignore 79 | inp.Read() |> ignore 80 | 81 | let _HALT = -1 82 | let IMMEDIATE = 9 // TODO 83 | let ADD = 25 84 | let MULT = 26 85 | let DIV = 14 86 | let MOD = 4 87 | let NAND = 5 88 | let GREATER = 6 89 | let EQUAL = 7 90 | let DOT = 8 91 | let NEXT = 0 92 | let CREATE = 10 93 | let VARIABLE = 11 94 | let LOAD = 12 95 | let STORE = 13 96 | let LIT = 3 97 | let BRANCH = 15 98 | let ZEROBRANCH = 16 99 | let TICK = 17 100 | let INTERACTIVE = 19 // TODO: MODE 101 | let COMPILING = 20 // TODO: MODE 102 | let COMMENTLINE = 22 103 | let COMMENTBLOCK = 23 104 | let DOVAR = 24 105 | let DOCOL = 1 106 | let DOSEMI = 2 107 | let APPENDDOCOLON = 27 108 | let APPENDSEMI = 28 109 | let KEY = 29 110 | let ECHO = 30 111 | let FIND = 31 112 | let EXEC = 32 113 | let ISINTERACITVE = 33 114 | let LITADDR = 34 115 | let LSH = 35 116 | let RSH = 36 117 | let UM = 37 118 | let DEBUG = 999 119 | 120 | let SEMI_ADDR = appendat DOSEMI 121 | let HALT_INST = appendat _HALT 122 | let HALT_ADDR = appendat HALT_INST; // don't need SEMI; will halt anyway 123 | 124 | let variable () = create (); append DOVAR; append 0; append NEXT 125 | let appendsemi () = append SEMI_ADDR 126 | let appenddocolon () = append DOCOL 127 | 128 | let mutable i = 0 129 | let mutable w = 0 130 | let mutable p = 0 131 | 132 | let next () = w <- mem.[i]; i <- i + 1; p <- w 133 | let docol () = rpush i; i <- w + 1; next () 134 | let dosemi () = i <- rpop (); next () 135 | 136 | let primitive name code = header name; append code; append NEXT 137 | let primitivecfa name code = primitive name code; cfa mem.[l] 138 | let LIT_ADDR = primitivecfa "LIT" LIT 139 | let litaddr () = push LIT_ADDR 140 | 141 | let branch () = i <- mem.[i] 142 | let zerobranch () = if pop() = 0 then i <- mem.[i] else i <- i + 1 143 | 144 | let dolit () = push mem.[i]; i <- i + 1 145 | let tick () = append LIT_ADDR; append (token() |> find |> cfa) 146 | let dovar () = push p; p <- p + 1 147 | 148 | let key () = 149 | if inp.Peek() = -1 then 150 | printf "ok\n>" 151 | inp <- new StringReader(Console.ReadLine() + Environment.NewLine) 152 | inp.Read() |> push 153 | let echo () = pop () |> char |> out.Write 154 | 155 | let findtok () = 156 | let sb = new StringBuilder() 157 | let len = mem.[mem.[h]] 158 | let tok = mem.[h] + 1 159 | for i in [tok..tok + len - 1] do 160 | mem.[i] |> char |> sb.Append |> ignore 161 | sb.ToString() |> find |> push 162 | 163 | let debug () = printfn "DEBUG: %A" (Array.rev mem.[mem.[s]..0xF000-1]) 164 | 165 | let um () = 166 | use file = File.Open(@"C:\Users\ashley.feniello\Desktop\SkyFolder\Projects\UM-32\bin\Debug\transforth.um", FileMode.Create) 167 | //use file = File.Open(@"C:\Users\ashleyf\Desktop\SkyFolder\Projects\UM-32\bin\Debug\transforth.um", FileMode.Create) 168 | for i in pop () .. pop () do 169 | let m = mem.[i] 170 | m >>> 24 |> byte |> file.WriteByte 171 | m >>> 16 |> byte |> file.WriteByte 172 | m >>> 8 |> byte |> file.WriteByte 173 | m |> byte |> file.WriteByte 174 | 175 | let rec exec () = 176 | let c = pop () |> cfa 177 | p <- c 178 | w <- c 179 | i <- HALT_ADDR 180 | execute () 181 | 182 | and execinline () = 183 | let c = pop () |> cfa 184 | p <- c 185 | w <- c 186 | rpush i 187 | execute () 188 | 189 | and execute () = 190 | let instruction = mem.[p] 191 | p <- p + 1 192 | match instruction with 193 | | -1 -> () 194 | | 0 -> next () 195 | | 1 -> docol () 196 | | 2 -> dosemi () 197 | | 3 -> dolit () 198 | | 4 -> dyadic (%) 199 | | 5 -> dyadic (fun a b -> ~~~(a &&& b)) 200 | | 6 -> comp (>) 201 | | 7 -> comp (=) 202 | | 8 -> dot () 203 | | 9 -> immediate () 204 | | 10 -> create () 205 | | 11 -> variable () 206 | | 12 -> load () 207 | | 13 -> store () 208 | | 14 -> dyadic (/) 209 | | 15 -> branch () 210 | | 16 -> zerobranch () 211 | | 17 -> tick () 212 | | 19 -> dointeractive () 213 | | 20 -> docompiling () 214 | | 22 -> comment '\n' 215 | | 23 -> comment ')' 216 | | 24 -> dovar () 217 | | 25 -> dyadic (+) 218 | | 26 -> dyadic (*) 219 | | 27 -> appenddocolon () 220 | | 28 -> appendsemi () 221 | | 29 -> key () 222 | | 30 -> echo () 223 | | 31 -> findtok () 224 | | 32 -> execinline () 225 | | 33 -> isinteractive () 226 | | 34 -> litaddr () 227 | | 35 -> dyadic (<<<) 228 | | 36 -> dyadic (>>>) 229 | | 37 -> um () 230 | | 999 -> debug () 231 | | _ -> failwith "Unknown instruction" 232 | if instruction <> -1 then execute () 233 | 234 | primitive "IMMEDIATE" IMMEDIATE 235 | primitive "+" ADD 236 | primitive "*" MULT 237 | primitive "/" DIV 238 | primitive "MOD" MOD 239 | primitive "NAND" NAND 240 | primitive ">" GREATER 241 | primitive "=" EQUAL 242 | primitive "." DOT 243 | primitive "VARIABLE" VARIABLE 244 | primitive "@" LOAD 245 | primitive "!" STORE 246 | primitive "BRANCH" BRANCH 247 | primitive "0BRANCH" ZEROBRANCH 248 | primitive "'" TICK; immediate () 249 | primitive "\\" COMMENTLINE; immediate () 250 | primitive "(" COMMENTBLOCK; immediate () 251 | primitive "KEY" KEY 252 | primitive "ECHO" ECHO 253 | primitive "FIND" FIND 254 | primitive "EXEC" EXEC 255 | primitive "ISINTERACITVE" ISINTERACITVE 256 | primitive "LITADDR" LITADDR 257 | primitive "LSH" LSH 258 | primitive "RSH" RSH 259 | primitive "UM" UM 260 | primitive "$" DEBUG 261 | 262 | let INTERACTIVE_ADDR = primitivecfa "INTERACTIVE" INTERACTIVE in immediate () 263 | let APPENDDOCOLON_ADDR = primitivecfa "APPENDDOCOLON" APPENDDOCOLON 264 | let APPENDSEMI_ADDR = primitivecfa "APPENDSEMI" APPENDSEMI 265 | let CREATE_ADDR = primitivecfa "CREATE" CREATE 266 | let COMPILING_ADDR = primitivecfa "COMPILING" COMPILING 267 | 268 | let rep () = 269 | while inp.Peek() <> -1 do 270 | let word = token () 271 | if word.Length > 0 then 272 | match find word with 273 | | -1 -> // literal? 274 | let number, value = Int32.TryParse word 275 | if number then 276 | if interactive then push value else append LIT_ADDR; append value 277 | else word + "?" |> failwith 278 | | d -> 279 | if interactive || isimmediate d 280 | then push d; exec () 281 | else cfa d |> append 282 | let reps source = inp <- new StringReader(source); rep () 283 | 284 | header ";"; append DOCOL; append APPENDSEMI_ADDR; append INTERACTIVE_ADDR; append SEMI_ADDR; immediate () 285 | header ":"; append DOCOL; append CREATE_ADDR; append APPENDDOCOLON_ADDR; append COMPILING_ADDR; append SEMI_ADDR 286 | 287 | out <- Console.Out 288 | reps " 289 | : S 0 ; 290 | : R 1 ; 291 | : H 2 ; 292 | : L 3 ; 293 | : S0 61439 ; \ 0xF000 - 1 294 | : HERE H @ ; 295 | : LATEST L @ ; 296 | : SP@ S @ ; 297 | : NEGATE -1 * ; 298 | : - ( a b -- diff) NEGATE + ; 299 | : 1+ 1 + ; 300 | : 1- 1 - ; 301 | : DEPTH ( -- n) S0 SP@ - ; 302 | : CLEAR ( --) S0 1+ S ! ; 303 | : DROP ( a -- ) SP@ 1+ S ! ; 304 | : , ( v --) HERE ! HERE 1+ H ! ; 305 | : BEGIN HERE ; IMMEDIATE 306 | : UNTIL ' 0BRANCH , , ; IMMEDIATE 307 | : PICK SP@ + 1+ @ ; 308 | : OVER ( a b -- a b a) 1 PICK ; 309 | : 2DUP ( a b -- a b a b) OVER OVER ; 310 | : 2+ 2 + ; 311 | : 2- 2 - ; 312 | : 2* 2 * ; 313 | : 2/ 2 / ; 314 | : DUP ( a -- a a) 0 PICK ; 315 | : >R R @ DUP DUP 1- R ! @ R @ ! ! ; 316 | : R> R @ 1+ @ R @ @ R @ 1+ ! R @ 1+ R ! ; 317 | : R@ R @ 1+ @ ; 318 | : ROLL SP@ 1+ + DUP @ >R BEGIN DUP >R 1- DUP @ R> ! DUP SP@ 2+ = UNTIL DROP R> SP@ 1+ ! ; 319 | : ? @ . ; 320 | : ROT ( a b c -- b c a) 2 ROLL ; 321 | : SWAP ( a b -- b a) 1 ROLL ; 322 | : +! ( add a -- ) DUP @ ROT + SWAP ! ; 323 | : ++! ( a -- a++) DUP @ 1+ SWAP ! ; 324 | : COUNTER 2* 3 + R @ + @ ; 325 | : I 0 COUNTER ; 326 | : J 1 COUNTER ; 327 | : K 2 COUNTER ; 328 | : -ROT ( a b c -- c a b) ROT ROT ; 329 | : NIP ( a b -- b) SWAP DROP ; 330 | : TUCK ( a b -- b a b) SWAP OVER ; 331 | : 2DROP ( a b -- ) DROP DROP ; 332 | : 3DROP ( a b c -- ) 2DROP DROP ; 333 | : 2OVER ( a b c d -- a b c d a b) 3 PICK 3 PICK ; 334 | : 3DUP ( a b c -- a b c a b c) DUP 2OVER ROT ; 335 | : SQUARE ( a -- a^2) DUP * ; 336 | : CUBE ( a -- a^3) DUP DUP * * ; 337 | : /MOD ( a b -- rem quot) 2DUP MOD -ROT / ; 338 | : TRUE ( -- t) -1 ; \ normally constant 339 | : FALSE ( -- f) 0 ; \ normally constant 340 | : NOT ( a -- ~a) DUP NAND ; 341 | : AND ( a b -- a&b) NAND NOT ; 342 | : OR ( a b -- a|b) NOT SWAP NOT NAND ; 343 | : NOR ( a b -- ~a|b) OR NOT ; 344 | : XOR ( a b -- a^b) 2DUP AND -ROT NOR NOR ; 345 | : XNOR ( a b -- ~a^b) XOR NOT ; 346 | : < ( a b -- a -ROT = OR NOT ; 347 | : <= ( a b -- a<=b) 2DUP < -ROT = OR ; 348 | : >= ( a b -- a>=b) 2DUP > -ROT = OR ; 349 | : <> ( a b -- ?) = NOT ; 350 | : 0> 0 > ; 351 | : 0= 0 = ; 352 | : 0< 0 < ; 353 | : 0<> 0 <> ; 354 | : IF ' 0BRANCH , HERE 0 , ; IMMEDIATE 355 | : ELSE ' BRANCH , HERE 0 , SWAP HERE SWAP ! ; IMMEDIATE 356 | : THEN HERE SWAP ! ; IMMEDIATE 357 | : ABS ( n -- |n|) DUP 0< IF NEGATE THEN ; 358 | : MIN 2DUP > IF SWAP THEN DROP ; 359 | : MAX 2DUP < IF SWAP THEN DROP ; 360 | : WHILE ' 0BRANCH , HERE 0 , ; IMMEDIATE 361 | : REPEAT ' BRANCH , HERE 1+ SWAP ! , ; IMMEDIATE 362 | : LEAVE ' BRANCH , HERE SWAP 0 , ; IMMEDIATE 363 | : DO HERE ' >R , ' >R , ; IMMEDIATE 364 | : LOOP ' R> , ' R> , ' 1+ , ' 2DUP , ' = , ' 0BRANCH , , ' 2DROP , ; IMMEDIATE 365 | : +LOOP ' R> , ' R> , ' ROT , ' + , ' 2DUP , ' = , ' 0BRANCH , , ' 2DROP , ; IMMEDIATE 366 | : .S SP@ 1- S0 2DUP < IF DO I @ . -1 +LOOP ELSE 2DROP THEN ; 367 | : CRLF 13 ECHO 10 ECHO ; 368 | : SP 32 ; 369 | : DUMP ( m n -- ) DO I . I @ . CRLF LOOP ; 370 | : ?DELIM ( v d -- v ?) 2DUP SP = IF >= ELSE = THEN ; 371 | : ?WS SP ?DELIM ; 372 | : SKIPWS KEY ?WS IF DROP SKIPWS THEN ; \ leaves first non-whitespace char on stack 373 | : TOKEN ( delim -- tok) >R HERE 1+ R@ SP = 374 | IF SKIPWS ELSE KEY THEN BEGIN 375 | OVER ! 1+ KEY R@ ?DELIM 376 | UNTIL R> 2DROP HERE - 1- HERE ! ; 377 | : WORD SP TOKEN ; 378 | : CFA ( addr -- c) 5 + ; 379 | : LINKA ( addr -- l) 4 + ; 380 | : HEADER WORD LATEST HERE LINKA ! HERE L ! HERE CFA H ! ; 381 | : FORGET WORD FIND DUP H ! LINKA @ L ! ; 382 | : TOKENCHARS ( -- b a) HERE HERE @ + 1+ HERE 1+ ; 383 | : 0-ASCII 48 ; 384 | : 9-ASCII 57 ; 385 | : ?DIGIT ( c -- c ?) DUP 0-ASCII >= OVER 9-ASCII <= AND ; 386 | : ?NUMBER 0 TRUE TOKENCHARS DO I @ ?DIGIT SWAP >R AND SWAP 10 * R> + 0-ASCII - SWAP LOOP DUP NOT IF SWAP DROP THEN ; 387 | : ?FOUND ( w -- ?) DUP 0 >= ; 388 | : HIGHBIT -2147483648 ; 389 | : ISIMMEDIATE ( addr -- ?) @ HIGHBIT AND HIGHBIT = ; 390 | : OUTER WORD FIND ?FOUND IF 391 | DUP ISIMMEDIATE ISINTERACTIVE OR 392 | IF EXEC ELSE CFA , THEN 393 | ELSE 394 | DROP ?NUMBER IF 395 | ISINTERACTIVE NOT IF LITADDR , , THEN 396 | ELSE 397 | 63 ECHO SP ECHO \ ? 398 | THEN 399 | THEN 400 | OUTER ; 401 | 402 | 403 | \ UM-32 Assembler - see: http://www.boundvariable.org/task.shtml 404 | 405 | : ORIGIN 32768 ; 406 | 407 | VARIABLE target 408 | ORIGIN target ! 409 | 410 | : m, target @ ! target ++! ; 411 | 412 | : msave target @ 1- ORIGIN UM ; 413 | 414 | : instruction, ( cbai-m ) 22 LSH OR 3 LSH OR 3 LSH OR m, ; 415 | 416 | : cmove, ( abc-m ) 0 instruction, ; \ c = b if a 417 | : fetch, ( abc-m ) 1 instruction, ; \ c = b[a] 418 | : store, ( abc-m ) 2 instruction, ; \ c[b] = a 419 | : add, ( abc-m ) 3 instruction, ; \ c = b + a 420 | : mult, ( abc-m ) 4 instruction, ; \ c = b * a 421 | : div, ( abc-m ) 5 instruction, ; \ c = b / a 422 | : nand, ( abc-m ) 6 instruction, ; \ c = b ~& a 423 | : halt, ( -m ) 0 0 0 7 instruction, ; 424 | : alloc, ( ab-m ) 0 8 instruction, ; \ new(b) -> a 425 | : free, ( a-m ) 0 0 9 instruction, ; 426 | : echo, ( a-m ) 0 0 10 instruction, ; 427 | : key, ( a-m ) 0 0 11 instruction, ; 428 | : loadjump, ( ab-m ) 0 12 instruction, ; \ load(b), jump(a) 429 | 430 | : literal, ( va -- m ) 13 3 LSH OR 25 LSH OR m, ; \ a = v 431 | 432 | : z 0 ; \ Zero constant register 433 | : t 1 ; \ Internal temp register 434 | : y 2 ; \ Temp register 435 | 436 | : jump, ( a-m ) z loadjump, ; \ jump(a) (uses t) 437 | 438 | : move, ( ab-m ) 1 t literal, t -ROT cmove, ; \ b = a (uses t) 439 | : inc, ( a-m ) DUP 1 t literal, t SWAP add, ; \ a++ (uses t) 440 | : not, ( ab-m ) SWAP DUP ROT nand, ; \ b = ~a 441 | : neg, ( ab-m ) DUP -ROT not, inc, ; \ b = -a (uses t, indirectly) 442 | : sub, ( abc-m ) 2 PICK DUP neg, -ROT add, ; \ c = b - a (uses t, indirectly) 443 | : dec, ( a-m ) 0 t literal, t t t nand, DUP t SWAP add, ; \ a-- (uses t) 444 | 445 | : address target @ ORIGIN - ; 446 | : branch, ( a-m ) y literal, y jump, ; \ jump to a (uses y and t, indirectly) 447 | : 0branch, ( ab-m ) y literal, address 1+ y cmove, y jump, ; \ if a = 0, jump to b (uses y and t) 448 | 449 | : forward target @ 0 ; \ leave target address on stack for later patching 450 | : tohere DUP @ address OR SWAP ! ; \ patch previous forward branch, 451 | 452 | : chr WORD HERE 1+ @ ; 453 | 454 | \ Inner Interpreter 455 | 456 | : x 3 ; \ Temp register 457 | : w 4 ; \ Working register 458 | : i 5 ; \ Interpreter register 459 | : s 6 ; \ Stack (data) register 460 | : r 7 ; \ Return stack register 461 | 462 | : push, ( ab-m ) \ b.push(a) 463 | DUP 464 | dec, \ b-- 465 | z store, \ M[b] = a 466 | ; 467 | 468 | : pop, ( ab-m ) \ b = a.pop() 469 | OVER SWAP 470 | z SWAP \ aazb 471 | fetch, \ b = M[a] 472 | inc, \ a++ 473 | ; 474 | 475 | forward branch, \ over dictionary 476 | 477 | \ 00000 60 y literal 478 | \ 00001 z y loadjump 479 | 480 | \ enter 481 | 482 | VARIABLE &enter address &enter ! 483 | 484 | i r push, \ r.push(i) 485 | 2 t literal, t w i add, \ i = w + 8 (skip over enter,) 486 | \ falls through to next, 487 | 488 | \ 00002 0 t literal 489 | \ 00003 t t t nand 490 | \ 00004 r t r add 491 | \ 00005 z r i store 492 | \ 00006 2 t literal 493 | \ 00007 i w t add 494 | 495 | : enter, &enter @ x literal, x jump, ; 496 | 497 | \ next 498 | 499 | VARIABLE &next address &next ! 500 | 501 | i z w fetch, \ w = M[i] 502 | i inc, \ i++ 503 | w jump, 504 | 505 | \ 00008 w z i fetch 506 | \ 00009 1 t literal 507 | \ 00010 i t i add 508 | \ 00011 z w loadjump 509 | 510 | : next, &next @ x literal, x jump, ; 511 | 512 | \ Dictionary 513 | 514 | VARIABLE &exit address &exit ! 515 | r i pop, \ i = r.pop() 516 | next, 517 | 518 | \ 00012 i z r fetch 519 | \ 00013 1 t literal 520 | \ 00014 r t r add 521 | \ 00015 8 x literal 522 | \ 00016 z x loadjump 523 | 524 | VARIABLE &lit address &lit ! 525 | i z y fetch, \ y = M[i] 526 | y s push, \ s.push(y) 527 | i inc, \ i++ 528 | next, 529 | 530 | \ 00017 y z i fetch 531 | \ 00018 0 t literal 532 | \ 00019 t t t nand 533 | \ 00020 s t s add 534 | \ 00021 z s y store 535 | \ 00022 1 t literal 536 | \ 00023 i t i add 537 | \ 00024 8 x literal 538 | \ 00025 z x loadjump 539 | 540 | VARIABLE &pick address &pick ! 541 | s y pop, \ y = s.pop() 542 | s x move, \ x = s 543 | y x x add, \ x = x + y 544 | x z x fetch, \ x = M[x] 545 | x s push, \ s.push(x) 546 | next, 547 | 548 | \ 00026 y z s fetch 549 | \ 00027 1 t literal 550 | \ 00028 s t s add 551 | \ 00029 1 t literal 552 | \ 00030 x s t cmove 553 | \ 00031 x x y add 554 | \ 00032 x z x fetch 555 | \ 00033 0 t literal 556 | \ 00034 t t t nand 557 | \ 00035 s t s add 558 | \ 00036 z s x store 559 | \ 00037 8 x literal 560 | \ 00038 z x loadjump 561 | 562 | VARIABLE &add address &add ! \ TODO: More efficient 563 | s y pop, \ y = s.pop() 564 | s z x fetch, \ x = M[s] 565 | y x x add, \ x = x + y 566 | x s z store, \ M[s] = x 567 | next, 568 | \ s y pop, \ y = s.pop() 569 | \ s x pop, \ x = s.pop() 570 | \ y x x add, \ x = x + y 571 | \ x s push, \ s.push(x) 572 | \ next, 573 | 574 | \ 00039 y z s fetch 575 | \ 00040 1 t literal 576 | \ 00041 s t s add 577 | \ 00042 x z s fetch 578 | \ 00043 x x y add 579 | \ 00044 z s x store 580 | \ 00045 8 x literal 581 | \ 00046 z x loadjump 582 | 583 | VARIABLE &halt address &halt ! 584 | halt, 585 | 586 | \ 00047 halt 587 | 588 | VARIABLE &dup address &dup ! 589 | enter, 590 | &lit @ m, 591 | 0 m, 592 | &pick @ m, 593 | &exit @ m, 594 | 595 | \ 00048 2 x literal 596 | \ 00049 z x loadjump 597 | \ 00050 17 598 | \ 00051 0 599 | \ 00052 26 600 | \ 00053 12 601 | 602 | VARIABLE &double address &double ! 603 | enter, 604 | &dup @ m, 605 | &add @ m, 606 | &exit @ m, 607 | 608 | \ 00054 2 x literal 609 | \ 00055 z x loadjump 610 | \ 00056 48 611 | \ 00057 39 612 | \ 00058 12 613 | 614 | \ Initialization 615 | 616 | VARIABLE terminate address terminate ! 617 | &halt @ m, 618 | 619 | \ 00059 620 | 621 | tohere 622 | 623 | 16383 r literal, \ top of return stack, 3FFF 624 | 12287 s literal, \ top of data stack, 2FFF 625 | terminate @ i literal, 626 | 627 | \ 00060 16383 r literal 628 | \ 00061 12287 s literal 629 | \ 00062 59 i literal 630 | 631 | 42 x literal, x s push, 632 | &double @ w literal, 633 | &double @ branch, 634 | 635 | \ 00063 42 x literal 636 | \ 00064 0 t literal 637 | \ 00065 t t t nand 638 | \ 00066 s t s add 639 | \ 00067 z s x store 640 | \ 00068 54 w literal 641 | \ 00069 54 y literal 642 | \ 00070 z y loadjump 643 | 644 | \ Image padding 645 | 646 | : pad, 16384 address DO 0 m, LOOP ; 647 | pad, msave 648 | 649 | \ 00000 60 y literal y = 60 650 | \ 00001 z y loadjump load(z:0), jump(y:60) 651 | \ 00060 16383 r literal r = 16383 652 | \ 00061 12287 s literal s = 12287 653 | \ 00062 59 i literal i = 59 654 | \ 00063 42 x literal x = 42 655 | \ 00064 0 t literal t = 0 656 | \ 00065 t t t nand t = t:0 ~& t:0 657 | \ 00066 s t s add s = t:4294967295 + s:12287 658 | \ 00067 z s x store M[z:0][s:12286] = x:42 659 | \ 00068 54 w literal w = 54 660 | \ 00069 54 y literal y = 54 661 | \ 00070 z y loadjump load(z:0), jump(y:54) 662 | \ 00054 2 x literal x = 2 663 | \ 00055 z x loadjump load(z:0), jump(x:2) 664 | \ 00002 0 t literal t = 0 665 | \ 00003 t t t nand t = t:0 ~& t:0 666 | \ 00004 r t r add r = t:4294967295 + r:16383 667 | \ 00005 z r i store M[z:0][r:16382] = i:59 668 | \ 00006 2 t literal t = 2 669 | \ 00007 i w t add i = w:54 + t:2 670 | \ 00008 w z i fetch w = M[z:0][i:56] 671 | \ 00009 1 t literal t = 1 672 | \ 00010 i t i add i = t:1 + i:56 673 | \ 00011 z w loadjump load(z:0), jump(w:48) 674 | \ 00048 2 x literal x = 2 675 | \ 00049 z x loadjump load(z:0), jump(x:2) 676 | \ 00002 0 t literal t = 0 677 | \ 00003 t t t nand t = t:0 ~& t:0 678 | \ 00004 r t r add r = t:4294967295 + r:16382 679 | \ 00005 z r i store M[z:0][r:16381] = i:57 680 | \ 00006 2 t literal t = 2 681 | \ 00007 i w t add i = w:48 + t:2 682 | \ 00008 w z i fetch w = M[z:0][i:50] 683 | \ 00009 1 t literal t = 1 684 | \ 00010 i t i add i = t:1 + i:50 685 | \ 00011 z w loadjump load(z:0), jump(w:17) 686 | \ 00017 y z i fetch y = M[z:0][i:51] 687 | \ 00018 0 t literal t = 0 688 | \ 00019 t t t nand t = t:0 ~& t:0 689 | \ 00020 s t s add s = t:4294967295 + s:12286 690 | \ 00021 z s y store M[z:0][s:12285] = y:0 691 | \ 00022 1 t literal t = 1 692 | \ 00023 i t i add i = t:1 + i:51 693 | \ 00024 8 x literal x = 8 694 | \ 00025 z x loadjump load(z:0), jump(x:8) 695 | \ 00008 w z i fetch w = M[z:0][i:52] 696 | \ 00009 1 t literal t = 1 697 | \ 00010 i t i add i = t:1 + i:52 698 | \ 00011 z w loadjump load(z:0), jump(w:26) 699 | \ 00026 y z s fetch y = M[z:0][s:12285] 700 | \ 00027 1 t literal t = 1 701 | \ 00028 s t s add s = t:1 + s:12285 702 | \ 00029 1 t literal t = 1 703 | \ 00030 x s t cmove x = s:12286 if t:1 704 | \ 00031 x x y add x = x:12286 + y:0 705 | \ 00032 x z x fetch x = M[z:0][x:12286] 706 | \ 00033 0 t literal t = 0 707 | \ 00034 t t t nand t = t:0 ~& t:0 708 | \ 00035 s t s add s = t:4294967295 + s:12286 709 | \ 00036 z s x store M[z:0][s:12285] = x:42 710 | \ 00037 8 x literal x = 8 711 | \ 00038 z x loadjump load(z:0), jump(x:8) 712 | \ 00008 w z i fetch w = M[z:0][i:53] 713 | \ 00009 1 t literal t = 1 714 | \ 00010 i t i add i = t:1 + i:53 715 | \ 00011 z w loadjump load(z:0), jump(w:12) 716 | \ 00012 i z r fetch i = M[z:0][r:16381] 717 | \ 00013 1 t literal t = 1 718 | \ 00014 r t r add r = t:1 + r:16381 719 | \ 00015 8 x literal x = 8 720 | \ 00016 z x loadjump load(z:0), jump(x:8) 721 | \ 00008 w z i fetch w = M[z:0][i:57] 722 | \ 00009 1 t literal t = 1 723 | \ 00010 i t i add i = t:1 + i:57 724 | \ 00011 z w loadjump load(z:0), jump(w:39) 725 | \ 00039 y z s fetch y = M[z:0][s:12285] 726 | \ 00040 1 t literal t = 1 727 | \ 00041 s t s add s = t:1 + s:12285 728 | \ 00042 x z s fetch x = M[z:0][s:12286] 729 | \ 00043 x x y add x = x:42 + y:42 730 | \ 00044 z s x store M[z:0][s:12286] = x:84 731 | \ 00045 8 x literal x = 8 732 | \ 00046 z x loadjump load(z:0), jump(x:8) 733 | \ 00008 w z i fetch w = M[z:0][i:58] 734 | \ 00009 1 t literal t = 1 735 | \ 00010 i t i add i = t:1 + i:58 736 | \ 00011 z w loadjump load(z:0), jump(w:12) 737 | \ 00012 i z r fetch i = M[z:0][r:16382] 738 | \ 00013 1 t literal t = 1 739 | \ 00014 r t r add r = t:1 + r:16382 740 | \ 00015 8 x literal x = 8 741 | \ 00016 z x loadjump load(z:0), jump(x:8) 742 | \ 00008 w z i fetch w = M[z:0][i:59] 743 | \ 00009 1 t literal t = 1 744 | \ 00010 i t i add i = t:1 + i:59 745 | \ 00011 z w loadjump load(z:0), jump(w:47) 746 | \ 00047 halt 747 | " 748 | 749 | let rec repl () = 750 | out.Write "\n>" 751 | try 752 | inp <- new StringReader(Console.ReadLine() + Environment.NewLine) 753 | rep () 754 | out.Write "ok" 755 | repl () 756 | with ex -> out.Write ex.Message; repl () 757 | 758 | let case source expected = 759 | out <- new StringWriter() 760 | mem.[s] <- 61440 761 | source + Environment.NewLine |> reps 762 | let result = out.ToString() 763 | if result <> expected then 764 | printfn "FAILURE: %s (Expected: %s, Actual: %s)" source expected result 765 | 766 | case "123 ." "123 " // literals 767 | case "1 2 3 .S" "1 2 3 " // stack 768 | case "5 6 + ." "11 " // addition 769 | case "5 6 7 + + ." "18 " // addition 770 | case "10 2 - ." "8 " // subtraction 771 | case "10 2 - 3 - ." "5 " // subtraction 772 | case "10 2 3 - - ." "11 " // subtraction 773 | case "2 3 * ." "6 " // multiplication 774 | case "2 3 4 * * ." "24 " // multiplication 775 | case "5 2 / ." "2 " // division 776 | case "5 2 MOD ." "1 " // modulo 777 | case "1 2 3 DEPTH ." "3 " // stack depth 778 | case "1 2 3 CLEAR DEPTH ." "0 " // depth of empty 779 | case "1 2 3 CLEAR .S" "" // clear stack 780 | case "1 2 3 4 3 PICK ." "1 " // pick 781 | case "1 2 3 4 3 ROLL .S" "2 3 4 1 " // roll 782 | case "1 2 3 DROP .S" "1 2 " // drop 783 | case "1 2 3 DUP .S" "1 2 3 3 " // duplicate 784 | case "1 2 3 SWAP .S" "1 3 2 " // swap 785 | case "1 2 3 OVER .S" "1 2 3 2 " // over 786 | case "1 2 3 ROT .S" "2 3 1 " // left rotate 787 | case "1 2 3 -ROT .S" "3 1 2 " // right rotate 788 | case "1 2 3 NIP .S" "1 3 " // drop 2nd 789 | case "1 2 3 TUCK .S" "1 3 2 3 " // bury to 2nd 790 | case "7 NEGATE ." "-7 " // negate positive 791 | case "-7 NEGATE ." "7 " // negate negative 792 | case "5 SQUARE ." "25 " // square 793 | case "5 CUBE ." "125 " // cubed 794 | case "22 4 /MOD . ." "5 2 " // quotient and remainder 795 | case "7 \ comment\n 8 .S" "7 8 " // comment skipped 796 | case "7 ( comment ) 8 .S" "7 8 " // comment skipped 797 | case "1 2 3 2DROP .S" "1 " // drop pair 798 | case "1 2 3 2DUP .S" "1 2 3 2 3 " // dup pair 799 | case "1 2 3 4 2OVER .S" "1 2 3 4 1 2 " // over pairs 800 | case "1 2 3 3DUP .S" "1 2 3 1 2 3 " // dup tripple 801 | case "42 1+ ." "43 " // increment 802 | case "42 1- ." "41 " // decrement 803 | case "42 2+ ." "44 " // double inc 804 | case "42 2- ." "40 " // double dec 805 | case "42 2* ." "84 " // left shift 806 | case "42 2/ ." "21 " // right shift 807 | case "TRUE ." "-1 " // true constant 808 | case "FALSE ." "0 " // false constant 809 | case "0 0 NAND ." "-1 " // nand 810 | case "0 -1 NAND ." "-1 " // nand 811 | case "-1 0 NAND ." "-1 " // nand 812 | case "-1 -1 NAND ." "0 " // nand 813 | case "0 NOT ." "-1 " // not 814 | case "-1 NOT ." "0 " // not 815 | case "0 0 AND ." "0 " // and 816 | case "0 -1 AND ." "0 " // and 817 | case "-1 0 AND ." "0 " // and 818 | case "-1 -1 AND ." "-1 " // and 819 | case "0 0 OR ." "0 " // or 820 | case "0 -1 OR ." "-1 " // or 821 | case "-1 0 OR ." "-1 " // or 822 | case "-1 -1 OR ." "-1 " // or 823 | case "0 0 NOR ." "-1 " // nor 824 | case "0 -1 NOR ." "0 " // nor 825 | case "-1 0 NOR ." "0 " // nor 826 | case "-1 -1 NOR ." "0 " // nor 827 | case "0 0 XOR ." "0 " // xor 828 | case "0 -1 XOR ." "-1 " // xor 829 | case "-1 0 XOR ." "-1 " // xor 830 | case "-1 -1 XOR ." "0 " // xor 831 | case "0 0 XNOR ." "-1 " // xnor 832 | case "0 -1 XNOR ." "0 " // xnor 833 | case "-1 0 XNOR ." "0 " // xnor 834 | case "-1 -1 XNOR ." "-1 " // xnor 835 | case "42 6 > ." "-1 " // greater 836 | case "6 42 > ." "0 " // greater 837 | case "6 6 > ." "0 " // greater 838 | case "6 42 = ." "0 " // equal 839 | case "6 6 = ." "-1 " // equal 840 | case "42 6 >= ." "-1 " // greater or equal 841 | case "6 42 >= ." "0 " // greater or equal 842 | case "6 6 >= ." "-1 " // greater or equal 843 | case "42 6 < ." "0 " // less 844 | case "6 42 < ." "-1 " // less 845 | case "6 6 < ." "0 " // less 846 | case "42 6 <= ." "0 " // less or equal 847 | case "6 42 <= ." "-1 " // less or equal 848 | case "6 6 <= ." "-1 " // less or equal 849 | case "42 6 <> ." "-1 " // not equal 850 | case "6 42 <> ." "-1 " // not equal 851 | case "6 6 <> ." "0 " // not equal 852 | case "-1 0> ." "0 " // greater than zero 853 | case "0 0> ." "0 " // greater than zero 854 | case "1 0> ." "-1 " // greater than zero 855 | case "42 0= ." "0 " // equal to zero 856 | case "0 0= ." "-1 " // equal to zero 857 | case "-1 0< ." "-1 " // less than zero 858 | case "0 0< ." "0 " // less than zero 859 | case "1 0< ." "0 " // less than zero 860 | case "0 0<> ." "0 " // not equal to zero 861 | case "42 0<> ." "-1 " // not equal to zero 862 | case "VARIABLE X 42 X ! X @ . X ? FORGET X" "42 42 " // variables 863 | case "VARIABLE Y 40 Y ! Y ? 2 Y +! Y ? FORGET Y" "40 42 " // add variable 864 | case "HERE : FOO 123 ; FORGET FOO HERE = ." "-1 " // forgetting frees heap 865 | case ": FOO IF 1 THEN 2 ; TRUE FOO .S FORGET FOO" "1 2 " // if true 866 | case ": FOO IF 1 THEN 2 ; FALSE FOO .S FORGET FOO" "2 " // if false 867 | case ": FOO IF 1 ELSE 2 THEN 3 ; TRUE FOO .S FORGET FOO" "1 3 " // if then 868 | case ": FOO IF 1 ELSE 2 THEN 3 ; FALSE FOO .S FORGET FOO" "2 3 " // else then 869 | case "7 ABS ." "7 " // absolute value (positive) 870 | case "-7 ABS ." "7 " // absolute value (negative) 871 | case "10 4 MIN ." "4 " // min 872 | case "10 4 MAX ." "10 " // max 873 | case "-10 4 MIN ." "-10 " // min 874 | case "-10 4 MAX ." "4 " // max 875 | case ": FOO 123 ; FOO . : FOO 456 ; FOO . FORGET FOO FOO . FORGET FOO" "123 456 123 " // redefinition and forgetting 876 | case "1 2 3 .S >R >R >R R@ . R> . R> . R> ." "1 2 3 1 1 2 3 " // return stack operators 877 | case ": FAC DUP 1 > IF DUP 1- FAC * THEN ; 7 FAC . FORGET FAC" "5040 " // recursive definition 878 | case ": QUADRATIC ( a b c x -- n) >R SWAP ROT R@ * + R> * + ; 2 7 9 3 QUADRATIC . FORGET QUADRATIC" "48 " // taken from Starting Forth, Pg 100 879 | case ": LOOPY BEGIN 1+ DUP . DUP 9 > UNTIL ; 0 LOOPY 5 LOOPY 100 LOOPY FORGET LOOPY" "1 2 3 4 5 6 7 8 9 10 6 7 8 9 10 101 " // BEGIN ... UNTIL 880 | case ": LOOPY BEGIN DUP 10 < WHILE 1+ DUP . REPEAT ; 0 LOOPY 5 LOOPY 100 LOOPY FORGET LOOPY" "1 2 3 4 5 6 7 8 9 10 6 7 8 9 10 " // BEGIN ... WHILE ... UNTIL 881 | case ": LOOPY BEGIN 1+ DUP 10 > IF LEAVE THEN DUP . REPEAT ; 0 LOOPY 5 LOOPY 100 LOOPY FORGET LOOPY" "1 2 3 4 5 6 7 8 9 10 6 7 8 9 10 " // BEGIN ... IF ... LEAVE ... THEN ... UNTIL 882 | case ": DECADE 10 0 DO I . LOOP ; DECADE FORGET DECADE" "0 1 2 3 4 5 6 7 8 9 " // DO ... LOOP 883 | case ": MULTIPLICATIONS 11 1 DO DUP I * . LOOP DROP ; 7 MULTIPLICATIONS FORGET MULTIPLICATIONS" "7 14 21 28 35 42 49 56 63 70 " // DO ... LOOP with stack work 884 | case ": NESTED 3 1 DO 3 1 DO 3 1 DO I J K * * . LOOP LOOP LOOP ; NESTED FORGET NESTED" "1 2 2 4 2 4 4 8 " // nested DO ... LOOPs 885 | case ": COUNTDOWN 0 100 DO I . -10 +LOOP ; COUNTDOWN FORGET COUNTDOWN" "100 90 80 70 60 50 40 30 20 10 " // +LOOP 886 | case "65 65 ?DELIM .S CLEAR" "65 -1 " // ?DELIM match 887 | case "66 65 ?DELIM .S CLEAR" "66 0 " // ?DELIM mismatch 888 | case "32 32 ?DELIM .S CLEAR" "32 -1 " // ?DELIM space match 889 | case "33 32 ?DELIM .S CLEAR" "33 0 " // ?DELIM space mismatch 890 | case "9 32 ?DELIM .S CLEAR" "9 -1 " // ?DELIM whitespace match 891 | case "10 32 ?DELIM .S CLEAR" "10 -1 " // ?DELIM whitespace match 892 | case "13 32 ?DELIM .S CLEAR" "13 -1 " // ?DELIM whitespace match 893 | case "47 ?DIGIT .S CLEAR" "47 0 " // not ?DIGIT 894 | case "48 ?DIGIT .S CLEAR" "48 -1 " // is ?DIGIT 895 | case "57 ?DIGIT .S CLEAR" "57 -1 " // is ?DIGIT 896 | case "58 ?DIGIT .S CLEAR" "58 0 " // not ?DIGIT 897 | case "4 HERE ! 48 HERE 1+ ! 49 HERE 2+ ! 50 HERE 3 + ! 51 HERE 4 + ! ?NUMBER .S CLEAR" "123 -1 " // PARSENUM 898 | case "4 HERE ! 48 HERE 1+ ! 49 HERE 2+ ! 65 HERE 3 + ! 51 HERE 4 + ! ?NUMBER .S CLEAR" "0 " // PARSENUM 899 | 900 | Console.Title <- "TransForth" 901 | out <- Console.Out 902 | out.Write "Welcome to TransForth" 903 | repl () 904 | --------------------------------------------------------------------------------