File: slib_list.cc

package info (click to toggle)
speech-tools 1:2.5.0-5
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 9,848 kB
  • sloc: cpp: 67,350; ansic: 12,175; sh: 4,047; java: 3,748; makefile: 1,109; lisp: 711; perl: 501; awk: 85; xml: 9
file content (247 lines) | stat: -rw-r--r-- 6,636 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
/*  
 *                   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);
 if NFLONUMP(x) return(NIL);
 if NFLONUMP(y) return(NIL);
 if (FLONM(x) == FLONM(y)) return(truth);
 return(NIL);}

static LISP nullp(LISP x)
{if EQ(x,NIL) 
          return(truth); 
    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.");
}