?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Removed the notion of a "large" context. For simplicity, all contexts
[panda.git] / src / st-primitives.c
blob3f2dc0eccf48e3fd777ad6bf0e59ba253bc58ca7
1 /*
2 * st-primitives.c
3 *
4 * Copyright (C) 2008 Vincent Geddes
5 *
6 * Permission is hereby granted, free of charge, to any person obtaining a copy
7 * of this software and associated documentation files (the "Software"), to deal
8 * in the Software without restriction, including without limitation the rights
9 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
10 * copies of the Software, and to permit persons to whom the Software is
11 * furnished to do so, subject to the following conditions:
12 *
13 * The above copyright notice and this permission notice shall be included in
14 * all copies or substantial portions of the Software.
15 *
16 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
19 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
21 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
22 * THE SOFTWARE.
23 */
24
25 #include "st-primitives.h"
26 #include "st-machine.h"
27 #include "st-array.h"
28 #include "st-large-integer.h"
29 #include "st-float.h"
30 #include "st-array.h"
31 #include "st-object.h"
32 #include "st-behavior.h"
33 #include "st-context.h"
34 #include "st-method.h"
35 #include "st-symbol.h"
36 #include "st-character.h"
37 #include "st-dictionary.h"
38 #include "st-unicode.h"
39 #include "st-compiler.h"
40 #include "st-handle.h"
41
42 #include <math.h>
43 #include <string.h>
44 #include <stdlib.h>
45 #include <setjmp.h>
46 #include <errno.h>
47 #include <fcntl.h>
48 #include <unistd.h>
49 #include <sys/stat.h>
50
51
52 #define ST_PRIMITIVE_FAIL(machine) \
53 machine->success = false
54
55
56 static inline void
57 set_success (st_machine *machine, bool success)
58 {
59 machine->success = machine->success && success;
60 }
61
62 static inline int
63 pop_integer (st_machine *machine)
64 {
65 st_oop object = ST_STACK_POP (machine);
66
67 if (ST_LIKELY (st_object_is_smi (object)))
68 return st_smi_value (object);
69
70 ST_PRIMITIVE_FAIL (machine);
71 return 0;
72 }
73
74 static inline int
75 pop_integer32 (st_machine *machine)
76 {
77 st_oop object = ST_STACK_POP (machine);
78
79 if (ST_LIKELY (st_object_is_smi (object)))
80 return st_smi_value (object);
81 else if (st_object_class (object) == ST_LARGE_INTEGER_CLASS)
82 return (int) mp_get_int (st_large_integer_value (object));
83
84 ST_PRIMITIVE_FAIL (machine);
85 return 0;
86 }
87
88 static void
89 SmallInteger_add (st_machine *machine)
90 {
91 int y = pop_integer (machine);
92 int x = pop_integer (machine);
93 int result;
94
95 if (ST_LIKELY (machine->success)) {
96 result = x + y;
97 if (((result << 1) ^ (result << 2)) >= 0) {
98 ST_STACK_PUSH (machine, st_smi_new (result));
99 return;
100 } else {
101 ST_PRIMITIVE_FAIL (machine);
102 }
103 }
104
105 ST_STACK_UNPOP (machine, 2);
106 }
107
108 static void
109 SmallInteger_sub (st_machine *machine)
110 {
111 int y = pop_integer (machine);
112 int x = pop_integer (machine);
113 int result;
114
115
116 if (ST_LIKELY (machine->success)) {
117 result = x + y;
118 if (((result << 1) ^ (result << 2)) >= 0) {
119 ST_STACK_PUSH (machine, st_smi_new (result));
120 return;
121 } else {
122 ST_PRIMITIVE_FAIL (machine);
123 }
124 }
125
126 ST_STACK_UNPOP (machine, 2);
127 }
128
129 static void
130 SmallInteger_lt (st_machine *machine)
131 {
132 int y = pop_integer (machine);
133 int x = pop_integer (machine);
134 st_oop result;
135
136 if (ST_LIKELY (machine->success)) {
137 result = (x < y) ? ST_TRUE : ST_FALSE;
138 ST_STACK_PUSH (machine, result);
139 return;
140 }
141
142 ST_STACK_UNPOP (machine, 2);
143 }
144
145 static void
146 SmallInteger_gt (st_machine *machine)
147 {
148 int y = pop_integer (machine);
149 int x = pop_integer (machine);
150 st_oop result;
151
152 if (ST_LIKELY (machine->success)) {
153 result = (x > y) ? ST_TRUE : ST_FALSE;
154 ST_STACK_PUSH (machine, result);
155 return;
156 }
157
158 ST_STACK_UNPOP (machine, 2);
159 }
160
161 static void
162 SmallInteger_le (st_machine *machine)
163 {
164 int y = pop_integer (machine);
165 int x = pop_integer (machine);
166 st_oop result;
167
168 if (ST_LIKELY (machine->success)) {
169 result = (x <= y) ? ST_TRUE : ST_FALSE;
170 ST_STACK_PUSH (machine, result);
171 return;
172 }
173
174 ST_STACK_UNPOP (machine, 2);
175 }
176
177 static void
178 SmallInteger_ge (st_machine *machine)
179 {
180 int y = pop_integer (machine);
181 int x = pop_integer (machine);
182 st_oop result;
183
184 if (ST_LIKELY (machine->success)) {
185 result = (x >= y) ? ST_TRUE : ST_FALSE;
186 ST_STACK_PUSH (machine, result);
187 return;
188 }
189
190 ST_STACK_UNPOP (machine, 2);
191 }
192
193 static void
194 SmallInteger_eq (st_machine *machine)
195 {
196 int y = pop_integer (machine);
197 int x = pop_integer (machine);
198 st_oop result;
199
200 if (ST_LIKELY (machine->success)) {
201 result = (x == y) ? ST_TRUE : ST_FALSE;
202 ST_STACK_PUSH (machine, result);
203 return;
204 }
205
206 ST_STACK_UNPOP (machine, 2);
207 }
208
209 static void
210 SmallInteger_ne (st_machine *machine)
211 {
212 int y = pop_integer (machine);
213 int x = pop_integer (machine);
214 st_oop result;
215
216 if (ST_LIKELY (machine->success)) {
217 result = (x != y) ? ST_TRUE : ST_FALSE;
218 ST_STACK_PUSH (machine, result);
219 return;
220 }
221
222 ST_STACK_UNPOP (machine, 2);
223 }
224
225 static void
226 SmallInteger_mul (st_machine *machine)
227 {
228 int y = pop_integer (machine);
229 int x = pop_integer (machine);
230 int64_t result;
231
232 if (machine->success) {
233 result = x * y;
234 if (result >= ST_SMALL_INTEGER_MIN && result <= ST_SMALL_INTEGER_MAX) {
235 ST_STACK_PUSH (machine, st_smi_new ((int) result));
236 return;
237 } else {
238 ST_PRIMITIVE_FAIL (machine);
239 }
240 }
241
242 ST_STACK_UNPOP (machine, 2);
243 }
244
245 /* selector: / */
246 static void
247 SmallInteger_div (st_machine *machine)
248 {
249 int y = pop_integer (machine);
250 int x = pop_integer (machine);
251 st_oop result;
252
253 if (ST_LIKELY (machine->success)) {
254
255 if (y != 0 && x % y == 0) {
256 result = st_smi_new (x / y);
257 ST_STACK_PUSH (machine, result);
258 return;
259 } else {
260 ST_PRIMITIVE_FAIL (machine);
261 }
262 }
263
264 ST_STACK_UNPOP (machine, 2);
265 }
266
267 static void
268 SmallInteger_intDiv (st_machine *machine)
269 {
270 int y = pop_integer (machine);
271 int x = pop_integer (machine);
272 st_oop result;
273
274 if (ST_LIKELY (machine->success)) {
275
276 if (y != 0) {
277 result = st_smi_new (x / y);
278 ST_STACK_PUSH (machine, result);
279 return;
280 } else {
281 ST_PRIMITIVE_FAIL (machine);
282 }
283 }
284
285 ST_STACK_UNPOP (machine, 2);
286 }
287
288 static void
289 SmallInteger_mod (st_machine *machine)
290 {
291 int y = pop_integer (machine);
292 int x = pop_integer (machine);
293 st_oop result;
294
295 if (ST_LIKELY (machine->success)) {
296 result = st_smi_new (x % y);
297 ST_STACK_PUSH (machine, result);
298 return;
299 }
300
301 ST_STACK_UNPOP (machine, 2);
302 }
303
304 static void
305 SmallInteger_bitOr (st_machine *machine)
306 {
307 int y = pop_integer (machine);
308 int x = pop_integer (machine);
309 st_oop result = ST_NIL;
310
311 if (ST_LIKELY (machine->success)) {
312 result = st_smi_new (x | y);
313 ST_STACK_PUSH (machine, result);
314 return;
315 }
316
317 ST_STACK_UNPOP (machine, 2);
318 }
319
320 static void
321 SmallInteger_bitXor (st_machine *machine)
322 {
323 int y = pop_integer (machine);
324 int x = pop_integer (machine);
325 st_oop result;
326
327 if (ST_LIKELY (machine->success)) {
328 result = st_smi_new (x ^ y);
329 ST_STACK_PUSH (machine, result);
330 return;
331 }
332
333 ST_STACK_UNPOP (machine, 2);
334 }
335
336 static void
337 SmallInteger_bitAnd (st_machine *machine)
338 {
339 int y = pop_integer (machine);
340 int x = pop_integer (machine);
341 st_oop result = ST_NIL;
342
343 if (ST_LIKELY (machine->success)) {
344 result = st_smi_new (x & y);
345 ST_STACK_PUSH (machine, result);
346 return;
347 }
348
349 ST_STACK_UNPOP (machine, 2);
350 }
351
352 static void
353 SmallInteger_bitShift (st_machine *machine)
354 {
355 int y = pop_integer (machine);
356 int x = pop_integer (machine);
357 st_oop result = ST_NIL;
358
359 if (ST_LIKELY (machine->success)) {
360 if (y > 0)
361 result = st_smi_new (x << y);
362 else if (y < 0)
363 result = st_smi_new (x >> (-y));
364 else
365 result = st_smi_new (x);
366
367 ST_STACK_PUSH (machine, result);
368 return;
369 }
370
371 ST_STACK_UNPOP (machine, 2);
372 }
373
374 static void
375 SmallInteger_asFloat (st_machine *machine)
376 {
377 int x = pop_integer (machine);
378 st_oop result = ST_NIL;
379
380 if (ST_LIKELY (machine->success)) {
381 result = st_float_new ((double) x);
382 ST_STACK_PUSH (machine, result);
383 return;
384 }
385
386 ST_STACK_UNPOP (machine, 1);
387 }
388
389 static void
390 SmallInteger_asLargeInteger (st_machine *machine)
391 {
392 int receiver = pop_integer (machine);
393 mp_int value;
394 st_oop result;
395
396 mp_init_set (&value, abs (receiver));
397
398 if (receiver < 0)
399 mp_neg (&value, &value);
400
401 result = st_large_integer_new (&value);
402 ST_STACK_PUSH (machine, result);
403 }
404
405 #define VALUE(oop) (&(ST_LARGE_INTEGER(oop)->value))
406
407 /* useful macros to avoid duplication of error-handling code */
408
409 #define OP_PROLOGUE \
410 mp_int value; \
411 mp_init (&value);
412
413
414 #define BINARY_OP(op, a, b) \
415 OP_PROLOGUE \
416 result = op (VALUE (a), VALUE (b), &value);
417
418 #define BINARY_DIV_OP(op, a, b) \
419 OP_PROLOGUE \
420 result = op (VALUE (a), VALUE (b), &value, NULL);
421
422 #define UNARY_OP(op, a) \
423 OP_PROLOGUE \
424 result = op (VALUE (a), &value);
425
426
427 static inline st_oop
428 pop_large_integer (st_machine *machine)
429 {
430 st_oop object = ST_STACK_POP (machine);
431
432 set_success (machine, st_object_class (object) == ST_LARGE_INTEGER_CLASS);
433
434 return object;
435 }
436
437 static void
438 LargeInteger_add (st_machine *machine)
439 {
440 st_oop b = pop_large_integer (machine);
441 st_oop a = pop_large_integer (machine);
442 st_oop result;
443
444 if (!machine->success) {
445 ST_STACK_UNPOP (machine, 2);
446 return;
447 }
448
449 BINARY_OP (mp_add, a, b);
450
451 result = st_large_integer_new (&value);
452 ST_STACK_PUSH (machine, result);
453 }
454
455 static void
456 LargeInteger_sub (st_machine *machine)
457 {
458 st_oop b = pop_large_integer (machine);
459 st_oop a = pop_large_integer (machine);
460 st_oop result;
461
462 if (!machine->success) {
463 ST_STACK_UNPOP (machine, 2);
464 return;
465 }
466
467 BINARY_OP (mp_sub, a, b);
468
469 result = st_large_integer_new (&value);
470 ST_STACK_PUSH (machine, result);
471 }
472
473 static void
474 LargeInteger_mul (st_machine *machine)
475 {
476 st_oop b = pop_large_integer (machine);
477 st_oop a = pop_large_integer (machine);
478 st_oop result;
479
480 if (!machine->success) {
481 ST_STACK_UNPOP (machine, 2);
482 return;
483 }
484
485 BINARY_OP (mp_mul, a, b);
486
487 result = st_large_integer_new (&value);
488 ST_STACK_PUSH (machine, result);
489 }
490
491 static void
492 LargeInteger_div (st_machine *machine)
493 {
494 st_oop b = pop_large_integer (machine);
495 st_oop a = pop_large_integer (machine);
496 mp_int quotient, remainder;
497 st_oop result;
498
499 if (!machine->success) {
500 ST_STACK_UNPOP (machine, 2);
501 return;
502 }
503
504 mp_init_multi (&quotient, &remainder, NULL);
505 mp_div (VALUE (a), VALUE (b), &quotient, &remainder);
506
507 int size;
508 char *str;
509
510 mp_radix_size (&remainder, 10, &size);
511 str = st_malloc (size);
512 mp_toradix (&remainder, str, 10);
513
514 if (mp_cmp_d (&remainder, 0) == MP_EQ) {
515 result = st_large_integer_new (&quotient);
516 ST_STACK_PUSH (machine, result);
517 mp_clear (&remainder);
518 } else {
519 set_success (machine, false);
520 ST_STACK_UNPOP (machine, 2);
521 mp_clear_multi (&quotient, &remainder, NULL);
522 }
523 }
524
525 static void
526 LargeInteger_intDiv (st_machine *machine)
527 {
528 st_oop b = pop_large_integer (machine);
529 st_oop a = pop_large_integer (machine);
530 st_oop result;
531
532 if (!machine->success) {
533 ST_STACK_UNPOP (machine, 2);
534 return;
535 }
536
537 BINARY_DIV_OP (mp_div, a, b);
538
539 result = st_large_integer_new (&value);
540 ST_STACK_PUSH (machine, result);
541 }
542
543 static void
544 LargeInteger_mod (st_machine *machine)
545 {
546 st_oop b = pop_large_integer (machine);
547 st_oop a = pop_large_integer (machine);
548 st_oop result;
549
550 if (!machine->success) {
551 ST_STACK_UNPOP (machine, 2);
552 return;
553 }
554
555 BINARY_OP (mp_mod, a, b);
556
557 result = st_large_integer_new (&value);
558 ST_STACK_PUSH (machine, result);
559 }
560
561 static void
562 LargeInteger_gcd (st_machine *machine)
563 {
564 st_oop b = pop_large_integer (machine);
565 st_oop a = pop_large_integer (machine);
566 st_oop result;
567
568 if (!machine->success) {
569 ST_STACK_UNPOP (machine, 2);
570 return;
571 }
572
573 BINARY_OP (mp_gcd, a, b);
574
575 result = st_large_integer_new (&value);
576 ST_STACK_PUSH (machine, result);
577 }
578
579 static void
580 LargeInteger_lcm (st_machine *machine)
581 {
582 st_oop b = pop_large_integer (machine);
583 st_oop a = pop_large_integer (machine);
584 st_oop result;
585
586 if (!machine->success) {
587 ST_STACK_UNPOP (machine, 2);
588 return;
589 }
590
591 BINARY_OP (mp_lcm, a, b);
592
593 result = st_large_integer_new (&value);
594 ST_STACK_PUSH (machine, result);
595 }
596
597 static void
598 LargeInteger_eq (st_machine *machine)
599 {
600 st_oop b = pop_large_integer (machine);
601 st_oop a = pop_large_integer (machine);
602 st_oop result;
603 int relation;
604
605 if (!machine->success) {
606 ST_STACK_UNPOP (machine, 2);
607 return;
608 }
609
610 relation = mp_cmp (VALUE (a), VALUE (b));
611 result = (relation == MP_EQ) ? ST_TRUE : ST_FALSE;
612 ST_STACK_PUSH (machine, result);
613 }
614
615 static void
616 LargeInteger_ne (st_machine *machine)
617 {
618 st_oop b = pop_large_integer (machine);
619 st_oop a = pop_large_integer (machine);
620 st_oop result;
621 int relation;
622
623 if (!machine->success) {
624 ST_STACK_UNPOP (machine, 2);
625 return;
626 }
627
628 relation = mp_cmp (VALUE (a), VALUE (b));
629 result = (relation == MP_EQ) ? ST_FALSE : ST_TRUE;
630 ST_STACK_PUSH (machine, result);
631 }
632
633 static void
634 LargeInteger_lt (st_machine *machine)
635 {
636 st_oop b = pop_large_integer (machine);
637 st_oop a = pop_large_integer (machine);
638 st_oop result;
639 int relation;
640
641 if (!machine->success) {
642 ST_STACK_UNPOP (machine, 2);
643 return;
644 }
645
646 relation = mp_cmp (VALUE (a), VALUE (b));
647 result = (relation == MP_LT) ? ST_TRUE : ST_FALSE;
648 ST_STACK_PUSH (machine, result);
649 }
650
651 static void
652 LargeInteger_gt (st_machine *machine)
653 {
654 st_oop b = pop_large_integer (machine);
655 st_oop a = pop_large_integer (machine);
656
657 st_oop result;
658 int relation;
659
660 if (!machine->success) {
661 ST_STACK_UNPOP (machine, 2);
662 return;
663 }
664
665 relation = mp_cmp (VALUE (a), VALUE (b));
666 result = (relation == MP_GT) ? ST_TRUE : ST_FALSE;
667 ST_STACK_PUSH (machine, result);
668 }
669
670 static void
671 LargeInteger_le (st_machine *machine)
672 {
673 st_oop b = pop_large_integer (machine);
674 st_oop a = pop_large_integer (machine);
675 st_oop result;
676 int relation;
677
678 if (!machine->success) {
679 ST_STACK_UNPOP (machine, 2);
680 return;
681 }
682
683 relation = mp_cmp (VALUE (a), VALUE (b));
684 result = (relation == MP_LT || relation == MP_EQ) ? ST_TRUE : ST_FALSE;
685 ST_STACK_PUSH (machine, result);
686 }
687
688 static void
689 LargeInteger_ge (st_machine *machine)
690 {
691 st_oop b = pop_large_integer (machine);
692 st_oop a = pop_large_integer (machine);
693 st_oop result;
694 int relation;
695
696 if (!machine->success) {
697 ST_STACK_UNPOP (machine, 2);
698 return;
699 }
700
701 relation = mp_cmp (VALUE (a), VALUE (b));
702 result = (relation == MP_GT || relation == MP_EQ) ? ST_TRUE : ST_FALSE;
703 ST_STACK_PUSH (machine, result);
704 }
705
706 static void
707 LargeInteger_squared (st_machine *machine)
708 {
709 st_oop receiver = pop_large_integer (machine);
710 st_oop result;
711
712 if (!machine->success) {
713 ST_STACK_UNPOP (machine, 1);
714 return;
715 }
716
717 UNARY_OP (mp_sqr, receiver);
718
719 result = st_large_integer_new (&value);
720 ST_STACK_PUSH (machine, result);
721 }
722
723 static void
724 LargeInteger_bitOr (st_machine *machine)
725 {
726 st_oop b = pop_large_integer (machine);
727 st_oop a = pop_large_integer (machine);
728 st_oop result;
729
730 if (!machine->success) {
731 ST_STACK_UNPOP (machine, 2);
732 return;
733 }
734
735 BINARY_OP (mp_or, a, b);
736
737 result = st_large_integer_new (&value);
738 ST_STACK_PUSH (machine, result);
739 }
740
741 static void
742 LargeInteger_bitAnd (st_machine *machine)
743 {
744 st_oop b = pop_large_integer (machine);
745 st_oop a = pop_large_integer (machine);
746 st_oop result;
747
748 if (!machine->success) {
749 ST_STACK_UNPOP (machine, 2);
750 return;
751 }
752
753 BINARY_OP (mp_and, a, b);
754
755 result = st_large_integer_new (&value);
756 ST_STACK_PUSH (machine, result);
757 }
758
759 static void
760 LargeInteger_bitXor (st_machine *machine)
761 {
762 st_oop b = pop_large_integer (machine);
763 st_oop a = pop_large_integer (machine);
764 st_oop result;
765
766 if (!machine->success) {
767 ST_STACK_UNPOP (machine, 2);
768 return;
769 }
770
771 BINARY_OP (mp_xor, a, b);
772
773 result = st_large_integer_new (&value);
774 ST_STACK_PUSH (machine, result);
775 }
776
777 static void
778 LargeInteger_bitShift (st_machine *machine)
779 {
780 int displacement = pop_integer32 (machine);
781 st_oop receiver = pop_large_integer (machine);
782 st_oop result;
783 mp_int value;
784
785 if (!machine->success) {
786 ST_STACK_UNPOP (machine, 2);
787 return;
788 }
789
790 mp_init (&value);
791
792 if (displacement >= 0)
793 mp_mul_2d (VALUE (receiver), displacement, &value);
794 else
795 mp_div_2d (VALUE (receiver), abs (displacement), &value, NULL);
796
797 result = st_large_integer_new (&value);
798 ST_STACK_PUSH (machine, result);
799 }
800
801 #define ST_DIGIT_RADIX (1L << DIGIT_BIT)
802
803
804 static void
805 LargeInteger_asFloat (st_machine *machine)
806 {
807 st_oop receiver = pop_large_integer (machine);
808 char *string;
809 double result;
810 mp_int *m;
811 int i;
812
813 m = st_large_integer_value (receiver);
814 if (m->used == 0) {
815 ST_STACK_PUSH (machine, st_float_new (0));
816 return;
817 }
818
819 i = m->used;
820 result = DIGIT (m, i);
821 while (--i >= 0)
822 result = (result * ST_DIGIT_RADIX) + DIGIT (m, i);
823
824 if (m->sign == MP_NEG)
825 result = -result;
826
827 ST_STACK_PUSH (machine, st_float_new (result));
828 }
829
830 static void
831 LargeInteger_printStringBase (st_machine *machine)
832 {
833 int radix = pop_integer (machine);
834 st_oop x = pop_large_integer (machine);
835 char *string;
836 st_oop result;
837
838 if (radix < 2 || radix > 36)
839 set_success (machine, false);
840
841 if (machine->success) {
842 string = st_large_integer_to_string (x, radix);
843 result = st_string_new (string);
844 }
845
846 if (machine->success)
847 ST_STACK_PUSH (machine, result);
848 else
849 ST_STACK_UNPOP (machine, 2);
850 }
851
852 static void
853 LargeInteger_hash (st_machine *machine)
854 {
855 st_oop receiver = ST_STACK_POP (machine);
856 mp_int *value;
857 int result;
858 const char *c;
859 unsigned int hash;
860 int len;
861
862 value = st_large_integer_value (receiver);
863 c = (const char *) value->dp;
864 len = value->used * sizeof (mp_digit);
865 hash = 5381;
866
867 for(unsigned int i = 0; i < len; i++)
868 if (c[i])
869 hash = ((hash << 5) + hash) + c[i];
870
871 result = hash;
872
873 if (result < 0)
874 result = -result;
875
876 ST_STACK_PUSH (machine, st_smi_new (result));
877 }
878
879
880 static inline st_oop
881 pop_float (st_machine *machine)
882 {
883 st_oop object = ST_STACK_POP (machine);
884
885 set_success (machine, st_object_class (object) == ST_FLOAT_CLASS);
886
887 return object;
888 }
889
890 static void
891 Float_add (st_machine *machine)
892 {
893 st_oop y = pop_float (machine);
894 st_oop x = pop_float (machine);
895 st_oop result = ST_NIL;
896
897 if (machine->success)
898 result = st_float_new (st_float_value (x) + st_float_value (y));
899
900 if (machine->success)
901 ST_STACK_PUSH (machine, result);
902 else
903 ST_STACK_UNPOP (machine, 2);
904 }
905
906 static void
907 Float_sub (st_machine *machine)
908 {
909 st_oop y = pop_float (machine);
910 st_oop x = pop_float (machine);
911 st_oop result = ST_NIL;
912
913 if (machine->success)
914 result = st_float_new (st_float_value (x) - st_float_value (y));
915
916 if (machine->success)
917 ST_STACK_PUSH (machine, result);
918 else
919 ST_STACK_UNPOP (machine, 2);
920 }
921
922 static void
923 Float_lt (st_machine *machine)
924 {
925 st_oop y = pop_float (machine);
926 st_oop x = pop_float (machine);
927 st_oop result = ST_NIL;
928
929 if (machine->success)
930 result = isless (st_float_value (x), st_float_value (y)) ? ST_TRUE : ST_FALSE;
931
932 if (machine->success)
933 ST_STACK_PUSH (machine, result);
934 else
935 ST_STACK_UNPOP (machine, 2);
936 }
937
938 static void
939 Float_gt (st_machine *machine)
940 {
941 st_oop y = pop_float (machine);
942 st_oop x = pop_float (machine);
943 st_oop result = ST_NIL;
944
945 if (machine->success)
946 result = isgreater (st_float_value (x), st_float_value (y)) ? ST_TRUE : ST_FALSE;
947
948 if (machine->success)
949 ST_STACK_PUSH (machine, result);
950 else
951 ST_STACK_UNPOP (machine, 2);
952 }
953
954 static void
955 Float_le (st_machine *machine)
956 {
957 st_oop y = pop_float (machine);
958 st_oop x = pop_float (machine);
959 st_oop result = ST_NIL;
960
961 if (machine->success)
962 result = islessequal (st_float_value (x), st_float_value (y)) ? ST_TRUE : ST_FALSE;
963
964 if (machine->success)
965 ST_STACK_PUSH (machine, result);
966 else
967 ST_STACK_UNPOP (machine, 2);
968 }
969
970 static void
971 Float_ge (st_machine *machine)
972 {
973 st_oop y = pop_float (machine);
974 st_oop x = pop_float (machine);
975 st_oop result = ST_NIL;
976
977 if (machine->success)
978 result = isgreaterequal (st_float_value (x), st_float_value (y)) ? ST_TRUE : ST_FALSE;
979
980 if (machine->success)
981 ST_STACK_PUSH (machine, result);
982 else
983 ST_STACK_UNPOP (machine, 2);
984 }
985
986 static void
987 Float_eq (st_machine *machine)
988 {
989 st_oop y = pop_float (machine);
990 st_oop x = pop_float (machine);
991 st_oop result = ST_NIL;
992
993 if (machine->success)
994 result = (st_float_value (x) == st_float_value (y)) ? ST_TRUE : ST_FALSE;
995
996 if (machine->success)
997 ST_STACK_PUSH (machine, result);
998 else
999 ST_STACK_UNPOP (machine, 2);
1000 }
1001
1002 static void
1003 Float_ne (st_machine *machine)
1004 {
1005 st_oop y = pop_float (machine);
1006 st_oop x = pop_float (machine);
1007 st_oop result = ST_NIL;
1008
1009 if (machine->success)
1010 result = (st_float_value (x) != st_float_value (y)) ? ST_TRUE : ST_FALSE;
1011
1012 if (machine->success)
1013 ST_STACK_PUSH (machine, result);
1014 else
1015 ST_STACK_UNPOP (machine, 2);
1016 }
1017
1018 static void
1019 Float_mul (st_machine *machine)
1020 {
1021 st_oop y = pop_float (machine);
1022 st_oop x = pop_float (machine);
1023 st_oop result = ST_NIL;
1024
1025 if (machine->success)
1026 result = st_float_new (st_float_value (x) * st_float_value (y));
1027
1028 if (machine->success)
1029 ST_STACK_PUSH (machine, result);
1030 else
1031 ST_STACK_UNPOP (machine, 2);
1032 }
1033
1034 static void
1035 Float_div (st_machine *machine)
1036 {
1037 st_oop y = pop_float (machine);
1038 st_oop x = pop_float (machine);
1039 st_oop result = ST_NIL;
1040
1041 set_success (machine, y != 0);
1042
1043 if (machine->success)
1044 result = st_float_new (st_float_value (x) / st_float_value (y));
1045
1046 if (machine->success)
1047 ST_STACK_PUSH (machine, result);
1048 else
1049 ST_STACK_UNPOP (machine, 2);
1050 }
1051
1052 static void
1053 Float_sin (st_machine *machine)
1054 {
1055 st_oop receiver = ST_STACK_POP (machine);
1056 st_oop result;
1057 double value;
1058
1059 value = st_float_value (receiver);
1060
1061 result = st_float_new (sin (value));
1062
1063 if (machine->success)
1064 ST_STACK_PUSH (machine, result);
1065 else
1066 ST_STACK_UNPOP (machine, 1);
1067 }
1068
1069 static void
1070 Float_cos (st_machine *machine)
1071 {
1072 st_oop receiver = ST_STACK_POP (machine);
1073 st_oop result;
1074 double value;
1075
1076 value = st_float_value (receiver);
1077
1078 result = st_float_new (cos (value));
1079
1080 if (machine->success)
1081 ST_STACK_PUSH (machine, result);
1082 else
1083 ST_STACK_UNPOP (machine, 1);
1084 }
1085
1086 static void
1087 Float_tan (st_machine *machine)
1088 {
1089 st_oop receiver = ST_STACK_POP (machine);
1090 st_oop result;
1091 double value;
1092
1093 value = st_float_value (receiver);
1094
1095 result = st_float_new (tan (value));
1096
1097 if (machine->success)
1098 ST_STACK_PUSH (machine, result);
1099 else
1100 ST_STACK_UNPOP (machine, 1);
1101 }
1102
1103 static void
1104 Float_arcSin (st_machine *machine)
1105 {
1106 st_oop receiver = ST_STACK_POP (machine);
1107 st_oop result;
1108 double value;
1109
1110 value = st_float_value (receiver);
1111
1112 result = st_float_new (asin (value));
1113
1114 if (machine->success)
1115 ST_STACK_PUSH (machine, result);
1116 else
1117 ST_STACK_UNPOP (machine, 1);
1118 }
1119
1120 static void
1121 Float_arcCos (st_machine *machine)
1122 {
1123 st_oop receiver = ST_STACK_POP (machine);
1124 st_oop result;
1125 double value;
1126
1127 value = st_float_value (receiver);
1128
1129 result = st_float_new (acos (value));
1130
1131 if (machine->success)
1132 ST_STACK_PUSH (machine, result);
1133 else
1134 ST_STACK_UNPOP (machine, 1);
1135 }
1136
1137 static void
1138 Float_arcTan (st_machine *machine)
1139 {
1140 st_oop receiver = ST_STACK_POP (machine);
1141 st_oop result;
1142 double value;
1143
1144 value = st_float_value (receiver);
1145
1146 result = st_float_new (atan (value));
1147
1148 if (machine->success)
1149 ST_STACK_PUSH (machine, result);
1150 else
1151 ST_STACK_UNPOP (machine, 1);
1152 }
1153
1154 static void
1155 Float_sqrt (st_machine *machine)
1156 {
1157 st_oop receiver = ST_STACK_POP (machine);
1158 st_oop result;
1159 double value;
1160
1161 value = st_float_value (receiver);
1162
1163 result = st_float_new (sqrt (value));
1164
1165 if (machine->success)
1166 ST_STACK_PUSH (machine, result);
1167 else
1168 ST_STACK_UNPOP (machine, 1);
1169 }
1170
1171 static void
1172 Float_log (st_machine *machine)
1173 {
1174 st_oop receiver = ST_STACK_POP (machine);
1175 st_oop result;
1176 double value;
1177
1178 value = st_float_value (receiver);
1179
1180 result = st_float_new (log10 (value));
1181
1182 if (machine->success)
1183 ST_STACK_PUSH (machine, result);
1184 else
1185 ST_STACK_UNPOP (machine, 1);
1186 }
1187
1188 static void
1189 Float_ln (st_machine *machine)
1190 {
1191 st_oop receiver = ST_STACK_POP (machine);
1192 st_oop result;
1193 double value;
1194
1195 value = st_float_value (receiver);
1196
1197 result = st_float_new (log (value));
1198
1199 if (machine->success)
1200 ST_STACK_PUSH (machine, result);
1201 else
1202 ST_STACK_UNPOP (machine, 1);
1203 }
1204
1205 static void
1206 Float_exp (st_machine *machine)
1207 {
1208 st_oop receiver = ST_STACK_POP (machine);
1209 st_oop result;
1210 double value;
1211
1212 value = st_float_value (receiver);
1213
1214 result = st_float_new (exp (value));
1215
1216 if (machine->success)
1217 ST_STACK_PUSH (machine, result);
1218 else
1219 ST_STACK_UNPOP (machine, 1);
1220 }
1221
1222 static void
1223 Float_truncated (st_machine *machine)
1224 {
1225 st_oop receiver = ST_STACK_POP (machine);
1226 int result;
1227
1228 result = (int) trunc (st_float_value (receiver));
1229
1230 ST_STACK_PUSH (machine, st_smi_new (result));
1231 }
1232
1233 static void
1234 Float_fractionPart (st_machine *machine)
1235 {
1236 st_oop receiver = ST_STACK_POP (machine);
1237 double frac_part, int_part;
1238 st_oop result;
1239
1240 frac_part = modf (st_float_value (receiver), &int_part);
1241
1242 result = st_float_new (frac_part);
1243
1244 ST_STACK_PUSH (machine, result);
1245 }
1246
1247 static void
1248 Float_integerPart (st_machine *machine)
1249 {
1250 st_oop receiver = ST_STACK_POP (machine);
1251 double int_part;
1252 st_oop result;
1253
1254 modf (st_float_value (receiver), &int_part);
1255
1256 result = st_smi_new ((int) int_part);
1257 ST_STACK_PUSH (machine, result);
1258 }
1259
1260 static void
1261 Float_hash (st_machine *machine)
1262 {
1263 st_oop receiver = ST_STACK_POP (machine);
1264 unsigned int hash = 0;
1265 int result;
1266 double value;
1267 unsigned char *c;
1268
1269 value = st_float_value (receiver);
1270
1271 if (value == 0)
1272 value = fabs (value);
1273
1274 c = (unsigned char *) & value;
1275 for (int i = 0; i < sizeof (double); i++) {
1276 hash = (hash * 971) ^ c[i];
1277 }
1278
1279 result = hash;
1280
1281 if (result < 0)
1282 result = -result;
1283
1284 ST_STACK_PUSH (machine, st_smi_new (result));
1285 }
1286
1287 static void
1288 Float_printStringBase (st_machine *machine)
1289 {
1290 int base = pop_integer(machine);
1291 st_oop receiver = ST_STACK_POP (machine);
1292 char *tmp;
1293 st_oop string;
1294
1295 if (!machine->success ||
1296 !st_object_is_heap (receiver) ||
1297 st_object_format (receiver) != ST_FORMAT_FLOAT) {
1298 machine->success = false;
1299 ST_STACK_UNPOP (machine, 2);
1300 return;
1301 }
1302
1303 /* ignore base for the time being */
1304 tmp = st_strdup_printf ("%g", st_float_value (receiver));
1305 string = st_string_new (tmp);
1306 st_free (tmp);
1307
1308 ST_STACK_PUSH (machine, string);
1309 }
1310
1311 static void
1312 Object_error (st_machine *machine)
1313 {
1314 st_oop message;
1315 st_oop traceback;
1316 st_oop receiver;
1317
1318 traceback = ST_STACK_POP (machine);
1319 message = ST_STACK_POP (machine);
1320 receiver = ST_STACK_POP (machine);
1321
1322 if (!st_object_is_heap (traceback) ||
1323 st_object_format (traceback) != ST_FORMAT_BYTE_ARRAY) {
1324 /* can't resume execution in this prim */
1325 abort();
1326 }
1327
1328 if (!st_object_is_heap (message) ||
1329 st_object_format (message) != ST_FORMAT_BYTE_ARRAY) {
1330 /* can't resume execution in this prim */
1331 abort();
1332 }
1333
1334 printf ("An error occurred during program execution\n");
1335 printf ("message: %s\n\n", st_byte_array_bytes (message));
1336
1337 printf ("Traceback:\n");
1338 puts (st_byte_array_bytes (traceback));
1339
1340 /* set success to false to signal error */
1341 machine->success = false;
1342 longjmp (machine->main_loop, 0);
1343 }
1344
1345 static void
1346 Object_class (st_machine *machine)
1347 {
1348 st_oop object;
1349
1350 object = ST_STACK_POP (machine);
1351
1352 ST_STACK_PUSH (machine, st_object_class (object));
1353 }
1354
1355 static void
1356 Object_identityHash (st_machine *machine)
1357 {
1358 st_oop object;
1359 st_uint hash;
1360
1361 object = ST_STACK_POP (machine);
1362
1363 if (st_object_is_smi (object))
1364 hash = st_smi_hash (object);
1365 else if (st_object_is_character (object))
1366 hash = st_character_hash (object);
1367 else {
1368 st_object_set_hashed (object, true);
1369 hash = st_identity_hashtable_hash (memory->ht, object);
1370 }
1371 ST_STACK_PUSH (machine, st_smi_new (hash));
1372 }
1373
1374 static void
1375 Object_copy (st_machine *machine)
1376 {
1377 st_oop receiver;
1378 st_oop copy;
1379 st_oop class;
1380 int size;
1381
1382 (void) ST_STACK_POP (machine);
1383
1384 if (!st_object_is_heap (machine->message_receiver)) {
1385 ST_STACK_PUSH (machine, machine->message_receiver);
1386 return;
1387 }
1388
1389 switch (st_object_format (machine->message_receiver)) {
1390
1391 case ST_FORMAT_OBJECT:
1392 {
1393 class = ST_OBJECT_CLASS (machine->message_receiver);
1394 size = st_smi_value (ST_BEHAVIOR_INSTANCE_SIZE (class));
1395 copy = st_object_new (class);
1396 st_oops_copy (ST_OBJECT_FIELDS (copy),
1397 ST_OBJECT_FIELDS (machine->message_receiver),
1398 size);
1399 break;
1400
1401 }
1402 case ST_FORMAT_ARRAY:
1403 {
1404 size = st_smi_value (ST_ARRAYED_OBJECT (machine->message_receiver)->size);
1405 copy = st_object_new_arrayed (ST_OBJECT_CLASS (machine->message_receiver), size);
1406 st_oops_copy (ST_ARRAY (copy)->elements,
1407 ST_ARRAY (machine->message_receiver)->elements,
1408 size);
1409 break;
1410 }
1411 case ST_FORMAT_BYTE_ARRAY:
1412 {
1413 size = st_smi_value (ST_ARRAYED_OBJECT (machine->message_receiver)->size);
1414 copy = st_object_new_arrayed (ST_OBJECT_CLASS (machine->message_receiver), size);
1415 memcpy (st_byte_array_bytes (copy),
1416 st_byte_array_bytes (machine->message_receiver),
1417 size);
1418 break;
1419 }
1420 case ST_FORMAT_FLOAT_ARRAY:
1421 {
1422 size = st_smi_value (st_arrayed_object_size (machine->message_receiver));
1423 copy = st_object_new_arrayed (ST_OBJECT_CLASS (machine->message_receiver), size);
1424 memcpy (st_float_array_elements (copy),
1425 st_float_array_elements (machine->message_receiver),
1426 sizeof (double) * size);
1427
1428 break;
1429 }
1430 case ST_FORMAT_WORD_ARRAY:
1431 {
1432 size = st_smi_value (st_arrayed_object_size (machine->message_receiver));
1433 copy = st_object_new_arrayed (ST_OBJECT_CLASS (machine->message_receiver), size);
1434 memcpy (st_word_array_elements (copy),
1435 st_word_array_elements (machine->message_receiver),
1436 sizeof (st_uint) * size);
1437 break;
1438 }
1439 case ST_FORMAT_FLOAT:
1440 {
1441 copy = st_object_new (ST_FLOAT_CLASS);
1442 st_float_set_value (copy, st_float_value (machine->message_receiver));
1443 break;
1444 }
1445 case ST_FORMAT_LARGE_INTEGER:
1446 {
1447 mp_int value;
1448 int result;
1449
1450 copy = st_object_new (ST_LARGE_INTEGER_CLASS);
1451
1452 result = mp_init_copy (st_large_integer_value (copy),
1453 st_large_integer_value (machine->message_receiver));
1454 if (result != MP_OKAY)
1455 abort ();
1456 break;
1457 }
1458 case ST_FORMAT_HANDLE:
1459
1460 copy = st_object_new (ST_HANDLE_CLASS);
1461 ST_HANDLE_VALUE (copy) = ST_HANDLE_VALUE (machine->message_receiver);
1462 break;
1463 case ST_FORMAT_CONTEXT:
1464 case ST_FORMAT_INTEGER_ARRAY:
1465 default:
1466 /* not implemented yet */
1467 abort ();
1468 }
1469
1470 ST_STACK_PUSH (machine, copy);
1471 }
1472
1473 static void
1474 Object_equivalent (st_machine *machine)
1475 {
1476 st_oop y = ST_STACK_POP (machine);
1477 st_oop x = ST_STACK_POP (machine);
1478
1479 ST_STACK_PUSH (machine, ((x == y) ? ST_TRUE : ST_FALSE));
1480 }
1481
1482 static st_oop
1483 lookup_method (st_oop class, st_oop selector)
1484 {
1485 st_oop method;
1486 st_oop parent = class;
1487 st_uint index;
1488
1489 while (parent != ST_NIL) {
1490 method = st_dictionary_at (ST_BEHAVIOR_METHOD_DICTIONARY (parent), selector);
1491 if (method != ST_NIL)
1492 return method;
1493 parent = ST_BEHAVIOR_SUPERCLASS (parent);
1494 }
1495
1496 return 0;
1497 }
1498
1499 static void
1500 Object_perform (st_machine *machine)
1501 {
1502 st_oop receiver;
1503 st_oop selector;
1504 st_oop method;
1505 st_uint selector_index;
1506
1507 selector = machine->message_selector;
1508 machine->message_selector = machine->stack[machine->sp - machine->message_argcount];
1509 receiver = machine->message_receiver;
1510
1511 set_success (machine, st_object_is_symbol (machine->message_selector));
1512 method = lookup_method (st_object_class (receiver), machine->message_selector);
1513 set_success (machine, st_method_get_arg_count (method) == (machine->message_argcount - 1));
1514
1515 if (machine->success) {
1516 selector_index = machine->sp - machine->message_argcount;
1517
1518 st_oops_move (machine->stack + selector_index,
1519 machine->stack + selector_index + 1,
1520 machine->message_argcount - 1);
1521
1522 machine->sp -= 1;
1523 machine->message_argcount -= 1;
1524 machine->new_method = method;
1525 st_machine_execute_method (machine);
1526
1527 } else {
1528 machine->message_selector = selector;
1529 }
1530 }
1531
1532 static void
1533 Object_perform_withArguments (st_machine *machine)
1534 {
1535 st_oop receiver;
1536 st_oop selector;
1537 st_oop method;
1538 st_oop array;
1539 int array_size;
1540
1541 array = ST_STACK_POP (machine);
1542
1543 set_success (machine, st_object_format (array) == ST_FORMAT_ARRAY);
1544
1545 if (ST_OBJECT_CLASS (machine->context) == ST_BLOCK_CONTEXT_CLASS)
1546 method = ST_METHOD_CONTEXT_METHOD (ST_BLOCK_CONTEXT_HOME (machine->context));
1547 else
1548 method = ST_METHOD_CONTEXT_METHOD (machine->context);
1549
1550 array_size = st_smi_value (st_arrayed_object_size (array));
1551 set_success (machine, (machine->sp + array_size - 1) < 32);
1552
1553 if (machine->success) {
1554
1555 selector = machine->message_selector;
1556 machine->message_selector = ST_STACK_POP (machine);
1557 receiver = ST_STACK_PEEK (machine);
1558 machine->message_argcount = array_size;
1559
1560 set_success (machine, st_object_is_symbol (machine->message_selector));
1561
1562 st_oops_copy (machine->stack + machine->sp,
1563 st_array_elements (array),
1564 array_size);
1565
1566 machine->sp += array_size;
1567
1568 method = lookup_method (st_object_class (receiver), machine->message_selector);
1569 set_success (machine, st_method_get_arg_count (method) == array_size);
1570
1571 if (machine->success) {
1572 machine->new_method = method;
1573 st_machine_execute_method (machine);
1574 } else {
1575 machine->sp -= machine->message_argcount;
1576 ST_STACK_PUSH (machine, machine->message_selector);
1577 ST_STACK_PUSH (machine, array);
1578 machine->message_argcount = 2;
1579 machine->message_selector = selector;
1580 }
1581
1582 } else {
1583 ST_STACK_UNPOP (machine, 1);
1584 }
1585 }
1586
1587 static void
1588 Behavior_new (st_machine *machine)
1589 {
1590 st_oop class;
1591 st_oop instance;
1592 int format;
1593
1594 class = ST_STACK_POP (machine);
1595
1596 switch (st_smi_value (ST_BEHAVIOR_FORMAT (class))) {
1597 case ST_FORMAT_OBJECT:
1598 instance = st_object_allocate (class);
1599 break;
1600 case ST_FORMAT_CONTEXT:
1601 /* not implemented */
1602 abort ();
1603 break;
1604 case ST_FORMAT_FLOAT:
1605 instance = st_float_allocate (class);
1606 break;
1607 case ST_FORMAT_LARGE_INTEGER:
1608 instance = st_large_integer_allocate (class, NULL);
1609 break;
1610 case ST_FORMAT_HANDLE:
1611 instance = st_handle_allocate (class);
1612 break;
1613 default:
1614 /* should not reach */
1615 abort ();
1616 }
1617
1618 ST_STACK_PUSH (machine, instance);
1619 }
1620
1621 static void
1622 Behavior_newSize (st_machine *machine)
1623 {
1624 st_oop class;
1625 int size;
1626 int format;
1627 st_oop instance;
1628
1629 size = pop_integer32 (machine);
1630 class = ST_STACK_POP (machine);
1631
1632 switch (st_smi_value (ST_BEHAVIOR_FORMAT (class))) {
1633 case ST_FORMAT_ARRAY:
1634 instance = st_array_allocate (class, size);
1635 break;
1636 case ST_FORMAT_BYTE_ARRAY:
1637 instance = st_byte_array_allocate (class, size);
1638 break;
1639 case ST_FORMAT_WORD_ARRAY:
1640 instance = st_word_array_allocate (class, size);
1641 break;
1642 case ST_FORMAT_FLOAT_ARRAY:
1643 instance = st_float_array_allocate (class, size);
1644 break;
1645 case ST_FORMAT_INTEGER_ARRAY:
1646 /* not implemented */
1647 abort ();
1648 break;
1649 default:
1650 /* should not reach */
1651 abort ();
1652 }
1653
1654 ST_STACK_PUSH (machine, instance);
1655 }
1656
1657 static void
1658 Behavior_compile (st_machine *machine)
1659 {
1660 st_compiler_error error;
1661 st_oop receiver;
1662 st_oop string;
1663
1664 string = ST_STACK_POP (machine);
1665 receiver = ST_STACK_POP (machine);
1666 if (!st_object_is_heap (string) ||
1667 st_object_format (string) != ST_FORMAT_BYTE_ARRAY) {
1668 machine->success = false;
1669 ST_STACK_UNPOP (machine, 2);
1670 return;
1671 }
1672
1673 if (!st_compile_string (receiver,
1674 (char *) st_byte_array_bytes (string),
1675 &error)) {
1676 machine->success = false;
1677 ST_STACK_UNPOP (machine, 2);
1678 return;
1679 }
1680
1681 ST_STACK_PUSH (machine, receiver);
1682 }
1683
1684 static void
1685 SequenceableCollection_size (st_machine *machine)
1686 {
1687 st_oop object;
1688
1689 object = ST_STACK_POP (machine);
1690
1691 ST_STACK_PUSH (machine, st_arrayed_object_size (object));
1692 }
1693
1694 static void
1695 Array_at (st_machine *machine)
1696 {
1697 int index = pop_integer32 (machine);
1698 st_oop receiver = ST_STACK_POP (machine);
1699
1700 if (ST_UNLIKELY (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver)))) {
1701 set_success (machine, false);
1702 ST_STACK_UNPOP (machine, 2);
1703 return;
1704 }
1705
1706 ST_STACK_PUSH (machine, st_array_at (receiver, index));
1707 }
1708
1709 static void
1710 Array_at_put (st_machine *machine)
1711 {
1712 st_oop object = ST_STACK_POP (machine);
1713 int index = pop_integer32 (machine);
1714 st_oop receiver = ST_STACK_POP (machine);
1715
1716 if (ST_UNLIKELY (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver)))) {
1717 set_success (machine, false);
1718 ST_STACK_UNPOP (machine, 3);
1719 return;
1720 }
1721
1722 st_array_at_put (receiver, index, object);
1723 ST_STACK_PUSH (machine, object);
1724 }
1725
1726 static void
1727 ByteArray_at (st_machine *machine)
1728 {
1729 int index = pop_integer32 (machine);
1730 st_oop receiver = ST_STACK_POP (machine);
1731 st_oop result;
1732
1733 if (!machine->success) {
1734 ST_STACK_UNPOP (machine, 2);
1735 return;
1736 }
1737
1738 if (ST_UNLIKELY (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver)))) {
1739 set_success (machine, false);
1740 ST_STACK_UNPOP (machine, 2);
1741 return;
1742 }
1743
1744 result = st_smi_new (st_byte_array_at (receiver, index));
1745
1746 ST_STACK_PUSH (machine, result);
1747 }
1748
1749 static void
1750 ByteArray_at_put (st_machine *machine)
1751 {
1752 int byte = pop_integer (machine);
1753 int index = pop_integer32 (machine);
1754 st_oop receiver = ST_STACK_POP (machine);
1755
1756 if (!machine->success) {
1757 ST_STACK_UNPOP (machine, 3);
1758 return;
1759 }
1760
1761 if (ST_UNLIKELY (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver)))) {
1762 set_success (machine, false);
1763 ST_STACK_UNPOP (machine, 3);
1764 return;
1765 }
1766
1767 st_byte_array_at_put (receiver, index, byte);
1768
1769 ST_STACK_PUSH (machine, st_smi_new (byte));
1770 }
1771
1772 static void
1773 ByteArray_hash (st_machine *machine)
1774 {
1775 st_oop receiver = ST_STACK_POP (machine);
1776 st_uint hash;
1777
1778 hash = st_byte_array_hash (receiver);
1779
1780 ST_STACK_PUSH (machine, st_smi_new (hash));
1781 }
1782
1783 static void
1784 ByteString_at (st_machine *machine)
1785 {
1786 int index = pop_integer32 (machine);
1787 st_oop receiver = ST_STACK_POP (machine);
1788 st_oop character;
1789 char *charptr;
1790
1791 if (ST_UNLIKELY (!machine->success)) {
1792 ST_STACK_UNPOP (machine, 2);
1793 return;
1794 }
1795
1796 if (ST_UNLIKELY (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver)))) {
1797 set_success (machine, false);
1798 ST_STACK_UNPOP (machine, 2);
1799 return;
1800 }
1801
1802 character = st_character_new (st_byte_array_at (receiver, index));
1803
1804 ST_STACK_PUSH (machine, character);
1805 }
1806
1807 static void
1808 ByteString_at_put (st_machine *machine)
1809 {
1810 st_oop character = ST_STACK_POP (machine);
1811 int index = pop_integer32 (machine);
1812 st_oop receiver = ST_STACK_POP (machine);
1813
1814 if (!machine->success) {
1815 ST_STACK_UNPOP (machine, 3);
1816 return;
1817 }
1818
1819 set_success (machine, st_object_class (character) == ST_CHARACTER_CLASS);
1820
1821 if (ST_UNLIKELY (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver)))) {
1822 set_success (machine, false);
1823 ST_STACK_UNPOP (machine, 3);
1824 return;
1825 }
1826
1827 st_byte_array_at_put (receiver, index, (st_uchar) st_character_value (character));
1828
1829 ST_STACK_PUSH (machine, character);
1830 }
1831
1832
1833 static void
1834 ByteString_size (st_machine *machine)
1835 {
1836 st_oop receiver;
1837 st_uint size;
1838
1839 receiver = ST_STACK_POP (machine);
1840
1841 size = st_arrayed_object_size (receiver);
1842
1843 /* TODO: allow size to go into a LargeInteger on overflow */
1844 ST_STACK_PUSH (machine, size);
1845 }
1846
1847 static void
1848 ByteString_compare (st_machine *machine)
1849 {
1850 st_oop argument = ST_STACK_POP (machine);
1851 st_oop receiver = ST_STACK_POP (machine);
1852 int order;
1853
1854 if (st_object_format (argument) != ST_FORMAT_BYTE_ARRAY)
1855 set_success (machine, false);
1856
1857 if (machine->success)
1858 order = strcmp ((const char *) st_byte_array_bytes (receiver),
1859 (const char *) st_byte_array_bytes (argument));
1860
1861 if (machine->success)
1862 ST_STACK_PUSH (machine, st_smi_new (order));
1863 else
1864 ST_STACK_UNPOP (machine, 2);
1865 }
1866
1867 static void
1868 WideString_at (st_machine *machine)
1869 {
1870 int index = pop_integer32 (machine);
1871 st_oop receiver = ST_STACK_POP (machine);
1872 st_uchar *bytes;
1873 st_unichar c;
1874
1875 if (!machine->success) {
1876 ST_STACK_UNPOP (machine, 2);
1877 return;
1878 }
1879
1880 if (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver))) {
1881 set_success (machine, false);
1882 ST_STACK_UNPOP (machine, 2);
1883 return;
1884 }
1885
1886 c = st_word_array_at (receiver, index);
1887
1888 ST_STACK_PUSH (machine, st_character_new (c));
1889 }
1890
1891 static void
1892 WideString_at_put (st_machine *machine)
1893 {
1894 st_oop character = ST_STACK_POP (machine);
1895 int index = pop_integer32 (machine);
1896 st_oop receiver = ST_STACK_POP (machine);
1897 st_uchar *bytes;
1898 st_unichar c;
1899
1900 if (!machine->success) {
1901 ST_STACK_UNPOP (machine, 3);
1902 return;
1903 }
1904
1905 set_success (machine, st_object_class (character) == ST_CHARACTER_CLASS);
1906
1907 if (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver))) {
1908 set_success (machine, false);
1909 ST_STACK_UNPOP (machine, 3);
1910 return;
1911 }
1912
1913 st_word_array_at_put (receiver, index, character);
1914
1915 ST_STACK_PUSH (machine, character);
1916 }
1917
1918 static void
1919 WordArray_at (st_machine *machine)
1920 {
1921 st_oop receiver;
1922 int index;
1923 st_uint element;
1924
1925 index = pop_integer32 (machine);
1926 receiver = ST_STACK_POP (machine);
1927
1928 if (ST_UNLIKELY (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver)))) {
1929 set_success (machine, false);
1930 ST_STACK_UNPOP (machine, 2);
1931 return;
1932 }
1933
1934 element = st_word_array_at (receiver, index);
1935
1936 ST_STACK_PUSH (machine, st_smi_new (element));
1937 }
1938
1939 static void
1940 WordArray_at_put (st_machine *machine)
1941 {
1942 int value = pop_integer (machine);
1943 int index = pop_integer32 (machine);
1944 st_oop receiver = ST_STACK_POP (machine);
1945
1946 if (!machine->success) {
1947 ST_STACK_UNPOP (machine, 3);
1948 return;
1949 }
1950
1951 if (ST_UNLIKELY (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver)))) {
1952 set_success (machine, false);
1953 ST_STACK_UNPOP (machine, 3);
1954 return;
1955 }
1956
1957 st_word_array_at_put (receiver, index, value);
1958
1959 ST_STACK_PUSH (machine, st_smi_new (value));
1960 }
1961
1962 static void
1963 FloatArray_at (st_machine *machine)
1964 {
1965 st_oop receiver;
1966 int index;
1967 double element;
1968
1969 index = pop_integer32 (machine);
1970 receiver = ST_STACK_POP (machine);
1971
1972 if (ST_UNLIKELY (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver)))) {
1973 set_success (machine, false);
1974 ST_STACK_UNPOP (machine, 2);
1975 return;
1976 }
1977
1978 element = st_float_array_at (receiver, index);
1979 ST_STACK_PUSH (machine, st_float_new (element));
1980 }
1981
1982 static void
1983 FloatArray_at_put (st_machine *machine)
1984 {
1985 st_oop flt = ST_STACK_POP (machine);
1986 int index = pop_integer32 (machine);
1987 st_oop receiver = ST_STACK_POP (machine);
1988
1989 set_success (machine, st_object_is_heap (flt) &&
1990 st_object_format (flt) == ST_FORMAT_FLOAT);
1991
1992 if (ST_UNLIKELY (index < 1 || index > st_smi_value (st_arrayed_object_size (receiver)))) {
1993 set_success (machine, false);
1994 ST_STACK_UNPOP (machine, 3);
1995 return;
1996 }
1997
1998 if (!machine->success) {
1999 ST_STACK_UNPOP (machine, 3);
2000 return;
2001 }
2002
2003 st_float_array_at_put (receiver, index, st_float_value (flt));
2004 ST_STACK_PUSH (machine, flt);
2005 }
2006
2007 static void
2008 BlockContext_value (st_machine *machine)
2009 {
2010 st_oop block;
2011 st_uint argcount;
2012 st_oop home;
2013
2014 block = machine->message_receiver;
2015 argcount = st_smi_value (ST_BLOCK_CONTEXT_ARGCOUNT (block));
2016 if (ST_UNLIKELY (argcount != machine->message_argcount)) {
2017 machine->success = false;
2018 return;
2019 }
2020
2021 st_oops_copy (ST_BLOCK_CONTEXT_STACK (block),
2022 machine->stack + machine->sp - argcount,
2023 argcount);
2024 machine->sp -= machine->message_argcount + 1;
2025
2026 ST_CONTEXT_PART_IP (block) = ST_BLOCK_CONTEXT_INITIALIP (block);
2027 ST_CONTEXT_PART_SP (block) = st_smi_new (argcount);
2028 ST_CONTEXT_PART_SENDER (block) = machine->context;
2029
2030 st_machine_set_active_context (machine, block);
2031 }
2032
2033 static void
2034 BlockContext_valueWithArguments (st_machine *machine)
2035 {
2036 st_oop block;
2037 st_oop values;
2038 int argcount;
2039
2040 block = machine->message_receiver;
2041 values = ST_STACK_PEEK (machine);
2042
2043 if (st_object_class (values) != ST_ARRAY_CLASS) {
2044 set_success (machine, false);
2045 return;
2046 }
2047
2048 argcount = st_smi_value (ST_BLOCK_CONTEXT_ARGCOUNT (block));
2049 if (argcount != st_smi_value (st_arrayed_object_size (values))) {
2050 set_success (machine, false);
2051 return;
2052 }
2053
2054 st_oops_copy (ST_BLOCK_CONTEXT_STACK (block),
2055 ST_ARRAY (values)->elements,
2056 argcount);
2057
2058 machine->sp -= machine->message_argcount + 1;
2059
2060 ST_CONTEXT_PART_IP (block) = ST_BLOCK_CONTEXT_INITIALIP (block);
2061 ST_CONTEXT_PART_SP (block) = st_smi_new (argcount);
2062 ST_CONTEXT_PART_SENDER (block) = machine->context;
2063
2064 st_machine_set_active_context (machine, block);
2065 }
2066
2067 static void
2068 System_exitWithResult (st_machine *machine)
2069 {
2070 /* set success to true to signal that everything was alright */
2071 machine->success = true;
2072 longjmp (machine->main_loop, 0);
2073 }
2074
2075 static void
2076 Character_value (st_machine *machine)
2077 {
2078 st_oop receiver = ST_STACK_POP (machine);
2079
2080 ST_STACK_PUSH (machine, st_smi_new (st_character_value (receiver)));
2081 }
2082
2083 static void
2084 Character_characterFor (st_machine *machine)
2085 {
2086 st_oop receiver;
2087 int value;
2088
2089 value = pop_integer (machine);
2090 receiver = ST_STACK_POP (machine);
2091
2092 if (machine->success)
2093 ST_STACK_PUSH (machine, st_character_new (value));
2094 else
2095 ST_STACK_UNPOP (machine, 2);
2096 }
2097
2098 static void
2099 FileStream_open (st_machine *machine)
2100 {
2101 st_oop filename;
2102 st_oop handle;
2103 char *str;
2104 int flags, mode;
2105 int fd;
2106
2107 mode = pop_integer32 (machine);
2108 filename = ST_STACK_POP (machine);
2109 if (st_object_format (filename) != ST_FORMAT_BYTE_ARRAY) {
2110 machine->success = false;
2111 ST_STACK_UNPOP (machine, 2);
2112 return;
2113 }
2114
2115 if (mode == 0)
2116 flags = O_RDONLY;
2117 else if (mode == 1)
2118 flags = O_WRONLY;
2119 else {
2120 machine->success = false;
2121 ST_STACK_UNPOP (machine, 2);
2122 return;
2123 }
2124
2125 str = st_byte_array_bytes (filename);
2126
2127 fd = open (str, O_WRONLY | O_CREAT, 0644);
2128 if (fd < 0) {
2129 fprintf (stderr, strerror (errno));
2130 machine->success = false;
2131 ST_STACK_UNPOP (machine, 2);
2132 return;
2133 }
2134
2135 ftruncate (fd, 0);
2136
2137 /* pop receiver */
2138 (void) ST_STACK_POP (machine);
2139
2140 handle = st_object_new (ST_HANDLE_CLASS);
2141 ST_HANDLE_VALUE (handle) = fd;
2142
2143 ST_STACK_PUSH (machine, handle);
2144 }
2145
2146 static void
2147 FileStream_close (st_machine *machine)
2148 {
2149 st_oop handle;
2150 int fd;
2151
2152 handle = ST_STACK_POP (machine);
2153 fd = ST_HANDLE_VALUE (handle);
2154
2155 if (close (fd) < 0) {
2156 machine->success = false;
2157 ST_STACK_UNPOP (machine, 1);
2158 return;
2159 }
2160
2161 /* leave receiver on stack */
2162
2163 }
2164
2165 static void
2166 FileStream_write (st_machine *machine)
2167 {
2168 st_oop handle;
2169 st_oop array;
2170 int fd;
2171 char *buffer;
2172 size_t total, size;
2173 ssize_t count;
2174
2175 array = ST_STACK_POP (machine);
2176 handle = ST_STACK_POP (machine);
2177 if (st_object_format (array) != ST_FORMAT_BYTE_ARRAY) {
2178 machine->success = false;
2179 ST_STACK_UNPOP (machine, 1);
2180 return;
2181 }
2182 if (st_object_format (handle) != ST_FORMAT_HANDLE) {
2183 machine->success = false;
2184 ST_STACK_UNPOP (machine, 2);
2185 return;
2186 }
2187
2188 fd = ST_HANDLE_VALUE (handle);
2189 buffer = st_byte_array_bytes (array);
2190 size = st_smi_value (st_arrayed_object_size (array));
2191
2192 total = 0;
2193 while (total < size) {
2194 count = write (fd, buffer + total, size - total);
2195 if (count < 0) {
2196 machine->success = false;
2197 ST_STACK_UNPOP (machine, 2);
2198 return;
2199 }
2200 total += count;
2201 }
2202
2203 /* leave receiver on stack */
2204 }
2205
2206 static void
2207 FileStream_seek (st_machine *machine)
2208 {
2209 /* not implemented yet */
2210 abort ();
2211 }
2212
2213 static void
2214 FileStream_read (st_machine *machine)
2215 {
2216 /* not implemented yet */
2217 abort ();
2218 }
2219
2220 const struct st_primitive st_primitives[] = {
2221 { "SmallInteger_add", SmallInteger_add },
2222 { "SmallInteger_sub", SmallInteger_sub },
2223 { "SmallInteger_lt", SmallInteger_lt },
2224 { "SmallInteger_gt", SmallInteger_gt },
2225 { "SmallInteger_le", SmallInteger_le },
2226 { "SmallInteger_ge", SmallInteger_ge },
2227 { "SmallInteger_eq", SmallInteger_eq },
2228 { "SmallInteger_ne", SmallInteger_ne },
2229 { "SmallInteger_mul", SmallInteger_mul },
2230 { "SmallInteger_div", SmallInteger_div },
2231 { "SmallInteger_intDiv", SmallInteger_intDiv },
2232 { "SmallInteger_mod", SmallInteger_mod },
2233 { "SmallInteger_bitOr", SmallInteger_bitOr },
2234 { "SmallInteger_bitXor", SmallInteger_bitXor },
2235 { "SmallInteger_bitAnd", SmallInteger_bitAnd },
2236 { "SmallInteger_bitShift", SmallInteger_bitShift },
2237 { "SmallInteger_asFloat", SmallInteger_asFloat },
2238 { "SmallInteger_asLargeInteger", SmallInteger_asLargeInteger },
2239
2240 { "LargeInteger_add", LargeInteger_add },
2241 { "LargeInteger_sub", LargeInteger_sub },
2242 { "LargeInteger_lt", LargeInteger_lt },
2243 { "LargeInteger_gt", LargeInteger_gt },
2244 { "LargeInteger_le", LargeInteger_le },
2245 { "LargeInteger_ge", LargeInteger_ge },
2246 { "LargeInteger_eq", LargeInteger_eq },
2247 { "LargeInteger_ne", LargeInteger_ne },
2248 { "LargeInteger_mul", LargeInteger_mul },
2249 { "LargeInteger_div", LargeInteger_div },
2250 { "LargeInteger_intDiv", LargeInteger_intDiv },
2251 { "LargeInteger_mod", LargeInteger_mod },
2252 { "LargeInteger_gcd", LargeInteger_gcd },
2253 { "LargeInteger_lcm", LargeInteger_lcm },
2254 { "LargeInteger_squared", LargeInteger_squared },
2255 { "LargeInteger_bitOr", LargeInteger_bitOr },
2256 { "LargeInteger_bitXor", LargeInteger_bitXor },
2257 { "LargeInteger_bitAnd", LargeInteger_bitAnd },
2258 { "LargeInteger_bitShift", LargeInteger_bitShift },
2259 { "LargeInteger_printStringBase", LargeInteger_printStringBase },
2260 { "LargeInteger_asFloat", LargeInteger_asFloat },
2261 { "LargeInteger_hash", LargeInteger_hash },
2262
2263 { "Float_add", Float_add },
2264 { "Float_sub", Float_sub },
2265 { "Float_lt", Float_lt },
2266 { "Float_gt", Float_gt },
2267 { "Float_le", Float_le },
2268 { "Float_ge", Float_ge },
2269 { "Float_eq", Float_eq },
2270 { "Float_ne", Float_ne },
2271 { "Float_mul", Float_mul },
2272 { "Float_div", Float_div },
2273 { "Float_exp", Float_exp },
2274 { "Float_sin", Float_sin },
2275 { "Float_cos", Float_cos },
2276 { "Float_tan", Float_tan },
2277 { "Float_arcSin", Float_arcSin },
2278 { "Float_arcCos", Float_arcCos },
2279 { "Float_arcTan", Float_arcTan },
2280 { "Float_ln", Float_ln },
2281 { "Float_log", Float_log },
2282 { "Float_sqrt", Float_sqrt },
2283 { "Float_truncated", Float_truncated },
2284 { "Float_fractionPart", Float_fractionPart },
2285 { "Float_integerPart", Float_integerPart },
2286 { "Float_hash", Float_hash },
2287 { "Float_printStringBase", Float_printStringBase },
2288
2289 { "Object_error", Object_error },
2290 { "Object_class", Object_class },
2291 { "Object_identityHash", Object_identityHash },
2292 { "Object_copy", Object_copy },
2293 { "Object_equivalent", Object_equivalent },
2294 { "Object_perform", Object_perform },
2295 { "Object_perform_withArguments", Object_perform_withArguments },
2296
2297 { "Behavior_new", Behavior_new },
2298 { "Behavior_newSize", Behavior_newSize },
2299 { "Behavior_compile", Behavior_compile },
2300
2301
2302 { "SequenceableCollection_size", SequenceableCollection_size },
2303
2304 { "Array_at", Array_at },
2305 { "Array_at_put", Array_at_put },
2306
2307 { "ByteArray_at", ByteArray_at },
2308 { "ByteArray_at_put", ByteArray_at_put },
2309 { "ByteArray_hash", ByteArray_hash },
2310
2311 { "ByteString_at", ByteString_at },
2312 { "ByteString_at_put", ByteString_at_put },
2313 { "ByteString_size", ByteString_size },
2314 { "ByteString_compare", ByteString_compare },
2315
2316 { "WideString_at", WideString_at },
2317 { "WideString_at_put", WideString_at_put },
2318
2319 { "WordArray_at", WordArray_at },
2320 { "WordArray_at_put", WordArray_at_put },
2321
2322 { "FloatArray_at", FloatArray_at },
2323 { "FloatArray_at_put", FloatArray_at_put },
2324
2325 { "System_exitWithResult", System_exitWithResult },
2326
2327 { "Character_value", Character_value },
2328 { "Character_characterFor", Character_characterFor },
2329
2330 { "BlockContext_value", BlockContext_value },
2331 { "BlockContext_valueWithArguments", BlockContext_valueWithArguments },
2332
2333 { "FileStream_open", FileStream_open },
2334 { "FileStream_close", FileStream_close },
2335 { "FileStream_read", FileStream_read },
2336 { "FileStream_write", FileStream_write },
2337 { "FileStream_seek", FileStream_seek },
2338
2339 };
2340
2341 /* returns 0 if there no primitive function corresponding
2342 * to the given name */
2343 int
2344 st_primitive_index_for_name (const char *name)
2345 {
2346 st_assert (name != NULL);
2347 for (int i = 0; i < ST_N_ELEMENTS (st_primitives); i++)
2348 if (streq (name, st_primitives[i].name))
2349 return i;
2350 return -1;
2351 }
2352
A Smalltalk implementation