src/forth.jl

   1 module forth
   2
   3 # VM mem size
   4 size_mem = 640*1024
   5
   6 # Buffer sizes
   7 size_RS = 1024   # Return stack size
   8 size_PS = 1024   # Parameter stack size
   9 size_TIB = 1096  # Terminal input buffer size
  10
  11 # The mem array constitutes the memory of the VM. It has the following geography:
  12 #
  13 # mem = +-----------------------+
  14 #       | Built-in Variables    |
  15 #       +-----------------------+
  16 #       | Return Stack          |
  17 #       +-----------------------+
  18 #       | Parameter Stack       |
  19 #       +-----------------------+
  20 #       | Terminal Input Buffer |
  21 #       +-----------------------+
  22 #       | Dictionary            |
  23 #       +-----------------------+
  24 #
  25 # Note that all words (user-defined, primitive, variables, etc) are included in
  26 # the dictionary.
  27 #
  28 # Simple linear addressing is used with one exception: references to primitive code
  29 # blocks, which are represented as anonymous functions, appear the negative index
  30 # into the primitives array which contains only these functions.
  31
  32 mem = Array{Int64,1}(size_mem)
  33 primitives = Array{Function,1}()
  34
  35 # Built-in variables
  36
  37 nextVarAddr = 1
  38 RSP0 = nextVarAddr; nextVarAddr += 1
  39 PSP0 = nextVarAddr; nextVarAddr += 1
  40 HERE = nextVarAddr; nextVarAddr += 1
  41 LATEST = nextVarAddr; nextVarAddr += 1
  42
  43 mem[RSP0] = nextVarAddr              # bottom of RS
  44 mem[PSP0] = mem[RSP0] + size_RS      # bottom of PS
  45 TIB = mem[PSP0] + size_PS            # address of terminal input buffer
  46 mem[HERE] = TIB + size_TIB           # location of bottom of dictionary
  47 mem[LATEST] = 0                      # no previous definition
  48
  49 DICT = mem[HERE] # Save bottom of dictionary as constant
  50
  51 # VM registers
  52 type Reg
  53     RSP::Int64  # Return stack pointer
  54     PSP::Int64  # Parameter/data stack pointer
  55     IP::Int64   # Instruction pointer
  56     W::Int64    # Working register
  57     X::Int64    # Extra register
  58 end
  59 reg = Reg(mem[RSP0], mem[PSP0], 0, 0, 0)
  60
  61 # Stack manipulation
  62
  63 type StackUnderflow <: Exception end
  64
  65 getRSDepth() = reg.RSP - mem[RSP0]
  66 getPSDepth() = reg.PSP - mem[PSP0]
  67
  68 function ensurePSDepth(depth::Int64)
  69     if getPSDepth()<depth
  70         throw(StackUnderflow())
  71     end
  72 end
  73
  74 function ensureRSDepth(depth::Int64)
  75     if getRSDepth()<depth
  76         throw(StackUnderflow())
  77     end
  78 end
  79
  80 function pushRS(val::Int64)
  81     mem[reg.RSP+=1] = val
  82 end
  83
  84 function popRS()
  85     ensureRSDepth(1)
  86
  87     val = mem[reg.RSP]
  88     reg.RSP -= 1
  89     return val
  90 end
  91
  92 function pushPS(val::Int64)
  93     mem[reg.PSP += 1] = val
  94 end
  95
  96 function popPS()
  97     ensurePSDepth(1)
  98
  99     val = mem[reg.PSP]
 100     reg.PSP -= 1
 101     return val
 102 end
 103
 104 # Primitive creation and calling functions
 105
 106 function createHeader(name::AbstractString, flags::Int64)
 107     mem[mem[HERE]] = mem[LATEST]
 108     mem[LATEST] = mem[HERE]
 109     mem[HERE] += 1
 110
 111     mem[mem[HERE]] = length(name) | flags; mem[HERE] += 1
 112     mem[mem[HERE]:(mem[HERE]+length(name)-1)] = [Int(c) for c in name]; mem[HERE] += length(name)
 113 end
 114
 115 function defPrim(name::AbstractString, f::Function; flags::Int64=0)
 116     createHeader(name, flags)
 117
 118     push!(primitives, f)
 119     mem[mem[HERE]] = -length(primitives)
 120     mem[HERE] += 1
 121
 122     return -length(primitives)
 123 end
 124
 125 callPrim(addr::Int64) = primitives[-addr]()
 126
 127 function defExistingVar(name::AbstractString, varAddr::Int64; flags::Int64=0)
 128     defPrim(name, eval(:(() -> begin
 129         pushPS($(varAddr))
 130         return NEXT
 131     end)))
 132 end
 133
 134 function defNewVar(name::AbstractString, initial::Int64; flags::Int64=0)
 135     createHeader(name, flags)
 136
 137     varAddr = mem[HERE] + 1
 138     push!(primitives, eval(:(() -> begin
 139         pushPS($(varAddr))
 140         return NEXT
 141     end)))
 142     mem[mem[HERE]] = -length(primitives); mem[HERE] += 1
 143
 144     mem[mem[HERE]] = initial; mem[HERE] += 1
 145
 146     return varAddr
 147 end
 148
 149 function defConst(name::AbstractString, val::Int64; flags::Int64=0)
 150     defPrim(name, eval(:(() -> begin
 151         pushPS($(val))
 152         return NEXT
 153     end)))
 154
 155     return val
 156 end
 157
 158 # Threading Primitives
 159
 160 NEXT = defPrim("NEXT", () -> begin
 161     reg.W = mem[reg.IP]
 162     reg.IP += 1
 163     X = mem[reg.W]
 164     return X
 165 end)
 166
 167 DOCOL = defPrim("DOCOL", () -> begin
 168     pushRS(reg.IP)
 169     reg.IP = reg.W + 1
 170     return NEXT
 171 end)
 172
 173 EXIT = defPrim("EXIT", () -> begin
 174     reg.IP = popRS()
 175     return NEXT
 176 end)
 177
 178
 179 # Basic forth primitives
 180
 181 DROP = defPrim("DROP", () -> begin
 182     popPS()
 183     return NEXT
 184 end)
 185
 186 SWAP = defPrim("SWAP", () -> begin
 187     a = popPS()
 188     b = popPS()
 189     pushPS(a)
 190     pushPS(b)
 191     return NEXT
 192 end)
 193
 194 DUP = defPrim("DUP", () -> begin
 195     pushPS(mem[reg.PSP])
 196     return NEXT
 197 end)
 198
 199 OVER = defPrim("OVER", () -> begin
 200     ensurePSDepth(2)
 201     pushPS(mem[reg.PSP-1])
 202     return NEXT
 203 end)
 204
 205 ROT = defPrim("ROT", () -> begin
 206     a = popPS()
 207     b = popPS()
 208     c = popPS()
 209     pushPS(a)
 210     pushPS(c)
 211     pushPS(b)
 212     return NEXT
 213 end)
 214
 215 NROT = defPrim("-ROT", () -> begin
 216     a = popPS()
 217     b = popPS()
 218     c = popPS()
 219     pushPS(b)
 220     pushPS(a)
 221     pushPS(c)
 222     return NEXT
 223 end)
 224
 225 TWODROP = defPrim("2DROP", () -> begin
 226     popPS()
 227     popPS()
 228     return NEXT
 229 end)
 230
 231 TWODUP = defPrim("2DUP", () -> begin
 232     ensurePSDepth(2)
 233     a = mem[reg.PSP-1]
 234     b = mem[reg.PSP]
 235     pushPS(a)
 236     pushPS(b)
 237     return NEXT
 238 end)
 239
 240 TWOSWAP = defPrim("2SWAP", () -> begin
 241     a = popPS()
 242     b = popPS()
 243     c = popPS()
 244     d = popPS()
 245     pushPS(b)
 246     pushPS(a)
 247     pushPS(c)
 248     pushPS(d)
 249     return NEXT
 250 end)
 251
 252 QDUP = defPrim("?DUP", () -> begin
 253     ensurePSDepth(1)
 254     val = mem[reg.PSP]
 255     if val != 0
 256         pushPS(val)
 257     end
 258     return NEXT
 259 end)
 260
 261 LIT = defPrim("LIT", () -> begin
 262     pushPS(mem[reg.IP])
 263     reg.IP += 1
 264     return NEXT
 265 end)
 266
 267 # Memory primitives
 268
 269 STORE = defPrim("!", () -> begin
 270     addr = popPS()
 271     dat = popPS()
 272     mem[addr] = dat
 273     return NEXT
 274 end)
 275
 276 FETCH = defPrim("@", () -> begin
 277     addr = popPS()
 278     pushPS(mem[addr])
 279     return NEXT
 280 end)
 281
 282 ADDSTORE = defPrim("+!", () -> begin
 283     addr = popPS()
 284     toAdd = popPS()
 285     mem[addr] += toAdd
 286     return NEXT
 287 end)
 288
 289 SUBSTORE = defPrim("-!", () -> begin
 290     addr = popPS()
 291     toSub = popPS()
 292     mem[addr] -= toSub
 293     return NEXT
 294 end)
 295
 296
 297 # Built-in variables
 298
 299 defExistingVar("HERE", HERE)
 300 defExistingVar("LATEST", LATEST)
 301 defExistingVar("PSP0", PSP0)
 302 defExistingVar("RSP0", RSP0)
 303 STATE = defNewVar("STATE", 0)
 304 BASE = defNewVar("BASE", 10)
 305
 306 # Constants
 307
 308 defConst("VERSION", 1)
 309 defConst("DOCOL", DOCOL)
 310 defConst("DICT", DICT)
 311 F_IMMED = defConst("F_IMMED", 128)
 312 F_HIDDEN = defConst("F_HIDDEN", 256)
 313 F_LENMASK = defConst("F_LENMASK", 127)
 314
 315 # Return Stack
 316
 317 TOR = defPrim(">R", () -> begin
 318     pushRS(popPS())
 319     return NEXT
 320 end)
 321
 322 FROMR = defPrim("R>", () -> begin
 323     pushPS(popRS())
 324     return NEXT
 325 end)
 326
 327 RSPFETCH = defPrim("RSP@", () -> begin
 328     pushPS(reg.RSP)
 329     return NEXT
 330 end)
 331
 332 RSPSTORE = defPrim("RSP!", () -> begin
 333     RSP = popPS()
 334     return NEXT
 335 end)
 336
 337 RDROP = defPrim("RDROP", () -> begin
 338     popRS()
 339     return NEXT
 340 end)
 341
 342 # Parameter Stack
 343
 344 PSPFETCH = defPrim("PSP@", () -> begin
 345     pushPS(reg.PSP)
 346     return NEXT
 347 end)
 348
 349 PSPSTORE = defPrim("PSP!", () -> begin
 350     PSP = popPS()
 351     return NEXT
 352 end)
 353
 354 # I/O
 355
 356 defConst("TIB", TIB)
 357 NUMTIB = defNewVar("#TIB", 0)
 358 TOIN = defNewVar(">IN", 0)
 359
 360 KEY = defPrim("KEY", () -> begin
 361     if mem[TOIN] >= mem[NUMTIB]
 362         mem[TOIN] = 0
 363         line = readline()
 364         mem[NUMTIB] = length(line)
 365         mem[TIB:(TIB+mem[NUMTIB]-1)] = [Int64(c) for c in collect(line)]
 366     end
 367
 368     pushPS(mem[TIB + mem[TOIN]])
 369     mem[TOIN] += 1
 370
 371     return NEXT
 372 end)
 373
 374 EMIT = defPrim("EMIT", () -> begin
 375     print(Char(popPS()))
 376     return NEXT
 377 end)
 378
 379 WORD = defPrim("WORD", () -> begin
 380
 381     c = -1
 382
 383     skip_to_end = false
 384     while true
 385
 386         callPrim(KEY)
 387         c = Char(popPS())
 388
 389         if c == '\\'
 390             skip_to_end = true
 391             continue
 392         end
 393
 394         if skip_to_end
 395             if c == '\n'
 396                 skip_to_end = false
 397             end
 398             continue
 399         end
 400
 401         if c == ' ' || c == '\t'
 402             continue
 403         end
 404
 405         break
 406     end
 407
 408     wordAddr = mem[HERE]
 409     offset = 0
 410
 411     while true
 412         mem[wordAddr + offset] = Int64(c)
 413         offset += 1
 414
 415         callPrim(KEY)
 416         c = Char(popPS())
 417
 418         if c == ' ' || c == '\t' || c == '\n'
 419             break
 420         end
 421     end
 422
 423     wordLen = offset
 424
 425     pushPS(wordAddr)
 426     pushPS(wordLen)
 427
 428     return NEXT
 429 end)
 430
 431 NUMBER = defPrim("NUMBER", () -> begin
 432
 433     wordLen = popPS()
 434     wordAddr = popPS()
 435
 436     s = ASCIIString([Char(c) for c in mem[wordAddr:(wordAddr+wordLen-1)]])
 437
 438     try
 439         pushPS(parse(Int64, s, mem[BASE]))
 440         pushPS(0)
 441     catch
 442         pushPS(1) # Error indication
 443     end
 444
 445     return NEXT
 446 end)
 447
 448 # Dictionary searches
 449
 450 FIND = defPrim("FIND", () -> begin
 451
 452     wordLen = popPS()
 453     wordAddr = popPS()
 454     word = ASCIIString([Char(c) for c in mem[wordAddr:(wordAddr+wordLen-1)]])
 455
 456     latest = mem[LATEST]
 457
 458     while latest>0
 459         lenAndFlags = mem[latest+1]
 460         len = lenAndFlags & F_LENMASK
 461         hidden = (lenAndFlags & F_HIDDEN) == F_HIDDEN
 462
 463         if hidden || len != wordLen
 464             latest = mem[latest]
 465             continue
 466         end
 467
 468         thisAddr = latest+2
 469         thisWord = ASCIIString([Char(c) for c in mem[thisAddr:(thisAddr+len-1)]])
 470
 471         if thisWord == word
 472             break
 473         end
 474     end
 475
 476     pushPS(latest)
 477
 478     return NEXT
 479 end)
 480
 481 TOCFA = defPrim(">CFA", () -> begin
 482
 483     addr = popPS()
 484     lenAndFlags = mem[addr+1]
 485     len = lenAndFlags & F_LENMASK
 486
 487     pushPS(addr + 1 + len)
 488
 489     return NEXT
 490 end)
 491
 492 #### VM loop ####
 493 #function runVM(reg::Reg)
 494 #    jmp = NEXT
 495 #    while (jmp = callPrim(reg, jmp)) != 0 end
 496 #end
 497
 498 # Debugging tools
 499
 500 function coredump(startAddr::Int64; count::Int64 = 16, cellsPerLine::Int64 = 8)
 501     chars = Array{Char,1}(cellsPerLine)
 502
 503     for i in 0:(count-1)
 504         addr = startAddr + i
 505         if i%cellsPerLine == 0
 506             print("$addr:")
 507         end
 508
 509         print("\t$(mem[addr]) ")
 510
 511         if (mem[addr]>=32 && mem[addr]<176)
 512             chars[i%cellsPerLine + 1] = Char(mem[addr])
 513         else
 514             chars[i%cellsPerLine + 1] = '.'
 515         end
 516
 517         if i%cellsPerLine == cellsPerLine-1
 518             println(string("\t", ASCIIString(chars)))
 519         end
 520     end
 521 end
 522
 523 function printPS()
 524     count = reg.PSP - mem[PSP0]
 525
 526     if count > 0
 527         print("<$count>")
 528         for i in (mem[PSP0]+1):reg.PSP
 529             print(" $(mem[i])")
 530         end
 531         println()
 532     else
 533         println("Parameter stack empty")
 534     end
 535 end
 536
 537 end