1 /* User defined objects */
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 #include <errno.h>
25
26 /* #define SL_APP_WANTS_FOREACH */
27 #include "slang.h"
28 #include "_slang.h"
29
30 /* This implementation of the class tables assumes SLtype is 16 bit */
31 typedef struct
32 {
33 SLang_Class_Type *classes[256];
34 unsigned int nclasses;
35 }
36 Class_Table_Type;
37 static Class_Table_Type *Class_Tables[256];
38
add_class_to_slot(Class_Table_Type * t,SLang_Class_Type ** clp,SLang_Class_Type * cl)39 static void add_class_to_slot (Class_Table_Type *t, SLang_Class_Type **clp,
40 SLang_Class_Type *cl)
41 {
42 *clp = cl;
43 t->nclasses++;
44 #if SLANG_OPTIMIZE_FOR_SPEED
45 _pSLang_set_class_info (cl->cl_data_type, cl);
46 #endif
47 }
48
lookup_class(SLtype type)49 static SLang_Class_Type *lookup_class (SLtype type)
50 {
51 Class_Table_Type *t;
52
53 t = Class_Tables[(type >> 8)&0xFF];
54
55 if (t == NULL)
56 return NULL;
57 return t->classes[type & 0xFF];
58 }
59
alloc_class_slot(SLtype type,Class_Table_Type ** tp)60 static SLang_Class_Type **alloc_class_slot (SLtype type, Class_Table_Type **tp)
61 {
62 unsigned int i;
63 Class_Table_Type *t;
64
65 if ((type&0xFFFF) != type)
66 {
67 _pSLang_verror (SL_APPLICATION_ERROR, "Class-Id larger than 0xFFFF is not supported");
68 return NULL;
69 }
70
71 i = ((type >> 8) & 0xFF);
72 if (NULL == (t = Class_Tables[i]))
73 {
74 t = (Class_Table_Type *)SLcalloc (1, sizeof (Class_Table_Type));
75 if (t == NULL)
76 return NULL;
77 Class_Tables[i] = t;
78 }
79 *tp = t;
80 return t->classes + (type&0xFF);
81 }
82
find_empty_class_slot(SLtype * typep,Class_Table_Type ** tp)83 static SLang_Class_Type **find_empty_class_slot (SLtype *typep, Class_Table_Type **tp)
84 {
85 unsigned int i;
86 Class_Table_Type *t;
87 SLtype type;
88
89 /* Class_Tables[0] is reserved (0 <= SLtype < 256) by interpreter */
90 for (i = 1; i < 256; i++)
91 {
92 unsigned int j;
93 SLang_Class_Type **clp;
94
95 if (NULL == (t = Class_Tables[i]))
96 {
97 type = (SLtype) (i << 8);
98 clp = alloc_class_slot (type, &t);
99 if (clp != NULL)
100 {
101 *typep = type;
102 *tp = t;
103 }
104 return clp;
105 }
106
107 if (t->nclasses == 256)
108 continue;
109
110 clp = t->classes;
111
112 for (j = 0; j < 256; j++)
113 {
114 if (clp[j] == NULL)
115 {
116 *typep = (SLtype) ((i << 8) | j);
117 *tp = t;
118 return clp + j;
119 }
120 }
121
122 _pSLang_verror (SL_INTERNAL_ERROR, "Class table nclasses variable is out of sync");
123 return NULL;
124 }
125
126 return NULL;
127 }
128
lookup_class_by_name(SLCONST char * name)129 static SLang_Class_Type *lookup_class_by_name (SLCONST char *name)
130 {
131 unsigned int i;
132
133 for (i = 0; i < 256; i++)
134 {
135 Class_Table_Type *t = Class_Tables[i];
136 SLang_Class_Type **clp, **clpmax;
137
138 if (t == NULL)
139 continue;
140
141 clp = t->classes;
142 clpmax = t->classes + 256;
143
144 while (clp < clpmax)
145 {
146 SLang_Class_Type *cl;
147 if ((NULL != (cl = *clp))
148 && (0 == strcmp (cl->cl_name, name)))
149 return cl;
150 clp++;
151 }
152 }
153 return NULL;
154 }
155
_pSLclass_get_class(SLtype type)156 SLang_Class_Type *_pSLclass_get_class (SLtype type)
157 {
158 SLang_Class_Type *cl;
159
160 if (NULL == (cl = lookup_class (type)))
161 SLang_exit_error ("Application error: Type %d not registered", (int) type);
162
163 return cl;
164 }
165
SLclass_is_class_defined(SLtype type)166 int SLclass_is_class_defined (SLtype type)
167 {
168 return (NULL != lookup_class (type));
169 }
170
_pSLclass_copy_class(SLtype to,SLtype from)171 int _pSLclass_copy_class (SLtype to, SLtype from)
172 {
173 SLang_Class_Type *cl, **clp;
174 Class_Table_Type *t;
175
176 cl = _pSLclass_get_class (from);
177 if (NULL == (clp = alloc_class_slot (to, &t)))
178 return -1;
179
180 if (*clp != NULL)
181 {
182 _pSLang_verror (SL_APPLICATION_ERROR, "Class %d already exists", to);
183 SLang_exit_error ("Application error: Fatal error");
184 }
185 add_class_to_slot (t, clp, cl);
186 #if SLANG_OPTIMIZE_FOR_SPEED
187 _pSLang_set_class_info (to, cl);
188 #endif
189 return 0;
190 }
191
_pSLclass_get_ptr_to_value(SLang_Class_Type * cl,SLang_Object_Type * obj)192 VOID_STAR _pSLclass_get_ptr_to_value (SLang_Class_Type *cl,
193 SLang_Object_Type *obj)
194 {
195 VOID_STAR p;
196
197 switch (cl->cl_class_type)
198 {
199 case SLANG_CLASS_TYPE_MMT:
200 case SLANG_CLASS_TYPE_PTR:
201 case SLANG_CLASS_TYPE_SCALAR:
202 p = (VOID_STAR) &obj->v;
203 break;
204
205 case SLANG_CLASS_TYPE_VECTOR:
206 p = obj->v.ptr_val;
207 break;
208
209 default:
210 p = NULL;
211 }
212 return p;
213 }
214
SLclass_get_datatype_name(SLtype stype)215 SLFUTURE_CONST char *SLclass_get_datatype_name (SLtype stype)
216 {
217 SLang_Class_Type *cl;
218
219 cl = _pSLclass_get_class (stype);
220 return cl->cl_name;
221 }
222
method_undefined_error(SLtype type,SLCONST char * method,SLCONST char * name)223 static int method_undefined_error (SLtype type, SLCONST char *method, SLCONST char *name)
224 {
225 if (name == NULL) name = SLclass_get_datatype_name (type);
226
227 _pSLang_verror (SL_TYPE_MISMATCH, "%s method not defined for %s",
228 method, name);
229 return -1;
230 }
231
232 static int
scalar_vector_bin_op_result(int op,SLtype a,SLtype b,SLtype * c)233 scalar_vector_bin_op_result (int op, SLtype a, SLtype b,
234 SLtype *c)
235 {
236 (void) a; (void) b;
237 switch (op)
238 {
239 case SLANG_NE:
240 case SLANG_EQ:
241 *c = SLANG_CHAR_TYPE;
242 return 1;
243 }
244 return 0;
245 }
246
247 static int
scalar_vector_bin_op(int op,SLtype a_type,VOID_STAR ap,SLuindex_Type na,SLtype b_type,VOID_STAR bp,SLuindex_Type nb,VOID_STAR cp)248 scalar_vector_bin_op (int op,
249 SLtype a_type, VOID_STAR ap, SLuindex_Type na,
250 SLtype b_type, VOID_STAR bp, SLuindex_Type nb,
251 VOID_STAR cp)
252 {
253 char *c;
254 char *a, *b;
255 size_t da, db;
256 SLuindex_Type n, n_max;
257 size_t data_type_len;
258 SLang_Class_Type *cl;
259
260 (void) b_type;
261 cl = _pSLclass_get_class (a_type);
262
263 data_type_len = cl->cl_sizeof_type;
264
265 a = (char *) ap;
266 b = (char *) bp;
267 c = (char *) cp;
268
269 if (na == 1) da = 0; else da = data_type_len;
270 if (nb == 1) db = 0; else db = data_type_len;
271 if (na > nb) n_max = na; else n_max = nb;
272
273 switch (op)
274 {
275 default:
276 return 0;
277
278 case SLANG_NE:
279 for (n = 0; n < n_max; n++)
280 {
281 c[n] = (0 != memcmp (a, b, data_type_len));
282 a += da; b += db;
283 }
284 break;
285
286 case SLANG_EQ:
287 for (n = 0; n < n_max; n++)
288 {
289 c[n] = (0 == memcmp (a, b, data_type_len));
290 a += da; b += db;
291 }
292 break;
293 }
294 return 1;
295 }
296
scalar_fread(SLtype type,FILE * fp,VOID_STAR ptr,SLstrlen_Type desired,SLstrlen_Type * actual)297 static int scalar_fread (SLtype type, FILE *fp, VOID_STAR ptr,
298 SLstrlen_Type desired, SLstrlen_Type *actual)
299 {
300 char *buf = (char *)ptr;
301 size_t desired_bytes, actual_bytes;
302 size_t size = _pSLclass_get_class (type)->cl_sizeof_type;
303
304 desired_bytes = size * desired;
305 actual_bytes = 0;
306
307 while (desired_bytes)
308 {
309 size_t n;
310 int e;
311
312 errno = 0;
313 clearerr (fp);
314 n = fread (buf, 1, desired_bytes, fp);
315
316 actual_bytes += n;
317 if (n == desired_bytes)
318 break;
319
320 e = errno;
321 desired_bytes -= n;
322 buf += n;
323
324 /* clearerr (fp); */
325 #ifdef EINTR
326 if ((e == EINTR)
327 && (0 == SLang_handle_interrupt ()))
328 continue;
329 #endif
330 _pSLerrno_errno = e;
331 break;
332 }
333
334 if (actual_bytes % size)
335 {
336 /* Sigh. We failed to read a full object. */
337 }
338 *actual = actual_bytes / size;
339 return 0;
340 }
341
scalar_fwrite(SLtype type,FILE * fp,VOID_STAR ptr,SLstrlen_Type desired,SLstrlen_Type * actual)342 static int scalar_fwrite (SLtype type, FILE *fp, VOID_STAR ptr,
343 SLstrlen_Type desired, SLstrlen_Type *actual)
344 {
345 char *buf = (char *)ptr;
346 size_t desired_bytes, actual_bytes;
347 size_t size = _pSLclass_get_class (type)->cl_sizeof_type;
348
349 desired_bytes = size * desired;
350 actual_bytes = 0;
351
352 while (desired_bytes)
353 {
354 size_t n;
355 int e;
356
357 errno = 0;
358 clearerr (fp);
359 n = fwrite (buf, 1, desired_bytes, fp);
360
361 actual_bytes += n;
362 if (n == desired_bytes)
363 break;
364
365 e = errno;
366 desired_bytes -= n;
367 buf += n;
368
369 /* clearerr (fp); */
370 #ifdef EINTR
371 if ((e == EINTR)
372 && (0 == SLang_handle_interrupt ()))
373 continue;
374 #endif
375 _pSLerrno_errno = e;
376
377 /* Apparantly, the write can be interrupted returning a short item
378 * count but not set errno.
379 */
380 if (n == 0)
381 break;
382
383 /* See the comment in slstdio.c:signal_safe_fputs about this */
384 #ifdef EPIPE
385 if (e == EPIPE)
386 break;
387 #endif
388 }
389
390 if (actual_bytes % size)
391 {
392 /* Sigh. We failed to write out a full object. */
393 }
394 *actual = actual_bytes / size;
395 return 0;
396 }
397
vector_apush(SLtype type,VOID_STAR ptr)398 static int vector_apush (SLtype type, VOID_STAR ptr)
399 {
400 SLang_Class_Type *cl;
401
402 cl = _pSLclass_get_class (type);
403 return (*cl->cl_push)(type, (VOID_STAR) &ptr);
404 }
405
vector_apop(SLtype type,VOID_STAR ptr)406 static int vector_apop (SLtype type, VOID_STAR ptr)
407 {
408 SLang_Class_Type *cl;
409
410 cl = _pSLclass_get_class (type);
411 return (*cl->cl_pop)(type, (VOID_STAR) &ptr);
412 }
413
default_push_mmt(SLtype type_unused,VOID_STAR ptr)414 static int default_push_mmt (SLtype type_unused, VOID_STAR ptr)
415 {
416 SLang_MMT_Type *ref;
417
418 (void) type_unused;
419 ref = *(SLang_MMT_Type **) ptr;
420 return SLang_push_mmt (ref);
421 }
422
default_destroy_simple(SLtype type_unused,VOID_STAR ptr_unused)423 static void default_destroy_simple (SLtype type_unused, VOID_STAR ptr_unused)
424 {
425 (void) type_unused;
426 (void) ptr_unused;
427 }
428
default_destroy_user(SLtype type,VOID_STAR ptr)429 static void default_destroy_user (SLtype type, VOID_STAR ptr)
430 {
431 (void) type;
432 SLang_free_mmt (*(SLang_MMT_Type **) ptr);
433 }
434
default_pop(SLtype type,VOID_STAR ptr)435 static int default_pop (SLtype type, VOID_STAR ptr)
436 {
437 return SLclass_pop_ptr_obj (type, (VOID_STAR *) ptr);
438 }
439
default_datatype_deref(SLtype type)440 static int default_datatype_deref (SLtype type)
441 {
442 return method_undefined_error (type, "datatype_deref", NULL);
443 }
444
default_acopy(SLtype type,VOID_STAR from,VOID_STAR to)445 static int default_acopy (SLtype type, VOID_STAR from, VOID_STAR to)
446 {
447 SLang_Class_Type *cl;
448
449 cl = _pSLclass_get_class (type);
450 if (-1 == (*cl->cl_apush) (type, from))
451 return -1;
452 return (*cl->cl_apop) (type, to);
453 }
454
scalar_acopy(SLtype type,VOID_STAR from,VOID_STAR to)455 static int scalar_acopy (SLtype type, VOID_STAR from, VOID_STAR to)
456 {
457 memcpy ((char *)to, (char *)from, _pSLclass_get_class (type)->cl_sizeof_type);
458 return 0;
459 }
460
SLclass_dup_object(SLtype type,VOID_STAR from,VOID_STAR to)461 int SLclass_dup_object (SLtype type, VOID_STAR from, VOID_STAR to)
462 {
463 SLang_Class_Type *cl = _pSLclass_get_class (type);
464 return cl->cl_acopy (type, from, to);
465 }
466
default_dereference_object(SLtype type,VOID_STAR ptr)467 static int default_dereference_object (SLtype type, VOID_STAR ptr)
468 {
469 (void) ptr;
470 return method_undefined_error (type, "dereference", NULL);
471 }
472
default_string(SLtype stype,VOID_STAR v)473 static char *default_string (SLtype stype, VOID_STAR v)
474 {
475 char buf [256];
476 char *s;
477 #if SLANG_HAS_COMPLEX
478 double *cplx;
479 #endif
480 s = buf;
481
482 switch (stype)
483 {
484 case SLANG_STRING_TYPE:
485 s = *(char **) v;
486 break;
487
488 case SLANG_NULL_TYPE:
489 s = (char *) "NULL";
490 break;
491
492 case SLANG_DATATYPE_TYPE:
493 s = (char *) SLclass_get_datatype_name ((SLtype) *(int *)v);
494 break;
495
496 #if SLANG_HAS_COMPLEX
497 case SLANG_COMPLEX_TYPE:
498 cplx = *(double **) v;
499 if (cplx[1] < 0)
500 sprintf (s, "(%g - %gi)", cplx [0], -cplx [1]);
501 else
502 sprintf (s, "(%g + %gi)", cplx [0], cplx [1]);
503 break;
504 #endif
505 default:
506 s = (char *) SLclass_get_datatype_name (stype);
507 }
508
509 return SLmake_string (s);
510 }
511
512 static int
use_cmp_bin_op_result(int op,SLtype a,SLtype b,SLtype * c)513 use_cmp_bin_op_result (int op, SLtype a, SLtype b,
514 SLtype *c)
515 {
516 if (a != b)
517 return 0;
518 switch (op)
519 {
520 case SLANG_NE:
521 case SLANG_EQ:
522 case SLANG_LT:
523 case SLANG_LE:
524 case SLANG_GT:
525 case SLANG_GE:
526 *c = SLANG_INT_TYPE;
527 return 1;
528 }
529 return 0;
530 }
531
532 static int
use_cmp_bin_op(int op,SLtype a_type,VOID_STAR ap,SLuindex_Type na,SLtype b_type,VOID_STAR bp,SLuindex_Type nb,VOID_STAR cp)533 use_cmp_bin_op (int op,
534 SLtype a_type, VOID_STAR ap, SLuindex_Type na,
535 SLtype b_type, VOID_STAR bp, SLuindex_Type nb,
536 VOID_STAR cp)
537 {
538 int *c;
539 char *a, *b;
540 SLuindex_Type da, db;
541 SLuindex_Type n, n_max;
542 size_t data_type_len;
543 SLang_Class_Type *cl;
544 int (*cmp)(SLtype, VOID_STAR, VOID_STAR, int *);
545
546 (void) b_type;
547 cl = _pSLclass_get_class (a_type);
548 cmp = cl->cl_cmp;
549 data_type_len = cl->cl_sizeof_type;
550
551 a = (char *) ap;
552 b = (char *) bp;
553 c = (int *) cp;
554
555 if (na == 1) da = 0; else da = data_type_len;
556 if (nb == 1) db = 0; else db = data_type_len;
557 if (na > nb) n_max = na; else n_max = nb;
558
559 switch (op)
560 {
561 int result;
562
563 default:
564 return 0;
565
566 case SLANG_NE:
567 for (n = 0; n < n_max; n++)
568 {
569 if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
570 return -1;
571 c[n] = (result != 0);
572 a += da; b += db;
573 }
574 break;
575
576 case SLANG_EQ:
577 for (n = 0; n < n_max; n++)
578 {
579 if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
580 return -1;
581 c[n] = (result == 0);
582 a += da; b += db;
583 }
584 break;
585
586 case SLANG_GT:
587 for (n = 0; n < n_max; n++)
588 {
589 if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
590 return -1;
591 c[n] = (result > 0);
592 a += da; b += db;
593 }
594 break;
595 case SLANG_GE:
596 for (n = 0; n < n_max; n++)
597 {
598 if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
599 return -1;
600 c[n] = (result >= 0);
601 a += da; b += db;
602 }
603 break;
604 case SLANG_LT:
605 for (n = 0; n < n_max; n++)
606 {
607 if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
608 return -1;
609 c[n] = (result < 0);
610 a += da; b += db;
611 }
612 break;
613 case SLANG_LE:
614 for (n = 0; n < n_max; n++)
615 {
616 if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
617 return -1;
618 c[n] = (result <= 0);
619 a += da; b += db;
620 }
621 break;
622 }
623 return 1;
624 }
625
_pSLclass_is_same_obj(SLang_Object_Type * a,SLang_Object_Type * b)626 int _pSLclass_is_same_obj (SLang_Object_Type *a, SLang_Object_Type *b)
627 {
628 SLang_Class_Type *cl;
629 size_t sizeof_type;
630
631 if (a->o_data_type != b->o_data_type)
632 return 0;
633
634 cl = _pSLclass_get_class (a->o_data_type);
635 sizeof_type = cl->cl_sizeof_type;
636
637 switch (cl->cl_class_type)
638 {
639 case SLANG_CLASS_TYPE_MMT:
640 case SLANG_CLASS_TYPE_PTR:
641 return (a->v.ptr_val == b->v.ptr_val);
642
643 case SLANG_CLASS_TYPE_SCALAR:
644 return !memcmp (&a->v, &b->v, sizeof_type);
645
646 case SLANG_CLASS_TYPE_VECTOR:
647 return !memcmp (a->v.ptr_val, b->v.ptr_val, sizeof_type);
648 }
649 return 0;
650 }
651
do_default_eqs(SLang_Class_Type * a_cl,VOID_STAR pa,SLang_Class_Type * b_cl,VOID_STAR pb)652 static int do_default_eqs (SLang_Class_Type *a_cl, VOID_STAR pa,
653 SLang_Class_Type *b_cl, VOID_STAR pb)
654 {
655 SLang_Class_Type *c_cl;
656 int (*binary_fun) (int,
657 SLtype, VOID_STAR, SLuindex_Type,
658 SLtype, VOID_STAR, SLuindex_Type,
659 VOID_STAR);
660 VOID_STAR pc;
661 int ret;
662
663 if (NULL == (binary_fun = _pSLclass_get_binary_fun (SLANG_EQ, a_cl, b_cl, &c_cl, 0)))
664 {
665 if (a_cl != b_cl)
666 return 0;
667
668 switch (a_cl->cl_class_type)
669 {
670 case SLANG_CLASS_TYPE_MMT:
671 case SLANG_CLASS_TYPE_PTR:
672 return (*(VOID_STAR *)pa == *(VOID_STAR *)pb);
673
674 case SLANG_CLASS_TYPE_SCALAR:
675 case SLANG_CLASS_TYPE_VECTOR:
676 return !memcmp ((char *)pa, (char *)pb, a_cl->cl_sizeof_type);
677 }
678 return 0;
679 }
680
681 pc = c_cl->cl_transfer_buf;
682
683 if (1 != (*binary_fun) (SLANG_EQ, a_cl->cl_data_type, pa, 1, b_cl->cl_data_type, pb, 1, pc))
684 return 0;
685
686 /* apush will create a copy, so make sure we free after the push */
687 ret = (*c_cl->cl_apush)(c_cl->cl_data_type, pc);
688 (*c_cl->cl_adestroy)(c_cl->cl_data_type, pc);
689
690 if (ret != 0)
691 return -1;
692
693 if (-1 == SLang_pop_integer (&ret))
694 return -1;
695
696 return (ret != 0);
697 }
698
699 /* This stack business is necessary to avoid problems with circular references */
700 typedef struct Eqs_Stack_Type
701 {
702 SLang_Object_Type *a, *b;
703 struct Eqs_Stack_Type *next;
704 }
705 Eqs_Stack_Type;
706 static Eqs_Stack_Type *Eqs_Stack;
push_eqs_comparison(SLang_Object_Type * a,SLang_Object_Type * b)707 static int push_eqs_comparison (SLang_Object_Type *a, SLang_Object_Type *b)
708 {
709 Eqs_Stack_Type *s = Eqs_Stack;
710 while (s != NULL)
711 {
712 if (((s->a == a) && (s->b == b))
713 || ((s->b == a) || (s->a == b)))
714 return 1;
715
716 s = s->next;
717 }
718 s = (Eqs_Stack_Type *) SLmalloc (sizeof (Eqs_Stack_Type));
719 if (s == NULL)
720 return -1;
721 s->a = a;
722 s->b = b;
723 s->next = Eqs_Stack;
724 Eqs_Stack = s;
725 return 0;
726 }
727
pop_eqs_comparison(void)728 static void pop_eqs_comparison (void)
729 {
730 Eqs_Stack_Type *s = Eqs_Stack;
731 Eqs_Stack = s->next;
732 SLfree ((char *) s);
733 }
734
_pSLclass_obj_eqs(SLang_Object_Type * a,SLang_Object_Type * b)735 int _pSLclass_obj_eqs (SLang_Object_Type *a, SLang_Object_Type *b)
736 {
737 SLang_Class_Type *a_cl, *b_cl;
738 VOID_STAR pa, pb;
739 int (*eqs)(SLtype, VOID_STAR, SLtype, VOID_STAR);
740 int status;
741
742 a_cl = _pSLclass_get_class (a->o_data_type);
743 b_cl = _pSLclass_get_class (b->o_data_type);
744
745 pa = _pSLclass_get_ptr_to_value (a_cl, a);
746 pb = _pSLclass_get_ptr_to_value (b_cl, b);
747
748 if ((pa == NULL) || (pb == NULL))
749 return -1;
750
751 if ((NULL == (eqs = a_cl->cl_eqs))
752 && (NULL == (eqs = b_cl->cl_eqs)))
753 return do_default_eqs (a_cl, pa, b_cl, pb);
754
755 status = push_eqs_comparison (a, b);
756 if (status != 0)
757 return status;
758
759 status = (*eqs) (a->o_data_type, pa, b->o_data_type, pb);
760 pop_eqs_comparison ();
761 return status;
762 }
763
SLclass_get_class_id(SLang_Class_Type * cl)764 int SLclass_get_class_id (SLang_Class_Type *cl)
765 {
766 if (cl == NULL)
767 return -1;
768 return (int) cl->cl_data_type;
769 }
770
SLclass_allocate_class(SLFUTURE_CONST char * name)771 SLang_Class_Type *SLclass_allocate_class (SLFUTURE_CONST char *name)
772 {
773 SLang_Class_Type *cl;
774
775 if (NULL != (cl = lookup_class_by_name (name)))
776 {
777 _pSLang_verror (SL_DUPLICATE_DEFINITION, "Type name %s already exists", name);
778 return NULL;
779 }
780
781 cl = (SLang_Class_Type *) SLmalloc (sizeof (SLang_Class_Type));
782 if (cl == NULL) return NULL;
783
784 SLMEMSET ((char *) cl, 0, sizeof (SLang_Class_Type));
785
786 if (NULL == (cl->cl_name = SLang_create_slstring (name)))
787 {
788 SLfree ((char *) cl);
789 return NULL;
790 }
791
792 return cl;
793 }
794
SLang_push_datatype(SLtype data_type)795 int SLang_push_datatype (SLtype data_type)
796 {
797 /* This data type could be a copy of another type, e.g., short and
798 * int if they are the same size (Int16 == Short). So, make sure
799 * we push the original and not the copy.
800 */
801 data_type = _pSLclass_get_class (data_type)->cl_data_type;
802 return SLclass_push_int_obj (SLANG_DATATYPE_TYPE, data_type);
803 }
804
datatype_deref(SLtype type,VOID_STAR ptr)805 static int datatype_deref (SLtype type, VOID_STAR ptr)
806 {
807 SLang_Class_Type *cl;
808 int status;
809
810 /* The parser generated code for this as if a function call were to be
811 * made. However, we are calling the deref object routine
812 * instead of the function call. So, I must simulate the function call.
813 */
814 if (-1 == _pSL_increment_frame_pointer ())
815 return -1;
816
817 type = (SLtype) *(int *) ptr;
818 cl = _pSLclass_get_class (type);
819 status = (*cl->cl_datatype_deref) (type);
820
821 (void) _pSL_decrement_frame_pointer ();
822 return status;
823 }
824
datatype_push(SLtype type_unused,VOID_STAR ptr)825 static int datatype_push (SLtype type_unused, VOID_STAR ptr)
826 {
827 (void) type_unused;
828 return SLang_push_datatype (*(SLtype *) ptr);
829 }
830
SLang_pop_datatype(SLtype * type)831 int SLang_pop_datatype (SLtype *type)
832 {
833 int i;
834 if (-1 == SLclass_pop_int_obj (SLANG_DATATYPE_TYPE, &i))
835 return -1;
836
837 *type = (SLtype) i;
838 return 0;
839 }
840
datatype_pop(SLtype type,VOID_STAR ptr)841 static int datatype_pop (SLtype type, VOID_STAR ptr)
842 {
843 if (-1 == SLang_pop_datatype (&type))
844 return -1;
845
846 *(SLtype *) ptr = type;
847 return 0;
848 }
849
_pSLclass_init(void)850 int _pSLclass_init (void)
851 {
852 SLang_Class_Type *cl;
853
854 /* First initialize the container classes. This is so binary operations
855 * added later will work with them.
856 */
857 if (-1 == _pSLarray_init_slarray ())
858 return -1;
859
860 /* DataType_Type */
861 if (NULL == (cl = SLclass_allocate_class ("DataType_Type")))
862 return -1;
863 cl->cl_pop = datatype_pop;
864 cl->cl_push = datatype_push;
865 cl->cl_dereference = datatype_deref;
866 if (-1 == SLclass_register_class (cl, SLANG_DATATYPE_TYPE, sizeof(SLtype),
867 SLANG_CLASS_TYPE_SCALAR))
868 return -1;
869
870 return 0;
871 }
872
register_new_datatype(SLFUTURE_CONST char * name,SLtype type)873 static int register_new_datatype (SLFUTURE_CONST char *name, SLtype type)
874 {
875 return SLns_add_iconstant (NULL, name, SLANG_DATATYPE_TYPE, type);
876 }
877
SLclass_create_synonym(SLFUTURE_CONST char * name,SLtype type)878 int SLclass_create_synonym (SLFUTURE_CONST char *name, SLtype type)
879 {
880 if (NULL == _pSLclass_get_class (type))
881 return -1;
882
883 return register_new_datatype (name, type);
884 }
885
SLclass_register_class(SLang_Class_Type * cl,SLtype type,unsigned int type_size,SLclass_Type class_type)886 int SLclass_register_class (SLang_Class_Type *cl, SLtype type, unsigned int type_size, SLclass_Type class_type)
887 {
888 Class_Table_Type *t = NULL;
889 SLang_Class_Type **clp;
890 char *name;
891 int can_binop = 1; /* scalar_vector_bin_op should work
892 * for all data types.
893 */
894
895 if (type == SLANG_VOID_TYPE)
896 clp = find_empty_class_slot (&type, &t);
897 else
898 clp = alloc_class_slot (type, &t);
899
900 if (clp == NULL)
901 {
902 _pSLang_verror (SL_APPLICATION_ERROR, "Class type %d already in use", (int) type);
903 return -1;
904 }
905
906 cl->cl_data_type = type;
907 cl->cl_class_type = class_type;
908 name = cl->cl_name;
909
910 switch (class_type)
911 {
912 case SLANG_CLASS_TYPE_MMT:
913 if (cl->cl_push == NULL) cl->cl_push = default_push_mmt;
914 if (cl->cl_destroy == NULL)
915 return method_undefined_error (type, "destroy", name);
916 cl->cl_user_destroy_fun = cl->cl_destroy;
917 cl->cl_destroy = default_destroy_user;
918 type_size = sizeof (VOID_STAR);
919 break;
920
921 case SLANG_CLASS_TYPE_SCALAR:
922 if (cl->cl_destroy == NULL) cl->cl_destroy = default_destroy_simple;
923 if ((type_size == 0)
924 || (type_size > sizeof (_pSL_Object_Union_Type)))
925 {
926 _pSLang_verror (SL_INVALID_PARM,
927 "Type size for %s not appropriate for SCALAR type",
928 name);
929 return -1;
930 }
931 if (cl->cl_pop == NULL)
932 return method_undefined_error (type, "pop", name);
933 if (cl->cl_fread == NULL) cl->cl_fread = scalar_fread;
934 if (cl->cl_fwrite == NULL) cl->cl_fwrite = scalar_fwrite;
935 if (cl->cl_acopy == NULL) cl->cl_acopy = scalar_acopy;
936 if (cl->cl_dereference == NULL) cl->cl_dereference = cl->cl_push;
937 can_binop = 1;
938 break;
939
940 case SLANG_CLASS_TYPE_PTR:
941 if (cl->cl_destroy == NULL)
942 return method_undefined_error (type, "destroy", name);
943 type_size = sizeof (VOID_STAR);
944 break;
945
946 case SLANG_CLASS_TYPE_VECTOR:
947 if (cl->cl_destroy == NULL)
948 return method_undefined_error (type, "destroy", name);
949 if (cl->cl_pop == NULL)
950 return method_undefined_error (type, "pop", name);
951 cl->cl_apop = vector_apop;
952 cl->cl_apush = vector_apush;
953 cl->cl_adestroy = default_destroy_simple;
954 if (cl->cl_fread == NULL) cl->cl_fread = scalar_fread;
955 if (cl->cl_fwrite == NULL) cl->cl_fwrite = scalar_fwrite;
956 if (cl->cl_acopy == NULL) cl->cl_acopy = scalar_acopy;
957 if (cl->cl_dereference == NULL) cl->cl_dereference = cl->cl_push;
958 can_binop = 1;
959 break;
960
961 default:
962 _pSLang_verror (SL_INVALID_PARM, "%s: unknown class type (%d)", name, class_type);
963 return -1;
964 }
965
966 if (type_size == 0)
967 {
968 _pSLang_verror (SL_INVALID_PARM, "type size must be non-zero for %s", name);
969 return -1;
970 }
971
972 if (cl->cl_string == NULL) cl->cl_string = default_string;
973 if (cl->cl_acopy == NULL) cl->cl_acopy = default_acopy;
974 if (cl->cl_datatype_deref == NULL) cl->cl_datatype_deref = default_datatype_deref;
975
976 if (cl->cl_pop == NULL) cl->cl_pop = default_pop;
977
978 if (cl->cl_push == NULL)
979 return method_undefined_error (type, "push", name);
980
981 if (cl->cl_byte_code_destroy == NULL)
982 cl->cl_byte_code_destroy = cl->cl_destroy;
983 if (cl->cl_push_literal == NULL)
984 cl->cl_push_literal = cl->cl_push;
985
986 if (cl->cl_dereference == NULL)
987 cl->cl_dereference = default_dereference_object;
988
989 if (cl->cl_apop == NULL) cl->cl_apop = cl->cl_pop;
990 if (cl->cl_apush == NULL) cl->cl_apush = cl->cl_push;
991 if (cl->cl_adestroy == NULL) cl->cl_adestroy = cl->cl_destroy;
992 if (cl->cl_push_intrinsic == NULL) cl->cl_push_intrinsic = cl->cl_push;
993
994 if ((cl->cl_foreach == NULL)
995 || (cl->cl_foreach_open == NULL)
996 || (cl->cl_foreach_close == NULL))
997 {
998 cl->cl_foreach = _pSLarray_cl_foreach;
999 cl->cl_foreach_open = _pSLarray_cl_foreach_open;
1000 cl->cl_foreach_close = _pSLarray_cl_foreach_close;
1001 }
1002
1003 cl->cl_sizeof_type = type_size;
1004
1005 if (NULL == (cl->cl_transfer_buf = (VOID_STAR) SLmalloc (type_size)))
1006 return -1;
1007
1008 add_class_to_slot (t, clp, cl);
1009
1010 if (-1 == register_new_datatype (name, type))
1011 return -1;
1012
1013 if (cl->cl_cmp != NULL)
1014 {
1015 if (-1 == SLclass_add_binary_op (type, type, use_cmp_bin_op, use_cmp_bin_op_result))
1016 return -1;
1017 }
1018 else if (can_binop
1019 && (-1 == SLclass_add_binary_op (type, type, scalar_vector_bin_op, scalar_vector_bin_op_result)))
1020 return -1;
1021
1022 cl->cl_anytype_typecast = _pSLanytype_typecast;
1023
1024 return 0;
1025 }
1026
SLclass_add_math_op(SLtype type,int (* handler)(int,SLtype,VOID_STAR,SLuindex_Type,VOID_STAR),int (* result)(int,SLtype,SLtype *))1027 int SLclass_add_math_op (SLtype type,
1028 int (*handler)(int,
1029 SLtype, VOID_STAR, SLuindex_Type,
1030 VOID_STAR),
1031 int (*result) (int, SLtype, SLtype *))
1032 {
1033 SLang_Class_Type *cl = _pSLclass_get_class (type);
1034
1035 cl->cl_math_op = handler;
1036 cl->cl_math_op_result_type = result;
1037 return 0;
1038 }
1039
SLclass_add_binary_op(SLtype a,SLtype b,int (* f)(int,SLtype,VOID_STAR,SLuindex_Type,SLtype,VOID_STAR,SLuindex_Type,VOID_STAR),int (* r)(int,SLtype,SLtype,SLtype *))1040 int SLclass_add_binary_op (SLtype a, SLtype b,
1041 int (*f) (int,
1042 SLtype, VOID_STAR, SLuindex_Type,
1043 SLtype, VOID_STAR, SLuindex_Type,
1044 VOID_STAR),
1045 int (*r) (int, SLtype, SLtype, SLtype *))
1046 {
1047 SL_OOBinary_Type *ab;
1048 SLang_Class_Type *cl;
1049
1050 if ((f == NULL) || (r == NULL)
1051 || ((a == SLANG_VOID_TYPE) && (b == SLANG_VOID_TYPE)))
1052 {
1053 _pSLang_verror (SL_INVALID_PARM, "SLclass_add_binary_op");
1054 return -1;
1055 }
1056
1057 if (NULL == (ab = (SL_OOBinary_Type *) SLmalloc (sizeof(SL_OOBinary_Type))))
1058 return -1;
1059
1060 ab->binary_function = f;
1061 ab->binary_result = r;
1062
1063 if (a == SLANG_VOID_TYPE)
1064 {
1065 cl = _pSLclass_get_class (b);
1066 ab->data_type = a;
1067 ab->next = NULL;
1068 cl->cl_void_binary_this = ab;
1069 }
1070 else if (b == SLANG_VOID_TYPE)
1071 {
1072 cl = _pSLclass_get_class (a);
1073 ab->data_type = b;
1074 ab->next = NULL;
1075 cl->cl_this_binary_void = ab;
1076 }
1077 else
1078 {
1079 cl = _pSLclass_get_class (a);
1080 ab->next = cl->cl_binary_ops;
1081 ab->data_type = b;
1082 cl->cl_binary_ops = ab;
1083 }
1084
1085 if ((a != SLANG_ARRAY_TYPE)
1086 && (b != SLANG_ARRAY_TYPE))
1087 {
1088 if ((-1 == _pSLarray_add_bin_op (a))
1089 || (-1 == _pSLarray_add_bin_op (b)))
1090 return -1;
1091 }
1092
1093 return 0;
1094 }
1095
SLclass_add_unary_op(SLtype type,int (* f)(int,SLtype,VOID_STAR,SLuindex_Type,VOID_STAR),int (* r)(int,SLtype,SLtype *))1096 int SLclass_add_unary_op (SLtype type,
1097 int (*f)(int,
1098 SLtype, VOID_STAR, SLuindex_Type,
1099 VOID_STAR),
1100 int (*r)(int, SLtype, SLtype *))
1101 {
1102 SLang_Class_Type *cl;
1103
1104 cl = _pSLclass_get_class (type);
1105 if ((f == NULL) || (r == NULL))
1106 {
1107 _pSLang_verror (SL_INVALID_PARM, "SLclass_add_unary_op");
1108 return -1;
1109 }
1110
1111 cl->cl_unary_op = f;
1112 cl->cl_unary_op_result_type = r;
1113
1114 return 0;
1115 }
1116
1117 #if 0
1118 int _pSLclass_add_arith_unary_op (SLtype type,
1119 int (*f)(int,
1120 SLtype, VOID_STAR, unsigned int,
1121 VOID_STAR),
1122 int (*r)(int, SLtype, SLtype *))
1123 {
1124 SLang_Class_Type *cl;
1125
1126 cl = _pSLclass_get_class (type);
1127 if ((f == NULL) || (r == NULL))
1128 {
1129 _pSLang_verror (SL_INVALID_PARM, "SLclass_add_arith_unary_op");
1130 return -1;
1131 }
1132
1133 cl->cl_arith_unary_op = f;
1134 cl->cl_arith_unary_op_result_type = r;
1135
1136 return 0;
1137 }
1138 #endif
1139
SLclass_add_app_unary_op(SLtype type,int (* f)(int,SLtype,VOID_STAR,SLuindex_Type,VOID_STAR),int (* r)(int,SLtype,SLtype *))1140 int SLclass_add_app_unary_op (SLtype type,
1141 int (*f)(int,
1142 SLtype, VOID_STAR, SLuindex_Type,
1143 VOID_STAR),
1144 int (*r)(int, SLtype, SLtype *))
1145 {
1146 SLang_Class_Type *cl;
1147
1148 cl = _pSLclass_get_class (type);
1149 if ((f == NULL) || (r == NULL))
1150 {
1151 _pSLang_verror (SL_INVALID_PARM, "SLclass_add_app_unary_op");
1152 return -1;
1153 }
1154
1155 cl->cl_app_unary_op = f;
1156 cl->cl_app_unary_op_result_type = r;
1157
1158 return 0;
1159 }
1160
SLclass_set_pop_function(SLang_Class_Type * cl,int (* f)(SLtype,VOID_STAR))1161 int SLclass_set_pop_function (SLang_Class_Type *cl, int (*f)(SLtype, VOID_STAR))
1162 {
1163 if (cl == NULL) return -1;
1164 cl->cl_pop = f;
1165
1166 return 0;
1167 }
1168
SLclass_set_push_function(SLang_Class_Type * cl,int (* f)(SLtype,VOID_STAR))1169 int SLclass_set_push_function (SLang_Class_Type *cl, int (*f)(SLtype, VOID_STAR))
1170 {
1171 if (cl == NULL) return -1;
1172 cl->cl_push = f;
1173
1174 return 0;
1175 }
1176
SLclass_set_apush_function(SLang_Class_Type * cl,int (* f)(SLtype,VOID_STAR))1177 int SLclass_set_apush_function (SLang_Class_Type *cl, int (*f)(SLtype, VOID_STAR))
1178 {
1179 if (cl == NULL) return -1;
1180 cl->cl_apush = f;
1181
1182 return 0;
1183 }
1184
SLclass_set_acopy_function(SLang_Class_Type * cl,int (* f)(SLtype,VOID_STAR,VOID_STAR))1185 int SLclass_set_acopy_function (SLang_Class_Type *cl, int (*f)(SLtype, VOID_STAR, VOID_STAR))
1186 {
1187 if (cl == NULL) return -1;
1188 cl->cl_acopy = f;
1189
1190 return 0;
1191 }
1192
SLclass_set_deref_function(SLang_Class_Type * cl,int (* f)(SLtype,VOID_STAR))1193 int SLclass_set_deref_function (SLang_Class_Type *cl, int (*f)(SLtype, VOID_STAR))
1194 {
1195 if (cl == NULL) return -1;
1196 cl->cl_dereference = f;
1197
1198 return 0;
1199 }
1200
SLclass_set_eqs_function(SLang_Class_Type * cl,int (* f)(SLtype,VOID_STAR,SLtype,VOID_STAR))1201 int SLclass_set_eqs_function (SLang_Class_Type *cl, int (*f)(SLtype, VOID_STAR, SLtype, VOID_STAR))
1202 {
1203 if (cl == NULL) return -1;
1204 cl->cl_eqs = f;
1205
1206 return 0;
1207 }
1208
SLclass_set_length_function(SLang_Class_Type * cl,int (* f)(SLtype,VOID_STAR,SLuindex_Type *))1209 int SLclass_set_length_function (SLang_Class_Type *cl, int (*f)(SLtype, VOID_STAR, SLuindex_Type *))
1210 {
1211 if (cl == NULL) return -1;
1212 cl->cl_length = f;
1213
1214 return 0;
1215 }
1216
SLclass_set_is_container(SLang_Class_Type * cl,int ic)1217 int SLclass_set_is_container (SLang_Class_Type *cl, int ic)
1218 {
1219 if (cl == NULL)
1220 return -1;
1221 cl->is_container = ic;
1222 return 0;
1223 }
1224
SLclass_set_string_function(SLang_Class_Type * cl,char * (* f)(SLtype,VOID_STAR))1225 int SLclass_set_string_function (SLang_Class_Type *cl, char *(*f)(SLtype, VOID_STAR))
1226 {
1227 if (cl == NULL) return -1;
1228
1229 cl->cl_string = f;
1230 return 0;
1231 }
1232
SLclass_set_destroy_function(SLang_Class_Type * cl,void (* f)(SLtype,VOID_STAR))1233 int SLclass_set_destroy_function (SLang_Class_Type *cl, void (*f)(SLtype, VOID_STAR))
1234 {
1235 if (cl == NULL) return -1;
1236
1237 cl->cl_destroy = f;
1238 return 0;
1239 }
1240
SLclass_set_sget_function(SLang_Class_Type * cl,int (* f)(SLtype,SLFUTURE_CONST char *))1241 int SLclass_set_sget_function (SLang_Class_Type *cl, int (*f)(SLtype, SLFUTURE_CONST char *))
1242 {
1243 if (cl == NULL) return -1;
1244 cl->cl_sget = f;
1245 return 0;
1246 }
1247
SLclass_set_sput_function(SLang_Class_Type * cl,int (* f)(SLtype,SLFUTURE_CONST char *))1248 int SLclass_set_sput_function (SLang_Class_Type *cl, int (*f)(SLtype, SLFUTURE_CONST char *))
1249 {
1250 if (cl == NULL) return -1;
1251 cl->cl_sput = f;
1252 return 0;
1253 }
1254
SLclass_set_aget_function(SLang_Class_Type * cl,int (* f)(SLtype,unsigned int))1255 int SLclass_set_aget_function (SLang_Class_Type *cl, int (*f)(SLtype, unsigned int))
1256 {
1257 if (cl == NULL) return -1;
1258 cl->cl_aget = f;
1259 return 0;
1260 }
1261
SLclass_set_aput_function(SLang_Class_Type * cl,int (* f)(SLtype,unsigned int))1262 int SLclass_set_aput_function (SLang_Class_Type *cl, int (*f)(SLtype, unsigned int))
1263 {
1264 if (cl == NULL) return -1;
1265 cl->cl_aput = f;
1266 return 0;
1267 }
1268
SLclass_set_anew_function(SLang_Class_Type * cl,int (* f)(SLtype,unsigned int))1269 int SLclass_set_anew_function (SLang_Class_Type *cl, int (*f)(SLtype, unsigned int))
1270 {
1271 if (cl == NULL) return -1;
1272 cl->cl_anew = f;
1273 return 0;
1274 }
1275
SLclass_set_aelem_init_function(SLang_Class_Type * cl,int (* f)(SLtype,VOID_STAR))1276 int SLclass_set_aelem_init_function (SLang_Class_Type *cl, int (*f)(SLtype, VOID_STAR))
1277 {
1278 if (cl == NULL) return -1;
1279 cl->cl_init_array_object = f;
1280 return 0;
1281 }
1282
SLclass_set_foreach_functions(SLang_Class_Type * cl,SLang_Foreach_Context_Type * (* fe_open)(SLtype,unsigned int),int (* fe)(SLtype,SLang_Foreach_Context_Type *),void (* fe_close)(SLtype,SLang_Foreach_Context_Type *))1283 int SLclass_set_foreach_functions (SLang_Class_Type *cl,
1284 SLang_Foreach_Context_Type *(*fe_open)(SLtype, unsigned int),
1285 int (*fe)(SLtype, SLang_Foreach_Context_Type *),
1286 void (*fe_close)(SLtype, SLang_Foreach_Context_Type *))
1287 {
1288 if (cl == NULL)
1289 return -1;
1290
1291 if ((fe_open == NULL) || (fe == NULL) || (fe_close == NULL))
1292 {
1293 SLang_set_error (SL_APPLICATION_ERROR);
1294 return -1;
1295 }
1296 cl->cl_foreach_open = fe_open;
1297 cl->cl_foreach = fe;
1298 cl->cl_foreach_close = fe_close;
1299
1300 return 0;
1301 }
1302
1303 /* Misc */
_pSLclass_type_mismatch_error(SLtype a,SLtype b)1304 void _pSLclass_type_mismatch_error (SLtype a, SLtype b)
1305 {
1306 _pSLang_verror (SL_TYPE_MISMATCH, "Expecting %s, found %s",
1307 SLclass_get_datatype_name (a),
1308 SLclass_get_datatype_name (b));
1309 }
1310
1311 /* */
1312
null_binary_fun(int op,SLtype a,VOID_STAR ap,SLuindex_Type na,SLtype b,VOID_STAR bp,SLuindex_Type nb,VOID_STAR cp)1313 static int null_binary_fun (int op,
1314 SLtype a, VOID_STAR ap, SLuindex_Type na,
1315 SLtype b, VOID_STAR bp, SLuindex_Type nb,
1316 VOID_STAR cp)
1317 {
1318 char *ic;
1319 unsigned int i;
1320 char c;
1321
1322 (void) ap; (void) bp;
1323
1324 switch (op)
1325 {
1326 case SLANG_EQ:
1327 c = (a == b);
1328 break;
1329
1330 case SLANG_NE:
1331 c = (a != b);
1332 break;
1333
1334 default:
1335 return 0;
1336 }
1337
1338 if (na > nb) nb = na;
1339 ic = (char *) cp;
1340 for (i = 0; i < nb; i++)
1341 ic[i] = c;
1342
1343 return 1;
1344 }
1345
1346 static SLCONST char *Unary_Ops[SLANG_UNARY_OP_MAX-SLANG_UNARY_OP_MIN+2] =
1347 {
1348 "++", "--", "-", "not", "~", "abs", "sign", "sqr", "mul2", "_ispos", "_isneg", "_isnonneg", NULL
1349 };
1350
1351 static SLCONST char *Binary_Ops [SLANG_BINARY_OP_MAX - SLANG_BINARY_OP_MIN + 2] =
1352 {
1353 "+", "-", "*", "/", "==", "!=", ">", ">=", "<", "<=", "^",
1354 "or", "and", "&", "|", "xor", "shl", "shr", "mod", NULL
1355 };
1356
get_binary_unary_opcode(SLCONST char * name,SLCONST char ** tbl,int min_val)1357 static int get_binary_unary_opcode (SLCONST char *name, SLCONST char **tbl, int min_val)
1358 {
1359 SLCONST char **u;
1360
1361 u = tbl;
1362 while (*u != NULL)
1363 {
1364 if (0 == strcmp (name, *u))
1365 return min_val + (int) (u - tbl);
1366
1367 u++;
1368 }
1369
1370 _pSLang_verror (SL_NOT_IMPLEMENTED,
1371 "Binary/Unary function %s is unsupported", name);
1372 return -1;
1373 }
1374
_pSLclass_get_unary_opcode(SLCONST char * name)1375 int _pSLclass_get_unary_opcode (SLCONST char *name)
1376 {
1377 return get_binary_unary_opcode (name, Unary_Ops, SLANG_UNARY_OP_MIN);
1378 }
1379
_pSLclass_get_binary_opcode(SLCONST char * name)1380 int _pSLclass_get_binary_opcode (SLCONST char *name)
1381 {
1382 return get_binary_unary_opcode (name, Binary_Ops, SLANG_BINARY_OP_MIN);
1383 }
1384
get_binary_op_string(int op)1385 static SLCONST char *get_binary_op_string (int op)
1386 {
1387 if ((op < SLANG_BINARY_OP_MIN)
1388 || (op > SLANG_BINARY_OP_MAX))
1389 return "- ?? -"; /* Note: -??- is a trigraph (sigh) */
1390 return Binary_Ops[op - SLANG_BINARY_OP_MIN];
1391 }
1392
_pSLclass_get_binary_fun(int op,SLang_Class_Type * a_cl,SLang_Class_Type * b_cl,SLang_Class_Type ** c_cl,int do_error)1393 int (*_pSLclass_get_binary_fun (int op,
1394 SLang_Class_Type *a_cl, SLang_Class_Type *b_cl,
1395 SLang_Class_Type **c_cl, int do_error))
1396 (int,
1397 SLtype, VOID_STAR, SLuindex_Type,
1398 SLtype, VOID_STAR, SLuindex_Type,
1399 VOID_STAR)
1400 {
1401 SL_OOBinary_Type *bt;
1402 SL_OOBinary_Type *last;
1403 SLtype a, b, c;
1404
1405 a = a_cl->cl_data_type;
1406 b = b_cl->cl_data_type;
1407
1408 if ((a == SLANG_NULL_TYPE) || (b == SLANG_NULL_TYPE))
1409 {
1410 *c_cl = _pSLclass_get_class (SLANG_CHAR_TYPE);
1411 return &null_binary_fun;
1412 }
1413 bt = a_cl->cl_binary_ops;
1414 last = NULL;
1415
1416 while (bt != NULL)
1417 {
1418 if (bt->data_type == b)
1419 break;
1420
1421 last = bt;
1422 bt = bt->next;
1423 }
1424
1425 if ((last != NULL) && (bt != NULL))
1426 {
1427 last->next = bt->next;
1428 bt->next = a_cl->cl_binary_ops;
1429 a_cl->cl_binary_ops = bt;
1430 }
1431
1432 /* Did find find any specific function, so look for a more generic match */
1433 if ((bt != NULL)
1434 || (NULL != (bt = a_cl->cl_this_binary_void))
1435 || (NULL != (bt = b_cl->cl_void_binary_this)))
1436 {
1437 if (1 == (*bt->binary_result)(op, a, b, &c))
1438 {
1439 if (c == a) *c_cl = a_cl;
1440 else if (c == b) *c_cl = b_cl;
1441 else *c_cl = _pSLclass_get_class (c);
1442
1443 return bt->binary_function;
1444 }
1445 }
1446
1447 if (do_error)
1448 _pSLang_verror (SL_TYPE_MISMATCH, "%s %s %s is not possible",
1449 a_cl->cl_name, get_binary_op_string (op), b_cl->cl_name);
1450
1451 *c_cl = NULL;
1452 return NULL;
1453 }
1454
_pSLclass_get_unary_fun(int op,SLang_Class_Type * a_cl,SLang_Class_Type ** b_cl,int utype)1455 int (*_pSLclass_get_unary_fun (int op,
1456 SLang_Class_Type *a_cl,
1457 SLang_Class_Type **b_cl,
1458 int utype))
1459 (int, SLtype, VOID_STAR, SLuindex_Type, VOID_STAR)
1460 {
1461 int (*f)(int, SLtype, VOID_STAR, SLuindex_Type, VOID_STAR);
1462 int (*r)(int, SLtype, SLtype *);
1463 SLtype a;
1464 SLtype b;
1465
1466 switch (utype)
1467 {
1468 case SLANG_BC_ARITH_UNARY:
1469 case SLANG_BC_UNARY:
1470 f = a_cl->cl_unary_op;
1471 r = a_cl->cl_unary_op_result_type;
1472 break;
1473
1474 case SLANG_BC_MATH_UNARY:
1475 f = a_cl->cl_math_op;
1476 r = a_cl->cl_math_op_result_type;
1477 break;
1478
1479 case SLANG_BC_APP_UNARY:
1480 f = a_cl->cl_app_unary_op;
1481 r = a_cl->cl_app_unary_op_result_type;
1482 break;
1483
1484 default:
1485 f = NULL;
1486 r = NULL;
1487 }
1488
1489 a = a_cl->cl_data_type;
1490 if ((f != NULL) && (r != NULL) && (1 == (*r) (op, a, &b)))
1491 {
1492 if (a == b)
1493 *b_cl = a_cl;
1494 else
1495 *b_cl = _pSLclass_get_class (b);
1496 return f;
1497 }
1498
1499 _pSLang_verror (SL_TYPE_MISMATCH, "undefined unary operation/function on %s",
1500 a_cl->cl_name);
1501
1502 *b_cl = NULL;
1503
1504 return NULL;
1505 }
1506
1507 int
SLclass_typecast(SLtype to_type,int is_implicit,int allow_array)1508 SLclass_typecast (SLtype to_type, int is_implicit, int allow_array)
1509 {
1510 SLtype from_type;
1511 SLang_Class_Type *cl_to, *cl_from;
1512 SLang_Object_Type obj;
1513 VOID_STAR ap;
1514 VOID_STAR bp;
1515 int status;
1516
1517 if (-1 == SLang_pop (&obj))
1518 return -1;
1519
1520 from_type = obj.o_data_type;
1521 if (from_type == to_type)
1522 return SLang_push (&obj);
1523
1524 cl_from = _pSLclass_get_class (from_type);
1525 cl_to = _pSLclass_get_class (to_type);
1526
1527 /* Check for alias, e.g., int and long */
1528 if (cl_from == cl_to)
1529 {
1530 obj.o_data_type = to_type;
1531 return SLang_push (&obj);
1532 }
1533
1534 /* Since the typecast functions are designed to work on arrays,
1535 * get the pointer to the value instead of just &obj.v.
1536 */
1537 ap = _pSLclass_get_ptr_to_value (cl_from, &obj);
1538
1539 if ((from_type == SLANG_ARRAY_TYPE)
1540 && (allow_array || (to_type != SLANG_ANY_TYPE)))
1541 {
1542 if (allow_array == 0)
1543 goto return_error;
1544
1545 cl_to = _pSLclass_get_class (SLANG_ARRAY_TYPE);
1546 bp = cl_to->cl_transfer_buf;
1547 status = _pSLarray_typecast (from_type, ap, 1, to_type, bp, is_implicit);
1548 }
1549 else
1550 {
1551 int (*t) (SLtype, VOID_STAR, SLuindex_Type, SLtype, VOID_STAR);
1552
1553 if (NULL == (t = _pSLclass_get_typecast (from_type, to_type, is_implicit)))
1554 {
1555 SLang_free_object (&obj);
1556 return -1;
1557 }
1558
1559 bp = cl_to->cl_transfer_buf;
1560 status = (*t) (from_type, ap, 1, to_type, bp);
1561 }
1562
1563 if (1 == status)
1564 {
1565 /* AnyType apush will do a reference, which is undesirable here.
1566 * So, to avoid that, perform push instead of apush. Yes, this is
1567 * an ugly hack.
1568 */
1569 if (to_type == SLANG_ANY_TYPE)
1570 status = (*cl_to->cl_push)(to_type, bp);
1571 else
1572 status = (*cl_to->cl_apush)(to_type, bp);
1573
1574 if (status == -1)
1575 {
1576 (*cl_to->cl_adestroy) (to_type, bp);
1577 SLang_free_object (&obj);
1578 return -1;
1579 }
1580
1581 /* cl_apush will push a copy, so destry this one */
1582 (*cl_to->cl_adestroy) (to_type, bp);
1583 SLang_free_object (&obj);
1584 return 0;
1585 }
1586
1587 return_error:
1588
1589 _pSLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s",
1590 cl_from->cl_name,
1591 SLclass_get_datatype_name (to_type));
1592 SLang_free_object (&obj);
1593 return -1;
1594 }
1595
_pSLclass_get_typecast(SLtype from,SLtype to,int is_implicit)1596 int (*_pSLclass_get_typecast (SLtype from, SLtype to, int is_implicit))
1597 (SLtype, VOID_STAR, SLuindex_Type,
1598 SLtype, VOID_STAR)
1599 {
1600 SL_Typecast_Type *t;
1601 SLang_Class_Type *cl_from;
1602
1603 cl_from = _pSLclass_get_class (from);
1604
1605 t = cl_from->cl_typecast_funs;
1606 while (t != NULL)
1607 {
1608 if (t->data_type != to)
1609 {
1610 t = t->next;
1611 continue;
1612 }
1613
1614 if (is_implicit && (t->allow_implicit == 0))
1615 break;
1616
1617 return t->typecast;
1618 }
1619
1620 if (to == SLANG_ANY_TYPE)
1621 return &_pSLanytype_typecast;
1622
1623 if ((is_implicit == 0)
1624 && (cl_from->cl_void_typecast != NULL))
1625 return cl_from->cl_void_typecast;
1626
1627 _pSLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s",
1628 cl_from->cl_name,
1629 SLclass_get_datatype_name (to));
1630
1631 return NULL;
1632 }
1633
1634 int
SLclass_add_typecast(SLtype from,SLtype to,int (* f)_PROTO ((SLtype,VOID_STAR,SLuindex_Type,SLtype,VOID_STAR)),int allow_implicit)1635 SLclass_add_typecast (SLtype from, SLtype to,
1636 int (*f)_PROTO((SLtype, VOID_STAR, SLuindex_Type,
1637 SLtype, VOID_STAR)),
1638 int allow_implicit)
1639 {
1640 SL_Typecast_Type *t;
1641 SLang_Class_Type *cl;
1642
1643 cl = _pSLclass_get_class (from);
1644 if (to == SLANG_VOID_TYPE)
1645 {
1646 cl->cl_void_typecast = f;
1647 return 0;
1648 }
1649
1650 (void) _pSLclass_get_class (to);
1651
1652 if (NULL == (t = (SL_Typecast_Type *) SLmalloc (sizeof (SL_Typecast_Type))))
1653 return -1;
1654
1655 SLMEMSET((char *) t, 0, sizeof(SL_Typecast_Type));
1656 t->data_type = to;
1657 t->next = cl->cl_typecast_funs;
1658 t->typecast = f;
1659 t->allow_implicit = allow_implicit;
1660
1661 cl->cl_typecast_funs = t;
1662
1663 return 0;
1664 }
1665
SLang_pop_mmt(SLtype type)1666 SLang_MMT_Type *SLang_pop_mmt (SLtype type) /*{{{*/
1667 {
1668 SLang_MMT_Type *mmt;
1669 SLang_Class_Type *cl;
1670
1671 cl = lookup_class (type);
1672 if (cl == NULL)
1673 {
1674 _pSLang_verror (SL_Application_Error, "SLtype %d is not registered", type);
1675 return NULL;
1676 }
1677 if (cl->cl_class_type != SLANG_CLASS_TYPE_MMT)
1678 {
1679 _pSLang_verror (SL_Application_Error, "SLtype %d is not an MMT", type);
1680 return NULL;
1681 }
1682
1683 if (-1 == SLclass_pop_ptr_obj (type, VOID_STAR_STAR(&mmt)))
1684 mmt = NULL;
1685 return mmt;
1686
1687 #if 0
1688 SLang_Object_Type obj;
1689 SLang_Class_Type *cl;
1690
1691 if (_pSLang_pop_object_of_type (type, &obj))
1692 return NULL;
1693
1694 cl = _pSLclass_get_class (type);
1695 if ((cl->cl_class_type == SLANG_CLASS_TYPE_MMT)
1696 && (obj.data_type == type))
1697 {
1698 return obj.v.ref;
1699 }
1700
1701 _pSLclass_type_mismatch_error (type, obj.data_type);
1702 SLang_free_object (&obj);
1703 return NULL;
1704 #endif
1705 }
1706
1707 /*}}}*/
1708
SLang_push_mmt(SLang_MMT_Type * ref)1709 int SLang_push_mmt (SLang_MMT_Type *ref) /*{{{*/
1710 {
1711 if (ref == NULL)
1712 return SLang_push_null ();
1713
1714 ref->count += 1;
1715
1716 if (0 == SLclass_push_ptr_obj (ref->data_type, (VOID_STAR) ref))
1717 return 0;
1718
1719 ref->count -= 1;
1720 return -1;
1721 }
1722
1723 /*}}}*/
1724
SLang_inc_mmt(SLang_MMT_Type * ref)1725 void SLang_inc_mmt (SLang_MMT_Type *ref)
1726 {
1727 if (ref != NULL)
1728 ref->count += 1;
1729 }
1730
SLang_object_from_mmt(SLang_MMT_Type * ref)1731 VOID_STAR SLang_object_from_mmt (SLang_MMT_Type *ref)
1732 {
1733 if (ref == NULL)
1734 return NULL;
1735
1736 return ref->user_data;
1737 }
1738
SLang_create_mmt(SLtype t,VOID_STAR p)1739 SLang_MMT_Type *SLang_create_mmt (SLtype t, VOID_STAR p)
1740 {
1741 SLang_MMT_Type *ref;
1742
1743 (void) _pSLclass_get_class (t); /* check to see if it is registered */
1744
1745 if (NULL == (ref = (SLang_MMT_Type *) SLmalloc (sizeof (SLang_MMT_Type))))
1746 return NULL;
1747
1748 SLMEMSET ((char *) ref, 0, sizeof (SLang_MMT_Type));
1749
1750 ref->data_type = t;
1751 ref->user_data = p;
1752 /* FIXME!! To be consistent with other types, the reference count should
1753 * be set to 1 here. However, doing so will require other code changes
1754 * involving the use of MMTs. For instance, SLang_free_mmt would have
1755 * to be called after every push of the MMT.
1756 */
1757 return ref;
1758 }
1759
SLang_free_mmt(SLang_MMT_Type * ref)1760 void SLang_free_mmt (SLang_MMT_Type *ref)
1761 {
1762 SLtype type;
1763 SLang_Class_Type *cl;
1764
1765 if (ref == NULL)
1766 return;
1767
1768 /* This can be zero if SLang_create_mmt is called followed
1769 * by this routine before anything gets a chance to attach itself
1770 * to it.
1771 */
1772 if (ref->count > 1)
1773 {
1774 ref->count -= 1;
1775 return;
1776 }
1777
1778 type = ref->data_type;
1779 cl = _pSLclass_get_class (type);
1780 (*cl->cl_user_destroy_fun) (type, ref->user_data);
1781 SLfree ((char *)ref);
1782 }
1783
SLang_push_value(SLtype type,VOID_STAR v)1784 int SLang_push_value (SLtype type, VOID_STAR v)
1785 {
1786 SLang_Class_Type *cl;
1787
1788 cl = _pSLclass_get_class (type);
1789 return (*cl->cl_apush)(type, v);
1790 }
1791
SLang_pop_value(SLtype type,VOID_STAR v)1792 int SLang_pop_value (SLtype type, VOID_STAR v)
1793 {
1794 SLang_Class_Type *cl;
1795
1796 cl = _pSLclass_get_class (type);
1797 return (*cl->cl_apop)(type, v);
1798 }
1799
SLang_free_value(SLtype type,VOID_STAR v)1800 void SLang_free_value (SLtype type, VOID_STAR v)
1801 {
1802 SLang_Class_Type *cl;
1803
1804 cl = _pSLclass_get_class (type);
1805 (*cl->cl_adestroy) (type, v);
1806 }
1807
1808 /* These routines are very low-level and are designed for application data
1809 * types to access the stack from their push/pop methods. The int and
1810 * pointer versions are in slang.c
1811 */
1812 #if SLANG_HAS_FLOAT
SLclass_push_float_obj(SLtype type,float x)1813 int SLclass_push_float_obj (SLtype type, float x)
1814 {
1815 SLang_Object_Type obj;
1816 obj.o_data_type = type;
1817 obj.v.float_val = x;
1818 return SLang_push (&obj);
1819 }
1820 #endif
1821
SLclass_push_long_obj(SLtype type,long x)1822 int SLclass_push_long_obj (SLtype type, long x)
1823 {
1824 SLang_Object_Type obj;
1825 obj.o_data_type = type;
1826 obj.v.long_val = x;
1827 return SLang_push (&obj);
1828 }
1829
1830 #ifdef HAVE_LONG_LONG
SLclass_push_llong_obj(SLtype type,long long x)1831 int SLclass_push_llong_obj (SLtype type, long long x)
1832 {
1833 SLang_Object_Type obj;
1834 obj.o_data_type = type;
1835 obj.v.llong_val = x;
1836 return SLang_push (&obj);
1837 }
1838 #endif
1839
SLclass_push_short_obj(SLtype type,short x)1840 int SLclass_push_short_obj (SLtype type, short x)
1841 {
1842 SLang_Object_Type obj;
1843 obj.o_data_type = type;
1844 obj.v.short_val = x;
1845 return SLang_push (&obj);
1846 }
1847
1848 #if SLANG_HAS_FLOAT
SLclass_pop_double_obj(SLtype type,double * x)1849 int SLclass_pop_double_obj (SLtype type, double *x)
1850 {
1851 SLang_Object_Type obj;
1852
1853 if (-1 == _pSLang_pop_object_of_type (type, &obj, 0))
1854 return -1;
1855
1856 *x = obj.v.double_val;
1857 return 0;
1858 }
1859
SLclass_pop_float_obj(SLtype type,float * x)1860 int SLclass_pop_float_obj (SLtype type, float *x)
1861 {
1862 SLang_Object_Type obj;
1863
1864 if (-1 == _pSLang_pop_object_of_type (type, &obj, 0))
1865 return -1;
1866
1867 *x = obj.v.float_val;
1868 return 0;
1869 }
1870 #endif
1871
SLclass_pop_long_obj(SLtype type,long * x)1872 int SLclass_pop_long_obj (SLtype type, long *x)
1873 {
1874 SLang_Object_Type obj;
1875
1876 if (-1 == _pSLang_pop_object_of_type (type, &obj, 0))
1877 return -1;
1878
1879 *x = obj.v.long_val;
1880 return 0;
1881 }
1882
SLclass_pop_int_obj(SLtype type,int * x)1883 int SLclass_pop_int_obj (SLtype type, int *x)
1884 {
1885 SLang_Object_Type obj;
1886
1887 if (-1 == _pSLang_pop_object_of_type (type, &obj, 0))
1888 return -1;
1889
1890 *x = obj.v.int_val;
1891 return 0;
1892 }
1893
SLclass_pop_short_obj(SLtype type,short * x)1894 int SLclass_pop_short_obj (SLtype type, short *x)
1895 {
1896 SLang_Object_Type obj;
1897
1898 if (-1 == _pSLang_pop_object_of_type (type, &obj, 0))
1899 return -1;
1900
1901 *x = obj.v.short_val;
1902 return 0;
1903 }
1904
SLclass_pop_char_obj(SLtype type,char * x)1905 int SLclass_pop_char_obj (SLtype type, char *x)
1906 {
1907 SLang_Object_Type obj;
1908
1909 if (-1 == _pSLang_pop_object_of_type (type, &obj, 0))
1910 return -1;
1911
1912 *x = obj.v.char_val;
1913 return 0;
1914 }
1915
SLang_get_int_type(int nbits)1916 SLtype SLang_get_int_type (int nbits)
1917 {
1918 switch (nbits)
1919 {
1920 case -8:
1921 return SLANG_CHAR_TYPE;
1922 case 8:
1923 return SLANG_UCHAR_TYPE;
1924 case -16:
1925 return _pSLANG_INT16_TYPE;
1926 case 16:
1927 return _pSLANG_UINT16_TYPE;
1928 case -32:
1929 return _pSLANG_INT32_TYPE;
1930 case 32:
1931 return _pSLANG_UINT32_TYPE;
1932 case -64:
1933 return _pSLANG_INT64_TYPE;
1934 case 64:
1935 return _pSLANG_UINT64_TYPE;
1936 }
1937 return 0;
1938 }
1939
SLang_get_int_size(SLtype type)1940 int SLang_get_int_size (SLtype type)
1941 {
1942 switch (type)
1943 {
1944 case 0:
1945 return 0;
1946 case SLANG_CHAR_TYPE:
1947 return -8;
1948 case SLANG_UCHAR_TYPE:
1949 return 8;
1950 case _pSLANG_INT16_TYPE:
1951 return -16;
1952 case _pSLANG_UINT16_TYPE:
1953 return 16;
1954 case _pSLANG_INT32_TYPE:
1955 return -32;
1956 case _pSLANG_UINT32_TYPE:
1957 return 32;
1958 default:
1959 if (type == _pSLANG_INT64_TYPE)
1960 return -64;
1961 if (type == _pSLANG_UINT64_TYPE)
1962 return 64;
1963 }
1964 return 0;
1965 }
1966
SLclass_patch_intrin_fun_table(SLang_Intrin_Fun_Type * table,SLtype * from_types,SLtype * to_types,unsigned int n)1967 int SLclass_patch_intrin_fun_table (SLang_Intrin_Fun_Type *table,
1968 SLtype *from_types, SLtype *to_types, unsigned int n)
1969 {
1970 unsigned int i, j;
1971
1972 for (i = 0; i < n; i++)
1973 {
1974 SLang_Intrin_Fun_Type *t = table;
1975 SLtype dummy = from_types[i];
1976 SLtype type = to_types[i];
1977
1978 while (t->name != NULL)
1979 {
1980 unsigned int nargs = t->num_args;
1981 SLtype *args = t->arg_types;
1982
1983 for (j = 0; j < nargs; j++)
1984 {
1985 if (args[j] == dummy)
1986 args[j] = type;
1987 }
1988
1989 /* For completeness */
1990 if (t->return_type == dummy)
1991 t->return_type = type;
1992 t++;
1993 }
1994 }
1995 return 0;
1996 }
SLclass_patch_intrin_fun_table1(SLang_Intrin_Fun_Type * table,SLtype from_type,SLtype to_type)1997 int SLclass_patch_intrin_fun_table1 (SLang_Intrin_Fun_Type *table,
1998 SLtype from_type, SLtype to_type)
1999 {
2000 return SLclass_patch_intrin_fun_table (table, &from_type, &to_type, 1);
2001 }
2002
2003