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", 100)
 312 F_HIDEN = defConst("F_HIDDEN", 1000)
 313
 314 # Return Stack
 315
 316 TOR = defPrim(">R", () -> begin
 317     pushRS(popPS())
 318     return NEXT
 319 end)
 320
 321 FROMR = defPrim("R>", () -> begin
 322     pushPS(popRS())
 323     return NEXT
 324 end)
 325
 326 RSPFETCH = defPrim("RSP@", () -> begin
 327     pushPS(reg.RSP)
 328     return NEXT
 329 end)
 330
 331 RSPSTORE = defPrim("RSP!", () -> begin
 332     RSP = popPS()
 333     return NEXT
 334 end)
 335
 336 RDROP = defPrim("RDROP", () -> begin
 337     popRS()
 338     return NEXT
 339 end)
 340
 341 # Parameter Stack
 342
 343 PSPFETCH = defPrim("PSP@", () -> begin
 344     pushPS(reg.PSP)
 345     return NEXT
 346 end)
 347
 348 PSPSTORE = defPrim("PSP!", () -> begin
 349     PSP = popPS()
 350     return NEXT
 351 end)
 352
 353 # I/O
 354
 355 defConst("TIB", TIB)
 356 NUMTIB = defNewVar("#TIB", 0)
 357 TOIN = defNewVar(">IN", 0)
 358
 359 KEY = defPrim("KEY", () -> begin
 360     if mem[TOIN] >= mem[NUMTIB]
 361         mem[TOIN] = 0
 362         line = readline()
 363         mem[NUMTIB] = length(line)
 364         mem[TIB:(TIB+mem[NUMTIB]-1)] = [Int64(c) for c in collect(line)]
 365     end
 366
 367     pushPS(mem[TIB + mem[TOIN]])
 368     mem[TOIN] += 1
 369
 370     return NEXT
 371 end)
 372
 373 EMIT = defPrim("EMIT", () -> begin
 374     print(Char(popPS()))
 375     return NEXT
 376 end)
 377
 378 WORD = defPrim("WORD", () -> begin
 379
 380     c = -1
 381
 382     skip_to_end = false
 383     while true
 384
 385         callPrim(KEY)
 386         c = Char(popPS())
 387
 388         if c == '\\'
 389             skip_to_end = true
 390             continue
 391         end
 392
 393         if skip_to_end
 394             if c == '\n'
 395                 skip_to_end = false
 396             end
 397             continue
 398         end
 399
 400         if c == ' ' || c == '\t'
 401             continue
 402         end
 403
 404         break
 405     end
 406
 407     wordAddr = mem[HERE]
 408     offset = 0
 409
 410     while true
 411         mem[wordAddr + offset] = Int64(c)
 412         offset += 1
 413
 414         callPrim(KEY)
 415         c = Char(popPS())
 416
 417         if c == ' ' || c == '\t' || c == '\n'
 418             break
 419         end
 420     end
 421
 422     wordLen = offset
 423
 424     pushPS(wordAddr)
 425     pushPS(wordLen)
 426
 427     return NEXT
 428 end)
 429
 430 NUMBER = defPrim("NUMBER", () -> begin
 431
 432     wordLen = popPS()
 433     wordAddr = popPS()
 434
 435     s = ASCIIString([Char(c) for c in mem[wordAddr:(wordAddr+wordLen-1)]])
 436
 437     try
 438         pushPS(parse(Int64, s, mem[BASE]))
 439         pushPS(0)
 440     catch
 441         pushPS(1) # Error indication
 442     end
 443
 444     return NEXT
 445 end)
 446
 447 #### VM loop ####
 448 #function runVM(reg::Reg)
 449 #    jmp = NEXT
 450 #    while (jmp = callPrim(reg, jmp)) != 0 end
 451 #end
 452
 453 # Debugging tools
 454
 455 function coredump(startAddr::Int64; count::Int64 = 16, cellsPerLine::Int64 = 8)
 456     chars = Array{Char,1}(cellsPerLine)
 457
 458     for i in 0:(count-1)
 459         addr = startAddr + i
 460         if i%cellsPerLine == 0
 461             print("$addr:")
 462         end
 463
 464         print("\t$(mem[addr]) ")
 465
 466         if (mem[addr]>=32 && mem[addr]<176)
 467             chars[i%cellsPerLine + 1] = Char(mem[addr])
 468         else
 469             chars[i%cellsPerLine + 1] = '.'
 470         end
 471
 472         if i%cellsPerLine == cellsPerLine-1
 473             println(string("\t", ASCIIString(chars)))
 474         end
 475     end
 476 end
 477
 478 function printPS()
 479     count = reg.PSP - mem[PSP0]
 480
 481     if count > 0
 482         print("<$count>")
 483         for i in (mem[PSP0]+1):reg.PSP
 484             print(" $(mem[i])")
 485         end
 486         println()
 487     else
 488         println("Parameter stack empty")
 489     end
 490 end
 491
 492 end