1 /* fns1.c Copyright (C) 1989-2008 Codemist Ltd */
2
3 /*
4 * Basic functions part 1.
5 */
6
7 /**************************************************************************
8 * Copyright (C) 2008, Codemist Ltd. A C Norman *
9 * *
10 * Redistribution and use in source and binary forms, with or without *
11 * modification, are permitted provided that the following conditions are *
12 * met: *
13 * *
14 * * Redistributions of source code must retain the relevant *
15 * copyright notice, this list of conditions and the following *
16 * disclaimer. *
17 * * Redistributions in binary form must reproduce the above *
18 * copyright notice, this list of conditions and the following *
19 * disclaimer in the documentation and/or other materials provided *
20 * with the distribution. *
21 * *
22 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *
23 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *
24 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *
25 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *
26 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *
27 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *
28 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS *
29 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
30 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR *
31 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF *
32 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *
33 * DAMAGE. *
34 *************************************************************************/
35
36
37
38 /* Signature: 3c078181 18-Aug-2010 */
39
40 #include "headers.h"
41
42
43
44
45 /*****************************************************************************/
46 /* Some basic functions */
47 /*****************************************************************************/
48
integerp(Lisp_Object p)49 Lisp_Object integerp(Lisp_Object p)
50 {
51 Lisp_Object nil = C_nil;
52 int tag = ((int)p) & TAG_BITS;
53 if (tag == TAG_FIXNUM) return lisp_true;
54 if (tag == TAG_NUMBERS)
55 { Header h = *(Header *)((char *)p - TAG_NUMBERS);
56 if (type_of_header(h) == TYPE_BIGNUM) return lisp_true;
57 }
58 return nil;
59 }
60
61 /*****************************************************************************/
62 /* Storage allocation. */
63 /*****************************************************************************/
64
65
cons(Lisp_Object a,Lisp_Object b)66 Lisp_Object cons(Lisp_Object a, Lisp_Object b)
67 {
68 nil_as_base
69 Lisp_Object r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
70 qcar(r) = a;
71 qcdr(r) = b;
72 fringe = r;
73 if ((char *)r <= (char *)heaplimit)
74 return reclaim((Lisp_Object)((char *)r + TAG_CONS),
75 "internal cons", GC_CONS, 0);
76 else return (Lisp_Object)((char *)r + TAG_CONS);
77 }
78
cons_no_gc(Lisp_Object a,Lisp_Object b)79 Lisp_Object cons_no_gc(Lisp_Object a, Lisp_Object b)
80 {
81 nil_as_base
82 Lisp_Object r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
83 qcar(r) = a;
84 qcdr(r) = b;
85 fringe = r;
86 return (Lisp_Object)((char *)r + TAG_CONS);
87 }
88
89 /*
90 * cons_gc_test() MUST be called after any sequence of cons_no_gc() calls.
91 */
92
cons_gc_test(Lisp_Object p)93 Lisp_Object cons_gc_test(Lisp_Object p)
94 {
95 nil_as_base
96 if ((char *)fringe <= (char *)heaplimit)
97 return reclaim(p, "cons gc test", GC_CONS, 0);
98 else return p;
99 }
100
ncons(Lisp_Object a)101 Lisp_Object ncons(Lisp_Object a)
102 {
103 Lisp_Object nil = C_nil;
104 Lisp_Object r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
105 qcar(r) = a;
106 qcdr(r) = nil;
107 fringe = r;
108 if ((char *)r <= (char *)heaplimit)
109 return reclaim((Lisp_Object)((char *)r + TAG_CONS),
110 "internal ncons", GC_CONS, 0);
111 else return (Lisp_Object)((char *)r + TAG_CONS);
112 }
113
list2(Lisp_Object a,Lisp_Object b)114 Lisp_Object list2(Lisp_Object a, Lisp_Object b)
115 {
116 /* Note that building two cons cells at once saves some overhead here */
117 Lisp_Object nil = C_nil;
118 Lisp_Object r = (Lisp_Object)((char *)fringe - 2*sizeof(Cons_Cell));
119 qcar(r) = a;
120 qcdr(r) = (Lisp_Object)((char *)r + sizeof(Cons_Cell) + TAG_CONS);
121 qcar((char *)r+sizeof(Cons_Cell)) = b;
122 qcdr((char *)r+sizeof(Cons_Cell)) = nil;
123 fringe = r;
124 if ((char *)r <= (char *)heaplimit)
125 return reclaim((Lisp_Object)((char *)r + TAG_CONS),
126 "internal list2", GC_CONS, 0);
127 else return (Lisp_Object)((char *)r + TAG_CONS);
128 }
129
list2star(Lisp_Object a,Lisp_Object b,Lisp_Object c)130 Lisp_Object list2star(Lisp_Object a, Lisp_Object b, Lisp_Object c)
131 {
132 nil_as_base
133 Lisp_Object r = (Lisp_Object)((char *)fringe - 2*sizeof(Cons_Cell));
134 qcar(r) = a;
135 qcdr(r) = (Lisp_Object)((char *)r + sizeof(Cons_Cell) + TAG_CONS);
136 qcar((char *)r+sizeof(Cons_Cell)) = b;
137 qcdr((char *)r+sizeof(Cons_Cell)) = c;
138 fringe = r;
139 if ((char *)r <= (char *)heaplimit)
140 return reclaim((Lisp_Object)((char *)r + TAG_CONS),
141 "internal list2*", GC_CONS, 0);
142 else return (Lisp_Object)((char *)r + TAG_CONS);
143 }
144
list3star(Lisp_Object a,Lisp_Object b,Lisp_Object c,Lisp_Object d)145 Lisp_Object list3star(Lisp_Object a, Lisp_Object b, Lisp_Object c, Lisp_Object d)
146 {
147 nil_as_base
148 Lisp_Object r = (Lisp_Object)((char *)fringe - 3*sizeof(Cons_Cell));
149 qcar(r) = a;
150 qcdr(r) = (Lisp_Object)((char *)r + sizeof(Cons_Cell) + TAG_CONS);
151 qcar((char *)r+sizeof(Cons_Cell)) = b;
152 qcdr((char *)r+sizeof(Cons_Cell)) =
153 (Lisp_Object)((char *)r + 2*sizeof(Cons_Cell) + TAG_CONS);
154 qcar((char *)r+2*sizeof(Cons_Cell)) = c;
155 qcdr((char *)r+2*sizeof(Cons_Cell)) = d;
156 fringe = r;
157 if ((char *)r <= (char *)heaplimit)
158 return reclaim((Lisp_Object)((char *)r + TAG_CONS),
159 "internal list3*", GC_CONS, 0);
160 else return (Lisp_Object)((char *)r + TAG_CONS);
161 }
162
list4(Lisp_Object a,Lisp_Object b,Lisp_Object c,Lisp_Object d)163 Lisp_Object list4(Lisp_Object a, Lisp_Object b, Lisp_Object c, Lisp_Object d)
164 {
165 Lisp_Object nil = C_nil;
166 Lisp_Object r = (Lisp_Object)((char *)fringe - 4*sizeof(Cons_Cell));
167 qcar(r) = a;
168 qcdr(r) = (Lisp_Object)((char *)r + sizeof(Cons_Cell) + TAG_CONS);
169 qcar((char *)r+sizeof(Cons_Cell)) = b;
170 qcdr((char *)r+sizeof(Cons_Cell)) =
171 (Lisp_Object)((char *)r + 2*sizeof(Cons_Cell) + TAG_CONS);
172 qcar((char *)r+2*sizeof(Cons_Cell)) = c;
173 qcdr((char *)r+2*sizeof(Cons_Cell)) =
174 (Lisp_Object)((char *)r + 3*sizeof(Cons_Cell) + TAG_CONS);
175 qcar((char *)r +3*sizeof(Cons_Cell)) = d;
176 qcdr((char *)r + 3*sizeof(Cons_Cell)) = nil;
177 fringe = r;
178 if ((char *)r <= (char *)heaplimit)
179 return reclaim((Lisp_Object)((char *)r + TAG_CONS),
180 "internal list4", GC_CONS, 0);
181 else return (Lisp_Object)((char *)r + TAG_CONS);
182 }
183
184
185
acons(Lisp_Object a,Lisp_Object b,Lisp_Object c)186 Lisp_Object acons(Lisp_Object a, Lisp_Object b, Lisp_Object c)
187 {
188 nil_as_base
189 Lisp_Object r = (Lisp_Object)((char *)fringe - 2*sizeof(Cons_Cell));
190 qcar(r) = (Lisp_Object)((char *)r + sizeof(Cons_Cell) + TAG_CONS);
191 qcdr(r) = c;
192 qcar((char *)r+sizeof(Cons_Cell)) = a;
193 qcdr((char *)r+sizeof(Cons_Cell)) = b;
194 fringe = r;
195 if ((char *)r <= (char *)heaplimit)
196 return reclaim((Lisp_Object)((char *)r + TAG_CONS),
197 "internal acons", GC_CONS, 0);
198 else return (Lisp_Object)((char *)r + TAG_CONS);
199 }
200
list3(Lisp_Object a,Lisp_Object b,Lisp_Object c)201 Lisp_Object list3(Lisp_Object a, Lisp_Object b, Lisp_Object c)
202 {
203 Lisp_Object nil = C_nil;
204 Lisp_Object r = (Lisp_Object)((char *)fringe - 3*sizeof(Cons_Cell));
205 qcar(r) = a;
206 qcdr(r) = (Lisp_Object)((char *)r + sizeof(Cons_Cell) + TAG_CONS);
207 qcar((char *)r+sizeof(Cons_Cell)) = b;
208 qcdr((char *)r+sizeof(Cons_Cell)) =
209 (Lisp_Object)((char *)r + 2*sizeof(Cons_Cell) + TAG_CONS);
210 qcar((char *)r+2*sizeof(Cons_Cell)) = c;
211 qcdr((char *)r+2*sizeof(Cons_Cell)) = nil;
212 fringe = r;
213 if ((char *)r <= (char *)heaplimit)
214 return reclaim((Lisp_Object)((char *)r + TAG_CONS),
215 "internal list3", GC_CONS, 0);
216 else return (Lisp_Object)((char *)r + TAG_CONS);
217 }
218
219 /*****************************************************************************/
220 /*****************************************************************************/
221 /*** Lisp-callable versions of all the above ***/
222 /*****************************************************************************/
223 /*****************************************************************************/
224
225 /*
226 * The set of car/cdr combinations here seem pretty dull, but they
227 * are fairly important for performance...
228 */
229
Lcar(Lisp_Object nil,Lisp_Object a)230 Lisp_Object Lcar(Lisp_Object nil, Lisp_Object a)
231 {
232 CSL_IGNORE(nil);
233 if (!car_legal(a)) return error(1, err_bad_car, a);
234 else return onevalue(qcar(a));
235 }
236
237 /*
238 * (car* a) = (car a) if a is non-atomic, but just a otherwise.
239 */
240
Lcar_star(Lisp_Object nil,Lisp_Object a)241 Lisp_Object Lcar_star(Lisp_Object nil, Lisp_Object a)
242 {
243 CSL_IGNORE(nil);
244 if (!car_legal(a)) return onevalue(a);
245 else return onevalue(qcar(a));
246 }
247
Lcdr(Lisp_Object nil,Lisp_Object a)248 Lisp_Object Lcdr(Lisp_Object nil, Lisp_Object a)
249 {
250 CSL_IGNORE(nil);
251 if (!car_legal(a)) return error(1, err_bad_cdr, a);
252 else return onevalue(qcdr(a));
253 }
254
Lcaar(Lisp_Object nil,Lisp_Object a)255 Lisp_Object Lcaar(Lisp_Object nil, Lisp_Object a)
256 {
257 CSL_IGNORE(nil);
258 if (!car_legal(a)) return error(1, err_bad_car, a);
259 else a = qcar(a);
260 if (!car_legal(a)) return error(1, err_bad_car, a);
261 else return onevalue(qcar(a));
262 }
263
Lcadr(Lisp_Object nil,Lisp_Object a)264 Lisp_Object Lcadr(Lisp_Object nil, Lisp_Object a)
265 {
266 CSL_IGNORE(nil);
267 if (!car_legal(a)) return error(1, err_bad_cdr, a);
268 else a = qcdr(a);
269 if (!car_legal(a)) return error(1, err_bad_car, a);
270 else return onevalue(qcar(a));
271 }
272
Lcdar(Lisp_Object nil,Lisp_Object a)273 Lisp_Object Lcdar(Lisp_Object nil, Lisp_Object a)
274 {
275 CSL_IGNORE(nil);
276 if (!car_legal(a)) return error(1, err_bad_car, a);
277 else a = qcar(a);
278 if (!car_legal(a)) return error(1, err_bad_cdr, a);
279 else return onevalue(qcdr(a));
280 }
281
Lcddr(Lisp_Object nil,Lisp_Object a)282 Lisp_Object Lcddr(Lisp_Object nil, Lisp_Object a)
283 {
284 CSL_IGNORE(nil);
285 if (!car_legal(a)) return error(1, err_bad_cdr, a);
286 else a = qcdr(a);
287 if (!car_legal(a)) return error(1, err_bad_cdr, a);
288 else return onevalue(qcdr(a));
289 }
290
Lcaaar(Lisp_Object nil,Lisp_Object a)291 Lisp_Object Lcaaar(Lisp_Object nil, Lisp_Object a)
292 {
293 CSL_IGNORE(nil);
294 if (!car_legal(a)) return error(1, err_bad_car, a);
295 else a = qcar(a);
296 if (!car_legal(a)) return error(1, err_bad_car, a);
297 else a = qcar(a);
298 if (!car_legal(a)) return error(1, err_bad_car, a);
299 else return onevalue(qcar(a));
300 }
301
Lcaadr(Lisp_Object nil,Lisp_Object a)302 Lisp_Object Lcaadr(Lisp_Object nil, Lisp_Object a)
303 {
304 CSL_IGNORE(nil);
305 if (!car_legal(a)) return error(1, err_bad_cdr, a);
306 else a = qcdr(a);
307 if (!car_legal(a)) return error(1, err_bad_car, a);
308 else a = qcar(a);
309 if (!car_legal(a)) return error(1, err_bad_car, a);
310 else return onevalue(qcar(a));
311 }
312
Lcadar(Lisp_Object nil,Lisp_Object a)313 Lisp_Object Lcadar(Lisp_Object nil, Lisp_Object a)
314 {
315 CSL_IGNORE(nil);
316 if (!car_legal(a)) return error(1, err_bad_car, a);
317 else a = qcar(a);
318 if (!car_legal(a)) return error(1, err_bad_cdr, a);
319 else a = qcdr(a);
320 if (!car_legal(a)) return error(1, err_bad_car, a);
321 else return onevalue(qcar(a));
322 }
323
Lcaddr(Lisp_Object nil,Lisp_Object a)324 Lisp_Object Lcaddr(Lisp_Object nil, Lisp_Object a)
325 {
326 CSL_IGNORE(nil);
327 if (!car_legal(a)) return error(1, err_bad_cdr, a);
328 else a = qcdr(a);
329 if (!car_legal(a)) return error(1, err_bad_cdr, a);
330 else a = qcdr(a);
331 if (!car_legal(a)) return error(1, err_bad_car, a);
332 else return onevalue(qcar(a));
333 }
334
Lcdaar(Lisp_Object nil,Lisp_Object a)335 Lisp_Object Lcdaar(Lisp_Object nil, Lisp_Object a)
336 {
337 CSL_IGNORE(nil);
338 if (!car_legal(a)) return error(1, err_bad_car, a);
339 else a = qcar(a);
340 if (!car_legal(a)) return error(1, err_bad_car, a);
341 else a = qcar(a);
342 if (!car_legal(a)) return error(1, err_bad_cdr, a);
343 else return onevalue(qcdr(a));
344 }
345
Lcdadr(Lisp_Object nil,Lisp_Object a)346 Lisp_Object Lcdadr(Lisp_Object nil, Lisp_Object a)
347 {
348 CSL_IGNORE(nil);
349 if (!car_legal(a)) return error(1, err_bad_cdr, a);
350 else a = qcdr(a);
351 if (!car_legal(a)) return error(1, err_bad_car, a);
352 else a = qcar(a);
353 if (!car_legal(a)) return error(1, err_bad_cdr, a);
354 else return onevalue(qcdr(a));
355 }
356
Lcddar(Lisp_Object nil,Lisp_Object a)357 Lisp_Object Lcddar(Lisp_Object nil, Lisp_Object a)
358 {
359 CSL_IGNORE(nil);
360 if (!car_legal(a)) return error(1, err_bad_car, a);
361 else a = qcar(a);
362 if (!car_legal(a)) return error(1, err_bad_cdr, a);
363 else a = qcdr(a);
364 if (!car_legal(a)) return error(1, err_bad_cdr, a);
365 else return onevalue(qcdr(a));
366 }
367
Lcdddr(Lisp_Object nil,Lisp_Object a)368 Lisp_Object Lcdddr(Lisp_Object nil, Lisp_Object a)
369 {
370 CSL_IGNORE(nil);
371 if (!car_legal(a)) return error(1, err_bad_cdr, a);
372 else a = qcdr(a);
373 if (!car_legal(a)) return error(1, err_bad_cdr, a);
374 else a = qcdr(a);
375 if (!car_legal(a)) return error(1, err_bad_cdr, a);
376 else return onevalue(qcdr(a));
377 }
378
Lcaaaar(Lisp_Object nil,Lisp_Object a)379 Lisp_Object Lcaaaar(Lisp_Object nil, Lisp_Object a)
380 {
381 CSL_IGNORE(nil);
382 if (!car_legal(a)) return error(1, err_bad_car, a);
383 else a = qcar(a);
384 if (!car_legal(a)) return error(1, err_bad_car, a);
385 else a = qcar(a);
386 if (!car_legal(a)) return error(1, err_bad_car, a);
387 else a = qcar(a);
388 if (!car_legal(a)) return error(1, err_bad_car, a);
389 else return onevalue(qcar(a));
390 }
391
Lcaaadr(Lisp_Object nil,Lisp_Object a)392 Lisp_Object Lcaaadr(Lisp_Object nil, Lisp_Object a)
393 {
394 CSL_IGNORE(nil);
395 if (!car_legal(a)) return error(1, err_bad_cdr, a);
396 else a = qcdr(a);
397 if (!car_legal(a)) return error(1, err_bad_car, a);
398 else a = qcar(a);
399 if (!car_legal(a)) return error(1, err_bad_car, a);
400 else a = qcar(a);
401 if (!car_legal(a)) return error(1, err_bad_car, a);
402 else return onevalue(qcar(a));
403 }
404
Lcaadar(Lisp_Object nil,Lisp_Object a)405 Lisp_Object Lcaadar(Lisp_Object nil, Lisp_Object a)
406 {
407 CSL_IGNORE(nil);
408 if (!car_legal(a)) return error(1, err_bad_car, a);
409 else a = qcar(a);
410 if (!car_legal(a)) return error(1, err_bad_cdr, a);
411 else a = qcdr(a);
412 if (!car_legal(a)) return error(1, err_bad_car, a);
413 else a = qcar(a);
414 if (!car_legal(a)) return error(1, err_bad_car, a);
415 else return onevalue(qcar(a));
416 }
417
Lcaaddr(Lisp_Object nil,Lisp_Object a)418 Lisp_Object Lcaaddr(Lisp_Object nil, Lisp_Object a)
419 {
420 CSL_IGNORE(nil);
421 if (!car_legal(a)) return error(1, err_bad_cdr, a);
422 else a = qcdr(a);
423 if (!car_legal(a)) return error(1, err_bad_cdr, a);
424 else a = qcdr(a);
425 if (!car_legal(a)) return error(1, err_bad_car, a);
426 else a = qcar(a);
427 if (!car_legal(a)) return error(1, err_bad_car, a);
428 else return onevalue(qcar(a));
429 }
430
Lcadaar(Lisp_Object nil,Lisp_Object a)431 Lisp_Object Lcadaar(Lisp_Object nil, Lisp_Object a)
432 {
433 CSL_IGNORE(nil);
434 if (!car_legal(a)) return error(1, err_bad_car, a);
435 else a = qcar(a);
436 if (!car_legal(a)) return error(1, err_bad_car, a);
437 else a = qcar(a);
438 if (!car_legal(a)) return error(1, err_bad_cdr, a);
439 else a = qcdr(a);
440 if (!car_legal(a)) return error(1, err_bad_car, a);
441 else return onevalue(qcar(a));
442 }
443
Lcadadr(Lisp_Object nil,Lisp_Object a)444 Lisp_Object Lcadadr(Lisp_Object nil, Lisp_Object a)
445 {
446 CSL_IGNORE(nil);
447 if (!car_legal(a)) return error(1, err_bad_cdr, a);
448 else a = qcdr(a);
449 if (!car_legal(a)) return error(1, err_bad_car, a);
450 else a = qcar(a);
451 if (!car_legal(a)) return error(1, err_bad_cdr, a);
452 else a = qcdr(a);
453 if (!car_legal(a)) return error(1, err_bad_car, a);
454 else return onevalue(qcar(a));
455 }
456
Lcaddar(Lisp_Object nil,Lisp_Object a)457 Lisp_Object Lcaddar(Lisp_Object nil, Lisp_Object a)
458 {
459 CSL_IGNORE(nil);
460 if (!car_legal(a)) return error(1, err_bad_car, a);
461 else a = qcar(a);
462 if (!car_legal(a)) return error(1, err_bad_cdr, a);
463 else a = qcdr(a);
464 if (!car_legal(a)) return error(1, err_bad_cdr, a);
465 else a = qcdr(a);
466 if (!car_legal(a)) return error(1, err_bad_car, a);
467 else return onevalue(qcar(a));
468 }
469
Lcadddr(Lisp_Object nil,Lisp_Object a)470 Lisp_Object Lcadddr(Lisp_Object nil, Lisp_Object a)
471 {
472 CSL_IGNORE(nil);
473 if (!car_legal(a)) return error(1, err_bad_cdr, a);
474 else a = qcdr(a);
475 if (!car_legal(a)) return error(1, err_bad_cdr, a);
476 else a = qcdr(a);
477 if (!car_legal(a)) return error(1, err_bad_cdr, a);
478 else a = qcdr(a);
479 if (!car_legal(a)) return error(1, err_bad_car, a);
480 else return onevalue(qcar(a));
481 }
482
Lcdaaar(Lisp_Object nil,Lisp_Object a)483 Lisp_Object Lcdaaar(Lisp_Object nil, Lisp_Object a)
484 {
485 CSL_IGNORE(nil);
486 if (!car_legal(a)) return error(1, err_bad_car, a);
487 else a = qcar(a);
488 if (!car_legal(a)) return error(1, err_bad_car, a);
489 else a = qcar(a);
490 if (!car_legal(a)) return error(1, err_bad_car, a);
491 else a = qcar(a);
492 if (!car_legal(a)) return error(1, err_bad_cdr, a);
493 else return onevalue(qcdr(a));
494 }
495
Lcdaadr(Lisp_Object nil,Lisp_Object a)496 Lisp_Object Lcdaadr(Lisp_Object nil, Lisp_Object a)
497 {
498 CSL_IGNORE(nil);
499 if (!car_legal(a)) return error(1, err_bad_cdr, a);
500 else a = qcdr(a);
501 if (!car_legal(a)) return error(1, err_bad_car, a);
502 else a = qcar(a);
503 if (!car_legal(a)) return error(1, err_bad_car, a);
504 else a = qcar(a);
505 if (!car_legal(a)) return error(1, err_bad_cdr, a);
506 else return onevalue(qcdr(a));
507 }
508
Lcdadar(Lisp_Object nil,Lisp_Object a)509 Lisp_Object Lcdadar(Lisp_Object nil, Lisp_Object a)
510 {
511 CSL_IGNORE(nil);
512 if (!car_legal(a)) return error(1, err_bad_car, a);
513 else a = qcar(a);
514 if (!car_legal(a)) return error(1, err_bad_cdr, a);
515 else a = qcdr(a);
516 if (!car_legal(a)) return error(1, err_bad_car, a);
517 else a = qcar(a);
518 if (!car_legal(a)) return error(1, err_bad_cdr, a);
519 else return onevalue(qcdr(a));
520 }
521
Lcdaddr(Lisp_Object nil,Lisp_Object a)522 Lisp_Object Lcdaddr(Lisp_Object nil, Lisp_Object a)
523 {
524 CSL_IGNORE(nil);
525 if (!car_legal(a)) return error(1, err_bad_cdr, a);
526 else a = qcdr(a);
527 if (!car_legal(a)) return error(1, err_bad_cdr, a);
528 else a = qcdr(a);
529 if (!car_legal(a)) return error(1, err_bad_car, a);
530 else a = qcar(a);
531 if (!car_legal(a)) return error(1, err_bad_cdr, a);
532 else return onevalue(qcdr(a));
533 }
534
Lcddaar(Lisp_Object nil,Lisp_Object a)535 Lisp_Object Lcddaar(Lisp_Object nil, Lisp_Object a)
536 {
537 CSL_IGNORE(nil);
538 if (!car_legal(a)) return error(1, err_bad_car, a);
539 else a = qcar(a);
540 if (!car_legal(a)) return error(1, err_bad_car, a);
541 else a = qcar(a);
542 if (!car_legal(a)) return error(1, err_bad_cdr, a);
543 else a = qcdr(a);
544 if (!car_legal(a)) return error(1, err_bad_cdr, a);
545 else return onevalue(qcdr(a));
546 }
547
Lcddadr(Lisp_Object nil,Lisp_Object a)548 Lisp_Object Lcddadr(Lisp_Object nil, Lisp_Object a)
549 {
550 CSL_IGNORE(nil);
551 if (!car_legal(a)) return error(1, err_bad_cdr, a);
552 else a = qcdr(a);
553 if (!car_legal(a)) return error(1, err_bad_car, a);
554 else a = qcar(a);
555 if (!car_legal(a)) return error(1, err_bad_cdr, a);
556 else a = qcdr(a);
557 if (!car_legal(a)) return error(1, err_bad_cdr, a);
558 else return onevalue(qcdr(a));
559 }
560
Lcdddar(Lisp_Object nil,Lisp_Object a)561 Lisp_Object Lcdddar(Lisp_Object nil, Lisp_Object a)
562 {
563 CSL_IGNORE(nil);
564 if (!car_legal(a)) return error(1, err_bad_car, a);
565 else a = qcar(a);
566 if (!car_legal(a)) return error(1, err_bad_cdr, a);
567 else a = qcdr(a);
568 if (!car_legal(a)) return error(1, err_bad_cdr, a);
569 else a = qcdr(a);
570 if (!car_legal(a)) return error(1, err_bad_cdr, a);
571 else return onevalue(qcdr(a));
572 }
573
Lcddddr(Lisp_Object nil,Lisp_Object a)574 Lisp_Object Lcddddr(Lisp_Object nil, Lisp_Object a)
575 {
576 CSL_IGNORE(nil);
577 if (!car_legal(a)) return error(1, err_bad_cdr, a);
578 else a = qcdr(a);
579 if (!car_legal(a)) return error(1, err_bad_cdr, a);
580 else a = qcdr(a);
581 if (!car_legal(a)) return error(1, err_bad_cdr, a);
582 else a = qcdr(a);
583 if (!car_legal(a)) return error(1, err_bad_cdr, a);
584 else return onevalue(qcdr(a));
585 }
586
Lrplaca(Lisp_Object nil,Lisp_Object a,Lisp_Object b)587 Lisp_Object Lrplaca(Lisp_Object nil,
588 Lisp_Object a, Lisp_Object b)
589 {
590 CSL_IGNORE(nil);
591 if (!consp(a)) return error(1, err_bad_rplac, a);
592 qcar(a) = b;
593 return onevalue(a);
594 }
595
Lrplacd(Lisp_Object nil,Lisp_Object a,Lisp_Object b)596 Lisp_Object Lrplacd(Lisp_Object nil,
597 Lisp_Object a, Lisp_Object b)
598 {
599 CSL_IGNORE(nil);
600 if (!consp(a)) return error(1, err_bad_rplac, a);
601 qcdr(a) = b;
602 return onevalue(a);
603 }
604
Lsymbolp(Lisp_Object nil,Lisp_Object a)605 Lisp_Object Lsymbolp(Lisp_Object nil, Lisp_Object a)
606 {
607 return onevalue(Lispify_predicate(symbolp(a)));
608 }
609
Latom(Lisp_Object nil,Lisp_Object a)610 Lisp_Object Latom(Lisp_Object nil, Lisp_Object a)
611 {
612 return onevalue(Lispify_predicate(!consp(a)));
613 }
614
Lconsp(Lisp_Object nil,Lisp_Object a)615 Lisp_Object Lconsp(Lisp_Object nil, Lisp_Object a)
616 {
617 return onevalue(Lispify_predicate(consp(a)));
618 }
619
Lconstantp(Lisp_Object nil,Lisp_Object a)620 Lisp_Object Lconstantp(Lisp_Object nil, Lisp_Object a)
621 /*
622 * This version is as required for Standard Lisp - it is inadequate
623 * for Common Lisp.
624 */
625 {
626 /*
627 * Standard Lisp requires that I report that "Function Pointers" are
628 * "constant" here. It is not at all clear that I have a way of
629 * doing that. I will go some way my ensuring that code-vectors are.
630 */
631 #ifdef COMMON
632 return onevalue(Lispify_predicate(
633 a == nil || a == lisp_true ||
634 is_char(a) ||
635 is_number(a) ||
636 is_vector(a) ||
637 is_bps(a)));
638 #else
639 return onevalue(Lispify_predicate(
640 is_number(a) ||
641 is_vector(a) || /* Vectors include strings here */
642 is_bps(a)));
643 #endif
644 }
645
Lidentity(Lisp_Object nil,Lisp_Object a)646 Lisp_Object Lidentity(Lisp_Object nil, Lisp_Object a)
647 {
648 CSL_IGNORE(nil);
649 return onevalue(a);
650 }
651
652 #ifdef COMMON
653
Llistp(Lisp_Object nil,Lisp_Object a)654 Lisp_Object Llistp(Lisp_Object nil, Lisp_Object a)
655 {
656 return onevalue(Lispify_predicate(is_cons(a)));
657 }
658
659 #endif
660
Lnumberp(Lisp_Object nil,Lisp_Object a)661 Lisp_Object Lnumberp(Lisp_Object nil, Lisp_Object a)
662 {
663 return onevalue(Lispify_predicate(is_number(a)));
664 }
665
Lintegerp(Lisp_Object nil,Lisp_Object a)666 Lisp_Object Lintegerp(Lisp_Object nil, Lisp_Object a)
667 {
668 CSL_IGNORE(nil);
669 return onevalue(integerp(a));
670 }
671
Leq_safe(Lisp_Object nil,Lisp_Object a)672 Lisp_Object Leq_safe(Lisp_Object nil, Lisp_Object a)
673 {
674 /*
675 * True if you can safely use EQ tests to check equality. Thus true for
676 * things that are represented in "immediate" form... and ALSO of nil
677 * and all other symbols.
678 */
679 #ifdef COMMON
680 return onevalue(symbolp(a) ||
681 is_fixnum(a) ||
682 is_sfloat(a) ||
683 is_odds(a) ? lisp_true : nil);
684 #else
685 return onevalue(symbolp(a) ||
686 is_fixnum(a) ||
687 is_odds(a) ? lisp_true : nil);
688 #endif
689 }
690
Lfixp(Lisp_Object nil,Lisp_Object a)691 Lisp_Object Lfixp(Lisp_Object nil, Lisp_Object a)
692 {
693 #ifdef COMMON
694 return onevalue(is_fixnum(a) ? lisp_true : nil);
695 #else
696 /*
697 * Standard Lisp defines fixp to say yes to bignums as well as
698 * fixnums.
699 */
700 CSL_IGNORE(nil);
701 return onevalue(integerp(a));
702 #endif
703 }
704
Lfloatp(Lisp_Object nil,Lisp_Object p)705 Lisp_Object Lfloatp(Lisp_Object nil, Lisp_Object p)
706 {
707 int tag = TAG_BITS & (int)p;
708 #ifdef COMMON
709 if (tag == TAG_SFLOAT) return onevalue(lisp_true);
710 #endif
711 if (tag == TAG_BOXFLOAT) return onevalue(lisp_true);
712 else return onevalue(nil);
713 }
714
715 #ifdef COMMON
716
Lshort_floatp(Lisp_Object nil,Lisp_Object p)717 static Lisp_Object Lshort_floatp(Lisp_Object nil, Lisp_Object p)
718 {
719 int tag = TAG_BITS & (int)p;
720 if (tag == TAG_SFLOAT) return onevalue(lisp_true);
721 else return onevalue(nil);
722 }
723
Lsingle_floatp(Lisp_Object nil,Lisp_Object p)724 static Lisp_Object Lsingle_floatp(Lisp_Object nil, Lisp_Object p)
725 {
726 int tag = TAG_BITS & (int)p;
727 if (tag == TAG_BOXFLOAT &&
728 type_of_header(flthdr(p)) == TYPE_SINGLE_FLOAT)
729 return onevalue(lisp_true);
730 else return onevalue(nil);
731 }
732
Ldouble_floatp(Lisp_Object nil,Lisp_Object p)733 static Lisp_Object Ldouble_floatp(Lisp_Object nil, Lisp_Object p)
734 {
735 int tag = TAG_BITS & (int)p;
736 if (tag == TAG_BOXFLOAT &&
737 type_of_header(flthdr(p)) == TYPE_DOUBLE_FLOAT)
738 return onevalue(lisp_true);
739 else return onevalue(nil);
740 }
741
Llong_floatp(Lisp_Object nil,Lisp_Object p)742 static Lisp_Object Llong_floatp(Lisp_Object nil, Lisp_Object p)
743 {
744 int tag = TAG_BITS & (int)p;
745 if (tag == TAG_BOXFLOAT &&
746 type_of_header(flthdr(p)) == TYPE_LONG_FLOAT)
747 return onevalue(lisp_true);
748 else return onevalue(nil);
749 }
750
Lrationalp(Lisp_Object nil,Lisp_Object a)751 Lisp_Object Lrationalp(Lisp_Object nil, Lisp_Object a)
752 {
753 CSL_IGNORE(nil);
754 return onevalue(
755 Lispify_predicate(
756 is_fixnum(a) ||
757 (is_numbers(a) &&
758 (is_bignum(a) || is_ratio(a)))));
759 }
760
Lcomplexp(Lisp_Object nil,Lisp_Object a)761 Lisp_Object Lcomplexp(Lisp_Object nil, Lisp_Object a)
762 {
763 CSL_IGNORE(nil);
764 return onevalue(Lispify_predicate(is_numbers(a) && is_complex(a)));
765 }
766
complex_stringp(Lisp_Object a)767 CSLbool complex_stringp(Lisp_Object a)
768 /*
769 * true if the arg is a string, but NOT a simple string. In general
770 * when this is true simplify_string() will then be called to do
771 * an adjustment.
772 */
773 {
774 Header h;
775 Lisp_Object w, nil = C_nil;
776 if (!is_vector(a)) return NO;
777 h = vechdr(a);
778 if (type_of_header(h) != TYPE_ARRAY) return NO;
779 /*
780 * Note that the cheery Common Lisp Committee decided the abolish the
781 * separate type 'string-char, so the test here is maybe dubious...
782 */
783 else if (elt(a, 0) != string_char_sym) return NO;
784 w = elt(a, 1);
785 if (!consp(w) || consp(qcdr(w))) return NO;
786 else return YES;
787 }
788
789 #endif
790
Lwarn_about_protected_symbols(Lisp_Object nil,Lisp_Object a)791 Lisp_Object Lwarn_about_protected_symbols(Lisp_Object nil, Lisp_Object a)
792 {
793 Lisp_Object retval = Lispify_predicate(warn_about_protected_symbols);
794 warn_about_protected_symbols = (a != nil);
795 return onevalue(retval);
796 }
797
Lprotect_symbols(Lisp_Object nil,Lisp_Object a)798 Lisp_Object Lprotect_symbols(Lisp_Object nil, Lisp_Object a)
799 {
800 Lisp_Object retval = Lispify_predicate(symbol_protect_flag);
801 symbol_protect_flag = (a != nil);
802 return onevalue(retval);
803 }
804
stringp(Lisp_Object a)805 CSLbool stringp(Lisp_Object a)
806 /*
807 * True if arg is a simple OR a general string
808 */
809 {
810 Header h;
811 #ifdef COMMON
812 Lisp_Object w, nil = C_nil;
813 #endif
814 if (!is_vector(a)) return NO;
815 h = vechdr(a);
816 if (type_of_header(h) == TYPE_STRING) return YES;
817 #ifdef COMMON
818 else if (type_of_header(h) != TYPE_ARRAY) return NO;
819 /*
820 * Beware abolition of 'string-char
821 */
822 else if (elt(a, 0) != string_char_sym) return NO;
823 w = elt(a, 1);
824 if (!consp(w) || consp(qcdr(w))) return NO;
825 else return YES;
826 #else
827 else return NO;
828 #endif
829 }
830
Lstringp(Lisp_Object nil,Lisp_Object a)831 Lisp_Object Lstringp(Lisp_Object nil, Lisp_Object a)
832 /*
833 * simple-string-p
834 */
835 {
836 if (!(is_vector(a)) || type_of_header(vechdr(a)) != TYPE_STRING)
837 return onevalue(nil);
838 else return onevalue(lisp_true);
839 }
840
841 #ifdef COMMON
842
Lc_stringp(Lisp_Object nil,Lisp_Object a)843 static Lisp_Object Lc_stringp(Lisp_Object nil, Lisp_Object a)
844 {
845 return onevalue(Lispify_predicate(stringp(a)));
846 }
847
848 #endif
849
Lhash_table_p(Lisp_Object nil,Lisp_Object a)850 Lisp_Object Lhash_table_p(Lisp_Object nil, Lisp_Object a)
851 /*
852 * hash-table-p
853 */
854 {
855 if (!(is_vector(a)) || type_of_header(vechdr(a)) != TYPE_HASH)
856 return onevalue(nil);
857 else return onevalue(lisp_true);
858 }
859
860 #ifdef COMMON
861
Lsimple_bit_vector_p(Lisp_Object nil,Lisp_Object a)862 static Lisp_Object Lsimple_bit_vector_p(Lisp_Object nil,
863 Lisp_Object a)
864 /*
865 * simple-bit-vector-p
866 */
867 {
868 if (!(is_vector(a))) return onevalue(nil);
869 else return onevalue(Lispify_predicate(header_of_bitvector(vechdr(a))));
870 }
871
872 #endif
873
Lsimple_vectorp(Lisp_Object nil,Lisp_Object a)874 Lisp_Object Lsimple_vectorp(Lisp_Object nil, Lisp_Object a)
875 /*
876 * simple-vector-p
877 */
878 {
879 if (!(is_vector(a))) return onevalue(nil);
880 else return onevalue(Lispify_predicate(
881 type_of_header(vechdr(a))==TYPE_SIMPLE_VEC));
882 }
883
Lbpsp(Lisp_Object nil,Lisp_Object a)884 Lisp_Object Lbpsp(Lisp_Object nil, Lisp_Object a)
885 {
886 if (!(is_bps(a))) return onevalue(nil);
887 else return onevalue(lisp_true);
888 }
889
Lthreevectorp(Lisp_Object nil,Lisp_Object a)890 Lisp_Object Lthreevectorp(Lisp_Object nil, Lisp_Object a)
891 /*
892 * This is useful for REDUCE - it checks if something is a vector
893 * of size 3!
894 */
895 {
896 if (!(is_vector(a))) return onevalue(nil);
897 return onevalue(Lispify_predicate(
898 vechdr(a) == (TAG_ODDS + TYPE_SIMPLE_VEC + ((4*CELL)<<10))));
899 }
900
901 #ifdef COMMON
902
Larrayp(Lisp_Object nil,Lisp_Object a)903 static Lisp_Object Larrayp(Lisp_Object nil, Lisp_Object a)
904 {
905 Header h;
906 if (!(is_vector(a))) return onevalue(nil);
907 h = vechdr(a);
908 /*
909 * I could consider accepting TYPE_VEC16 and TYPE_VEC32 etc here...
910 */
911 if (type_of_header(h)==TYPE_ARRAY ||
912 type_of_header(h)==TYPE_STRING ||
913 type_of_header(h)==TYPE_SIMPLE_VEC ||
914 header_of_bitvector(h)) return onevalue(lisp_true);
915 else return onevalue(nil);
916 }
917
Lcomplex_arrayp(Lisp_Object nil,Lisp_Object a)918 static Lisp_Object Lcomplex_arrayp(Lisp_Object nil, Lisp_Object a)
919 {
920 if (!(is_vector(a))) return onevalue(nil);
921 else return onevalue(Lispify_predicate(
922 type_of_header(vechdr(a))==TYPE_ARRAY));
923 }
924
Lconvert_to_array(Lisp_Object nil,Lisp_Object a)925 static Lisp_Object Lconvert_to_array(Lisp_Object nil, Lisp_Object a)
926 {
927 if (!(is_vector(a))) return onevalue(nil);
928 vechdr(a) = TYPE_ARRAY + (vechdr(a) & ~header_mask);
929 return onevalue(a);
930 }
931
932 #endif
933
Lstructp(Lisp_Object nil,Lisp_Object a)934 static Lisp_Object Lstructp(Lisp_Object nil, Lisp_Object a)
935 /*
936 * structp
937 */
938 {
939 if (!(is_vector(a))) return onevalue(nil);
940 else return onevalue(Lispify_predicate(
941 type_of_header(vechdr(a))==TYPE_STRUCTURE));
942 }
943
Lconvert_to_struct(Lisp_Object nil,Lisp_Object a)944 static Lisp_Object Lconvert_to_struct(Lisp_Object nil, Lisp_Object a)
945 {
946 if (!(is_vector(a))) return onevalue(nil);
947 vechdr(a) = TYPE_STRUCTURE + (vechdr(a) & ~header_mask);
948 return onevalue(a);
949 }
950
Lcons(Lisp_Object nil,Lisp_Object a,Lisp_Object b)951 Lisp_Object Lcons(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
952 {
953 Lisp_Object r;
954 CSL_IGNORE(nil);
955 r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
956 qcar(r) = a;
957 qcdr(r) = b;
958 fringe = r;
959 if ((char *)r <= (char *)heaplimit)
960 return onevalue(reclaim((Lisp_Object)((char *)r + TAG_CONS),
961 "cons", GC_CONS, 0));
962 else return onevalue((Lisp_Object)((char *)r + TAG_CONS));
963 }
964
Lxcons(Lisp_Object nil,Lisp_Object a,Lisp_Object b)965 Lisp_Object Lxcons(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
966 {
967 Lisp_Object r;
968 CSL_IGNORE(nil);
969 r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
970 qcar(r) = b;
971 qcdr(r) = a;
972 fringe = r;
973 if ((char *)r <= (char *)heaplimit)
974 return onevalue(reclaim((Lisp_Object)((char *)r + TAG_CONS),
975 "xcons", GC_CONS, 0));
976 else return onevalue((Lisp_Object)((char *)r + TAG_CONS));
977 }
978
Lncons(Lisp_Object nil,Lisp_Object a)979 Lisp_Object Lncons(Lisp_Object nil, Lisp_Object a)
980 {
981 Lisp_Object r;
982 r = (Lisp_Object)((char *)fringe - sizeof(Cons_Cell));
983 qcar(r) = a;
984 qcdr(r) = nil;
985 fringe = r;
986 if ((char *)r <= (char *)heaplimit)
987 return onevalue(reclaim((Lisp_Object)((char *)r + TAG_CONS),
988 "ncons", GC_CONS, 0));
989 else return onevalue((Lisp_Object)((char *)r + TAG_CONS));
990 }
991
Llist2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)992 Lisp_Object Llist2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
993 {
994 a = list2(a, b);
995 errexit();
996 return onevalue(a);
997 }
998
Lmkquote(Lisp_Object nil,Lisp_Object a)999 Lisp_Object Lmkquote(Lisp_Object nil, Lisp_Object a)
1000 {
1001 a = list2(quote_symbol, a);
1002 errexit();
1003 return onevalue(a);
1004 }
1005
Llist2star(Lisp_Object nil,int nargs,...)1006 Lisp_Object MS_CDECL Llist2star(Lisp_Object nil, int nargs, ...)
1007 {
1008 va_list aa;
1009 Lisp_Object a, b, c;
1010 argcheck(nargs, 3, "list2*");
1011 va_start(aa, nargs);
1012 a = va_arg(aa, Lisp_Object);
1013 b = va_arg(aa, Lisp_Object);
1014 c = va_arg(aa, Lisp_Object);
1015 va_end(aa);
1016 a = list2star(a,b,c);
1017 errexit();
1018 return onevalue(a);
1019 }
1020
Lacons(Lisp_Object nil,int nargs,...)1021 Lisp_Object MS_CDECL Lacons(Lisp_Object nil, int nargs, ...)
1022 {
1023 va_list aa;
1024 Lisp_Object a, b, c;
1025 argcheck(nargs, 3, "acons");
1026 va_start(aa, nargs);
1027 a = va_arg(aa, Lisp_Object);
1028 b = va_arg(aa, Lisp_Object);
1029 c = va_arg(aa, Lisp_Object);
1030 va_end(aa);
1031 a = acons(a,b,c);
1032 errexit();
1033 return onevalue(a);
1034 }
1035
Llist3(Lisp_Object nil,int nargs,...)1036 Lisp_Object MS_CDECL Llist3(Lisp_Object nil, int nargs, ...)
1037 {
1038 va_list aa;
1039 Lisp_Object a, b, c;
1040 argcheck(nargs, 3, "list3");
1041 va_start(aa, nargs);
1042 a = va_arg(aa, Lisp_Object);
1043 b = va_arg(aa, Lisp_Object);
1044 c = va_arg(aa, Lisp_Object);
1045 va_end(aa);
1046 a = list3(a,b,c);
1047 errexit();
1048 return onevalue(a);
1049 }
1050
Llist3star(Lisp_Object nil,int nargs,...)1051 Lisp_Object MS_CDECL Llist3star(Lisp_Object nil, int nargs, ...)
1052 {
1053 va_list aa;
1054 Lisp_Object a, b, c, d;
1055 argcheck(nargs, 4, "list3*");
1056 va_start(aa, nargs);
1057 a = va_arg(aa, Lisp_Object);
1058 b = va_arg(aa, Lisp_Object);
1059 c = va_arg(aa, Lisp_Object);
1060 d = va_arg(aa, Lisp_Object);
1061 va_end(aa);
1062 a = list3star(a,b,c,d);
1063 errexit();
1064 return onevalue(a);
1065 }
1066
Llist4(Lisp_Object nil,int nargs,...)1067 Lisp_Object MS_CDECL Llist4(Lisp_Object nil, int nargs, ...)
1068 {
1069 va_list aa;
1070 Lisp_Object a, b, c, d;
1071 argcheck(nargs, 4, "list4");
1072 va_start(aa, nargs);
1073 a = va_arg(aa, Lisp_Object);
1074 b = va_arg(aa, Lisp_Object);
1075 c = va_arg(aa, Lisp_Object);
1076 d = va_arg(aa, Lisp_Object);
1077 va_end(aa);
1078 a = list4(a,b,c,d);
1079 errexit();
1080 return onevalue(a);
1081 }
1082
1083
1084
1085 #ifdef COMMON
1086 /*
1087 * In non-COMMON mode I implement list and list* as special forms
1088 * rather than as functions, guessing that that will be more efficient.
1089 */
1090
Llist(Lisp_Object nil,int nargs,...)1091 Lisp_Object MS_CDECL Llist(Lisp_Object nil, int nargs, ...)
1092 {
1093 Lisp_Object r = nil, w, w1;
1094 va_list a;
1095 va_start(a, nargs);
1096 push_args(a, nargs);
1097 while (nargs > 1)
1098 { pop2(w, w1);
1099 nargs-=2;
1100 r = list2star(w1, w, r);
1101 errexitn(nargs);
1102 }
1103 while (nargs > 0)
1104 { pop(w);
1105 nargs--;
1106 r = cons(w, r);
1107 errexitn(nargs);
1108 }
1109 return onevalue(r);
1110 }
1111
Lliststar(Lisp_Object nil,int nargs,...)1112 static Lisp_Object MS_CDECL Lliststar(Lisp_Object nil, int nargs, ...)
1113 {
1114 Lisp_Object r, w, w1;
1115 va_list a;
1116 if (nargs == 0) return onevalue(nil);
1117 va_start(a, nargs);
1118 push_args(a, nargs);
1119 pop(r);
1120 nargs--;
1121 while (nargs > 1)
1122 { pop2(w, w1);
1123 nargs-=2;
1124 r = list2star(w1, w, r);
1125 errexitn(nargs);
1126 }
1127 while (nargs > 0)
1128 { pop(w);
1129 nargs--;
1130 r = cons(w, r);
1131 errexitn(nargs);
1132 }
1133 return onevalue(r);
1134 }
1135
1136 /*
1137 * fill-vector is used for open-compilation of (vector ...) to avoid
1138 * passing grossly unreasonable numbers of arguments. The expansion of
1139 * (vector e1 ... en) should be
1140 * (let ((v (mkvect <n-1>)) (i 0))
1141 * (setq i (fill-vector v i e1 e2 ... e10))
1142 * (setq i (fill-vector v i e11 e12 ... ))
1143 * ...
1144 * v)
1145 */
Lfill_vector(Lisp_Object nil,int nargs,...)1146 static Lisp_Object MS_CDECL Lfill_vector(Lisp_Object nil, int nargs, ...)
1147 {
1148 va_list a;
1149 Lisp_Object v, il;
1150 int32_t i;
1151 CSL_IGNORE(nil);
1152 if (nargs < 3) return aerror("fill-vector");
1153 va_start(a, nargs);
1154 v = va_arg(a, Lisp_Object);
1155 il = va_arg(a, Lisp_Object);
1156 if (!is_vector(v) || !is_fixnum(il)) return aerror("fill-vector");
1157 i = int_of_fixnum(il);
1158 nargs -= 2;
1159 while (nargs != 0)
1160 { elt(v, i++) = va_arg(a, Lisp_Object);
1161 nargs--;
1162 }
1163 return onevalue(fixnum_of_int(i));
1164 }
1165
1166 #endif
1167
Lpair(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1168 Lisp_Object Lpair(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1169 {
1170 Lisp_Object r = nil;
1171 while (consp(a) && consp(b))
1172 { push2(a, b);
1173 r = acons(qcar(a), qcar(b), r);
1174 pop2(b, a);
1175 errexit();
1176 a = qcdr(a);
1177 b = qcdr(b);
1178 }
1179 a = nil;
1180 while (r != nil)
1181 { b = qcdr(r);
1182 qcdr(r) = a;
1183 a = r;
1184 r = b;
1185 }
1186 return onevalue(a);
1187 }
1188
1189
membercount(Lisp_Object a,Lisp_Object b)1190 static int32_t membercount(Lisp_Object a, Lisp_Object b)
1191 /*
1192 * Counts how many times a is a member of the list b
1193 */
1194 {
1195 int32_t r = 0;
1196 #ifdef COMMON
1197 Lisp_Object nil = C_nil;
1198 #endif
1199 if (is_symbol(a) || is_fixnum(a))
1200 { while (consp(b))
1201 { if (a == qcar(b)) r++;
1202 b = qcdr(b);
1203 }
1204 return r;
1205 }
1206 while (consp(b))
1207 { Lisp_Object cb = qcar(b);
1208 if (equal(a, cb)) r++;
1209 b = qcdr(b);
1210 }
1211 return r;
1212 }
1213
1214 /*
1215 * INTERSECTION(A,B)
1216 * The result will have its items in the order that they occur in A.
1217 * If lists A and B contain duplicate items these will appear in the
1218 * output if and only if the items involved are duplicated in both
1219 * input lists.
1220 */
Lintersect(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1221 Lisp_Object Lintersect(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1222 {
1223 Lisp_Object r = nil, w;
1224 push(b);
1225 while (consp(a))
1226 { push2(a, r);
1227 w = Lmember(nil, qcar(a), stack[-2]);
1228 errexitn(3);
1229 /* Here I ignore any item in a that is not also in b */
1230 if (w != nil)
1231 { int32_t n1 = membercount(qcar(stack[-1]), stack[0]);
1232 errexitn(3);
1233 /*
1234 * Here I want to arrange that items only appear in the result list multiple
1235 * times if they occur multipl times in BOTH the input lists.
1236 */
1237 if (n1 != 0)
1238 { int32_t n2 = membercount(qcar(stack[-1]), stack[-2]);
1239 errexitn(3);
1240 if (n2 > n1) n1 = 0;
1241 }
1242 if (n1 == 0)
1243 { pop(r);
1244 a = stack[0];
1245 r = cons(qcar(a), r);
1246 errexitn(2);
1247 pop(a);
1248 }
1249 else pop2(r, a);
1250 }
1251 else pop2(r, a);
1252 a = qcdr(a);
1253 }
1254 popv(1);
1255 a = nil;
1256 while (consp(r))
1257 { b = r;
1258 r = qcdr(r);
1259 qcdr(b) = a;
1260 a = b;
1261 }
1262 return onevalue(a);
1263 }
1264
1265 /*
1266 * UNION(A, B)
1267 * This works by consing onto the front of B each element of A that
1268 * is not already in B. Thus items in A (but not already in B) get
1269 * added in reversed order. Duplicates in B remain there, and but
1270 * duplicates in A are dropped.
1271 */
Lunion(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1272 Lisp_Object Lunion(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1273 {
1274 while (consp(a))
1275 { Lisp_Object c;
1276 push2(a, b);
1277 c = Lmember(nil, qcar(a), b);
1278 errexitn(2);
1279 pop(b);
1280 if (c == nil)
1281 { b = cons(qcar(stack[0]), b);
1282 errexitn(1);
1283 }
1284 pop(a);
1285 a = qcdr(a);
1286 }
1287 return onevalue(b);
1288 }
1289
Lenable_backtrace(Lisp_Object nil,Lisp_Object a)1290 Lisp_Object Lenable_backtrace(Lisp_Object nil, Lisp_Object a)
1291 {
1292 int32_t n = miscflags;
1293 if (a == nil) miscflags &= ~MESSAGES_FLAG;
1294 else miscflags |= MESSAGES_FLAG;
1295 return onevalue(Lispify_predicate((n & MESSAGES_FLAG) != 0));
1296 }
1297
1298 #ifdef NAG
1299
Lunwind(Lisp_Object nil,int nargs,...)1300 Lisp_Object MS_CDECL Lunwind(Lisp_Object nil, int nargs, ...)
1301 {
1302 argcheck(nargs, 0, "unwind");
1303 exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
1304 UNWIND_UNWIND;
1305 exit_count = 0;
1306 exit_tag = nil;
1307 flip_exception();
1308 return nil;
1309 }
1310
1311 #endif
1312
1313 /*
1314 * If the variable *break-function* has as its value a symbol, and that
1315 * symbol names a function, then the function concerned will be called
1316 * with one argument after the headline for the diagnostic. When it returns
1317 * the system will unwind in the usual manner.
1318 */
1319
Lerror(Lisp_Object nil,int nargs,...)1320 Lisp_Object MS_CDECL Lerror(Lisp_Object nil, int nargs, ...)
1321 {
1322 va_list a;
1323 Lisp_Object w;
1324 #ifdef COMMON
1325 Lisp_Object r = nil, w1;
1326 #else
1327 int i;
1328 #endif
1329 if (nargs == 0) return aerror("error");
1330 errors_now++;
1331 if (errors_limit >= 0 && errors_now > errors_limit)
1332 return resource_exceeded();
1333 va_start(a, nargs);
1334 push_args(a, nargs);
1335 #ifdef COMMON
1336 while (nargs > 1)
1337 { pop2(w, w1);
1338 nargs -= 2;
1339 w = list2star(w1, w, r);
1340 nil = C_nil;
1341 if (exception_pending()) flip_exception();
1342 else r = w;
1343 }
1344 while (nargs > 0)
1345 { pop(w);
1346 nargs--;
1347 w = cons(w, r);
1348 nil = C_nil;
1349 if (exception_pending()) flip_exception();
1350 else r = w;
1351 }
1352 if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
1353 { push(r);
1354 err_printf("\n+++ error: ");
1355 /*
1356 * I will use FORMAT to handle error messages provided the first arg
1357 * to error had been a string and also provided (for bootstrapping) that
1358 * the function FORMAT seems to be defined.
1359 */
1360 if (qfn1(format_symbol) == undefined1 ||
1361 !consp(r) ||
1362 !stringp(qcar(r))) loop_print_error(r);
1363 else Lapply_n(nil, 3, format_symbol, qvalue(error_output), r);
1364 ignore_exception();
1365 err_printf("\n");
1366 pop(r);
1367 ignore_exception();
1368 }
1369 qvalue(emsg_star) = r; /* "Error message" in CL world */
1370 exit_value = fixnum_of_int(0); /* "Error number" in CL world */
1371 #else
1372 if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
1373 { err_printf("\n+++ error: ");
1374 loop_print_error(stack[1-nargs]);
1375 for (i=1; i<nargs; i++)
1376 { err_printf(" ");
1377 loop_print_error(stack[1+i-nargs]);
1378 }
1379 err_printf("\n");
1380 }
1381 if (nargs == 1)
1382 { push(nil);
1383 nargs++;
1384 }
1385 qvalue(emsg_star) = stack[2-nargs]; /* "Error message" in SL world */
1386 exit_value = stack[1-nargs]; /* "Error number" in SL world */
1387 popv(nargs);
1388 #endif
1389 if ((w = qvalue(break_function)) != nil &&
1390 symbolp(w) &&
1391 qfn1(w) != undefined1)
1392 { (*qfn1(w))(qenv(w), qvalue(emsg_star));
1393 ignore_exception();
1394 }
1395 exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
1396 UNWIND_UNWIND;
1397 exit_count = 0;
1398 exit_tag = nil;
1399 flip_exception();
1400 return nil;
1401 }
1402
Lerror1(Lisp_Object nil,Lisp_Object a1)1403 Lisp_Object Lerror1(Lisp_Object nil, Lisp_Object a1)
1404 {
1405 return Lerror(nil, 1, a1);
1406 }
1407
Lerror2(Lisp_Object nil,Lisp_Object a1,Lisp_Object a2)1408 Lisp_Object Lerror2(Lisp_Object nil, Lisp_Object a1, Lisp_Object a2)
1409 {
1410 return Lerror(nil, 2, a1, a2);
1411 }
1412
Lerror0(Lisp_Object nil,int nargs,...)1413 Lisp_Object MS_CDECL Lerror0(Lisp_Object nil, int nargs, ...)
1414 {
1415 /*
1416 * Silently provoked error - unwind to surrounding errorset level. Note that
1417 * this will NEVER enter a user-provided break loop...
1418 */
1419 argcheck(nargs, 0, "error0");
1420 errors_now++;
1421 if (errors_limit >= 0 && errors_now > errors_limit)
1422 return resource_exceeded();
1423 if (!always_noisy) miscflags &= ~(MESSAGES_FLAG | HEADLINE_FLAG);
1424 exit_reason = UNWIND_UNWIND;
1425 exit_value = exit_tag = nil;
1426 exit_count = 0;
1427 flip_exception();
1428 return nil;
1429 }
1430
Lstop(Lisp_Object env,Lisp_Object code)1431 Lisp_Object Lstop(Lisp_Object env, Lisp_Object code)
1432 {
1433 /*
1434 * I ignore "env" and set up nil for myself here to make it easier to call
1435 * this function from random places in my interface code...
1436 */
1437 Lisp_Object nil = C_nil;
1438 CSL_IGNORE(env);
1439 if (!is_fixnum(code)) return aerror("stop");
1440 exit_value = code;
1441 exit_tag = fixnum_of_int(0); /* Flag to say "stop" */
1442 exit_reason = UNWIND_RESTART;
1443 exit_count = 1;
1444 flip_exception();
1445 return nil;
1446 }
1447
Lmake_special(Lisp_Object nil,Lisp_Object a)1448 Lisp_Object Lmake_special(Lisp_Object nil, Lisp_Object a)
1449 {
1450 CSL_IGNORE(nil);
1451 if (!symbolp(a)) return aerror1("make-special", a);
1452 qheader(a) |= SYM_SPECIAL_VAR;
1453 return onevalue(a);
1454 }
1455
Lmake_global(Lisp_Object nil,Lisp_Object a)1456 Lisp_Object Lmake_global(Lisp_Object nil, Lisp_Object a)
1457 {
1458 CSL_IGNORE(nil);
1459 if (!symbolp(a)) return aerror("make-global");
1460 qheader(a) |= (SYM_SPECIAL_VAR | SYM_GLOBAL_VAR);
1461 return onevalue(a);
1462 }
1463
Lunmake_special(Lisp_Object nil,Lisp_Object a)1464 Lisp_Object Lunmake_special(Lisp_Object nil, Lisp_Object a)
1465 {
1466 if (!symbolp(a)) return onevalue(nil);
1467 qheader(a) &= ~(SYM_SPECIAL_VAR | SYM_GLOBAL_VAR);
1468 return onevalue(a);
1469 }
1470
Lunmake_global(Lisp_Object nil,Lisp_Object a)1471 Lisp_Object Lunmake_global(Lisp_Object nil, Lisp_Object a)
1472 {
1473 if (!symbolp(a)) return onevalue(nil);
1474 qheader(a) &= ~(SYM_SPECIAL_VAR | SYM_GLOBAL_VAR);
1475 return onevalue(a);
1476 }
1477
Lsymbol_specialp(Lisp_Object nil,Lisp_Object a)1478 Lisp_Object Lsymbol_specialp(Lisp_Object nil, Lisp_Object a)
1479 {
1480 if (!symbolp(a)) return onevalue(nil);
1481 else if ((qheader(a) & (SYM_SPECIAL_VAR | SYM_GLOBAL_VAR)) ==
1482 SYM_SPECIAL_VAR) return onevalue(lisp_true);
1483 else return onevalue(nil);
1484 }
1485
Lsymbol_globalp(Lisp_Object nil,Lisp_Object a)1486 Lisp_Object Lsymbol_globalp(Lisp_Object nil, Lisp_Object a)
1487 {
1488 if (!symbolp(a)) return onevalue(nil);
1489 else if ((qheader(a) & SYM_GLOBAL_VAR) != 0) return onevalue(lisp_true);
1490 else return onevalue(nil);
1491 }
1492
Lkeywordp(Lisp_Object nil,Lisp_Object a)1493 Lisp_Object Lkeywordp(Lisp_Object nil, Lisp_Object a)
1494 {
1495 if (!symbolp(a)) return onevalue(nil);
1496 else if ((qheader(a) & (SYM_SPECIAL_VAR | SYM_GLOBAL_VAR)) ==
1497 (SYM_SPECIAL_VAR | SYM_GLOBAL_VAR))
1498 return onevalue(lisp_true);
1499 else return onevalue(nil);
1500 }
1501
Lboundp(Lisp_Object nil,Lisp_Object a)1502 Lisp_Object Lboundp(Lisp_Object nil, Lisp_Object a)
1503 {
1504 if (!symbolp(a)) return onevalue(nil);
1505 #ifndef COMMON
1506 /*
1507 * In COMMON Lisp it seems that this is intended to just check if the
1508 * value cell in a shallow-bound implementation contains some marker value
1509 * that stands for "junk". In Standard Lisp mode I deem that variables
1510 * that have not been declared fluid are unbound. Seems to me like a
1511 * classical mix-up between the concept of binding and of having some
1512 * particular value... Oh well.
1513 */
1514 else if ((qheader(a) & SYM_SPECIAL_VAR) == 0) return onevalue(nil);
1515 #endif
1516 else if (qvalue(a) == unset_var) return onevalue(nil); /* no value yet */
1517 else return onevalue(lisp_true);
1518 }
1519
Lsymbol_value(Lisp_Object nil,Lisp_Object a)1520 Lisp_Object Lsymbol_value(Lisp_Object nil, Lisp_Object a)
1521 {
1522 CSL_IGNORE(nil);
1523 if (!symbolp(a)) return onevalue(a);
1524 else return onevalue(qvalue(a));
1525 }
1526
Lset(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1527 Lisp_Object Lset(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1528 {
1529 if (!symbolp(a) || a == nil || a == lisp_true) return aerror("set");
1530 qvalue(a) = b;
1531 return onevalue(b);
1532 }
1533
Lsymbol_function(Lisp_Object nil,Lisp_Object a)1534 Lisp_Object Lsymbol_function(Lisp_Object nil, Lisp_Object a)
1535 {
1536 one_args *f1;
1537 two_args *f2;
1538 n_args *fn;
1539 if (!symbolp(a)) return onevalue(nil);
1540 f1 = qfn1(a); f2 = qfn2(a); fn = qfnn(a);
1541 if ((qheader(a) & (SYM_SPECIAL_FORM | SYM_MACRO)) != 0 ||
1542 (f1 == undefined1 && f2 == undefined2 &&
1543 fn == undefinedn)) return onevalue(nil);
1544 else if (f1 == interpreted1 ||
1545 f2 == interpreted2 ||
1546 fn == interpretedn)
1547 /* I wonder if onevalue(cons(...)) is really valid here. It is OK in SL mode */
1548 return onevalue(cons(lambda, qenv(a)));
1549 else if (f1 == funarged1 ||
1550 f2 == funarged2 ||
1551 fn == funargedn)
1552 return onevalue(cons(funarg, qenv(a)));
1553 else if (f1 == traceinterpreted1 ||
1554 f2 == traceinterpreted2 ||
1555 fn == traceinterpretedn)
1556 return onevalue(cons(lambda, qcdr(qenv(a))));
1557 else if (f1 == tracefunarged1 ||
1558 f2 == tracefunarged2 ||
1559 fn == tracefunargedn)
1560 return onevalue(cons(funarg, qcdr(qenv(a))));
1561 else
1562 {
1563 #ifdef COMMON
1564 Lisp_Object b = get(a, work_symbol, nil);
1565 #else
1566 Lisp_Object b = get(a, work_symbol);
1567 #endif
1568 /*
1569 * If I have already manufactured a code pointer for this function I
1570 * can find it on the property list - in that case I will re-use it.
1571 */
1572 while (b != nil)
1573 { Lisp_Object c = qcar(b);
1574 if ((qheader(c) & (SYM_C_DEF | SYM_CODEPTR)) ==
1575 (SYM_CODEPTR | (qheader(a) & SYM_C_DEF)))
1576 return onevalue(c);
1577 b = qcdr(b);
1578 }
1579 push(a);
1580 /*
1581 * To carry a code-pointer I manufacture a sort of gensym, flagging
1582 * it in its header as a "code pointer object" and sticking the required
1583 * definition in with it. I need to link this to the originating
1584 * definition in some cases to allow for preserve/restart problems wrt
1585 * the initialisation of function addresses that refer to C code.
1586 * I make the carrier using GENSYM1, but need to clear the gensym flag bit
1587 * to show I have a regular name for the object, and that I will not need
1588 * to append a serial number later on. In Common Lisp mode I let the name
1589 * of the gensym be just the name of the function, while in Standard Lisp
1590 * mode I will append a numeric suffix. I do this because in Common Lisp
1591 * mode the thing will print as (say) #:apply which is visibly different
1592 * from the name 'apply of the base function, while in Standard Lisp a name
1593 * like apply775 is needed to make the distinction (easily) visible.
1594 */
1595 #ifdef COMMON
1596 b = Lgensym2(nil, a);
1597 #else
1598 b = Lgensym1(nil, a);
1599 #endif
1600 pop(a);
1601 errexit();
1602 set_fns(b, f1, f2, fn);
1603 qenv(b) = qenv(a);
1604 #ifdef COMMON
1605 /* in Common Lisp mode gensyms that are "unprinted" are not special */
1606 qheader(b) ^= (SYM_ANY_GENSYM | SYM_CODEPTR);
1607 #else
1608 qheader(b) ^= (SYM_UNPRINTED_GENSYM | SYM_ANY_GENSYM | SYM_CODEPTR);
1609 #endif
1610 if ((qheader(a) & SYM_C_DEF) != 0)
1611 { Lisp_Object c, w;
1612 #ifdef COMMON
1613 c = get(a, unset_var, nil);
1614 #else
1615 c = get(a, unset_var);
1616 #endif
1617 if (c == nil) c = a;
1618 push3(a, b, c);
1619 qheader(b) |= SYM_C_DEF;
1620 putprop(b, unset_var, c);
1621 errexitn(3);
1622 c = stack[0]; b = stack[-1];
1623 #ifdef COMMON
1624 w = get(c, work_symbol, nil);
1625 #else
1626 w = get(c, work_symbol);
1627 #endif
1628 w = cons(b, w);
1629 pop(c);
1630 errexitn(2);
1631 putprop(c, work_symbol, w);
1632 pop2(b, a);
1633 errexit();
1634 }
1635 return onevalue(b);
1636 }
1637 }
1638
Lspecial_form_p(Lisp_Object nil,Lisp_Object a)1639 Lisp_Object Lspecial_form_p(Lisp_Object nil, Lisp_Object a)
1640 {
1641 if (!symbolp(a)) return onevalue(nil);
1642 else if ((qheader(a) & SYM_SPECIAL_FORM) != 0) return onevalue(lisp_true);
1643 else return onevalue(nil);
1644 }
1645
Lcodep(Lisp_Object nil,Lisp_Object a)1646 Lisp_Object Lcodep(Lisp_Object nil, Lisp_Object a)
1647 /*
1648 * This responds TRUE for the special pseudo-symbols that are used to
1649 * carry compiled code objects. It returns NIL on the symbols that
1650 * are normally used by the user.
1651 */
1652 {
1653 if (!symbolp(a)) return onevalue(nil);
1654 if ((qheader(a) & (SYM_CODEPTR | SYM_C_DEF)) == SYM_CODEPTR)
1655 return onevalue(lisp_true);
1656 else return onevalue(nil);
1657 }
1658
1659 #ifdef DEBUG
1660 static int validate_count = 0;
1661 #endif
1662
getvector(int tag,int type,int32_t size)1663 Lisp_Object getvector(int tag, int type, int32_t size)
1664 {
1665 /*
1666 * tag is the value (e.g. TAG_SYMBOL) that will go in the low order
1667 * 3 bits of the pointer result.
1668 * type is the code (e.g. TYPE_SYMBOL) that gets packed, together with
1669 * the size, into a header word.
1670 * size is measured in bytes and must allow space for the header word.
1671 * [Note that this last issue - size including the header - was probably
1672 * a mistake since the header size depends on whether I am using a
1673 * 32-bit or 64-bit representation. However it would be hard to unwind
1674 * that now!]
1675 */
1676 Lisp_Object nil = C_nil;
1677 #ifdef DEBUG
1678 /*
1679 * If I do a full validation every time I allocate a vector that REALLY
1680 * hits performance, so I will do it occasionally. The 1 in 500 indicated
1681 * at present is a pretty random choice of frequency!
1682 */
1683 if ((++validate_count) % 500 == 0)
1684 { copy_into_nilseg(NO);
1685 validate_all("getvector", __LINE__, __FILE__);
1686 }
1687 #endif
1688 for (;;)
1689 { char *r = (char *)vfringe;
1690 uint32_t free = (uint32_t)((char *)vheaplimit - r);
1691 /*
1692 * On a 64-bit system the allocation size will be a multiple of 8 anyway, so
1693 * the doubleword_align here will have no effect! The result is that I never
1694 * need or use a padding word at the end of a vector in that case. Note that
1695 * well. On 32-bit systems vectors may have a dummy padder word at the end
1696 * but on 64-bit systems they do not.
1697 */
1698 int32_t alloc_size = (int32_t)doubleword_align_up(size);
1699 /*
1700 * There is a real NASTY here - it is quite possible that I ought to implement
1701 * a scheme whereby large vectors can be allocated as a series of chunks so as
1702 * to avoid the current absolute limit on size. At one stage I used a page
1703 * size of just 64K on small machines, and for embedded applications that
1704 * may still be sensible. But MOSTLY I now have 4Mb pages. But as discussed
1705 * in restart.c I need to limit the size of a vector to HALF the page
1706 * size of I am later on going to reload on a 64-bit machine, so here I
1707 * have a rather odd test that tries to enforce this on "standard" machines
1708 * but not on truly tiny ones. The specific judgement applied here is
1709 * that if the page size is at least 2M and I am on a 32-bit machine I will
1710 * use at most half the page. To be specific about the consequences, it means
1711 * that I can have an array of length up to about 512K cells not 1M in
1712 * that case. If I ask for someting too bif I will report the request size
1713 * as if it has been for a vector of lisp items.
1714 */
1715 if (alloc_size >
1716 ((CSL_PAGE_SIZE>2000000 &&
1717 !SIXTY_FOUR_BIT) ? CSL_PAGE_SIZE/2 - 32 :
1718 CSL_PAGE_SIZE - 32))
1719 return aerror1("vector request too big",
1720 fixnum_of_int(alloc_size/CELL-1));
1721 if (alloc_size > free)
1722
1723 { char msg[40];
1724 /*
1725 * I go to a whole load of trouble here to tell the user what sort of
1726 * vector request provoked this garbage collection. I wonder if the user
1727 * really cares - but I do very much when I am chasing after GC bugs!
1728 */
1729 switch (tag)
1730 {
1731 case TAG_SYMBOL:
1732 sprintf(msg, "symbol header");
1733 break;
1734 case TAG_NUMBERS:
1735 switch (type)
1736 {
1737 case TYPE_BIGNUM:
1738 sprintf(msg, "bignum(%ld)", (long)size);
1739 break;
1740 default:
1741 sprintf(msg, "numbers(%lx,%ld)", (long)type, (long)size);
1742 break;
1743 }
1744 break;
1745 case TAG_VECTOR:
1746 switch (type)
1747 {
1748 case TYPE_STRING:
1749 sprintf(msg, "string(%ld)", (long)size);
1750 break;
1751 case TYPE_BPS:
1752 sprintf(msg, "BPS(%ld)", (long)size);
1753 break;
1754 case TYPE_SIMPLE_VEC:
1755 sprintf(msg, "simple vector(%ld)", (long)size);
1756 break;
1757 case TYPE_HASH:
1758 sprintf(msg, "hash table(%ld)", (long)size);
1759 break;
1760 default:
1761 sprintf(msg, "vector(%lx,%ld)", (long)type, (long)size);
1762 break;
1763 }
1764 break;
1765 case TAG_BOXFLOAT:
1766 sprintf(msg, "float(%ld)", (long)size);
1767 break;
1768 default:
1769 sprintf(msg, "getvector(%lx,%ld)", (long)tag, (long)size);
1770 break;
1771 }
1772 reclaim(nil, msg, GC_VEC, alloc_size);
1773 errexit();
1774 continue;
1775 }
1776 vfringe = (Lisp_Object)(r + alloc_size);
1777 *((Header *)r) = type + (size << 10) + TAG_ODDS;
1778 /*
1779 * DANGER: the vector allocated here is left uninitialised at this stage.
1780 * This is OK if the vector will contain binary information, but if it
1781 * will hold any Lisp_Objects it needs safe values put in PDQ.
1782 */
1783 return (Lisp_Object)(r + tag);
1784 }
1785 }
1786
getvector_init(int32_t n,Lisp_Object k)1787 Lisp_Object getvector_init(int32_t n, Lisp_Object k)
1788 {
1789 Lisp_Object p, nil;
1790 push(k);
1791 p = getvector(TAG_VECTOR, TYPE_SIMPLE_VEC, n);
1792 pop(k);
1793 errexit();
1794 if (!SIXTY_FOUR_BIT && ((n & 4) != 0))
1795 n += 4; /* Ensure last doubleword is tidy */
1796 while (n > CELL)
1797 { n -= CELL;
1798 *(Lisp_Object *)((char *)p - TAG_VECTOR + n) = k;
1799 }
1800 return p;
1801 }
1802
1803 clock_t base_time;
1804 double *clock_stack, consolidated_time[10], gc_time;
1805
push_clock(void)1806 void push_clock(void)
1807 {
1808 clock_t t0 = read_clock();
1809 /*
1810 * Provided that I do this often enough I will not suffer clock
1811 * wrap-around or overflow.
1812 */
1813 double delta = (double)(t0 - base_time)/(double)CLOCKS_PER_SEC;
1814 base_time = t0;
1815 *clock_stack += delta;
1816 *++clock_stack = 0.0;
1817 }
1818
pop_clock(void)1819 double pop_clock(void)
1820 {
1821 clock_t t0 = read_clock();
1822 double delta = (double)(t0 - base_time)/(double)CLOCKS_PER_SEC;
1823 base_time = t0;
1824 return delta + *clock_stack--;
1825 }
1826
Ltime(Lisp_Object nil,int nargs,...)1827 Lisp_Object MS_CDECL Ltime(Lisp_Object nil, int nargs, ...)
1828 {
1829 uint32_t tt, tthigh;
1830 double td;
1831 Lisp_Object r;
1832 if (clock_stack == &consolidated_time[0])
1833 { clock_t t0 = read_clock();
1834 double delta = (double)(t0 - base_time)/(double)CLOCKS_PER_SEC;
1835 base_time = t0;
1836 consolidated_time[0] += delta;
1837 }
1838 argcheck(nargs, 0, "time");
1839 CSL_IGNORE(nil);
1840 /*
1841 * If I just converted to an uint32_t value here I would get overflow
1842 * after 2^32 milliseconds, which is 49.7 days. This is, I fear, just within
1843 * the range that could come and bite me! So I will arrange the
1844 * conversion so I get a greater range supported!
1845 */
1846 td = 1000.0 * consolidated_time[0];
1847 /*
1848 * By dividing by 2^16 I get a value tthigh that only only approaches overflow
1849 * after almost 9000 years. That seems good enough to me!
1850 */
1851 tthigh = (uint32_t)(td/(double)0x10000);
1852 /*
1853 * On the next line the conversion of thigh back to a double and the
1854 * multiplication ought not to introduce any error at all, and so td should
1855 * and up an accurate remainder.
1856 */
1857 td -= (double)0x10000 * (double)tthigh;
1858 if (td < 0.0)
1859 { tthigh--;
1860 td += (double)0x10000;
1861 }
1862 tt = (uint32_t)td;
1863 /*
1864 * Now I shuffle bits in tt and tthigh to get a proper CSL-ish representation
1865 * of a 2-word integer, with the low 31 bits in tt.
1866 */
1867 tt += (tthigh & 0x7fff) << 16;
1868 tthigh >>= 15;
1869 if ((tt & 0x80000000) != 0)
1870 { tt &= 0x7fffffff;
1871 tthigh++;
1872 }
1873 if (tthigh != 0) r = make_two_word_bignum(tthigh, tt);
1874 else if ((tt & fix_mask) != 0) r = make_one_word_bignum(tt);
1875 else return onevalue(fixnum_of_int(tt));
1876 errexit();
1877 return onevalue(r);
1878 }
1879
Lgctime(Lisp_Object nil,int nargs,...)1880 Lisp_Object MS_CDECL Lgctime(Lisp_Object nil, int nargs, ...)
1881 {
1882 argcheck(nargs, 0, "gctime");
1883 CSL_IGNORE(nil);
1884 return onevalue(fixnum_of_int((int32_t)(1000.0 * gc_time)));
1885 }
1886
1887 #ifdef COMMON
1888
Ldecoded_time(Lisp_Object nil,int nargs,...)1889 Lisp_Object MS_CDECL Ldecoded_time(Lisp_Object nil, int nargs, ...)
1890 {
1891 time_t t0 = time(NULL);
1892 /*
1893 * tm_sec -- seconds 0..59
1894 * tm_min -- minutes 0..59
1895 * tm_hour -- hour of day 0..23
1896 * tm_mday -- day of month 1..31
1897 * tm_mon -- month 0..11
1898 * tm_year -- years since 1900
1899 * tm_wday -- day of week, 0..6 (Sunday..Saturday)
1900 * tm_yday -- day of year, 0..365
1901 * tm_isdst -- >0 if daylight savings time
1902 * -- ==0 if not DST
1903 * -- <0 if don't know
1904 */
1905 struct tm *tbuf = localtime(&t0);
1906 Lisp_Object r, *p = &mv_2;
1907 int w;
1908 argcheck(nargs, 0, "get-decoded-time");
1909 r = fixnum_of_int(tbuf->tm_sec);
1910 *p++ = fixnum_of_int(tbuf->tm_min);
1911 *p++ = fixnum_of_int(tbuf->tm_hour);
1912 *p++ = fixnum_of_int(tbuf->tm_mday);
1913 *p++ = fixnum_of_int(tbuf->tm_mon+1);
1914 *p++ = fixnum_of_int(tbuf->tm_year+1900);
1915 w = tbuf->tm_wday;
1916 *p++ = fixnum_of_int(w == 0 ? 6 : w-1);
1917 *p++ = tbuf->tm_isdst > 0 ? lisp_true : nil;
1918 *p++ = fixnum_of_int(0); /* Time zone info not available? */
1919 return nvalues(r, 9);
1920 }
1921
1922 #endif
1923
Ldate(Lisp_Object nil,int nargs,...)1924 Lisp_Object MS_CDECL Ldate(Lisp_Object nil, int nargs, ...)
1925 {
1926 Lisp_Object w;
1927 time_t t = time(NULL);
1928 char today[32];
1929 argcheck(nargs, 0, "date");
1930 CSL_IGNORE(nil);
1931 strcpy(today, ctime(&t)); /* e.g. "Sun Sep 16 01:03:52 1973\n" */
1932 today[24] = 0; /* loses final '\n' */
1933 w = make_string(today);
1934 errexit();
1935 return onevalue(w);
1936 }
1937
Ldate1(Lisp_Object nil,Lisp_Object a1)1938 Lisp_Object MS_CDECL Ldate1(Lisp_Object nil, Lisp_Object a1)
1939 {
1940 Lisp_Object w;
1941 time_t t = time(NULL);
1942 char today[32];
1943 char today1[32];
1944 CSL_IGNORE(nil);
1945 strcpy(today, ctime(&t)); /* e.g. "Sun Sep 16 01:03:52 1973\n" */
1946 /* 012345678901234567890123 */
1947 today[24] = 0; /* loses final '\n' */
1948 today1[0] = today[8]==' ' ? '0' : today[8];
1949 today1[1] = today[9];
1950 today1[2] = '-';
1951 today1[3] = today[4];
1952 today1[4] = today[5];
1953 today1[5] = today[6];
1954 today1[6] = '-';
1955 today1[7] = today[22];
1956 today1[8] = today[23];
1957 today1[9] = 0; /* Now as in 03-Apr-09 */
1958 w = make_string(today1);
1959 errexit();
1960 return onevalue(w);
1961 }
1962
Ldatestamp(Lisp_Object nil,int nargs,...)1963 Lisp_Object MS_CDECL Ldatestamp(Lisp_Object nil, int nargs, ...)
1964 /*
1965 * Returns date-stamp integer, which on many systems will be the
1966 * number of seconds between 1970.0.0 and now, but which could be
1967 * pretty-well other things, as per the C "time_t" type.
1968 */
1969 {
1970 Lisp_Object w;
1971 time_t t = time(NULL);
1972 /*
1973 * Hmmm - I need to check time_t on a 64-bit machine!
1974 */
1975 uint32_t n = (uint32_t)t; /* NON-PORTABLE assumption about time_t */
1976 argcheck(nargs, 0, "datestamp");
1977 CSL_IGNORE(nil);
1978 if ((n & fix_mask) == 0) w = fixnum_of_int(n);
1979 else if ((n & 0xc0000000U) == 0) w = make_one_word_bignum(n);
1980 else w = make_two_word_bignum((n >> 31) & 1, n & 0x7fffffff);
1981 errexit();
1982 return onevalue(w);
1983 }
1984
1985 #define STR24HDR (TAG_ODDS+TYPE_STRING+((24+CELL)<<10))
1986
getint(char * p,int len)1987 static int getint(char *p, int len)
1988 {
1989 int r = 0;
1990 while (len-- != 0)
1991 { int c = *p++;
1992 if (c == ' ') c = '0';
1993 r = 10*r + (c - '0');
1994 }
1995 return r;
1996 }
1997
getmon(char * s)1998 static int getmon(char *s)
1999 {
2000 int c1 = s[0], c2 = s[1], c3 = s[2], r = -1, w;
2001 char *m = "janfebmaraprmayjunjulaugsepoctnovdec";
2002 if (isupper(c1)) c1 = tolower(c1);
2003 if (isupper(c2)) c2 = tolower(c2);
2004 if (isupper(c3)) c3 = tolower(c3);
2005 for (w=0; w<12; w++)
2006 { if (c1==m[0] && c2==m[1] && c3==m[2])
2007 { r = w;
2008 break;
2009 }
2010 m += 3;
2011 }
2012 return r;
2013 }
2014
Ldatelessp(Lisp_Object nil,Lisp_Object a,Lisp_Object b)2015 static Lisp_Object Ldatelessp(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
2016 /*
2017 * This is maybe a bit of an abomination! The functions (date) and
2018 * (filedate "filename") [and also (modulep 'modulename)] return times
2019 * as strings of 24 characters. This function decodes these and
2020 * sorts out which time is earlier. The alternative would be to provide
2021 * a collection of functions that returned coded times (as in C "time_t"),
2022 * but I have greater doubts about making those utterly portable, while the
2023 * textual arrangement used here seems fairly robust (until you start
2024 * worrying about carrying a portable machine across time zones or switching
2025 * to daylight savings time).
2026 */
2027 {
2028 char *aa, *bb;
2029 CSLbool res;
2030 int wa, wb;
2031 if (!is_vector(a) || !is_vector(b) ||
2032 vechdr(a) != STR24HDR ||
2033 vechdr(b) != STR24HDR) return aerror2("datelessp", a, b);
2034 aa = (char *)a + (CELL - TAG_VECTOR);
2035 bb = (char *)b + (CELL - TAG_VECTOR);
2036 /*
2037 * Layout is eg. "Wed May 12 15:50:23 1993"
2038 * 012345678901234567890123
2039 * Note that the year is 4 digits so that the year 2000 should hold
2040 * no special terrors JUST here.
2041 */
2042 if ((wa = getint(aa+20, 4)) != (wb = getint(bb+20, 4))) res = wa < wb;
2043 else if ((wa = getmon(aa+4)) != (wb = getmon(bb+4))) res = wa < wb;
2044 else if ((wa = getint(aa+8, 2)) != (wb = getint(bb+8, 2))) res = wa < wb;
2045 else if ((wa = getint(aa+11, 2)) != (wb = getint(bb+11, 2))) res = wa < wb;
2046 else if ((wa = getint(aa+14, 2)) != (wb = getint(bb+14, 2))) res = wa < wb;
2047 else if ((wa = getint(aa+17, 2)) != (wb = getint(bb+17, 2))) res = wa < wb;
2048 else res = NO;
2049 return onevalue(Lispify_predicate(res));
2050 }
2051
Lrepresentation1(Lisp_Object nil,Lisp_Object a)2052 static Lisp_Object Lrepresentation1(Lisp_Object nil, Lisp_Object a)
2053 /*
2054 * Intended for debugging, and use with indirect (q.v.)
2055 */
2056 {
2057 if (SIXTY_FOUR_BIT)
2058 /* /* unreconstructed - may need to build a 64-bit int here */
2059 { int32_t top = (int32_t)a & 0xf8000000U;
2060 CSL_IGNORE(nil);
2061 if (top == 0 || top == 0xf8000000U)
2062 return onevalue(fixnum_of_int((int32_t)a));
2063 a = make_one_word_bignum((int32_t)a);
2064 errexit();
2065 return onevalue(a);
2066 }
2067 else
2068 { int32_t top = (int32_t)a & 0xf8000000U;
2069 CSL_IGNORE(nil);
2070 if (top == 0 || top == 0xf8000000U)
2071 return onevalue(fixnum_of_int((int32_t)a));
2072 a = make_one_word_bignum((int32_t)a);
2073 errexit();
2074 return onevalue(a);
2075 }
2076 }
2077
Lrepresentation2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)2078 static Lisp_Object Lrepresentation2(Lisp_Object nil,
2079 Lisp_Object a, Lisp_Object b)
2080 /*
2081 * Intended for debugging, and use with indirect (q.v.). arg2, if
2082 * present and non-nil makes this more verbose.
2083 */
2084 {
2085 if (SIXTY_FOUR_BIT)
2086 /* /* Unreconstructed wrt return value but trace printing is 64 bit */
2087 { int32_t top = (int32_t)a & 0xf8000000U;
2088 CSL_IGNORE(nil);
2089 if (b != nil) trace_printf(" %.16lx ", (long)(uint64_t)a);
2090 if (top == 0 || top == 0xf8000000U)
2091 return onevalue(fixnum_of_int((int32_t)a));
2092 a = make_one_word_bignum((int32_t)a);
2093 errexit();
2094 return onevalue(a);
2095 }
2096 else
2097 { int32_t top = (int32_t)a & 0xf8000000U;
2098 CSL_IGNORE(nil);
2099 if (b != nil) trace_printf(" %.8lx ", (long)(uint32_t)a);
2100 if (top == 0 || top == 0xf8000000U)
2101 return onevalue(fixnum_of_int((int32_t)a));
2102 a = make_one_word_bignum((int32_t)a);
2103 errexit();
2104 return onevalue(a);
2105 }
2106 }
2107
Lindirect(Lisp_Object nil,Lisp_Object a)2108 Lisp_Object Lindirect(Lisp_Object nil, Lisp_Object a)
2109 {
2110 CSL_IGNORE(nil);
2111 if (SIXTY_FOUR_BIT)
2112 return onevalue(*(Lisp_Object *)(intptr_t)sixty_four_bits(a));
2113 else return onevalue(*(Lisp_Object *)(intptr_t)thirty_two_bits(a));
2114 }
2115
2116 setup_type const funcs1_setup[] =
2117 {
2118 {"acons", wrong_no_na, wrong_no_nb, Lacons},
2119 {"atom", Latom, too_many_1, wrong_no_1},
2120 {"boundp", Lboundp, too_many_1, wrong_no_1},
2121
2122 {"car", Lcar, too_many_1, wrong_no_1},
2123 {"car*", Lcar_star, too_many_1, wrong_no_1},
2124 {"cdr", Lcdr, too_many_1, wrong_no_1},
2125 {"caar", Lcaar, too_many_1, wrong_no_1},
2126 {"cadr", Lcadr, too_many_1, wrong_no_1},
2127 {"cdar", Lcdar, too_many_1, wrong_no_1},
2128 {"cddr", Lcddr, too_many_1, wrong_no_1},
2129 {"caaar", Lcaaar, too_many_1, wrong_no_1},
2130 {"caadr", Lcaadr, too_many_1, wrong_no_1},
2131 {"cadar", Lcadar, too_many_1, wrong_no_1},
2132 {"caddr", Lcaddr, too_many_1, wrong_no_1},
2133 {"cdaar", Lcdaar, too_many_1, wrong_no_1},
2134 {"cdadr", Lcdadr, too_many_1, wrong_no_1},
2135 {"cddar", Lcddar, too_many_1, wrong_no_1},
2136 {"cdddr", Lcdddr, too_many_1, wrong_no_1},
2137 {"caaaar", Lcaaaar, too_many_1, wrong_no_1},
2138 {"caaadr", Lcaaadr, too_many_1, wrong_no_1},
2139 {"caadar", Lcaadar, too_many_1, wrong_no_1},
2140 {"caaddr", Lcaaddr, too_many_1, wrong_no_1},
2141 {"cadaar", Lcadaar, too_many_1, wrong_no_1},
2142 {"cadadr", Lcadadr, too_many_1, wrong_no_1},
2143 {"caddar", Lcaddar, too_many_1, wrong_no_1},
2144 {"cadddr", Lcadddr, too_many_1, wrong_no_1},
2145 {"cdaaar", Lcdaaar, too_many_1, wrong_no_1},
2146 {"cdaadr", Lcdaadr, too_many_1, wrong_no_1},
2147 {"cdadar", Lcdadar, too_many_1, wrong_no_1},
2148 {"cdaddr", Lcdaddr, too_many_1, wrong_no_1},
2149 {"cddaar", Lcddaar, too_many_1, wrong_no_1},
2150 {"cddadr", Lcddadr, too_many_1, wrong_no_1},
2151 {"cdddar", Lcdddar, too_many_1, wrong_no_1},
2152 {"cddddr", Lcddddr, too_many_1, wrong_no_1},
2153
2154 {"qcar", Lcar, too_many_1, wrong_no_1},
2155 {"qcdr", Lcdr, too_many_1, wrong_no_1},
2156 {"qcaar", Lcaar, too_many_1, wrong_no_1},
2157 {"qcadr", Lcadr, too_many_1, wrong_no_1},
2158 {"qcdar", Lcdar, too_many_1, wrong_no_1},
2159 {"qcddr", Lcddr, too_many_1, wrong_no_1},
2160
2161 {"bpsp", Lbpsp, too_many_1, wrong_no_1},
2162 {"codep", Lcodep, too_many_1, wrong_no_1},
2163 {"constantp", Lconstantp, too_many_1, wrong_no_1},
2164 {"date", Ldate1, wrong_no_nb, Ldate},
2165 {"datestamp", wrong_no_na, wrong_no_nb, Ldatestamp},
2166 {"enable-backtrace", Lenable_backtrace, too_many_1, wrong_no_1},
2167 {"error", Lerror1, Lerror2, Lerror},
2168 {"error1", wrong_no_na, wrong_no_nb, Lerror0},
2169 #ifdef NAG
2170 {"unwind", wrong_no_na, wrong_no_nb, Lunwind},
2171 #endif
2172 {"eq-safe", Leq_safe, too_many_1, wrong_no_1},
2173 {"fixp", Lfixp, too_many_1, wrong_no_1},
2174 {"floatp", Lfloatp, too_many_1, wrong_no_1},
2175 {"fluidp", Lsymbol_specialp, too_many_1, wrong_no_1},
2176 {"keywordp", Lkeywordp, too_many_1, wrong_no_1},
2177 {"gctime", wrong_no_na, wrong_no_nb, Lgctime},
2178 {"globalp", Lsymbol_globalp, too_many_1, wrong_no_1},
2179 {"hash-table-p", Lhash_table_p, too_many_1, wrong_no_1},
2180 {"indirect", Lindirect, too_many_1, wrong_no_1},
2181 {"integerp", Lintegerp, too_many_1, wrong_no_1},
2182 {"intersection", too_few_2, Lintersect, wrong_no_2},
2183 {"list2", too_few_2, Llist2, wrong_no_2},
2184 {"list2*", wrong_no_na, wrong_no_nb, Llist2star},
2185 {"list3", wrong_no_na, wrong_no_nb, Llist3},
2186 {"list3*", wrong_no_na, wrong_no_nb, Llist3star},
2187 {"list4", wrong_no_na, wrong_no_nb, Llist4},
2188 {"make-global", Lmake_global, too_many_1, wrong_no_1},
2189 {"make-special", Lmake_special, too_many_1, wrong_no_1},
2190 {"mkquote", Lmkquote, too_many_1, wrong_no_1},
2191 {"ncons", Lncons, too_many_1, wrong_no_1},
2192 {"numberp", Lnumberp, too_many_1, wrong_no_1},
2193 {"pair", too_few_2, Lpair, wrong_no_2},
2194 {"protect-symbols", Lprotect_symbols, too_many_1, wrong_no_1},
2195 {"protected-symbol-warn", Lwarn_about_protected_symbols, too_many_1, wrong_no_1},
2196 {"put", wrong_no_na, wrong_no_nb, Lputprop},
2197 {"remprop", too_few_2, Lremprop, wrong_no_2},
2198 {"representation", Lrepresentation1, Lrepresentation2, wrong_no_2},
2199 {"rplaca", too_few_2, Lrplaca, wrong_no_2},
2200 {"rplacd", too_few_2, Lrplacd, wrong_no_2},
2201 {"set", too_few_2, Lset, wrong_no_2},
2202 {"special-form-p", Lspecial_form_p, too_many_1, wrong_no_1},
2203 {"stop", Lstop, too_many_1, wrong_no_1},
2204 {"symbol-function", Lsymbol_function, too_many_1, wrong_no_1},
2205 {"symbol-value", Lsymbol_value, too_many_1, wrong_no_1},
2206 {"time", wrong_no_na, wrong_no_nb, Ltime},
2207 {"datelessp", too_few_2, Ldatelessp, wrong_no_2},
2208 {"union", too_few_2, Lunion, wrong_no_2},
2209 {"unmake-global", Lunmake_global, too_many_1, wrong_no_1},
2210 {"unmake-special", Lunmake_special, too_many_1, wrong_no_1},
2211 {"xcons", too_few_2, Lxcons, wrong_no_2},
2212 /* I provide both IDP and SYMBOLP in both modes... */
2213 {"symbolp", Lsymbolp, too_many_1, wrong_no_1},
2214 {"idp", Lsymbolp, too_many_1, wrong_no_1},
2215 /* I support the Common Lisp names here in both modes */
2216 {"simple-string-p", Lstringp, too_many_1, wrong_no_1},
2217 {"simple-vector-p", Lsimple_vectorp, too_many_1, wrong_no_1},
2218 #ifdef COMMON
2219 {"fill-vector", wrong_no_na, wrong_no_nb, Lfill_vector},
2220 {"get", too_few_2, Lget, Lget_3},
2221 {"get-decoded-time", wrong_no_0a, wrong_no_0b, Ldecoded_time},
2222 {"arrayp", Larrayp, too_many_1, wrong_no_1},
2223 {"complex-arrayp", Lcomplex_arrayp, too_many_1, wrong_no_1},
2224 {"short-floatp", Lshort_floatp, too_many_1, wrong_no_1},
2225 {"single-floatp", Lsingle_floatp, too_many_1, wrong_no_1},
2226 {"double-floatp", Ldouble_floatp, too_many_1, wrong_no_1},
2227 {"long-floatp", Llong_floatp, too_many_1, wrong_no_1},
2228 {"rationalp", Lrationalp, too_many_1, wrong_no_1},
2229 {"complexp", Lcomplexp, too_many_1, wrong_no_1},
2230 {"consp", Lconsp, too_many_1, wrong_no_1},
2231 {"convert-to-array", Lconvert_to_array, too_many_1, wrong_no_1},
2232 {"convert-to-struct", Lconvert_to_struct, too_many_1, wrong_no_1},
2233 {"identity", Lidentity, too_many_1, wrong_no_1},
2234 {"list", Lncons, Llist2, Llist},
2235 {"list*", Lidentity, Lcons, Lliststar},
2236 {"listp", Llistp, too_many_1, wrong_no_1},
2237 {"bit-vector-p", Lsimple_bit_vector_p, too_many_1, wrong_no_1},
2238 {"simple-bit-vector-p", Lsimple_bit_vector_p, too_many_1, wrong_no_1},
2239 {"stringp", Lc_stringp, too_many_1, wrong_no_1},
2240 {"structp", Lstructp, too_many_1, wrong_no_1},
2241 {"flag", too_few_2, Lflag, wrong_no_2},
2242 {"flagp", too_few_2, Lflagp, wrong_no_2},
2243 {"flagpcar", too_few_2, Lflagpcar, wrong_no_2},
2244 {"remflag", too_few_2, Lremflag, wrong_no_2},
2245 {"time*", wrong_no_na, wrong_no_nb, Ltime},
2246 #else
2247 {"get", too_few_2, Lget, wrong_no_2},
2248 {"convert-to-evector", Lconvert_to_struct, too_many_1, wrong_no_1},
2249 {"evectorp", Lstructp, too_many_1, wrong_no_1},
2250 {"get*", too_few_2, Lget, wrong_no_2},
2251 {"pairp", Lconsp, too_many_1, wrong_no_1},
2252 /* I provide CONSP as well as PAIRP since otherwise I get muddled */
2253 {"consp", Lconsp, too_many_1, wrong_no_1},
2254 {"flag", too_few_2, Lflag, wrong_no_2},
2255 {"flagp", too_few_2, Lflagp, wrong_no_2},
2256 {"flagpcar", too_few_2, Lflagpcar, wrong_no_2},
2257 {"flagp**", too_few_2, Lflagp, wrong_no_2},
2258 {"remflag", too_few_2, Lremflag, wrong_no_2},
2259 {"stringp", Lstringp, too_many_1, wrong_no_1},
2260 {"threevectorp", Lthreevectorp, too_many_1, wrong_no_1},
2261 {"vectorp", Lsimple_vectorp, too_many_1, wrong_no_1},
2262 #endif
2263 {NULL, 0, 0, 0}
2264 };
2265
2266 /* end of fns1.c */
2267