1 /* Structure type implementation */
2 /*
3 Copyright (C) 2004-2017,2018 John E. Davis
4
5 This file is part of the S-Lang Library.
6
7 The S-Lang Library is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public License as
9 published by the Free Software Foundation; either version 2 of the
10 License, or (at your option) any later version.
11
12 The S-Lang Library is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this library; if not, write to the Free Software
19 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
20 USA.
21 */
22
23 #include "slinclud.h"
24
25 /* #define SL_APP_WANTS_FOREACH */
26 #include "slang.h"
27 #include "_slang.h"
28
free_fields(_pSLstruct_Field_Type * fields,unsigned int n)29 static void free_fields (_pSLstruct_Field_Type *fields, unsigned int n)
30 {
31 _pSLstruct_Field_Type *field, *field_max;
32
33 if (fields == NULL)
34 return;
35
36 field = fields;
37 field_max = field + n;
38
39 while (field < field_max)
40 {
41 SLang_free_object (&field->obj);
42 SLang_free_slstring ((char *) field->name); /* could be NULL */
43 field++;
44 }
45 SLfree ((char *) fields);
46 }
47
free_struct(_pSLang_Struct_Type * s)48 static void free_struct (_pSLang_Struct_Type *s)
49 {
50 if (s == NULL) return;
51
52 if (s->num_refs > 1)
53 {
54 s->num_refs -= 1;
55 return;
56 }
57
58 if (s->destroy_method != NULL)
59 {
60 int err, status;
61
62 if ((0 != (err = _pSLang_Error))
63 && (-1 == _pSLang_push_error_context ()))
64 {
65 SLang_free_function (s->destroy_method);
66 free_fields (s->fields, s->nfields);
67 SLfree ((char *) s);
68 return;
69 }
70
71 status = 0;
72 if ((-1 == SLang_start_arg_list ())
73 || (-1 == SLang_push_struct (s))
74 || (-1 == SLang_end_arg_list ())
75 || (-1 == SLexecute_function (s->destroy_method)))
76 status = -1;
77
78 if (err)
79 _pSLang_pop_error_context (status != 0);
80
81 if (s->num_refs > 1)
82 {
83 s->num_refs -= 1;
84 return;
85 }
86
87 SLang_free_function (s->destroy_method);
88 }
89 free_fields (s->fields, s->nfields);
90 SLfree ((char *) s);
91 }
92
SLang_free_struct(_pSLang_Struct_Type * s)93 void SLang_free_struct (_pSLang_Struct_Type *s)
94 {
95 free_struct (s);
96 }
97
allocate_struct(unsigned int nfields)98 static _pSLang_Struct_Type *allocate_struct (unsigned int nfields)
99 {
100 _pSLang_Struct_Type *s;
101 _pSLstruct_Field_Type *f;
102 unsigned int i, size;
103
104 s = (_pSLang_Struct_Type *) SLmalloc (sizeof (_pSLang_Struct_Type));
105 if (s == NULL) return NULL;
106
107 SLMEMSET((char *) s, 0, sizeof (_pSLang_Struct_Type));
108
109 size = nfields * sizeof(_pSLstruct_Field_Type);
110 if (NULL == (f = (_pSLstruct_Field_Type *) _SLcalloc (nfields, size)))
111 {
112 SLfree ((char *) s);
113 return NULL;
114 }
115 SLMEMSET ((char *) f, 0, size);
116 s->nfields = nfields;
117 s->fields = f;
118
119 /* By default, all structs will be created with elements set to NULL. I
120 * do not know whether or not it is better to use SLANG_UNDEFINED_TYPE.
121 */
122 for (i = 0; i < nfields; i++)
123 f[i].obj.o_data_type = SLANG_NULL_TYPE;
124
125 return s;
126 }
127
push_struct_of_type(SLtype type,_pSLang_Struct_Type * s)128 static int push_struct_of_type (SLtype type, _pSLang_Struct_Type *s)
129 {
130 SLang_Object_Type obj;
131
132 obj.o_data_type = type;
133 obj.v.struct_val = s;
134 s->num_refs += 1;
135
136 if (0 == SLang_push (&obj))
137 return 0;
138
139 s->num_refs -= 1;
140 return -1;
141 }
142
SLang_push_struct(_pSLang_Struct_Type * s)143 int SLang_push_struct (_pSLang_Struct_Type *s)
144 {
145 if (s == NULL)
146 return SLang_push_null ();
147
148 return push_struct_of_type (SLANG_STRUCT_TYPE, s);
149 }
150
SLang_pop_struct(_pSLang_Struct_Type ** sp)151 int SLang_pop_struct (_pSLang_Struct_Type **sp)
152 {
153 SLang_Object_Type obj;
154 SLtype type;
155
156 if (0 != SLang_pop (&obj))
157 return -1;
158
159 type = obj.o_data_type;
160 if (type != SLANG_STRUCT_TYPE)
161 {
162 SLang_Class_Type *cl;
163 cl = _pSLclass_get_class (type);
164 if (cl->is_struct == 0)
165 {
166 *sp = NULL;
167 SLang_free_object (&obj);
168 _pSLang_verror (SL_TYPE_MISMATCH,
169 "Expecting struct type object. Found %s",
170 cl->cl_name);
171 return -1;
172 }
173 }
174
175 *sp = obj.v.struct_val;
176 return 0;
177 }
178
struct_destroy(SLtype type,VOID_STAR vs)179 static void struct_destroy (SLtype type, VOID_STAR vs)
180 {
181 (void) type;
182 SLang_free_struct (*(_pSLang_Struct_Type **) vs);
183 }
184
struct_push(SLtype type,VOID_STAR ptr)185 static int struct_push (SLtype type, VOID_STAR ptr)
186 {
187 return push_struct_of_type (type, *(_pSLang_Struct_Type **) ptr);
188 }
189
find_field_in_fields(_pSLstruct_Field_Type * fields,unsigned int n,SLCONST char * name)190 static _pSLstruct_Field_Type *find_field_in_fields (_pSLstruct_Field_Type *fields, unsigned int n, SLCONST char *name)
191 {
192 _pSLstruct_Field_Type *f, *fmax;
193
194 f = fields;
195 fmax = fields + n;
196
197 while (f < fmax)
198 {
199 /* Since both these are slstrings, only compare pointer */
200 if (name == f->name)
201 return f;
202
203 f++;
204 }
205
206 return NULL;
207 }
208
find_field(_pSLang_Struct_Type * s,SLCONST char * name)209 static _pSLstruct_Field_Type *find_field (_pSLang_Struct_Type *s, SLCONST char *name)
210 {
211 return find_field_in_fields (s->fields, s->nfields, name);
212 }
213
find_field_strcmp(_pSLang_Struct_Type * s,SLCONST char * name)214 static _pSLstruct_Field_Type *find_field_strcmp (_pSLang_Struct_Type *s, SLCONST char *name)
215 {
216 _pSLstruct_Field_Type *f, *fmax;
217
218 if (NULL != (f = find_field_in_fields (s->fields, s->nfields, name)))
219 return f;
220
221 f = s->fields;
222 fmax = f + s->nfields;
223
224 while (f < fmax)
225 {
226 if (0 == strcmp (name, f->name))
227 return f;
228
229 f++;
230 }
231
232 return NULL;
233 }
234
235 /* This function is used by the qualifier-code. Here "name" cannot be
236 * assumed to be an slstring.
237 */
_pSLstruct_get_field_value(SLang_Struct_Type * s,SLCONST char * name)238 SLang_Object_Type *_pSLstruct_get_field_value (SLang_Struct_Type *s, SLCONST char *name)
239 {
240 _pSLstruct_Field_Type *f = find_field_strcmp (s, name);
241
242 if (f == NULL)
243 return NULL;
244
245 return &f->obj;
246 }
247
pop_field(_pSLang_Struct_Type * s,SLCONST char * name,_pSLstruct_Field_Type * (* find)(_pSLang_Struct_Type *,SLCONST char *))248 static _pSLstruct_Field_Type *pop_field (_pSLang_Struct_Type *s, SLCONST char *name,
249 _pSLstruct_Field_Type *(*find)(_pSLang_Struct_Type *, SLCONST char *))
250 {
251 _pSLstruct_Field_Type *f;
252
253 f = (*find) (s, name);
254 if (f == NULL)
255 _pSLang_verror (SL_INVALID_PARM, "struct has no field named %s", name);
256 return f;
257 }
258
259 static _pSLang_Struct_Type *
create_struct(unsigned int nfields,SLFUTURE_CONST char ** field_names,SLtype * field_types,VOID_STAR * field_values)260 create_struct (unsigned int nfields,
261 SLFUTURE_CONST char **field_names,
262 SLtype *field_types,
263 VOID_STAR *field_values)
264 {
265 _pSLang_Struct_Type *s;
266 _pSLstruct_Field_Type *f;
267 unsigned int i;
268
269 if (NULL == (s = allocate_struct (nfields)))
270 return NULL;
271
272 f = s->fields;
273 for (i = 0; i < nfields; i++)
274 {
275 SLtype type;
276 SLang_Class_Type *cl;
277 VOID_STAR value;
278 SLFUTURE_CONST char *name = field_names [i];
279
280 if (name == NULL)
281 {
282 _pSLang_verror (SL_APPLICATION_ERROR, "A struct field name cannot be NULL");
283 goto return_error;
284 }
285 #if 0
286 if (-1 == _pSLcheck_identifier_syntax (name))
287 goto return_error;
288 #endif
289 if (NULL == (f->name = SLang_create_slstring (name)))
290 goto return_error;
291
292 if ((field_values == NULL)
293 || (NULL == (value = field_values [i])))
294 {
295 f++;
296 continue;
297 }
298
299 type = field_types[i];
300 cl = _pSLclass_get_class (type);
301
302 if ((-1 == (cl->cl_apush (type, value)))
303 || (-1 == SLang_pop (&f->obj)))
304 goto return_error;
305
306 f++;
307 }
308
309 return s;
310
311 return_error:
312 SLang_free_struct (s);
313 return NULL;
314 }
315
SLstruct_create_struct(unsigned int nfields,SLFUTURE_CONST char ** field_names,SLtype * field_types,VOID_STAR * field_values)316 int SLstruct_create_struct (unsigned int nfields,
317 SLFUTURE_CONST char **field_names,
318 SLtype *field_types,
319 VOID_STAR *field_values)
320 {
321 _pSLang_Struct_Type *s;
322
323 if (NULL == (s = create_struct (nfields, field_names, field_types, field_values)))
324 return -1;
325
326 if (0 == SLang_push_struct (s))
327 return 0;
328
329 SLang_free_struct (s);
330 return -1;
331 }
332
333 /* Interpreter interface */
334
struct_from_struct_fields(int nfields)335 static _pSLang_Struct_Type *struct_from_struct_fields (int nfields)
336 {
337 _pSLang_Struct_Type *s;
338 _pSLstruct_Field_Type *f;
339 int max_fields;
340
341 if (nfields <= 0)
342 {
343 _pSLang_verror (SL_INVALID_PARM, "Number of struct fields must be > 0");
344 return NULL;
345 }
346
347 if (NULL == (s = allocate_struct (nfields)))
348 return NULL;
349
350 f = s->fields;
351 max_fields = nfields;
352 while (nfields)
353 {
354 char *name;
355 int i;
356
357 nfields--;
358 if (-1 == SLang_pop_slstring (&name))
359 {
360 SLang_free_struct (s);
361 return NULL;
362 }
363
364 f[nfields].name = name;
365
366 for (i = nfields + 1; i < max_fields; i++)
367 {
368 if (name != f[i].name)
369 continue;
370
371 _pSLang_verror (SL_DuplicateDefinition_Error,
372 "Field %s used more than once in the struct",
373 name);
374 SLang_free_struct (s);
375 return NULL;
376 }
377 }
378
379 return s;
380 }
381
_pSLstruct_define_struct(void)382 int _pSLstruct_define_struct (void)
383 {
384 _pSLang_Struct_Type *s;
385 int nfields;
386
387 if (-1 == SLang_pop_integer (&nfields))
388 return -1;
389
390 if (NULL == (s = struct_from_struct_fields (nfields)))
391 return -1;
392
393 if (-1 == SLang_push_struct (s))
394 {
395 SLang_free_struct (s);
396 return -1;
397 }
398 return 0;
399 }
400
pop_to_struct_field(_pSLang_Struct_Type * s,SLCONST char * name)401 static int pop_to_struct_field (_pSLang_Struct_Type *s, SLCONST char *name)
402 {
403 _pSLstruct_Field_Type *f;
404 SLang_Object_Type obj;
405
406 if ((NULL == (f = pop_field (s, name, find_field)))
407 || (-1 == SLang_pop (&obj)))
408 return -1;
409
410 SLang_free_object (&f->obj);
411 f->obj = obj;
412
413 return 0;
414 }
415
416 /* Take the fields of b and use those to replace the field atname of a */
merge_struct_fields(SLCONST char * atname,_pSLang_Struct_Type * a,_pSLang_Struct_Type * b)417 static int merge_struct_fields (SLCONST char *atname, _pSLang_Struct_Type *a, _pSLang_Struct_Type *b)
418 {
419 unsigned int i, j;
420 SLFUTURE_CONST char **new_names;
421 _pSLstruct_Field_Type *f, *fmax, *new_fields;
422 _pSLstruct_Field_Type *atfield;
423 unsigned int num_before, num_insert, num_after, new_num;
424
425 atfield = find_field (a, atname);
426 if (atfield == NULL)
427 {
428 SLang_verror (SL_Internal_Error, "Unable to find struct field %s", atname);
429 return -1;
430 }
431 num_before = atfield - a->fields;
432 num_after = a->nfields - (1 + num_before);
433 num_insert = 0;
434
435 if (b != NULL)
436 {
437 unsigned int nb = b->nfields;
438 new_names = (SLFUTURE_CONST char **)_SLcalloc (nb, sizeof (char *));
439 if (new_names == NULL)
440 return -1;
441
442 f = b->fields;
443 fmax = f + nb;
444 while (f < fmax)
445 {
446 if (NULL == find_field (a, f->name))
447 new_names[num_insert++] = f->name;
448 f++;
449 }
450 }
451 else new_names = NULL;
452
453 new_num = num_before + num_insert + num_after;
454 new_fields = (_pSLstruct_Field_Type *)SLcalloc (new_num, sizeof(_pSLstruct_Field_Type));
455 if (new_fields == NULL)
456 {
457 SLfree ((char *) new_names);
458 return -1;
459 }
460
461 f = a->fields;
462 j = 0;
463 for (i = 0; i < num_before; i++)
464 {
465 new_fields[j++] = f[i];
466 memset ((char *)&f[i], 0, sizeof(_pSLstruct_Field_Type));
467 }
468
469 for (i = 0; i < num_insert; i++)
470 {
471 if (NULL == (new_fields[j].name = SLang_create_slstring (new_names[i])))
472 goto return_error;
473 j++;
474 }
475
476 f = a->fields + num_before + 1;
477 for (i = 0; i < num_after; i++)
478 {
479 new_fields[j++] = f[i];
480 memset ((char *)&f[i], 0, sizeof(_pSLstruct_Field_Type));
481 }
482
483 if (b != NULL)
484 {
485 f = b->fields;
486 fmax = f + b->nfields;
487 while (f < fmax)
488 {
489 _pSLstruct_Field_Type *fa;
490
491 /* Cannot fail by construction */
492 fa = find_field_in_fields (new_fields, new_num, f->name);
493
494 if ((-1 == _pSLpush_slang_obj (&f->obj))
495 || (-1 == SLang_pop (&fa->obj)))
496 goto return_error;
497
498 f++;
499 }
500 }
501
502 SLfree ((char *) new_names);
503 free_fields (a->fields, a->nfields);
504 a->fields = new_fields;
505 a->nfields = new_num;
506 return 0;
507
508 return_error:
509
510 free_fields (new_fields, new_num);
511 SLfree ((char *) new_names);
512 return -1;
513 }
514
pop_struct_into_field(_pSLang_Struct_Type * s,SLCONST char * name)515 static int pop_struct_into_field (_pSLang_Struct_Type *s, SLCONST char *name)
516 {
517 _pSLang_Struct_Type *t;
518 int status;
519
520 if (SLang_peek_at_stack () == SLANG_NULL_TYPE)
521 {
522 (void) SLdo_pop_n(1);
523 return merge_struct_fields (name, s, NULL);
524 }
525
526 if (-1 == SLang_pop_struct (&t))
527 {
528 SLang_verror (SL_TypeMismatch_Error, "Field %s should represent a struct", name);
529 return -1;
530 }
531
532 status = merge_struct_fields (name, s, t);
533 free_struct (t);
534 return status;
535 }
536
537 /* This function is used for structure definitions with embedded assignments */
_pSLstruct_define_struct2(void)538 int _pSLstruct_define_struct2 (void)
539 {
540 _pSLang_Struct_Type *s;
541 int nfields;
542 int nassigns;
543
544 if (-1 == SLang_pop_integer (&nassigns))
545 return -1;
546
547 if (-1 == SLang_pop_integer (&nfields))
548 return -1;
549
550 if (NULL == (s = struct_from_struct_fields (nfields)))
551 return -1;
552
553 /* On stack: nameN, valN, ...., name1, val1 .... */
554 if (nassigns
555 && (-1 == SLreverse_stack (2*nassigns)))
556 goto return_error;
557 while (nassigns > 0)
558 {
559 char *name;
560 int status;
561
562 /* Stack: val1, name1, val2, name2, ...
563 */
564 if ((-1 == SLreverse_stack (2))
565 || (-1 == SLang_pop_slstring (&name)))
566 goto return_error;
567
568 if (*name == '@')
569 status = pop_struct_into_field (s, name);
570 else
571 status = pop_to_struct_field (s, name);
572
573 SLang_free_slstring (name);
574 if (status == -1)
575 goto return_error;
576
577 nassigns--;
578 }
579
580 if (0 == SLang_push_struct (s))
581 return 0;
582
583 return_error:
584
585 SLang_free_struct (s);
586 return -1;
587 }
588
589 static int init_struct_with_user_methods (SLtype, _pSLang_Struct_Type *);
590 /* Simply make a struct that contains the same fields as struct s. Do not
591 * duplicate the field values.
592 */
make_struct_shell(_pSLang_Struct_Type * s,SLtype type)593 static _pSLang_Struct_Type *make_struct_shell (_pSLang_Struct_Type *s, SLtype type)
594 {
595 _pSLang_Struct_Type *new_s;
596 _pSLstruct_Field_Type *new_f, *old_f;
597 unsigned int i, nfields;
598
599 nfields = s->nfields;
600 if (NULL == (new_s = allocate_struct (nfields)))
601 return NULL;
602
603 new_f = new_s->fields;
604 old_f = s->fields;
605
606 for (i = 0; i < nfields; i++)
607 {
608 if (NULL == (new_f[i].name = SLang_create_slstring (old_f[i].name)))
609 {
610 SLang_free_struct (new_s);
611 return NULL;
612 }
613 }
614
615 if (type != SLANG_STRUCT_TYPE)
616 (void) init_struct_with_user_methods (type, new_s);
617 return new_s;
618 }
619
struct_init_array_object(SLtype type,VOID_STAR addr)620 static int struct_init_array_object (SLtype type, VOID_STAR addr)
621 {
622 SLang_Class_Type *cl;
623 _pSLang_Struct_Type *s;
624
625 cl = _pSLclass_get_class (type);
626 if (NULL == (s = make_struct_shell (cl->cl_struct_def, type)))
627 return -1;
628
629 s->num_refs = 1;
630 *(_pSLang_Struct_Type **) addr = s;
631 return 0;
632 }
633
634 static int
typedefed_struct_datatype_deref(SLtype type)635 typedefed_struct_datatype_deref (SLtype type)
636 {
637 SLang_Class_Type *cl;
638 _pSLang_Struct_Type *s;
639
640 cl = _pSLclass_get_class (type);
641 if (NULL == (s = make_struct_shell (cl->cl_struct_def, type)))
642 return -1;
643
644 if (-1 == push_struct_of_type (type, s))
645 {
646 SLang_free_struct (s);
647 return -1;
648 }
649
650 return 0;
651 }
652
duplicate_struct(_pSLang_Struct_Type * s,SLtype type)653 static _pSLang_Struct_Type *duplicate_struct (_pSLang_Struct_Type *s, SLtype type)
654 {
655 _pSLang_Struct_Type *new_s;
656 _pSLstruct_Field_Type *new_f, *f, *fmax;
657
658 new_s = make_struct_shell (s, type);
659
660 if (new_s == NULL)
661 return NULL;
662
663 f = s->fields;
664 fmax = f + s->nfields;
665 new_f = new_s->fields;
666
667 while (f < fmax)
668 {
669 SLang_Object_Type *obj;
670
671 obj = &f->obj;
672 if (obj->o_data_type != SLANG_UNDEFINED_TYPE)
673 {
674 if ((-1 == _pSLpush_slang_obj (obj))
675 || (-1 == SLang_pop (&new_f->obj)))
676 {
677 SLang_free_struct (new_s);
678 return NULL;
679 }
680 }
681 new_f++;
682 f++;
683 }
684
685 return new_s;
686 }
687
struct_dereference(SLtype type,VOID_STAR addr)688 static int struct_dereference (SLtype type, VOID_STAR addr)
689 {
690 _pSLang_Struct_Type *s;
691
692 if (NULL == (s = duplicate_struct (*(_pSLang_Struct_Type **) addr, type)))
693 return -1;
694
695 if (-1 == push_struct_of_type (type, s))
696 {
697 SLang_free_struct (s);
698 return -1;
699 }
700
701 return 0;
702 }
703
704 /*{{{ foreach */
705
706 struct _pSLang_Foreach_Context_Type
707 {
708 _pSLang_Struct_Type *s;
709 char *next_field_name;
710 };
711
712 static SLang_Foreach_Context_Type *
struct_foreach_open(SLtype type,unsigned int num)713 struct_foreach_open (SLtype type, unsigned int num)
714 {
715 SLang_Foreach_Context_Type *c;
716 _pSLang_Struct_Type *s;
717 char *next_name;
718
719 (void) type;
720
721 if (-1 == SLang_pop_struct (&s))
722 return NULL;
723
724 switch (num)
725 {
726 case 0:
727 next_name = SLang_create_slstring ("next");
728 break;
729
730 case 1:
731 if (-1 == SLang_pop_slstring (&next_name))
732 next_name = NULL;
733 break;
734
735 default:
736 next_name = NULL;
737 _pSLang_verror (SL_NOT_IMPLEMENTED,
738 "'foreach (Struct_Type) using' requires single control value");
739 SLdo_pop_n (num);
740 break;
741 }
742
743 if (next_name == NULL)
744 {
745 SLang_free_struct (s);
746 return NULL;
747 }
748
749 c = (SLang_Foreach_Context_Type *)SLmalloc (sizeof (SLang_Foreach_Context_Type));
750 if (c == NULL)
751 {
752 SLang_free_struct (s);
753 SLang_free_slstring (next_name);
754 return NULL;
755 }
756 memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type));
757
758 c->next_field_name = next_name;
759 c->s = s;
760
761 return c;
762 }
763
struct_foreach_close(SLtype type,SLang_Foreach_Context_Type * c)764 static void struct_foreach_close (SLtype type, SLang_Foreach_Context_Type *c)
765 {
766 (void) type;
767 if (c == NULL) return;
768
769 SLang_free_slstring (c->next_field_name);
770 if (c->s != NULL) SLang_free_struct (c->s);
771 SLfree ((char *) c);
772 }
773
struct_foreach(SLtype type,SLang_Foreach_Context_Type * c)774 static int struct_foreach (SLtype type, SLang_Foreach_Context_Type *c)
775 {
776 _pSLstruct_Field_Type *f;
777 _pSLang_Struct_Type *next_s;
778
779 (void) type;
780
781 if (c == NULL)
782 return -1;
783
784 if (c->s == NULL)
785 return 0; /* done */
786
787 if (-1 == SLang_push_struct (c->s))
788 return -1;
789
790 /* Now get the next one ready for the next foreach loop */
791
792 next_s = NULL;
793 if (NULL != (f = find_field (c->s, c->next_field_name)))
794 {
795 SLang_Class_Type *cl;
796
797 cl = _pSLclass_get_class (f->obj.o_data_type);
798 /* Note that I cannot simply look for SLANG_STRUCT_TYPE since the
799 * user may have typedefed another struct type. So, look at the
800 * class methods.
801 */
802 if (cl->cl_foreach_open == struct_foreach_open)
803 {
804 next_s = f->obj.v.struct_val;
805 next_s->num_refs += 1;
806 }
807 }
808
809 SLang_free_struct (c->s);
810 c->s = next_s;
811
812 /* keep going */
813 return 1;
814 }
815
816 /*}}}*/
817
818 /* Operator Overloading Functions */
819 static int push_struct_of_type (SLtype type, _pSLang_Struct_Type *s);
820
821 #define NUM_BINARY_OPS (SLANG_BINARY_OP_MAX-SLANG_BINARY_OP_MIN+1)
822 #define NUM_UNARY_OPS (SLANG_UNARY_OP_MAX-SLANG_UNARY_OP_MIN+1)
823
824 typedef struct Binary_Op_List_Type_
825 {
826 SLtype type;
827 SLang_Class_Type *result_cl;
828 SLang_Name_Type *binary_func;
829 struct Binary_Op_List_Type_ *next;
830 }
831 Binary_Op_List_Type;
832
833 typedef struct
834 {
835 SLang_Name_Type *this_op_any;
836 SLang_Class_Type *result_this_op_any_cl;
837 SLang_Name_Type *any_op_this;
838 SLang_Class_Type *result_any_op_this_cl;
839 Binary_Op_List_Type *that_op_this_list;
840 Binary_Op_List_Type *this_op_that_list;
841 }
842 Binary_Op_Info_Type;
843
844 typedef struct
845 {
846 SLang_Class_Type *result_cl;
847 SLang_Name_Type *unary_function;
848 }
849 Unary_Op_Info_Type;
850
851 typedef struct _Typecast_Info_Type
852 {
853 SLang_Name_Type *typecast_fun;
854 SLtype totype;
855 struct _Typecast_Info_Type *next;
856 }
857 Typecast_Info_Type;
858
859 typedef struct _Struct_Info_Type
860 {
861 SLtype type;
862 struct _Struct_Info_Type *next;
863
864 int binary_registered;
865 int unary_registered;
866 Binary_Op_Info_Type *bi;
867 Unary_Op_Info_Type *ui;
868 Typecast_Info_Type *ti;
869
870 /* Other methods */
871 SLang_Name_Type *destroy_method;
872 SLang_Name_Type *string_method;
873 SLang_Name_Type *aget_method;
874 SLang_Name_Type *aput_method;
875 }
876 Struct_Info_Type;
877
878 static Struct_Info_Type *Struct_Info_List;
879
880 static Binary_Op_Info_Type *find_binary_info (int, SLtype);
881 static Unary_Op_Info_Type *find_unary_info (int, SLtype);
882
allocate_struct_info(SLtype type)883 static int allocate_struct_info (SLtype type)
884 {
885 Struct_Info_Type *si;
886
887 si = (Struct_Info_Type *)SLmalloc (sizeof (Struct_Info_Type));
888 if (si == NULL)
889 return -1;
890
891 memset ((char *) si, 0, sizeof (Struct_Info_Type));
892 si->type = type;
893 si->next = Struct_Info_List;
894 Struct_Info_List = si;
895
896 return 0;
897 }
898
find_struct_info(SLtype type,int do_error)899 static Struct_Info_Type *find_struct_info (SLtype type, int do_error)
900 {
901 Struct_Info_Type *s, *prev = NULL;
902
903 s = Struct_Info_List;
904 while (s != NULL)
905 {
906 Struct_Info_Type *next = s->next;
907 if (s->type == type)
908 {
909 if (s != Struct_Info_List)
910 {
911 if (prev != NULL)
912 prev->next = next;
913 s->next = Struct_Info_List;
914 Struct_Info_List = s;
915 }
916 return s;
917 }
918 prev = s;
919 s = next;
920 }
921 if (do_error)
922 _pSLang_verror (SL_TYPE_MISMATCH,
923 "%s is not a user-defined type", SLclass_get_datatype_name (type));
924 return NULL;
925 }
926
struct_unary_result(int op,SLtype t,SLtype * result)927 static int struct_unary_result (int op, SLtype t, SLtype *result)
928 {
929 Unary_Op_Info_Type *ui;
930
931 if (NULL == (ui = find_unary_info (op, t)))
932 return 0;
933
934 if (ui->result_cl == NULL)
935 return 0;
936
937 *result = (SLtype) ui->result_cl->cl_data_type;
938 return 1;
939 }
940
check_struct_array(SLtype t,SLang_Struct_Type ** sp,SLuindex_Type n)941 static int check_struct_array (SLtype t, SLang_Struct_Type **sp, SLuindex_Type n)
942 {
943 SLuindex_Type i;
944
945 for (i = 0; i < n; i++)
946 {
947 if (sp[i] == NULL)
948 {
949 _pSLang_verror (SL_VARIABLE_UNINITIALIZED, "%s[%lu] not initialized for binary/unary operation",
950 SLclass_get_datatype_name(t), (unsigned long) i);
951 return -1;
952 }
953 }
954 return 0;
955 }
956
struct_unary(int op,SLtype a_type,VOID_STAR ap,SLuindex_Type na,VOID_STAR bp)957 static int struct_unary (int op, SLtype a_type, VOID_STAR ap, SLuindex_Type na,
958 VOID_STAR bp)
959 {
960 SLang_Struct_Type **sa;
961 Unary_Op_Info_Type *ui;
962 SLuindex_Type i;
963 SLtype result_type;
964 SLang_Name_Type *function;
965 SLang_Class_Type *bcl;
966 int (*apop) (SLtype, VOID_STAR);
967 size_t binc;
968
969 if (NULL == (ui = find_unary_info (op, a_type)))
970 {
971 _pSLang_verror (SL_INTERNAL_ERROR, "unary-op not supported");
972 return -1;
973 }
974
975 sa = (SLang_Struct_Type **) ap;
976
977 if (-1 == check_struct_array (a_type, sa, na))
978 return -1;
979
980 function = ui->unary_function;
981 bcl = ui->result_cl;
982 result_type = bcl->cl_data_type;
983 apop = bcl->cl_apop;
984 binc = bcl->cl_sizeof_type;
985
986 for (i = 0; i < na; i++)
987 {
988 if ((-1 == SLang_start_arg_list ())
989 || (-1 == push_struct_of_type (a_type, sa[i]))
990 || (-1 == SLang_end_arg_list ())
991 || (-1 == SLexecute_function (function))
992 || (-1 == (*apop)(result_type, bp)))
993 goto return_error;
994
995 bp = (VOID_STAR) ((char *)bp + binc);
996 }
997
998 return 1;
999
1000 return_error:
1001 while (i > 0)
1002 {
1003 i--;
1004 bp = (VOID_STAR) ((char *)bp - binc);
1005 bcl->cl_adestroy (result_type, bp);
1006 memset ((char *)bp, 0, binc);
1007 }
1008 return -1;
1009 }
1010
find_type_in_binary_list(Binary_Op_List_Type * list,SLtype type)1011 static Binary_Op_List_Type *find_type_in_binary_list (Binary_Op_List_Type *list, SLtype type)
1012 {
1013 while ((list != NULL) && (list->type != type))
1014 list = list->next;
1015
1016 return list;
1017 }
1018
this_op_any_result(int op,SLtype a,SLtype b,SLtype * result)1019 static int this_op_any_result (int op, SLtype a, SLtype b, SLtype *result)
1020 {
1021 Binary_Op_Info_Type *bi;
1022 Binary_Op_List_Type *item;
1023 SLang_Class_Type *cl;
1024
1025 if (NULL == (bi = find_binary_info (op, a)))
1026 return 0;
1027
1028 if (NULL != (item = find_type_in_binary_list (bi->this_op_that_list, b)))
1029 cl = item->result_cl;
1030 else
1031 cl = bi->result_this_op_any_cl;
1032
1033 if (cl == NULL)
1034 return 0;
1035
1036 *result = cl->cl_data_type;
1037 return 1;
1038 }
1039
any_op_this_result(int op,SLtype a,SLtype b,SLtype * result)1040 static int any_op_this_result (int op, SLtype a, SLtype b, SLtype *result)
1041 {
1042 Binary_Op_Info_Type *bi;
1043 Binary_Op_List_Type *item;
1044 SLang_Class_Type *cl;
1045
1046 if (NULL == (bi = find_binary_info (op, b)))
1047 return 0;
1048
1049 if (NULL != (item = find_type_in_binary_list (bi->that_op_this_list, a)))
1050 cl = item->result_cl;
1051 else
1052 cl = bi->result_any_op_this_cl;
1053
1054 if (cl == NULL)
1055 return 0;
1056
1057 *result = cl->cl_data_type;
1058 return 1;
1059 }
1060
do_struct_binary(SLang_Name_Type * function,SLang_Class_Type * cla,VOID_STAR ap,SLuindex_Type na,SLang_Class_Type * clb,VOID_STAR bp,SLuindex_Type nb,SLang_Class_Type * clc,VOID_STAR cp)1061 static int do_struct_binary (SLang_Name_Type *function,
1062 SLang_Class_Type *cla, VOID_STAR ap, SLuindex_Type na,
1063 SLang_Class_Type *clb, VOID_STAR bp, SLuindex_Type nb,
1064 SLang_Class_Type *clc, VOID_STAR cp)
1065 {
1066 SLuindex_Type i;
1067 SLtype a_type, b_type, c_type;
1068 int (*cpop) (SLtype, VOID_STAR);
1069 int (*apush) (SLtype, VOID_STAR);
1070 int (*bpush) (SLtype, VOID_STAR);
1071 size_t ainc, binc, cinc;
1072 SLuindex_Type num;
1073
1074 if (na == 1) ainc = 0; else ainc = cla->cl_sizeof_type;
1075 if (nb == 1) binc = 0; else binc = clb->cl_sizeof_type;
1076 cinc = clc->cl_sizeof_type;
1077
1078 a_type = cla->cl_data_type;
1079 b_type = clb->cl_data_type;
1080 c_type = clc->cl_data_type;
1081 apush = cla->cl_apush;
1082 bpush = clb->cl_apush;
1083 cpop = clc->cl_apop;
1084
1085 if (na > nb) num = na; else num = nb;
1086
1087 for (i = 0; i < num; i++)
1088 {
1089 if ((-1 == SLang_start_arg_list ())
1090 || (-1 == (*apush) (a_type, ap))
1091 || (-1 == (*bpush) (b_type, bp))
1092 || (-1 == SLang_end_arg_list ())
1093 || (-1 == SLexecute_function (function))
1094 || (-1 == (*cpop)(c_type, cp)))
1095 goto return_error;
1096
1097 ap = (VOID_STAR) ((char *)ap + ainc);
1098 bp = (VOID_STAR) ((char *)bp + binc);
1099 cp = (VOID_STAR) ((char *)cp + cinc);
1100 }
1101
1102 return 1;
1103
1104 return_error:
1105 while (i > 0)
1106 {
1107 i--;
1108 cp = (VOID_STAR) ((char *)cp - cinc);
1109 clc->cl_adestroy (c_type, cp);
1110 memset ((char *)cp, 0, cinc);
1111 }
1112 return -1;
1113 }
1114
this_op_any(int op,SLtype a,VOID_STAR ap,SLuindex_Type na,SLtype b,VOID_STAR bp,SLuindex_Type nb,VOID_STAR cp)1115 static int this_op_any (int op,
1116 SLtype a, VOID_STAR ap, SLuindex_Type na,
1117 SLtype b, VOID_STAR bp, SLuindex_Type nb,
1118 VOID_STAR cp)
1119 {
1120 Binary_Op_Info_Type *bi;
1121 Binary_Op_List_Type *item;
1122 SLang_Name_Type *nt;
1123 SLang_Class_Type *cl;
1124
1125 if (NULL == (bi = find_binary_info (op, a)))
1126 {
1127 _pSLang_verror (SL_INTERNAL_ERROR, "binary-op not supported");
1128 return -1;
1129 }
1130
1131 if (NULL != (item = find_type_in_binary_list (bi->this_op_that_list, b)))
1132 {
1133 nt = item->binary_func;
1134 cl = item->result_cl;
1135 }
1136 else
1137 {
1138 nt = bi->this_op_any;
1139 cl = bi->result_this_op_any_cl;
1140 }
1141
1142 return do_struct_binary (nt,
1143 _pSLclass_get_class (a), ap, na,
1144 _pSLclass_get_class (b), bp, nb,
1145 cl, cp);
1146 }
1147
any_op_this(int op,SLtype a,VOID_STAR ap,SLuindex_Type na,SLtype b,VOID_STAR bp,SLuindex_Type nb,VOID_STAR cp)1148 static int any_op_this (int op,
1149 SLtype a, VOID_STAR ap, SLuindex_Type na,
1150 SLtype b, VOID_STAR bp, SLuindex_Type nb,
1151 VOID_STAR cp)
1152 {
1153 Binary_Op_Info_Type *bi;
1154 Binary_Op_List_Type *item;
1155 SLang_Name_Type *nt;
1156 SLang_Class_Type *cl;
1157
1158 if (NULL == (bi = find_binary_info (op, b)))
1159 {
1160 _pSLang_verror (SL_INTERNAL_ERROR, "binary-op not supported");
1161 return -1;
1162 }
1163
1164 if (NULL != (item = find_type_in_binary_list (bi->that_op_this_list, a)))
1165 {
1166 nt = item->binary_func;
1167 cl = item->result_cl;
1168 }
1169 else
1170 {
1171 nt = bi->any_op_this;
1172 cl = bi->result_any_op_this_cl;
1173 }
1174
1175 return do_struct_binary (nt,
1176 _pSLclass_get_class (a), ap, na,
1177 _pSLclass_get_class (b), bp, nb,
1178 cl, cp);
1179 }
1180
register_unary_ops(Struct_Info_Type * si,SLtype t)1181 static int register_unary_ops (Struct_Info_Type *si, SLtype t)
1182 {
1183 if (si->unary_registered)
1184 return 0;
1185
1186 if (-1 == SLclass_add_unary_op (t, struct_unary, struct_unary_result))
1187 return -1;
1188
1189 si->unary_registered = 1;
1190 return 0;
1191 }
1192
register_binary_ops(Struct_Info_Type * si,SLtype t)1193 static int register_binary_ops (Struct_Info_Type *si, SLtype t)
1194 {
1195 if (si->binary_registered)
1196 return 0;
1197
1198 if ((-1 == SLclass_add_binary_op (t, SLANG_VOID_TYPE,
1199 this_op_any, this_op_any_result))
1200 || (-1 == SLclass_add_binary_op (SLANG_VOID_TYPE, t,
1201 any_op_this, any_op_this_result))
1202 || (-1 == SLclass_add_binary_op (t, t, this_op_any, this_op_any_result)))
1203 return -1;
1204
1205 si->binary_registered = 1;
1206 return 0;
1207 }
1208
find_unary_info(int op,SLtype t)1209 static Unary_Op_Info_Type *find_unary_info (int op, SLtype t)
1210 {
1211 Struct_Info_Type *si;
1212
1213 if (NULL == (si = find_struct_info (t, 1)))
1214 return NULL;
1215
1216 if (-1 == register_unary_ops (si, t))
1217 return NULL;
1218
1219 if (si->ui == NULL)
1220 {
1221 Unary_Op_Info_Type *ui;
1222
1223 ui = (Unary_Op_Info_Type *)_SLcalloc (NUM_UNARY_OPS,sizeof(Unary_Op_Info_Type));
1224 if (NULL == (si->ui = ui))
1225 return NULL;
1226
1227 memset ((char *) ui, 0, NUM_UNARY_OPS*sizeof(Unary_Op_Info_Type));
1228 }
1229
1230 op -= SLANG_UNARY_OP_MIN;
1231 if ((op >= NUM_UNARY_OPS) || (op < 0))
1232 {
1233 _pSLang_verror (SL_INTERNAL_ERROR,
1234 "struct_unary_op: op-code out of range");
1235 return NULL;
1236 }
1237
1238 return si->ui + op;
1239 }
1240
find_binary_info(int op,SLtype t)1241 static Binary_Op_Info_Type *find_binary_info (int op, SLtype t)
1242 {
1243 Struct_Info_Type *si;
1244
1245 if (NULL == (si = find_struct_info (t, 1)))
1246 return NULL;
1247
1248 if (-1 == register_binary_ops (si, t))
1249 return NULL;
1250
1251 if (si->bi == NULL)
1252 {
1253 Binary_Op_Info_Type *bi;
1254
1255 bi = (Binary_Op_Info_Type *)_SLcalloc (NUM_BINARY_OPS, sizeof(Binary_Op_Info_Type));
1256 if (NULL == (si->bi = bi))
1257 return NULL;
1258
1259 memset ((char *) bi, 0, NUM_BINARY_OPS*sizeof(Binary_Op_Info_Type));
1260 }
1261
1262 op -= SLANG_BINARY_OP_MIN;
1263 if ((op >= NUM_BINARY_OPS) || (op < 0))
1264 {
1265 _pSLang_verror (SL_INTERNAL_ERROR,
1266 "struct_binary_op: op-code out of range");
1267 return NULL;
1268 }
1269
1270 return si->bi + op;
1271 }
1272
add_binary_op_to_list(Binary_Op_List_Type ** listp,SLang_Class_Type * cl,SLang_Name_Type * nt,SLtype type)1273 static int add_binary_op_to_list (Binary_Op_List_Type **listp,
1274 SLang_Class_Type *cl,
1275 SLang_Name_Type *nt, SLtype type)
1276 {
1277 Binary_Op_List_Type *item, *list = *listp;
1278
1279 if (NULL == (item = find_type_in_binary_list (list, type)))
1280 {
1281 item = (Binary_Op_List_Type *)SLmalloc (sizeof(Binary_Op_List_Type));
1282 if (item == NULL)
1283 return -1;
1284 memset (item, 0, sizeof(Binary_Op_List_Type));
1285 item->type = type;
1286
1287 if (list == NULL)
1288 *listp = item;
1289 else
1290 {
1291 while (list->next != NULL) list = list->next;
1292 list->next = item;
1293 }
1294 /* drop */
1295 }
1296 SLang_free_function (item->binary_func);
1297 item->binary_func = nt;
1298 item->result_cl = cl;
1299 return 0;
1300 }
1301
add_binary_op(char * op,SLtype result_type,SLang_Name_Type * nt,SLtype a_type,SLtype b_type)1302 static int add_binary_op (char *op,
1303 SLtype result_type, SLang_Name_Type *nt,
1304 SLtype a_type, SLtype b_type)
1305 {
1306 Binary_Op_Info_Type *bi;
1307 SLang_Class_Type *cl;
1308 int opcode;
1309
1310 if (-1 == (opcode = _pSLclass_get_binary_opcode (op)))
1311 return -1;
1312
1313 cl = _pSLclass_get_class (result_type);
1314
1315 if ((a_type == SLANG_ANY_TYPE)
1316 || (NULL == find_struct_info (a_type, 0)))
1317 {
1318 /* something op this form */
1319 bi = find_binary_info (opcode, b_type);
1320 if (bi == NULL)
1321 return -1;
1322 if (a_type == SLANG_ANY_TYPE)
1323 {
1324 SLang_free_function (bi->any_op_this); /* NULL ok */
1325 bi->any_op_this = nt;
1326 bi->result_any_op_this_cl = cl;
1327 return 0;
1328 }
1329
1330 return add_binary_op_to_list (&bi->that_op_this_list, cl, nt, a_type);
1331 }
1332
1333 /* Otherwise this op something form */
1334 bi = find_binary_info (opcode, a_type);
1335 if (bi == NULL)
1336 return -1;
1337 if (b_type == SLANG_ANY_TYPE)
1338 {
1339 SLang_free_function (bi->this_op_any); /* NULL ok */
1340 bi->this_op_any = nt;
1341 bi->result_this_op_any_cl = cl;
1342 return 0;
1343 }
1344
1345 return add_binary_op_to_list (&bi->this_op_that_list, cl, nt, b_type);
1346 }
1347
add_unary_op(char * op,SLtype result_type,SLang_Name_Type * nt,SLtype type)1348 static int add_unary_op (char *op,
1349 SLtype result_type, SLang_Name_Type *nt, SLtype type)
1350 {
1351 Unary_Op_Info_Type *ui;
1352 int opcode;
1353
1354 if (-1 == (opcode = _pSLclass_get_unary_opcode (op)))
1355 return -1;
1356
1357 if (NULL == (ui = find_unary_info (opcode, type)))
1358 return -1;
1359
1360 if (ui->unary_function != NULL)
1361 SLang_free_function (ui->unary_function);
1362
1363 ui->unary_function = nt;
1364 ui->result_cl = _pSLclass_get_class (result_type);
1365 return 0;
1366 }
1367
add_unary_op_intrin(void)1368 static void add_unary_op_intrin (void)
1369 {
1370 SLtype type, result_type;
1371 SLang_Name_Type *nt;
1372 char *op;
1373
1374 if ((-1 == SLang_pop_datatype (&type))
1375 || (NULL == (nt = SLang_pop_function ())))
1376 return;
1377
1378 if ((-1 == SLang_pop_datatype (&result_type))
1379 || (-1 == SLang_pop_slstring (&op)))
1380 {
1381 SLang_free_function (nt);
1382 return;
1383 }
1384
1385 if (-1 == add_unary_op (op, result_type, nt, type))
1386 SLang_free_function (nt);
1387
1388 SLang_free_slstring (op);
1389 }
1390
add_binary_op_intrin(void)1391 static void add_binary_op_intrin (void)
1392 {
1393 SLtype a_type, b_type, result_type;
1394 SLang_Name_Type *nt;
1395 char *op;
1396
1397 if ((-1 == SLang_pop_datatype (&b_type))
1398 || (-1 == SLang_pop_datatype (&a_type))
1399 || (NULL == (nt = SLang_pop_function ())))
1400 return;
1401
1402 if ((-1 == SLang_pop_datatype (&result_type))
1403 || (-1 == SLang_pop_slstring (&op)))
1404 {
1405 SLang_free_function (nt);
1406 return;
1407 }
1408
1409 if (-1 == add_binary_op (op, result_type, nt, a_type, b_type))
1410 SLang_free_function (nt);
1411
1412 SLang_free_slstring (op);
1413 }
1414
add_destroy_method(void)1415 static void add_destroy_method (void)
1416 {
1417 _pSLang_Struct_Type *s;
1418 SLang_Name_Type *f;
1419
1420 if (NULL == (f = SLang_pop_function ()))
1421 return;
1422
1423 if (SLang_peek_at_stack () == SLANG_DATATYPE_TYPE)
1424 {
1425 SLtype type;
1426 Struct_Info_Type *si;
1427
1428 if ((-1 == SLang_pop_datatype (&type))
1429 || (NULL == (si = find_struct_info (type, 1))))
1430 {
1431 SLang_free_function (f);
1432 return;
1433 }
1434
1435 if (si->destroy_method != NULL)
1436 SLang_free_function (si->destroy_method);
1437 si->destroy_method = f;
1438 return;
1439 }
1440
1441 if (-1 == SLang_pop_struct (&s))
1442 {
1443 SLang_free_function (f);
1444 return;
1445 }
1446
1447 if (s->destroy_method != NULL)
1448 SLang_free_function (s->destroy_method);
1449 s->destroy_method = SLang_copy_function (f);
1450 SLang_free_struct (s);
1451 }
1452
add_string_method(SLtype * typep,SLang_Ref_Type * ref)1453 static void add_string_method (SLtype *typep, SLang_Ref_Type *ref)
1454 {
1455 Struct_Info_Type *si;
1456 SLang_Name_Type *f;
1457 SLtype type = *typep;
1458
1459 if (NULL == (f = SLang_get_fun_from_ref (ref)))
1460 return;
1461
1462 if (NULL == (si = find_struct_info (type, 1)))
1463 return;
1464
1465 if (si->string_method != NULL)
1466 SLang_free_function (si->string_method);
1467
1468 si->string_method = SLang_copy_function (f);
1469 }
1470
aget_method(SLtype type,unsigned int num_indices)1471 static int aget_method (SLtype type, unsigned int num_indices)
1472 {
1473 Struct_Info_Type *si;
1474
1475 if (NULL == (si = find_struct_info (type, 1)))
1476 return -1;
1477
1478 if (si->aget_method == NULL)
1479 {
1480 SLang_verror (SL_Internal_Error, "aget method called but is NULL");
1481 return -1;
1482 }
1483
1484 if ((-1 == _pSLang_restart_arg_list ((int) num_indices))
1485 || (-1 == SLang_end_arg_list ())
1486 || (-1 == SLexecute_function (si->aget_method)))
1487 return -1;
1488
1489 return 0;
1490 }
1491
aput_method(SLtype type,unsigned int num_indices)1492 static int aput_method (SLtype type, unsigned int num_indices)
1493 {
1494 Struct_Info_Type *si;
1495
1496 if (NULL == (si = find_struct_info (type, 1)))
1497 return -1;
1498
1499 if (si->aput_method == NULL)
1500 {
1501 SLang_verror (SL_Internal_Error, "aput method called but is NULL");
1502 return -1;
1503 }
1504
1505 if ((-1 == _pSLang_restart_arg_list ((int) num_indices))
1506 || (-1 == SLang_end_arg_list ())
1507 || (-1 == SLexecute_function (si->aput_method)))
1508 return -1;
1509
1510 return 0;
1511 }
1512
add_aget_method(SLtype * typep,SLang_Ref_Type * ref)1513 static void add_aget_method (SLtype *typep, SLang_Ref_Type *ref)
1514 {
1515 Struct_Info_Type *si;
1516 SLang_Name_Type *f;
1517 SLtype type = *typep;
1518 SLang_Class_Type *cl;
1519
1520 if (NULL == (cl = _pSLclass_get_class (type)))
1521 return;
1522
1523 if (NULL == (f = SLang_get_fun_from_ref (ref)))
1524 return;
1525
1526 if (NULL == (si = find_struct_info (type, 1)))
1527 return;
1528
1529 if (si->aget_method != NULL)
1530 SLang_free_function (si->aget_method);
1531
1532 si->aget_method = SLang_copy_function (f);
1533 (void) SLclass_set_aget_function (cl, aget_method);
1534 }
1535
add_aput_method(SLtype * typep,SLang_Ref_Type * ref)1536 static void add_aput_method (SLtype *typep, SLang_Ref_Type *ref)
1537 {
1538 Struct_Info_Type *si;
1539 SLang_Name_Type *f;
1540 SLtype type = *typep;
1541 SLang_Class_Type *cl;
1542
1543 if (NULL == (cl = _pSLclass_get_class (type)))
1544 return;
1545
1546 if (NULL == (f = SLang_get_fun_from_ref (ref)))
1547 return;
1548
1549 if (NULL == (si = find_struct_info (type, 1)))
1550 return;
1551
1552 if (si->aput_method != NULL)
1553 SLang_free_function (si->aput_method);
1554
1555 si->aput_method = SLang_copy_function (f);
1556 (void) SLclass_set_aput_function (cl, aput_method);
1557 }
1558
find_typecast(Struct_Info_Type * si,SLtype to)1559 static Typecast_Info_Type *find_typecast (Struct_Info_Type *si, SLtype to)
1560 {
1561 Typecast_Info_Type *ti = si->ti;
1562
1563 while (ti != NULL)
1564 {
1565 if (ti->totype == to)
1566 return ti;
1567 ti = ti->next;
1568 }
1569 return ti;
1570 }
1571
typecast_method(SLtype a_type,VOID_STAR ap,SLuindex_Type na,SLtype b_type,VOID_STAR bp)1572 static int typecast_method (SLtype a_type, VOID_STAR ap, SLuindex_Type na,
1573 SLtype b_type, VOID_STAR bp)
1574 {
1575 Struct_Info_Type *si;
1576 Typecast_Info_Type *ti;
1577 SLuindex_Type i;
1578 SLang_Class_Type *acl, *bcl;
1579 int (*apush) (SLtype, VOID_STAR);
1580 int (*bpop) (SLtype, VOID_STAR);
1581 size_t ainc, binc;
1582 SLang_Name_Type *f;
1583
1584 if (NULL == (si = find_struct_info (a_type, 1)))
1585 return -1;
1586
1587 if ((NULL == (ti = find_typecast (si, b_type)))
1588 || (NULL == (f = ti->typecast_fun)))
1589 {
1590 _pSLang_verror (SL_TYPE_MISMATCH, "Typecast method not found");
1591 return -1;
1592 }
1593
1594 acl = _pSLclass_get_class (a_type);
1595 bcl = _pSLclass_get_class (b_type);
1596 apush = acl->cl_apush;
1597 bpop = bcl->cl_apop;
1598 ainc = acl->cl_sizeof_type;
1599 binc = bcl->cl_sizeof_type;
1600
1601 for (i = 0; i < na; i++)
1602 {
1603 if ((-1 == SLang_start_arg_list ())
1604 || (-1 == (*apush) (a_type, ap))
1605 || (-1 == SLang_end_arg_list ())
1606 || (-1 == SLexecute_function (f))
1607 || (-1 == (*bpop)(b_type, bp)))
1608 return -1;
1609
1610 ap = (VOID_STAR) ((char *)ap + ainc);
1611 bp = (VOID_STAR) ((char *)bp + binc);
1612 }
1613
1614 return 1;
1615 }
1616
add_typecast_method(SLtype * fromtype,SLtype * totype,SLang_Ref_Type * ref)1617 static void add_typecast_method (SLtype *fromtype, SLtype *totype, SLang_Ref_Type *ref)
1618 {
1619 Struct_Info_Type *si;
1620 SLang_Name_Type *f;
1621 SLtype to = *totype, from = *fromtype;
1622 Typecast_Info_Type *ti;
1623
1624 if (NULL == (f = SLang_get_fun_from_ref (ref)))
1625 return;
1626
1627 if (NULL == (si = find_struct_info (from, 1)))
1628 return;
1629
1630 if (NULL != (ti = find_typecast (si, to)))
1631 {
1632 if (ti->typecast_fun != NULL)
1633 SLang_free_function (ti->typecast_fun);
1634 ti->typecast_fun = SLang_copy_function (f);
1635 return;
1636 }
1637
1638 if (NULL == (ti = (Typecast_Info_Type *)SLmalloc (sizeof (Typecast_Info_Type))))
1639 return;
1640
1641 ti->totype = to;
1642 ti->typecast_fun = SLang_copy_function (f);
1643 ti->next = si->ti;
1644 si->ti = ti;
1645 (void) SLclass_add_typecast (from, to, typecast_method, 1);
1646 }
1647
init_struct_with_user_methods(SLtype type,_pSLang_Struct_Type * s)1648 static int init_struct_with_user_methods (SLtype type, _pSLang_Struct_Type *s)
1649 {
1650 Struct_Info_Type *si;
1651
1652 if (NULL == (si = find_struct_info (type, 1)))
1653 return -1;
1654
1655 s->destroy_method = SLang_copy_function (si->destroy_method);
1656
1657 return 0;
1658 }
1659
struct_sput(SLtype type,SLFUTURE_CONST char * name)1660 static int struct_sput (SLtype type, SLFUTURE_CONST char *name)
1661 {
1662 _pSLang_Struct_Type *s;
1663
1664 (void) type;
1665
1666 if (-1 == SLang_pop_struct (&s))
1667 return -1;
1668
1669 if (-1 == pop_to_struct_field (s, name))
1670 {
1671 SLang_free_struct (s);
1672 return -1;
1673 }
1674 SLang_free_struct (s);
1675 return 0;
1676 }
1677
_pSLstruct_pop_field(SLang_Struct_Type * s,SLFUTURE_CONST char * name,int do_free)1678 int _pSLstruct_pop_field (SLang_Struct_Type *s, SLFUTURE_CONST char *name, int do_free)
1679 {
1680 int ret = pop_to_struct_field (s, name);
1681
1682 if (do_free)
1683 SLang_free_struct (s);
1684
1685 return ret;
1686 }
1687
_pSLstruct_push_field(SLang_Struct_Type * s,SLFUTURE_CONST char * name,int do_free)1688 int _pSLstruct_push_field (SLang_Struct_Type *s, SLFUTURE_CONST char *name, int do_free)
1689 {
1690 _pSLstruct_Field_Type *f;
1691 int ret;
1692
1693 if (NULL == (f = pop_field (s, name, find_field)))
1694 {
1695 if (do_free) SLang_free_struct (s);
1696 return -1;
1697 }
1698
1699 ret = _pSLpush_slang_obj (&f->obj);
1700 if (do_free) SLang_free_struct (s);
1701 return ret;
1702 }
1703
struct_sget(SLtype type,SLFUTURE_CONST char * name)1704 static int struct_sget (SLtype type, SLFUTURE_CONST char *name)
1705 {
1706 _pSLang_Struct_Type *s;
1707 _pSLstruct_Field_Type *f;
1708 int ret;
1709
1710 (void) type;
1711
1712 if (-1 == SLang_pop_struct (&s))
1713 return -1;
1714
1715 if (NULL == (f = pop_field (s, name, find_field)))
1716 {
1717 SLang_free_struct (s);
1718 return -1;
1719 }
1720
1721 ret = _pSLpush_slang_obj (&f->obj);
1722 SLang_free_struct (s);
1723 return ret;
1724 }
1725
struct_typecast(SLtype a_type,VOID_STAR ap,SLuindex_Type na,SLtype b_type,VOID_STAR bp)1726 static int struct_typecast
1727 (SLtype a_type, VOID_STAR ap, SLuindex_Type na,
1728 SLtype b_type, VOID_STAR bp)
1729 {
1730 _pSLang_Struct_Type **a, **b;
1731 unsigned int i;
1732
1733 (void) a_type;
1734 (void) b_type;
1735
1736 a = (_pSLang_Struct_Type **) ap;
1737 b = (_pSLang_Struct_Type **) bp;
1738 for (i = 0; i < na; i++)
1739 {
1740 b[i] = a[i];
1741 if (a[i] != NULL)
1742 a[i]->num_refs += 1;
1743 }
1744
1745 return 1;
1746 }
1747
string_method(SLtype type,VOID_STAR p)1748 static char *string_method (SLtype type, VOID_STAR p)
1749 {
1750 SLang_Struct_Type *s;
1751 Struct_Info_Type *si;
1752 SLang_Name_Type *f;
1753 char *str;
1754
1755 s = *(SLang_Struct_Type **)p;
1756
1757 si = find_struct_info (type, 0);
1758 if ((si == NULL)
1759 || (NULL == (f = si->string_method)))
1760 {
1761 char buf[256];
1762 (void) SLsnprintf (buf, sizeof(buf), "%s with %d fields", SLclass_get_datatype_name (type), s->nfields);
1763 return SLmake_string (buf);
1764 }
1765
1766 if ((-1 == SLang_start_arg_list ())
1767 || (-1 == SLang_push_struct (s))
1768 || (-1 == SLang_end_arg_list ())
1769 || (-1 == SLexecute_function (f)))
1770 return NULL;
1771
1772 if (-1 == SLpop_string (&str))
1773 return NULL;
1774
1775 return str;
1776 }
1777
struct_eqs_method(SLtype a_type,VOID_STAR ap,SLtype b_type,VOID_STAR bp)1778 static int struct_eqs_method (SLtype a_type, VOID_STAR ap, SLtype b_type, VOID_STAR bp)
1779 {
1780 SLang_Struct_Type *a, *b;
1781 _pSLstruct_Field_Type *afields;
1782 unsigned int i, nfields;
1783
1784 a = *(SLang_Struct_Type **) ap;
1785 b = *(SLang_Struct_Type **) bp;
1786
1787 /* Suppose typedef struct {x}T; a = @T; b = typecast (a, Struct_Type);
1788 * Then a_type != b_type BUT ap == bp. So compare pointers after types
1789 */
1790 if ((a_type != b_type)
1791 || (a->nfields != b->nfields))
1792 return 0;
1793
1794 if (a == b)
1795 return 1;
1796
1797 nfields = a->nfields;
1798 afields = a->fields;
1799
1800 for (i = 0; i < nfields; i++)
1801 {
1802 if (NULL == find_field (b, afields[i].name))
1803 return 0;
1804 }
1805
1806 for (i = 0; i < nfields; i++)
1807 {
1808 int status;
1809
1810 _pSLstruct_Field_Type *afield = afields + i;
1811 _pSLstruct_Field_Type *bfield = find_field (b, afield->name);
1812 status = _pSLclass_obj_eqs (&afield->obj, &bfield->obj);
1813 if (status <= 0)
1814 return status;
1815 }
1816
1817 return 1;
1818 }
1819
struct_acopy(SLtype unused,VOID_STAR src_sptr,VOID_STAR dest_sptr)1820 static int struct_acopy (SLtype unused, VOID_STAR src_sptr, VOID_STAR dest_sptr)
1821 {
1822 _pSLang_Struct_Type *s;
1823
1824 (void) unused;
1825 s = *(_pSLang_Struct_Type **)src_sptr;
1826 s->num_refs++;
1827 *(_pSLang_Struct_Type **)dest_sptr = s;
1828 return 0;
1829 }
1830
_pSLstruct_define_typedef(void)1831 int _pSLstruct_define_typedef (void)
1832 {
1833 char *type_name;
1834 _pSLang_Struct_Type *s, *s1;
1835 SLang_Class_Type *cl;
1836
1837 if (-1 == SLang_pop_slstring (&type_name))
1838 return -1;
1839
1840 if (-1 == SLang_pop_struct (&s))
1841 {
1842 SLang_free_slstring (type_name);
1843 return -1;
1844 }
1845
1846 if (NULL == (s1 = make_struct_shell (s, SLANG_STRUCT_TYPE)))
1847 {
1848 SLang_free_slstring (type_name);
1849 SLang_free_struct (s);
1850 return -1;
1851 }
1852
1853 SLang_free_struct (s);
1854
1855 if (NULL == (cl = SLclass_allocate_class (type_name)))
1856 {
1857 SLang_free_slstring (type_name);
1858 SLang_free_struct (s1);
1859 return -1;
1860 }
1861 SLang_free_slstring (type_name);
1862
1863 cl->cl_struct_def = s1;
1864 cl->cl_datatype_deref = typedefed_struct_datatype_deref;
1865 cl->cl_destroy = struct_destroy;
1866 cl->cl_push = struct_push;
1867 cl->cl_dereference = struct_dereference;
1868 cl->cl_foreach_open = struct_foreach_open;
1869 cl->cl_foreach_close = struct_foreach_close;
1870 cl->cl_foreach = struct_foreach;
1871
1872 (void) SLclass_set_aelem_init_function (cl, struct_init_array_object);
1873 (void) SLclass_set_string_function (cl, string_method);
1874 (void) SLclass_set_eqs_function (cl, struct_eqs_method);
1875 (void) SLclass_set_acopy_function (cl, struct_acopy);
1876
1877 cl->cl_sget = struct_sget;
1878 cl->cl_sput = struct_sput;
1879 cl->is_container = 1;
1880 cl->is_struct = 1;
1881
1882 if ((-1 == SLclass_register_class (cl,
1883 SLANG_VOID_TYPE, /* any open slot */
1884 sizeof (_pSLang_Struct_Type),
1885 SLANG_CLASS_TYPE_PTR))
1886 || (-1 == allocate_struct_info (cl->cl_data_type)))
1887 {
1888 /* FIXME: Priority=low */
1889 /* There is a memory leak here if this fails... */
1890 return -1;
1891 }
1892 /* Note: typecast from a user type to a struct type allowed but not the other
1893 * way.
1894 */
1895 if (-1 == SLclass_add_typecast (cl->cl_data_type, SLANG_STRUCT_TYPE, struct_typecast, 1))
1896 return -1;
1897
1898 return 0;
1899 }
1900
1901 static int
struct_datatype_deref(SLtype stype)1902 struct_datatype_deref (SLtype stype)
1903 {
1904 (void) stype;
1905
1906 if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE)
1907 {
1908 SLang_Array_Type *at;
1909 int status;
1910
1911 if (-1 == SLang_pop_array_of_type (&at, SLANG_STRING_TYPE))
1912 return -1;
1913
1914 status = SLstruct_create_struct (at->num_elements,
1915 (SLFUTURE_CONST char **) at->data, NULL, NULL);
1916
1917 SLang_free_array (at);
1918 return status;
1919 }
1920
1921 if (-1 == SLang_push_int (SLang_Num_Function_Args))
1922 return -1;
1923
1924 return _pSLstruct_define_struct ();
1925 }
1926
register_struct(void)1927 static int register_struct (void)
1928 {
1929 SLang_Class_Type *cl;
1930
1931 if (NULL == (cl = SLclass_allocate_class ("Struct_Type")))
1932 return -1;
1933
1934 (void) SLclass_set_destroy_function (cl, struct_destroy);
1935 (void) SLclass_set_push_function (cl, struct_push);
1936 cl->cl_dereference = struct_dereference;
1937 cl->cl_datatype_deref = struct_datatype_deref;
1938
1939 cl->cl_foreach_open = struct_foreach_open;
1940 cl->cl_foreach_close = struct_foreach_close;
1941 cl->cl_foreach = struct_foreach;
1942
1943 cl->cl_sget = struct_sget;
1944 cl->cl_sput = struct_sput;
1945 (void) SLclass_set_string_function (cl, string_method);
1946 (void) SLclass_set_eqs_function (cl, struct_eqs_method);
1947 (void) SLclass_set_acopy_function (cl, struct_acopy);
1948
1949 cl->is_container = 1;
1950 cl->is_struct = 1;
1951
1952 if (-1 == SLclass_register_class (cl, SLANG_STRUCT_TYPE, sizeof (_pSLang_Struct_Type),
1953 SLANG_CLASS_TYPE_PTR))
1954 return -1;
1955
1956 return 0;
1957 }
1958
get_struct_field_names(_pSLang_Struct_Type * s)1959 static void get_struct_field_names (_pSLang_Struct_Type *s)
1960 {
1961 SLang_Array_Type *a;
1962 char **data;
1963 SLindex_Type i, nfields;
1964 _pSLstruct_Field_Type *f;
1965
1966 nfields = (SLindex_Type) s->nfields;
1967
1968 if (NULL == (a = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &nfields, 1)))
1969 return;
1970
1971 f = s->fields;
1972 data = (char **) a->data;
1973 for (i = 0; i < nfields; i++)
1974 {
1975 /* Since we are dealing with hashed strings, the next call should not
1976 * fail. If it does, the interpreter will handle it at some other
1977 * level.
1978 */
1979 data [i] = SLang_create_slstring (f[i].name);
1980 }
1981
1982 SLang_push_array (a, 1);
1983 }
1984
push_struct_fields_intrin(void)1985 static void push_struct_fields_intrin (void)
1986 {
1987 _pSLang_Struct_Type *s;
1988 _pSLstruct_Field_Type *f, *fmax;
1989 SLang_Array_Type *at = NULL;
1990 int num;
1991
1992 switch (SLang_Num_Function_Args)
1993 {
1994 default:
1995 SLang_verror (SL_Usage_Error, "Usage: Incorrect number of arguments passed, expecting one or two arguments");
1996 return;
1997 case 2:
1998 if (-1 == SLang_pop_array_of_type (&at, SLANG_STRING_TYPE))
1999 return;
2000 /* drop */
2001 case 1:
2002 if (-1 == SLang_pop_struct (&s))
2003 {
2004 SLang_free_array (at); /* NULL ok */
2005 return;
2006 }
2007 break;
2008 }
2009
2010 if (at != NULL)
2011 {
2012 char **namep, **namep_max;
2013 int ret = 0;
2014
2015 namep = (char **)at->data;
2016 namep_max = namep + at->num_elements;
2017 while ((ret == 0) && (namep < namep_max))
2018 {
2019 /* Use strcmp method since there is no guarantee that the array is one of slstrings */
2020 if (NULL == (f = find_field_strcmp (s, *namep)))
2021 ret = SLang_push_null ();
2022 else
2023 ret = _pSLpush_slang_obj (&f->obj);
2024
2025 namep++;
2026 }
2027 SLang_free_array (at);
2028 free_struct (s);
2029 return;
2030 }
2031
2032 f = s->fields;
2033 fmax = f + s->nfields;
2034 num = 0;
2035
2036 while (fmax > f)
2037 {
2038 fmax--;
2039 if (-1 == _pSLpush_slang_obj (&fmax->obj))
2040 break;
2041
2042 num++;
2043 }
2044 SLang_free_struct (s);
2045 (void) SLang_push_int (num);
2046 }
2047
2048 /* Syntax: set_struct_field (s, name, value); */
struct_set_field(void)2049 static void struct_set_field (void)
2050 {
2051 _pSLang_Struct_Type *s;
2052 _pSLstruct_Field_Type *f;
2053 SLang_Object_Type obj;
2054 char *name;
2055
2056 if (-1 == SLang_pop (&obj))
2057 return;
2058
2059 if (-1 == SLang_pop_slstring (&name))
2060 {
2061 SLang_free_object (&obj);
2062 return;
2063 }
2064
2065 if (-1 == SLang_pop_struct (&s))
2066 {
2067 SLang_free_slstring (name);
2068 SLang_free_object (&obj);
2069 return;
2070 }
2071
2072 if (NULL == (f = pop_field (s, name, find_field)))
2073 {
2074 SLang_free_struct (s);
2075 SLang_free_slstring (name);
2076 SLang_free_object (&obj);
2077 return;
2078 }
2079
2080 SLang_free_object (&f->obj);
2081 f->obj = obj;
2082
2083 SLang_free_struct (s);
2084 SLang_free_slstring (name);
2085 }
2086
2087 /* Syntax: set_struct_fields (s, values....); */
set_struct_fields(void)2088 static void set_struct_fields (void)
2089 {
2090 unsigned int n;
2091 _pSLang_Struct_Type *s;
2092 _pSLstruct_Field_Type *f;
2093
2094 n = (unsigned int) SLang_Num_Function_Args;
2095
2096 if (-1 == SLreverse_stack (n))
2097 return;
2098
2099 n--;
2100 if (-1 == SLang_pop_struct (&s))
2101 {
2102 SLdo_pop_n (n);
2103 return;
2104 }
2105
2106 if (n > s->nfields)
2107 {
2108 SLdo_pop_n (n);
2109 _pSLang_verror (SL_INVALID_PARM, "Too many values for structure");
2110 SLang_free_struct (s);
2111 return;
2112 }
2113
2114 f = s->fields;
2115 while (n > 0)
2116 {
2117 SLang_Object_Type obj;
2118
2119 if (-1 == SLang_pop (&obj))
2120 break;
2121
2122 SLang_free_object (&f->obj);
2123 f->obj = obj;
2124
2125 f++;
2126 n--;
2127 }
2128
2129 SLang_free_struct (s);
2130 }
2131
get_struct_field(char * name)2132 static void get_struct_field (char *name)
2133 {
2134 (void) struct_sget (0, name);
2135 }
2136
is_struct_type(void)2137 static int is_struct_type (void)
2138 {
2139 SLang_Object_Type obj;
2140 SLtype type;
2141 int status;
2142
2143 if (-1 == SLang_pop (&obj))
2144 return -1;
2145
2146 type = obj.o_data_type;
2147 if (type == SLANG_STRUCT_TYPE)
2148 status = 1;
2149 else
2150 status = (NULL != _pSLclass_get_class (type)->cl_struct_def);
2151 SLang_free_object (&obj);
2152 return status;
2153 }
2154
is_struct_type1(void)2155 static int is_struct_type1 (void)
2156 {
2157 SLang_Object_Type obj;
2158 SLtype type;
2159 int status;
2160
2161 if (-1 == SLang_pop (&obj))
2162 return -1;
2163
2164 type = obj.o_data_type;
2165 if (type == SLANG_ARRAY_TYPE)
2166 type = obj.v.array_val->data_type;
2167 if (type == SLANG_STRUCT_TYPE)
2168 status = 1;
2169 else
2170 status = (NULL != _pSLclass_get_class (type)->cl_struct_def);
2171 SLang_free_object (&obj);
2172 return status;
2173 }
2174
2175 static SLang_Intrin_Fun_Type Struct_Table [] =
2176 {
2177 MAKE_INTRINSIC_1("get_struct_field_names", get_struct_field_names, SLANG_VOID_TYPE, SLANG_STRUCT_TYPE),
2178 MAKE_INTRINSIC_1("get_struct_field", get_struct_field, SLANG_VOID_TYPE, SLANG_STRING_TYPE),
2179 MAKE_INTRINSIC_0("_push_struct_field_values", push_struct_fields_intrin, SLANG_VOID_TYPE),
2180 MAKE_INTRINSIC_0("set_struct_field", struct_set_field, SLANG_VOID_TYPE),
2181 MAKE_INTRINSIC_0("set_struct_fields", set_struct_fields, SLANG_VOID_TYPE),
2182 MAKE_INTRINSIC_0("is_struct_type", is_struct_type, SLANG_INT_TYPE),
2183 MAKE_INTRINSIC_0("_is_struct_type", is_struct_type1, SLANG_INT_TYPE),
2184 MAKE_INTRINSIC_0("__add_unary", add_unary_op_intrin, SLANG_VOID_TYPE),
2185 MAKE_INTRINSIC_0("__add_binary", add_binary_op_intrin, SLANG_VOID_TYPE),
2186 MAKE_INTRINSIC_0("__add_destroy", add_destroy_method, SLANG_VOID_TYPE),
2187 MAKE_INTRINSIC_2("__add_string", add_string_method, SLANG_VOID_TYPE, SLANG_DATATYPE_TYPE, SLANG_REF_TYPE),
2188 MAKE_INTRINSIC_2("__add_aget", add_aget_method, SLANG_VOID_TYPE, SLANG_DATATYPE_TYPE, SLANG_REF_TYPE),
2189 MAKE_INTRINSIC_2("__add_aput", add_aput_method, SLANG_VOID_TYPE, SLANG_DATATYPE_TYPE, SLANG_REF_TYPE),
2190 MAKE_INTRINSIC_3("__add_typecast", add_typecast_method, SLANG_VOID_TYPE, SLANG_DATATYPE_TYPE, SLANG_DATATYPE_TYPE, SLANG_REF_TYPE),
2191
2192 /* MAKE_INTRINSIC_I("_create_struct", create_struct, SLANG_VOID_TYPE), */
2193 SLANG_END_INTRIN_FUN_TABLE
2194 };
2195
_pSLstruct_init(void)2196 int _pSLstruct_init (void)
2197 {
2198 if ((-1 == SLadd_intrin_fun_table (Struct_Table, NULL))
2199 || (-1 == register_struct ()))
2200 return -1;
2201
2202 return 0;
2203 }
2204
_pSLstruct_pop_args(int * np)2205 void _pSLstruct_pop_args (int *np)
2206 {
2207 SLang_Array_Type *at;
2208 SLindex_Type i, n;
2209 _pSLang_Struct_Type **data;
2210
2211 n = *np;
2212
2213 if (n < 0)
2214 {
2215 SLang_set_error (SL_INVALID_PARM);
2216 return;
2217 }
2218
2219 data = (_pSLang_Struct_Type **) _SLcalloc (n, sizeof (_pSLang_Struct_Type *));
2220 if (data == NULL)
2221 {
2222 SLdo_pop_n (n);
2223 return;
2224 }
2225
2226 memset ((char *)data, 0, n * sizeof (_pSLang_Struct_Type *));
2227
2228 i = n;
2229 while (i > 0)
2230 {
2231 _pSLang_Struct_Type *s;
2232 _pSLstruct_Field_Type *f;
2233
2234 i--;
2235
2236 if (NULL == (s = allocate_struct (1)))
2237 goto return_error;
2238
2239 data[i] = s;
2240 s->num_refs += 1; /* keeping a copy */
2241
2242 f = s->fields;
2243 if (NULL == (f->name = SLang_create_slstring ("value")))
2244 goto return_error;
2245
2246 if (-1 == SLang_pop (&f->obj))
2247 goto return_error;
2248 }
2249
2250 if (NULL == (at = SLang_create_array (SLANG_STRUCT_TYPE, 0,
2251 (VOID_STAR) data, &n, 1)))
2252 goto return_error;
2253
2254 (void) SLang_push_array (at, 1);
2255 return;
2256
2257 return_error:
2258 for (i = 0; i < n; i++)
2259 {
2260 _pSLang_Struct_Type *s;
2261
2262 s = data[i];
2263 if (s != NULL)
2264 SLang_free_struct (s);
2265 }
2266
2267 SLfree ((char *) data);
2268 }
2269
_pSLstruct_push_args(SLang_Array_Type * at)2270 void _pSLstruct_push_args (SLang_Array_Type *at)
2271 {
2272 _pSLang_Struct_Type **sp;
2273 SLuindex_Type num;
2274
2275 if (at->data_type != SLANG_STRUCT_TYPE)
2276 {
2277 SLang_set_error (SL_TYPE_MISMATCH);
2278 return;
2279 }
2280
2281 sp = (_pSLang_Struct_Type **) at->data;
2282 num = at->num_elements;
2283
2284 while ((_pSLang_Error == 0) && (num > 0))
2285 {
2286 _pSLang_Struct_Type *s;
2287
2288 num--;
2289 if (NULL == (s = *sp++))
2290 {
2291 SLang_push_null ();
2292 continue;
2293 }
2294
2295 /* I should check to see if the value field is present, but... */
2296 (void) _pSLpush_slang_obj (&s->fields->obj);
2297 }
2298 }
2299
2300 /* C structures */
find_field_via_strcmp(_pSLang_Struct_Type * s,SLCONST char * name)2301 static _pSLstruct_Field_Type *find_field_via_strcmp (_pSLang_Struct_Type *s, SLCONST char *name)
2302 {
2303 _pSLstruct_Field_Type *f, *fmax;
2304
2305 f = s->fields;
2306 fmax = f + s->nfields;
2307
2308 while (f < fmax)
2309 {
2310 if (0 == strcmp (name, f->name))
2311 return f;
2312
2313 f++;
2314 }
2315 return NULL;
2316 }
2317
free_cstruct_field(SLang_CStruct_Field_Type * cfield,VOID_STAR cs)2318 static void free_cstruct_field (SLang_CStruct_Field_Type *cfield, VOID_STAR cs)
2319 {
2320 SLang_Class_Type *cl;
2321
2322 if ((cfield->read_only == 0)
2323 && (NULL != (cl = _pSLclass_get_class (cfield->type))))
2324 _pSLarray_free_array_elements (cl, (VOID_STAR)((char*)cs + cfield->offset), 1);
2325 }
2326
SLang_free_cstruct(VOID_STAR cs,SLang_CStruct_Field_Type * cfields)2327 void SLang_free_cstruct (VOID_STAR cs, SLang_CStruct_Field_Type *cfields)
2328 {
2329 if ((cs == NULL) || (cfields == NULL))
2330 return;
2331
2332 while (cfields->field_name != NULL)
2333 {
2334 free_cstruct_field (cfields, cs);
2335 cfields++;
2336 }
2337 }
2338
SLang_pop_cstruct(VOID_STAR cs,SLang_CStruct_Field_Type * cfields)2339 int SLang_pop_cstruct (VOID_STAR cs, SLang_CStruct_Field_Type *cfields)
2340 {
2341 _pSLang_Struct_Type *s;
2342 SLang_CStruct_Field_Type *cfield;
2343 SLCONST char *field_name;
2344 char *cs_addr;
2345
2346 if ((cfields == NULL) || (cs == NULL))
2347 return -1;
2348
2349 if (-1 == SLang_pop_struct (&s))
2350 return -1;
2351
2352 cfield = cfields;
2353 cs_addr = (char *) cs;
2354
2355 while (NULL != (field_name = cfield->field_name))
2356 {
2357 if (cfield->read_only == 0)
2358 {
2359 _pSLstruct_Field_Type *f;
2360 SLang_Class_Type *cl;
2361 VOID_STAR addr = (VOID_STAR) (cs_addr + cfield->offset);
2362
2363 if ((NULL == (f = pop_field (s, field_name, find_field_via_strcmp)))
2364 || (-1 == _pSLpush_slang_obj (&f->obj)))
2365 goto return_error;
2366
2367 if (cfield->type == SLANG_ARRAY_TYPE)
2368 {
2369 if (-1 == SLang_pop_array ((SLang_Array_Type **)addr, 1))
2370 goto return_error;
2371 }
2372 else if ((NULL == (cl = _pSLclass_get_class (cfield->type)))
2373 || (-1 == (*cl->cl_apop)(cfield->type, addr)))
2374 goto return_error;
2375 }
2376
2377 cfield++;
2378 }
2379
2380 SLang_free_struct (s);
2381 return 0;
2382
2383 return_error:
2384 while (cfield != cfields)
2385 {
2386 free_cstruct_field (cfield, cs);
2387 cfield--;
2388 }
2389 SLang_free_struct (s);
2390 return -1;
2391 }
2392
create_cstruct(VOID_STAR cs,SLang_CStruct_Field_Type * cfields)2393 static _pSLang_Struct_Type *create_cstruct (VOID_STAR cs, SLang_CStruct_Field_Type *cfields)
2394 {
2395 unsigned int i, n;
2396 _pSLang_Struct_Type *s;
2397 SLang_CStruct_Field_Type *cfield;
2398 SLFUTURE_CONST char **field_names;
2399 VOID_STAR *field_values;
2400 SLtype *field_types;
2401
2402 if ((cs == NULL) || (cfields == NULL))
2403 return NULL;
2404
2405 cfield = cfields;
2406 while (cfield->field_name != NULL)
2407 cfield++;
2408 n = cfield - cfields;
2409 if (n == 0)
2410 {
2411 _pSLang_verror (SL_APPLICATION_ERROR, "C structure has no fields");
2412 return NULL;
2413 }
2414
2415 s = NULL;
2416 field_types = NULL;
2417 field_values = NULL;
2418 if ((NULL == (field_names = (SLFUTURE_CONST char **) _SLcalloc (n,sizeof (char *))))
2419 || (NULL == (field_types = (SLtype *)_SLcalloc (n,sizeof(SLtype))))
2420 || (NULL == (field_values = (VOID_STAR *)_SLcalloc (n,sizeof(VOID_STAR)))))
2421 goto return_error;
2422
2423 for (i = 0; i < n; i++)
2424 {
2425 cfield = cfields + i;
2426 field_names[i] = cfield->field_name;
2427 field_types[i] = cfield->type;
2428 field_values[i] = (VOID_STAR)((char *)cs + cfield->offset);
2429 }
2430
2431 s = create_struct (n, field_names, field_types, field_values);
2432 /* drop */
2433
2434 return_error:
2435 SLfree ((char *) field_values);
2436 SLfree ((char *) field_types);
2437 SLfree ((char *) field_names);
2438
2439 return s;
2440 }
2441
SLang_push_cstruct(VOID_STAR cs,SLang_CStruct_Field_Type * cfields)2442 int SLang_push_cstruct (VOID_STAR cs, SLang_CStruct_Field_Type *cfields)
2443 {
2444 _pSLang_Struct_Type *s;
2445
2446 if (NULL == (s = create_cstruct (cs, cfields)))
2447 return -1;
2448
2449 if (0 == SLang_push_struct (s))
2450 return 0;
2451
2452 SLang_free_struct (s);
2453 return -1;
2454 }
2455
SLang_assign_cstruct_to_ref(SLang_Ref_Type * ref,VOID_STAR cs,SLang_CStruct_Field_Type * cfields)2456 int SLang_assign_cstruct_to_ref (SLang_Ref_Type *ref, VOID_STAR cs, SLang_CStruct_Field_Type *cfields)
2457 {
2458 _pSLang_Struct_Type *s;
2459
2460 if (NULL == (s = create_cstruct (cs, cfields)))
2461 return -1;
2462
2463 if (0 == SLang_assign_to_ref (ref, SLANG_STRUCT_TYPE, (VOID_STAR) &s))
2464 return 0;
2465
2466 SLang_free_struct (s);
2467 return -1;
2468 }
2469
2470 /* Struct Field Reference */
2471 typedef struct
2472 {
2473 SLang_Struct_Type *s;
2474 SLCONST char *field_name;
2475 }
2476 Struct_Field_Ref_Type;
2477
struct_field_deref_assign(VOID_STAR vdata)2478 static int struct_field_deref_assign (VOID_STAR vdata)
2479 {
2480 Struct_Field_Ref_Type *data = (Struct_Field_Ref_Type *)vdata;
2481 return pop_to_struct_field (data->s, data->field_name);
2482 }
2483
struct_field_deref(VOID_STAR vdata)2484 static int struct_field_deref (VOID_STAR vdata)
2485 {
2486 Struct_Field_Ref_Type *frt = (Struct_Field_Ref_Type *)vdata;
2487 _pSLstruct_Field_Type *f;
2488
2489 if (NULL == (f = pop_field (frt->s, frt->field_name, find_field)))
2490 return -1;
2491
2492 return _pSLpush_slang_obj (&f->obj);
2493 }
2494
struct_field_ref_destroy(VOID_STAR vdata)2495 static void struct_field_ref_destroy (VOID_STAR vdata)
2496 {
2497 Struct_Field_Ref_Type *frt = (Struct_Field_Ref_Type *)vdata;
2498
2499 SLang_free_slstring ((char *) frt->field_name);
2500 SLang_free_struct (frt->s);
2501 }
2502
2503 /* Stack: struct */
_pSLstruct_push_field_ref(SLFUTURE_CONST char * name)2504 int _pSLstruct_push_field_ref (SLFUTURE_CONST char *name)
2505 {
2506 SLang_Struct_Type *s;
2507 Struct_Field_Ref_Type *frt;
2508 SLang_Ref_Type *ref;
2509 int ret;
2510
2511 if (-1 == SLang_pop_struct (&s))
2512 return -1;
2513
2514 if (NULL == (name = SLang_create_slstring (name)))
2515 {
2516 SLang_free_struct (s);
2517 return -1;
2518 }
2519 if (NULL == (ref = _pSLang_new_ref (sizeof (Struct_Field_Ref_Type))))
2520 {
2521 SLang_free_struct (s);
2522 SLang_free_slstring ((char *) name);
2523 return -1;
2524 }
2525 frt = (Struct_Field_Ref_Type *) ref->data;
2526 frt->s = s;
2527 frt->field_name = name;
2528 ref->deref = struct_field_deref;
2529 ref->deref_assign = struct_field_deref_assign;
2530 ref->destroy = struct_field_ref_destroy;
2531
2532 ret = SLang_push_ref (ref);
2533 SLang_free_ref (ref);
2534 return ret;
2535 }
2536
SLang_create_struct(SLFUTURE_CONST char ** field_names,unsigned int nfields)2537 SLang_Struct_Type *SLang_create_struct (SLFUTURE_CONST char **field_names, unsigned int nfields)
2538 {
2539 SLang_Struct_Type *s = create_struct (nfields, field_names, NULL, NULL);
2540 if (s != NULL)
2541 s->num_refs = 1;
2542 return s;
2543 }
2544
SLang_pop_struct_field(SLang_Struct_Type * s,char * name)2545 int SLang_pop_struct_field (SLang_Struct_Type *s, char *name)
2546 {
2547 _pSLstruct_Field_Type *f;
2548 SLang_Object_Type obj;
2549
2550 if (NULL == (f = pop_field (s, name, find_field_via_strcmp)))
2551 return -1;
2552
2553 if (-1 == SLang_pop (&obj))
2554 return -1;
2555
2556 if (f->obj.o_data_type != SLANG_NULL_TYPE)
2557 SLang_free_object (&f->obj);
2558
2559 f->obj = obj;
2560 return 0;
2561 }
2562
SLang_push_struct_field(SLang_Struct_Type * s,char * name)2563 int SLang_push_struct_field (SLang_Struct_Type *s, char *name)
2564 {
2565 _pSLstruct_Field_Type *f;
2566
2567 if (NULL == (f = pop_field (s, name, find_field_via_strcmp)))
2568 return -1;
2569
2570 return _pSLpush_slang_obj (&f->obj);
2571 }
2572
SLang_pop_struct_fields(SLang_Struct_Type * s,int n)2573 int SLang_pop_struct_fields (SLang_Struct_Type *s, int n)
2574 {
2575 _pSLstruct_Field_Type *fields, *f;
2576
2577 if (n < 0)
2578 n = (int) s->nfields;
2579 else if ((unsigned int)n > s->nfields)
2580 {
2581 _pSLang_verror (SL_Application_Error, "SLang_pop_struct_fields called with too many field values");
2582 return -1;
2583 }
2584
2585 fields = s->fields;
2586 f = fields + n;
2587 while (f > fields)
2588 {
2589 SLang_Object_Type obj;
2590
2591 f--;
2592
2593 if (-1 == SLang_pop (&obj))
2594 return -1;
2595
2596 if (f->obj.o_data_type != SLANG_NULL_TYPE)
2597 SLang_free_object (&f->obj);
2598
2599 f->obj = obj;
2600 }
2601 return 0;
2602 }
2603