languages/tcl/runtime/builtin/info.pir

   1 .HLL 'Tcl', ''
   2 .namespace []
   3
   4 .sub '&info'
   5   .param pmc argv :slurpy
   6
   7   .local int argc
   8   argc = elements argv
   9   unless argc goto bad_args
  10
  11   .local string subcommand_name
  12   subcommand_name = shift argv
  13
  14   .local pmc options
  15   options = get_root_global ['_tcl'; 'helpers'; 'info'], 'options'
  16
  17   .local pmc select_option
  18   select_option  = get_root_global ['_tcl'], 'select_option'
  19
  20   .local string canonical_subcommand
  21   canonical_subcommand = select_option(options, subcommand_name)
  22
  23   .local pmc subcommand_proc
  24   null subcommand_proc
  25
  26   subcommand_proc = get_root_global ['_tcl';'helpers';'info'], canonical_subcommand
  27   if null subcommand_proc goto bad_subcommand
  28
  29   .return subcommand_proc(argv)
  30
  31 bad_subcommand:
  32   .return ('') # once all commands are implemented, remove this...
  33
  34  bad_args:
  35   die 'wrong # args: should be "info subcommand ?argument ...?"'
  36 .end
  37
  38 .HLL '_Tcl', ''
  39 .namespace [ 'helpers'; 'info' ]
  40
  41 .sub 'args'
  42   .param pmc argv
  43
  44   .local int argc
  45   argc = elements argv
  46   if argc != 1 goto bad_args
  47
  48   .local pmc retval
  49
  50   .local string procname
  51   procname = shift argv
  52
  53   .local pmc splitNamespace
  54   splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
  55
  56   .local pmc    ns
  57   .local string name
  58   ns   = splitNamespace(procname)
  59   name = pop ns
  60   name = '&' . name
  61
  62   unshift ns, 'tcl'
  63   $P1 = get_root_global ns, name
  64   if null $P1 goto no_args
  65
  66   $P2 = getattribute $P1, 'args'
  67   if null $P2 goto no_args
  68   .return($P2)
  69
  70   .return($P2)
  71
  72 no_args:
  73   $S0 = '"'
  74   $S0 .= procname
  75   $S0 .= "\" isn't a procedure"
  76   die $S0
  77
  78 bad_args:
  79   die 'wrong # args: should be "info args procname"'
  80 .end
  81
  82 .sub 'body'
  83   .param pmc argv
  84
  85   .local int argc
  86   argc = elements argv
  87   if argc != 1 goto bad_args
  88
  89   .local string procname
  90   procname = argv[0]
  91
  92   .local pmc splitNamespace
  93   splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
  94
  95   .local pmc    ns
  96   .local string name
  97   ns   = splitNamespace(procname)
  98   name = pop ns
  99   name = '&' . name
 100
 101   unshift ns, 'tcl'
 102   $P1 = get_root_global ns, name
 103   if null $P1 goto no_body
 104   $P2 = getattribute $P1, 'HLL_source'
 105   if null $P2 goto no_body
 106   .return($P2)
 107
 108 no_body:
 109   $S0 = '"'
 110   $S0 .= procname
 111   $S0 .= "\" isn't a procedure"
 112   die $S0
 113
 114 bad_args:
 115   die 'wrong # args: should be "info body procname"'
 116 .end
 117
 118 .sub 'complete'
 119   .param pmc argv
 120   .local int argc
 121   argc = elements argv
 122   if argc != 1 goto bad_args
 123
 124   .local pmc body
 125   body = argv[0]
 126   push_eh nope
 127     $P1 = compileTcl(body)
 128   pop_eh
 129   .return(1)
 130
 131 nope:
 132   get_results '0,0', $P0, $S0
 133   if $S0 == 'missing close-brace'   goto fail
 134   if $S0 == 'missing close-bracket' goto fail
 135   if $S0 == 'missing "'             goto fail
 136   rethrow $P0
 137
 138 fail:
 139   .return(0)
 140
 141 bad_args:
 142   die 'wrong # args: should be "info complete command"'
 143 .end
 144
 145 .sub 'default'
 146   .param pmc argv
 147
 148   .local int argc
 149   argc = elements argv
 150   if argc != 3 goto bad_args
 151
 152   .local pmc retval
 153
 154   .local string procname, argname, varname
 155   procname = argv[0]
 156   argname  = argv[1]
 157   varname  = argv[2]
 158
 159   .local pmc setVar
 160   setVar = get_root_global ['_tcl'], 'setVar'
 161
 162   .local pmc splitNamespace
 163   splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
 164
 165   .local pmc    ns
 166   .local string name
 167   ns   = splitNamespace(procname)
 168   name = pop ns
 169   name = '&' . name
 170
 171   unshift ns, 'tcl'
 172   $P1 = get_root_global ns, name
 173   if null $P1 goto not_proc
 174
 175   $P2 = getattribute $P1, 'defaults'
 176   $P9 = getattribute $P1, 'args'
 177   if null $P2 goto check_arg
 178
 179   $P3 = $P2[argname]
 180   if_null $P3, check_arg
 181   push_eh error_on_set
 182     setVar(varname, $P3)
 183   pop_eh
 184
 185   # store in variable
 186   .return (1)
 187
 188 check_arg:
 189   # there's no default. is there even an arg?
 190   $P3 = toList($P9)
 191   $P4 = new 'Iterator', $P3
 192 loop:
 193   unless $P4 goto not_argument
 194   $S1 = shift $P4
 195   if $S1==argname goto no_default
 196   goto loop
 197
 198 not_argument:
 199   $S0 = 'procedure "'
 200   $S0 .= procname
 201   $S0 .= "\" doesn't have an argument \""
 202   $S0 .= argname
 203   $S0 .= '"'
 204   die $S0
 205
 206 no_default:
 207   push_eh error_on_set
 208     setVar(varname, '')
 209   pop_eh
 210   .return (0)
 211
 212 error_on_set:
 213   $S0 = "couldn't store default value in variable \""
 214   $S0 .= varname
 215   $S0 .= '"'
 216   die $S0
 217
 218 not_proc:
 219   $S0 = '"'
 220   $S0 .= procname
 221   $S0 .= "\" isn't a procedure"
 222   die $S0
 223
 224
 225 bad_args:
 226   die 'wrong # args: should be "info default procname arg varname"'
 227 .end
 228
 229
 230 .sub 'functions'
 231   .param pmc argv
 232
 233   .local int argc
 234   argc = elements argv
 235   if argc > 1 goto bad_args
 236
 237   .local pmc mathfunc,iterator,retval
 238
 239   mathfunc = get_root_namespace ['tcl'; 'tcl'; 'mathfunc']
 240   iterator = new 'Iterator', mathfunc
 241   iterator = 0
 242   retval = new 'TclList'
 243
 244   .local pmc globber,rule,match
 245   globber = compreg 'Tcl::Glob'
 246   if argc == 1 goto got_glob
 247   $S1 = '&*'
 248   goto compile
 249 got_glob:
 250   $S1 = argv[0]
 251   $S1 = '&' . $S1
 252 compile:
 253   rule = globber.'compile'($S1)
 254 loop:
 255   unless iterator goto end
 256   $S0 = shift iterator
 257   $P0 = mathfunc[$S0]
 258   match = rule($S0)
 259   unless match goto loop
 260   $S1 = substr $S0, 1
 261   push retval, $S1
 262   goto loop
 263 end:
 264   .return(retval)
 265
 266 bad_args:
 267   die 'wrong # args: should be "info functions ?pattern?"'
 268 .end
 269
 270 .sub 'commands'
 271     .param pmc argv
 272
 273     .local int argc
 274     argc = elements argv
 275     if argc > 1 goto bad_args
 276     .local pmc matching
 277     null matching
 278     if argc ==0 goto done_setup
 279
 280     $P1 = compreg 'Tcl::Glob'
 281     .local string pattern
 282     pattern = argv[0]
 283
 284     # cheat and just remove a leading "::" for now
 285     $S0 = substr pattern, 0, 2
 286     if $S0 != "::" goto create_glob
 287     $S0 = substr pattern, 0, 2, ''
 288
 289   create_glob:
 290     matching = $P1.'compile'(pattern)
 291
 292   done_setup:
 293     .local pmc result
 294     result = new 'TclList'
 295
 296     .local pmc ns
 297     ns = get_root_global 'tcl'
 298
 299     .local pmc iter
 300     iter = new 'Iterator', ns
 301   iter_loop:
 302      unless iter goto iter_loop_end
 303      $S1 = shift iter
 304      $S2 = substr $S1, 0, 1
 305      unless $S2 == '&' goto iter_loop
 306      $S1 = substr $S1, 1
 307      if_null matching, add_result
 308      $P2 = matching($S1)
 309      unless $P2 goto iter_loop
 310   add_result:
 311      push result, $S1
 312      goto iter_loop
 313   iter_loop_end:
 314
 315     .return(result)
 316
 317   bad_args:
 318     die 'wrong # args: should be "info commands ?pattern?"'
 319
 320 .end
 321
 322 .sub 'exists'
 323   .param pmc argv
 324
 325   .local int argc
 326   argc = elements argv
 327   if argc != 1 goto bad_args
 328
 329   .local string varname
 330   varname = argv[0]
 331
 332   .local pmc readVar, found_var
 333   readVar  = get_root_global ['_tcl'], 'readVar'
 334   push_eh not_found
 335     found_var = readVar(varname)
 336   pop_eh
 337   .return (1)
 338
 339 not_found:
 340   .return (0)
 341
 342 bad_args:
 343   die 'wrong # args: should be "info exists varName"'
 344 .end
 345
 346 .sub 'tclversion'
 347   .param pmc argv
 348
 349   .local int argc
 350   argc = elements argv
 351
 352   if argc != 0 goto bad_args
 353
 354   $P1 = get_root_global ['tcl'], '$tcl_version'
 355   .return($P1)
 356
 357 bad_args:
 358   die 'wrong # args: should be "info tclversion"'
 359
 360 .end
 361
 362 .sub 'patchlevel'
 363   .param pmc argv
 364
 365   .local int argc
 366   argc = elements argv
 367
 368   if argc != 0 goto bad_args
 369
 370   $P1 = get_root_global ['tcl'], '$tcl_patchLevel'
 371   .return($P1)
 372
 373 bad_args:
 374   die 'wrong # args: should be "info patchlevel"'
 375
 376 .end
 377
 378 .sub 'library'
 379   .param pmc argv
 380
 381   .local int argc
 382   argc = elements argv
 383
 384   if argc != 0 goto bad_args
 385
 386   $P1 = get_root_global ['tcl'], '$tcl_library'
 387   .return($P1)
 388
 389 bad_args:
 390   die 'wrong # args: should be "info library"'
 391
 392 .end
 393
 394 .sub 'vars'
 395   .param pmc argv
 396
 397   .local int argc
 398   argc = elements argv
 399
 400   if argc == 0 goto iterate
 401   if argc > 1  goto bad_args
 402
 403 iterate:
 404   .local pmc call_chain, lexpad
 405   call_chain = get_root_global ['_tcl'], 'call_chain'
 406   $I1 = elements call_chain
 407   if $I1 == 0 goto get_globals
 408
 409   lexpad     = call_chain[-1]
 410
 411   .local pmc    iter, retval
 412   .local string elem
 413   iter   = new 'Iterator', lexpad
 414   retval = new 'TclList'
 415 loop:
 416   unless iter goto end
 417   elem = shift iter
 418   $S0 = substr elem, 0, 1, ''
 419   unless $S0 == '$' goto loop
 420   push retval, elem
 421   goto loop
 422 end:
 423   .return(retval)
 424
 425 bad_args:
 426   die 'wrong # args: should be "info vars ?pattern?"'
 427
 428 get_globals:
 429   .return 'globals'(argv)
 430 .end
 431
 432 .sub 'level'
 433   .param pmc argv
 434
 435   .local int argc
 436   argc = elements argv
 437
 438   if argc == 0 goto current_level
 439   if argc == 1 goto find_level
 440
 441   die 'wrong # args: should be "info level ?number?"'
 442
 443 current_level:
 444   .local pmc call_chain
 445   call_chain = get_root_global ['_tcl'], 'call_chain'
 446   $I0 = elements call_chain
 447   .return($I0)
 448
 449 find_level:
 450   .local pmc toInteger, getCallLevel
 451   toInteger    = get_root_global ['_tcl'], 'toInteger'
 452   getCallLevel = get_root_global ['_tcl'], 'getCallLevel'
 453
 454   .local pmc level
 455   level = shift argv
 456   level = toInteger(level)
 457   if level >= 0 goto find_info_level
 458   level = getCallLevel(level)
 459   .return(level)
 460
 461 find_info_level:
 462   .local pmc info_level
 463   info_level = get_root_global ['_tcl'], 'info_level'
 464   $P0 = info_level[level]
 465   .return($P0)
 466 .end
 467
 468 .sub 'globals'
 469   .param pmc argv
 470
 471   .local int argc
 472   argc = elements argv
 473   if argc > 1 goto bad_args
 474
 475   .local pmc ns,iterator,retval
 476
 477   ns = get_root_namespace ['tcl']
 478   iterator = new 'Iterator', ns
 479   iterator = 0
 480   retval = new 'TclList'
 481
 482   .local pmc globber,rule,match
 483   globber = compreg 'Tcl::Glob'
 484   if argc == 1 goto got_glob
 485   $S1 = "$*"
 486   goto compile
 487 got_glob:
 488   $S1 = argv[0]
 489   $S1 = '$' . $S1
 490 compile:
 491   rule = globber.'compile'($S1)
 492 loop:
 493   unless iterator goto end
 494   $S0 = shift iterator
 495   $P0 = ns[$S0]
 496   match = rule($S0)
 497   unless match goto loop
 498   $S1 = substr $S0, 1
 499   push retval, $S1
 500   goto loop
 501 end:
 502   .return(retval)
 503
 504 bad_args:
 505   die 'wrong # args: should be "info globals ?pattern?"'
 506 .end
 507
 508 # RT#40739: stub
 509 .sub 'script'
 510   .param pmc argv
 511   .return(0)
 512 .end
 513
 514 # RT#40740: stub
 515 # sharedlibextension - should be able to pull this from parrot config.
 516 .sub 'sharedlibextension'
 517   .param pmc argv
 518   .return(0)
 519 .end
 520
 521 # RT#40741: stub
 522 .sub 'nameofexecutable'
 523   .param pmc argv
 524   .local int argc
 525   argc = elements argv
 526   if argc goto bad_args
 527   $P1 = get_root_global ['_tcl'], 'nameofexecutable'
 528   .return($P1)
 529 bad_args:
 530   die 'wrong # args: should be "info nameofexecutable"'
 531 .end
 532
 533 # RT#40742: stub
 534 .sub 'loaded'
 535   .param pmc argv
 536   .return(0)
 537 .end
 538
 539 # RT#40744: stub
 540 .sub 'cmdcount'
 541   .param pmc argv
 542   .return(0)
 543 .end
 544
 545 .sub 'anon' :anon :load
 546   .local pmc options
 547   options = new 'TclList'
 548   push options, 'args'
 549   push options, 'body'
 550   push options, 'cmdcount'
 551   push options, 'commands'
 552   push options, 'complete'
 553   push options, 'default'
 554   push options, 'exists'
 555   push options, 'frame'
 556   push options, 'functions'
 557   push options, 'globals'
 558   push options, 'hostname'
 559   push options, 'level'
 560   push options, 'library'
 561   push options, 'loaded'
 562   push options, 'locals'
 563   push options, 'nameofexecutable'
 564   push options, 'patchlevel'
 565   push options, 'procs'
 566   push options, 'script'
 567   push options, 'sharedlibextension'
 568   push options, 'tclversion'
 569   push options, 'vars'
 570
 571   set_root_global ['_tcl'; 'helpers'; 'info'], 'options', options
 572 .end
 573
 574 # Local Variables:
 575 #   mode: pir
 576 #   fill-column: 100
 577 # End:
 578 # vim: expandtab shiftwidth=4 ft=pir: