1 /*
2 * Error-Handling for CLISP
3 * Bruno Haible 1990-2005, 2009, 2017
4 * Marcus Daniels 8.4.1994
5 * Sam Steingold 1998-2012, 2017
6 * German comments translated into English: Stefan Kain 2002-09-11
7 */
8
9 #include "lispbibl.c"
10
11 /* SYS::*RECURSIVE-ERROR-COUNT* =
12 depth of recursion of the output of error messages */
13
cancel_interrupts(void)14 local void cancel_interrupts (void) {
15 #ifdef PENDING_INTERRUPTS
16 interrupt_pending = false; /* Ctrl-C pending time is soon completed */
17 #ifndef WIN32_NATIVE
18 begin_system_call();
19 #ifdef HAVE_UALARM
20 ualarm(0,0); /* abort SIGALRM timer */
21 #else
22 alarm(0); /* abort SIGALRM timer */
23 #endif
24 end_system_call();
25 #endif
26 #endif
27 }
28
29 /* UP: Starts the output of an error message.
30 begin_error()
31 < STACK_0: Stream (in general *ERROR-OUTPUT*)
32 < STACK_1: value of *error-handler*
33 < STACK_2: list of arguments for *error-handler*
34 < STACK_3: type of condition (in general SIMPLE-ERROR) or NIL
35 decreases STACK by 7 */
begin_error(void)36 local void begin_error (void)
37 {
38 end_system_call(); /* there is no system call running anymore */
39 cancel_interrupts();
40 STOP_WRITING_TO_SUBPROCESS;
41 /* make sure *ERROR-OUTPUT* is valid */
42 var_stream(S(error_output),strmflags_wr_ch_B);
43 if (!posfixnump(Symbol_value(S(recursive_error_count)))) /* should be a fixnum >=0 */
44 Symbol_value(S(recursive_error_count)) = Fixnum_0; /* otherwise emergency correction */
45 /* increase error-count, if >3 abort output: */
46 dynamic_bind(S(recursive_error_count),
47 fixnum_inc(Symbol_value(S(recursive_error_count)),1));
48 if (posfixnum_to_V(Symbol_value(S(recursive_error_count))) > 3) {
49 /* multiple nested error message. */
50 Symbol_value(S(recursive_error_count)) = Fixnum_0; /* delete error count */
51 /* bind *PRINT-PRETTY* to NIL (in order to save memory): */
52 dynamic_bind(S(print_pretty),NIL);
53 error(serious_condition,
54 /* Note: All translations of this error message should be in
55 pure ASCII, to avoid endless recursion if *terminal-encoding*
56 supports only ASCII characters. */
57 GETTEXT("Unprintable error message"));
58 }
59 var object error_handler = Symbol_value(S(error_handler)); /* *ERROR-HANDLER* */
60 if (!nullp(error_handler)) { /* *ERROR-HANDER* /= NIL */
61 pushSTACK(NIL); pushSTACK(NIL); pushSTACK(error_handler);
62 pushSTACK(make_string_output_stream()); /* String-Output-Stream */
63 } else if (nullpSv(use_clcs)) { /* SYS::*USE-CLCS* */
64 /* *ERROR-HANDER* = NIL, SYS::*USE-CLCS* = NIL */
65 pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL);
66 pushSTACK(var_stream(S(error_output),strmflags_wr_ch_B)); /* Stream *ERROR-OUTPUT* */
67 fresh_line(&STACK_0); /* new line */
68 write_sstring(&STACK_0,O(error_string1)); /* print "*** - " */
69 } else { /* *ERROR-HANDER* = NIL, SYS::*USE-CLCS* /= NIL */
70 pushSTACK(S(simple_error)); pushSTACK(NIL); pushSTACK(unbound);
71 pushSTACK(make_string_output_stream()); /* String-Output-Stream */
72 }
73 }
74
75 /* UP: output an error-object. */
write_errorobject(object obj)76 local void write_errorobject (object obj) {
77 if (nullp(STACK_1)) {
78 dynamic_bind(S(prin_stream),unbound); /* bind SYS::*PRIN-STREAM* to #<UNBOUND> */
79 dynamic_bind(S(print_escape),T); /* bind *PRINT-ESCAPE* to T */
80 dynamic_bind(S(print_readably),NIL); /* bind *PRINT-READABLY* to NIL */
81 prin1(&STACK_(0+3+3+3),obj); /* output directly */
82 dynamic_unbind(S(print_readably));
83 dynamic_unbind(S(print_escape));
84 dynamic_unbind(S(prin_stream));
85 } else {
86 /* push obj onto the argument list: */
87 pushSTACK(obj);
88 obj = allocate_cons();
89 Car(obj) = popSTACK();
90 Cdr(obj) = STACK_2; STACK_2 = obj;
91 /* and write "~S" into the format string: */
92 write_ascii_char(&STACK_0,'~'); write_ascii_char(&STACK_0,'S');
93 }
94 }
95
96 /* UP: outputs an error-character. */
write_errorchar(object obj)97 local void write_errorchar (object obj) {
98 if (nullp(STACK_1)) {
99 write_char(&STACK_0,obj); /* write directly */
100 } else { /* push obj on the argument list: */
101 pushSTACK(obj);
102 obj = allocate_cons();
103 Car(obj) = popSTACK();
104 Cdr(obj) = STACK_2; STACK_2 = obj;
105 /* and write "~A" into the format string: */
106 write_ascii_char(&STACK_0,'~'); write_ascii_char(&STACK_0,'A');
107 }
108 }
109
110 /* UP: Outputs a piece of an error string without modifications.
111 write_errorasciz_substring(start,end);
112 > start, end: delimit an unmovable string in UTF-8 encoding */
write_errorasciz_substring(const uintB * start,const uintB * end)113 local void write_errorasciz_substring (const uintB* start, const uintB* end)
114 {
115 #ifdef ENABLE_UNICODE
116 var object encoding = O(internal_encoding);
117 var const uintB* bptr = start;
118 var const uintB* bendptr = end;
119 var uintL clen = Encoding_mblen(encoding)(encoding,bptr,bendptr);
120 if (clen > 0) {
121 var DYNAMIC_ARRAY(charbuf,chart,clen);
122 {
123 var chart* cptr = &charbuf[0];
124 var chart* cendptr = cptr+clen;
125 Encoding_mbstowcs(encoding)(encoding,nullobj,&bptr,
126 bendptr,&cptr,cendptr);
127 ASSERT(cptr == cendptr);
128 }
129 {
130 var const chart* cptr = &charbuf[0];
131 dotimespL(clen,clen, { write_code_char(&STACK_0,*cptr); cptr++; });
132 }
133 FREE_DYNAMIC_ARRAY(charbuf);
134 }
135 #else
136 var const uintB* bptr = start;
137 while (bptr != end) {
138 write_code_char(&STACK_0,as_chart(*bptr));
139 bptr++;
140 }
141 #endif
142 }
143
144 /* UP: Outputs an errorstring unchanged.
145 write_errorasciz(asciz);
146 > asciz: errorstring (a non-relocatable ASCIZ-string), in UTF-8 Encoding */
write_errorasciz(const char * asciz)147 local void write_errorasciz (const char* asciz) {
148 write_errorasciz_substring((const uintB*)asciz,
149 (const uintB*)(asciz + asciz_length(asciz)));
150 }
151
152 /* UP: Outputs an errorstring. At each tilde-S '~S' an object from the stack
153 is printed, at each tilde-C '~C' a character from the stack is printed.
154 write_errorstring(errorstring)
155 > STACK_0: Stream etc.
156 > errorstring: Errorstring (an non-relocatable ASCIZ-string),
157 in UTF-8 Encoding
158 > STACK_7, STACK_8, ...: arguments (for each '~S' resp. '~C' one argument),
159 in reversed order as with FUNCALL !
160 < result: STACK-value above the stream and the arguments */
write_errorstring(const char * errorstring)161 local gcv_object_t* write_errorstring (const char* errorstring)
162 {
163 var gcv_object_t* argptr = args_end_pointer STACKop 7; /* pointer above stream and frame */
164 while (1) {
165 var char ch = *errorstring; /* next character */
166 if (ch==0) /* string finished? */
167 break;
168 if (ch=='~') { /* tilde? */
169 if (errorstring[1]=='S') {
170 /* print an object from stack: */
171 write_errorobject(BEFORE(argptr));
172 errorstring += 2;
173 continue;
174 }
175 if (errorstring[1]=='C') {
176 /* print a character from stack: */
177 write_errorchar(BEFORE(argptr));
178 errorstring += 2;
179 continue;
180 }
181 pushSTACK(asciz_to_string(errorstring,Symbol_value(S(utf_8))));
182 error(error_condition,
183 GETTEXT("internal error or error in message catalog: invalid low-level format string ~S"));
184 }
185 /* output all characters until the next special character */
186 var const char* ptr = errorstring;
187 while (1) {
188 ptr++;
189 ch = *ptr;
190 if (ch==0 || ch=='~')
191 break;
192 }
193 write_errorasciz_substring((const uintB*)errorstring,(const uintB*)ptr);
194 errorstring = ptr;
195 }
196 return argptr;
197 }
198
199 /* SIGNAL the CONDITION and INVOKE the debugger */
signal_and_debug(object condition)200 local _Noreturn void signal_and_debug (object condition) {
201 if (quit_on_signal_in_progress) /* if we are terminating on sighup, */
202 quit(); /* printing the "exiting" messages will fail */
203 pushSTACK(condition); /* save condition */
204 dynamic_bind(S(print_escape),T); /* bind *PRINT-ESCAPE* to NIL */
205 dynamic_bind(S(print_readably),NIL); /* bind *PRINT-READABLY* to NIL */
206 pushSTACK(condition); funcall(L(clcs_signal),1); /* (SIGNAL condition) */
207 dynamic_bind(S(prin_stream),unbound); /* bind SYS::*PRIN-STREAM* to #<UNBOUND> */
208 pushSTACK(STACK_(0+3+3+3)); /* condition */
209 funcall(L(invoke_debugger),1); /* (INVOKE-DEBUGGER condition) */
210 NOTREACHED;
211 }
212
213 /* finishes the output of an error message and starts a new driver,
214 (when start_driver_p is true)
215 can trigger GC */
end_error(gcv_object_t * stackptr,bool start_driver_p)216 local maygc void end_error (gcv_object_t* stackptr, bool start_driver_p) {
217 #ifdef MULTITHREAD
218 /* NB: just for debugging - but for now in the release as well.
219 this code is for checking whether there is no part of the runtime
220 that will signal an error while it is considered to be in safe for GC
221 region. Seems there are such possibilities in the xxxaux.d and socket.d.
222 Hope to catch all of them here (it is possible to miss some cases
223 however). */
224 if (spinlock_tryacquire(¤t_thread()->_gc_suspend_ack)) {
225 /* this should never happen - we always hold this lock unless we are in
226 blocking system call (or waiting for the GC) */
227 fprint(stderr,"*** thread is going into lisp land without calling end_blocking_call()\n");
228 abort();
229 }
230 if (current_thread()->_suspend_count) {
231 /* hmm aren't we supposed to be suspended? if we are here - there
232 is GC running NOW */
233 fprint(stderr,"*** thread is going into lisp land while GC in progress.\n");
234 abort();
235 }
236 #endif
237 elastic_newline(&STACK_0);
238 if (nullp(STACK_1)) {
239 /* *ERROR-HANDER* = NIL, SYS::*USE-CLCS* = NIL */
240 skipSTACK(4); /* error message has already been printed */
241 /* unbind binding frame for sys::*recursive-error-count*,
242 because no error message output is active */
243 dynamic_unbind(S(recursive_error_count));
244 set_args_end_pointer(stackptr);
245 break_driver(false); /* call break-driver (does not return) */
246 } else {
247 STACK_0 = get_output_stream_string(&STACK_0);
248 var object arguments = nreverse(STACK_2);
249 /* stack layout: type, args, handler, errorstring. */
250 if (boundp(STACK_1)) {
251 /* *ERROR-HANDER* /= NIL
252 stack layout: nil, args, handler, errorstring.
253 execute (apply *error-handler* nil errorstring args): */
254 check_SP(); check_STACK();
255 {
256 var object error_handler = STACK_1; STACK_1 = NIL;
257 apply(error_handler,2,arguments);
258 skipSTACK(2);
259 }
260 /* unbind binding frame for sys::*recursive-error-count*,
261 because no error message output is active */
262 dynamic_unbind(S(recursive_error_count));
263 set_args_end_pointer(stackptr);
264 if (start_driver_p)
265 break_driver(false); /* call break-driver (does not return) */
266 } else {
267 /* *ERROR-HANDER* = NIL, SYS::*USE-CLCS* /= NIL
268 stack layout: type, args, --, errorstring. */
269 var object type = STACK_3;
270 var object errorstring = STACK_0;
271 skipSTACK(4);
272 dynamic_unbind(S(recursive_error_count));
273 /* execute (APPLY #'coerce-to-condition errorstring args
274 'error type keyword-arguments) */
275 pushSTACK(errorstring); pushSTACK(arguments);
276 pushSTACK(S(error)); pushSTACK(type);
277 var uintC argcount = 4;
278 /* arithmetic-error, division-by-zero, floating-point-overflow,
279 floating-point-underflow --> complete :operation, :operands */
280 if (eq(type,S(simple_arithmetic_error))
281 || eq(type,S(simple_division_by_zero))
282 || eq(type,S(simple_floating_point_overflow))
283 || eq(type,S(simple_floating_point_underflow))) {
284 pushSTACK(S(Koperands)); pushSTACK(BEFORE(stackptr)); /* :operands */
285 pushSTACK(S(Koperation)); pushSTACK(BEFORE(stackptr)); /* :operation */
286 argcount += 4;
287 }
288 /* cell-error, uncound-variable, undefined-function, unbound-slot
289 --> complete :name */
290 if (eq(type,S(simple_cell_error))
291 || eq(type,S(simple_unbound_variable))
292 || eq(type,S(simple_undefined_function))
293 || eq(type,S(simple_unbound_slot))) {
294 pushSTACK(S(Kname)); pushSTACK(BEFORE(stackptr)); /* :name ... */
295 argcount += 2;
296 }
297 /* unbound-slot --> complete :instance */
298 if (eq(type,S(simple_unbound_slot))) {
299 pushSTACK(S(Kinstance)); pushSTACK(BEFORE(stackptr)); /* :instance ... */
300 argcount += 2;
301 }
302 /* type-error, keyword-error --> complete :datum, :expected-type */
303 if (eq(type,S(simple_type_error))
304 || eq(type,S(simple_keyword_error))
305 || eq(type,S(simple_charset_type_error))) {
306 pushSTACK(S(Kexpected_type)); pushSTACK(BEFORE(stackptr)); /* :expected-type ... */
307 pushSTACK(S(Kdatum)); pushSTACK(BEFORE(stackptr)); /* :datum ... */
308 argcount += 4;
309 }
310 /* argument-list-dotted --> complete :datum */
311 if (eq(type,S(simple_argument_list_dotted))) {
312 pushSTACK(S(Kexpected_type)); pushSTACK(S(list)); /* :expected-type 'LIST */
313 pushSTACK(S(Kdatum)); pushSTACK(BEFORE(stackptr)); /* :datum ... */
314 argcount += 4;
315 }
316 /* package-error --> complete :package */
317 if (eq(type,S(simple_package_error))) {
318 pushSTACK(S(Kpackage)); pushSTACK(BEFORE(stackptr)); /* :package ... */
319 argcount += 2;
320 }
321 /* print-not-readable --> complete :object */
322 if (eq(type,S(simple_print_not_readable))) {
323 pushSTACK(S(Kobject)); pushSTACK(BEFORE(stackptr)); /* :object */
324 argcount += 2;
325 }
326 /* stream-error, reader-error, end-of-file --> complete :stream */
327 if (eq(type,S(simple_stream_error))
328 || eq(type,S(simple_reader_error))
329 || eq(type,S(simple_end_of_file))) {
330 pushSTACK(S(Kstream)); pushSTACK(BEFORE(stackptr)); /* :stream ... */
331 argcount += 2;
332 }
333 /* os-stream-error --> complete :stream & :code */
334 if (eq(type,S(os_stream_error))) {
335 STACK_3 = NIL; /* reset errstring */
336 pushSTACK(S(Kcode)); pushSTACK(BEFORE(stackptr)); /* :code ... */
337 pushSTACK(S(Kstream)); pushSTACK(BEFORE(stackptr)); /* :stream ... */
338 argcount += 4;
339 }
340 /* file-error --> complete :pathname */
341 if (eq(type,S(simple_file_error))) {
342 pushSTACK(S(Kpathname)); pushSTACK(BEFORE(stackptr)); /* :pathname ... */
343 argcount += 2;
344 }
345 /* os-file-error --> complete :pathname & :code */
346 if (eq(type,S(os_file_error))) {
347 STACK_3 = NIL; /* reset errstring */
348 pushSTACK(S(Kcode)); pushSTACK(BEFORE(stackptr)); /* :code ... */
349 pushSTACK(S(Kpathname)); pushSTACK(BEFORE(stackptr)); /* :pathname ... */
350 argcount += 4;
351 }
352 /* os-error --> complete :code */
353 if (eq(type,S(os_error))
354 #if defined(WIN32_NATIVE)
355 || eq(type,S(os_error_win32))
356 #endif
357 ) {
358 STACK_3 = NIL; /* reset errstring */
359 pushSTACK(S(Kcode)); pushSTACK(BEFORE(stackptr)); /* :code ... */
360 argcount += 2;
361 }
362 /* source-program-error --> complete :detail */
363 if (eq(type,S(simple_source_program_error))) {
364 pushSTACK(S(Kdetail)); pushSTACK(BEFORE(stackptr)); /* :detail ... */
365 argcount += 2;
366 }
367 funcall(S(coerce_to_condition),argcount); /* SYS::COERCE-TO-CONDITION */
368 set_args_end_pointer(stackptr);
369 if (start_driver_p)
370 signal_and_debug(value1);
371 }
372 }
373 }
374
375 /* helper -- see doc for error() */
prepare_error(condition_t errortype,const char * errorstring,bool start_driver_p)376 local void prepare_error (condition_t errortype, const char* errorstring,
377 bool start_driver_p)
378 { /* the common part of error(), check_value() &c */
379 begin_error(); /* start error message */
380 if (!nullp(STACK_3)) { /* *ERROR-HANDLER* = NIL, SYS::*USE-CLCS* /= NIL ? */
381 /* choose error-type-symbol for errortype: */
382 var object sym = S(simple_condition); /* first error-type */
383 sym = objectplus(sym,
384 (soint)(sizeof(*TheSymbol(sym))
385 <<(oint_addr_shift-addr_shift))
386 * (uintL)errortype);
387 STACK_3 = sym;
388 }
389 end_error(write_errorstring(errorstring),start_driver_p); /* finish */
390 }
391
392 /* Error message with Errorstring. Does not return.
393 error(errortype,errorstring);
394 > errortype: condition type
395 > errorstring: Constant ASCIZ-string, in UTF-8 Encoding.
396 At each tilde-S a LISP-object is taken from STACK and printed instead of
397 the tilde-S.
398 > on the STACK: initialization values for the condition,
399 according to errortype */
error(condition_t errortype,const char * errorstring)400 modexp _Noreturn void error (condition_t errortype, const char* errorstring) {
401 prepare_error(errortype,errorstring,true); /* finish error message */
402 /* there is no point in using the condition system here:
403 we will get into an infinite loop reporting the error */
404 fprintf(stderr,"[%s:%d] cannot handle the fatal error due to a fatal error in the fatal error handler!\n",__FILE__,__LINE__);
405 abort();
406 /* NOTREACHED; */
407 }
408
409 /* Report an error and try to recover by asking the user to supply a value.
410 check_value(errortype,errorstring);
411 > errortype: condition-type
412 > errorstring: constant ASCIZ-String, in UTF-8 Encoding.
413 At every tilde-S, a LISP-object is taken from the STACK and printed
414 instead of the tilde-S.
415 > on the STACK: PLACE (form to be shown to the user) or NIL, then
416 the initial values for the Condition, depending on error-type
417 < value1, value2: return values from CHECK-VALUE:
418 value1 = value supplied by the user, as is, not evaluated.
419 This does present a problem when the object does not have a readable
420 syntax (e.g., a stream or a CLOS object). The workaround is to use [#.].
421 We can discuss calling eval1(value1) at the end of this function.
422 value2 = indicates whether PLACE should be filled
423 < STACK: cleaned up
424 can trigger GC */
check_value(condition_t errortype,const char * errorstring)425 modexp maygc void check_value (condition_t errortype, const char* errorstring)
426 {
427 prepare_error(errortype,errorstring,nullpSv(use_clcs));
428 /* if SYS::*USE-CLCS* /= NIL, use CHECK-VALUE */
429 pushSTACK(value1); /* place is already on the stack! */
430 funcall(S(check_value),2);
431 }
432
433 /* Report an error and try to recover by asking the user to choose among some
434 alternatives.
435 correctable_error(errortype,errorstring);
436 > errortype: condition-type
437 > errorstring: constant ASCIZ-String, in UTF-8 Encoding.
438 At every tilde-S, a LISP-object is taken from the STACK and printed
439 instead of the tilde-S.
440 > on the STACK: list of alternatives
441 ((restart-name restart-help-string . value-returned-by-the-restart)*),
442 then the initial values for the Condition, depending on error-type
443 < value1: return value from CORRECTABLE-ERROR, one of the CDDRs of the
444 alternatives
445 < STACK: cleaned up
446 can trigger GC */
correctable_error(condition_t errortype,const char * errorstring)447 global maygc void correctable_error (condition_t errortype, const char* errorstring)
448 {
449 prepare_error(errortype,errorstring,nullpSv(use_clcs));
450 /* if SYS::*USE-CLCS* /= NIL, use CORRECTABLE-ERROR */
451 pushSTACK(value1); /* options are already on the stack! */
452 funcall(S(correctable_error),2);
453 }
454
455 #if defined(WIN32_NATIVE) || defined(HAVE_DLOPEN)
456 typedef object error_code_converter_t (long code);
457 static error_code_converter_t *ecc_a = (error_code_converter_t*)1;
convert_error_code(long code,error_code_converter_t ** ecc,const char * name)458 local object convert_error_code (long code, error_code_converter_t **ecc,
459 const char* name) {
460 if (*ecc == (error_code_converter_t*)1)
461 *ecc = (error_code_converter_t*)find_name(NULL,name);
462 if (*ecc)
463 return (*ecc)(code);
464 return L_to_I(code);
465 }
466 #define ANSIC_error_code_converter(e) \
467 convert_error_code(e,&ecc_a,"errno_to_symbol_a")
468 #else
469 #define ANSIC_error_code_converter(e) L_to_I(e)
470 #endif /* WIN32_NATIVE || HAVE_DLOPEN */
471 #if defined(WIN32_NATIVE)
472 static error_code_converter_t *ecc_w = (error_code_converter_t*)1;
473 #define WINDOWS_error_code_converter(e) \
474 convert_error_code(e,&ecc_w,"errno_to_symbol_w")
475 #endif
476
477 #undef OS_error
478 #undef OS_error_arg
479 #undef OS_filestream_error
480
481 #if defined(WIN32_NATIVE) || defined(UNIX_CYGWIN)
format_message(DWORD errcode)482 local char * format_message (DWORD errcode) {
483 char* ret;
484 begin_system_call();
485 var int status = FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER |
486 FORMAT_MESSAGE_FROM_SYSTEM |
487 FORMAT_MESSAGE_IGNORE_INSERTS,
488 NULL, errcode, 0, (LPTSTR)&ret, 0, NULL);
489 end_system_call();
490 if (status == 0)
491 return NULL;
492 /* strip terminating spaces, newlines and periods to conform to strerror */
493 while (cint_white_p(ret[status-1]) || ret[status-1] == '.')
494 status--;
495 ret[status] = 0;
496 return ret;
497 }
498 #endif
499
500 #ifdef UNIX
501 /* Define OS_error, OS_error_arg. */
502 #include "errunix.c"
503 #else
504 /* Define just ANSIC_error. */
505 #define OS_error ANSIC_error
506 #define OS_error_internal ANSIC_error_internal
507 #include "errunix.c"
508 #undef OS_error_internal
509 #undef OS_error
510 #endif /* UNIX */
511
512 #ifdef WIN32_NATIVE
513 #include "errwin32.c"
514 #endif
515
516 #if defined(WIN32_NATIVE) || defined(UNIX_CYGWIN)
517 LISPFUNNF(format_message,1) {
518 DWORD error_code = I_to_uint32(check_uint32(popSTACK()));
519 char *msg = format_message(error_code);
520 if (msg) {
521 VALUES1(asciz_to_string(msg,O(misc_encoding)));
522 begin_system_call();
523 LocalFree(msg);
524 end_system_call();
525 } VALUES1(NIL);
526 }
527 #endif
528
529 /* Just like OS_error, but takes a channel stream and signals a FILE-ERROR.
530 OS_filestream_error(stream);
531 > stream: a channel stream
532 > end_system_call() already called */
OS_filestream_error(object stream)533 modexp _Noreturn void OS_filestream_error (object stream) {
534 if (streamp(stream)) {
535 if (TheStream(stream)->strmtype == strmtype_file
536 && !nullp(TheStream(stream)->strm_file_truename))
537 OS_error_arg(S(os_file_error),TheStream(stream)->strm_file_truename);
538 else OS_error_arg(S(os_stream_error),stream);
539 } else {
540 OS_error();
541 }
542 }
543
544 LISPFUN(error,seclass_default,1,0,rest,nokey,0,NIL)
545 /* (ERROR errorstring {expr})
546 Does not return.
547 (defun error (errorstring &rest args)
548 (if (or *error-handler* (not *use-clcs*))
549 (progn
550 (if *error-handler*
551 (apply *error-handler* nil errorstring args)
552 (progn
553 (fresh-line *error-output*)
554 (write-string "*** - " *error-output*)
555 (apply #'format *error-output* errorstring args)
556 (elastic-newline *error-output*)))
557 (funcall *break-driver* nil))
558 (let ((condition (coerce-to-condition errorstring args 'error
559 'simple-error)))
560 (signal condition)
561 (invoke-debugger condition)))) */
562 {
563 if (!nullpSv(error_handler) || nullpSv(use_clcs)) {
564 begin_error(); /* start error message */
565 rest_args_pointer skipSTACKop 1; /* pointer to the arguments */
566 if (nullp(STACK_1)) {
567 /* write error message:
568 (FORMAT *ERROR-OUTPUT* errorstring {expr})
569 (ELASTIC-NEWLINE *ERROR-OUTPUT*) */
570 var object stream = STACK_0;
571 skipSTACK(4);
572 pushSTACK(stream);
573 pushSTACK(stream);
574 {
575 var gcv_object_t* ptr = rest_args_pointer;
576 var uintC count;
577 dotimespC(count,1+argcount, { pushSTACK(NEXT(ptr)); } );
578 }
579 funcall(S(format),2+argcount);
580 funcall(L(elastic_newline),1);
581 } else {
582 /* write error message:
583 ({handler} nil errorstring {expr}) */
584 var object fun = STACK_1;
585 skipSTACK(4);
586 pushSTACK(NIL);
587 {
588 var gcv_object_t* ptr = rest_args_pointer;
589 var uintC count;
590 dotimespC(count,1+argcount, { pushSTACK(NEXT(ptr)); } );
591 }
592 funcall(fun,2+argcount);
593 }
594 /* finish error message, cf. end_error(): */
595 dynamic_unbind(S(recursive_error_count)); /* no error message output is active */
596 set_args_end_pointer(rest_args_pointer); /* clean up STACK */
597 break_driver(false); /* call break-driver (does not return) */
598 } else {
599 {
600 var object arguments = listof(argcount);
601 pushSTACK(arguments);
602 }
603 pushSTACK(S(error));
604 pushSTACK(S(simple_error));
605 funcall(S(coerce_to_condition),4); /* (SYS::COERCE-TO-CONDITION ...) */
606 signal_and_debug(value1);
607 }
608 NOTREACHED;
609 }
610
611 /* (SYSTEM::%DEFCLCS error-types)
612 sets the data needed for ERROR-OF-TYPE. */
613 LISPFUNN(defclcs,1)
614 {
615 O(error_types) = check_vector(popSTACK());
616 var int i;
617 var Symbol conditions = &(symbol_tab.S_simple_condition);
618 var gcv_object_t* et_data = TheSvector(O(error_types))->data;
619 for (i=0; i < number_of_conditions_defined_in_c; i++)
620 ASSERT(eq(Symbol_name(Cdr(et_data[i])),conditions[i].pname));
621 ASSERT(Svector_length(O(error_types)) == number_of_conditions_defined_in_c);
622 VALUES0;
623 }
624
625 /* Converts a condition type into the corresponding Simple-Condition. */
convert_simple_condition(object type)626 local object convert_simple_condition (object type) {
627 /* traverse vector O(error_types) like an Alist: */
628 var object v = O(error_types);
629 var uintL count = Svector_length(v);
630 if (count > 0) {
631 var gcv_object_t* ptr = &TheSvector(v)->data[0];
632 dotimespL(count,count, {
633 if (eq(type,Car(*ptr)))
634 return Cdr(*ptr);
635 ptr++;
636 });
637 }
638 return type; /* not found -> leave type unchanged */
639 }
640
641 LISPFUN(cerror_of_type,seclass_default,3,0,rest,nokey,0,NIL)
642 /* (SYSTEM::CERROR-OF-TYPE continue-format-string type {keyword value}*
643 error-format-string {arg}*)
644 (defun cerror-of-type (continue-format-string type &rest arguments)
645 (let ((keyword-arguments '()))
646 (loop
647 (unless (and (consp arguments) (symbolp (car arguments))) (return))
648 (push (pop arguments) keyword-arguments)
649 (push (pop arguments) keyword-arguments))
650 (setq keyword-arguments (nreverse keyword-arguments))
651 (let ((error-format-string (first arguments))
652 (args (rest arguments)))
653 (apply #'cerror
654 continue-format-string
655 (if (or *error-handler* (not *use-clcs*))
656 error-format-string
657 (apply #'coerce-to-condition error-format-string args
658 'cerror (convert-simple-condition type) keyword-arguments))
659 args)))) */
660 {
661 var gcv_object_t* cfstring_ = &Next(rest_args_pointer STACKop 3);
662 var uintC keyword_argcount = 0;
663 rest_args_pointer skipSTACKop 1; /* pointer to the arguments behind type */
664 while (argcount>=2) {
665 var object next_arg = Next(rest_args_pointer); /* next argument */
666 if (!symbolp(next_arg)) /* keyword? */
667 break;
668 rest_args_pointer skipSTACKop -2; argcount -= 2; keyword_argcount += 2;
669 }
670 /* next argument is hopefully a string. */
671 if (!nullpSv(error_handler) || nullpSv(use_clcs)) {
672 /* the type and the keyword-arguments are ignored. */
673 BEFORE(rest_args_pointer) = *cfstring_;
674 funcall(S(cerror),argcount+2);
675 skipSTACK(keyword_argcount+1);
676 } else {
677 var object arguments = listof(argcount);
678 /* stack layout: continue-format-string, type, {keyword, value}*,
679 errorstring.
680 rearrange the stack a little bit: */
681 var object errorstring = STACK_0;
682 pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL);
683 {
684 var gcv_object_t* ptr2 = args_end_pointer;
685 var gcv_object_t* ptr1 = ptr2 STACKop 4;
686 var uintC count;
687 dotimesC(count,keyword_argcount, { BEFORE(ptr2) = BEFORE(ptr1); } );
688 BEFORE(ptr2) = convert_simple_condition(BEFORE(ptr1));
689 BEFORE(ptr2) = S(cerror);
690 BEFORE(ptr2) = arguments;
691 BEFORE(ptr2) = errorstring;
692 BEFORE(ptr2) = arguments;
693 }
694 /* stack layout: continue-format-string, arguments, errorstring, args,
695 CERROR, type, {keyword, value}*. */
696 funcall(S(coerce_to_condition),4+keyword_argcount); /* (SYS::COERCE-TO-CONDITION ...) */
697 /* stack layout: continue-format-string, arguments. */
698 arguments = STACK_0;
699 STACK_0 = value1;
700 apply(S(cerror),2,arguments); /* (CERROR continue-format-string condition ...) */
701 }
702 }
703
704 LISPFUN(error_of_type,seclass_default,2,0,rest,nokey,0,NIL)
705 /* (SYSTEM::ERROR-OF-TYPE type {keyword value}* errorstring {expr}*)
706 does not return.
707 (defun error-of-type (type &rest arguments)
708 ;; split off keyword arguments from the &rest arguments:
709 (let ((keyword-arguments '()))
710 (loop
711 (unless (and (consp arguments) (symbolp (car arguments))) (return))
712 (push (pop arguments) keyword-arguments)
713 (push (pop arguments) keyword-arguments))
714 (setq keyword-arguments (nreverse keyword-arguments))
715 (let ((errorstring (first arguments))
716 (args (rest arguments)))
717 (if (or *error-handler* (not *use-clcs*))
718 (progn
719 (if *error-handler*
720 (apply *error-handler* nil errorstring args)
721 (progn
722 (fresh-line *error-output*)
723 (write-string "*** - " *error-output*)
724 (apply #'format *error-output* errorstring args)
725 (elastic-newline *error-output*)))
726 (funcall *break-driver* nil))
727 (let ((condition
728 (apply #'coerce-to-condition errorstring args
729 'error (convert-simple-condition type)
730 keyword-arguments)))
731 (signal condition)
732 (invoke-debugger condition)))))) */
733 {
734 var uintC keyword_argcount = 0;
735 rest_args_pointer skipSTACKop 1; /* pointer to the arguments behind type */
736 while (argcount>=2) {
737 var object next_arg = Next(rest_args_pointer); /* next argument */
738 if (!symbolp(next_arg)) /* keyword? */
739 break;
740 rest_args_pointer skipSTACKop -2; argcount -= 2; keyword_argcount += 2;
741 }
742 /* next argument is hopefully a string. */
743 if (!nullpSv(error_handler) || nullpSv(use_clcs)) {
744 /* the type and the keyword-arguments are ignored. */
745 begin_error(); /* start error message */
746 if (nullp(STACK_1)) {
747 /* write error message:
748 (FORMAT *ERROR-OUTPUT* errorstring {expr})
749 (ELASTIC-NEWLINE *ERROR-OUTPUT*) */
750 var object stream = STACK_0;
751 skipSTACK(4);
752 pushSTACK(stream);
753 pushSTACK(stream);
754 {
755 var gcv_object_t* ptr = rest_args_pointer;
756 var uintC count;
757 dotimespC(count,1+argcount, { pushSTACK(NEXT(ptr)); } );
758 }
759 funcall(S(format),2+argcount);
760 funcall(L(elastic_newline),1);
761 } else {
762 /* write error message:
763 ({handler} nil errorstring {expr}) */
764 var object fun = STACK_1;
765 skipSTACK(4);
766 pushSTACK(NIL);
767 {
768 var gcv_object_t* ptr = rest_args_pointer;
769 var uintC count;
770 dotimespC(count,1+argcount, { pushSTACK(NEXT(ptr)); } );
771 }
772 funcall(fun,2+argcount);
773 }
774 /* finish error message, cf. end_error(): */
775 dynamic_unbind(S(recursive_error_count)); /* no error message output is active */
776 set_args_end_pointer(rest_args_pointer); /* clean up STACK */
777 break_driver(false); /* call break-driver (does not return) */
778 } else {
779 var object arguments = listof(argcount);
780 /* stack layout: type, {keyword, value}*, errorstring.
781 rearrange the stack a little bit: */
782 var object errorstring = STACK_0;
783 pushSTACK(NIL); pushSTACK(NIL);
784 {
785 var gcv_object_t* ptr2 = args_end_pointer;
786 var gcv_object_t* ptr1 = ptr2 STACKop 3;
787 var uintC count;
788 dotimesC(count,keyword_argcount, { BEFORE(ptr2) = BEFORE(ptr1); } );
789 BEFORE(ptr2) = convert_simple_condition(BEFORE(ptr1));
790 BEFORE(ptr2) = S(error);
791 BEFORE(ptr2) = arguments;
792 BEFORE(ptr2) = errorstring;
793 }
794 /* stack layout: errorstring, args, ERROR, type, {keyword, value}*. */
795 funcall(S(coerce_to_condition),4+keyword_argcount); /* (SYS::COERCE-TO-CONDITION ...) */
796 signal_and_debug(value1);
797 }
798 NOTREACHED;
799 }
800
801 LISPFUNN(invoke_debugger,1)
802 /* (INVOKE-DEBUGGER condition), CLtL2 p. 915
803 does not return.
804 (defun invoke-debugger (condition)
805 (when *debugger-hook*
806 (let ((debugger-hook *debugger-hook*)
807 (*debugger-hook* nil))
808 (funcall debugger-hook condition debugger-hook)))
809 (funcall *break-driver* nil condition t)) */
810 {
811 var object hook = Symbol_value(S(debugger_hook));
812 if (!nullp(hook)) {
813 var object condition = STACK_0;
814 dynamic_bind(S(debugger_hook),NIL); /* bind *DEBUGGER-HOOK* to NIL */
815 pushSTACK(condition); pushSTACK(hook); funcall(hook,2); /* call Debugger-Hook */
816 dynamic_unbind(S(debugger_hook));
817 }
818 /* *BREAK-DRIVER* can be assumed here as /= NIL. */
819 pushSTACK(NIL); pushSTACK(STACK_(0+1)); pushSTACK(T);
820 funcall(Symbol_value(S(break_driver)),3); /* call break-driver */
821 reset(1); /* returns unexpectedly -> back to the next loop */
822 NOTREACHED;
823 }
824
825 /* UP: Executes a break-loop because of keyboard interrupt.
826 > STACK_0 : calling function
827 changes STACK, can trigger GC */
tast_break(void)828 global maygc void tast_break (void)
829 {
830 #if !defined(MULTITHREAD)
831 cancel_interrupts();
832 STOP_WRITING_TO_SUBPROCESS;
833 if (!nullpSv(error_handler) || nullpSv(use_clcs)) {
834 /* simulate begin_error(), 7 elements on the STACK: */
835 pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL);
836 pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL);
837 pushSTACK(var_stream(S(debug_io),strmflags_wr_ch_B)); /* Stream *DEBUG-IO* */
838 fresh_line(&STACK_0); /* new line */
839 write_sstring(&STACK_0,O(error_string1)); /* print "*** - " */
840 /* print string, consume caller names, clean up STACK: */
841 set_args_end_pointer(write_errorstring(GETTEXT("~S: User break")));
842 break_driver(true); /* call break-driver */
843 } else {
844 pushSTACK(CLSTEXT("Continue execution"));
845 pushSTACK(S(simple_interrupt_condition)); /* SYSTEM::[SIMPLE-]INTERRUPT-CONDITION */
846 pushSTACK(CLSTEXT("~S: User break"));
847 pushSTACK(STACK_(0+3)); /* caller */
848 funcall(L(cerror_of_type),4); /* (SYS::CERROR-OF-TYPE "..." 'SYSTEM::[SIMPLE-]INTERRUPT-CONDITION "..." caller) */
849 skipSTACK(1);
850 }
851 #else
852 /* in MT - just clear the STACK */
853 /* it will be very rare to get called here - since the interruptp()
854 does not expand to anything in MT and most use of tast_break() was
855 from it.*/
856 skipSTACK(1);
857 #endif
858 }
859
860 LISPFUN(clcs_signal,seclass_default,1,0,rest,nokey,0,NIL)
861 /* (SIGNAL datum {arg}*), CLtL2 p. 888
862 (defun signal (datum &rest arguments)
863 (let ((condition ; CLtL2 p. 918 specifies this
864 (coerce-to-condition datum arguments 'signal
865 'simple-condition)))
866 (when (typep condition *break-on-signals*)
867 ; Enter the debugger prior to signalling the condition
868 (restart-case (invoke-debugger condition)
869 (CONTINUE ())))
870 (invoke-handlers condition)
871 nil)) */
872 {
873 {
874 var object arguments = listof(argcount);
875 pushSTACK(arguments);
876 }
877 pushSTACK(S(clcs_signal));
878 pushSTACK(S(simple_condition));
879 funcall(S(coerce_to_condition),4); /* (SYS::COERCE-TO-CONDITION ...) */
880 pushSTACK(value1); /* save condition */
881 pushSTACK(value1); pushSTACK(Symbol_value(S(break_on_signals)));
882 funcall(S(safe_typep),2); /* (SYS::SAFE-TYPEP condition *BREAK-ON-SIGNALS*) */
883 if (!nullp(value1)) {
884 /* call break-driver: (funcall *break-driver* t condition t)
885 *BREAK-DRIVER* can be assumed here as /= NIL . */
886 pushSTACK(T); pushSTACK(STACK_(0+1)); pushSTACK(T);
887 funcall(Symbol_value(S(break_driver)),3);
888 }
889 var object condition = popSTACK(); /* condition back */
890 /* (CATCH 'SYS::DONE-SIGNALING ...). This can be used by handlers to override
891 all other applicable handlers.
892 Build CATCH frame: */
893 pushSTACK(S(done_signaling));
894 var gcv_object_t* top_of_frame = STACK STACKop 1; /* pointer above frame */
895 var sp_jmp_buf returner; /* memorize return point */
896 finish_entry_frame(CATCH,returner,, goto catch_return; );
897 /* Call handlers: */
898 invoke_handlers(condition);
899 catch_return: /* we jump to this label, if the catch-frame built
900 above has caught a throw. */
901 skipSTACK(3); /* unwind CATCH-frame */
902 VALUES1(NIL);
903 }
904
905 /* check_classname(obj,type)
906 > obj: an object
907 > classname: a symbol expected to name a class with "proper name" classname
908 < result: an object of the given type, either the same as obj or a replacement
909 can trigger GC */
check_classname(object obj,object type)910 modexp maygc object check_classname (object obj, object type) {
911 while (!typep_classname(obj,type)) {
912 pushSTACK(type); /* save type */
913 pushSTACK(NIL); /* no PLACE */
914 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
915 pushSTACK(type); /* TYPE-ERROR slot EXPECTED-TYPE */
916 pushSTACK(type); pushSTACK(obj);
917 pushSTACK(TheSubr(subr_self)->name);
918 check_value(type_error,GETTEXT("~S: ~S is not of type ~S"));
919 obj = value1; type = popSTACK();
920 }
921 return obj;
922 }
923
924 #ifdef FOREIGN
925 /* check_fpointer_replacement(obj,restart_p)
926 > obj: an object
927 > restart_p: flag whether to allow entering a replacement
928 < result: a valid foreign pointer, either the same as obj or a replacement
929 can trigger GC */
check_fpointer_replacement(object obj,bool restart_p)930 modexp maygc object check_fpointer_replacement (object obj, bool restart_p) {
931 for (;;) {
932 if (!fpointerp(obj)) {
933 pushSTACK(NIL); /* no PLACE */
934 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
935 pushSTACK(S(foreign_pointer)); /* TYPE-ERROR slot EXPECTED-TYPE */
936 pushSTACK(S(foreign_pointer)); pushSTACK(obj);
937 pushSTACK(TheSubr(subr_self)->name);
938 if (restart_p)
939 check_value(type_error,GETTEXT("~S: ~S is not a ~S"));
940 else
941 error(type_error,GETTEXT("~S: ~S is not a ~S"));
942 obj = value1;
943 continue;
944 }
945 if (!fp_validp(TheFpointer(obj))) {
946 pushSTACK(NIL); /* no PLACE */
947 pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
948 if (restart_p)
949 check_value(error_condition,GETTEXT("~S: ~S comes from a previous Lisp session and is invalid"));
950 else
951 error(error_condition,GETTEXT("~S: ~S comes from a previous Lisp session and is invalid"));
952 obj = value1;
953 continue;
954 }
955 break;
956 }
957 return obj;
958 }
959 #endif
960
961 /* error-message, if an object is not a list.
962 error_list(obj);
963 > obj: non-list */
error_list(object obj)964 modexp _Noreturn void error_list (object obj) {
965 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
966 pushSTACK(S(list)); /* TYPE-ERROR slot EXPECTED-TYPE */
967 pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
968 error(type_error,GETTEXT("~S: ~S is not a list"));
969 }
970
971 /* define a global check_TYPE_replacement function
972 > name: type name
973 > expected_type: object O(...)
974 > test: test for the acceptability of the replacement value
975 > error_message: C string GETTEXT(...) */
976 #define MAKE_CHECK_REPLACEMENT(typename,expected_type,test,error_message) \
977 modexp maygc object check_##typename##_replacement (object obj) { \
978 do { \
979 pushSTACK(NIL); /* no PLACE */ \
980 pushSTACK(obj); /* TYPE-ERROR slot DATUM */ \
981 pushSTACK(expected_type); /* TYPE-ERROR slot EXPECTED-TYPE */ \
982 pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); \
983 check_value(type_error,error_message); \
984 obj = value1; \
985 } while (!test(obj)); \
986 return obj; \
987 }
988
989 /* check_list_replacement(obj)
990 > obj: not a list
991 < result: a list, a replacement
992 can trigger GC */
993 MAKE_CHECK_REPLACEMENT(list,S(list),listp,GETTEXT("~S: ~S is not a list"))
994
995 /* Error message, if an object isn't a proper list because it is dotted.
996 error_proper_list_dotted(caller,obj);
997 > caller: the caller (a symbol)
998 > obj: end of the list, non-list */
error_proper_list_dotted(object caller,object obj)999 modexp _Noreturn void error_proper_list_dotted (object caller, object obj) {
1000 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1001 pushSTACK(O(type_proper_list)); /* TYPE-ERROR slot EXPECTED-TYPE */
1002 pushSTACK(obj); pushSTACK(caller);
1003 error(type_error,GETTEXT("~S: A proper list must not end with ~S"));
1004 }
1005
1006 /* Error message, if an object isn't a proper list because it is circular.
1007 error_proper_list_circular(caller,obj);
1008 > caller: the caller (a symbol)
1009 > obj: circular list */
error_proper_list_circular(object caller,object obj)1010 global _Noreturn void error_proper_list_circular (object caller, object obj) {
1011 dynamic_bind(S(print_circle),T); /* bind *PRINT-CIRCLE* to T */
1012 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1013 pushSTACK(O(type_proper_list)); /* TYPE-ERROR slot EXPECTED-TYPE */
1014 pushSTACK(obj); pushSTACK(caller);
1015 error(type_error,GETTEXT("~S: A proper list must not be circular: ~S"));
1016 }
1017
1018 /* return the name of the current caller (subr or fsubr)
1019 this is only necessary for error signaled from both. */
caller_name(void)1020 local inline object caller_name (void) {
1021 var object caller = subr_self;
1022 return subrp(caller) ? TheSubr(caller)->name : TheFsubr(caller)->name;
1023 }
1024
1025 /* check_symbol_replacement(obj)
1026 > obj: not a symbol
1027 < result: a symbol, a replacement
1028 can trigger GC */
check_symbol_replacement(object obj)1029 global maygc object check_symbol_replacement (object obj) {
1030 do {
1031 pushSTACK(NIL); /* no PLACE */
1032 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1033 pushSTACK(S(symbol)); /* TYPE-ERROR slot EXPECTED-TYPE */
1034 pushSTACK(obj); pushSTACK(caller_name());
1035 check_value(type_error,GETTEXT("~S: ~S is not a symbol"));
1036 obj = value1;
1037 } while (!symbolp(obj));
1038 return obj;
1039 }
1040
1041 /* check_symbol_non_constant_replacement(obj)
1042 > obj: not a non-constant symbol
1043 > caller: a symbol
1044 < result: a non-constant symbol, a replacement
1045 can trigger GC */
check_symbol_non_constant_replacement(object obj,object caller)1046 global maygc object check_symbol_non_constant_replacement
1047 (object obj, object caller) {
1048 for (;;) {
1049 obj = check_symbol(obj);
1050 if (!constant_var_p(TheSymbol(obj))) break;
1051 pushSTACK(NIL); /* no PLACE */
1052 pushSTACK(obj); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1053 pushSTACK(obj); pushSTACK(caller);
1054 check_value(source_program_error,
1055 GETTEXT("~S: ~S is a constant, may not be used as a variable"));
1056 obj = value1;
1057 }
1058 return obj;
1059 }
1060
1061 /* UP: signal an error if a non-symbol was declared (e.g. SPECIAL)
1062 returns the symbol
1063 can trigger GC */
check_symbol_in_declaration(object obj,object decl_identifier,object caller)1064 global maygc object check_symbol_in_declaration (object obj, object decl_identifier, object caller) {
1065 while (!symbolp(obj)) {
1066 pushSTACK(decl_identifier); pushSTACK(caller);
1067 pushSTACK(NIL); /* no PLACE */
1068 pushSTACK(obj); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1069 pushSTACK(decl_identifier); pushSTACK(obj); pushSTACK(caller);
1070 check_value(source_program_error,
1071 GETTEXT("~S: ~S is not a symbol, cannot be declared ~S"));
1072 caller = popSTACK(); decl_identifier = popSTACK();
1073 obj = value1;
1074 }
1075 return obj;
1076 }
1077
1078 /* UP: make sure that the symbol does not name a global symbol-macro
1079 return the symbol
1080 can trigger GC */
check_symbol_not_symbol_macro(object symbol)1081 global maygc object check_symbol_not_symbol_macro (object symbol) {
1082 symbol = check_symbol(symbol);
1083 if (symmacro_var_p(TheSymbol(symbol))) {
1084 pushSTACK(symbol); /* save */
1085 pushSTACK(NIL); /* 4 continue-format-string */
1086 pushSTACK(S(simple_program_error)); /* 3 error-type */
1087 pushSTACK(NIL); /* 2 error-format-string */
1088 pushSTACK(TheSubr(subr_self)->name); /* 1 */
1089 pushSTACK(symbol); /* 0 */
1090 /* CLSTEXT "can trigger GC", so it cannot be called until
1091 all the arguments have been already pushed on the STACK */
1092 STACK_4 = CLSTEXT("Remove the global SYMBOL-MACRO definition");
1093 if (eq(subr_self,L(proclaim)))
1094 STACK_2 = CLSTEXT("~S: attempting to turn ~S into a SPECIAL variable, but it is already a global SYMBOL-MACRO.");
1095 else if (eq(subr_self,L(proclaim_constant)))
1096 STACK_2 = CLSTEXT("~S: attempting to turn ~S into a constant, but it is already a global SYMBOL-MACRO.");
1097 else STACK_2 = CLSTEXT("~S: interning ~S into the KEYWORD package would turn it into a constant, but it is already a global SYMBOL-MACRO.");
1098 funcall(L(cerror_of_type),5);
1099 /* continue restart ==> remove SYMBOL-MACRO definition */
1100 pushSTACK(STACK_0); /* save symbol */
1101 clear_symmacro_flag(TheSymbol(STACK_0/*symbol*/));
1102 pushSTACK(S(symbolmacro)); funcall(L(remprop),2);
1103 symbol = popSTACK();
1104 }
1105 return symbol;
1106 }
1107
1108 /* UP: make sure that the symbol does not name a global special variable
1109 return the symbol
1110 can trigger GC */
check_symbol_not_global_special(object symbol)1111 global maygc object check_symbol_not_global_special (object symbol) {
1112 symbol = check_symbol(symbol);
1113 if (keywordp(symbol)) {
1114 pushSTACK(symbol); pushSTACK(TheSubr(subr_self)->name);
1115 error(program_error,
1116 GETTEXT("~S: the symbol ~S names a global SPECIAL variable"));
1117 }
1118 if (special_var_p(TheSymbol(symbol))) {
1119 pushSTACK(symbol); /* save */
1120 pushSTACK(NIL); /* 4 continue-format-string */
1121 pushSTACK(S(simple_program_error)); /* 3 error-type */
1122 pushSTACK(NIL); /* 2 error-format-string */
1123 pushSTACK(TheSubr(subr_self)->name); /* 1 */
1124 pushSTACK(symbol); /* 0 */
1125 /* CLSTEXT "can trigger GC", so it cannot be called until
1126 all the arguments have been already pushed on the STACK */
1127 STACK_4 = CLSTEXT("Remove the global SPECIAL variable binding");
1128 STACK_2 = CLSTEXT("~S: the symbol ~S names a global SPECIAL variable");
1129 funcall(L(cerror_of_type),5);
1130 /* continue restart ==> remove the global SPECIAL binding */
1131 symbol = popSTACK();
1132 Symbol_value(symbol) = unbound;
1133 clear_special_flag(TheSymbol(symbol));
1134 clear_const_flag(TheSymbol(symbol));
1135 }
1136 return symbol;
1137 }
1138
1139 /* error-message, if an object is not a simple-vector.
1140 error_no_svector(caller,obj);
1141 > caller: caller (a symbol)
1142 > obj: non-Svector */
error_no_svector(object caller,object obj)1143 modexp _Noreturn void error_no_svector (object caller, object obj) {
1144 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1145 pushSTACK(S(simple_vector)); /* TYPE-ERROR slot EXPECTED-TYPE */
1146 pushSTACK(S(simple_vector)); pushSTACK(obj); pushSTACK(caller);
1147 error(type_error,GETTEXT("~S: ~S is not a ~S"));
1148 }
1149
1150 /* error-message, if an object is not a vector.
1151 error_vector(obj);
1152 > obj: non-vector */
error_vector(object obj)1153 modexp _Noreturn void error_vector (object obj) {
1154 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1155 pushSTACK(S(vector)); /* TYPE-ERROR slot EXPECTED-TYPE */
1156 pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
1157 error(type_error,GETTEXT("~S: ~S is not a vector"));
1158 }
1159
1160 /* check_array_replacement(obj)
1161 > obj: not an array
1162 < result: an array, a replacement
1163 can trigger GC */
1164 MAKE_CHECK_REPLACEMENT(array,S(array),arrayp,
1165 GETTEXT("~S: argument ~S is not an array"))
1166
1167 /* check_vector_replacement(obj)
1168 > obj: not an vector
1169 < result: an vector, a replacement
1170 can trigger GC */
1171 MAKE_CHECK_REPLACEMENT(vector,S(vector),vectorp,
1172 GETTEXT("~S: argument ~S is not a vector"))
1173
1174 /* check_byte_vector_replacement(obj)
1175 > obj: not an (ARRAY (UNSIGNED-BYTE 8) (*))
1176 < result: an (ARRAY (UNSIGNED-BYTE 8) (*)), a replacement
1177 can trigger GC */
check_byte_vector_replacement(object obj)1178 modexp maygc object check_byte_vector_replacement (object obj) {
1179 do {
1180 pushSTACK(NIL); /* no PLACE */
1181 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1182 pushSTACK(O(type_uint8_vector)); /* TYPE-ERROR slot EXPECTED-TYPE */
1183 pushSTACK(O(type_uint8_vector)); pushSTACK(obj);
1184 pushSTACK(TheSubr(subr_self)->name);
1185 check_value(type_error,GETTEXT("~S: argument ~S is not a vector of type ~S"));
1186 obj = value1;
1187 } while (!bit_vector_p(Atype_8Bit,obj));
1188 return obj;
1189 }
1190
1191
1192 /* error-message, if an object is not an environment.
1193 error_environment(obj);
1194 > obj: non-vector */
error_environment(object obj)1195 global _Noreturn void error_environment (object obj) {
1196 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1197 pushSTACK(O(type_svector5)); /* TYPE-ERROR slot EXPECTED-TYPE */
1198 pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
1199 error(type_error,GETTEXT("~S: ~S may not be used as an environment"));
1200 }
1201
1202 /* error-message, if an argument is not a Fixnum >=0 :
1203 error_posfixnum(obj);
1204 > obj: the erroneous argument */
error_posfixnum(object obj)1205 global _Noreturn void error_posfixnum (object obj) {
1206 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1207 pushSTACK(O(type_posfixnum)); /* TYPE-ERROR slot EXPECTED-TYPE */
1208 pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
1209 error(type_error,GETTEXT("~S: argument ~S is not a nonnegative fixnum"));
1210 }
1211
1212 /* check_posfixnum_replacement(obj)
1213 > obj: not a fixnum >= 0
1214 < result: a fixnum >= 0, a replacement
1215 can trigger GC */
1216 MAKE_CHECK_REPLACEMENT(posfixnum,O(type_posfixnum),posfixnump,
1217 GETTEXT("~S: argument ~S is not a nonnegative fixnum"))
1218
1219 /* check_integer_replacement(obj)
1220 > obj: not an integer
1221 < result: an integer, a replacement
1222 can trigger GC */
1223 MAKE_CHECK_REPLACEMENT(integer,S(integer),integerp,
1224 GETTEXT("~S: ~S is not an integer"))
1225
1226 /* check_pos_integer_replacement(obj)
1227 > obj: not an integer >= 0
1228 < result: an integer >= 0, a replacement
1229 can trigger GC */
check_pos_integer_replacement(object obj)1230 modexp maygc object check_pos_integer_replacement (object obj) {
1231 do {
1232 pushSTACK(NIL); /* no PLACE */
1233 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1234 pushSTACK(O(type_posinteger)); /* TYPE-ERROR slot EXPECTED-TYPE */
1235 pushSTACK(obj);
1236 pushSTACK(TheSubr(subr_self)->name);
1237 check_value(type_error,GETTEXT("~S: ~S is not a non-negative integer"));
1238 obj = value1;
1239 } while (!(integerp(obj) && !R_minusp(obj)));
1240 return obj;
1241 }
1242
1243 /* Error when the argument is not a non-negative integer
1244 YES, we _CAN_ create lists longer than MOST-POSITIVE-FIXNUM!
1245 > kw: keyword naming the argument
1246 > object: bad index */
error_pos_integer(object kw,object obj)1247 global _Noreturn void error_pos_integer (object kw, object obj) {
1248 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1249 pushSTACK(O(type_posinteger)); /* TYPE-ERROR slot EXPECTED-TYPE */
1250 pushSTACK(obj);
1251 if (eq(kw,nullobj)) {
1252 pushSTACK(TheSubr(subr_self)->name);
1253 error(type_error,GETTEXT("~S: index should not be negative: ~S"));
1254 } else {
1255 pushSTACK(kw); pushSTACK(TheSubr(subr_self)->name);
1256 error(type_error,GETTEXT("~S: ~S-index should not be negative: ~S"));
1257 }
1258 }
1259
1260 /* error-message, if an argument is not a Character:
1261 error_char(obj);
1262 > obj: the erroneous argument */
error_char(object obj)1263 global _Noreturn void error_char (object obj) {
1264 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1265 pushSTACK(S(character)); /* TYPE-ERROR slot EXPECTED-TYPE */
1266 pushSTACK(obj);
1267 pushSTACK(TheSubr(subr_self)->name);
1268 error(type_error,GETTEXT("~S: argument ~S is not a character"));
1269 }
1270
1271 /* check_char_replacement(obj)
1272 > obj: not a character
1273 < result: a character, a replacement
1274 can trigger GC */
S(character)1275 MAKE_CHECK_REPLACEMENT(char,S(character),charp,
1276 GETTEXT("~S: argument ~S is not a character"))
1277
1278 /* check_string_replacement(obj)
1279 > obj: not a string
1280 < result: a string, a replacement
1281 can trigger GC */
1282 MAKE_CHECK_REPLACEMENT(string,S(string),stringp,
1283 GETTEXT("~S: argument ~S is not a string"))
1284
1285 /* error-message, if an argument is not a Simple-String:
1286 > obj: the erroneous argument */
1287 modexp _Noreturn void error_sstring (object obj) {
1288 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1289 pushSTACK(S(simple_string)); /* TYPE-ERROR slot EXPECTED-TYPE */
1290 pushSTACK(S(simple_string)); pushSTACK(obj);
1291 pushSTACK(TheSubr(subr_self)->name);
1292 error(type_error,GETTEXT("~S: argument ~S is not a ~S"));
1293 }
1294
1295 /* error-message, if a Simple-String is immutable:
1296 error_sstring_immutable(obj);
1297 > obj: the String */
error_sstring_immutable(object obj)1298 global _Noreturn void error_sstring_immutable (object obj) {
1299 pushSTACK(obj);
1300 error(error_condition,GETTEXT("Attempt to modify a read-only string: ~S"));
1301 }
1302
1303 /* Error message, if an argument is not of type (OR STRING INTEGER).
1304 error_string_integer(obj) */
error_string_integer(object obj)1305 modexp _Noreturn void error_string_integer (object obj) {
1306 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1307 pushSTACK(O(type_string_integer)); /* TYPE-ERROR slot EXPECTED-TYPE */
1308 pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
1309 error(type_error,
1310 GETTEXT("~S: argument ~S is neither a string nor an integer"));
1311 }
1312
1313 /* Error message, if a string size is too big.
1314 error_stringsize(size);
1315 > size: the desired string length */
error_stringsize(uintV size)1316 global _Noreturn void error_stringsize (uintV size) {
1317 var object obj = UV_to_I(size);
1318 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1319 pushSTACK(O(type_stringsize)); /* TYPE-ERROR slot EXPECTED-TYPE */
1320 pushSTACK(obj);
1321 error(type_error,GETTEXT("string too long: desired length ~S exceeds the supported maximum length"));
1322 }
1323
1324 /* error message if an argument is not a class.
1325 error_class(caller,obj);
1326 > obj: the erroneous argument */
error_class(object obj)1327 global _Noreturn void error_class (object obj) {
1328 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1329 pushSTACK(S(class)); /* CLOS:CLASS, TYPE-ERROR slot EXPECTED-TYPE */
1330 pushSTACK(obj);
1331 pushSTACK(TheSubr(subr_self)->name); /* function name */
1332 error(type_error,GETTEXT("~S: ~S is not a class"));
1333 }
1334
1335 /* error-message, if an argument is not a Stream:
1336 check_stream_replacement(obj);
1337 > obj: not a stream
1338 < obj: a stream
1339 can trigger GC */
1340 MAKE_CHECK_REPLACEMENT(stream,S(stream),streamp,
1341 GETTEXT("~S: argument ~S is not a stream"))
1342
1343 /* Report an error when the argument is not an encoding:
1344 > obj: the (possibly) bad argument
1345 > default: what to return for :DEFAULT
1346 > keyword_p: true if the object comes from the :EXTERNAL-FORMAT argument
1347 < result: an encoding
1348 can trigger GC */
check_encoding(object arg,const gcv_object_t * e_default,bool keyword_p)1349 global maygc object check_encoding (object arg, const gcv_object_t *e_default,
1350 bool keyword_p) {
1351 restart:
1352 if (!boundp(arg) || eq(arg,S(Kdefault)))
1353 return *e_default;
1354 if (encodingp(arg))
1355 return arg;
1356 #ifdef ENABLE_UNICODE
1357 if (symbolp(arg) && constant_var_p(TheSymbol(arg))
1358 && encodingp(Symbol_value(arg)))
1359 return Symbol_value(arg);
1360 #ifdef HAVE_GOOD_ICONV
1361 if (stringp(arg)) { /* (make-encoding :charset arg) */
1362 pushSTACK(arg); /* :charset */
1363 pushSTACK(unbound); /* :line-terminator */
1364 pushSTACK(unbound); /* :input-error-action */
1365 pushSTACK(unbound); /* :output-error-action */
1366 pushSTACK(unbound); /* :if-does-not-exist */
1367 C_make_encoding();
1368 return value1;
1369 }
1370 #endif
1371 #else
1372 /* This is a hack to get away without an error. */
1373 if (symbolp(arg) && eq(Symbol_package(arg),O(charset_package)))
1374 return O(default_file_encoding);
1375 #endif
1376 if (eq(arg,S(Kunix)) || eq(arg,S(Kmac)) || eq(arg,S(Kdos))) {
1377 /* (make-encoding :charset default-file-encoding :line-terminator arg) */
1378 pushSTACK(*e_default); /* :charset */
1379 pushSTACK(arg); /* :line-terminator */
1380 pushSTACK(unbound); /* :input-error-action */
1381 pushSTACK(unbound); /* :output-error-action */
1382 pushSTACK(unbound); /* :if-does-not-exist */
1383 C_make_encoding();
1384 return value1;
1385 }
1386 pushSTACK(NIL); /* no PLACE */
1387 pushSTACK(arg); /* TYPE-ERROR slot DATUM */
1388 pushSTACK(O(type_external_format)); /* TYPE-ERROR slot EXPECTED-TYPE */
1389 pushSTACK(arg);
1390 if (keyword_p) pushSTACK(S(Kexternal_format));
1391 pushSTACK(TheSubr(subr_self)->name);
1392 check_value(type_error,
1393 keyword_p ? GETTEXT("~S: Illegal ~S argument ~S")
1394 : GETTEXT("~S: Argument ~S is not a character set"));
1395 arg = value1;
1396 goto restart;
1397 }
1398
1399 /* Signal an Error on illegal argument
1400 > arg: bad object
1401 > typ: expected type (may be nullobj to signal a regular error
1402 instead of a type-error)
1403 > key: the argument name (usually a keyword) */
error_illegal_arg(object arg,object typ,object key)1404 global _Noreturn void error_illegal_arg (object arg, object typ, object key) {
1405 condition_t errtype = error_condition;
1406 if (!eq(typ,nullobj)) {
1407 pushSTACK(arg); /* TYPE-ERROR slot DATUM */
1408 pushSTACK(typ); /* TYPE-ERROR slot EXPECTED-TYPE */
1409 errtype = type_error;
1410 }
1411 pushSTACK(arg); pushSTACK(key); pushSTACK(TheSubr(subr_self)->name);
1412 error(errtype,GETTEXT("~S: Illegal ~S argument ~S"));
1413 }
1414
1415 /* Error when the property list has odd length
1416 error_plist_odd(caller,plist);
1417 > plist: bad plist */
error_plist_odd(object plist)1418 modexp _Noreturn void error_plist_odd (object plist) {
1419 pushSTACK(plist); /* TYPE-ERROR slot DATUM */
1420 pushSTACK(S(plist)); /* TYPE-ERROR slot EXPECTED-TYPE*/
1421 pushSTACK(plist); pushSTACK(TheSubr(subr_self)->name);
1422 error(type_error,GETTEXT("~S: the property list ~S has an odd length"));
1423 }
1424
1425 /* error-message for non-paired keyword-arguments
1426 error_key_odd(argcount,caller);
1427 > argcount: the number of arguments on the STACK
1428 > caller: function */
error_key_odd(uintC argcount,object caller)1429 modexp _Noreturn void error_key_odd (uintC argcount, object caller) {
1430 var uintC count;
1431 pushSTACK(NIL); pushSTACK(NIL);
1432 for (count=0; count<argcount; count++) STACK_(count) = STACK_(count+2);
1433 STACK_(argcount) = caller;
1434 var object arglist = listof(argcount);
1435 STACK_1 = arglist;
1436 /* ANSI CL 3.5.1.6. wants a PROGRAM-ERROR here. */
1437 error(program_error,
1438 GETTEXT("~S: keyword arguments in ~S should occur pairwise"));
1439 }
1440
1441 /* error-message for flawed keyword
1442 error_key_notkw(kw);
1443 > kw: Non-Symbol
1444 > caller: function */
error_key_notkw(object kw,object caller)1445 global _Noreturn void error_key_notkw (object kw, object caller) {
1446 pushSTACK(kw); /* KEYWORD-ERROR slot DATUM */
1447 pushSTACK(S(symbol)); /* KEYWORD-ERROR slot EXPECTED-TYPE */
1448 pushSTACK(kw); pushSTACK(S(LLkey)); pushSTACK(caller);
1449 error(keyword_error,GETTEXT("~S: ~S marker ~S is not a symbol"));
1450 }
1451
1452 /* error-message for flawed keyword
1453 error_key_badkw(fun,kw,kwlist);
1454 > fun: function
1455 > key: illegal keyword
1456 > val: its value
1457 > kwlist: list of legal keywords */
error_key_badkw(object fun,object key,object val,object kwlist)1458 modexp _Noreturn void error_key_badkw (object fun, object key, object val, object kwlist) {
1459 pushSTACK(key); /* KEYWORD-ERROR slot DATUM */
1460 pushSTACK(kwlist);
1461 pushSTACK(kwlist);
1462 pushSTACK(val);
1463 pushSTACK(key);
1464 pushSTACK(fun);
1465 { /* `(MEMBER ,@kwlist) = KEYWORD-ERROR slot EXPECTED-TYPE */
1466 var object type = allocate_cons();
1467 Car(type) = S(member); Cdr(type) = STACK_4;
1468 STACK_4 = type;
1469 }
1470 error(keyword_error,
1471 GETTEXT("~S: illegal keyword/value pair ~S, ~S in argument list.\n"
1472 "The allowed keywords are ~S"));
1473 }
1474
1475 /* check_function_replacement(obj)
1476 > obj: not a function
1477 < result: a function, a replacement
1478 can trigger GC */
check_function_replacement(object obj)1479 global maygc object check_function_replacement (object obj) {
1480 do {
1481 pushSTACK(NIL); /* no PLACE */
1482 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1483 pushSTACK(S(function)); /* TYPE-ERROR slot EXPECTED-TYPE */
1484 pushSTACK(obj);
1485 pushSTACK(TheSubr(subr_self)->name);
1486 check_value(type_error,GETTEXT("~S: ~S is not a function"));
1487 if (symbolp(value1))
1488 obj = Symbol_function(value1);
1489 else if (funnamep(value1)) {
1490 var object name = get(Car(Cdr(value1)),S(setf_function));
1491 if (symbolp(name)) obj = Symbol_function(name);
1492 else obj = value1;
1493 } else if (consp(value1) && eq(Car(value1),S(lambda))) {
1494 pushSTACK(value1); pushSTACK(S(function));
1495 funcall(L(coerce),2);
1496 obj = value1;
1497 } else obj = value1;
1498 } while (!functionp(obj));
1499 return obj;
1500 }
1501
1502 /* error if funname does not have a function definition
1503 check_fdefinition(funname,caller)
1504 > funname: symbol or (setf symbol)
1505 > caller: symbol
1506 < a function object, possibly also installed as (FDEFINITION funname)
1507 can trigger GC */
check_fdefinition(object funname,object caller)1508 global maygc object check_fdefinition (object funname, object caller)
1509 {
1510 var object name = (symbolp(funname) ? funname
1511 : get(Car(Cdr(funname)),S(setf_function)));
1512 var object def = (symbolp(name) ? (object)Symbol_function(name) : unbound);
1513 var bool store_p = false;
1514 while (!functionp(def)) {
1515 pushSTACK(caller); pushSTACK(funname); /* save */
1516 pushSTACK(S(quote)); pushSTACK(funname); def = listof(2);
1517 pushSTACK(S(fdefinition)); pushSTACK(def); def = listof(2);
1518 pushSTACK(def); /* PLACE */
1519 pushSTACK(STACK_1/*funname*/); /* CELL-ERROR Slot NAME */
1520 pushSTACK(STACK_0); /* funname */
1521 pushSTACK(STACK_4); /* caller */
1522 check_value(undefined_function,GETTEXT("~S: undefined function ~S"));
1523 /* value2 selects the restart: 0: CONTINUE, T: STORE-VALUE, else: USE-VALUE
1524 see also condition.lisp:check-value */
1525 store_p = eq(value2,T);
1526 /* this is the only place where check_value()'s second value is checked
1527 for something other than non-NIL */
1528 if (eq(value2,Fixnum_0)) { /* RETRY restart */
1529 funname = STACK_0;
1530 name = (symbolp(funname) ? funname
1531 : get(Car(Cdr(funname)),S(setf_function)));
1532 value1 = (symbolp(name) ? (object)Symbol_function(name) : unbound);
1533 }
1534 funname = popSTACK(); caller = popSTACK(); /* restore */
1535 def = value1;
1536 }
1537 if (store_p) { /* STORE-VALUE restart */
1538 name = (symbolp(funname) ? funname
1539 : get(Car(Cdr(funname)),S(setf_function)));
1540 if (!symbolp(name)) {
1541 pushSTACK(Car(Cdr(funname))); /* the symbol in (setf symbol) */
1542 pushSTACK(def); /* save new function */
1543 pushSTACK(funname); funcall(S(get_funname_symbol),1);
1544 pushSTACK(value1); /* save new name */
1545 pushSTACK(value1); pushSTACK(S(setf_function)); pushSTACK(STACK_4);
1546 funcall(L(put),3); /* (put symbol 'setf-function name) */
1547 name = popSTACK(); def = popSTACK(); /* restore */
1548 skipSTACK(1); /* drop symbol in (setf symbol) */
1549 }
1550 Symbol_function(name) = def;
1551 }
1552 return def;
1553 }
1554
1555 /* check_funname_replacement(obj)
1556 > errtype: type of condition to signal if obj is not a function name,
1557 either type_error or source_program_error
1558 > caller: a symbol
1559 > obj: not a function name
1560 < result: a function name, either the same as obj or a replacement
1561 can trigger GC */
check_funname_replacement(condition_t errtype,object caller,object obj)1562 global maygc object check_funname_replacement
1563 (condition_t errtype, object caller, object obj) {
1564 pushSTACK(caller); /* save */
1565 do {
1566 caller = STACK_0;
1567 pushSTACK(NIL); /* no PLACE */
1568 switch (errtype) {
1569 case type_error:
1570 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1571 pushSTACK(O(type_function_name)); /* slot EXPECTED-TYPE */
1572 break;
1573 case source_program_error:
1574 pushSTACK(obj); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1575 break;
1576 default: NOTREACHED;
1577 }
1578 pushSTACK(obj); pushSTACK(caller);
1579 check_value(errtype,GETTEXT("~S: ~S is not a function name; try using a symbol instead"));
1580 obj = value1;
1581 } while (!funnamep(obj));
1582 skipSTACK(1); /* drop caller */
1583 return obj;
1584 }
1585
1586 /* error-message, if an argument is a lambda-expression instead of a function:
1587 caller: caller (a symbol)
1588 obj: the erroneous argument */
error_lambda_expression(object caller,object obj)1589 global _Noreturn void error_lambda_expression (object caller, object obj) {
1590 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1591 pushSTACK(S(function)); /* TYPE-ERROR slot EXPECTED-TYPE */
1592 pushSTACK(obj); pushSTACK(caller);
1593 error(type_error,
1594 GETTEXT("~S: argument ~S is not a function.\n"
1595 "To get a function in the current environment, write (FUNCTION ...).\n"
1596 "To get a function in the global environment, write (COERCE '... 'FUNCTION)."));
1597 }
1598
1599 /* too many arguments in a function call
1600 > caller : the function that is reporting the error (unbound == EVAL/APPLY)
1601 > func : the function being incorrectly called
1602 > ngiven : the number of arguments given
1603 < nmax : the maximum number of arguments accepted */
error_too_many_args(object caller,object func,uintL ngiven,uintL nmax)1604 global _Noreturn void error_too_many_args (object caller, object func, uintL ngiven, uintL nmax) {
1605 pushSTACK(func);
1606 pushSTACK(fixnum(nmax));
1607 pushSTACK(fixnum(ngiven));
1608 /* ANSI CL 3.5.1.3. wants a PROGRAM-ERROR here. */
1609 if (!boundp(caller))
1610 error(program_error,GETTEXT("EVAL/APPLY: Too many arguments (~S instead of at most ~S) given to ~S"));
1611 else {
1612 pushSTACK(caller);
1613 error(program_error,GETTEXT("~S: Too many arguments (~S instead of at most ~S) given to ~S"));
1614 }
1615 }
1616
1617 /* too few arguments in a function call
1618 > caller : the function that is reporting the error (unbound == EVAL/APPLY)
1619 > func : the function being incorrectly called
1620 > ngiven : the number of arguments given
1621 < nmin : the minimum number of arguments required */
error_too_few_args(object caller,object func,uintL ngiven,uintL nmin)1622 global _Noreturn void error_too_few_args (object caller, object func, uintL ngiven, uintL nmin) {
1623 pushSTACK(func);
1624 pushSTACK(fixnum(nmin));
1625 pushSTACK(fixnum(ngiven));
1626 /* ANSI CL 3.5.1.2. wants a PROGRAM-ERROR here. */
1627 if (!boundp(caller))
1628 error(program_error,GETTEXT("EVAL/APPLY: Too few arguments (~S instead of at least ~S) given to ~S"));
1629 else {
1630 pushSTACK(caller);
1631 error(program_error,GETTEXT("~S: Too few arguments (~S instead of at least ~S) given to ~S"));
1632 }
1633 }
1634
1635 /* error-message, if a symbol has no value.
1636 > symbol_: unbound symbol
1637 > restart_p: false if nonreturning
1638 < value1: bound value
1639 < value2: T if STORE-VALUE was selected, NIL otherwise
1640 can trigger GC */
check_variable_value_replacement(gcv_object_t * symbol_,bool restart_p)1641 global maygc void check_variable_value_replacement (gcv_object_t *symbol_,
1642 bool restart_p) {
1643 do {
1644 if (restart_p) pushSTACK(*symbol_); /* PLACE */
1645 pushSTACK(*symbol_); /* CELL-ERROR Slot NAME */
1646 pushSTACK(*symbol_); pushSTACK(caller_name());
1647 if (restart_p)
1648 check_value(unbound_variable,GETTEXT("~S: variable ~S has no value"));
1649 else error(unbound_variable,GETTEXT("~S: variable ~S has no value"));
1650 } while (!boundp(value1));
1651 }
1652
1653 /* error if an argument is not of a given elementary integer C type.
1654 error_c_integer(obj);
1655 > obj: the faulty argument
1656 > tcode: type code: 0 for int8, 1 for int16, 2 for int32, 3 for int64
1657 > signedp: sint or uint */
prepare_c_integer_signal(object obj,int tcode,bool signedp)1658 local const char* prepare_c_integer_signal (object obj, int tcode, bool signedp)
1659 {
1660 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1661 pushSTACK((signedp?&O(type_sint8):&O(type_uint8))[tcode]); /*EXPECTED-TYPE*/
1662 pushSTACK(fixnum(8<<tcode)); pushSTACK(obj);
1663 pushSTACK(TheSubr(subr_self)->name);
1664 return signedp
1665 ? GETTEXT("~S: argument ~S is not an integer with at most ~S bits (including the sign bit)")
1666 : GETTEXT("~S: argument ~S is not a nonnegative integer with at most ~S bits");
1667 }
error_c_integer(object obj,int tcode,bool signedp)1668 modexp _Noreturn void error_c_integer (object obj, int tcode, bool signedp) {
1669 error(type_error,prepare_c_integer_signal(obj,tcode,signedp));
1670 }
1671
1672 /* get a replacement of a given elementary integer C type.
1673 check_c_integer_replacement(obj)
1674 > obj: not an integer in the range specified by tcode and signedp (see above)
1675 < obj: an integer in the range specified by tcode and signedp
1676 can trigger GC */
check_c_integer_replacement(object obj,int tcode,bool signedp)1677 modexp maygc object check_c_integer_replacement (object obj, int tcode,
1678 bool signedp) {
1679 while (1) {
1680 pushSTACK(NIL); /* no PLACE */
1681 check_value(type_error,prepare_c_integer_signal(obj,tcode,signedp));
1682 obj = value1;
1683 switch (signedp ? tcode : tcode + 4) {
1684 case 0: if (sint8_p(obj)) return obj; else break;
1685 case 1: if (sint16_p(obj)) return obj; else break;
1686 case 2: if (sint32_p(obj)) return obj; else break;
1687 case 3: if (sint64_p(obj)) return obj; else break;
1688 case 4: if (uint8_p(obj)) return obj; else break;
1689 case 5: if (uint16_p(obj)) return obj; else break;
1690 case 6: if (uint32_p(obj)) return obj; else break;
1691 case 7: if (uint64_p(obj)) return obj; else break;
1692 default: NOTREACHED;
1693 }
1694 };
1695 }
1696
1697 #if (int_bitsize==16)
1698 #define uint_type_object O(type_uint16)
1699 #define sint_type_object O(type_sint16)
1700 #else /* (int_bitsize==32) */
1701 #define uint_type_object O(type_uint32)
1702 #define sint_type_object O(type_sint32)
1703 #endif
1704
1705 /* error, if argument is not an integer in the range of the C type 'uint'.
1706 check_uint_replacement(obj)
1707 > obj: not an integer in the range of uint
1708 < obj: an integer in the range of uint
1709 can trigger GC */
1710 MAKE_CHECK_REPLACEMENT(uint,uint_type_object,uint_p,
1711 GETTEXT("~S: ~S is not an `unsigned int' number"))
1712
1713 /* error, if argument is not an integer in the range of the C type 'sint'.
1714 check_sint_replacement(obj)
1715 > obj: not an integer in the range of sint
1716 < obj: an integer in the range of sint
1717 can trigger GC */
1718 MAKE_CHECK_REPLACEMENT(sint,sint_type_object,sint_p,
1719 GETTEXT("~S: ~S is not an `int' number"))
1720
1721 #undef uint_type_object
1722 #undef sint_type_object
1723
1724 #if (long_bitsize==32)
1725 #define ulong_type_object O(type_uint32)
1726 #define slong_type_object O(type_sint32)
1727 #else /* (long_bitsize==64) */
1728 #define ulong_type_object O(type_uint64)
1729 #define slong_type_object O(type_sint64)
1730 #endif
1731
1732 /* error, if argument is not an integer in the range of the C type 'ulong'.
1733 check_ulong_replacement(obj)
1734 > obj: not an integer in the range of ulong
1735 < obj: an integer in the range of ulong
1736 can trigger GC */
1737 MAKE_CHECK_REPLACEMENT(ulong,ulong_type_object,ulong_p,
1738 GETTEXT("~S: ~S is not a `unsigned long' number"))
1739
1740 /* error, if argument is not an integer in the range of the C type 'slong'.
1741 check_slong_replacement(obj)
1742 > obj: not an integer in the range of slong
1743 < obj: an integer in the range of slong
1744 can trigger GC */
1745 MAKE_CHECK_REPLACEMENT(slong,slong_type_object,slong_p,
1746 GETTEXT("~S: ~S is not a `long' number"))
1747
1748 #undef ulong_type_object
1749 #undef slong_type_object
1750
1751 /* error, if argument is not a Single-Float.
1752 check_ffloat_replacement(obj)
1753 > obj: not a single-float
1754 < obj: a single-float
1755 can trigger GC */
1756 MAKE_CHECK_REPLACEMENT(ffloat,S(single_float),single_float_p,
1757 GETTEXT("~S: ~S is not a single-float"))
1758
1759 /* error, if argument is not a Double-Float.
1760 check_dfloat_replacement(obj)
1761 > obj: not a double-float
1762 < obj: a double-float
1763 can trigger GC */
1764 MAKE_CHECK_REPLACEMENT(dfloat,S(double_float),double_float_p,
1765 GETTEXT("~S: ~S is not a double-float"))
1766