You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 

579 lines
16 KiB

const Int = Symbol \Int
try window
catch
global.window = global
between = (a, b, x) -> x >= a and x < b
bool = (x) -> if x then -1 else 0
cmp = (x, y) ->
if x < y then -1
else if x == y then 0
else if x > y then 1
export class Xt
(@name, @flags, @code) -> void
to-string: -> "' #{@name ? '[noname]'}"
export class Wordlist
->
@wl = []
add-xt: (xt) !-> @wl.unshift xt
add: (name, flags, code) !->
@add-xt new Xt name, flags, code
search: (name) ->
name = name.to-upper-case!
for e in @wl then return e if e.name == name
null
to-string: -> 'WORDLIST'
export class Stack
(@exc) ->
@stack = []
push: (value) !-> @stack.push value
peek: (n = 0) ->
n++
if @stack.length < n then throw @exc
else @stack[@stack.length - n]
pop: ->
if @stack.length == 0 then throw @exc
else @stack.pop!
roll: (n) !->
if @stack.length < n + 1 then throw @exc
else
x = @stack[@stack.length - n - 1]
for i from 0 til n
j = n - 1 - i
@stack[@stack.length - j - 2] = @stack[@stack.length - j - 1]
@stack[@stack.length - 1] = x
roll2: (n) !->
if @stack.length < n + 1 then throw @exc
else
x = @stack[@stack.length - 1]
for i from 0 til n
@stack[@stack.length - i - 1] = @stack[@stack.length - i - 2]
@stack[@stack.length - n - 1] = x
print: (name) !->
console.log "#{name} #{@stack.length}"
for x, i in @stack
console.log "\t#{@stack.length - 1 - i} #x"
to-string: -> '[stack]'
export class Pointer
(@buf, @off) -> void
add: (n) -> new Pointer @buf, @off + n
diff: (other) ->
if @buf != other.buf then throw -21
else @off - other.off
bounds: (i) !-> throw -9 unless between 0, @buf.length, i
read: (n) ->
@bounds @off + n
@buf[@off + n]
write: (n, value) !->
@bounds @off + n
@buf[@off + n] = value
read-string: (n, length) ->
for i from 0 til length then String.from-char-code @read n + i
.join ''
to-string: -> "POINTER #{@off}/#{@buf.length}"
export class Branch
(@type, @ptr) -> void
to-string: -> 'BRANCH'
export class Literal
(@value) -> void
to-string: -> "LITERAL #{@value}"
export class JSFORTH
->
@code = null
@sys-data = [10, 0, 0]
@base-ptr = new Pointer @sys-data, 0
@to-in-ptr = new Pointer @sys-data, 1
@state-ptr = new Pointer @sys-data, 2
@source-ptr = new Pointer [], 0
@source-len = 0
@source-id = -1
@sp = new Stack -4
@rp = new Stack -6
@qp = new Stack -257
@last-def = null
@here = []
@forth-wl = new Wordlist
..add 'DROP' {} !~> @sp.pop!
..add 'DUP' {} !~> @sp.push @sp.peek!
..add 'SWAP' {} !~> @sp.roll 1
..add 'ROT' {} !~> @sp.roll 2
..add '-ROT' {} !~> @sp.roll2 2
..add '>R' {} !~> @rp.push @sp.pop!
..add 'R>' {} !~> @sp.push @rp.pop!
..add 'R@' {} !~> @sp.push @rp.peek!
..add '>Q' {} !~> @qp.push @sp.pop!
..add 'Q>' {} !~> @sp.push @qp.pop!
..add 'Q@' {} !~> @sp.push @qp.peek!
..add 'R>Q' {} !~> @qp.push @rp.pop!
..add 'Q>R' {} !~> @rp.push @qp.pop!
..add '2>R' {} !~>
a = @sp.pop!
b = @sp.pop!
@rp.push b
@rp.push a
..add '2R>' {} !~>
a = @rp.pop!
b = @rp.pop!
@sp.push b
@sp.push a
..add '2R@' {} !~>
a = @rp.pop!
@sp.push @rp.peek!
@sp.push a
@rp.push a
..add 'PICK' {} !~> @types1s Int, (x) !~> @sp.push @sp.peek x
..add 'RPICK' {} !~> @types1s Int, (x) !~> @sp.push @rp.peek x
..add 'QPICK' {} !~> @types1s Int, (x) !~> @sp.push @qp.peek x
..add 'ROLL' {} !~> @types1s Int, (x) !~> @sp.roll x
..add '+' {} !~> @types2 do
[Int, Int, (x, y) !~> @sp.push x + y]
[Pointer, Int, (p, n) !~> @sp.push p.add n]
[Int, Pointer, (n, p) !~> @sp.push p.add n]
..add '-' {} !~> @types2 do
[Int, Int, (x, y) !~> @sp.push x - y]
[Pointer, Int, (p, n) !~> @sp.push p.add -n]
[Pointer, Pointer, (x, y) !~> @sp.push x.diff y]
..add '*' {} !~> @types2s Int, Int, (x, y) !~> @sp.push x * y
..add 'AND' {} !~> @types2s Int, Int, (x, y) !~> @sp.push x .&. y
..add 'OR' {} !~> @types2s Int, Int, (x, y) !~> @sp.push x .|. y
..add 'XOR' {} !~> @types2s Int, Int, (x, y) !~> @sp.push x .^. y
..add '=' {} !~> @types2s Int, Int, (x, y) !~> @sp.push bool x == y
..add '<>' {} !~> @types2s Int, Int, (x, y) !~> @sp.push bool x != y
..add '<' {} !~> @types2s Int, Int, (x, y) !~> @sp.push bool x < y
..add '>' {} !~> @types2s Int, Int, (x, y) !~> @sp.push bool x > y
..add '<=' {} !~> @types2s Int, Int, (x, y) !~> @sp.push bool x <= y
..add '>=' {} !~> @types2s Int, Int, (x, y) !~> @sp.push bool x >= y
..add '<=>' {} !~> @types2s Int, Int, (x, y) !~>
@sp.push x `cmp` y
..add 'NEGATE' {} !~> @types1s Int, (x) !~> @sp.push -x
..add 'INVERT' {} !~> @types1s Int, (x) !~> @sp.push ~x
..add '@' {} !~> @types1s Pointer, (p) !~> @sp.push p.read 0
..add '!' {} !~> @types2s null, Pointer, (x, p) !~> p.write 0, x
..add 'EXECUTE' {} !~> @types1s Xt, (xt) !~> @execute xt
..add 'EXIT' {} !~> @code = @rp.pop!
..add 'EVALUATE1' {} !~>
id = @check-type Int, @sp.pop!
len = @check-type Int, @sp.pop!
ptr = @check-type Pointer, @sp.pop!
str = ptr.read-string 0, len
@evaluate-str str, id
..add 'PARSE1' {} !~> @types2s Int, Int, (delim, skip) !~>
[base, len] = @parse delim, skip
@sp.push base
@sp.push len
..add 'FIND1W' {} !~>
len = @check-type Int, @sp.pop
base = @check-type Pointer, @sp.pop
wl = @check-type Wordlist, @sp.pop
name = base.read-string 0, len
xt = wl.search name
if xt?
@sp.push xt
@sp.push -1
else @sp.push 0
..add 'FIND1' {} !~>
len = @check-type Int, @sp.pop
base = @check-type Pointer, @sp.pop
name = base.read-string 0, len
xt = @search-all name
if xt?
@sp.push xt
@sp.push -1
else @sp.push 0
..add 'WORDLIST' {} !~> @sp.push new Wordlist
..add 'FORTH-WORDLIST' {} !~> @sp.push @forth-wl
..add 'GET-CURRENT' {} !~> @sp.push @wl-current
..add 'SET-CURRENT' {} !~> @types1 Wordlist, (wl) !~> @wl-current = wl
..add 'GET-ORDER' {} !~>
for x in reverse @search-order then @sp.push x
@sp.push @search-order.length
..add 'SET-ORDER' {} !~> @types1 Int, (n) !~>
if n < 0 then @search-order = [@forth-wl]
else
@search-order = []
for i from 0 til n then @search-order.push @sp.pop!
..add 'SOURCE' {} !~>
@sp.push @source-ptr
@sp.push @source-len
..add 'SOURCE-ID' {} !~> @sp.push @source-id
..add 'BASE' {} !~> @sp.push @base-ptr
..add '>IN' {} !~> @sp.push @to-in-ptr
..add 'STATE' {} !~> @sp.push @state-ptr
..add 'HERE' {} !~> @sp.push new Pointer @here, @here.length
..add 'ALLOT' {} !~> @types1s Int, (n) !~> @here.length += n
..add ',' {} !~> @here.push @sp.pop!
..add 'BREAK-REGION' {} !~>
@sp.push new Pointer @here, 0
@here = []
..add 'ALLOCATE' {} !~> @types1s Int, (size) !~>
@sp.push new Pointer (new Array size), 0
@sp.push 0
..add 'FREE' {} !~>
@sp.pop!
@sp.push 0
..add 'RESIZE' {} !~>
size = @check-type Int, @sp.pop!
@sp.peek!.buf.length += size
@sp.push 0
..add ':' {} !~>
xt = new Xt @parse-name!.to-upper-case!, {}, null
@sp.push xt
@here = []
@state-ptr.write 0, 1
..add ':NONAME' {} !~>
xt = new Xt null, {}, null
@sp.push xt
@here = []
@state-ptr.write 0, 1
..add ';' {+immediate, +compile-only} !~>
xt = @check-type Xt, @sp.pop!
@here.push @xt-exit
xt.code = new Pointer @here, 0
if xt.name? then @wl-current.add-xt xt
else @sp.push xt
@last-def = xt
@state-ptr.write 0, 0
@here = []
..add 'SYNONYM' {} !~>
new-name = @parse-name!.to-upper-case!
old-name = @parse-name!
old-xt = @search-all-err old-name
new-xt = new Xt new-name, old-xt.flags, old-xt
@wl-current.add-xt new-xt
..add 'CREATE' {} !~>
name = @parse-name!.to-upper-case!
@here = []
ptr = new Pointer @here, 0
code =
new Literal ptr
@xt-exit
null
xt = new Xt name, {+created}, (new Pointer code, 0)
@wl-current.add-xt xt
@last-def = xt
..add '>BODY' {} !~>
xt = @check-type Xt, @sp.pop!
@sp.push xt.code.read 0 .value
..add 'DOES>' {} !~>
@last-def.code.write 1, new Branch -1, @code
@last-def.code.write 2, @xt-exit
@code = @rp.pop!
..add 'IMMEDIATE' {} !~> @last-def.flags.immediate = true
..add 'COMPILE-ONLY' {} !~> @last-def.flags.compile-only = true
..add 'IMMEDIATE?' {} !~> @types1s Xt, (xt) !~>
@here.push bool xt.flags.immediate
..add 'COMPILE-ONLY?' {} !~> @types1s Xt, (xt) !~>
@here.push bool xt.flags.compile-only
..add '\'' {} !~> @sp.push @search-all-err @parse-name!
..add 'POSTPONE' {+immediate, +compile-only} !~>
xt = @search-all-err @parse-name!
if xt.flags.immediate then @here.push xt
else
@here.push new Literal xt
@here.push @xt-compile
..add 'MAKE-LITERAL' {} !~> @sp.push new Literal @sp.pop!
..add 'MAKE-BRANCH' {} !~> @types2s Pointer, Int, (ptr, type) !~>
@sp.push new Branch type, ptr
..add 'COMPILE,' {} !~> @types1s Xt, (xt) !~> @here.push xt
..add '.' {} !~> console.log @sp.pop!
..add '.S' {} !~> @dot-s!
..add 'WINDOW' {} !~> @sp.push window
..add 'NULL' {} !~> @sp.push null
..add 'UNDEFINED' {} !~> @sp.push undefined
..add 'THIS' {} !~> @sp.push @
..add 'JSTRING' {} !~> @types2s Pointer, Int, (base, len) !~>
@sp.push base.read-string 0, len
..add 'PROPERTY@' {} !~>
k = @sp.pop!
obj = @sp.pop!
@sp.push obj[k]
..add 'PROPERTY!' {} !~>
k = @sp.pop!
obj = @sp.pop!
v = @sp.pop!
obj[k] = v
..add 'PROPERTY-DELETE' {} !~>
k = @sp.pop!
obj = @sp.pop!
delete obj[k]
..add 'J=' {} !~>
b = @sp.pop!
a = @sp.pop!
@sp.push bool a == b
..add 'J<>' {} !~>
b = @sp.pop!
a = @sp.pop!
@sp.push bool a != b
..add 'JCALL' {} !~>
fn = @sp.pop!
ths = @sp.pop!
argn = @check-type Int, @sp.pop!
args = []
for i from 0 til argn then args.unshift @sp.pop!
@sp.push fn.apply ths, args
..add 'JEXECUTE' {} !~> @types1s Xt, (xt) !~>
f = (ths, args) ~>
for x in args then @sp.push x
@sp.push args.length
@sp.push ths
code = @code
@code = null
@execute xt
@run!
@code = code
@sp.pop!
@sp.push (...args) -> f @, args
..add 'THROW' {} !~>
e = @sp.pop!
throw e if e != 0
..add 'SEE' {} !~> @see @search-all-err @parse-name!
@wl-current = @forth-wl
@search-order = [@forth-wl]
@xt-exit = @forth-wl.search 'EXIT'
@xt-compile = @forth-wl.search 'COMPILE,'
is-type: (value, type) ->
switch type
case null then true
case Int then value == (value .|. 0)
default value instanceof type
check-type: (type, value) ->
if value `@is-type` type then value
else throw -12
types1s: (ta, f) !->
a = @check-type ta, @sp.pop!
f a
types2s: (ta, tb, f) !->
b = @check-type tb, @sp.pop!
a = @check-type ta, @sp.pop!
f a, b
types2: (...defs) !->
b = @sp.pop!
a = @sp.pop!
for [ta, tb, f] in defs
if a `@is-type` ta and b `@is-type` tb
f a, b
return
throw -12
search-all: (name) ->
for wl in @search-order
xt = wl.search name
return xt if xt?
null
search-all-err: (name) -> (@search-all name) ? throw -13
execute: (xt) !->
throw -14 if (@state-ptr.read 0) == 0 and xt.flags.compile-only
if typeof xt.code == \function then xt.code!
else if xt.code instanceof Xt then @execute xt.code
else if xt.code instanceof Pointer
@rp.push @code
@code = xt.code
else throw -256
step: !->
op = @code.read 0
@code = @code.add 1
if op instanceof Literal then @sp.push op.value
else if op instanceof Xt then @execute op
else if op instanceof Branch
c = switch op.type
case -1 then true
case 0 then @sp.pop! == 0
case 1 then @sp.pop! != 0
default throw -256
@code = op.ptr if c
else throw -256
run: !-> while @code? then @step!
parse: (delim, skip) ->
i = @to-in-ptr.read 0
len = 0
base = @source-ptr.add i
while i < @source-len
c = @source-ptr.read i++
if skip
if c == delim then base = base.add 1
else skip = false
unless skip
if c == delim then break
else len++
@to-in-ptr.write 0, i
[base, len]
parse-name: ->
[base, len] = @parse 32, true
base.read-string 0, len
parse-digit: (digit) ->
k = digit.char-code-at 0
if between 48, 58, k then k - 48
else if between 65, 91, k then k - 55
else if between 97, 123, k then k - 87
else null
parse-number: (word) ->
base = @base-ptr.read 0
n = 0
m = if word[0] == '-'
word = word.slice 1
-1
else 1
for c in word
d = @parse-digit c
return null if not d? or d >= base
n = n * base + d
n * m
eval-word: (word) !->
xt = @search-all word
if xt?
if xt.flags.immediate or (@state-ptr.read 0) == 0
@execute xt
@run!
else @here.push xt
else
n = @parse-number word
if n?
if @state-ptr.read 0 then @here.push new Literal n
else @sp.push n
else throw -13
evaluate: !->
while true
word = @parse-name!
return unless word.length != 0
@eval-word word
evaluate-str: (str, id = -1) !->
old-ptr = @source-ptr
old-len = @source-len
old-id = @source-id
old-to-in = @to-in-ptr.read 0
buf = for c in str then c.char-code-at 0
@source-ptr = new Pointer buf, 0
@source-len = str.length
@source-id = id
@to-in-ptr.write 0, 0
@evaluate!
@source-ptr = old-ptr
@source-len = old-len
@source-id = old-id
@to-in-ptr.write 0, old-to-in
evaluate-lines: (str, id = -1) !->
for line in str.split '\n' then @evaluate-str line, id
see-code: (ptr) !->
code = ptr.buf.slice ptr.off
for x, i in code
m = if x instanceof Xt then x.name ? '[noname]'
else if x instanceof Branch
t = switch x.type
case -1 then 'BRANCH'
case 0 then 'BRANCH?-Z'
case 1 then 'BRANCH?-NZ'
default throw -256
"#{t} #{x.ptr.diff ptr}"
else x.to-string!
console.log "\t#i #m"
see: (xt) !->
h = if xt.flags.created then 'CREATE ' else ': '
h += xt.name
h += if xt.flags.immediate then ' IMMEDIATE' else ''
h += if xt.flags.compile-only then ' COMPILE-ONLY' else ''
console.log h
if xt.flags.created
b = xt.code.read 1
if b instanceof Branch
console.log '\tDOES>'
@see-code b.ptr
return
if typeof xt.code == \function
console.log '\tNATIVE'
else if xt.code instanceof Xt
console.log "\tSYNONYM-OF #{xt.code.name}"
else if xt.code instanceof Pointer
@see-code xt.code
else throw -256
dot-s: !->
@sp.print 'D'
@rp.print 'R'
@qp.print 'Q'