M lib/tukan/ustore.sc +1 -0
@@ 26,6 26,7 @@ enum URefKind : u32
Number = 3 # sign, expn, len, bits...
Table = 4
TableLimb = 5
+ Tuple = 6
struct URef plain
Hasher := SHA224
A => testing/test_uvm2.sc +440 -0
@@ 0,0 1,440 @@
+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;
+
+###############################################################################
+
+#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