├── LICENSE ├── Makefile ├── README ├── as ├── README ├── as.go ├── kernel.4as └── softcore.4th ├── bootstrap └── bootstrap.go ├── forth ├── boot.4th ├── doc.go ├── error.go ├── kern.go ├── prim.go ├── stack.go └── vm.go └── main.go /LICENSE: -------------------------------------------------------------------------------- 1 | The "No problem Bugroff" license. 2 | 3 | Richard Stallman of the Free Software Foundation devised, in addition 4 | to some marvelous software, the GNU General Public License (GPL for 5 | short). Or the CopyLeft it is sometimes called. 6 | 7 | It is quite a revolutionary document, using the "copyright" tool to to 8 | protect your right to use free software. 9 | 10 | Unfortunately using copyright to protect free software is a lot like 11 | using a Jackal to guard the hens. 12 | 13 | In fact, various inconveniences relating to this have resulted in 14 | modifications such as the LGPL (Library General Public License) and 15 | more recently the NPL (Netscape Public License) 16 | 17 | I call these matters mere inconveniences, the real damage will occur 18 | when the Jackal's, (sorry, I mean lawyers), actually get to test the 19 | GPL in court for the first time. 20 | 21 | Thus enter my version. 22 | 23 | Its very simple. 24 | 25 | Entirely consistent. 26 | 27 | Completely unrestrictive. 28 | 29 | Easy to apply. 30 | 31 | The "No problem Bugroff" license is as follows... 32 | 33 | The answer to any and every question relating to the copyright, 34 | patents, legal issues of Bugroff licensed software is.... 35 | 36 | Sure, No problem. Don't worry, be happy. Now bugger off. 37 | 38 | All portions of this license are important.. 39 | 40 | * "Sure, no problem." Gives you complete freedom. I mean it. Utterly 41 | complete. A bit of a joke really. You have complete freedom anyway. 42 | * "Don't worry, be happy." Apart from being good advice and a good 43 | song, it also says :- No matter what anyone else says or does, you 44 | still have complete freedom. 45 | * Now bugger off. The only way to get rid of pushy Jackals is to 46 | ignore them and not feed them. The GPL is just begging somebody to 47 | take it to court. Can't you just see it. Exactly the same thing 48 | that happened when some twit (not Linus) registered Linux as his 49 | own personal trademark. People got upset, started a fund, and 50 | hired, off all ruddy things, a Jackal to try and defend the 51 | chicken! Who really benefits from this trademark / patent / 52 | copyright thing anyway? The lawyers. Who made it up in the first 53 | place? The lawyers. 54 | 55 | OK so the last part of the license sounds a bit harsh, but seriously 56 | folks, if you are a :- 57 | 58 | * Lawyer asking these legalese questions... You should go off and 59 | learn an honest trade that will actually contribute to life instead 60 | of draining it. 61 | * Programmer asking these legalese questions... You have amazingly 62 | powerful tools in your hands and mind, use them to ask and answer 63 | the worthwhile questions of life, the universe and everything. Stop 64 | mucking about with such legal nonsense and get back to programming. 65 | * User/reader asking these question... Don't worry. Go off and be 66 | happy. Have fun. Enjoy what has been created for you. 67 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Copyright 2011 Vadim Vygonets. All rights reserved. 2 | # Use of this source code is governed by the Bugroff 3 | # license that can be found in the LICENSE file. 4 | 5 | KERNEL = forth/kern.new 6 | KSRC = forth/boot.4th 7 | 8 | all: 9 | go build 10 | 11 | kernel: $(KERNEL) 12 | 13 | $(KERNEL): $(KSRC) 14 | go run ./bootstrap/bootstrap.go <$(KSRC) >$(KERNEL) 15 | 16 | .PHONY: all kernel $(KERNEL) 17 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | forego - A Forth implementation in Go 2 | ===================================== 3 | 4 | Why? 5 | ---- 6 | 7 | For ego. This is me learning the language. Both of them. 8 | 9 | Someone once said that everybody who learns Forth and likes it 10 | thinks "oh nice, that'd be cool to write a Forth VM". This 11 | happened to me, but I had no actual reason to do it until I 12 | started searching for a Go learning project. 13 | 14 | 15 | And? 16 | ---- 17 | 18 | Lessons learned: writing a VM without performance constrains or 19 | a crude assembler is easy, wrapping your head around multiple 20 | run times of Forth compiling words is less so. 21 | 22 | 23 | So What Is It? 24 | -------------- 25 | 26 | Forego is a naive implementation of a Forth virtual machine in Go 27 | that I hacked up in a month or so. Here are its main features 28 | and misfeatures: 29 | 30 | The Good: 31 | 32 | - The compiler, assembler, parser, main loop and disassembler are 33 | now written in Forth. It has (my understanding of) the full 34 | CORE wordset and then some, like: 35 | .( .r u.r :noname compile, parse parse-name refill source-id 36 | to value within \ 37 | pick roll ?do again case endcase of endof 38 | .s ? dump words ;code ahead bye state 39 | /string cmove cmove> sliteral 40 | ...and those are written in Forth. Type "words" at the prompt 41 | to see the whole list. 42 | 43 | The Ambiguous: 44 | 45 | - It has no file support and no interaction with the outside 46 | world except key and emit, so untrusted code will have to 47 | overflow a buffer in xterm or something to exploit your box. 48 | 49 | The Bad: 50 | 51 | - The VM does not resemble real hardware at all. 52 | 53 | - The "kernel" ("machine" code) is hardcoded in the package. 54 | 55 | - It's probably damn slow. 56 | 57 | - The README is incomplete. 58 | -------------------------------------------------------------------------------- /as/README: -------------------------------------------------------------------------------- 1 | Historical, was used for bootstrapping. 2 | 3 | as.go assembler 4 | kernel.4as assembly source of the kernel 5 | softcore.4th forth source of the rest 6 | -------------------------------------------------------------------------------- /as/as.go: -------------------------------------------------------------------------------- 1 | // Copyright 2013 Vadim Vygonets. All rights reserved. 2 | // Use of this source code is governed by the Bugroff 3 | // license that can be found in the LICENSE file. 4 | 5 | package main 6 | 7 | import ( 8 | "bufio" 9 | "errors" 10 | "fmt" 11 | "io" 12 | "log" 13 | "os" 14 | "strconv" 15 | "strings" 16 | ) 17 | 18 | const ( 19 | cellSize = 4 20 | cellBits = 32 21 | ) 22 | 23 | type ( 24 | Cell uint32 25 | 26 | dict map[string]Cell 27 | 28 | instr struct { 29 | c Cell 30 | s string 31 | } 32 | 33 | unres struct { 34 | a Cell // address 35 | s string // unresolved symbol 36 | } 37 | 38 | parser struct { 39 | l int // line number 40 | s string // source line 41 | a Cell // address 42 | d dict // dictionary of labels 43 | u []unres // unresolved 44 | i []instr // compiled instructions 45 | } 46 | ) 47 | 48 | var ( 49 | parseError = errors.New("parse error") 50 | labelExistsError = errors.New("label already exists") 51 | 52 | primitives = []string{ 53 | "nop", 54 | "exit", 55 | "(abort)", 56 | "(quit)", 57 | // stack 58 | "pick", 59 | "roll", 60 | "depth", 61 | "drop", 62 | // 0x08 63 | "2drop", 64 | "?dup", 65 | "nip", 66 | "tuck", 67 | // rstack 68 | ">r", 69 | "r>", 70 | "r@", 71 | "rdrop", 72 | // 0x10 73 | // basic memory access 74 | "@", 75 | "!", 76 | "c@", 77 | "c!", 78 | // more memory access 79 | "2!", 80 | "2@", 81 | "+!", 82 | "", 83 | // 0x18 84 | "", 85 | "", 86 | // comparison 87 | "=", 88 | "<>", 89 | "<", 90 | ">", 91 | "u<", 92 | "u>", 93 | // 0x20 94 | "0<", 95 | "0>", 96 | // logic 97 | "0=", 98 | "0<>", 99 | // bitwise logic 100 | "invert", 101 | "and", 102 | "or", 103 | "xor", 104 | // 0x28 105 | "lshift", 106 | "rshift", 107 | "2*", 108 | "2/", 109 | // arithmetics 110 | "1+", 111 | "1-", 112 | "+", 113 | "-", 114 | // 0x30 115 | "*", 116 | "/", 117 | "mod", 118 | "/mod", 119 | "*/", 120 | "*/mod", 121 | "m*", 122 | "um*", 123 | // 0x38 124 | "fm/mod", 125 | "sm/rem", 126 | "um/mod", 127 | "negate", 128 | "", 129 | "", 130 | "", 131 | "", 132 | // 0x40 133 | // io 134 | "key", 135 | "emit", 136 | // compiling! 137 | "(refill)", 138 | "(parse)", 139 | "(parse-word)", 140 | "(.)", 141 | "builtin-words", 142 | "trace", 143 | // 144 | "builtin-type", 145 | "builtin-execute", 146 | "builtin(find)", 147 | "builtin(trynum)", 148 | "", 149 | "", 150 | "builtin-dump", 151 | "", 152 | // 0x50 153 | "bye", 154 | "eof", 155 | } 156 | 157 | revPrimitives = func() map[string]Cell { 158 | rp := make(map[string]Cell) 159 | for k, v := range primitives { 160 | if v != "" { 161 | rp[v] = Cell(k) 162 | } 163 | } 164 | return rp 165 | }() 166 | ) 167 | 168 | func (p *parser) defLabel(lbl string) error { 169 | if _, ok := p.d[lbl]; ok { 170 | return labelExistsError 171 | } 172 | p.d[lbl] = p.a 173 | return nil 174 | } 175 | 176 | func (p *parser) parseNum(num string) (Cell, error) { 177 | if num == "." { 178 | return p.a + cellSize, nil 179 | } 180 | if c, ok := p.d[num]; ok { 181 | return c, nil 182 | } 183 | n, err := strconv.ParseUint(num, 0x10, 32) 184 | return Cell(n), err 185 | } 186 | 187 | func (p *parser) store(c Cell) { 188 | p.i = append(p.i, instr{c, p.s}) 189 | p.a += cellSize 190 | p.s = "\\\n" // for tri-instruction PUSH etc 191 | } 192 | 193 | func (p *parser) storeUnresolved(c Cell, s string) { 194 | p.u = append(p.u, 195 | unres{ 196 | a: p.a, 197 | s: s, 198 | }) 199 | p.store(c) 200 | } 201 | 202 | func (p *parser) resolve() []string { 203 | var syms []string 204 | for _, v := range p.u { 205 | if c, ok := p.d[v.s]; ok { 206 | p.i[v.a>>2].c |= c 207 | } else { 208 | syms = append(syms, v.s) 209 | } 210 | } 211 | return syms 212 | } 213 | 214 | const ( 215 | instrShift = 28 216 | instrParamMask = (1 << instrShift) - 1 217 | instrMask = ^Cell(instrParamMask) 218 | litSignBit = 24 219 | litNumMask = 1<<(litSignBit+1) - 1 220 | litSameBits = ^Cell(1< 0 { 250 | var c Cell 251 | for k, v := range b { 252 | if k == cellSize { 253 | break 254 | } 255 | c |= Cell(v) << ((cellBits - 8) - uint(k)<<3) 256 | } 257 | p.store(c) 258 | if len(b) <= cellSize { 259 | break 260 | } 261 | b = b[cellSize:] 262 | } 263 | return nil 264 | } 265 | 266 | func (p *parser) cell(num string) error { 267 | n, err := p.parseNum(num) 268 | if err != nil { 269 | p.storeUnresolved(0, num) 270 | return nil 271 | } 272 | p.store(n) 273 | return nil 274 | } 275 | 276 | func (p *parser) literal(num string) error { 277 | n, err := p.parseNum(num) 278 | if err != nil { 279 | p.storeUnresolved(0x40000000, num) 280 | return nil 281 | } 282 | 283 | // The rest from vm.go 284 | for s := litMaxShift; s >= 0; s-- { 285 | if n&(1<>uint(s)&litNumMask) 292 | return nil 293 | } 294 | break 295 | } 296 | } 297 | // can't store number in one instruction, do the "or" 298 | p.store(0x40000000 | n&(litNumMask>>1)) 299 | p.store(0x40000000 | litMaxShift<>litMaxShift) 300 | p.store(0x00000026) 301 | return nil 302 | } 303 | 304 | func (p *parser) pickRoll(f []string) error { 305 | if len(f) != 3 { 306 | return parseError 307 | } 308 | var i Cell = 0x50000000 309 | switch f[0] { 310 | //case "PICK": 311 | case "RPICK": 312 | i |= 0x10000 313 | case "ROLL": 314 | i |= 0x20000 315 | case "RROLL": 316 | i |= 0x30000 317 | } 318 | 319 | switch j, err := p.parseNum(f[1]); { 320 | case err != nil: 321 | return err 322 | case j >= 0x40: 323 | return parseError 324 | default: 325 | i |= j << 8 326 | } 327 | 328 | switch j, err := p.parseNum(f[2]); { 329 | case err != nil: 330 | return err 331 | case j >= 0x40: 332 | return parseError 333 | default: 334 | i |= j 335 | } 336 | p.store(i) 337 | return nil 338 | } 339 | 340 | func (p *parser) jmp(f []string) error { 341 | var i Cell 342 | switch f[0] { 343 | case "call": 344 | i = 0x10000000 345 | case "jmp": 346 | i = 0x20000000 347 | case "jz": 348 | i = 0x30000000 349 | } 350 | 351 | n, err := p.parseNum(f[1]) 352 | if err != nil { 353 | p.storeUnresolved(i, f[1]) 354 | return nil 355 | } 356 | p.store(i | n) 357 | return nil 358 | } 359 | 360 | func (p *parser) primitive(s string) error { 361 | if c, ok := revPrimitives[s]; ok { 362 | p.store(c) 363 | return nil 364 | } 365 | return parseError 366 | } 367 | 368 | func (p *parser) genPrimitives(prevLabel string) error { 369 | var b [32]byte 370 | if prevLabel == "" { 371 | prevLabel = "0" 372 | } 373 | lastAddr, err := p.parseNum(prevLabel) 374 | if err != nil { 375 | return err 376 | } 377 | for i, v := range primitives { 378 | if v == "" { 379 | continue 380 | } 381 | thisAddr := p.a 382 | b[0] = byte(len(v)) 383 | copy(b[1:], v) 384 | p.s = ".B " + strconv.FormatInt(int64(len(v)), 16) + 385 | " '" + v + "'\n" 386 | p.storeBytes(b[:len(v)+1]) 387 | p.s = "^\n" 388 | p.store(lastAddr) 389 | p.s = "\t" + v + "\n" 390 | p.store(Cell(i)) 391 | lastAddr = thisAddr 392 | } 393 | p.d["w/(last-primitive)"] = lastAddr 394 | return nil 395 | } 396 | 397 | func (p *parser) doLine() error { 398 | f := strings.Fields(p.s) 399 | if len(f) == 0 { 400 | return nil 401 | } 402 | switch f[0] { 403 | case `\`: 404 | return nil 405 | case ".B": 406 | if len(f) < 2 { 407 | return parseError 408 | } 409 | return p.bytes(f[1:]) 410 | case ".C": 411 | if len(f) != 2 { 412 | return parseError 413 | } 414 | return p.cell(f[1]) 415 | case ".L": // label 416 | if len(f) != 2 { 417 | return parseError 418 | } 419 | return p.defLabel(f[1]) 420 | case ".PRIMITIVES": 421 | if len(f) != 2 { 422 | return parseError 423 | } 424 | return p.genPrimitives(f[1]) 425 | case "PUSH": 426 | if len(f) != 2 { 427 | return parseError 428 | } 429 | return p.literal(f[1]) 430 | case "PICK", "ROLL", "RPICK", "RROLL": 431 | return p.pickRoll(f) 432 | case "call", "jmp", "jz": 433 | if len(f) != 2 { 434 | return parseError 435 | } 436 | return p.jmp(f) 437 | default: 438 | if len(f) != 1 { 439 | return parseError 440 | } 441 | return p.primitive(f[0]) 442 | } 443 | return parseError 444 | } 445 | 446 | func (p *parser) dump() { 447 | fmt.Print(`// Autogenerated! Shall not be edited. 448 | 449 | package forth 450 | 451 | var kernel = []byte{ 452 | `) 453 | for k, v := range p.i { 454 | fmt.Printf("\t%#02x, %#02x, %#02x, %#02x, // %04x %s", 455 | (v.c>>24)&0xff, (v.c>>16)&0xff, 456 | (v.c>>8)&0xff, v.c&0xff, k*cellSize, v.s) 457 | } 458 | fmt.Print(`} 459 | `) 460 | } 461 | 462 | func main() { 463 | var p = &parser{} 464 | p.d = make(dict) 465 | in := bufio.NewReader(os.Stdin) 466 | loop: 467 | for { 468 | var err error 469 | p.l++ 470 | switch p.s, err = in.ReadString('\n'); err { 471 | case nil: 472 | case io.EOF: 473 | break loop 474 | default: 475 | log.Fatalln(p.l, err) 476 | } 477 | if err = p.doLine(); err != nil { 478 | log.Fatalln(p.l, err) 479 | } 480 | } 481 | if syms := p.resolve(); len(syms) != 0 { 482 | log.Fatalf("unresolved symbols: %s\n", syms) 483 | } 484 | p.dump() 485 | } 486 | -------------------------------------------------------------------------------- /as/kernel.4as: -------------------------------------------------------------------------------- 1 | \ *************************************************************** 2 | \ Microcode 3 | 4 | .L l;abort 5 | (abort) 6 | PUSH 0 7 | PUSH source-id 8 | ! 9 | 10 | .L l;quit 11 | (quit) 12 | call refill 13 | jz l;eof 14 | call lineproc 15 | PUSH state 16 | @ 17 | 0= 18 | jz l;quit 19 | PUSH s"ok:" 20 | PUSH 4 21 | builtin-type 22 | jmp l;quit 23 | .L l;eof 24 | eof 25 | 26 | .L lineproc 27 | call parse-word 28 | PICK 1 0 29 | jz 2drop,exit 30 | call (find) 31 | ?dup 32 | jz trynumber 33 | 1- 34 | jz exec 35 | PUSH state 36 | @ 37 | jz exec 38 | call compile, 39 | jmp lineproc 40 | .L exec 41 | builtin-execute 42 | jmp lineproc 43 | .L trynumber 44 | PUSH base 45 | @ 46 | builtin(trynum) 47 | jz notfound 48 | PUSH state 49 | @ 50 | jz lineproc 51 | call literal 52 | jmp lineproc 53 | .L 2drop,exit 54 | 2drop 55 | exit 56 | .L notfound 57 | PUSH a 58 | emit 59 | builtin-type 60 | PUSH s"?" 61 | PUSH 4 62 | builtin-type 63 | jmp l;abort 64 | 65 | \ "ok: " 66 | .L s"ok:" 67 | .C 6f6b3a20 68 | \ " ? " 69 | .L s"?" 70 | .C 203f2020 71 | 72 | \ source -1 (evaluate) 73 | .L #tib[-1] 74 | .C 0 75 | .L tib[-1] 76 | .C 0 77 | .L >in[-1] 78 | .C 0 79 | 80 | \ source 0 (input) 81 | .L #tib[0] 82 | .C 0 83 | .L tib[0] 84 | .C 0 85 | .L >in[0] 86 | .C 0 87 | 88 | \ *************************************************************** 89 | \ wordlist 90 | 91 | \ dict: struct 92 | \ flags|namelen byte 93 | \ name [1-31]byte 94 | \ align? [0-3]byte 95 | \ prev Cell 96 | \ codeword | 0 Cell 97 | \ data? []Cell 98 | \ flags: 99 | \ 0x80 immediate 100 | \ 0x40 variable 101 | \ 0x20 unused/reserved 102 | \ 0x1f len(name) 103 | 104 | \ *************************************************************** 105 | \ variables 106 | 107 | \ here 108 | .L w/here 109 | .B 44 'here' 110 | .C 0 111 | @ 112 | .L here 113 | .C l;end 114 | 115 | \ (words) 116 | .L w/(words) 117 | .B 47 '(words)' 118 | .C w/here 119 | nop 120 | .L dicthead 121 | .C lastword 122 | 123 | \ state 124 | .L w/state 125 | .B 45 'state' 126 | .C w/(words) 127 | @ 128 | .L state 129 | .C 0 130 | 131 | \ source-id ( -- x ) 132 | .L w/source-id 133 | .B 49 'source-id' 134 | .C w/state 135 | @ 136 | .L source-id 137 | .C 0 138 | 139 | \ (source) 140 | .L w/(source) 141 | .B 8 '(source)' 142 | .C w/source-id 143 | call . 144 | .L (source) 145 | PUSH #tib[0] 146 | PUSH source-id 147 | @ 148 | PUSH c 149 | * 150 | + 151 | exit 152 | 153 | \ source 154 | .L w/source 155 | .B 6 'source' 156 | .C w/(source) 157 | call . 158 | call (source) 159 | 2@ 160 | exit 161 | 162 | \ >in 163 | .L w/>in 164 | .B 3 '>in' 165 | .C w/source 166 | call . 167 | call (source) 168 | PUSH 8 169 | + 170 | exit 171 | 172 | \ base 173 | .L w/base 174 | .B 44 'base' 175 | .C w/>in 176 | nop 177 | .L base 178 | .C a 179 | 180 | \ *************************************************************** 181 | \ primitives 182 | 183 | .PRIMITIVES w/base 184 | 185 | \ quit ( R: j*x -- ) 186 | .L w/quit 187 | .B 4 'quit' 188 | .C w/(last-primitive) 189 | jmp l;quit 190 | 191 | \ abort ( i*x -- ) ( R: j*x -- ) 192 | .L w/abort 193 | .B 5 'abort' 194 | .C w/quit 195 | jmp l;abort 196 | 197 | \ *************************************************************** 198 | \ assembler 199 | 200 | \ *************************************************************** 201 | \ compiler 202 | 203 | \ ] ( -- ) 204 | .L w/] 205 | .B 41 ']' 206 | .C w/abort 207 | call ] 208 | .C ffffffff 209 | .L ] 210 | @ 211 | PUSH state 212 | jmp !,exit 213 | 214 | \ [ ( -- ) immediate (variable, too) 215 | \ good luck compiling this one 216 | .L w/[ 217 | .B c1 '[' 218 | .C w/] 219 | call ] 220 | .C 0 221 | 222 | \ , ( x -- ) 223 | .L w/, 224 | .B 1 ',' 225 | .C w/[ 226 | call . 227 | .L , 228 | PUSH here 229 | @ 230 | ! 231 | PUSH 4 232 | .L here,+!,exit 233 | PUSH here 234 | +! 235 | exit 236 | 237 | \ c, ( char -- ) 238 | .L w/c, 239 | .B 2 'c,' 240 | .C w/, 241 | call . 242 | .L c, 243 | PUSH here 244 | @ 245 | c! 246 | PUSH 1 247 | jmp here,+!,exit 248 | 249 | \ aligned ( addr -- a-addr ) 250 | .L w/aligned 251 | .B 7 'aligned' 252 | .C w/c, 253 | call . 254 | .L aligned 255 | PUSH 3 256 | + 257 | PUSH fffffffc 258 | and 259 | exit 260 | 261 | \ align ( -- ) 262 | .L w/align 263 | .B 5 'align' 264 | .C w/aligned 265 | call . 266 | PUSH here 267 | @ 268 | call aligned 269 | PUSH here 270 | .L !,exit 271 | ! 272 | exit 273 | 274 | \ ' ( "name" -- xt ) 275 | .L w/' 276 | .B 1 27 277 | .C w/align 278 | call . 279 | call parse-word 280 | call (find) 281 | jz notfound 282 | \ what's going on above? 283 | exit 284 | 285 | \ (s,) ( addr u -- ) 286 | .L w/(s,) 287 | .B 4 '(s,)' 288 | .C w/' 289 | call . 290 | .L (s,)/begin 291 | PICK 1 0 292 | jz 2drop,exit 293 | PICK 1 1 294 | c@ 295 | call c, 296 | ROLL 1 1 297 | 1+ 298 | ROLL 1 1 299 | 1- 300 | jmp (s,)/begin 301 | 302 | \ literal Compilation: ( x -- ) Run-time: ( -- x ) immediate 303 | \ : literal 304 | \ 7 begin 305 | \ >r 1 r@ lshift 1- over and while 306 | \ r> ?dup while 307 | \ 1- repeat 308 | .L w/literal 309 | .B 87 'literal' 310 | .C w/(s,) 311 | call . 312 | .L literal 313 | PUSH 7 314 | .L literal/begin 315 | >r 316 | PUSH 1 317 | r@ 318 | lshift 319 | 1- 320 | PICK 1 1 321 | and 322 | jz literal/handle 323 | r> 324 | ?dup 325 | jz literal/longform 326 | 1- 327 | jmp literal/begin 328 | .L literal/handle 329 | PUSH ff000000 330 | r@ 331 | lshift 332 | PICK 2 0 333 | and 334 | ?dup 335 | jz literal/drop+short 336 | xor 337 | jz literal/shortform 338 | rdrop 339 | .L literal/longform 340 | PICK 1 0 341 | PUSH 00ffffff 342 | and 343 | PUSH 40000000 344 | or 345 | call , 346 | PUSH 7 347 | rshift 348 | PUSH 4e000000 349 | or 350 | call , 351 | PUSH 26 352 | jmp , 353 | .L literal/drop+short 354 | drop 355 | .L literal/shortform 356 | r@ 357 | rshift 358 | PUSH fe000000 359 | invert 360 | and 361 | r> 362 | PUSH 19 363 | lshift 364 | or 365 | PUSH 40000000 366 | or 367 | call , 368 | .L exit 369 | exit 370 | 371 | \ compile, Execution: ( xt -- ) 372 | .L w/compile, 373 | .B 8 'compile,' 374 | .C w/literal 375 | call . 376 | .L compile, 377 | PICK 1 0 378 | PUSH 1 379 | and 380 | jz compile,/then 381 | PICK 1 0 382 | call aligned 383 | call literal 384 | 1- 385 | .L compile,/then 386 | @ 387 | ?dup 388 | jz exit 389 | jmp , 390 | 391 | .L w/parse 392 | .B 5 'parse' 393 | .C w/compile, 394 | call . 395 | .L parse 396 | call (source) 397 | (parse) 398 | exit 399 | 400 | .L w/parse-word 401 | .B a 'parse-word' 402 | .C w/parse 403 | call . 404 | .L parse-word 405 | PUSH 20 406 | jmp parse 407 | 408 | .L w/(find) 409 | .B 6 '(find)' 410 | .C w/parse-word 411 | call . 412 | .L (find) 413 | PUSH dicthead 414 | builtin(find) 415 | exit 416 | 417 | .L w/words 418 | .B 5 'words' 419 | .C w/(find) 420 | call . 421 | PUSH dicthead 422 | builtin-words 423 | exit 424 | 425 | .L w/execute 426 | .B 7 'execute' 427 | .C w/words 428 | builtin-execute 429 | 430 | .L w/refill 431 | .B 6 'refill' 432 | .C w/execute 433 | call . 434 | .L refill 435 | PUSH source-id 436 | @ 437 | jz refill/doit 438 | .L refill/fail 439 | PUSH 0 440 | exit 441 | .L refill/doit 442 | PUSH fe00 443 | (refill) 444 | jz refill/fail 445 | PUSH #tib[0] 446 | ! 447 | PUSH 0 448 | PUSH fe00 449 | PUSH tib[0] 450 | 2! 451 | PUSH ffffffff 452 | exit 453 | 454 | \ *************************************************************** 455 | \ some stack stuff 456 | 457 | \ dup ( x -- x x ) 458 | .L w/dup 459 | .B 3 'dup' 460 | .C w/refill 461 | PICK 1 0 462 | 463 | \ over ( x1 x2 -- x1 x2 x1 ) 464 | .L w/over 465 | .B 4 'over' 466 | .C w/dup 467 | PICK 1 1 468 | 469 | \ swap ( x1 x2 -- x2 x1 ) 470 | .L w/swap 471 | .B 4 'swap' 472 | .C w/over 473 | ROLL 1 1 474 | 475 | \ rot ( x1 x2 x3 -- x2 x3 x1 ) 476 | .L w/rot 477 | .B 3 'rot' 478 | .C w/swap 479 | ROLL 1 2 480 | 481 | \ -rot ( x1 x2 x3 -- x3 x1 x2 ) 482 | .L w/-rot 483 | .B 4 '-rot' 484 | .C w/rot 485 | ROLL 2 1 486 | 487 | \ 2dup ( x1 x2 -- x1 x2 x1 x2 ) 488 | .L w/2dup 489 | .B 4 '2dup' 490 | .C w/-rot 491 | PICK 2 0 492 | 493 | \ 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) 494 | .L w/2over 495 | .B 5 '2over' 496 | .C w/2dup 497 | PICK 2 2 498 | 499 | \ 2swap ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) 500 | .L w/2swap 501 | .B 5 '2swap' 502 | .C w/2over 503 | ROLL 2 2 504 | 505 | \ 2rot ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 ) 506 | .L w/2rot 507 | .B 4 '2rot' 508 | .C w/2swap 509 | ROLL 2 4 510 | 511 | \ 2-rot ( x1 x2 x3 x4 x5 x6 -- x5 x6 x1 x2 x3 x4 ) 512 | .L w/2-rot 513 | .B 5 '2-rot' 514 | .C w/2rot 515 | ROLL 4 2 516 | 517 | .L lastword 518 | 519 | \ evaluate ( i*x c-addr u -- j*x ) 520 | .L w/evaluate 521 | .B 8 'evaluate' 522 | .C w/2-rot 523 | call . 524 | PUSH #tib[-1] 525 | 2! 526 | PUSH 0 527 | PUSH >in[-1] 528 | ! 529 | PUSH ffffffff 530 | PUSH source-id 531 | ! 532 | call lineproc 533 | PUSH 0 534 | PUSH source-id 535 | ! 536 | exit 537 | 538 | .L l;end 539 | -------------------------------------------------------------------------------- /as/softcore.4th: -------------------------------------------------------------------------------- 1 | 1 2* 2* 2* 2* base ! 2 | here 013a0000 , 3 | (words) @ , (words) ! 4 | here 4 + 10000000 or , 5 | ] here parse-word dup c, (s,) align 6 | (words) @ , here 4 + 10000000 or , ] exit [ 7 | : ; [ ' exit literal ] compile, (words) ! [ ' [ compile, ] 8 | exit [ 9 | dup c@ 80 or over c! 10 | (words) ! 11 | 12 | : immediate (words) @ dup c@ 80 or swap c! ; 13 | 14 | : \ a parse 2drop ; immediate 15 | 16 | \ ok, here's a copy of the above: 17 | \ : : here parse-word dup c, (s,) align (words) @ , here 4 + 10000000 or , ] ; 18 | \ : ; postpone exit (words) ! postpone [ ; immediate 19 | 20 | \ : literal (literal) ; immediate 21 | 22 | \ Assembly 23 | \ : primitive, , ; 24 | 25 | \ call, jmp, jz, ( addr -- ) 26 | : call, 10000000 or , ; 27 | : jmp, 20000000 or , ; 28 | : jz, 30000000 or , ; 29 | 30 | \ literal elsewhere 31 | 32 | \ (0101) 0000 0000 00os 00ww wwww 00ff ffff 33 | \ o = operation (0: pick, 1: roll) 34 | \ s = stack (0: data stack, 1: rstack) 35 | \ w = width 36 | \ f = from 37 | 38 | \ pick, ( width from -- ) 39 | : pick, 50000000 or swap 8 lshift or , ; 40 | : roll, 00020000 or pick, ; 41 | : rpick, 00010000 or pick, ; 42 | : rroll, 00030000 or pick, ; 43 | 44 | : if here 0 jz, ; immediate 45 | : then dup @ f0000000 and here 0fffffff and or swap ! ; immediate 46 | 47 | : postpone parse-word (find) 1- if 48 | [ ' literal compile, ' compile, ] literal then compile, ; immediate 49 | \ what is this i don't even 50 | 51 | : begin here ; immediate 52 | : again jmp, ; immediate 53 | : until jz, ; immediate 54 | : ahead here 0 jmp, ; immediate 55 | 56 | : else postpone ahead swap postpone then ; immediate 57 | : while postpone if swap ; immediate 58 | : repeat postpone again postpone then ; immediate 59 | 60 | : 2>r postpone swap postpone >r postpone >r ; immediate 61 | : 2r> postpone r> postpone r> postpone swap ; immediate 62 | : 2r@ postpone r> postpone r@ postpone swap postpone dup postpone >r ; immediate 63 | : 2rdrop postpone rdrop postpone rdrop ; immediate 64 | 65 | : . base @ (.) ; 66 | : cr a emit ; 67 | 68 | : i postpone r@ ; immediate 69 | : (do) postpone begin postpone 2>r ; 70 | : do 0 (do) ; immediate 71 | : ?do 0 postpone 2dup postpone xor postpone if (do) ; immediate 72 | : unloop postpone 2rdrop ; immediate 73 | : loop postpone 2r> postpone 1+ postpone 2dup postpone = 74 | postpone until 75 | begin ?dup while postpone then repeat 76 | postpone 2drop 77 | ; immediate 78 | 79 | \ fucking leave, how does it normally work? 80 | : leave 81 | 0 begin over while swap >r 1+ repeat 82 | postpone ahead swap 83 | begin ?dup while r> swap 1- repeat 84 | ; immediate 85 | 86 | \ : foo 10 0 ?do i . i 5 = if leave then loop ; 87 | 88 | : ['] ' postpone literal ; immediate 89 | 90 | : char parse-word drop c@ ; 91 | : [char] char postpone literal ; immediate 92 | : ( [char] ) parse 2drop ; immediate 93 | 94 | : cell+ 4 + ; 95 | : cells 2 lshift ; 96 | : >body fffffffc and cell+ ; \ 1+ aligned 97 | 98 | : decode dup 00ffffff and 99 | over 01000000 and if fe000000 or then 100 | swap 19 ( that's hex, btw) rshift 7 and lshift ; 101 | 102 | : hex 10 base ! ; 103 | : decimal a base ! ; 104 | 105 | \ : bl 20 ; 106 | \ we need: 107 | \ 20 constant bl 108 | : bl 20 state if postpone literal then ; immediate 109 | 110 | : <= > 0= ; 111 | : >= < 0= ; 112 | 113 | : dumplast (words) @ here over - builtin-dump ; 114 | 115 | \ Now we have loops and some basics. time to define a more-real compiler. 116 | 117 | \ : state d0 @ ; \ TODO 118 | : to ' >body state if postpone literal postpone ! else ! then ; immediate 119 | : allot here + aligned to here ; 120 | 121 | \ : source-id ec @ ; 122 | \ : source e0 source-id c * + 2@ ; 123 | \ : >in e8 source-id c * + ; 124 | 125 | : (scan) ( char xt c-addr c-addr -- c-addr ) 126 | >r >r 127 | begin 2r@ > while 128 | 2dup r@ c@ swap execute while 129 | r> 1+ >r repeat then 130 | 2drop r> rdrop 131 | ; 132 | 133 | : parse ( char "ccc" -- c-addr u ) 134 | source over + >r >in @ + 135 | over bl = if over swap ['] >= swap r@ (scan) then 136 | swap 2dup bl = if ['] < else ['] <> then 137 | swap r> (scan) 138 | dup source >r - 139 | dup r> < if 1+ then >in ! 140 | over - 141 | ; 142 | 143 | : parse-word ( "name" -- c-addr u ) bl parse ; 144 | 145 | : (:) >r here parse-word dup r> or c, (s,) align (words) @ , ; 146 | : (;) (words) ! ; 147 | : (create) 40 (:) (;) ; 148 | : create (create) 0 , ; 149 | : variable create 0 , ; 150 | : value (create) ['] @ compile, , ; 151 | : : 0 (:) here cell+ call, ] ; 152 | : ; postpone exit (;) postpone [ ; immediate 153 | 154 | : skipname dup c@ 1f and + 1+ aligned ; 155 | 156 | : nextwordaddr dup c@ 1f and + 1+ aligned @ ; 157 | 158 | : does> r> 10000000 or (words) @ skipname cell+ ! ; 159 | 160 | : constant value immediate 161 | does> @ state if postpone literal then ; 162 | 163 | : :1; 0 (:) (;) ; 164 | : primitive :1; , ; 165 | : alias 0 (:) ' compile, (;) ; 166 | 167 | : .s depth 0 ?do i pick . loop cr ; 168 | : type 0 ?do dup c@ emit 1+ loop drop ; 169 | : space bl emit ; 170 | : spaces 0 ?do space loop ; 171 | 172 | : sliteral 173 | postpone ahead postpone begin swap 174 | 2over (s,) align 175 | postpone then postpone literal postpone literal drop 176 | ; immediate 177 | 178 | : s" [char] " parse postpone sliteral ; immediate 179 | : ." postpone s" postpone type ; immediate 180 | 181 | alias char+ 1+ 182 | 183 | : tolower ( char -- char ) 184 | dup [char] A >= if dup [char] Z <= if 185 | [ char a char A - ] literal + then then ; 186 | 187 | : weq ( addr1 u1 addr2 u2 -- flag ) 188 | 2 pick <> if drop 2drop 0 exit then 189 | swap 0 ?do 190 | over c@ tolower over c@ tolower <> if unloop 2drop 0 exit then 191 | swap char+ swap char+ loop 192 | 2drop -1 ; 193 | 194 | : (find) ( addr u -- addr u 0 | xt 1 | xt -1 ) 195 | 2>r (words) begin @ ?dup while 196 | dup c@ swap 1+ over 1f and 2dup + aligned -rot 2r@ weq if 197 | cell+ swap 6 rshift tuck 1 and or 198 | swap 2 and 1- 2rdrop exit then 199 | nip repeat 200 | 2r> 0 201 | ; 202 | 203 | decimal 204 | -------------------------------------------------------------------------------- /bootstrap/bootstrap.go: -------------------------------------------------------------------------------- 1 | // Copyright 2013 Vadim Vygonets. All rights reserved. 2 | // Use of this source code is governed by the Bugroff 3 | // license that can be found in the LICENSE file. 4 | 5 | /* 6 | Bootstrap is a helper for bootstrapping the Forego kernel. 7 | 8 | Usage: 9 | ./bootstrap <../forth/boot.4th >../forth/kern.go 10 | */ 11 | package main 12 | 13 | import ( 14 | "fmt" 15 | "io/ioutil" 16 | "log" 17 | "os" 18 | "strings" 19 | 20 | "github.com/unixdj/forego/forth" 21 | ) 22 | 23 | func main() { 24 | code, err := ioutil.ReadAll(os.Stdin) 25 | if err != nil { 26 | log.Fatalln(err) 27 | } 28 | if len(code) > forth.MemSize/4 { 29 | log.Fatalln("code size must be less than", 30 | forth.MemSize/4, "bytes. sorry.") 31 | } 32 | var ( 33 | addr = forth.MemSize - 0x200 - len(code) 34 | eval = fmt.Sprintf("%d %d evaluate\n", addr, len(code)) 35 | dump = "0 here dump2go bye\n" 36 | in = strings.NewReader(eval + eval + dump) 37 | vm = forth.NewVM(in, os.Stdout) 38 | ) 39 | copy(vm.Mem[addr:], code) 40 | if err := vm.Run(); err != nil { 41 | instr := err.(*forth.Error).Instr 42 | log.Fatalf("%v: %v (%v)\n", err, instr, forth.Cell(instr)) 43 | } 44 | } 45 | -------------------------------------------------------------------------------- /forth/boot.4th: -------------------------------------------------------------------------------- 1 | \ Copyright 2013 Vadim Vygonets. All rights reserved. 2 | \ Use of this source code is governed by the Bugroff 3 | \ license that can be found in the LICENSE file. 4 | 5 | \ *************************************************************** 6 | \ This file bootstraps a running Forth VM image. It does so by 7 | \ compiling words and microcode to the other half of memory (the 8 | \ begining of the upper half if curretly running in the lower 9 | \ half, and address 0 otherwise), then switching to the new 10 | \ microcode and compiling more words. To generate Go source file 11 | \ containing the kernel, evaluate this file twice, then say: 12 | 13 | \ 0 here dump2go bye 14 | 15 | \ This can be done from stdin: 16 | 17 | \ ( cat forth/boot.4th forth/boot.4th ; \ 18 | \ echo cr 0 here dump2go ) | ./forego \ 19 | \ | grep -v ^ok: >forth/kern.go 20 | 21 | \ or by using the EVALUATE word, which avoids grepping. This is 22 | \ what bootstrap does, so you can just run: 23 | 24 | \ ./bootstrap/bootstrap forth/kern.go 25 | 26 | \ *************************************************************** 27 | \ use the other half of the memory 28 | hex 29 | here fffe0000 and 20000 xor constant target 30 | 31 | : blank-target target cell+ 1000 0 ?do 0 over ! cell+ loop drop ; blank-target 32 | 33 | \ *************************************************************** 34 | \ aliases and helpers 35 | 36 | ' here >body value there 37 | alias (old-words) (words) 38 | : [[ 0 state ! ; immediate 39 | : ]] -1 state ! ; 40 | alias ;; ; immediate 41 | 42 | : patch-abort 43 | target if 0 to here target jmp, then 44 | ; 45 | 46 | \ this is used instead of quit to handle running under evaluate 47 | : do-quit ( xt -- ) 48 | (quit) [ target 10 + ] literal >r 49 | source-id if 50 | source >in @ rot over + -rot - rot @ 10000000 xor >r else 51 | drop then 52 | ; 53 | 54 | \ *************************************************************** 55 | \ start compiling to new space 56 | 57 | target 80 + to here 58 | 59 | \ *************************************************************** 60 | \ Now we have to be really careful to compile new words so the 61 | \ resulting bytecode contains only primitives and new words, but 62 | \ to avoid runing new compiling words. 63 | \ At this point postpone doesn't work on non-immediate words. 64 | 65 | \ primitives 66 | 67 | 0 primitive nop ( -- ) 68 | 1 primitive exit ( -- ) ( R: nest-sys -- ) 69 | 2 primitive (abort) ( i*x -- ) 70 | 3 primitive (quit) ( R: i*x -- ) 71 | 4 primitive pick ( xu ... x1 x0 u -- xu ... x1 x0 xu ) 72 | 5 primitive roll ( xu xu-1 ... x0 u -- xu-1 ... x0 xu ) 73 | 6 primitive depth ( -- +n ) 74 | 7 primitive drop ( x -- ) 75 | 8 primitive 2drop ( x1 x2 -- ) 76 | 9 primitive ?dup ( x -- 0 | x x ) 77 | a primitive nip ( x1 x2 -- x2 ) 78 | b primitive tuck ( x1 x2 -- x2 x1 x2 ) 79 | c primitive >r ( x -- ) ( R: -- x ) 80 | d primitive r> ( -- x ) ( R: x -- ) 81 | e primitive r@ ( -- x ) ( R: x -- x ) 82 | f primitive rdrop ( R: x -- ) 83 | 84 | 10 primitive @ ( a-addr -- x ) 85 | 11 primitive ! ( x a-addr -- ) 86 | 12 primitive c@ ( c-addr -- char ) 87 | 13 primitive c! ( char c-addr -- ) 88 | 14 primitive 2! ( x1 x2 a-addr -- ) 89 | 15 primitive 2@ ( a-addr -- x1 x2 ) 90 | 16 primitive +! ( n|u a-addr -- ) 91 | 92 | 1a primitive = ( x1 x2 -- flag ) 93 | 1b primitive <> ( x1 x2 -- flag ) 94 | 1c primitive < ( n1 n2 -- flag ) 95 | 1d primitive > ( n1 n2 -- flag ) 96 | 1e primitive u< ( u1 u2 -- flag ) 97 | 1f primitive u> ( u1 u2 -- flag ) 98 | 99 | 20 primitive 0< ( n -- flag ) 100 | 21 primitive 0> ( n -- flag ) 101 | 22 primitive 0= ( x -- flag ) 102 | 23 primitive 0<> ( x -- flag ) 103 | 24 primitive invert ( x1 -- x2 ) 104 | 25 primitive and ( x1 x2 -- x3 ) 105 | 26 primitive or ( x1 x2 -- x3 ) 106 | 27 primitive xor ( x1 x2 -- x3 ) 107 | 28 primitive lshift ( x1 u -- x2 ) 108 | 29 primitive rshift ( x1 u -- x2 ) 109 | 2a primitive 2* ( x1 -- x2 ) 110 | 2b primitive 2/ ( x1 -- x2 ) 111 | 2c primitive 1+ ( n1|u1 -- n2|u2 ) 112 | 2d primitive 1- ( n1|u1 -- n2|u2 ) 113 | 2e primitive + ( n1|u1 n2|u2 -- n3|u3 ) 114 | 2f primitive - ( n1|u1 n2|u2 -- n3|u3 ) 115 | 116 | 30 primitive * ( n1|u1 n2|u2 -- n3|u3 ) 117 | 31 primitive / ( n1|u1 n2|u2 -- n3|u3 ) 118 | 32 primitive mod ( n1 n2 -- n3 ) 119 | 33 primitive /mod ( n1 n2 -- n3 n4 ) 120 | 34 primitive */ ( n1 n2 n3 -- n4 ) 121 | 35 primitive */mod ( n1 n2 n3 -- n4 n5 ) 122 | 36 primitive m* ( n1 n2 -- d ) 123 | 37 primitive um* ( u1 u2 -- ud ) 124 | 38 primitive fm/mod ( d1 n1 -- n2 n3 ) 125 | 39 primitive sm/rem ( d1 n1 -- n2 n3 ) 126 | 3a primitive um/mod ( ud n1 -- n2 n3 ) 127 | 3b primitive negate ( n1 -- n2 ) 128 | 3c primitive ud+ ( ud1 ud2 -- ud3 ) 129 | 3d primitive ud- ( ud1 ud2 -- ud3 ) 130 | 3e primitive ud* ( ud1 ud2 -- ud3 ) 131 | 3f primitive ud/mod ( ud1 ud2 -- ud3 ud4 ) 132 | 133 | 40 primitive key ( -- char | -1 ) 134 | 41 primitive emit ( char -- ) 135 | 136 | 47 primitive trace ( flag -- ) 137 | 138 | 50 primitive bye ( -- ) 139 | 51 primitive eof ( -- ) 140 | 141 | \ one-instruction words 142 | :1; abort target jmp, 143 | :1; quit target 10 + jmp, 144 | 145 | \ stack manipulation 146 | :1; dup 1 0 pick, 147 | :1; over 1 1 pick, 148 | :1; swap 1 1 roll, 149 | :1; rot 1 2 roll, 150 | :1; -rot 2 1 roll, 151 | :1; 2dup 2 0 pick, 152 | :1; 2over 2 2 pick, 153 | :1; 2swap 2 2 roll, 154 | :1; 2rot 2 4 roll, 155 | :1; 2-rot 4 2 roll, 156 | 157 | \ basics 158 | : <= > 0= ; 159 | : >= < 0= ; 160 | : u<= u> 0= ; 161 | : u>= u< 0= ; 162 | 163 | : within ( test low high -- flag ) over - -rot - u> ; 164 | 165 | alias char+ 1+ 166 | :1; chars 0 , \ alias wouldn't work because nop doesn't compile, 167 | : cell+ 4 + ; 168 | : cells 2 lshift ; 169 | 170 | : cr a emit ; 171 | 172 | : type ( c-addr u -- ) 173 | 0 ?do 174 | dup c@ emit char+ loop 175 | drop 176 | ; 177 | 178 | : cmove ( c-addr1 c-addr2 u -- ) 179 | 0 ?do 180 | over c@ over c! char+ swap char+ swap loop 181 | 2drop 182 | ; 183 | 184 | : cmove> ( c-addr1 c-addr2 u -- ) 185 | dup >r + swap r@ + swap r> 186 | 0 ?do 187 | swap 1- tuck c@ swap 1- tuck c! loop 188 | 2drop 189 | ; 190 | 191 | : move ( addr1 addr2 u -- ) 192 | 0 2over u< nip if cmove> else cmove then ; 193 | 194 | \ *************************************************************** 195 | \ execute 196 | 197 | : decode-push ( x -- u ) 198 | dup 00ffffff and 199 | over 01000000 and if ff000000 or then 200 | swap 19 rshift lshift 201 | ; 202 | 203 | : execute ( i*x xt -- j*x ) 204 | dup 1 and if 1- dup cell+ swap then \ variable 205 | @ ?dup if \ nop 206 | dup 1 = if drop rdrop exit then \ exit 207 | dup f0000000 and 208 | dup 10000000 = if xor >r exit then \ call 209 | dup 20000000 = if xor rdrop >r exit then \ jmp 210 | dup 30000000 = if xor swap if drop else rdrop >r then exit then \ jz 211 | dup 40000000 = if xor decode-push exit then \ push 212 | drop [ here 2 cells + ] literal ! [ 0 , ] \ prim/pick/roll -> pad 213 | then 214 | ; 215 | 216 | \ *************************************************************** 217 | \ compiler basics 218 | 219 | variable state 220 | 221 | : ] -1 state ! ; 222 | : [ 0 state ! ; immediate 223 | 224 | 0 value here 225 | variable (words) 226 | 227 | variable base 228 | 229 | : hex 10 base ! ; 230 | : decimal a base ! ; 231 | hex 232 | 233 | 0 value source-id 234 | 235 | create (die-#tiben) 6 cells allot 236 | 237 | : (source) ( -- a-addr ) 238 | (die-#tiben) source-id 1+ c * + ; 239 | 240 | : source (source) 2@ ; 241 | : >in (source) 8 + ; 242 | 243 | : aligned ( addr -- a-addr ) 244 | 3 + fffffffc and ; 245 | 246 | : align ( -- ) 247 | here aligned to here ; 248 | 249 | : , ( x -- ) 250 | here tuck ! cell+ to here ; 251 | 252 | : c, ( char -- ) 253 | here tuck c! char+ to here ; 254 | 255 | : s, ( addr u -- ) 256 | tuck here swap cmove here + to here ; 257 | 258 | \ *************************************************************** 259 | \ assembler 260 | 261 | \ (0000) 0000 0000 0000 0000 0000 0iii iiii 262 | \ primitive, ( u -- ) 263 | alias primitive, , 264 | 265 | \ (00xx) aaaa aaaa aaaa aaaa aaaa aaaa aaaa 266 | \ call, jmp, jz, ( a-addr -- ) 267 | : call, 10000000 or , ; 268 | : jmp, 20000000 or , ; 269 | : jz, 30000000 or , ; 270 | 271 | \ (0100) uuuN nnnn nnnn nnnn nnnn nnnn nnnn 272 | \ u... = shift bits 273 | \ Nn... = number bits 274 | \ (N = sign, extended left) 275 | \ stores n>>u 276 | : push, ( n u -- ) \ Run-time: ( -- n ) 277 | dup 19 lshift -rot rshift fe000000 invert and or 40000000 or , 278 | ; 279 | 280 | \ (0101) 0000 0000 00os 00ww wwww 00ff ffff 281 | \ o = operation (0: pick, 1: roll) 282 | \ s = stack (0: data stack, 1: rstack) 283 | \ w = width 284 | \ f = from 285 | \ pick, roll, rpick, rroll, ( width from -- ) 286 | : pick, 50000000 or swap 8 lshift or , ; 287 | : rpick, 00010000 or pick, ; 288 | : roll, 00020000 or pick, ; 289 | : rroll, 00030000 or pick, ; 290 | 291 | \ *************************************************************** 292 | \ parser 293 | 294 | : /string ( c-addr1 u1 n -- c-addr2 u2 ) tuck - -rot + swap ; 295 | : 1/string ( c-addr1 u1 -- c-addr2 u2 ) 1- swap char+ swap ; 296 | 297 | : <% ( -- c-addr u ) 298 | source >in @ /string 299 | ; 300 | 301 | : (wscan) ( c-addr1 u1 xt -- c-addr2 u2 ) 302 | >r begin dup while 303 | over c@ bl r@ execute while 304 | 1/string 305 | repeat then 306 | rdrop 307 | ; 308 | 309 | : %space ( c-addr1 u1 -- c-addr2 u2 ) ['] <= (wscan) ; 310 | : %word ( c-addr1 u1 -- c-addr2 u2 ) ['] > (wscan) ; 311 | 312 | : %>char ( c-addr1 u1 char -- c-addr2 u2 ) 313 | >r begin dup while 314 | over c@ 315 | dup a <> while 316 | dup r@ <> while 317 | drop 1/string 318 | repeat then 319 | drop 320 | then rdrop 321 | ; 322 | 323 | : save>in ( c-addr -- ) 324 | source drop - >in ! 325 | ; 326 | 327 | : >%< ( c-addr u -- c-addr u ) 328 | over save>in 329 | ; 330 | 331 | : scanned ( c-addr1 -- c-addr2 u ) 332 | source drop >in @ + 333 | tuck - 334 | ; 335 | 336 | : %> ( c-addr1 u1 -- c-addr2 u2 ) 337 | over scanned 338 | 2swap if 1+ then 339 | save>in 340 | ; 341 | 342 | : parse-name ( "name" -- c-addr u ) 343 | <% %space >%< %word %> 344 | ; 345 | 346 | : parse ( char "ccc" -- c-addr u ) 347 | <% rot %>char %> 348 | ; 349 | 350 | : tolower ( char1 -- char2 ) 351 | dup [char] A [[ char Z 1+ ]] literal within if 352 | [[ char a char A - ]] literal + then 353 | ; 354 | 355 | : >digit ( char -- u | -1 ) 356 | dup [char] 0 [[ char 9 1+ ]] literal within if 357 | [char] 0 - else 358 | tolower dup [char] a [[ char z 1+ ]] literal within if 359 | [[ char a a - ]] literal - else 360 | drop -1 then then 361 | ; 362 | 363 | : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) 364 | begin dup while 365 | over c@ >digit 366 | dup base @ u< while 367 | -rot 2>r 368 | >r base @ us>d ud* r> us>d ud+ 369 | 2r> 1/string 370 | repeat 371 | drop 372 | then 373 | ; 374 | 375 | : >num ( c-addr u -- n|u -1 | 0 ) 376 | over c@ [char] - = if 377 | 1/string -1 else 378 | 1 then 379 | -rot 0 0 2swap 380 | >number nip nip ?dup if 381 | 2drop drop 0 else 382 | * -1 then 383 | ; 384 | 385 | : weq ( addr1 u1 addr2 u2 -- flag ) 386 | 2 pick <> if drop 2drop 0 exit then 387 | swap 0 ?do 388 | over c@ tolower over c@ tolower <> if unloop 2drop 0 exit then 389 | swap char+ swap char+ loop 390 | 2drop -1 391 | ; 392 | 393 | : (find) ( addr u -- addr u 0 | xt 1 | xt -1 ) 394 | 2>r (words) 395 | begin @ ?dup while 396 | dup c@ swap 1+ over 1f and 2dup + aligned -rot 2r@ weq if 397 | cell+ swap 6 rshift tuck 1 and or 398 | swap 2 and 1- 2rdrop exit then 399 | nip repeat 400 | 2r> 0 401 | ; 402 | 403 | : (notfound) 404 | cr type s" ? " type abort ; 405 | 406 | : accept ( c-addr +n1 -- +n2 ) 407 | over -rot 408 | begin dup while 409 | key 410 | dup a <> while 411 | dup 1+ while 412 | 2 pick 413 | c! 414 | 1/string 415 | repeat 416 | eof then 417 | drop then 418 | drop swap - 419 | ; 420 | 421 | : set-source ( a-addr u -- ) 422 | (source) 2! 0 >in ! 423 | ; 424 | 425 | : refill ( -- flag ) 426 | source-id if 0 exit then 427 | 3fe00 dup 200 accept set-source 428 | -1 429 | ; 430 | 431 | \ *************************************************************** 432 | \ compiler 433 | 434 | \ word structure: 435 | \ flags|namelen byte 436 | \ name byte{1,31} 437 | \ align? byte{0,3} 438 | \ prev Cell 439 | \ codeword Cell 440 | \ data? Cell* 441 | \ code? Cell* 442 | \ flags: 443 | \ 0x80 immediate 444 | \ 0x40 variable 445 | \ 0x20 unused/reserved 446 | \ 0x1f len(name) 447 | \ a :noname word doesn't have anything before codeword, and 448 | \ normally doesn't have data either. 449 | \ codeword can be 0 (nop), a call to code or anything else. 450 | \ a word defined with does> has in its codeword a call pointing 451 | \ elsewhere. 452 | 453 | \ xt (execution token) is the address of the codeword, 454 | \ "or"ed with 1 if the variable flag is set. 455 | 456 | : literal ( x -- ) 457 | 8 begin ?dup while 458 | 1- 459 | 2dup 1 swap lshift 1- and while 460 | repeat 461 | 2dup ff000000 swap lshift tuck and 462 | ?dup if 463 | over = while then 464 | drop push, exit 465 | then 2drop 466 | then 467 | dup 0 push, 7 push, [[ ' or @ ]] literal primitive, 468 | ; immediate 469 | 470 | : compile, \ Execution: ( xt -- ) 471 | dup 1 and if dup aligned postpone literal 1- then 472 | @ ?dup if , then 473 | ; 474 | 475 | : lineproc 476 | begin parse-name ?dup while 477 | (find) ?dup if 478 | 1- if 479 | state @ 0= while then 480 | execute else 481 | compile, then 482 | else 483 | 2dup >num if 484 | nip nip 485 | state @ if postpone literal then 486 | else (notfound) then 487 | then 488 | repeat 489 | drop 490 | ; 491 | 492 | : evaluate ( i*x c-addr u -- j*x ) 493 | -1 to source-id 494 | set-source lineproc 495 | 0 to source-id 496 | ; 497 | 498 | : callthis, here cell+ call, ; 499 | 500 | variable (:cw) 501 | 502 | : :noname ( -- xt colon-sys ) 503 | here dup (:cw) ! callthis, 0 ] 504 | ; 505 | 506 | : (:def) ( u1 c-addr u2 -- colon-sys ) 507 | here >r 508 | rot over or c, s, align 509 | (words) @ , 510 | here (:cw) ! 511 | r> 512 | ; 513 | 514 | : (:) ( u "name" -- colon-sys ) parse-name (:def) ; 515 | : (;) ( colon-sys -- ) (words) ! ; 516 | 517 | : ;code ( colon-sys -- ) 518 | postpone [ ?dup if (;) then 519 | ; immediate 520 | 521 | : ; ( colon-sys -- ) 522 | ['] exit compile, postpone ;code 523 | ; immediate 524 | 525 | : : ( "name" -- colon-sys ) 526 | 0 (:) callthis, ] 527 | ;; 528 | 529 | \ *************************************************************** 530 | \ microcode 531 | 532 | there @ to here 533 | target there ! 534 | 535 | ]] 536 | 537 | \ abort (4 cells) 538 | (abort) 0 to source-id 539 | 540 | \ quit 541 | begin (quit) refill while 542 | lineproc 543 | state @ 0= if s" ok: " type then 544 | repeat 545 | s" evaluating?! " type 546 | abort 547 | 548 | [[ 549 | 550 | patch-abort 551 | 552 | \ *************************************************************** 553 | \ set new dictionary head to the value of old head 554 | (old-words) @ (words) ! 555 | 556 | \ unlink dictionaries. we will have no comments beyond this 557 | \ point. after execute we will have self-containment. 558 | 559 | ' evaluate ' do-quit 560 | 0 ' nop 4 - ! 561 | execute 562 | 563 | : immediate (words) @ dup c@ 80 or swap c! ; 564 | : \ a parse 2drop ; immediate 565 | 566 | \ *************************************************************** 567 | \ we have self-containment! and \ comments. 568 | \ ( comments ) need [char] needs [postpone] needs ' needs if. 569 | 570 | \ flow control and some helpers 571 | 572 | : if here 0 jz, ; immediate 573 | : then dup @ here or swap ! ; immediate 574 | 575 | : ' \ ( "name" -- xt ) 576 | parse-name (find) if exit then (notfound) ; 577 | 578 | : postpone parse-name (find) 1- if 579 | [ ' literal compile, ' compile, ] literal then compile, ; immediate 580 | \ what is this i don't even 581 | 582 | : ['] ' postpone literal ; immediate 583 | : char parse-name drop c@ ; 584 | : [char] char postpone literal ; immediate 585 | : ( [char] ) parse 2drop ; immediate 586 | 587 | \ *************************************************************** 588 | \ more compiler 589 | 590 | : :1; 0 (:) (;) ; 591 | : primitive :1; primitive, ; 592 | : alias 0 (:) ' compile, (;) ; 593 | : (create) 40 (:) (;) ; 594 | : create (create) 0 , ; 595 | : variable create 0 , ; 596 | : value (create) ['] @ compile, , ; 597 | 598 | : count dup char+ swap c@ ; 599 | : :>s count 1f and ; 600 | : recurse (:cw) @ compile, ; immediate 601 | : does> r> 10000000 or (:cw) @ ! ; 602 | 603 | : constant 604 | value immediate 605 | does> @ state @ if postpone literal then 606 | ; 607 | 608 | 0 constant false 609 | 0 0= constant true 610 | 20 constant bl 611 | 4 constant cell 612 | 613 | \ *************************************************************** 614 | \ flow control 615 | 616 | alias cs-pick pick 617 | alias cs-roll roll 618 | 619 | : begin here ; immediate 620 | : again jmp, ; immediate 621 | : until jz, ; immediate 622 | : ahead here 0 jmp, ; immediate 623 | 624 | : else postpone ahead swap postpone then ; immediate 625 | : while postpone if swap ; immediate 626 | : repeat postpone again postpone then ; immediate 627 | 628 | : >body fffffffc and cell+ ; 629 | : to ' >body state @ if postpone literal postpone ! else ! then ; immediate 630 | : allot here + aligned to here ; 631 | 632 | : 2>r postpone swap postpone >r postpone >r ; immediate 633 | : 2r> postpone r> postpone r> postpone swap ; immediate 634 | : 2rdrop postpone rdrop postpone rdrop ; immediate 635 | : 2r@ 2 0 rpick, postpone 2r> ; immediate 636 | alias i r@ 637 | : j 1 2 rpick, postpone r> ; immediate 638 | 639 | : (do) postpone begin postpone 2>r ; 640 | : do 0 (do) ; immediate 641 | : ?do 0 postpone 2dup postpone <> postpone if (do) ; immediate 642 | : unloop postpone 2rdrop ; immediate 643 | : (loop) 644 | postpone 2dup postpone = 645 | postpone until 646 | begin ?dup while postpone then repeat 647 | postpone 2drop 648 | ; 649 | : loop postpone 2r> postpone 1+ (loop) ; immediate 650 | : +loop postpone 2r> postpone rot postpone + (loop) ; immediate 651 | 652 | \ fucking leave, how does it work? 653 | : leave 654 | 0 begin over while swap >r 1+ repeat 655 | postpone ahead swap 656 | begin ?dup while r> swap 1- repeat 657 | ; immediate 658 | 659 | : case 0 ; immediate 660 | : of 1+ >r postpone over postpone = postpone if postpone drop r> ; immediate 661 | : endof >r postpone else r> ; immediate 662 | : endcase postpone drop 0 ?do postpone then loop ; immediate 663 | 664 | : fill -rot 0 ?do 2dup c! 1+ loop 2drop ; 665 | 666 | \ *************************************************************** 667 | \ string output 668 | 669 | : space bl emit ; 670 | : spaces 0 ?do space loop ; 671 | 672 | : sliteral \ Compilation: ( c-addr1 u -- ) Run-time: ( -- c-addr2 u ) 673 | tuck here -rot 0 call, 674 | s, align 675 | postpone then ['] r> compile, postpone literal 676 | ; immediate 677 | 678 | : s" \ Compilation: ( "ccc" -- ) Run-time: ( -- c-addr u ) 679 | [char] " parse postpone sliteral 680 | ; immediate 681 | 682 | : ." \ Compilation: ( "ccc" -- ) Run-time: ( -- ) 683 | postpone s" postpone type 684 | ; immediate 685 | 686 | : s( ( "ccc" -- c-addr u ) 687 | [char] ) parse 688 | ; immediate 689 | 690 | : .( ( "ccc" -- ) 691 | postpone s( type 692 | ; immediate 693 | 694 | \ *************************************************************** 695 | \ number output 696 | 697 | : min 2dup > if swap then drop ; 698 | : max 2dup < if swap then drop ; 699 | : abs dup 0< if negate then ; 700 | 701 | : s>d dup 0< if -1 else 0 then ; 702 | 0 constant us>d 703 | alias d>s drop 704 | alias ud>s drop 705 | 706 | variable (#pad) 707 | 708 | 44 allot 709 | here constant (end#pad) 710 | 711 | : <# ( -- ) 712 | (end#pad) (#pad) ! 713 | ; 714 | 715 | : hold ( char -- ) 716 | (#pad) @ 1- tuck c! (#pad) ! 717 | ; 718 | 719 | : sign ( n -- ) 720 | 0< if [char] - hold then 721 | ; 722 | 723 | : # ( ud1 -- ud2 ) 724 | base @ us>d ud/mod 2swap ud>s 725 | dup a < if [char] 0 else [ char A a - ] literal then + 726 | hold 727 | ; 728 | 729 | : #s ( ud1 -- ud2 ) 730 | begin # 2dup or 0= until 731 | ; 732 | 733 | : #> ( xd -- c-addr u ) 734 | 2drop (#pad) @ (end#pad) over - 735 | ; 736 | 737 | : holds ( c-addr u -- ) 738 | tuck + swap 0 ?do 1- dup c@ hold loop drop 739 | ; 740 | 741 | : typer ( c-addr u n -- ) 742 | over - 0 max spaces type 743 | ; 744 | 745 | : <.> ( n u1 -- c-addr u2 ) us>d <# #s rot sign #> ; 746 | : (s.) ( n -- ) dup abs <.> type ; 747 | : (u.) ( u -- ) 0 swap <.> type ; 748 | : .r ( n1 n2 -- ) swap dup abs <.> rot typer ; 749 | : u.r ( u n -- ) 0 rot <.> rot typer ; 750 | : u.x ( u -- ) base @ swap hex (u.) base ! ; 751 | : h.x ( u -- ) base @ swap hex us>d <# # # # #s #> type base ! ; 752 | : .x ( u -- ) base @ swap hex us>d <# # # # # # # # # #> type base ! ; 753 | : . ( n -- ) (s.) space ; 754 | : u. ( u -- ) (u.) space ; 755 | : ? ( a-addr -- ) @ . ; 756 | 757 | : .s depth 1- -1 swap ?do i pick . -1 +loop cr ; 758 | 759 | : #go ( ud1 -- ud2 ) 760 | s" , " holds # # s" 0x" holds 761 | ; 762 | 763 | : .go ( x -- ) 764 | base @ swap hex 765 | us>d <# #go #go #go #go #> type 766 | base ! 767 | ; 768 | 769 | : holdp ( char -- ) 770 | dup 7f < if 771 | dup bl < while then 772 | drop [char] . 773 | then hold 774 | ; 775 | 776 | : #p ( ud1 -- ud2 ) 777 | ud>s dup ff and holdp 8 rshift us>d 778 | ; 779 | 780 | : .p ( x -- ) 781 | us>d <# #p #p #p #p #> type 782 | ; 783 | 784 | \ *************************************************************** 785 | \ disassembler and dump 786 | 787 | : dis-pickroll ( x -- c-addr u ) 788 | dup 0ffcc0c0 and if drop 0 0 exit then 789 | base @ swap hex 790 | us>d <# 791 | over 3f and us>d #s 2drop bl hold 792 | over 8 rshift 3f and us>d #s 2drop bl hold 793 | over 00020000 and if 794 | s" roll" else 795 | s" pick" then 796 | holds 797 | over 00010000 and if 798 | [char] r hold then 799 | bl hold bl hold 800 | #> 801 | rot base ! 802 | ; 803 | 804 | : dis-primitive ( x -- c-addr u ) 805 | >r [ ' bye cell+ ] literal 806 | begin ?dup while 807 | :>s 2dup + aligned dup cell+ @ r@ <> while 808 | nip nip @ 809 | repeat 810 | drop <# 2dup holds bl hold bl hold #> else 811 | 0 0 then 812 | rdrop 813 | ; 814 | 815 | : dis ( x -- ) 816 | dup 80 u< if dis-primitive type exit then 817 | dup f0000000 and 818 | dup 10000000 = if xor ." call " h.x exit then 819 | dup 20000000 = if xor ." jmp " h.x exit then 820 | dup 30000000 = if xor ." jz " h.x exit then 821 | dup 40000000 = if xor ." push " decode-push u.x exit then 822 | dup 50000000 = if xor dis-pickroll type exit then 823 | 2drop 824 | ; 825 | 826 | : dumpcell2go ( a-addr -- a-addr ) 827 | dup @ 828 | 9 emit dup .go ." // " over h.x bl emit bl emit dup .p dis cr 829 | ; 830 | 831 | : dumpcell ( a-addr -- a-addr ) 832 | dup .x ." : " dup @ .x cr 833 | ; 834 | 835 | : (dump) ( a-addr u xt -- ) 836 | -rot 837 | 2 rshift 0 ?do 838 | over execute 839 | cell+ 840 | loop 841 | 2drop 842 | ; 843 | 844 | : dump ( a-addr u -- ) 845 | ['] dumpcell (dump) 846 | ; 847 | 848 | : dump2go ( a-addr u -- ) 849 | ." // Autogenerated! Shall not be edited." cr cr 850 | ." package forth" cr cr 851 | ." var kernel = []byte{" cr 852 | ['] dumpcell2go (dump) 853 | [char] } emit cr 854 | ; 855 | 856 | : dumplast (words) @ here over - dump ; 857 | 858 | : words ( -- ) 859 | (words) begin 860 | @ ?dup while 861 | :>s 2dup type a 2dup mod - spaces + aligned repeat 862 | ; 863 | 864 | \ *************************************************************** 865 | \ environmental queries 866 | 867 | : (>env) 868 | parse-name dup c, s, align 869 | dup 1+ 0 do , loop 870 | ; 871 | 872 | create (env) 873 | ff 1 (>env) /COUNTED-STRING 874 | 44 1 (>env) /HOLD 875 | 0 1 (>env) /PAD 876 | 20 1 (>env) ADDRESS-UNIT-BITS 877 | 0 1 (>env) FLOORED 878 | ff 1 (>env) MAX-CHAR 879 | 7fffffff ffffffff 2 (>env) MAX-D 880 | 7fffffff 1 (>env) MAX-N 881 | ffffffff 1 (>env) MAX-U 882 | ffffffff ffffffff 2 (>env) MAX-UD 883 | 20 1 (>env) RETURN-STACK-CELLS 884 | 20 1 (>env) STACK-CELLS 885 | -1 1 (>env) CORE 886 | 0 c, \ align 887 | 888 | : environment? 889 | (env) begin count dup while 890 | 2over 2over weq if 891 | 2swap 2drop + aligned dup @ 0 ?do 892 | cell+ dup @ swap loop 893 | drop -1 exit then 894 | + aligned dup @ 1+ cells + 895 | repeat 896 | 2drop 2drop 0 897 | ; 898 | 899 | decimal 900 | -------------------------------------------------------------------------------- /forth/doc.go: -------------------------------------------------------------------------------- 1 | // Copyright 2011, 2013 Vadim Vygonets. All rights reserved. 2 | // Use of this source code is governed by the Bugroff 3 | // license that can be found in the LICENSE file. 4 | 5 | // Package forth implements the Forego virtual machine. 6 | // 7 | // The Forego VM is a big-endian FORTH machine with 32-bit cells 8 | // having two 32-cell stacks and 256 KB of memory. 9 | // 10 | // Each VM instruction occupies a 32-bit cell. The most 11 | // significant 4 bits contain the opcode, which leaves 28 bits 12 | // for parameters. The default kernel makes instructions 13 | // accessible using compiling words. Forego has six 14 | // instructions, one of which is further subdivided into 15 | // "primitives", described further below. 16 | // 17 | // 0: primitive 18 | // FORTH compiling word: PRIMITIVE, 19 | // FORTH defining word: PRIMITIVE 20 | // Bit field: (0000) 0000 0000 0000 0000 0000 0ppp pppp 21 | // p... = primitive 22 | // Run primitive p from the list below. 23 | // 24 | // 1: call 25 | // FORTH compiling word: CALL, 26 | // Bit field: (0001) aaaa aaaa aaaa aaaa aaaa aaaa aaaa 27 | // a... = address 28 | // Call the address a, pushing the address of the next cell 29 | // to rstack. 30 | // 31 | // 2: jmp 32 | // FORTH compiling word: JMP, 33 | // Bit field: (0010) aaaa aaaa aaaa aaaa aaaa aaaa aaaa 34 | // a... = address 35 | // Jump to the address a. 36 | // 37 | // 3: jz 38 | // FORTH compiling word: JZ, 39 | // Bit field: (0011) aaaa aaaa aaaa aaaa aaaa aaaa aaaa 40 | // a... = address 41 | // Pop a cell off the stack. If the cell value is zero, 42 | // jump to the address a. 43 | // 44 | // 4: push 45 | // FORTH compiling word: PUSH, 46 | // also accessible via: LITERAL 47 | // Bit field: (0100) sssN nnnn nnnn nnnn nnnn nnnn nnnn 48 | // s... = shift 49 | // Nn... = number 50 | // (N = sign, extended left) 51 | // Push n, shifted left s bits, to the stack, propagating 52 | // the sign bit N to the left. 53 | // 54 | // 5: pick/roll 55 | // FORTH compiling words: PICK, ROLL, RPICK, RROLL, 56 | // Bit field: (0101) 0000 0000 00os 00ww wwww 00ff ffff 57 | // o = operation (0: pick, 1: roll) 58 | // s = stack (0: data stack, 1: rstack) 59 | // w... = width 60 | // f... = from 61 | // Pick or roll w cells from depth f in stack or rstack. 62 | // 63 | // Primitives are simple instructions operating on the stacks 64 | // or providing low-level services, intended to be called 65 | // directly from FORTH code. The default kernel exports the 66 | // primitives as FORTH words. Most instructions operate as 67 | // described in DPANS, others are commented. 68 | // 69 | // Opcode FORTH name 70 | // 71 | // 0 NOP ( -- ) \ do nothing 72 | // 1 EXIT ( R: nest-sys -- ) 73 | // 2 (ABORT) ( i*x -- ) \ clear stack 74 | // 3 (QUIT) ( R: i*x -- ) \ clear rstack 75 | // 4 PICK ( xu ... x0 u -- xu ... x0 xu ) 76 | // 5 ROLL ( xu xu-1 ... x0 u -- xu-1 ... x0 xu ) 77 | // 6 DEPTH ( -- +n ) 78 | // 7 DROP ( x -- ) 79 | // 8 2DROP ( x1 x2 -- ) 80 | // 9 ?DUP ( x -- 0 | x x ) 81 | // A NIP ( x1 x2 -- x2 ) 82 | // B TUCK ( x1 x2 -- x2 x1 x2 ) 83 | // C >R ( x -- ) ( R: -- x ) 84 | // D R> ( -- x ) ( R: x -- ) 85 | // E R@ ( -- x ) ( R: x -- x ) 86 | // F RDROP ( R: x -- ) 87 | // 88 | // 10 @ ( a-addr -- x ) 89 | // 11 ! ( x a-addr -- ) 90 | // 12 C@ ( c-addr -- char ) 91 | // 13 C! ( char c-addr -- ) 92 | // 14 2! ( x1 x2 a-addr -- ) 93 | // 15 2@ ( a-addr -- x1 x2 ) 94 | // 16 +! ( n|u a-addr -- ) 95 | // 96 | // 1A = ( x1 x2 -- flag ) 97 | // 1B <> ( x1 x2 -- flag ) 98 | // 1C < ( n1 n2 -- flag ) 99 | // 1D > ( n1 n2 -- flag ) 100 | // 1E U< ( u1 u2 -- flag ) 101 | // 1F U> ( u1 u2 -- flag ) 102 | // 103 | // 20 0< ( n -- flag ) 104 | // 21 0> ( n -- flag ) 105 | // 22 0= ( x -- flag ) 106 | // 23 0<> ( x -- flag ) 107 | // 24 INVERT ( x1 -- x2 ) 108 | // 25 AND ( x1 x2 -- x3 ) 109 | // 26 OR ( x1 x2 -- x3 ) 110 | // 27 XOR ( x1 x2 -- x3 ) 111 | // 28 LSHIFT ( x1 u -- x2 ) 112 | // 29 RSHIFT ( x1 u -- x2 ) 113 | // 2A 2* ( x1 -- x2 ) 114 | // 2B 2/ ( x1 -- x2 ) 115 | // 2C 1+ ( n1|u1 -- n2|u2 ) 116 | // 2D 1- ( n1|u1 -- n2|u2 ) 117 | // 2E + ( n1|u1 n2|u2 -- n3|u3 ) 118 | // 2F - ( n1|u1 n2|u2 -- n3|u3 ) 119 | // 120 | // 30 * ( n1|u1 n2|u2 -- n3|u3 ) 121 | // 31 / ( n1|u1 n2|u2 -- n3|u3 ) 122 | // 32 MOD ( n1 n2 -- n3 ) 123 | // 33 /MOD ( n1 n2 -- n3 n4 ) 124 | // 34 */ ( n1 n2 n3 -- n4 ) 125 | // 35 */MOD ( n1 n2 n3 -- n4 n5 ) 126 | // 36 M* ( n1 n2 -- d ) 127 | // 37 UM* ( u1 u2 -- ud ) 128 | // 38 FM/MOD ( d1 n1 -- n2 n3 ) 129 | // 39 SM/REM ( d1 n1 -- n2 n3 ) 130 | // 3A UM/MOD ( d1 n1 -- n2 n3 ) 131 | // 3B NEGATE ( n1 -- n2 ) 132 | // 3C UD+ ( ud1 ud1 -- ud3 ) \ unsigned double cell 133 | // 3D UD- ( ud1 ud1 -- ud3 ) \ arithmetics 134 | // 3E UD* ( ud1 ud1 -- ud3 ) \ 135 | // 3F UD/MOD ( ud1 ud1 -- ud3 ud4 ) \ 136 | // 137 | // 40 KEY ( -- char | -1 ) 138 | // 41 EMIT ( char -- ) 139 | // 140 | // 47 TRACE ( flag -- ) \ set/reset VM tracing 141 | // 142 | // 50 BYE ( -- ) 143 | // 51 EOF ( -- ) \ raise EOF trap 144 | package forth 145 | -------------------------------------------------------------------------------- /forth/error.go: -------------------------------------------------------------------------------- 1 | package forth 2 | 3 | // List of VM traps for Errno 4 | const ( 5 | Bye = Errno(iota) 6 | EOF 7 | StackOverflow 8 | StackUnderflow 9 | RStackOverflow 10 | RStackUnderflow 11 | IllegalInstruction 12 | IllegalAddress 13 | UnalignedAddress 14 | ZeroDivision 15 | IOError 16 | ) 17 | 18 | var strError = []string{ 19 | "BYE", 20 | "EOF", 21 | "stack overflow", 22 | "stack underflow", 23 | "return stack overflow", 24 | "return stack underflow", 25 | "illegal instruction", 26 | "illegal address", 27 | "unaligned address", 28 | "zero division", 29 | "I/O error", 30 | } 31 | 32 | // Errno describes the reason for a VM trap. 33 | type Errno int 34 | 35 | func (e Errno) Error() string { 36 | return strError[e] 37 | } 38 | 39 | func rstackError(e error) error { 40 | if e == nil { 41 | return nil 42 | } 43 | return e.(Errno) + (RStackOverflow - StackOverflow) 44 | } 45 | 46 | // Error describes the cause and the context of a VM trap. 47 | type Error struct { 48 | Errno Errno // nature of the trap 49 | Err error // I/O error when Errno is IOError 50 | PC Cell // program counter before the trap 51 | Instr Instr // instruction that raised the trap 52 | Addr Cell // address when Errno is IllegalAddress or UnalignedAddress 53 | Stack Stack // data stack 54 | RStack Stack // return stack 55 | } 56 | 57 | func (e *Error) Error() string { 58 | var msg = "forego: " 59 | if e.Err != nil { 60 | msg += e.Err.Error() 61 | } else { 62 | msg += e.Errno.Error() 63 | switch e.Errno { 64 | case IllegalInstruction: 65 | msg += " " + Cell(e.Instr).String() 66 | case IllegalAddress, UnalignedAddress: 67 | msg += " " + e.Addr.String() 68 | } 69 | } 70 | return msg + " at " + e.PC.String() 71 | } 72 | 73 | func (vm *VM) newErrorFull(errno Errno, err error, addr Cell) error { 74 | return &Error{ 75 | Errno: errno, 76 | Err: err, 77 | PC: vm.lastpc, 78 | Addr: addr, 79 | Instr: vm.icell, 80 | Stack: append(make([]Cell, 0, stackDepth), vm.stack...), 81 | RStack: append(make([]Cell, 0, stackDepth), vm.rstack...), 82 | } 83 | } 84 | 85 | func (vm *VM) newErrorAddr(errno Errno, addr Cell) error { 86 | return vm.newErrorFull(errno, nil, addr) 87 | } 88 | 89 | func (vm *VM) newError(errno Errno) error { 90 | return vm.newErrorAddr(errno, 0) 91 | } 92 | 93 | func (vm *VM) newIOError(e error) error { 94 | return vm.newErrorFull(IOError, e, 0) 95 | } 96 | -------------------------------------------------------------------------------- /forth/prim.go: -------------------------------------------------------------------------------- 1 | // Copyright 2011, 2013 Vadim Vygonets. All rights reserved. 2 | // Use of this source code is governed by the Bugroff 3 | // license that can be found in the LICENSE file. 4 | 5 | package forth 6 | 7 | import "io" 8 | 9 | func (vm *VM) unimplemented() error { 10 | return IllegalInstruction 11 | } 12 | 13 | // nop ( -- ) 14 | func (vm *VM) nop() error { 15 | return nil 16 | } 17 | 18 | // exit ( -- ) ( R: nest-sys -- ) 19 | func (vm *VM) exit() error { 20 | var err error 21 | vm.pc, err = vm.rstack.pop() 22 | return rstackError(err) 23 | } 24 | 25 | // (abort) ( i*x -- ) 26 | func (vm *VM) abortHelper() error { 27 | vm.stack.clear() 28 | return nil 29 | } 30 | 31 | // (quit) ( R: i*x -- ) 32 | func (vm *VM) quitHelper() error { 33 | vm.rstack.clear() 34 | return nil 35 | } 36 | 37 | // pick ( xu ... x1 x0 u -- xu ... x1 x0 xu ) 38 | func (vm *VM) pick() error { 39 | c, err := vm.stack.pop() 40 | if err != nil { 41 | return err 42 | } 43 | return vm.stack.pick(1, int(c)) 44 | } 45 | 46 | // roll ( xu xu-1 ... x0 u -- xu-1 ... x0 xu ) 47 | func (vm *VM) roll() error { 48 | c, err := vm.stack.pop() 49 | if err != nil { 50 | return err 51 | } 52 | return vm.stack.roll(1, int(c)) 53 | } 54 | 55 | // depth ( -- +n ) 56 | func (vm *VM) depth() error { 57 | return vm.stack.push(vm.stack.depth()) 58 | } 59 | 60 | // drop ( x -- ) 61 | func (vm *VM) drop() error { 62 | _, err := vm.stack.pop() 63 | return err 64 | } 65 | 66 | // 2drop ( x1 x2 -- ) 67 | func (vm *VM) twoDrop() error { 68 | _, _, err := vm.stack.pop2() 69 | return err 70 | } 71 | 72 | // ?dup ( x -- 0 | x x ) 73 | func (vm *VM) questionDup() error { 74 | c, err := vm.stack.peek() 75 | if c == 0 { 76 | return err 77 | } 78 | return vm.stack.push(c) 79 | } 80 | 81 | // nip ( x1 x2 -- x2 ) 82 | func (vm *VM) nip() error { 83 | if err := vm.stack.roll(1, 1); err != nil { // swap 84 | return err 85 | } 86 | vm.stack.pop() // drop 87 | return nil 88 | } 89 | 90 | // tuck ( x1 x2 -- x2 x1 x2 ) 91 | func (vm *VM) tuck() error { 92 | if err := vm.stack.need(2, 1); err != nil { 93 | return err 94 | } 95 | vm.stack.pick(1, 0) // dup 96 | vm.stack.roll(2, 1) // -rot 97 | return nil 98 | } 99 | 100 | // >r ( x -- ) ( R: -- x ) 101 | func (vm *VM) toR() error { 102 | c, err := vm.stack.pop() 103 | if err != nil { 104 | return err 105 | } 106 | return rstackError(vm.rstack.push(c)) 107 | } 108 | 109 | // r> ( -- x ) ( R: x -- ) 110 | func (vm *VM) rFrom() error { 111 | c, err := vm.rstack.pop() 112 | if err != nil { 113 | return rstackError(err) 114 | } 115 | return vm.stack.push(c) 116 | } 117 | 118 | // r@ ( -- x ) ( R: x -- x ) 119 | func (vm *VM) rFetch() error { 120 | c, err := vm.rstack.peek() 121 | if err != nil { 122 | return rstackError(err) 123 | } 124 | return vm.stack.push(c) 125 | } 126 | 127 | // rdrop ( R: x -- ) 128 | func (vm *VM) rDrop() error { 129 | _, err := vm.rstack.pop() 130 | return rstackError(err) 131 | } 132 | 133 | // @ ( a-addr -- x ) 134 | func (vm *VM) fetch() error { 135 | c, err := vm.stack.pop() 136 | if err != nil { 137 | return err 138 | } 139 | if c, err = vm.readCell(c); err != nil { 140 | return err 141 | } 142 | return vm.stack.push(c) 143 | } 144 | 145 | // ! ( x a-addr -- ) 146 | func (vm *VM) store() error { 147 | c, a, err := vm.stack.pop2() 148 | if err != nil { 149 | return err 150 | } 151 | return vm.writeCell(a, c) 152 | } 153 | 154 | // c@ ( c-addr -- char ) 155 | func (vm *VM) cFetch() error { 156 | c, err := vm.stack.pop() 157 | if err != nil { 158 | return err 159 | } 160 | if c, err = vm.readByte(c); err != nil { 161 | return err 162 | } 163 | return vm.stack.push(c) 164 | } 165 | 166 | // c! ( char c-addr -- ) 167 | func (vm *VM) cStore() error { 168 | c, a, err := vm.stack.pop2() 169 | if err != nil { 170 | return err 171 | } 172 | return vm.writeByte(a, c) 173 | } 174 | 175 | // 2@ ( a-addr -- x1 x2 ) 176 | func (vm *VM) twoFetch() error { 177 | a, err := vm.stack.pop() 178 | if err != nil { 179 | return err 180 | } 181 | c, err := vm.readCell(a + cellSize) 182 | if err != nil { 183 | return err 184 | } 185 | vm.stack.push(c) // will succeed 186 | if c, err = vm.readCell(a); err != nil { 187 | return err 188 | } 189 | return vm.stack.push(c) 190 | } 191 | 192 | // 2! ( x1 x2 a-addr -- ) 193 | func (vm *VM) twoStore() error { 194 | if err := vm.stack.need(3, 0); err != nil { 195 | return err 196 | } 197 | c, a, _ := vm.stack.pop2() 198 | if err := vm.writeCell(a, c); err != nil { 199 | return err 200 | } 201 | c, _ = vm.stack.pop() 202 | return vm.writeCell(a+cellSize, c) 203 | } 204 | 205 | // +! ( n|u a-addr -- ) 206 | func (vm *VM) plusStore() error { 207 | c, a, err := vm.stack.pop2() 208 | if err != nil { 209 | return err 210 | } 211 | v, err := vm.readCell(a) 212 | if err != nil { 213 | return err 214 | } 215 | return vm.writeCell(a, v+c) 216 | } 217 | 218 | func flag(b bool) Cell { 219 | if b { 220 | return forthTrue 221 | } 222 | return forthFalse 223 | } 224 | 225 | func (vm *VM) unaryOp(op func(c Cell) Cell) error { 226 | c, err := vm.stack.pop() 227 | if err != nil { 228 | return err 229 | } 230 | return vm.stack.push(op(c)) 231 | } 232 | 233 | func (vm *VM) binaryOp(op func(x, y Cell) Cell) error { 234 | x, y, err := vm.stack.pop2() 235 | if err != nil { 236 | return err 237 | } 238 | return vm.stack.push(op(x, y)) 239 | } 240 | 241 | // = ( x1 x2 -- flag ) 242 | func (vm *VM) equals() error { 243 | return vm.binaryOp(func(x, y Cell) Cell { return flag(x == y) }) 244 | } 245 | 246 | // <> ( x1 x2 -- flag ) 247 | func (vm *VM) notEquals() error { 248 | return vm.binaryOp(func(x, y Cell) Cell { return flag(x != y) }) 249 | } 250 | 251 | // < ( n1 n2 -- flag ) 252 | func (vm *VM) lessThan() error { 253 | return vm.binaryOp(func(x, y Cell) Cell { 254 | return flag(sCell(x) < sCell(y)) 255 | }) 256 | } 257 | 258 | // > ( n1 n2 -- flag ) 259 | func (vm *VM) greaterThan() error { 260 | return vm.binaryOp(func(x, y Cell) Cell { 261 | return flag(sCell(x) > sCell(y)) 262 | }) 263 | } 264 | 265 | // u< ( u1 u2 -- flag ) 266 | func (vm *VM) uLessThan() error { 267 | return vm.binaryOp(func(x, y Cell) Cell { return flag(x < y) }) 268 | } 269 | 270 | // u> ( u1 u2 -- flag ) 271 | func (vm *VM) uGreaterThan() error { 272 | return vm.binaryOp(func(x, y Cell) Cell { return flag(x > y) }) 273 | } 274 | 275 | // 0< ( n -- flag ) 276 | func (vm *VM) zeroLess() error { 277 | return vm.unaryOp(func(c Cell) Cell { return flag(sCell(c) < 0) }) 278 | } 279 | 280 | // 0> ( n -- flag ) 281 | func (vm *VM) zeroGreater() error { 282 | return vm.unaryOp(func(c Cell) Cell { return flag(sCell(c) > 0) }) 283 | } 284 | 285 | // 0= ( x -- flag ) 286 | func (vm *VM) zeroEquals() error { 287 | return vm.unaryOp(func(c Cell) Cell { return flag(c == forthFalse) }) 288 | } 289 | 290 | // 0<> ( x -- flag ) 291 | func (vm *VM) zeroNotEquals() error { 292 | return vm.unaryOp(func(c Cell) Cell { return flag(c != forthFalse) }) 293 | } 294 | 295 | // invert ( x1 -- x2 ) 296 | func (vm *VM) invert() error { 297 | return vm.unaryOp(func(c Cell) Cell { return ^c }) 298 | } 299 | 300 | // and ( x1 x2 -- x3 ) 301 | func (vm *VM) and() error { 302 | return vm.binaryOp(func(x, y Cell) Cell { return x & y }) 303 | } 304 | 305 | // or ( x1 x2 -- x3 ) 306 | func (vm *VM) or() error { 307 | return vm.binaryOp(func(x, y Cell) Cell { return x | y }) 308 | } 309 | 310 | // xor ( x1 x2 -- x3 ) 311 | func (vm *VM) xor() error { 312 | return vm.binaryOp(func(x, y Cell) Cell { return x ^ y }) 313 | } 314 | 315 | // lshift ( x1 u -- x2 ) 316 | func (vm *VM) lShift() error { 317 | return vm.binaryOp(func(x, y Cell) Cell { return x << y }) 318 | } 319 | 320 | // rshift ( x1 u -- x2 ) 321 | func (vm *VM) rShift() error { 322 | return vm.binaryOp(func(x, y Cell) Cell { return x >> y }) 323 | } 324 | 325 | // 2* ( x1 -- x2 ) 326 | func (vm *VM) twoStar() error { 327 | return vm.unaryOp(func(c Cell) Cell { return c << 1 }) 328 | } 329 | 330 | // 2/ ( x1 -- x2 ) 331 | func (vm *VM) twoSlash() error { 332 | return vm.unaryOp(func(c Cell) Cell { return Cell(sCell(c) / 2) }) 333 | } 334 | 335 | // 1+ ( n1|u1 -- n2|u2 ) 336 | func (vm *VM) onePlus() error { 337 | return vm.unaryOp(func(c Cell) Cell { return c + 1 }) 338 | } 339 | 340 | // 1- ( n1|u1 -- n2|u2 ) 341 | func (vm *VM) oneMinus() error { 342 | return vm.unaryOp(func(c Cell) Cell { return c - 1 }) 343 | } 344 | 345 | // + ( n1|u1 n2|u2 -- n3|u3 ) 346 | func (vm *VM) plus() error { 347 | return vm.binaryOp(func(x, y Cell) Cell { return x + y }) 348 | } 349 | 350 | // - ( n1|u1 n2|u2 -- n3|u3 ) 351 | func (vm *VM) minus() error { 352 | return vm.binaryOp(func(x, y Cell) Cell { return x - y }) 353 | } 354 | 355 | // * ( n1|u1 n2|u2 -- n3|u3 ) 356 | func (vm *VM) star() error { 357 | return vm.binaryOp(func(x, y Cell) Cell { return x * y }) 358 | } 359 | 360 | // / ( n1 n2 -- n3 ) 361 | func (vm *VM) slash() error { 362 | x, y, err := vm.stack.pop2() 363 | switch { 364 | case err != nil: 365 | return err 366 | case y == 0: 367 | return ZeroDivision 368 | } 369 | return vm.stack.push(Cell(sCell(x) / sCell(y))) 370 | } 371 | 372 | // mod ( n1 n2 -- n3 ) 373 | func (vm *VM) mod() error { 374 | x, y, err := vm.stack.pop2() 375 | switch { 376 | case err != nil: 377 | return err 378 | case y == 0: 379 | return ZeroDivision 380 | } 381 | return vm.stack.push(Cell(sCell(x) % sCell(y))) 382 | } 383 | 384 | // /mod ( n1 n2 -- n3 n4 ) 385 | func (vm *VM) slashMod() error { 386 | x, y, err := vm.stack.pop2() 387 | switch { 388 | case err != nil: 389 | return err 390 | case y == 0: 391 | return ZeroDivision 392 | } 393 | vm.stack.push(Cell(sCell(x) % sCell(y))) // will succeed 394 | return vm.stack.push(Cell(sCell(x) / sCell(y))) 395 | } 396 | 397 | // */ ( n1 n2 n3 -- n4 ) 398 | func (vm *VM) starSlash() error { 399 | if err := vm.stack.need(3, 0); err != nil { 400 | return err 401 | } 402 | c, _ := vm.stack.pop() 403 | if c == 0 { 404 | return ZeroDivision 405 | } 406 | a, b, _ := vm.stack.pop2() 407 | return vm.stack.push(Cell( 408 | sdCell(sCell(a)) * sdCell(sCell(b)) / sdCell(sCell(c)))) 409 | } 410 | 411 | // */mod ( n1 n2 n3 -- n4 n5 ) 412 | func (vm *VM) starSlashMod() error { 413 | if err := vm.stack.need(3, 0); err != nil { 414 | return err 415 | } 416 | c, _ := vm.stack.pop() 417 | if c == 0 { 418 | return ZeroDivision 419 | } 420 | a, b, _ := vm.stack.pop2() 421 | vm.stack.push(Cell( // will succeed 422 | sdCell(sCell(a)) * sdCell(sCell(b)) % sdCell(sCell(c)))) 423 | return vm.stack.push(Cell( 424 | sdCell(sCell(a)) * sdCell(sCell(b)) / sdCell(sCell(c)))) 425 | } 426 | 427 | // m* ( n1 n2 -- d ) 428 | func (vm *VM) mStar() error { 429 | a, b, err := vm.stack.pop2() 430 | if err != nil { 431 | return err 432 | } 433 | return vm.stack.pushd(dCell(sdCell(sCell(a)) * sdCell(sCell(b)))) 434 | } 435 | 436 | // um* ( u1 u2 -- ud ) 437 | func (vm *VM) umStar() error { 438 | a, b, err := vm.stack.pop2() 439 | if err != nil { 440 | return err 441 | } 442 | return vm.stack.pushd(dCell(a) * dCell(b)) 443 | } 444 | 445 | // fm/mod ( d1 n1 -- n2 n3 ) 446 | func (vm *VM) fmSlashMod() error { 447 | // (a - (a<0 ? b-1 : 0)) / b 448 | if err := vm.stack.need(3, 0); err != nil { 449 | return err 450 | } 451 | b, _ := vm.stack.pop() 452 | if b == 0 { 453 | return ZeroDivision 454 | } 455 | a, _ := vm.stack.popd() 456 | q := sdCell(a) / sdCell(sCell(b)) 457 | if (sdCell(a)%sdCell(sCell(b)) != 0) && 458 | ((sdCell(a) < 0) != (sdCell(sCell(b)) < 0)) { 459 | q-- 460 | } 461 | vm.stack.push(Cell(sdCell(a) - (sdCell(a) * q))) // will succeed 462 | return vm.stack.push(Cell(q)) 463 | } 464 | 465 | // sm/rem ( d1 n1 -- n2 n3 ) 466 | func (vm *VM) smSlashRem() error { 467 | if err := vm.stack.need(3, 0); err != nil { 468 | return err 469 | } 470 | b, _ := vm.stack.pop() 471 | if b == 0 { 472 | return ZeroDivision 473 | } 474 | a, _ := vm.stack.popd() 475 | vm.stack.push(Cell(sdCell(a) % sdCell(sCell(b)))) // will succeed 476 | return vm.stack.push(Cell(sdCell(a) / sdCell(sCell(b)))) 477 | } 478 | 479 | // um/mod ( ud n2 -- n3 n4 ) 480 | func (vm *VM) umSlashMod() error { 481 | if err := vm.stack.need(3, 0); err != nil { 482 | return err 483 | } 484 | b, _ := vm.stack.pop() 485 | if b == 0 { 486 | return ZeroDivision 487 | } 488 | a, _ := vm.stack.popd() 489 | vm.stack.push(Cell(a % dCell(b))) // will succeed 490 | return vm.stack.push(Cell(a / dCell(b))) 491 | } 492 | 493 | // negate ( n1 -- n2 ) 494 | func (vm *VM) negate() error { 495 | return vm.unaryOp(func(c Cell) Cell { return Cell(-sCell(c)) }) 496 | } 497 | 498 | // ud+ ( ud1 ud2 -- ud3 ) 499 | func (vm *VM) udPlus() error { 500 | a, b, err := vm.stack.pop2d() 501 | if err != nil { 502 | return err 503 | } 504 | return vm.stack.pushd(a + b) 505 | } 506 | 507 | // ud- ( ud1 ud2 -- ud3 ) 508 | func (vm *VM) udMinus() error { 509 | a, b, err := vm.stack.pop2d() 510 | if err != nil { 511 | return err 512 | } 513 | return vm.stack.pushd(a - b) 514 | } 515 | 516 | // ud* ( ud1 ud2 -- ud3 ) 517 | func (vm *VM) udStar() error { 518 | a, b, err := vm.stack.pop2d() 519 | if err != nil { 520 | return err 521 | } 522 | return vm.stack.pushd(a * b) 523 | } 524 | 525 | // ud/mod ( ud1 ud2 -- ud3 ud4 ) 526 | func (vm *VM) udSlashMod() error { 527 | a, b, err := vm.stack.pop2d() 528 | switch { 529 | case err != nil: 530 | return err 531 | case b == 0: 532 | return ZeroDivision 533 | } 534 | vm.stack.pushd(a % b) // will succeed 535 | return vm.stack.pushd(a / b) 536 | } 537 | 538 | // key ( -- char ) 539 | func (vm *VM) key() error { 540 | switch b, err := vm.in.ReadByte(); err { 541 | case nil: 542 | return vm.stack.push(Cell(b)) 543 | case io.EOF: 544 | return vm.stack.push(forthTrue) 545 | default: 546 | return vm.newIOError(err) 547 | } 548 | } 549 | 550 | // emit ( char -- ) 551 | func (vm *VM) emit() error { 552 | c, err := vm.stack.pop() 553 | if err != nil { 554 | return err 555 | } 556 | if _, err = vm.out.Write([]byte{byte(c)}); err != nil { 557 | return vm.newIOError(err) 558 | } 559 | return nil 560 | } 561 | 562 | // trace ( flag -- ) 563 | func (vm *VM) setTrace() error { 564 | c, err := vm.stack.pop() 565 | if err != nil { 566 | return err 567 | } 568 | vm.debug = c != 0 569 | return nil 570 | } 571 | 572 | // bye ( -- ) 573 | func (vm *VM) bye() error { 574 | return Bye 575 | } 576 | 577 | // eof ( -- ) 578 | func (vm *VM) eof() error { 579 | return EOF 580 | } 581 | 582 | var primitives = []struct { 583 | name string 584 | f func(*VM) error 585 | }{ 586 | {"nop", (*VM).nop}, 587 | {"exit", (*VM).exit}, 588 | {"(abort)", (*VM).abortHelper}, 589 | {"(quit)", (*VM).quitHelper}, 590 | // stack 591 | {"pick", (*VM).pick}, 592 | {"roll", (*VM).roll}, 593 | {"depth", (*VM).depth}, 594 | {"drop", (*VM).drop}, 595 | // 0x08 596 | {"2drop", (*VM).twoDrop}, 597 | {"?dup", (*VM).questionDup}, 598 | {"nip", (*VM).nip}, 599 | {"tuck", (*VM).tuck}, 600 | // rstack 601 | {">r", (*VM).toR}, 602 | {"r>", (*VM).rFrom}, 603 | {"r@", (*VM).rFetch}, 604 | {"rdrop", (*VM).rDrop}, 605 | // 0x10 606 | // basic memory access 607 | {"@", (*VM).fetch}, 608 | {"!", (*VM).store}, 609 | {"c@", (*VM).cFetch}, 610 | {"c!", (*VM).cStore}, 611 | // more memory access 612 | {"2!", (*VM).twoStore}, 613 | {"2@", (*VM).twoFetch}, 614 | {"+!", (*VM).plusStore}, 615 | {"", (*VM).unimplemented}, 616 | // 0x18 617 | {"", (*VM).unimplemented}, 618 | {"", (*VM).unimplemented}, 619 | // comparison 620 | {"=", (*VM).equals}, 621 | {"<>", (*VM).notEquals}, 622 | {"<", (*VM).lessThan}, 623 | {">", (*VM).greaterThan}, 624 | {"u<", (*VM).uLessThan}, 625 | {"u>", (*VM).uGreaterThan}, 626 | // 0x20 627 | {"0<", (*VM).zeroLess}, 628 | {"0>", (*VM).zeroGreater}, 629 | // logic 630 | {"0=", (*VM).zeroEquals}, 631 | {"0<>", (*VM).zeroNotEquals}, 632 | // bitwise logic 633 | {"invert", (*VM).invert}, 634 | {"and", (*VM).and}, 635 | {"or", (*VM).or}, 636 | {"xor", (*VM).xor}, 637 | // 0x28 638 | {"lshift", (*VM).lShift}, 639 | {"rshift", (*VM).rShift}, 640 | {"2*", (*VM).twoStar}, 641 | {"2/", (*VM).twoSlash}, 642 | // arithmetics 643 | {"1+", (*VM).onePlus}, 644 | {"1-", (*VM).oneMinus}, 645 | {"+", (*VM).plus}, 646 | {"-", (*VM).minus}, 647 | // 0x30 648 | {"*", (*VM).star}, 649 | {"/", (*VM).slash}, 650 | {"mod", (*VM).mod}, 651 | {"/mod", (*VM).slashMod}, 652 | {"*/", (*VM).starSlash}, 653 | {"*/mod", (*VM).starSlashMod}, 654 | {"m*", (*VM).mStar}, 655 | {"um*", (*VM).umStar}, 656 | // 0x38 657 | {"fm/mod", (*VM).fmSlashMod}, 658 | {"sm/rem", (*VM).smSlashRem}, 659 | {"um/mod", (*VM).umSlashMod}, 660 | {"negate", (*VM).negate}, 661 | {"ud+", (*VM).udPlus}, 662 | {"ud-", (*VM).udMinus}, 663 | {"ud*", (*VM).udStar}, 664 | {"ud/mod", (*VM).udSlashMod}, 665 | // 0x40 666 | // io 667 | {"key", (*VM).key}, 668 | {"emit", (*VM).emit}, 669 | // compiling! 670 | {"", (*VM).unimplemented}, 671 | {"", (*VM).unimplemented}, 672 | {"", (*VM).unimplemented}, 673 | {"", (*VM).unimplemented}, 674 | {"", (*VM).unimplemented}, 675 | {"trace", (*VM).setTrace}, 676 | // 677 | {"", (*VM).unimplemented}, 678 | {"", (*VM).unimplemented}, 679 | {"", (*VM).unimplemented}, 680 | {"", (*VM).unimplemented}, 681 | {"", (*VM).unimplemented}, 682 | {"", (*VM).unimplemented}, 683 | {"", (*VM).unimplemented}, 684 | {"", (*VM).unimplemented}, 685 | // 0x50 686 | {"bye", (*VM).bye}, 687 | {"eof", (*VM).eof}, 688 | } 689 | -------------------------------------------------------------------------------- /forth/stack.go: -------------------------------------------------------------------------------- 1 | // Copyright 2011, 2013 Vadim Vygonets. All rights reserved. 2 | // Use of this source code is governed by the Bugroff 3 | // license that can be found in the LICENSE file. 4 | 5 | package forth 6 | 7 | const stackDepth = 32 8 | 9 | // Stack represents a virtual machine stack, growing up. 10 | type Stack []Cell 11 | 12 | // String formats s as a space-separated series of Cells. 13 | func (s Stack) String() string { 14 | if len(s) == 0 { 15 | return "" 16 | } 17 | var ret = s[0].String() 18 | for _, v := range s[1:] { 19 | ret += " " + v.String() 20 | } 21 | return ret 22 | } 23 | 24 | func (s *Stack) depth() Cell { 25 | return Cell(len(*s)) 26 | } 27 | 28 | func (s *Stack) clear() { 29 | *s = (*s)[:0] 30 | } 31 | 32 | func (s *Stack) need(down, up int) error { 33 | switch { 34 | case len(*s) < down: 35 | return StackUnderflow 36 | case len(*s)+up > cap(*s): 37 | return StackOverflow 38 | default: 39 | return nil 40 | } 41 | } 42 | 43 | func (s *Stack) push(c Cell) error { 44 | if err := s.need(0, 1); err != nil { 45 | return err 46 | } 47 | *s = append(*s, c) 48 | return nil 49 | } 50 | 51 | func (s *Stack) pop() (Cell, error) { 52 | if err := s.need(1, 0); err != nil { 53 | return 0, err 54 | } 55 | var c Cell 56 | *s, c = (*s)[:len(*s)-1], (*s)[len(*s)-1] 57 | return c, nil 58 | } 59 | 60 | func (s *Stack) pushd(d dCell) error { 61 | if err := s.push(Cell(d)); err != nil { 62 | return err 63 | } 64 | return s.push(Cell(d) >> cellBits) 65 | } 66 | 67 | func (s *Stack) pop2() (Cell, Cell, error) { 68 | if err := s.need(2, 0); err != nil { 69 | return 0, 0, err 70 | } 71 | var x, y Cell 72 | *s, x, y = (*s)[:len(*s)-2], (*s)[len(*s)-2], (*s)[len(*s)-1] 73 | return x, y, nil 74 | } 75 | 76 | func (s *Stack) popd() (dCell, error) { 77 | x, y, err := s.pop2() 78 | return dCell(y)< cells from depth 99 | func (s *Stack) pick(size, from int) error { 100 | if err := s.need(from+size, size); err != nil { 101 | return err 102 | } 103 | *s = append(*s, (*s)[len(*s)-from-size:len(*s)-from]...) 104 | return nil 105 | } 106 | 107 | func (s *Stack) roll(size, from int) error { 108 | if err := s.need(from+size, 0); err != nil { 109 | return err 110 | } 111 | var buf [stackDepth]Cell 112 | l := len(*s) 113 | copy(buf[:], (*s)[l-from-size:l-from]) 114 | copy((*s)[l-from-size:l-size], (*s)[l-from:]) 115 | copy((*s)[l-size:], buf[:size]) 116 | return nil 117 | } 118 | -------------------------------------------------------------------------------- /forth/vm.go: -------------------------------------------------------------------------------- 1 | // Copyright 2011, 2013 Vadim Vygonets. All rights reserved. 2 | // Use of this source code is governed by the Bugroff 3 | // license that can be found in the LICENSE file. 4 | 5 | package forth 6 | 7 | import ( 8 | "bufio" 9 | "fmt" 10 | "io" 11 | ) 12 | 13 | // Cell matches the FORTH virtual machine cell type. 14 | type Cell uint32 15 | 16 | type ( 17 | sCell int32 18 | dCell uint64 19 | sdCell int64 20 | ) 21 | 22 | // String formats c as a zero-padded eight-digit lowercase 23 | // hexadecimal number. 24 | func (c Cell) String() string { 25 | var buf [8]byte 26 | for i := 7; i >= 0; i-- { 27 | buf[i] = "0123456789abcdef"[c&0x0f] 28 | c >>= 4 29 | } 30 | return string(buf[:]) 31 | } 32 | 33 | // Instr represents a virtual machine instruction. 34 | type Instr Cell 35 | 36 | const ( 37 | cellSize = 4 38 | cellBits = 32 39 | forthFalse = Cell(0) 40 | forthTrue = ^forthFalse 41 | ) 42 | 43 | // VM memory size in bytes 44 | const MemSize = 0x40000 45 | 46 | // VM implements a Forego FORTH virtual machine. 47 | // 48 | // Execution starts at address 0 and ends when a trap is raised. 49 | // Possible causes for a trap are: 50 | // * BYE or EOF instruction runs 51 | // * stack overflow 52 | // * stack underflow 53 | // * illegal memory access (beyond end of memory) 54 | // * unaligned cell-level memory access 55 | // * zero division on one of: 56 | // / MOD /MOD */ */MOD FM/MOD SM/REM UM/MOD UD/MOD 57 | // * illegal instruction 58 | // * I/O error on KEY or EMIT (except EOF) 59 | // Cell-level memory access includes fetching and storing cells 60 | // using instructions @ ! 2@ 2! +! as well as fetching the next 61 | // instruction pointed to by the program counter. Byte-level 62 | // memory access is is provided by C@ and C! instructions. 63 | // When a trap is raised other than by BYE or EOF, the program 64 | // counter is reset to 0. 65 | type VM struct { 66 | in bufio.Reader // input 67 | out io.Writer // output 68 | pc, lastpc Cell // program counter 69 | icell Instr // current instruction 70 | stack, rstack Stack // data and return stacks 71 | debug bool // tracing enabled 72 | Mem [MemSize]byte // memory 73 | } 74 | 75 | func (vm *VM) trace(format string, a ...interface{}) { 76 | if vm.debug { 77 | fmt.Fprintf(vm.out, format, a...) 78 | } 79 | } 80 | 81 | // memory ops with address checking 82 | func (vm *VM) readByte(a Cell) (Cell, error) { 83 | if a >= MemSize { 84 | return 0, vm.newErrorAddr(IllegalAddress, a) 85 | } 86 | return Cell(vm.Mem[a]), nil 87 | } 88 | 89 | func (vm *VM) readCell(a Cell) (Cell, error) { 90 | if a >= MemSize { 91 | return 0, vm.newErrorAddr(IllegalAddress, a) 92 | } else if a%cellSize != 0 { 93 | return 0, vm.newErrorAddr(UnalignedAddress, a) 94 | } 95 | return Cell(vm.Mem[a])<<24 | Cell(vm.Mem[a+1])<<16 | 96 | Cell(vm.Mem[a+2])<<8 | Cell(vm.Mem[a+3]), nil 97 | } 98 | 99 | func (vm *VM) writeByte(a, v Cell) error { 100 | if a >= MemSize { 101 | return vm.newErrorAddr(IllegalAddress, a) 102 | } 103 | vm.Mem[a] = byte(v) 104 | return nil 105 | } 106 | 107 | func (vm *VM) writeCell(a, v Cell) error { 108 | if a >= MemSize { 109 | return vm.newErrorAddr(IllegalAddress, a) 110 | } else if a%cellSize != 0 { 111 | return vm.newErrorAddr(UnalignedAddress, a) 112 | } 113 | copy(vm.Mem[a:], 114 | []byte{byte(v >> 24), byte(v >> 16), byte(v >> 8), byte(v)}) 115 | return nil 116 | } 117 | 118 | func (vm *VM) primitive(param Cell) error { 119 | if param >= Cell(len(primitives)) { 120 | return IllegalInstruction 121 | } 122 | return primitives[param].f(vm) 123 | } 124 | 125 | func (vm *VM) call(param Cell) error { 126 | if err := vm.rstack.push(vm.pc); err != nil { 127 | return rstackError(err) 128 | } 129 | vm.pc = param 130 | return nil 131 | } 132 | 133 | func (vm *VM) jmp(param Cell) error { 134 | vm.pc = param 135 | return nil 136 | } 137 | 138 | func (vm *VM) jz(param Cell) error { 139 | c, err := vm.stack.pop() 140 | switch { 141 | case err != nil: 142 | return err 143 | case c == 0: 144 | vm.trace("jz: jumping\n") 145 | vm.pc = param 146 | default: 147 | vm.trace("jz: staying\n") 148 | } 149 | return nil 150 | } 151 | 152 | const ( 153 | litSignBit = 24 154 | litNumMask = Cell(1<<(litSignBit+1) - 1) 155 | ) 156 | 157 | // (0100) sssN nnnn nnnn nnnn nnnn nnnn nnnn 158 | // s... = shift bits 159 | // Nn... = number bits 160 | // (N = sign, extended left) 161 | func (vm *VM) push(param Cell) error { 162 | s := param >> (litSignBit + 1) 163 | param &= litNumMask 164 | if param&(1<> 16 & 1 181 | s = []*Stack{&vm.stack, &vm.rstack}[r] 182 | f = []func(*Stack, int, int) error{ 183 | (*Stack).pick, (*Stack).roll, 184 | }[param>>17&1] 185 | ) 186 | err := f(s, int(param>>8&0x3f), int(param&0x3f)) 187 | if r != 0 { 188 | return rstackError(err) 189 | } 190 | return err 191 | } 192 | 193 | // iiii pppp pppp pppp pppp pppp pppp pppp 194 | var instructions = []func(vm *VM, param Cell) error{ 195 | (*VM).primitive, 196 | (*VM).call, 197 | (*VM).jmp, 198 | (*VM).jz, 199 | (*VM).push, 200 | (*VM).pickRoll, 201 | } 202 | 203 | const ( 204 | instrShift = 28 205 | instrParamMask = (1 << instrShift) - 1 206 | ) 207 | 208 | // Step rus the instruction pointed to by the program counter, 209 | // advancing the latter. Step returns an error of type Error if 210 | // the instruction raises a VM trap, or nil. In case a trap is 211 | // raised other than by BYE or EOF, the program counter is reset 212 | // to 0. 213 | func (vm *VM) Step() error { 214 | if ic, err := vm.readCell(vm.pc); err != nil { 215 | return err 216 | } else { 217 | vm.icell = Instr(ic) 218 | } 219 | if vm.debug { 220 | vm.trace("@ %v: %v\n", vm.pc, vm.icell) 221 | } 222 | vm.lastpc = vm.pc 223 | op := vm.icell >> instrShift 224 | if op >= Instr(len(instructions)) { 225 | return vm.newError(IllegalInstruction) 226 | } 227 | vm.pc += cellSize 228 | err := instructions[op](vm, Cell(vm.icell&instrParamMask)) 229 | if err != nil { 230 | if en, ok := err.(Errno); ok { 231 | if en != Bye && en != EOF { 232 | vm.pc = 0 233 | } 234 | return vm.newError(en) 235 | } 236 | _ = err.(*Error) 237 | return err 238 | } 239 | if vm.debug { 240 | vm.trace("%v R: %v\n", vm.stack, vm.rstack) 241 | } 242 | _, err = vm.readCell(vm.pc) 243 | return err 244 | } 245 | 246 | // Run runs vm until a trap is raised. Run returns nil if the 247 | // trap was raised by the BYE instruction, and an Error 248 | // describing the trap otherwise. 249 | func (vm *VM) Run() error { 250 | var err error 251 | for err == nil { 252 | err = vm.Step() 253 | } 254 | if err.(*Error).Errno == Bye { 255 | return nil 256 | } 257 | return err 258 | } 259 | 260 | // NewVM creates a new VM whose KEY reads from in and EMIT 261 | // writes to out. The Mem of the new VM is initialized with the 262 | // default kernel, and the program counter is set to 0. 263 | func NewVM(in io.Reader, out io.Writer) *VM { 264 | vm := &VM{ 265 | in: *bufio.NewReader(in), 266 | out: out, 267 | stack: make([]Cell, 0, stackDepth), 268 | rstack: make([]Cell, 0, stackDepth), 269 | //debug: true, 270 | } 271 | for a := Cell(0); a < MemSize; a += cellSize { 272 | vm.writeCell(a, 0xdeadbeef) 273 | } 274 | copy(vm.Mem[:], kernel) 275 | vm.trace("hi\n") 276 | return vm 277 | } 278 | 279 | // String returns the lower case string representation of instr. 280 | // Primitives are represented as bare FORTH words. The PICK/ROLL 281 | // instruction is formatted as "pick", "roll", "rpick" or 282 | // "rroll", followed by the WIDTH and FROM parameters in 283 | // hexadecimal, thereby distinguishing it from the PICK and ROLL 284 | // primitives. Other instructions are represented as "call", 285 | // "jmp", "jz" or "push", followed by the parameter as an eight 286 | // digit hexadecimal number. For illegal instructions, the 287 | // string "illegal instruction" is returned. 288 | func (instr Instr) String() string { 289 | var ( 290 | op = instr >> instrShift 291 | s string 292 | ) 293 | if op < Instr(len(instructions)) { 294 | s = []func(param Cell) string{ 295 | func(param Cell) string { 296 | if param >= Cell(len(primitives)) { 297 | return "" 298 | } 299 | return primitives[param].name 300 | }, 301 | func(param Cell) string { 302 | return "call " + param.String() 303 | }, 304 | func(param Cell) string { 305 | return "jmp " + param.String() 306 | }, 307 | func(param Cell) string { 308 | return "jz " + param.String() 309 | }, 310 | func(param Cell) string { 311 | s := param >> (litSignBit + 1) 312 | param &= litNumMask 313 | if param&(1<>16&1], 324 | []string{"pick", "roll"}[param>>17&1], 325 | int(param>>8&0x3f), 326 | int(param&0x3f)) 327 | }, 328 | }[op](Cell(instr & instrParamMask)) 329 | } 330 | if s == "" { 331 | return "illegal instruction" 332 | } 333 | return s 334 | } 335 | -------------------------------------------------------------------------------- /main.go: -------------------------------------------------------------------------------- 1 | // Copyright 2011 Vadim Vygonets. All rights reserved. 2 | // Use of this source code is governed by the Bugroff 3 | // license that can be found in the LICENSE file. 4 | 5 | /* 6 | Forego is a FORTH system. 7 | 8 | Forego runs the Forego virtual machine with the default kernel 9 | using stdin and stdout for I/O. Unless the VM stops due to BYE 10 | being executed, Forego prints the trap description on stderr and 11 | exits with error code 1. 12 | */ 13 | package main 14 | 15 | import ( 16 | "fmt" 17 | "os" 18 | 19 | "github.com/unixdj/forego/forth" 20 | ) 21 | 22 | func main() { 23 | if err := forth.NewVM(os.Stdin, os.Stdout).Run(); err != nil { 24 | fmt.Fprintln(os.Stderr, err) 25 | if fe := err.(*forth.Error); fe.Errno != forth.EOF { 26 | fmt.Fprintf(os.Stderr, 27 | "instruction: %v <%v>\nstack: %v\nrstack: %v\n", 28 | fe.Instr, forth.Cell(fe.Instr), 29 | fe.Stack, fe.RStack) 30 | } 31 | os.Exit(1) 32 | } 33 | } 34 | --------------------------------------------------------------------------------