1. my class Match is Capture is Cool does NQPMatchRole {
  2. my Mu $EMPTY_LIST := nqp::list();
  3. my Mu $NO_CAPS := nqp::hash();
  4. my Mu $DID_MATCH := nqp::create(NQPdidMATCH);
  5. method STR() {
  6. nqp::if(
  7. nqp::istype(nqp::getattr(self,Match,'$!match'), NQPdidMATCH),
  8. self.Str,
  9. self!MATCH.Str
  10. )
  11. }
  12. method MATCH() {
  13. nqp::if(
  14. nqp::istype(nqp::getattr(self,Match,'$!match'), NQPdidMATCH),
  15. self,
  16. self!MATCH
  17. )
  18. }
  19. method !MATCH() {
  20. my int $from = nqp::getattr_i(self, Match, '$!from');
  21. my int $pos = nqp::getattr_i(self, Match, '$!pos');
  22. my Mu $list;
  23. my Mu $hash := nqp::hash();
  24. if nqp::isge_i($pos, $from) {
  25. # For captures with lists, initialize the lists.
  26. my $caplist := $NO_CAPS;
  27. my $rxsub := nqp::getattr(self, Match, '$!regexsub');
  28. my str $onlyname = '';
  29. my int $namecount = 0;
  30. if nqp::not_i(nqp::isnull($rxsub)) {
  31. $caplist := nqp::can($rxsub, 'CAPS') ?? nqp::findmethod($rxsub, 'CAPS')($rxsub) !! nqp::null();
  32. if nqp::not_i(nqp::isnull($caplist)) && nqp::istrue($caplist) {
  33. my $iter := nqp::iterator($caplist);
  34. my str $name;
  35. while $iter {
  36. $namecount = nqp::add_i($namecount, 1);
  37. if nqp::iterval(nqp::shift($iter)) >= 2 {
  38. $name = nqp::iterkey_s($iter);
  39. $onlyname = $name if nqp::iseq_i($namecount, 1);
  40. nqp::iscclass(nqp::const::CCLASS_NUMERIC, $name, 0)
  41. ?? nqp::bindpos(
  42. nqp::if(nqp::isconcrete($list), $list, ($list := nqp::list())),
  43. nqp::fromstr_I($name, Int), [])
  44. !! nqp::bindkey($hash, $name, []);
  45. }
  46. }
  47. }
  48. }
  49. # Walk the capture stack and populate the Match.
  50. my Mu $cs := nqp::getattr(self, Match, '$!cstack');
  51. if nqp::isnull($cs) || nqp::not_i(nqp::istrue($cs)) {}
  52. elsif nqp::not_i(nqp::istrue($caplist)) {}
  53. elsif nqp::iseq_i($namecount, 1) && nqp::isgt_i(nqp::chars($onlyname), 0) && nqp::eqat($onlyname, '$!', 0) {
  54. # If there's only one destination, avoid repeated hash lookups
  55. my int $cselems = nqp::elems($cs);
  56. my int $csi = -1;
  57. my Mu $dest;
  58. # numeric: <= ord("9") so positional capture
  59. $dest := nqp::islt_i(nqp::ord($onlyname),58)
  60. ?? nqp::atpos($list, $onlyname)
  61. !! nqp::atkey($hash, $onlyname);
  62. my $subcur;
  63. my str $name;
  64. while nqp::islt_i(++$csi,$cselems) {
  65. $subcur := nqp::atpos($cs, $csi);
  66. $name = nqp::getattr_s($subcur, $?CLASS, '$!name');
  67. nqp::push($dest,$subcur.MATCH())
  68. if nqp::not_i(nqp::isnull_s($name));
  69. }
  70. }
  71. else {
  72. my int $cselems = nqp::elems($cs);
  73. my int $csi = -1;
  74. my $subcur;
  75. my str $name;
  76. while nqp::islt_i(++$csi,$cselems) {
  77. $subcur := nqp::atpos($cs, $csi);
  78. $name = nqp::getattr_s($subcur, $?CLASS, '$!name');
  79. if nqp::not_i(nqp::isnull_s($name)) && nqp::isgt_i(nqp::chars($name), 0) {
  80. my Mu $submatch := $subcur.MATCH;
  81. if nqp::eqat($name, '$', 0) && (nqp::iseq_s($name, '$!from') || nqp::iseq_s($name, '$!to')) {
  82. nqp::bindattr_i(self, Match, $name, $submatch.from);
  83. }
  84. elsif nqp::islt_i(nqp::index($name, '='), 0) {
  85. my Mu $capval := nqp::atkey($caplist, $name);
  86. my int $needs_list = nqp::isconcrete($capval) && $capval >= 2;
  87. if nqp::iscclass(nqp::const::CCLASS_NUMERIC, $name, 0) {
  88. $list := nqp::list() unless nqp::isconcrete($list);
  89. $needs_list
  90. ?? nqp::atpos($list, nqp::fromstr_I($name, Int)).append($submatch)
  91. !! nqp::bindpos($list, nqp::fromstr_I($name, Int), $submatch);
  92. }
  93. else {
  94. $needs_list
  95. ?? nqp::atkey($hash, $name).append($submatch)
  96. !! nqp::bindkey($hash, $name, $submatch);
  97. }
  98. }
  99. else {
  100. my $names := nqp::split('=', $name);
  101. my $iter := nqp::iterator($names);
  102. my Mu $capval;
  103. my int $needs_list;
  104. while $iter {
  105. $name = nqp::shift($iter);
  106. $capval := nqp::atkey($caplist, $name);
  107. $needs_list = nqp::isconcrete($capval) && $capval >= 2;
  108. if nqp::iscclass(nqp::const::CCLASS_NUMERIC, $name, 0) {
  109. $list := nqp::list() unless nqp::isconcrete($list);
  110. $needs_list
  111. ?? nqp::atpos($list, nqp::fromstr_I($name, Int)).append($submatch)
  112. !! nqp::bindpos($list, nqp::fromstr_I($name, Int), $submatch);
  113. }
  114. else {
  115. $needs_list
  116. ?? nqp::atkey($hash, $name).append($submatch)
  117. !! nqp::bindkey($hash, $name, $submatch);
  118. }
  119. }
  120. }
  121. }
  122. }
  123. }
  124. }
  125. nqp::bindattr(self, Capture, '@!list', nqp::isconcrete($list) ?? $list !! $EMPTY_LIST);
  126. nqp::bindattr(self, Capture, '%!hash', $hash);
  127. nqp::bindattr(self, Match, '$!match', $DID_MATCH);
  128. # Once we've produced the captures, and if we know we're finished and
  129. # will never be backtracked into, we can release cstack and regexsub.
  130. unless nqp::defined(nqp::getattr(self, Match, '$!bstack')) {
  131. nqp::bindattr(self, Match, '$!cstack', nqp::null());
  132. nqp::bindattr(self, Match, '$!regexsub', nqp::null());
  133. }
  134. self;
  135. }
  136. method CURSOR_NEXT() { # from !cursor_next in nqp
  137. nqp::if(
  138. nqp::defined($!restart),
  139. $!restart(self),
  140. nqp::stmts(
  141. (my $cur := self."!cursor_start_cur"()),
  142. $cur."!cursor_fail"(),
  143. $cur
  144. )
  145. )
  146. }
  147. method CURSOR_OVERLAP() { # adapted from !cursor_more in nqp
  148. nqp::stmts(
  149. (my $new := nqp::create(self)),
  150. nqp::bindattr( $new,$?CLASS,'$!shared',$!shared),
  151. nqp::bindattr( $new,$?CLASS,'$!braid',$!braid),
  152. nqp::bindattr_i($new,$?CLASS,'$!from',-1),
  153. nqp::bindattr_i($new,$?CLASS,'$!pos',nqp::add_i($!from,1)),
  154. nqp::bindattr_i($new,$?CLASS,'$!to',-1),
  155. $!regexsub($new)
  156. )
  157. }
  158. method CURSOR_MORE() { # adapted from !cursor_more in nqp
  159. nqp::stmts(
  160. (my $new := nqp::create(self)),
  161. nqp::bindattr( $new,$?CLASS,'$!shared',$!shared),
  162. nqp::bindattr( $new,$?CLASS,'$!braid',$!braid),
  163. nqp::bindattr_i($new,$?CLASS,'$!from',-1),
  164. nqp::bindattr_i($new,$?CLASS,'$!pos',
  165. nqp::if(
  166. nqp::isge_i($!from,$!pos),
  167. nqp::add_i($!from,1),
  168. $!pos
  169. )
  170. ),
  171. nqp::bindattr_i($new,$?CLASS,'$!to',-1),
  172. $!regexsub($new)
  173. )
  174. }
  175. # INTERPOLATE will iterate over the string $tgt beginning at position 0.
  176. # If it can't match against pattern var (or any element of var if it is an array)
  177. # it will increment $pos and try again. Therefor it is important to only match
  178. # against the current position.
  179. # $i is case insensitive flag
  180. # $s is for sequential matching instead of junctive
  181. # $a is true if we are in an assertion
  182. method INTERPOLATE(\var, int $i, int $m, int $monkey, int $s, int $a = 0, $context = PseudoStash) {
  183. if nqp::isconcrete(var) {
  184. # Call it if it is a routine. This will capture if requested.
  185. return (var)(self) if nqp::istype(var,Callable);
  186. my $maxmatch;
  187. my $cur := self.'!cursor_start_cur'();
  188. my str $tgt = $cur.target;
  189. my int $eos = nqp::chars($tgt);
  190. my int $maxlen = -1;
  191. my int $pos = nqp::getattr_i($cur, $?CLASS, '$!from');
  192. my int $start = 1;
  193. my int $nomod = !($i || $m);
  194. my Mu $order := nqp::list();
  195. # Looks something we need to loop over
  196. if nqp::istype(var, Iterable) and !nqp::iscont(var) {
  197. my $varlist := var.list;
  198. my int $elems = $varlist.elems; # reifies
  199. my $list := nqp::getattr($varlist,List,'$!reified');
  200. # Order matters for sequential matching, so no NFA involved.
  201. if $s {
  202. $order := $list;
  203. }
  204. # prepare to run the NFA if var is array-ish.
  205. else {
  206. my Mu $nfa := QRegex::NFA.new;
  207. my Mu $alts := nqp::setelems(nqp::list,$elems);
  208. my int $fate = 0;
  209. my int $j = -1;
  210. while nqp::islt_i(++$j,$elems) {
  211. my Mu $topic := nqp::atpos($list,$j);
  212. nqp::bindpos($alts,$j,$topic);
  213. # We are in a regex assertion, the strings we get will
  214. # be treated as regex rules.
  215. if $a {
  216. return $cur.'!cursor_start_cur'()
  217. if nqp::istype($topic,Associative);
  218. my $rx := MAKE_REGEX($topic,$i,$m,$monkey,$context);
  219. $nfa.mergesubstates($start,0,nqp::decont($fate),
  220. nqp::findmethod($rx,'NFA')($rx),
  221. Mu);
  222. }
  223. # A Regex already.
  224. elsif nqp::istype($topic,Regex) {
  225. $nfa.mergesubstates($start,0,nqp::decont($fate),
  226. nqp::findmethod($topic,'NFA')($topic),
  227. Mu);
  228. }
  229. # The pattern is a string.
  230. else {
  231. my Mu $lit := QAST::Regex.new(
  232. :rxtype<literal>, $topic,
  233. :subtype( $nomod
  234. ?? ''
  235. !! $m
  236. ?? $i
  237. ?? 'ignorecase+ignoremark'
  238. !! 'ignoremark'
  239. !! 'ignorecase')
  240. );
  241. my Mu $nfa2 := QRegex::NFA.new;
  242. my Mu $node := nqp::findmethod($nfa2,'addnode')($nfa2,$lit);
  243. $nfa.mergesubstates($start,0,nqp::decont($fate),
  244. nqp::findmethod($node,'save')($node,:non_empty(1)),
  245. Mu);
  246. }
  247. ++$fate;
  248. }
  249. # Now run the NFA
  250. my Mu $fates := nqp::findmethod($nfa,'run')($nfa,$tgt,$pos);
  251. my int $count = nqp::elems($fates);
  252. nqp::setelems($order,$count);
  253. $j = -1;
  254. nqp::bindpos($order,$j,
  255. nqp::atpos($alts,nqp::atpos_i($fates,$j)))
  256. while nqp::islt_i(++$j,$count);
  257. }
  258. }
  259. # Use the var as it is if it's not array-ish.
  260. else {
  261. nqp::push($order, var);
  262. }
  263. my str $topic_str;
  264. my int $omax = nqp::elems($order);
  265. my int $o = -1;
  266. while nqp::islt_i(++$o,$omax) {
  267. my Mu $topic := nqp::atpos($order,$o);
  268. my $match;
  269. my int $len;
  270. # We are in a regex assertion, the strings we get will be
  271. # treated as regex rules.
  272. if $a {
  273. return $cur.'!cursor_start_cur'()
  274. if nqp::istype($topic,Associative);
  275. my $rx := MAKE_REGEX($topic,$i,$m,$monkey,$context);
  276. $match := self.$rx;
  277. $len = $match.pos - $match.from;
  278. }
  279. # A Regex already.
  280. elsif nqp::istype($topic,Regex) {
  281. $match := self.$topic;
  282. $len = $match.pos - $match.from;
  283. }
  284. # The pattern is a string. $len and and $topic_str are used
  285. # later on if this condition does not hold.
  286. elsif nqp::iseq_i(($len = nqp::chars($topic_str = $topic.Str)),0) {
  287. $match = 1;
  288. }
  289. # no modifier, match literally
  290. elsif $nomod {
  291. $match = nqp::eqat($tgt, $topic_str, $pos)
  292. }
  293. # ignoremark(+ignorecase?)
  294. elsif $m {
  295. my int $k = -1;
  296. # ignorecase+ignoremark
  297. if $i {
  298. my str $tgt_fc = nqp::fc(nqp::substr($tgt,$pos,$len));
  299. my str $topic_fc = nqp::fc($topic_str);
  300. Nil while nqp::islt_i(++$k,$len)
  301. && nqp::iseq_i(
  302. nqp::ordbaseat($tgt_fc, nqp::add_i($pos,$k)),
  303. nqp::ordbaseat($topic_fc, $k)
  304. );
  305. }
  306. # ignoremark
  307. else {
  308. Nil while nqp::islt_i(++$k, $len)
  309. && nqp::iseq_i(
  310. nqp::ordbaseat($tgt, nqp::add_i($pos,$k)),
  311. nqp::ordbaseat($topic_str, $k)
  312. );
  313. }
  314. $match = nqp::iseq_i($k,$len); # match if completed
  315. }
  316. # ignorecase
  317. else {
  318. $match = nqp::iseq_s(
  319. nqp::fc(nqp::substr($tgt, $pos, $len)),
  320. nqp::fc($topic_str)
  321. )
  322. }
  323. if $match
  324. && nqp::isgt_i($len,$maxlen)
  325. && nqp::isle_i(nqp::add_i($pos,$len),$eos) {
  326. $maxlen = $len;
  327. $maxmatch := $match;
  328. last if $s; # stop here for sequential alternation
  329. }
  330. }
  331. nqp::istype($maxmatch, Match)
  332. ?? $maxmatch
  333. !! nqp::isge_i($maxlen,0)
  334. ?? $cur.'!cursor_pass'(nqp::add_i($pos,$maxlen), '')
  335. !! $cur
  336. }
  337. else {
  338. self."!cursor_start_cur"()
  339. }
  340. }
  341. method CALL_SUBRULE($rule, |c) {
  342. $rule(self, |c)
  343. }
  344. method DYNQUANT_LIMITS($mm) {
  345. nqp::istype($mm,Range)
  346. ?? $mm.min == Inf
  347. ?? die 'Range minimum in quantifier (**) cannot be +Inf'
  348. !! $mm.max == -Inf
  349. ?? die 'Range maximum in quantifier (**) cannot be -Inf'
  350. !! nqp::list_i(
  351. $mm.min < 0 ?? 0 !! $mm.min.Int,
  352. $mm.max == Inf ?? -1 !! $mm.max.Int)
  353. !! $mm == -Inf || $mm == Inf
  354. ?? Failure.new('Fixed quantifier cannot be infinite')
  355. !! nqp::list_i($mm.Int, $mm.Int)
  356. }
  357. method OTHERGRAMMAR($grammar, $name, |) {
  358. my $lang_cursor := $grammar.'!cursor_init'(self.target(), :p(self.pos()));
  359. $lang_cursor.clone_braid_from(self);
  360. $lang_cursor."$name"();
  361. }
  362. method INDMETHOD($name, |c) {
  363. self."$name"(|c);
  364. }
  365. method INDRULE($rule, |c) {
  366. $rule(self, |c)
  367. }
  368. method RECURSE() {
  369. nqp::getlexdyn('$?REGEX')(self)
  370. }
  371. sub MAKE_REGEX($arg, int $i, int $m, int $monkey, $context) {
  372. my role CachedCompiledRegex {
  373. has $.regex;
  374. }
  375. if nqp::istype($arg,Regex) {
  376. $arg
  377. }
  378. elsif nqp::istype($arg, CachedCompiledRegex) {
  379. $arg.regex
  380. }
  381. else {
  382. my $*RESTRICTED = "Prohibited regex interpolation"
  383. unless $monkey; # Comes from when regex was originally compiled.
  384. my $rx := $i
  385. ?? $m
  386. ?? EVAL("anon regex \{ :i :m $arg\}", :$context)
  387. !! EVAL("anon regex \{ :i $arg\}", :$context)
  388. !! $m
  389. ?? EVAL("anon regex \{ :m $arg\}", :$context)
  390. !! EVAL("anon regex \{ $arg\}", :$context);
  391. $arg does CachedCompiledRegex($rx);
  392. $rx
  393. }
  394. }
  395. submethod BUILD(
  396. :$orig = '',
  397. :$from = 0,
  398. :to(:$pos),
  399. :ast(:$made),
  400. :$shared,
  401. :$braid,
  402. :$list,
  403. :$hash)
  404. {
  405. # :build tells !cursor_init that it's too late to do a CREATE
  406. self.'!cursor_init'($orig, :build, :p($pos), :$shared, :$braid);
  407. nqp::bindattr_i(self, Match, '$!from', $from);
  408. nqp::bindattr( self, Match, '$!made', nqp::decont($made)) if $made.defined;
  409. }
  410. method clone() {
  411. my $new := nqp::clone(self);
  412. $new;
  413. }
  414. multi method WHICH (Match:D:) {
  415. self.Mu::WHICH # skip Capture's as Match is not a value type
  416. }
  417. proto method Bool(|) { * }
  418. multi method Bool(Match:U:) { False }
  419. multi method Bool(Match:D:) { nqp::p6bool($!pos >= $!from) }
  420. multi method Numeric(Match:D:) {
  421. self.Str.Numeric
  422. }
  423. multi method ACCEPTS(Match:D: Any $) { self }
  424. method prematch(Match:D:) {
  425. nqp::substr(self.target,0,$!from)
  426. }
  427. method postmatch(Match:D:) {
  428. nqp::substr(self.target,self.to)
  429. }
  430. method caps(Match:D:) {
  431. my @caps;
  432. for self.pairs -> $p {
  433. if nqp::istype($p.value,Array) {
  434. @caps.push: $p.key => $_ for $p.value.list
  435. } elsif $p.value.DEFINITE {
  436. @caps.push: $p
  437. }
  438. }
  439. @caps.sort: -> $a { $a.value.from +< 32 + $a.value.pos }
  440. }
  441. method chunks(Match:D:) {
  442. my $prev = $!from;
  443. my $target := self.target;
  444. gather {
  445. for self.caps {
  446. if .value.from > $prev {
  447. take '~' => substr($target,$prev, .value.from - $prev)
  448. }
  449. take $_;
  450. $prev = .value.pos;
  451. }
  452. take '~' => substr($target,$prev, $!pos - $prev) if $prev < $!pos;
  453. }
  454. }
  455. multi method perl(Match:D:) {
  456. my %attrs;
  457. %attrs.ASSIGN-KEY("orig", (self.orig // '' ).perl);
  458. %attrs.ASSIGN-KEY("from", (self.from // 0 ).perl);
  459. %attrs.ASSIGN-KEY("pos", (self.pos // 0 ).perl);
  460. %attrs.ASSIGN-KEY("made", (self.made // Any).perl);
  461. %attrs.ASSIGN-KEY("list", (self.Capture::list // [] ).perl);
  462. %attrs.ASSIGN-KEY("hash", (self.Capture::hash // {} ).perl);
  463. 'Match.new('
  464. ~ %attrs.fmt('%s => %s', ', ')
  465. ~ ')'
  466. }
  467. multi method gist (Match:D: $d = 0) {
  468. return "#<failed match>" unless self;
  469. my $s = ' ' x ($d + 1);
  470. my $r = ("=> " if $d) ~ "\x[FF62]{self}\x[FF63]\n";
  471. for @.caps {
  472. $r ~= $s ~ (.key // '?') ~ ' ' ~ .value.gist($d + 1)
  473. }
  474. $d == 0 ?? $r.chomp !! $r;
  475. }
  476. }
  477. multi sub infix:<eqv>(Match:D \a, Match:D \b) {
  478. a =:= b
  479. ||
  480. [&&] (
  481. a.pos eqv b.pos,
  482. a.from eqv b.from,
  483. a.orig eqv b.orig,
  484. (a.made // Any) eqv (b.made // Any),
  485. (a.Capture::list // nqp::list ) eqv (b.Capture::list // nqp::list ),
  486. (a.Capture::hash // nqp::hash ) eqv (b.Capture::hash // nqp::hash )
  487. );
  488. }
  489. sub make(Mu \made) {
  490. my $slash := nqp::getlexcaller('$/');
  491. nqp::bindattr( nqp::decont($slash), Match, '$!made', made );
  492. }