compilers/pge/PGE/Regex.pir

   1 # Copyright (C) 2006-2009, Parrot Foundation.
   2 # $Id$
   3
   4 =head1 TITLE
   5
   6 Regex - base class for grammars and built-in rules
   7
   8 =head1 DESCRIPTION
   9
  10 This implements the base classes for forming grammars, and provides
  11 a number of built-in rules.
  12
  13 =cut
  14
  15 .namespace [ 'PGE'; 'Match' ]
  16
  17 .include 'cclass.pasm'
  18 .include 'interpinfo.pasm'
  19
  20 .sub '__onload' :load
  21     .local pmc p6meta
  22     p6meta = new 'P6metaclass'
  23     p6meta.'new_class'('PGE::Grammar', 'parent'=>'PGE::Match')
  24     $P0 = new 'Hash'
  25     set_global '%!cache', $P0
  26     .return ()
  27 .end
  28
  29
  30 =head2 Built-in regex
  31
  32 =over 4
  33
  34 =item C<ident()>
  35
  36 Match an identifier.
  37
  38 =cut
  39
  40 .sub 'ident' :method :nsentry('ident')
  41     .param pmc adverbs         :slurpy :named
  42     .local string target
  43     .local pmc mob, mfrom, mpos
  44     .local int pos, lastpos
  45
  46     $P0 = get_hll_global ['PGE'], 'Match'
  47     (mob, pos, target) = $P0.'new'(self)
  48
  49     lastpos = length target
  50     $S0 = substr target, pos, 1
  51     if $S0 == '_' goto ident_1
  52     $I0 = is_cclass .CCLASS_ALPHABETIC, target, pos
  53     if $I0 == 0 goto end
  54   ident_1:
  55     pos = find_not_cclass .CCLASS_WORD, target, pos, lastpos
  56     mob.'to'(pos)
  57   end:
  58     .return (mob)
  59 .end
  60
  61
  62 =item C<alpha()>
  63
  64 Match a single alphabetic character.
  65
  66 =cut
  67
  68 .sub 'alpha' :method
  69     .param pmc adverbs         :slurpy :named
  70     .local string target
  71     .local pmc mob, mfrom, mpos
  72     .local int pos, lastpos
  73
  74     $P0 = get_hll_global ['PGE'], 'Match'
  75     (mob, pos, target) = $P0.'new'(self)
  76
  77     lastpos = length target
  78     $S0 = substr target, pos, 1
  79     if $S0 == '_' goto ident_1
  80     $I0 = is_cclass .CCLASS_ALPHABETIC, target, pos
  81     if $I0 == 0 goto end
  82   ident_1:
  83     inc pos
  84     mob.'to'(pos)
  85   end:
  86     .return (mob)
  87 .end
  88
  89
  90 =item C<upper()>
  91
  92 Match a single uppercase character.
  93
  94 =cut
  95
  96 .sub 'upper' :method
  97     .tailcall '!cclass'(self, .CCLASS_UPPERCASE)
  98 .end
  99
 100
 101 =item C<lower()>
 102
 103 Match a single lowercase character.
 104
 105 =cut
 106
 107 .sub "lower" :method
 108     .tailcall '!cclass'(self, .CCLASS_LOWERCASE)
 109 .end
 110
 111
 112 =item C<digit()>
 113
 114 Match a single digit.
 115
 116 =cut
 117
 118 .sub "digit" :method
 119     .tailcall '!cclass'(self, .CCLASS_NUMERIC)
 120 .end
 121
 122 =item C<xdigit()>
 123
 124 Match a single alphanumeric character.
 125
 126 =cut
 127
 128 .sub "xdigit" :method
 129     .tailcall '!cclass'(self, .CCLASS_HEXADECIMAL)
 130 .end
 131
 132 =item C<space()>
 133
 134 Match a single whitespace character.
 135
 136 =cut
 137
 138 .sub "space" :method
 139     .tailcall '!cclass'(self, .CCLASS_WHITESPACE)
 140 .end
 141
 142 =item C<print()>
 143
 144 Match a single printable character.
 145
 146 =cut
 147
 148 .sub "print" :method
 149     .tailcall '!cclass'(self, .CCLASS_PRINTING)
 150 .end
 151
 152 =item C<graph()>
 153
 154 Match a single "graphical" character.
 155
 156 =cut
 157
 158 .sub "graph" :method
 159     .tailcall '!cclass'(self, .CCLASS_GRAPHICAL)
 160 .end
 161
 162 =item C<blank()>
 163
 164 Match a single "blank" character.
 165
 166 =cut
 167
 168 .sub "blank" :method
 169     .tailcall '!cclass'(self, .CCLASS_BLANK)
 170 .end
 171
 172 =item C<cntrl()>
 173
 174 Match a single "control" character.
 175
 176 =cut
 177
 178 .sub "cntrl" :method
 179     .tailcall '!cclass'(self, .CCLASS_CONTROL)
 180 .end
 181
 182 =item C<punct()>
 183
 184 Match a single punctuation character.
 185
 186 =cut
 187
 188 .sub "punct" :method
 189     .tailcall '!cclass'(self, .CCLASS_PUNCTUATION)
 190 .end
 191
 192 =item C<alnum()>
 193
 194 Match a single alphanumeric character.
 195
 196 =cut
 197
 198 .sub "alnum" :method
 199     .tailcall '!cclass'(self, .CCLASS_ALPHANUMERIC)
 200 .end
 201
 202
 203 =item C<ws()>
 204
 205 Match whitespace between tokens.
 206
 207 =cut
 208
 209 .sub "ws" :method
 210     .local string target
 211     .local pmc mob, mfrom, mpos
 212     .local int rep, pos, lastpos
 213     .local string nextchars
 214     .const 'Sub' corou = "ws_corou"
 215     nextchars = ""
 216   ws_1:
 217     $P0 = get_hll_global ['PGE'], 'Match'
 218     (mob, pos, target, mfrom, mpos) = $P0.'new'(self)
 219     lastpos = length target
 220     pos = mfrom
 221     if pos >= lastpos goto found
 222     if pos < 1 goto ws_scan
 223     $I0 = is_cclass .CCLASS_WORD, target, pos
 224     if $I0 == 0 goto ws_scan
 225     $I1 = pos - 1
 226     $I0 = is_cclass .CCLASS_WORD, target, $I1
 227     if $I0 == 0 goto ws_scan
 228     goto end
 229   ws_scan:
 230     $I0 = pos
 231     pos = find_not_cclass .CCLASS_WHITESPACE, target, pos, lastpos
 232     if pos == $I0 goto nobacktrack
 233     $I0 = length nextchars
 234     if $I0 == 0 goto backtrack
 235     $I1 = find_cclass .CCLASS_WHITESPACE, nextchars, 0, $I0
 236     if $I1 >= $I0 goto nobacktrack
 237   backtrack:
 238     mpos = pos
 239     $P0 = corou
 240     $P0 = clone $P0
 241     setattribute mob, '&!corou', $P0
 242     $P0(mob, mfrom, mpos)
 243     .return (mob)
 244   nobacktrack:
 245     if nextchars == "" goto found
 246     $S1 = substr target, pos, 1
 247     $I1 = index nextchars, $S1
 248     if $I1 < 0 goto end
 249   found:
 250     mpos = pos
 251   end:
 252     .return (mob)
 253 .end
 254 .sub "ws_corou" :anon
 255     .param pmc mob
 256     .param pmc mfrom
 257     .param pmc mpos
 258   loop:
 259     .yield (mob)
 260     dec mpos
 261     if mpos > mfrom goto loop
 262     null $P0
 263     setattribute mob, '&!corou', $P0
 264     goto loop
 265 .end
 266
 267
 268 =item C<wb(PMC mob)>
 269
 270 Returns true if we're at a word boundary (as defined by
 271 Perl 5's \b regex).
 272
 273 =cut
 274
 275 .sub "wb" :method
 276     .local string target
 277     .local pmc mob
 278     .local int pos
 279     $P0 = get_hll_global ['PGE'], 'Match'
 280     (mob, pos, target) = $P0.'new'(self)
 281     if pos == 0 goto succeed
 282     $I0 = length target
 283     if pos == $I0 goto succeed
 284     $I0 = pos - 1
 285     $I1 = is_cclass .CCLASS_WORD, target, $I0
 286     $I2 = is_cclass .CCLASS_WORD, target, pos
 287     if $I1 == $I2 goto end
 288   succeed:
 289     mob.'to'(pos)
 290   end:
 291     .return (mob)
 292 .end
 293
 294
 295 =item C<before(PMC mob, STR pattern)>
 296
 297 Perform lookahead -- i.e., check if we're at a position where
 298 C<pattern> matches.  Returns a zero-width Match object on
 299 success.
 300
 301 =cut
 302
 303 .sub "before" :method
 304     .param string pattern      :optional
 305     .param int has_pattern     :opt_flag
 306     .param pmc adverbs         :slurpy :named
 307     .local pmc mob, cache, rule
 308
 309     if has_pattern goto lookahead
 310     mob = '!fail'(self)
 311     .return (mob)
 312   lookahead:
 313     cache = get_global '%!cache'
 314     $I0 = exists cache[pattern]
 315     if $I0 == 0 goto new_pattern
 316     rule = cache[pattern]
 317     goto match
 318   new_pattern:
 319     $P0 = compreg 'PGE::Perl6Regex'
 320     rule = $P0(pattern)
 321     cache[pattern] = rule
 322   match:
 323     mob = rule(self)
 324     unless mob goto end
 325     $P0 = getattribute mob, '$.from'
 326     $P1 = getattribute mob, '$.pos'
 327     assign $P1, $P0
 328     null $P0
 329     setattribute mob, '&!corou', $P0
 330   end:
 331     .return (mob)
 332 .end
 333
 334 =item C<after(PMC mob, STR pattern)>
 335
 336 Perform lookbehind -- i.e., check if the string before the
 337 current position matches <pattern> (anchored at the end).
 338 Returns a zero-width Match object on success.
 339
 340 XXX: Note that this implementation cheats in a big way.
 341 S05 says that C<after> is implemented by reversing the
 342 syntax tree and looking for things in opposite order going
 343 to the left.  This implementation just grabs the (sub)string
 344 up to the current match position and tests that, anchoring
 345 the pattern to the end of the substring.  It's cheap and
 346 potentially very inefficient, but it "works" for now.
 347
 348 =cut
 349
 350 .sub "after" :method
 351     .param string pattern      :optional
 352     .param int has_pattern     :opt_flag
 353     .param pmc adverbs         :slurpy :named
 354     .local pmc mob, cache, rule
 355     .local int from
 356
 357     mob = self
 358     if has_pattern goto lookbehind
 359     mob = '!fail'(mob)
 360     .return (mob)
 361   lookbehind:
 362     pattern = concat '[', pattern
 363     pattern = concat pattern, ']$'
 364     cache = get_global '%!cache'
 365     $I0 = exists cache[pattern]
 366     if $I0 == 0 goto new_pattern
 367     rule = cache[pattern]
 368     goto match
 369   new_pattern:
 370     $P0 = compreg 'PGE::Perl6Regex'
 371     rule = $P0(pattern)
 372     cache[pattern] = rule
 373   match:
 374     $P0 = getattribute mob, '$.target'
 375     $S0 = $P0
 376     $P0 = getattribute mob, '$.pos'
 377     from = $P0
 378     $S0 = substr $S0, 0, from
 379     mob = rule($S0)
 380     unless mob goto end
 381     $P0 = getattribute mob, '$.from'
 382     $P1 = getattribute mob, '$.pos'
 383     $P0 = from
 384     $P1 = from
 385     null $P0
 386     setattribute mob, '&!corou', $P0
 387   end:
 388     .return (mob)
 389 .end
 390
 391 =item FAILGOAL(pmc mob, string goal [, 'dba'=>dba])
 392
 393 Throw an exception when parsing fails in goal matching.
 394
 395 =cut
 396
 397 .sub 'FAILGOAL' :method
 398     .param string goal
 399     .param pmc options         :slurpy :named
 400     .local string dba
 401     dba = options['dba']
 402     if dba goto have_dba
 403     $P0 = getinterp
 404     $P0 = $P0['sub'; 1]
 405     dba = $P0
 406   have_dba:
 407     .local string message
 408     message = concat "Unable to parse ", dba
 409     message .= ", couldn't find final "
 410     message .= goal
 411     die message
 412 .end
 413
 414 =back
 415
 416 =head2  Support subroutines
 417
 418 =over 4
 419
 420
 421 =item C<!fail>
 422
 423 Force a backtrack.  (Taken from A05.)
 424
 425 =cut
 426
 427 .sub "!fail" :anon
 428     .param pmc mob
 429     $P0 = get_hll_global ['PGE'], 'Match'
 430     .tailcall $P0.'new'(mob)
 431 .end
 432
 433
 434 =item C<!cclass(mob, cclass)>
 435
 436 Match according to character class C<cclass>.
 437
 438 =cut
 439
 440 .sub '!cclass' :anon
 441     .param pmc mob
 442     .param int cclass
 443
 444     .local string target
 445     $P0 = get_hll_global ['PGE'], 'Match'
 446     (mob, $I0, target) = $P0.'new'(mob)
 447     $I1 = is_cclass cclass, target, $I0
 448     unless $I1 goto end
 449     inc $I0
 450     mob.'to'($I0)
 451   end:
 452     .return (mob)
 453 .end
 454
 455 =item C<!literal(mob, literal)>
 456
 457 Match according to C<literal>.
 458
 459 =cut
 460
 461 .sub '!literal' :anon
 462     .param pmc mob
 463     .param string literal
 464     .local string target
 465     .local int pos
 466     $P0 = get_hll_global ['PGE'], 'Match'
 467     (mob, pos, target) = $P0.'new'(mob)
 468     $I0 = length literal
 469     $S0 = substr target, pos, $I0
 470     if $S0 != literal goto end
 471     pos += $I0
 472     mob.'to'(pos)
 473   end:
 474     .return (mob)
 475 .end
 476
 477 =back
 478
 479 =head1 AUTHOR
 480
 481 Patrick Michaud (pmichaud@pobox.com) is the author and maintainer.
 482 Patches and suggestions should be sent to the Perl 6 compiler list
 483 (perl6-compiler@perl.org).
 484
 485 =cut
 486
 487 # Local Variables:
 488 #   mode: pir
 489 #   fill-column: 100
 490 # End:
 491 # vim: expandtab shiftwidth=4 ft=pir: