1 /******************************** -*- C -*- ****************************
2 *
3 * C Callin facilities
4 *
5 * This module provides many routines to allow C code to invoke
6 * Smalltalk messages on objects, most of which are based on
7 * low-level facilities exposed by interp.c and dict.c.
8 *
9 *
10 ***********************************************************************/
11
12
13 /***********************************************************************
14 *
15 * Copyright 1988,89,90,91,92,94,95,99,2000,2001,2002,2006,2008,2009
16 * Free Software Foundation, Inc.
17 * Written by Steve Byrne.
18 *
19 * This file is part of GNU Smalltalk.
20 *
21 * GNU Smalltalk is free software; you can redistribute it and/or modify it
22 * under the terms of the GNU General Public License as published by the Free
23 * Software Foundation; either version 2, or (at your option) any later
24 * version.
25 *
26 * Linking GNU Smalltalk statically or dynamically with other modules is
27 * making a combined work based on GNU Smalltalk. Thus, the terms and
28 * conditions of the GNU General Public License cover the whole
29 * combination.
30 *
31 * In addition, as a special exception, the Free Software Foundation
32 * give you permission to combine GNU Smalltalk with free software
33 * programs or libraries that are released under the GNU LGPL and with
34 * independent programs running under the GNU Smalltalk virtual machine.
35 *
36 * You may copy and distribute such a system following the terms of the
37 * GNU GPL for GNU Smalltalk and the licenses of the other code
38 * concerned, provided that you include the source code of that other
39 * code when and as the GNU GPL requires distribution of source code.
40 *
41 * Note that people who make modified versions of GNU Smalltalk are not
42 * obligated to grant this special exception for their modified
43 * versions; it is their choice whether to do so. The GNU General
44 * Public License gives permission to release a modified version without
45 * this exception; this exception also makes it possible to release a
46 * modified version which carries forward this exception.
47 *
48 * GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
49 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
50 * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
51 * more details.
52 *
53 * You should have received a copy of the GNU General Public License along with
54 * GNU Smalltalk; see the file COPYING. If not, write to the Free Software
55 * Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
56 *
57 ***********************************************************************/
58
59 #include "gstpriv.h"
60 #include "gstpub.h"
61
62 #ifndef NAN
63 #define NAN (0.0 / 0.0)
64 #endif
65
66 typedef struct oop_registry
67 {
68 rb_node_t rb;
69 OOP oop;
70 int usage;
71 }
72 oop_registry;
73
74 typedef struct oop_array_registry
75 {
76 rb_node_t rb;
77 OOP **first;
78 OOP **last;
79 int usage;
80 }
81 oop_array_registry;
82
83
84 /* The registry of OOPs which have been passed to C code. Implemented
85 as a red-black tree. The registry is examined at GC time to ensure
86 that OOPs that C code knows about don't go away. */
87 static oop_registry *oop_registry_root;
88 static oop_array_registry *oop_array_registry_root;
89
90 OOP
_gst_va_msg_send(OOP receiver,OOP selector,va_list ap)91 _gst_va_msg_send (OOP receiver,
92 OOP selector,
93 va_list ap)
94 {
95 va_list save;
96 OOP *args, anArg;
97 int numArgs;
98
99 if (!_gst_smalltalk_initialized)
100 _gst_initialize (NULL, NULL, GST_NO_TTY);
101
102 #ifdef __va_copy
103 __va_copy (save, ap);
104 #else
105 save = ap;
106 #endif
107
108 for (numArgs = 0; va_arg (ap, OOP) != NULL; numArgs++)
109 ;
110
111 if (numArgs != _gst_selector_num_args (selector))
112 return (_gst_nil_oop);
113 else
114 {
115 args = (OOP *) alloca (sizeof (OOP) * numArgs);
116 for (numArgs = 0; (anArg = va_arg (save, OOP)) != NULL; numArgs++)
117 args[numArgs] = anArg;
118
119 return _gst_nvmsg_send (receiver, selector, args, numArgs);
120 }
121 }
122
123 OOP
_gst_msg_send(OOP receiver,OOP selector,...)124 _gst_msg_send (OOP receiver,
125 OOP selector,
126 ...)
127 {
128 va_list ap;
129
130 va_start (ap, selector);
131 return _gst_va_msg_send (receiver, selector, ap);
132 }
133
134 OOP
_gst_vmsg_send(OOP receiver,OOP selector,OOP * args)135 _gst_vmsg_send (OOP receiver,
136 OOP selector,
137 OOP * args)
138 {
139 int numArgs;
140
141 if (!_gst_smalltalk_initialized)
142 _gst_initialize (NULL, NULL, GST_NO_TTY);
143
144 for (numArgs = 0; args[numArgs]; numArgs++);
145
146 if (numArgs != _gst_selector_num_args (selector))
147 return (_gst_nil_oop);
148 else
149 return _gst_nvmsg_send (receiver, selector, args, numArgs);
150 }
151
152 OOP
_gst_str_msg_send(OOP receiver,const char * sel,...)153 _gst_str_msg_send (OOP receiver,
154 const char *sel,
155 ...)
156 {
157 va_list ap;
158 OOP selector = _gst_symbol_to_oop (sel);
159 va_start (ap, sel);
160 return _gst_va_msg_send (receiver, selector, ap);
161 }
162
163 /* Use like printf */
164 void
_gst_va_msg_sendf(PTR resultPtr,const char * fmt,va_list ap)165 _gst_va_msg_sendf (PTR resultPtr,
166 const char *fmt,
167 va_list ap)
168 {
169 OOP selector, *args, result;
170 int i, numArgs;
171 const char *fp;
172 char *s, selectorBuf[256];
173 inc_ptr incPtr;
174 mst_Boolean receiver_is_block = false;
175
176 if (!_gst_smalltalk_initialized)
177 _gst_initialize (NULL, NULL, GST_NO_TTY);
178
179 incPtr = INC_SAVE_POINTER ();
180
181 numArgs = 0;
182 for (s = selectorBuf, fp = &fmt[2]; *fp; fp++)
183 {
184 if (*fp == '%')
185 {
186 fp++;
187 numArgs++;
188 if (*fp == '%')
189 {
190 *s++ = '%';
191 numArgs--;
192 }
193 else if (*fp == 'B')
194 receiver_is_block = true;
195 }
196 else if (*fp != ' ' && *fp != '\t')
197 *s++ = *fp;
198 }
199
200 *s = '\0';
201
202 if (receiver_is_block)
203 selector = NULL;
204 else
205 selector = _gst_intern_string (selectorBuf);
206
207 if (numArgs != 1 + _gst_selector_num_args (selector))
208 return;
209
210 args = (OOP *) alloca (sizeof (OOP) * numArgs);
211 for (i = -1, fp = &fmt[2]; *fp; fp++)
212 {
213 if (*fp != '%')
214 continue;
215
216 fp++;
217 switch (*fp)
218 {
219 case 'i':
220 args[++i] = FROM_C_INT (va_arg (ap, long));
221 INC_ADD_OOP (args[i]);
222 break;
223
224 case 'f':
225 args[++i] = floatd_new (va_arg (ap, double));
226 INC_ADD_OOP (args[i]);
227 break;
228
229 case 'F':
230 args[++i] = floatq_new (va_arg (ap, long double));
231 INC_ADD_OOP (args[i]);
232 break;
233
234 case 'b':
235 args[++i] = va_arg (ap, int) ? _gst_true_oop : _gst_false_oop;
236 INC_ADD_OOP (args[i]);
237 break;
238
239 case 'c':
240 args[++i] = CHAR_OOP_AT ((char) va_arg (ap, int));
241 INC_ADD_OOP (args[i]);
242 break;
243
244 case 'C':
245 args[++i] = COBJECT_NEW (va_arg (ap, PTR), _gst_nil_oop,
246 _gst_c_object_class);
247 INC_ADD_OOP (args[i]);
248 break;
249
250 case 's':
251 args[++i] = _gst_string_new (va_arg (ap, const char *));
252 INC_ADD_OOP (args[i]);
253 break;
254
255 case 'S':
256 args[++i] = _gst_intern_string (va_arg (ap, const char *));
257 INC_ADD_OOP (args[i]);
258 break;
259
260 case 'B':
261 case 'o':
262 args[++i] = va_arg (ap, OOP);
263 INC_ADD_OOP (args[i]);
264 break;
265
266 case 't': /* type string, followed by a void * */
267 {
268 OOP ctype;
269 ctype = _gst_type_name_to_oop (va_arg (ap, const char *));
270 INC_ADD_OOP (ctype);
271
272 args[++i] = COBJECT_NEW (va_arg (ap, PTR), ctype, _gst_nil_oop);
273
274 INC_ADD_OOP (args[i]);
275 }
276 break;
277
278
279 case 'T': /* existing type instance, and a void * */
280 {
281 OOP ctype;
282 ctype = va_arg (ap, OOP);
283 args[++i] = COBJECT_NEW (va_arg (ap, PTR), ctype, _gst_nil_oop);
284
285 INC_ADD_OOP (args[i]);
286 }
287 break;
288
289 case 'w':
290 #if SIZEOF_WCHAR_T <= SIZEOF_INT
291 args[++i] = char_new ((wchar_t) va_arg (ap, int));
292 #else
293 args[++i] = char_new ((wchar_t) va_arg (ap, wchar_t));
294 #endif
295 INC_ADD_OOP (args[i]);
296 break;
297
298 case 'W':
299 args[++i] = _gst_unicode_string_new (va_arg (ap, const wchar_t *));
300 INC_ADD_OOP (args[i]);
301 break;
302 }
303 }
304
305 result = _gst_nvmsg_send (args[0], selector, args + 1, numArgs - 1);
306
307 if (resultPtr)
308 {
309 switch (fmt[1])
310 {
311 case 'i':
312 *(int *) resultPtr = IS_NIL (result) ? 0 : TO_C_INT (result);
313 break;
314
315 case 'c':
316 *(char *) resultPtr =
317 IS_NIL (result) ? 0 : CHAR_OOP_VALUE (result);
318 break;
319
320 case 'C':
321 *(PTR *) resultPtr =
322 IS_NIL (result) ? NULL : cobject_value (result);
323 break;
324
325 case 's':
326 *(char **) resultPtr =
327 IS_NIL (result) ? NULL : (char *) _gst_to_cstring (result);
328 break;
329
330 case 'b':
331 *(int *) resultPtr =
332 IS_NIL (result) ? false : (result == _gst_true_oop);
333 break;
334
335 case 'f':
336 *(double *) resultPtr =
337 IS_NIL (result) ? 0.0 : _gst_oop_to_float (result);
338 break;
339
340 case 'F':
341 *(long double *) resultPtr =
342 IS_NIL (result) ? 0.0 : _gst_oop_to_long_double (result);
343 break;
344
345 case 'v': /* don't care about the result */
346 break; /* "v" for "void" */
347
348 case '?':
349 *(long *) resultPtr = _gst_oop_to_c (result);
350 break;
351
352 case 'w':
353 *(wchar_t *) resultPtr =
354 IS_NIL (result) ? 0 : CHAR_OOP_VALUE (result);
355 break;
356
357 case 'W':
358 *(wchar_t **) resultPtr =
359 IS_NIL (result) ? NULL : _gst_to_wide_cstring (result);
360 break;
361
362 case 'o':
363 default:
364 *(OOP *) resultPtr = result;
365 break;
366 }
367 }
368
369 INC_RESTORE_POINTER (incPtr);
370 }
371
372
373 void
_gst_msg_sendf(PTR resultPtr,const char * fmt,...)374 _gst_msg_sendf (PTR resultPtr,
375 const char *fmt,
376 ...)
377 {
378 va_list ap;
379 va_start (ap, fmt);
380 _gst_va_msg_sendf (resultPtr, fmt, ap);
381 }
382
383 OOP
_gst_type_name_to_oop(const char * name)384 _gst_type_name_to_oop (const char *name)
385 {
386 OOP result;
387 char buf[300];
388
389 sprintf (buf, "^%s!", name);
390
391 result = _gst_eval_expr (buf);
392 return (result);
393 }
394
395
396 void
_gst_eval_code(const char * str)397 _gst_eval_code (const char *str)
398 {
399 if (!_gst_smalltalk_initialized)
400 _gst_initialize (NULL, NULL, GST_NO_TTY);
401
402 _gst_push_cstring (str);
403 _gst_parse_stream (false);
404 _gst_pop_stream (true);
405 }
406
407
408 OOP
_gst_eval_expr(const char * str)409 _gst_eval_expr (const char *str)
410 {
411 OOP result;
412
413 if (!_gst_smalltalk_initialized)
414 _gst_initialize (NULL, NULL, GST_NO_TTY);
415
416 _gst_push_cstring (str);
417 _gst_parse_stream (false);
418 _gst_pop_stream (true);
419 result = _gst_last_returned_value;
420
421 return (result);
422 }
423
424 OOP
_gst_object_alloc(OOP class_oop,int size)425 _gst_object_alloc (OOP class_oop,
426 int size)
427 {
428 OOP oop;
429
430 if (CLASS_IS_INDEXABLE (class_oop))
431 instantiate_with (class_oop, size, &oop);
432 else
433 instantiate (class_oop, &oop);
434
435 INC_ADD_OOP (oop);
436 return oop;
437 }
438
439 int
_gst_basic_size(OOP oop)440 _gst_basic_size (OOP oop)
441 {
442 return (NUM_INDEXABLE_FIELDS (oop));
443 }
444
445
446 /***********************************************************************
447 *
448 * Conversion *to* Smalltalk datatypes routines
449 *
450 ***********************************************************************/
451
452 OOP
_gst_class_name_to_oop(const char * name)453 _gst_class_name_to_oop (const char *name)
454 {
455 OOP result, key;
456 char *s, *p, *prev_p;
457
458 if (!name || !*name)
459 return NULL;
460
461 s = strdup (name);
462 if (!_gst_smalltalk_initialized)
463 _gst_initialize (NULL, NULL, GST_NO_TTY);
464
465 result = _gst_smalltalk_dictionary;
466 for (p = s; (prev_p = strsep (&p, ".")) != NULL; )
467 {
468 key = _gst_intern_string (prev_p);
469 result = dictionary_at (result, key);
470 if (IS_NIL (result))
471 return NULL;
472 }
473
474 free (s);
475 return (result);
476 }
477
478
479 OOP
_gst_uint_to_oop(unsigned long int i)480 _gst_uint_to_oop (unsigned long int i)
481 {
482 if (!_gst_smalltalk_initialized)
483 _gst_initialize (NULL, NULL, GST_NO_TTY);
484
485 return (FROM_C_ULONG (i));
486 }
487
488 OOP
_gst_int_to_oop(long int i)489 _gst_int_to_oop (long int i)
490 {
491 if (!_gst_smalltalk_initialized)
492 _gst_initialize (NULL, NULL, GST_NO_TTY);
493
494 return (FROM_C_LONG (i));
495 }
496
497 OOP
_gst_id_to_oop(long int i)498 _gst_id_to_oop (long int i)
499 {
500 if (!_gst_smalltalk_initialized)
501 _gst_initialize (NULL, NULL, GST_NO_TTY);
502
503 return (OOP_AT (i));
504 }
505
506 OOP
_gst_long_double_to_oop(long double f)507 _gst_long_double_to_oop (long double f)
508 {
509 return (INC_ADD_OOP (floatq_new (f)));
510 }
511
512 OOP
_gst_float_to_oop(double f)513 _gst_float_to_oop (double f)
514 {
515 return (INC_ADD_OOP (floatd_new (f)));
516 }
517
518 OOP
_gst_bool_to_oop(int b)519 _gst_bool_to_oop (int b)
520 {
521 if (!_gst_smalltalk_initialized)
522 _gst_initialize (NULL, NULL, GST_NO_TTY);
523
524 if (b)
525 return (_gst_true_oop);
526 else
527 return (_gst_false_oop);
528 }
529
530
531 OOP
_gst_char_to_oop(char c)532 _gst_char_to_oop (char c)
533 {
534 if (!_gst_smalltalk_initialized)
535 _gst_initialize (NULL, NULL, GST_NO_TTY);
536
537 return (CHAR_OOP_AT (c));
538 }
539
540 OOP
_gst_wchar_to_oop(wchar_t wc)541 _gst_wchar_to_oop (wchar_t wc)
542 {
543 if (!_gst_smalltalk_initialized)
544 _gst_initialize (NULL, NULL, GST_NO_TTY);
545
546 return (char_new (wc));
547 }
548
549
550 /* !!! Add in byteArray support sometime soon */
551
552 OOP
_gst_string_to_oop(const char * str)553 _gst_string_to_oop (const char *str)
554 {
555 if (!_gst_smalltalk_initialized)
556 _gst_initialize (NULL, NULL, GST_NO_TTY);
557
558 if (str == NULL)
559 return (_gst_nil_oop);
560 else
561 return (INC_ADD_OOP (_gst_string_new (str)));
562 }
563
564 OOP
_gst_wstring_to_oop(const wchar_t * str)565 _gst_wstring_to_oop (const wchar_t *str)
566 {
567 if (!_gst_smalltalk_initialized)
568 _gst_initialize (NULL, NULL, GST_NO_TTY);
569
570 if (str == NULL)
571 return (_gst_nil_oop);
572 else
573 return (INC_ADD_OOP (_gst_unicode_string_new (str)));
574 }
575
576 OOP
_gst_byte_array_to_oop(const char * str,int n)577 _gst_byte_array_to_oop (const char *str,
578 int n)
579 {
580 if (!_gst_smalltalk_initialized)
581 _gst_initialize (NULL, NULL, GST_NO_TTY);
582
583 if (str == NULL)
584 return (_gst_nil_oop);
585 else
586 return (INC_ADD_OOP (_gst_byte_array_new (str, n)));
587 }
588
589 OOP
_gst_symbol_to_oop(const char * str)590 _gst_symbol_to_oop (const char *str)
591 {
592 if (!_gst_smalltalk_initialized)
593 _gst_initialize (NULL, NULL, GST_NO_TTY);
594
595 if (str == NULL)
596 return (_gst_nil_oop);
597 else
598 /* Symbols don't get freed, so the new OOP doesn't need to be
599 registered */
600 return (_gst_intern_string (str));
601 }
602
603 OOP
_gst_c_object_to_oop(PTR co)604 _gst_c_object_to_oop (PTR co)
605 {
606 if (!_gst_smalltalk_initialized)
607 _gst_initialize (NULL, NULL, GST_NO_TTY);
608
609 if (co == NULL)
610 return (_gst_nil_oop);
611 else
612 return (INC_ADD_OOP (COBJECT_NEW (co, _gst_nil_oop, _gst_c_object_class)));
613 }
614
615 void
_gst_set_c_object(OOP oop,PTR co)616 _gst_set_c_object (OOP oop, PTR co)
617 {
618 if (!_gst_smalltalk_initialized)
619 _gst_initialize (NULL, NULL, GST_NO_TTY);
620
621 set_cobject_value (oop, co);
622 }
623
624
625 /***********************************************************************
626 *
627 * Conversion *from* Smalltalk datatypes routines
628 *
629 ***********************************************************************/
630
631 /* ### need a type inquiry routine */
632
633 long
_gst_oop_to_c(OOP oop)634 _gst_oop_to_c (OOP oop)
635 {
636 if (!_gst_smalltalk_initialized)
637 _gst_initialize (NULL, NULL, GST_NO_TTY);
638
639 if (IS_C_LONG (oop) || IS_C_ULONG (oop))
640 return (TO_C_LONG (oop));
641
642 else if (OOP_CLASS (oop) == _gst_true_class
643 || OOP_CLASS (oop) == _gst_false_class)
644 return (oop == _gst_true_oop);
645
646 else if (OOP_CLASS (oop) == _gst_char_class
647 || OOP_CLASS (oop) == _gst_unicode_character_class)
648 return (CHAR_OOP_VALUE (oop));
649
650 else if (IS_NIL (oop))
651 return (0);
652
653 else if (is_a_kind_of (OOP_CLASS (oop), _gst_c_object_class))
654 return ((long) cobject_value (oop));
655
656 else
657 return (0);
658 }
659
660 long
_gst_oop_to_int(OOP oop)661 _gst_oop_to_int (OOP oop)
662 {
663 if (!_gst_smalltalk_initialized)
664 _gst_initialize (NULL, NULL, GST_NO_TTY);
665
666 return (TO_C_LONG (oop));
667 }
668
669 long
_gst_oop_to_id(OOP oop)670 _gst_oop_to_id (OOP oop)
671 {
672 if (!_gst_smalltalk_initialized)
673 _gst_initialize (NULL, NULL, GST_NO_TTY);
674
675 return (OOP_INDEX (oop));
676 }
677
678 double
_gst_oop_to_float(OOP oop)679 _gst_oop_to_float (OOP oop)
680 {
681 if (!_gst_smalltalk_initialized)
682 _gst_initialize (NULL, NULL, GST_NO_TTY);
683
684 if (IS_INT (oop))
685 return (TO_INT (oop));
686 else if (IS_CLASS (oop, _gst_floatd_class))
687 return (FLOATD_OOP_VALUE (oop));
688 else if (IS_CLASS (oop, _gst_floate_class))
689 return (FLOATE_OOP_VALUE (oop));
690 else if (IS_CLASS (oop, _gst_floatq_class))
691 return (FLOATQ_OOP_VALUE (oop));
692 else
693 return 0.0 / 0.0;
694 }
695
696 long double
_gst_oop_to_long_double(OOP oop)697 _gst_oop_to_long_double (OOP oop)
698 {
699 if (!_gst_smalltalk_initialized)
700 _gst_initialize (NULL, NULL, GST_NO_TTY);
701
702 if (IS_INT (oop))
703 return (TO_INT (oop));
704 else if (IS_CLASS (oop, _gst_floatd_class))
705 return (FLOATD_OOP_VALUE (oop));
706 else if (IS_CLASS (oop, _gst_floate_class))
707 return (FLOATE_OOP_VALUE (oop));
708 else if (IS_CLASS (oop, _gst_floatq_class))
709 return (FLOATQ_OOP_VALUE (oop));
710 else
711 return 0.0 / 0.0;
712 }
713
714 int
_gst_oop_to_bool(OOP oop)715 _gst_oop_to_bool (OOP oop)
716 {
717 if (!_gst_smalltalk_initialized)
718 _gst_initialize (NULL, NULL, GST_NO_TTY);
719
720 return (oop == _gst_true_oop);
721 }
722
723 char
_gst_oop_to_char(OOP oop)724 _gst_oop_to_char (OOP oop)
725 {
726 if (!_gst_smalltalk_initialized)
727 _gst_initialize (NULL, NULL, GST_NO_TTY);
728
729 return (CHAR_OOP_VALUE (oop));
730 }
731
732 wchar_t
_gst_oop_to_wchar(OOP oop)733 _gst_oop_to_wchar (OOP oop)
734 {
735 if (!_gst_smalltalk_initialized)
736 _gst_initialize (NULL, NULL, GST_NO_TTY);
737
738 return (CHAR_OOP_VALUE (oop));
739 }
740
741 char *
_gst_oop_to_string(OOP oop)742 _gst_oop_to_string (OOP oop)
743 {
744 if (!_gst_smalltalk_initialized)
745 _gst_initialize (NULL, NULL, GST_NO_TTY);
746
747 if (IS_NIL (oop))
748 return (NULL);
749 else
750 return ((char *) _gst_to_cstring (oop));
751 }
752
753 wchar_t *
_gst_oop_to_wstring(OOP oop)754 _gst_oop_to_wstring (OOP oop)
755 {
756 if (!_gst_smalltalk_initialized)
757 _gst_initialize (NULL, NULL, GST_NO_TTY);
758
759 if (IS_NIL (oop))
760 return (NULL);
761 else
762 return ((wchar_t *) _gst_to_wide_cstring (oop));
763 }
764
765 char *
_gst_oop_to_byte_array(OOP oop)766 _gst_oop_to_byte_array (OOP oop)
767 {
768 if (!_gst_smalltalk_initialized)
769 _gst_initialize (NULL, NULL, GST_NO_TTY);
770
771 if (IS_NIL (oop))
772 return (NULL);
773 else
774 return ((char *) _gst_to_byte_array (oop));
775 }
776
777 PTR
_gst_oop_to_c_object(OOP oop)778 _gst_oop_to_c_object (OOP oop)
779 {
780 if (!_gst_smalltalk_initialized)
781 _gst_initialize (NULL, NULL, GST_NO_TTY);
782
783 if (IS_NIL (oop))
784 return (NULL);
785 else
786 return (cobject_value (oop));
787 }
788
789 OOP
_gst_get_object_class(OOP oop)790 _gst_get_object_class (OOP oop)
791 {
792 if (!_gst_smalltalk_initialized)
793 _gst_initialize (NULL, NULL, GST_NO_TTY);
794
795 return OOP_INT_CLASS (oop);
796 }
797
798 OOP
_gst_get_superclass(OOP oop)799 _gst_get_superclass (OOP oop)
800 {
801 if (!_gst_smalltalk_initialized)
802 _gst_initialize (NULL, NULL, GST_NO_TTY);
803
804 /* Quick tests for "class-ness". */
805 assert (IS_OOP (oop));
806 assert (OOP_CLASS (oop) == _gst_behavior_class
807 || OOP_CLASS (OOP_CLASS (oop)) == _gst_metaclass_class);
808
809 return SUPERCLASS (oop);
810 }
811
812 mst_Boolean
_gst_class_is_kind_of(OOP candidate,OOP superclass)813 _gst_class_is_kind_of (OOP candidate, OOP superclass)
814 {
815 if (!_gst_smalltalk_initialized)
816 _gst_initialize (NULL, NULL, GST_NO_TTY);
817
818 /* Quick tests for "class-ness". */
819 assert (IS_OOP (candidate) && IS_OOP (superclass));
820 assert (OOP_CLASS (candidate) == _gst_behavior_class
821 || OOP_CLASS (OOP_CLASS (candidate)) == _gst_metaclass_class);
822
823 if (superclass == _gst_nil_oop || candidate == superclass)
824 return true;
825
826 assert (OOP_CLASS (superclass) == _gst_behavior_class
827 || OOP_CLASS (OOP_CLASS (superclass)) == _gst_metaclass_class);
828
829 return is_a_kind_of (candidate, superclass);
830 }
831
832
833 mst_Boolean
_gst_object_is_kind_of(OOP candidate,OOP superclass)834 _gst_object_is_kind_of (OOP candidate, OOP superclass)
835 {
836 OOP its_class;
837 if (!_gst_smalltalk_initialized)
838 _gst_initialize (NULL, NULL, GST_NO_TTY);
839
840 if (IS_INT (candidate))
841 {
842 its_class = _gst_small_integer_class;
843 if (superclass == _gst_small_integer_class
844 || superclass == _gst_object_class)
845 return true;
846 }
847 else
848 its_class = OOP_CLASS (candidate);
849
850 if (superclass == _gst_nil_oop || its_class == superclass)
851 return true;
852
853 /* Quick tests for "class-ness". */
854 assert (IS_OOP (superclass));
855 assert (OOP_CLASS (superclass) == _gst_behavior_class
856 || OOP_CLASS (OOP_CLASS (superclass)) == _gst_metaclass_class);
857
858 return is_a_kind_of (its_class, superclass);
859 }
860
861 OOP
_gst_perform(OOP receiver,OOP selector)862 _gst_perform (OOP receiver, OOP selector)
863 {
864 if (!_gst_smalltalk_initialized)
865 _gst_initialize (NULL, NULL, GST_NO_TTY);
866
867 return _gst_nvmsg_send (receiver, selector, NULL, 0);
868 }
869
870 OOP
_gst_perform_with(OOP receiver,OOP selector,OOP arg)871 _gst_perform_with (OOP receiver, OOP selector, OOP arg)
872 {
873 if (!_gst_smalltalk_initialized)
874 _gst_initialize (NULL, NULL, GST_NO_TTY);
875
876 return _gst_nvmsg_send (receiver, selector, &arg, 1);
877 }
878
879 mst_Boolean
_gst_class_implements_selector(OOP classOOP,OOP selector)880 _gst_class_implements_selector (OOP classOOP, OOP selector)
881 {
882 if (!_gst_smalltalk_initialized)
883 _gst_initialize (NULL, NULL, GST_NO_TTY);
884
885 assert (IS_OOP (classOOP));
886 assert (OOP_CLASS (classOOP) == _gst_behavior_class
887 || OOP_CLASS (OOP_CLASS (classOOP)) == _gst_metaclass_class);
888
889 return _gst_find_class_method (classOOP, selector) != _gst_nil_oop;
890 }
891
892 mst_Boolean
_gst_class_can_understand(OOP classOOP,OOP selector)893 _gst_class_can_understand (OOP classOOP, OOP selector)
894 {
895 method_cache_entry dummy;
896 if (!_gst_smalltalk_initialized)
897 _gst_initialize (NULL, NULL, GST_NO_TTY);
898
899 /* Quick test for "class-ness". */
900 assert (IS_OOP (classOOP));
901 assert (OOP_CLASS (classOOP) == _gst_behavior_class
902 || OOP_CLASS (OOP_CLASS (classOOP)) == _gst_metaclass_class);
903
904 return _gst_find_method (classOOP, selector, &dummy);
905 }
906
907 mst_Boolean
_gst_responds_to(OOP oop,OOP selector)908 _gst_responds_to (OOP oop, OOP selector)
909 {
910 method_cache_entry dummy;
911 if (!_gst_smalltalk_initialized)
912 _gst_initialize (NULL, NULL, GST_NO_TTY);
913
914 return _gst_find_method (OOP_INT_CLASS (oop), selector, &dummy);
915 }
916
917 size_t
_gst_oop_size(OOP oop)918 _gst_oop_size (OOP oop)
919 {
920 if (!_gst_smalltalk_initialized)
921 _gst_initialize (NULL, NULL, GST_NO_TTY);
922
923 return NUM_INDEXABLE_FIELDS (oop);
924 }
925
926 OOP
_gst_oop_at(OOP oop,size_t index)927 _gst_oop_at (OOP oop, size_t index)
928 {
929 OOP result;
930 if (!_gst_smalltalk_initialized)
931 _gst_initialize (NULL, NULL, GST_NO_TTY);
932
933 result = index_oop (oop, index + 1);
934 assert (result);
935 return result;
936 }
937
938 OOP
_gst_oop_at_put(OOP oop,size_t index,OOP new)939 _gst_oop_at_put (OOP oop, size_t index, OOP new)
940 {
941 OOP old;
942 if (!_gst_smalltalk_initialized)
943 _gst_initialize (NULL, NULL, GST_NO_TTY);
944
945 old = index_oop (oop, index + 1);
946 assert (old);
947 index_oop_put (oop, index + 1, new);
948 return old;
949 }
950
951 void *
_gst_oop_indexed_base(OOP oop)952 _gst_oop_indexed_base (OOP oop)
953 {
954 if (!_gst_smalltalk_initialized)
955 _gst_initialize (NULL, NULL, GST_NO_TTY);
956
957 return &OOP_TO_OBJ (oop)->data[OOP_FIXED_FIELDS (oop)];
958 }
959
960 enum gst_indexed_kind
_gst_oop_indexed_kind(OOP oop)961 _gst_oop_indexed_kind (OOP oop)
962 {
963 if (!_gst_smalltalk_initialized)
964 _gst_initialize (NULL, NULL, GST_NO_TTY);
965
966 return OOP_INSTANCE_SPEC (oop) & ISP_INDEXEDVARS;
967 }
968
969
970
971 /***********************************************************************
972 *
973 * Registry bookkeeping routines
974 *
975 ***********************************************************************/
976
977 OOP
_gst_register_oop(OOP oop)978 _gst_register_oop (OOP oop)
979 {
980 rb_node_t **p = (rb_node_t **) &oop_registry_root;
981 oop_registry *node;
982 oop_registry *entry = NULL;
983
984 if (!oop || IS_NIL (oop))
985 return (oop);
986
987 while (*p)
988 {
989 entry = (oop_registry *) *p;
990
991 if (oop < entry->oop)
992 p = &(*p)->rb_left;
993 else if (oop > entry->oop)
994 p = &(*p)->rb_right;
995 else
996 {
997 entry->usage++;
998 return (oop);
999 }
1000 }
1001
1002 node = (oop_registry *) xmalloc(sizeof(oop_registry));
1003 node->rb.rb_parent = (rb_node_t *) entry;
1004 node->rb.rb_left = node->rb.rb_right = NULL;
1005 node->usage = 1;
1006 node->oop = oop;
1007 *p = &(node->rb);
1008
1009 rb_rebalance(&node->rb, (rb_node_t **) &oop_registry_root);
1010 return (oop);
1011 }
1012
1013 void
_gst_unregister_oop(OOP oop)1014 _gst_unregister_oop (OOP oop)
1015 {
1016 oop_registry *entry = oop_registry_root;
1017
1018 /* Speed things up, this will never be in the registry (but we allow
1019 it to simplify client code). */
1020 if (!oop || IS_NIL (oop))
1021 return;
1022
1023 while (entry)
1024 {
1025 if (entry->oop == oop)
1026 {
1027 if (!--entry->usage)
1028 {
1029 rb_erase (&entry->rb, (rb_node_t **) &oop_registry_root);
1030 xfree (entry);
1031 }
1032 break;
1033 }
1034
1035 entry = (oop_registry *)
1036 (oop < entry->oop ? entry->rb.rb_left : entry->rb.rb_right);
1037 }
1038 }
1039
1040
1041 void
_gst_register_oop_array(OOP ** first,OOP ** last)1042 _gst_register_oop_array (OOP **first, OOP **last)
1043 {
1044 rb_node_t **p = (rb_node_t **) &oop_array_registry_root;
1045 oop_array_registry *node;
1046 oop_array_registry *entry = NULL;
1047
1048 while (*p)
1049 {
1050 entry = (oop_array_registry *) *p;
1051
1052 if (first < entry->first)
1053 p = &(*p)->rb_left;
1054 else if (first > entry->first)
1055 p = &(*p)->rb_right;
1056 else
1057 entry->usage++;
1058 }
1059
1060 node = (oop_array_registry *) xmalloc(sizeof(oop_array_registry));
1061 node->rb.rb_parent = (rb_node_t *) entry;
1062 node->rb.rb_left = node->rb.rb_right = NULL;
1063 node->usage = 1;
1064 node->first = first;
1065 node->last = last;
1066 *p = &(node->rb);
1067
1068 rb_rebalance(&node->rb, (rb_node_t **) &oop_array_registry_root);
1069 }
1070
1071 void
_gst_unregister_oop_array(OOP ** first)1072 _gst_unregister_oop_array (OOP **first)
1073 {
1074 oop_array_registry *entry = oop_array_registry_root;
1075
1076 while (entry)
1077 {
1078 if (entry->first == first)
1079 {
1080 if (!--entry->usage)
1081 {
1082 rb_erase (&entry->rb, (rb_node_t **) &oop_array_registry_root);
1083 xfree (entry);
1084 }
1085 break;
1086 }
1087
1088 entry = (oop_array_registry *)
1089 (first < entry->first ? entry->rb.rb_left : entry->rb.rb_right);
1090 }
1091 }
1092
1093
1094 void
_gst_copy_registered_oops(void)1095 _gst_copy_registered_oops (void)
1096 {
1097 rb_node_t *node;
1098 rb_traverse_t t;
1099
1100 /* Walk the OOP registry... */
1101 for (node = rb_first(&(oop_registry_root->rb), &t);
1102 node; node = rb_next(&t))
1103 {
1104 oop_registry *k = (oop_registry *) node;
1105 MAYBE_COPY_OOP (k->oop);
1106 }
1107
1108 /* ...and then the OOP-array registry. */
1109 for (node = rb_first(&(oop_array_registry_root->rb), &t);
1110 node; node = rb_next(&t))
1111 {
1112 oop_array_registry *k = (oop_array_registry *) node;
1113
1114 /* Dereference the pointers in the tree to obtain where the array
1115 lies. */
1116 OOP *first = *(k->first);
1117 OOP *last = *(k->last);
1118 _gst_copy_oop_range (first, last);
1119 }
1120 }
1121
1122 void
_gst_mark_registered_oops(void)1123 _gst_mark_registered_oops (void)
1124 {
1125 rb_node_t *node;
1126 rb_traverse_t t;
1127
1128 /* Walk the OOP registry... */
1129 for (node = rb_first(&(oop_registry_root->rb), &t);
1130 node; node = rb_next(&t))
1131 {
1132 oop_registry *k = (oop_registry *) node;
1133 MAYBE_MARK_OOP (k->oop);
1134 }
1135
1136 /* ...and then the OOP-array registry. */
1137 for (node = rb_first(&(oop_array_registry_root->rb), &t);
1138 node; node = rb_next(&t))
1139 {
1140 oop_array_registry *k = (oop_array_registry *) node;
1141
1142 /* Dereference the pointers in the tree to obtain where the array
1143 lies. */
1144 OOP *first = *(k->first);
1145 OOP *last = *(k->last);
1146 _gst_mark_oop_range (first, last);
1147 }
1148 }
1149
1150 void
_gst_init_vmproxy(void)1151 _gst_init_vmproxy (void)
1152 {
1153 gst_interpreter_proxy.nilOOP = _gst_nil_oop;
1154 gst_interpreter_proxy.trueOOP = _gst_true_oop;
1155 gst_interpreter_proxy.falseOOP = _gst_false_oop;
1156
1157 gst_interpreter_proxy.objectClass = _gst_object_class;
1158 gst_interpreter_proxy.arrayClass = _gst_array_class;
1159 gst_interpreter_proxy.stringClass = _gst_string_class;
1160 gst_interpreter_proxy.characterClass = _gst_char_class;
1161 gst_interpreter_proxy.smallIntegerClass = _gst_small_integer_class;
1162 gst_interpreter_proxy.floatDClass = _gst_floatd_class;
1163 gst_interpreter_proxy.floatEClass = _gst_floate_class;
1164 gst_interpreter_proxy.byteArrayClass = _gst_byte_array_class;
1165 gst_interpreter_proxy.objectMemoryClass = _gst_object_memory_class;
1166 gst_interpreter_proxy.classClass = _gst_class_class;
1167 gst_interpreter_proxy.behaviorClass = _gst_behavior_class;
1168 gst_interpreter_proxy.blockClosureClass = _gst_block_closure_class;
1169 gst_interpreter_proxy.contextPartClass = _gst_context_part_class;
1170 gst_interpreter_proxy.blockContextClass = _gst_block_context_class;
1171 gst_interpreter_proxy.methodContextClass = _gst_method_context_class;
1172 gst_interpreter_proxy.compiledMethodClass = _gst_compiled_method_class;
1173 gst_interpreter_proxy.compiledBlockClass = _gst_compiled_block_class;
1174 gst_interpreter_proxy.fileDescriptorClass = _gst_file_descriptor_class;
1175 gst_interpreter_proxy.fileStreamClass = _gst_file_stream_class;
1176 gst_interpreter_proxy.processClass = _gst_process_class;
1177 gst_interpreter_proxy.semaphoreClass = _gst_semaphore_class;
1178 gst_interpreter_proxy.cObjectClass = _gst_c_object_class;
1179
1180 /* And system objects. */
1181 gst_interpreter_proxy.processorOOP = _gst_processor_oop;
1182 }
1183
1184 struct VMProxy *
_gst_get_vmproxy(void)1185 _gst_get_vmproxy (void)
1186 {
1187 struct VMProxy *result;
1188
1189 result = xmalloc (sizeof (struct VMProxy));
1190 memcpy (result, &gst_interpreter_proxy, sizeof (struct VMProxy));
1191 return result;
1192 }
1193