1 /* pvm-val.c - Values for the PVM. */
2
3 /* Copyright (C) 2019, 2020, 2021 Jose E. Marchesi */
4
5 /* This program is free software: you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation, either version 3 of the License, or
8 * (at your option) any later version.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this program. If not, see <http://www.gnu.org/licenses/>.
17 */
18
19 #include <config.h>
20 #include <stdlib.h>
21 #include <assert.h>
22 #include <string.h>
23 #include <inttypes.h>
24 #include "xalloc.h"
25
26 #include "pkt.h"
27 #include "pkl.h"
28 #include "pvm.h"
29 #include "pvm-program.h"
30 #include "pvm-val.h"
31 #include "pvm-alloc.h"
32 #include "pk-utils.h"
33
34 /* Unitary values that are always reused.
35
36 These values are created in pvm_val_initialize and disposed in
37 pvm_val_finalize. */
38
39 static pvm_val string_type;
40 static pvm_val void_type;
41 static pvm_val any_type;
42
43 pvm_val
pvm_make_int(int32_t value,int size)44 pvm_make_int (int32_t value, int size)
45 {
46 return PVM_MAKE_INT (value, size);
47 }
48
49 pvm_val
pvm_make_uint(uint32_t value,int size)50 pvm_make_uint (uint32_t value, int size)
51 {
52 return PVM_MAKE_UINT (value, size);
53 }
54
55 pvm_val
pvm_make_long(int64_t value,int size)56 pvm_make_long (int64_t value, int size)
57 {
58 return PVM_MAKE_LONG_ULONG (value, size, PVM_VAL_TAG_LONG);
59 }
60
61 pvm_val
pvm_make_ulong(uint64_t value,int size)62 pvm_make_ulong (uint64_t value, int size)
63 {
64 return PVM_MAKE_LONG_ULONG (value, size, PVM_VAL_TAG_ULONG);
65 }
66
67 static pvm_val_box
pvm_make_box(uint8_t tag)68 pvm_make_box (uint8_t tag)
69 {
70 pvm_val_box box = pvm_alloc (sizeof (struct pvm_val_box));
71
72 PVM_VAL_BOX_TAG (box) = tag;
73 return box;
74 }
75
76 pvm_val
pvm_make_string(const char * str)77 pvm_make_string (const char *str)
78 {
79 pvm_val_box box = pvm_make_box (PVM_VAL_TAG_STR);
80
81 PVM_VAL_BOX_STR (box) = pvm_alloc_strdup (str);
82 return PVM_BOX (box);
83 }
84
85 pvm_val
pvm_make_array(pvm_val nelem,pvm_val type)86 pvm_make_array (pvm_val nelem, pvm_val type)
87 {
88 pvm_val_box box = pvm_make_box (PVM_VAL_TAG_ARR);
89 pvm_array arr = pvm_alloc (sizeof (struct pvm_array));
90 size_t num_elems = PVM_VAL_ULONG (nelem);
91 size_t num_allocated = num_elems > 0 ? num_elems : 16;
92 size_t nbytes = (sizeof (struct pvm_array_elem) * num_allocated);
93 size_t i;
94
95 PVM_MAPINFO_MAPPED_P (arr->mapinfo) = 0;
96 PVM_MAPINFO_STRICT_P (arr->mapinfo) = 1;
97 PVM_MAPINFO_IOS (arr->mapinfo) = PVM_NULL;
98 PVM_MAPINFO_OFFSET (arr->mapinfo) = pvm_make_ulong (0, 64);
99
100 PVM_MAPINFO_MAPPED_P (arr->mapinfo_back) = 0;
101 PVM_MAPINFO_IOS (arr->mapinfo_back) = PVM_NULL;
102 PVM_MAPINFO_OFFSET (arr->mapinfo_back) = PVM_NULL;
103
104 arr->elems_bound = PVM_NULL;
105 arr->size_bound = PVM_NULL;
106 arr->mapper = PVM_NULL;
107 arr->writer = PVM_NULL;
108 arr->nelem = pvm_make_ulong (0, 64);
109 arr->nallocated = num_allocated;
110 arr->type = type;
111
112 arr->elems = pvm_alloc (nbytes);
113 for (i = 0; i < num_allocated; ++i)
114 {
115 arr->elems[i].offset = PVM_NULL;
116 arr->elems[i].value = PVM_NULL;
117 }
118
119 PVM_VAL_BOX_ARR (box) = arr;
120 return PVM_BOX (box);
121 }
122
123 int
pvm_array_insert(pvm_val arr,pvm_val idx,pvm_val val)124 pvm_array_insert (pvm_val arr, pvm_val idx, pvm_val val)
125 {
126 size_t index = PVM_VAL_ULONG (idx);
127 size_t nelem = PVM_VAL_ULONG (PVM_VAL_ARR_NELEM (arr));
128 size_t nallocated = PVM_VAL_ARR_NALLOCATED (arr);
129 size_t nelem_to_add = index - nelem + 1;
130 size_t val_size = pvm_sizeof (val);
131 size_t array_boffset = PVM_VAL_ULONG (PVM_VAL_ARR_OFFSET (arr));
132 size_t elem_boffset = array_boffset + pvm_sizeof (arr);
133 size_t i;
134
135 /* First of all, make sure that the given index doesn't correspond
136 to an existing element. If that is the case, return 0 now. */
137 if (index < nelem)
138 return 0;
139
140 /* We have a hard-limit in the number of elements to append, in
141 order to avoid malicious code or harmful bugs. */
142 if (nelem_to_add > 1024)
143 return 0;
144
145 /* Make sure there is enough room in the array for the new elements.
146 Otherwise, make space for the new elements, plus a buffer of 16
147 elements more. */
148 if ((nallocated - nelem) < nelem_to_add)
149 {
150 PVM_VAL_ARR_NALLOCATED (arr) += nelem_to_add + 16;
151 PVM_VAL_ARR_ELEMS (arr) = pvm_realloc (PVM_VAL_ARR_ELEMS (arr),
152 PVM_VAL_ARR_NALLOCATED (arr)
153 * sizeof (struct pvm_array_elem));
154
155 for (i = index + 1; i < PVM_VAL_ARR_NALLOCATED (arr); ++i)
156 {
157 PVM_VAL_ARR_ELEM_VALUE (arr, i) = PVM_NULL;
158 PVM_VAL_ARR_ELEM_OFFSET (arr, i) = PVM_NULL;
159 }
160 }
161
162 /* Initialize the new elements with the given value, also setting
163 their bit-offset. */
164 for (i = nelem; i <= PVM_VAL_ULONG (idx); ++i)
165 {
166 PVM_VAL_ARR_ELEM_VALUE (arr, i) = val;
167 PVM_VAL_ARR_ELEM_OFFSET (arr, i) = pvm_make_ulong (elem_boffset, 64);
168 elem_boffset += val_size;
169 }
170
171 /* Finally, adjust the number of elements. */
172 PVM_VAL_ARR_NELEM (arr)
173 = pvm_make_ulong (PVM_VAL_ULONG (PVM_VAL_ARR_NELEM (arr)) + nelem_to_add, 64);
174
175 return 1;
176 }
177
178 int
pvm_array_set(pvm_val arr,pvm_val idx,pvm_val val)179 pvm_array_set (pvm_val arr, pvm_val idx, pvm_val val)
180 {
181 size_t index = PVM_VAL_ULONG (idx);
182 size_t nelem = PVM_VAL_ULONG (PVM_VAL_ARR_NELEM (arr));
183 size_t elem_boffset;
184 size_t i;
185
186 /* Make sure that the given index is within bounds. */
187 if (index >= nelem)
188 return 0;
189
190 /* Update the element with the given value. */
191 PVM_VAL_ARR_ELEM_VALUE (arr, index) = val;
192
193 /* Recalculate the bit-offset of all the elemens following the
194 element just updated. */
195 elem_boffset
196 = (PVM_VAL_ULONG (PVM_VAL_ARR_ELEM_OFFSET (arr, index))
197 + pvm_sizeof (PVM_VAL_ARR_ELEM_VALUE (arr, index)));
198
199 for (i = index + 1; i < nelem; ++i)
200 {
201 PVM_VAL_ARR_ELEM_OFFSET (arr, i) = pvm_make_ulong (elem_boffset, 64);
202 elem_boffset += pvm_sizeof (PVM_VAL_ARR_ELEM_VALUE (arr, i));
203 }
204
205 return 1;
206 }
207
208 int
pvm_array_rem(pvm_val arr,pvm_val idx)209 pvm_array_rem (pvm_val arr, pvm_val idx)
210 {
211 size_t index = PVM_VAL_ULONG (idx);
212 size_t nelem = PVM_VAL_ULONG (PVM_VAL_ARR_NELEM (arr));
213 size_t i;
214
215 /* Make sure the given index is within bounds. */
216 if (index >= nelem)
217 return 0;
218
219 for (i = index; i < (nelem - 1); i++)
220 PVM_VAL_ARR_ELEM (arr,i) = PVM_VAL_ARR_ELEM (arr, i + 1);
221 PVM_VAL_ARR_NELEM (arr) = pvm_make_ulong (nelem - 1, 64);
222
223 return 1;
224 }
225
226 pvm_val
pvm_make_struct(pvm_val nfields,pvm_val nmethods,pvm_val type)227 pvm_make_struct (pvm_val nfields, pvm_val nmethods, pvm_val type)
228 {
229 pvm_val_box box = pvm_make_box (PVM_VAL_TAG_SCT);
230 pvm_struct sct = pvm_alloc (sizeof (struct pvm_struct));
231 size_t i;
232 size_t nfieldbytes
233 = sizeof (struct pvm_struct_field) * PVM_VAL_ULONG (nfields);
234 size_t nmethodbytes
235 = sizeof (struct pvm_struct_method) * PVM_VAL_ULONG (nmethods);
236
237
238 PVM_MAPINFO_MAPPED_P (sct->mapinfo) = 0;
239 PVM_MAPINFO_STRICT_P (sct->mapinfo) = 1;
240 PVM_MAPINFO_IOS (sct->mapinfo) = PVM_NULL;
241 PVM_MAPINFO_OFFSET (sct->mapinfo) = pvm_make_ulong (0, 64);
242
243 PVM_MAPINFO_MAPPED_P (sct->mapinfo_back) = 0;
244 PVM_MAPINFO_IOS (sct->mapinfo_back) = PVM_NULL;
245 PVM_MAPINFO_OFFSET (sct->mapinfo_back) = PVM_NULL;
246
247 sct->mapper = PVM_NULL;
248 sct->writer = PVM_NULL;
249 sct->type = type;
250
251 sct->nfields = nfields;
252 sct->fields = pvm_alloc (nfieldbytes);
253 memset (sct->fields, 0, nfieldbytes);
254
255 sct->nmethods = nmethods;
256 sct->methods = pvm_alloc (nmethodbytes);
257 memset (sct->methods, 0, nmethodbytes);
258
259 for (i = 0; i < PVM_VAL_ULONG (sct->nfields); ++i)
260 {
261 sct->fields[i].offset = PVM_NULL;
262 sct->fields[i].name = PVM_NULL;
263 sct->fields[i].value = PVM_NULL;
264 sct->fields[i].modified = PVM_MAKE_INT (0, 32);
265 sct->fields[i].modified_back = PVM_NULL;
266 sct->fields[i].offset_back = PVM_NULL;
267 }
268
269 for (i = 0; i < PVM_VAL_ULONG (sct->nmethods); ++i)
270 {
271 sct->methods[i].name = PVM_NULL;
272 sct->methods[i].value = PVM_NULL;
273 }
274
275 PVM_VAL_BOX_SCT (box) = sct;
276 return PVM_BOX (box);
277 }
278
279 pvm_val
pvm_ref_struct_cstr(pvm_val sct,const char * name)280 pvm_ref_struct_cstr (pvm_val sct, const char *name)
281 {
282 size_t nfields, nmethods, i;
283 struct pvm_struct_field *fields;
284 struct pvm_struct_method *methods;
285
286 assert (PVM_IS_SCT (sct));
287
288 /* Lookup fields. */
289 nfields = PVM_VAL_ULONG (PVM_VAL_SCT_NFIELDS (sct));
290 fields = PVM_VAL_SCT (sct)->fields;
291
292 for (i = 0; i < nfields; ++i)
293 {
294 if (!PVM_VAL_SCT_FIELD_ABSENT_P (sct, i)
295 && fields[i].name != PVM_NULL
296 && STREQ (PVM_VAL_STR (fields[i].name),
297 name))
298 return fields[i].value;
299 }
300
301 /* Lookup methods. */
302 nmethods = PVM_VAL_ULONG (PVM_VAL_SCT_NMETHODS (sct));
303 methods = PVM_VAL_SCT (sct)->methods;
304
305 for (i = 0; i < nmethods; ++i)
306 {
307 if (STREQ (PVM_VAL_STR (methods[i].name),
308 name))
309 return methods[i].value;
310 }
311
312 return PVM_NULL;
313 }
314
315 pvm_val
pvm_ref_struct(pvm_val sct,pvm_val name)316 pvm_ref_struct (pvm_val sct, pvm_val name)
317 {
318 assert (PVM_IS_STR (name));
319 return pvm_ref_struct_cstr (sct, PVM_VAL_STR (name));
320 }
321
322 pvm_val
pvm_refo_struct(pvm_val sct,pvm_val name)323 pvm_refo_struct (pvm_val sct, pvm_val name)
324 {
325 size_t nfields, i;
326 struct pvm_struct_field *fields;
327
328 assert (PVM_IS_SCT (sct) && PVM_IS_STR (name));
329
330 nfields = PVM_VAL_ULONG (PVM_VAL_SCT_NFIELDS (sct));
331 fields = PVM_VAL_SCT (sct)->fields;
332
333 for (i = 0; i < nfields; ++i)
334 {
335 if (!PVM_VAL_SCT_FIELD_ABSENT_P (sct, i)
336 && fields[i].name != PVM_NULL
337 && STREQ (PVM_VAL_STR (fields[i].name),
338 PVM_VAL_STR (name)))
339 return fields[i].offset;
340 }
341
342 return PVM_NULL;
343 }
344
345 int
pvm_set_struct(pvm_val sct,pvm_val name,pvm_val val)346 pvm_set_struct (pvm_val sct, pvm_val name, pvm_val val)
347 {
348 size_t nfields, i;
349 struct pvm_struct_field *fields;
350
351 assert (PVM_IS_SCT (sct) && PVM_IS_STR (name));
352
353 nfields = PVM_VAL_ULONG (PVM_VAL_SCT_NFIELDS (sct));
354 fields = PVM_VAL_SCT (sct)->fields;
355
356 for (i = 0; i < nfields; ++i)
357 {
358 if (fields[i].name != PVM_NULL
359 && STREQ (PVM_VAL_STR (fields[i].name),
360 PVM_VAL_STR (name)))
361 {
362 PVM_VAL_SCT_FIELD_VALUE (sct,i) = val;
363 PVM_VAL_SCT_FIELD_MODIFIED (sct,i) =
364 PVM_MAKE_INT (1, 32);
365 return 1;
366 }
367 }
368
369 return 0;
370 }
371
372 pvm_val
pvm_get_struct_method(pvm_val sct,const char * name)373 pvm_get_struct_method (pvm_val sct, const char *name)
374 {
375 size_t i, nmethods = PVM_VAL_ULONG (PVM_VAL_SCT_NMETHODS (sct));
376 struct pvm_struct_method *methods = PVM_VAL_SCT (sct)->methods;
377
378 for (i = 0; i < nmethods; ++i)
379 {
380 if (STREQ (PVM_VAL_STR (methods[i].name), name))
381 return methods[i].value;
382 }
383
384 return PVM_NULL;
385 }
386
387 static pvm_val
pvm_make_type(enum pvm_type_code code)388 pvm_make_type (enum pvm_type_code code)
389 {
390 pvm_val_box box = pvm_make_box (PVM_VAL_TAG_TYP);
391 pvm_type type = pvm_alloc (sizeof (struct pvm_type));
392
393 memset (type, 0, sizeof (struct pvm_type));
394 type->code = code;
395
396 PVM_VAL_BOX_TYP (box) = type;
397 return PVM_BOX (box);
398 }
399
400 pvm_val
pvm_make_integral_type(pvm_val size,pvm_val signed_p)401 pvm_make_integral_type (pvm_val size, pvm_val signed_p)
402 {
403 pvm_val itype = pvm_make_type (PVM_TYPE_INTEGRAL);
404
405 PVM_VAL_TYP_I_SIZE (itype) = size;
406 PVM_VAL_TYP_I_SIGNED_P (itype) = signed_p;
407 return itype;
408 }
409
410 pvm_val
pvm_make_string_type(void)411 pvm_make_string_type (void)
412 {
413 return string_type;
414 }
415
416 pvm_val
pvm_make_void_type(void)417 pvm_make_void_type (void)
418 {
419 return void_type;
420 }
421
422 pvm_val
pvm_make_any_type(void)423 pvm_make_any_type (void)
424 {
425 return any_type;
426 }
427
428 pvm_val
pvm_make_offset_type(pvm_val base_type,pvm_val unit)429 pvm_make_offset_type (pvm_val base_type, pvm_val unit)
430 {
431 pvm_val otype = pvm_make_type (PVM_TYPE_OFFSET);
432
433 PVM_VAL_TYP_O_BASE_TYPE (otype) = base_type;
434 PVM_VAL_TYP_O_UNIT (otype) = unit;
435 return otype;
436 }
437
438 pvm_val
pvm_make_array_type(pvm_val type,pvm_val bound)439 pvm_make_array_type (pvm_val type, pvm_val bound)
440 {
441 pvm_val atype = pvm_make_type (PVM_TYPE_ARRAY);
442
443 PVM_VAL_TYP_A_ETYPE (atype) = type;
444 PVM_VAL_TYP_A_BOUND (atype) = bound;
445 return atype;
446 }
447
448 pvm_val
pvm_make_struct_type(pvm_val nfields,pvm_val name,pvm_val * fnames,pvm_val * ftypes)449 pvm_make_struct_type (pvm_val nfields, pvm_val name,
450 pvm_val *fnames, pvm_val *ftypes)
451 {
452 pvm_val stype = pvm_make_type (PVM_TYPE_STRUCT);
453
454 PVM_VAL_TYP_S_NAME (stype) = name;
455 PVM_VAL_TYP_S_NFIELDS (stype) = nfields;
456 PVM_VAL_TYP_S_FNAMES (stype) = fnames;
457 PVM_VAL_TYP_S_FTYPES (stype) = ftypes;
458
459 return stype;
460 }
461
462 pvm_val
pvm_make_closure_type(pvm_val rtype,pvm_val nargs,pvm_val * atypes)463 pvm_make_closure_type (pvm_val rtype,
464 pvm_val nargs, pvm_val *atypes)
465 {
466 pvm_val ctype = pvm_make_type (PVM_TYPE_CLOSURE);
467
468 PVM_VAL_TYP_C_RETURN_TYPE (ctype) = rtype;
469 PVM_VAL_TYP_C_NARGS (ctype) = nargs;
470 PVM_VAL_TYP_C_ATYPES (ctype) = atypes;
471
472 return ctype;
473 }
474
475 pvm_val
pvm_make_cls(pvm_program program)476 pvm_make_cls (pvm_program program)
477 {
478 pvm_val_box box = pvm_make_box (PVM_VAL_TAG_CLS);
479 pvm_cls cls = pvm_alloc_cls ();
480
481 cls->program = program;
482 cls->entry_point = pvm_program_beginning (program);
483 cls->env = NULL; /* This should be set by a PEC instruction before
484 using the closure. */
485
486 PVM_VAL_BOX_CLS (box) = cls;
487 return PVM_BOX (box);
488 }
489
490 pvm_val
pvm_make_offset(pvm_val magnitude,pvm_val unit)491 pvm_make_offset (pvm_val magnitude, pvm_val unit)
492 {
493 pvm_val_box box = pvm_make_box (PVM_VAL_TAG_OFF);
494 pvm_off off = pvm_alloc (sizeof (struct pvm_off));
495
496 off->base_type = pvm_typeof (magnitude);
497 off->magnitude = magnitude;
498 off->unit = unit;
499
500 PVM_VAL_BOX_OFF (box) = off;
501 return PVM_BOX (box);
502 }
503
504 int
pvm_val_equal_p(pvm_val val1,pvm_val val2)505 pvm_val_equal_p (pvm_val val1, pvm_val val2)
506 {
507 if (val1 == PVM_NULL && val2 == PVM_NULL)
508 return 1;
509 else if (PVM_IS_INT (val1) && PVM_IS_INT (val2))
510 return (PVM_VAL_INT_SIZE (val1) == PVM_VAL_INT_SIZE (val2))
511 && (PVM_VAL_INT (val1) == PVM_VAL_INT (val2));
512 else if (PVM_IS_UINT (val1) && PVM_IS_UINT (val2))
513 return (PVM_VAL_UINT_SIZE (val1) == PVM_VAL_UINT_SIZE (val2))
514 && (PVM_VAL_UINT (val1) == PVM_VAL_UINT (val2));
515 else if (PVM_IS_LONG (val1) && PVM_IS_LONG (val2))
516 return (PVM_VAL_LONG_SIZE (val1) && PVM_VAL_LONG_SIZE (val2))
517 && (PVM_VAL_LONG (val1) == PVM_VAL_LONG (val2));
518 else if (PVM_IS_ULONG (val1) && PVM_IS_ULONG (val2))
519 return (PVM_VAL_ULONG_SIZE (val1) == PVM_VAL_ULONG_SIZE (val2))
520 && (PVM_VAL_ULONG (val1) == PVM_VAL_ULONG (val2));
521 else if (PVM_IS_STR (val1) && PVM_IS_STR (val2))
522 return STREQ (PVM_VAL_STR (val1), PVM_VAL_STR (val2));
523 else if (PVM_IS_OFF (val1) && PVM_IS_OFF (val2))
524 {
525 int pvm_off_mag_equal, pvm_off_unit_equal;
526
527 pvm_off_mag_equal = pvm_val_equal_p (PVM_VAL_OFF_MAGNITUDE (val1),
528 PVM_VAL_OFF_MAGNITUDE (val2));
529 pvm_off_unit_equal = pvm_val_equal_p (PVM_VAL_OFF_UNIT (val1),
530 PVM_VAL_OFF_UNIT (val2));
531
532 return pvm_off_mag_equal && pvm_off_unit_equal;
533 }
534 else if (PVM_IS_SCT (val1) && PVM_IS_SCT (val2))
535 {
536 size_t pvm_sct1_nfields = PVM_VAL_ULONG (PVM_VAL_SCT_NFIELDS (val1));
537 size_t pvm_sct2_nfields = PVM_VAL_ULONG (PVM_VAL_SCT_NFIELDS (val2));
538 size_t pvm_sct1_nmethods = PVM_VAL_ULONG (PVM_VAL_SCT_NMETHODS (val1));
539 size_t pvm_sct2_nmethods = PVM_VAL_ULONG (PVM_VAL_SCT_NMETHODS (val2));
540
541 if ((pvm_sct1_nfields != pvm_sct2_nfields)
542 || (pvm_sct1_nmethods != pvm_sct2_nmethods))
543 return 0;
544
545 if (!pvm_val_equal_p (PVM_VAL_SCT_IOS (val1), PVM_VAL_SCT_IOS (val2)))
546 return 0;
547
548 if (!pvm_val_equal_p (PVM_VAL_SCT_TYPE (val1), PVM_VAL_SCT_TYPE (val2)))
549 return 0;
550
551 if (!pvm_val_equal_p (PVM_VAL_SCT_OFFSET (val1),
552 PVM_VAL_SCT_OFFSET (val2)))
553 return 0;
554
555 for (size_t i = 0 ; i < pvm_sct1_nfields ; i++)
556 {
557 if (PVM_VAL_SCT_FIELD_ABSENT_P (val1, i)
558 != PVM_VAL_SCT_FIELD_ABSENT_P (val2, i))
559 return 0;
560
561 if (!PVM_VAL_SCT_FIELD_ABSENT_P (val1, i))
562 {
563 if (!pvm_val_equal_p (PVM_VAL_SCT_FIELD_NAME (val1, i),
564 PVM_VAL_SCT_FIELD_NAME (val2, i)))
565 return 0;
566
567 if (!pvm_val_equal_p (PVM_VAL_SCT_FIELD_VALUE (val1, i),
568 PVM_VAL_SCT_FIELD_VALUE (val2, i)))
569 return 0;
570
571 if (!pvm_val_equal_p (PVM_VAL_SCT_FIELD_OFFSET (val1, i),
572 PVM_VAL_SCT_FIELD_OFFSET (val2, i)))
573 return 0;
574 }
575 }
576
577 for (size_t i = 0 ; i < pvm_sct1_nmethods ; i++)
578 {
579 if (!pvm_val_equal_p (PVM_VAL_SCT_METHOD_NAME (val1, i),
580 PVM_VAL_SCT_METHOD_NAME (val2, i)))
581 return 0;
582 }
583
584 return 1;
585 }
586 else if (PVM_IS_ARR (val1) && PVM_IS_ARR (val2))
587 {
588 size_t pvm_arr1_nelems = PVM_VAL_ULONG (PVM_VAL_ARR_NELEM (val1));
589 size_t pvm_arr2_nelems = PVM_VAL_ULONG (PVM_VAL_ARR_NELEM (val2));
590
591 if (pvm_arr1_nelems != pvm_arr2_nelems)
592 return 0;
593
594 if (!pvm_val_equal_p (PVM_VAL_ARR_TYPE (val1), PVM_VAL_ARR_TYPE (val2)))
595 return 0;
596
597 if (!pvm_val_equal_p (PVM_VAL_ARR_IOS (val1), PVM_VAL_ARR_IOS (val2)))
598 return 0;
599
600 if (!pvm_val_equal_p (PVM_VAL_ARR_OFFSET (val1),
601 PVM_VAL_ARR_OFFSET (val2)))
602 return 0;
603
604 if (!pvm_val_equal_p (PVM_VAL_ARR_ELEMS_BOUND (val1),
605 PVM_VAL_ARR_ELEMS_BOUND (val2)))
606 return 0;
607
608 if (!pvm_val_equal_p (PVM_VAL_ARR_SIZE_BOUND (val1),
609 PVM_VAL_ARR_SIZE_BOUND (val2)))
610 return 0;
611
612 for (size_t i = 0 ; i < pvm_arr1_nelems ; i++)
613 {
614 if (!pvm_val_equal_p (PVM_VAL_ARR_ELEM_VALUE (val1, i),
615 PVM_VAL_ARR_ELEM_VALUE (val2, i)))
616 return 0;
617
618 if (!pvm_val_equal_p (PVM_VAL_ARR_ELEM_OFFSET (val1, i),
619 PVM_VAL_ARR_ELEM_OFFSET (val2, i)))
620 return 0;
621 }
622
623 return 1;
624 }
625 else if (PVM_IS_TYP (val1) && PVM_IS_TYP (val2))
626 return pvm_type_equal_p (val1, val2);
627 else
628 return 0;
629 }
630
631 void
pvm_allocate_struct_attrs(pvm_val nfields,pvm_val ** fnames,pvm_val ** ftypes)632 pvm_allocate_struct_attrs (pvm_val nfields,
633 pvm_val **fnames, pvm_val **ftypes)
634 {
635 size_t nbytes = sizeof (pvm_val) * PVM_VAL_ULONG (nfields) * 2;
636 *fnames = pvm_alloc (nbytes);
637 *ftypes = pvm_alloc (nbytes);
638 }
639
640 void
pvm_allocate_closure_attrs(pvm_val nargs,pvm_val ** atypes)641 pvm_allocate_closure_attrs (pvm_val nargs, pvm_val **atypes)
642 {
643 size_t nbytes = sizeof (pvm_val) * PVM_VAL_ULONG (nargs);
644 *atypes = pvm_alloc (nbytes);
645 }
646
647 pvm_val
pvm_elemsof(pvm_val val)648 pvm_elemsof (pvm_val val)
649 {
650 if (PVM_IS_ARR (val))
651 return PVM_VAL_ARR_NELEM (val);
652 else if (PVM_IS_SCT (val))
653 {
654 size_t nfields;
655 size_t i, present_fields = 0;
656
657 nfields = PVM_VAL_ULONG (PVM_VAL_SCT_NFIELDS (val));
658 for (i = 0; i < nfields; ++i)
659 {
660 if (!PVM_VAL_SCT_FIELD_ABSENT_P (val, i))
661 present_fields++;
662 }
663
664 return pvm_make_ulong (present_fields, 64);
665 }
666 else if (PVM_IS_STR (val))
667 return pvm_make_ulong (strlen (PVM_VAL_STR (val)), 64);
668 else
669 return pvm_make_ulong (1, 64);
670 }
671
672 pvm_val
pvm_val_mapper(pvm_val val)673 pvm_val_mapper (pvm_val val)
674 {
675 if (PVM_IS_ARR (val))
676 return PVM_VAL_ARR_MAPPER (val);
677 if (PVM_IS_SCT (val))
678 return PVM_VAL_SCT_MAPPER (val);
679
680 return PVM_NULL;
681 }
682
683 pvm_val
pvm_val_writer(pvm_val val)684 pvm_val_writer (pvm_val val)
685 {
686 if (PVM_IS_ARR (val))
687 return PVM_VAL_ARR_WRITER (val);
688 if (PVM_IS_SCT (val))
689 return PVM_VAL_SCT_WRITER (val);
690
691 return PVM_NULL;
692 }
693
694 void
pvm_val_unmap(pvm_val val)695 pvm_val_unmap (pvm_val val)
696 {
697 PVM_VAL_SET_MAPPED_P (val, 0);
698
699 if (PVM_IS_ARR (val))
700 {
701 size_t nelem, i;
702
703 nelem = PVM_VAL_ULONG (PVM_VAL_ARR_NELEM (val));
704 for (i = 0; i < nelem; ++i)
705 pvm_val_unmap (PVM_VAL_ARR_ELEM_VALUE (val, i));
706 }
707 else if (PVM_IS_SCT (val))
708 {
709 size_t nfields, i;
710
711 nfields = PVM_VAL_ULONG (PVM_VAL_SCT_NFIELDS (val));
712 for (i = 0; i < nfields; ++i)
713 pvm_val_unmap (PVM_VAL_SCT_FIELD_VALUE (val, i));
714 }
715 }
716
717 void
pvm_val_reloc(pvm_val val,pvm_val ios,pvm_val boffset)718 pvm_val_reloc (pvm_val val, pvm_val ios, pvm_val boffset)
719 {
720 uint64_t boff = PVM_VAL_ULONG (boffset);
721
722 if (PVM_IS_ARR (val))
723 {
724 size_t nelem, i;
725 uint64_t array_offset = PVM_VAL_ULONG (PVM_VAL_ARR_OFFSET (val));
726
727 nelem = PVM_VAL_ULONG (PVM_VAL_ARR_NELEM (val));
728 for (i = 0; i < nelem; ++i)
729 {
730 pvm_val elem_value = PVM_VAL_ARR_ELEM_VALUE (val, i);
731 pvm_val elem_offset = PVM_VAL_ARR_ELEM_OFFSET (val, i);
732 uint64_t elem_new_offset
733 = boff + (PVM_VAL_ULONG (PVM_VAL_ARR_ELEM_OFFSET (val, i))
734 - array_offset);
735
736 PVM_VAL_ARR_ELEM_OFFSET_BACK (val, i) = elem_offset;
737 PVM_VAL_ARR_ELEM_OFFSET (val, i)
738 = pvm_make_ulong (elem_new_offset, 64);
739
740 pvm_val_reloc (elem_value, ios,
741 pvm_make_ulong (elem_new_offset, 64));
742 }
743
744 PVM_VAL_ARR_MAPINFO_BACK (val) = PVM_VAL_ARR_MAPINFO (val);
745
746 PVM_VAL_ARR_MAPPED_P (val) = 1;
747 PVM_VAL_ARR_IOS (val) = ios;
748 PVM_VAL_ARR_OFFSET (val) = pvm_make_ulong (boff, 64);
749 }
750 else if (PVM_IS_SCT (val))
751 {
752 size_t nfields, i;
753 uint64_t struct_offset = PVM_VAL_ULONG (PVM_VAL_SCT_OFFSET (val));
754
755 nfields = PVM_VAL_ULONG (PVM_VAL_SCT_NFIELDS (val));
756 for (i = 0; i < nfields; ++i)
757 {
758 pvm_val field_value = PVM_VAL_SCT_FIELD_VALUE (val, i);
759 pvm_val field_offset = PVM_VAL_SCT_FIELD_OFFSET (val, i);
760 uint64_t field_new_offset
761 = boff + (PVM_VAL_ULONG (PVM_VAL_SCT_FIELD_OFFSET (val, i))
762 - struct_offset);
763
764 /* Do not relocate absent fields. */
765 if (PVM_VAL_SCT_FIELD_ABSENT_P (val, i))
766 continue;
767
768 PVM_VAL_SCT_FIELD_OFFSET_BACK (val, i)
769 = field_offset;
770 PVM_VAL_SCT_FIELD_OFFSET (val, i)
771 = pvm_make_ulong (field_new_offset, 64);
772 PVM_VAL_SCT_FIELD_MODIFIED_BACK (val, i)
773 = PVM_VAL_SCT_FIELD_MODIFIED (val, i);
774 PVM_VAL_SCT_FIELD_MODIFIED (val, i) =
775 PVM_MAKE_INT (1, 32);
776
777 pvm_val_reloc (field_value, ios,
778 pvm_make_ulong (field_new_offset, 64));
779 }
780
781 PVM_VAL_SCT_MAPINFO_BACK (val) = PVM_VAL_SCT_MAPINFO (val);
782
783 PVM_VAL_SCT_MAPPED_P (val) = 1;
784 PVM_VAL_SCT_IOS (val) = ios;
785 PVM_VAL_SCT_OFFSET (val) = pvm_make_ulong (boff, 64);
786 }
787 }
788
789 void
pvm_val_ureloc(pvm_val val)790 pvm_val_ureloc (pvm_val val)
791 {
792 if (PVM_IS_ARR (val))
793 {
794 size_t nelem, i;
795
796 nelem = PVM_VAL_ULONG (PVM_VAL_ARR_NELEM (val));
797 for (i = 0; i < nelem; ++i)
798 {
799 pvm_val elem_value = PVM_VAL_ARR_ELEM_VALUE (val, i);
800
801 PVM_VAL_ARR_ELEM_OFFSET (val, i) = PVM_VAL_ARR_ELEM_OFFSET_BACK (val, i);
802 pvm_val_ureloc (elem_value);
803 }
804
805 PVM_VAL_ARR_MAPINFO (val) = PVM_VAL_ARR_MAPINFO_BACK (val);
806 }
807 else if (PVM_IS_SCT (val))
808 {
809 size_t nfields, i;
810
811 nfields = PVM_VAL_ULONG (PVM_VAL_SCT_NFIELDS (val));
812 for (i = 0; i < nfields; ++i)
813 {
814 pvm_val field_value = PVM_VAL_SCT_FIELD_VALUE (val, i);
815
816 PVM_VAL_SCT_FIELD_OFFSET (val, i)
817 = PVM_VAL_SCT_FIELD_OFFSET_BACK (val, i);
818 PVM_VAL_SCT_FIELD_MODIFIED (val, i)
819 = PVM_VAL_SCT_FIELD_MODIFIED_BACK (val, i);
820
821 pvm_val_ureloc (field_value);
822 }
823
824 PVM_VAL_ARR_MAPINFO (val) = PVM_VAL_ARR_MAPINFO_BACK (val);
825 }
826 }
827
828 uint64_t
pvm_sizeof(pvm_val val)829 pvm_sizeof (pvm_val val)
830 {
831 if (PVM_IS_INT (val))
832 return PVM_VAL_INT_SIZE (val);
833 else if (PVM_IS_UINT (val))
834 return PVM_VAL_UINT_SIZE (val);
835 else if (PVM_IS_LONG (val))
836 return PVM_VAL_LONG_SIZE (val);
837 else if (PVM_IS_ULONG (val))
838 return PVM_VAL_ULONG_SIZE (val);
839 else if (PVM_IS_STR (val))
840 return (strlen (PVM_VAL_STR (val)) + 1) * 8;
841 else if (PVM_IS_ARR (val))
842 {
843 size_t nelem, i;
844 size_t size = 0;
845
846 nelem = PVM_VAL_ULONG (PVM_VAL_ARR_NELEM (val));
847 for (i = 0; i < nelem; ++i)
848 size += pvm_sizeof (PVM_VAL_ARR_ELEM_VALUE (val, i));
849
850 return size;
851 }
852 else if (PVM_IS_SCT (val))
853 {
854 pvm_val sct_offset = PVM_VAL_SCT_OFFSET (val);
855 size_t nfields, i, size, sct_offset_bits;
856
857 if (sct_offset == PVM_NULL)
858 sct_offset_bits = 0;
859 else
860 sct_offset_bits = PVM_VAL_ULONG (sct_offset);
861
862 nfields = PVM_VAL_ULONG (PVM_VAL_SCT_NFIELDS (val));
863
864 size = 0;
865 for (i = 0; i < nfields; ++i)
866 {
867 pvm_val elem_value = PVM_VAL_SCT_FIELD_VALUE (val, i);
868 pvm_val elem_offset = PVM_VAL_SCT_FIELD_OFFSET (val, i);
869
870 if (! PVM_VAL_SCT_FIELD_ABSENT_P (val, i))
871 {
872 uint64_t elem_size_bits = pvm_sizeof (elem_value);
873
874 if (elem_offset == PVM_NULL)
875 size += elem_size_bits;
876 else
877 {
878 uint64_t elem_offset_bits = PVM_VAL_ULONG (elem_offset);
879
880 #define MAX(A,B) ((A) > (B) ? (A) : (B))
881 size = MAX (size, elem_offset_bits - sct_offset_bits + elem_size_bits);
882 }
883 }
884 }
885
886 return size;
887 }
888 else if (PVM_IS_OFF (val))
889 return pvm_sizeof (PVM_VAL_OFF_MAGNITUDE (val));
890 else if (PVM_IS_TYP (val))
891 /* By convention, type values have size zero. */
892 return 0;
893 else if (PVM_IS_CLS (val))
894 /* By convention, closure values have size zero. */
895 return 0;
896
897 assert (0);
898 return 0;
899 }
900
901 static void
print_unit_name(uint64_t unit)902 print_unit_name (uint64_t unit)
903 {
904 switch (unit)
905 {
906 case PVM_VAL_OFF_UNIT_BITS:
907 pk_puts ("b");
908 break;
909 case PVM_VAL_OFF_UNIT_NIBBLES:
910 pk_puts ("N");
911 break;
912 case PVM_VAL_OFF_UNIT_BYTES:
913 pk_puts ("B");
914 break;
915 case PVM_VAL_OFF_UNIT_KILOBITS:
916 pk_puts ("Kb");
917 break;
918 case PVM_VAL_OFF_UNIT_KILOBYTES:
919 pk_puts ("KB");
920 break;
921 case PVM_VAL_OFF_UNIT_MEGABITS:
922 pk_puts ("Mb");
923 break;
924 case PVM_VAL_OFF_UNIT_MEGABYTES:
925 pk_puts ("MB");
926 break;
927 case PVM_VAL_OFF_UNIT_GIGABITS:
928 pk_puts ("Gb");
929 break;
930 case PVM_VAL_OFF_UNIT_GIGABYTES:
931 pk_puts ("GB");
932 break;
933 case PVM_VAL_OFF_UNIT_KIBIBITS:
934 pk_puts ("Kib");
935 break;
936 case PVM_VAL_OFF_UNIT_KIBIBYTES:
937 pk_puts ("KiB");
938 break;
939 case PVM_VAL_OFF_UNIT_MEBIBITS:
940 pk_puts ("Mib");
941 break;
942 case PVM_VAL_OFF_UNIT_MEBIBYTES:
943 pk_puts ("MiB");
944 break;
945 case PVM_VAL_OFF_UNIT_GIGIBITS:
946 pk_puts ("Gib");
947 break;
948 case PVM_VAL_OFF_UNIT_GIGIBYTES:
949 pk_puts ("GiB");
950 break;
951 default:
952 /* XXX: print here the name of the base type of the
953 offset. */
954 pk_printf ("%" PRIu64, unit);
955 }
956 }
957
958 #define PVM_PRINT_VAL_1(...) \
959 pvm_print_val_1 (vm, depth, mode, base, indent, acutoff, flags, __VA_ARGS__)
960
961 static void
pvm_print_val_1(pvm vm,int depth,int mode,int base,int indent,int acutoff,uint32_t flags,pvm_val val,int ndepth)962 pvm_print_val_1 (pvm vm, int depth, int mode, int base, int indent,
963 int acutoff, uint32_t flags,
964 pvm_val val, int ndepth)
965 {
966 const char *long64_fmt, *long_fmt;
967 const char *ulong64_fmt, *ulong_fmt;
968 const char *int32_fmt, *int16_fmt, *int8_fmt, *int4_fmt, *int_fmt;
969 const char *uint32_fmt, *uint16_fmt, *uint8_fmt, *uint4_fmt, *uint_fmt;
970
971 /* Extract configuration settings from FLAGS. */
972 int maps = flags & PVM_PRINT_F_MAPS;
973 int pprint = flags & PVM_PRINT_F_PPRINT;
974
975 /* Select the appropriate formatting templates for the given
976 base. */
977 switch (base)
978 {
979 case 8:
980 long64_fmt = "0o%" PRIo64 "L";
981 long_fmt = "(int<%d>) 0o%" PRIo64;
982 ulong64_fmt = "0o%" PRIo64 "UL";
983 ulong_fmt = "(uint<%d>) 0o%" PRIo64;
984 int32_fmt = "0o%" PRIo32;
985 int16_fmt = "0o%" PRIo32 "H";
986 int8_fmt = "0o%" PRIo32 "B";
987 int4_fmt = "0o%" PRIo32 "N";
988 int_fmt = "(int<%d>) 0o%" PRIo32;
989 uint32_fmt = "0o%" PRIo32 "U";
990 uint16_fmt = "0o%" PRIo32 "UH";
991 uint8_fmt = "0o%" PRIo32 "UB";
992 uint4_fmt = "0o%" PRIo32 "UN";
993 uint_fmt = "(uint<%d>) 0o%" PRIo32;
994 break;
995 case 10:
996 long64_fmt = "%" PRIi64 "L";
997 long_fmt = "(int<%d>) %" PRIi64;
998 ulong64_fmt = "%" PRIu64 "UL";
999 ulong_fmt = "(uint<%d>) %" PRIu64;
1000 int32_fmt = "%" PRIi32;
1001 int16_fmt = "%" PRIi32 "H";
1002 int8_fmt = "%" PRIi32 "B";
1003 int4_fmt = "%" PRIi32 "N";
1004 int_fmt = "(int<%d>) %" PRIi32;
1005 uint32_fmt = "%" PRIu32 "U";
1006 uint16_fmt = "%" PRIu32 "UH";
1007 uint8_fmt = "%" PRIu32 "UB";
1008 uint4_fmt = "%" PRIu32 "UN";
1009 uint_fmt = "(uint<%d>) %" PRIu32;
1010 break;
1011 case 16:
1012 long64_fmt = "0x%" PRIx64 "L";
1013 long_fmt = "(int<%d>) %" PRIx64;
1014 ulong64_fmt = "0x%" PRIx64 "UL";
1015 ulong_fmt = "(uint<%d>) %" PRIx64;
1016 int32_fmt = "0x%" PRIx32;
1017 int16_fmt = "0x%" PRIx32 "H";
1018 int8_fmt = "0x%" PRIx32 "B";
1019 int4_fmt = "0x%" PRIx32 "N";
1020 int_fmt = "(int<%d>) 0x%" PRIx32;
1021 uint32_fmt = "0x%" PRIx32 "U";
1022 uint16_fmt = "0x%" PRIx32 "UH";
1023 uint8_fmt = "0x%" PRIx32 "UB";
1024 uint4_fmt = "0x%" PRIx32 "UN";
1025 uint_fmt = "(uint<%d>) 0x%" PRIx32;
1026 break;
1027 case 2:
1028 /* This base doesn't use printf's formatting strings, but its
1029 own printer. */
1030 long64_fmt = "";
1031 long_fmt = "";
1032 ulong64_fmt = "";
1033 ulong_fmt = "";
1034 int32_fmt = "";
1035 int16_fmt = "";
1036 int8_fmt = "";
1037 int4_fmt = "";
1038 int_fmt = "";
1039 uint32_fmt = "";
1040 uint16_fmt = "";
1041 uint8_fmt = "";
1042 uint4_fmt = "";
1043 uint_fmt = "";
1044 break;
1045 default:
1046 assert (0);
1047 break;
1048 }
1049
1050 /* And print out the value in the given stream.. */
1051 if (val == PVM_NULL)
1052 pk_puts ("null");
1053 else if (PVM_IS_LONG (val))
1054 {
1055 int size = PVM_VAL_LONG_SIZE (val);
1056 int64_t longval = PVM_VAL_LONG (val);
1057 uint64_t ulongval;
1058
1059 pk_term_class ("integer");
1060
1061 if (size == 64)
1062 ulongval = (uint64_t) longval;
1063 else
1064 ulongval = (uint64_t) longval & ((((uint64_t) 1) << size) - 1);
1065
1066 if (base == 2)
1067 {
1068 pk_puts ("0b");
1069 pk_print_binary (pk_puts, ulongval, size, 1);
1070 }
1071 else
1072 {
1073 if (size == 64)
1074 pk_printf (long64_fmt, base == 10 ? longval : ulongval);
1075 else
1076 pk_printf (long_fmt, PVM_VAL_LONG_SIZE (val),
1077 base == 10 ? longval : ulongval);
1078 }
1079
1080 pk_term_end_class ("integer");
1081 }
1082 else if (PVM_IS_INT (val))
1083 {
1084 int size = PVM_VAL_INT_SIZE (val);
1085 int32_t intval = PVM_VAL_INT (val);
1086 uint32_t uintval;
1087
1088 pk_term_class ("integer");
1089
1090 if (size == 32)
1091 uintval = (uint32_t) intval;
1092 else
1093 uintval = (uint32_t) intval & ((((uint32_t) 1) << size) - 1);
1094
1095 if (base == 2)
1096 {
1097 pk_puts ("0b");
1098 pk_print_binary (pk_puts, (uint64_t) uintval, size, 1);
1099 }
1100 else
1101 {
1102 if (size == 32)
1103 pk_printf (int32_fmt, base == 10 ? intval : uintval);
1104 else if (size == 16)
1105 pk_printf (int16_fmt, base == 10 ? intval : uintval);
1106 else if (size == 8)
1107 pk_printf (int8_fmt, base == 10 ? intval : uintval);
1108 else if (size == 4)
1109 pk_printf (int4_fmt, base == 10 ? intval : uintval);
1110 else
1111 pk_printf (int_fmt, PVM_VAL_INT_SIZE (val),
1112 base == 10 ? intval : uintval);
1113 }
1114
1115 pk_term_end_class ("integer");
1116 }
1117 else if (PVM_IS_ULONG (val))
1118 {
1119 int size = PVM_VAL_ULONG_SIZE (val);
1120 uint64_t ulongval = PVM_VAL_ULONG (val);
1121
1122 pk_term_class ("integer");
1123
1124 if (base == 2)
1125 {
1126 pk_puts ("0b");
1127 pk_print_binary (pk_puts, ulongval, size, 0);
1128 }
1129 else
1130 {
1131 if (size == 64)
1132 pk_printf (ulong64_fmt, ulongval);
1133 else
1134 pk_printf (ulong_fmt, PVM_VAL_LONG_SIZE (val), ulongval);
1135 }
1136
1137 pk_term_end_class ("integer");
1138 }
1139 else if (PVM_IS_UINT (val))
1140 {
1141 int size = PVM_VAL_UINT_SIZE (val);
1142 uint32_t uintval = PVM_VAL_UINT (val);
1143
1144 pk_term_class ("integer");
1145
1146 if (base == 2)
1147 {
1148 pk_puts ("0b");
1149 pk_print_binary (pk_puts, uintval, size, 0);
1150 }
1151 else
1152 {
1153 if (size == 32)
1154 pk_printf (uint32_fmt, uintval);
1155 else if (size == 16)
1156 pk_printf (uint16_fmt, uintval);
1157 else if (size == 8)
1158 pk_printf (uint8_fmt, uintval);
1159 else if (size == 4)
1160 pk_printf (uint4_fmt, uintval);
1161 else
1162 pk_printf (uint_fmt, PVM_VAL_UINT_SIZE (val),
1163 uintval);
1164 }
1165
1166 pk_term_end_class ("integer");
1167 }
1168 else if (PVM_IS_STR (val))
1169 {
1170 const char *str = PVM_VAL_STR (val);
1171 char *str_printable;
1172 size_t str_size = strlen (PVM_VAL_STR (val));
1173 size_t printable_size, i, j;
1174
1175 pk_term_class ("string");
1176
1177 /* Calculate the length (in bytes) of the printable string
1178 corresponding to the string value. */
1179 for (printable_size = 0, i = 0; i < str_size; i++)
1180 {
1181 switch (str[i])
1182 {
1183 case '\n': printable_size += 2; break;
1184 case '\t': printable_size += 2; break;
1185 case '\\': printable_size += 2; break;
1186 case '\"': printable_size += 2; break;
1187 default: printable_size += 1; break;
1188 }
1189 }
1190
1191 /* Now build the printable string. */
1192 str_printable = xmalloc (printable_size + 1);
1193 for (i = 0, j = 0; i < str_size; i++)
1194 {
1195 switch (str[i])
1196 {
1197 case '\n':
1198 str_printable[j] = '\\';
1199 str_printable[j+1] = 'n';
1200 j += 2;
1201 break;
1202 case '\t':
1203 str_printable[j] = '\\';
1204 str_printable[j+1] = 't';
1205 j += 2;
1206 break;
1207 case '\\':
1208 str_printable[j] = '\\';
1209 str_printable[j+1] = '\\';
1210 j += 2;
1211 break;
1212 case '"':
1213 str_printable[j] = '\\';
1214 str_printable[j+1] = '\"';
1215 j += 2;
1216 break;
1217 default:
1218 str_printable[j] = str[i];
1219 j++;
1220 break;
1221 }
1222 }
1223 assert (j == printable_size);
1224 str_printable[j] = '\0';
1225
1226 pk_printf ("\"%s\"", str_printable);
1227 free (str_printable);
1228
1229 pk_term_end_class ("string");
1230 }
1231 else if (PVM_IS_ARR (val))
1232 {
1233 size_t nelem, idx;
1234 pvm_val array_offset = PVM_VAL_ARR_OFFSET (val);
1235
1236 nelem = PVM_VAL_ULONG (PVM_VAL_ARR_NELEM (val));
1237 pk_term_class ("array");
1238
1239 pk_puts ("[");
1240 for (idx = 0; idx < nelem; idx++)
1241 {
1242 pvm_val elem_value = PVM_VAL_ARR_ELEM_VALUE (val, idx);
1243 pvm_val elem_offset = PVM_VAL_ARR_ELEM_OFFSET (val, idx);
1244
1245 if (idx != 0)
1246 pk_puts (",");
1247
1248 if ((acutoff != 0) && (acutoff <= idx))
1249 {
1250 pk_term_class ("ellipsis");
1251 pk_puts ("...");
1252 pk_term_end_class ("ellipsis");
1253 break;
1254 }
1255
1256 PVM_PRINT_VAL_1 (elem_value, ndepth);
1257
1258 if (maps && elem_offset != PVM_NULL)
1259 {
1260 pk_puts (" @ ");
1261 pk_term_class ("offset");
1262 PVM_PRINT_VAL_1 (elem_offset, ndepth);
1263 pk_puts ("#b");
1264 pk_term_end_class ("offset");
1265 }
1266 }
1267 pk_puts ("]");
1268
1269 if (maps && array_offset != PVM_NULL)
1270 {
1271 /* The struct offset is a bit-offset. Do not bother to
1272 create a real offset here. */
1273 pk_puts (" @ ");
1274 pk_term_class ("offset");
1275 PVM_PRINT_VAL_1 (array_offset, ndepth);
1276 pk_puts ("#b");
1277 pk_term_end_class ("offset");
1278 }
1279
1280 pk_term_end_class ("array");
1281 }
1282 else if (PVM_IS_SCT (val))
1283 {
1284 size_t nelem, idx, nabsent;
1285 pvm_val struct_type = PVM_VAL_SCT_TYPE (val);
1286 pvm_val struct_type_name = PVM_VAL_TYP_S_NAME (struct_type);
1287 pvm_val struct_offset = PVM_VAL_SCT_OFFSET (val);
1288
1289 /* If the struct has a pretty printing method (called _print)
1290 then use it, unless the PVM is configured to not do so. */
1291 if (pprint)
1292 {
1293 if (pvm_call_pretty_printer (vm, val))
1294 return;
1295 }
1296
1297 nelem = PVM_VAL_ULONG (PVM_VAL_SCT_NFIELDS (val));
1298
1299 pk_term_class ("struct");
1300
1301 if (struct_type_name != PVM_NULL)
1302 {
1303 pk_term_class ("struct-type-name");
1304 pk_puts ( PVM_VAL_STR (struct_type_name));
1305 pk_term_end_class ("struct-type-name");
1306 }
1307 else
1308 pk_puts ("struct");
1309
1310 if (ndepth >= depth && depth != 0)
1311 {
1312 pk_puts (" {...}");
1313 pk_term_end_class ("struct");
1314 return;
1315 }
1316
1317 pk_puts (" ");
1318 pk_printf ("{");
1319
1320 nabsent = 0;
1321 for (idx = 0; idx < nelem; ++idx)
1322 {
1323 pvm_val name = PVM_VAL_SCT_FIELD_NAME (val, idx);
1324 pvm_val value = PVM_VAL_SCT_FIELD_VALUE (val, idx);
1325 pvm_val offset = PVM_VAL_SCT_FIELD_OFFSET (val, idx);
1326
1327 if (PVM_VAL_SCT_FIELD_ABSENT_P (val, idx))
1328 nabsent++;
1329 else
1330 {
1331 if ((idx - nabsent) != 0)
1332 pk_puts (",");
1333
1334 if (mode == PVM_PRINT_TREE)
1335 pk_term_indent (ndepth + 1, indent);
1336
1337 if (name != PVM_NULL)
1338 {
1339 pk_term_class ("struct-field-name");
1340 pk_printf ("%s", PVM_VAL_STR (name));
1341 pk_term_end_class ("struct-field-name");
1342 pk_puts ("=");
1343 }
1344 PVM_PRINT_VAL_1 (value, ndepth + 1);
1345 }
1346
1347 if (maps && offset != PVM_NULL)
1348 {
1349 pk_puts (" @ ");
1350 pk_term_class ("offset");
1351 PVM_PRINT_VAL_1 (offset, ndepth);
1352 pk_puts ("#b");
1353 pk_term_end_class ("offset");
1354 }
1355 }
1356
1357 if (mode == PVM_PRINT_TREE)
1358 pk_term_indent (ndepth, indent);
1359 pk_puts ("}");
1360
1361 if (maps && struct_offset != PVM_NULL)
1362 {
1363 /* The struct offset is a bit-offset. Do not bother to
1364 create a real offset here. */
1365 pk_puts (" @ ");
1366 pk_term_class ("offset");
1367 PVM_PRINT_VAL_1 (struct_offset, ndepth);
1368 pk_puts ("#b");
1369 pk_term_end_class ("offset");
1370 }
1371
1372 pk_term_end_class ("struct");
1373 }
1374 else if (PVM_IS_TYP (val))
1375 {
1376 pk_term_class ("type");
1377
1378 switch (PVM_VAL_TYP_CODE (val))
1379 {
1380 case PVM_TYPE_INTEGRAL:
1381 {
1382 if (!(PVM_VAL_INT (PVM_VAL_TYP_I_SIGNED_P (val))))
1383 pk_puts ("u");
1384
1385 switch (PVM_VAL_ULONG (PVM_VAL_TYP_I_SIZE (val)))
1386 {
1387 case 8: pk_puts ("int8"); break;
1388 case 16: pk_puts ("int16"); break;
1389 case 32: pk_puts ("int32"); break;
1390 case 64: pk_puts ("int64"); break;
1391 default: assert (0); break;
1392 }
1393 }
1394 break;
1395 case PVM_TYPE_STRING:
1396 pk_puts ("string");
1397 break;
1398 case PVM_TYPE_VOID:
1399 pk_puts ("void");
1400 break;
1401 case PVM_TYPE_ANY:
1402 pk_term_class ("any");
1403 pk_puts ("any");
1404 pk_term_end_class ("any");
1405 break;
1406 case PVM_TYPE_ARRAY:
1407 PVM_PRINT_VAL_1 (PVM_VAL_TYP_A_ETYPE (val), ndepth);
1408 pk_puts ("[");
1409 if (PVM_VAL_TYP_A_BOUND (val) != PVM_NULL)
1410 PVM_PRINT_VAL_1 (PVM_VAL_TYP_A_BOUND (val), ndepth);
1411 pk_puts ("]");
1412 break;
1413 case PVM_TYPE_OFFSET:
1414 pk_puts ("[");
1415 PVM_PRINT_VAL_1 (PVM_VAL_TYP_O_BASE_TYPE (val), ndepth);
1416 pk_puts (" ");
1417 print_unit_name (PVM_VAL_ULONG (PVM_VAL_TYP_O_UNIT (val)));
1418 pk_puts ("]");
1419 break;
1420 case PVM_TYPE_CLOSURE:
1421 {
1422 size_t i, nargs;
1423
1424 nargs = PVM_VAL_ULONG (PVM_VAL_TYP_C_NARGS (val));
1425
1426 pk_puts ("(");
1427 for (i = 0; i < nargs; ++i)
1428 {
1429 pvm_val atype = PVM_VAL_TYP_C_ATYPE (val, i);
1430 if (i != 0)
1431 pk_puts (",");
1432 PVM_PRINT_VAL_1 (atype, ndepth);
1433 }
1434 pk_puts (")");
1435
1436 PVM_PRINT_VAL_1 (PVM_VAL_TYP_C_RETURN_TYPE (val), ndepth);
1437 break;
1438 }
1439 case PVM_TYPE_STRUCT:
1440 {
1441 size_t i, nelem;
1442 pvm_val type_name = PVM_VAL_TYP_S_NAME (val);
1443
1444 nelem = PVM_VAL_ULONG (PVM_VAL_TYP_S_NFIELDS (val));
1445
1446 if (type_name != PVM_NULL)
1447 pk_puts (PVM_VAL_STR (type_name));
1448 else
1449 pk_puts ("struct");
1450
1451 pk_puts (" {");
1452 for (i = 0; i < nelem; ++i)
1453 {
1454 pvm_val ename = PVM_VAL_TYP_S_FNAME(val, i);
1455 pvm_val etype = PVM_VAL_TYP_S_FTYPE(val, i);
1456
1457 if (i != 0)
1458 pk_puts (" ");
1459
1460 PVM_PRINT_VAL_1 (etype, ndepth);
1461 if (ename != PVM_NULL)
1462 pk_printf (" %s", PVM_VAL_STR (ename));
1463 pk_puts (";");
1464 }
1465 pk_puts ("}");
1466 break;
1467 }
1468 default:
1469 assert (0);
1470 }
1471
1472 pk_term_end_class ("type");
1473 }
1474 else if (PVM_IS_OFF (val))
1475 {
1476 pk_term_class ("offset");
1477 PVM_PRINT_VAL_1 (PVM_VAL_OFF_MAGNITUDE (val), ndepth);
1478 pk_puts ("#");
1479 print_unit_name (PVM_VAL_ULONG (PVM_VAL_OFF_UNIT (val)));
1480 pk_term_end_class ("offset");
1481 }
1482 else if (PVM_IS_CLS (val))
1483 {
1484 pk_term_class ("special");
1485 pk_puts ("#<closure>");
1486 pk_term_end_class ("special");
1487 }
1488 else
1489 assert (0);
1490 }
1491
1492 #undef PVM_PRINT_VAL_1
1493
1494 void
pvm_print_val(pvm vm,pvm_val val)1495 pvm_print_val (pvm vm, pvm_val val)
1496 {
1497 pvm_print_val_1 (vm,
1498 pvm_odepth (vm), pvm_omode (vm),
1499 pvm_obase (vm), pvm_oindent (vm),
1500 pvm_oacutoff (vm),
1501 (pvm_omaps (vm) << (PVM_PRINT_F_MAPS - 1)
1502 | (pvm_pretty_print (vm) << (PVM_PRINT_F_PPRINT - 1))),
1503 val,
1504 0 /* ndepth */);
1505 }
1506
1507 void
pvm_print_val_with_params(pvm vm,pvm_val val,int depth,int mode,int base,int indent,int acutoff,uint32_t flags)1508 pvm_print_val_with_params (pvm vm, pvm_val val,
1509 int depth,int mode, int base,
1510 int indent, int acutoff,
1511 uint32_t flags)
1512 {
1513 pvm_print_val_1 (vm,
1514 depth, mode, base, indent, acutoff,
1515 flags,
1516 val,
1517 0 /* ndepth */);
1518 }
1519
1520 pvm_val
pvm_typeof(pvm_val val)1521 pvm_typeof (pvm_val val)
1522 {
1523 pvm_val type;
1524
1525 if (PVM_IS_INT (val))
1526 type = pvm_make_integral_type (pvm_make_ulong (PVM_VAL_INT_SIZE (val), 64),
1527 PVM_MAKE_INT (1, 32));
1528 else if (PVM_IS_UINT (val))
1529 type = pvm_make_integral_type (pvm_make_ulong (PVM_VAL_UINT_SIZE (val), 64),
1530 PVM_MAKE_INT (0, 32));
1531 else if (PVM_IS_LONG (val))
1532 type = pvm_make_integral_type (pvm_make_ulong (PVM_VAL_LONG_SIZE (val), 64),
1533 PVM_MAKE_INT (1, 32));
1534 else if (PVM_IS_ULONG (val))
1535 type = pvm_make_integral_type (pvm_make_ulong (PVM_VAL_ULONG_SIZE (val), 64),
1536 PVM_MAKE_INT (0, 32));
1537 else if (PVM_IS_STR (val))
1538 type = pvm_make_string_type ();
1539 else if (PVM_IS_OFF (val))
1540 type = pvm_make_offset_type (PVM_VAL_OFF_BASE_TYPE (val),
1541 PVM_VAL_OFF_UNIT (val));
1542 else if (PVM_IS_ARR (val))
1543 type = PVM_VAL_ARR_TYPE (val);
1544 else if (PVM_IS_SCT (val))
1545 type = PVM_VAL_SCT_TYPE (val);
1546 else
1547 assert (0);
1548
1549 return type;
1550 }
1551
1552 int
pvm_type_equal_p(pvm_val type1,pvm_val type2)1553 pvm_type_equal_p (pvm_val type1, pvm_val type2)
1554 {
1555 enum pvm_type_code type_code_1 = PVM_VAL_TYP_CODE (type1);
1556 enum pvm_type_code type_code_2 = PVM_VAL_TYP_CODE (type2);
1557
1558 if (type_code_1 != type_code_2)
1559 return 0;
1560
1561 switch (type_code_1)
1562 {
1563 case PVM_TYPE_INTEGRAL:
1564 {
1565 size_t t1_size = PVM_VAL_ULONG (PVM_VAL_TYP_I_SIZE (type1));
1566 size_t t2_size = PVM_VAL_ULONG (PVM_VAL_TYP_I_SIZE (type2));
1567 int32_t t1_signed = PVM_VAL_INT (PVM_VAL_TYP_I_SIGNED_P (type1));
1568 int32_t t2_signed = PVM_VAL_INT (PVM_VAL_TYP_I_SIGNED_P (type2));
1569
1570 return (t1_size == t2_size && t1_signed == t2_signed);
1571 }
1572 case PVM_TYPE_STRING:
1573 case PVM_TYPE_ANY:
1574 case PVM_TYPE_VOID:
1575 return 1;
1576 case PVM_TYPE_ARRAY:
1577 return pvm_type_equal_p (PVM_VAL_TYP_A_ETYPE (type1),
1578 PVM_VAL_TYP_A_ETYPE (type2));
1579 case PVM_TYPE_STRUCT:
1580 return (STREQ (PVM_VAL_STR (PVM_VAL_TYP_S_NAME (type1)),
1581 PVM_VAL_STR (PVM_VAL_TYP_S_NAME (type2))));
1582 case PVM_TYPE_OFFSET:
1583 return (pvm_type_equal_p (PVM_VAL_TYP_O_BASE_TYPE (type1),
1584 PVM_VAL_TYP_O_BASE_TYPE (type2))
1585 && (PVM_VAL_ULONG (PVM_VAL_TYP_O_UNIT (type1))
1586 == PVM_VAL_ULONG (PVM_VAL_TYP_O_UNIT (type2))));
1587 case PVM_TYPE_CLOSURE:
1588 {
1589 size_t i, nargs;
1590
1591 if (PVM_VAL_ULONG (PVM_VAL_TYP_C_NARGS (type1))
1592 != PVM_VAL_ULONG (PVM_VAL_TYP_C_NARGS (type2)))
1593 return 0;
1594
1595 if (!pvm_type_equal_p (PVM_VAL_TYP_C_RETURN_TYPE (type1),
1596 PVM_VAL_TYP_C_RETURN_TYPE (type2)))
1597 return 0;
1598
1599 nargs = PVM_VAL_ULONG (PVM_VAL_TYP_C_NARGS (type1));
1600 for (i = 0; i < nargs; i++)
1601 {
1602 if (!pvm_type_equal_p (PVM_VAL_TYP_C_ATYPE (type1, i),
1603 PVM_VAL_TYP_C_ATYPE (type2, i)))
1604 return 0;
1605 }
1606
1607 return 1;
1608 }
1609 default:
1610 assert (0);
1611 }
1612 }
1613
1614 void
pvm_print_string(pvm_val string)1615 pvm_print_string (pvm_val string)
1616 {
1617 pk_puts (PVM_VAL_STR (string));
1618 }
1619
1620 /* Call a struct pretty-print function in the closure CLS,
1621 corresponding to the struct VAL. */
1622
1623 int
pvm_call_pretty_printer(pvm vm,pvm_val val)1624 pvm_call_pretty_printer (pvm vm, pvm_val val)
1625 {
1626 pvm_val cls = pvm_get_struct_method (val, "_print");
1627
1628 if (cls == PVM_NULL)
1629 return 0;
1630
1631 pvm_call_closure (vm, cls, val, PVM_NULL);
1632 return 1;
1633 }
1634
1635 /* IMPORTANT: please keep pvm_make_exception in sync with the
1636 definition of the struct Exception in pkl-rt.pk. */
1637
1638 pvm_val
pvm_make_exception(int code,char * message,int exit_status)1639 pvm_make_exception (int code, char *message, int exit_status)
1640 {
1641 pvm_val nfields = pvm_make_ulong (3, 64);
1642 pvm_val nmethods = pvm_make_ulong (0, 64);
1643 pvm_val struct_name = pvm_make_string ("Exception");
1644 pvm_val code_name = pvm_make_string ("code");
1645 pvm_val msg_name = pvm_make_string ("msg");
1646 pvm_val exit_status_name = pvm_make_string ("exit_status");
1647 pvm_val *field_names, *field_types, type;
1648 pvm_val exception;
1649
1650 pvm_allocate_struct_attrs (nfields, &field_names, &field_types);
1651
1652 field_names[0] = code_name;
1653 field_types[0] = pvm_make_integral_type (32, 1);
1654
1655 field_names[1] = msg_name;
1656 field_types[1] = pvm_make_string_type ();
1657
1658 type = pvm_make_struct_type (nfields, struct_name,
1659 field_names, field_types);
1660
1661 exception = pvm_make_struct (nfields, nmethods, type);
1662
1663 PVM_VAL_SCT_FIELD_NAME (exception, 0) = code_name;
1664 PVM_VAL_SCT_FIELD_VALUE (exception, 0)
1665 = PVM_MAKE_INT (code, 32);
1666
1667 PVM_VAL_SCT_FIELD_NAME (exception, 1) = msg_name;
1668 PVM_VAL_SCT_FIELD_VALUE (exception, 1)
1669 = pvm_make_string (message);
1670
1671 PVM_VAL_SCT_FIELD_NAME (exception, 2) = exit_status_name;
1672 PVM_VAL_SCT_FIELD_VALUE (exception, 2)
1673 = PVM_MAKE_INT (exit_status, 32);
1674
1675 return exception;
1676 }
1677
1678 pvm_program
pvm_val_cls_program(pvm_val cls)1679 pvm_val_cls_program (pvm_val cls)
1680 {
1681 return PVM_VAL_CLS_PROGRAM (cls);
1682 }
1683
1684 void
pvm_val_initialize(void)1685 pvm_val_initialize (void)
1686 {
1687 pvm_alloc_add_gc_roots (&string_type, 1);
1688 pvm_alloc_add_gc_roots (&void_type, 1);
1689 pvm_alloc_add_gc_roots (&any_type, 1);
1690
1691 string_type = pvm_make_type (PVM_TYPE_STRING);
1692 void_type = pvm_make_type (PVM_TYPE_VOID);
1693 any_type = pvm_make_type (PVM_TYPE_ANY);
1694 }
1695
1696 void
pvm_val_finalize(void)1697 pvm_val_finalize (void)
1698 {
1699 pvm_alloc_remove_gc_roots (&string_type, 1);
1700 pvm_alloc_remove_gc_roots (&void_type, 1);
1701 pvm_alloc_remove_gc_roots (&any_type, 1);
1702 }
1703