charstring.c
Go to the documentation of this file.
00001 /****************************************************************
00002 /* CHARACTER and STRING functions
00003 /*      1987-Dec-17
00004 /*      Copyright(c) Toshihiro MATSUI, ETL, 1988.
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 /* This code should be eliminated, because the compiler cannot know if
00020    this object is a normal string or a foreign string, thus no optimization.
00021   if (elmtypeof(a)==ELM_FOREIGN) 
00022     return(makeint((a->c.foreign.chars)[n]));
00023   else */
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 /*  if (elmtypeof(a)==ELM_FOREIGN) 
00037     ((byte *)(a->c.ivec.iv[0]))[n]=newval;
00038   else */
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 /* S T R I N G  compare
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 /* initializers */
00179 
00180 void charstring(ctx,mod)
00181 register context *ctx;
00182 register pointer mod;
00183 {
00184   defun(ctx,"CHAR",mod,EUSCHAR,NULL);
00185   defun(ctx,"SCHAR",mod,EUSCHAR,NULL);
00186   defun(ctx,"SETCHAR",mod,SETCHAR,NULL);
00187   defun(ctx,"ALPHA-CHAR-P",mod,ALPHAP,NULL);
00188   defun(ctx,"UPPER-CASE-P",mod,UPCASEP,NULL);
00189   defun(ctx,"LOWER-CASE-P",mod,LOWCASEP,NULL);
00190   defun(ctx,"DIGIT-CHAR-P",mod,DIGITP,NULL);
00191   defun(ctx,"ALPHANUMERICP",mod,ALNUMP,NULL);
00192   defun(ctx,"CHAR-UPCASE",mod,CHUPCASE,NULL);
00193   defun(ctx,"CHAR-DOWNCASE",mod,CHDOWNCASE,NULL);
00194   defun(ctx,"STRINGEQ",mod,STRINGEQ,NULL);
00195   defun(ctx,"STRINGEQUAL",mod,STRINGEQUAL,NULL);
00196   defun(ctx,"STRING<",mod,STR_LT,NULL);
00197   defun(ctx,"STRING<=",mod,STR_LE,NULL);
00198   defun(ctx,"STRING=",mod,STR_EQ,NULL);
00199   defun(ctx,"STRING>",mod,STR_GT,NULL);
00200   defun(ctx,"STRING>=",mod,STR_GE,NULL);
00201   
00202   }
00203 


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 6 2019 18:05:53