1implement Tcl_Core; 2 3# these are the outside modules, self explanatory.. 4include "sys.m"; 5 sys: Sys; 6include "draw.m"; 7 draw: Draw; 8 9include "bufio.m"; 10 bufmod : Bufio; 11Iobuf : import bufmod; 12 13include "string.m"; 14 str : String; 15 16include "tk.m"; 17 tk: Tk; 18 19include "wmlib.m"; 20 wmlib: Wmlib; 21 22# these are stand alone Tcl libraries, for Tcl pieces that 23# are "big" enough to be called their own. 24 25include "tcl.m"; 26 27include "tcllib.m"; 28 29include "utils.m"; 30 htab: Str_Hashtab; 31 mhtab : Mod_Hashtab; 32 shtab : Sym_Hashtab; 33 stack : Tcl_Stack; 34 utils : Tcl_Utils; 35 36Hash: import htab; 37MHash : import mhtab; 38SHash : import shtab; 39 40 41 42 43# global error flag and message. One day, this will be stack based.. 44errmsg : string; 45error, mypid : int; 46 47sproc : adt { 48 name : string; 49 args : string; 50 script : string; 51}; 52 53TCL_UNKNOWN, TCL_SIMPLE, TCL_ARRAY : con iota; 54 55# Global vars. Simple variables, and associative arrays. 56libmods : ref MHash; 57proctab := array[100] of sproc; 58retfl : int; 59symtab : ref SHash; 60nvtab : ref Hash; 61avtab : array of (ref Hash,string); 62tclmod : TclData; 63 64core_commands:=array[] of { 65 "append" , "array", "break" , "continue" , "catch", "dumpstack", 66 "exit" , "expr" , "eval" , 67 "for" , "foreach" , 68 "global" , "if" , "incr" , "info", 69 "lappend" , "level" , "load" , 70 "proc" , "return" , "set" , 71 "source" ,"switch" , "time" , 72 "unset" , "uplevel", "upvar", "while" , "#" 73}; 74 75 76about() : array of string { 77 return core_commands; 78} 79 80init(ctxt: ref Draw->Context, argv: list of string) { 81 sys = load Sys Sys->PATH; 82 draw = load Draw Draw->PATH; 83 bufmod = load Bufio Bufio->PATH; 84 htab = load Str_Hashtab Str_Hashtab->PATH; 85 mhtab = load Mod_Hashtab Mod_Hashtab->PATH; 86 shtab = load Sym_Hashtab Sym_Hashtab->PATH; 87 stack = load Tcl_Stack Tcl_Stack->PATH; 88 str = load String String->PATH; 89 utils = load Tcl_Utils Tcl_Utils->PATH; 90 tk = load Tk Tk->PATH; 91 wmlib= load Wmlib Wmlib->PATH; 92 if (bufmod == nil || htab == nil || stack == nil || 93 str == nil || utils == nil || tk == nil || 94 wmlib==nil || mhtab == nil || shtab == nil){ 95 sys->print("can't load initial modules %r\n"); 96 exit; 97 } 98 99 # get a new stack frame. 100 stack->init(); 101 (nvtab,avtab,symtab)=stack->newframe(); 102 103 libmods=mhtab->alloc(101); 104 105 # grab my pid, and set a new group to make me easy to kill. 106 mypid=sys->pctl(sys->NEWPGRP, nil); 107 108 # no default top window. 109 tclmod.top=nil; 110 tclmod.context=ctxt; 111 tclmod.debug=0; 112 113 # set up library modules. 114 args:=array[] of {"do_load","io"}; 115 do_load(args); 116 args=array[] of {"do_load","string"}; 117 do_load(args); 118 args=array[] of {"do_load","calc"}; 119 do_load(args); 120 args=array[] of {"do_load","list"}; 121 do_load(args); 122 args=array[] of {"do_load","tk"}; 123 do_load(args); 124 arr:=about(); 125 for(i:=0;i<len arr;i++) 126 libmods.insert(arr[i],nil); 127 128 # cmd line args... 129 if (argv != nil) 130 argv = tl argv; 131 while (argv != nil) { 132 loadfile(hd argv); 133 argv = tl argv; 134 } 135 136} 137 138set_top(win:ref Tk->Toplevel){ 139 tclmod.top=win; 140} 141 142clear_error(){ 143 error=0; 144 errmsg=""; 145} 146 147notify(num : int,s : string) : string { 148 error=1; 149 case num{ 150 1 => 151 errmsg=sys->sprint( 152 "wrong # args: should be \"%s\"",s); 153 * => 154 errmsg= s; 155 } 156 return errmsg; 157} 158 159grab_lines(new_inp,unfin: string ,lines : chan of string){ 160 error=0; 161 tclmod.lines=lines; 162 input,line : string; 163 if (new_inp==nil) 164 new_inp = "tcl%"; 165 if (unfin==nil) 166 unfin = "tcl>"; 167 sys->print("%s ", new_inp); 168 iob := bufmod->fopen(sys->fildes(0),bufmod->OREAD); 169 if (iob==nil){ 170 sys->print("cannot open stdin for reading.\n"); 171 return; 172 } 173 while((input=iob.gets('\n'))!=nil){ 174 line+=input; 175 if (!finished(line,0)) 176 sys->print("%s ", unfin); 177 else{ 178 lines <- = line; 179 line=nil; 180 } 181 } 182} 183 184# this is the main function. Its input is a complete (i.e. matching 185# brackets etc) tcl script, and its output is a message - if there 186# is one. 187evalcmd(s: string, termchar: int) : string { 188 msg : string; 189 i:=0; 190 retfl=0; 191 if (tclmod.debug==2) 192 sys->print("Entered evalcmd, s=%s, termchar=%c\n",s,termchar); 193 # strip null statements.. 194 while((i<len s) && (s[i]=='\n' || s[i]==';')) i++; 195 if (i==len s) return nil; 196 197 # parse the script statement by statement 198 for(;s!=nil;i++){ 199 # wait till we have a complete statement 200 if (i==len s || ((s[i]==termchar || s[i]==';' || s[i]=='\n') 201 && finished(s[0:i],termchar))){ 202 # throw it away if its a comment... 203 if (s[0]!='#') 204 argv := parsecmd(s[0:i],termchar,0); 205 msg = nil; 206 if (tclmod.debug==2) 207 for(k:=0;k<len argv;k++) 208 sys->print("argv[%d]: (%s)\n",k,argv[k]); 209 210 # argv is now a completely parsed array of arguments 211 # for the Tcl command.. 212 213 # find the module that the command is in and 214 # execute it. 215 if (len argv != 0){ 216 mod:=lookup(argv[0]); 217 if (mod!=nil){ 218 (error,msg)= 219 mod->exec(ref tclmod,argv); 220 if (error) 221 errmsg=msg; 222 } else { 223 if (argv[0]!=nil && 224 argv[0][0]=='.') 225 msg=do_tk(argv); 226 else 227 msg=exec(argv); 228 } 229 } 230 231 # was there an error? 232 if (error) { 233 if (len argv > 0 && argv[0]!=""){ 234 stat : string; 235 stat = "In function "+argv[0]; 236 if (len argv >1 && argv[1]!=""){ 237 stat[len stat]=' '; 238 stat+=argv[1]; 239 } 240 stat+=".....\n\t"; 241 errmsg=stat+errmsg; 242 } 243 msg=errmsg; 244 } 245 246 # we stop parsing if we hit a break, continue, return, 247 # error, termchar or end of string. 248 if (msg=="break" || msg=="continue" || error || retfl==1 249 || len s <= i || (len s > i && s[i]==termchar)) 250 return msg; 251 252 # otherwise eat up the parsed statement and continue 253 s=s[i+1:]; 254 i=-1; 255 } 256 } 257 return msg; 258} 259 260 261# returns 1 if the line has matching braces, brackets and 262# double-quotes and does not end in "\\\n" 263finished(s : string, termchar : int) : int { 264 cb:=0; 265 dq:=0; 266 sb:=0; 267 if (s==nil) return 1; 268 if (termchar=='}') cb++; 269 if (termchar==']') sb++; 270 if (len s > 1 && s[len s -2]=='\\') 271 return 0; 272 if (s[0]=='{') cb++; 273 if (s[0]=='}' && cb>0) cb--; 274 if (s[0]=='[') sb++; 275 if (s[0]==']' && sb>0) sb--; 276 if (s[0]=='"') dq=1-dq; 277 for(i:=1;i<len s;i++){ 278 if (s[i]=='{' && s[i-1]!='\\') cb++; 279 if (s[i]=='}' && s[i-1]!='\\' && cb>0) cb--; 280 if (s[i]=='[' && s[i-1]!='\\') sb++; 281 if (s[i]==']' && s[i-1]!='\\' && sb>0) sb--; 282 if (s[i]=='"' && s[i-1]!='\\') dq=1-dq; 283 } 284 return (cb==0 && sb==0 && dq==0); 285} 286 287# counts the offset till the next matching ']' 288strip_to_match(s : string, ptr: int) : int { 289 j :=0; 290 nb:=0; 291 while(j<len s){ 292 if (s[j]=='{') 293 while (j < len s && s[j]!='}') j++; 294 if (s[j]=='[') nb++; 295 if (s[j]==']'){ 296 nb--; 297 if (nb==-1) return ptr+j; 298 } 299 j++; 300 } 301 return ptr+j; 302} 303 304# returns the type of variable represented by the string s, which is 305# a name. 306isa(s: string) : (int,int,string) { 307 found,val : int; 308 name,al : string; 309 curlev:=stack->level(); 310 if (tclmod.debug==2) 311 sys->print("Called isa with %s, current stack level is %d\n",s,curlev); 312 (found,nil)=nvtab.find(s); 313 if (found) return (TCL_SIMPLE,curlev,s); 314 for (i:=0;i<len avtab;i++){ 315 (nil,name)=avtab[i]; 316 if (name==s) return (TCL_ARRAY,curlev,s); 317 } 318 if (symtab==nil) 319 return (TCL_UNKNOWN,curlev,s); 320 (found,val,al)=symtab.find(s); 321 if (!found) 322 return (TCL_UNKNOWN,curlev,s); 323 (tnv,tav,nil):=stack->examine(val); 324 if (tclmod.debug==2) 325 sys->print("have a level %d for %s\n",val,al); 326 if (tnv!=nil){ 327 (found,nil)=tnv.find(al); 328 if (found) return (TCL_SIMPLE,val,al); 329 } 330 if (tav!=nil){ 331 for (i=0;i<len tav;i++){ 332 (nil,name)=tav[i]; 333 if (name==al) return (TCL_ARRAY,val,al); 334 } 335 } 336 if (tclmod.debug==2) 337 sys->print("%s not found, creating at stack level %d\n",al,val); 338 return (TCL_UNKNOWN,val,al); 339} 340 341# This function only works if the string is already parsed! 342# takes a var_name and returns the hash table for it and the 343# name to look up. This is one of two things: 344# for simple variables: 345# findvar(foo) ---> (nvtab,foo) 346# for associative arrays: 347# findvar(foo(bar)) -----> (avtab[i],bar) 348# where avtab[i].name==foo 349# if create is 1, then an associative array is created upon first 350# reference. 351# returns (nil,error message) if there is a problem. 352 353find_var(s : string,create : int) : (ref Hash,string) { 354 rest,name,index : string; 355 retval,tnv : ref Hash; 356 tav : array of (ref Hash,string); 357 i,tag,lev: int; 358 (name,index)=str->splitl(s,"("); 359 if (index!=nil){ 360 (index,rest)=str->splitl(index[1:],")"); 361 if (rest!=")") 362 return (nil,"bad variable name"); 363 } 364 (tag,lev,name) = isa(name); 365 case tag { 366 TCL_SIMPLE => 367 if (index!=nil) 368 return (nil,"variable isn't array"); 369 (tnv,nil,nil)=stack->examine(lev); 370 return (tnv,name); 371 TCL_ARRAY => 372 if (index==nil) 373 return (nil,"variable is array"); 374 (nil,tav,nil)=stack->examine(lev); 375 for(i=0;i<len tav;i++){ 376 (retval,rest)=tav[i]; 377 if (rest==name) 378 return (retval,index); 379 } 380 return (nil,"find_var: impossible!!"); 381 # if we get here, the variable needs to be 382 # created. 383 TCL_UNKNOWN => 384 if (!create) 385 return (nil,"no such variable"); 386 (tnv,tav,nil)=stack->examine(lev); 387 if (index==nil) 388 return (tnv,name); 389 390 } 391 # if we get here, we are creating an associative variable in the 392 # tav array. 393 for(i=0;i<len tav;i++){ 394 (retval,rest)=tav[i]; 395 if (rest==nil){ 396 retval=htab->alloc(101); 397 tav[i]=(retval,name); 398 return (retval,index); 399 } 400 } 401 return (nil,"associative array table full!"); 402} 403 404# the main parsing function, a la ousterhouts man pages. Takes a 405# string that is meant to be a tcl statement and parses it, 406# reevaluating and quoting upto the termchar character. If disable 407# is true, then whitespace is not ignored. 408parsecmd(s: string, termchar,disable: int) : array of string { 409 argv:= array[200] of string; 410 buf,nm,id: string; 411 argc := 0; 412 nc := 0; 413 c :=0; 414 tab : ref Hash; 415 416 if (disable && (termchar=='\n' || termchar==';')) termchar=0; 417 outer: 418 for (i := 0; i<len s ;) { 419 if ((i>0 &&s[i-1]!='\\' &&s[i]==termchar)||(s[0]==termchar)) 420 break; 421 case int s[i] { 422 ' ' or '\t' or '\n' => 423 if (!disable){ 424 if (nc > 0) { # end of a word? 425 argv[argc++] = buf; 426 buf = nil; 427 nc = 0; 428 } 429 i++; 430 } 431 else 432 buf[nc++]=s[i++]; 433 '$' => 434 if (i>0 && s[i-1]=='\\') 435 buf[nc++]=s[i++]; 436 else { 437 (nm,id) = parsename(s[i+1:], termchar); 438 if (id!=nil) 439 nm=nm+"("+id+")"; 440 (tab,nm)=find_var(nm,0); #don't create var! 441 if (len nm > 0 && tab!=nil) { 442 (found, val) := tab.find(nm); 443 buf += val; 444 nc += len val; 445 #sys->print("Here s[i:] is (%s)\n",s[i:]); 446 if(nm==id) 447 while(s[i]!=')') i++; 448 else 449 if (s[i+1]=='{') 450 while(s[i]!='}') i++; 451 else 452 i += len nm; 453 if (nc==0 && (i==len s-1 || 454 s[i+1]==' ' || 455 s[i+1]=='\t'|| 456 s[i+1]==termchar)) 457 argv[argc++]=buf; 458 } else { 459 buf[nc++] = '$'; 460 } 461 i++; 462 } 463 '{' => 464 if (i>0 && s[i-1]=='\\') 465 buf[nc++]=s[i++]; 466 else if (s[i+1]=='}'){ 467 argv[argc++] = nil; 468 buf = nil; 469 nc = 0; 470 i+=2; 471 } else { 472 nbra := 1; 473 for (i++; i < len s; i++) { 474 if (s[i] == '{') 475 nbra++; 476 else if (s[i] == '}') { 477 nbra--; 478 if (nbra == 0) { 479 i++; 480 continue outer; 481 } 482 } 483 buf[nc++] = s[i]; 484 } 485 } 486 '[' => 487 if (i>0 && s[i-1]=='\\') 488 buf[nc++]=s[i++]; 489 else{ 490 a:=evalcmd(s[i+1:],']'); 491 if (error) 492 return nil; 493 if (nc>0){ 494 buf+=a; 495 nc += len a; 496 } else { 497 argv[argc++] = a; 498 buf = nil; 499 nc = 0; 500 } 501 i++; 502 i=strip_to_match(s[i:],i); 503 i++; 504 } 505 '"' => 506 if (i>0 && s[i-1]!='\\' && nc==0){ 507 ans:=parsecmd(s[i+1:],'"',1); 508 #sys->print("len ans is %d\n",len ans); 509 if (len ans!=0){ 510 for(;;){ 511 i++; 512 if(s[i]=='"' && 513 s[i-1]!='\\') 514 break; 515 } 516 i++; 517 argv[argc++] = ans[0]; 518 } else { 519 argv[argc++] = nil; 520 i+=2; 521 } 522 buf = nil; 523 nc = 0; 524 } 525 else buf[nc++] = s[i++]; 526 * => 527 if (s[i]=='\\'){ 528 c=unesc(s[i:]); 529 if (c!=0){ 530 buf[nc++] = c; 531 i+=2; 532 } else { 533 if (i+1 < len s && !(s[i+1]=='"' 534 || s[i+1]=='$' || s[i+1]=='{' 535 || s[i+1]=='[')) 536 buf[nc++]=s[i]; 537 i++; 538 } 539 c=0; 540 } else 541 buf[nc++]=s[i++]; 542 } 543 } 544 if (nc > 0) # fix up last word if present 545 argv[argc++] = buf; 546 ret := array[argc] of string; 547 ret[0:] = argv[0:argc]; 548 return ret; 549} 550 551# parses a name by Tcl rules, a valid name is either $foo, $foo(bar) 552# or ${foo}. 553parsename(s: string, termchar: int) : (string,string) { 554 ret,arr,rest: string; 555 rets : array of string; 556 if (len s == 0) 557 return (nil,nil); 558 if (s[0]=='{'){ 559 (ret,nil)=str->splitl(s,"}"); 560 #sys->print("returning [%s]\n",ret[1:]); 561 return (ret[1:],nil); 562 } 563 loop: for (i := 0; i < len s && s[i] != termchar; i++) { 564 case (s[i]) { 565 'a' to 'z' or 'A' to 'Z' or '0' to '9' or '_' => 566 ret[i] = s[i]; 567 * => 568 break loop; 569 '(' => 570 arr=ret[0:i]; 571 rest=s[i+1:]; 572 rets=parsecmd(rest,')',0); 573 # should always be len 1? 574 if (len rets >1) 575 sys->print("len rets>1 in parsename!\n"); 576 return (arr,rets[0]); 577 } 578 } 579 return (ret,nil); 580} 581 582loadfile(file :string) : string { 583 iob : ref Iobuf; 584 msg,input,line : string; 585 if (file==nil) 586 return nil; 587 iob = bufmod->open(file,bufmod->OREAD); 588 if (iob==nil) 589 return notify(0,sys->sprint( 590 "couldn't read file \"%s\":%r",file)); 591 while((input=iob.gets('\n'))!=nil){ 592 line+=input; 593 if (finished(line,0)){ 594 # put in a return catch here... 595 line = prepass(line); 596 msg=evalcmd(line,0); 597 if (error) return errmsg; 598 line=nil; 599 } 600 } 601 return msg; 602} 603 604 605#unescapes a string. Can do better..... 606unesc(s: string) : int { 607 c: int; 608 if (len s == 1) return 0; 609 case s[1] { 610 'a'=> c = '\a'; 611 'n'=> c = '\n'; 612 't'=> c = '\t'; 613 'r'=> c = '\r'; 614 'b'=> c = '\b'; 615 '\\'=> c = '\\'; 616 '}' => c = '}'; 617 ']' => c=']'; 618 # do hex and octal. 619 * => c = 0; 620 } 621 return c; 622} 623 624# prepass a string and replace "\\n[ \t]*" with ' ' 625prepass(s : string) : string { 626 for(i := 0; i < len s; i++) { 627 if(s[i] != '\\') 628 continue; 629 j:=i; 630 if (s[i+1] == '\n') { 631 s[j]=' '; 632 i++; 633 while(i<len s && (s[i]==' ' || s[i]=='\t')) 634 i++; 635 if (i==len s) 636 s = s[0:j]; 637 else 638 s=s[0:j]+s[i+1:]; 639 i=j; 640 } 641 } 642 return s; 643} 644 645exec(argv : array of string) : string { 646 msg : string; 647 if (argv[0]=="") 648 return nil; 649 case (argv[0]) { 650 "append" => 651 msg= do_append(argv); 652 "array" => 653 msg= do_array(argv); 654 "break" or "continue" => 655 return argv[0]; 656 "catch" => 657 msg=do_catch(argv); 658 "debug" => 659 msg=do_debug(argv); 660 "dumpstack" => 661 msg=do_dumpstack(argv); 662 "exit" => 663 do_exit(); 664 "expr" => 665 msg = do_expr(argv); 666 "eval" => 667 msg = do_eval(argv); 668 "for" => 669 msg = do_for(argv); 670 "foreach" => 671 msg = do_foreach(argv); 672 "format" => 673 msg = do_string(argv); 674 "global" => 675 msg = do_global(argv); 676 "if" => 677 msg = do_if(argv); 678 "incr" => 679 msg = do_incr(argv); 680 "info" => 681 msg = do_info(argv); 682 "lappend" => 683 msg = do_lappend(argv); 684 "level" => 685 msg=sys->sprint("Current Stack "+ 686 "level is %d", 687 stack->level()); 688 "load" => 689 msg=do_load(argv); 690 "proc" => 691 msg=do_proc(argv); 692 "return" => 693 msg=do_return(argv); 694 retfl =1; 695 "set" => 696 msg = do_set(argv); 697 "source" => 698 msg = do_source(argv); 699 "string" => 700 msg = do_string(argv); 701 "switch" => 702 msg = do_switch(argv); 703 "time" => 704 msg=do_time(argv); 705 "unset" => 706 msg = do_unset(argv); 707 "uplevel" => 708 msg=do_uplevel(argv); 709 "upvar" => 710 msg=do_upvar(argv); 711 "while" => 712 msg = do_while(argv); 713 "#" => 714 msg=nil; 715 * => 716 msg = uproc(argv); 717 } 718 return msg; 719} 720 721# from here on is the list of commands, alpahabetised, we hope. 722 723do_append(argv :array of string) : string { 724 tab : ref Hash; 725 if (len argv==1 || len argv==2) 726 return notify(1, 727 "append varName value ?value ...?"); 728 name := argv[1]; 729 (tab,name)=find_var(name,1); 730 if (tab==nil) 731 return notify(0,name); 732 (found, val) := tab.find(name); 733 for (i:=2;i<len argv;i++) 734 val+=argv[i]; 735 tab.insert(name,val); 736 return val; 737} 738 739do_array(argv : array of string) : string { 740 tab : ref Hash; 741 name : string; 742 flag : int; 743 if (len argv!=3) 744 return notify(1,"array [names, size] name"); 745 case argv[1] { 746 "names" => 747 flag=1; 748 "size" => 749 flag=0; 750 * => 751 return notify(0,"expexted names or size, got "+argv[1]); 752 753 } 754 (tag,lev,al) := isa(argv[2]); 755 if (tag!=TCL_ARRAY) 756 return notify(0,argv[2]+" isn't an array"); 757 (nil,tav,nil):=stack->examine(lev); 758 for (i:=0;i<len tav;i++){ 759 (tab,name)=tav[i]; 760 if (name==al) break; 761 } 762 if (flag==0) 763 return string tab.lsize; 764 return tab.dump(); 765} 766 767do_catch(argv : array of string) : string { 768 if (len argv==1 || len argv > 3) 769 return notify(1,"catch command ?varName?"); 770 msg:=evalcmd(argv[1],0); 771 if (len argv==3 && error){ 772 (tab,name):=find_var(argv[2],1); 773 if (tab==nil) 774 return notify(0,name); 775 tab.insert(name, msg); 776 } 777 ret:=string error; 778 error=0; 779 return ret; 780} 781 782do_debug(argv : array of string) : string { 783 add : string; 784 if (len argv!=2) 785 return notify(1,"debug"); 786 (i,rest):=str->toint(argv[1],10); 787 if (rest!=nil) 788 return notify(0,"Expected integer and got "+argv[1]); 789 tclmod.debug=i; 790 if (tclmod.debug==0) 791 add="off"; 792 else 793 add="on"; 794 return "debugging is now "+add+" at level"+ string i; 795} 796 797do_dumpstack(argv : array of string) : string { 798 if (len argv!=1) 799 return notify(1,"dumpstack"); 800 stack->dump(); 801 return nil; 802} 803 804do_eval(argv : array of string) : string { 805 eval_str : string; 806 for(i:=1;i<len argv;i++){ 807 eval_str += argv[i]; 808 eval_str[len eval_str]=' '; 809 } 810 return evalcmd(eval_str[0:len eval_str -1],0); 811} 812 813do_exit(){ 814 kfd := sys->open("#p/"+string mypid+"/ctl", sys->OWRITE); 815 if(kfd == nil) 816 sys->print("error opening pid %d (%r)\n",mypid); 817 sys->fprint(kfd, "killgrp"); 818 exit; 819} 820 821 822 823do_expr(argv : array of string) : string { 824 retval : string; 825 for (i:=1;i<len argv;i++){ 826 retval+=argv[i]; 827 retval[len retval]=' '; 828 } 829 retval=retval[0: len retval -1]; 830 argv=parsecmd(retval,0,0); 831 cal:=lookup("calc"); 832 (err,ret):= cal->exec(ref tclmod,argv); 833 if (err) return notify(0,ret); 834 return ret; 835} 836 837 838do_for(argv : array of string) : string { 839 if (len argv!=5) 840 return notify(1,"for start test next command"); 841 test := array[] of {"expr",argv[2]}; 842 evalcmd(argv[1],0); 843 for(;;){ 844 msg:=do_expr(test); 845 if (msg=="Error!") 846 return notify(0,sys->sprint( 847 "syntax error in expression \"%s\"", 848 argv[2])); 849 if (msg=="0") 850 return nil; 851 msg=evalcmd(argv[4],0); 852 if (msg=="break") 853 return nil; 854 if (msg=="continue"); #do nothing! 855 evalcmd(argv[3],0); 856 if (error) 857 return errmsg; 858 } 859} 860 861 862 863do_foreach(argv: array of string) : string{ 864 tab : ref Hash; 865 if (len argv!=4) 866 return notify(1,"foreach varName list command"); 867 name := argv[1]; 868 (tab,name)=find_var(name,1); 869 if (tab==nil) 870 return notify(0,name); 871 arr:=utils->break_it(argv[2]); 872 for(i:=0;i<len arr;i++){ 873 tab.insert(name,arr[i]); 874 evalcmd(argv[3],0); 875 } 876 return nil; 877} 878 879 880 881do_global(argv : array of string) : string { 882 if (len argv==1) 883 return notify(1,"global varName ?varName ...?"); 884 if (symtab==nil) 885 return nil; 886 for (i:=1 ; i < len argv;i++) 887 symtab.insert(argv[i],argv[i],0); 888 return nil; 889} 890 891 892 893do_if(argv : array of string) : string { 894 if (len argv==1) 895 return notify(1,"no expression after \"if\" argument"); 896 expr1 := array[] of {"expr",argv[1]}; 897 msg:=do_expr(expr1); 898 if (msg=="Error!") 899 return notify(0,sys->sprint( 900 "syntax error in expression \"%s\"", 901 argv[1])); 902 if (len argv==2) 903 return notify(1,sys->sprint( 904 "no script following \""+ 905 "%s\" argument",msg)); 906 if (msg=="0"){ 907 if (len argv>3){ 908 if (argv[3]=="else"){ 909 if (len argv==4) 910 return notify(1, 911 "no script"+ 912 " following \"else\" argument"); 913 return evalcmd(argv[4],0); 914 } 915 if (argv[3]=="elseif"){ 916 argv[3]="if"; 917 return do_if(argv[3:]); 918 } 919 } 920 return nil; 921 } 922 return evalcmd(argv[2],0); 923} 924 925do_incr(argv :array of string) : string { 926 num,xtra : int; 927 rest :string; 928 tab : ref Hash; 929 if (len argv==1) 930 return notify(1,"incr varName ?increment?"); 931 name := argv[1]; 932 (tab,name)=find_var(name,0); #doesn't create!! 933 if (tab==nil) 934 return notify(0,name); 935 (found, val) := tab.find(name); 936 if (!found) 937 return notify(0,sys->sprint("can't read \"%s\": " 938 +"no such variable",name)); 939 (num,rest)=str->toint(val,10); 940 if (rest!=nil) 941 return notify(0,sys->sprint( 942 "expected integer but got \"%s\"",val)); 943 if (len argv == 2){ 944 num+=1; 945 tab.insert(name,string num); 946 } 947 if (len argv == 3) { 948 val = argv[2]; 949 (xtra,rest)=str->toint(val,10); 950 if (rest!=nil) 951 return notify(0,sys->sprint( 952 "expected integer but got \"%s\"" 953 ,val)); 954 num+=xtra; 955 tab.insert(name, string num); 956 } 957 return string num; 958} 959 960do_info(argv : array of string) : string { 961 if (len argv==1) 962 return notify(1,"info option ?arg arg ...?"); 963 case argv[1] { 964 "args" => 965 return do_info_args(argv,0); 966 "body" => 967 return do_info_args(argv,1); 968 "commands" => 969 return do_info_commands(argv); 970 "exists" => 971 return do_info_exists(argv); 972 "procs" => 973 return do_info_procs(argv); 974 975 } 976 return sys->sprint( 977 "bad option \"%s\": should be args, body, commands, exists, procs", 978 argv[1]); 979} 980 981do_info_args(argv : array of string,body :int) : string { 982 name: string; 983 s : sproc; 984 if (body) 985 name="body"; 986 else 987 name="args"; 988 if (len argv!=3) 989 return notify(1,"info "+name+" procname"); 990 for(i:=0;i<len proctab;i++){ 991 s=proctab[i]; 992 if (s.name==argv[2]) 993 break; 994 } 995 if (i==len proctab) 996 return notify(0,argv[2]+" isn't a procedure."); 997 if (body) 998 return s.script; 999 return s.args; 1000} 1001 1002do_info_commands(argv : array of string) : string { 1003 if (len argv==1 || len argv>3) 1004 return notify(1,"info commands [pattern]"); 1005 return libmods.dump(); 1006} 1007 1008do_info_exists(argv : array of string) : string { 1009 name, index : string; 1010 tab : ref Hash; 1011 if (len argv!=3) 1012 return notify(1,"info exists varName"); 1013 (name,index)=parsename(argv[2],0); 1014 (i,nil,nil):=isa(name); 1015 if (i==TCL_UNKNOWN) 1016 return "0"; 1017 if (index==nil) 1018 return "1"; 1019 (tab,name)=find_var(argv[2],0); 1020 if (tab==nil) 1021 return "0"; 1022 (found, val) := tab.find(name); 1023 if (!found) 1024 return "0"; 1025 return "1"; 1026 1027} 1028 1029do_info_procs(argv : array of string) : string { 1030 if (len argv==1 || len argv>3) 1031 return notify(1,"info procs [pattern]"); 1032 retval : string; 1033 for(i:=0;i<len proctab;i++){ 1034 s:=proctab[i]; 1035 if (s.name!=nil){ 1036 retval+=s.name; 1037 retval[len retval]=' '; 1038 } 1039 } 1040 return retval; 1041} 1042 1043do_lappend(argv : array of string) : string{ 1044 tab : ref Hash; 1045 retval :string; 1046 retval=nil; 1047 if (len argv==1 || len argv==2) 1048 return notify(1, 1049 "lappend varName value ?value ...?"); 1050 name := argv[1]; 1051 (tab,name)=find_var(name,1); 1052 if (tab==nil) 1053 return notify(0,name); 1054 (found, val) := tab.find(name); 1055 for(i:=2;i<len argv;i++){ 1056 flag:=0; 1057 if (spaces(argv[i])) flag=1; 1058 if (flag) retval[len retval]='{'; 1059 retval += argv[i]; 1060 if (flag) retval[len retval]='}'; 1061 retval[len retval]=' '; 1062 } 1063 if (retval!=nil) 1064 retval=retval[0:len retval-1]; 1065 if (val!=nil) 1066 retval=val+" "+retval; 1067 tab.insert(name,retval); 1068 return retval; 1069} 1070 1071spaces(s : string) : int{ 1072 if (s==nil) return 1; 1073 for(i:=0;i<len s;i++) 1074 if (s[i]==' ' || s[i]=='\t') return 1; 1075 return 0; 1076} 1077 1078do_load(argv : array of string) : string { 1079 # look for a dis library to load up, then 1080 # add to library array. 1081 if (len argv!=2) 1082 return notify(1,"load libname"); 1083 fname:="/dis/lib/tcl_"+argv[1]+".dis"; 1084 mod:= load TclLib fname; 1085 if (mod==nil) 1086 return notify(0, 1087 sys->sprint("Cannot load %s",fname)); 1088 arr:=mod->about(); 1089 for(i:=0;i<len arr;i++) 1090 libmods.insert(arr[i],mod); 1091 return nil; 1092} 1093 1094 1095do_proc(argv : array of string) : string { 1096 if (len argv != 4) 1097 return notify(1,"proc name args body"); 1098 for(i:=0;i<len proctab;i++) 1099 if (proctab[i].name==nil || 1100 proctab[i].name==argv[1]) break; 1101 if (i==len proctab) 1102 return notify(0,"procedure table full!"); 1103 proctab[i].name=argv[1]; 1104 proctab[i].args=argv[2]; 1105 proctab[i].script=argv[3]; 1106 return nil; 1107} 1108 1109do_return(argv : array of string) : string { 1110 if (len argv==1) 1111 return nil; 1112 # put in options here..... 1113 return argv[1]; 1114} 1115 1116do_set(argv : array of string) : string { 1117 tab : ref Hash; 1118 if (len argv == 1 || len argv > 3) 1119 return notify(1,"set varName ?newValue?"); 1120 name := argv[1]; 1121 (tab,name)=find_var(name,1); 1122 if (tab==nil) 1123 return notify(0,name); 1124 (found, val) := tab.find(name); 1125 if (len argv == 2) 1126 if (!found) 1127 val = notify(0,sys->sprint( 1128 "can't read \"%s\": " 1129 +"no such variable",name)); 1130 if (len argv == 3) { 1131 val = argv[2]; 1132 tab.insert(name, val); 1133 } 1134 return val; 1135} 1136 1137do_source(argv : array of string) : string { 1138 if (len argv !=2) 1139 return notify(1,"source fileName"); 1140 return loadfile(argv[1]); 1141} 1142 1143do_string(argv : array of string) : string { 1144 stringmod := lookup("string"); 1145 if (stringmod==nil) 1146 return notify(0,sys->sprint( 1147 "String Package not loaded (%r)")); 1148 (err,retval):= stringmod->exec(ref tclmod,argv); 1149 if (err) return notify(0,retval); 1150 return retval; 1151} 1152 1153do_switch(argv : array of string) : string { 1154 i:=0; 1155 arr : array of string; 1156 if (len argv < 3) 1157 return notify(1,"switch " 1158 +"?switches? string pattern body ... "+ 1159 "?default body?\""); 1160 if (len argv == 3) 1161 arr=utils->break_it(argv[2]); 1162 else 1163 arr=argv[2:]; 1164 if (len arr % 2 !=0) 1165 return notify(0, 1166 "extra switch pattern with no body"); 1167 for (i=0;i<len arr;i+=2) 1168 if (argv[1]==arr[i]) 1169 break; 1170 if (i==len arr){ 1171 if (arr[i-2]=="default") 1172 return evalcmd(arr[i-1],0); 1173 else return nil; 1174 } 1175 while (i<len arr && arr[i+1]=="-") i+=2; 1176 return evalcmd(arr[i+1],0); 1177} 1178 1179do_time(argv : array of string) : string { 1180 rest : string; 1181 end,start,times : int; 1182 if (len argv==1 || len argv>3) 1183 return notify(1,"time command ?count?"); 1184 if (len argv==2) 1185 times=1; 1186 else{ 1187 (times,rest)=str->toint(argv[2],10); 1188 if (rest!=nil) 1189 return notify(0,sys->sprint( 1190 "expected integer but got \"%s\"",argv[2])); 1191 } 1192 start=sys->millisec(); 1193 for(i:=0;i<times;i++) 1194 evalcmd(argv[1],0); 1195 end=sys->millisec(); 1196 r:= (real end - real start) / real times; 1197 return sys->sprint("%g milliseconds per iteration", r); 1198} 1199 1200do_unset(argv : array of string) : string { 1201 tab : ref Hash; 1202 name: string; 1203 if (len argv == 1) 1204 return notify(1,"unset "+ 1205 "varName ?varName ...?"); 1206 for(i:=1;i<len argv;i++){ 1207 name = argv[i]; 1208 (tab,name)=find_var(name,0); 1209 if (tab==nil) 1210 return notify(0,sys->sprint("can't unset \"%s\": no such" + 1211 " variable",name)); 1212 tab.delete(name); 1213 1214 } 1215 return nil; 1216} 1217 1218do_uplevel(argv : array of string) : string { 1219 level: int; 1220 rest,scr : string; 1221 scr=nil; 1222 exact:=0; 1223 i:=1; 1224 if (len argv==1) 1225 return notify(1,"uplevel ?level? command ?arg ...?"); 1226 if (len argv==2) 1227 level=-1; 1228 else { 1229 lev:=argv[1]; 1230 if (lev[0]=='#'){ 1231 exact=1; 1232 lev=lev[1:]; 1233 } 1234 (level,rest)=str->toint(lev,10); 1235 if (rest!=nil){ 1236 i=2; 1237 level =-1; 1238 } 1239 } 1240 oldlev:=stack->level(); 1241 if (!exact) 1242 level+=oldlev; 1243 (tnv,tav,sym):=stack->examine(level); 1244 if (tnv==nil && tav==nil) 1245 return notify(0,"bad level "+argv[1]); 1246 if (tclmod.debug==2) 1247 sys->print("In uplevel, current level is %d, moving to level %d\n", 1248 oldlev,level); 1249 stack->move(level); 1250 oldav:=avtab; 1251 oldnv:=nvtab; 1252 oldsym:=symtab; 1253 avtab=tav; 1254 nvtab=tnv; 1255 symtab=sym; 1256 for(;i<len argv;i++) 1257 scr=scr+argv[i]+" "; 1258 msg:=evalcmd(scr[0:len scr-1],0); 1259 avtab=oldav; 1260 nvtab=oldnv; 1261 symtab=oldsym; 1262 ok:=stack->move(oldlev); 1263 if (tclmod.debug==2) 1264 sys->print("Leaving uplevel, current level is %d, moving back to"+ 1265 " level %d,move was %d\n", 1266 level,oldlev,ok); 1267 return msg; 1268} 1269 1270do_upvar(argv : array of string) : string { 1271 level:int; 1272 rest:string; 1273 i:=1; 1274 exact:=0; 1275 if (len argv<3 || len argv>4) 1276 return notify(1,"upvar ?level? ThisVar OtherVar"); 1277 if (len argv==3) 1278 level=-1; 1279 else { 1280 lev:=argv[1]; 1281 if (lev[0]=='#'){ 1282 exact=1; 1283 lev=lev[1:]; 1284 } 1285 (level,rest)=str->toint(lev,10); 1286 if (rest!=nil){ 1287 i=2; 1288 level =-1; 1289 } 1290 } 1291 if (!exact) 1292 level+=stack->level(); 1293 symtab.insert(argv[i],argv[i+1],level); 1294 return nil; 1295} 1296 1297do_while(argv : array of string) : string { 1298 if (len argv!=3) 1299 return notify(1,"while test command"); 1300 for(;;){ 1301 expr1 := array[] of {"expr",argv[1]}; 1302 msg:=do_expr(expr1); 1303 if (msg=="Error!") 1304 return notify(0,sys->sprint( 1305 "syntax error in expression \"%s\"", 1306 argv[1])); 1307 if (msg=="0") 1308 return nil; 1309 evalcmd(argv[2],0); 1310 if (error) 1311 return errmsg; 1312 } 1313} 1314 1315uproc(argv : array of string) : string { 1316 cmd,add : string; 1317 for(i:=0;i< len proctab;i++) 1318 if (proctab[i].name==argv[0]) 1319 break; 1320 if (i==len proctab) 1321 return notify(0,sys->sprint("invalid command name \"%s\"", 1322 argv[0])); 1323 # save tables 1324 # push a newframe 1325 # bind args to arguments 1326 # do cmd 1327 # pop frame 1328 # return msg 1329 1330 # globals are supported, but upvar and uplevel are not! 1331 1332 arg_arr:=utils->break_it(proctab[i].args); 1333 j:=len arg_arr; 1334 if (len argv < j+1 && arg_arr[j-1]!="args"){ 1335 j=len argv-1; 1336 return notify(0,sys->sprint( 1337 "no value given for"+ 1338 " parameter \"%s\" to \"%s\"", 1339 arg_arr[j],proctab[i].name)); 1340 } 1341 if ((len argv > j+1) && arg_arr[j-1]!="args") 1342 return notify(0,"called "+proctab[i].name+ 1343 " with too many arguments"); 1344 oldavtab:=avtab; 1345 oldnvtab:=nvtab; 1346 oldsymtab:=symtab; 1347 (nvtab,avtab,symtab)=stack->newframe(); 1348 for (j=0;j< len arg_arr-1;j++){ 1349 cmd="set "+arg_arr[j]+" {"+argv[j+1]+"}"; 1350 evalcmd(cmd,0); 1351 } 1352 if (len arg_arr>j && arg_arr[j] != "args") { 1353 cmd="set "+arg_arr[j]+" {"+argv[j+1]+"}"; 1354 evalcmd(cmd,0); 1355 } 1356 else { 1357 if (len arg_arr > j) { 1358 if (j+1==len argv) 1359 add=""; 1360 else 1361 add=argv[j+1]; 1362 cmd="set "+arg_arr[j]+" "; 1363 arglist:="{"+add+" "; 1364 j++; 1365 while(j<len argv-1) { 1366 arglist+=argv[j+1]; 1367 arglist[len arglist]=' '; 1368 j++; 1369 } 1370 arglist[len arglist]='}'; 1371 cmd+=arglist; 1372 evalcmd(cmd,0); 1373 } 1374 } 1375 msg:=evalcmd(proctab[i].script,0); 1376 stack->pop(); 1377 avtab=oldavtab; 1378 nvtab=oldnvtab; 1379 symtab=oldsymtab; 1380 #sys->print("Error is %d, msg is %s\n",error,msg); 1381 return msg; 1382} 1383 1384do_tk(argv : array of string) : string { 1385 tkpack:=lookup("button"); 1386 (err,retval):= tkpack->exec(ref tclmod,argv); 1387 if (err) return notify(0,retval); 1388 return retval; 1389} 1390 1391 1392lookup(s : string) : TclLib { 1393 (found,mod):=libmods.find(s); 1394 if (!found) 1395 return nil; 1396 return mod; 1397} 1398