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