"Fossies" - the Fresh Open Source Software Archive 
1 /*
2 * COPYRIGHT (c) 1988-1994 BY *
3 * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
4 * See the source file SLIB.C for more information. *
5
6 * Reorganization of files (Mar 1999) by Alan W Black <awb@cstr.ed.ac.uk>
7
8 * General list functions
9
10 */
11 #include <cstdio>
12 #include "siod.h"
13 #include "siodp.h"
14
15 static LISP llength(LISP obj)
16 {LISP l;
17 long n;
18 switch TYPE(obj)
19 {case tc_string:
20 return(flocons(obj->storage_as.string.dim));
21 case tc_double_array:
22 return(flocons(obj->storage_as.double_array.dim));
23 case tc_long_array:
24 return(flocons(obj->storage_as.long_array.dim));
25 case tc_lisp_array:
26 return(flocons(obj->storage_as.lisp_array.dim));
27 case tc_nil:
28 return(flocons(0.0));
29 case tc_cons:
30 for(l=obj,n=0;CONSP(l);l=CDR(l),++n) INTERRUPT_CHECK();
31 if NNULLP(l) err("improper list to length",obj);
32 return(flocons(n));
33 default:
34 return(err("wrong type of argument to length",obj));}}
35
36 LISP assoc(LISP x,LISP alist)
37 {LISP l,tmp;
38 for(l=alist;CONSP(l);l=CDR(l))
39 {tmp = CAR(l);
40 if (CONSP(tmp) && equal(CAR(tmp),x)) return(tmp);
41 INTERRUPT_CHECK();}
42 if EQ(l,NIL) return(NIL);
43 return(err("improper list to assoc",alist));}
44
45 LISP assq(LISP x,LISP alist)
46 {LISP l,tmp;
47 for(l=alist;CONSP(l);l=CDR(l))
48 {tmp = CAR(l);
49 if (CONSP(tmp) && EQ(CAR(tmp),x)) return(tmp);
50 INTERRUPT_CHECK();}
51 if EQ(l,NIL) return(NIL);
52 return(err("improper list to assq",alist));}
53
54 LISP setcar(LISP cell, LISP value)
55 {if NCONSP(cell) err("wrong type of argument to setcar",cell);
56 return(CAR(cell) = value);}
57
58 LISP setcdr(LISP cell, LISP value)
59 {if NCONSP(cell) err("wrong type of argument to setcdr",cell);
60 return(CDR(cell) = value);}
61
62 LISP delq(LISP elem,LISP l)
63 {if NULLP(l) return(l);
64 STACK_CHECK(&elem);
65 if EQ(elem,car(l)) return(cdr(l));
66 setcdr(l,delq(elem,cdr(l)));
67 return(l);}
68
69 LISP copy_list(LISP x)
70 {if NULLP(x) return(NIL);
71 STACK_CHECK(&x);
72 return(cons(car(x),copy_list(cdr(x))));}
73
74 static LISP eq(LISP x,LISP y)
75 {if EQ(x,y) return(truth); else return(NIL);}
76
77 LISP eql(LISP x,LISP y)
78 {if EQ(x,y) return(truth);
79 if NFLONUMP(x) return(NIL);
80 if NFLONUMP(y) return(NIL);
81 if (FLONM(x) == FLONM(y)) return(truth);
82 return(NIL);}
83
84 static LISP nullp(LISP x)
85 {if EQ(x,NIL)
86 return(truth);
87 return(NIL);}
88
89 LISP siod_flatten(LISP tree)
90 {
91 if (tree == NIL)
92 return NIL;
93 else if (consp(tree))
94 return append(siod_flatten(car(tree)),siod_flatten(cdr(tree)));
95 else
96 return cons(tree,NIL);
97 }
98
99 LISP cons(LISP x,LISP y)
100 {LISP z;
101 NEWCELL(z,tc_cons);
102 CAR(z) = x;
103 CDR(z) = y;
104 return(z);}
105
106 LISP atomp(LISP x)
107 {
108 if ((x==NIL) || CONSP(x))
109 return NIL;
110 else
111 return truth;
112 }
113
114 LISP consp(LISP x)
115 {if CONSP(x) return(truth); else return(NIL);}
116
117 LISP car(LISP x)
118 {switch TYPE(x)
119 {case tc_nil:
120 return(NIL);
121 case tc_cons:
122 return(CAR(x));
123 default:
124 return(err("wrong type of argument to car",x));}}
125
126 LISP cdr(LISP x)
127 {switch TYPE(x)
128 {case tc_nil:
129 return(NIL);
130 case tc_cons:
131 return(CDR(x));
132 default:
133 return(err("wrong type of argument to cdr",x));}}
134
135 LISP equal(LISP a,LISP b)
136 {struct user_type_hooks *p;
137 long atype;
138 STACK_CHECK(&a);
139 loop:
140 INTERRUPT_CHECK();
141 if EQ(a,b) return(truth);
142 atype = TYPE(a);
143 if (atype != TYPE(b)) return(NIL);
144 switch(atype)
145 {case tc_cons:
146 if NULLP(equal(car(a),car(b))) return(NIL);
147 a = cdr(a);
148 b = cdr(b);
149 goto loop;
150 case tc_flonum:
151 return((FLONM(a) == FLONM(b)) ? truth : NIL);
152 case tc_symbol:
153 case tc_closure:
154 case tc_subr_0:
155 case tc_subr_1:
156 case tc_subr_2:
157 case tc_subr_3:
158 case tc_subr_4:
159 case tc_lsubr:
160 case tc_fsubr:
161 case tc_msubr:
162 return(NIL);
163 default:
164 p = get_user_type_hooks(atype);
165 if (p->equal)
166 return((*p->equal)(a,b));
167 else if (p) /* a user type */
168 return ((USERVAL(a) == USERVAL(b)) ? truth : NIL);
169 else
170 return(NIL);}}
171
172 LISP reverse(LISP l)
173 {LISP n,p;
174 n = NIL;
175 for(p=l;NNULLP(p);p=cdr(p)) n = cons(car(p),n);
176 return(n);}
177
178 LISP append(LISP l1, LISP l2)
179 {LISP n=l2,p,rl1 = reverse(l1);
180 for(p=rl1;NNULLP(p);p=cdr(p))
181 n = cons(car(p),n);
182 return(n);}
183
184 void init_subrs_list(void)
185 {
186 init_subr_2("assoc",assoc,
187 "(assoc KEY A-LIST)\n\
188 Return pair with KEY in A-LIST or nil.");
189 init_subr_1("length",llength,
190 "(length LIST)\n\
191 Return length of LIST, or 0 if LIST is not a list.");
192 init_subr_1("flatten",siod_flatten,
193 "(flatten LIST)\n\
194 Return flatend list (list of all atoms in LIST).");
195 init_subr_2("assq",assq,
196 "(assq ITEM ALIST)\n\
197 Returns pairs from ALIST whose car is ITEM or nil if ITEM is not in ALIST.");
198 init_subr_2("delq",delq,
199 "(delq ITEM LIST)\n\
200 Destructively delete ITEM from LIST, returns LIST, if ITEM is not first\n\
201 in LIST, cdr of LIST otherwise. If ITEM is not in LIST, LIST is\n\
202 returned unchanged." );
203 init_subr_1("copy-list",copy_list,
204 "(copy-list LIST)\n\
205 Return new list with same members as LIST.");
206 init_subr_2("cons",cons,
207 "(cons DATA1 DATA2)\n\
208 Construct cons pair whose car is DATA1 and cdr is DATA2.");
209 init_subr_1("pair?",consp,
210 "(pair? DATA)\n\
211 Returns t if DATA is a cons cell, nil otherwise.");
212 init_subr_1("car",car,
213 "(car DATA1)\n\
214 Returns car of DATA1. If DATA1 is nil or a symbol, return nil.");
215 init_subr_1("cdr",cdr,
216 "(cdr DATA1)\n\
217 Returns cdr of DATA1. If DATA1 is nil or a symbol, return nil.");
218 init_subr_2("set-car!",setcar,
219 "(set-car! CONS1 DATA1)\n\
220 Set car of CONS1 to be DATA1. Returns CONS1. If CONS1 not of type\n\
221 consp an error is is given. This is a destructive operation.");
222 init_subr_2("set-cdr!",setcdr,
223 "(set-cdr! CONS1 DATA1)\n\
224 Set cdr of CONS1 to be DATA1. Returns CONS1. If CONS1 not of type\n\
225 consp an error is is given. This is a destructive operation.");
226 init_subr_2("eq?",eq,
227 "(eq? DATA1 DATA2)\n\
228 Returns t if DATA1 and DATA2 are the same object.");
229 init_subr_2("eqv?",eql,
230 "(eqv? DATA1 DATA2)\n\
231 Returns t if DATA1 and DATA2 are the same object or equal numbers.");
232 init_subr_2("equal?",equal,
233 "(equal? A B)\n\
234 t if s-expressions A and B are recursively equal, nil otherwise.");
235 init_subr_1("not",nullp,
236 "(not DATA)\n\
237 Returns t if DATA is nil, nil otherwise.");
238 init_subr_1("null?",nullp,
239 "(null? DATA)\n\
240 Returns t if DATA is nil, nil otherwise.");
241 init_subr_1("reverse",reverse,
242 "(reverse LIST)\n\
243 Returns destructively reversed LIST.");
244 init_subr_2("append",append,
245 "(append LIST1 LIST2)\n\
246 Returns LIST2 appended to LIST1, LIST1 is distroyed.");
247 }
2.4-release_vs_2.5.0-release.