A => lib/tukan/ccvm.sc +468 -0
@@ 0,0 1,468 @@
+using import struct
+using import enum
+using import Array
+using import Map
+using import Rc
+using import Option
+
+using import .uvm
+
+################################################################################
+
+let Index = i32
+let Label = u64
+
+""""CCVM builtins
+enum Builtins : Label
+ \ unknown unreachable + - * / // % & | ^ fn quote set get nextindex
+ \ < <= > >= == != :
+ \ not dump totext .. cond setmeta getmeta macro eval maptext
+ \ tou32 tof32 floor sqrt fold do cell sin cos map kindof defined?
+ \ condbr
+ userlabel = 1000
+
+global mt_ccvm_c : Atom = (Cell.new (type = "ccvm.c"))
+global mt_ccvm_x : Atom = (Cell.new (type = "ccvm.x"))
+global mt_ccvm_label : Atom = (Cell.new (type = "ccvm.label"))
+global mt_ccvm_ret : Atom = (Cell.new (type = "ccvm.ret"))
+global mt_ccvm_fx : Atom = (Cell.new (type = "ccvm.fx"))
+global mt_ccvm_fret : Atom = (Cell.new (type = "ccvm.fret"))
+
+enum Argument
+
+fn... getarg (args, i = 0)
+ if (i >= (countof args))
+ Argument.undefined;
+ else
+ copy (args @ i)
+
+""""CCVM Inputs
+enum Inputs : i32
+ setup
+ screensize
+ iteration
+ state
+ break
+ close
+ readline
+ samplerate
+ samplecount
+
+""""CCVM argument
+enum Argument
+ c : Index # closure context index
+ x : Index # argument index
+ label : Label # instruction label
+ const : Atom # constant
+ ret # capture return label + context as closure
+ undefined # undefined value that can not be computed
+ fx : Label Index # foreign argument index
+ fret : Label # foreign return argument
+ variadic : (Rc (Array this-type)) # variadic argument list
+ fxall : Label Index # all foreign arguments of this label starting at index
+ keyed : Atom (Rc this-type)
+
+ fn append (self return_expr last_arg?)
+ if last_arg?
+ dispatch self
+ case variadic (args)
+ for arg in args
+ 'append return_expr (copy arg)
+ default
+ 'append return_expr self
+ else
+ 'append return_expr ('getarg self)
+
+ fn... getarg (self, i = 0)
+ dispatch self
+ case variadic (args)
+ getarg args i
+ case fxall (id k)
+ Argument.fx id (i + k)
+ default
+ self
+
+ fn from-args (return_expr)
+ if ((countof return_expr) == 1)
+ return ('pop return_expr)
+ else
+ return (this-type.variadic (Rc.wrap (deref return_expr)))
+
+ fn... wrap (value : this-type)
+ viewing value
+ let return-metacell =
+ inline "#hidden" (T ...)
+ return (Atom ('set-meta (Cell.new ...) (copy T)))
+ dispatch value
+ case c (i)
+ return-metacell mt_ccvm_c i
+ case x (i)
+ return-metacell mt_ccvm_x i
+ case label (id)
+ return-metacell mt_ccvm_label id
+ case const (atom)
+ return (copy atom)
+ case ret ()
+ return-metacell mt_ccvm_ret
+ case fx (id i)
+ return-metacell mt_ccvm_fx id i
+ case fret (id)
+ return-metacell mt_ccvm_fret id
+ default
+ unreachable;
+
+ fn... unwrap (value : Atom)
+ viewing value
+ switch ('kind value)
+ case Atom.Kind.Cell
+ value as:= Cell
+ let mt = ('get-meta value)
+ if (not ('none? mt))
+ let return-int1 =
+ inline "#hidden" (T IT)
+ let a = ('get-index value 0)
+ return (T
+ (copy (a as Number as integer as IT)))
+ let return-int2 =
+ inline "#hidden" (T IT1 IT2)
+ let a = ('get-index value 0)
+ let b = ('get-index value 1)
+ return (T
+ (copy (a as Number as integer as IT1))
+ (copy (a as Number as integer as IT2)))
+ let content2 = ('get-index value 1)
+ if (mt == mt_ccvm_c)
+ return-int1 this-type.c Index
+ elseif (mt == mt_ccvm_x)
+ return-int1 this-type.x Index
+ elseif (mt == mt_ccvm_label)
+ return-int1 this-type.label Label
+ elseif (mt == mt_ccvm_ret)
+ return (this-type.ret)
+ elseif (mt == mt_ccvm_fx)
+ return-int2 this-type.fx Label Index
+ elseif (mt == mt_ccvm_fret)
+ return-int1 this-type.fx Label
+ default;
+ this-type.const (copy value)
+
+let Argument__repr = Argument.__repr
+type+ Argument
+ fn __repr (self)
+ returning string
+ dispatch self
+ case label (id)
+ if (id < Builtins.userlabel)
+ repr (id as Builtins)
+ else
+ .. "L" (tostring id)
+ case fx (id i)
+ if (id == Builtins.userlabel)
+ repr ((copy i) as Inputs)
+ else
+ .. "L" (tostring id) ".x" (tostring i)
+ case fret (id)
+ if (id == Builtins.userlabel)
+ "main.ret"
+ else
+ .. "L" (tostring id) ".ret"
+ case fxall (id i)
+ .. "L" (tostring id) ".x" (tostring i) "..."
+ case keyed (sym arg)
+ .. "(: " (('tostring sym) as string) " " (repr (arg as Argument)) ")"
+ case const (atom)
+ ('tostring atom) as string
+ default
+ Argument__repr self
+
+struct Bindings
+let RcBindings = (Rc Bindings)
+
+struct Bindings
+ parent : (Option RcBindings)
+ symbols : (Map Symbol Argument)
+
+ fn... set (self, name : Symbol, value : Argument)
+ 'set self.symbols name value
+ fn... get (self, name : Symbol)
+ loop (self = self)
+ try
+ break ('get self.symbols name)
+ else
+ repeat
+ try (('unwrap self.parent) as this-type)
+ else
+ error
+ .. "no such bound name: " (repr name)
+
+ fn fork (parent)
+ RcBindings (copy parent)
+
+""""CCVM instruction
+struct Instruction
+ next : Argument = (Argument.undefined)
+ args : (Array Argument)
+ ret : Argument = (Argument.undefined)
+ retctx : (Array Argument)
+
+ fn __repr (self)
+ let s =
+ fold (s = (repr self.next)) for arg in self.args
+ .. s " " (repr arg)
+ dispatch self.ret
+ case undefined () s
+ default
+ fold (s = (.. s " -> " (repr self.ret))) for arg in self.retctx
+ .. s " " (repr arg)
+
+""""CCVM program
+struct Program
+ instrs : (Array Instruction) # id = index + userlabel
+ start : Label
+
+ cache :
+ Map (tuple Argument (Array Argument)) Label
+ fn (value)
+ let next args = (unpack value)
+ fold (h = (hash next)) for arg in args
+ hash h arg
+
+ fn index->label (i)
+ (Builtins.userlabel as integer + i) as Label
+
+ fn label->index (label)
+ label - Builtins.userlabel as integer
+
+ fn... next-label-id (self)
+ index->label (countof self.instrs)
+
+ fn tocondbr (self)
+ # find cond labels and change them to condbr
+ let count = (countof self.instrs)
+ let cond_builtin = (Argument.label Builtins.cond)
+ let condbr_builtin = (Argument.label Builtins.condbr)
+
+ for i in (range count)
+ instr := self.instrs @ i
+ if (instr.next != cond_builtin)
+ continue;
+ let ret = (copy instr.ret)
+
+ let then_label = ('next-label-id self)
+ let then_instr = ('append self.instrs (Instruction))
+ then_instr.next = (copy ret)
+ let then_value = (copy (instr.args @ 1))
+ 'append then_instr.args then_value
+
+ let else_label = ('next-label-id self)
+ let else_instr = ('append self.instrs (Instruction))
+ else_instr.next = (copy ret)
+ let else_value = (copy (instr.args @ 2))
+ 'append else_instr.args else_value
+
+ instr.next = (copy condbr_builtin)
+ instr.ret = (Argument.undefined)
+ instr.args @ 1 = (Argument.label then_label)
+ instr.args @ 2 = (Argument.label else_label)
+ ;
+
+ fn singleuserpull (self)
+ # pull labels that produce values used by only one site close to that site
+
+ # LE -> LD -> LC, LB refs LC.x*
+ # if LB is only user of LC vars, generated by LD,
+ # and LB != LC and LB provides no vars
+ # we need to repoint LD to LB, and LE skips LD to reach LC directly
+ # LD = pred(LC)
+ # LE = pred(LD)
+ # if condbr?(LC)
+ # and LB is only user of its var
+ # and count(pred(LC)) == 1
+ # then
+ # replaceret(LE, LD -> LC) # fix route
+ # replacevars(*, LD -> LC) # fix var
+ # replaceret(LD, LC -> LB) # fix route
+ # replacevars(LB, LC -> LB) # fix var
+ # replacelabels(pred(LB), LB -> LD) # fix route
+
+ fn optimize (self)
+ 'tocondbr self
+ 'singleuserpull self
+
+ fn... fill-label (self, next : Argument, args : (Array Argument), ret : Argument)
+ let instr = ('last self.instrs)
+ dispatch instr.next
+ case undefined ()
+ instr.next = next
+ instr.args = args
+ instr.ret = ret
+ default
+ assert false "append instruction is non-empty"
+
+ fn... make-label (self, next : Argument, args : (Array Argument))
+ let key = (tupleof (copy next) (copy args))
+ let index_dest =
+ try
+ copy ('get self.cache (view key))
+ else
+ let index_dest = ((Builtins.userlabel as integer + (countof self.instrs)) as Label)
+ 'fill-label self next args (Argument.label index_dest)
+ 'append self.instrs
+ Instruction;
+ 'set self.cache key index_dest
+ index_dest
+ Argument.fxall index_dest 0
+
+ fn... eval-do (self, env : RcBindings, args : list)
+ returning (uniqueof Argument -1)
+ raising Error
+ local newenv = (Bindings.fork env)
+ let lastindex = ((countof args) - 1)
+ local return_expr : (Array Argument)
+ for i expr in (enumerate args usize)
+ if (('typeof expr) == list)
+ let head expr = (decons (expr as list))
+ let head2 = (decons expr)
+ if (('typeof head) == Symbol)
+ head as:= Symbol
+ if (head == 'let) # (let name body ...)
+ let name expr = (decons expr)
+ 'set newenv (name as Symbol)
+ 'getarg ('eval-do self newenv expr)
+ continue;
+ elseif (head == 'let@) # (let@ name ... expr)
+ print "todo: let@"
+ continue;
+ elseif (head == 'let:) # (let: name ... expr)
+ print "todo: let:"
+ continue;
+ elseif (((head == 'fn) or (head == 'macro))
+ and (('typeof head2) == Symbol)) # (fn|macro name ...)
+ print "todo: fn"
+ continue;
+ let result =
+ 'eval self newenv expr
+ 'append result return_expr (i == lastindex)
+ Argument.from-args return_expr
+
+ fn... eval-builtin-call (self, head_value, id : Label, args : (Array Argument))
+ let next = (Argument.label id)
+ switch id
+ pass Builtins.cond
+ pass Builtins.defined?
+ pass Builtins.==
+ pass Builtins.!=
+ pass Builtins.>
+ pass Builtins.>=
+ pass Builtins.<
+ pass Builtins.<=
+ pass Builtins.+
+ pass Builtins.-
+ pass Builtins.*
+ pass Builtins./
+ pass Builtins.//
+ pass Builtins.%
+ pass (getattr Builtins '..)
+ pass Builtins.get
+ pass Builtins.set
+ pass Builtins.cell
+ pass Builtins.totext
+ do
+ return
+ 'make-label self next args
+ default;
+ error
+ .. "can not apply builtin: " (repr head_value)
+
+ fn... eval (self, env : RcBindings, expr_value : Value)
+ viewing env expr_value
+ returning (uniqueof Argument -1)
+ raising Error
+ let T = ('typeof expr_value)
+ try
+ if (T == Symbol)
+ let sym = (expr_value as Symbol)
+ return (copy ('get env sym))
+ elseif (T == list)
+ let expr = (expr_value as list)
+ let head_value expr = (decons expr)
+ let head = ('eval self env head_value)
+ dispatch head
+ case label (id)
+ if (id < Builtins.userlabel)
+ id as:= Builtins
+ switch id
+ case Builtins.do
+ return ('eval-do self env expr)
+ case Builtins.quote
+ let value = (decons expr)
+ return (Argument.const (Atom.from-value value))
+ case (getattr Builtins ':)
+ let key expr = (decons expr)
+ let value = ('getarg ('eval-do self env expr))
+ return (Argument.keyed (key as Symbol) (Rc.wrap value))
+ default
+ local args : (Array Argument)
+ let lastindex = ((countof expr) - 1)
+ for i arg in (enumerate expr usize)
+ 'append
+ 'eval self env arg
+ \ args (i == lastindex)
+ return ('eval-builtin-call self head_value id args)
+ else
+ print "label" id
+ default
+ error
+ .. "unhandled expression: " (repr expr_value)
+ except (err)
+ hide-traceback;
+ error@+ err ('anchor expr_value) "while expanding"
+ return
+ Argument.const
+ Atom.from-value expr_value
+ #error
+ .. "unhandled token: " (repr expr_value)
+
+ """"transcode to CCVM representation
+ fn... from-expr (self, expr : list)
+ let userlabel = (Builtins.userlabel as integer)
+ local env : RcBindings
+ 'set env 'false (Argument.const (Atom false))
+ 'set env 'true (Argument.const (Atom true))
+ va-map
+ inline (field)
+ let name = field.Name
+ let index = field.Index
+ static-if (index != userlabel)
+ 'set env name (Argument.label field.Index)
+ Builtins.__fields__
+ 'set env 'sugar-quote (copy ('get env 'quote))
+ let label_start = ('next-label-id self)
+ 'append self.instrs
+ Instruction;
+ va-map
+ inline (field)
+ let name = field.Name
+ let index = field.Index
+ 'set env name (Argument.fx label_start field.Index)
+ Inputs.__fields__
+ let result = ('eval self env expr)
+ local args : (Array Argument)
+ 'append args result
+ 'fill-label self
+ Argument.fret label_start
+ args
+ ret = (Argument.undefined)
+ 'optimize self
+
+ fn debug-dump (self)
+ for i instr in (enumerate self.instrs)
+ id := Builtins.userlabel as integer + i
+ print (.. "L" (tostring id) ":") (repr instr)
+ #instrs : (Array Instruction) # id = index + userlabel
+ #start : Label
+
+do
+ let Program
+
+ locals;
M lib/tukan/uvm.sc +14 -5
@@ 164,17 164,20 @@ type Number :: (storageof bf_t)
bf_get_float64 self &outp bf_rnd_t.BF_RNDN
outp
+ fn integer? (self)
+ ('floor self) == self
+
fn toindex32 (self)
if (self >= 0)
if (self <= 0x7fffffff:i32)
- if (('floor self) == self)
+ if ('integer? self)
return ((toi32 self) as u32)
raise;
fn toindex (self)
if (self >= 0)
if (self <= 0x7fffffffffffffff:i64)
- if (('floor self) == self)
+ if ('integer? self)
return ((toi64 self) as u64)
raise;
@@ 447,10 450,12 @@ struct Cell
digest
@@ memo
- inline gen-each-index (f)
+ inline gen-each-index (f errorT)
fn process (table ...)
fn recur (node depth index ...)
returning void
+ static-if (not (none? errorT))
+ raising errorT
dispatch node
case CellLimb (limb)
let maxindex = (depth-maxindex depth)
@@ 468,10 473,12 @@ struct Cell
recur table.ivalues table.depth 0:u64 ...
@@ memo
- inline gen-each-index-reverse (f)
+ inline gen-each-index-reverse (f errorT)
fn process (table ...)
fn recur (node depth index ...)
returning void
+ static-if (not (none? errorT))
+ raising errorT
dispatch node
case CellLimb (limb)
let maxindex = (depth-maxindex depth)
@@ 489,10 496,12 @@ struct Cell
recur table.ivalues table.depth 0:u64 ...
@@ memo
- inline gen-each-pair (f)
+ inline gen-each-pair (f errorT)
fn process (table ...)
fn recur (key value ...)
returning void
+ static-if (not (none? errorT))
+ raising errorT
dispatch key
case CellLimb (klimb)
dispatch value
A => testing/test_ccvm.sc +40 -0
@@ 0,0 1,40 @@
+import ..lib.tukan.use
+using import tukan.ccvm
+
+local prog : Program
+'from-expr prog
+ sugar-quote
+ do
+ let exit?
+ cond (defined? readline)
+ == "\n" readline
+ false
+ let state
+ cond (defined? state) state
+ cell
+ : meta
+ cell
+ : class "state"
+ : index 0
+ cond exit?
+ cell
+ : exit 0
+ : stdout "exiting...\n"
+ : state state
+ do
+ let state
+ cond (defined? readline)
+ set state 'index (+ (get state 'index) 1)
+ state
+ cell
+ : block-break true
+ : prompt
+ .. (totext (get state 'index)) "> "
+ : stdout
+ cond (defined? break)
+ "enter empty line to exit\n"
+ readline
+ : state state
+'debug-dump prog
+
+;
A => testing/test_tuk2dag.sc +594 -0
@@ 0,0 1,594 @@
+using import struct
+using import enum
+using import itertools
+using import Array
+using import String
+using import Rc
+using import Map
+
+import ..lib.tukan.use
+using import tukan.uvm
+
+global mt_builtin : Atom =
+ Cell.new
+ type = 'builtin
+global mt_input : Atom =
+ Cell.new
+ type = 'input
+global mt_variadic : Atom =
+ Cell.new
+ type = 'variadic
+global mt_param : Atom =
+ Cell.new
+ type = 'param
+global mt_closure : Atom =
+ Cell.new
+ type = 'closure
+global mt_keyed : Atom =
+ Cell.new
+ type = 'keyed
+global mt_call : Atom =
+ Cell.new
+ type = 'call
+global mt_quote : Atom =
+ Cell.new
+ type = 'quote
+
+let global-env builtins inputs =
+ do
+ inline bind-scope-env-symbols (env mt names)
+ fold (scope env = (Scope) env) for name in names
+ sym := (Atom (name as Symbol))
+ code := ('hashbits sym)
+ _
+ 'bind scope name `code
+ 'set env sym
+ 'set-meta
+ Cell.new (copy sym)
+ copy mt
+
+ let builtins env =
+ bind-scope-env-symbols (Cell) mt_builtin
+ sugar-quote unknown unreachable + - * / // % & | ^ fn quote set get
+ \ nextindex < <= > >= == != : not dump totext .. cond setmeta
+ \ getmeta macro eval maptext tou32 tof32 floor sqrt fold do cell
+ \ sin cos map kindof defined? condbr arg funcdef
+
+ let env = ('set env 'sugar-quote (copy ('get env 'quote)))
+
+ let inputs env =
+ bind-scope-env-symbols env mt_input
+ sugar-quote setup screensize iteration state break close readline \
+ samplerate samplecount
+
+ let env = ('set env 'false false)
+ let env = ('set env 'true true)
+
+ let env = ('set env 'globals (copy env))
+
+ _ env builtins inputs
+
+global global-env : Atom = global-env
+
+run-stage;
+
+let original =
+ sugar-quote
+ do
+ let exit?
+ cond (defined? readline)
+ == "\n" readline
+ false
+ let state
+ cond (defined? state) state
+ cell
+ : meta
+ cell
+ : class "state"
+ : index 0
+ cond exit?
+ cell
+ : exit 0
+ : stdout "exiting...\n"
+ : state state
+ do
+ let state
+ cond (defined? readline)
+ set state 'index (+ (get state 'index) 1)
+ state
+ cell
+ : block-break true
+ : prompt
+ .. (totext (get state 'index)) "> "
+ : stdout
+ cond (defined? break)
+ "enter empty line to exit\n"
+ readline
+ : state state
+
+fn array->cell (args)
+ viewing args
+ fold (l = (Cell)) for arg in args
+ 'append l (copy arg)
+fn array->arglist (args)
+ viewing args
+ if ((countof args) == 1)
+ return (copy ('last args))
+ else
+ Atom
+ 'set-meta
+ array->cell args
+ copy mt_variadic
+
+fn getarg (value index)
+ viewing value
+ dispatch value
+ case Cell (cell)
+ if (('get-meta cell) == mt_variadic)
+ return (copy ('get cell index))
+ default;
+ if (index == 0)
+ copy value
+ else
+ (Atom) # none
+
+inline getmeta (value)
+ dispatch value
+ case Cell (cell)
+ copy ('get-meta cell)
+ default
+ (Atom)
+
+inline ismeta? (value mt)
+ dispatch value
+ case Cell (cell)
+ ('get-meta cell) == mt
+ default
+ false
+
+fn argcount (value)
+ viewing value
+ if (ismeta? value mt_variadic)
+ 'next-index (value as Cell)
+ else
+ 1:u64
+
+fn append-arg (self return_expr last_arg?)
+ viewing self return_expr
+ if last_arg?
+ for i in (range (argcount self))
+ 'append return_expr (getarg self i)
+ else
+ 'append return_expr (getarg self 0)
+ ;
+
+#
+ common subexpression elimination during codegen:
+
+ if for any variadic list, argument list or cond branch pair, there are
+ common subexpressions between them, they need to be generated first -
+ recursively.
+
+ for fold/map functions, every expression not depending on an input argument
+ is going to be executed multiple times, and so must be moved in front of the
+ fold operation
+
+#
+ type specialization:
+
+ do a DFS type inference first, collecting properties of types as they build
+
+#
+ present kinds
+
+ none
+ bool
+ string
+ number
+ cell
+
+ reduced kinds
+
+ none
+ bit[N]
+ bool: bit[1] as 1-bit integer - or just bit.
+ operations:
+ * cond
+ number:
+ bit[N] for N-bit integers
+ operations:
+ * add
+ * sub
+ * mul
+ * div
+ * rem
+ * and
+ * or
+ * xor
+ bit[32 | 64] for floats and doubles
+ operations:
+ * fadd
+ * fsub
+ * fmul
+ * fdiv
+ * frem
+ * various transcendental functions
+ bit[V][N]
+ bool vector: bit[v][1]
+ number:
+ bit[V][N] for N-bit integer vectors
+ bit[V][32 | 64] for float and double vectors
+ string: bit[V][8] for strings
+ operations:
+ * slice x i1 i2
+ * join a b
+ factorial packings:
+ bit[32] converts to
+ bit[2][16]
+ bit[4][8]
+ and vice versa, and so on
+ these require constant V=1..4 and N=8,16,32:
+ bit[W][V][N] for arrays of vectors
+ bit[H][W][V][N] for 2d images
+ bit[D][H][W][V][N] for 3d images
+ bit[D][H][W][4][8] for RGBA8 layer/volume textures
+ all three support special sampling methods
+ cell
+ in the abstract, this is a sparse, polymorphic bit[inf]... in which
+ at the first level, any other bit array can be used as key; in an
+ implementation, the key is hashed to keep the key size constant.
+ the depth of the bit array after this point is arbitrary and depends
+ on the provided key.
+
+ bit-array reduction:
+
+ (bit[x][y]...)[k] = bit[y]...
+
+let NodeId = u64
+let IndexMask = u8
+
+enum Node
+let RcNode = (Rc Node)
+
+enum Node
+ empty
+ const : Atom
+ op : (array NodeId 4)
+
+struct NodeDAG
+ let NodeUserMap = (Map NodeId IndexMask)
+ nodes : (Map NodeId RcNode)
+ users : (Map NodeId NodeUserMap)
+ next-id : NodeId = 0
+
+ fn new-id (self)
+ let next-id = self.next-id
+ let id = (copy next-id)
+ next-id += 1
+ id
+
+ fn... connect-sources (self, id : NodeId, node : RcNode)
+ viewing node
+ let users = self.users
+ dispatch (node as Node)
+ case op (args)
+ for i arg in (enumerate args IndexMask)
+ let mask = ((IndexMask 1) << i)
+ try
+ let srcusers = ('get users arg)
+ 'set srcusers id
+ | mask
+ try (copy ('get srcusers id))
+ else (IndexMask)
+ ;
+ else
+ local srcusers : NodeUserMap
+ 'set srcusers id mask
+ 'set users arg (deref srcusers)
+ ;
+ default;
+
+ fn... disconnect-sources (self, id : NodeId, node : RcNode)
+ viewing node
+ let users = self.users
+ dispatch (node as Node)
+ case op (args)
+ for i arg in (enumerate args IndexMask)
+ let mask = (~ ((IndexMask 1) << i))
+ try
+ let srcusers = ('get users arg)
+ 'discard srcusers id
+ ;
+ else;
+ default;
+
+ fn... replace-users (self, id : NodeId, newid : NodeId)
+ let nodes = self.nodes
+ let users = self.users
+ let srcusers =
+ try ('pop users id)
+ else
+ return;
+ for snkid mask in srcusers
+ let node =
+ try ('get nodes snkid)
+ else
+ continue;
+ dispatch node
+ case op (args)
+ for i in (iterbits mask)
+ args @ i = newid
+ default;
+ if newid
+ 'set users newid srcusers
+
+ fn... disconnect-users (self, id : NodeId)
+ 'replace-users self id (NodeId 0)
+ ;
+
+ fn... insert (self, node : RcNode)
+ let id = ('new-id self)
+ 'connect-sources self id node
+ 'set self.nodes id node
+ id
+ case (self, node : Node)
+ this-function self (Rc.wrap node)
+
+ fn... replace (self, id : NodeId, node : RcNode)
+ let nodes = self.nodes
+ let oldnode =
+ try ('pop nodes id)
+ else
+ return;
+ 'disconnect-sources self id oldnode
+ 'set nodes id node
+ 'connect-sources self id node
+
+ fn... remove (self, id : NodeId)
+ let node =
+ try ('get self.nodes id)
+ else
+ return;
+ 'disconnect-sources self id node
+ 'disconnect-users self id
+ 'discard self.nodes id
+ ;
+
+
+do
+ local dag : NodeDAG
+
+ 'remove dag
+ 'insert dag (Node.empty)
+
+ ;
+
+
+struct Tuk2DAG
+ struct Context
+ env : Atom
+ closure-def : Atom
+
+ fn __copy (self)
+ this-type
+ env = (copy self.env)
+ closure-def = (copy self.closure-def)
+
+ fn... eval-do (self, ctx : Context, args : list)
+ viewing ctx
+ returning (uniqueof Atom -1)
+ raising Error
+ local newenv = (copy ctx.env)
+ let lastindex = ((countof args) - 1)
+ local return_expr : (Array Atom)
+ for i expr in (enumerate args usize)
+ if (('typeof expr) == list)
+ let head expr = (decons (expr as list))
+ let head2 = (decons expr)
+ if (('typeof head) == Symbol)
+ head as:= Symbol
+ if (head == 'let) # (let name body ...)
+ let name expr = (decons expr)
+ name as:= Symbol # verify
+ local ctx = (copy ctx)
+ ctx.env = (copy newenv)
+ newenv =
+ 'set (newenv as Cell) name
+ getarg ('eval-do self (deref ctx) expr) 0
+ continue;
+ elseif (head == 'let@) # (let@ name ... expr)
+ print "todo: let@"
+ continue;
+ elseif (head == 'let:) # (let: name ... expr)
+ print "todo: let:"
+ continue;
+ elseif ((head == 'fn)
+ and (('typeof head2) == Symbol)) # (fn|macro name ...)
+ let name expr = (decons expr)
+ name as:= Symbol # verify
+ local ctx = (copy ctx)
+ ctx.env = (copy newenv)
+ newenv =
+ 'set (newenv as Cell) name
+ getarg ('eval-fn self (deref ctx) expr) 0
+ continue;
+ local ctx = (copy ctx)
+ ctx.env = (copy newenv)
+ let result =
+ 'eval self (deref ctx) expr
+ append-arg result return_expr (i == lastindex)
+ return (array->arglist return_expr)
+
+ fn make-param (i level)
+ 'set-meta
+ if (level == 0)
+ Cell.new i
+ else
+ Cell.new i level
+ copy mt_param
+
+ fn... eval-fn (self, ctx : Context, args : list)
+ viewing ctx
+ returning (uniqueof Atom -1)
+ raising Error
+ local newenv = (copy ctx.env)
+ let params body = (decons args)
+ params as:= list
+ let paramcount = ((countof params) as i32)
+ let level = ('next-index (ctx.closure-def as Cell))
+ for i param in (enumerate params)
+ param as:= Symbol
+ newenv =
+ 'set (newenv as Cell) param (make-param i level)
+ let closure-def = ('append (ctx.closure-def as Cell) paramcount)
+ local ctx = (copy ctx)
+ ctx.env = newenv
+ ctx.closure-def = (copy closure-def)
+ Atom
+ 'set-meta
+ Cell.new closure-def
+ 'eval-do self ctx body
+ copy mt_closure
+
+ fn... eval-call (self, ctx : Context, func : Atom, args : (Array Atom))
+ returning (uniqueof Atom -1)
+ raising Error
+ func as:= Cell
+ let params = ('get-index func 0)
+ let body = ('get-index func 1)
+ let paramcount = (('get (params as Cell) 0) as Number as integer)
+ let level = (('next-index (params as Cell)) - 1)
+ local newenv = (copy ctx.env)
+ for i arg in (enumerate args)
+ let paramdef = (make-param i level)
+ newenv =
+ 'set (newenv as Cell) paramdef (copy arg)
+ local ctx = (copy ctx)
+ ctx.env = newenv
+ 'remap self ctx body
+
+ fn... remap (self, ctx : Context, value : Atom)
+ returning (uniqueof Atom -1)
+ raising Error
+ let key = ('get (ctx.env as Cell) value)
+ if (not ('none? key))
+ return key
+ dispatch value
+ case Cell (cell)
+ let mt = ('get-meta cell)
+ match mt
+ case mt_call
+ value as:= Cell
+ let head = ('get-index value 0)
+ let head = ('remap self ctx head)
+ let callargs = (('get-index value 1) as Cell)
+ local args : (Array Atom)
+ let argcount = ('next-index callargs)
+ let lastindex = (argcount - 1)
+ for i in (range argcount)
+ append-arg
+ 'remap self ctx ('get-index callargs i)
+ \ args (i == lastindex)
+ return
+ Atom
+ 'set-meta
+ Cell.new head (array->cell args)
+ copy mt_call
+ case mt_builtin (return (copy value))
+ case mt_param (return (copy value))
+ case mt_variadic
+ value as:= Cell
+ local args : (Array Atom)
+ let argcount = ('next-index value)
+ let lastindex = (argcount - 1)
+ for i in (range argcount)
+ append-arg
+ 'remap self ctx ('get-index value i)
+ \ args (i == lastindex)
+ return (array->arglist args)
+ case mt_closure
+ value as:= Cell
+ let params = ('get-index value 0)
+ let body = ('get-index value 1)
+ let body = ('remap self ctx body)
+ return
+ Atom
+ 'set-meta
+ Cell.new params body
+ copy mt_closure
+ default;
+ default
+ return (copy value)
+ error
+ .. "unhandled remap: " (('tostring value) as string)
+
+ fn... eval (self, ctx : Context, expr_value : Value)
+ viewing ctx
+ returning (uniqueof Atom -1)
+ raising Error
+ let T = ('typeof expr_value)
+ try
+ if (T == Symbol)
+ return ('get (ctx.env as Cell) (expr_value as Symbol))
+ elseif (T == list)
+ let expr = (expr_value as list)
+ let head_value expr = (decons expr)
+ let head = (getarg ('eval self ctx head_value) 0)
+ if (ismeta? head mt_builtin)
+ id := ('hashbits ('get (head as Cell) 0))
+ switch id
+ case builtins.do
+ return ('eval-do self ctx expr)
+ case builtins.quote
+ let value expr = (decons expr)
+ return
+ Atom
+ 'set-meta
+ Cell.new (Atom.from-value value)
+ copy mt_quote
+ case builtins.fn
+ return ('eval-fn self ctx expr)
+ case (getattr builtins ':)
+ let key expr = (decons expr)
+ key as:= Symbol
+ let value = (getarg ('eval-do self ctx expr) 0)
+ return
+ Atom
+ 'set-meta
+ Cell.new key value
+ copy mt_keyed
+ default;
+ local args : (Array Atom)
+ let lastindex = ((countof expr) - 1)
+ for i arg in (enumerate expr usize)
+ append-arg
+ 'eval self ctx arg
+ \ args (i == lastindex)
+ if (ismeta? head mt_closure)
+ # function application
+ return ('eval-call self ctx head args)
+ else
+ return
+ Atom
+ 'set-meta
+ Cell.new head (array->cell args)
+ copy mt_call
+ #error
+ .. "unhandled expression: " (repr expr_value)
+ except (err)
+ hide-traceback;
+ error@+ err ('anchor expr_value) "while expanding"
+ return (Atom.from-value expr_value)
+
+ fn... from-expr (self, expr : list)
+ let env = (copy global-env)
+ let ctx =
+ Context
+ env = env
+ closure-def = (Atom (Cell))
+ 'eval self ctx expr
+
+local t2d : Tuk2DAG
+print
+ 'tostring
+ 'from-expr t2d original
M testing/tuk_interpreter.sc +1 -0
@@ 88,6 88,7 @@ global KEY_SAMPLECOUNT = (Atom 'sampleco
global KEY_SOUND = (Atom 'sound)
fn run (argc argv program opts)
+
#
BASIC
=====