charstring.c
Go to the documentation of this file.
1 /****************************************************************
2 /* CHARACTER and STRING functions
3 /* 1987-Dec-17
4 /* Copyright(c) Toshihiro MATSUI, ETL, 1988.
5 /****************************************************************/
6 static char *rcsid="@(#)$Id$";
7 #include <ctype.h>
8 #include "eus.h"
9 
10 pointer EUSCHAR(ctx,n,argv)
11 register context *ctx;
12 register int n;
13 register pointer argv[];
14 { register pointer a=argv[0];
15  ckarg(2);
16  n=ckintval(argv[1]);
17  if (!isstring(a)) error(E_NOSTRING);
18  if (n<0 || vecsize(a)<=n) error(E_ARRAYINDEX);
19 /* This code should be eliminated, because the compiler cannot know if
20  this object is a normal string or a foreign string, thus no optimization.
21  if (elmtypeof(a)==ELM_FOREIGN)
22  return(makeint((a->c.foreign.chars)[n]));
23  else */
24  return(makeint(a->c.str.chars[n]));}
25 
26 pointer SETCHAR(ctx,n,argv)
27 register context *ctx;
28 register int n;
29 register pointer argv[];
30 { register pointer a=argv[0];
31  register int newval=ckintval(argv[2]);
32  ckarg(3);
33  n=ckintval(argv[1]);
34  if (!isstring(a)) error(E_NOSTRING);
35  if (n<0 || vecsize(a)<=n) error(E_ARRAYINDEX);
36 /* if (elmtypeof(a)==ELM_FOREIGN)
37  ((byte *)(a->c.ivec.iv[0]))[n]=newval;
38  else */
39  a->c.str.chars[n]=newval;
40  return(argv[2]);}
41 
42 pointer UPCASEP(ctx,n,argv)
43 register context *ctx;
44 register int n;
45 register pointer argv[];
46 { ckarg(1); n=ckintval(argv[0]);
47  return((isupper(n))?T:NIL);}
48 
49 pointer LOWCASEP(ctx,n,argv)
50 register context *ctx;
51 register int n;
52 register pointer argv[];
53 { ckarg(1); n=ckintval(argv[0]);
54  return((islower(n))?T:NIL);}
55 
56 pointer ALPHAP(ctx,n,argv)
57 register context *ctx;
58 register int n;
59 pointer argv[];
60 { ckarg(1); n=ckintval(argv[0]);
61  return((isalpha(n))?T:NIL);}
62 
63 pointer DIGITP(ctx,n,argv)
64 register context *ctx;
65 register int n;
66 pointer argv[];
67 { ckarg(1); n=ckintval(argv[0]);
68  return((isdigit(n))?T:NIL);}
69 
70 pointer ALNUMP(ctx,n,argv)
71 register context *ctx;
72 register int n;
73 register pointer argv[];
74 { ckarg(1); n=ckintval(argv[0]);
75  return((isalnum(n))?T:NIL);}
76 
77 pointer CHUPCASE(ctx,n,argv)
78 register context *ctx;
79 register int n;
80 pointer argv[];
81 { ckarg(1); n=ckintval(argv[0]);
82  return((islower(n))?(makeint(toupper(n))):argv[0]);}
83 
84 pointer CHDOWNCASE(ctx,n,argv)
85 register context *ctx;
86 register int n;
87 pointer argv[];
88 { ckarg(1); n=ckintval(argv[0]);
89  return((isupper(n))?(makeint(tolower(n))):argv[0]);}
90 
91 pointer STRINGEQ(ctx,n,argv)
92 register context *ctx;
93 int n;
94 register pointer argv[];
95 { register byte *str1, *str2;
96  int start1,end1,start2,end2;
97  register int len;
98  pointer s1=Getstring(argv[0]), s2=Getstring(argv[1]);
99  ckarg(6);
100  start1=ckintval(argv[2]); end1=ckintval(argv[3]);
101  end1=min(end1,vecsize(s1));
102  start2=ckintval(argv[4]); end2=ckintval(argv[5]);
103  end2=min(end2,vecsize(s2));
104  len=end1-start1;
105  if (len!=end2-start2) return(NIL);
106  str1= &s1->c.str.chars[start1]; str2= &s2->c.str.chars[start2];
107  while (len-->0) if (*str1++ != *str2++) return(NIL);
108  return(T);}
109 
111 register context *ctx;
112 int n;
113 register pointer argv[];
114 { register byte *str1, *str2;
115  int start1,end1,start2,end2,ch1,ch2;
116  pointer s1=Getstring(argv[0]),s2=Getstring(argv[1]);
117  register int len;
118  ckarg(6);
119  start1=ckintval(argv[2]); end1=ckintval(argv[3]); end1=min(end1,vecsize(s1));
120  start2=ckintval(argv[4]); end2=ckintval(argv[5]); end2=min(end2,vecsize(s2));
121  len=end1-start1;
122  if (len!=end2-start2) return(NIL);
123  str1= &s1->c.str.chars[start1]; str2= &s2->c.str.chars[start2];
124  while (len-->0) {
125  ch1= *str1++; ch2= *str2++;
126  if (islower(ch1)) ch1=toupper(ch1);
127  if (islower(ch2)) ch2=toupper(ch2);
128  if (ch1!=ch2) return(NIL);}
129  return(T);}
130 
131 /****************************************************************/
132 /* S T R I N G compare
133 /****************************************************************/
134 
135 
136 #define eusstrcmp(a,b) strcmp((char *)(a), (char *)(b))
137 
138 pointer STR_LT(ctx,n,argv)
139 register context *ctx;
140 int n;
141 register pointer argv[];
142 { ckarg(2);
143  if (eusstrcmp(get_string(argv[0]),get_string(argv[1]))<0) return(T);
144  else return(NIL);}
145 
146 pointer STR_LE(ctx,n,argv)
147 register context *ctx;
148 int n;
149 register pointer argv[];
150 { ckarg(2);
151  if (eusstrcmp(get_string(argv[0]),get_string(argv[1]))<=0) return(T);
152  else return(NIL);}
153 
154 pointer STR_EQ(ctx,n,argv)
155 register context *ctx;
156 int n;
157 register pointer argv[];
158 { ckarg(2);
159  if (eusstrcmp(get_string(argv[0]),get_string(argv[1]))==0) return(T);
160  else return(NIL);}
161 
162 pointer STR_GT(ctx,n,argv)
163 register context *ctx;
164 int n;
165 register pointer argv[];
166 { ckarg(2);
167  if (eusstrcmp(get_string(argv[0]),get_string(argv[1]))>0) return(T);
168  else return(NIL);}
169 
170 pointer STR_GE(ctx,n,argv)
171 register context *ctx;
172 int n;
173 register pointer argv[];
174 { ckarg(2);
175  if (eusstrcmp(get_string(argv[0]),get_string(argv[1]))>=0) return(T);
176  else return(NIL);}
177 
178 /* initializers */
179 
180 void charstring(ctx,mod)
181 register context *ctx;
182 register pointer mod;
183 {
184  defun(ctx,"CHAR",mod,EUSCHAR,NULL);
185  defun(ctx,"SCHAR",mod,EUSCHAR,NULL);
186  defun(ctx,"SETCHAR",mod,SETCHAR,NULL);
187  defun(ctx,"ALPHA-CHAR-P",mod,ALPHAP,NULL);
188  defun(ctx,"UPPER-CASE-P",mod,UPCASEP,NULL);
189  defun(ctx,"LOWER-CASE-P",mod,LOWCASEP,NULL);
190  defun(ctx,"DIGIT-CHAR-P",mod,DIGITP,NULL);
191  defun(ctx,"ALPHANUMERICP",mod,ALNUMP,NULL);
192  defun(ctx,"CHAR-UPCASE",mod,CHUPCASE,NULL);
193  defun(ctx,"CHAR-DOWNCASE",mod,CHDOWNCASE,NULL);
194  defun(ctx,"STRINGEQ",mod,STRINGEQ,NULL);
195  defun(ctx,"STRINGEQUAL",mod,STRINGEQUAL,NULL);
196  defun(ctx,"STRING<",mod,STR_LT,NULL);
197  defun(ctx,"STRING<=",mod,STR_LE,NULL);
198  defun(ctx,"STRING=",mod,STR_EQ,NULL);
199  defun(ctx,"STRING>",mod,STR_GT,NULL);
200  defun(ctx,"STRING>=",mod,STR_GE,NULL);
201 
202  }
203 
#define makeint(v)
Definition: sfttest.c:2
Definition: eus.h:522
pointer STR_LT(context *ctx, int n, argv)
Definition: charstring.c:138
struct string str
Definition: eus.h:400
byte chars[1]
Definition: eus.h:210
pointer Getstring()
pointer CHDOWNCASE(context *ctx, int n, argv)
Definition: charstring.c:84
pointer T
Definition: eus.c:110
GLfloat n[6][3]
Definition: cube.c:15
pointer LOWCASEP(context *ctx, int n, argv)
Definition: charstring.c:49
defun("ADR_TO_STRING", mod, ADR_TO_STRING)
pointer STR_GT(context *ctx, int n, argv)
Definition: charstring.c:162
ckarg(2)
pointer STR_GE(context *ctx, int n, argv)
Definition: charstring.c:170
#define min(x, y)
Definition: rmflags.c:17
pointer UPCASEP(context *ctx, int n, argv)
Definition: charstring.c:42
static char * rcsid
Definition: charstring.c:6
pointer STRINGEQUAL(context *ctx, int n, argv)
Definition: charstring.c:110
pointer STR_EQ(context *ctx, int n, argv)
Definition: charstring.c:154
union cell::cellunion c
Definition: eus.h:379
pointer EUSCHAR(context *ctx, int n, argv)
Definition: charstring.c:10
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
pointer ALNUMP(context *ctx, int n, argv)
Definition: charstring.c:70
byte * get_string()
pointer STRINGEQ(context *ctx, int n, argv)
Definition: charstring.c:91
pointer ALPHAP(context *ctx, int n, argv)
Definition: charstring.c:56
#define NULL
Definition: transargv.c:8
pointer CHUPCASE(context *ctx, int n, argv)
Definition: charstring.c:77
void charstring(context *ctx, pointer mod)
Definition: charstring.c:180
unsigned char byte
Definition: eus.h:161
pointer DIGITP(context *ctx, int n, argv)
Definition: charstring.c:63
pointer NIL
Definition: eus.c:110
pointer STR_LE(context *ctx, int n, argv)
Definition: charstring.c:146
pointer SETCHAR(context *ctx, int n, argv)
Definition: charstring.c:26
char a[26]
Definition: freq.c:4


euslisp
Author(s): Toshihiro Matsui
autogenerated on Fri Feb 21 2020 03:20:54