predicates.c
Go to the documentation of this file.
1 /****************************************************************/
2 /* predicates.c
3 /* 1986-Jul 6, Copyright(C), T.Matsui
4 *****************************************************************/
5 static char *rcsid="@(#)$Id$";
6 
7 #include "eus.h"
8 
11 
12 pointer ATOM(ctx,n,argv)
13 register context *ctx;
14 int n;
15 register pointer *argv;
16 { ckarg(1);
17  return(islist(argv[0])?NIL:T);}
18 
19 pointer EQ(ctx,n,argv)
20 register context *ctx;
21 register int n;
22 register pointer *argv;
23 { ckarg(2);
24  return(argv[0]==argv[1]?T:NIL);}
25 
26 pointer NILP(ctx,n,argv)
27 register context *ctx;
28 register int n;
29 register pointer *argv;
30 { ckarg(1);
31  return(argv[0]==NIL?T:NIL);}
32 
33 pointer SYMBOLP(ctx,n,argv)
34 register context *ctx;
35 int n;
36 register pointer *argv;
37 { ckarg(1);
38  return(issymbol(*argv)?T:NIL);}
39 
40 pointer STRINGP(ctx,n,argv)
41 register context *ctx;
42 int n;
43 pointer *argv;
44 { ckarg(1);
45  return(isstring(*argv)?T:NIL);}
46 
47 pointer LISTP(ctx,n,argv)
48 register context *ctx;
49 int n;
50 pointer *argv;
51 { register pointer a=argv[0];
52  ckarg(1);
53  if (islist(a)) return(T);
54  else if (a==NIL) return(T);
55  else return(NIL);}
56 
57 pointer CONSP(ctx,n,argv)
58 register context *ctx;
59 int n;
60 register pointer *argv;
61 { ckarg(1);
62  return(islist(argv[0])?T:NIL);}
63 
64 pointer ENDP(ctx,n,argv)
65 register context *ctx;
66 int n;
67 register pointer argv[];
68 { ckarg(1);
69  if (argv[0]==NIL) return(T);
70  else if (islist(argv[0])) return(NIL);
71  else error(E_NOLIST);}
72 
73 pointer NUMBERP(ctx,n,argv)
74 register context *ctx;
75 int n;
76 register pointer *argv;
77 { ckarg(1);
78  if (isnum(argv[0]) || pisextnum(argv[0])) return(T);
79  else return(NIL);}
80 
81 pointer INTEGERP(ctx,n,argv)
82 register context *ctx;
83 int n;
84 register pointer *argv;
85 { ckarg(1);
86  return(isint(argv[0])?T:NIL);}
87 
88 pointer FLOATP(ctx,n,argv)
89 register context *ctx;
90 int n;
91 register pointer *argv;
92 { ckarg(1);
93  return(isflt(argv[0])?T:NIL);}
94 
95 pointer BOUNDP(ctx,n,argv)
96 register context *ctx;
97 int n;
98 register pointer argv[];
99 { register pointer a=argv[0], vtp;
100  ckarg(1);
101  if (!issymbol(a)) error(E_NOSYMBOL);
102  vtp=a->c.sym.vtype;
103  if (SPEVALOF(a)==UNBOUND) return(NIL);
104  else return(T);}
105 
106 pointer FBOUNDP(ctx,n,argv)
107 register context *ctx;
108 int n;
109 register pointer *argv;
110 { register pointer a=argv[0];
111  ckarg(1);
112  if (!issymbol(a)) error(E_NOSYMBOL);
113  if (a->c.sym.spefunc==UNBOUND) return(NIL); else return(T);}
114 
115 pointer STREAMP(ctx,n,argv)
116 register context *ctx;
117 int n;
118 register pointer argv[];
119 { register pointer s=argv[0];
120  ckarg(1);
121  if (isstream(s) || isiostream(s)) return(T);
122  else return(NIL);}
123 
124 pointer superequal(x,y) /* mutex_lock before call */
125 register pointer x,y;
126 { register int i,n,xe;
127  register eusinteger_t *cx,*cy;
128  bpointer bx,by;
129  pointer result;
130  if (x==y) return(T);
131  if (isnum(x) || isnum(y)) return(NIL);
132  if (x->cix != y->cix) return(NIL); /*different class*/
133  if (pissymbol(x)) return(NIL);
134  bx=bpointerof(x);
135  by=bpointerof(y);
136  if (bx->h.mark || by->h.mark) return(UNBOUND); /*circular list*/
137  xe=bx->h.elmtype;
138  if (xe!=by->h.elmtype) return(NIL); /*element type mismatch*/
139  if (xe==ELM_FIXED || xe==ELM_POINTER) {
140  bx->h.mark=by->h.mark=1;
141  if (xe==ELM_POINTER) n=vecsize(x)+1;
142  else n=objsize(x);
143  for (i=0; i<n; i++) {
144  result=superequal(x->c.obj.iv[i],y->c.obj.iv[i]);
145  if (result!=T) {
146  bx->h.mark=by->h.mark=0;
147  return(result);} }
148  /*all elements matched*/
149  bx->h.mark=by->h.mark=0;
150  return(T);}
151  else {
152  n=vecsize(x);
153  if (n!=vecsize(y)) return(NIL); /*length mismatch*/
154  cx=x->c.ivec.iv; cy=y->c.ivec.iv;
155  switch(xe) {
156  case ELM_BIT: n=(n+WORD_SIZE-1)/WORD_SIZE; break;
157  case ELM_CHAR: case ELM_BYTE: n=(n+sizeof(eusinteger_t)-1)/sizeof(eusinteger_t); break;
158  case ELM_FOREIGN: cx=(eusinteger_t *)(cx[0]); cy=(eusinteger_t *)(cy[0]); break;}
159  for (i=0; i<n; i++) if (cx[i]!=cy[i]) return(NIL);
160  return(T);} }
161 
163 register pointer x,y;
164 { register int i,n,xe;
165  register eusinteger_t *cx,*cy;
166  if (x==y) return(T);
167  if (isnum(x) || isnum(y)) return(NIL);
168  if (x->cix != y->cix) return(NIL); /*different class*/
169  if (pissymbol(x)) return(NIL);
170  xe=elmtypeof(x);
171  if (xe!=elmtypeof(y)) return(NIL); /*element type mismatch*/
172  /* foreign string is always not equal to normal string */
173  if (xe==ELM_FIXED || xe==ELM_POINTER) {
174  if (xe==ELM_POINTER) n=vecsize(x)+1;
175  else n=objsize(x);
176  for (i=0; i<n; i++)
177  if (equal(x->c.obj.iv[i],y->c.obj.iv[i])!=T) return(NIL);
178  return(T);}
179  else {
180  n=vecsize(x);
181  if (n!=vecsize(y)) return(NIL); /*length mismatch*/
182  cx=x->c.ivec.iv; cy=y->c.ivec.iv;
183  switch(xe) {
184  case ELM_BIT: n=(n+WORD_SIZE-1)/WORD_SIZE; break;
185  case ELM_CHAR: case ELM_BYTE: n=(n+sizeof(eusinteger_t)-1)/sizeof(eusinteger_t); break;
186  case ELM_FOREIGN: cx=(eusinteger_t *)(cx[0]); cy=(eusinteger_t *)(cy[0]); break;}
187  for (i=0; i<n; i++) if (cx[i]!=cy[i]) return(NIL);
188  return(T);} }
189 
190 pointer EQUAL(ctx,n,argv)
191 register context *ctx;
192 int n;
193 register pointer argv[];
194 { ckarg(2);
195  return(equal(argv[0],argv[1]));}
196 
198 register context *ctx;
199 int n;
200 register pointer argv[];
201 { register pointer result;
202  ckarg(2);
203 #if THREADED
204  mutex_lock(&mark_lock);
205  mark_locking="SUPEREQUAL";
206  result=superequal(argv[0],argv[1]);
207  mutex_unlock(&mark_lock);
208 #else
209  result=superequal(argv[0],argv[1]);
210 #endif
211  if (result==UNBOUND) error(E_CIRCULAR);
212  else return(result);}
213 
214 void predicates(ctx,mod)
215 register context *ctx;
216 register pointer mod;
217 { /* preds*/
218  defun(ctx,"ATOM",mod,ATOM,NULL);
219  QEQ=defun(ctx,"EQ",mod,EQ,NULL);
220  QEQ=QEQ->c.sym.spefunc;
221  defun(ctx,"EQL",mod,EQ,NULL);
222  defun(ctx,"NULL",mod,NILP,NULL);
223  QNOT=defun(ctx,"NOT",mod,NILP,NULL);
224  QEQUAL=defun(ctx,"EQUAL",mod,EQUAL,NULL);
225  defun(ctx,"SUPEREQUAL",mod,SUPEREQUAL,NULL);
226  defun(ctx,"SYMBOLP",mod,SYMBOLP,NULL);
227  defun(ctx,"STRINGP",mod,STRINGP,NULL);
228  defun(ctx,"LISTP",mod,LISTP,NULL);
229  defun(ctx,"CONSP",mod,CONSP,NULL);
230  defun(ctx,"ENDP",mod,ENDP,NULL);
231  defun(ctx,"NUMBERP",mod,NUMBERP,NULL);
232  defun(ctx,"INTEGERP",mod,INTEGERP,NULL);
233  defun(ctx,"FLOATP",mod,FLOATP,NULL);
234  defun(ctx,"BOUNDP",mod,BOUNDP,NULL);
235  defun(ctx,"FBOUNDP",mod,FBOUNDP,NULL);
236  defun(ctx,"STREAMP",mod,STREAMP,NULL); }
cellheader::elmtype
unsigned elmtype
Definition: eus.h:182
superequal
pointer superequal(pointer x, pointer y)
Definition: predicates.c:124
NIL
pointer NIL
Definition: eus.c:110
rcsid
static char * rcsid
Definition: predicates.c:5
NILP
pointer NILP(context *ctx, int n, pointer *argv)
Definition: predicates.c:26
defun
defun("ADR_TO_STRING", mod, ADR_TO_STRING)
E_CIRCULAR
@ E_CIRCULAR
Definition: eus.h:969
context
Definition: eus.h:524
s
short s
Definition: structsize.c:2
symbol::spefunc
pointer spefunc
Definition: eus.h:206
STREAMP
pointer STREAMP(context *ctx, int n, argv)
Definition: predicates.c:115
bcell::h
struct cellheader h
Definition: eus.h:440
EQ
pointer EQ(context *ctx, int n, pointer *argv)
Definition: predicates.c:19
ENDP
pointer ENDP(context *ctx, int n, argv)
Definition: predicates.c:64
QEQUAL
pointer QEQUAL
Definition: eus.c:127
SYMBOLP
pointer SYMBOLP(context *ctx, int n, pointer *argv)
Definition: predicates.c:33
T
pointer T
Definition: eus.c:110
eus.h
cell::cellunion::sym
struct symbol sym
Definition: eus.h:401
mark_lock
mutex_t mark_lock
Definition: mthread.c:25
equal
pointer equal(pointer x, pointer y)
Definition: predicates.c:162
cell::c
union cell::cellunion c
LISTP
pointer LISTP(context *ctx, int n, pointer *argv)
Definition: predicates.c:47
BOUNDP
pointer BOUNDP(context *ctx, int n, argv)
Definition: predicates.c:95
NULL
#define NULL
Definition: transargv.c:8
INTEGERP
pointer INTEGERP(context *ctx, int n, pointer *argv)
Definition: predicates.c:81
cellheader::mark
unsigned mark
Definition: eus.h:177
predicates
void predicates(context *ctx, pointer mod)
Definition: predicates.c:214
SUPEREQUAL
pointer SUPEREQUAL(context *ctx, int n, argv)
Definition: predicates.c:197
E_NOLIST
@ E_NOLIST
Definition: eus.h:949
QNOT
pointer QNOT
Definition: eus.c:127
ATOM
pointer ATOM(context *ctx, int n, pointer *argv)
Definition: predicates.c:12
error
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
call2
pointer call2(context *, pointer, pointer, pointer)
Definition: sequence.c:45
cell
Definition: eus.h:381
eusinteger_t
long eusinteger_t
Definition: eus.h:19
mark_locking
char * mark_locking
Definition: mthread.c:26
EQUAL
pointer EQUAL(context *ctx, int n, argv)
Definition: predicates.c:190
STRINGP
pointer STRINGP(context *ctx, int n, pointer *argv)
Definition: predicates.c:40
FBOUNDP
pointer FBOUNDP(context *ctx, int n, pointer *argv)
Definition: predicates.c:106
FLOATP
pointer FLOATP(context *ctx, int n, pointer *argv)
Definition: predicates.c:88
QEQ
pointer QEQ
Definition: eus.c:127
bcell
Definition: eus.h:439
NUMBERP
pointer NUMBERP(context *ctx, int n, pointer *argv)
Definition: predicates.c:73
a
char a[26]
Definition: freq.c:4
E_NOSYMBOL
@ E_NOSYMBOL
Definition: eus.h:948
n
GLfloat n[6][3]
Definition: cube.c:15
CONSP
pointer CONSP(context *ctx, int n, pointer *argv)
Definition: predicates.c:57
call1
pointer call1(context *, pointer, pointer)
Definition: sequence.c:37
ckarg
ckarg(2)


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 15 2023 02:06:43