Edinburgh Speech Tools  2.4-release
slib_list.cc
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 }
Definition: siod_defs.h:31