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
|
/* Structured input, compact format */
#include "fail.h"
#include "gc.h"
#include "intext.h"
#include "io.h"
#include "memory.h"
#include "mlvalues.h"
#include "misc.h"
#include "reverse.h"
static header_t * intern_ptr;
static asize_t obj_counter;
static value * intern_obj_table;
static unsigned int intern_color;
static header_t intern_header;
static value intern_block;
#define Sign_extend_shift ((sizeof(long) - 1) * 8)
#define Sign_extend(x) (((long)(x) << Sign_extend_shift) >> Sign_extend_shift)
static long input8u(chan)
struct channel * chan;
{
return getch(chan);
}
static long input8s(chan)
struct channel * chan;
{
long b1 = getch(chan);
return Sign_extend(b1);
}
static long input16u(chan)
struct channel * chan;
{
long b1 = getch(chan);
long b2 = getch(chan);
return (b1 << 8) + b2;
}
static long input16s(chan)
struct channel * chan;
{
long b1 = getch(chan);
long b2 = getch(chan);
return (Sign_extend(b1) << 8) + b2;
}
static long input32u(chan)
struct channel * chan;
{
long b1 = getch(chan);
long b2 = getch(chan);
long b3 = getch(chan);
long b4 = getch(chan);
return (b1 << 24) + (b2 << 16) + (b3 << 8) + b4;
}
static long input32s(chan)
struct channel * chan;
{
long b1 = getch(chan);
long b2 = getch(chan);
long b3 = getch(chan);
long b4 = getch(chan);
return (Sign_extend(b1) << 24) + (b2 << 16) + (b3 << 8) + b4;
}
#ifdef SIXTYFOUR
static long input64s(chan)
struct channel * chan;
{
long res;
int i;
res = 0;
for (i = 0; i < 8; i++) res = (res << 8) + getch(chan);
return res;
}
#endif
static void read_compact(chan, dest)
struct channel * chan;
value * dest;
{
unsigned int code;
tag_t tag;
mlsize_t size, len, ofs_ind;
value v;
asize_t ofs;
header_t header;
tailcall:
code = getch(chan);
if (code >= PREFIX_SMALL_INT) {
if (code >= PREFIX_SMALL_BLOCK) {
/* Small block */
tag = code & 0xF;
size = (code >> 4) & 0x7;
read_block:
if (size == 0) {
v = Atom(tag);
} else {
v = Val_hp(intern_ptr);
*dest = v;
intern_obj_table[obj_counter++] = v;
dest = (value *) (intern_ptr + 1);
*intern_ptr = Make_header(size, tag, intern_color);
intern_ptr += 1 + size;
for(/*nothing*/; size > 1; size--, dest++)
read_compact(chan, dest);
goto tailcall;
}
} else {
/* Small integer */
v = Val_int(code & 0x3F);
}
} else {
if (code >= PREFIX_SMALL_STRING) {
/* Small string */
len = (code & 0x1F);
read_string:
size = (len + sizeof(value)) / sizeof(value);
v = Val_hp(intern_ptr);
intern_obj_table[obj_counter++] = v;
*intern_ptr = Make_header(size, String_tag, intern_color);
intern_ptr += 1 + size;
Field(v, size - 1) = 0;
ofs_ind = Bsize_wsize(size) - 1;
Byte(v, ofs_ind) = ofs_ind - len;
really_getblock(chan, String_val(v), len);
} else {
switch(code) {
case CODE_INT8:
v = Val_long(input8s(chan));
break;
case CODE_INT16:
v = Val_long(input16s(chan));
break;
case CODE_INT32:
v = Val_long(input32s(chan));
break;
case CODE_INT64:
#ifdef SIXTYFOUR
v = Val_long(input64s(chan));
break;
#else
stat_free((char *) intern_obj_table);
Hd_val(intern_block) = intern_header; /* Don't confuse the GC */
failwith("input_value: integer too large");
break;
#endif
case CODE_SHARED8:
ofs = input8u(chan);
read_shared:
Assert(ofs > 0 && ofs <= obj_counter);
v = intern_obj_table[obj_counter - ofs];
break;
case CODE_SHARED16:
ofs = input16u(chan);
goto read_shared;
case CODE_SHARED32:
ofs = input32u(chan);
goto read_shared;
case CODE_BLOCK32:
header = (header_t) input32u(chan);
tag = Tag_hd(header);
size = Wosize_hd(header);
goto read_block;
case CODE_STRING8:
len = input8u(chan);
goto read_string;
case CODE_STRING32:
len = input32u(chan);
goto read_string;
case CODE_DOUBLE_LITTLE:
case CODE_DOUBLE_BIG:
if (sizeof(double) != 8) {
stat_free((char *) intern_obj_table);
Hd_val(intern_block) = intern_header; /* Don't confuse the GC */
invalid_argument("input_value: non-standard floats");
}
v = Val_hp(intern_ptr);
intern_obj_table[obj_counter++] = v;
*intern_ptr = Make_header(Double_wosize, Double_tag, intern_color);
intern_ptr += 1 + Double_wosize;
really_getblock(chan, (char *) v, 8);
if (code != CODE_DOUBLE_NATIVE) Reverse_double(v);
break;
}
}
}
*dest = v;
}
value input_value(chan) /* ML */
struct channel * chan;
{
uint32 magic;
mlsize_t num_objects, size_32, size_64, whsize;
value res;
magic = getword(chan);
if (magic != Compact_magic_number) failwith("input_value: bad object");
num_objects = getword(chan);
size_32 = getword(chan);
size_64 = getword(chan);
#ifdef SIXTYFOUR
whsize = size_64;
#else
whsize = size_32;
#endif
if (whsize == 0) {
read_compact(chan, &res);
} else {
if (Wosize_whsize(whsize) > Max_wosize)
failwith("intern: structure too big");
intern_block = alloc_shr(Wosize_whsize(whsize), String_tag);
intern_header = Hd_val(intern_block);
intern_color = Color_hd(intern_header);
Assert (intern_color == White || intern_color == Black);
intern_ptr = (header_t *) Hp_val(intern_block);
obj_counter = 0;
intern_obj_table = (value *) stat_alloc(num_objects * sizeof(value));
read_compact(chan, &res);
stat_free((char *) intern_obj_table);
}
return res;
}
|
