languages/tcl/runtime/builtin/array.pir

   1 ###
   2 # [array]
   3
   4 .HLL 'Tcl', 'tcl_group'
   5 .namespace []
   6
   7 #
   8 # similar to but not exactly like [string]'s subcommand dispatch
   9 #   - we pass in a boolean (array or not), the array itself, and the name
  10 #   - we know we need an array name for *all* args, so we test for it here.
  11
  12 .sub '&array'
  13   .param pmc argv :slurpy
  14
  15   .local int argc
  16   argc = argv
  17
  18   if argc < 2 goto few_args  # subcommand *and* array name
  19
  20   .local string subcommand_name
  21   subcommand_name = shift argv
  22
  23   .local pmc options
  24   options = new 'ResizablePMCArray'
  25   options[0] = 'anymore'
  26   options[1] = 'donesearch'
  27   options[2] = 'exists'
  28   options[3] = 'get'
  29   options[4] = 'names'
  30   options[5] = 'nextelement'
  31   options[6] = 'set'
  32   options[7] = 'size'
  33   options[8] = 'startsearch'
  34   options[9] = 'statistics'
  35   options[10] = 'unset'
  36
  37   .local pmc select_option
  38   select_option  = get_root_global ['_tcl'], 'select_option'
  39   .local string canonical_subcommand
  40   canonical_subcommand = select_option(options, subcommand_name)
  41
  42   .local pmc subcommand_proc
  43   null subcommand_proc
  44
  45   subcommand_proc = get_root_global ['_tcl'; 'helpers'; 'array'], canonical_subcommand
  46   if null subcommand_proc goto bad_args
  47
  48   .local int is_array
  49   .local string array_name
  50   .local pmc the_array
  51
  52   array_name = shift argv
  53
  54   null the_array
  55
  56   .local pmc __find_var
  57   __find_var = get_root_global ['_tcl'], '__find_var'
  58   the_array  = __find_var(array_name)
  59
  60   if_null the_array, array_no
  61
  62   $I99 = does the_array, 'hash'
  63   if $I99==0 goto array_no
  64
  65   is_array = 1
  66   goto scommand
  67
  68 array_no:
  69   is_array = 0
  70
  71 scommand:
  72   .return subcommand_proc(is_array,the_array,array_name,argv)
  73
  74 bad_args:
  75   .return ('') # once all commands are implemented, remove this...
  76
  77 few_args:
  78   tcl_error 'wrong # args: should be "array option arrayName ?arg ...?"'
  79
  80 .end
  81
  82 .HLL '_Tcl', ''
  83
  84 .namespace [ 'helpers' ; 'array' ]
  85
  86 .sub 'exists'
  87   .param int is_array
  88   .param pmc the_array
  89   .param string array_name
  90   .param pmc argv
  91
  92   .local int argc
  93   argc = argv
  94   if argc goto bad_args
  95
  96   .return (is_array)
  97
  98 bad_args:
  99   tcl_error 'wrong # args: should be "array exists arrayName"'
 100 .end
 101
 102 .sub 'size'
 103   .param int is_array
 104   .param pmc the_array
 105   .param string array_name
 106   .param pmc argv
 107
 108   .local int argc
 109   argc = argv
 110   if argc goto bad_args
 111
 112   if is_array == 0 goto size_none
 113   $I0 = the_array
 114   .return ($I0)
 115
 116 size_none:
 117   .return (0)
 118
 119 bad_args:
 120   tcl_error 'wrong # args: should be "array size arrayName"'
 121 .end
 122
 123 .sub 'set'
 124   .param int is_array
 125   .param pmc the_array
 126   .param string array_name
 127   .param pmc argv
 128
 129   .local int argc
 130   argc = argv
 131   if argc != 1 goto bad_args
 132
 133   .local pmc elems
 134   elems = argv[0]
 135
 136   .local pmc __list
 137   __list = get_root_global ['_tcl'], '__list'
 138   elems  = __list(elems)
 139
 140 pre_loop:
 141   .local int count
 142   count = elems
 143   $I0 = count % 2
 144   if $I0 == 1 goto odd_args
 145
 146   # pull out all the key/value pairs and set them.
 147   .local int loop
 148   loop = 0
 149   .local string key
 150   .local pmc    val
 151
 152   .local pmc set
 153   set = get_root_global ['_tcl'], '__set'
 154
 155   if_null the_array, new_array # create a new array if no var
 156   goto set_loop
 157
 158 new_array:
 159   the_array = new 'TclArray'
 160   set(array_name,the_array) # create an empty named array...
 161
 162 set_loop:
 163   if loop >= count goto done
 164   key = elems[loop]
 165   inc loop
 166   val = elems[loop]
 167   inc loop
 168
 169   # Do this just as if were were calling each set manually, as tcl's
 170   # error messages indicate it seems to.
 171
 172   # equals creates an alias, so use assign.
 173   .local string subvar
 174   subvar = '' # why is this necessary, if we're doing an assign ???
 175   assign subvar, array_name
 176   subvar .= '('
 177   subvar .= key
 178   subvar .= ')'
 179   set(subvar, val)
 180
 181   goto set_loop
 182
 183 done:
 184   .return ('')
 185
 186 bad_args:
 187   tcl_error 'wrong # args: should be "array set arrayName list"'
 188
 189 odd_args:
 190   tcl_error 'list must have an even number of elements'
 191 .end
 192
 193
 194 .include 'iterator.pasm'
 195 .sub 'get'
 196   .param int is_array
 197   .param pmc the_array
 198   .param string array_name
 199   .param pmc argv
 200
 201   .local int argc
 202   argc = argv
 203   if argc > 1 goto bad_args
 204
 205   .local string match_str
 206   # ?pattern? defaults to matching everything.
 207   match_str = '*'
 208
 209   # if it's there, get it from the arglist
 210   if argc == 0 goto no_args
 211   match_str = shift argv
 212
 213 no_args:
 214   if is_array == 0 goto not_array
 215
 216   .local pmc retval
 217
 218   .local pmc iter, val
 219   .local string str
 220
 221   .local pmc globber
 222   globber = compreg 'Tcl::Glob'
 223   .local pmc rule
 224   rule = globber.'compile'(match_str)
 225
 226   iter = new 'Iterator', the_array
 227
 228   retval = new 'TclList'
 229
 230   .local int count
 231   count = 0
 232
 233 push_loop:
 234   unless iter goto push_end
 235   str = shift iter
 236
 237   # check for match
 238   $P2 = rule(str)
 239   unless $P2 goto push_loop
 240
 241   inc count
 242   push retval, str
 243   val = the_array[str]
 244   val = clone val
 245   push retval, val
 246
 247   branch push_loop
 248
 249 push_end:
 250   .return(retval)
 251
 252 bad_args:
 253   tcl_error 'wrong # args: should be "array get arrayName ?pattern?"'
 254
 255 not_array:
 256   .return ('')
 257 .end
 258
 259 .sub 'unset'
 260   .param int is_array
 261   .param pmc the_array
 262   .param string array_name
 263   .param pmc argv
 264
 265   .local int argc
 266   argc = argv
 267   if argc > 1 goto bad_args
 268
 269
 270   .local string match_str
 271   # ?pattern? defaults to matching everything.
 272   match_str = '*'
 273
 274   # if it's there, get it from the arglist
 275   if argc == 0 goto no_args
 276   match_str = shift argv
 277
 278 no_args:
 279   if is_array == 0 goto not_array
 280
 281   .local pmc retval
 282
 283   .local pmc iter, val
 284   .local string str
 285
 286   .local pmc globber
 287   globber = compreg 'Tcl::Glob'
 288   .local pmc rule
 289   (rule, $P0, $P1) = globber.'compile'(match_str)
 290
 291   iter = new 'Iterator', the_array
 292
 293 push_loop:
 294   unless iter goto push_end
 295   str = shift iter
 296
 297  # check for match
 298   $P2 = rule(str)
 299   unless $P2 goto push_loop
 300
 301   delete the_array[str]
 302
 303   branch push_loop
 304 push_end:
 305   .return ('')
 306
 307
 308 bad_args:
 309    tcl_error 'wrong # args: should be "array unset arrayName ?pattern?"'
 310
 311 not_array:
 312    .return ('')
 313 .end
 314
 315 .sub 'names'
 316   .param int is_array
 317   .param pmc the_array
 318   .param string array_name
 319   .param pmc argv
 320
 321   .local pmc retval
 322
 323   .local int argc
 324   argc = argv
 325   if argc > 2 goto bad_args
 326
 327   .local string mode, pattern
 328   mode = '-glob'
 329   pattern = '*'
 330   if argc == 0 goto skip_args
 331   if argc == 1 goto skip_mode
 332
 333   mode = shift argv
 334 skip_mode:
 335   pattern = shift argv
 336 skip_args:
 337
 338   .local pmc match_proc
 339   null match_proc
 340
 341   match_proc = get_hll_global [ 'helpers'; 'array'; 'names_helper' ], mode
 342   if null match_proc goto bad_mode
 343
 344   if is_array == 0 goto not_array
 345
 346   .return match_proc(the_array, pattern)
 347
 348 bad_args:
 349   tcl_error 'wrong # args: should be "array names arrayName ?mode? ?pattern?"'
 350
 351 bad_mode:
 352   $S0 = 'bad option "'
 353   $S0 .= mode
 354   $S0 .= '": must be -exact, -glob, or -regexp'
 355   tcl_error $S0
 356
 357 not_array:
 358   tcl_error '' # is this right? -Coke
 359 .end
 360
 361 .namespace [ 'helpers' ; 'array'; 'names_helper' ]
 362
 363 .sub '-glob'
 364   .param pmc the_array
 365   .param string pattern
 366
 367   .local pmc iter
 368   .local string name
 369
 370   .local pmc globber, retval
 371   globber = compreg 'Tcl::Glob'
 372   .local pmc rule
 373   rule = globber.'compile'(pattern)
 374
 375   iter = new 'Iterator', the_array
 376
 377   retval = new 'TclList'
 378
 379   .local int count
 380   count = 0
 381
 382 check_loop:
 383   unless iter goto check_end
 384   name = shift iter
 385   $P0 = rule(name)
 386   unless $P0 goto check_loop
 387
 388   inc count
 389   push retval, name
 390
 391   branch check_loop
 392 check_end:
 393
 394   .return (retval)
 395 .end
 396
 397 .sub '-exact'
 398   .param pmc the_array
 399   .param string match
 400
 401   .local pmc iter, retval
 402   .local string name
 403
 404   iter = new 'Iterator', the_array
 405
 406   retval = new 'String'
 407   retval = ''
 408
 409 check_loop:
 410   unless iter goto check_end
 411   name = shift iter
 412
 413   if name == match goto found_match
 414   branch check_loop
 415 check_end:
 416   .return (retval)
 417
 418 found_match:
 419   retval = name
 420   .return (retval)
 421 .end
 422
 423 .sub '-regexp'
 424   .param pmc the_array
 425   .param string pattern
 426
 427   .local pmc iter
 428   .local string name
 429
 430   .local pmc tclARE, retval
 431   tclARE = compreg 'PGE::P5Regex'
 432   .local pmc rule
 433   rule = tclARE(pattern)
 434
 435   iter = new 'Iterator', the_array
 436
 437   retval = new 'TclList'
 438
 439   .local int count
 440   count = 0
 441
 442 check_loop:
 443   unless iter goto check_end
 444   name = shift iter
 445   $P0 = rule(name)
 446   unless $P0 goto check_loop
 447
 448   inc count
 449   push retval, name
 450
 451   branch check_loop
 452 check_end:
 453
 454   .return (retval)
 455 .end
 456
 457 # Local Variables:
 458 #   mode: pir
 459 #   fill-column: 100
 460 # End:
 461 # vim: expandtab shiftwidth=4 ft=pir: