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


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