ref: f4624471579e0cfb531ffc733cdbe007ecdfed9d
dir: /appl/lib/tcl_list.b/
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;
}
}