00001
00002
00003
00004
00005
00006
00007 static char *rcsid="@(#)$Id$";
00008
00009 #include "eus.h"
00010
00011 extern pointer equal();
00012 extern pointer call1(context *, pointer, pointer);
00013 extern pointer call2(context *, pointer, pointer, pointer);
00014
00015
00016
00017 pointer CAR(ctx,n,argv)
00018 register context *ctx;
00019 register int n;
00020 register pointer *argv;
00021 { register pointer a=argv[0];
00022 ckarg(1);
00023 if (iscons(a)) return(ccar(a));
00024 if (a==NIL) return(NIL);
00025 error(E_NOLIST);}
00026
00027 pointer CDR(ctx,n,argv)
00028 register context *ctx;
00029 register int n;
00030 register pointer *argv;
00031 { register pointer a=argv[0];
00032 ckarg(1);
00033 if (iscons(a)) return(ccdr(a));
00034 if (a==NIL) return(NIL);
00035 error(E_NOLIST);}
00036
00037 pointer CADR(ctx,n,argv)
00038 register context *ctx;
00039 register int n;
00040 register pointer argv[];
00041 { register pointer p=argv[0];
00042 ckarg(1);
00043 if (iscons(p)) p=ccdr(p);
00044 else if (p==NIL) return(NIL);
00045 else error(E_NOLIST);
00046 if (iscons(p)) return(ccar(p));
00047 else if (p==NIL) return(NIL);
00048 else error(E_NOLIST);}
00049
00050 pointer CDDR(ctx,n,argv)
00051 register context *ctx;
00052 register int n;
00053 register pointer argv[];
00054 { register pointer p=argv[0];
00055 ckarg(1);
00056 if (iscons(p)) p=ccdr(p);
00057 else if (p==NIL) return(NIL);
00058 else error(E_NOLIST);
00059 if (iscons(p)) return(ccdr(p));
00060 else if (p==NIL) return(NIL);
00061 else error(E_NOLIST);}
00062
00063 pointer CDAR(ctx,n,argv)
00064 register context *ctx;
00065 register int n;
00066 register pointer argv[];
00067 { register pointer p=argv[0];
00068 ckarg(1);
00069 if (iscons(p)) p=ccar(p);
00070 else if (p==NIL) return(NIL);
00071 else error(E_NOLIST);
00072 if (iscons(p)) return(ccdr(p));
00073 else if (p==NIL) return(NIL);
00074 else error(E_NOLIST);}
00075
00076 pointer CAAR(ctx,n,argv)
00077 register context *ctx;
00078 register int n;
00079 register pointer argv[];
00080 { register pointer p=argv[0];
00081 ckarg(1);
00082 if (iscons(p)) p=ccar(p);
00083 else if (p==NIL) return(NIL);
00084 else error(E_NOLIST);
00085 if (iscons(p)) return(ccar(p));
00086 else if (p==NIL) return(NIL);
00087 else error(E_NOLIST);}
00088
00089 pointer CADDR(ctx,n,argv)
00090 register context *ctx;
00091 register int n;
00092 register pointer argv[];
00093 { register pointer p=argv[0];
00094 ckarg(1);
00095 if (iscons(p)) p=ccdr(p);
00096 else if (p==NIL) return(NIL);
00097 else error(E_NOLIST);
00098 if (iscons(p)) p=ccdr(p);
00099 else if (p==NIL) return(NIL);
00100 else error(E_NOLIST);
00101 if (iscons(p)) return(ccar(p));
00102 else if (p==NIL) return(NIL);
00103 else error(E_NOLIST);}
00104
00105 pointer NTH(ctx,n,argv)
00106 register context *ctx;
00107 register int n;
00108 register pointer *argv;
00109 { register int i;
00110 register pointer a=argv[1];
00111 ckarg(2);
00112 i=ckintval(argv[0]);
00113 if (i<0) error(E_NOINT);
00114 while (i-->0 && islist(a)) a=ccdr(a);
00115 if (islist(a)) return(ccar(a));
00116 else if (a==NIL) return(NIL);
00117 else error(E_NOLIST);}
00118
00119 pointer NTHCDR(ctx,n,argv)
00120 register context *ctx;
00121 register int n;
00122 register pointer *argv;
00123 { register int i;
00124 register pointer a;
00125 ckarg(2);
00126 i=ckintval(argv[0]);
00127 a=argv[1];
00128 if (i<0) error(E_NOINT);
00129 if (a==NIL) return(NIL);
00130 else if (!islist(a)) error(E_NOLIST);
00131 while (i-->0 && islist(a)) a=ccdr(a);
00132 return(a);}
00133
00134 pointer CONS(ctx,n,argv)
00135 register context *ctx;
00136 register int n;
00137 register pointer *argv;
00138 { ckarg(2);
00139 return(cons(ctx,argv[0],argv[1]));}
00140
00141 pointer RPLACA(ctx,n,argv)
00142 register context *ctx;
00143 register int n;
00144 register pointer argv[];
00145 { register pointer a=argv[0];
00146 ckarg(2);
00147 if (islist(a)) {pointer_update(ccar(a),argv[1]);}
00148 else error(E_NOLIST);
00149 return(a);}
00150
00151 pointer RPLACA2(ctx,n,argv)
00152 register context *ctx;
00153 register int n;
00154 register pointer argv[];
00155 { register pointer a=argv[0];
00156 ckarg(2);
00157 if (islist(a)) {pointer_update(ccar(a),argv[1]);}
00158 else error(E_NOLIST);
00159 return(argv[1]);}
00160
00161 pointer RPLACD(ctx,n,argv)
00162 register context *ctx;
00163 register int n;
00164 register pointer argv[];
00165 { register pointer a=argv[0];
00166 ckarg(2);
00167 if (islist(a)) {pointer_update(ccdr(a),argv[1]);}
00168 else error(E_NOLIST);
00169 return(a);}
00170
00171 pointer RPLACD2(ctx,n,argv)
00172 register context *ctx;
00173 register int n;
00174 register pointer argv[];
00175 { register pointer a=argv[0];
00176 ckarg(2);
00177 if (islist(a)) {pointer_update(ccdr(a),argv[1]);}
00178 else error(E_NOLIST);
00179 return(argv[1]);}
00180
00181 pointer LIST(ctx,n,argv)
00182 register context *ctx;
00183 register int n;
00184 register pointer argv[];
00185 { register pointer result=NIL;
00186 while (n>0) result=cons(ctx,argv[--n],result);
00187 return(result);}
00188
00189 pointer LIST_STAR(ctx,n,argv)
00190 register context *ctx;
00191 register int n;
00192 register pointer argv[];
00193 { register pointer result=argv[--n];
00194 while (n>0) result=cons(ctx,argv[--n],result);
00195 return(result);}
00196
00197 pointer APPEND(ctx,n,argv)
00198 register context *ctx;
00199 register int n;
00200 register pointer argv[];
00201 { register pointer a,r;
00202 register int i;
00203 if (n==0) return(NIL);
00204 r=argv[--n];
00205 while (n>0) {
00206 a=argv[--n];
00207 if (!islist(a) && a != NIL) error(E_NOLIST);
00208 i=0;
00209 while (islist(a)) { ckpush(ccar(a)); a=ccdr(a); i++;}
00210 while (i-->0) r=cons(ctx,vpop(),r);}
00211 return(r);}
00212
00213 pointer NCONC(ctx,n,argv)
00214 register context *ctx;
00215 register int n;
00216 register pointer argv[];
00217 { register pointer a,c;
00218 while (--n>=0) if (islist(argv[n])) goto nconc1;
00219 return(NIL);
00220 nconc1:
00221 a=argv[n];
00222 while (--n>=0) {
00223 c=argv[n];
00224 if (islist(c)) {
00225 while (islist(ccdr(c))) { breakck; c=ccdr(c);}
00226 pointer_update(ccdr(c),a);
00227 a=argv[n];}
00228 }
00229 return(a);}
00230
00231 pointer subst(ctx,x,y,z)
00232 register context *ctx;
00233 register pointer x,y,z;
00234 { pointer temp;
00235 if (equal(y,z)==T) return(x);
00236 if (!islist(z)) return(z);
00237 temp=subst(ctx,x,y,ccar(z));
00238 vpush(temp);
00239 temp = subst(ctx,x,y,ccdr(z));
00240 return (cons(ctx,vpop(),temp));}
00241
00242
00243 pointer SUBST(ctx,n,argv)
00244 register context *ctx;
00245 int n;
00246 register pointer argv[];
00247 {
00248 ckarg(3);
00249 return(subst(ctx,argv[0],argv[1],argv[2]));}
00250
00251 pointer nsubst(x,y,z)
00252 register pointer x,y, *z;
00253 { register pointer zz= *z;
00254 if (y==zz) pointer_update(*z,x);
00255 if (iscons(zz)) {
00256 nsubst(x,y,&(zz->c.cons.car));
00257 nsubst(x,y,&(zz->c.cons.cdr));} }
00258
00259 pointer NSUBST(ctx,n,argv)
00260 register context *ctx;
00261 int n;
00262 register pointer argv[];
00263 { ckarg(3);
00264 nsubst(argv[0],argv[1],&argv[2]);
00265 return(argv[2]);}
00266
00267 pointer memq(item,list)
00268 register pointer item,list;
00269 { while (iscons(list))
00270 if (ccar(list)==item) return(list);
00271 else list=ccdr(list);
00272 return(NIL);}
00273
00274 pointer MEMQ(ctx,n,argv)
00275 register context *ctx;
00276 int n;
00277 register pointer argv[];
00278 { ckarg(2);
00279 return(memq(argv[0],argv[1]));}
00280
00281 pointer MEMBER(ctx,n,argv)
00282 register context *ctx;
00283 int n;
00284 register pointer argv[];
00285 { pointer item=argv[0],list=argv[1],result;
00286 ckarg(2);
00287 while (islist(list)) {
00288 result=equal(ccar(list),item);
00289 if (result==T) return(list);
00290 else if (result==UNBOUND) error(E_CIRCULAR);
00291 else list=ccdr(list);}
00292 return(NIL);}
00293
00294 pointer SUPERMEMBER(ctx,n,argv)
00295 register context *ctx;
00296 int n;
00297 register pointer argv[];
00298 { register pointer item=argv[0],list=argv[1];
00299 pointer key=argv[2],test=argv[3],testnot=argv[4];
00300 register pointer target;
00301 eusinteger_t result;
00302 ckarg(5);
00303 while (islist(list)) {
00304 target=ccar(list);
00305 if (key!=NIL) target=call1(ctx,key,target);
00306 if (testnot!=NIL) result=(call2(ctx,testnot,item,target)==NIL);
00307 else if (test==QEQUAL) {
00308 target=equal(item,target);
00309 if (target==UNBOUND) error(E_CIRCULAR);
00310 else result=(target!=NIL);}
00311 else if (test!=NIL) result=(call2(ctx,test,item,target)!=NIL);
00312 else result=(item==target);
00313 if (result) return(list);
00314 else list=ccdr(list);}
00315 return(NIL);}
00316
00317 pointer assq(item,alist)
00318 register pointer item,alist;
00319 { register pointer temp;
00320 while (iscons(alist)) {
00321 temp=ccar(alist);
00322 if (iscons(temp)) {
00323 if (ccar(temp)==item) return(temp);
00324 else alist=ccdr(alist);}
00325 else error(E_ALIST);}
00326 return(NIL);}
00327
00328 pointer ASSQ(ctx,n,argv)
00329 register context *ctx;
00330 int n;
00331 register pointer argv[];
00332 { ckarg(2);
00333 return(assq(argv[0],argv[1])); }
00334
00335 pointer ASSOC(ctx,n,argv)
00336 register context *ctx;
00337 int n;
00338 register pointer argv[];
00339 { register pointer item=argv[0],alist=argv[1],temp,compare;
00340 ckarg(2);
00341 while (islist(alist)) {
00342 temp=ccar(alist);
00343 if (islist(temp)) {
00344 compare=equal(item,ccar(temp));
00345 if (compare==T) return(temp);
00346 else if (compare==UNBOUND) error(E_CIRCULAR);
00347 else alist=ccdr(alist);}
00348 else error(E_ALIST);}
00349 return(NIL);}
00350
00351 pointer SUPERASSOC(ctx,n,argv)
00352 register context *ctx;
00353 int n;
00354 register pointer argv[];
00355 { register pointer item=argv[0],alist=argv[1];
00356 pointer key=argv[2],test=argv[3],testnot=argv[4];
00357 register pointer temp,target;
00358 register eusinteger_t compare;
00359 ckarg(5);
00360 while (islist(alist)) {
00361 target=ccar(alist);
00362 if (islist(target)) {
00363 if (key==NIL) temp=ccar(target);
00364 else temp=call1(ctx,key,target);
00365 if (testnot!=NIL) compare=(call2(ctx,testnot,item,temp)==NIL);
00366 else if (test==NIL || test==QEQ) compare=(item==temp);
00367 else if (test==QEQUAL) compare=(equal(item,temp)==T);
00368 else compare=(call2(ctx,test,item,temp)!=NIL);
00369 if (compare) return(target);}
00370 alist=ccdr(alist);}
00371 return(NIL);}
00372
00373 pointer BUTLAST(ctx,n,argv)
00374 register context *ctx;
00375 register int n;
00376 pointer argv[];
00377 { register pointer a=argv[0];
00378 register int count=0;
00379 if (n==2) n=ckintval(argv[1]);
00380 else n=1;
00381 if (!iscons(a)) {
00382 if (a==NIL) return(NIL);
00383 else error(E_NOLIST); }
00384 if (n<0) error(E_USER,(pointer)"The second argument must be non-negative number");
00385 while (iscons(a)) { ckpush(ccar(a)); a=ccdr(a); count++;}
00386 n=min(count,n);
00387 ctx->vsp -= n;
00388 return((pointer)stacknlist(ctx,count-n));}
00389
00390 pointer NBUTLAST(ctx,n,argv)
00391 register context *ctx;
00392 register int n;
00393 pointer argv[];
00394 { register pointer a=argv[0], b;
00395 register int count=0;
00396 register pointer *vspsave=ctx->vsp;
00397 if (n==2) n=ckintval(argv[1]);
00398 else n=1;
00399 if (!iscons(a)) {
00400 if (a==NIL) return(NIL);
00401 else error(E_NOLIST); }
00402 if (n<0) error(E_USER,(pointer)"The second argument must be non-negative number");
00403 while (iscons(a)) { ckpush(a); a=ccdr(a); count++;}
00404 n=min(count,n);
00405 b= *(ctx->vsp - n - 1);
00406 pointer_update(ccdr(b),NIL);
00407 return(argv[0]);}
00408
00409
00410
00411 void lists(ctx,mod)
00412 register context *ctx;
00413 register pointer mod;
00414 { defun(ctx,"CAR",mod,CAR);
00415 defun(ctx,"CDR",mod,CDR);
00416 defun(ctx,"REST",mod,CDR);
00417 defun(ctx,"CADR",mod,CADR);
00418 defun(ctx,"CDDR",mod,CDDR);
00419 defun(ctx,"CDAR",mod,CDAR);
00420 defun(ctx,"CAAR",mod,CAAR);
00421 defun(ctx,"CADDR",mod,CADDR);
00422 defun(ctx,"NTH",mod,NTH);
00423 defun(ctx,"NTHCDR",mod,NTHCDR);
00424 defun(ctx,"CONS",mod,CONS);
00425 defun(ctx,"RPLACA",mod,RPLACA);
00426 defun(ctx,"RPLACA2",mod,RPLACA2);
00427 defun(ctx,"RPLACD",mod,RPLACD);
00428 defun(ctx,"RPLACD2",mod,RPLACD2);
00429 defun(ctx,"APPEND",mod,APPEND);
00430 defun(ctx,"NCONC",mod,NCONC);
00431 defun(ctx,"SUBST",mod,SUBST);
00432 defun(ctx,"NSUBST",mod,NSUBST);
00433
00434 defun(ctx,"BUTLAST",mod,BUTLAST);
00435 defun(ctx,"NBUTLAST",mod,NBUTLAST);
00436 defun(ctx,"LIST",mod,LIST);
00437 defun(ctx,"LIST*",mod,LIST_STAR);
00438 defun(ctx,"MEMQ",mod,MEMQ);
00439 defun(ctx,"MEMBER",mod,MEMBER);
00440 defun(ctx,"SUPERMEMBER",mod,SUPERMEMBER);
00441 defun(ctx,"ASSQ",mod,ASSQ);
00442 defun(ctx,"ASSOC",mod,ASSOC);
00443 defun(ctx,"SUPERASSOC",mod,SUPERASSOC);
00444 }
00445