diff options
Diffstat (limited to 'appl/lib/tcl_list.b')
| -rw-r--r-- | appl/lib/tcl_list.b | 335 |
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; + } +} + |