843221e69919 — Leonard Ritter a month ago
* third evaluator works
1 files changed, 535 insertions(+), 22 deletions(-)

M testing/test_uvm3.sc
M testing/test_uvm3.sc +535 -22
@@ 10,7 10,7 @@ using import tukan.libbf
 using import tukan.thread
 using import tukan.SHA256
 
-# forward declarations
+let u256 = (integer 256)
 
 ###############################################################################
 

          
@@ 116,6 116,13 @@ type Number :: (storageof bf_t)
         bf_get_float64 self &outp bf_rnd_t.BF_RNDN
         outp
 
+    fn toindex (self)
+        if (self >= 0)
+            if (self <= 0x7fffffffffffffff:i64)
+                if (('floor self) == self)
+                    return ((toi64 self) as u64)
+        raise;
+
     @@ memo
     inline __as (cls T)
         static-match T

          
@@ 139,11 146,14 @@ type Number :: (storageof bf_t)
             inline (self)
                 cls self
 
-    fn __repr (self)
+    fn tostring (self)
         local sz : u64
         let s =
             bf_ftoa &sz self 10 DEFAULT_PREC BF_FTOA_FORMAT_FREE_MIN
-        string s sz
+        String s sz
+
+    fn __repr (self)
+        (tostring self) as string
 
     fn cmp (self other)
         bf_cmp self other

          
@@ 245,14 255,18 @@ struct TableLimb
     cells : (array UAtom ArrayCellCount)
     mask : u64 = 0 # slots used
 
-    fn uhash (self)
+    fn... uhash (self)
         viewing self
         local digest : SHA256.DigestType
         local sha : SHA256
-        for i in (range ArrayCellCount)
-            local celldigest = ('uhash (self.cells @ i))
-            'hash sha (&celldigest as rawstring) (sizeof celldigest)
-        'hash sha (&self.mask as rawstring) (sizeof self.mask)
+        local celldigest : SHA256.DigestType
+        va-map
+            inline (i)
+                celldigest = ('uhash (self.cells @ i))
+                'hash sha (&celldigest as rawstring) (sizeof celldigest)
+            va-range ArrayCellCount
+        local mask = self.mask
+        'hash sha (&mask as rawstring) (sizeof mask)
         'digest sha digest
         digest
 

          
@@ 347,6 361,8 @@ struct Table
         depth-maxindex (copy self.depth)
 
     fn... set-index (self, index : u64, value : UAtom)
+        let value = (move value)
+
         fn recur (node depth index value)
             returning (uniqueof UAtom -1) u64
             #raising (uniqueof UError -1)

          
@@ 447,6 463,187 @@ struct Table
         self.depth = depth
         self
 
+    fn... del-index (self, index : u64)
+        set-index self index (UAtom)
+
+    fn... get-index (self, index : u64)
+        fn recur (node depth index)
+            returning (uniqueof UAtom -1)
+            #raising (uniqueof UError -1)
+
+            node := (copy node)
+
+            maxindex := (depth-maxindex depth)
+            if (index > maxindex)
+                return (UAtom)
+
+            dispatch node
+            case TableLimb (limb)
+                let slot-capacity = ((maxindex >> IndexBits) + 1)
+                let slot-index = (index // slot-capacity)
+                assert (slot-index < ArrayCellCount)
+
+                let subnode = (copy (limb.cells @ slot-index))
+
+                # subindex
+                let index = (index - (slot-index * slot-capacity))
+                if (depth == 0)
+                    return subnode
+                this-function subnode (depth - 1) index
+            default
+                if (index == 0)
+                    return node
+                else
+                    return (UAtom)
+        recur (copy self.ivalues) (copy self.depth) index
+
+    fn next-index (self)
+        if ('none? self.ivalues)
+            return 0:u64
+        loop (node depth index = (deref self.ivalues) (copy self.depth) 0:u64)
+            dispatch node
+            case TableLimb (limb)
+                repeat
+                    label found
+                        for i in (rrange ArrayCellCount)
+                            let node =
+                                deref (limb.cells @ i)
+                            if (not ('none? node))
+                                maxindex := (depth-maxindex depth)
+                                let slot-capacity = ((maxindex >> IndexBits) + 1)
+                                merge found node
+                                    depth - 1
+                                    index + slot-capacity * i
+                        else
+                            assert false "unexpected end"
+                            unreachable;
+            default
+                break (index + 1)
+
+    fn... append (self, value : UAtom)
+        set-index self (next-index self) value
+
+    fn get-meta (self) self.meta
+
+    fn... set-meta (self, metatable : UAtom)
+        assert (('kind metatable) == UAtom.Kind.Table)
+        local self = (copy self)
+        self.meta = metatable
+        self
+
+    fn... set (self, key : UAtom, value : UAtom)
+        fn recur (keylimb valuelimb key value depth)
+            returning (uniqueof UAtom -1) (uniqueof UAtom -2)
+            assert (depth <= 56)
+            let mask = (((('hashbits key) >> (depth * IndexBits)) as u32) & IndexMask)
+            if (('kind keylimb) == UAtom.Kind.TableLimb) # branch
+                assert (('kind valuelimb) == UAtom.Kind.TableLimb)
+                local newkl = (copy (keylimb as TableLimb))
+                local newvl = (copy (valuelimb as TableLimb))
+                let currentkey = (copy (newkl.cells @ mask))
+                let subkeylimb subvaluelimb =
+                    this-function currentkey (newvl.cells @ mask) key value (depth + 1)
+                flag := 1:u64 << mask
+                if ('none? subkeylimb)
+                    flag := (~ flag)
+                    newkl.mask &= flag
+                    newvl.mask &= flag
+                else
+                    newkl.mask |= flag
+                    newvl.mask |= flag
+                newkl.cells @ mask = subkeylimb
+                newvl.cells @ mask = subvaluelimb
+                assert (newkl.mask != 0)
+                if ((bitcount newkl.mask) == 1)
+                    let index = (findmsb newkl.mask)
+                    assert (index < ArrayCellCount)
+                    let node = (newkl.cells @ index)
+                    assert (not ('none? node))
+                    return (copy node) (copy (newvl.cells @ index))
+                else
+                    return (UAtom newkl) (UAtom newvl)
+            elseif (('none? keylimb) or (keylimb == key)) # empty or same key
+                if ('none? value) # clear
+                    return (UAtom) (UAtom)
+                else
+                    return (copy key) (copy value)
+            else # split?
+                if ('none? value)
+                    # we're removing this value anyway
+                    return (copy keylimb) (copy valuelimb)
+                let oldmask = (((('hashbits keylimb) >> (depth * IndexBits)) as u32) & IndexMask)
+                local limb : TableLimb
+                for i in (range ArrayCellCount)
+                    limb.cells @ i = (UAtom)
+                limb.mask = 1:u64 << oldmask
+                limb.cells @ oldmask = (copy keylimb)
+                let kref = (UAtom (copy limb))
+                limb.cells @ oldmask = (copy valuelimb)
+                let vref = (UAtom limb)
+                return
+                    this-function kref vref key value depth
+
+        label do-regular-set
+            dispatch key
+            case Number (num)
+                let index =
+                    try ('toindex num)
+                    else
+                        merge do-regular-set
+                return (set-index self index value)
+            default;
+        let keys values = (recur self.keys self.values key value 0)
+        local self = (copy self)
+        self.keys = keys
+        self.values = values
+        self
+
+    fn... del (self, key : UAtom)
+        label do-regular-del
+            dispatch key
+            case Number (num)
+                let index =
+                    try ('toindex num)
+                    else
+                        merge do-regular-del
+                return (del-index self index)
+            default;
+        set self key (UAtom)
+
+    fn... get (self, key : UAtom)
+        label do-regular-get
+            dispatch key
+            case Number (num)
+                let index =
+                    try ('toindex num)
+                    else
+                        merge do-regular-get
+                return (get-index self index)
+            default;
+        fn recur (keylimb valuelimb key depth)
+            returning (uniqueof UAtom -1)
+            let mask = (((('hashbits key) >> (depth * IndexBits)) as u32) & IndexMask)
+            if (('kind keylimb) == UAtom.Kind.TableLimb) # branch
+                local newkl = (copy (keylimb as TableLimb))
+                local newvl = (copy (valuelimb as TableLimb))
+                return
+                    this-function (newkl.cells @ mask) (newvl.cells @ mask) key (depth + 1)
+            elseif (keylimb == key) # found key
+                return (copy valuelimb)
+            # key not found
+            return (UAtom)
+        recur self.keys self.values key 0
+
+    fn new (...)
+        local table : this-type
+        va-lfold table
+            inline (key value t)
+                static-if (key == unnamed)
+                    append t value
+                else
+                    set t key value
+            ...
+
 # UAtom
 ################################################################################
 

          
@@ 472,6 669,8 @@ type UHashed < Struct
 
     #fn __drop (self)
         report "dropped"
+        assert false "what the hell"
+        #super-type.__drop self
         ;
 
     fn __repr (self)

          
@@ 514,15 713,18 @@ type+ UAtom
         # no bits must be set
         assert ((val & 0xf:usize) == 0:usize)
         let ptr = (inttoptr (val | (kind as integer as usize)) voidstar)
-        let self = (dupe (bitcast ptr this-type))
-        lose origptr
-        self
+        static-if (plain? origptr)
+            bitcast ptr this-type
+        else
+            let self = (dupe (bitcast ptr this-type))
+            lose (move origptr)
+            self
 
     @@ memo
     inline __rimply (T cls)
         static-if (T == bool)
             inline (self)
-                wrap null
+                wrap (null as voidstar)
                     ? self Kind.True Kind.False
         elseif (imply? T Number)
             inline (self)

          
@@ 539,11 741,10 @@ type+ UAtom
                 wrap (UTable self) Kind.Table
         elseif ((imply? T String) or (T == string))
             inline (self)
-                self := (imply self String)
-                wrap (UString self) Kind.String
+                wrap (UString (self as String)) Kind.String
         elseif (T == Nothing)
             inline (self)
-                wrap null Kind.None
+                wrap (null as voidstar) Kind.None
 
     fn topointer (self)
         viewing self

          
@@ 590,6 791,57 @@ type+ UAtom
                 assert ((kind self) == Kind.None)
                 none
 
+    fn... from-value (value : Value)
+        returning (uniqueof UAtom -1)
+        let recur = this-function
+        let T = ('typeof value)
+        match T
+        case list
+            let l = (value as list)
+            let t =
+                fold (t = (Table)) for i elem in (enumerate l)
+                    label done
+                        if (('typeof elem) == list)
+                            elem as:= list
+                            if ((countof elem) == 3)
+                                let head key value = (decons elem 3)
+                                if (('typeof head) == Symbol)
+                                    head as:= Symbol
+                                    switch head
+                                    pass 'square-list
+                                    pass ':
+                                    do
+                                        key := (recur key)
+                                        value := (recur value)
+                                        merge done
+                                            'set t key value
+                                    default;
+                        key := (recur elem)
+                        'append t key
+            return (t as UAtom)
+        case string
+            return (value as string as UAtom)
+        case Symbol
+            return (value as Symbol as UAtom)
+        case Nothing
+            return (UAtom)
+        case bool
+            return (value as bool as UAtom)
+        default
+            let tk = ('kind ('storageof T))
+            switch tk
+            case type-kind-integer
+                return (UAtom (sc_const_int_extract value))
+            case type-kind-real
+                return (UAtom (sc_const_real_extract value))
+            default;
+            report "unable to handle type" (repr T)
+            error (.. "unable to handle type" (repr T))
+
+    @@ memo
+    inline __ras (T cls)
+        static-if (T == Value) from-value
+
     fn uhash (self)
         let ptr = (topointer self)
         let kind = ('kind self)

          
@@ 607,10 859,17 @@ type+ UAtom
                 copy ((bitcast ptr UTable) . id)
             default
                 nullof SHA256.DigestType
-        # embed kind bits into digest
+        # embed kind bits into most significant bits of digest
+        let kindmask = (0xf:u64 << 60)
+        let kindbits = (kind as integer as u64 << 60)
         insertvalue digest
-            ((digest @ 0) & (~ 0xf:u64)) | (kind as integer)
-            0
+            ((digest @ 3) & (~ kindmask)) | kindbits
+            3
+
+    fn hashbits (self)
+        local digest = (uhash self)
+        static-assert ((sizeof digest) == (sizeof u256))
+        @ (bitcast &digest @u256)
 
     @@ memo
     inline __== (cls T)

          
@@ 674,6 933,62 @@ type+ UAtom
             default "?"
             ")"
 
+    fn tostring (self)
+        #returning String
+
+        let uatom-repr = this-function
+
+        dispatch self
+        case None () "none"
+            return (String (default-styler style-number "none"))
+        case False () "false"
+            return (String (default-styler style-number "false"))
+        case True () "true"
+            return (String (default-styler style-number "true"))
+        case Number (num)
+            let str = (('tostring num) as string)
+            return
+                String (default-styler style-number str)
+        case String (str)
+            let str = (str as string)
+            String
+                repr str
+        case Symbol (str)
+            let str = (Symbol (str as string))
+            String
+                repr str
+        case Table (table)
+            local str : String
+            'append str "("
+            let f =
+                Table.gen-each-index
+                    inline (index node str count)
+                        if (count > 0)
+                            'append str " "
+                        if (count != index)
+                            'append str
+                                default-styler style-number (tostring index)
+                            'append str "="
+                        'append str (uatom-repr node)
+                        count += 1
+            local count = 0
+            f table str count
+            let f =
+                Table.gen-each-pair
+                    inline (key value str count)
+                        if (count > 0)
+                            'append str " "
+                        'append str (uatom-repr key)
+                        'append str "="
+                        'append str (uatom-repr value)
+                        count += 1
+            f table str count
+            'append str ")"
+            deref str
+        default
+            String
+                repr self
+
     fn __copy (self)
         viewing self
         let ptr = (topointer self)

          
@@ 704,7 1019,195 @@ type+ UAtom
 
 run-stage;
 
+###############################################################################
+
+let builtins global-env =
+    fold (scope env = (Scope) (Table)) for name in
+        sugar-quote + - * / let fn
+        sym := (UAtom (name as Symbol))
+        code := ('hashbits sym)
+        _
+            'bind scope name `code
+            'set env sym sym
+
+global global-env : UAtom = global-env
+
+run-stage;
+
+global mt_closure : UAtom =
+    Table.new
+        type = "closure"
+
+fn global-environment ()
+    global-env
+
+fn... ueval (env : UAtom, expr : UAtom)
+    let ueval = this-function
+
+    assert (('kind env) == UAtom.Kind.Table)
+    let envtable = (env as Table)
+    switch ('kind expr)
+    case UAtom.Kind.Symbol
+        return ('get envtable expr)
+    case UAtom.Kind.Table
+        let table = (expr as Table)
+        let head = ('get-index table 0)
+        let head =
+            if (('kind head) == UAtom.Kind.Symbol)
+                let result = ('get envtable head)
+                if ('none? result)
+                    print "unknown name: " head
+                result
+            else
+                ueval env head
+
+        switch ('kind head)
+        case UAtom.Kind.Table
+            let headtable = (head as Table)
+            if (('get-meta headtable) == mt_closure)
+                let origenv = env
+                local env = (copy (('get-index headtable 0) as Table))
+                let f = ('get-index headtable 1)
+                let ftable = (f as Table)
+                let params = ('get-index ftable 1)
+                let eachf =
+                    Table.gen-each-index
+                        inline (i value origenv env params)
+                            if (i > 0)
+                                let name =
+                                    'get-index params (i - 1)
+                                env =
+                                    'set env name
+                                        ueval origenv (copy value)
+                            ;
+                eachf (expr as Table) origenv env (params as Table)
+                let expr = ('get-index ftable 2)
+                ueval env expr
+            else
+                print "cannot apply table:" ('tostring expr)
+                return (UAtom)
+        case UAtom.Kind.Symbol
+            let table = (expr as Table)
+
+            fn verify (val K)
+                if (('kind val) != K)
+                    print K "expected, got" ('tostring val)
+            fn verify-bool (val)
+                switch ('kind val)
+                pass UAtom.Kind.False
+                pass UAtom.Kind.True
+                do;
+                default
+                    print "boolean expected, got" ('tostring val)
+
+            inline binop (f)
+                let a = (ueval env ('get-index table 1))
+                verify a UAtom.Kind.Number
+                let b = (ueval env ('get-index table 2))
+                verify b UAtom.Kind.Number
+                return (UAtom (f (a as Number) (b as Number)))
+
+            inline eval-let ()
+                let f =
+                    Table.gen-each-pair
+                        inline (k v origenv env)
+                            env =
+                                'set env (copy k)
+                                    ueval origenv (copy v)
+                            ;
+                local newenv = (copy (env as Table))
+                f table env newenv
+                return (ueval newenv ('get table 1))
+
+            inline eval-fn ()
+                UAtom
+                    'set-meta
+                        Table.new (copy env) (copy expr)
+                        copy mt_closure
+
+            switch ('hashbits head)
+            case builtins.+ (binop +)
+            case builtins.- (binop -)
+            case builtins.* (binop *)
+            case builtins./ (binop /)
+            case builtins.let (eval-let)
+            case builtins.fn (eval-fn)
+            default
+                print "syntax error:" ('tostring expr)
+                return (UAtom)
+        default
+            print "cannot apply:" ('tostring expr)
+            return (UAtom)
+    default
+        return (copy expr)
+
+###############################################################################
+
+#fn from-value (value)
+    do
+        return (UNumber value)
+
+#
+    match T
+    case string
+        return (value as string as UAtom)
+    default (UAtom)
+
+fn testfunc ()
+    #print ("test" as UAtom)
+
+    let expr =
+        sugar-quote
+            test "test" 1 2 3 (a b c) [d e] 3.5 (: (1 2 3) (4 5 6))
+    print 1
+    let expr =
+        UAtom.from-value expr
+    print 2
+    print
+        'tostring expr
+    let tab = (expr as Table)
+    print
+        'get tab (Table.new 1 2 3)
+    ;
+
+    print
+        'tostring
+            ueval
+                global-environment;
+                UAtom.from-value
+                    sugar-quote
+                        let
+                            : a 2
+                            : b 2.5
+                            : c 4
+                            : make-seq
+                                fn (f1 f2)
+                                    fn (x y z)
+                                        f2 (f1 x y) z
+                            : pow2
+                                fn (x)
+                                    * x x
+                            let
+                                : muladd (make-seq * +)
+                                muladd (pow2 c) b a
+
+#
+    print
+        sha256-digest-string
+            local digest =
+                'uhash expr
+    print
+        (('hashbits expr) >> (256 - 4)) as u8
+    ;
+
 do
+    #print ("test" as UAtom)
+
+    testfunc;
+
+    ;
+
+#
     let val =
         UAtom 303
         #UAtom "hello"

          
@@ 726,11 1229,21 @@ do
     let table = (UAtom (Table))
     print table
     print
-        UAtom
-            'set-index (table as Table) 10 (UAtom "test")
+        Table.new "this" "is" "a" "test"
+            x = 1
+            y = 2.5
+            z = 3
     print
-        UAtom
-            'set-index (table as Table) 11 (UAtom "test")
+        'tostring
+            UAtom
+                'set-index (table as Table) 10 (UAtom "test")
+    print
+        'get
+            'set (table as Table) 10 "test"
+            10
+
+    print
+        (Number 3.5) as integer
 
     # e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855
     #print (sha256-digest-string digest)