euslisp: predicates.c Source File

Go to the documentation of this file.
00001 /****************************************************************/
00002 /* predicates.c
00003 /*      1986-Jul 6, Copyright(C), T.Matsui
00004 *****************************************************************/
00005 static char *rcsid="@(#)$Id$";
00006 
00007 #include "eus.h"
00008 
00009 extern pointer call1(context *, pointer, pointer);
00010 extern pointer call2(context *, pointer, pointer, pointer);
00011 
00012 pointer ATOM(ctx,n,argv)
00013 register context *ctx;
00014 int n;
00015 register pointer *argv;
00016 { ckarg(1);
00017   return(islist(argv[0])?NIL:T);}
00018 
00019 pointer EQ(ctx,n,argv)
00020 register context *ctx;
00021 register int n;
00022 register pointer *argv;
00023 { ckarg(2);
00024   return(argv[0]==argv[1]?T:NIL);}
00025 
00026 pointer NILP(ctx,n,argv)
00027 register context *ctx;
00028 register int n;
00029 register pointer *argv;
00030 { ckarg(1);
00031   return(argv[0]==NIL?T:NIL);}
00032 
00033 pointer SYMBOLP(ctx,n,argv)
00034 register context *ctx;
00035 int n;
00036 register pointer *argv;
00037 { ckarg(1);
00038   return(issymbol(*argv)?T:NIL);}
00039 
00040 pointer STRINGP(ctx,n,argv)
00041 register context *ctx;
00042 int n;
00043 pointer *argv;
00044 { ckarg(1);
00045   return(isstring(*argv)?T:NIL);}
00046 
00047 pointer LISTP(ctx,n,argv)
00048 register context *ctx;
00049 int n;
00050 pointer *argv;
00051 { register pointer a=argv[0];
00052   ckarg(1);
00053   if (islist(a)) return(T);
00054   else if (a==NIL) return(T); 
00055   else return(NIL);}
00056 
00057 pointer CONSP(ctx,n,argv)
00058 register context *ctx;
00059 int n;
00060 register pointer *argv;
00061 { ckarg(1);
00062   return(islist(argv[0])?T:NIL);}
00063 
00064 pointer ENDP(ctx,n,argv)
00065 register context *ctx;
00066 int n;
00067 register pointer argv[];
00068 { ckarg(1);
00069   if (argv[0]==NIL) return(T);
00070   else if (islist(argv[0])) return(NIL);
00071   else error(E_NOLIST);}
00072 
00073 pointer NUMBERP(ctx,n,argv)
00074 register context *ctx;
00075 int n;
00076 register pointer *argv;
00077 { ckarg(1);
00078   if (isnum(argv[0]) || pisextnum(argv[0])) return(T);
00079   else return(NIL);}
00080 
00081 pointer INTEGERP(ctx,n,argv)
00082 register context *ctx;
00083 int n;
00084 register pointer *argv;
00085 { ckarg(1);
00086   return(isint(argv[0])?T:NIL);}
00087 
00088 pointer FLOATP(ctx,n,argv)
00089 register context *ctx;
00090 int n;
00091 register pointer *argv;
00092 { ckarg(1);
00093   return(isflt(argv[0])?T:NIL);}
00094 
00095 pointer BOUNDP(ctx,n,argv)
00096 register context *ctx;
00097 int n;
00098 register pointer argv[];
00099 { register pointer a=argv[0], vtp;
00100   ckarg(1);
00101   if (!issymbol(a)) error(E_NOSYMBOL);
00102   vtp=a->c.sym.vtype;
00103   if (SPEVALOF(a)==UNBOUND) return(NIL);
00104   else return(T);}
00105 
00106 pointer FBOUNDP(ctx,n,argv)
00107 register context *ctx;
00108 int n;
00109 register pointer *argv;
00110 { register pointer a=argv[0];
00111   ckarg(1);
00112   if (!issymbol(a)) error(E_NOSYMBOL);
00113   if (a->c.sym.spefunc==UNBOUND) return(NIL); else return(T);}
00114 
00115 pointer STREAMP(ctx,n,argv)
00116 register context *ctx;
00117 int n;
00118 register pointer argv[];
00119 { register pointer s=argv[0];
00120   ckarg(1);
00121   if (isstream(s) || isiostream(s)) return(T);
00122   else return(NIL);}
00123 
00124 pointer superequal(x,y) /* mutex_lock before call */
00125 register pointer x,y;
00126 { register int i,n,xe;
00127   register eusinteger_t *cx,*cy;
00128   bpointer bx,by;
00129   pointer result;
00130   if (x==y) return(T);
00131   if (isnum(x) || isnum(y)) return(NIL);
00132   if (x->cix != y->cix) return(NIL);    /*different class*/
00133   if (pissymbol(x)) return(NIL);
00134     bx=bpointerof(x);
00135     by=bpointerof(y);
00136     if (bx->h.mark || by->h.mark) return(UNBOUND);      /*circular list*/
00137     xe=bx->h.elmtype;
00138     if (xe!=by->h.elmtype) return(NIL); /*element type mismatch*/
00139     if (xe==ELM_FIXED || xe==ELM_POINTER) {
00140       bx->h.mark=by->h.mark=1;
00141       if (xe==ELM_POINTER) n=vecsize(x)+1;
00142       else n=objsize(x);
00143       for (i=0; i<n; i++) {
00144         result=superequal(x->c.obj.iv[i],y->c.obj.iv[i]);
00145         if (result!=T) {
00146           bx->h.mark=by->h.mark=0;
00147           return(result);} } 
00148       /*all elements matched*/
00149       bx->h.mark=by->h.mark=0;
00150       return(T);}
00151     else {
00152       n=vecsize(x);
00153       if (n!=vecsize(y)) return(NIL);   /*length mismatch*/
00154       cx=x->c.ivec.iv; cy=y->c.ivec.iv;
00155       switch(xe) {
00156         case ELM_BIT: n=(n+WORD_SIZE-1)/WORD_SIZE; break;
00157         case ELM_CHAR: case ELM_BYTE: n=(n+sizeof(eusinteger_t)-1)/sizeof(eusinteger_t); break;
00158         case ELM_FOREIGN: cx=(eusinteger_t *)(cx[0]); cy=(eusinteger_t *)(cy[0]); break;}
00159       for (i=0; i<n; i++) if (cx[i]!=cy[i]) return(NIL);
00160       return(T);}  }
00161 
00162 pointer equal(x,y)
00163 register pointer x,y;
00164 { register int i,n,xe;
00165   register eusinteger_t *cx,*cy;
00166   if (x==y) return(T);
00167   if (isnum(x) || isnum(y)) return(NIL);
00168   if (x->cix != y->cix) return(NIL);    /*different class*/
00169   if (pissymbol(x)) return(NIL);
00170   xe=elmtypeof(x);
00171   if (xe!=elmtypeof(y)) return(NIL);    /*element type mismatch*/
00172   /* foreign string is always not equal to normal string */
00173   if (xe==ELM_FIXED || xe==ELM_POINTER) {
00174     if (xe==ELM_POINTER) n=vecsize(x)+1;
00175     else n=objsize(x);
00176     for (i=0; i<n; i++)
00177       if (equal(x->c.obj.iv[i],y->c.obj.iv[i])!=T) return(NIL);
00178     return(T);}
00179   else {
00180     n=vecsize(x);
00181     if (n!=vecsize(y)) return(NIL);     /*length mismatch*/
00182     cx=x->c.ivec.iv; cy=y->c.ivec.iv;
00183     switch(xe) {
00184       case ELM_BIT: n=(n+WORD_SIZE-1)/WORD_SIZE; break;
00185       case ELM_CHAR: case ELM_BYTE: n=(n+sizeof(eusinteger_t)-1)/sizeof(eusinteger_t); break;
00186       case ELM_FOREIGN: cx=(eusinteger_t *)(cx[0]); cy=(eusinteger_t *)(cy[0]); break;}
00187     for (i=0; i<n; i++) if (cx[i]!=cy[i]) return(NIL);
00188     return(T);}  }
00189 
00190 pointer EQUAL(ctx,n,argv)
00191 register context *ctx;
00192 int n;
00193 register pointer argv[];
00194 { ckarg(2);
00195   return(equal(argv[0],argv[1]));}
00196 
00197 pointer SUPEREQUAL(ctx,n,argv)
00198 register context *ctx;
00199 int n;
00200 register pointer argv[];
00201 { register pointer result;
00202   ckarg(2);
00203 #if THREADED
00204   mutex_lock(&mark_lock);
00205   mark_locking="SUPEREQUAL";
00206   result=superequal(argv[0],argv[1]);
00207   mutex_unlock(&mark_lock);
00208 #else
00209   result=superequal(argv[0],argv[1]);
00210 #endif
00211   if (result==UNBOUND) error(E_CIRCULAR);
00212   else return(result);}
00213 
00214 void predicates(ctx,mod)
00215 register context *ctx;
00216 register pointer mod;
00217 { /* preds*/
00218   defun(ctx,"ATOM",mod,ATOM,NULL);
00219   QEQ=defun(ctx,"EQ",mod,EQ,NULL);
00220   QEQ=QEQ->c.sym.spefunc;
00221   defun(ctx,"EQL",mod,EQ,NULL);
00222   defun(ctx,"NULL",mod,NILP,NULL);
00223   QNOT=defun(ctx,"NOT",mod,NILP,NULL);
00224   QEQUAL=defun(ctx,"EQUAL",mod,EQUAL,NULL);
00225   defun(ctx,"SUPEREQUAL",mod,SUPEREQUAL,NULL);
00226   defun(ctx,"SYMBOLP",mod,SYMBOLP,NULL);
00227   defun(ctx,"STRINGP",mod,STRINGP,NULL);
00228   defun(ctx,"LISTP",mod,LISTP,NULL);
00229   defun(ctx,"CONSP",mod,CONSP,NULL);
00230   defun(ctx,"ENDP",mod,ENDP,NULL);
00231   defun(ctx,"NUMBERP",mod,NUMBERP,NULL);
00232   defun(ctx,"INTEGERP",mod,INTEGERP,NULL);
00233   defun(ctx,"FLOATP",mod,FLOATP,NULL);
00234   defun(ctx,"BOUNDP",mod,BOUNDP,NULL);
00235   defun(ctx,"FBOUNDP",mod,FBOUNDP,NULL);
00236   defun(ctx,"STREAMP",mod,STREAMP,NULL); }