lists.c
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* LIST functions
00003 /*      1988-July-7
00004 /*      Copyright(C) Toshihiro Matsui, Electrotechnical Laboratory
00005 /*      all rights reserved.
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 /* CAR/CDR combinations*/
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 /* (subst new old list) */
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)) {       /*ignore non-pair elements*/
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,NULL);
00415   defun(ctx,"CDR",mod,CDR,NULL);
00416   defun(ctx,"REST",mod,CDR,NULL);
00417   defun(ctx,"CADR",mod,CADR,NULL);
00418   defun(ctx,"CDDR",mod,CDDR,NULL);
00419   defun(ctx,"CDAR",mod,CDAR,NULL);
00420   defun(ctx,"CAAR",mod,CAAR,NULL);
00421   defun(ctx,"CADDR",mod,CADDR,NULL);
00422   defun(ctx,"NTH",mod,NTH,NULL);
00423   defun(ctx,"NTHCDR",mod,NTHCDR,NULL);
00424   defun(ctx,"CONS",mod,CONS,NULL);
00425   defun(ctx,"RPLACA",mod,RPLACA,NULL);
00426   defun(ctx,"RPLACA2",mod,RPLACA2,NULL);
00427   defun(ctx,"RPLACD",mod,RPLACD,NULL);
00428   defun(ctx,"RPLACD2",mod,RPLACD2,NULL);
00429   defun(ctx,"APPEND",mod,APPEND,NULL);
00430   defun(ctx,"NCONC",mod,NCONC,NULL);
00431   defun(ctx,"SUBST",mod,SUBST,NULL);
00432   defun(ctx,"NSUBST",mod,NSUBST,NULL);
00433 
00434   defun(ctx,"BUTLAST",mod,BUTLAST,NULL);
00435   defun(ctx,"NBUTLAST",mod,NBUTLAST,NULL);
00436   defun(ctx,"LIST",mod,LIST,NULL);
00437   defun(ctx,"LIST*",mod,LIST_STAR,NULL);
00438   defun(ctx,"MEMQ",mod,MEMQ,NULL);
00439   defun(ctx,"MEMBER",mod,MEMBER,NULL);
00440   defun(ctx,"SUPERMEMBER",mod,SUPERMEMBER,NULL);
00441   defun(ctx,"ASSQ",mod,ASSQ,NULL);
00442   defun(ctx,"ASSOC",mod,ASSOC,NULL);
00443   defun(ctx,"SUPERASSOC",mod,SUPERASSOC,NULL);
00444   }
00445 


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