/
rowl1-tuple.rlc
161 lines (139 loc) · 3.63 KB
/
rowl1-tuple.rlc
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
;
; rowl - 1st generation
; Copyright (C) 2010 nineties
;
; $Id: rowl1-list.rlc 2013-03-19 11:49:08 nineties $
;
(import "rlvm-compile")
(import "rowl1-types")
(compile `object `(
(import "rowl1-util")
(import "rowl1-node")
(import "rowl1-module")
(import "rowl1-compile")
(import "rowl1-assemble")
(import "rowl1-error")
(extern object current_loc)
(extern object current_mod)
(export fun tuple2 (a b) (
(var t (allocate_tuple 2))
(array_set object t 0 a)
(array_set object t 1 b)
(return t)
))
(export fun tuple3 (a b c) (
(var t (allocate_tuple 3))
(array_set object t 0 a)
(array_set object t 1 b)
(array_set object t 2 c)
(return t)
))
(export fun tuple4 (a b c d) (
(var t (allocate_tuple 4))
(array_set object t 0 a)
(array_set object t 1 b)
(array_set object t 2 c)
(array_set object t 3 d)
(return t)
))
(export fun tuple5 (a b c d e) (
(var t (allocate_tuple 5))
(array_set object t 0 a)
(array_set object t 1 b)
(array_set object t 2 c)
(array_set object t 3 d)
(array_set object t 4 e)
(return t)
))
(fun tp_new (n) (
(= n (unbox n))
(var t (allocate_tuple n))
(for i 0 n (do
(array_set object t i @C_UNDEF)
))
(return t)
))
(fun tp_length (t) (
(return (box (seq_size t)))
))
(fun tp_hash (t) (
(var f (lookup_func current_mod (to_sym "hash")))
(var n (seq_size t))
(var h 0)
(for i 0 n (do
(= h (+ (* h 13) (unbox (byterun f (array_get object t i)))))
))
(return (box h))
))
(fun tp_equal (t1 t2) (
(var n (seq_size t1))
(if (!= (seq_size t2) n) (return @C_FALSE))
(var f (lookup_func current_mod (to_sym "equal")))
(for i 0 n (do
(if (== (byterun f
(array_get object t1 i) (array_get object t2 i)) @C_FALSE)
(return @C_FALSE))
))
(return @C_TRUE)
))
(export fun tuple_at (t i) (
(var n (seq_size t))
(if (>= i n) (throw (out_of_range current_loc t (box i))))
(return (array_get object t i))
))
(fun tp_at (t i) (
(return (tuple_at t (unbox i)))
))
(export fun tuple_store (t i v) (
(var n (seq_size t))
(if (>= i n) (throw (out_of_range current_loc t (box i))))
(array_set object t i v)
(return v)
))
(fun tp_store (t i v) (
(return (tuple_store t (unbox i) v))
))
(export fun tuple_restof (tup i) (
(var ls 0)
(var size (seq_size tup))
(rfor j i size (do
(= ls (cons (array_get object tup j) ls))
))
(return ls)
))
(export fun tuple_copy (tup) (
(var n (seq_size tup))
(var t (allocate_tuple n))
(for i 0 n (do
(array_set object t i (array_get object tup i))
))
(return t)
))
(export fun tuple_to_list (tup) (
(var ls 0)
(var size (seq_size tup))
(rfor i 0 size (do
(= ls (cons (array_get object tup i) ls))
))
(return ls)
))
(export fun list_to_tuple (list) (
(var n (list_len list))
(var t (allocate_tuple n))
(for i 0 n (do
(array_set object t i (car list))
(= list (cdr list))
))
(return t)
))
(export fun setup_tuple (std) (
(var mod (create_module std (to_sym "Tuple")))
(add_function1 mod (to_sym "new") intT tp_new 0)
(add_function1 std (to_sym "length") tupleT tp_length 0)
(add_function1 std (to_sym "size") tupleT tp_length 0)
(add_function1 std (to_sym "hash") tupleT tp_hash 0)
(add_function2 std (to_sym "equal") tupleT tupleT tp_equal 0)
(add_function2 std (to_sym "at") tupleT intT tp_at 0)
(add_function3 std (to_sym "store") tupleT intT DontCare tp_store 0)
))
))