runtime/parrot/library/Tcl/Glob.pir

   1 =head1 TITLE
   2
   3 Tcl::Glob - Parse and compile glob notation expressions.
   4
   5 =head1 DESCRIPTION
   6
   7 A parser for Tcl-stype glob notation.
   8
   9 =head2 Functions
  10
  11 =over 4
  12
  13 =item C<compile_glob(PMC source, PMC adverbs :slurpy :named)>
  14
  15 Return the result of compiling the glob expression given by
  16 C<source>.   Normally this function is obtained using
  17 C<compreg 'Tcl::Glob'> instead of calling it directly.
  18
  19 Returns the compiled regular expression.  If a C<target>
  20 named parameter is supplied, then it will return the parse tree
  21 (target='parse'), the expression tree (target='exp'),
  22 or the resulting PIR code (target='PIR').
  23
  24 =cut
  25
  26 .namespace [ 'Tcl::Glob' ]
  27
  28 .sub 'compile_glob'
  29     .param pmc source
  30     .param pmc adverbs         :slurpy :named
  31
  32     .local string target
  33     target = adverbs['target']
  34     target = downcase target
  35
  36     .local pmc match
  37     null match
  38     if source == '' goto analyze
  39     $P0 = get_global 'glob'
  40     match = $P0(source)
  41     if target != 'parse' goto check
  42     .return (match)
  43
  44   check:
  45     unless match goto check_1
  46     $S0 = source
  47     $S1 = match
  48     if $S0 == $S1 goto analyze
  49   check_1:
  50     null $P0
  51     .return ($P0)
  52
  53   analyze:
  54     .local pmc exp, pad
  55     exp = new 'PGE::Exp::Concat'
  56     $I0 = 1
  57     $P0 = new 'PGE::Exp::Anchor'
  58     $P0.'result_object'('^')
  59     exp[0] = $P0
  60     if null match goto analyze_1
  61     $P0 = match['expr']
  62     exp[$I0] = $P0
  63     inc $I0
  64   analyze_1:
  65     $P0 = new 'PGE::Exp::Anchor'
  66     $P0.'result_object'('$')
  67     exp[$I0] = $P0
  68
  69     .return exp.'compile'(adverbs :flat :named)
  70 .end
  71
  72
  73 .sub 'main' :main
  74     .param pmc args
  75
  76     load_bytecode 'PGE.pbc'
  77
  78     $P0 = compreg 'Tcl::Glob'
  79     .return $P0.'command_line'(args)
  80 .end
  81
  82
  83 .sub '__onload' :load :init
  84     .local pmc optable
  85     load_bytecode 'PGE.pbc'
  86     load_bytecode 'PCT/HLLCompiler.pbc'
  87
  88     optable = new 'PGE::OPTable'
  89     store_global '$optable', optable
  90
  91     $P0 = find_global 'glob_literal'
  92     optable.newtok('term:', 'precedence'=>'=', 'nows'=>1, 'parsed'=>$P0)
  93
  94     $P0 = find_global 'glob_quest'
  95     optable.newtok('term:?', 'equiv'=>'term:', 'nows'=>1, 'parsed'=>$P0)
  96
  97     $P0 = find_global 'glob_star'
  98     optable.newtok('term:*', 'equiv'=>'term:', 'nows'=>1, 'parsed'=>$P0)
  99
 100     $P0 = find_global 'glob_enum'
 101     optable.newtok('term:[', 'equiv'=>'term:', 'nows'=>1, 'parsed'=>$P0)
 102
 103     optable.newtok('infix:', 'looser'=>'term:', 'assoc'=>'list', 'nows'=>1, 'match'=>'PGE::Exp::Concat')
 104
 105     $P2 = newclass [ 'Tcl::Glob::Compiler' ]
 106     addattribute $P2, '$!compsub'
 107
 108     $P0 = get_global 'compile_glob'
 109     $P1 = new [ 'Tcl::Glob::Compiler' ]
 110     $P1.'register'('Tcl::Glob', $P0)
 111
 112     .return ()
 113 .end
 114
 115
 116 =item C<glob(PMC mob, PMC adverbs :slurpy :named)>
 117
 118 Parses a glob expression, returning the corresponding
 119 parse C<PGE::Match> object.
 120
 121 =cut
 122
 123 .const int GLOB_INF = 2147483647
 124
 125 .sub 'glob'
 126     .param pmc mob
 127     .param pmc adverbs         :slurpy :named
 128
 129     .local pmc optable, match
 130     optable = find_global 'Tcl::Glob', '$optable'
 131     match = optable.'parse'(mob)
 132     .return (match)
 133 .end
 134
 135
 136 .sub 'scan_literal'
 137     .param string target
 138     .param int pos
 139     .param string delim
 140
 141     .local int lastpos
 142     lastpos = length target
 143     .local string literal
 144     literal = ''
 145   literal_loop:
 146     if pos >= lastpos goto literal_end
 147     $S0 = substr target, pos, 1
 148     $I0 = index delim, $S0
 149     if $I0 >= 0 goto literal_end
 150     if $S0 != '\' goto literal_add
 151     inc pos
 152     $S0 = substr target, pos, 1
 153   literal_add:
 154     literal .= $S0
 155     inc pos
 156     goto literal_loop
 157   literal_end:
 158     .return (literal, pos)
 159 .end
 160
 161
 162 =item C<glob_literal(PMC mob, PMC adverbs)>
 163
 164 Scan a literal from a string, stopping at any metacharacters such
 165 as C<*> or C<[>.  Return the matched portion, with the C<result_object>
 166 set to the decoded literal.
 167
 168 =cut
 169
 170 .sub 'glob_literal'
 171     .param pmc mob
 172     .param pmc adverbs         :slurpy :named
 173
 174     .local string target
 175     .local int pos
 176     (mob, pos, target) = mob.'new'(mob, 'grammar'=>'PGE::Exp::Literal')
 177     ($S0, $I0) = 'scan_literal'(target, pos, '*?[')
 178     if $I0 <= pos goto end
 179     mob.'to'($I0)
 180     mob.'result_object'($S0)
 181   end:
 182     .return (mob)
 183 .end
 184
 185
 186 =item C<glob_quest(PMC mob, PMC adverbs)>
 187
 188 Process a C<?> wildcard character in a glob.  For this we just
 189 return a CCShortcut that is set to '.'
 190
 191 =cut
 192
 193 .sub 'glob_quest'
 194     .param pmc mob
 195     .param pmc adverbs         :slurpy :named
 196     .local int pos
 197     ##   The '?' is already in mob['KEY'], so we don't need to find it here.
 198     (mob, pos) = mob.'new'(mob, 'grammar'=>'PGE::Exp::CCShortcut')
 199     mob.'to'(pos)
 200     mob.'result_object'('.')
 201     .return (mob)
 202 .end
 203
 204
 205 =item C<glob_star(PMC mob, PMC adverbs)>
 206
 207 Process a C<*> wildcard character in a glob.  This is a little
 208 bit more complex, as we have to return a quantified '.'.
 209
 210 =cut
 211
 212 .sub 'glob_star'
 213     .param pmc mob
 214     .param pmc adverbs         :slurpy :named
 215     .local int pos
 216     ##   The '*' is already in mob['KEY'], so we don't need to find it here.
 217     ##   We create a Quant object, then a CCShortcut inside of it.
 218     (mob, pos) = mob.'new'(mob, 'grammar'=>'PGE::Exp::Quant')
 219     mob.'to'(pos)
 220     mob['min'] = 0
 221     mob['max'] = GLOB_INF
 222     ($P0, $I0) = mob.'new'(mob, 'grammar'=>'PGE::Exp::CCShortcut')
 223     $P0.'to'($I0)
 224     $P0.'result_object'('.')
 225     mob[0] = $P0
 226     .return (mob)
 227 .end
 228
 229 =item C<glob_enum(PMC mob, PMC adverbs)>
 230
 231 Parse an enumerated character list, such as [abcd],
 232 [!abcd], and [^0-9].
 233
 234 =cut
 235
 236 .sub glob_enum
 237     .param pmc mob
 238     .param pmc adverbs         :slurpy :named
 239
 240     .local string target
 241     .local int pos, lastpos
 242     (mob, pos, target) = mob.'new'(mob, 'grammar'=>'PGE::Exp::EnumCharList')
 243     lastpos = length target
 244     $S0 = substr target, pos, 1
 245     mob['isnegated'] = 0
 246     goto firstchar
 247   firstchar:
 248     .local string charlist
 249     charlist = ''
 250     $S0 = substr target, pos, 1
 251     if $S0 == '-' goto addfirst
 252     if $S0 == ']' goto addfirst
 253     goto scan_loop
 254   addfirst:
 255     charlist .= $S0
 256     inc pos
 257   scan_loop:
 258     ($S0, pos) = 'scan_literal'(target, pos, '-]')
 259     if pos >= lastpos goto err_noclose
 260     charlist .= $S0
 261     $S0 = substr target, pos, 1
 262     if $S0 == ']' goto scan_end
 263     inc pos
 264     $S0 = substr target, pos, 1
 265     if $S0 == ']' goto scan_endhyphen
 266     inc pos
 267     $I1 = ord $S0
 268     $I0 = ord charlist, -1
 269   add_range:
 270     if $I0 > $I1 goto scan_loop
 271     $S1 = chr $I0
 272     charlist .= $S1
 273     inc $I0
 274     goto add_range
 275   scan_endhyphen:
 276     charlist .= '-'
 277   scan_end:
 278     inc pos
 279     mob.'to'(pos)
 280     mob.'result_object'(charlist)
 281     .return (mob)
 282
 283   err_noclose:
 284     mob.'to'(-1)
 285     .return (mob)
 286 .end
 287
 288 =item C<glob_alt(PMC mob, PMC adverbs)>
 289
 290 Parse an enumerated character list, such as [abcd],
 291 [!abcd], and [^0-9].
 292
 293 =cut
 294
 295 .sub glob_alt
 296     .param pmc mob
 297     .param pmc adverbs         :slurpy :named
 298
 299     .local string target
 300     .local int pos, lastpos
 301     (mob, pos, target) = mob.'new'(mob, 'grammar'=>'PGE::Exp::Literal')
 302     lastpos = length target
 303
 304     ($S0, pos) = 'scan_literal'(target, pos, ',}')
 305     mob.'result_object'($S0)
 306     mob.'to'(pos)
 307   alt_loop:
 308     if pos >= lastpos goto err_noclose
 309     $S0 = substr target, pos, 1
 310     if $S0 == '}' goto end
 311     $P0 = mob.'new'(mob, 'grammar'=>'PGE::Exp::Alt')
 312     inc pos
 313     $P0.'to'(pos)
 314     $P0[0] = mob
 315     mob = $P0
 316     $P0 = mob.'new'(mob, 'grammar'=>'PGE::Exp::Literal')
 317     ($S0, pos) = 'scan_literal'(target, pos, ',}')
 318     $P0.'to'(pos)
 319     $P0.'result_object'($S0)
 320     mob[1] = $P0
 321     goto alt_loop
 322   end:
 323     inc pos
 324     mob.'to'(pos)
 325     .return (mob)
 326
 327   err_noclose:
 328     mob.to(-1)
 329     .return (mob)
 330 .end
 331
 332 .namespace [ 'Tcl::Glob::Compiler' ]
 333
 334 =item register(string name, pmc compsub)
 335
 336 Registers this compiler object as C<name> and
 337 using C<compsub> as the subroutine to call for performing compilation.
 338
 339 =cut
 340
 341 .sub 'register' :method
 342     .param string name
 343     .param pmc compsub
 344
 345     setattribute self, '$!compsub', compsub
 346     compreg name, self
 347
 348     .return ()
 349 .end
 350
 351 =item compile(pmc code [, "option" => value, ... ])
 352
 353 Compile C<source> (possibly modified by any provided options).
 354
 355 =cut
 356
 357 .sub 'compile' :method
 358     .param pmc source
 359     .param pmc adverbs         :slurpy :named
 360
 361     .local pmc compsub
 362
 363     #   $!compsub is deprecated
 364     compsub = getattribute self, '$!compsub'
 365
 366     .return compsub(source, adverbs :flat :named)
 367 .end
 368
 369 =back
 370
 371 =head1 BUGS AND LIMITATIONS
 372
 373 This is basically a cut and paste of PGE::Glob. There should probably be
 374 much less code duplication here.
 375
 376 =head1 AUTHOR
 377
 378 PGE::Glob was originally authored by Jonathan Scott Duff (duff@pobox.com),
 379 It has been updated for later versions of PGE by Patrick R. Michaud
 380 (pmichaud@pobox.com).
 381
 382 =cut
 383
 384 # Local Variables:
 385 #   mode: pir
 386 #   fill-column: 100
 387 # End:
 388 # vim: expandtab shiftwidth=4 ft=pir: