# HG changeset patch # User Leonard Ritter # Date 1604837563 -3600 # Sun Nov 08 13:12:43 2020 +0100 # Node ID fafde678d7e314344e9bf70e96c0d83d1f3a5d60 # Parent edb3c78a9dddcd8e89e6267c4b4691d6666e8a2f * cleaned up uvm tests diff --git a/testing/test_uvm.sc b/testing/test_uvm.sc --- a/testing/test_uvm.sc +++ b/testing/test_uvm.sc @@ -1,1052 +1,166 @@ using import struct using import enum using import Map +using import Set using import Array using import String +using import Rc import ..lib.tukan.use -using import tukan.ustore -using import tukan.libbf - -# - new idea for VM: - number = fp128 - tuple as basic composite - -inline verify-sizeof (size) - inline (T) - #static-assert ((alignof T) == 8) - .. "(alignof " (tostring T) ") != 8" - static-assert ((sizeof T) == size) - .. "(sizeof " (tostring T) ") == " - \ (tostring (sizeof T)) " != " (tostring size) - T - -# Number -############################################################################### - -let realloc = - extern 'realloc - function voidstar voidstar usize -fn urealloc (opaque ptr size) - realloc ptr size -global bf_ctx : bf_context_t -bf_context_init &bf_ctx urealloc null +using import tukan.uvm +using import tukan.module +using import tukan.pickle -struct Number plain - sign : i64 - expn : i64 - len : u64 - tab : (array u64) - - let DEFAULT_PREC = 56 +############################################################################## - fn... from_bf (n : &bf_t) - bufsize := (sizeof this-type) + (sizeof u64) * n.len - let buf = - ptrtoref - bitcast - alloca-array u8 bufsize - mutable pointer this-type - buf.sign = n.sign - buf.expn = n.expn - buf.len = n.len - for i in (range n.len) - buf.tab @ i = n.tab @ i - local uref = (URef.store &buf bufsize) - uref.kind = URef.Kind.Number - uref - -fn bftostr (x) - local sz : u64 - let s = - bf_ftoa &sz x 10 Number.DEFAULT_PREC BF_FTOA_FORMAT_FREE_MIN - String s sz +fn testfunc () + #print ("test" as UAtom) -fn bftosstr (x) - local sz : u64 - let s = - bf_ftoa &sz x 10 Number.DEFAULT_PREC BF_FTOA_FORMAT_FREE_MIN - string s sz - -fn numbertobf (r ref) - let num = - bitcast ('load ref) (pointer Number) - local n = - bf_t - sign = (num.sign as i32) - expn = num.expn - len = num.len - tab = (bitcast (& (num.tab @ 0)) (mutable pointer u64)) - bf_set r &n - -fn numbertostr (ref) - local n : bf_t - bf_init &bf_ctx &n - numbertobf &n ref - let str = (bftostr &n) - bf_delete &n - str - -fn numbertosstr (ref) - local n : bf_t - bf_init &bf_ctx &n - numbertobf &n ref - let str = (bftosstr &n) - bf_delete &n - str + let expr = + uquote + test "test" 1 2 3 (a b c) (: 10 true) (: d e) 3.5 (: (1 2 3) (4 5 6)) + #print + 'tostring expr + let tab = (expr as Table) + #print + 'get tab (Table.new 1 2 3) + ; -inline gen-number (f value) - local n : bf_t - bf_init &bf_ctx &n - f &n value - let uref = (Number.from_bf n) - bf_delete &n - uref - -fn... number (value : i64) - gen-number bf_set_si value -case (value : u64) - gen-number bf_set_ui value -case (value : f64) - gen-number bf_set_float64 value - -inline number_op0_inplace (f ...) - fn (x) - local res : bf_t - bf_init &bf_ctx &res - numbertobf &res x - f &res ... - let result = (Number.from_bf res) - bf_delete &res - result - -inline number_op0 (f ...) - fn () - local res : bf_t - bf_init &bf_ctx &res - f &res ... - let result = (Number.from_bf res) - bf_delete &res - result + let expr = + uquote + let + : a 2 + : b 2.5 + : c 4 + : d + : 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 (: x c)) b a -inline number_op1 (f ...) - fn (x) - local bfx : bf_t - bf_init &bf_ctx &bfx - numbertobf &bfx x - local res : bf_t - bf_init &bf_ctx &res - f &res &bfx ... - let result = (Number.from_bf res) - bf_delete &bfx - bf_delete &res - result - -inline number_op2 (f ...) - fn (a b) - local bfa : bf_t - local bfb : bf_t - bf_init &bf_ctx &bfa - bf_init &bf_ctx &bfb - numbertobf &bfa a - numbertobf &bfb b - local res : bf_t - bf_init &bf_ctx &res - f &res &bfa &bfb ... - let result = (Number.from_bf res) - bf_delete &bfa - bf_delete &bfb - bf_delete &res - result - -fn number-cmp (a b) - local bfa : bf_t - local bfb : bf_t - bf_init &bf_ctx &bfa - bf_init &bf_ctx &bfb - numbertobf &bfa a - numbertobf &bfb b - let result = (bf_cmp &bfa &bfb) - bf_delete bfa - bf_delete bfb - result - -let number-const-log2 = (number_op0 bf_const_log2 Number.DEFAULT_PREC 0) -let number-const-pi = (number_op0 bf_const_pi Number.DEFAULT_PREC 0) - -let number-toint = (number_op0_inplace bf_rint bf_rnd_t.BF_RNDZ) -let number-neg = (number_op0_inplace bf_neg) - -let number-add = (number_op2 bf_add Number.DEFAULT_PREC 0) -let number-sub = (number_op2 bf_sub Number.DEFAULT_PREC 0) -let number-mul = (number_op2 bf_mul Number.DEFAULT_PREC 0) -let number-div = (number_op2 bf_div Number.DEFAULT_PREC 0) -let number-rem = (number_op2 bf_rem Number.DEFAULT_PREC 0 bf_rnd_t.BF_RNDZ) - -let number-pow = (number_op2 bf_pow Number.DEFAULT_PREC 0) -let number-atan2 = (number_op2 bf_atan2 Number.DEFAULT_PREC 0) - -let number-or = (number_op2 bf_logic_or) -let number-xor = (number_op2 bf_logic_xor) -let number-and = (number_op2 bf_logic_and) + using import tukan.File + let testfilepath = + .. module-dir "/test.uvm" + do + let testfile = + try (File.open testfilepath "wb") + else + error + .. "creating " testfilepath " failed" + pickle testfile expr + let expr2 = + do + let testfile = + try (File.open testfilepath "rb") + else + error + .. "opening " testfilepath " failed" + unpickle testfile -let number-sqrt = (number_op1 bf_sqrt Number.DEFAULT_PREC 0) -let number-exp = (number_op1 bf_exp Number.DEFAULT_PREC 0) -let number-log = (number_op1 bf_log Number.DEFAULT_PREC 0) -let number-pow = (number_op1 bf_pow Number.DEFAULT_PREC 0) -let number-cos = (number_op1 bf_cos Number.DEFAULT_PREC 0) -let number-sin = (number_op1 bf_sin Number.DEFAULT_PREC 0) -let number-tan = (number_op1 bf_tan Number.DEFAULT_PREC 0) -let number-atan = (number_op1 bf_atan Number.DEFAULT_PREC 0) -let number-asin = (number_op1 bf_asin Number.DEFAULT_PREC 0) -let number-acos = (number_op1 bf_acos Number.DEFAULT_PREC 0) - -fn number-int? (x) - (number-cmp x (number-toint x)) == 0 - -fn number-get-u64 (x) - local bfx : bf_t - bf_init &bf_ctx &bfx - try - numbertobf &bfx x - else - bf_delete &bfx - raise; + let testmodulepath = + .. module-dir "/test.um" + let expr3 = + do + try + let mod = (Module testmodulepath) + report "storing..." + let act = ('edit mod) + 'store act expr + 'commit act + except (err) + raise (err as Error) - local bfcmp : bf_t - bf_init &bf_ctx &bfcmp - bf_set_zero &bfcmp 0 - if ((bf_cmp &bfx &bfcmp) >= 0) - bf_set_si &bfcmp 0x7fffffffffffffff:i64 - if ((bf_cmp &bfx &bfcmp) <= 0) - local bfint : bf_t - bf_init &bf_ctx &bfint - bf_set &bfint &bfx - bf_rint &bfint bf_rnd_t.BF_RNDZ - if ((bf_cmp &bfx &bfint) == 0) - local outp : i64 - bf_get_int64 &outp &bfx 0 - bf_delete &bfint - bf_delete &bfcmp - bf_delete &bfx - return ((deref outp) as u64) - bf_delete &bfint - bf_delete &bfcmp - bf_delete &bfx - raise; + try + let mod = (Module testmodulepath) + report "loading..." + let act = ('view mod) + 'load act + except (err) + raise (err as Error) + print "db load:" + 'tostring expr3 -# String -############################################################################### - -inline... ustring (str : string) - local uref = (URef.store (str as rawstring) (countof str)) - uref.kind = URef.Kind.String - uref - -inline... usymbol (str : string) - local uref = (URef.store (str as rawstring) (countof str)) - uref.kind = URef.Kind.Symbol - uref - -# Table -############################################################################### - -let IndexBits = 4 -let ArrayCellCount = (1 << IndexBits) -let IndexMask = (ArrayCellCount - 1) + let env = (global-environment) + let result1 result2 = + ueval env expr + ueval env expr2 + print + 'tostring expr + print + 'tostring result1 + print + 'tostring expr2 + print + 'tostring result2 + assert (expr == expr2) + assert (result1 == result2) -@@ verify-sizeof 520 -struct TableLimb plain - cells : (array URef ArrayCellCount) - mask : u64 = 0 # slots used - - fn unref (uref) - ptrtoref - bitcast ('load uref) (pointer this-type) - - fn ref (limb) - local uref = (URef.store &limb (sizeof limb)) - uref.kind = URef.Kind.TableLimb - uref - -@@ verify-sizeof 136 -struct Table plain - meta : URef - keys : URef - values : URef - ivalues : URef - depth : u64 - - fn unref (uref) - ptrtoref - bitcast ('load uref) (pointer this-type) - - fn ref (table) - local uref = (URef.store &table (sizeof table)) - uref.kind = URef.Kind.Table - uref - -fn depth-maxindex (depth) - ((ArrayCellCount as u64) << (depth * IndexBits)) - 1 - -fn table-capacity (uarr) - uarr := (Table.unref uarr) - depth-maxindex (copy uarr.depth) - -fn... table-seti (uarr, index : u64, value : URef) - fn recur (node depth index value) - returning URef u64 - raising (uniqueof UError -1) - - if (index == 0) - # truncate - return value depth - - node := (copy node) - maxindex := (depth-maxindex depth) - let node depth = - if (index > maxindex) - # exceeding existing capacity - if ('null? value) - # nothing to do - return node depth - if ('null? node) - # increase depth until it fits - _ node - loop (depth = depth) - let newdepth = (depth + 1) - maxindex := (depth-maxindex newdepth) - if (index > maxindex) - repeat newdepth - else - break newdepth - else - loop (node depth = (copy node) depth) - let newdepth = (depth + 1) - maxindex := (depth-maxindex newdepth) - # split - local newlimb = (TableLimb) - newlimb.mask = 1 - newlimb.cells @ 0 = node - for i in (range 1 ArrayCellCount) - newlimb.cells @ i = (URef) - let node = ('ref newlimb) - if (index > maxindex) - repeat node newdepth - else - break node newdepth - else - _ node depth - - let newlimb = - if (node.kind == URef.Kind.TableLimb) - local newlimb = (TableLimb.unref node) - else - # split - local newlimb = (TableLimb) - newlimb.cells @ 0 = node - if (not ('null? node)) - newlimb.mask = 1 - for i in (range 1 ArrayCellCount) - newlimb.cells @ i = (URef) - newlimb - - maxindex := (depth-maxindex depth) - let slot-capacity = ((maxindex >> IndexBits) + 1) - let slot-index = (index // slot-capacity) - assert (slot-index < ArrayCellCount) - - # subindex - let index = (index - (slot-index * slot-capacity)) - let value newdepth = - if (depth == 0) - _ (copy value) depth - else - let value depth = - this-function (newlimb.cells @ slot-index) (depth - 1) index value - _ value (depth + 1) - flag := 1:u64 << slot-index - if ('null? value) - newlimb.mask &= (~ flag) - else - newlimb.mask |= flag - if (newlimb.mask == 0) # empty - return (URef) depth - else - newlimb.cells @ slot-index = value - return - 'ref newlimb - newdepth - uarr := (Table.unref uarr) - # truncate excess capacity - let node depth = - loop (node depth = (recur uarr.ivalues (copy uarr.depth) index value)) - if (node.kind == URef.Kind.TableLimb) - let limb = (TableLimb.unref node) - if (limb.mask == 1) - repeat - copy (limb.cells @ 0) - depth - 1 - break node depth - local uarr = uarr - uarr.ivalues = node - uarr.depth = depth - 'ref uarr - -fn... table-deli (uarr, index : u64) - table-seti uarr index (URef) - -fn... table-geti (uarr, index : u64) - uarr := (Table.unref uarr) - fn recur (node depth index) - returning URef - raising (uniqueof UError -1) - - node := (copy node) - - maxindex := (depth-maxindex depth) - if (index > maxindex) - return (URef) - - if (node.kind != URef.Kind.TableLimb) - if (index == 0) - return node - else - return (URef) - - let limb = (TableLimb.unref node) - - 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 - recur (copy uarr.ivalues) (copy uarr.depth) index - -fn table-last-index (uarr) - uarr := (Table.unref uarr) - if ('null? uarr.ivalues) - return -1:u64 - loop (node depth index = (deref uarr.ivalues) (copy uarr.depth) 0:u64) - if (node.kind == URef.Kind.TableLimb) # branch - let limb = (TableLimb.unref node) - repeat - label found - for i in (rrange ArrayCellCount) - let node = - deref (limb.cells @ i) - if (not ('null? 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; - else - break index - -fn... table-append (uarr, value : URef) - table-seti uarr ((table-last-index uarr) + 1) value - -fn... table-set (table, key : URef, value : URef) - label do-regular-set - if (key.kind == URef.Kind.Number) - let index = - try (number-get-u64 key) - else - merge do-regular-set - return (table-seti table index value) - table := (Table.unref table) - fn recur (keylimb valuelimb key value depth) - returning URef URef - assert (depth <= 56) - let mask = ((((key as integer) >> (depth * IndexBits)) as u32) & IndexMask) - if (keylimb.kind == URef.Kind.TableLimb) # branch - assert (valuelimb.kind == URef.Kind.TableLimb) - local newkl = (TableLimb.unref keylimb) - local newvl = (TableLimb.unref valuelimb) - let currentkey = (copy (newkl.cells @ mask)) - let subkeylimb subvaluelimb = - this-function currentkey (newvl.cells @ mask) key value (depth + 1) - newkl.cells @ mask = subkeylimb - newvl.cells @ mask = subvaluelimb - flag := 1:u64 << mask - if ('null? subkeylimb) - flag := (~ flag) - newkl.mask &= flag - newvl.mask &= flag - else - newkl.mask |= flag - newvl.mask |= flag - assert (newkl.mask != 0) - if ((bitcount newkl.mask) == 1) - let index = (findmsb newkl.mask) - assert (index < ArrayCellCount) - let node = (newkl.cells @ index) - assert (not ('null? node)) - return (copy node) (copy (newvl.cells @ index)) - else - return ('ref newkl) ('ref newvl) - elseif (('null? keylimb) or (keylimb == key)) # empty or same key - if ('null? value) # clear - return (URef) (URef) - else - return key value - else # split? - if ('null? value) - # we're removing this value anyway - return (copy keylimb) (copy valuelimb) - let oldmask = ((((keylimb as integer) >> (depth * IndexBits)) as u32) & IndexMask) - local limb : TableLimb - for i in (range ArrayCellCount) - limb.cells @ i = (URef) - limb.mask = 1:u64 << oldmask - limb.cells @ oldmask = keylimb - let kref = ('ref limb) - limb.cells @ oldmask = valuelimb - let vref = ('ref limb) - return - this-function kref vref key value depth - let keys values = (recur table.keys table.values key value 0) - local table = table - table.keys = keys - table.values = values - 'ref table - -fn table-getmeta (table) - let table = (Table.unref table) - copy table.meta - -fn table-setmeta (table metatable) - assert (metatable.kind == URef.Kind.Table) - local table = (Table.unref table) - table.meta = metatable - 'ref table - -fn... table-del (table, key : URef) - label do-regular-del - if (key.kind == URef.Kind.Number) - let index = - try (number-get-u64 key) - else - merge do-regular-del - return (table-deli table index) - table-set table key (URef) - -fn... table-get (table, key : URef) - label do-regular-get - if (key.kind == URef.Kind.Number) - let index = - try (number-get-u64 key) - else - merge do-regular-get - return (table-geti table index) - table := (Table.unref table) - fn recur (keylimb valuelimb key depth) - returning URef - let mask = ((((key as integer) >> (depth * IndexBits)) as u32) & IndexMask) - if (keylimb.kind == URef.Kind.TableLimb) # branch - local newkl = (TableLimb.unref keylimb) - local newvl = (TableLimb.unref valuelimb) - return - this-function (newkl.cells @ mask) (newvl.cells @ mask) key (depth + 1) - elseif (keylimb == key) # found key - return (copy valuelimb) - # key not found - return (URef) - recur table.keys table.values key 0 - -fn table-dump (table) - print "table" table - table := (Table.unref table) - fn recur (pre node depth index) - returning void - let maxindex = (depth-maxindex depth) - if (node.kind == URef.Kind.TableLimb) # branch - let limb = (TableLimb.unref node) - let slot-capacity = ((maxindex >> IndexBits) + 1) - print - .. pre - repr node - " (capacity: " - repr (maxindex + 1) - " mask: 0b" - bin limb.mask - ")" - for i in (range ArrayCellCount) - let index = (index + slot-capacity * i) - this-function - .. pre " @" (repr index) ": " - limb.cells @ i - depth - 1 - index - elseif (not ('null? node)) - print - .. pre - repr node - else - print - .. pre "null" - print "max index:" (depth-maxindex (copy table.depth)) - recur " " table.ivalues (copy table.depth) 0 - fn recur (pre keylimb valuelimb depth) - returning void - if (keylimb.kind == URef.Kind.TableLimb) # branch - let kl = (TableLimb.unref keylimb) - let vl = (TableLimb.unref valuelimb) - print - .. pre - repr keylimb - " " - repr valuelimb - for i in (range ArrayCellCount) - this-function - .. pre " @" (repr i) ": " - kl.cells @ i - vl.cells @ i - depth + 1 - elseif (not ('null? keylimb)) - print - .. pre - repr keylimb - "=" - repr valuelimb - else - print - .. pre "null" - recur " " table.keys table.values 0 - print; +# + print + sha256-digest-string + local digest = + 'uhash expr + print + (('hashbits expr) >> (256 - 4)) as u8 + ; -@@ memo -inline table-eachi (f) - fn process (value ...) - fn recur (node depth index ...) - returning void - if (node.kind == URef.Kind.TableLimb) # branch - let limb = (TableLimb.unref node) - let maxindex = (depth-maxindex depth) - let slot-capacity = ((maxindex >> IndexBits) + 1) - for i in (range ArrayCellCount) - let index = (index + slot-capacity * i) - this-function - limb.cells @ i - depth - 1 - index - ... - elseif (not ('null? node)) - f index node ... - return; - table := (Table.unref value) - recur table.ivalues table.depth 0:u64 ... - -@@ memo -inline table-each (f) - fn process (value ...) - fn recur (key value ...) - returning void - if (key.kind == URef.Kind.TableLimb) # branch - let kl = ((TableLimb.unref key) . cells) - let vl = ((TableLimb.unref value) . cells) - for i in (range ArrayCellCount) - let k v = - kl @ i - vl @ i - this-function k v ... - elseif (not ('null? key)) - f key value ... - return; - table := (Table.unref value) - recur table.keys table.values ... - -fn table (...) - local table : Table - let t = ('ref table) - va-lfold t - inline (key value t) - static-if (key == unnamed) - table-append t value - else - table-set t - usymbol (key as string) - value - ... - -############################################################################### - -fn uref-repr (value) - #returning String - - let uref-repr = this-function - if ('null? value) - return (String "null") - - switch value.kind - case URef.Kind.Number - let str = (numbertosstr value) - return - String (default-styler style-number str) - case URef.Kind.String - let buf sz = ('load value) - let str = (string (buf as rawstring) sz) - String - repr str - case URef.Kind.Symbol - let buf sz = ('load value) - let str = (Symbol (string (buf as rawstring) sz)) - String - repr str - case URef.Kind.Table - table := (Table.unref value) - local str : String - 'append str "(" - local count = 0 - fn recur (str node depth index count) - returning void - let maxindex = (depth-maxindex depth) - if (node.kind == URef.Kind.TableLimb) # branch - let limb = (TableLimb.unref node) - let slot-capacity = ((maxindex >> IndexBits) + 1) - for i in (range ArrayCellCount) - let index = (index + slot-capacity * i) - this-function str - limb.cells @ i - depth - 1 - index - count - elseif (not ('null? node)) - if (count > 0) - 'append str " " - if (count != index) - 'append str - default-styler style-number (tostring index) - 'append str "=" - 'append str (uref-repr node) - count += 1 - recur str table.ivalues table.depth 0:u64 count - fn recur (str key value count) - returning void - if (key.kind == URef.Kind.TableLimb) # branch - let kl = ((TableLimb.unref key) . cells) - let vl = ((TableLimb.unref value) . cells) - for i in (range ArrayCellCount) - let k v = - kl @ i - vl @ i - this-function str k v count - elseif (not ('null? key)) - if (count > 0) - 'append str " " - 'append str (uref-repr key) - 'append str "=" - 'append str (uref-repr value) - count += 1 - recur str table.keys table.values count - 'append str ")" - deref str - default - String - repr value - -############################################################################### - -let builtins global-env = - fold (scope env = (Scope) (table)) for name in - sugar-quote + - * / let fn - sym := (usymbol (name as Symbol as string)) - code := sym as integer - _ - 'bind scope name `code - try - table-set env sym sym - else - error "expanding table failed" - -run-stage; - -global mt_closure = - do - try - table - type = (ustring "closure") - else - error "defining metatype failed" - -fn global-environment () - global-env - -fn... ueval (env : URef, expr : URef) - let ueval = this-function - - assert (env.kind == URef.Kind.Table) - switch expr.kind - case URef.Kind.Symbol - return (table-get env expr) - case URef.Kind.Table - let head = (table-geti expr 0) - let head = - if (head.kind == URef.Kind.Symbol) - let result = (table-get env head) - if ('null? result) - print "unknown name: " head - result - else - ueval env head - - switch head.kind - case URef.Kind.Table - if ((table-getmeta head) == mt_closure) - let origenv = env - local env = (table-geti head 0) - let f = (table-geti head 1) - let params = (table-geti f 1) - let eachf = - table-eachi - inline (i value origenv env params) - if (i > 0) - let name = - table-geti params (i - 1) - env = - table-set env name - ueval origenv (copy value) - ; - eachf expr origenv env params - let expr = (table-geti f 2) - ueval (copy env) expr - else - print "cannot apply table:" (uref-repr expr) - return (URef) - case URef.Kind.Symbol - fn verify (val K) - if (val.kind != K) - print K "expected, got" (uref-repr val) - - inline binop (f) - let a = (ueval env (table-geti expr 1)) - verify a URef.Kind.Number - let b = (ueval env (table-geti expr 2)) - verify b URef.Kind.Number - return - number-add a b - - inline eval-let () - let f = - table-each - inline (k v origenv env) - env = - table-set env (copy k) - ueval origenv (copy v) - ; - local newenv = env - f expr env newenv - return (ueval newenv (table-geti expr 1)) - - inline eval-fn () - return - table-setmeta - table env expr - mt_closure - - using builtins - switch (head as integer) - case + (binop number-add) - case - (binop number-sub) - case * (binop number-mul) - case / (binop number-div) - case let (eval-let) - case fn (eval-fn) - default - print "syntax error:" (uref-repr expr) - return (URef) - default - print "cannot apply:" (uref-repr expr) - return (URef) - default - return expr - -############################################################################### - -fn translate-quote-recur (value) - returning URef - let recur = this-function - let T = ('typeof value) - match T - case list - let l = (value as list) - return - 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 - try - table-set t key value - except (err) - error (repr err) - default; - key := (recur elem) - try - table-append t key - except (err) - error (repr err) - case string - let str = (value as string) - return (ustring str) - case Symbol - let str = (value as Symbol as string) - return (usymbol str) - default - let tk = ('kind ('storageof T)) - switch tk - case type-kind-integer - return (number (sc_const_int_extract value)) - case type-kind-real - return (number (sc_const_real_extract value)) - default; - report "unable to handle type" (repr T) - error (.. "unable to handle type" (repr T)) - -inline translate-quote (value) - translate-quote-recur (value as Value) - -sugar uquote (expr...) - if ((countof expr...) == 1) - let at = (decons expr...) - translate-quote at - else - translate-quote expr... - -run-stage; - -############################################################################### - -fn table-tests () - let t = (table) - print "empty table:" t - let t = - table-set t (ustring "key") (ustring "value") - print "after 1 insert:" t - table-dump t - let t = - table-set t (ustring "key2") (ustring "value") - print "after 2 insert:" t - table-dump t - print "get" (table-get t (ustring "key")) - let t = - table-del t (ustring "key") - table-dump t - let t = - table-del t (ustring "key2") - table-dump t - print "get" (table-get t (ustring "key")) - -fn number-tests () - print - number -1 - number 0 - number 1 - number 2 - print - uref-repr (number-const-pi) - value := - number-neg - number-toint - number-sqrt - number-or - number 41 - number 10 - print - numbertostr value - print - number-cmp value (number -6) - print (number-int? value) - -fn uref-tests () - print (uref-repr (ustring "test")) - print (uref-repr (number 3.5)) - let t = - table - number 23 - number 42 - number 303 - key1 = (ustring "value") - key2 = (ustring "value2") - let t = - table-set t (number 10) (ustring "test") - print - uref-repr t - print - uref-repr - uquote (test "test" 1 2 3 (a b c) [d e] 3.5 (: (1 2 3) (4 5 6))) - -fn uarray-tests () - let a = (table) - table-dump a - let a = (table-seti a 1 (number 1)) - table-dump a - let a = (table-seti a 960 (number 960)) - table-dump a - let a = (table-seti a 254 (number 960)) - table-dump a - let a = (table-deli a 960) - table-dump a - let a = (table-deli a 254) - table-dump a - print "last index:" (table-last-index a) - #let a = - uarray-set-index a 1000 (URef) - #uarray-dump a - -try - print - uref-repr - ueval - global-environment; - uquote - 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 - #table-tests; - #number-tests; - #uref-tests; - #uarray-tests; +do + #print ("test" as UAtom) + + testfunc; + + ; + # - print "final emptied table:" t + let val = + UAtom 303 + #UAtom "hello" + + local digest = ('uhash val) + + print ((UAtom 2) != (UAtom 2)) + + let val2 = (copy val) + + dispatch val + case Number (n) + print n + default + print "nope" + + print ('kind (UAtom)) + + let table = (UAtom (Table)) + print table print - ustring "hello" -else - print "failed" + Table.new "this" "is" "a" "test" + x = 1 + y = 2.5 + z = 3 + print + '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) + #drop val + ; ; \ No newline at end of file diff --git a/testing/test_uvm2.sc b/testing/test_uvm2.sc deleted file mode 100644 --- a/testing/test_uvm2.sc +++ /dev/null @@ -1,463 +0,0 @@ -using import struct -using import enum -using import Map -using import Array -using import String - -import ..lib.tukan.use -using import tukan.ustore -using import tukan.libbf - -# - new idea for VM: - number = fp128 - tuple as basic composite - -inline verify-sizeof (size) - inline (T) - #static-assert ((alignof T) == 8) - .. "(alignof " (tostring T) ") != 8" - static-assert ((sizeof T) == size) - .. "(sizeof " (tostring T) ") == " - \ (tostring (sizeof T)) " != " (tostring size) - T - -# Number -############################################################################### - -let realloc = - extern 'realloc - function voidstar voidstar usize -fn urealloc (opaque ptr size) - realloc ptr size -global bf_ctx : bf_context_t -bf_context_init &bf_ctx urealloc null - -struct Number plain - sign : i64 - expn : i64 - len : u64 - tab : (array u64) - - let DEFAULT_PREC = 56 - - fn... from_bf (n : &bf_t) - bufsize := (sizeof this-type) + (sizeof u64) * n.len - let buf = - ptrtoref - bitcast - alloca-array u8 bufsize - mutable pointer this-type - buf.sign = n.sign - buf.expn = n.expn - buf.len = n.len - for i in (range n.len) - buf.tab @ i = n.tab @ i - local uref = (URef.store &buf bufsize) - uref.kind = URef.Kind.Number - uref - -fn bftostr (x) - local sz : u64 - let s = - bf_ftoa &sz x 10 Number.DEFAULT_PREC BF_FTOA_FORMAT_FREE_MIN - String s sz - -fn bftosstr (x) - local sz : u64 - let s = - bf_ftoa &sz x 10 Number.DEFAULT_PREC BF_FTOA_FORMAT_FREE_MIN - string s sz - -fn numbertobf (r ref) - let num = - bitcast ('load ref) (pointer Number) - local n = - bf_t - sign = (num.sign as i32) - expn = num.expn - len = num.len - tab = (bitcast (& (num.tab @ 0)) (mutable pointer u64)) - bf_set r &n - -fn numbertostr (ref) - local n : bf_t - bf_init &bf_ctx &n - numbertobf &n ref - let str = (bftostr &n) - bf_delete &n - str - -fn numbertosstr (ref) - local n : bf_t - bf_init &bf_ctx &n - numbertobf &n ref - let str = (bftosstr &n) - bf_delete &n - str - -inline gen-number (f value) - local n : bf_t - bf_init &bf_ctx &n - f &n value - let uref = (Number.from_bf n) - bf_delete &n - uref - -fn... number (value : i64) - gen-number bf_set_si value -case (value : u64) - gen-number bf_set_ui value -case (value : f64) - gen-number bf_set_float64 value - -inline number_op0_inplace (f ...) - fn (x) - local res : bf_t - bf_init &bf_ctx &res - numbertobf &res x - f &res ... - let result = (Number.from_bf res) - bf_delete &res - result - -inline number_op0 (f ...) - fn () - local res : bf_t - bf_init &bf_ctx &res - f &res ... - let result = (Number.from_bf res) - bf_delete &res - result - -inline number_op1 (f ...) - fn (x) - local bfx : bf_t - bf_init &bf_ctx &bfx - numbertobf &bfx x - local res : bf_t - bf_init &bf_ctx &res - f &res &bfx ... - let result = (Number.from_bf res) - bf_delete &bfx - bf_delete &res - result - -inline number_op2 (f ...) - fn (a b) - local bfa : bf_t - local bfb : bf_t - bf_init &bf_ctx &bfa - bf_init &bf_ctx &bfb - numbertobf &bfa a - numbertobf &bfb b - local res : bf_t - bf_init &bf_ctx &res - f &res &bfa &bfb ... - let result = (Number.from_bf res) - bf_delete &bfa - bf_delete &bfb - bf_delete &res - result - -fn number-cmp (a b) - local bfa : bf_t - local bfb : bf_t - bf_init &bf_ctx &bfa - bf_init &bf_ctx &bfb - numbertobf &bfa a - numbertobf &bfb b - let result = (bf_cmp &bfa &bfb) - bf_delete bfa - bf_delete bfb - result - -let number-const-log2 = (number_op0 bf_const_log2 Number.DEFAULT_PREC 0) -let number-const-pi = (number_op0 bf_const_pi Number.DEFAULT_PREC 0) - -let number-toint = (number_op0_inplace bf_rint bf_rnd_t.BF_RNDZ) -let number-neg = (number_op0_inplace bf_neg) - -let number-add = (number_op2 bf_add Number.DEFAULT_PREC 0) -let number-sub = (number_op2 bf_sub Number.DEFAULT_PREC 0) -let number-mul = (number_op2 bf_mul Number.DEFAULT_PREC 0) -let number-div = (number_op2 bf_div Number.DEFAULT_PREC 0) -let number-rem = (number_op2 bf_rem Number.DEFAULT_PREC 0 bf_rnd_t.BF_RNDZ) - -let number-pow = (number_op2 bf_pow Number.DEFAULT_PREC 0) -let number-atan2 = (number_op2 bf_atan2 Number.DEFAULT_PREC 0) - -let number-or = (number_op2 bf_logic_or) -let number-xor = (number_op2 bf_logic_xor) -let number-and = (number_op2 bf_logic_and) - -let number-sqrt = (number_op1 bf_sqrt Number.DEFAULT_PREC 0) -let number-exp = (number_op1 bf_exp Number.DEFAULT_PREC 0) -let number-log = (number_op1 bf_log Number.DEFAULT_PREC 0) -let number-pow = (number_op1 bf_pow Number.DEFAULT_PREC 0) -let number-cos = (number_op1 bf_cos Number.DEFAULT_PREC 0) -let number-sin = (number_op1 bf_sin Number.DEFAULT_PREC 0) -let number-tan = (number_op1 bf_tan Number.DEFAULT_PREC 0) -let number-atan = (number_op1 bf_atan Number.DEFAULT_PREC 0) -let number-asin = (number_op1 bf_asin Number.DEFAULT_PREC 0) -let number-acos = (number_op1 bf_acos Number.DEFAULT_PREC 0) - -fn number-int? (x) - (number-cmp x (number-toint x)) == 0 - -fn number-get-u64 (x) - local bfx : bf_t - bf_init &bf_ctx &bfx - try - numbertobf &bfx x - else - bf_delete &bfx - raise; - - local bfcmp : bf_t - bf_init &bf_ctx &bfcmp - bf_set_zero &bfcmp 0 - if ((bf_cmp &bfx &bfcmp) >= 0) - bf_set_si &bfcmp 0x7fffffffffffffff:i64 - if ((bf_cmp &bfx &bfcmp) <= 0) - local bfint : bf_t - bf_init &bf_ctx &bfint - bf_set &bfint &bfx - bf_rint &bfint bf_rnd_t.BF_RNDZ - if ((bf_cmp &bfx &bfint) == 0) - local outp : i64 - bf_get_int64 &outp &bfx 0 - bf_delete &bfint - bf_delete &bfcmp - bf_delete &bfx - return ((deref outp) as u64) - bf_delete &bfint - bf_delete &bfcmp - bf_delete &bfx - raise; - -# String -############################################################################### - -inline... ustring (str : string) - local uref = (URef.store (str as rawstring) (countof str)) - uref.kind = URef.Kind.String - uref - -inline... usymbol (str : string) - local uref = (URef.store (str as rawstring) (countof str)) - uref.kind = URef.Kind.Symbol - uref - -# Tuple -############################################################################### - -let IndexBits = 4 -let ArrayCellCount = (1 << IndexBits) -let IndexMask = (ArrayCellCount - 1) - -struct UTuple plain - cells : (array URef) - - fn unref (uref) - let ptr sz = ('load uref) - _ - ptrtoref - bitcast ptr (pointer this-type) - sz // (sizeof URef) - -inline utuple-init (count f) - bufsize := (sizeof URef) * count - let buf = - ptrtoref - bitcast - alloca-array u8 bufsize - mutable pointer UTuple - f buf.cells - local uref = (URef.store &buf bufsize) - uref.kind = URef.Kind.Tuple - uref - -fn utuple (...) - count := (va-countof ...) - utuple-init count - inline (cells) - va-map - inline (i) - cells @ i = (va@ i ...) - va-range count - -############################################################################### - -fn uref-repr (value) - #returning String - - let uref-repr = this-function - if ('null? value) - return (String "null") - - switch value.kind - case URef.Kind.Number - let str = (numbertosstr value) - return - String (default-styler style-number str) - case URef.Kind.String - let buf sz = ('load value) - let str = (string (buf as rawstring) sz) - String - repr str - case URef.Kind.Symbol - let buf sz = ('load value) - let str = (Symbol (string (buf as rawstring) sz)) - String - repr str - case URef.Kind.Tuple - let ut count = (UTuple.unref value) - local str : String - 'append str "(" - for i in (range count) - if (i > 0) - 'append str " " - 'append str (uref-repr (ut.cells @ i)) - 'append str ")" - deref str - default - String - repr value - -############################################################################### - -fn translate-quote (value) - fn recur (value) - returning URef - let recur = this-function - let T = ('typeof value) - match T - case list - let l = (value as list) - let sz = (countof l) - return - utuple-init sz - inline (cells) - for i elem in (enumerate l) - cells @ i = (recur elem) - case string - let str = (value as string) - return (ustring str) - case Symbol - let str = (value as Symbol as string) - return (usymbol str) - default - let tk = ('kind ('storageof T)) - switch tk - case type-kind-integer - return (number (sc_const_int_extract value)) - case type-kind-real - return (number (sc_const_real_extract value)) - default; - report "unable to handle type" (repr T) - error (.. "unable to handle type" (repr T)) - recur (value as Value) - -sugar uquote (expr...) - if ((countof expr...) == 1) - let at = (decons expr...) - translate-quote at - else - translate-quote expr... - -run-stage; - -############################################################################### - -type i64f64 <: (integer 128) - -let MANTISSA_MAX = (-1:u64 as f64) -let i128 = (integer 128 true) -let i256 = (integer 256 true) - -fn... from-double (d : f64) - let u = (d as i64) - let v = (((d % 1.0:f64) * MANTISSA_MAX) as i64) - ((u as i128) << 64) | (v as i128) - -fn... to-double (d : i128) - let u = ((d >> 64) as f64) - let v = (((d & -1:u64) as f64) / MANTISSA_MAX) - u + v - -let P = ((from-double pi:f64) as i256) -print - pi:f64 * pi:f64 - to-double (((P * P) >> 64) as i128) - -############################################################################### - -#fn table-tests () - let t = (table) - print "empty table:" t - let t = - table-set t (ustring "key") (ustring "value") - print "after 1 insert:" t - table-dump t - let t = - table-set t (ustring "key2") (ustring "value") - print "after 2 insert:" t - table-dump t - print "get" (table-get t (ustring "key")) - let t = - table-del t (ustring "key") - table-dump t - let t = - table-del t (ustring "key2") - table-dump t - print "get" (table-get t (ustring "key")) - -fn number-tests () - print - number -1 - number 0 - number 1 - number 2 - print - uref-repr (number-const-pi) - value := - number-neg - number-toint - number-sqrt - number-or - number 41 - number 10 - print - numbertostr value - print - number-cmp value (number -6) - print (number-int? value) - -inline uref-tests () - print (uref-repr (ustring "test")) - print (uref-repr (number 3.5)) - let t = - utuple - number 23 - number 42 - number 303 - print - uref-repr t - print - uref-repr - uquote (test "test" 1 2 3 (a b c) 3.5) - -try - #table-tests; - #number-tests; - uref-tests; - #uarray-tests; -# - print "final emptied table:" t - print - ustring "hello" -else - print "failed" - -; \ No newline at end of file diff --git a/testing/test_uvm3.sc b/testing/test_uvm3.sc deleted file mode 100644 --- a/testing/test_uvm3.sc +++ /dev/null @@ -1,166 +0,0 @@ -using import struct -using import enum -using import Map -using import Set -using import Array -using import String -using import Rc - -import ..lib.tukan.use -using import tukan.uvm -using import tukan.module -using import tukan.pickle - -############################################################################## - -fn testfunc () - #print ("test" as UAtom) - - let expr = - uquote - test "test" 1 2 3 (a b c) (: 10 true) (: d e) 3.5 (: (1 2 3) (4 5 6)) - #print - 'tostring expr - let tab = (expr as Table) - #print - 'get tab (Table.new 1 2 3) - ; - - let expr = - uquote - let - : a 2 - : b 2.5 - : c 4 - : d - : 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 (: x c)) b a - - using import tukan.File - let testfilepath = - .. module-dir "/test.uvm" - do - let testfile = - try (File.open testfilepath "wb") - else - error - .. "creating " testfilepath " failed" - pickle testfile expr - let expr2 = - do - let testfile = - try (File.open testfilepath "rb") - else - error - .. "opening " testfilepath " failed" - unpickle testfile - - let testmodulepath = - .. module-dir "/test.um" - let expr3 = - do - try - let mod = (Module testmodulepath) - report "storing..." - let act = ('edit mod) - 'store act expr - 'commit act - except (err) - raise (err as Error) - - try - let mod = (Module testmodulepath) - report "loading..." - let act = ('view mod) - 'load act - except (err) - raise (err as Error) - print "db load:" - 'tostring expr3 - - let env = (global-environment) - let result1 result2 = - ueval env expr - ueval env expr2 - print - 'tostring expr - print - 'tostring result1 - print - 'tostring expr2 - print - 'tostring result2 - assert (expr == expr2) - assert (result1 == result2) - - -# - 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" - - local digest = ('uhash val) - - print ((UAtom 2) != (UAtom 2)) - - let val2 = (copy val) - - dispatch val - case Number (n) - print n - default - print "nope" - - print ('kind (UAtom)) - - let table = (UAtom (Table)) - print table - print - Table.new "this" "is" "a" "test" - x = 1 - y = 2.5 - z = 3 - print - '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) - #drop val - ; - -; \ No newline at end of file