summaryrefslogtreecommitdiff
path: root/appl/lib/tcl_core.b
diff options
context:
space:
mode:
Diffstat (limited to 'appl/lib/tcl_core.b')
-rw-r--r--appl/lib/tcl_core.b1397
1 files changed, 1397 insertions, 0 deletions
diff --git a/appl/lib/tcl_core.b b/appl/lib/tcl_core.b
new file mode 100644
index 00000000..ef05ef97
--- /dev/null
+++ b/appl/lib/tcl_core.b
@@ -0,0 +1,1397 @@
+implement Tcl_Core;
+
+# these are the outside modules, self explanatory..
+include "sys.m";
+ sys: Sys;
+include "draw.m";
+ draw: Draw;
+
+include "bufio.m";
+ bufmod : Bufio;
+Iobuf : import bufmod;
+
+include "string.m";
+ str : String;
+
+include "tk.m";
+ tk: Tk;
+
+include "wmlib.m";
+ wmlib: Wmlib;
+
+# these are stand alone Tcl libraries, for Tcl pieces that
+# are "big" enough to be called their own.
+
+include "tcl.m";
+
+include "tcllib.m";
+
+include "utils.m";
+ htab: Str_Hashtab;
+ mhtab : Mod_Hashtab;
+ shtab : Sym_Hashtab;
+ stack : Tcl_Stack;
+ utils : Tcl_Utils;
+
+Hash: import htab;
+MHash : import mhtab;
+SHash : import shtab;
+
+
+
+
+# global error flag and message. One day, this will be stack based..
+errmsg : string;
+error, mypid : int;
+
+sproc : adt {
+ name : string;
+ args : string;
+ script : string;
+};
+
+TCL_UNKNOWN, TCL_SIMPLE, TCL_ARRAY : con iota;
+
+# Global vars. Simple variables, and associative arrays.
+libmods : ref MHash;
+proctab := array[100] of sproc;
+retfl : int;
+symtab : ref SHash;
+nvtab : ref Hash;
+avtab : array of (ref Hash,string);
+tclmod : TclData;
+
+core_commands:=array[] of {
+ "append" , "array", "break" , "continue" , "catch", "dumpstack",
+ "exit" , "expr" , "eval" ,
+ "for" , "foreach" ,
+ "global" , "if" , "incr" , "info",
+ "lappend" , "level" , "load" ,
+ "proc" , "return" , "set" ,
+ "source" ,"switch" , "time" ,
+ "unset" , "uplevel", "upvar", "while" , "#"
+};
+
+
+about() : array of string {
+ return core_commands;
+}
+
+init(ctxt: ref Draw->Context, argv: list of string) {
+ sys = load Sys Sys->PATH;
+ draw = load Draw Draw->PATH;
+ bufmod = load Bufio Bufio->PATH;
+ htab = load Str_Hashtab Str_Hashtab->PATH;
+ mhtab = load Mod_Hashtab Mod_Hashtab->PATH;
+ shtab = load Sym_Hashtab Sym_Hashtab->PATH;
+ stack = load Tcl_Stack Tcl_Stack->PATH;
+ str = load String String->PATH;
+ utils = load Tcl_Utils Tcl_Utils->PATH;
+ tk = load Tk Tk->PATH;
+ wmlib= load Wmlib Wmlib->PATH;
+ if (bufmod == nil || htab == nil || stack == nil ||
+ str == nil || utils == nil || tk == nil ||
+ wmlib==nil || mhtab == nil || shtab == nil){
+ sys->print("can't load initial modules %r\n");
+ exit;
+ }
+
+ # get a new stack frame.
+ stack->init();
+ (nvtab,avtab,symtab)=stack->newframe();
+
+ libmods=mhtab->alloc(101);
+
+ # grab my pid, and set a new group to make me easy to kill.
+ mypid=sys->pctl(sys->NEWPGRP, nil);
+
+ # no default top window.
+ tclmod.top=nil;
+ tclmod.context=ctxt;
+ tclmod.debug=0;
+
+ # set up library modules.
+ args:=array[] of {"do_load","io"};
+ do_load(args);
+ args=array[] of {"do_load","string"};
+ do_load(args);
+ args=array[] of {"do_load","calc"};
+ do_load(args);
+ args=array[] of {"do_load","list"};
+ do_load(args);
+ args=array[] of {"do_load","tk"};
+ do_load(args);
+ arr:=about();
+ for(i:=0;i<len arr;i++)
+ libmods.insert(arr[i],nil);
+
+ # cmd line args...
+ if (argv != nil)
+ argv = tl argv;
+ while (argv != nil) {
+ loadfile(hd argv);
+ argv = tl argv;
+ }
+
+}
+
+set_top(win:ref Tk->Toplevel){
+ tclmod.top=win;
+}
+
+clear_error(){
+ error=0;
+ errmsg="";
+}
+
+notify(num : int,s : string) : string {
+ error=1;
+ case num{
+ 1 =>
+ errmsg=sys->sprint(
+ "wrong # args: should be \"%s\"",s);
+ * =>
+ errmsg= s;
+ }
+ return errmsg;
+}
+
+grab_lines(new_inp,unfin: string ,lines : chan of string){
+ error=0;
+ tclmod.lines=lines;
+ input,line : string;
+ if (new_inp==nil)
+ new_inp = "tcl%";
+ if (unfin==nil)
+ unfin = "tcl>";
+ sys->print("%s ", new_inp);
+ iob := bufmod->fopen(sys->fildes(0),bufmod->OREAD);
+ if (iob==nil){
+ sys->print("cannot open stdin for reading.\n");
+ return;
+ }
+ while((input=iob.gets('\n'))!=nil){
+ line+=input;
+ if (!finished(line,0))
+ sys->print("%s ", unfin);
+ else{
+ lines <- = line;
+ line=nil;
+ }
+ }
+}
+
+# this is the main function. Its input is a complete (i.e. matching
+# brackets etc) tcl script, and its output is a message - if there
+# is one.
+evalcmd(s: string, termchar: int) : string {
+ msg : string;
+ i:=0;
+ retfl=0;
+ if (tclmod.debug==2)
+ sys->print("Entered evalcmd, s=%s, termchar=%c\n",s,termchar);
+ # strip null statements..
+ while((i<len s) && (s[i]=='\n' || s[i]==';')) i++;
+ if (i==len s) return nil;
+
+ # parse the script statement by statement
+ for(;s!=nil;i++){
+ # wait till we have a complete statement
+ if (i==len s || ((s[i]==termchar || s[i]==';' || s[i]=='\n')
+ && finished(s[0:i],termchar))){
+ # throw it away if its a comment...
+ if (s[0]!='#')
+ argv := parsecmd(s[0:i],termchar,0);
+ msg = nil;
+ if (tclmod.debug==2)
+ for(k:=0;k<len argv;k++)
+ sys->print("argv[%d]: (%s)\n",k,argv[k]);
+
+ # argv is now a completely parsed array of arguments
+ # for the Tcl command..
+
+ # find the module that the command is in and
+ # execute it.
+ if (len argv != 0){
+ mod:=lookup(argv[0]);
+ if (mod!=nil){
+ (error,msg)=
+ mod->exec(ref tclmod,argv);
+ if (error)
+ errmsg=msg;
+ } else {
+ if (argv[0]!=nil &&
+ argv[0][0]=='.')
+ msg=do_tk(argv);
+ else
+ msg=exec(argv);
+ }
+ }
+
+ # was there an error?
+ if (error) {
+ if (len argv > 0 && argv[0]!=""){
+ stat : string;
+ stat = "In function "+argv[0];
+ if (len argv >1 && argv[1]!=""){
+ stat[len stat]=' ';
+ stat+=argv[1];
+ }
+ stat+=".....\n\t";
+ errmsg=stat+errmsg;
+ }
+ msg=errmsg;
+ }
+
+ # we stop parsing if we hit a break, continue, return,
+ # error, termchar or end of string.
+ if (msg=="break" || msg=="continue" || error || retfl==1
+ || len s <= i || (len s > i && s[i]==termchar))
+ return msg;
+
+ # otherwise eat up the parsed statement and continue
+ s=s[i+1:];
+ i=-1;
+ }
+ }
+ return msg;
+}
+
+
+# returns 1 if the line has matching braces, brackets and
+# double-quotes and does not end in "\\\n"
+finished(s : string, termchar : int) : int {
+ cb:=0;
+ dq:=0;
+ sb:=0;
+ if (s==nil) return 1;
+ if (termchar=='}') cb++;
+ if (termchar==']') sb++;
+ if (len s > 1 && s[len s -2]=='\\')
+ return 0;
+ if (s[0]=='{') cb++;
+ if (s[0]=='}' && cb>0) cb--;
+ if (s[0]=='[') sb++;
+ if (s[0]==']' && sb>0) sb--;
+ if (s[0]=='"') dq=1-dq;
+ for(i:=1;i<len s;i++){
+ if (s[i]=='{' && s[i-1]!='\\') cb++;
+ if (s[i]=='}' && s[i-1]!='\\' && cb>0) cb--;
+ if (s[i]=='[' && s[i-1]!='\\') sb++;
+ if (s[i]==']' && s[i-1]!='\\' && sb>0) sb--;
+ if (s[i]=='"' && s[i-1]!='\\') dq=1-dq;
+ }
+ return (cb==0 && sb==0 && dq==0);
+}
+
+# counts the offset till the next matching ']'
+strip_to_match(s : string, ptr: int) : int {
+ j :=0;
+ nb:=0;
+ while(j<len s){
+ if (s[j]=='{')
+ while (j < len s && s[j]!='}') j++;
+ if (s[j]=='[') nb++;
+ if (s[j]==']'){
+ nb--;
+ if (nb==-1) return ptr+j;
+ }
+ j++;
+ }
+ return ptr+j;
+}
+
+# returns the type of variable represented by the string s, which is
+# a name.
+isa(s: string) : (int,int,string) {
+ found,val : int;
+ name,al : string;
+ curlev:=stack->level();
+ if (tclmod.debug==2)
+ sys->print("Called isa with %s, current stack level is %d\n",s,curlev);
+ (found,nil)=nvtab.find(s);
+ if (found) return (TCL_SIMPLE,curlev,s);
+ for (i:=0;i<len avtab;i++){
+ (nil,name)=avtab[i];
+ if (name==s) return (TCL_ARRAY,curlev,s);
+ }
+ if (symtab==nil)
+ return (TCL_UNKNOWN,curlev,s);
+ (found,val,al)=symtab.find(s);
+ if (!found)
+ return (TCL_UNKNOWN,curlev,s);
+ (tnv,tav,nil):=stack->examine(val);
+ if (tclmod.debug==2)
+ sys->print("have a level %d for %s\n",val,al);
+ if (tnv!=nil){
+ (found,nil)=tnv.find(al);
+ if (found) return (TCL_SIMPLE,val,al);
+ }
+ if (tav!=nil){
+ for (i=0;i<len tav;i++){
+ (nil,name)=tav[i];
+ if (name==al) return (TCL_ARRAY,val,al);
+ }
+ }
+ if (tclmod.debug==2)
+ sys->print("%s not found, creating at stack level %d\n",al,val);
+ return (TCL_UNKNOWN,val,al);
+}
+
+# This function only works if the string is already parsed!
+# takes a var_name and returns the hash table for it and the
+# name to look up. This is one of two things:
+# for simple variables:
+# findvar(foo) ---> (nvtab,foo)
+# for associative arrays:
+# findvar(foo(bar)) -----> (avtab[i],bar)
+# where avtab[i].name==foo
+# if create is 1, then an associative array is created upon first
+# reference.
+# returns (nil,error message) if there is a problem.
+
+find_var(s : string,create : int) : (ref Hash,string) {
+ rest,name,index : string;
+ retval,tnv : ref Hash;
+ tav : array of (ref Hash,string);
+ i,tag,lev: int;
+ (name,index)=str->splitl(s,"(");
+ if (index!=nil){
+ (index,rest)=str->splitl(index[1:],")");
+ if (rest!=")")
+ return (nil,"bad variable name");
+ }
+ (tag,lev,name) = isa(name);
+ case tag {
+ TCL_SIMPLE =>
+ if (index!=nil)
+ return (nil,"variable isn't array");
+ (tnv,nil,nil)=stack->examine(lev);
+ return (tnv,name);
+ TCL_ARRAY =>
+ if (index==nil)
+ return (nil,"variable is array");
+ (nil,tav,nil)=stack->examine(lev);
+ for(i=0;i<len tav;i++){
+ (retval,rest)=tav[i];
+ if (rest==name)
+ return (retval,index);
+ }
+ return (nil,"find_var: impossible!!");
+ # if we get here, the variable needs to be
+ # created.
+ TCL_UNKNOWN =>
+ if (!create)
+ return (nil,"no such variable");
+ (tnv,tav,nil)=stack->examine(lev);
+ if (index==nil)
+ return (tnv,name);
+
+ }
+ # if we get here, we are creating an associative variable in the
+ # tav array.
+ for(i=0;i<len tav;i++){
+ (retval,rest)=tav[i];
+ if (rest==nil){
+ retval=htab->alloc(101);
+ tav[i]=(retval,name);
+ return (retval,index);
+ }
+ }
+ return (nil,"associative array table full!");
+}
+
+# the main parsing function, a la ousterhouts man pages. Takes a
+# string that is meant to be a tcl statement and parses it,
+# reevaluating and quoting upto the termchar character. If disable
+# is true, then whitespace is not ignored.
+parsecmd(s: string, termchar,disable: int) : array of string {
+ argv:= array[200] of string;
+ buf,nm,id: string;
+ argc := 0;
+ nc := 0;
+ c :=0;
+ tab : ref Hash;
+
+ if (disable && (termchar=='\n' || termchar==';')) termchar=0;
+ outer:
+ for (i := 0; i<len s ;) {
+ if ((i>0 &&s[i-1]!='\\' &&s[i]==termchar)||(s[0]==termchar))
+ break;
+ case int s[i] {
+ ' ' or '\t' or '\n' =>
+ if (!disable){
+ if (nc > 0) { # end of a word?
+ argv[argc++] = buf;
+ buf = nil;
+ nc = 0;
+ }
+ i++;
+ }
+ else
+ buf[nc++]=s[i++];
+ '$' =>
+ if (i>0 && s[i-1]=='\\')
+ buf[nc++]=s[i++];
+ else {
+ (nm,id) = parsename(s[i+1:], termchar);
+ if (id!=nil)
+ nm=nm+"("+id+")";
+ (tab,nm)=find_var(nm,0); #don't create var!
+ if (len nm > 0 && tab!=nil) {
+ (found, val) := tab.find(nm);
+ buf += val;
+ nc += len val;
+ #sys->print("Here s[i:] is (%s)\n",s[i:]);
+ if(nm==id)
+ while(s[i]!=')') i++;
+ else
+ if (s[i+1]=='{')
+ while(s[i]!='}') i++;
+ else
+ i += len nm;
+ if (nc==0 && (i==len s-1 ||
+ s[i+1]==' ' ||
+ s[i+1]=='\t'||
+ s[i+1]==termchar))
+ argv[argc++]=buf;
+ } else {
+ buf[nc++] = '$';
+ }
+ i++;
+ }
+ '{' =>
+ if (i>0 && s[i-1]=='\\')
+ buf[nc++]=s[i++];
+ else if (s[i+1]=='}'){
+ argv[argc++] = nil;
+ buf = nil;
+ nc = 0;
+ i+=2;
+ } else {
+ nbra := 1;
+ for (i++; i < len s; i++) {
+ if (s[i] == '{')
+ nbra++;
+ else if (s[i] == '}') {
+ nbra--;
+ if (nbra == 0) {
+ i++;
+ continue outer;
+ }
+ }
+ buf[nc++] = s[i];
+ }
+ }
+ '[' =>
+ if (i>0 && s[i-1]=='\\')
+ buf[nc++]=s[i++];
+ else{
+ a:=evalcmd(s[i+1:],']');
+ if (error)
+ return nil;
+ if (nc>0){
+ buf+=a;
+ nc += len a;
+ } else {
+ argv[argc++] = a;
+ buf = nil;
+ nc = 0;
+ }
+ i++;
+ i=strip_to_match(s[i:],i);
+ i++;
+ }
+ '"' =>
+ if (i>0 && s[i-1]!='\\' && nc==0){
+ ans:=parsecmd(s[i+1:],'"',1);
+ #sys->print("len ans is %d\n",len ans);
+ if (len ans!=0){
+ for(;;){
+ i++;
+ if(s[i]=='"' &&
+ s[i-1]!='\\')
+ break;
+ }
+ i++;
+ argv[argc++] = ans[0];
+ } else {
+ argv[argc++] = nil;
+ i+=2;
+ }
+ buf = nil;
+ nc = 0;
+ }
+ else buf[nc++] = s[i++];
+ * =>
+ if (s[i]=='\\'){
+ c=unesc(s[i:]);
+ if (c!=0){
+ buf[nc++] = c;
+ i+=2;
+ } else {
+ if (i+1 < len s && !(s[i+1]=='"'
+ || s[i+1]=='$' || s[i+1]=='{'
+ || s[i+1]=='['))
+ buf[nc++]=s[i];
+ i++;
+ }
+ c=0;
+ } else
+ buf[nc++]=s[i++];
+ }
+ }
+ if (nc > 0) # fix up last word if present
+ argv[argc++] = buf;
+ ret := array[argc] of string;
+ ret[0:] = argv[0:argc];
+ return ret;
+}
+
+# parses a name by Tcl rules, a valid name is either $foo, $foo(bar)
+# or ${foo}.
+parsename(s: string, termchar: int) : (string,string) {
+ ret,arr,rest: string;
+ rets : array of string;
+ if (len s == 0)
+ return (nil,nil);
+ if (s[0]=='{'){
+ (ret,nil)=str->splitl(s,"}");
+ #sys->print("returning [%s]\n",ret[1:]);
+ return (ret[1:],nil);
+ }
+ loop: for (i := 0; i < len s && s[i] != termchar; i++) {
+ case (s[i]) {
+ 'a' to 'z' or 'A' to 'Z' or '0' to '9' or '_' =>
+ ret[i] = s[i];
+ * =>
+ break loop;
+ '(' =>
+ arr=ret[0:i];
+ rest=s[i+1:];
+ rets=parsecmd(rest,')',0);
+ # should always be len 1?
+ if (len rets >1)
+ sys->print("len rets>1 in parsename!\n");
+ return (arr,rets[0]);
+ }
+ }
+ return (ret,nil);
+}
+
+loadfile(file :string) : string {
+ iob : ref Iobuf;
+ msg,input,line : string;
+ if (file==nil)
+ return nil;
+ iob = bufmod->open(file,bufmod->OREAD);
+ if (iob==nil)
+ return notify(0,sys->sprint(
+ "couldn't read file \"%s\":%r",file));
+ while((input=iob.gets('\n'))!=nil){
+ line+=input;
+ if (finished(line,0)){
+ # put in a return catch here...
+ line = prepass(line);
+ msg=evalcmd(line,0);
+ if (error) return errmsg;
+ line=nil;
+ }
+ }
+ return msg;
+}
+
+
+#unescapes a string. Can do better.....
+unesc(s: string) : int {
+ c: int;
+ if (len s == 1) return 0;
+ case s[1] {
+ 'a'=> c = '\a';
+ 'n'=> c = '\n';
+ 't'=> c = '\t';
+ 'r'=> c = '\r';
+ 'b'=> c = '\b';
+ '\\'=> c = '\\';
+ '}' => c = '}';
+ ']' => c=']';
+ # do hex and octal.
+ * => c = 0;
+ }
+ return c;
+}
+
+# prepass a string and replace "\\n[ \t]*" with ' '
+prepass(s : string) : string {
+ for(i := 0; i < len s; i++) {
+ if(s[i] != '\\')
+ continue;
+ j:=i;
+ if (s[i+1] == '\n') {
+ s[j]=' ';
+ i++;
+ while(i<len s && (s[i]==' ' || s[i]=='\t'))
+ i++;
+ if (i==len s)
+ s = s[0:j];
+ else
+ s=s[0:j]+s[i+1:];
+ i=j;
+ }
+ }
+ return s;
+}
+
+exec(argv : array of string) : string {
+ msg : string;
+ if (argv[0]=="")
+ return nil;
+ case (argv[0]) {
+ "append" =>
+ msg= do_append(argv);
+ "array" =>
+ msg= do_array(argv);
+ "break" or "continue" =>
+ return argv[0];
+ "catch" =>
+ msg=do_catch(argv);
+ "debug" =>
+ msg=do_debug(argv);
+ "dumpstack" =>
+ msg=do_dumpstack(argv);
+ "exit" =>
+ do_exit();
+ "expr" =>
+ msg = do_expr(argv);
+ "eval" =>
+ msg = do_eval(argv);
+ "for" =>
+ msg = do_for(argv);
+ "foreach" =>
+ msg = do_foreach(argv);
+ "format" =>
+ msg = do_string(argv);
+ "global" =>
+ msg = do_global(argv);
+ "if" =>
+ msg = do_if(argv);
+ "incr" =>
+ msg = do_incr(argv);
+ "info" =>
+ msg = do_info(argv);
+ "lappend" =>
+ msg = do_lappend(argv);
+ "level" =>
+ msg=sys->sprint("Current Stack "+
+ "level is %d",
+ stack->level());
+ "load" =>
+ msg=do_load(argv);
+ "proc" =>
+ msg=do_proc(argv);
+ "return" =>
+ msg=do_return(argv);
+ retfl =1;
+ "set" =>
+ msg = do_set(argv);
+ "source" =>
+ msg = do_source(argv);
+ "string" =>
+ msg = do_string(argv);
+ "switch" =>
+ msg = do_switch(argv);
+ "time" =>
+ msg=do_time(argv);
+ "unset" =>
+ msg = do_unset(argv);
+ "uplevel" =>
+ msg=do_uplevel(argv);
+ "upvar" =>
+ msg=do_upvar(argv);
+ "while" =>
+ msg = do_while(argv);
+ "#" =>
+ msg=nil;
+ * =>
+ msg = uproc(argv);
+ }
+ return msg;
+}
+
+# from here on is the list of commands, alpahabetised, we hope.
+
+do_append(argv :array of string) : string {
+ tab : ref Hash;
+ if (len argv==1 || len argv==2)
+ return notify(1,
+ "append varName value ?value ...?");
+ name := argv[1];
+ (tab,name)=find_var(name,1);
+ if (tab==nil)
+ return notify(0,name);
+ (found, val) := tab.find(name);
+ for (i:=2;i<len argv;i++)
+ val+=argv[i];
+ tab.insert(name,val);
+ return val;
+}
+
+do_array(argv : array of string) : string {
+ tab : ref Hash;
+ name : string;
+ flag : int;
+ if (len argv!=3)
+ return notify(1,"array [names, size] name");
+ case argv[1] {
+ "names" =>
+ flag=1;
+ "size" =>
+ flag=0;
+ * =>
+ return notify(0,"expexted names or size, got "+argv[1]);
+
+ }
+ (tag,lev,al) := isa(argv[2]);
+ if (tag!=TCL_ARRAY)
+ return notify(0,argv[2]+" isn't an array");
+ (nil,tav,nil):=stack->examine(lev);
+ for (i:=0;i<len tav;i++){
+ (tab,name)=tav[i];
+ if (name==al) break;
+ }
+ if (flag==0)
+ return string tab.lsize;
+ return tab.dump();
+}
+
+do_catch(argv : array of string) : string {
+ if (len argv==1 || len argv > 3)
+ return notify(1,"catch command ?varName?");
+ msg:=evalcmd(argv[1],0);
+ if (len argv==3 && error){
+ (tab,name):=find_var(argv[2],1);
+ if (tab==nil)
+ return notify(0,name);
+ tab.insert(name, msg);
+ }
+ ret:=string error;
+ error=0;
+ return ret;
+}
+
+do_debug(argv : array of string) : string {
+ add : string;
+ if (len argv!=2)
+ return notify(1,"debug");
+ (i,rest):=str->toint(argv[1],10);
+ if (rest!=nil)
+ return notify(0,"Expected integer and got "+argv[1]);
+ tclmod.debug=i;
+ if (tclmod.debug==0)
+ add="off";
+ else
+ add="on";
+ return "debugging is now "+add+" at level"+ string i;
+}
+
+do_dumpstack(argv : array of string) : string {
+ if (len argv!=1)
+ return notify(1,"dumpstack");
+ stack->dump();
+ return nil;
+}
+
+do_eval(argv : array of string) : string {
+ eval_str : string;
+ for(i:=1;i<len argv;i++){
+ eval_str += argv[i];
+ eval_str[len eval_str]=' ';
+ }
+ return evalcmd(eval_str[0:len eval_str -1],0);
+}
+
+do_exit(){
+ kfd := sys->open("#p/"+string mypid+"/ctl", sys->OWRITE);
+ if(kfd == nil)
+ sys->print("error opening pid %d (%r)\n",mypid);
+ sys->fprint(kfd, "killgrp");
+ exit;
+}
+
+
+
+do_expr(argv : array of string) : string {
+ retval : string;
+ for (i:=1;i<len argv;i++){
+ retval+=argv[i];
+ retval[len retval]=' ';
+ }
+ retval=retval[0: len retval -1];
+ argv=parsecmd(retval,0,0);
+ cal:=lookup("calc");
+ (err,ret):= cal->exec(ref tclmod,argv);
+ if (err) return notify(0,ret);
+ return ret;
+}
+
+
+do_for(argv : array of string) : string {
+ if (len argv!=5)
+ return notify(1,"for start test next command");
+ test := array[] of {"expr",argv[2]};
+ evalcmd(argv[1],0);
+ for(;;){
+ msg:=do_expr(test);
+ if (msg=="Error!")
+ return notify(0,sys->sprint(
+ "syntax error in expression \"%s\"",
+ argv[2]));
+ if (msg=="0")
+ return nil;
+ msg=evalcmd(argv[4],0);
+ if (msg=="break")
+ return nil;
+ if (msg=="continue"); #do nothing!
+ evalcmd(argv[3],0);
+ if (error)
+ return errmsg;
+ }
+}
+
+
+
+do_foreach(argv: array of string) : string{
+ tab : ref Hash;
+ if (len argv!=4)
+ return notify(1,"foreach varName list command");
+ name := argv[1];
+ (tab,name)=find_var(name,1);
+ if (tab==nil)
+ return notify(0,name);
+ arr:=utils->break_it(argv[2]);
+ for(i:=0;i<len arr;i++){
+ tab.insert(name,arr[i]);
+ evalcmd(argv[3],0);
+ }
+ return nil;
+}
+
+
+
+do_global(argv : array of string) : string {
+ if (len argv==1)
+ return notify(1,"global varName ?varName ...?");
+ if (symtab==nil)
+ return nil;
+ for (i:=1 ; i < len argv;i++)
+ symtab.insert(argv[i],argv[i],0);
+ return nil;
+}
+
+
+
+do_if(argv : array of string) : string {
+ if (len argv==1)
+ return notify(1,"no expression after \"if\" argument");
+ expr1 := array[] of {"expr",argv[1]};
+ msg:=do_expr(expr1);
+ if (msg=="Error!")
+ return notify(0,sys->sprint(
+ "syntax error in expression \"%s\"",
+ argv[1]));
+ if (len argv==2)
+ return notify(1,sys->sprint(
+ "no script following \""+
+ "%s\" argument",msg));
+ if (msg=="0"){
+ if (len argv>3){
+ if (argv[3]=="else"){
+ if (len argv==4)
+ return notify(1,
+ "no script"+
+ " following \"else\" argument");
+ return evalcmd(argv[4],0);
+ }
+ if (argv[3]=="elseif"){
+ argv[3]="if";
+ return do_if(argv[3:]);
+ }
+ }
+ return nil;
+ }
+ return evalcmd(argv[2],0);
+}
+
+do_incr(argv :array of string) : string {
+ num,xtra : int;
+ rest :string;
+ tab : ref Hash;
+ if (len argv==1)
+ return notify(1,"incr varName ?increment?");
+ name := argv[1];
+ (tab,name)=find_var(name,0); #doesn't create!!
+ if (tab==nil)
+ return notify(0,name);
+ (found, val) := tab.find(name);
+ if (!found)
+ return notify(0,sys->sprint("can't read \"%s\": "
+ +"no such variable",name));
+ (num,rest)=str->toint(val,10);
+ if (rest!=nil)
+ return notify(0,sys->sprint(
+ "expected integer but got \"%s\"",val));
+ if (len argv == 2){
+ num+=1;
+ tab.insert(name,string num);
+ }
+ if (len argv == 3) {
+ val = argv[2];
+ (xtra,rest)=str->toint(val,10);
+ if (rest!=nil)
+ return notify(0,sys->sprint(
+ "expected integer but got \"%s\""
+ ,val));
+ num+=xtra;
+ tab.insert(name, string num);
+ }
+ return string num;
+}
+
+do_info(argv : array of string) : string {
+ if (len argv==1)
+ return notify(1,"info option ?arg arg ...?");
+ case argv[1] {
+ "args" =>
+ return do_info_args(argv,0);
+ "body" =>
+ return do_info_args(argv,1);
+ "commands" =>
+ return do_info_commands(argv);
+ "exists" =>
+ return do_info_exists(argv);
+ "procs" =>
+ return do_info_procs(argv);
+
+ }
+ return sys->sprint(
+ "bad option \"%s\": should be args, body, commands, exists, procs",
+ argv[1]);
+}
+
+do_info_args(argv : array of string,body :int) : string {
+ name: string;
+ s : sproc;
+ if (body)
+ name="body";
+ else
+ name="args";
+ if (len argv!=3)
+ return notify(1,"info "+name+" procname");
+ for(i:=0;i<len proctab;i++){
+ s=proctab[i];
+ if (s.name==argv[2])
+ break;
+ }
+ if (i==len proctab)
+ return notify(0,argv[2]+" isn't a procedure.");
+ if (body)
+ return s.script;
+ return s.args;
+}
+
+do_info_commands(argv : array of string) : string {
+ if (len argv==1 || len argv>3)
+ return notify(1,"info commands [pattern]");
+ return libmods.dump();
+}
+
+do_info_exists(argv : array of string) : string {
+ name, index : string;
+ tab : ref Hash;
+ if (len argv!=3)
+ return notify(1,"info exists varName");
+ (name,index)=parsename(argv[2],0);
+ (i,nil,nil):=isa(name);
+ if (i==TCL_UNKNOWN)
+ return "0";
+ if (index==nil)
+ return "1";
+ (tab,name)=find_var(argv[2],0);
+ if (tab==nil)
+ return "0";
+ (found, val) := tab.find(name);
+ if (!found)
+ return "0";
+ return "1";
+
+}
+
+do_info_procs(argv : array of string) : string {
+ if (len argv==1 || len argv>3)
+ return notify(1,"info procs [pattern]");
+ retval : string;
+ for(i:=0;i<len proctab;i++){
+ s:=proctab[i];
+ if (s.name!=nil){
+ retval+=s.name;
+ retval[len retval]=' ';
+ }
+ }
+ return retval;
+}
+
+do_lappend(argv : array of string) : string{
+ tab : ref Hash;
+ retval :string;
+ retval=nil;
+ if (len argv==1 || len argv==2)
+ return notify(1,
+ "lappend varName value ?value ...?");
+ name := argv[1];
+ (tab,name)=find_var(name,1);
+ if (tab==nil)
+ return notify(0,name);
+ (found, val) := tab.find(name);
+ for(i:=2;i<len argv;i++){
+ flag:=0;
+ if (spaces(argv[i])) flag=1;
+ if (flag) retval[len retval]='{';
+ retval += argv[i];
+ if (flag) retval[len retval]='}';
+ retval[len retval]=' ';
+ }
+ if (retval!=nil)
+ retval=retval[0:len retval-1];
+ if (val!=nil)
+ retval=val+" "+retval;
+ tab.insert(name,retval);
+ return retval;
+}
+
+spaces(s : string) : int{
+ if (s==nil) return 1;
+ for(i:=0;i<len s;i++)
+ if (s[i]==' ' || s[i]=='\t') return 1;
+ return 0;
+}
+
+do_load(argv : array of string) : string {
+ # look for a dis library to load up, then
+ # add to library array.
+ if (len argv!=2)
+ return notify(1,"load libname");
+ fname:="/dis/lib/tcl_"+argv[1]+".dis";
+ mod:= load TclLib fname;
+ if (mod==nil)
+ return notify(0,
+ sys->sprint("Cannot load %s",fname));
+ arr:=mod->about();
+ for(i:=0;i<len arr;i++)
+ libmods.insert(arr[i],mod);
+ return nil;
+}
+
+
+do_proc(argv : array of string) : string {
+ if (len argv != 4)
+ return notify(1,"proc name args body");
+ for(i:=0;i<len proctab;i++)
+ if (proctab[i].name==nil ||
+ proctab[i].name==argv[1]) break;
+ if (i==len proctab)
+ return notify(0,"procedure table full!");
+ proctab[i].name=argv[1];
+ proctab[i].args=argv[2];
+ proctab[i].script=argv[3];
+ return nil;
+}
+
+do_return(argv : array of string) : string {
+ if (len argv==1)
+ return nil;
+ # put in options here.....
+ return argv[1];
+}
+
+do_set(argv : array of string) : string {
+ tab : ref Hash;
+ if (len argv == 1 || len argv > 3)
+ return notify(1,"set varName ?newValue?");
+ name := argv[1];
+ (tab,name)=find_var(name,1);
+ if (tab==nil)
+ return notify(0,name);
+ (found, val) := tab.find(name);
+ if (len argv == 2)
+ if (!found)
+ val = notify(0,sys->sprint(
+ "can't read \"%s\": "
+ +"no such variable",name));
+ if (len argv == 3) {
+ val = argv[2];
+ tab.insert(name, val);
+ }
+ return val;
+}
+
+do_source(argv : array of string) : string {
+ if (len argv !=2)
+ return notify(1,"source fileName");
+ return loadfile(argv[1]);
+}
+
+do_string(argv : array of string) : string {
+ stringmod := lookup("string");
+ if (stringmod==nil)
+ return notify(0,sys->sprint(
+ "String Package not loaded (%r)"));
+ (err,retval):= stringmod->exec(ref tclmod,argv);
+ if (err) return notify(0,retval);
+ return retval;
+}
+
+do_switch(argv : array of string) : string {
+ i:=0;
+ arr : array of string;
+ if (len argv < 3)
+ return notify(1,"switch "
+ +"?switches? string pattern body ... "+
+ "?default body?\"");
+ if (len argv == 3)
+ arr=utils->break_it(argv[2]);
+ else
+ arr=argv[2:];
+ if (len arr % 2 !=0)
+ return notify(0,
+ "extra switch pattern with no body");
+ for (i=0;i<len arr;i+=2)
+ if (argv[1]==arr[i])
+ break;
+ if (i==len arr){
+ if (arr[i-2]=="default")
+ return evalcmd(arr[i-1],0);
+ else return nil;
+ }
+ while (i<len arr && arr[i+1]=="-") i+=2;
+ return evalcmd(arr[i+1],0);
+}
+
+do_time(argv : array of string) : string {
+ rest : string;
+ end,start,times : int;
+ if (len argv==1 || len argv>3)
+ return notify(1,"time command ?count?");
+ if (len argv==2)
+ times=1;
+ else{
+ (times,rest)=str->toint(argv[2],10);
+ if (rest!=nil)
+ return notify(0,sys->sprint(
+ "expected integer but got \"%s\"",argv[2]));
+ }
+ start=sys->millisec();
+ for(i:=0;i<times;i++)
+ evalcmd(argv[1],0);
+ end=sys->millisec();
+ r:= (real end - real start) / real times;
+ return sys->sprint("%g milliseconds per iteration", r);
+}
+
+do_unset(argv : array of string) : string {
+ tab : ref Hash;
+ name: string;
+ if (len argv == 1)
+ return notify(1,"unset "+
+ "varName ?varName ...?");
+ for(i:=1;i<len argv;i++){
+ name = argv[i];
+ (tab,name)=find_var(name,0);
+ if (tab==nil)
+ return notify(0,sys->sprint("can't unset \"%s\": no such" +
+ " variable",name));
+ tab.delete(name);
+
+ }
+ return nil;
+}
+
+do_uplevel(argv : array of string) : string {
+ level: int;
+ rest,scr : string;
+ scr=nil;
+ exact:=0;
+ i:=1;
+ if (len argv==1)
+ return notify(1,"uplevel ?level? command ?arg ...?");
+ if (len argv==2)
+ level=-1;
+ else {
+ lev:=argv[1];
+ if (lev[0]=='#'){
+ exact=1;
+ lev=lev[1:];
+ }
+ (level,rest)=str->toint(lev,10);
+ if (rest!=nil){
+ i=2;
+ level =-1;
+ }
+ }
+ oldlev:=stack->level();
+ if (!exact)
+ level+=oldlev;
+ (tnv,tav,sym):=stack->examine(level);
+ if (tnv==nil && tav==nil)
+ return notify(0,"bad level "+argv[1]);
+ if (tclmod.debug==2)
+ sys->print("In uplevel, current level is %d, moving to level %d\n",
+ oldlev,level);
+ stack->move(level);
+ oldav:=avtab;
+ oldnv:=nvtab;
+ oldsym:=symtab;
+ avtab=tav;
+ nvtab=tnv;
+ symtab=sym;
+ for(;i<len argv;i++)
+ scr=scr+argv[i]+" ";
+ msg:=evalcmd(scr[0:len scr-1],0);
+ avtab=oldav;
+ nvtab=oldnv;
+ symtab=oldsym;
+ ok:=stack->move(oldlev);
+ if (tclmod.debug==2)
+ sys->print("Leaving uplevel, current level is %d, moving back to"+
+ " level %d,move was %d\n",
+ level,oldlev,ok);
+ return msg;
+}
+
+do_upvar(argv : array of string) : string {
+ level:int;
+ rest:string;
+ i:=1;
+ exact:=0;
+ if (len argv<3 || len argv>4)
+ return notify(1,"upvar ?level? ThisVar OtherVar");
+ if (len argv==3)
+ level=-1;
+ else {
+ lev:=argv[1];
+ if (lev[0]=='#'){
+ exact=1;
+ lev=lev[1:];
+ }
+ (level,rest)=str->toint(lev,10);
+ if (rest!=nil){
+ i=2;
+ level =-1;
+ }
+ }
+ if (!exact)
+ level+=stack->level();
+ symtab.insert(argv[i],argv[i+1],level);
+ return nil;
+}
+
+do_while(argv : array of string) : string {
+ if (len argv!=3)
+ return notify(1,"while test command");
+ for(;;){
+ expr1 := array[] of {"expr",argv[1]};
+ msg:=do_expr(expr1);
+ if (msg=="Error!")
+ return notify(0,sys->sprint(
+ "syntax error in expression \"%s\"",
+ argv[1]));
+ if (msg=="0")
+ return nil;
+ evalcmd(argv[2],0);
+ if (error)
+ return errmsg;
+ }
+}
+
+uproc(argv : array of string) : string {
+ cmd,add : string;
+ for(i:=0;i< len proctab;i++)
+ if (proctab[i].name==argv[0])
+ break;
+ if (i==len proctab)
+ return notify(0,sys->sprint("invalid command name \"%s\"",
+ argv[0]));
+ # save tables
+ # push a newframe
+ # bind args to arguments
+ # do cmd
+ # pop frame
+ # return msg
+
+ # globals are supported, but upvar and uplevel are not!
+
+ arg_arr:=utils->break_it(proctab[i].args);
+ j:=len arg_arr;
+ if (len argv < j+1 && arg_arr[j-1]!="args"){
+ j=len argv-1;
+ return notify(0,sys->sprint(
+ "no value given for"+
+ " parameter \"%s\" to \"%s\"",
+ arg_arr[j],proctab[i].name));
+ }
+ if ((len argv > j+1) && arg_arr[j-1]!="args")
+ return notify(0,"called "+proctab[i].name+
+ " with too many arguments");
+ oldavtab:=avtab;
+ oldnvtab:=nvtab;
+ oldsymtab:=symtab;
+ (nvtab,avtab,symtab)=stack->newframe();
+ for (j=0;j< len arg_arr-1;j++){
+ cmd="set "+arg_arr[j]+" {"+argv[j+1]+"}";
+ evalcmd(cmd,0);
+ }
+ if (len arg_arr>j && arg_arr[j] != "args") {
+ cmd="set "+arg_arr[j]+" {"+argv[j+1]+"}";
+ evalcmd(cmd,0);
+ }
+ else {
+ if (len arg_arr > j) {
+ if (j+1==len argv)
+ add="";
+ else
+ add=argv[j+1];
+ cmd="set "+arg_arr[j]+" ";
+ arglist:="{"+add+" ";
+ j++;
+ while(j<len argv-1) {
+ arglist+=argv[j+1];
+ arglist[len arglist]=' ';
+ j++;
+ }
+ arglist[len arglist]='}';
+ cmd+=arglist;
+ evalcmd(cmd,0);
+ }
+ }
+ msg:=evalcmd(proctab[i].script,0);
+ stack->pop();
+ avtab=oldavtab;
+ nvtab=oldnvtab;
+ symtab=oldsymtab;
+ #sys->print("Error is %d, msg is %s\n",error,msg);
+ return msg;
+}
+
+do_tk(argv : array of string) : string {
+ tkpack:=lookup("button");
+ (err,retval):= tkpack->exec(ref tclmod,argv);
+ if (err) return notify(0,retval);
+ return retval;
+}
+
+
+lookup(s : string) : TclLib {
+ (found,mod):=libmods.find(s);
+ if (!found)
+ return nil;
+ return mod;
+}
generated by cgit v1.2.3 (git 2.46.0) at 2025-12-10 11:45:27 +0000