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;				}

Lines 1–500 of 1397. Load more