1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* This file contains utilities for interrupts, errors, etc. */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include "history.h"
32 #include "syscall.h"
33
34 #ifdef __OS2__
35 extern void OS2_handle_attention_interrupt (void);
36 #endif
37
38 SCHEME_OBJECT * history_register;
39 unsigned long prev_restore_history_offset;
40
41 static SCHEME_OBJECT copy_history (SCHEME_OBJECT);
42 static void error_death (long, const char *) NORETURN;
43
44 /* Helper procedures for setup_interrupt, which follows. */
45
46 static unsigned long
compute_interrupt_number(unsigned long masked_interrupts)47 compute_interrupt_number (unsigned long masked_interrupts)
48 {
49 unsigned long interrupt_number = 0;
50 unsigned long bit_mask = 1;
51 while ((interrupt_number <= MAX_INTERRUPT_NUMBER)
52 && ((masked_interrupts & bit_mask) == 0))
53 {
54 interrupt_number += 1;
55 bit_mask <<= 1;
56 }
57 return (interrupt_number);
58 }
59
60 static unsigned long
compute_interrupt_handler_mask(SCHEME_OBJECT interrupt_masks,unsigned long interrupt_number)61 compute_interrupt_handler_mask (SCHEME_OBJECT interrupt_masks,
62 unsigned long interrupt_number)
63 {
64 if ((VECTOR_P (interrupt_masks))
65 && (interrupt_number <= (VECTOR_LENGTH (interrupt_masks))))
66 {
67 SCHEME_OBJECT mask
68 = (VECTOR_REF (interrupt_masks, interrupt_number));
69 if ((INTEGER_P (mask)) && (integer_to_ulong_p (mask)))
70 /* Guarantee that the given interrupt is disabled. */
71 return ((integer_to_ulong (mask)) &~ (1UL << interrupt_number));
72 }
73 return
74 ((interrupt_number <= MAX_INTERRUPT_NUMBER)
75 ? ((1UL << interrupt_number) - 1)
76 : GET_INT_MASK);
77 }
78
79 static void
terminate_no_interrupt_handler(unsigned long masked_interrupts)80 terminate_no_interrupt_handler (unsigned long masked_interrupts)
81 {
82 outf_fatal ("\nInterrupts = %#08lx, Mask = %#08lx, Masked = %#08lx\n",
83 GET_INT_CODE,
84 GET_INT_MASK,
85 masked_interrupts);
86 Microcode_Termination (TERM_NO_INTERRUPT_HANDLER);
87 }
88
89 SCHEME_OBJECT
initialize_interrupt_handler_vector(void)90 initialize_interrupt_handler_vector (void)
91 {
92 return (make_vector ((MAX_INTERRUPT_NUMBER + 2), SHARP_F, false));
93 }
94
95 SCHEME_OBJECT
initialize_interrupt_mask_vector(void)96 initialize_interrupt_mask_vector (void)
97 {
98 SCHEME_OBJECT v = (make_vector ((MAX_INTERRUPT_NUMBER + 2), SHARP_F, false));
99 unsigned long interrupt_number = 0;
100 while (interrupt_number <= MAX_INTERRUPT_NUMBER)
101 {
102 VECTOR_SET (v,
103 interrupt_number,
104 (ulong_to_integer ((1UL << interrupt_number) - 1)));
105 interrupt_number += 1;
106 }
107 return (v);
108 }
109
110 /* setup_interrupt is called from the Interrupt macro to do all of the
111 setup for calling the user's interrupt routines. */
112
113 void
setup_interrupt(unsigned long masked_interrupts)114 setup_interrupt (unsigned long masked_interrupts)
115 {
116 SCHEME_OBJECT interrupt_handlers = SHARP_F;
117 SCHEME_OBJECT interrupt_masks = SHARP_F;
118 unsigned long interrupt_number
119 = (compute_interrupt_number (masked_interrupts));
120 unsigned long interrupt_mask;
121 SCHEME_OBJECT interrupt_handler;
122
123 #ifdef __OS2__
124 if ((1UL << interrupt_number) == INT_Global_1)
125 {
126 OS2_handle_attention_interrupt ();
127 abort_to_interpreter (PRIM_POP_RETURN);
128 }
129 #endif
130 if (!VECTOR_P (fixed_objects))
131 {
132 outf_fatal ("\nInvalid fixed-objects vector");
133 terminate_no_interrupt_handler (masked_interrupts);
134 }
135 interrupt_handlers = (VECTOR_REF (fixed_objects, SYSTEM_INTERRUPT_VECTOR));
136 interrupt_masks = (VECTOR_REF (fixed_objects, FIXOBJ_INTERRUPT_MASK_VECTOR));
137 if (! ((VECTOR_P (interrupt_handlers))
138 && (interrupt_number < (VECTOR_LENGTH (interrupt_handlers)))))
139 {
140 outf_fatal ("\nUnable to get interrupt handler.");
141 terminate_no_interrupt_handler (masked_interrupts);
142 }
143 interrupt_mask
144 = (compute_interrupt_handler_mask (interrupt_masks, interrupt_number));
145 interrupt_handler = (VECTOR_REF (interrupt_handlers, interrupt_number));
146
147 stop_history ();
148 preserve_interrupt_mask ();
149 Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
150
151 /* There used to be some code here for gc checks, but that is done
152 uniformly now by RC_NORMAL_GC_DONE. */
153
154 /* Now make an environment frame for use in calling the
155 user supplied interrupt routine. It will be given two arguments:
156 the UNmasked interrupt requests, and the currently enabled
157 interrupts. */
158 STACK_PUSH (ULONG_TO_FIXNUM (GET_INT_MASK));
159 STACK_PUSH (ULONG_TO_FIXNUM (GET_INT_CODE));
160 STACK_PUSH (interrupt_handler);
161 PUSH_APPLY_FRAME_HEADER (2);
162 Pushed ();
163 /* Turn off interrupts: */
164 SET_INTERRUPT_MASK (interrupt_mask);
165 }
166
167 /* Error processing utilities */
168
169 void
err_print(long error_code,outf_channel where)170 err_print (long error_code, outf_channel where)
171 {
172 const char * message
173 = ((error_code <= MAX_ERROR)
174 ? (Error_Names[error_code])
175 : 0);
176 if (message == 0)
177 outf (where, "Unknown error code %#lx.\n", error_code);
178 else
179 outf (where, "Error code %#lx (%s).\n", error_code, message);
180 }
181
182 long death_blow;
183
184 static void
error_death(long code,const char * message)185 error_death (long code, const char * message)
186 {
187 death_blow = code;
188 outf_fatal ("\nMicrocode Error: %s.\n", message);
189 err_print (code, FATAL_OUTPUT);
190 outf_error ("\n**** Stack Trace ****\n\n");
191 Back_Trace (ERROR_OUTPUT);
192 termination_no_error_handler ();
193 /*NOTREACHED*/
194 }
195
196 void
Stack_Death(void)197 Stack_Death (void)
198 {
199 outf_fatal("\nWill_Push vs. Pushed inconsistency.\n");
200 Microcode_Termination (TERM_BAD_STACK);
201 /*NOTREACHED*/
202 }
203
204 void
preserve_interrupt_mask(void)205 preserve_interrupt_mask (void)
206 {
207 Will_Push (CONTINUATION_SIZE);
208 SET_RC (RC_RESTORE_INT_MASK);
209 SET_EXP (ULONG_TO_FIXNUM (GET_INT_MASK));
210 SAVE_CONT ();
211 Pushed ();
212 }
213
214 /* canonicalize_primitive_context should be used by "unsafe"
215 primitives to guarantee that their execution context is the
216 expected one, ie. they are called from the interpreter. If they
217 are called from compiled code, they should abort to the interpreter
218 and reenter. */
219
220 void
canonicalize_primitive_context(void)221 canonicalize_primitive_context (void)
222 {
223 SCHEME_OBJECT primitive = GET_PRIMITIVE;
224 unsigned long n_args;
225
226 assert (PRIMITIVE_P (primitive));
227 n_args = (PRIMITIVE_N_ARGUMENTS (primitive));
228
229 #ifdef CC_SUPPORT_P
230 if (CC_ENTRY_P (STACK_REF (n_args)))
231 {
232 /* The primitive has been invoked from compiled code. */
233 STACK_PUSH (primitive);
234 PUSH_APPLY_FRAME_HEADER (n_args);
235 guarantee_interp_return ();
236 SET_PRIMITIVE (SHARP_F);
237 PRIMITIVE_ABORT (PRIM_APPLY);
238 /*NOTREACHED*/
239 }
240 #endif
241 }
242
243 /* back_out_of_primitive sets the registers up so that the backout
244 mechanism in "interp.c" will cause the primitive to be
245 restarted if the error/interrupt is proceeded. */
246
247 void
back_out_of_primitive(void)248 back_out_of_primitive (void)
249 {
250 SCHEME_OBJECT primitive = GET_PRIMITIVE;
251 assert (PRIMITIVE_P (primitive));
252 STACK_PUSH (primitive);
253 PUSH_APPLY_FRAME_HEADER (PRIMITIVE_N_ARGUMENTS (primitive));
254 guarantee_interp_return ();
255 SET_PRIMITIVE (SHARP_F);
256 SET_EXP (SHARP_F);
257 SET_RC (RC_INTERNAL_APPLY);
258 SAVE_CONT ();
259 SET_ENV (THE_NULL_ENV);
260 SET_VAL (SHARP_F);
261 }
262
263 /* Useful error procedures */
264
265 /* Note that backing out of the primitives happens after aborting,
266 not before.
267 This guarantees that the interpreter state is consistent, since the
268 longjmp restores the relevant registers even if the primitive was
269 invoked from compiled code. */
270
271 void
signal_error_from_primitive(long error_code)272 signal_error_from_primitive (long error_code)
273 {
274 PRIMITIVE_ABORT (error_code);
275 /*NOTREACHED*/
276 }
277
278 void
signal_interrupt_from_primitive(void)279 signal_interrupt_from_primitive (void)
280 {
281 PRIMITIVE_ABORT (PRIM_INTERRUPT);
282 /*NOTREACHED*/
283 }
284
285 void
error_wrong_type_arg(int n)286 error_wrong_type_arg (int n)
287 {
288 long error_code;
289
290 switch (n)
291 {
292 case 1: error_code = ERR_ARG_1_WRONG_TYPE; break;
293 case 2: error_code = ERR_ARG_2_WRONG_TYPE; break;
294 case 3: error_code = ERR_ARG_3_WRONG_TYPE; break;
295 case 4: error_code = ERR_ARG_4_WRONG_TYPE; break;
296 case 5: error_code = ERR_ARG_5_WRONG_TYPE; break;
297 case 6: error_code = ERR_ARG_6_WRONG_TYPE; break;
298 case 7: error_code = ERR_ARG_7_WRONG_TYPE; break;
299 case 8: error_code = ERR_ARG_8_WRONG_TYPE; break;
300 case 9: error_code = ERR_ARG_9_WRONG_TYPE; break;
301 case 10: error_code = ERR_ARG_10_WRONG_TYPE; break;
302 default: error_code = ERR_EXTERNAL_RETURN; break;
303 }
304 signal_error_from_primitive (error_code);
305 }
306
307 void
error_bad_range_arg(int n)308 error_bad_range_arg (int n)
309 {
310 long error_code;
311
312 switch (n)
313 {
314 case 1: error_code = ERR_ARG_1_BAD_RANGE; break;
315 case 2: error_code = ERR_ARG_2_BAD_RANGE; break;
316 case 3: error_code = ERR_ARG_3_BAD_RANGE; break;
317 case 4: error_code = ERR_ARG_4_BAD_RANGE; break;
318 case 5: error_code = ERR_ARG_5_BAD_RANGE; break;
319 case 6: error_code = ERR_ARG_6_BAD_RANGE; break;
320 case 7: error_code = ERR_ARG_7_BAD_RANGE; break;
321 case 8: error_code = ERR_ARG_8_BAD_RANGE; break;
322 case 9: error_code = ERR_ARG_9_BAD_RANGE; break;
323 case 10: error_code = ERR_ARG_10_BAD_RANGE; break;
324 default: error_code = ERR_EXTERNAL_RETURN; break;
325 }
326 signal_error_from_primitive (error_code);
327 }
328
329 void
error_external_return(void)330 error_external_return (void)
331 {
332 signal_error_from_primitive (ERR_EXTERNAL_RETURN);
333 }
334
335 static SCHEME_OBJECT error_argument;
336
337 void
error_with_argument(SCHEME_OBJECT argument)338 error_with_argument (SCHEME_OBJECT argument)
339 {
340 error_argument = argument;
341 signal_error_from_primitive
342 (((VECTOR_P (argument))
343 && ((VECTOR_LENGTH (argument)) > 0)
344 && ((VECTOR_REF (argument, 0))
345 == (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL))))
346 ? ERR_IN_SYSTEM_CALL
347 : ERR_WITH_ARGUMENT);
348 /*NOTREACHED*/
349 }
350
351 void
error_in_system_call(enum syserr_names err,enum syscall_names name)352 error_in_system_call (enum syserr_names err, enum syscall_names name)
353 {
354 /* System call errors have some additional information.
355 Encode this as a vector in place of the error code. */
356 SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 0));
357 VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
358 VECTOR_SET (v, 1, (LONG_TO_UNSIGNED_FIXNUM ((unsigned int) err)));
359 VECTOR_SET (v, 2, (LONG_TO_UNSIGNED_FIXNUM ((unsigned int) name)));
360 error_argument = v;
361 signal_error_from_primitive (ERR_IN_SYSTEM_CALL);
362 /*NOTREACHED*/
363 }
364
365 void
error_system_call(int code,enum syscall_names name)366 error_system_call (int code, enum syscall_names name)
367 {
368 error_in_system_call ((OS_error_code_to_syserr (code)), name);
369 /*NOTREACHED*/
370 }
371
372 long
arg_integer(int arg_number)373 arg_integer (int arg_number)
374 {
375 SCHEME_OBJECT object = (ARG_REF (arg_number));
376 if (! (INTEGER_P (object)))
377 error_wrong_type_arg (arg_number);
378 if (! (integer_to_long_p (object)))
379 error_bad_range_arg (arg_number);
380 return (integer_to_long (object));
381 }
382
383 intmax_t
arg_integer_to_intmax(int arg_number)384 arg_integer_to_intmax (int arg_number)
385 {
386 SCHEME_OBJECT object = (ARG_REF (arg_number));
387 if (! (INTEGER_P (object)))
388 error_wrong_type_arg (arg_number);
389 if (! (integer_to_intmax_p (object)))
390 error_bad_range_arg (arg_number);
391 return (integer_to_intmax (object));
392 }
393
394 long
arg_nonnegative_integer(int arg_number)395 arg_nonnegative_integer (int arg_number)
396 {
397 long result = (arg_integer (arg_number));
398 if (result < 0)
399 error_bad_range_arg (arg_number);
400 return (result);
401 }
402
403 long
arg_index_integer(int arg_number,long upper_limit)404 arg_index_integer (int arg_number, long upper_limit)
405 {
406 long result = (arg_integer (arg_number));
407 if ((result < 0) || (result >= upper_limit))
408 error_bad_range_arg (arg_number);
409 return (result);
410 }
411
412 intmax_t
arg_index_integer_to_intmax(int arg_number,intmax_t upper_limit)413 arg_index_integer_to_intmax (int arg_number, intmax_t upper_limit)
414 {
415 intmax_t result = (arg_integer_to_intmax (arg_number));
416 if ((result < 0) || (result >= upper_limit))
417 error_bad_range_arg (arg_number);
418 return (result);
419 }
420
421 long
arg_integer_in_range(int arg_number,long lower_limit,long upper_limit)422 arg_integer_in_range (int arg_number, long lower_limit, long upper_limit)
423 {
424 long result = (arg_integer (arg_number));
425 if ((result < lower_limit) || (result >= upper_limit))
426 error_bad_range_arg (arg_number);
427 return (result);
428 }
429
430 unsigned long
arg_ulong_integer(int arg_number)431 arg_ulong_integer (int arg_number)
432 {
433 SCHEME_OBJECT object = (ARG_REF (arg_number));
434 if (! (INTEGER_P (object)))
435 error_wrong_type_arg (arg_number);
436 if (! (integer_to_ulong_p (object)))
437 error_bad_range_arg (arg_number);
438 return (integer_to_ulong (object));
439 }
440
441 unsigned long
arg_ulong_index_integer(int arg_number,unsigned long upper_limit)442 arg_ulong_index_integer (int arg_number, unsigned long upper_limit)
443 {
444 unsigned long result = (arg_ulong_integer (arg_number));
445 if (result >= upper_limit)
446 error_bad_range_arg (arg_number);
447 return (result);
448 }
449
450 unsigned long
arg_ulong_integer_in_range(int arg_number,unsigned long lower_limit,unsigned long upper_limit)451 arg_ulong_integer_in_range (int arg_number,
452 unsigned long lower_limit,
453 unsigned long upper_limit)
454 {
455 unsigned long result = (arg_ulong_integer (arg_number));
456 if (! ((result >= lower_limit) && (result < upper_limit)))
457 error_bad_range_arg (arg_number);
458 return (result);
459 }
460
461 bool
real_number_to_double_p(SCHEME_OBJECT x)462 real_number_to_double_p (SCHEME_OBJECT x)
463 {
464 return
465 ((BIGNUM_P (x))
466 ? (BIGNUM_TO_DOUBLE_P (x))
467 : (FLONUM_P (x))
468 ? (flonum_is_finite_p (x))
469 : true);
470 }
471
472 double
real_number_to_double(SCHEME_OBJECT x)473 real_number_to_double (SCHEME_OBJECT x)
474 {
475 return
476 ((FIXNUM_P (x))
477 ? (FIXNUM_TO_DOUBLE (x))
478 : (BIGNUM_P (x))
479 ? (bignum_to_double (x))
480 : (FLONUM_TO_DOUBLE (x)));
481 }
482
483 double
arg_real_number(int arg_number)484 arg_real_number (int arg_number)
485 {
486 SCHEME_OBJECT number = (ARG_REF (arg_number));
487 if (! (REAL_P (number)))
488 error_wrong_type_arg (arg_number);
489 if (! (real_number_to_double_p (number)))
490 error_bad_range_arg (arg_number);
491 return (real_number_to_double (number));
492 }
493
494 double
arg_real_in_range(int arg_number,double lower_limit,double upper_limit)495 arg_real_in_range (int arg_number, double lower_limit, double upper_limit)
496 {
497 double result = (arg_real_number (arg_number));
498 if ((result < lower_limit) || (result > upper_limit))
499 error_bad_range_arg (arg_number);
500 return (result);
501 }
502
503 bool
interpreter_applicable_p(SCHEME_OBJECT object)504 interpreter_applicable_p (SCHEME_OBJECT object)
505 {
506 tail_recurse:
507 switch (OBJECT_TYPE (object))
508 {
509 case TC_PRIMITIVE:
510 case TC_PROCEDURE:
511 case TC_EXTENDED_PROCEDURE:
512 case TC_CONTROL_POINT:
513 return (true);
514
515 case TC_ENTITY:
516 {
517 object = (MEMORY_REF (object, ENTITY_OPERATOR));
518 goto tail_recurse;
519 }
520 #ifdef CC_SUPPORT_P
521 case TC_COMPILED_ENTRY:
522 {
523 cc_entry_type_t cet;
524 return
525 ((read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (object))))
526 ? false
527 : ((cet.marker) == CET_PROCEDURE));
528 }
529 #endif
530 default:
531 return (false);
532 }
533 }
534
535 /* Error handling
536
537 It is assumed that any caller of the error code has already
538 restored its state to a situation which will make it restartable if
539 the error handler returns normally. As a result, the only work to
540 be done on an error is to verify that there is an error handler,
541 save the current continuation and create a new one if entered from
542 Pop_Return rather than Eval, turn off interrupts, and call it with
543 two arguments: the error code and interrupt enables. */
544
545 void
Do_Micro_Error(long error_code,bool from_pop_return_p)546 Do_Micro_Error (long error_code, bool from_pop_return_p)
547 {
548 SCHEME_OBJECT handler = SHARP_F;
549
550 #ifdef ENABLE_DEBUGGING_TOOLS
551 err_print (error_code, ERROR_OUTPUT);
552 if ((GET_RC == RC_INTERNAL_APPLY)
553 || (GET_RC == RC_INTERNAL_APPLY_VAL))
554 {
555 SCHEME_OBJECT * sp = (STACK_LOC (CONTINUATION_SIZE));
556 Print_Expression ((sp[STACK_ENV_FUNCTION]), "Procedure was");
557 outf_error ("\n");
558 outf_error ("# of arguments: %lu\n",
559 (APPLY_FRAME_HEADER_N_ARGS (sp[STACK_ENV_HEADER])));
560 }
561 else
562 {
563 Print_Expression (GET_EXP, "Expression was");
564 outf_error ("\n");
565 Print_Expression (GET_ENV, "Environment was");
566 outf_error ("\n");
567 }
568 Print_Return ("Return code");
569 outf_error ("\n");
570 #endif
571
572 if (Trace_On_Error)
573 {
574 outf_error ("\n\n**** Stack Trace ****\n\n");
575 Back_Trace (ERROR_OUTPUT);
576 }
577
578 #ifdef ENABLE_DEBUGGING_TOOLS
579 {
580 unsigned int * from = local_circle;
581 unsigned int * end = (from + local_nslots);
582 unsigned int * to = debug_circle;
583 while (from < end)
584 (*to++) = (*from++);
585 }
586 debug_nslots = local_nslots;
587 debug_slotno = local_slotno;
588 #endif
589
590 Will_Push (CONTINUATION_SIZE + (from_pop_return_p ? 0 : 1));
591 if (from_pop_return_p)
592 SET_EXP (GET_VAL);
593 else
594 PUSH_ENV ();
595 SET_RC (from_pop_return_p ? RC_POP_RETURN_ERROR : RC_EVAL_ERROR);
596 SAVE_CONT ();
597 Pushed ();
598
599 {
600 SCHEME_OBJECT error_vector = SHARP_F;
601 if (VECTOR_P (fixed_objects))
602 error_vector = (VECTOR_REF (fixed_objects, SYSTEM_ERROR_VECTOR));
603 if (!VECTOR_P (error_vector))
604 error_death (error_code, "No error handlers");
605 if ((error_code >= 0) && (error_code < (VECTOR_LENGTH (error_vector))))
606 handler = (VECTOR_REF (error_vector, error_code));
607 else if (ERR_BAD_ERROR_CODE < (VECTOR_LENGTH (error_vector)))
608 handler = (VECTOR_REF (error_vector, ERR_BAD_ERROR_CODE));
609 else
610 error_death (error_code, "No error handlers");
611 }
612
613 /* Return from error handler will re-enable interrupts & restore history */
614 stop_history ();
615 preserve_interrupt_mask ();
616
617 Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
618 /* Arg 2: interrupt mask */
619 STACK_PUSH (ULONG_TO_FIXNUM (GET_INT_MASK));
620 /* Arg 1: error code */
621 if ((error_code == ERR_WITH_ARGUMENT) || (error_code == ERR_IN_SYSTEM_CALL))
622 STACK_PUSH (error_argument);
623 else
624 STACK_PUSH (long_to_integer (error_code));
625 STACK_PUSH (handler);
626 PUSH_APPLY_FRAME_HEADER (2);
627 Pushed ();
628
629 /* Disable all interrupts */
630 SET_INTERRUPT_MASK (0);
631 }
632
633 /* History */
634
635 void
reset_history(void)636 reset_history (void)
637 {
638 prev_restore_history_offset = 0;
639 history_register
640 = (((VECTOR_P (fixed_objects))
641 && ((READ_DUMMY_HISTORY ()) != SHARP_F))
642 ? (OBJECT_ADDRESS (READ_DUMMY_HISTORY ()))
643 : (make_dummy_history ()));
644 }
645
646 SCHEME_OBJECT *
make_dummy_history(void)647 make_dummy_history (void)
648 {
649 SCHEME_OBJECT * rib = Free;
650 (Free[RIB_EXP]) = SHARP_F;
651 (Free[RIB_ENV]) = SHARP_F;
652 (Free[RIB_NEXT_REDUCTION])
653 = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, rib));
654 Free += 3;
655 {
656 SCHEME_OBJECT * history = Free;
657 (Free[HIST_RIB])
658 = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, rib));
659 (Free[HIST_NEXT_SUBPROBLEM])
660 = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history));
661 (Free[HIST_PREV_SUBPROBLEM])
662 = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history));
663 Free += 3;
664 return (history);
665 }
666 }
667
668 /* save_history places a restore history frame on the stack. Such a
669 frame consists of a normal continuation frame plus a pointer to the
670 stacklet on which the last restore history is located and the
671 offset within that stacklet. If the last restore history is in
672 this stacklet then the history pointer is #F to signify this. If
673 there is no previous restore history then the history pointer is #F
674 and the offset is 0. */
675
676 void
save_history(unsigned long rc)677 save_history (unsigned long rc)
678 {
679 Will_Push (HISTORY_SIZE);
680 STACK_PUSH (SHARP_F); /* Prev_Restore_History_Stacklet */
681 STACK_PUSH (ULONG_TO_FIXNUM (prev_restore_history_offset));
682 SET_EXP (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history_register));
683 SET_RC (rc);
684 SAVE_CONT ();
685 Pushed ();
686 history_register = (OBJECT_ADDRESS (READ_DUMMY_HISTORY ()));
687 }
688
689 /* restore_history pops a history object off the stack and makes a
690 copy of it the current history collection object. This is called
691 only from the RC_RESTORE_HISTORY case in "interp.c". */
692
693 bool
restore_history(SCHEME_OBJECT hist_obj)694 restore_history (SCHEME_OBJECT hist_obj)
695 {
696 SCHEME_OBJECT new_hist = (copy_history (hist_obj));
697 if (new_hist == SHARP_F)
698 return (false);
699 history_register = (OBJECT_ADDRESS (new_hist));
700 return (true);
701 }
702
703 /* The entire trick to history is right here: it is either copied or
704 reused when restored. Initially, stop_history marks the stack so
705 that the history will merely be popped and reused. On a catch,
706 however, the return code is changed to force the history to be
707 copied instead. Thus, histories saved as part of a control point
708 are not side-effected in the history collection process. */
709
710 void
stop_history(void)711 stop_history (void)
712 {
713 SCHEME_OBJECT exp = GET_EXP;
714 SCHEME_OBJECT ret = GET_RET;
715 SAVE_HISTORY (RC_RESTORE_DONT_COPY_HISTORY);
716 prev_restore_history_offset = (STACK_N_PUSHED + CONTINUATION_RETURN_CODE);
717 SET_RET (ret);
718 SET_EXP (exp);
719 }
720
721 void
new_subproblem(SCHEME_OBJECT expression,SCHEME_OBJECT environment)722 new_subproblem (SCHEME_OBJECT expression, SCHEME_OBJECT environment)
723 {
724 history_register = (OBJECT_ADDRESS (history_register[HIST_NEXT_SUBPROBLEM]));
725 HISTORY_MARK (history_register[HIST_MARK]);
726 {
727 SCHEME_OBJECT * rib = (OBJECT_ADDRESS (history_register[HIST_RIB]));
728 HISTORY_MARK (rib[RIB_MARK]);
729 (rib[RIB_ENV]) = environment;
730 (rib[RIB_EXP]) = expression;
731 }
732 }
733
734 void
reuse_subproblem(SCHEME_OBJECT expression,SCHEME_OBJECT environment)735 reuse_subproblem (SCHEME_OBJECT expression, SCHEME_OBJECT environment)
736 {
737 SCHEME_OBJECT * rib = (OBJECT_ADDRESS (history_register[HIST_RIB]));
738 HISTORY_MARK (rib[RIB_MARK]);
739 (rib[RIB_ENV]) = environment;
740 (rib[RIB_EXP]) = expression;
741 }
742
743 void
new_reduction(SCHEME_OBJECT expression,SCHEME_OBJECT environment)744 new_reduction (SCHEME_OBJECT expression, SCHEME_OBJECT environment)
745 {
746 SCHEME_OBJECT * rib
747 = (OBJECT_ADDRESS
748 (MEMORY_REF ((history_register[HIST_RIB]), RIB_NEXT_REDUCTION)));
749 (history_register[HIST_RIB])
750 = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, rib));
751 (rib[RIB_ENV]) = (environment);
752 (rib[RIB_EXP]) = (expression);
753 HISTORY_UNMARK (rib[RIB_MARK]);
754 }
755
756 void
end_subproblem(void)757 end_subproblem (void)
758 {
759 HISTORY_UNMARK (history_register[HIST_MARK]);
760 history_register = (OBJECT_ADDRESS (history_register[HIST_PREV_SUBPROBLEM]));
761 }
762
763 void
compiler_new_subproblem(void)764 compiler_new_subproblem (void)
765 {
766 new_subproblem (SHARP_F, (MAKE_RETURN_CODE (RC_POP_FROM_COMPILED_CODE)));
767 }
768
769 void
compiler_new_reduction(void)770 compiler_new_reduction (void)
771 {
772 new_reduction (SHARP_F, (MAKE_RETURN_CODE (RC_POP_FROM_COMPILED_CODE)));
773 }
774
775 /* Returns SHARP_F if insufficient space available. */
776
777 static SCHEME_OBJECT
copy_history(SCHEME_OBJECT hist_obj)778 copy_history (SCHEME_OBJECT hist_obj)
779 {
780 unsigned long space_left, vert_type, rib_type;
781 SCHEME_OBJECT new_hunk, * last_hunk, * hist_ptr, * orig_hist, temp;
782 SCHEME_OBJECT * orig_rib, * source_rib, * rib_slot;
783
784 assert (HUNK3_P (hist_obj));
785
786 space_left = (SPACE_BEFORE_GC ());
787 if (space_left < 3)
788 return (SHARP_F);
789 space_left -= 3;
790
791 vert_type = (OBJECT_TYPE (hist_obj));
792 orig_hist = (OBJECT_ADDRESS (hist_obj));
793 hist_ptr = orig_hist;
794 last_hunk = (heap_end - 3);
795
796 do
797 {
798 /* Allocate and link the vertebra. */
799 if (space_left < 3)
800 return (SHARP_F);
801 space_left -= 3;
802
803 new_hunk = (MAKE_POINTER_OBJECT (vert_type, Free));
804 (last_hunk[HIST_NEXT_SUBPROBLEM]) = new_hunk;
805
806 (Free[HIST_PREV_SUBPROBLEM])
807 = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (hist_ptr[HIST_PREV_SUBPROBLEM])),
808 last_hunk));
809 last_hunk = Free;
810 Free += 3;
811
812 /* Copy the rib. */
813 temp = (hist_ptr[HIST_RIB]);
814 rib_type = (OBJECT_TYPE (temp));
815 orig_rib = (OBJECT_ADDRESS (temp));
816 rib_slot = (last_hunk + HIST_RIB);
817
818 source_rib = orig_rib;
819
820 do
821 {
822 if (space_left < 3)
823 return (SHARP_F);
824 space_left -= 3;
825
826 (*rib_slot) = (MAKE_POINTER_OBJECT (rib_type, Free));
827 (Free[RIB_EXP]) = (source_rib[RIB_EXP]);
828 (Free[RIB_ENV]) = (source_rib[RIB_ENV]);
829 rib_slot = (Free + RIB_NEXT_REDUCTION);
830 Free += 3;
831 temp = (source_rib[RIB_NEXT_REDUCTION]);
832 rib_type = (OBJECT_TYPE (temp));
833 source_rib = (OBJECT_ADDRESS (temp));
834 }
835 while (source_rib != orig_rib);
836
837 (*rib_slot) = (OBJECT_NEW_TYPE (rib_type, (last_hunk[HIST_RIB])));
838
839 temp = (hist_ptr[HIST_NEXT_SUBPROBLEM]);
840 vert_type = (OBJECT_TYPE (temp));
841 hist_ptr = (OBJECT_ADDRESS (temp));
842 }
843 while (hist_ptr != orig_hist);
844
845 new_hunk = (heap_end [HIST_NEXT_SUBPROBLEM - 3]);
846 (last_hunk[HIST_NEXT_SUBPROBLEM]) = (OBJECT_NEW_TYPE (vert_type, new_hunk));
847 MEMORY_SET (new_hunk, HIST_PREV_SUBPROBLEM,
848 (MAKE_POINTER_OBJECT
849 ((OBJECT_TYPE (hist_ptr[HIST_PREV_SUBPROBLEM])),
850 last_hunk)));
851 return (new_hunk);
852 }
853
854 /* If a "debugging" version of the interpreter is made, then this
855 procedure is called to actually invoke a primitive. When a
856 "production" version is made, all of the consistency checks are
857 omitted and a macro from "interp.h" is used to directly code the
858 call to the primitive function. */
859
860 #ifdef ENABLE_DEBUGGING_TOOLS
861
862 void
primitive_apply_internal(SCHEME_OBJECT primitive)863 primitive_apply_internal (SCHEME_OBJECT primitive)
864 {
865 if (Primitive_Debug)
866 Print_Primitive (primitive);
867 #if 0
868 {
869 SCHEME_OBJECT * saved_stack = stack_pointer;
870 PRIMITIVE_APPLY_INTERNAL (primitive);
871 /* Some primitives violate this condition, for example,
872 WITH-INTERRUPT-MASK. */
873 if (saved_stack != stack_pointer)
874 {
875 unsigned long arity = (PRIMITIVE_N_ARGUMENTS (primitive));
876 Print_Expression (primitive, "Stack bad after ");
877 outf_fatal ("\nStack was %#lx, now %#lx, #args=%lu.\n",
878 ((unsigned long) saved_stack),
879 ((unsigned long) stack_pointer),
880 arity);
881 Microcode_Termination (TERM_EXIT);
882 }
883 }
884 #else
885 PRIMITIVE_APPLY_INTERNAL (primitive);
886 #endif
887 if (Primitive_Debug)
888 {
889 Print_Expression (GET_VAL, "Primitive Result");
890 outf_error("\n");
891 outf_flush_error();
892 }
893 }
894
895 #endif /* ENABLE_DEBUGGING_TOOLS */
896
897 #ifdef ENABLE_PRIMITIVE_PROFILING
898
899 /* The profiling mechanism is enabled by storing a vector in the fixed
900 objects vector. The vector should be initialized to contain all
901 zeros. */
902
903 void
record_primitive_entry(SCHEME_OBJECT primitive)904 record_primitive_entry (SCHEME_OBJECT primitive)
905 {
906
907 if (VECTOR_P (fixed_objects))
908 {
909 SCHEME_OBJECT table
910 = (VECTOR_REF (fixed_objects, Primitive_Profiling_Table));
911 if (VECTOR_P (table))
912 {
913 unsigned long index = (OBJECT_DATUM (primitive));
914 VECTOR_SET (table,
915 index,
916 (ulong_to_integer
917 (1 + (integer_to_ulong (VECTOR_REF (table, index))))));
918 }
919 }
920 }
921
922 #endif /* ENABLE_PRIMITIVE_PROFILING */
923
924 #ifdef __WIN32__
925
926 #include <windows.h>
927
928 SCHEME_OBJECT
Compiler_Get_Fixed_Objects(void)929 Compiler_Get_Fixed_Objects (void)
930 {
931 return ((VECTOR_P (fixed_objects)) ? fixed_objects : SHARP_F);
932 }
933
934 extern SCHEME_OBJECT Re_Enter_Interpreter (void);
935 extern SCHEME_OBJECT C_call_scheme
936 (SCHEME_OBJECT, long, SCHEME_OBJECT *);
937
938 SCHEME_OBJECT
C_call_scheme(SCHEME_OBJECT proc,long n_args,SCHEME_OBJECT * argvec)939 C_call_scheme (SCHEME_OBJECT proc,
940 long n_args,
941 SCHEME_OBJECT * argvec)
942 {
943 SCHEME_OBJECT primitive, prim_lexpr, * sp, result;
944 SCHEME_OBJECT * callers_last_return_code;
945
946 #ifdef CC_IS_NATIVE
947 extern void * C_Frame_Pointer;
948 extern void * C_Stack_Pointer;
949 void * cfp = C_Frame_Pointer;
950 void * csp = C_Stack_Pointer;
951 #ifdef CL386
952 __try
953 #endif
954 #endif
955 {
956 primitive = GET_PRIMITIVE;
957 prim_lexpr = GET_LEXPR_ACTUALS;
958 callers_last_return_code = last_return_code;
959
960 if (! (PRIMITIVE_P (primitive)))
961 abort_to_interpreter (ERR_CANNOT_RECURSE);
962 /*NOTREACHED*/
963 sp = stack_pointer;
964
965 Will_Push ((2 * CONTINUATION_SIZE) + (n_args + STACK_ENV_EXTRA_SLOTS + 1));
966 {
967 long i;
968
969 SET_RC (RC_END_OF_COMPUTATION);
970 SET_EXP (primitive);
971 SAVE_CONT ();
972
973 for (i = n_args; --i >= 0; )
974 STACK_PUSH (argvec[i]);
975 STACK_PUSH (proc);
976 PUSH_APPLY_FRAME_HEADER (n_args);
977
978 SET_RC (RC_INTERNAL_APPLY);
979 SET_EXP (SHARP_F);
980 SAVE_CONT ();
981 }
982 Pushed ();
983 result = (Re_Enter_Interpreter ());
984
985 if (stack_pointer != sp)
986 signal_error_from_primitive (ERR_STACK_HAS_SLIPPED);
987 /*NOTREACHED*/
988
989 last_return_code = callers_last_return_code;
990 SET_LEXPR_ACTUALS (prim_lexpr);
991 SET_PRIMITIVE (primitive);
992 }
993 #ifdef CC_IS_NATIVE
994 #ifdef CL386
995 __finally
996 #endif
997 {
998 C_Frame_Pointer = cfp;
999 C_Stack_Pointer = csp;
1000 }
1001 #endif
1002
1003 return result;
1004 }
1005
1006 #endif /* __WIN32__ */
1007
1008 void
set_ptr_register(unsigned int index,SCHEME_OBJECT * p)1009 set_ptr_register (unsigned int index, SCHEME_OBJECT * p)
1010 {
1011 (Registers[index]) = ((SCHEME_OBJECT) p);
1012 }
1013
1014 void
set_ulong_register(unsigned int index,unsigned long value)1015 set_ulong_register (unsigned int index, unsigned long value)
1016 {
1017 (Registers[index]) = ((SCHEME_OBJECT) value);
1018 }
1019