1. my class X::ControlFlow::Return { ... }
  2. my class X::Eval::NoSuchLang { ... }
  3. my class X::Multi::NoMatch { ... }
  4. my class X::NYI { ... }
  5. my class PseudoStash { ... }
  6. my class Label { ... }
  7. class CompUnit::DependencySpecification { ... }
  8. sub THROW(int $type, Mu \arg) {
  9. my Mu $ex := nqp::newexception();
  10. nqp::setpayload($ex, arg);
  11. nqp::setextype($ex, $type);
  12. nqp::throw($ex);
  13. arg;
  14. }
  15. sub THROW-NIL(int $type --> Nil) {
  16. my Mu $ex := nqp::newexception();
  17. # nqp::setpayload($ex, Nil);
  18. nqp::setextype($ex, $type);
  19. nqp::throw($ex);
  20. }
  21. sub RETURN-LIST(Mu \list) is raw {
  22. my Mu $storage := nqp::getattr(list, List, '$!reified');
  23. nqp::iseq_i(nqp::elems($storage), 0)
  24. ?? Nil
  25. !! (nqp::iseq_i(nqp::elems($storage), 1)
  26. ?? nqp::shift($storage)
  27. !! list)
  28. }
  29. proto sub return-rw(|) {*}
  30. multi sub return-rw(--> Nil) {
  31. nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, Nil);
  32. }
  33. multi sub return-rw(Mu \x --> Nil) {
  34. nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, x);
  35. }
  36. multi sub return-rw(**@x is raw --> Nil) {
  37. nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, @x);
  38. }
  39. proto sub return(|) {*}
  40. multi sub return(--> Nil) {
  41. nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, Nil);
  42. }
  43. multi sub return(Mu \x --> Nil) {
  44. nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, nqp::p6recont_ro(x));
  45. }
  46. multi sub return(**@x is raw --> Nil) {
  47. nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, @x);
  48. }
  49. proto sub take-rw(|) { * }
  50. multi sub take-rw() { die "take-rw without parameters doesn't make sense" }
  51. multi sub take-rw(\x) { THROW(nqp::const::CONTROL_TAKE, x) }
  52. multi sub take-rw(|) {
  53. THROW(nqp::const::CONTROL_TAKE,RETURN-LIST(nqp::p6argvmarray))
  54. }
  55. proto sub take(|) { * }
  56. multi sub take() { die "take without parameters doesn't make sense" }
  57. multi sub take(\x) {
  58. THROW(nqp::const::CONTROL_TAKE, nqp::p6recont_ro(x))
  59. }
  60. multi sub take(|) {
  61. THROW(
  62. nqp::const::CONTROL_TAKE,
  63. nqp::p6recont_ro(RETURN-LIST(nqp::p6argvmarray))
  64. )
  65. }
  66. proto sub goto(|) { * }
  67. multi sub goto(Label:D \x --> Nil) { x.goto }
  68. proto sub last(|) { * }
  69. multi sub last(--> Nil) { nqp::throwextype(nqp::const::CONTROL_LAST); Nil }
  70. multi sub last(Label:D \x --> Nil) { x.last }
  71. proto sub next(|) { * }
  72. multi sub next(--> Nil) { nqp::throwextype(nqp::const::CONTROL_NEXT); Nil }
  73. multi sub next(Label:D \x --> Nil) { x.next }
  74. proto sub redo(|) { * }
  75. multi sub redo(--> Nil) { nqp::throwextype(nqp::const::CONTROL_REDO); Nil }
  76. multi sub redo(Label:D \x --> Nil) { x.redo }
  77. proto sub succeed(|) { * }
  78. multi sub succeed(--> Nil) { THROW-NIL(nqp::const::CONTROL_SUCCEED) }
  79. multi sub succeed(\x --> Nil) { THROW(nqp::const::CONTROL_SUCCEED, x) }
  80. multi sub succeed(| --> Nil) {
  81. THROW(nqp::const::CONTROL_SUCCEED,RETURN-LIST(nqp::p6argvmarray))
  82. }
  83. sub proceed(--> Nil) { THROW-NIL(nqp::const::CONTROL_PROCEED) }
  84. sub callwith(|c) is raw {
  85. $/ := nqp::getlexcaller('$/');
  86. my Mu $dispatcher := nqp::p6finddispatcher('callwith');
  87. $dispatcher.exhausted ?? Nil !!
  88. $dispatcher.call_with_args(|c)
  89. }
  90. sub nextwith(|c) is raw {
  91. $/ := nqp::getlexcaller('$/');
  92. my Mu $dispatcher := nqp::p6finddispatcher('nextwith');
  93. nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, $dispatcher.exhausted
  94. ?? Nil
  95. !! $dispatcher.call_with_args(|c))
  96. }
  97. sub callsame() is raw {
  98. $/ := nqp::getlexcaller('$/');
  99. my Mu $dispatcher := nqp::p6finddispatcher('callsame');
  100. $dispatcher.exhausted ?? Nil !!
  101. $dispatcher.call_with_capture(
  102. nqp::p6argsfordispatcher($dispatcher))
  103. }
  104. sub nextsame() is raw {
  105. $/ := nqp::getlexcaller('$/');
  106. my Mu $dispatcher := nqp::p6finddispatcher('nextsame');
  107. nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, $dispatcher.exhausted
  108. ?? Nil
  109. !! $dispatcher.call_with_capture(nqp::p6argsfordispatcher($dispatcher)))
  110. }
  111. sub lastcall(--> True) {
  112. nqp::p6finddispatcher('lastcall').last();
  113. }
  114. sub nextcallee() {
  115. my Mu $dispatcher := nqp::p6finddispatcher('nextsame');
  116. $dispatcher.exhausted ?? Nil !! $dispatcher.shift_callee()
  117. }
  118. sub samewith(|c) {
  119. $/ := nqp::getlexcaller('$/');
  120. my Mu $ctx := nqp::ctxcaller(nqp::ctx());
  121. until nqp::isnull($ctx) {
  122. my $caller := nqp::getcodeobj(nqp::ctxcode($ctx));
  123. if nqp::istype($caller, Routine) {
  124. if $caller.multi {
  125. my $dispatcher := $caller.?dispatcher || die "Could not find dispatcher";
  126. return nqp::istype($caller, Method)
  127. ?? $dispatcher(nqp::atkey($ctx, 'self') // $caller.package,|c)
  128. !! $dispatcher(|c);
  129. }
  130. else {
  131. return $caller(|c);
  132. }
  133. }
  134. $ctx := nqp::ctxouter($ctx);
  135. }
  136. die "Cannot use samewith outside of a routine";
  137. }
  138. sub leave(|) { X::NYI.new(feature => 'leave').throw }
  139. sub emit(\value --> Nil) {
  140. THROW(nqp::const::CONTROL_EMIT, nqp::p6recont_ro(value));
  141. }
  142. sub done(--> Nil) {
  143. THROW-NIL(nqp::const::CONTROL_DONE);
  144. }
  145. proto sub die(|) {*};
  146. multi sub die(--> Nil) {
  147. my $stash := CALLER::;
  148. my $payload = $stash<$!>.DEFINITE ?? $stash<$!> !! "Died";
  149. $payload ~~ Exception
  150. ?? $payload.throw
  151. !! X::AdHoc.new(:$payload).throw
  152. }
  153. multi sub die(Exception:U $e --> Nil) {
  154. X::AdHoc.new(:payload("Died with undefined " ~ $e.^name)).throw;
  155. }
  156. multi sub die($payload --> Nil) {
  157. $payload ~~ Exception
  158. ?? $payload.throw
  159. !! X::AdHoc.new(:$payload).throw
  160. }
  161. multi sub die(|cap ( *@msg ) --> Nil) {
  162. X::AdHoc.from-slurpy(|cap).throw
  163. }
  164. multi sub warn(*@msg) {
  165. my $msg = @msg.join || "Warning: something's wrong";
  166. my $ex := nqp::newexception();
  167. nqp::setmessage($ex, nqp::unbox_s($msg));
  168. nqp::setextype($ex, nqp::const::CONTROL_WARN);
  169. nqp::throw($ex);
  170. 0;
  171. }
  172. my class Rakudo::Internals::EvalIdSource {
  173. my Int $count = 0;
  174. my Lock $lock = Lock.new;
  175. method next-id() {
  176. $lock.protect: { $count++ }
  177. }
  178. }
  179. proto sub EVAL(Cool $code, Str() :$lang = 'perl6', PseudoStash :$context, *%n) {
  180. # First look in compiler registry.
  181. my $compiler := nqp::getcomp($lang);
  182. if nqp::isnull($compiler) {
  183. # Try a multi-dispatch to another EVAL candidate. If that fails to
  184. # dispatch, map it to a typed exception.
  185. CATCH {
  186. when X::Multi::NoMatch {
  187. X::Eval::NoSuchLang.new(:$lang).throw
  188. }
  189. }
  190. return {*};
  191. }
  192. $context := CALLER:: unless nqp::defined($context);
  193. my $eval_ctx := nqp::getattr(nqp::decont($context), PseudoStash, '$!ctx');
  194. my $?FILES := 'EVAL_' ~ Rakudo::Internals::EvalIdSource.next-id;
  195. my \mast_frames := nqp::hash();
  196. my $*CTXSAVE; # make sure we don't use the EVAL's MAIN context for the currently compiling compilation unit
  197. my $compiled;
  198. my $LANG := $context<%?LANG>;
  199. if !$LANG {
  200. $LANG := CALLERS::<%?LANG>;
  201. }
  202. if $LANG {
  203. # XXX
  204. my $grammar := $LANG<MAIN>;
  205. my $actions := $LANG<MAIN-actions>;
  206. $compiled := $compiler.compile(
  207. $code.Stringy,
  208. :outer_ctx($eval_ctx),
  209. :global(GLOBAL),
  210. :mast_frames(mast_frames),
  211. :grammar($grammar),
  212. :actions($actions),
  213. );
  214. }
  215. else {
  216. $compiled := $compiler.compile(
  217. $code.Stringy,
  218. :outer_ctx($eval_ctx),
  219. :global(GLOBAL),
  220. :mast_frames(mast_frames),
  221. );
  222. }
  223. if $*W and $*W.is_precompilation_mode() { # we are still compiling
  224. $*W.add_additional_frames(mast_frames);
  225. }
  226. nqp::forceouterctx(nqp::getattr($compiled, ForeignCode, '$!do'), $eval_ctx);
  227. $compiled();
  228. }
  229. multi sub EVAL(Cool $code, Str :$lang where { ($lang // '') eq 'Perl5' }, PseudoStash :$context) {
  230. my $eval_ctx := nqp::getattr(nqp::decont($context // CALLER::), PseudoStash, '$!ctx');
  231. my $?FILES := 'EVAL_' ~ (state $no)++;
  232. state $p5;
  233. unless $p5 {
  234. {
  235. my $compunit := $*REPO.need(CompUnit::DependencySpecification.new(:short-name<Inline::Perl5>));
  236. GLOBAL.WHO.merge-symbols($compunit.handle.globalish-package);
  237. CATCH {
  238. #X::Eval::NoSuchLang.new(:$lang).throw;
  239. note $_;
  240. }
  241. }
  242. $p5 = ::("Inline::Perl5").default_perl5;
  243. }
  244. $p5.run($code);
  245. }
  246. proto sub EVALFILE($, *%) {*}
  247. multi sub EVALFILE($filename, :$lang = 'perl6') {
  248. EVAL slurp($filename), :$lang, :context(CALLER::);
  249. }
  250. constant Inf = nqp::p6box_n(nqp::inf());
  251. constant NaN = nqp::p6box_n(nqp::nan());
  252. # For some reason, we cannot move this to Rakudo::Internals as a class
  253. # method, because then the return value is always HLLized :-(
  254. sub CLONE-HASH-DECONTAINERIZED(\hash) {
  255. nqp::if(
  256. nqp::getattr(hash,Map,'$!storage').DEFINITE,
  257. nqp::stmts(
  258. (my $clone := nqp::hash),
  259. (my $iter := nqp::iterator(nqp::getattr(hash,Map,'$!storage'))),
  260. nqp::while(
  261. $iter,
  262. nqp::bindkey($clone,
  263. nqp::iterkey_s(nqp::shift($iter)),
  264. nqp::if(
  265. nqp::defined(nqp::iterval($iter)),
  266. nqp::decont(nqp::iterval($iter)).Str,
  267. ''
  268. )
  269. )
  270. ),
  271. $clone
  272. ),
  273. nqp::hash
  274. )
  275. }
  276. sub CLONE-LIST-DECONTAINERIZED(*@list) {
  277. my Mu $list-without := nqp::list();
  278. nqp::push($list-without, nqp::decont(~$_)) for @list.eager;
  279. $list-without;
  280. }