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