| blob | ecec0384d5b7f9288432afe1aeb007e517070858 |
1 #!perl
2 # Copyright (C) 2001-2009, Parrot Foundation.
3 # $Id$
5 use strict;
6 use warnings;
7 use lib qw( . lib ../lib ../../lib );
9 use Test::More;
10 use Parrot::Test tests => 99;
12 =head1 NAME
14 t/op/calling.t - Parrot Calling Conventions
16 =head1 SYNOPSIS
18 % prove t/op/calling.t
20 =head1 DESCRIPTION
22 Tests Parrot calling conventions.
24 =cut
26 pasm_output_is( <<'CODE', <<'OUTPUT', "set_args - parsing" );
27 noop
28 set_args "0, 0", P0, I0
29 print "Ok 1\n"
30 set_args ""
31 print "Ok 2\n"
32 end
33 CODE
34 Ok 1
35 Ok 2
36 OUTPUT
38 pasm_output_is( <<'CODE', <<'OUTPUT', "var_args - parsing" );
39 .pcc_sub main:
40 print "Ok 1\n"
41 set_args "0, 0", P0, I0
42 find_name P1, "foo"
43 print "Ok 2\n"
44 invokecc P1
45 print "Ok 5\n"
46 get_results "0", I0
47 print "Ok 6\n"
48 end
49 .pcc_sub foo:
50 get_params "0, 0", P0, I0
51 print "Ok 3\n"
52 set_returns "0", 42
53 print "Ok 4\n"
54 returncc
55 CODE
56 Ok 1
57 Ok 2
58 Ok 3
59 Ok 4
60 Ok 5
61 Ok 6
62 OUTPUT
64 pasm_output_is( <<'CODE', <<'OUTPUT', "call - i, ic" );
65 .pcc_sub main:
66 set I16, 77
67 set_args "0, 0", 42, I16
68 find_name P1, "foo"
69 invokecc P1
70 print "back\n"
71 end
72 .pcc_sub foo:
73 get_params "0, 0", I16, I17
74 print I16
75 print "\n"
76 print I17
77 print "\n"
78 returncc
79 CODE
80 42
81 77
82 back
83 OUTPUT
85 pasm_output_is( <<'CODE', <<'OUTPUT', "call - i, ic, return i, ic" );
86 .pcc_sub main:
87 set I16, 77
88 set_args "0, 0", 42, I16
89 find_name P1, "foo"
90 invokecc P1
91 get_results "0, 0", I16, I17
92 print I16
93 print "\n"
94 print I17
95 print "\nback\n"
96 end
97 .pcc_sub foo:
98 get_params "0, 0", I16, I17
99 print I16
100 print "\n"
101 print I17
102 print "\n"
103 set I16, 88
104 set_returns "0, 0", 99, I16
105 returncc
106 CODE
107 42
108 77
109 99
110 88
111 back
112 OUTPUT
114 pasm_output_is( <<'CODE', <<'OUTPUT', "call - i, ic, return i, ic - adjust sig" );
115 .pcc_sub main:
116 set I16, 77
117 set_args "0, 0", 42, I16
118 find_name P1, "foo"
119 invokecc P1
120 get_results "0, 0", I16, I17
121 print I16
122 print "\n"
123 print I17
124 print "\nback\n"
125 end
126 .pcc_sub foo:
127 get_params "0, 0", I16, I17
128 print I16
129 print "\n"
130 print I17
131 print "\n"
132 set I16, 88
133 set_returns "0, 0", 99, I16
134 returncc
135 CODE
136 42
137 77
138 99
139 88
140 back
141 OUTPUT
143 pasm_output_is( <<'CODE', <<'OUTPUT', "all together now" );
144 .pcc_sub main:
145 set I16, 77
146 set N16, 2.3
147 set S16, "ok 1\n"
148 new P16, 'Integer'
149 set P16, 101
150 set_args "0, 0, 0, 0, 0, 0, 0", 42, I16, 4.5, N16, S16, "ok 2\n", P16
151 find_name P1, "foo"
152 invokecc P1
153 get_results "0, 0, 0, 0", I16, N16, S16, P16
154 print I16
155 print "\n"
156 print N16
157 print "\n"
158 print S16
159 print P16
160 end
161 .pcc_sub foo:
162 get_params "0, 0, 0, 0, 0, 0, 0", I16, I17, N16, N17, S16, S17, P16
163 print I16
164 print "\n"
165 print I17
166 print "\n"
167 print N16
168 print "\n"
169 print N17
170 print "\n"
171 print S16
172 print S17
173 print P16
174 print "\n"
175 set I16, 88
176 set N16, 5.5
177 set S16, "ok 3\n"
178 new P16, 'String'
179 set P16, "ok 4\n"
180 set_returns "0, 0, 0, 0", I16, N16, S16, P16
181 returncc
182 CODE
183 42
184 77
185 4.5
186 2.3
187 ok 1
188 ok 2
189 101
190 88
191 5.5
192 ok 3
193 ok 4
194 OUTPUT
196 pasm_output_is( <<'CODE', <<'OUTPUT', "flatten arg" );
197 .pcc_sub main:
198 new P16, 'String'
199 set P16, "ok 1\n"
200 new P17, 'ResizablePMCArray'
201 push P17, "ok 2\n"
202 push P17, "ok 3\n"
203 push P17, "ok 4\n"
204 new P18, 'String'
205 set P18, "ok 5\n"
206 set_args "0, 0x20, 0", P16, P17, P18
207 find_name P1, "foo"
208 invokecc P1
209 print "back\n"
210 end
211 .pcc_sub foo:
212 get_params "0, 0, 0, 0, 0", P1, P2, P3, P4, P5
213 print P1
214 print P2
215 print P3
216 print P4
217 print P5
218 returncc
219 CODE
220 ok 1
221 ok 2
222 ok 3
223 ok 4
224 ok 5
225 back
226 OUTPUT
228 pasm_output_is( <<'CODE', <<'OUTPUT', "slurpy param" );
229 .pcc_sub main:
230 new P16, 'String'
231 set P16, "ok 1\n"
232 new P17, 'String'
233 set P17, "ok 2\n"
234 new P18, 'String'
235 set P18, "ok 3\n"
236 set_args "0, 0, 0", P16, P17, P18
237 find_name P1, "foo"
238 invokecc P1
239 print "back\n"
240 end
241 .pcc_sub foo:
242 get_params "0, 0x20", P1, P2
243 print P1
244 set I0, P2
245 print I0
246 print "\n"
247 set S0, P2[0]
248 print S0
249 set S0, P2[1]
250 print S0
251 returncc
252 CODE
253 ok 1
254 2
255 ok 2
256 ok 3
257 back
258 OUTPUT
260 pir_output_is( <<'CODE', <<'OUTPUT', "use it in PIR" );
261 .sub main :main
262 $P0 = new 'String'
263 $P0 = "hello\n"
264 find_name $P1, "foo"
265 # set_args and invoke must be adjacent
266 set_args "0", $P0
267 invokecc $P1
268 .end
269 .sub foo
270 get_params "0", $P0
271 print $P0
272 .end
273 CODE
274 hello
275 OUTPUT
277 pasm_output_is( <<'CODE', <<'OUTPUT', "flatten + slurpy param" );
278 .pcc_sub main:
279 new P16, 'String'
280 set P16, "ok 1\n"
281 new P19, 'ResizablePMCArray'
282 new P17, 'String'
283 set P17, "ok 2\n"
284 push P19, P17
285 new P18, 'String'
286 set P18, "ok 3\n"
287 push P19, P18
288 new P20, 'ResizablePMCArray'
289 new P17, 'String'
290 set P17, "ok 4\n"
291 push P20, P17
292 new P18, 'String'
293 set P18, "ok 5\n"
294 push P20, P18
295 new P21, 'String'
296 set P21, "ok 6\n"
297 set_args "0, 0x20, 0x20, 0", P16, P19, P20, P21
298 find_name P1, "foo"
299 invokecc P1
300 print "back\n"
301 end
302 .pcc_sub foo:
303 get_params "0, 0x20", P1, P2
304 print P1
305 set I0, P2
306 print I0
307 print "\n"
308 set S0, P2[0]
309 print S0
310 set S0, P2[1]
311 print S0
312 set S0, P2[2]
313 print S0
314 set S0, P2[3]
315 print S0
316 set S0, P2[4]
317 print S0
318 set P0, P2[5]
319 if_null P0, ok
320 print "not ok 7\n"
321 ok:
322 returncc
323 CODE
324 ok 1
325 5
326 ok 2
327 ok 3
328 ok 4
329 ok 5
330 ok 6
331 back
332 OUTPUT
334 pir_output_is( <<'CODE', <<'OUTPUT', "use it in PIR" );
335 .sub main :main
336 $P0 = new 'String'
337 $P0 = "hello\n"
338 find_name $P1, "foo"
339 # set_args and invoke must be adjacent
340 set_args "0", $P0
341 invokecc $P1
342 .end
343 .sub foo
344 get_params "0", $P0
345 print $P0
346 .end
347 CODE
348 hello
349 OUTPUT
351 pir_output_is( <<'CODE', <<'OUTPUT', "type conversion - autobox" );
352 .sub main :main
353 $P0 = new 'String'
354 $P0 = "hello"
355 find_name $P1, "foo"
356 # set_args and invoke must be adjacent
357 set_args "0,0,0", $P0, 42, "bar"
358 invokecc $P1
359 .end
360 .sub foo
361 get_params "0x20", $P0
362 $S0 = $P0[0]
363 print $S0
364 print ' '
365 $S0 = $P0[1]
366 print $S0
367 print ' '
368 $S0 = $P0[2]
369 print $S0
370 print "\n"
371 .end
372 CODE
373 hello 42 bar
374 OUTPUT
376 pir_output_is( <<'CODE', <<'OUTPUT', "more autobox" );
377 .sub main :main
378 foo( 101, 0.77, 'seven and seven is' )
379 .end
381 .sub foo
382 .param pmc some_int
383 .param pmc some_float
384 .param pmc some_string
386 $S0 = typeof some_int
387 print $S0
388 print "\n"
390 $S0 = typeof some_float
391 print $S0
392 print "\n"
394 $S0 = typeof some_string
395 print $S0
396 print "\n"
398 .return()
399 .end
400 CODE
401 Integer
402 Float
403 String
404 OUTPUT
406 pir_output_is( <<'CODE', <<'OUTPUT', "type conversion - fetch" );
407 .sub main :main
408 $P0 = new 'String'
409 $P0 = "hello"
410 $P1 = new 'Integer'
411 $P1 = 42
412 $P2 = new 'String'
413 $P2 = "again"
414 $P3 = new 'Float'
415 $P3 = 47.11
416 find_name $P10, "foo"
417 # set_args and invoke must be adjacent
418 set_args "0,0,0,0", $P0, $P1, $P2, $P3
419 invokecc $P10
420 .end
421 .sub foo
422 get_params "0,0,0,0", $P0, $I0, $S0, $N0
423 print $P0
424 print ' '
425 print $I0
426 print ' '
427 print $S0
428 print ' '
429 print $N0
430 print "\n"
431 returncc
432 .end
433 CODE
434 hello 42 again 47.11
435 OUTPUT
437 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too few" );
438 .sub main :main
439 .include "errors.pasm"
440 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
441 $P0 = new 'String'
442 $P0 = "hello\n"
443 find_name $P1, "foo"
444 set_args "0", $P0
445 invokecc $P1
446 .end
447 .sub foo
448 get_params "0,0", $P0, $P1
449 print $P0
450 .end
451 CODE
452 /too few positional arguments/
453 OUTPUT
455 pir_output_like(
456 <<'CODE', <<'OUTPUT', "argc mismatch, too many - no getparams", todo => 'no get_params at all' );
457 .sub main :main
458 .include "errors.pasm"
459 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
460 foo(5)
461 .end
462 .sub foo
463 print "nada"
464 .end
465 CODE
466 /too many arguments passed/
467 OUTPUT
469 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many - force get_params" );
470 .macro no_params
471 get_params '()'
472 .endm
473 .sub main :main
474 .include "errors.pasm"
475 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
476 foo(5)
477 .end
478 .sub foo
479 .no_params
480 print "nada"
481 .end
482 CODE
483 /too many positional arguments/
484 OUTPUT
486 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many" );
487 .sub main :main
488 .include "errors.pasm"
489 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
490 $P0 = new 'String'
491 $P0 = "hello\n"
492 find_name $P1, "foo"
493 set_args "0,0", $P0, 77
494 invokecc $P1
495 .end
496 .sub foo
497 get_params "0", $P0
498 print $P0
499 .end
500 CODE
501 /too many positional arguments/
502 OUTPUT
504 pir_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many - catch exception" );
505 .sub main :main
506 .include "errors.pasm"
507 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
508 $P0 = new 'String'
509 $P0 = "hello\n"
510 find_name $P1, "foo"
511 set_args "0,0", $P0, 77
512 invokecc $P1
513 .end
514 .sub foo
515 push_eh arg_handler
516 get_params "0", $P0
517 print $P0
518 print "never\n"
519 arg_handler:
520 get_results "0", $P1
521 $S0 = $P1
522 print "caught: "
523 print $S0
524 # $S1 = typeof $P1
525 # print "\nexception type: "
526 # print $S1
527 .end
528 CODE
529 /^caught: too many positional arguments/
530 OUTPUT
532 pir_output_is( <<'CODE', <<'OUTPUT', "argc mismatch, optional" );
533 .sub main :main
534 .include "errors.pasm"
535 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
536 $P0 = new 'String'
537 $P0 = "hello\n"
538 find_name $P1, "foo"
539 set_args "0", $P0
540 invokecc $P1
541 .end
542 .sub foo
543 get_params "0,0x80,0x100", $P0, $P1, $I0
544 print $P0
545 if_null $P1, ok
546 print "not "
547 ok:
548 print "ok\n"
549 .end
550 CODE
551 hello
552 ok
553 OUTPUT
555 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, optional" );
556 .sub main :main
557 .include "errors.pasm"
558 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
559 .local pmc ar
560 ar = new 'ResizableIntegerArray'
561 push ar, 1
562 push ar, 2
563 push ar, 3
564 push ar, 4
565 foo(ar :flat)
566 print "never\n"
567 .end
568 .sub foo
569 .param int i
570 .param int j :optional
571 .param int got_j :opt_flag
572 .param int k :optional
573 .param int got_k :opt_flag
574 .end
575 CODE
576 /too many positional arguments/
577 OUTPUT
579 pasm_output_is( <<'CODE', <<'OUTPUT', "get_param later" );
580 .pcc_sub main:
581 set I16, 77
582 set_args "0, 0", 42, I16
583 find_name P1, "foo"
584 invokecc P1
585 get_results "0, 0", I16, I17
586 print I16
587 print "\n"
588 print I17
589 print "\nback\n"
590 end
591 .pcc_sub foo:
592 noop
593 get_params "0, 0", I16, I17
594 print I16
595 print "\n"
596 print I17
597 print "\n"
598 set I16, 88
599 set_returns "4, 0", 99, I16
600 returncc
601 CODE
602 42
603 77
604 99
605 88
606 back
607 OUTPUT
609 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall 1" );
610 .sub main :main
611 .const 'Sub' f = "foo"
612 print "main\n"
613 invokecc f
614 get_results "0", $S0
615 print $S0
616 .end
617 .sub foo
618 .const 'Sub' b = "bar"
619 print "foo\n"
620 tailcall b
621 .end
622 .sub bar
623 print "bar\n"
624 set_returns "0", "bar_ret\n"
625 returncc
626 .end
627 CODE
628 main
629 foo
630 bar
631 bar_ret
632 OUTPUT
634 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall 2 - pass arg" );
635 .sub main :main
636 .const 'Sub' f = "foo"
637 print "main\n"
638 invokecc f
639 get_results "0", $S0
640 print $S0
641 .end
642 .sub foo
643 .const 'Sub' b = "bar"
644 print "foo\n"
645 set_args "0", "from_foo\n"
646 tailcall b
647 .end
648 .sub bar
649 get_params "0", $S0
650 print "bar\n"
651 print $S0
652 set_returns "0", "bar_ret\n"
653 returncc
654 .end
655 CODE
656 main
657 foo
658 bar
659 from_foo
660 bar_ret
661 OUTPUT
663 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall 3 - pass arg" );
664 .sub main :main
665 .const 'Sub' f = "foo"
666 print "main\n"
667 invokecc f
668 get_results "0", $S0
669 print $S0
670 .end
671 .sub foo
672 .const 'Sub' b = "bar"
673 print "foo\n"
674 set_args "0", "from_foo\n"
675 tailcall b
676 .end
677 .sub bar
678 get_params "0", $S0
679 print "bar\n"
680 print $S0
681 set_returns "0", "bar_ret\n"
682 returncc
683 .end
684 CODE
685 main
686 foo
687 bar
688 from_foo
689 bar_ret
690 OUTPUT
692 pir_output_is( <<'CODE', <<'OUTPUT', "empty args" );
693 .sub main :main
694 $P0 = new 'String'
695 $P0 = "hello\n"
696 find_name $P1, "foo"
697 set_args ""
698 invokecc $P1
699 .end
700 .sub foo
701 get_params "0x80, 0x100", $P1, $I0
702 if_null $P1, ok
703 print "not "
704 ok:
705 print "ok\n"
706 .end
707 CODE
708 ok
709 OUTPUT
711 pir_output_is( <<'CODE', <<'OUTPUT', "optional args" );
712 .sub main :main
713 $P0 = new 'String'
714 $P0 = "hello\n"
715 find_name $P1, "foo"
716 set_args "0x0", $P0
717 invokecc $P1
718 .end
719 .sub foo
720 get_params "0x80, 0x100", $P1, $I0
721 unless_null $P1, ok
722 print "not "
723 ok:
724 print "ok\n"
725 .end
726 CODE
727 ok
728 OUTPUT
730 pir_output_is( <<'CODE', <<'OUTPUT', "pir uses no ops" );
731 .sub main :main
732 $I0 = 77
733 foo(42, $I0)
734 print "back\n"
735 .end
737 .sub foo
738 get_params "0, 0", $I16, $I17
739 print $I16
740 print "\n"
741 print $I17
742 print "\n"
743 set_returns ""
744 returncc
745 .end
746 CODE
747 42
748 77
749 back
750 OUTPUT
752 pir_output_is( <<'CODE', <<'OUTPUT', "pir call evaled code" );
753 .sub main :main
754 .local string s
755 s = ".sub foo\n"
756 s .= ".param int i\n"
757 s .= ".param int j\n"
758 s .= "print i\n"
759 s .= "print ' '\n"
760 s .= "print j\n"
761 s .= "print \"\\n\"\n"
762 s .= ".return(99)\n"
763 s .= ".end\n"
764 .local pmc comp
765 comp = compreg "PIR"
766 $P0 = comp(s)
767 $I0 = 77
768 $I0 = foo(42, $I0)
769 print $I0
770 print "\n"
771 .end
773 CODE
774 42 77
775 99
776 OUTPUT
778 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall 4 - pir calls" );
779 .sub main :main
780 .const 'Sub' f = "foo"
781 print "main\n"
782 $S0 = f()
783 print $S0
784 .end
785 .sub foo
786 .const 'Sub' b = "bar"
787 print "foo\n"
788 .tailcall b("from_foo\n")
789 .end
790 .sub bar
791 .param string s
792 print "bar\n"
793 print s
794 .return ("bar_ret\n")
795 .end
796 CODE
797 main
798 foo
799 bar
800 from_foo
801 bar_ret
802 OUTPUT
804 pir_output_is( <<'CODE', <<'OUTPUT', "type conversion - native" );
805 .sub main :main
806 foo_int(42, "42", 42.20)
807 foo_float(42, "42", 42.20)
808 foo_string(42, "42", 42.20)
809 .end
810 .sub foo_int
811 get_params "0,0,0", $I0, $I1, $I2
812 print $I0
813 print ' '
814 print $I1
815 print ' '
816 print $I2
817 print "\n"
818 .end
819 .sub foo_float
820 get_params "0,0,0", $N0, $N1, $N2
821 print $N0
822 print ' '
823 print $N1
824 print ' '
825 print $N2
826 print "\n"
827 .end
828 .sub foo_string
829 get_params "0,0,0", $S0, $S1, $S2
830 print $S0
831 print ' '
832 print $S1
833 print ' '
834 print $S2
835 print "\n"
836 .end
837 CODE
838 42 42 42
839 42 42 42.2
840 42 42 42.2
841 OUTPUT
843 pir_output_is( <<'CODE', <<'OUTPUT', "type conversion - PIR const" );
844 .const int MYCONST = -2
845 .sub main :main
846 $P0 = new 'String'
847 "foo"(MYCONST)
848 .end
849 .sub "foo"
850 .param string str1 :optional
851 .param int has_s :opt_flag
852 print str1
853 print "\n"
854 .end
855 CODE
856 -2
857 OUTPUT
859 pir_output_is( <<'CODE', <<'OUTPUT', "optional args, :opt_flag" );
860 .sub main :main
861 $P0 = new 'String'
862 $P0 = "hello\n"
863 foo($P0)
864 foo()
865 .end
866 .sub foo
867 .param pmc p1 :optional
868 .param int i1 :opt_flag
870 if_null p1, skip
871 print p1
872 skip:
873 print i1
874 print "\n"
875 .end
876 CODE
877 hello
878 1
879 0
880 OUTPUT
882 pir_output_is( <<'CODE', <<'OUTPUT', "optional multiple :opt_flag" );
883 .sub main :main
884 $P0 = new 'String'
885 $P0 = "ok 1\n"
886 foo($P0, "ok 2\n", "ok 3\n")
887 .end
888 .sub foo
889 .param pmc p1 :optional
890 .param int i1 :opt_flag
891 .param pmc p2 :optional
892 .param int i2 :opt_flag
893 .param pmc p3 :optional
894 .param int i3 :opt_flag
895 .param pmc p4 :optional
896 .param int i4 :opt_flag
898 print p1
899 print p2
900 print p3
901 if_null p4, ok
902 print "not "
903 ok:
904 print "ok 4\n"
905 print i1
906 print ' '
907 print i2
908 print ' '
909 print i3
910 print ' '
911 print i4
912 print "\n"
913 .end
916 CODE
917 ok 1
918 ok 2
919 ok 3
920 ok 4
921 1 1 1 0
922 OUTPUT
924 pir_output_is( <<'CODE', <<'OUTPUT', "optional returns, void ret" );
925 .sub main :main
926 .local pmc f
927 $I0 = 99
928 f = get_global "foo"
929 .begin_call
930 .call f
931 .get_result $P0 :optional
932 .get_result $I0 :opt_flag
933 .end_call
934 unless $I0, ex
935 print "not "
936 ex:
937 print "ok 1\n"
938 .end
939 .sub foo
940 .end
941 CODE
942 ok 1
943 OUTPUT
945 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall 5 - arg/param conflict" );
946 .sub main :main
947 .local pmc a, b
948 a = new 'Integer'
949 a = 1
950 b = new 'Integer'
951 b = 2
952 .local pmc c, d
953 (c, d) = foo(a, b)
954 eq_addr a, c, ok1
955 print "not "
956 ok1:
957 print "ok 1\n"
958 eq_addr b, d, ok2
959 print "not "
960 ok2:
961 print "ok 2\n"
962 .end
964 .sub foo
965 .param pmc a
966 .param pmc b
967 $P0 = new 'Integer'
968 $P0 = 3
969 .tailcall bar($P0, a, b)
970 .end
972 .sub bar
973 .param pmc x
974 .param pmc a
975 .param pmc b
976 .return (a, b)
977 .end
978 CODE
979 ok 1
980 ok 2
981 OUTPUT
983 pir_output_is( <<'CODE', <<'OUTPUT', "OO argument passing" );
984 .sub main :main
985 .local pmc cl, o, f
986 cl = newclass "Foo"
987 o = new "Foo"
988 o."bar"("ok 1\n")
989 f = get_global ["Foo"], "bar"
990 f(o, "ok 2\n")
991 o."baz"("ok 3\n")
992 f = get_global ["Foo"], "baz"
993 f(o, "ok 4\n")
994 .end
995 .namespace ["Foo"]
996 .sub bar :method :nsentry('bar')
997 .param string s
998 print self
999 print " "
1000 print s
1001 .end
1002 .sub baz :method :nsentry('baz')
1003 .param string s
1004 print self
1005 print " "
1006 print s
1007 .end
1008 .sub get_string :vtable :method
1009 $S0 = typeof self
1010 .return ($S0)
1011 .end
1012 CODE
1013 Foo ok 1
1014 Foo ok 2
1015 Foo ok 3
1016 Foo ok 4
1017 OUTPUT
1019 pir_output_is( <<'CODE', <<'OUTPUT', "OO argument passing - 2" );
1020 .sub main :main
1021 .local pmc cl, o, f
1022 cl = newclass "Foo"
1023 o = new "Foo"
1024 $S0 = o
1025 print $S0
1026 $S1 = o[2]
1027 print $S1
1028 print $S0
1029 .end
1030 .namespace ["Foo"]
1031 .sub get_string :vtable :method
1032 $S0 = typeof self
1033 print $S0
1034 print " "
1035 .return ("ok 1\n")
1036 .end
1037 .sub get_string_keyed_int :vtable :method
1038 .param int key
1039 $S0 = "ok "
1040 $S1 = key
1041 $S0 .= $S1
1042 $S0 .= "\n"
1043 .return ($S0)
1044 .end
1045 CODE
1046 Foo ok 1
1047 ok 2
1048 ok 1
1049 OUTPUT
1051 pir_output_is( <<'CODE', <<'OUTPUT', "OO argument passing - 3" );
1052 .sub main :main
1053 .local pmc cl, o, f
1054 cl = newclass "Foo"
1055 o = new "Foo"
1056 $S0 = foo(o)
1057 print $S0
1058 .end
1059 .sub foo
1060 .param pmc arg
1061 .return (arg) # force conversion to string
1062 .end
1063 .namespace ["Foo"]
1064 .sub get_string :vtable :method
1065 $S0 = typeof self
1066 print $S0
1067 print " "
1068 .return ("ok 1\n")
1069 .end
1071 CODE
1072 Foo ok 1
1073 OUTPUT
1075 # see also tcl in leo-ctx5 by Coke; Date 28.08.2005
1076 pir_output_is( <<'CODE', <<'OUTPUT', "bug - :slurpy promotes to :flatten" );
1077 .sub main :main
1078 $P0 = new 'String'
1079 $P0 = "ok 1\n"
1080 $P1 = new 'String'
1081 $P1 = "ok 2\n"
1082 $P0 = foo($P0, $P1)
1083 print $P0
1084 .end
1085 .sub foo
1086 .param pmc p :slurpy
1087 .tailcall bar(p)
1088 .end
1089 .sub bar
1090 .param pmc p
1091 .local pmc q
1092 q = p[0]
1093 print q
1094 q = p[1]
1095 .return (q)
1096 .end
1097 CODE
1098 ok 1
1099 ok 2
1100 OUTPUT
1102 pir_output_is( <<'CODE', <<'OUTPUT', "call :slurpy with :flat" );
1103 .sub _fn1
1104 .param pmc rest_arg :slurpy
1105 print "[in _fn1]\n"
1106 print rest_arg
1107 print "\n"
1108 .end
1109 .sub main :main
1110 $P34 = new 'ResizablePMCArray'
1111 $P34 = 0
1112 ## normal flattening direct call, non-slurpy returns
1113 $P35 = _fn1($P34 :flat)
1114 .end
1115 CODE
1116 [in _fn1]
1117 0
1118 OUTPUT
1120 pir_output_is( <<'CODE', <<'OUTPUT', "call with :flat in the middle" );
1121 .sub _fn1
1122 .param int arg1
1123 .param int arg2
1124 .param int arg3
1125 .param int arg4
1126 print arg1
1127 print ' '
1128 print arg2
1129 print ' '
1130 print arg3
1131 print ' '
1132 print arg4
1133 print "\n"
1134 .end
1135 .sub main :main
1136 $P30 = new 'Integer'
1137 $P30 = 2
1138 $P31 = new 'Integer'
1139 $P31 = 3
1140 $P34 = new 'ResizablePMCArray'
1141 $P34 = 2
1142 $P34[0] = $P30
1143 $P34[1] = $P31
1144 $I4 = 4
1145 $P35 = _fn1(1, $P34 :flat, $I4)
1146 .end
1147 CODE
1148 1 2 3 4
1149 OUTPUT
1151 pir_output_is( <<'CODE', <<'OUTPUT', "right number of args via :flat" );
1152 .sub _fn1
1153 .param int arg1
1154 .param int arg2
1155 .param int arg3
1156 .param int arg4
1157 print arg1
1158 print ' '
1159 print arg2
1160 print ' '
1161 print arg3
1162 print ' '
1163 print arg4
1164 print "\n"
1165 .end
1166 .sub main :main
1167 .include "errors.pasm"
1168 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
1169 $P30 = new 'Integer'
1170 $P30 = 2
1171 $P31 = new 'Integer'
1172 $P31 = 3
1173 $P34 = new 'ResizablePMCArray'
1174 $P34 = 3
1175 $P34[0] = $P30
1176 $P34[1] = $P31
1177 $P34[2] = $P30
1178 $P35 = _fn1(1, $P34 :flat)
1179 .end
1180 CODE
1181 1 2 3 2
1182 OUTPUT
1184 pir_error_output_like( <<'CODE', <<'OUTPUT', "too many args via :flat" );
1185 .sub _fn1
1186 .param int arg1
1187 .param int arg2
1188 .param int arg3
1189 .param int arg4
1190 print arg1
1191 print ' '
1192 print arg2
1193 print ' '
1194 print arg3
1195 print ' '
1196 print arg4
1197 print "\n"
1198 .end
1199 .sub main :main
1200 .include "errors.pasm"
1201 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
1202 $P30 = new 'Integer'
1203 $P30 = 2
1204 $P31 = new 'Integer'
1205 $P31 = 3
1206 $P34 = new 'ResizablePMCArray'
1207 $P34 = 4
1208 $P34[0] = $P30
1209 $P34[1] = $P31
1210 $P34[2] = $P30
1211 $P34[3] = $P31
1212 $P35 = _fn1(1, $P34 :flat)
1213 .end
1214 CODE
1215 /too many positional arguments: 5 passed, 4 expected/
1216 OUTPUT
1218 pir_error_output_like( <<'CODE', <<'OUTPUT', "too few args via :flat" );
1219 .sub _fn1
1220 .param int arg1
1221 .param int arg2
1222 .param int arg3
1223 .param int arg4
1224 print arg1
1225 print ' '
1226 print arg2
1227 print ' '
1228 print arg3
1229 print ' '
1230 print arg4
1231 print "\n"
1232 .end
1233 .sub main :main
1234 .include "errors.pasm"
1235 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
1236 $P30 = new 'Integer'
1237 $P30 = 2
1238 $P31 = new 'Integer'
1239 $P31 = 3
1240 $P34 = new 'ResizablePMCArray'
1241 $P34 = 2
1242 $P34[0] = $P30
1243 $P34[1] = $P31
1244 $P35 = _fn1(1, $P34 :flat)
1245 .end
1246 CODE
1247 /too few positional arguments: 3 passed, 4 \(or more\) expected/
1248 OUTPUT
1250 pir_output_is( <<'CODE', <<'OUTPUT', "faux tailcall to NCI" );
1251 .sub main :main
1252 .local pmc s
1253 s = new 'String'
1254 $I0 = s."is_integer"(22)
1255 say $I0
1256 $I1 = foo(s)
1257 say $I1
1258 .end
1259 .sub foo
1260 .param pmc s
1261 $I0 = s."is_integer"(22)
1262 .return ($I0)
1263 .end
1264 CODE
1265 1
1266 1
1267 OUTPUT
1269 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall to NCI - 2" );
1270 .sub main :main
1271 $P0 = eval("print \"Foo!\\n\"")
1272 $P0()
1273 end
1274 .end
1276 .sub eval
1277 .param string code
1278 code = ".sub main :main :anon\n" . code
1279 code = code . "\n.end\n"
1280 $P0 = compreg "PIR"
1281 .tailcall $P0(code)
1282 .end
1283 CODE
1284 Foo!
1285 OUTPUT
1287 # bug - repeated calls to eval'd sub crashes (pmichaud, 2005.10.27)
1288 pir_output_is( <<'CODE', <<'OUTPUT', "repeated calls to eval'd sub" );
1289 .sub main :main
1290 .local string s
1291 .local pmc outer
1292 s = ".namespace [ \"XYZ\" ]\n"
1293 s .= ".sub outer\n"
1294 s .= " .param int n\n"
1295 s .= " $I0 = n % 1000\n"
1296 s .= " if $I0 goto end\n"
1297 s .= " print n\n"
1298 s .= " print \"\\n\"\n"
1299 s .= " end:\n"
1300 s .= ".end\n"
1301 $P0 = compreg "PIR"
1302 $P0(s)
1303 outer = get_global ["XYZ"], "outer"
1304 $I1 = 0
1305 loop:
1306 inc $I1
1307 if $I1 > 10000 goto end
1308 outer($I1)
1309 goto loop
1310 end:
1311 .end
1312 CODE
1313 1000
1314 2000
1315 3000
1316 4000
1317 5000
1318 6000
1319 7000
1320 8000
1321 9000
1322 10000
1323 OUTPUT
1325 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall - overlapping Ix" );
1326 .sub main :main
1327 ($I0, $I1) = foo()
1328 print $I0
1329 print $I1
1330 print "\n"
1331 .end
1332 .sub foo
1333 .const 'Sub' b = "bar"
1334 $I0 = 10
1335 $I1 = 20
1336 set_args "0,0", $I1, $I0
1337 tailcall b
1338 .end
1339 .sub bar
1340 get_params "0,0", $I0, $I1
1341 .return ($I0, $I1)
1342 .end
1343 CODE
1344 2010
1345 OUTPUT
1347 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall - optional not set" );
1348 .sub main :main
1349 foo()
1350 print "ok\n"
1351 .end
1352 .sub foo
1353 .const 'Sub' b = "bar"
1354 .tailcall b(10, 20)
1355 .end
1356 .sub bar
1357 .param int a
1358 .param int b
1359 .param int c :optional
1360 .param int has_c :opt_flag
1361 print a
1362 print ' '
1363 print b
1364 print ' '
1365 unless has_c goto no_c
1366 print c
1367 goto got_c
1368 no_c:
1369 print 'no'
1370 got_c:
1371 print "\n"
1372 .end
1373 CODE
1374 10 20 no
1375 ok
1376 OUTPUT
1378 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall - optional set" );
1379 .sub main :main
1380 foo()
1381 print "ok\n"
1382 .end
1383 .sub foo
1384 .const 'Sub' b = "bar"
1385 .tailcall b(10, 20, 30)
1386 .end
1387 .sub bar
1388 .param int a
1389 .param int b
1390 .param int c :optional
1391 .param int has_c :opt_flag
1392 print a
1393 print ' '
1394 print b
1395 print ' '
1396 unless has_c goto no_c
1397 print c
1398 goto got_c
1399 no_c:
1400 print 'no'
1401 got_c:
1402 print "\n"
1403 .end
1404 CODE
1405 10 20 30
1406 ok
1407 OUTPUT
1409 pir_output_is( <<'CODE', <<'OUTPUT', "clone_key_arg" );
1410 .sub main :main
1411 foo()
1412 print "ok\n"
1413 .end
1415 .sub foo
1416 .local pmc cl, o
1417 cl = newclass "MyClass"
1418 o = new "MyClass"
1419 $S0 = "key"
1420 $I0 = 3
1421 o[$S0;$I0] = 42
1422 .end
1424 .namespace ["MyClass"]
1426 # key arguments in register have to be expanded into their
1427 # values because in the called sub frame the original refered
1428 # registers just don't exist #' for vim
1430 .sub set_integer_keyed :vtable :method
1431 .param pmc key
1432 .param int val
1433 print key # print first key
1434 print ' '
1435 key = shift key # get next key
1436 print key
1437 print ' '
1438 print val
1439 print "\n"
1440 .end
1441 CODE
1442 key 3 42
1443 ok
1444 OUTPUT
1446 # result_info op
1448 pir_output_is( <<'CODE', <<'OUTPUT', "result_info op" );
1449 .sub main :main
1450 test()
1451 $P0 = new 'FixedIntegerArray'
1452 set_result_info $P0
1453 $P0 = 1
1454 $I0 = test()
1455 $P0 = new 'FixedIntegerArray'
1456 $P0 = 3
1457 set_result_info $P0
1458 ($I1, $I2, $I3) = test()
1459 .end
1461 .sub test
1462 $P0 = result_info
1463 $I0 = elements $P0
1464 print $I0
1465 print "\n"
1466 .return (0)
1467 .end
1468 CODE
1469 0
1470 1
1471 3
1472 OUTPUT
1474 pir_output_is( <<'CODE', <<'OUTPUT', "result_info op with eval" );
1475 .sub main :main
1476 $S0 = <<"TESTSUB"
1477 .sub test
1478 $P0 = result_info
1479 $I0 = elements $P0
1480 print $I0
1481 print "\\n"
1482 .end
1483 TESTSUB
1484 $P0 = compreg "PIR"
1485 $P1 = $P0($S0)
1486 $P0 = new 'FixedIntegerArray'
1487 set_result_info $P0
1488 test()
1490 $P0 = new 'FixedIntegerArray'
1491 $P0 = 1
1492 set_result_info $P0
1493 $I0 = test()
1495 $P0 = new 'FixedIntegerArray'
1496 $P0 = 3
1497 set_result_info $P0
1498 ($I1, $I2, $I3) = test()
1499 .end
1500 CODE
1501 0
1502 1
1503 3
1504 OUTPUT
1506 pir_output_is( <<'CODE', <<'OUTPUT', ":slurpy result" );
1507 .sub main :main
1508 ($P0 :slurpy) = foo()
1509 $S0 = $P0[0]
1510 print $S0
1511 $S0 = $P0[1]
1512 print $S0
1513 .end
1514 .sub foo
1515 .return("ok 1\n", "ok 2\n")
1516 .end
1517 CODE
1518 ok 1
1519 ok 2
1520 OUTPUT
1522 pir_output_is( <<'CODE', <<'OUTPUT', ":optional result" );
1523 .sub main :main
1524 ($S0 :optional, $I1 :opt_flag) = foo()
1525 unless $I1 goto no_ret
1526 print "ok 1\n"
1527 print $S0
1528 end
1529 no_ret:
1530 print "not ok 1\n"
1531 .end
1532 .sub foo
1533 .return("ok 2\n")
1534 .end
1535 CODE
1536 ok 1
1537 ok 2
1538 OUTPUT
1540 pir_output_is( <<'CODE', <<'OUTPUT', ":optional result" );
1541 .sub main :main
1542 ($S0 :optional, $I1 :opt_flag) = foo()
1543 if $I1 goto has_ret
1544 print "ok 1\n"
1545 end
1546 has_ret:
1547 print "not ok 1\n"
1548 .end
1549 .sub foo
1550 .return()
1551 .end
1552 CODE
1553 ok 1
1554 OUTPUT
1556 pir_output_is( <<'CODE', <<'OUTPUT', "set_args via continuation -> results" );
1557 .sub main :main
1558 .local string result
1559 result = foo("ok 1\n")
1560 print result
1561 .end
1563 .sub foo
1564 .param string s
1565 .local pmc cc
1566 .include 'interpinfo.pasm'
1567 cc = interpinfo .INTERPINFO_CURRENT_CONT
1568 bar(cc, s)
1569 .end
1571 .sub bar
1572 .param pmc cc
1573 .param string s
1574 print s
1575 cc("ok 2\n")
1576 .end
1577 CODE
1578 ok 1
1579 ok 2
1580 OUTPUT
1582 pir_output_is( <<'CODE', <<'OUTPUT', "set_args via explicit continuation" );
1583 .sub main :main
1584 .local string result
1585 result = "not ok 2\n"
1586 .local pmc cont
1587 cont = new 'Continuation'
1588 set_addr cont, cont_dest
1589 bar(cont, "ok 1\n")
1590 print "oops\n"
1591 cont_dest:
1592 .get_results (result)
1593 print result
1594 .end
1596 .sub bar
1597 .param pmc cc
1598 .param string s
1599 print s
1600 cc("ok 2\n")
1601 .end
1602 CODE
1603 ok 1
1604 ok 2
1605 OUTPUT
1607 # this is a regression test for a bug in which tail-calling without set_args
1608 # used the args of the sub.
1609 pir_output_is( <<'CODE', <<'OUTPUT', "tailcall explicit continuation, no args" );
1610 .sub main :main
1611 .local string result
1612 result = "not ok 2\n"
1613 .local pmc cont
1614 cont = new 'Continuation'
1615 set_addr cont, cont_dest
1616 bar(cont, "ok 1\n")
1617 print "oops\n"
1618 cont_dest:
1619 print "ok 2\n"
1620 .end
1622 .sub bar
1623 .param pmc cc
1624 .param string s
1625 print s
1626 .tailcall cc()
1627 .end
1628 CODE
1629 ok 1
1630 ok 2
1631 OUTPUT
1633 pir_output_is( <<'CODE', <<'OUTPUT', "newclosure followed by tailcall" );
1634 ## regression test for newclosure followed by tailcall, which used to recycle
1635 ## the context too soon. it looks awful because (a) the original version was
1636 ## produced by a compiler, and (b) in order to detect regression, we must force
1637 ## parrot to reuse the context, which seems to requires having other calls that
1638 ## use particular numbers of registers (and probably a fair amount of luck).
1639 .sub _main :main
1640 ## debug 0x80
1641 .lex "MAIN-CONT", $P41
1642 $I42 = 10
1643 $P41 = new 'Continuation'
1644 set_addr $P41, L2
1645 goto L3
1646 L2:
1647 get_results '0', $P45
1648 print "got "
1649 print $P45
1650 print ".\n"
1651 .return ()
1652 L3:
1653 .const 'Sub' $P49 = "___internal_main_test_"
1654 newclosure $P48, $P49
1655 .tailcall _try_it($I42, $P48)
1656 .end
1658 .sub ___internal_main_test_ :outer('_main')
1659 .param pmc arg1
1660 print "[in test]\n"
1661 find_lex $P41, "MAIN-CONT"
1662 $P55 = new "Undef"
1663 if arg1 != 3 goto L3
1664 $P58 = arg1
1665 $P59 = arg1
1666 $P57 = mul $P58, $P59
1667 set_args '(0)', $P57
1668 tailcall $P41
1669 L3:
1670 print "not "
1671 print arg1
1672 print "\n"
1673 .end
1676 .sub _try_it
1677 .param int n
1678 .param pmc closure
1679 $P42 = new "Undef"
1680 $P42 = 0
1681 goto L4
1682 L2:
1683 closure($P42)
1684 $P42 = $P42 + 1
1685 L4:
1686 if $P42 < n goto L2
1687 .end
1688 CODE
1689 [in test]
1690 not 0
1691 [in test]
1692 not 1
1693 [in test]
1694 not 2
1695 [in test]
1696 got 9.
1697 OUTPUT
1699 pir_output_is( <<'CODE', <<'OUTPUT', "call evaled vtable code" );
1700 .sub main :main
1701 .local string s
1702 .local pmc cl, o
1703 cl = newclass "Foo"
1704 s = <<"END_PIR"
1705 .namespace ['Foo']
1706 .sub get_integer_keyed_int :vtable :method
1707 .param int i
1708 i += 5
1709 .return(i)
1710 .end
1711 END_PIR
1712 .local pmc comp
1713 comp = compreg "PIR"
1714 $P0 = comp(s)
1715 o = new 'Foo'
1716 $I0 = o[12]
1717 print $I0
1718 print "\n"
1719 .end
1720 CODE
1721 17
1722 OUTPUT
1724 pasm_output_is( <<'CODE', <<'OUTPUT', "named - 1" );
1725 .pcc_sub main:
1726 set_args "0x200, 0, 0x200, 0", "b", 10, "a", 20
1727 find_name P1, "foo"
1728 invokecc P1
1729 get_results ""
1730 print "ok\n"
1731 end
1732 .pcc_sub foo:
1733 get_params "0x200, 0, 0x200, 0", "a", I0, "b", I1
1734 print I1
1735 print ' '
1736 print I0
1737 print "\n"
1738 returncc
1739 CODE
1740 10 20
1741 ok
1742 OUTPUT
1744 pasm_output_is( <<'CODE', <<'OUTPUT', "named - 2 flatten" );
1745 .pcc_sub main:
1746 new P0, 'Hash'
1747 set P0['a'], 20
1748 set P0['b'], 10
1749 set_args "0x220", P0 # :flatten :named
1750 find_name P1, "foo"
1751 invokecc P1
1752 get_results ""
1753 print "ok\n"
1754 end
1755 .pcc_sub foo:
1756 get_params "0x200, 0, 0x200, 0", "a", I0, "b", I1
1757 print I1
1758 print ' '
1759 print I0
1760 print "\n"
1761 returncc
1762 CODE
1763 10 20
1764 ok
1765 OUTPUT
1767 pir_output_is( <<'CODE', <<'OUTPUT', "named - 3 slurpy hash PIR" );
1768 .sub main :main
1769 foo('a' => 10 , 'b' => 20, 'c' => 30)
1770 print "ok\n"
1771 end
1772 .end
1773 .sub foo
1774 .param int a :named('a')
1775 .param pmc bar :slurpy :named
1776 print a
1777 print ' '
1778 elements $I1, bar
1779 print $I1
1780 print ' '
1781 typeof $S0, bar
1782 print $S0
1783 print ' '
1784 set $I2, bar['b']
1785 print $I2
1786 print ' '
1787 set $I2, bar['c']
1788 print $I2
1789 print "\n"
1790 .end
1792 CODE
1793 10 2 Hash 20 30
1794 ok
1795 OUTPUT
1797 pasm_output_is( <<'CODE', <<'OUTPUT', "named - 3 slurpy hash" );
1798 .pcc_sub main:
1799 set_args "0x200, 0, 0x200, 0,0x200, 0", "a", 10, "b", 20, 'c', 30
1800 find_name P1, "foo"
1801 invokecc P1
1802 get_results ""
1803 print "ok\n"
1804 end
1805 .pcc_sub foo:
1806 get_params "0x200, 0, 0x220", "a", I0, P0
1807 print I0
1808 print ' '
1809 elements I1, P0
1810 print I1
1811 print ' '
1812 typeof S0, P0
1813 print S0
1814 print ' '
1815 set I2, P0['b']
1816 print I2
1817 print ' '
1818 set I2, P0['c']
1819 print I2
1820 print "\n"
1821 returncc
1823 CODE
1824 10 2 Hash 20 30
1825 ok
1826 OUTPUT
1828 pasm_output_is( <<'CODE', <<'OUTPUT', "named - 4 positional -> named" );
1829 .pcc_sub main:
1830 set_args "0, 0, 0", 10, 20, 30
1831 find_name P1, "foo"
1832 invokecc P1
1833 get_results ""
1834 print "ok\n"
1835 end
1836 .pcc_sub foo:
1837 get_params "0x200, 0, 0x200, 0, 0x200, 0", "a", I0, "b", I1, 'c', I2
1838 print I0
1839 print ' '
1840 print I1
1841 print ' '
1842 print I2
1843 print "\n"
1844 returncc
1845 CODE
1846 10 20 30
1847 ok
1848 OUTPUT
1850 pasm_output_is( <<'CODE', <<'OUTPUT', "named - 5 slurpy array -> named" );
1851 .pcc_sub main:
1852 set_args "0, 0, 0, 0x200, 0, 0x200, 0", 10, 20, 30, 'a', 40, 'b', 50
1853 find_name P1, "foo"
1854 invokecc P1
1855 get_results ""
1856 print "ok\n"
1857 end
1858 .pcc_sub foo:
1859 get_params "0, 0x20, 0x200, 0, 0x200, 0", I0, P0, "b", I1, "a", I2
1860 print I0
1861 print ' '
1862 set I0, P0[0]
1863 print I0
1864 print ' '
1865 set I0, P0[1]
1866 print I0
1867 print ' '
1868 print I1
1869 print ' '
1870 print I2
1871 print "\n"
1872 returncc
1873 CODE
1874 10 20 30 50 40
1875 ok
1876 OUTPUT
1878 pir_output_is( <<'CODE', <<'OUTPUT', ":optional followed by :slurpy (empty)" );
1879 .sub main :main
1880 _write_thing(3)
1881 .end
1882 .sub _write_thing
1883 .param pmc arg1 :optional
1884 .param pmc rest_arg :slurpy
1885 print arg1
1886 print ' '
1887 print rest_arg
1888 print "\n"
1889 .end
1890 CODE
1891 3 0
1892 OUTPUT
1894 pir_output_is( <<'CODE', <<'OUTPUT', ":optional followed by :slurpy (used)" );
1895 .sub main :main
1896 _write_thing(3, 4, 5)
1897 .end
1898 .sub _write_thing
1899 .param pmc arg1 :optional
1900 .param pmc rest_arg :slurpy
1901 print arg1
1902 print ' '
1903 print rest_arg
1904 print "\n"
1905 .end
1906 CODE
1907 3 2
1908 OUTPUT
1910 ## Named
1911 pir_output_is( <<'CODE', <<'OUTPUT', ":named(\"...\") syntax for .param and sub call" );
1912 .sub main :main
1913 foo( 10 :named("b"), 20 :named("a"))
1914 print "ok\n"
1915 end
1916 .end
1918 .sub foo
1919 .param int c :named("a")
1920 .param int d :named("b")
1922 print d
1923 print ' '
1924 print c
1925 print "\n"
1926 .return()
1927 .end
1928 CODE
1929 10 20
1930 ok
1931 OUTPUT
1933 ## Named
1934 pir_output_is( <<'CODE', <<'OUTPUT', ":named(\"...\") syntax for the 4 kind" );
1935 .sub main :main
1936 ($I0 :named("b"), $I1 :named("a")) = foo( 10 :named("b"), 20 :named("a"))
1937 print $I0
1938 print ' '
1939 print $I1
1940 print "\n"
1941 print "ok\n"
1943 end
1944 .end
1946 .sub foo
1947 .param int c :named("a")
1948 .param int d :named("b")
1950 print d
1951 print ' '
1952 print c
1953 print "\n"
1955 .return ( 10 :named("a"), 20 :named("b"))
1956 .end
1957 CODE
1958 10 20
1959 20 10
1960 ok
1961 OUTPUT
1963 ## Named
1964 pir_output_is( <<'CODE', <<'OUTPUT', " 'foo' => 10 syntax for function call" );
1965 .sub main :main
1966 foo ('a'=>20,'b'=>10)
1967 print "ok\n"
1969 end
1970 .end
1972 .sub foo
1973 .param int c :named("a")
1974 .param int d :named("b")
1976 print d
1977 print ' '
1978 print c
1979 print "\n"
1981 .return ()
1982 .end
1983 CODE
1984 10 20
1985 ok
1986 OUTPUT
1988 pir_error_output_like( <<'CODE', <<'OUTPUT', "named => pos passing" );
1989 .sub main :main
1990 foo( "b" => 10 , "a" => 20)
1991 print "never\n"
1992 end
1993 .end
1995 .sub foo
1996 .param int a
1997 .param int b
1998 .end
1999 CODE
2000 /too few positional/
2001 OUTPUT
2003 pir_output_is( <<'CODE', <<'OUTPUT', "named optional - set" );
2004 .sub main :main
2005 foo ('a'=>20,'b'=>10)
2006 print "ok\n"
2007 .end
2009 .sub foo
2010 .param int d :named('b')
2011 .param int c :named('a') :optional
2012 print d
2013 print ' '
2014 print c
2015 print "\n"
2016 .end
2017 CODE
2018 10 20
2019 ok
2020 OUTPUT
2022 pir_output_is( <<'CODE', <<'OUTPUT', "named optional - set, :opt_flag" );
2023 .sub main :main
2024 foo ('a'=>20,'b'=>10)
2025 print "ok\n"
2026 .end
2028 .sub foo
2029 .param int d :named('b') :optional
2030 .param int has_d :opt_flag
2031 .param int c :named('a') :optional
2032 .param int has_c :opt_flag
2033 print d
2034 print ' '
2035 print has_d
2036 print ' '
2037 print c
2038 print ' '
2039 print has_c
2040 print "\n"
2041 .end
2042 CODE
2043 10 1 20 1
2044 ok
2045 OUTPUT
2047 pir_output_is( <<'CODE', <<'OUTPUT', "named optional - mix" );
2048 .sub main :main
2049 foo ('a'=>20,'b'=>10)
2050 foo ('b'=>10)
2051 foo ('a'=>20)
2052 foo ()
2053 print "ok\n"
2054 .end
2056 .sub foo
2057 .param int d :named('b') :optional
2058 .param int has_d :opt_flag
2059 .param int c :named('a') :optional
2060 .param int has_c :opt_flag
2061 print d
2062 print ' '
2063 print has_d
2064 print ' '
2065 print c
2066 print ' '
2067 print has_c
2068 print "\n"
2069 .end
2070 CODE
2071 10 1 20 1
2072 10 1 0 0
2073 0 0 20 1
2074 0 0 0 0
2075 ok
2076 OUTPUT
2078 pir_output_is( <<'CODE', <<'OUTPUT', "named flat/slurpy" );
2079 .sub main :main
2080 .local pmc h
2081 h = new 'Hash'
2082 h['a'] = 20
2083 h['b'] = 10
2084 foo( h :named :flat )
2085 print "ok\n"
2086 end
2087 .end
2089 .sub foo
2090 .param pmc h :named :slurpy
2091 $I0 = h['a']
2092 $I1 = h['b']
2093 print $I0
2094 print ' '
2095 print $I1
2096 print "\n"
2097 .end
2098 CODE
2099 20 10
2100 ok
2101 OUTPUT
2103 pir_error_output_like( <<'CODE', <<'OUTPUT', "param .. 'a' => v :named('foo')" );
2104 .sub main :main
2105 foo( "b" => 10, "a" => 20)
2106 print "never\n"
2107 end
2108 .end
2110 .sub foo
2111 .param int c :named("foo") :named("bar")
2112 .param int "b" => d
2113 .end
2114 CODE
2115 /Named parameter with more than one name/
2116 OUTPUT
2118 pir_output_is( <<'CODE', <<'OUTPUT', "default value for an unused :optional" );
2119 .sub main :main
2120 print 1
2121 foo(1)
2122 foo(2)
2123 foo()
2124 print "\n"
2125 .end
2126 .sub foo
2127 .param int var :optional
2128 print var
2129 .end
2130 CODE
2131 1120
2132 OUTPUT
2134 pir_error_output_like( <<'CODE', qr/too few named arguments/, "argc mismatch - missing named" );
2135 .sub main :main
2136 .include "errors.pasm"
2137 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
2138 foo ('b'=>10)
2139 print "ok\n"
2140 .end
2142 .sub foo
2143 .param int d :named('b')
2144 .param int c :named('a')
2145 print d
2146 print ' '
2147 print c
2148 print "\n"
2149 .end
2150 CODE
2152 pir_error_output_like( <<'CODE', qr/too few named arguments/, "argc mismatch - missing named" );
2153 .sub main :main
2154 .include "errors.pasm"
2155 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
2156 foo ('a'=>10)
2157 print "ok\n"
2158 .end
2160 .sub foo
2161 .param int d :named('b')
2162 .param int c :named('a')
2163 print d
2164 print ' '
2165 print c
2166 print "\n"
2167 .end
2168 CODE
2170 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch - too many named" );
2171 .sub main :main
2172 .include "errors.pasm"
2173 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
2174 foo ('a'=>10, 'b'=>20, 'c'=>30)
2175 print "ok\n"
2176 .end
2178 .sub foo
2179 .param int d :named('b')
2180 .param int c :named('a')
2181 print d
2182 print ' '
2183 print c
2184 print "\n"
2185 .end
2186 CODE
2187 /too many/
2188 OUTPUT
2190 pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch - duplicate named" );
2191 .sub main :main
2192 .include "errors.pasm"
2193 errorson .PARROT_ERRORS_PARAM_COUNT_FLAG
2194 foo ('a'=>10, 'b'=>20, 'a'=>30)
2195 print "ok\n"
2196 .end
2198 .sub foo
2199 .param int d :named('b')
2200 .param int c :named('a')
2201 print d
2202 print ' '
2203 print c
2204 print "\n"
2205 .end
2206 CODE
2207 /duplicate name/
2208 OUTPUT
2210 pir_output_is( <<'CODE', <<'OUTPUT', "slurpy named after slurpy array" );
2211 .sub main :main
2212 foo(0, 'abc' => 1)
2213 foo('abc' => 2)
2214 $P0 = new 'ResizablePMCArray'
2215 push $P0, 1
2216 foo($P0 :flat, 'abc' => 3)
2217 $P0 = new 'ResizablePMCArray'
2218 foo($P0 :flat, 'abc' => 4)
2219 .end
2221 .sub foo
2222 .param pmc array :slurpy
2223 .param pmc hash :slurpy :named
2224 print "ok "
2225 $P0 = hash['abc']
2226 print $P0
2227 print "\n"
2228 .end
2229 CODE
2230 ok 1
2231 ok 2
2232 ok 3
2233 ok 4
2234 OUTPUT
2236 pir_output_is( <<'CODE', <<'OUTPUT', "slurpy named loses :flat arg (#39044)" );
2237 .sub main :main
2238 $P0 = new 'Hash'
2239 $P0['a'] = 11
2240 $P0['b'] = 22
2241 $P0['c'] = 33
2242 foo(0, 1, $P0 :flat :named)
2243 .end
2245 .sub foo
2246 .param pmc array :slurpy
2247 .param pmc hash :slurpy :named
2248 $I0 = elements array
2249 print $I0
2250 print "\n"
2251 $P0 = hash['a']
2252 say $P0
2253 $P0 = hash['b']
2254 say $P0
2255 $P0 = hash['c']
2256 say $P0
2257 .end
2258 CODE
2259 2
2260 11
2261 22
2262 33
2263 OUTPUT
2265 pir_output_is( <<'CODE', <<'OUTPUT', "slurpy named loses :flat arg" );
2266 .sub main :main
2267 $P0 = new 'Hash'
2268 $P0['a'] = 11
2269 $P0['b'] = 22
2270 $P0['c'] = 33
2271 foo(0, 1, 'z'=>2626, $P0 :flat :named)
2272 .end
2274 .sub foo
2275 .param pmc array :slurpy
2276 .param pmc hash :slurpy :named
2277 $P0 = hash['a']
2278 say $P0
2279 $P0 = hash['b']
2280 say $P0
2281 $P0 = hash['c']
2282 say $P0
2283 $P0 = hash['z']
2284 say $P0
2285 .end
2286 CODE
2287 11
2288 22
2289 33
2290 2626
2291 OUTPUT
2293 pir_error_output_like( <<'CODE', <<'OUTPUT', "unexpected positional arg" );
2294 .sub 'main'
2295 'foo'('abc', 'def', 'ghi'=>1)
2296 .end
2298 .sub 'foo'
2299 .param string name
2300 .param pmc args :slurpy :named
2301 .end
2302 CODE
2303 /too many positional arguments/
2304 OUTPUT
2306 pir_error_output_like( <<'CODE', <<'OUTPUT', "unexpected positional arg" );
2307 .sub 'main'
2308 'foo'('abc', 'def'=>1, 'ghi', 'jkl'=>1)
2309 .end
2311 .sub 'foo'
2312 .param string name
2313 .param pmc args :slurpy :named
2314 .end
2315 CODE
2316 /named arguments must follow all positional arguments/
2317 OUTPUT
2319 pir_output_is( <<'CODE', <<'OUTPUT', "flat/slurpy named arguments" );
2320 .sub 'main' :main
2321 .local pmc args
2322 args = new 'Hash'
2323 args['foo'] = 1
2324 args['bar'] = 2
2326 bar_only( args :flat :named )
2327 .end
2329 .sub 'bar_only'
2330 .param string bar :named( 'bar' )
2331 .param pmc args :named :slurpy
2333 print "Have bar: "
2334 print bar
2335 print "\n"
2336 .end
2337 CODE
2338 Have bar: 2
2339 OUTPUT
2341 pir_output_is(
2342 <<'CODE', <<'OUTPUT', "Tail call without arguments should not free the context when a closure depends on it" );
2343 .sub main :main
2344 $P0 = create_closure_and_run_it()
2345 .end
2347 .sub create_closure_and_run_it
2348 $P0 = new "Integer"
2349 $P0 = 3
2350 .lex "val", $P0
2351 $P2 = get_global "myclosure"
2352 $P1 = newclosure $P2
2353 # There is a closure depending on our current context, so this shouldn't
2354 # free it.
2355 .tailcall $P1()
2356 .end
2358 .sub myclosure :outer(create_closure_and_run_it)
2359 $P1 = find_lex "val"
2360 say $P1
2361 donothing()
2362 $P1 = find_lex "val"
2363 say $P1
2364 .return ()
2365 .end
2367 .sub donothing
2368 $P0 = new "Integer"
2369 $P0 = 5
2370 # This creates a new binding that is not accessible by the
2371 # caller (myclosure)
2372 .lex "val", $P0
2373 null $P2
2374 null $P1
2375 .end
2376 CODE
2377 3
2378 3
2379 OUTPUT
2381 pir_output_is( <<'CODE', <<'OUTPUT', "slurpy named after :optional" );
2382 .sub main :main
2383 foo(0, 'abc' => 1)
2384 foo('abc' => 2)
2385 $P0 = new 'ResizablePMCArray'
2386 push $P0, 1
2387 foo($P0 :flat, 'abc' => 3)
2388 $P0 = new 'ResizablePMCArray'
2389 foo($P0 :flat, 'abc' => 4)
2390 $P0 = new 'Hash'
2391 $P0['abc'] = 5
2392 foo($P0 :named :flat)
2393 .end
2395 .sub foo
2396 .param pmc val :optional
2397 .param int has_val :opt_flag
2398 .param pmc hash :slurpy :named
2399 print "ok "
2400 $P0 = hash['abc']
2401 print $P0
2402 print "\n"
2403 .end
2404 CODE
2405 ok 1
2406 ok 2
2407 ok 3
2408 ok 4
2409 ok 5
2410 OUTPUT
2412 pir_output_is( <<'CODE', <<'OUTPUT', "named optional after :optional" );
2413 .sub main :main
2414 foo()
2415 foo(1 :named('y'))
2416 $P0 = new 'Integer'
2417 $P0 = 2
2418 'foo'($P0 :named('y'))
2419 .end
2421 .sub foo
2422 .param pmc x :optional
2423 .param int has_x :opt_flag
2424 .param pmc y :optional :named('y')
2425 .param int has_y :opt_flag
2426 if has_y goto have_y
2427 y = new 'Integer'
2428 y = 0
2429 have_y:
2430 say y
2431 .end
2432 CODE
2433 0
2434 1
2435 2
2436 OUTPUT
2438 pir_error_output_like( <<'CODE', <<'OUTPUT', "arg mismatch with no params", todo=> 'TT #1033' );
2439 .sub main :main
2440 foo(1)
2441 .end
2443 .sub foo
2444 .end
2445 CODE
2446 /too many arguments passed\(1\) - 0 params expected/
2447 OUTPUT
2449 # See Rakudo queue http://rt.perl.org/rt3/Ticket/Display.html?id=62730
2450 pir_output_is( <<'CODE', <<'OUTPUT', "named from register, not constant" );
2451 .sub 'main'
2452 $S0 = 'foo'
2453 example('foo' => 42) # normal named parameter
2454 example( $S0 => 42) # parameter named by non-const register
2455 just_a_string( $S0, 'foo' => 42 ) # nameyness should not stick on register
2456 .end
2458 .sub 'example'
2459 .param pmc foo :named('foo')
2460 say foo
2461 .end
2463 .sub 'just_a_string'
2464 .param pmc bar
2465 .param int baz :named( 'foo' )
2466 say bar
2467 say baz
2468 .end
2469 CODE
2470 42
2471 42
2472 foo
2473 42
2474 OUTPUT
2476 # See Rakudo queue http://rt.perl.org/rt3/Ticket/Display.html?id=62730
2477 pir_output_is( <<'CODE', <<'OUTPUT', "Handling :flat of empty arguments" );
2478 .sub 'main'
2479 $P0 = new ['Undef']
2480 ($P0) = foo()
2481 $S0 = typeof $P0
2482 say $S0
2483 .end
2485 .sub 'foo'
2486 .param pmc arg :slurpy
2487 $S0 = typeof arg
2488 say $S0
2489 .return (arg :flat)
2490 .end
2491 CODE
2492 ResizablePMCArray
2493 Undef
2494 OUTPUT
2496 pir_output_is( <<'CODE', <<'OUTPUT', "Tailcall from vtable" );
2498 .sub main :main
2499 $P1 = newclass "Foo"
2500 $P2 = new "Foo"
2502 ## Should return 2, but doesn't.
2503 $I1 = elements $P2
2504 $S1 = $I1
2505 say $S1
2506 .end
2508 .namespace ["Foo"]
2510 .sub elements :vtable
2511 $I0 = 13
2512 $I1 = 2
2513 .tailcall identity($I1)
2514 .end
2516 .sub identity
2517 .param int arg
2518 .return (arg)
2519 .end
2520 CODE
2521 2
2522 OUTPUT
2524 pir_output_is( <<'CODE', <<'OUTPUT', "methodtailcall 1 TT#133" );
2526 .sub main
2527 say "main"
2528 $P0 = foo() ## fails :-(
2529 $P0 = bar()
2530 say "done"
2531 .end
2533 .sub foo
2534 .local pmc p
2535 say "foo"
2536 p = new "Class"
2537 .tailcall p."attributes"()
2538 .end
2540 .sub bar
2541 .local pmc p
2542 say "bar"
2543 p = new "Class"
2544 $P0 = p."attributes"()
2545 .return ($P0)
2546 .end
2548 CODE
2549 main
2550 foo
2551 bar
2552 done
2553 OUTPUT
2555 pir_output_is( <<'CODE', <<'OUTPUT', "handling of slurpy after optional, TT #1733" );
2557 # Lua calling convention scheme
2559 # f() has 2 known parameters
2560 .sub 'f'
2561 .param pmc p1 :optional
2562 .param int has_p1 :opt_flag
2563 .param pmc p2 :optional
2564 .param int has_p2 :opt_flag
2565 .param pmc extra :slurpy
2566 unless has_p1 goto L1
2567 say p1
2568 unless has_p2 goto L1
2569 say p2
2570 $P0 = iter extra
2571 L2:
2572 unless $P0 goto L1
2573 $P1 = shift $P0
2574 say $P1
2575 goto L2
2576 L1:
2577 .end
2579 .sub 'main' :main
2580 $P1 = box "p1"
2581 $P2 = box "p2"
2582 $P3 = box "p3"
2583 f($P1, $P2, $P3)
2584 f($P1, $P2)
2585 f($P1)
2586 .end
2588 CODE
2589 p1
2590 p2
2591 p3
2592 p1
2593 p2
2594 p1
2595 OUTPUT
2597 # Local Variables:
2598 # mode: cperl
2599 # cperl-indent-level: 4
2600 # fill-column: 100
2601 # End:
2602 # vim: expandtab shiftwidth=4: