1 /* eval4.c Copyright (C) 1991-2008, Codemist Ltd */
2
3 /*
4 * Bytecode interpreter/main interpreter interfaces
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: 4eebc042 04-Jan-2009 */
39
40 #include "headers.h"
41
42
43
44 #ifdef DEBUG
45 int trace_all = 0;
46 #endif
47
48 #define name_from(def) elt(qcdr(def), 0)
49
bytecoded0(Lisp_Object def,int nargs,...)50 Lisp_Object MS_CDECL bytecoded0(Lisp_Object def, int nargs, ...)
51 {
52 Lisp_Object nil=C_nil;
53 if (nargs != 0) return error(2, err_wrong_no_args, name_from(def),
54 fixnum_of_int((int32_t)nargs));
55 push2(litvec, codevec);
56 stackcheck1(2, def);
57 /*
58 * The "-2" a few lines down is discussed in the file bytes1.c. It is
59 * part of the mechanism for allowing functions to have a few data bytes
60 * at the start of the code-vector.
61 */
62 #ifdef DEBUG
63 if (trace_all)
64 { trace_all = 0;
65 push(def);
66 freshline_trace();
67 trace_printf("Entering ");
68 loop_print_trace(name_from(def));
69 trace_printf(" (no args)");
70 if (callstack != nil)
71 { trace_printf(" from ");
72 /*/*
73 * The following line is not garbage-collector safe, and similarly for the
74 * other places I print trace output involving callstack. But since it is
75 * just for use when debugging I will be sloppy about that just for now!
76 */
77 loop_print_trace(qcar(callstack));
78 }
79 trace_printf("\n");
80 trace_all = 1;
81 nil = C_nil;
82 if (exception_pending()) { popv(3); return nil; }
83 pop(def);
84 }
85 #endif
86 def = bytestream_interpret(qcar(def)-2, qcdr(def), stack);
87 nil = C_nil;
88 if (exception_pending())
89 { flip_exception();
90 pop2(codevec, litvec);
91 flip_exception();
92 return nil;
93 }
94 pop2(codevec, litvec);
95 return def;
96 }
97
bytecoded1(Lisp_Object def,Lisp_Object a)98 Lisp_Object bytecoded1(Lisp_Object def, Lisp_Object a)
99 {
100 Lisp_Object r;
101 Lisp_Object nil = C_nil;
102 push3(litvec, codevec, a);
103 stackcheck1(3, def);
104 #ifdef DEBUG
105 if (trace_all)
106 { trace_all = 0;
107 push(def);
108 freshline_trace();
109 trace_printf("Entering ");
110 loop_print_trace(name_from(def));
111 if (callstack != nil)
112 { trace_printf(" from ");
113 loop_print_trace(qcar(callstack));
114 }
115 trace_printf("\nArg1: ");
116 loop_print_trace(stack[-1]);
117 trace_printf("\n");
118 trace_all = 1;
119 nil = C_nil;
120 if (exception_pending()) { popv(4); return nil; }
121 pop(def);
122 }
123 #endif
124 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1);
125 nil = C_nil;
126 if (exception_pending())
127 { flip_exception();
128 /*
129 * If bytestream_interpret handed back a failure code then the VERY LAST
130 * thing that it did was to move stack down, in effect losing the argument
131 * that had been passed to the bytesteam code. But nothing can touch the
132 * stack between that action and here, so if I quickly increment the
133 * stack pointer again I can find the argument again - or at least whetever
134 * value the failed function left in that variable. Yes this does look
135 * a little delicate, but I do like seeing argument values in my backtraces,
136 * and the software stack involved here it totally under my control.
137 * NOTE however that if the function I am calling here does a tail call
138 * to something that is not directly bytecoded then the stack can be
139 * clobbered, and the results will be garbage in the backtrace.
140 */
141 stack++;
142 pop3(a, codevec, litvec);
143 if ((exit_reason & UNWIND_ERROR) != 0)
144 { err_printf("Arg1: ");
145 loop_print_error(a); err_printf("\n");
146 ignore_exception();
147 }
148 flip_exception();
149 return nil;
150 }
151 pop2(codevec, litvec);
152 return r;
153 }
154
bytecoded2(Lisp_Object def,Lisp_Object a,Lisp_Object b)155 Lisp_Object bytecoded2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
156 {
157 Lisp_Object r;
158 Lisp_Object nil = C_nil;
159 push4(litvec, codevec, a, b);
160 stackcheck1(4, def);
161 #ifdef DEBUG
162 if (trace_all)
163 { trace_all = 0;
164 push(def);
165 freshline_trace();
166 trace_printf("Entering ");
167 loop_print_trace(name_from(def));
168 if (callstack != nil)
169 { trace_printf(" from ");
170 loop_print_trace(qcar(callstack));
171 }
172 trace_printf("\nArg1: ");
173 loop_print_trace(stack[-2]);
174 trace_printf("\n");
175 trace_printf("Arg2: ");
176 loop_print_trace(stack[-1]);
177 trace_printf("\n");
178 trace_all = 1;
179 nil = C_nil;
180 if (exception_pending()) { popv(5); return nil; }
181 pop(def);
182 }
183 #endif
184 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2);
185 nil = C_nil;
186 if (exception_pending())
187 { flip_exception();
188 stack += 2;
189 if ((exit_reason & UNWIND_ERROR) != 0)
190 { err_printf("Arg 1: ");
191 loop_print_error(stack[-1]); err_printf("\n");
192 ignore_exception();
193 err_printf("Arg 2: ");
194 loop_print_error(stack[0]); err_printf("\n");
195 ignore_exception();
196 }
197 popv(2); pop2(codevec, litvec);
198 flip_exception();
199 return nil;
200 }
201 pop2(codevec, litvec);
202 return r;
203 }
204
bytecoded3(Lisp_Object def,int nargs,...)205 Lisp_Object MS_CDECL bytecoded3(Lisp_Object def, int nargs, ...)
206 {
207 va_list aa;
208 Lisp_Object r, a, b, c;
209 Lisp_Object nil = C_nil;
210 if (nargs != 3) return error(2, err_wrong_no_args, name_from(def),
211 fixnum_of_int((int32_t)nargs));
212 va_start(aa, nargs);
213 a = va_arg(aa, Lisp_Object);
214 b = va_arg(aa, Lisp_Object);
215 c = va_arg(aa, Lisp_Object);
216 va_end(aa);
217 push5(litvec, codevec, a, b, c);
218 stackcheck1(5, def);
219 #ifdef DEBUG
220 if (trace_all)
221 { trace_all = 0;
222 push(def);
223 freshline_trace();
224 trace_printf("Entering ");
225 loop_print_trace(name_from(def));
226 if (callstack != nil)
227 { trace_printf(" from ");
228 loop_print_trace(qcar(callstack));
229 }
230 trace_printf("\nArg1: ");
231 loop_print_trace(stack[-3]);
232 trace_printf("\n");
233 trace_printf("Arg2: ");
234 loop_print_trace(stack[-2]);
235 trace_printf("\n");
236 trace_printf("Arg3: ");
237 loop_print_trace(stack[-1]);
238 trace_printf("\n");
239 trace_all = 1;
240 nil = C_nil;
241 if (exception_pending()) { popv(6); return nil; }
242 pop(def);
243 }
244 #endif
245 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3);
246 nil = C_nil;
247 if (exception_pending())
248 { flip_exception();
249 stack += 3;
250 if ((exit_reason & UNWIND_ERROR) != 0)
251 { err_printf("Arg1: ");
252 loop_print_error(stack[-2]); err_printf("\n");
253 ignore_exception();
254 err_printf("Arg2: ");
255 loop_print_error(stack[-1]); err_printf("\n");
256 ignore_exception();
257 err_printf("Arg3: ");
258 loop_print_error(stack[0]); err_printf("\n");
259 ignore_exception();
260 }
261 popv(3); pop2(codevec, litvec);
262 flip_exception();
263 return nil;
264 }
265 pop2(codevec, litvec);
266 return r;
267 }
268
bytecodedn(Lisp_Object def,int nargs,...)269 Lisp_Object MS_CDECL bytecodedn(Lisp_Object def, int nargs, ...)
270 {
271 /*
272 * The messing about here is to get the (unknown number of) args
273 * into a nice neat vector so that they can be indexed into. If I knew
274 * that the args were in consecutive locations on the stack I could
275 * probably save a copying operation.
276 */
277 Lisp_Object r;
278 Lisp_Object nil = C_nil;
279 int i;
280 Lisp_Object *stack_save = stack;
281 va_list a;
282 push2(litvec, codevec);
283 if (nargs != 0)
284 { va_start(a, nargs);
285 push_args(a, nargs);
286 }
287 stackcheck1(stack-stack_save, def);
288 r = qcar(def);
289 if (nargs != ((unsigned char *)data_of_bps(r))[0])
290 { popv(nargs+2);
291 return error(2, err_wrong_no_args, name_from(def),
292 fixnum_of_int((int32_t)nargs));
293 }
294 r = bytestream_interpret(r-1, qcdr(def), stack-nargs);
295 nil = C_nil;
296 if (exception_pending())
297 { flip_exception();
298 stack += nargs;
299 if ((exit_reason & UNWIND_ERROR) != 0)
300 /*
301 * Note that in this display if a function had over 50 args then the
302 * final bunch of them will be bundled up in to a list (as if for &rest).
303 */
304 for (i=1; i<=nargs; i++)
305 { err_printf("Arg%d: ", i);
306 loop_print_error(stack[i-nargs]); err_printf("\n");
307 ignore_exception();
308 }
309 popv(nargs); pop2(codevec, litvec);
310 flip_exception();
311 return nil;
312 }
313 pop2(codevec, litvec);
314 return r;
315 }
316
317 /*
318 * Now I have carbon copies of the above, but with some print statements
319 * inserted. These are installed when a function is marked for trace
320 * output.
321 */
322
unpack_mv(Lisp_Object nil,Lisp_Object r)323 Lisp_Object unpack_mv(Lisp_Object nil, Lisp_Object r)
324 {
325 Lisp_Object *p = &mv_1;
326 exit_count = 0;
327 *p = nil;
328 while (r != nil)
329 { *p++ = qcar(r);
330 r = qcdr(r);
331 exit_count++;
332 }
333 return mv_1;
334 }
335
tracebytecoded0(Lisp_Object def,int nargs,...)336 Lisp_Object MS_CDECL tracebytecoded0(Lisp_Object def, int nargs, ...)
337 {
338 Lisp_Object r, nil=C_nil;
339 if (nargs != 0) return error(2, err_wrong_no_args, name_from(def),
340 fixnum_of_int((int32_t)nargs));
341 push3(litvec, codevec, def);
342 freshline_trace();
343 trace_printf("Entering ");
344 loop_print_trace(name_from(def));
345 trace_printf(" (no args)");
346 if (callstack != nil)
347 { trace_printf(" from ");
348 loop_print_trace(qcar(callstack));
349 }
350 trace_printf("\n");
351 nil = C_nil;
352 if (exception_pending()) { popv(3); return nil; }
353 def = stack[0];
354 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack);
355 nil = C_nil;
356 if (exception_pending())
357 { flip_exception();
358 popv(1); pop2(codevec, litvec);
359 flip_exception();
360 return nil;
361 }
362 #ifdef COMMON
363 r = Lmv_list(nil, r);
364 if (exception_pending())
365 { flip_exception();
366 popv(1); pop2(codevec, litvec);
367 flip_exception();
368 return nil;
369 }
370 #endif
371 pop(def);
372 push(r);
373 freshline_trace();
374 loop_print_trace(name_from(def));
375 nil = C_nil;
376 if (!exception_pending())
377 { trace_printf(" = ");
378 loop_print_trace(r);
379 trace_printf("\n");
380 }
381 if (exception_pending())
382 { flip_exception();
383 popv(1); pop2(codevec, litvec);
384 flip_exception();
385 return nil;
386 }
387 pop3(r, codevec, litvec);
388 #ifdef COMMON
389 r = unpack_mv(nil, r);
390 #endif
391 return r;
392 }
393
tracebytecoded1(Lisp_Object def,Lisp_Object a)394 Lisp_Object tracebytecoded1(Lisp_Object def, Lisp_Object a)
395 {
396 Lisp_Object r;
397 Lisp_Object nil = C_nil;
398 push4(litvec, codevec, def, a);
399 freshline_trace();
400 trace_printf("Entering ");
401 loop_print_trace(name_from(def));
402 nil = C_nil;
403 if (exception_pending())
404 { flip_exception();
405 popv(2); pop2(codevec, litvec);
406 flip_exception();
407 return nil;
408 }
409 trace_printf(" (1 arg)");
410 if (callstack != nil)
411 { trace_printf(" from ");
412 loop_print_trace(qcar(callstack));
413 }
414 trace_printf("\nArg1: ");
415 loop_print_trace(stack[0]);
416 trace_printf("\n");
417 nil = C_nil;
418 if (exception_pending())
419 { flip_exception();
420 popv(2); pop2(codevec, litvec);
421 flip_exception();
422 return nil;
423 }
424 stackcheck0(4);
425 def = stack[-1];
426 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1);
427 nil = C_nil;
428 if (exception_pending())
429 { flip_exception();
430 stack++;
431 pop(a); popv(1); pop2(codevec, litvec);
432 if ((exit_reason & UNWIND_ERROR) != 0)
433 { err_printf("Arg1: ");
434 loop_print_error(a); err_printf("\n");
435 ignore_exception();
436 }
437 flip_exception();
438 return nil;
439 }
440 #ifdef COMMON
441 r = Lmv_list(nil, r);
442 if (exception_pending())
443 { flip_exception();
444 popv(1); pop2(codevec, litvec);
445 flip_exception();
446 return nil;
447 }
448 #endif
449 pop(def);
450 push(r);
451 freshline_trace();
452 loop_print_trace(name_from(def));
453 trace_printf(" = ");
454 loop_print_trace(r);
455 trace_printf("\n");
456 pop3(r, codevec, litvec);
457 #ifdef COMMON
458 r = unpack_mv(nil, r);
459 #endif
460 return r;
461 }
462
tracebytecoded2(Lisp_Object def,Lisp_Object a,Lisp_Object b)463 Lisp_Object tracebytecoded2(Lisp_Object def,
464 Lisp_Object a, Lisp_Object b)
465 {
466 Lisp_Object r;
467 Lisp_Object nil = C_nil;
468 push5(litvec, codevec, def, a, b);
469 freshline_trace();
470 trace_printf("Entering ");
471 loop_print_trace(name_from(def));
472 nil = C_nil;
473 if (exception_pending())
474 { flip_exception();
475 popv(3); pop2(codevec, litvec);
476 flip_exception();
477 return nil;
478 }
479 trace_printf(" (2 args)");
480 if (callstack != nil)
481 { trace_printf(" from ");
482 loop_print_trace(qcar(callstack));
483 }
484 trace_printf("\nArg1: ");
485 loop_print_trace(stack[-1]);
486 nil = C_nil;
487 if (exception_pending())
488 { flip_exception();
489 popv(3); pop2(codevec, litvec);
490 flip_exception();
491 return nil;
492 }
493 trace_printf("\nArg2: ");
494 loop_print_trace(stack[0]);
495 trace_printf("\n");
496 nil = C_nil;
497 if (exception_pending())
498 { flip_exception();
499 popv(3); pop2(codevec, litvec);
500 flip_exception();
501 return nil;
502 }
503 stackcheck0(5);
504 def = stack[-2];
505 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2);
506 nil = C_nil;
507 if (exception_pending())
508 { flip_exception();
509 stack += 2;
510 if ((exit_reason & UNWIND_ERROR) != 0)
511 { err_printf("Arg1: ");
512 loop_print_error(stack[-1]); err_printf("\n");
513 ignore_exception();
514 err_printf("Arg2: ");
515 loop_print_error(stack[0]); err_printf("\n");
516 ignore_exception();
517 }
518 popv(3); pop2(codevec, litvec);
519 flip_exception();
520 return nil;
521 }
522 #ifdef COMMON
523 r = Lmv_list(nil, r);
524 if (exception_pending())
525 { flip_exception();
526 popv(1); pop2(codevec, litvec);
527 flip_exception();
528 return nil;
529 }
530 #endif
531 pop(def);
532 push(r);
533 freshline_trace();
534 loop_print_trace(name_from(def));
535 trace_printf(" = ");
536 loop_print_trace(r);
537 trace_printf("\n");
538 pop3(r, codevec, litvec);
539 #ifdef COMMON
540 r = unpack_mv(nil, r);
541 #endif
542 return r;
543 }
544
tracebytecoded3(Lisp_Object def,int nargs,...)545 Lisp_Object MS_CDECL tracebytecoded3(Lisp_Object def, int nargs, ...)
546 {
547 va_list aa;
548 Lisp_Object r, a, b, c;
549 Lisp_Object nil = C_nil;
550 if (nargs != 3) return error(2, err_wrong_no_args, name_from(def),
551 fixnum_of_int((int32_t)nargs));
552 va_start(aa, nargs);
553 a = va_arg(aa, Lisp_Object);
554 b = va_arg(aa, Lisp_Object);
555 c = va_arg(aa, Lisp_Object);
556 va_end(aa);
557 push2(litvec, codevec);
558 push4(def, a, b, c);
559 freshline_trace();
560 trace_printf("Entering ");
561 loop_print_trace(name_from(def));
562 nil = C_nil;
563 if (exception_pending())
564 { flip_exception();
565 popv(4); pop2(codevec, litvec);
566 flip_exception();
567 return nil;
568 }
569 trace_printf(" (3 args)");
570 if (callstack != nil)
571 { trace_printf(" from ");
572 loop_print_trace(qcar(callstack));
573 }
574 trace_printf("\nArg1: ");
575 loop_print_trace(stack[-2]);
576 nil = C_nil;
577 if (exception_pending())
578 { flip_exception();
579 popv(4); pop2(codevec, litvec);
580 flip_exception();
581 return nil;
582 }
583 trace_printf("\nArg2: ");
584 loop_print_trace(stack[-1]);
585 nil = C_nil;
586 if (exception_pending())
587 { flip_exception();
588 popv(4); pop2(codevec, litvec);
589 flip_exception();
590 return nil;
591 }
592 trace_printf("\nArg3: ");
593 loop_print_trace(stack[0]);
594 trace_printf("\n");
595 nil = C_nil;
596 if (exception_pending())
597 { flip_exception();
598 popv(4); pop2(codevec, litvec);
599 flip_exception();
600 return nil;
601 }
602 stackcheck0(6);
603 def = stack[-3];
604 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3);
605 nil = C_nil;
606 if (exception_pending())
607 { flip_exception();
608 stack += 3;
609 if ((exit_reason & UNWIND_ERROR) != 0)
610 { err_printf("Arg1: ");
611 loop_print_error(stack[-2]); err_printf("\n");
612 ignore_exception();
613 err_printf("Arg2: ");
614 loop_print_error(stack[-1]); err_printf("\n");
615 ignore_exception();
616 err_printf("Arg3: ");
617 loop_print_error(stack[0]); err_printf("\n");
618 ignore_exception();
619 }
620 popv(4); pop2(codevec, litvec);
621 flip_exception();
622 return nil;
623 }
624 #ifdef COMMON
625 r = Lmv_list(nil, r);
626 if (exception_pending())
627 { flip_exception();
628 popv(1); pop2(codevec, litvec);
629 flip_exception();
630 return nil;
631 }
632 #endif
633 pop(def);
634 push(r);
635 freshline_trace();
636 loop_print_trace(name_from(def));
637 trace_printf(" = ");
638 loop_print_trace(r);
639 trace_printf("\n");
640 pop3(r, codevec, litvec);
641 #ifdef COMMON
642 r = unpack_mv(nil, r);
643 #endif
644 return r;
645 }
646
tracebytecodedn(Lisp_Object def,int nargs,...)647 Lisp_Object MS_CDECL tracebytecodedn(Lisp_Object def, int nargs, ...)
648 {
649 /*
650 * The messing about here is to get the (unknown number of) args
651 * into a nice neat vector so that they can be indexed into. If I knew
652 * that the args were in consecutive locations on the stack I could
653 * probably save a copying operation.
654 */
655 Lisp_Object r;
656 Lisp_Object nil = C_nil;
657 int i;
658 Lisp_Object *stack_save = stack;
659 va_list a;
660 push3(litvec, codevec, def);
661 if (nargs != 0)
662 { va_start(a, nargs);
663 push_args(a, nargs);
664 }
665 stackcheck1(stack-stack_save, def);
666 freshline_trace();
667 loop_print_trace(name_from(def));
668 trace_printf(" (%d args)", nargs);
669 if (callstack != nil)
670 { trace_printf(" from ");
671 loop_print_trace(qcar(callstack));
672 }
673 trace_printf("\n");
674 for (i=1; i<=nargs; i++)
675 { trace_printf("Arg%d: ", i);
676 loop_print_trace(stack[i-nargs]);
677 trace_printf("\n");
678 }
679 def = stack[-nargs];
680 r = qcar(def);
681 if (nargs != ((unsigned char *)data_of_bps(r))[0])
682 { popv(nargs+3);
683 return error(2, err_wrong_no_args, name_from(def),
684 fixnum_of_int((int32_t)nargs));
685 }
686 r = bytestream_interpret(r-1, qcdr(def), stack-nargs);
687 nil = C_nil;
688 if (exception_pending())
689 { flip_exception();
690 stack += nargs;
691 if ((exit_reason & UNWIND_ERROR) != 0)
692 for (i=1; i<=nargs; i++)
693 { err_printf("Arg%d: ", i);
694 loop_print_error(stack[i-nargs]); err_printf("\n");
695 ignore_exception();
696 }
697 popv(nargs+1); pop2(codevec, litvec);
698 flip_exception();
699 return nil;
700 }
701 #ifdef COMMON
702 r = Lmv_list(nil, r);
703 if (exception_pending())
704 { flip_exception();
705 popv(1); pop2(codevec, litvec);
706 flip_exception();
707 return nil;
708 }
709 #endif
710 pop(def);
711 push(r);
712 freshline_trace();
713 loop_print_trace(name_from(def));
714 trace_printf(" = ");
715 loop_print_trace(r);
716 trace_printf("\n");
717 pop3(r, codevec, litvec);
718 #ifdef COMMON
719 r = unpack_mv(nil, r);
720 #endif
721 return r;
722 }
723
724 int doubled_execution = 0;
725
double_bytecoded0(Lisp_Object def,int nargs,...)726 Lisp_Object MS_CDECL double_bytecoded0(Lisp_Object def, int nargs, ...)
727 {
728 Lisp_Object nil=C_nil;
729 if (nargs != 0) return error(2, err_wrong_no_args, name_from(def),
730 fixnum_of_int((int32_t)nargs));
731 push2(litvec, codevec);
732 stackcheck1(2, def);
733 if (!doubled_execution)
734 { push3(def, litvec, codevec);
735 doubled_execution = 1;
736 bytestream_interpret(qcar(def)-2, qcdr(def), stack);
737 nil = C_nil;
738 pop3(codevec, litvec, def);
739 if (!exception_pending())
740 def = bytestream_interpret(qcar(def)-2, qcdr(def), stack);
741 doubled_execution = 0;
742 }
743 else def = bytestream_interpret(qcar(def)-2, qcdr(def), stack);
744 nil = C_nil;
745 if (exception_pending())
746 { flip_exception();
747 pop2(codevec, litvec);
748 flip_exception();
749 return nil;
750 }
751 pop2(codevec, litvec);
752 return def;
753 }
754
double_bytecoded1(Lisp_Object def,Lisp_Object a)755 Lisp_Object double_bytecoded1(Lisp_Object def, Lisp_Object a)
756 {
757 Lisp_Object r;
758 Lisp_Object nil = C_nil;
759 push3(litvec, codevec, a);
760 stackcheck1(3, def);
761 if (!doubled_execution)
762 { push4(def, litvec, codevec, a);
763 doubled_execution = 1;
764 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1);
765 nil = C_nil;
766 pop3(codevec, litvec, def);
767 if (!exception_pending())
768 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1);
769 doubled_execution = 0;
770 }
771 else r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1);
772 nil = C_nil;
773 if (exception_pending())
774 { flip_exception();
775 stack++;
776 pop3(a, codevec, litvec);
777 if ((exit_reason & UNWIND_ERROR) != 0)
778 { err_printf("Arg1: ");
779 loop_print_error(a); err_printf("\n");
780 ignore_exception();
781 }
782 flip_exception();
783 return nil;
784 }
785 pop2(codevec, litvec);
786 return r;
787 }
788
double_bytecoded2(Lisp_Object def,Lisp_Object a,Lisp_Object b)789 Lisp_Object double_bytecoded2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
790 {
791 Lisp_Object r;
792 Lisp_Object nil = C_nil;
793 push4(litvec, codevec, a, b);
794 stackcheck1(4, def);
795 if (!doubled_execution)
796 { push5(def, litvec, codevec, a, b);
797 doubled_execution = 1;
798 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2);
799 nil = C_nil;
800 pop3(codevec, litvec, def);
801 if (!exception_pending())
802 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2);
803 doubled_execution = 0;
804 }
805 else r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2);
806 nil = C_nil;
807 if (exception_pending())
808 { flip_exception();
809 stack += 2;
810 if ((exit_reason & UNWIND_ERROR) != 0)
811 { err_printf("Arg 1: ");
812 loop_print_error(stack[-1]); err_printf("\n");
813 ignore_exception();
814 err_printf("Arg 2: ");
815 loop_print_error(stack[0]); err_printf("\n");
816 ignore_exception();
817 }
818 popv(2); pop2(codevec, litvec);
819 flip_exception();
820 return nil;
821 }
822 pop2(codevec, litvec);
823 return r;
824 }
825
double_bytecoded3(Lisp_Object def,int nargs,...)826 Lisp_Object MS_CDECL double_bytecoded3(Lisp_Object def, int nargs, ...)
827 {
828 va_list aa;
829 Lisp_Object r, a, b, c;
830 Lisp_Object nil = C_nil;
831 if (nargs != 3) return error(2, err_wrong_no_args, name_from(def),
832 fixnum_of_int((int32_t)nargs));
833 va_start(aa, nargs);
834 a = va_arg(aa, Lisp_Object);
835 b = va_arg(aa, Lisp_Object);
836 c = va_arg(aa, Lisp_Object);
837 va_end(aa);
838 push5(litvec, codevec, a, b, c);
839 stackcheck1(5, def);
840 if (!doubled_execution)
841 { push6(def, litvec, codevec, a, b, c);
842 doubled_execution = 1;
843 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3);
844 nil = C_nil;
845 pop3(codevec, litvec, def);
846 if (!exception_pending())
847 r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3);
848 doubled_execution = 0;
849 }
850 else r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3);
851 nil = C_nil;
852 if (exception_pending())
853 { flip_exception();
854 stack += 3;
855 if ((exit_reason & UNWIND_ERROR) != 0)
856 { err_printf("Arg1: ");
857 loop_print_error(stack[-2]); err_printf("\n");
858 ignore_exception();
859 err_printf("Arg2: ");
860 loop_print_error(stack[-1]); err_printf("\n");
861 ignore_exception();
862 err_printf("Arg3: ");
863 loop_print_error(stack[0]); err_printf("\n");
864 ignore_exception();
865 }
866 popv(3); pop2(codevec, litvec);
867 flip_exception();
868 return nil;
869 }
870 pop2(codevec, litvec);
871 return r;
872 }
873
double_bytecodedn(Lisp_Object def,int nargs,...)874 Lisp_Object MS_CDECL double_bytecodedn(Lisp_Object def, int nargs, ...)
875 {
876 Lisp_Object r;
877 Lisp_Object nil = C_nil;
878 int i;
879 Lisp_Object *stack_save = stack;
880 va_list a;
881 push2(litvec, codevec);
882 if (nargs != 0)
883 { va_start(a, nargs);
884 push_args(a, nargs);
885 }
886 stackcheck1(stack-stack_save, def);
887 r = qcar(def);
888 if (nargs != ((unsigned char *)data_of_bps(r))[0])
889 { popv(nargs+2);
890 return error(2, err_wrong_no_args, name_from(def),
891 fixnum_of_int((int32_t)nargs));
892 }
893 trace_printf("Function with > 3 args not doubled\n");
894 r = bytestream_interpret(r-1, qcdr(def), stack-nargs);
895 nil = C_nil;
896 if (exception_pending())
897 { flip_exception();
898 stack += nargs;
899 if ((exit_reason & UNWIND_ERROR) != 0)
900 for (i=1; i<=nargs; i++)
901 { err_printf("Arg%d: ", i);
902 loop_print_error(stack[i-nargs]); err_printf("\n");
903 ignore_exception();
904 }
905 popv(nargs); pop2(codevec, litvec);
906 flip_exception();
907 return nil;
908 }
909 pop2(codevec, litvec);
910 return r;
911 }
912
913
914 /*
915 * The code that follows is just used to support compiled code that
916 * has &optional or &rest arguments.
917 */
918
byteopt1(Lisp_Object def,Lisp_Object a)919 Lisp_Object byteopt1(Lisp_Object def, Lisp_Object a)
920 {
921 return byteoptn(def, 1, a);
922 }
923
byteopt2(Lisp_Object def,Lisp_Object a,Lisp_Object b)924 Lisp_Object byteopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
925 {
926 return byteoptn(def, 2, a, b);
927 }
928
vbyteoptn(Lisp_Object def,int nargs,va_list a,Lisp_Object dflt)929 static Lisp_Object vbyteoptn(Lisp_Object def, int nargs,
930 va_list a, Lisp_Object dflt)
931 {
932 Lisp_Object r;
933 Lisp_Object nil = C_nil;
934 int i, wantargs, wantopts;
935 Lisp_Object *stack_save = stack;
936 push2(litvec, codevec);
937 /*
938 * Maybe I should raise an exception (continuable error) if too many args
939 * are provided - for now I just silently ignore the excess.
940 */
941 if (nargs != 0) push_args(a, nargs);
942 else va_end(a);
943 stackcheck1(stack-stack_save, def);
944 r = qcar(def);
945 wantargs = ((unsigned char *)data_of_bps(r))[0];
946 wantopts = ((unsigned char *)data_of_bps(r))[1];
947 if (nargs < wantargs || nargs > wantargs+wantopts)
948 { popv(nargs); pop2(codevec, litvec)
949 return error(2, err_wrong_no_args, name_from(def),
950 fixnum_of_int((int32_t)nargs));
951 }
952 while (nargs < wantargs+wantopts)
953 { push(dflt); /* Provide value for all optional args */
954 nargs++;
955 }
956 stackcheck1(stack-stack_save, def);
957 r = qcar(def);
958 r = bytestream_interpret(r, qcdr(def), stack-nargs);
959 nil = C_nil;
960 if (exception_pending())
961 { flip_exception();
962 stack += nargs;
963 if ((exit_reason & UNWIND_ERROR) != 0)
964 for (i=1; i<=nargs; i++)
965 { err_printf("Arg%d: ", i);
966 loop_print_error(stack[i-nargs]); err_printf("\n");
967 ignore_exception();
968 }
969 popv(nargs); pop2(codevec, litvec);
970 flip_exception();
971 return nil;
972 }
973 pop2(codevec, litvec);
974 return r;
975 }
976
byteoptn(Lisp_Object def,int nargs,...)977 Lisp_Object MS_CDECL byteoptn(Lisp_Object def, int nargs, ...)
978 {
979 va_list a;
980 va_start(a, nargs);
981 return vbyteoptn(def, nargs, a, C_nil);
982 }
983
hardopt1(Lisp_Object def,Lisp_Object a)984 Lisp_Object hardopt1(Lisp_Object def, Lisp_Object a)
985 {
986 return hardoptn(def, 1, a);
987 }
988
hardopt2(Lisp_Object def,Lisp_Object a,Lisp_Object b)989 Lisp_Object hardopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
990 {
991 return hardoptn(def, 2, a, b);
992 }
993
hardoptn(Lisp_Object def,int nargs,...)994 Lisp_Object MS_CDECL hardoptn(Lisp_Object def, int nargs, ...)
995 {
996 va_list a;
997 va_start(a, nargs);
998 return vbyteoptn(def, nargs, a, SPID_NOARG);
999 }
1000
byteoptrest1(Lisp_Object def,Lisp_Object a)1001 Lisp_Object byteoptrest1(Lisp_Object def, Lisp_Object a)
1002 {
1003 return byteoptrestn(def, 1, a);
1004 }
1005
byteoptrest2(Lisp_Object def,Lisp_Object a,Lisp_Object b)1006 Lisp_Object byteoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
1007 {
1008 return byteoptrestn(def, 2, a, b);
1009 }
1010
vbyterestn(Lisp_Object def,int nargs,va_list a,Lisp_Object dflt)1011 static Lisp_Object vbyterestn(Lisp_Object def, int nargs,
1012 va_list a, Lisp_Object dflt)
1013 {
1014 Lisp_Object r;
1015 Lisp_Object nil = C_nil;
1016 int i, wantargs, wantopts;
1017 Lisp_Object *stack_save = stack;
1018 push2(litvec, codevec);
1019 if (nargs != 0) push_args(a, nargs);
1020 else va_end(a);
1021 stackcheck1(stack-stack_save, def);
1022 r = qcar(def);
1023 wantargs = ((unsigned char *)data_of_bps(r))[0];
1024 wantopts = ((unsigned char *)data_of_bps(r))[1];
1025 if (nargs < wantargs)
1026 { popv(nargs+2);
1027 return error(2, err_wrong_no_args, name_from(def),
1028 fixnum_of_int((int32_t)nargs));
1029 }
1030 while (nargs < wantargs+wantopts)
1031 { push(dflt); /* Provide value for all optional args */
1032 nargs++;
1033 }
1034 { Lisp_Object rest = nil;
1035 while (nargs > wantargs+wantopts)
1036 { Lisp_Object w = stack[0];
1037 stack[0] = def;
1038 rest = cons(w, rest);
1039 errexitn(nargs+2);
1040 pop(def);
1041 nargs--;
1042 }
1043 push(rest);
1044 nargs++;
1045 }
1046 stackcheck1(stack-stack_save, def);
1047 r = qcar(def);
1048 r = bytestream_interpret(r, qcdr(def), stack-nargs);
1049 nil = C_nil;
1050 if (exception_pending())
1051 { flip_exception();
1052 stack += nargs;
1053 if ((exit_reason & UNWIND_ERROR) != 0)
1054 for (i=1; i<=nargs; i++)
1055 { err_printf("Arg%d: ", i);
1056 loop_print_error(stack[i-nargs]); err_printf("\n");
1057 ignore_exception();
1058 }
1059 popv(nargs); pop2(codevec, litvec);
1060 flip_exception();
1061 return nil;
1062 }
1063 pop2(codevec, litvec);
1064 return r;
1065 }
1066
byteoptrestn(Lisp_Object def,int nargs,...)1067 Lisp_Object MS_CDECL byteoptrestn(Lisp_Object def, int nargs, ...)
1068 {
1069 va_list a;
1070 va_start(a, nargs);
1071 return vbyterestn(def, nargs, a, C_nil);
1072 }
1073
hardoptrest1(Lisp_Object def,Lisp_Object a)1074 Lisp_Object hardoptrest1(Lisp_Object def, Lisp_Object a)
1075 {
1076 return hardoptrestn(def, 1, a);
1077 }
1078
hardoptrest2(Lisp_Object def,Lisp_Object a,Lisp_Object b)1079 Lisp_Object hardoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
1080 {
1081 return hardoptrestn(def, 2, a, b);
1082 }
1083
hardoptrestn(Lisp_Object def,int nargs,...)1084 Lisp_Object MS_CDECL hardoptrestn(Lisp_Object def, int nargs, ...)
1085 {
1086 va_list a;
1087 va_start(a, nargs);
1088 return vbyterestn(def, nargs, a, SPID_NOARG);
1089 }
1090
1091 /*
1092 * Next the execution-doubling versions of the &opt/&rest interfaces
1093 */
1094
double_byteopt1(Lisp_Object def,Lisp_Object a)1095 Lisp_Object double_byteopt1(Lisp_Object def, Lisp_Object a)
1096 {
1097 return double_byteoptn(def, 1, a);
1098 }
1099
double_byteopt2(Lisp_Object def,Lisp_Object a,Lisp_Object b)1100 Lisp_Object double_byteopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
1101 {
1102 return double_byteoptn(def, 2, a, b);
1103 }
1104
double_vbyteoptn(Lisp_Object def,int nargs,va_list a,Lisp_Object dflt)1105 static Lisp_Object double_vbyteoptn(Lisp_Object def, int nargs,
1106 va_list a, Lisp_Object dflt)
1107 {
1108 Lisp_Object r;
1109 Lisp_Object nil = C_nil;
1110 int i, wantargs, wantopts;
1111 Lisp_Object *stack_save = stack;
1112 push2(litvec, codevec);
1113 /*
1114 * Maybe I should raise an exception (continuable error) if too many args
1115 * are provided - for now I just silently ignore th excess.
1116 */
1117 if (nargs != 0) push_args(a, nargs);
1118 else va_end(a);
1119 stackcheck1(stack-stack_save, def);
1120 r = qcar(def);
1121 wantargs = ((unsigned char *)data_of_bps(r))[0];
1122 wantopts = ((unsigned char *)data_of_bps(r))[1];
1123 if (nargs < wantargs || nargs > wantargs+wantopts)
1124 { popv(nargs); pop2(codevec, litvec)
1125 return error(2, err_wrong_no_args, name_from(def),
1126 fixnum_of_int((int32_t)nargs));
1127 }
1128 while (nargs < wantargs+wantopts)
1129 { push(dflt); /* Provide value for all optional args */
1130 nargs++;
1131 }
1132 stackcheck1(stack-stack_save, def);
1133 trace_printf("Function with simple &opt arg not doubled\n");
1134 r = qcar(def);
1135 r = bytestream_interpret(r, qcdr(def), stack-nargs);
1136 nil = C_nil;
1137 if (exception_pending())
1138 { flip_exception();
1139 stack += nargs;
1140 if ((exit_reason & UNWIND_ERROR) != 0)
1141 for (i=1; i<=nargs; i++)
1142 { err_printf("Arg%d: ", i);
1143 loop_print_error(stack[i-nargs]); err_printf("\n");
1144 ignore_exception();
1145 }
1146 popv(nargs); pop2(codevec, litvec);
1147 flip_exception();
1148 return nil;
1149 }
1150 pop2(codevec, litvec);
1151 return r;
1152 }
1153
double_byteoptn(Lisp_Object def,int nargs,...)1154 Lisp_Object MS_CDECL double_byteoptn(Lisp_Object def, int nargs, ...)
1155 {
1156 va_list a;
1157 va_start(a, nargs);
1158 return double_vbyteoptn(def, nargs, a, C_nil);
1159 }
1160
double_hardopt1(Lisp_Object def,Lisp_Object a)1161 Lisp_Object double_hardopt1(Lisp_Object def, Lisp_Object a)
1162 {
1163 return double_hardoptn(def, 1, a);
1164 }
1165
double_hardopt2(Lisp_Object def,Lisp_Object a,Lisp_Object b)1166 Lisp_Object double_hardopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
1167 {
1168 return double_hardoptn(def, 2, a, b);
1169 }
1170
double_hardoptn(Lisp_Object def,int nargs,...)1171 Lisp_Object MS_CDECL double_hardoptn(Lisp_Object def, int nargs, ...)
1172 {
1173 va_list a;
1174 va_start(a, nargs);
1175 return double_vbyteoptn(def, nargs, a, SPID_NOARG);
1176 }
1177
double_byteoptrest1(Lisp_Object def,Lisp_Object a)1178 Lisp_Object double_byteoptrest1(Lisp_Object def, Lisp_Object a)
1179 {
1180 return double_byteoptrestn(def, 1, a);
1181 }
1182
double_byteoptrest2(Lisp_Object def,Lisp_Object a,Lisp_Object b)1183 Lisp_Object double_byteoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
1184 {
1185 return double_byteoptrestn(def, 2, a, b);
1186 }
1187
double_vbyterestn(Lisp_Object def,int nargs,va_list a,Lisp_Object dflt)1188 static Lisp_Object double_vbyterestn(Lisp_Object def, int nargs,
1189 va_list a, Lisp_Object dflt)
1190 {
1191 Lisp_Object r;
1192 Lisp_Object nil = C_nil;
1193 int i, wantargs, wantopts;
1194 Lisp_Object *stack_save = stack;
1195 push2(litvec, codevec);
1196 if (nargs != 0) push_args(a, nargs);
1197 else va_end(a);
1198 stackcheck1(stack-stack_save, def);
1199 r = qcar(def);
1200 wantargs = ((unsigned char *)data_of_bps(r))[0];
1201 wantopts = ((unsigned char *)data_of_bps(r))[1];
1202 if (nargs < wantargs)
1203 { popv(nargs+2);
1204 return error(2, err_wrong_no_args, name_from(def),
1205 fixnum_of_int((int32_t)nargs));
1206 }
1207 while (nargs < wantargs+wantopts)
1208 { push(dflt); /* Provide value for all optional args */
1209 nargs++;
1210 }
1211 { Lisp_Object rest = nil;
1212 while (nargs > wantargs+wantopts)
1213 { Lisp_Object w = stack[0];
1214 stack[0] = def;
1215 rest = cons(w, rest);
1216 errexitn(nargs+2);
1217 pop(def);
1218 nargs--;
1219 }
1220 push(rest);
1221 nargs++;
1222 }
1223 stackcheck1(stack-stack_save, def);
1224 trace_printf("Function with simple &rest arg not doubled\n");
1225 r = qcar(def);
1226 r = bytestream_interpret(r, qcdr(def), stack-nargs);
1227 nil = C_nil;
1228 if (exception_pending())
1229 { flip_exception();
1230 stack += nargs;
1231 if ((exit_reason & UNWIND_ERROR) != 0)
1232 for (i=1; i<=nargs; i++)
1233 { err_printf("Arg%d: ", i);
1234 loop_print_error(stack[i-nargs]); err_printf("\n");
1235 ignore_exception();
1236 }
1237 popv(nargs); pop2(codevec, litvec);
1238 flip_exception();
1239 return nil;
1240 }
1241 pop2(codevec, litvec);
1242 return r;
1243 }
1244
double_byteoptrestn(Lisp_Object def,int nargs,...)1245 Lisp_Object MS_CDECL double_byteoptrestn(Lisp_Object def, int nargs, ...)
1246 {
1247 va_list a;
1248 va_start(a, nargs);
1249 return double_vbyterestn(def, nargs, a, C_nil);
1250 }
1251
double_hardoptrest1(Lisp_Object def,Lisp_Object a)1252 Lisp_Object double_hardoptrest1(Lisp_Object def, Lisp_Object a)
1253 {
1254 return double_hardoptrestn(def, 1, a);
1255 }
1256
double_hardoptrest2(Lisp_Object def,Lisp_Object a,Lisp_Object b)1257 Lisp_Object double_hardoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
1258 {
1259 return double_hardoptrestn(def, 2, a, b);
1260 }
1261
double_hardoptrestn(Lisp_Object def,int nargs,...)1262 Lisp_Object MS_CDECL double_hardoptrestn(Lisp_Object def, int nargs, ...)
1263 {
1264 va_list a;
1265 va_start(a, nargs);
1266 return double_vbyterestn(def, nargs, a, SPID_NOARG);
1267 }
1268
tracebyteopt1(Lisp_Object def,Lisp_Object a)1269 Lisp_Object tracebyteopt1(Lisp_Object def, Lisp_Object a)
1270 {
1271 return tracebyteoptn(def, 1, a);
1272 }
1273
tracebyteopt2(Lisp_Object def,Lisp_Object a,Lisp_Object b)1274 Lisp_Object tracebyteopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
1275 {
1276 return tracebyteoptn(def, 2, a, b);
1277 }
1278
vtracebyteoptn(Lisp_Object def,int nargs,va_list a,Lisp_Object dflt)1279 static Lisp_Object vtracebyteoptn(Lisp_Object def, int nargs,
1280 va_list a, Lisp_Object dflt)
1281 {
1282 Lisp_Object r;
1283 Lisp_Object nil = C_nil;
1284 int i, wantargs, wantopts;
1285 Lisp_Object *stack_save = stack;
1286 push3(litvec, codevec, def);
1287 /*
1288 * Maybe I should raise an exception (continuable error) if too many args
1289 * are provided - for now I just silently ignore th excess.
1290 */
1291 if (nargs != 0) push_args(a, nargs);
1292 else va_end(a);
1293 stackcheck1(stack-stack_save, def);
1294 r = qcar(def);
1295 wantargs = ((unsigned char *)data_of_bps(r))[0];
1296 wantopts = ((unsigned char *)data_of_bps(r))[1];
1297 if (nargs < wantargs || nargs > wantargs+wantopts)
1298 { popv(nargs+1); pop2(codevec, litvec)
1299 return error(2, err_wrong_no_args, name_from(def),
1300 fixnum_of_int((int32_t)nargs));
1301 }
1302 while (nargs < wantargs+wantopts)
1303 { push(dflt); /* Provide value for all optional args */
1304 nargs++;
1305 }
1306 stackcheck1(stack-stack_save, def);
1307 freshline_trace();
1308 loop_print_trace(name_from(def));
1309 trace_printf(" (%d args)", nargs);
1310 if (callstack != nil)
1311 { trace_printf(" from ");
1312 loop_print_trace(qcar(callstack));
1313 }
1314 trace_printf("\n");
1315 for (i=1; i<=nargs; i++)
1316 { trace_printf("Arg%d: ", i);
1317 loop_print_trace(stack[i-nargs]);
1318 trace_printf("\n");
1319 }
1320 def = stack[-nargs];
1321 r = qcar(def);
1322 r = bytestream_interpret(r, qcdr(def), stack-nargs);
1323 nil = C_nil;
1324 if (exception_pending())
1325 { flip_exception();
1326 stack += nargs;
1327 if ((exit_reason & UNWIND_ERROR) != 0)
1328 for (i=1; i<=nargs; i++)
1329 { err_printf("Arg%d: ", i);
1330 loop_print_error(stack[i-nargs]); err_printf("\n");
1331 ignore_exception();
1332 }
1333 popv(nargs+1); pop2(codevec, litvec);
1334 flip_exception();
1335 return nil;
1336 }
1337 #ifdef COMMON
1338 r = Lmv_list(nil, r);
1339 if (exception_pending())
1340 { flip_exception();
1341 popv(1); pop2(codevec, litvec);
1342 flip_exception();
1343 return nil;
1344 }
1345 #endif
1346 pop(def);
1347 push(r);
1348 freshline_trace();
1349 loop_print_trace(name_from(def));
1350 nil = C_nil;
1351 if (!exception_pending())
1352 { trace_printf(" = ");
1353 loop_print_trace(r);
1354 trace_printf("\n");
1355 }
1356 if (exception_pending())
1357 { flip_exception();
1358 popv(1); pop2(codevec, litvec);
1359 flip_exception();
1360 return nil;
1361 }
1362 pop3(r, codevec, litvec);
1363 #ifdef COMMON
1364 r = unpack_mv(nil, r);
1365 #endif
1366 return r;
1367 }
1368
tracebyteoptn(Lisp_Object def,int nargs,...)1369 Lisp_Object MS_CDECL tracebyteoptn(Lisp_Object def, int nargs, ...)
1370 {
1371 va_list a;
1372 va_start(a, nargs);
1373 return vtracebyteoptn(def, nargs, a, C_nil);
1374 }
1375
tracehardopt1(Lisp_Object def,Lisp_Object a)1376 Lisp_Object tracehardopt1(Lisp_Object def, Lisp_Object a)
1377 {
1378 return tracehardoptn(def, 1, a);
1379 }
1380
tracehardopt2(Lisp_Object def,Lisp_Object a,Lisp_Object b)1381 Lisp_Object tracehardopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
1382 {
1383 return tracehardoptn(def, 2, a, b);
1384 }
1385
tracehardoptn(Lisp_Object def,int nargs,...)1386 Lisp_Object MS_CDECL tracehardoptn(Lisp_Object def, int nargs, ...)
1387 {
1388 va_list a;
1389 va_start(a, nargs);
1390 return vtracebyteoptn(def, nargs, a, SPID_NOARG);
1391 }
1392
tracebyteoptrest1(Lisp_Object def,Lisp_Object a)1393 Lisp_Object tracebyteoptrest1(Lisp_Object def, Lisp_Object a)
1394 {
1395 return tracebyteoptrestn(def, 1, a);
1396 }
1397
tracebyteoptrest2(Lisp_Object def,Lisp_Object a,Lisp_Object b)1398 Lisp_Object tracebyteoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
1399 {
1400 return tracebyteoptrestn(def, 2, a, b);
1401 }
1402
vtracebyterestn(Lisp_Object def,int nargs,va_list a,Lisp_Object dflt)1403 static Lisp_Object vtracebyterestn(Lisp_Object def, int nargs,
1404 va_list a, Lisp_Object dflt)
1405 {
1406 Lisp_Object r;
1407 Lisp_Object nil = C_nil;
1408 int i, wantargs, wantopts;
1409 Lisp_Object *stack_save = stack;
1410 push3(litvec, codevec, def);
1411 if (nargs != 0) push_args(a, nargs);
1412 else va_end(a);
1413 stackcheck1(stack-stack_save, def);
1414 r = qcar(def);
1415 wantargs = ((unsigned char *)data_of_bps(r))[0];
1416 wantopts = ((unsigned char *)data_of_bps(r))[1];
1417 if (nargs < wantargs)
1418 { popv(nargs+2);
1419 return error(2, err_wrong_no_args, name_from(def),
1420 fixnum_of_int((int32_t)nargs));
1421 }
1422 while (nargs < wantargs+wantopts)
1423 { push(dflt); /* Provide value for all optional args */
1424 nargs++;
1425 }
1426 { Lisp_Object rest = nil;
1427 while (nargs > wantargs+wantopts)
1428 { Lisp_Object w = stack[0];
1429 stack[0] = def;
1430 rest = cons(w, rest);
1431 errexitn(nargs+2);
1432 pop(def);
1433 nargs--;
1434 }
1435 push(rest);
1436 nargs++;
1437 }
1438 stackcheck1(stack-stack_save, def);
1439 freshline_trace();
1440 loop_print_trace(name_from(def));
1441 trace_printf(" (%d args)", nargs);
1442 if (callstack != nil)
1443 { trace_printf(" from ");
1444 loop_print_trace(qcar(callstack));
1445 }
1446 trace_printf("\n");
1447 for (i=1; i<=nargs; i++)
1448 { trace_printf("Arg%d: ", i);
1449 loop_print_trace(stack[i-nargs]);
1450 trace_printf("\n");
1451 }
1452 def = stack[-nargs];
1453 r = qcar(def);
1454 r = bytestream_interpret(r, qcdr(def), stack-nargs);
1455 nil = C_nil;
1456 if (exception_pending())
1457 { flip_exception();
1458 stack += nargs;
1459 if ((exit_reason & UNWIND_ERROR) != 0)
1460 for (i=1; i<=nargs; i++)
1461 { err_printf("Arg%d: ", i);
1462 loop_print_error(stack[i-nargs]); err_printf("\n");
1463 ignore_exception();
1464 }
1465 popv(nargs+1); pop2(codevec, litvec);
1466 flip_exception();
1467 return nil;
1468 }
1469 #ifdef COMMON
1470 r = Lmv_list(nil, r);
1471 if (exception_pending())
1472 { flip_exception();
1473 popv(1); pop2(codevec, litvec);
1474 flip_exception();
1475 return nil;
1476 }
1477 #endif
1478 pop(def);
1479 push(r);
1480 freshline_trace();
1481 loop_print_trace(name_from(def));
1482 nil = C_nil;
1483 if (!exception_pending())
1484 { trace_printf(" = ");
1485 loop_print_trace(r);
1486 trace_printf("\n");
1487 }
1488 if (exception_pending())
1489 { flip_exception();
1490 popv(1); pop2(codevec, litvec);
1491 flip_exception();
1492 return nil;
1493 }
1494 pop3(r, codevec, litvec);
1495 #ifdef COMMON
1496 r = unpack_mv(nil, r);
1497 #endif
1498 return r;
1499 }
1500
tracebyteoptrestn(Lisp_Object def,int nargs,...)1501 Lisp_Object MS_CDECL tracebyteoptrestn(Lisp_Object def, int nargs, ...)
1502 {
1503 va_list a;
1504 va_start(a, nargs);
1505 return vtracebyterestn(def, nargs, a, C_nil);
1506 }
1507
tracehardoptrest1(Lisp_Object def,Lisp_Object a)1508 Lisp_Object tracehardoptrest1(Lisp_Object def, Lisp_Object a)
1509 {
1510 return tracehardoptrestn(def, 1, a);
1511 }
1512
tracehardoptrest2(Lisp_Object def,Lisp_Object a,Lisp_Object b)1513 Lisp_Object tracehardoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
1514 {
1515 return tracehardoptrestn(def, 2, a, b);
1516 }
1517
tracehardoptrestn(Lisp_Object def,int nargs,...)1518 Lisp_Object MS_CDECL tracehardoptrestn(Lisp_Object def, int nargs, ...)
1519 {
1520 va_list a;
1521 va_start(a, nargs);
1522 return vtracebyterestn(def, nargs, a, SPID_NOARG);
1523 }
1524
Lis_spid(Lisp_Object nil,Lisp_Object a)1525 static Lisp_Object Lis_spid(Lisp_Object nil, Lisp_Object a)
1526 { /* Used in compilation for optional args */
1527 return onevalue(Lispify_predicate(is_spid(a)));
1528 }
1529
Lspid_to_nil(Lisp_Object nil,Lisp_Object a)1530 static Lisp_Object Lspid_to_nil(Lisp_Object nil, Lisp_Object a)
1531 { /* Used in compilation for optional args */
1532 if (is_spid(a)) a = nil;
1533 return onevalue(a);
1534 }
1535
Lload_spid(Lisp_Object nil,int nargs,...)1536 static Lisp_Object MS_CDECL Lload_spid(Lisp_Object nil, int nargs, ...)
1537 { /* Used in compilation of UNWIND-PROTECT */
1538 CSL_IGNORE(nil);
1539 CSL_IGNORE(nargs);
1540 return onevalue(SPID_PROTECT);
1541 }
1542
Lmv_list(Lisp_Object nil,Lisp_Object a)1543 Lisp_Object Lmv_list(Lisp_Object nil, Lisp_Object a)
1544 /*
1545 * This does a (multiple-value-list A) on just one form. It must be used
1546 * carefully so that the value-count information does not get lost between
1547 * the evaluation of A and calling this code.
1548 */
1549 {
1550 #ifdef COMMON
1551 Lisp_Object r, *save_stack = stack;
1552 int i, x = exit_count;
1553 stackcheck1(0, a);
1554 if (x > 0) push(a);
1555 for (i=2; i<=x; i++) push((&work_0)[i]);
1556 r = nil;
1557 for (i=0; i<x; i++)
1558 { Lisp_Object w;
1559 pop(w);
1560 r = cons(w, r);
1561 nil = C_nil;
1562 if (exception_pending())
1563 { stack = save_stack;
1564 return nil;
1565 }
1566 }
1567 return onevalue(r);
1568 #else
1569 CSL_IGNORE(nil);
1570 return ncons(a);
1571 #endif
1572 }
1573
1574 /*
1575 * In these tables there are some functions that would need adjusting
1576 * for a Common Lisp compiler, since they take different numbers of
1577 * args in Common and Standard Lisp.
1578 * This means, to be specific:
1579 *
1580 * Lgensym Lread Latan Ltruncate Lfloat
1581 * Lintern Lmacroexpand Lmacroexpand_1
1582 * Lrandom Lunintern Lappend Leqn Lgcd
1583 * Lgeq Lgreaterp Llcm Lleq Llessp
1584 * Lquotient
1585 *
1586 * In these cases (at least!) the Common Lisp version of the compiler will
1587 * need to avoid generating the call that uses this table.
1588 *
1589 * Some functions are missing from the list here because they seemed
1590 * critical enough to be awarded single-byte opcodes or because the
1591 * compiler always expands them away - car through cddddr are the main
1592 * cases, together with eq and equal.
1593 */
1594
1595
1596 n_args *zero_arg_functions[] =
1597 {
1598 Lbatchp, /* 0 */
1599 Ldate, /* 1 */
1600 Leject, /* 2 */
1601 Lerror0, /* 3 */
1602 Lgctime, /* 4 */
1603 Lgensym, /* 5 */
1604 Llposn, /* 6 */
1605 Lnext_random, /* 7 */
1606 Lposn, /* 8 */
1607 Lread, /* 9 */
1608 Lreadch, /* 10 */
1609 Lterpri, /* 11 */
1610 Ltime, /* 12 */
1611 Ltyi, /* 13 */
1612 Lload_spid, /* 14 */ /* ONLY used in compiled code */
1613 NULL
1614 };
1615
1616 one_args *one_arg_functions[] =
1617 {
1618 Labsval, /* 0 */
1619 Ladd1, /* 1 */
1620 Latan, /* 2 */
1621 Lapply0, /* 3 */
1622 Latom, /* 4 */
1623 Lboundp, /* 5 */
1624 Lchar_code, /* 6 */
1625 Lclose, /* 7 */
1626 Lcodep, /* 8 */
1627 Lcompress, /* 9 */
1628 Lconstantp, /* 10 */
1629 Ldigitp, /* 11 */
1630 Lendp, /* 12 */
1631 Leval, /* 13 */
1632 Levenp, /* 14 */
1633 Levlis, /* 15 */
1634 Lexplode, /* 16 */
1635 Lexplode2lc, /* 17 */
1636 Lexplodec, /* 18 */
1637 Lfixp, /* 19 */
1638 Lfloat, /* 20 */
1639 Lfloatp, /* 21 */
1640 Lsymbol_specialp, /* 22 */
1641 Lgc, /* 23 */
1642 Lgensym1, /* 24 */
1643 Lgetenv, /* 25 */
1644 Lsymbol_globalp, /* 26 */
1645 Liadd1, /* 27 */
1646 Lsymbolp, /* 28 */
1647 Liminus, /* 29 */
1648 Liminusp, /* 30 */
1649 Lindirect, /* 31 */
1650 Lintegerp, /* 32 */
1651 Lintern, /* 33 */
1652 Lisub1, /* 34 */
1653 Llength, /* 35 */
1654 Llengthc, /* 36 */
1655 Llinelength, /* 37 */
1656 Lalpha_char_p, /* 38 */
1657 Lload_module, /* 39 */
1658 Llognot, /* 40 */
1659 Lmacroexpand, /* 41 */
1660 Lmacroexpand_1, /* 42 */
1661 Lmacro_function, /* 43 */
1662 Lget_bps, /* 44 */
1663 Lmake_global, /* 45 */
1664 Lsmkvect, /* 46 */
1665 Lmake_special, /* 47 */
1666 Lminus, /* 48 */
1667 Lminusp, /* 49 */
1668 Lmkvect, /* 50 */
1669 Lmodular_minus, /* 51 */
1670 Lmodular_number, /* 52 */
1671 Lmodular_reciprocal, /* 53 */
1672 Lnull, /* 54 */
1673 Loddp, /* 55 */
1674 Lonep, /* 56 */
1675 Lpagelength, /* 57 */
1676 Lconsp, /* 58 */
1677 Lplist, /* 59 */
1678 Lplusp, /* 60 */
1679 Lprin, /* 61 */
1680 Lprinc, /* 62 */
1681 Lprint, /* 63 */
1682 Lprintc, /* 64 */
1683 Lrandom, /* 65 */
1684 Lrational, /* 66 */
1685 Lrdf1, /* 67 */
1686 Lrds, /* 68 */
1687 Lremd, /* 69 */
1688 Lreverse, /* 70 */
1689 Lnreverse, /* 71 */
1690 Lwhitespace_char_p, /* 72 */
1691 Lset_small_modulus, /* 73 */
1692 Lxtab, /* 74 */
1693 Lspecial_char, /* 75 */
1694 Lspecial_form_p, /* 76 */
1695 Lspool, /* 77 */
1696 Lstop, /* 78 */
1697 Lstringp, /* 79 */
1698 Lsub1, /* 80 */
1699 Lsymbol_env, /* 81 */
1700 Lsymbol_function, /* 82 */
1701 Lsymbol_name, /* 83 */
1702 Lsymbol_value, /* 84 */
1703 Lsystem, /* 85 */
1704 Ltruncate, /* 86 */
1705 Lttab, /* 87 */
1706 Ltyo, /* 88 */
1707 Lunintern, /* 89 */
1708 Lunmake_global, /* 90 */
1709 Lunmake_special, /* 91 */
1710 Lupbv, /* 92 */
1711 Lsimple_vectorp, /* 93 */
1712 Lverbos, /* 94 */
1713 Lwrs, /* 95 */
1714 Lzerop, /* 96 */
1715 Lcar, /* 97 */
1716 Lcdr, /* 98 */
1717 Lcaar, /* 99 */
1718 Lcadr, /* 100 */
1719 Lcdar, /* 101 */
1720 Lcddr, /* 102 */
1721 Lcar, /* 103 */ /* Really QCAR (unchecked) */
1722 Lcdr, /* 104 */
1723 Lcaar, /* 105 */
1724 Lcadr, /* 106 */
1725 Lcdar, /* 107 */
1726 Lcddr, /* 108 */
1727 Lncons, /* 109 */
1728 Lnumberp, /* 110 */
1729 Lis_spid, /* 111 */ /* ONLY used in compiled code */
1730 Lspid_to_nil, /* 112 */ /* ONLY used in compiled code */
1731 Lmv_list, /* 113 */ /* ONLY used in compiled code */
1732 NULL
1733 };
1734
1735 two_args *two_arg_functions[] =
1736 {
1737 Lappend, /* 0 */
1738 Lash, /* 1 */
1739 Lassoc, /* 2 */
1740 Latsoc, /* 3 */
1741 Ldeleq, /* 4 */
1742 Ldelete, /* 5 */
1743 Ldivide, /* 6 */
1744 Leqcar, /* 7 */
1745 Leql, /* 8 */
1746 Leqn, /* 9 */
1747 Lexpt, /* 10 */
1748 Lflag, /* 11 */
1749 Lflagpcar, /* 12 */
1750 Lgcd, /* 13 */
1751 Lgeq, /* 14 */
1752 Lgetv, /* 15 */
1753 Lgreaterp, /* 16 */
1754 Lidifference, /* 17 */
1755 Ligreaterp, /* 18 */
1756 Lilessp, /* 19 */
1757 Limax, /* 20 */
1758 Limin, /* 21 */
1759 Liplus2, /* 22 */
1760 Liquotient, /* 23 */
1761 Liremainder, /* 24 */
1762 Lirightshift, /* 25 */
1763 Litimes2, /* 26 */
1764 Llcm, /* 27 */
1765 Lleq, /* 28 */
1766 Llessp, /* 29 */
1767 Lmake_random_state, /* 30 */
1768 Lmax2, /* 31 */
1769 Lmember, /* 32 */
1770 Lmemq, /* 33 */
1771 Lmin2, /* 34 */
1772 Lmod, /* 35 */
1773 Lmodular_difference, /* 36 */
1774 Lmodular_expt, /* 37 */
1775 Lmodular_plus, /* 38 */
1776 Lmodular_quotient, /* 39 */
1777 Lmodular_times, /* 40 */
1778 Lnconc, /* 41 */
1779 Lneq, /* 42 */
1780 Lorderp, /* 43 */
1781 Lquotient, /* 44 */
1782 Lrem, /* 45 */
1783 Lremflag, /* 46 */
1784 Lremprop, /* 47 */
1785 Lrplaca, /* 48 */
1786 Lrplacd, /* 49 */
1787 Lsgetv, /* 50 */
1788 Lset, /* 51 */
1789 Lsmemq, /* 52 */
1790 Lsubla, /* 53 */
1791 Lsublis, /* 54 */
1792 Lsymbol_set_definition, /* 55 */
1793 Lsymbol_set_env, /* 56 */
1794 Ltimes2, /* 57 */
1795 Lxcons, /* 58 */
1796 Lequal, /* 59 */
1797 Leq, /* 60 */
1798 Lcons, /* 61 */
1799 Llist2, /* 62 */
1800 Lget, /* 63 */
1801 Lgetv, /* 64 */ /* QGETV */
1802 Lflagp, /* 65 */
1803 Lapply1, /* 66 */
1804 Ldifference2, /* 67 */
1805 Lplus2, /* 68 */
1806 Ltimes2, /* 69 */
1807 Lequalcar, /* 70 */
1808 Leq, /* 71 */ /* IEQUAL */
1809 Lnreverse2, /* 72 */
1810 NULL
1811 };
1812
1813 n_args *three_arg_functions[] =
1814 {
1815 Lbpsputv, /* 0 */
1816 Lerrorsetn, /* 1 */
1817 Llist2star, /* 2 */
1818 Llist3, /* 3 */
1819 Lputprop, /* 4 */
1820 Lputv, /* 5 */
1821 Lsputv, /* 6 */
1822 Lsubst, /* 7 */
1823 Lapply2, /* 8 */
1824 Lacons, /* 9 */
1825 NULL
1826 };
1827
1828 /* end of eval4.c */
1829
1830