rev: ed75a3e440d5bfe660a22175fd08458fce62598e tukan/testing/test_typeschema2.sc -rw-r--r-- 8.5 KiB View raw Log this file
ed75a3e440d5 — Leonard Ritter * more work on type schema a month ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
#
    do we need a database format?

    our general data model has two parts:

    1. an immutable, conceptually ever-expanding table of data blobs,
        addressable by content (content-addressable store)

        which can be used to implement tries and merkle trees

    2. a mutable entry point into the root data structure

using import struct
using import enum
using import Map
using import Array

# declare void @llvm.memcpy.p0i8.p0i8.i64(i8* <dest>, i8* <src>,
                                        i64 <len>, i1 <isvolatile>)
let llvm.memcpy.p0i8.p0i8.i64 =
    extern 'llvm.memcpy.p0i8.p0i8.i64
        function void (mutable rawstring) rawstring i64 bool

import ..lib.tukan.use
using import tukan.SHA256

fn hex64 (value)
    ..
        va-map
            inline (i)
                hex
                    (value >> (i * 8)) & 0xff
            va-range 8

type UPointer : SHA256.DigestType

    inline... to (data : voidstar, size : usize)
        (sha256 (data as rawstring) size) as this-type

    inline __hash (self)
        (deref ((storagecast self) @ 0)) as hash

    fn __repr (self)
        .. "@"
            va-map hex64
                unpack (storagecast self)

    @@ memo
    inline __== (cls T)
        static-if (cls == T)
            inline (a b)
                (storagecast a) == (storagecast b)

    @@ memo
    inline __imply (cls T)
        static-if (T == (storageof cls))
            storagecast

    @@ memo
    inline __rimply (T cls)
        static-if (T == (storageof cls))
            inline (self)
                bitcast self cls

struct UBlob plain
    size : usize
    offset : usize

    fn __repr (self)
        .. "<UBlob["
            dec self.size
            "] @ "
            dec self.offset
            ">"

struct UStore # content addressable store abstraction
    # memory blob
    memory : (Array u64)
    # address to offset into memory
    map : (Map UPointer UBlob)
    # root address
    root : UPointer = (undef UPointer)

    inline... @ (self, blob : UBlob, T : type)
        @ ((& (self.memory @ blob.offset)) as @T)

    fn... get (self, addr : UPointer)
        'get self.map addr

    fn... insert
    case (self, data : voidstar, size : usize)
        let addr = (UPointer.to data size)
        try
            let blob = ('get self.map addr)
            _ addr (copy blob)
        else
            let offset = (countof self.memory)
            let ptr =
                'emplace-append-many self.memory ((size + 7) // 8) 0:u64
            llvm.memcpy.p0i8.p0i8.i64
                &ptr as (mutable rawstring)
                data as rawstring
                size as i64
                false
            let blob =
                UBlob
                    size = size
                    offset = offset
            'set self.map addr blob
            _ addr blob
    case (self, str : string)
        this-function self (str as rawstring) (countof str)
    case (self, data)
        static-assert (not ((storageof data) < pointer))
        let data =
            static-if (&? data) data
            else
                local data = data
        this-function self &data (sizeof data)

global module : UStore

inline intern-string (s)
    let addr = ('insert module s)
    global interned-string = addr
    interned-string

let ref-type-name = (intern-string "ref256")
let integer-type-name = (intern-string "integer")
let real-type-name = (intern-string "real")

type UPointerType <: ('packed tuple UPointer i32)

type NumberType <: ('packed tuple UPointer i32)

static-assert ((sizeof NumberType) == 36)

fn... number-type (name : UPointer, bitcount : i32,)
    let value =
        NumberType name bitcount
    _ ('insert module value) ()

inline integer-type (bitcount)
    number-type integer-type-name bitcount

inline real-type (bitcount)
    number-type real-type-name bitcount

inline bitcountof (T)
    try
        let ptr = ('@ module ('get module T) NumberType)
        deref (ptr @ 1)
    else 0

global i32-type = (integer-type 32)
global f32-type = (real-type 32)



print
    bitcountof
        integer-type 32
print
    real-type 32

#
    untyped
    type.typename <module-uri:StringId> <name:StringId> <super-type:TypeId> <storage-type:TypeId> <memoized-value:Any> ...
    OK type.storage.integer <bitcount:i32> (negative bitcount: signed integer)
    OK type.storage.real <bitcount:u32>
    type.storage.pointer <flags:u32> <storage-class:StringId>
    type.storage.array <element-type:TypeId> <size:u64>
    type.storage.vector <element-type:TypeId> <size:u64>
    type.storage.tuple [<element-type:TypeId> ...]
    type.function <return-tuple-type:TypeId> <arguments-tuple-type:TypeId>
    type.qualify <type:TypeId> <sorted-qualifier:TypeId> ...

    subsequently, following builtin typenames are defined:

    type.typename "builtin" "Nothing" untyped (type.storage.tuple)
    type.typename "builtin" "Id" untyped (type.storage.integer 32)
    type.typename "builtin" "Type" untyped (type.storage.integer 32)
    type.typename "builtin" "Any" untyped (type.storage.tuple Type Id)
    type.typename "builtin" "String" untyped (type.storage.integer 32)
    type.typename "builtin" "Symbol" untyped (type.storage.integer 32)

    when a type is defined


#
    types:

    bool
    i32
    f32
    tuple T ...
    vector T size
    function <tuple-type> <- <tuple-type>




#fn decode-schemastr (s ofs)
    returning type i32
    if (ofs > (countof s))
        error "schemastr is empty"
    c := s @ ofs
    nextofs := ofs + 1
    switch c
    case (char "b") (_ bool nextofs)
    case (char "c") (_ i8 nextofs)
    case (char "h") (_ i16 nextofs)
    case (char "i") (_ i32 nextofs)
    case (char "l") (_ i64 nextofs)
    case (char "C") (_ u8 nextofs)
    case (char "H") (_ u16 nextofs)
    case (char "I") (_ u32 nextofs)
    case (char "L") (_ u64 nextofs)
    case (char "f") (_ f32 nextofs)
    case (char "d") (_ f64 nextofs)
    case (char "p")
        let T nextofs = (this-function s nextofs)
        _ (pointer.type T) nextofs
    case (char "(")
        local types : (Array type)
        loop (ofs = nextofs)
            c := s @ ofs
            switch c
            case (char ")")
                let firstval = (reftoptr (types @ 0))
                break (sc_tuple_type ((countof types) as i32) firstval) (ofs + 1)
            default
                let T nextofs = (this-function s ofs)
                assert (nextofs != ofs)
                'append types T
                repeat nextofs
    default
        error
            .. "can't parse schemastr: " (repr s)

#fn... from-schemastr (s)
    let T c = (decode-schemastr s 0)
    assert (c == (countof s))
    T


#fn encode-schemastr (stack T)
    returning string
    T := ('storageof T)
    for i elem in (enumerate ('reverse stack))
        if (elem == T)
            if (i > 9)
                error
                    .. "recursion limit reached (" (repr i) ")"
            return
                hex i
    kind := ('kind T)
    let parent = this-function
    inline array-like-type (open-token close-token)
        let size = ('element-count T)
        .. open-token
            parent stack ('element@ T 0)
            hex size
            close-token
    switch kind
    case type-kind-tuple
        'append stack T
        let size = ('element-count T)
        ..
            fold (s = "(") for i in (range size)
                elem := ('element@ T i)
                .. s (this-function stack elem)
            ")"
    case type-kind-array
        array-like-type "[" "]"
    case type-kind-vector
        array-like-type "<" ">"
    case type-kind-integer
        width := ('bitcount T)
        signed := ('signed? T)
        switch width
        case 1 "b"
        case 8 (? signed "c" "C")
        case 16 (? signed "h" "H")
        case 32 (? signed "i" "I")
        case 64 (? signed "l" "L")
        default
            error
                .. "can't handle integer bitcount: " (repr width)
    case type-kind-real
        width := ('bitcount T)
        switch width
        case 32 "f"
        case 64 "d"
        default
            error
                .. "can't handle real bitcount: " (repr width)
    case type-kind-pointer
        .. "p" (this-function stack ('element@ T 0))
    default
        error
            .. "can't handle kind: " (repr kind)

#fn schemastr (T)
    local stack : (Array type)
    encode-schemastr stack T

do
    let s = "Rosetta code"
    local k = (tupleof 1 2 3)
    let addr =
        'insert module k
    let blob =
        try
            'get module addr
        else
            error "invalid access"
    let ptr = ('@ module blob (tuple i32 i32 i32))
    print ptr
    ;


;