00001
00002
00003
00004
00005
00006 static char *rcsid="@(#)$Id$";
00007 #include <ctype.h>
00008 #include "eus.h"
00009
00010 pointer EUSCHAR(ctx,n,argv)
00011 register context *ctx;
00012 register int n;
00013 register pointer argv[];
00014 { register pointer a=argv[0];
00015 ckarg(2);
00016 n=ckintval(argv[1]);
00017 if (!isstring(a)) error(E_NOSTRING);
00018 if (n<0 || vecsize(a)<=n) error(E_ARRAYINDEX);
00019
00020
00021
00022
00023
00024 return(makeint(a->c.str.chars[n]));}
00025
00026 pointer SETCHAR(ctx,n,argv)
00027 register context *ctx;
00028 register int n;
00029 register pointer argv[];
00030 { register pointer a=argv[0];
00031 register int newval=ckintval(argv[2]);
00032 ckarg(3);
00033 n=ckintval(argv[1]);
00034 if (!isstring(a)) error(E_NOSTRING);
00035 if (n<0 || vecsize(a)<=n) error(E_ARRAYINDEX);
00036
00037
00038
00039 a->c.str.chars[n]=newval;
00040 return(argv[2]);}
00041
00042 pointer UPCASEP(ctx,n,argv)
00043 register context *ctx;
00044 register int n;
00045 register pointer argv[];
00046 { ckarg(1); n=ckintval(argv[0]);
00047 return((isupper(n))?T:NIL);}
00048
00049 pointer LOWCASEP(ctx,n,argv)
00050 register context *ctx;
00051 register int n;
00052 register pointer argv[];
00053 { ckarg(1); n=ckintval(argv[0]);
00054 return((islower(n))?T:NIL);}
00055
00056 pointer ALPHAP(ctx,n,argv)
00057 register context *ctx;
00058 register int n;
00059 pointer argv[];
00060 { ckarg(1); n=ckintval(argv[0]);
00061 return((isalpha(n))?T:NIL);}
00062
00063 pointer DIGITP(ctx,n,argv)
00064 register context *ctx;
00065 register int n;
00066 pointer argv[];
00067 { ckarg(1); n=ckintval(argv[0]);
00068 return((isdigit(n))?T:NIL);}
00069
00070 pointer ALNUMP(ctx,n,argv)
00071 register context *ctx;
00072 register int n;
00073 register pointer argv[];
00074 { ckarg(1); n=ckintval(argv[0]);
00075 return((isalnum(n))?T:NIL);}
00076
00077 pointer CHUPCASE(ctx,n,argv)
00078 register context *ctx;
00079 register int n;
00080 pointer argv[];
00081 { ckarg(1); n=ckintval(argv[0]);
00082 return((islower(n))?(makeint(toupper(n))):argv[0]);}
00083
00084 pointer CHDOWNCASE(ctx,n,argv)
00085 register context *ctx;
00086 register int n;
00087 pointer argv[];
00088 { ckarg(1); n=ckintval(argv[0]);
00089 return((isupper(n))?(makeint(tolower(n))):argv[0]);}
00090
00091 pointer STRINGEQ(ctx,n,argv)
00092 register context *ctx;
00093 int n;
00094 register pointer argv[];
00095 { register byte *str1, *str2;
00096 int start1,end1,start2,end2;
00097 register int len;
00098 pointer s1=Getstring(argv[0]), s2=Getstring(argv[1]);
00099 ckarg(6);
00100 start1=ckintval(argv[2]); end1=ckintval(argv[3]);
00101 end1=min(end1,vecsize(s1));
00102 start2=ckintval(argv[4]); end2=ckintval(argv[5]);
00103 end2=min(end2,vecsize(s2));
00104 len=end1-start1;
00105 if (len!=end2-start2) return(NIL);
00106 str1= &s1->c.str.chars[start1]; str2= &s2->c.str.chars[start2];
00107 while (len-->0) if (*str1++ != *str2++) return(NIL);
00108 return(T);}
00109
00110 pointer STRINGEQUAL(ctx,n,argv)
00111 register context *ctx;
00112 int n;
00113 register pointer argv[];
00114 { register byte *str1, *str2;
00115 int start1,end1,start2,end2,ch1,ch2;
00116 pointer s1=Getstring(argv[0]),s2=Getstring(argv[1]);
00117 register int len;
00118 ckarg(6);
00119 start1=ckintval(argv[2]); end1=ckintval(argv[3]); end1=min(end1,vecsize(s1));
00120 start2=ckintval(argv[4]); end2=ckintval(argv[5]); end2=min(end2,vecsize(s2));
00121 len=end1-start1;
00122 if (len!=end2-start2) return(NIL);
00123 str1= &s1->c.str.chars[start1]; str2= &s2->c.str.chars[start2];
00124 while (len-->0) {
00125 ch1= *str1++; ch2= *str2++;
00126 if (islower(ch1)) ch1=toupper(ch1);
00127 if (islower(ch2)) ch2=toupper(ch2);
00128 if (ch1!=ch2) return(NIL);}
00129 return(T);}
00130
00131
00132
00133
00134
00135
00136 #define eusstrcmp(a,b) strcmp((char *)(a), (char *)(b))
00137
00138 pointer STR_LT(ctx,n,argv)
00139 register context *ctx;
00140 int n;
00141 register pointer argv[];
00142 { ckarg(2);
00143 if (eusstrcmp(get_string(argv[0]),get_string(argv[1]))<0) return(T);
00144 else return(NIL);}
00145
00146 pointer STR_LE(ctx,n,argv)
00147 register context *ctx;
00148 int n;
00149 register pointer argv[];
00150 { ckarg(2);
00151 if (eusstrcmp(get_string(argv[0]),get_string(argv[1]))<=0) return(T);
00152 else return(NIL);}
00153
00154 pointer STR_EQ(ctx,n,argv)
00155 register context *ctx;
00156 int n;
00157 register pointer argv[];
00158 { ckarg(2);
00159 if (eusstrcmp(get_string(argv[0]),get_string(argv[1]))==0) return(T);
00160 else return(NIL);}
00161
00162 pointer STR_GT(ctx,n,argv)
00163 register context *ctx;
00164 int n;
00165 register pointer argv[];
00166 { ckarg(2);
00167 if (eusstrcmp(get_string(argv[0]),get_string(argv[1]))>0) return(T);
00168 else return(NIL);}
00169
00170 pointer STR_GE(ctx,n,argv)
00171 register context *ctx;
00172 int n;
00173 register pointer argv[];
00174 { ckarg(2);
00175 if (eusstrcmp(get_string(argv[0]),get_string(argv[1]))>=0) return(T);
00176 else return(NIL);}
00177
00178
00179
00180 void charstring(ctx,mod)
00181 register context *ctx;
00182 register pointer mod;
00183 {
00184 defun(ctx,"CHAR",mod,EUSCHAR);
00185 defun(ctx,"SCHAR",mod,EUSCHAR);
00186 defun(ctx,"SETCHAR",mod,SETCHAR);
00187 defun(ctx,"ALPHA-CHAR-P",mod,ALPHAP);
00188 defun(ctx,"UPPER-CASE-P",mod,UPCASEP);
00189 defun(ctx,"LOWER-CASE-P",mod,LOWCASEP);
00190 defun(ctx,"DIGIT-CHAR-P",mod,DIGITP);
00191 defun(ctx,"ALPHANUMERICP",mod,ALNUMP);
00192 defun(ctx,"CHAR-UPCASE",mod,CHUPCASE);
00193 defun(ctx,"CHAR-DOWNCASE",mod,CHDOWNCASE);
00194 defun(ctx,"STRINGEQ",mod,STRINGEQ);
00195 defun(ctx,"STRINGEQUAL",mod,STRINGEQUAL);
00196 defun(ctx,"STRING<",mod,STR_LT);
00197 defun(ctx,"STRING<=",mod,STR_LE);
00198 defun(ctx,"STRING=",mod,STR_EQ);
00199 defun(ctx,"STRING>",mod,STR_GT);
00200 defun(ctx,"STRING>=",mod,STR_GE);
00201
00202 }
00203