languages/tcl/runtime/builtin/dict.pir

   1 ###
   2 # [dict]
   3
   4 .HLL 'Tcl', 'tcl_group'
   5 .namespace []
   6
   7 .sub '&dict'
   8   .param pmc argv :slurpy
   9
  10   .local pmc retval
  11
  12   $I3 = argv
  13   unless $I3 goto no_args
  14
  15   .local string subcommand_name
  16   subcommand_name = shift argv
  17
  18   .local pmc options
  19   options = new 'ResizablePMCArray'
  20   options[0] = 'append'
  21   options[1] = 'create'
  22   options[2] = 'exists'
  23   options[3] = 'filter'
  24   options[4] = 'for'
  25   options[5] = 'get'
  26   options[6] = 'incr'
  27   options[7] = 'info'
  28   options[8] = 'keys'
  29   options[9] = 'lappend'
  30   options[10] = 'merge'
  31   options[11] = 'remove'
  32   options[12] = 'replace'
  33   options[13] = 'set'
  34   options[14] = 'size'
  35   options[15] = 'unset'
  36   options[16] = 'update'
  37   options[17] = 'values'
  38   options[18] = 'with'
  39
  40   .local pmc select_option
  41   select_option  = get_root_global ['_tcl'], 'select_option'
  42   .local string canonical_subcommand
  43   canonical_subcommand = select_option(options, subcommand_name, 'subcommand')
  44
  45   .local pmc subcommand_proc
  46   null subcommand_proc
  47
  48   subcommand_proc = get_root_global ['_tcl'; 'helpers'; 'dict'], canonical_subcommand
  49   if_null subcommand_proc, bad_args
  50   .return subcommand_proc(argv)
  51
  52 bad_args:
  53   .return ('') # once all commands are implemented, remove this...
  54
  55 no_args:
  56   tcl_error 'wrong # args: should be "dict subcommand ?arg ...?"'
  57
  58 .end
  59
  60 .HLL '_Tcl', ''
  61
  62 .namespace [ 'helpers'; 'dict' ]
  63
  64 .sub 'append'
  65   .param pmc argv
  66
  67   .local int argc
  68   argc = elements argv
  69   if argc < 2 goto bad_args
  70
  71   .local pmc read, set
  72   read = get_root_global ['_tcl'], '__read'
  73   set  = get_root_global ['_tcl'], '__set'
  74
  75   .local pmc dictionary, dict_name
  76   dict_name = shift argv
  77   push_eh dict_error
  78     dictionary = read(dict_name)
  79   pop_eh
  80   dictionary = __dict(dictionary)
  81   goto got_dict
  82
  83 dict_error:
  84   get_results '0,0', $P0, $S0
  85   $I0 = index $S0, 'variable is array'
  86   if $I0 != -1 goto cant_dict_array
  87   dictionary = new 'TclDict'
  88
  89 got_dict:
  90   .local pmc key, value
  91   key = shift argv
  92
  93   # argv now contains all the new elements to append.
  94
  95   $I0 = exists dictionary[key]
  96   if $I0 goto vivified
  97   value = new 'TclString'
  98   value = ''
  99   goto loop
 100
 101 vivified:
 102   value = dictionary[key]
 103
 104 loop:
 105   argc = elements argv
 106   unless argc goto loop_done
 107   $S1 = shift argv
 108   $S2 = value
 109   $S2 .= $S1
 110   .local pmc stringy
 111   stringy = new 'String'
 112   stringy = $S2
 113   copy value, stringy
 114   goto loop
 115 loop_done:
 116
 117   dictionary[key] = value
 118   set(dict_name, dictionary)
 119   .return (dictionary)
 120
 121 cant_dict_array:
 122   $S1 = dict_name
 123   $S1 = "can't set \"" . $S1
 124   $S1 .= '": variable is array'
 125   tcl_error $S1
 126
 127 bad_args:
 128   tcl_error 'wrong # args: should be "dict append varName key ?value ...?"'
 129 .end
 130
 131
 132 .sub 'create'
 133   .param pmc argv
 134
 135   $I2 = elements argv
 136   $I3 = $I2 % 2
 137   if $I3 goto bad_args
 138
 139   .local pmc retval
 140   retval = new 'TclDict'
 141
 142   .local pmc key,value
 143
 144 loop:
 145   $I1 = elements argv
 146   unless $I1 goto loop_done
 147   key = shift argv
 148   value = shift argv
 149   retval[key] = value
 150   goto loop
 151
 152 loop_done:
 153   .return (retval)
 154
 155 bad_args:
 156   tcl_error 'wrong # args: should be "dict create ?key value ...?"'
 157
 158 .end
 159
 160 .sub 'exists'
 161   .param pmc argv
 162
 163   .local int argc
 164   argc = elements argv
 165   if argc < 2 goto bad_args
 166
 167   .local pmc dictionary
 168   dictionary = shift argv
 169   dictionary = __dict(dictionary)
 170
 171   .local pmc key
 172 loop:
 173   argc = elements argv
 174   unless argc goto loop_done
 175   key = shift argv
 176   dictionary = dictionary[key]
 177   if_null dictionary, not_exist
 178   goto loop
 179
 180 loop_done:
 181   .return (1)
 182
 183 not_exist:
 184   .return (0)
 185
 186 bad_args:
 187   tcl_error 'wrong # args: should be "dict exists dictionary key ?key ...?"'
 188
 189 .end
 190
 191 .sub 'filter'
 192   .param pmc argv
 193
 194   .local int argc
 195   argc = elements argv
 196   if argc < 2 goto bad_args
 197
 198   .local pmc dictionary
 199   dictionary = shift argv
 200   dictionary = __dict(dictionary)
 201
 202   .local pmc options
 203   options = new 'TclList'
 204   options[0] = 'key'
 205   options[1] = 'script'
 206   options[2] = 'value'
 207
 208   .local pmc select_option, __script, __boolean
 209   select_option  = get_root_global ['_tcl'], 'select_option'
 210   __script  = get_root_global ['_tcl'], '__script'
 211   __boolean  = get_root_global ['_tcl'], '__boolean'
 212   .local pmc option
 213   option = shift argv
 214   option = select_option(options, option, 'filterType')
 215
 216   .local pmc results, key, value
 217   results = new 'TclDict'
 218
 219   if option == 'script' goto do_script_prelude
 220
 221   .local pmc globber, pattern
 222   globber = compreg 'Tcl::Glob'
 223   if argc != 3 goto missing_glob
 224   pattern = shift argv
 225
 226   .local pmc rule, match, iterator
 227   rule = globber.'compile'(pattern)
 228   iterator = new 'Iterator', dictionary
 229
 230   if option == 'key' goto do_key_loop
 231
 232 do_value_loop:
 233   unless iterator goto do_value_done
 234   key = shift iterator
 235   value = dictionary[key]
 236   match = rule(value)
 237   unless match goto do_value_loop
 238   results[key] = value
 239   goto do_value_loop
 240 do_value_done:
 241   .return (results)
 242
 243 do_key_loop:
 244   unless iterator goto do_key_done
 245   key = shift iterator
 246   match = rule(key)
 247   unless match goto do_key_loop
 248   value = dictionary[key]
 249   results[key] = value
 250   goto do_key_loop
 251 do_key_done:
 252   .return (results)
 253
 254 do_script_prelude:
 255   argc = elements argv
 256   if argc != 2 goto bad_script_args
 257
 258   .local pmc vars, body
 259   vars = shift argv
 260   vars = __list(vars)
 261   $I0 = elements vars
 262   if $I0 != 2 goto bad_list_size
 263
 264   body = shift argv
 265   .local string keyVar,valueVar
 266   keyVar   = vars[0]
 267   valueVar = vars[1]
 268
 269   .local pmc iterator
 270   iterator = new 'Iterator', dictionary
 271   .local pmc retval
 272   retval = new 'TclDict'
 273   .local pmc body_proc
 274   body_proc = __script(body)
 275
 276   .local pmc check_key,check_value
 277 script_loop:
 278   unless iterator goto end_script_loop
 279   check_key = shift iterator
 280   __set(keyVar,check_key)
 281   check_value = dictionary[check_key]
 282   __set(valueVar,check_value)
 283   push_eh body_handler
 284     $P1 = body_proc()
 285   pop_eh
 286   $P1 = __boolean($P1)
 287   unless $P1 goto script_loop
 288   retval[check_key] = check_value
 289   goto script_loop
 290 end_script_loop:
 291   .return (retval)
 292
 293 body_handler:
 294   .catch()
 295   .get_return_code($I0)
 296   if $I0 == .CONTROL_CONTINUE goto script_loop
 297   if $I0 == .CONTROL_BREAK goto end_script_loop
 298   .rethrow()
 299
 300 bad_script_args:
 301   tcl_error 'wrong # args: should be "dict filter dictionary script {keyVar valueVar} filterScript"'
 302
 303 bad_list_size:
 304   tcl_error 'must have exactly two variable names'
 305
 306 missing_glob:
 307   $S1 = option
 308   $S1 = 'wrong # args: should be "dict filter dictionary ' . $S1
 309   $S1 .= ' globPattern"'
 310   tcl_error $S1
 311
 312 bad_args:
 313   tcl_error 'wrong # args: should be "dict filter dictionary filterType ..."'
 314 .end
 315
 316 .sub 'for'
 317   .param pmc argv
 318
 319   .local int argc
 320   argc = elements argv
 321   if argc != 3 goto bad_args
 322
 323   .local pmc set, script
 324   set     = get_root_global ['_tcl'], '__set'
 325   script  = get_root_global ['_tcl'], '__script'
 326
 327   .local pmc varNames
 328   .local string keyVar, valueVar
 329
 330   varNames = shift argv
 331   varNames = __list(varNames)
 332   $I0 = elements varNames
 333   if $I0 != 2 goto bad_list_size
 334   keyVar   = varNames[0]
 335   valueVar = varNames[1]
 336
 337   .local pmc dictionary
 338   dictionary = shift argv
 339   dictionary = __dict(dictionary)
 340
 341   .local pmc body,code
 342   body = shift argv
 343   code = __script(body)
 344
 345   .local pmc iterator
 346   iterator = new 'Iterator', dictionary
 347 for_loop:
 348   unless iterator goto for_loop_done
 349   $P1 = shift iterator
 350   __set(keyVar,   $P1)
 351   $S1 = $P1
 352   $P2 = dictionary[$S1]
 353   __set(valueVar, $P2)
 354
 355   push_eh loop_handler
 356     code()
 357   pop_eh
 358
 359   goto for_loop
 360
 361 loop_handler:
 362   .catch()
 363   .get_return_code($I0)
 364   if $I0 == .CONTROL_CONTINUE goto for_loop
 365   if $I0 == .CONTROL_BREAK goto for_loop_done
 366   .rethrow()
 367
 368 for_loop_done:
 369
 370   .return('')
 371
 372 bad_list_size:
 373   tcl_error 'must have exactly two variable names'
 374
 375 bad_args:
 376   tcl_error 'wrong # args: should be "dict for {keyVar valueVar} dictionary script"'
 377
 378 .end
 379
 380 .sub 'get'
 381   .param pmc argv
 382
 383   .local int argc
 384   argc = elements argv
 385   if argc < 1 goto bad_args
 386
 387   .local pmc dictionary
 388   dictionary = shift argv
 389   dictionary = __dict(dictionary)
 390   if argc < 0 goto loop_done
 391
 392   .local pmc key
 393 loop:
 394   argc = elements argv
 395   if argc <= 1 goto loop_done
 396   key = shift argv
 397   dictionary = dictionary[key]
 398   if_null dictionary, not_exist
 399   dictionary = __dict(dictionary) # might be a string, error out if so
 400   goto loop
 401
 402 loop_done:
 403   if argc == 0 goto done
 404   key = shift argv
 405   dictionary = dictionary[key]
 406   if_null dictionary, not_exist
 407 done:
 408   .return (dictionary)
 409
 410 not_exist:
 411   $S1 = key
 412   $S1 = 'key "' . $S1
 413   $S1 .= '" not known in dictionary'
 414   tcl_error $S1
 415
 416 bad_args:
 417   tcl_error 'wrong # args: should be "dict get dictionary ?key key ...?"'
 418 .end
 419
 420 .sub 'incr'
 421   .param pmc argv
 422
 423   .local int argc
 424   argc = elements argv
 425   if argc < 2 goto bad_args
 426   if argc > 3 goto bad_args
 427
 428   .local pmc read, set
 429   read = get_root_global ['_tcl'], '__read'
 430   set  = get_root_global ['_tcl'], '__set'
 431
 432   .local pmc dictionary, dict_name
 433   dict_name = shift argv
 434   push_eh dict_error
 435     dictionary = read(dict_name)
 436   pop_eh
 437   dictionary = __dict(dictionary)
 438   goto got_dict
 439
 440 dict_error:
 441   get_results '0,0', $P0, $S0
 442   $I0 = index $S0, 'variable is array'
 443   if $I0 != -1 goto cant_dict_array
 444   dictionary = new 'TclDict'
 445
 446 got_dict:
 447   .local pmc key
 448   key = shift argv
 449
 450   .local pmc increment
 451   increment = new 'TclInt'
 452   increment = 1
 453
 454   if argc == 2 goto got_increment
 455   increment = shift argv
 456   increment = __integer (increment)
 457
 458   .local pmc value
 459
 460 got_increment:
 461   $I0 = exists dictionary[key]
 462   if $I0 goto vivified
 463   value = increment
 464   goto done
 465
 466 vivified:
 467   value = dictionary[key]
 468   value = __integer(value)
 469   value += increment
 470
 471 done:
 472   dictionary[key] = value
 473   set(dict_name, dictionary)
 474   $P1 = new 'TclList'
 475   $P1[0] = key
 476   $P1[1] = value
 477   .return ($P1)
 478
 479 cant_dict_array:
 480   $S1 = dict_name
 481   $S1 = "can't set \"" . $S1
 482   $S1 .= '": variable is array'
 483   tcl_error $S1
 484
 485 bad_args:
 486   tcl_error 'wrong # args: should be "dict incr varName key ?increment?"'
 487 .end
 488
 489
 490 # This is a stub, doesn't actually generate the info.
 491 # it's exposing the guts of the interface, not sure how if it's appropriate
 492 # to do this in partcl.
 493 .sub 'info'
 494   .param pmc argv
 495
 496   .local int argc
 497   argc = elements argv
 498   if argc != 1 goto bad_args
 499
 500   .local pmc dictionary
 501   dictionary = shift argv
 502   dictionary = __dict(dictionary)
 503
 504   .return (dictionary)
 505
 506 bad_args:
 507   tcl_error 'wrong # args: should be "dict info dictionary"'
 508
 509 .end
 510
 511 .sub 'lappend'
 512   .param pmc argv
 513
 514   .local int argc
 515   argc = elements argv
 516   if argc < 2 goto bad_args
 517
 518   .local pmc read, set
 519   read = get_root_global ['_tcl'], '__read'
 520   set  = get_root_global ['_tcl'], '__set'
 521
 522   .local pmc dictionary, dict_name
 523   dict_name = shift argv
 524   push_eh dict_error
 525     dictionary = read(dict_name)
 526   pop_eh
 527   dictionary = __dict(dictionary)
 528   goto got_dict
 529
 530 dict_error:
 531   get_results '0,0', $P0, $S0
 532   $I0 = index $S0, 'variable is array'
 533   if $I0 != -1 goto cant_dict_array
 534   dictionary = new 'TclDict'
 535
 536 got_dict:
 537   .local pmc key, value
 538   key = shift argv
 539
 540   # argv now contains all the new list elements to lappend.
 541
 542   $I0 = exists dictionary[key]
 543   if $I0 goto vivified
 544   value = new 'TclList'
 545   goto loop
 546
 547 vivified:
 548   value = dictionary[key]
 549   value = __list(value)
 550
 551 loop:
 552   argc = elements argv
 553   unless argc goto loop_done
 554   $P1 = shift argv
 555   push value, $P1
 556   goto loop
 557 loop_done:
 558
 559   dictionary[key] = value
 560   set(dict_name, dictionary)
 561   .return (dictionary)
 562
 563 cant_dict_array:
 564   $S1 = dict_name
 565   $S1 = "can't set \"" . $S1
 566   $S1 .= '": variable is array'
 567   tcl_error $S1
 568
 569 bad_args:
 570   tcl_error 'wrong # args: should be "dict lappend varName key ?value ...?"'
 571 .end
 572
 573 .sub 'keys'
 574   .param pmc argv
 575
 576   .local int argc
 577   argc = elements argv
 578   if argc < 1 goto bad_args
 579   if argc > 2 goto bad_args
 580
 581   .local pmc dictionary
 582   dictionary = shift argv
 583   dictionary = __dict(dictionary)
 584
 585   .local string pattern
 586   pattern = '*'
 587   if argc == 1 goto got_pattern
 588   pattern = shift argv
 589
 590 got_pattern:
 591   .local pmc globber
 592   globber = compreg 'Tcl::Glob'
 593
 594   .local pmc rule, match
 595   rule = globber.'compile'(pattern)
 596
 597   .local pmc iterator
 598   iterator = new 'Iterator', dictionary
 599
 600   .local pmc results, key
 601   results = new 'TclList'
 602 loop:
 603   unless iterator goto loop_done
 604   key = shift iterator
 605   match = rule(key)
 606   unless match goto loop
 607   push results, key
 608   goto loop
 609
 610 loop_done:
 611   .return (results)
 612
 613 bad_args:
 614   tcl_error 'wrong # args: should be "dict keys dictionary ?pattern?"'
 615 .end
 616
 617
 618 .sub 'merge'
 619   .param pmc argv
 620
 621   .local int argc
 622   argc = elements argv
 623   if argc == 0 goto nothing
 624
 625   .local pmc retval
 626   $P1 = argv[0]
 627   retval = clone $P1
 628   retval = __dict(retval)
 629   if argc == 1 goto done
 630   $P2 =  shift argv # discard
 631
 632   .local pmc dictionary,key,value,iterator
 633
 634 dict_loop:
 635   $I1 = elements argv
 636   unless $I1 goto done
 637   dictionary = shift argv
 638   dictionary = __dict(dictionary)
 639   iterator = new 'Iterator', dictionary
 640 key_loop:
 641   unless iterator goto dict_loop
 642   key = shift iterator
 643   value = dictionary[key]
 644   retval[key] = value
 645   goto key_loop
 646
 647 done:
 648   .return (retval)
 649 nothing:
 650   .return ('')
 651
 652 .end
 653
 654 .sub 'remove'
 655   .param pmc argv
 656
 657   .local int argc
 658   argc = elements argv
 659   if argc < 1  goto bad_args
 660
 661   .local pmc dictionary
 662   dictionary = shift argv
 663   dictionary = __dict(dictionary)
 664   dictionary = clone dictionary
 665
 666   .local pmc key, value
 667 loop:
 668   argc = elements argv
 669   unless argc goto loop_done
 670   key   = shift argv
 671   delete dictionary[key]
 672   goto loop
 673
 674 loop_done:
 675   .return (dictionary)
 676
 677 bad_args:
 678   tcl_error 'wrong # args: should be "dict remove dictionary ?key ...?"'
 679 .end
 680
 681
 682 .sub 'replace'
 683   .param pmc argv
 684
 685   .local int argc
 686   argc = elements argv
 687   if argc < 1  goto bad_args
 688   if argc == 2 goto bad_args
 689
 690   .local pmc dictionary
 691   dictionary = shift argv
 692   dictionary = __dict(dictionary)
 693   dictionary = clone dictionary
 694
 695   if argc < 0 goto loop_done
 696   $I0 = mod argc, 2
 697   if $I0 == 0 goto odd_args # we shifted the dict off, above...
 698
 699   .local pmc key, value
 700 loop:
 701   argc = elements argv
 702   unless argc goto loop_done
 703   key   = shift argv
 704   value = shift argv
 705   dictionary[key] = value
 706   goto loop
 707
 708 loop_done:
 709   .return (dictionary)
 710
 711 odd_args:
 712   tcl_error 'missing value to go with key'
 713
 714 bad_args:
 715   tcl_error 'wrong # args: should be "dict replace dictionary ?key value ...?"'
 716 .end
 717
 718 .sub 'set'
 719   .param pmc argv
 720
 721   .local int argc
 722   argc = elements argv
 723   if argc < 3 goto bad_args
 724
 725   .local pmc read, set
 726   read = get_root_global ['_tcl'], '__read'
 727   set  = get_root_global ['_tcl'], '__set'
 728
 729   .local pmc dictionary, dict_name
 730   dict_name = shift argv
 731   push_eh dict_error
 732     dictionary = read(dict_name)
 733   pop_eh
 734   dictionary = __dict(dictionary)
 735   goto got_dict
 736
 737 dict_error:
 738   get_results '0,0', $P0, $S0
 739   $I0 = index $S0, 'variable is array'
 740   if $I0 != -1 goto cant_dict_array
 741   dictionary = new 'TclDict'
 742
 743 got_dict:
 744   .local pmc value
 745   value = pop argv
 746
 747   .local pmc key, sub_dict
 748   sub_dict = dictionary
 749 loop:
 750   argc = elements argv
 751   if argc <= 1 goto loop_done
 752   key = shift argv
 753   $P1= sub_dict[key]
 754   # Does this key exist? set it.
 755   if null $P1 goto new_key
 756   sub_dict = $P1
 757   goto loop
 758 new_key:
 759   $P1 = new 'TclDict'
 760   sub_dict[key] = $P1
 761   sub_dict = $P1
 762   goto loop
 763 loop_done:
 764   key = shift argv # should be the last one..
 765   sub_dict[key] = value
 766
 767   set(dict_name, dictionary)
 768   .return (dictionary)
 769
 770 cant_dict_array:
 771   $S1 = dict_name
 772   $S1 = "can't set \"" . $S1
 773   $S1 .= '": variable is array'
 774   tcl_error $S1
 775
 776 bad_args:
 777   tcl_error 'wrong # args: should be "dict set varName key ?key ...? value"'
 778 .end
 779
 780 .sub 'size'
 781   .param pmc argv
 782
 783   .local int argc
 784   argc = elements argv
 785   if argc !=1 goto bad_args
 786
 787   .local pmc dictionary
 788   dictionary = shift argv
 789   dictionary = __dict(dictionary)
 790
 791   .local int size
 792   size = elements dictionary
 793   .return (size)
 794
 795 bad_args:
 796   tcl_error 'wrong # args: should be "dict size dictionary"'
 797
 798 .end
 799
 800 .sub 'unset'
 801   .param pmc argv
 802
 803   .local int argc
 804   argc = elements argv
 805   if argc < 2 goto bad_args
 806
 807   .local pmc read, set
 808   read = get_root_global ['_tcl'], '__read'
 809   set  = get_root_global ['_tcl'], '__set'
 810
 811   .local pmc dictionary, dict_name
 812   dict_name = shift argv
 813   push_eh dict_error
 814     dictionary = read(dict_name)
 815   pop_eh
 816   dictionary = __dict(dictionary)
 817   goto got_dict
 818
 819 dict_error:
 820   get_results '0,0', $P0, $S0
 821   $I0 = index $S0, 'variable is array'
 822   if $I0 != -1 goto cant_dict_array
 823   dictionary = new 'TclDict'
 824   set(dict_name, dictionary)
 825
 826 got_dict:
 827
 828   .local pmc key, sub_dict
 829   sub_dict = dictionary
 830 loop:
 831   argc = elements argv
 832   if argc <=1 goto loop_done
 833   key = shift argv
 834   sub_dict = sub_dict[key]
 835   if null sub_dict goto not_exist
 836   goto loop
 837 loop_done:
 838   key = shift argv # should be the last one..
 839   delete sub_dict[key]
 840
 841   .return (dictionary)
 842
 843 not_exist:
 844   $S1 = key
 845   $S1 = 'key "' . $S1
 846   $S1 .= '" not known in dictionary'
 847   tcl_error $S1
 848
 849 cant_dict_array:
 850   $S1 = dict_name
 851   $S1 = "can't set \"" . $S1
 852   $S1 .= '": variable is array'
 853   tcl_error $S1
 854
 855 bad_args:
 856   tcl_error 'wrong # args: should be "dict unset varName key ?key ...?"'
 857 .end
 858
 859 .sub 'update'
 860   .param pmc argv
 861
 862   .local int argc
 863   argc = elements argv
 864   if argc < 4 goto bad_args
 865   $I0 = argc % 2
 866   if $I0 goto bad_args
 867
 868   .local pmc read, set
 869   read = get_root_global ['_tcl'], '__read'
 870   set  = get_root_global ['_tcl'], '__set'
 871
 872   .local pmc dictionary, dict_name
 873   dict_name = shift argv
 874   push_eh dict_error
 875     dictionary = read(dict_name)
 876   pop_eh
 877   dictionary = __dict(dictionary)
 878   goto got_dict
 879
 880 dict_error:
 881   get_results '0,0', $P0, $S0
 882   $I0 = index $S0, 'variable is array'
 883   if $I0 != -1 goto cant_dict_array
 884   dictionary = new 'TclDict'
 885
 886 got_dict:
 887   .local pmc body
 888   body = pop argv
 889
 890   .local pmc keys,varnames
 891   keys = new 'ResizablePMCArray'
 892   varnames = new 'ResizablePMCArray'
 893   # get lists of both keys & varnames, setting the variables.
 894 key_loop:
 895   $I0 = elements argv
 896   unless $I0 goto done_key_loop
 897   $P1 = shift argv
 898   push keys, $P1
 899   $P2 = shift argv
 900   push varnames, $P2
 901   $P3 = dictionary[$P1]
 902   __set($P2, $P3)
 903   goto key_loop
 904 done_key_loop:
 905 # run the body of the script. save the return vaalue.
 906   .local pmc retval
 907   $P1 = __script(body)
 908   retval = $P1()
 909
 910 # go through the varnames, setting the appropriate keys to those values.
 911   .local pmc iter1,iter2
 912   iter1 = new 'Iterator', keys
 913   iter2 = new 'Iterator', varnames
 914 set_loop:
 915   unless iter1 goto set_loop_done
 916   $P1 = shift iter1
 917   $P2 = shift iter2
 918   $P3 = __read($P2)
 919   dictionary[$P1] = $P3
 920   goto set_loop
 921 set_loop_done:
 922
 923 done:
 924   .return (retval)
 925
 926 cant_dict_array:
 927   $S1 = dict_name
 928   $S1 = "can't set \"" . $S1
 929   $S1 .= '": variable is array'
 930   tcl_error $S1
 931
 932 bad_args:
 933   tcl_error 'wrong # args: should be "dict update varName key varName ?key varName ...? script"'
 934
 935 .end
 936
 937
 938 .sub 'values'
 939   .param pmc argv
 940
 941   .local int argc
 942   argc = elements argv
 943   if argc < 1 goto bad_args
 944   if argc > 2 goto bad_args
 945
 946   .local pmc dictionary
 947   dictionary = shift argv
 948   dictionary = __dict(dictionary)
 949
 950   .local string pattern
 951   pattern = '*'
 952   if argc == 1 goto got_pattern
 953   pattern = shift argv
 954
 955 got_pattern:
 956   .local pmc globber
 957   globber = compreg 'Tcl::Glob'
 958
 959   .local pmc rule, match
 960   rule = globber.'compile'(pattern)
 961
 962   .local pmc iterator
 963   iterator = new 'Iterator', dictionary
 964
 965   .local pmc results, key, value
 966   results = new 'TclList'
 967 loop:
 968   unless iterator goto loop_done
 969   key = shift iterator
 970   value = dictionary[key]
 971   match = rule(value)
 972   unless match goto loop
 973   push results, value
 974   goto loop
 975
 976 loop_done:
 977   .return (results)
 978
 979 bad_args:
 980   tcl_error 'wrong # args: should be "dict values dictionary ?pattern?"'
 981 .end
 982
 983 .sub 'with'
 984   .param pmc argv
 985
 986   .local int argc
 987   argc = elements argv
 988   if argc ==0  goto bad_args
 989
 990   .local pmc read, set
 991   read = get_root_global ['_tcl'], '__read'
 992   set  = get_root_global ['_tcl'], '__set'
 993
 994   .local pmc dictionary, dict_name
 995   dict_name = shift argv
 996   push_eh dict_error
 997     dictionary = read(dict_name)
 998   pop_eh
 999   dictionary = __dict(dictionary)
1000   goto got_dict
1001
1002 dict_error:
1003   get_results '0,0', $P0, $S0
1004   $I0 = index $S0, 'variable is array'
1005   if $I0 != -1 goto cant_dict_array
1006   dictionary = new 'TclDict'
1007
1008 got_dict:
1009   .local pmc body
1010   body = pop argv
1011   # walk to point in hierarchy for keys..
1012
1013 while_keys:
1014   .local pmc key
1015   $I0 = elements argv
1016   unless $I0 goto done_keys
1017   key = shift argv
1018   dictionary=dictionary[key]
1019
1020 done_keys:
1021   .local pmc iterator
1022   iterator = new 'Iterator', dictionary
1023
1024 alias_keys:
1025   unless iterator goto done_alias
1026   $P1 = shift iterator
1027   $P2 = dictionary[$P1]
1028   __set($P1,$P2)
1029   goto alias_keys
1030 done_alias:
1031   .local pmc retval
1032   $P1 = __script(body)
1033   retval = $P1()
1034
1035   iterator = new 'Iterator', dictionary
1036 update_keys:
1037   unless iterator goto done_update
1038   $P1 = shift iterator
1039   $P2 = __read($P1)
1040   dictionary[$P1] = $P2
1041   goto update_keys
1042
1043 done_update:
1044   .return (retval)
1045
1046 cant_dict_array:
1047   $S1 = dict_name
1048   $S1 = "can't set \"" . $S1
1049   $S1 .= '": variable is array'
1050   tcl_error $S1
1051
1052 bad_args:
1053   tcl_error 'wrong # args: should be "dict with dictVar ?key ...? script"'
1054 .end
1055
1056
1057
1058 # Local Variables:
1059 #   mode: pir
1060 #   fill-column: 100
1061 # End:
1062 # vim: expandtab shiftwidth=4 ft=pir: