246 lines
6.5 KiB
C++
246 lines
6.5 KiB
C++
/*
|
|
* COPYRIGHT (c) 1988-1994 BY *
|
|
* PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
|
|
* See the source file SLIB.C for more information. *
|
|
|
|
* Reorganization of files (Mar 1999) by Alan W Black <awb@cstr.ed.ac.uk>
|
|
|
|
* General list functions
|
|
|
|
*/
|
|
#include <cstdio>
|
|
#include "siod.h"
|
|
#include "siodp.h"
|
|
|
|
static LISP llength(LISP obj)
|
|
{LISP l;
|
|
long n;
|
|
switch TYPE(obj)
|
|
{case tc_string:
|
|
return(flocons(obj->storage_as.string.dim));
|
|
case tc_double_array:
|
|
return(flocons(obj->storage_as.double_array.dim));
|
|
case tc_long_array:
|
|
return(flocons(obj->storage_as.long_array.dim));
|
|
case tc_lisp_array:
|
|
return(flocons(obj->storage_as.lisp_array.dim));
|
|
case tc_nil:
|
|
return(flocons(0.0));
|
|
case tc_cons:
|
|
for(l=obj,n=0;CONSP(l);l=CDR(l),++n) INTERRUPT_CHECK();
|
|
if NNULLP(l) err("improper list to length",obj);
|
|
return(flocons(n));
|
|
default:
|
|
return(err("wrong type of argument to length",obj));}}
|
|
|
|
LISP assoc(LISP x,LISP alist)
|
|
{LISP l,tmp;
|
|
for(l=alist;CONSP(l);l=CDR(l))
|
|
{tmp = CAR(l);
|
|
if (CONSP(tmp) && equal(CAR(tmp),x)) return(tmp);
|
|
INTERRUPT_CHECK();}
|
|
if EQ(l,NIL) return(NIL);
|
|
return(err("improper list to assoc",alist));}
|
|
|
|
LISP assq(LISP x,LISP alist)
|
|
{LISP l,tmp;
|
|
for(l=alist;CONSP(l);l=CDR(l))
|
|
{tmp = CAR(l);
|
|
if (CONSP(tmp) && EQ(CAR(tmp),x)) return(tmp);
|
|
INTERRUPT_CHECK();}
|
|
if EQ(l,NIL) return(NIL);
|
|
return(err("improper list to assq",alist));}
|
|
|
|
LISP setcar(LISP cell, LISP value)
|
|
{if NCONSP(cell) err("wrong type of argument to setcar",cell);
|
|
return(CAR(cell) = value);}
|
|
|
|
LISP setcdr(LISP cell, LISP value)
|
|
{if NCONSP(cell) err("wrong type of argument to setcdr",cell);
|
|
return(CDR(cell) = value);}
|
|
|
|
LISP delq(LISP elem,LISP l)
|
|
{if NULLP(l) return(l);
|
|
STACK_CHECK(&elem);
|
|
if EQ(elem,car(l)) return(cdr(l));
|
|
setcdr(l,delq(elem,cdr(l)));
|
|
return(l);}
|
|
|
|
LISP copy_list(LISP x)
|
|
{if NULLP(x) return(NIL);
|
|
STACK_CHECK(&x);
|
|
return(cons(car(x),copy_list(cdr(x))));}
|
|
|
|
static LISP eq(LISP x,LISP y)
|
|
{if EQ(x,y) return(truth); else return(NIL);}
|
|
|
|
LISP eql(LISP x,LISP y)
|
|
{if EQ(x,y) return(truth); else
|
|
if NFLONUMP(x) return(NIL); else
|
|
if NFLONUMP(y) return(NIL); else
|
|
if (FLONM(x) == FLONM(y)) return(truth);
|
|
return(NIL);}
|
|
|
|
static LISP nullp(LISP x)
|
|
{if EQ(x,NIL) return(truth); else return(NIL);}
|
|
|
|
LISP siod_flatten(LISP tree)
|
|
{
|
|
if (tree == NIL)
|
|
return NIL;
|
|
else if (consp(tree))
|
|
return append(siod_flatten(car(tree)),siod_flatten(cdr(tree)));
|
|
else
|
|
return cons(tree,NIL);
|
|
}
|
|
|
|
LISP cons(LISP x,LISP y)
|
|
{LISP z;
|
|
NEWCELL(z,tc_cons);
|
|
CAR(z) = x;
|
|
CDR(z) = y;
|
|
return(z);}
|
|
|
|
LISP atomp(LISP x)
|
|
{
|
|
if ((x==NIL) || CONSP(x))
|
|
return NIL;
|
|
else
|
|
return truth;
|
|
}
|
|
|
|
LISP consp(LISP x)
|
|
{if CONSP(x) return(truth); else return(NIL);}
|
|
|
|
LISP car(LISP x)
|
|
{switch TYPE(x)
|
|
{case tc_nil:
|
|
return(NIL);
|
|
case tc_cons:
|
|
return(CAR(x));
|
|
default:
|
|
return(err("wrong type of argument to car",x));}}
|
|
|
|
LISP cdr(LISP x)
|
|
{switch TYPE(x)
|
|
{case tc_nil:
|
|
return(NIL);
|
|
case tc_cons:
|
|
return(CDR(x));
|
|
default:
|
|
return(err("wrong type of argument to cdr",x));}}
|
|
|
|
LISP equal(LISP a,LISP b)
|
|
{struct user_type_hooks *p;
|
|
long atype;
|
|
STACK_CHECK(&a);
|
|
loop:
|
|
INTERRUPT_CHECK();
|
|
if EQ(a,b) return(truth);
|
|
atype = TYPE(a);
|
|
if (atype != TYPE(b)) return(NIL);
|
|
switch(atype)
|
|
{case tc_cons:
|
|
if NULLP(equal(car(a),car(b))) return(NIL);
|
|
a = cdr(a);
|
|
b = cdr(b);
|
|
goto loop;
|
|
case tc_flonum:
|
|
return((FLONM(a) == FLONM(b)) ? truth : NIL);
|
|
case tc_symbol:
|
|
case tc_closure:
|
|
case tc_subr_0:
|
|
case tc_subr_1:
|
|
case tc_subr_2:
|
|
case tc_subr_3:
|
|
case tc_subr_4:
|
|
case tc_lsubr:
|
|
case tc_fsubr:
|
|
case tc_msubr:
|
|
return(NIL);
|
|
default:
|
|
p = get_user_type_hooks(atype);
|
|
if (p->equal)
|
|
return((*p->equal)(a,b));
|
|
else if (p) /* a user type */
|
|
return ((USERVAL(a) == USERVAL(b)) ? truth : NIL);
|
|
else
|
|
return(NIL);}}
|
|
|
|
LISP reverse(LISP l)
|
|
{LISP n,p;
|
|
n = NIL;
|
|
for(p=l;NNULLP(p);p=cdr(p)) n = cons(car(p),n);
|
|
return(n);}
|
|
|
|
LISP append(LISP l1, LISP l2)
|
|
{LISP n=l2,p,rl1 = reverse(l1);
|
|
for(p=rl1;NNULLP(p);p=cdr(p))
|
|
n = cons(car(p),n);
|
|
return(n);}
|
|
|
|
void init_subrs_list(void)
|
|
{
|
|
init_subr_2("assoc",assoc,
|
|
"(assoc KEY A-LIST)\n\
|
|
Return pair with KEY in A-LIST or nil.");
|
|
init_subr_1("length",llength,
|
|
"(length LIST)\n\
|
|
Return length of LIST, or 0 if LIST is not a list.");
|
|
init_subr_1("flatten",siod_flatten,
|
|
"(flatten LIST)\n\
|
|
Return flatend list (list of all atoms in LIST).");
|
|
init_subr_2("assq",assq,
|
|
"(assq ITEM ALIST)\n\
|
|
Returns pairs from ALIST whose car is ITEM or nil if ITEM is not in ALIST.");
|
|
init_subr_2("delq",delq,
|
|
"(delq ITEM LIST)\n\
|
|
Destructively delete ITEM from LIST, returns LIST, if ITEM is not first\n\
|
|
in LIST, cdr of LIST otherwise. If ITEM is not in LIST, LIST is\n\
|
|
returned unchanged." );
|
|
init_subr_1("copy-list",copy_list,
|
|
"(copy-list LIST)\n\
|
|
Return new list with same members as LIST.");
|
|
init_subr_2("cons",cons,
|
|
"(cons DATA1 DATA2)\n\
|
|
Construct cons pair whose car is DATA1 and cdr is DATA2.");
|
|
init_subr_1("pair?",consp,
|
|
"(pair? DATA)\n\
|
|
Returns t if DATA is a cons cell, nil otherwise.");
|
|
init_subr_1("car",car,
|
|
"(car DATA1)\n\
|
|
Returns car of DATA1. If DATA1 is nil or a symbol, return nil.");
|
|
init_subr_1("cdr",cdr,
|
|
"(cdr DATA1)\n\
|
|
Returns cdr of DATA1. If DATA1 is nil or a symbol, return nil.");
|
|
init_subr_2("set-car!",setcar,
|
|
"(set-car! CONS1 DATA1)\n\
|
|
Set car of CONS1 to be DATA1. Returns CONS1. If CONS1 not of type\n\
|
|
consp an error is is given. This is a destructive operation.");
|
|
init_subr_2("set-cdr!",setcdr,
|
|
"(set-cdr! CONS1 DATA1)\n\
|
|
Set cdr of CONS1 to be DATA1. Returns CONS1. If CONS1 not of type\n\
|
|
consp an error is is given. This is a destructive operation.");
|
|
init_subr_2("eq?",eq,
|
|
"(eq? DATA1 DATA2)\n\
|
|
Returns t if DATA1 and DATA2 are the same object.");
|
|
init_subr_2("eqv?",eql,
|
|
"(eqv? DATA1 DATA2)\n\
|
|
Returns t if DATA1 and DATA2 are the same object or equal numbers.");
|
|
init_subr_2("equal?",equal,
|
|
"(equal? A B)\n\
|
|
t if s-expressions A and B are recursively equal, nil otherwise.");
|
|
init_subr_1("not",nullp,
|
|
"(not DATA)\n\
|
|
Returns t if DATA is nil, nil otherwise.");
|
|
init_subr_1("null?",nullp,
|
|
"(null? DATA)\n\
|
|
Returns t if DATA is nil, nil otherwise.");
|
|
init_subr_1("reverse",reverse,
|
|
"(reverse LIST)\n\
|
|
Returns destructively reversed LIST.");
|
|
init_subr_2("append",append,
|
|
"(append LIST1 LIST2)\n\
|
|
Returns LIST2 appended to LIST1, LIST1 is distroyed.");
|
|
}
|