20060303a

1 files changed, 335 insertions, 0 deletions

diff --git a/appl/lib/tcl_list.b b/appl/lib/tcl_list.b
new file mode 100644
index 00000000..9ef281d1
--- /dev/null
+++ b/appl/lib/tcl_list.b
@@ -0,0 +1,335 @@
+implement TclLib;
+
+include "sys.m";
+	sys: Sys;
+include "draw.m";
+include "tk.m";
+include "bufio.m";
+	bufmod : Bufio;
+Iobuf : import bufmod;
+
+include "string.m";
+	str : String;
+
+include "tcl.m";
+include "tcllib.m";
+
+include "utils.m";
+	utils : Tcl_Utils;
+
+
+error : int;
+
+DEF,DEC,INT : con iota;
+valid_commands:= array[] of {
+		"concat" , 
+		"join" , 
+		"lindex" , 
+		"linsert" , 
+		"list" , 
+		"llength" ,
+		"lrange" , 
+		"lreplace" , 
+		"lsearch" , 
+		"lsort" , 
+		"split"
+};
+
+about() : array of string {
+	return valid_commands;
+}
+
+exec(tcl : ref Tcl_Core->TclData,argv : array of string) : (int,string) {
+	if (tcl.context==nil);
+	str = load String String->PATH;
+	sys = load Sys Sys->PATH;
+	utils = load Tcl_Utils Tcl_Utils->PATH;
+	if (str==nil || utils==nil)
+		return (1,"Can't load modules\n");
+	case argv[0] {
+		"concat" => 
+			return (error,do_concat(argv,0));					
+		"join" => 
+			return (error,do_join(argv));
+		"lindex" => 
+			return (error,do_lindex(argv));		 
+		"linsert" => 
+			return (error,do_linsert(argv));
+		"list" => 
+			return (error,do_concat(argv,1));
+		"llength" =>
+			return (error,do_llength(argv));					
+		"lrange" => 
+			return (error,do_lrange(argv));
+		"lreplace" => 
+			return (error,do_lreplace(argv));
+		"lsearch" => 
+			return (error,do_lsearch(argv));
+		"lsort" => 
+			return (error,do_lsort(argv));
+		"split" =>
+			return (error,do_split(argv));
+	}
+	return (1,nil);
+}
+
+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;
+}
+	
+
+sort(a: array of string, key: int): array of string {
+	m: int;
+	n := len a;
+	for(m = n; m > 1; ) {
+		if(m < 5)
+			m = 1;
+		else
+			m = (5*m-1)/11;
+		for(i := n-m-1; i >= 0; i--) {
+			tmp := a[i];
+			for(j := i+m; j <= n-1 && greater(tmp, a[j], key); j += m)
+				a[j-m] = a[j];
+			a[j-m] = tmp;
+		}
+	}
+	return a;
+}
+
+greater(x, y: string, sortkey: int): int {
+	case (sortkey) {
+	DEF => return(x > y);
+	DEC => return(x < y);
+	INT => return(int x > int y);
+	}
+	return 0;
+}
+
+# from here on are the commands in alphabetical order...
+
+# turns an array into a string with spaces between the elements.
+# in braces is non-zero, the elements will be enclosed in braces.
+do_concat(argv : array of string, braces : int) : string {
+	retval :string;
+	retval=nil;
+	for(i:=1;i<len argv;i++){
+		flag:=0;
+		if (spaces(argv[i])) flag=1;
+		if (braces && flag) retval[len retval]='{';
+		retval += argv[i];
+		if (braces && flag) retval[len retval]='}';
+		retval[len retval]=' ';
+	}
+	if (retval!=nil)
+		retval=retval[0:len retval-1];
+	return retval;
+}
+
+do_join(argv : array of string) : string {
+	retval : string;
+	if (len argv ==1 || len argv >3)
+		return notify(1,"join list ?joinString?");
+	if (len argv == 2) 
+		return argv[1];
+	if (argv[1]==nil) return nil;
+	arr := utils->break_it(argv[1]);
+	for (i:=0;i<len arr;i++){
+		retval+=arr[i];
+		if (i!=len arr -1)
+			retval+=argv[2];
+	}
+	return retval;
+}
+
+do_lindex(argv : array of string) : string {
+	if (len argv != 3)
+		return notify(1,"lindex list index");
+	(num,rest):=str->toint(argv[2],10);
+	if (rest!=nil)
+		return notify(2,argv[2]);
+	arr:=utils->break_it(argv[1]);
+	if (num>=len arr)
+		return nil;
+	return arr[num];
+}
+
+do_linsert(argv : array of string) : string {
+	if (len argv < 4){
+		return notify(1,
+			"linsert list index element ?element ...?");
+	}
+	(num,rest):=str->toint(argv[2],10);
+	if (rest!=nil)
+		return notify(2,argv[2]);
+	arr:=utils->break_it(argv[1]);
+	narr := array[len arr + len argv - 2] of string;
+	narr[0]="do_concat";
+	if (num==0){
+		narr[1:]=argv[3:];
+		narr[len argv -2:]=arr[0:];
+	}else if (num>= len arr){
+		narr[1:]=arr[0:];
+		narr[len arr+1:]=argv[3:];
+	}else{
+		narr[1:]=arr[0:num];
+		narr[num+1:]=argv[3:];
+		narr[num+len argv -2:]=arr[num:];
+	}
+	return do_concat(narr,1);
+}
+
+do_llength(argv : array of string) : string {
+	if (len argv !=2){
+		return notify(1,"llength list");
+	}
+	arr:=utils->break_it(argv[1]);
+	return string len arr;
+}
+
+do_lrange(argv :array of string) : string {
+	beg,end : int;
+	rest : string;
+	if (len argv != 4)
+		return notify(1,"lrange list first last");
+	(beg,rest)=str->toint(argv[2],10);
+	if (rest!=nil)
+		return notify(2,argv[2]);
+	(end,rest)=str->toint(argv[3],10);
+	if (rest!=nil)
+		return notify(2,argv[3]);
+	if (beg <0) beg=0;
+	if (end < 0) return nil;
+	if (beg > end) return nil;
+	arr:=utils->break_it(argv[1]);
+	if (beg>len arr) return nil;
+	narr:=array[end-beg+2] of string;
+	narr[0]="do_concat";
+	narr[1:]=arr[beg:end+1];
+	return do_concat(narr,1);
+}
+
+do_lreplace(argv : array of string) : string {
+	beg,end : int;
+	rest : string;
+	if (len argv < 3)
+		return notify(1,"lreplace list "+
+			"first last ?element element ...?");
+	arr:=utils->break_it(argv[1]);
+	(beg,rest)=str->toint(argv[2],10);
+	if (rest!=nil)
+		return notify(2,argv[2]);
+	(end,rest)=str->toint(argv[3],10);
+	if (rest!=nil)
+		return notify(2,argv[3]);
+	if (beg <0) beg=0;
+	if (end < 0) return nil;
+	if (beg > end) 
+		return notify(0,
+		       "first index must not be greater than second");
+	if (beg>len arr) 
+		return notify(1,
+			"list doesn't contain element "+string beg);
+	narr:=array[len arr-(end-beg+1)+len argv - 3] of string;
+	narr[1:]=arr[0:beg];
+	narr[beg+1:]=argv[4:];
+	narr[beg+1+len argv-4:]=arr[end+1:];
+	narr[0]="do_concat";
+	return do_concat(narr,1);
+}
+
+do_lsearch(argv : array of string) : string {
+	if (len argv!=3) 
+		return notify(1,"lsearch ?mode? list pattern");
+	arr:=utils->break_it(argv[1]);
+	for(i:=0;i<len arr;i++)
+		if (arr[i]==argv[2])
+			return string i;
+	return "-1";
+}
+
+do_lsort(argv : array of string) : string {
+	lis : array of string;
+	key : int;
+	key=DEF;
+	if (len argv == 1) 
+		return notify(1,"lsort ?-ascii? ?-integer? ?-real?"+
+			" ?-increasing? ?-decreasing?"+
+			" ?-command string? list");
+	for(i:=1;i<len argv;i++)
+		if (argv[i][0]=='-')
+			case argv[i]{
+				"-decreasing" =>
+					key = DEC;
+				* =>
+					if (len argv != i+1)
+					return notify(0,sys->sprint(
+					"bad switch \"%s\": must be"+
+					" -ascii, -integer, -real, "+
+					"-increasing -decreasing, or"+
+					" -command" ,argv[i]));
+			}
+	lis=utils->break_it(argv[len argv-1]);
+	arr:=sort(lis,key);
+	narr:= array[len arr+1] of string;
+	narr[0]="list";
+	narr[1:]=arr[0:];
+	return do_concat(narr,1);
+}
+
+
+
+do_split(argv : array of string) : string {
+	arr := array[20] of string;
+	narr : array of string;
+	if (len argv ==1 || len argv>3)
+		return notify(1,"split string ?splitChars?");
+	if (len argv == 2)
+		return argv[1];
+	s:=argv[1];
+	if (s==nil) return nil;
+	if (argv[2]==nil){
+		arr=array[len s+1] of string;
+		for(i:=0;i<len s;i++)
+			arr[i+1][len arr[i+1]]=s[i];
+		arr[0]="do_concat";
+		return do_concat(arr,1);
+	}
+	i:=1;
+	while(s!=nil){
+		(piece,rest):=str->splitl(s,argv[2]);
+		arr[i]=piece;
+		if (len rest>1)
+			s=rest[1:];
+		if (len rest==1) 
+			s=nil;
+		i++;
+		if (i==len arr){
+			narr=array[i+10] of string;
+			narr[0:]=arr[0:];
+			arr=array[i+10] of string;
+			arr=narr;
+		}
+	}
+	narr = array[i] of string;
+	arr[0]="do_concat";
+	narr = arr[0:i+1];
+	return do_concat(narr,1);
+}
+
+notify(num : int,s : string) : string {
+	error=1;
+	case num{
+		1 =>
+			return sys->sprint(
+			"wrong # args: should be \"%s\"",s);		
+		2 =>
+			return sys->sprint(
+			"expected integer but got \"%s\"",s);
+		* =>
+			return s;
+	}
+}
+