1 /* eval1.c Copyright (C) 1989-2010 Codemist Ltd */
2
3 /*
4 * Interpreter (part 1).
5 */
6
7 /**************************************************************************
8 * Copyright (C) 2010, 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: 63a6fea7 12-May-2010 */
39
40 #include "headers.h"
41
42
43
nreverse(Lisp_Object a)44 Lisp_Object nreverse(Lisp_Object a)
45 {
46 Lisp_Object nil = C_nil;
47 Lisp_Object b = nil;
48 while (consp(a))
49 { Lisp_Object c = a;
50 a = qcdr(a);
51 qcdr(c) = b;
52 b = c;
53 }
54 return b;
55 }
56
57 /*
58 * Environments are represented as association lists, and have to cope
59 * with several sorts of things. The items in an environment can be
60 * in one of the following forms:
61 *
62 * (a) (symbol . value) normal lexical variable binding
63 * (b) (symbol . ~magic~) given symbol is (locally) special
64 * (c) (0 . tag) (block tag ...) marker
65 * (d) (1 . (tag ...)) (tagbody ... tag ...) marker
66 * (e) (2 . <anything>) case (c) or (d) but now invalidated
67 * (f) (def . symbol) (flet ...) or (macrolet ...) binding,
68 * where the def is non-atomic.
69 *
70 * Format for def in case (f)
71 *
72 * (1) (funarg env bvl ...) flet and labels
73 * (2) (bvl ...) macrolet
74 * Note that 'funarg is not valid as a bvl
75 * and indeed in this case bvl is a list
76 */
77
78 /*
79 * In CSL mode flet, macrolet and local declarations are not supported.
80 */
81
Ceval(Lisp_Object u,Lisp_Object env)82 Lisp_Object Ceval(Lisp_Object u, Lisp_Object env)
83 {
84 Lisp_Object nil = C_nil;
85 #ifdef COMMON
86 int t;
87 #ifdef CHECK_STACK
88 if (check_stack(__FILE__,__LINE__)) return aerror("deep stack in eval");
89 #endif
90 restart:
91 t = (int)u & TAG_BITS;
92 /*
93 * The first case considered is of symbols - lexical and special bindings
94 * have to be sorted out.
95 */
96 if (t == TAG_SYMBOL)
97 {
98 Header h = qheader(u);
99 if (h & SYM_SPECIAL_VAR)
100 { Lisp_Object v = qvalue(u);
101 if (v == unset_var) return error(1, err_unset_var, u);
102 else return onevalue(v);
103 }
104 else
105 {
106 while (env != nil)
107 { Lisp_Object p = qcar(env);
108 if (qcar(p) == u)
109 { Lisp_Object v =qcdr(p);
110 /*
111 * If a variable is lexically bound to the value work_symbol that means
112 * that the symbol has been (lexically) declared to be special, so its
113 * value cell should be inspected.
114 */
115 if (v == work_symbol)
116 { v = qvalue(u);
117 if (v == unset_var) return error(1, err_unset_var, u);
118 }
119 return onevalue(v);
120 }
121 env = qcdr(env);
122 }
123 { Lisp_Object v = qvalue(u);
124 if (v == unset_var) return error(1, err_unset_var, u);
125 else return onevalue(v);
126 }
127 }
128 }
129 /*
130 * Things that are neither symbols nor lists evaluate to themselves,
131 * e.g. numbers and vectors.
132 */
133 else if (t != TAG_CONS) return onevalue(u);
134 else
135 #endif /* COMMON */
136 {
137 /*
138 * The final case is that of a list (fn ...), and one case that has to
139 * be checked is if fn is lexically bound.
140 */
141 Lisp_Object fn, args;
142 #ifdef COMMON
143 /*
144 * The test for nil here is because although nil is a symbol the tagging
145 * structure tested here marks it as a list.
146 */
147 if (u == nil) return onevalue(nil);
148 #endif
149 stackcheck2(0, u, env);
150 fn = qcar(u);
151 args = qcdr(u);
152 #ifdef COMMON
153 /*
154 * Local function bindings must be looked for first.
155 */
156 { Lisp_Object p;
157 for (p=env; p!=nil; p=qcdr(p))
158 { Lisp_Object w = qcar(p);
159 /*
160 * The form (<list> . sym) is used in an environment to indicate a local
161 * binding of a function, either as a regular function or as a macro
162 * (i.e. flet or macrolet). The structure of the list distinguishes
163 * between these two cases.
164 */
165 if (qcdr(w) == fn && is_cons(w = qcar(w)) && w!=nil)
166 {
167 p = qcar(w);
168 if (p == funarg) /* ordinary function */
169 { fn = w; /* (funarg ...) is OK to apply */
170 goto ordinary_function;
171 }
172 /*
173 * Here it is a local macro. Observe that the macroexpansion is done
174 * with respect to an empty environment. Macros that are defined at the same
175 * time may seem to be mutually recursive but there is a sense in which they
176 * are not (as well as a sense in which they are) - self and cross references
177 * only happen AFTER an expansion and can not happen during one.
178 */
179 push2(u, env);
180 w = cons(lambda, w);
181 nil = C_nil;
182 if (!exception_pending())
183 p = Lfuncalln(nil, 4, qvalue(macroexpand_hook),
184 w, u, nil);
185 pop2(env, u);
186 nil = C_nil;
187 if (exception_pending())
188 { flip_exception();
189 if ((exit_reason & UNWIND_ERROR) != 0)
190 { err_printf("\nMacroexpanding: ");
191 loop_print_error(u);
192 nil = C_nil;
193 if (exception_pending()) flip_exception();
194 }
195 flip_exception();
196 return nil;
197 }
198 u = p;
199 goto restart;
200 }
201 }
202 }
203 #endif
204 if (is_symbol(fn))
205 {
206 /*
207 * Special forms and macros are checked for next. Special forms
208 * take precedence over macros.
209 */
210 Header h = qheader(fn);
211 if (h & SYM_SPECIAL_FORM)
212 { Lisp_Object v;
213 #ifdef DEBUG
214 if (qfn1(fn) == NULL)
215 { term_printf("Illegal special form\n");
216 my_exit(EXIT_FAILURE);
217 }
218 #endif
219 v = ((Special_Form *)qfn1(fn))(args, env);
220 return v;
221 }
222 else if (h & SYM_MACRO)
223 {
224 push2(u, env);
225 /*
226 * the environment passed to macroexpand should only be needed to cope
227 * with macrolet, I think. Since I use just one datastructure for the
228 * whole environment I also pass along lexical bindings etc, but I hope that
229 * they will never be accessed. I do not think that macrolet is important
230 * enough to call for complication and slow-down in the interpreter this
231 * way - but then I am not exactly what you would call a Common Lisp Fan!
232 */
233 fn = macroexpand(u, env);
234 pop2(env, u);
235 nil = C_nil;
236 if (exception_pending())
237 { flip_exception();
238 if ((exit_reason & UNWIND_ERROR) != 0)
239 { err_printf("\nMacroexpanding: ");
240 loop_print_error(u);
241 nil = C_nil;
242 if (exception_pending()) flip_exception();
243 }
244 flip_exception();
245 return nil;
246 }
247 return eval(fn, env);
248 }
249 }
250 /*
251 * Otherwise we have a regular function call. I prepare the args and
252 * call APPLY.
253 */
254 #ifdef COMMON
255 ordinary_function:
256 #endif
257 { int nargs = 0;
258 Lisp_Object *save_stack = stack;
259 /*
260 * Args are built up on the stack here...
261 */
262 while (consp(args))
263 { Lisp_Object w;
264 push3(fn, args, env);
265 w = qcar(args);
266 w = eval(w, env);
267 pop3(env, args, fn);
268 /*
269 * nil having its mark bit set indicates that a special sort of exit
270 * is in progress. Multiple values can be ignored in this case.
271 */
272 nil = C_nil;
273 if (exception_pending())
274 { flip_exception();
275 stack = save_stack;
276 if ((exit_reason & UNWIND_ERROR) != 0)
277 { err_printf("\nEvaluating: ");
278 loop_print_error(qcar(args));
279 nil = C_nil;
280 if (exception_pending()) flip_exception();
281 }
282 flip_exception();
283 return nil;
284 }
285 push(w); /* args build up on the Lisp stack */
286 nargs++;
287 args = qcdr(args);
288 }
289
290 /*
291 * I pass the environment down to apply() because it will be used if the
292 * function was a simple lambda expression. If the function is a symbol
293 * or a closure, env will be irrelevant. The arguments are on the Lisp
294 * stack, and it is the responsibility of apply() to pop them.
295 */
296 return apply(fn, nargs, env, fn);
297 }
298 }
299 }
300
301 #ifdef COMMON
302 /*
303 * Keyword arguments are not supported in CSL mode - but &optional
304 * and &rest and &aux will be (at least for now). Removal of
305 * support for keywords will save a little space and an even smaller
306 * amount of time.
307 */
308
check_no_unwanted_keys(Lisp_Object restarg,Lisp_Object ok_keys)309 static CSLbool check_no_unwanted_keys(Lisp_Object restarg, Lisp_Object ok_keys)
310 /*
311 * verify that there were no unwanted keys in the actual arg list
312 */
313 {
314 Lisp_Object nil = C_nil;
315 CSLbool odd_key_found = NO;
316 while (restarg!=nil)
317 { Lisp_Object k = qcar(restarg);
318 Lisp_Object w;
319 for (w=ok_keys; w!=nil; w=qcdr(w))
320 if (k == qcar(w)) goto is_ok;
321 odd_key_found = YES;
322 is_ok:
323 restarg = qcdr(restarg);
324 if (restarg==nil) return YES; /* odd length list */
325 if (k == allow_key_key && qcar(restarg) != nil) return NO; /* OK */
326 restarg = qcdr(restarg);
327 }
328 return odd_key_found;
329 }
330
check_keyargs_even(Lisp_Object restarg)331 static CSLbool check_keyargs_even(Lisp_Object restarg)
332 /*
333 * check that list is even length with alternate items symbols in
334 * the keyword package.
335 */
336 {
337 Lisp_Object nil = C_nil;
338 while (restarg!=nil)
339 { Lisp_Object q = qcar(restarg);
340 if (!is_symbol(q) || qpackage(q) != qvalue(keyword_package)) return YES;
341 restarg = qcdr(restarg);
342 if (restarg==nil) return YES; /* Odd length is wrong */
343 restarg = qcdr(restarg);
344 }
345 return NO; /* OK */
346 }
347
keywordify(Lisp_Object v)348 static Lisp_Object keywordify(Lisp_Object v)
349 {
350 /*
351 * arg is a non-nil symbol. Should nil be permitted - I think not
352 * since there seems too much chance of confusion.
353 */
354 Lisp_Object nil, name = get_pname(v);
355 errexit();
356 return Lintern_2(nil, name, qvalue(keyword_package));
357 }
358
key_lookup(Lisp_Object keyname,Lisp_Object args)359 static Lisp_Object key_lookup(Lisp_Object keyname, Lisp_Object args)
360 {
361 Lisp_Object nil = C_nil;
362 while (args!=nil)
363 { Lisp_Object next = qcdr(args);
364 if (next==nil) return nil;
365 if (qcar(args) == keyname) return next;
366 else args = qcdr(next);
367 }
368 return nil;
369 }
370
371 #endif
372
apply_lambda(Lisp_Object def,int nargs,Lisp_Object env,Lisp_Object name)373 Lisp_Object apply_lambda(Lisp_Object def, int nargs,
374 Lisp_Object env, Lisp_Object name)
375 /*
376 * Here def is a lambda expression (sans the initial lambda) that is to
377 * be applied. Much horrible messing about is needed so that I can cope
378 * with &optional and &rest args (including initialisers and supplied-p
379 * variables, also &key, &allow-other-keys and &aux). Note the need to find
380 * any special declarations at the head of the body of the lambda-form.
381 * Must pop (nargs) items from the stack at exit.
382 */
383 {
384 /*
385 * lambda-lists are parsed using a finite state engine with the
386 * following states, plus an exit state.
387 */
388 #define STATE_NULL 0 /* at start and during regular args */
389 #define STATE_OPT 1 /* after &optional */
390 #define STATE_OPT1 2 /* after &optional + at least one var */
391 #define STATE_REST 3 /* immediately after &rest */
392 #define STATE_REST1 4 /* after &rest vv */
393 #ifdef COMMON
394 #define STATE_KEY 5 /* &key with no &rest */
395 #define STATE_ALLOW 6 /* &allow-other-keys */
396 #endif
397 #define STATE_AUX 7 /* &aux */
398
399 Lisp_Object nil = C_nil;
400 int opt_rest_state = STATE_NULL;
401 Lisp_Object *next_arg;
402 int args_left = nargs;
403 Lisp_Object w;
404 if (!consp(def))
405 { popv(nargs);
406 return onevalue(nil); /* Should never happen */
407 }
408 stackcheck3(0, def, env, name);
409 w = qcar(def);
410 next_arg = &stack[1-nargs]; /* Points to arg1 */
411 push4(w, /* bvl */
412 qcdr(def), /* body */
413 env, name);
414 /*
415 * Here I need to macroexpand the first few items in body and
416 * look for declare/special items. I will only bother with SPECIAL decls.
417 * Note that args have been pushed onto the stack first to avoid corruption
418 * while the interpreter performs macroexpansion. This is the sort of place
419 * where I feel that Common Lisp has built in causes of inefficiency.
420 * Well oh well!!! The Common Lisp standardisation group thought so too,
421 * and have now indicated that DECLARE forms can not be hidden away as
422 * the result of macros, so some of this is unnecessary.
423 */
424 push5(nil, nil, /* local_decs, ok_keys */
425 nil, nil, nil); /* restarg, specenv, val1 */
426 push5(nil, nil, /* arg, v1 */
427 nil, nil, nil); /* v, p, w */
428 /*
429 * On computers which have unsigned offsets in indexed memory reference
430 * instructions the negative indexes off the stack suggested here might
431 * be more expensive than I would like - maybe on such machines the stack
432 * pointer should be kept offset by 64 bytes (say). Doing so in general
433 * would be to the disadvantage of machines with auto-index address modes
434 * that might be used when pushing/popping single items on the stack.
435 */
436 #define w stack[0]
437 #define p stack[-1]
438 #define v stack[-2]
439 #define v1 stack[-3]
440 #define arg stack[-4]
441 #define val1 stack[-5]
442 #define specenv stack[-6]
443 #define restarg stack[-7]
444 #ifdef COMMON
445 #define ok_keys stack[-8]
446 #define local_decs stack[-9]
447 #endif
448 #define name stack[-10]
449 #define env stack[-11]
450 #define body stack[-12]
451 #define bvl stack[-13]
452 #define arg1 stack[-14]
453 #define stack_used ((int)(nargs + 14))
454
455 #ifdef COMMON
456 for (;;)
457 { if (!consp(body)) break;
458 p = macroexpand(qcar(body), env);
459 nil = C_nil;
460 if (exception_pending())
461 { Lisp_Object qname = name;
462 popv(stack_used);
463 return qname;
464 }
465 body = qcdr(body);
466 if (!consp(p))
467 { if (stringp(p) && consp(body)) continue;
468 body = cons(p, body);
469 break;
470 }
471 if (qcar(p) != declare_symbol)
472 { body = cons(p, body);
473 break;
474 }
475 for (v = qcdr(v); consp(v); v = qcdr(v))
476 { v1 = qcar(v);
477 if (!consp(v1) || qcar(v1) != special_symbol) continue;
478 /* here v1 says (special ...) */
479 for (v1=qcdr(v1); consp(v1); v1 = qcdr(v1))
480 { local_decs = cons(qcar(v1), local_decs);
481 if (exception_pending()) break;
482 }
483 }
484 }
485 nil = C_nil;
486 if (exception_pending())
487 { Lisp_Object qname = name;
488 popv(stack_used);
489 return qname;
490 }
491 #endif
492 /*
493 * Parse the BVL
494 */
495 for (p = bvl; consp(p); p=qcdr(p))
496 { v = qcar(p);
497 v1 = nil;
498 arg = nil;
499 val1 = nil;
500 /*
501 * I can break from this switch statement with v a variable to bind
502 * and arg the value to bind to it, also v1 (if not nil) is a second
503 * variable to be bound (a supplied-p value) and val1 the value to bind it to.
504 * If I see &rest or &key the remaining actual args get collected into
505 * restarg, which takes the place of arg in some respects.
506 */
507 switch (opt_rest_state)
508 {
509
510 case STATE_NULL:
511 if (v == opt_key)
512 { opt_rest_state = STATE_OPT;
513 continue;
514 }
515
516 #define BAD1(msg) { error(0, msg); goto unwind_special_bindings; }
517 #define BAD2(msg, a) { error(1, msg, a); goto unwind_special_bindings; }
518
519 #define collect_rest_arg() \
520 while (args_left-- != 0) \
521 { if (!exception_pending()) \
522 restarg = cons(next_arg[args_left], restarg); \
523 nil = C_nil; \
524 }
525
526 if (v == rest_key)
527 { collect_rest_arg();
528 if (exception_pending()) goto unwind_special_bindings;
529 opt_rest_state = STATE_REST;
530 continue;
531 }
532 #ifdef COMMON
533 if (v == key_key)
534 { collect_rest_arg();
535 if (exception_pending()) goto unwind_special_bindings;
536 if (check_keyargs_even(restarg)) BAD2(err_bad_keyargs, restarg);
537 opt_rest_state = STATE_KEY;
538 continue;
539 }
540
541 if (v == aux_key)
542 { if (args_left != 0) BAD1(err_excess_args);
543 opt_rest_state = STATE_AUX;
544 continue;
545 }
546 if (v == allow_other_keys) BAD2(err_bad_bvl, v);
547 #endif
548 if (args_left == 0) BAD1(err_insufficient_args);
549 arg = *next_arg++;
550 args_left--;
551 v1 = nil; /* no suppliedp mess here, I'm glad to say */
552 break;
553
554 case STATE_OPT:
555 if (v == opt_key
556 || v == rest_key
557 #ifdef COMMON
558 || v == key_key
559 || v == allow_other_keys
560 || v == aux_key
561 #endif
562 ) BAD2(err_bad_bvl, v);
563 /*
564 * Here v may be a simple variable, or a list (var init suppliedp)
565 */
566 opt_rest_state = STATE_OPT1;
567 process_optional_parameter:
568 if (args_left != 0)
569 { arg = *next_arg++;
570 args_left--;
571 val1 = lisp_true;
572 }
573 else
574 { arg = nil;
575 val1 = nil;
576 }
577 v1 = nil;
578 if (!consp(v)) break; /* Simple case */
579 { w = qcdr(v);
580 v = qcar(v);
581 if (!consp(w)) break; /* (var) */
582 if (val1 == nil) /* use the init form */
583 { arg = qcar(w);
584 arg = eval(arg, env);
585 nil = C_nil;
586 if (exception_pending()) goto unwind_special_bindings;
587 }
588 w = qcdr(w);
589 if (consp(w)) v1 = qcar(w); /* suppliedp name */
590 break;
591 }
592
593 case STATE_OPT1:
594 if (v == rest_key)
595 { collect_rest_arg();
596 if (exception_pending()) goto unwind_special_bindings;
597 opt_rest_state = STATE_REST;
598 continue;
599 }
600 #ifdef COMMON
601 if (v == key_key)
602 { collect_rest_arg();
603 if (exception_pending()) goto unwind_special_bindings;
604 if (check_keyargs_even(restarg)) BAD2(err_bad_keyargs, restarg);
605 opt_rest_state = STATE_KEY;
606 continue;
607 }
608 if (v == aux_key)
609 { if (args_left != 0) BAD1(err_excess_args);
610 opt_rest_state = STATE_AUX;
611 continue;
612 }
613 #endif
614 if (v == opt_key
615 #ifdef COMMON
616 || v == allow_other_keys
617 #endif
618 ) BAD2(err_bad_bvl, v);
619 goto process_optional_parameter;
620
621 case STATE_REST:
622 if (v == opt_key
623 || v == rest_key
624 #ifdef COMMON
625 || v == key_key
626 || v == allow_other_keys
627 || v == aux_key
628 #endif
629 ) BAD2(err_bad_bvl, v);
630 opt_rest_state = STATE_REST1;
631 arg = restarg;
632 break;
633
634 case STATE_REST1:
635 #ifdef COMMON
636 if (v == key_key)
637 { if (check_keyargs_even(restarg)) BAD2(err_bad_keyargs, restarg);
638 opt_rest_state = STATE_KEY;
639 continue;
640 }
641 if (v == aux_key)
642 {
643 opt_rest_state = STATE_AUX;
644 continue;
645 }
646 #endif
647 BAD2(err_bad_bvl, rest_key);
648
649 #ifdef COMMON
650 case STATE_KEY:
651 if (v == allow_other_keys)
652 { opt_rest_state = STATE_ALLOW;
653 continue;
654 }
655 if (v == aux_key)
656 { if (check_no_unwanted_keys(restarg, ok_keys))
657 BAD2(err_bad_keyargs, restarg);
658 opt_rest_state = STATE_AUX;
659 continue;
660 }
661 if (v == opt_key || v == rest_key || v == key_key)
662 BAD2(err_bad_bvl, v);
663 process_keyword_parameter:
664 /*
665 * v needs to expand to ((:kv v) init svar) in effect here.
666 */
667 { Lisp_Object keyname = nil;
668 w = nil;
669 if (!consp(v))
670 { if (!is_symbol(v)) BAD2(err_bad_bvl, v);
671 keyname = keywordify(v);
672 }
673 else
674 { w = qcdr(v);
675 v = qcar(v);
676 if (!consp(v))
677 { if (!is_symbol(v)) BAD2(err_bad_bvl, v);
678 keyname = keywordify(v);
679 nil = C_nil;
680 if (exception_pending()) goto unwind_special_bindings;
681 }
682 else
683 { keyname = qcar(v);
684 if (!is_symbol(keyname)) BAD2(err_bad_bvl, v);
685 keyname = keywordify(keyname);
686 nil = C_nil;
687 if (exception_pending()) goto unwind_special_bindings;
688 v = qcdr(v);
689 if (consp(v)) v = qcar(v);
690 else BAD2(err_bad_bvl, v);
691 }
692 }
693 ok_keys = cons(keyname, ok_keys);
694 nil = C_nil;
695 if (exception_pending()) goto unwind_special_bindings;
696 arg = key_lookup(qcar(ok_keys), restarg);
697 if (arg == nil) val1 = nil;
698 else
699 { arg = qcar(arg);
700 val1 = lisp_true;
701 }
702 v1 = nil;
703 if (!consp(w)) break; /* (var) */
704 if (val1 == nil) /* use the init form */
705 { arg = qcar(w);
706 arg = eval(arg, env);
707 nil = C_nil;
708 if (exception_pending()) goto unwind_special_bindings;
709 }
710 w = qcdr(w);
711 if (consp(w)) v1 = qcar(w); /* suppliedp name */
712 break;
713 }
714
715 case STATE_ALLOW:
716 if (v == aux_key)
717 { opt_rest_state = STATE_AUX;
718 continue;
719 }
720 if (v == opt_key || v == rest_key || v == key_key ||
721 v == allow_other_keys) BAD2(err_bad_bvl, v);
722 goto process_keyword_parameter;
723
724 case STATE_AUX:
725 if (v == opt_key || v == rest_key ||
726 v == key_key || v == allow_other_keys ||
727 v == aux_key) BAD2(err_bad_bvl, v);
728 if (consp(v))
729 { w = qcdr(v);
730 v = qcar(v);
731 if (consp(w))
732 { arg = qcar(w);
733 arg = eval(arg, env);
734 nil = C_nil;
735 if (exception_pending()) goto unwind_special_bindings;
736 }
737 }
738 else arg = nil;
739 v1 = nil;
740 break;
741 #endif
742 }
743 /*
744 * This is where I get when I have one or two vars to bind.
745 */
746
747 #ifndef COMMON
748 /*
749 * CSL mode does not have to mess about looking for local special bindings
750 * and so is MUCH shorter and neater. I always shallow bind
751 */
752 #define instate_binding(var, val, local_decs1, lab) \
753 { if (!is_symbol(var)) BAD2(err_bad_bvl, var); \
754 w = acons(var, qvalue(var), specenv); \
755 nil = C_nil; \
756 if (exception_pending()) goto unwind_special_bindings; \
757 specenv = w; \
758 qvalue(var) = val; \
759 }
760 #else
761 #define instate_binding(var, val, local_decs1, lab) \
762 { Header h; \
763 if (!is_symbol(var)) BAD2(err_bad_bvl, var); \
764 h = qheader(var); \
765 if ((h & SYM_SPECIAL_VAR) != 0) \
766 { w = acons(var, qvalue(var), specenv); \
767 nil = C_nil; \
768 if (exception_pending()) goto unwind_special_bindings; \
769 specenv = w; \
770 qvalue(var) = val; \
771 } \
772 else \
773 { for (w = local_decs1; w!=nil; w = qcdr(w)) \
774 { if (qcar(w) == var) \
775 { qcar(w) = fixnum_of_int(0);/* decl is used up */\
776 w = acons(var, work_symbol, env); \
777 nil = C_nil; \
778 if (exception_pending()) \
779 goto unwind_special_bindings; \
780 env = w; \
781 w = acons(var, qvalue(var), specenv); \
782 nil = C_nil; \
783 if (exception_pending()) \
784 goto unwind_special_bindings; \
785 specenv = w; \
786 qvalue(var) = val; \
787 goto lab; \
788 } \
789 } \
790 w = acons(var, val, env); \
791 nil = C_nil; \
792 if (exception_pending()) goto unwind_special_bindings; \
793 env = w; \
794 lab: ; \
795 } \
796 }
797 #endif
798
799 #ifdef COMMON
800 /*
801 * Must check about local special declarations here...
802 */
803 #endif
804 instate_binding(v, arg, local_decs, label1);
805 if (v1 != nil) instate_binding(v1, val1, local_decs, label2);
806
807 } /* End of for loop that scans BVL */
808
809 #ifdef COMMON
810 /*
811 * As well as local special declarations that have applied to bindings here
812 * there can be some that apply just to variable references within the body.
813 */
814 while (local_decs!=nil)
815 { Lisp_Object q = qcar(local_decs);
816 local_decs=qcdr(local_decs);
817 if (!is_symbol(q)) continue;
818 w = acons(q, work_symbol, env);
819 nil = C_nil;
820 if (exception_pending()) goto unwind_special_bindings;
821 env = w;
822 }
823 #endif
824
825 switch (opt_rest_state)
826 {
827 case STATE_NULL:
828 case STATE_OPT1: /* Ensure there had not been too many args */
829 if (args_left != 0) BAD1(err_excess_args);
830 break;
831
832 case STATE_OPT: /* error if bvl finishes here */
833 case STATE_REST:
834 BAD2(err_bad_bvl, opt_rest_state == STATE_OPT ? opt_key : rest_key);
835
836 #ifdef COMMON
837 case STATE_KEY: /* ensure only valid keys were given */
838 if (check_no_unwanted_keys(restarg, ok_keys))
839 BAD2(err_bad_keyargs, restarg);
840 break;
841 #endif
842
843 default:
844 /* in the following cases all is known to be well
845 case STATE_REST1:
846 case STATE_ALLOW:
847 case STATE_AUX:
848 */
849 break;
850 }
851
852 /*
853 * Now all the argument bindings have been performed - it remains to
854 * process the body of the lambda-expression.
855 */
856 if (specenv == nil)
857 { Lisp_Object bodyx = body, envx = env;
858 Lisp_Object qname = name;
859 popv(stack_used);
860 push(qname);
861 bodyx = progn_fn(bodyx, envx);
862 pop(qname);
863 nil = C_nil;
864 if (exception_pending()) return qname;
865 return bodyx;
866 }
867 { body = progn_fn(body, env);
868 nil = C_nil;
869 if (exception_pending()) goto unwind_special_bindings;
870 while (specenv != nil)
871 {
872 Lisp_Object bv = qcar(specenv);
873 qvalue(qcar(bv)) = qcdr(bv);
874 specenv = qcdr(specenv);
875 }
876 { Lisp_Object bodyx = body;
877 popv(stack_used);
878 /*
879 * note that exit_count has not been disturbed since I called progn_fn,
880 * so the numbert of values that will be returned remains correctly
881 * established (in Common Lisp mode where it is needed.
882 */
883 return bodyx;
884 }
885 }
886
887 unwind_special_bindings:
888 /*
889 * I gete here ONLY if nil has its mark bit set, which means that (for
890 * one reason or another) I am having to unwind the stack, restoring
891 * special bindings as I go.
892 */
893 nil = C_nil;
894 flip_exception();
895 while (specenv != nil)
896 { Lisp_Object bv = qcar(specenv);
897 qvalue(qcar(bv)) = qcdr(bv);
898 specenv = qcdr(specenv);
899 }
900 flip_exception();
901 { Lisp_Object qname = name;
902 popv(stack_used);
903 return qname;
904 }
905 #undef w
906 #undef p
907 #undef v
908 #undef v1
909 #undef arg
910 #undef val1
911 #undef specenv
912 #undef restarg
913 #undef ok_keys
914 #undef local_decs
915 #undef name
916 #undef env
917 #undef body
918 #undef bvl
919 #undef stack_used
920 }
921
Leval(Lisp_Object nil,Lisp_Object a)922 Lisp_Object Leval(Lisp_Object nil, Lisp_Object a)
923 {
924 return eval(a, nil); /* Multiple values may be returned */
925 }
926
Levlis(Lisp_Object nil,Lisp_Object a)927 Lisp_Object Levlis(Lisp_Object nil, Lisp_Object a)
928 {
929 Lisp_Object r;
930 stackcheck1(0, a);
931 r = nil;
932 while (consp(a))
933 { push2(qcdr(a), r);
934 a = qcar(a);
935 a = eval(a, nil);
936 errexitn(2);
937 pop(r);
938 r = cons(a, r);
939 pop(a);
940 errexit();
941 }
942 return onevalue(nreverse(r));
943 }
944
Lapply_n(Lisp_Object nil,int nargs,...)945 Lisp_Object MS_CDECL Lapply_n(Lisp_Object nil, int nargs, ...)
946 {
947 va_list a;
948 int i;
949 Lisp_Object *stack_save = stack, last, fn = nil;
950 if (nargs == 0) return aerror("apply");
951 else if (nargs > 1)
952 { va_start(a, nargs);
953 fn = va_arg(a, Lisp_Object);
954 push_args_1(a, nargs);
955 pop(last);
956 i = nargs-2;
957 while (consp(last))
958 { push(qcar(last));
959 last = qcdr(last);
960 i++;
961 }
962 }
963 else i = 0;
964 stackcheck1(stack-stack_save, fn);
965 return apply(fn, i, nil, fn);
966 }
967
Lapply_1(Lisp_Object nil,Lisp_Object fn)968 Lisp_Object Lapply_1(Lisp_Object nil, Lisp_Object fn)
969 {
970 return Lapply_n(nil, 1, fn);
971 }
972
Lapply_2(Lisp_Object nil,Lisp_Object fn,Lisp_Object a1)973 Lisp_Object Lapply_2(Lisp_Object nil, Lisp_Object fn, Lisp_Object a1)
974 {
975 return Lapply_n(nil, 2, fn, a1);
976 }
977
Lapply0(Lisp_Object nil,Lisp_Object fn)978 Lisp_Object Lapply0(Lisp_Object nil, Lisp_Object fn)
979 {
980 if (is_symbol(fn)) return (*qfnn(fn))(qenv(fn), 0);
981 stackcheck1(0, fn);
982 return apply(fn, 0, C_nil, fn);
983 }
984
Lapply1(Lisp_Object nil,Lisp_Object fn,Lisp_Object a)985 Lisp_Object Lapply1(Lisp_Object nil, Lisp_Object fn, Lisp_Object a)
986 {
987 if (is_symbol(fn)) return (*qfn1(fn))(qenv(fn), a);
988 push(a);
989 stackcheck1(1, fn);
990 return apply(fn, 1, C_nil, fn);
991 }
992
Lapply2(Lisp_Object nil,int nargs,...)993 Lisp_Object MS_CDECL Lapply2(Lisp_Object nil, int nargs, ...)
994 {
995 va_list aa;
996 Lisp_Object fn, a, b;
997 argcheck(nargs, 3, "apply2");
998 va_start(aa, nargs);
999 fn = va_arg(aa, Lisp_Object);
1000 a = va_arg(aa, Lisp_Object);
1001 b = va_arg(aa, Lisp_Object);
1002 va_end(aa);
1003 if (is_symbol(fn)) return (*qfn2(fn))(qenv(fn), a, b);
1004 push2(a, b);
1005 stackcheck1(2, fn);
1006 return apply(fn, 2, C_nil, fn);
1007 }
1008
Lapply3(Lisp_Object nil,int nargs,...)1009 Lisp_Object MS_CDECL Lapply3(Lisp_Object nil, int nargs, ...)
1010 {
1011 va_list aa;
1012 Lisp_Object fn, a, b, c;
1013 argcheck(nargs, 4, "apply3");
1014 va_start(aa, nargs);
1015 fn = va_arg(aa, Lisp_Object);
1016 a = va_arg(aa, Lisp_Object);
1017 b = va_arg(aa, Lisp_Object);
1018 c = va_arg(aa, Lisp_Object);
1019 va_end(aa);
1020 if (is_symbol(fn)) return (*qfnn(fn))(qenv(fn), 3, a, b, c);
1021 push3(a, b, c);
1022 stackcheck1(3, fn);
1023 return apply(fn, 3, C_nil, fn);
1024 }
1025
Lfuncall1(Lisp_Object nil,Lisp_Object fn)1026 Lisp_Object Lfuncall1(Lisp_Object nil, Lisp_Object fn)
1027 {
1028 if (is_symbol(fn)) return (*qfnn(fn))(qenv(fn), 0);
1029 stackcheck1(0, fn);
1030 return apply(fn, 0, nil, fn);
1031 }
1032
Lfuncall2(Lisp_Object nil,Lisp_Object fn,Lisp_Object a1)1033 Lisp_Object Lfuncall2(Lisp_Object nil, Lisp_Object fn, Lisp_Object a1)
1034 {
1035 if (is_symbol(fn)) return (*qfn1(fn))(qenv(fn), a1);
1036 push(a1);
1037 stackcheck1(1, fn);
1038 return apply(fn, 1, nil, fn);
1039 }
1040
Lfuncalln_sub(Lisp_Object nil,int nargs,va_list a)1041 static Lisp_Object MS_CDECL Lfuncalln_sub(Lisp_Object nil, int nargs, va_list a)
1042 {
1043 Lisp_Object *stack_save = stack, fn;
1044 fn = va_arg(a, Lisp_Object);
1045 push_args_1(a, nargs);
1046 stackcheck1(stack-stack_save, fn);
1047 return apply(fn, nargs-1, nil, fn);
1048 }
1049
Lfuncalln(Lisp_Object nil,int nargs,...)1050 Lisp_Object MS_CDECL Lfuncalln(Lisp_Object nil, int nargs, ...)
1051 {
1052 va_list a;
1053 Lisp_Object fn, a1, a2, a3, a4;
1054 va_start(a, nargs);
1055 switch (nargs)
1056 {
1057 case 0: return aerror("funcall");
1058 case 1: /* cases 1 and 2 should go through Lfuncall1,2 not here */
1059 case 2: return aerror("funcall wrong call");
1060 case 3: fn = va_arg(a, Lisp_Object);
1061 a1 = va_arg(a, Lisp_Object);
1062 a2 = va_arg(a, Lisp_Object);
1063 if (is_symbol(fn)) return (*qfn2(fn))(qenv(fn), a1, a2);
1064 push2(a1, a2);
1065 return apply(fn, 2, nil, fn);
1066 case 4: fn = va_arg(a, Lisp_Object);
1067 a1 = va_arg(a, Lisp_Object);
1068 a2 = va_arg(a, Lisp_Object);
1069 a3 = va_arg(a, Lisp_Object);
1070 if (is_symbol(fn)) return (*qfnn(fn))(qenv(fn), 3, a1, a2, a3);
1071 push3(a1, a2, a3);
1072 return apply(fn, 3, nil, fn);
1073 case 5: fn = va_arg(a, Lisp_Object);
1074 a1 = va_arg(a, Lisp_Object);
1075 a2 = va_arg(a, Lisp_Object);
1076 a3 = va_arg(a, Lisp_Object);
1077 a4 = va_arg(a, Lisp_Object);
1078 if (is_symbol(fn)) return (*qfnn(fn))(qenv(fn), 4, a1, a2, a3, a4);
1079 push4(a1, a2, a3, a4);
1080 return apply(fn, 4, nil, fn);
1081 default:
1082 return Lfuncalln_sub(nil, nargs, a);
1083 }
1084 }
1085
1086 #ifdef COMMON
1087
Lvalues(Lisp_Object nil,int nargs,...)1088 Lisp_Object MS_CDECL Lvalues(Lisp_Object nil, int nargs, ...)
1089 {
1090 va_list a;
1091 Lisp_Object *p = &mv_2, w;
1092 int i;
1093 /*
1094 * Because multiple-values get passed back in static storage there is
1095 * a fixed upper limit to how many I can handle - truncate here to allow
1096 * for that.
1097 */
1098 if (nargs > 50) nargs = 50;
1099 if (nargs == 0) return nvalues(nil, 0);
1100 va_start(a, nargs);
1101 push_args(a, nargs);
1102 for (i=1; i<nargs; i++)
1103 { pop(w);
1104 p[nargs-i-1] = w;
1105 }
1106 pop(w);
1107 return nvalues(w, nargs);
1108 }
1109
Lvalues_2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1110 Lisp_Object Lvalues_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1111 {
1112 return Lvalues(nil, 2, a, b);
1113 }
1114
Lvalues_1(Lisp_Object nil,Lisp_Object a)1115 Lisp_Object Lvalues_1(Lisp_Object nil, Lisp_Object a)
1116 {
1117 return Lvalues(nil, 1, a);
1118 }
1119
mv_call_fn(Lisp_Object args,Lisp_Object env)1120 Lisp_Object mv_call_fn(Lisp_Object args, Lisp_Object env)
1121 /*
1122 * here with the rest of the interpreter rather than in specforms.c
1123 */
1124 {
1125 Lisp_Object nil = C_nil;
1126 Lisp_Object fn, *stack_save = stack;
1127 int i=0, j=0;
1128 if (!consp(args)) return nil; /* (multiple-value-call) => nil */
1129 stackcheck2(0, args, env);
1130 push2(args, env);
1131 fn = qcar(args);
1132 fn = eval(fn, env);
1133 pop2(env, args);
1134 errexit();
1135 args = qcdr(args);
1136 while (consp(args))
1137 { Lisp_Object r1;
1138 push2(args, env);
1139 r1 = qcar(args);
1140 r1 = eval(r1, env);
1141 nil = C_nil;
1142 if (exception_pending())
1143 { stack = stack_save;
1144 return nil;
1145 }
1146 /*
1147 * It is critical here that push does not check for stack overflow and
1148 * thus can not call the garbage collector, or otherwise lead to calculation
1149 * that could possibly clobber the multiple results that I am working with
1150 * here.
1151 */
1152 pop2(env, args);
1153 push(r1);
1154 i++;
1155 for (j = 2; j<=exit_count; j++)
1156 { push((&work_0)[j]);
1157 i++;
1158 }
1159 args = qcdr(args);
1160 }
1161 stackcheck2(stack-stack_save, fn, env);
1162 return apply(fn, i, env, fn);
1163 }
1164
1165 #endif
1166
interpreted1(Lisp_Object def,Lisp_Object a1)1167 Lisp_Object interpreted1(Lisp_Object def, Lisp_Object a1)
1168 {
1169 Lisp_Object nil = C_nil;
1170 push(a1);
1171 stackcheck1(1, def);
1172 return apply_lambda(def, 1, nil, def);
1173 }
1174
interpreted2(Lisp_Object def,Lisp_Object a1,Lisp_Object a2)1175 Lisp_Object interpreted2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
1176 {
1177 Lisp_Object nil = C_nil;
1178 push2(a1, a2);
1179 stackcheck1(2, def);
1180 return apply_lambda(def, 2, nil, def);
1181 }
1182
interpretedn(Lisp_Object def,int nargs,...)1183 Lisp_Object MS_CDECL interpretedn(Lisp_Object def, int nargs, ...)
1184 {
1185 /*
1186 * The messing about here is to get the (unknown number of) args
1187 * into a nice neat vector so that they can be indexed into. If I knew
1188 * that the args were in consecutive locations on the stack I could
1189 * probably save a copying operation.
1190 */
1191 Lisp_Object nil = C_nil;
1192 Lisp_Object *stack_save = stack;
1193 va_list a;
1194 if (nargs != 0)
1195 { va_start(a, nargs);
1196 push_args(a, nargs);
1197 }
1198 stackcheck1(stack-stack_save, def);
1199 return apply_lambda(def, nargs, nil, def);
1200 }
1201
funarged1(Lisp_Object def,Lisp_Object a1)1202 Lisp_Object funarged1(Lisp_Object def, Lisp_Object a1)
1203 {
1204 Lisp_Object nil = C_nil;
1205 push(a1);
1206 stackcheck1(1, def);
1207 return apply_lambda(qcdr(def), 1, qcar(def), qcdr(def));
1208 }
1209
funarged2(Lisp_Object def,Lisp_Object a1,Lisp_Object a2)1210 Lisp_Object funarged2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
1211 {
1212 Lisp_Object nil = C_nil;
1213 push2(a1, a2);
1214 stackcheck1(2, def);
1215 return apply_lambda(qcdr(def), 2, qcar(def), qcdr(def));
1216 }
1217
funargedn(Lisp_Object def,int nargs,...)1218 Lisp_Object MS_CDECL funargedn(Lisp_Object def, int nargs, ...)
1219 {
1220 Lisp_Object nil = C_nil;
1221 Lisp_Object *stack_save = stack;
1222 va_list a;
1223 if (nargs != 0)
1224 { va_start(a, nargs);
1225 push_args(a, nargs);
1226 }
1227 stackcheck1(stack-stack_save, def);
1228 return apply_lambda(qcdr(def), nargs, qcar(def), qcdr(def));
1229 }
1230
1231 /*
1232 * Now some execution-doubling versions...
1233 */
1234
double_interpreted1(Lisp_Object def,Lisp_Object a1)1235 Lisp_Object double_interpreted1(Lisp_Object def, Lisp_Object a1)
1236 {
1237 Lisp_Object nil = C_nil;
1238 push(a1);
1239 stackcheck1(1, def);
1240 return apply_lambda(def, 1, nil, def);
1241 }
1242
double_interpreted2(Lisp_Object def,Lisp_Object a1,Lisp_Object a2)1243 Lisp_Object double_interpreted2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
1244 {
1245 Lisp_Object nil = C_nil;
1246 push2(a1, a2);
1247 stackcheck1(2, def);
1248 return apply_lambda(def, 2, nil, def);
1249 }
1250
double_interpretedn(Lisp_Object def,int nargs,...)1251 Lisp_Object MS_CDECL double_interpretedn(Lisp_Object def, int nargs, ...)
1252 {
1253 /*
1254 * The messing about here is to get the (unknown number of) args
1255 * into a nice neat vector so that they can be indexed into. If I knew
1256 * that the args were in consecutive locations on the stack I could
1257 * probably save a copying operation.
1258 */
1259 Lisp_Object nil = C_nil;
1260 Lisp_Object *stack_save = stack;
1261 va_list a;
1262 if (nargs != 0)
1263 { va_start(a, nargs);
1264 push_args(a, nargs);
1265 }
1266 stackcheck1(stack-stack_save, def);
1267 return apply_lambda(def, nargs, nil, def);
1268 }
1269
double_funarged1(Lisp_Object def,Lisp_Object a1)1270 Lisp_Object double_funarged1(Lisp_Object def, Lisp_Object a1)
1271 {
1272 Lisp_Object nil = C_nil;
1273 push(a1);
1274 stackcheck1(1, def);
1275 return apply_lambda(qcdr(def), 1, qcar(def), qcdr(def));
1276 }
1277
double_funarged2(Lisp_Object def,Lisp_Object a1,Lisp_Object a2)1278 Lisp_Object double_funarged2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
1279 {
1280 Lisp_Object nil = C_nil;
1281 push2(a1, a2);
1282 stackcheck1(2, def);
1283 return apply_lambda(qcdr(def), 2, qcar(def), qcdr(def));
1284 }
1285
double_funargedn(Lisp_Object def,int nargs,...)1286 Lisp_Object MS_CDECL double_funargedn(Lisp_Object def, int nargs, ...)
1287 {
1288 Lisp_Object nil = C_nil;
1289 Lisp_Object *stack_save = stack;
1290 va_list a;
1291 if (nargs != 0)
1292 { va_start(a, nargs);
1293 push_args(a, nargs);
1294 }
1295 stackcheck1(stack-stack_save, def);
1296 return apply_lambda(qcdr(def), nargs, qcar(def), qcdr(def));
1297 }
1298
traceinterpreted1(Lisp_Object def,Lisp_Object a1)1299 Lisp_Object traceinterpreted1(Lisp_Object def, Lisp_Object a1)
1300 /*
1301 * Like interpreted() but the definition has the fn name consed on the front
1302 */
1303 {
1304 Lisp_Object nil = C_nil, r;
1305 push(a1);
1306 stackcheck1(1, def);
1307 freshline_trace();
1308 trace_printf("Entering ");
1309 loop_print_trace(qcar(def));
1310 trace_printf(" (1 arg)\n");
1311 trace_printf("Arg1: ");
1312 loop_print_trace(stack[0]);
1313 trace_printf("\n");
1314 r = apply_lambda(qcdr(def), 1, nil, def);
1315 errexit();
1316 push(r);
1317 trace_printf("Value = ");
1318 loop_print_trace(r);
1319 trace_printf("\n");
1320 pop(r);
1321 return r;
1322 }
1323
traceinterpreted2(Lisp_Object def,Lisp_Object a1,Lisp_Object a2)1324 Lisp_Object traceinterpreted2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
1325 /*
1326 * Like interpreted() but the definition has the fn name consed on the front
1327 */
1328 {
1329 Lisp_Object nil = C_nil, r;
1330 int i;
1331 push2(a1, a2);
1332 stackcheck1(2, def);
1333 freshline_trace();
1334 trace_printf("Entering ");
1335 loop_print_trace(qcar(def));
1336 trace_printf(" (2 args)\n");
1337 for (i=1; i<=2; i++)
1338 { trace_printf("Arg%d: ", i);
1339 loop_print_trace(stack[i-2]);
1340 trace_printf("\n");
1341 }
1342 r = apply_lambda(qcdr(def), 2, nil, def);
1343 errexit();
1344 push(r);
1345 trace_printf("Value = ");
1346 loop_print_trace(r);
1347 trace_printf("\n");
1348 pop(r);
1349 return r;
1350 }
1351
traceinterpretedn(Lisp_Object def,int nargs,...)1352 Lisp_Object MS_CDECL traceinterpretedn(Lisp_Object def, int nargs, ...)
1353 /*
1354 * Like interpreted() but the definition has the fn name consed on the front
1355 */
1356 {
1357 int i;
1358 Lisp_Object nil = C_nil, r;
1359 Lisp_Object *stack_save = stack;
1360 va_list a;
1361 if (nargs != 0)
1362 { va_start(a, nargs);
1363 push_args(a, nargs);
1364 }
1365 stackcheck1(stack-stack_save, def);
1366 freshline_trace();
1367 trace_printf("Entering ");
1368 loop_print_trace(qcar(def));
1369 trace_printf(" (%d args)\n", nargs);
1370 for (i=1; i<=nargs; i++)
1371 { trace_printf("Arg%d: ", i);
1372 loop_print_trace(stack[i-nargs]);
1373 trace_printf("\n");
1374 }
1375 r = apply_lambda(qcdr(def), nargs, nil, def);
1376 errexit();
1377 push(r);
1378 trace_printf("Value = ");
1379 loop_print_trace(r);
1380 trace_printf("\n");
1381 pop(r);
1382 return r;
1383 }
1384
tracefunarged1(Lisp_Object def,Lisp_Object a1)1385 Lisp_Object tracefunarged1(Lisp_Object def, Lisp_Object a1)
1386 /*
1387 * Like funarged() but with some printing
1388 */
1389 {
1390 Lisp_Object nil = C_nil, r;
1391 push(a1);
1392 stackcheck1(1, def);
1393 freshline_trace();
1394 trace_printf("Entering funarg ");
1395 loop_print_trace(qcar(def));
1396 trace_printf(" (1 arg)\n");
1397 def = qcdr(def);
1398 r = apply_lambda(qcdr(def), 1, qcar(def), qcdr(def));
1399 errexit();
1400 push(r);
1401 trace_printf("Value = ");
1402 loop_print_trace(r);
1403 trace_printf("\n");
1404 pop(r);
1405 return r;
1406 }
1407
tracefunarged2(Lisp_Object def,Lisp_Object a1,Lisp_Object a2)1408 Lisp_Object tracefunarged2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
1409 /*
1410 * Like funarged() but with some printing
1411 */
1412 {
1413 Lisp_Object nil = C_nil, r;
1414 push2(a1, a2);
1415 stackcheck1(2, def);
1416 freshline_trace();
1417 trace_printf("Entering funarg ");
1418 loop_print_trace(qcar(def));
1419 trace_printf(" (2 args)\n");
1420 def = qcdr(def);
1421 r = apply_lambda(qcdr(def), 2, qcar(def), qcdr(def));
1422 errexit();
1423 push(r);
1424 trace_printf("Value = ");
1425 loop_print_trace(r);
1426 trace_printf("\n");
1427 pop(r);
1428 return r;
1429 }
1430
tracefunargedn(Lisp_Object def,int nargs,...)1431 Lisp_Object MS_CDECL tracefunargedn(Lisp_Object def, int nargs, ...)
1432 /*
1433 * Like funarged() but with some printing
1434 */
1435 {
1436 Lisp_Object nil = C_nil, r;
1437 Lisp_Object *stack_save = stack;
1438 va_list a;
1439 if (nargs != 0)
1440 { va_start(a, nargs);
1441 push_args(a, nargs);
1442 }
1443 stackcheck1(stack-stack_save, def);
1444 freshline_trace();
1445 trace_printf("Entering funarg ");
1446 loop_print_trace(qcar(def));
1447 trace_printf(" (%d args)\n", nargs);
1448 def = qcdr(def);
1449 r = apply_lambda(qcdr(def), nargs, qcar(def), qcdr(def));
1450 errexit();
1451 push(r);
1452 trace_printf("Value = ");
1453 loop_print_trace(r);
1454 trace_printf("\n");
1455 pop(r);
1456 return r;
1457 }
1458
macroexpand_1(Lisp_Object form,Lisp_Object env)1459 static Lisp_Object macroexpand_1(Lisp_Object form, Lisp_Object env)
1460 { /* The environment here seems only necessary for macrolet */
1461 Lisp_Object done;
1462 Lisp_Object f, nil;
1463 nil = C_nil;
1464 stackcheck2(0, form, env);
1465 done = nil;
1466 if (consp(form))
1467 { f = qcar(form);
1468 #ifdef COMMON
1469 /*
1470 * look for local macro definitions
1471 */
1472 { Lisp_Object p;
1473 for (p=env; p!=nil; p=qcdr(p))
1474 { Lisp_Object w = qcar(p);
1475 if (qcdr(w) == f && is_cons(w = qcar(w)) && w!=nil)
1476 {
1477 p = qcar(w);
1478 if (p == funarg) /* ordinary function */
1479 { mv_2 = nil;
1480 return nvalues(form, 2);
1481 }
1482 push2(form, done);
1483 w = cons(lambda, w);
1484 errexitn(1);
1485 p = Lfuncalln(nil, 4, qvalue(macroexpand_hook),
1486 w, stack[-1], nil);
1487 pop2(done, form);
1488 nil = C_nil;
1489 if (exception_pending())
1490 { flip_exception();
1491 if ((exit_reason & UNWIND_ERROR) != 0)
1492 { err_printf("\nMacroexpanding: ");
1493 loop_print_error(form);
1494 nil = C_nil;
1495 if (exception_pending()) flip_exception();
1496 }
1497 flip_exception();
1498 return nil;
1499 }
1500 mv_2 = lisp_true;
1501 return nvalues(p, 2);
1502 }
1503 }
1504 }
1505 /*
1506 * If there is no local macro definition I need to look for a global one
1507 */
1508 #endif
1509 if (symbolp(f) && (qheader(f) & SYM_MACRO) != 0)
1510 {
1511 done = qvalue(macroexpand_hook);
1512 if (done == unset_var)
1513 return error(1, err_macroex_hook, macroexpand_hook);
1514 push3(form, env, done);
1515 f = cons(lambda, qenv(f));
1516 pop3(done, env, form);
1517 nil = C_nil;
1518 if (!exception_pending())
1519 {
1520 #ifndef COMMON
1521 /* CSL does not pass an environment down here, so does not demand &opt arg */
1522 form = Lfuncalln(nil, 3, done, f, form);
1523 #else
1524 form = Lfuncalln(nil, 4, done, f, form, env);
1525 #endif
1526 nil = C_nil;
1527 }
1528 if (exception_pending()) return nil;
1529 done = lisp_true;
1530 }
1531 }
1532 mv_2 = done;
1533 return nvalues(form, 2); /* Multiple values handed back */
1534 }
1535
macroexpand(Lisp_Object form,Lisp_Object env)1536 Lisp_Object macroexpand(Lisp_Object form, Lisp_Object env)
1537 { /* The environment here seems only necessary for macrolet */
1538 Lisp_Object done, nil;
1539 nil = C_nil;
1540 stackcheck2(0, form, env);
1541 done = nil;
1542 for (;;)
1543 { push2(env, done);
1544 form = macroexpand_1(form, env);
1545 pop2(done, env);
1546 errexit();
1547 if (mv_2 == nil) break;
1548 done = lisp_true;
1549 }
1550 mv_2 = done;
1551 return nvalues(form, 2); /* Multiple values handed back */
1552 }
1553
Lmacroexpand(Lisp_Object nil,Lisp_Object a)1554 Lisp_Object Lmacroexpand(Lisp_Object nil, Lisp_Object a)
1555 {
1556 return macroexpand(a, nil);
1557 }
1558
1559 #ifdef COMMON
Lmacroexpand_2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1560 Lisp_Object Lmacroexpand_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1561 {
1562 CSL_IGNORE(nil);
1563 return macroexpand(a, b);
1564 }
1565 #endif
1566
Lmacroexpand_1(Lisp_Object nil,Lisp_Object a)1567 Lisp_Object Lmacroexpand_1(Lisp_Object nil, Lisp_Object a)
1568 {
1569 return macroexpand_1(a, nil);
1570 }
1571
1572 #ifdef COMMON
Lmacroexpand_1_2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1573 Lisp_Object Lmacroexpand_1_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1574 {
1575 CSL_IGNORE(nil);
1576 return macroexpand_1(a, b);
1577 }
1578
1579 #endif
1580
1581 /*
1582 * To make something autoloadable I should set the environment cell to
1583 * (name-of-self module-name-1 module-name-2 ...)
1584 * and when invoked the function will do a load-module on each of the
1585 * modules specified and then re-attempt to call. Loading the
1586 * modules is expected to establish a proper definition for the
1587 * function involved.
1588 */
1589
autoload1(Lisp_Object fname,Lisp_Object a1)1590 Lisp_Object autoload1(Lisp_Object fname, Lisp_Object a1)
1591 {
1592 Lisp_Object nil = C_nil;
1593 push2(a1, qcar(fname));
1594 set_fns(qcar(fname), undefined1, undefined2, undefinedn);
1595 qenv(qcar(fname)) = qcar(fname);
1596 fname = qcdr(fname);
1597 while (consp(fname))
1598 { push(qcdr(fname));
1599 Lload_module(nil, qcar(fname));
1600 errexitn(3);
1601 pop(fname);
1602 }
1603 pop(fname);
1604 return apply(fname, 1, nil, fname);
1605 }
1606
autoload2(Lisp_Object fname,Lisp_Object a1,Lisp_Object a2)1607 Lisp_Object autoload2(Lisp_Object fname, Lisp_Object a1, Lisp_Object a2)
1608 {
1609 Lisp_Object nil = C_nil;
1610 push3(a1, a2, qcar(fname));
1611 set_fns(qcar(fname), undefined1, undefined2, undefinedn);
1612 qenv(qcar(fname)) = qcar(fname);
1613 fname = qcdr(fname);
1614 while (consp(fname))
1615 { push(qcdr(fname));
1616 Lload_module(nil, qcar(fname));
1617 errexitn(4);
1618 pop(fname);
1619 }
1620 pop(fname);
1621 return apply(fname, 2, nil, fname);
1622 }
1623
autoloadn(Lisp_Object fname,int nargs,...)1624 Lisp_Object MS_CDECL autoloadn(Lisp_Object fname, int nargs, ...)
1625 {
1626 Lisp_Object nil = C_nil;
1627 va_list a;
1628 va_start(a, nargs);
1629 push_args(a, nargs);
1630 push(qcar(fname));
1631 set_fns(qcar(fname), undefined1, undefined2, undefinedn);
1632 qenv(qcar(fname)) = qcar(fname);
1633 fname = qcdr(fname);
1634 while (consp(fname))
1635 { push(qcdr(fname));
1636 Lload_module(nil, qcar(fname));
1637 errexitn(nargs+2);
1638 pop(fname);
1639 }
1640 pop(fname);
1641 return apply(fname, nargs, nil, fname);
1642 }
1643
undefined1(Lisp_Object fname,Lisp_Object a1)1644 Lisp_Object undefined1(Lisp_Object fname, Lisp_Object a1)
1645 {
1646 /*
1647 * It would be perfectly possible to grab and save the args here, and retry
1648 * the function call after error has patched things up. Again
1649 * this entrypoint is for compiled code calling something that is undefined,
1650 * and so no lexical environment is needed.
1651 */
1652 CSL_IGNORE(a1);
1653 return error(1, err_undefined_function_1, fname);
1654 }
1655
undefined2(Lisp_Object fname,Lisp_Object a1,Lisp_Object a2)1656 Lisp_Object undefined2(Lisp_Object fname, Lisp_Object a1, Lisp_Object a2)
1657 {
1658 CSL_IGNORE(a1);
1659 CSL_IGNORE(a2);
1660 return error(1, err_undefined_function_2, fname);
1661 }
1662
undefinedn(Lisp_Object fname,int nargs,...)1663 Lisp_Object MS_CDECL undefinedn(Lisp_Object fname, int nargs, ...)
1664 {
1665 CSL_IGNORE(nargs);
1666 return error(1, err_undefined_function_n, fname);
1667 }
1668
1669 /*
1670 * The next few functions allow me to create variants on things! The
1671 * entrypoint fX_as_Y goes in the function cell of a symbol, and the name
1672 * of a function with Y arguments goes in is environment cell. The result will
1673 * be a function that accepts X arguments and discards all but the first Y of
1674 * them, then chains to the other function. The purpose is to support goo
1675 * compilation of things like
1676 * (de funny_equal (a b c) (equal a b))
1677 */
1678
f0_as_0(Lisp_Object env,int nargs,...)1679 Lisp_Object MS_CDECL f0_as_0(Lisp_Object env, int nargs, ...)
1680 {
1681 if (nargs != 0) return aerror1("wrong number of args (0->0)", env);
1682 return (*qfnn(env))(qenv(env), 0);
1683 }
1684
f1_as_0(Lisp_Object env,Lisp_Object a)1685 Lisp_Object f1_as_0(Lisp_Object env, Lisp_Object a)
1686 {
1687 CSL_IGNORE(a);
1688 return (*qfnn(env))(qenv(env), 0);
1689 }
1690
f2_as_0(Lisp_Object env,Lisp_Object a,Lisp_Object b)1691 Lisp_Object f2_as_0(Lisp_Object env, Lisp_Object a, Lisp_Object b)
1692 {
1693 CSL_IGNORE(a);
1694 CSL_IGNORE(b);
1695 return (*qfnn(env))(qenv(env), 0);
1696 }
1697
f3_as_0(Lisp_Object env,int nargs,...)1698 Lisp_Object MS_CDECL f3_as_0(Lisp_Object env, int nargs, ...)
1699 {
1700 if (nargs != 3) return aerror1("wrong number of args (3->0)", env);
1701 return (*qfnn(env))(qenv(env), 0);
1702 }
1703
f1_as_1(Lisp_Object env,Lisp_Object a)1704 Lisp_Object f1_as_1(Lisp_Object env, Lisp_Object a)
1705 {
1706 return (*qfn1(env))(qenv(env), a);
1707 }
1708
f2_as_1(Lisp_Object env,Lisp_Object a,Lisp_Object b)1709 Lisp_Object f2_as_1(Lisp_Object env, Lisp_Object a, Lisp_Object b)
1710 {
1711 CSL_IGNORE(b);
1712 return (*qfn1(env))(qenv(env), a);
1713 }
1714
f3_as_1(Lisp_Object env,int nargs,...)1715 Lisp_Object MS_CDECL f3_as_1(Lisp_Object env, int nargs, ...)
1716 {
1717 va_list a;
1718 Lisp_Object a1;
1719 if (nargs != 3) return aerror1("wrong number of args (3->1)", env);
1720 va_start(a, nargs);
1721 a1 = va_arg(a, Lisp_Object);
1722 va_end(a);
1723 return (*qfn1(env))(qenv(env), a1);
1724 }
1725
f2_as_2(Lisp_Object env,Lisp_Object a,Lisp_Object b)1726 Lisp_Object f2_as_2(Lisp_Object env, Lisp_Object a, Lisp_Object b)
1727 {
1728 return (*qfn2(env))(qenv(env), a, b);
1729 }
1730
f3_as_2(Lisp_Object env,int nargs,...)1731 Lisp_Object MS_CDECL f3_as_2(Lisp_Object env, int nargs, ...)
1732 {
1733 va_list a;
1734 Lisp_Object a1, a2;
1735 if (nargs != 3) return aerror1("wrong number of args (3->2)", env);
1736 va_start(a, nargs);
1737 a1 = va_arg(a, Lisp_Object);
1738 a2 = va_arg(a, Lisp_Object);
1739 va_end(a);
1740 return (*qfn2(env))(qenv(env), a1, a2);
1741 }
1742
f3_as_3(Lisp_Object env,int nargs,...)1743 Lisp_Object MS_CDECL f3_as_3(Lisp_Object env, int nargs, ...)
1744 {
1745 va_list a;
1746 Lisp_Object a1, a2, a3;
1747 if (nargs != 3) return aerror1("wrong number of args (3->3)", env);
1748 va_start(a, nargs);
1749 a1 = va_arg(a, Lisp_Object);
1750 a2 = va_arg(a, Lisp_Object);
1751 a3 = va_arg(a, Lisp_Object);
1752 va_end(a);
1753 return (*qfnn(env))(qenv(env), 3, a1, a2, a3);
1754 }
1755
1756 /*
1757 * The next function is EXPERIMENTAL and is only available if there is
1758 * a "fork" function available. It is probably only even partially useful
1759 * if the operating system and libraries used implement that using a
1760 * "copy on write" strategy. This is the case with Linux, and I believe it to
1761 * be so in MacOSX. But Windows does not provide that sort of functionality
1762 * comfortably, so this stuff will not be available there. Observe that I
1763 * make fairly extreme use of the autoconf detection stuff to try to avoid
1764 * trying this where it might not make sense!
1765 */
1766
1767 /*
1768 * Expected behaviour
1769 * (parallel f a)
1770 * runs two tasks, one of which is f(a, nil), the other is f(a, t).
1771 * when the first of those tasks completes the other is killed.
1772 * The result is a pair (fg . val)
1773 * If fg > 0 it is 1 or 2 to indicate which of the two calls
1774 * "won". In that case the value is the result returned by the
1775 * call, but NOTE that it has been in effect through print/read, and
1776 * so gensym identity and structure sharing will have been lost.
1777 * If fg < 0 then the true result was computed, but its printed
1778 * representation was longer than around 2K characters. The absolute
1779 * value of fg again indicates which task won, but the value is now
1780 * a string consisting of the first segment of characters in a printed
1781 * representation of the result. If creating parallel processes
1782 * fails or if the first task to finish does so by failing then this
1783 * call will report an error.
1784 * While it may be legal to use nested instaces of parallel to get
1785 * extra concurrency the memory demands that will result could be
1786 * severe. The overhead associated with starting and finishing a
1787 * task may also be significant, and so this is only liable to make
1788 * sense on a multi-cpu system for sub-tasks that are fairly demanding.
1789 * Note that the longer running task will be cancelled and no output
1790 * from it will be available at all.
1791 * Tasks run this way should probably avoid all input and output
1792 * operations.
1793 *
1794 * If the computer on which CSL has been built does not support "fork"
1795 * and the shared memory operations required here the parallel function
1796 * will just always report an error.
1797 *
1798 * While this code is in development it may genatate a certain amount
1799 * of unwanted trace or logging information.
1800 */
1801
1802 #if defined HAVE_UNISTD_H && \
1803 defined HAVE_SYS_TYPES_H && \
1804 defined HAVE_SYS_STAT_H && \
1805 defined HAVE_SYS_WAIT_H && \
1806 defined HAVE_SIGNAL_H && \
1807 defined HAVE_SYS_SHM_H && \
1808 defined HAVE_SYS_IPC_H && \
1809 defined HAVE_FORK && \
1810 defined HAVE_WAIT && \
1811 defined HAVE_WAITPID && \
1812 defined HAVE_SHMGET && \
1813 defined HAVE_SHMAT && \
1814 defined HAVE_SHMDT && \
1815 defined HAVE_SHMCTL
1816
1817 #include <sys/types.h>
1818 #include <sys/stat.h>
1819 #include <unistd.h>
1820 #include <sys/wait.h>
1821 #include <sys/shm.h>
1822 #include <sys/ipc.h>
1823 #include <errno.h>
1824
1825 #define PARSIZE 2048
1826
write_result(Lisp_Object nil,Lisp_Object r,char * shared)1827 static void write_result(Lisp_Object nil, Lisp_Object r, char *shared)
1828 {
1829 /*
1830 * This converts an arbitrary resulty into a string so I can pass it back.
1831 */
1832 int32_t i, len, ok = 1;
1833 /*
1834 * Cyclic and re-entrant structures could lead to failure here, and
1835 * uninterned symbols (eg gensyms) will not be coped with very well. But
1836 * SIMPLE data types should all be safe.
1837 */
1838 r = Lexplode(nil, r);
1839 if (exception_pending())
1840 { strcpy(shared, "Failed");
1841 exit(2);
1842 }
1843 r = Llist_to_string(nil, r);
1844 if (exception_pending())
1845 { strcpy(shared, "Failed");
1846 exit(3);
1847 }
1848 len = length_of_header(vechdr(r)) - CELL;
1849 /*
1850 * If the displayed form ou the output was too long I just truncate it
1851 * at present. A more agressive attitude would be to count that as a form
1852 * of failure. As an intermediate step I use the first character in my
1853 * buffer as an "overflow flag" and leave a blank in it if all is well.
1854 */
1855 if (len > PARSIZE-2)
1856 { len=PARSIZE-2;
1857 ok = 0;
1858 }
1859 shared[0] = ok ? ' ' : '#';
1860 for (i=0; i<len; i++) shared[i+1] = celt(r, i);
1861 shared[len+1] = 0;
1862 }
1863
Lparallel(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1864 Lisp_Object Lparallel(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
1865 {
1866 pid_t pid1, pid2, pidx, pidy;
1867 /*
1868 * Create an identifier for a private shared segment of memory of size
1869 * 2*PARSIZE. This will be used for passing a result from the sub-task
1870 * to the main one. Give up if such a segment can not be allocated.
1871 */
1872 int status, segid = shmget(IPC_PRIVATE, (size_t)(2*PARSIZE),
1873 IPC_CREAT | S_IRUSR | S_IWUSR);
1874 char *shared, *w;
1875 int overflow;
1876 Lisp_Object r;
1877 if (segid == -1) return aerror("Unable to allocate a shared segment");
1878 /*
1879 * Attach to the shared segment to obtain a memory address via which it can be
1880 * accessed. Again raise an error if this fails.
1881 */
1882 shared = (char *)shmat(segid, NULL, 0);
1883 if (shared == (char *)(-1))
1884 return aerror("Unable to attach to shared segment");
1885 /*
1886 * the shared segment is set up to contain null strings in the two places
1887 * where it might be used to hold return values.
1888 */
1889 shared[0] = shared[PARSIZE] = 0;
1890 /*
1891 * Split off a clone of the current process that can be used to do the
1892 * first evaluation. If this succeeds call a(b, nil) in it. Note that
1893 * processes created via "fork" inherit shared memory segments from their
1894 * parent.
1895 */
1896 pid1 = fork();
1897 if (pid1 < 0) /* Task not created, must tidy up. */
1898 { shmdt(shared);
1899 shmctl(segid, IPC_RMID, 0);
1900 return aerror("Fork 1 failed");
1901 }
1902 else if (pid1 == 0)
1903 { /* TASK 1 created OK */
1904 Lisp_Object r1 = Lapply2(nil, 3, a, b, nil);
1905 nil = C_nil;
1906 /*
1907 * If the evaluation failed I will exit indicating a failure.
1908 */
1909 if (exception_pending())
1910 { strcpy(shared, "Failed");
1911 exit(1);
1912 }
1913 /*
1914 * Write result from first task into the first half of the shared memory block.
1915 */
1916 write_result(nil, r1, shared);
1917 /*
1918 * Exiting from the sub-task would in fact detach from the shared data
1919 * segment, but I do it explictly to feel tidy.
1920 */
1921 shmdt(shared);
1922 exit(0);
1923 }
1924 else
1925 {
1926 /*
1927 * This is the continuation of the main process. Create a second task in
1928 * much the same way.
1929 */
1930 pid2 = fork();
1931 if (pid2 < 0) /* If task 2 can not be created then kill task 1 */
1932 { kill(pid1, SIGKILL);
1933 waitpid(pid1, &status, 0);
1934 shmdt(shared);
1935 shmctl(segid, IPC_RMID, 0);
1936 return aerror("Fork 2 failed");
1937 }
1938 else if (pid2 == 0)
1939 { /* TASK 2 */
1940 Lisp_Object r2 = Lapply2(nil, 3, a, b, lisp_true);
1941 nil = C_nil;
1942 if (exception_pending())
1943 { strcpy(shared, "Failed");
1944 exit(1);
1945 }
1946 write_result(nil, r2, shared+PARSIZE);
1947 shmdt(shared);
1948 exit(0);
1949 }
1950 else
1951 {
1952 /*
1953 * Wait for whichever of the two sub-tasks finishes first. Then kill the
1954 * other one, and return the result left by the winner.
1955 */
1956 pidx = wait(&status);
1957 term_printf("First signal was from task %d\n", pidx);
1958 if (!WIFEXITED(status) ||
1959 WEXITSTATUS(status) != 0)
1960 {
1961 /*
1962 * If the first task to complete in fact failed rather than exited cleanly
1963 * I will count it as an overall failure and cancel everything. This
1964 * covers aborting (in which case WIFEXITED will return false) or
1965 * exiting cleanly but with a non-zero return code.
1966 */
1967 kill(pid1, SIGKILL);
1968 kill(pid2, SIGKILL);
1969 waitpid(pid1, &status, 0);
1970 waitpid(pid2, &status, 0);
1971 shmdt(shared);
1972 shmctl(segid, IPC_RMID, 0);
1973 return aerror("Task did not exit cleanly");
1974 }
1975 if (pidx == pid1)
1976 { w = shared;
1977 pidy = pid2;
1978 overflow = 1;
1979 }
1980 else
1981 { w = shared+PARSIZE;
1982 pidy = pid1;
1983 overflow = 2;
1984 }
1985 kill(pidy, SIGKILL); /* Kill alternate task */
1986 waitpid(pidy, &status, 0);
1987 /*
1988 * If the first character of the buffer is a blank then there was no
1989 * overflow and all is well.
1990 */
1991 if (w[0] == ' ') r = read_from_vector(w + 1);
1992 else
1993 { overflow = -overflow;
1994 r = make_string(w + 1);
1995 }
1996 /*
1997 * Need to tidy up the shared segment at the end.
1998 */
1999 shmdt(shared);
2000 shmctl(segid, IPC_RMID, 0);
2001 errexit();
2002 r = cons(fixnum_of_int(overflow), r);
2003 errexit();
2004 return onevalue(r);
2005 }
2006 }
2007 }
2008
2009 #else
2010
Lparallel(Lisp_Object nil,Lisp_Object a,Lisp_Object b)2011 Lisp_Object Lparallel(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
2012 {
2013 return aerror("parallel not supported on this platform");
2014 }
2015
2016 #endif
2017
2018 setup_type const eval1_setup[] =
2019 {
2020 {"bytecounts", wrong_no_na, wrong_no_nb, bytecounts},
2021 /*
2022 * PSL has a function idapply that is, as best I understand, just the
2023 * same as apply apart from the fact that it expects an identifier as
2024 * its first argument. But it them says it tests for that and moans if
2025 * given a list, so I find it hard to understand how or why it is liable
2026 * to be faster than plain apply! However to ease portability I provide
2027 * that name here... I think I should mention funcall as a possible
2028 * optimisation in this area...
2029 */
2030 {"idapply", Lapply_1, Lapply_2, Lapply_n},
2031 {"apply", Lapply_1, Lapply_2, Lapply_n},
2032 {"apply0", Lapply0, too_many_1, wrong_no_1},
2033 {"apply1", too_few_2, Lapply1, wrong_no_2},
2034 {"apply2", wrong_no_na, wrong_no_nb, Lapply2},
2035 {"apply3", wrong_no_na, wrong_no_nb, Lapply3},
2036 {"evlis", Levlis, too_many_1, wrong_no_1},
2037 {"funcall", Lfuncall1, Lfuncall2, Lfuncalln},
2038 {"funcall*", Lfuncall1, Lfuncall2, Lfuncalln},
2039 {"parallel", too_few_2, Lparallel, wrong_no_2},
2040 #ifdef COMMON
2041 {"values", Lvalues_1, Lvalues_2, Lvalues},
2042 {"macroexpand", Lmacroexpand, Lmacroexpand_2, wrong_no_1},
2043 {"macroexpand-1", Lmacroexpand_1, Lmacroexpand_1_2, wrong_no_1},
2044 #else
2045 {"macroexpand", Lmacroexpand, too_many_1, wrong_no_1},
2046 {"macroexpand-1", Lmacroexpand_1, too_many_1, wrong_no_1},
2047 #endif
2048 {NULL, 0, 0, 0}
2049 };
2050
2051 /* end of eval1.c */
2052