1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 1997-2020, University of Amsterdam
7 VU University Amsterdam
8 All rights reserved.
9
10 Redistribution and use in source and binary forms, with or without
11 modification, are permitted provided that the following conditions
12 are met:
13
14 1. Redistributions of source code must retain the above copyright
15 notice, this list of conditions and the following disclaimer.
16
17 2. Redistributions in binary form must reproduce the above copyright
18 notice, this list of conditions and the following disclaimer in
19 the documentation and/or other materials provided with the
20 distribution.
21
22 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
27 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
28 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
29 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
30 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
31 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
32 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33 POSSIBILITY OF SUCH DAMAGE.
34 */
35
36 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
37 throw(error(<Formal>, <SWI-Prolog>))
38
39 <SWI-Prolog> ::= context(Name/Arity, Message)
40 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
41
42 #include "pl-incl.h"
43 #include "pl-comp.h"
44 #include "os/pl-cstack.h"
45 /* BeOS has EACCES defined elsewhere, but errno is here */
46 #if !defined(EACCES) || defined(__BEOS__)
47 #include <errno.h>
48 #endif
49
50 static int
put_name_arity(term_t t,functor_t f)51 put_name_arity(term_t t, functor_t f)
52 { GET_LD
53 FunctorDef fdef = valueFunctor(f);
54 term_t a;
55
56 if ( (a=PL_new_term_refs(2)) )
57 { PL_put_atom(a+0, fdef->name);
58
59 return (PL_put_integer(a+1, fdef->arity) &&
60 PL_cons_functor(t, FUNCTOR_divide2, a+0, a+1));
61 }
62
63 return FALSE;
64 }
65
66
67 static void
rewrite_callable(atom_t * expected,term_t actual)68 rewrite_callable(atom_t *expected, term_t actual)
69 { GET_LD
70 term_t a = 0;
71 int loops = 0;
72
73 while ( PL_is_functor(actual, FUNCTOR_colon2) )
74 { if ( !a )
75 a = PL_new_term_ref();
76
77 _PL_get_arg(1, actual, a);
78 if ( !PL_is_atom(a) )
79 { *expected = ATOM_atom;
80 PL_put_term(actual, a);
81 return;
82 } else
83 { _PL_get_arg(2, actual, a);
84 PL_put_term(actual, a);
85 }
86
87 if ( ++loops > 100 && !PL_is_acyclic(actual) )
88 break;
89 }
90 }
91
92
93 static int
evaluation_error(term_t formal,atom_t which)94 evaluation_error(term_t formal, atom_t which)
95 { GET_LD
96 return PL_unify_term(formal,
97 PL_FUNCTOR, FUNCTOR_evaluation_error1,
98 PL_ATOM, which);
99 }
100
101 int
PL_error(const char * pred,int arity,const char * msg,PL_error_code id,...)102 PL_error(const char *pred, int arity, const char *msg, PL_error_code id, ...)
103 { GET_LD
104 char msgbuf[50];
105 Definition caller;
106 term_t except, formal, swi, msgterm=0;
107 va_list args;
108 int do_throw = FALSE;
109 fid_t fid;
110 int rc;
111
112 if ( exception_term ) /* do not overrule older exception */
113 return FALSE;
114
115 if ( environment_frame )
116 caller = environment_frame->predicate;
117 else
118 caller = NULL;
119
120 if ( id == ERR_FILE_OPERATION &&
121 !truePrologFlag(PLFLAG_FILEERRORS) )
122 fail;
123
124 if ( msg == MSG_ERRNO )
125 { if ( errno == EPLEXCEPTION )
126 return FALSE;
127 msg = OsError();
128 }
129
130 LD->exception.processing = TRUE; /* allow using spare stack */
131
132 if ( !(fid = PL_open_foreign_frame()) )
133 goto nomem;
134
135 except = PL_new_term_ref();
136 formal = PL_new_term_ref();
137 swi = PL_new_term_ref();
138
139 /* build (ISO) formal part */
140 va_start(args, id);
141 switch(id)
142 { case ERR_INSTANTIATION:
143 err_instantiation:
144 rc = PL_unify_atom(formal, ATOM_instantiation_error);
145 break;
146 case ERR_UNINSTANTIATION:
147 { int argn = va_arg(args, int);
148 term_t bound = va_arg(args, term_t);
149
150 if ( !msg && argn > 0 )
151 { Ssprintf(msgbuf, "%d-%s argument",
152 argn, argn == 1 ? "st" : argn == 2 ? "nd" : "th");
153 msg = msgbuf;
154 }
155
156 rc = PL_unify_term(formal,
157 PL_FUNCTOR, FUNCTOR_uninstantiation_error1,
158 PL_TERM, bound);
159 break;
160 }
161 case ERR_TYPE: /* ERR_INSTANTIATION if var(actual) */
162 { atom_t expected = va_arg(args, atom_t);
163 term_t actual = va_arg(args, term_t);
164
165 case_type_error:
166 if ( expected == ATOM_callable )
167 rewrite_callable(&expected, actual);
168 if ( PL_is_variable(actual) && expected != ATOM_variable )
169 goto err_instantiation;
170
171 rc = PL_unify_term(formal,
172 PL_FUNCTOR, FUNCTOR_type_error2,
173 PL_ATOM, expected,
174 PL_TERM, actual);
175 break;
176 case ERR_PTR_TYPE: /* atom_t, Word */
177 { Word ptr;
178
179 expected = va_arg(args, atom_t);
180 ptr = va_arg(args, Word);
181 actual = PL_new_term_ref();
182
183 *valTermRef(actual) = *ptr;
184 goto case_type_error;
185 }
186 }
187 case ERR_CHARS_TYPE: /* ERR_INSTANTIATION if var(actual) */
188 { const char *expected = va_arg(args, const char*);
189 term_t actual = va_arg(args, term_t);
190
191 if ( PL_is_variable(actual) && !streq(expected, "variable") )
192 goto err_instantiation;
193
194 rc = PL_unify_term(formal,
195 PL_FUNCTOR, FUNCTOR_type_error2,
196 PL_CHARS, expected,
197 PL_TERM, actual);
198 break;
199 }
200 case ERR_AR_TYPE: /* arithmetic type error */
201 { atom_t expected = va_arg(args, atom_t);
202 Number num = va_arg(args, Number);
203 term_t actual = PL_new_term_ref();
204
205 rc = (_PL_put_number(actual, num) &&
206 PL_unify_term(formal,
207 PL_FUNCTOR, FUNCTOR_type_error2,
208 PL_ATOM, expected,
209 PL_TERM, actual));
210 break;
211 }
212 case ERR_AR_DOMAIN:
213 { atom_t domain = va_arg(args, atom_t);
214 Number num = va_arg(args, Number);
215 term_t actual = PL_new_term_ref();
216
217 rc = (_PL_put_number(actual, num) &&
218 PL_unify_term(formal,
219 PL_FUNCTOR, FUNCTOR_domain_error2,
220 PL_ATOM, domain,
221 PL_TERM, actual));
222 break;
223 }
224 case ERR_AR_UNDEF:
225 { rc = evaluation_error(formal, ATOM_undefined);
226 break;
227 }
228 case ERR_AR_OVERFLOW:
229 { rc = evaluation_error(formal, ATOM_float_overflow);
230 break;
231 }
232 case ERR_AR_RAT_OVERFLOW:
233 { rc = evaluation_error(formal, ATOM_rational_overflow);
234 break;
235 }
236 case ERR_AR_UNDERFLOW:
237 { rc = evaluation_error(formal, ATOM_float_underflow);
238 break;
239 }
240 case ERR_AR_TRIPWIRE:
241 { atom_t tripwire = va_arg(args, atom_t);
242 Number num = va_arg(args, Number);
243 term_t actual = PL_new_term_ref();
244
245 rc = (_PL_put_number(actual, num) &&
246 PL_unify_term(formal,
247 PL_FUNCTOR, FUNCTOR_resource_error1,
248 PL_FUNCTOR, FUNCTOR_tripwire2,
249 PL_ATOM, tripwire,
250 PL_TERM, actual));
251 break;
252 }
253 case ERR_DOMAIN: /* ERR_INSTANTIATION if var(arg) */
254 { atom_t domain = va_arg(args, atom_t);
255 term_t arg = va_arg(args, term_t);
256
257 case_domain_error:
258 if ( PL_is_variable(arg) )
259 goto err_instantiation;
260
261 rc = PL_unify_term(formal,
262 PL_FUNCTOR, FUNCTOR_domain_error2,
263 PL_ATOM, domain,
264 PL_TERM, arg);
265 break;
266 case ERR_PTR_DOMAIN: /* atom_t, Word */
267 { Word ptr;
268
269 domain = va_arg(args, atom_t);
270 ptr = va_arg(args, Word);
271 arg = PL_new_term_ref();
272
273 *valTermRef(arg) = *ptr;
274 goto case_domain_error;
275 }
276 }
277 case ERR_RANGE: /* domain_error(range(low,high), arg) */
278 { term_t low = va_arg(args, term_t);
279 term_t high = va_arg(args, term_t);
280 term_t arg = va_arg(args, term_t);
281
282 rc = PL_unify_term(formal,
283 PL_FUNCTOR, FUNCTOR_domain_error2,
284 PL_FUNCTOR, FUNCTOR_range2,
285 PL_TERM, low,
286 PL_TERM, high,
287 PL_TERM, arg);
288 break;
289 }
290 case ERR_REPRESENTATION:
291 { atom_t what = va_arg(args, atom_t);
292
293 rc = PL_unify_term(formal,
294 PL_FUNCTOR, FUNCTOR_representation_error1,
295 PL_ATOM, what);
296 break;
297 }
298 { Definition def; /* shared variables */
299 Procedure proc;
300 term_t pred;
301
302 case ERR_MODIFY_STATIC_PROC:
303 proc = va_arg(args, Procedure);
304 def = proc->definition;
305 goto modify_static;
306 case ERR_MODIFY_STATIC_PREDICATE:
307 def = va_arg(args, Definition);
308
309 modify_static:
310 rc = ((pred = PL_new_term_ref()) &&
311 unify_definition(MODULE_user, pred, def, 0,
312 GP_NAMEARITY|GP_HIDESYSTEM) &&
313 PL_unify_term(formal,
314 PL_FUNCTOR, FUNCTOR_permission_error3,
315 PL_ATOM, ATOM_modify,
316 PL_ATOM, ATOM_static_procedure,
317 PL_TERM, pred));
318 break;
319 }
320 case ERR_MODIFY_THREAD_LOCAL_PROC:
321 { Procedure proc = va_arg(args, Procedure);
322 term_t pred = PL_new_term_ref();
323
324 rc = (unify_definition(MODULE_user, pred, proc->definition, 0,
325 GP_NAMEARITY|GP_HIDESYSTEM) &&
326 PL_unify_term(formal,
327 PL_FUNCTOR, FUNCTOR_permission_error3,
328 PL_ATOM, ATOM_modify,
329 PL_ATOM, ATOM_thread_local_procedure,
330 PL_TERM, pred));
331 break;
332 }
333 case ERR_UNDEFINED_PROC:
334 { Definition def = va_arg(args, Definition);
335 Definition clr = va_arg(args, Definition);
336 term_t pred = PL_new_term_ref();
337
338 if ( clr )
339 caller = clr;
340
341 rc = (unify_definition(MODULE_user, pred, def, 0, GP_NAMEARITY) &&
342 PL_unify_term(formal,
343 PL_FUNCTOR, FUNCTOR_existence_error2,
344 PL_ATOM, ATOM_procedure,
345 PL_TERM, pred));
346 break;
347 }
348 case ERR_PERMISSION_PROC:
349 { atom_t op = va_arg(args, atom_t);
350 atom_t type = va_arg(args, atom_t);
351 predicate_t pred = va_arg(args, predicate_t);
352 term_t pi = PL_new_term_ref();
353
354 rc = ( PL_unify_predicate(pi, pred, GP_NAMEARITY|GP_HIDESYSTEM) &&
355 PL_unify_term(formal,
356 PL_FUNCTOR, FUNCTOR_permission_error3,
357 PL_ATOM, op,
358 PL_ATOM, type,
359 PL_TERM, pi));
360 break;
361 }
362 case ERR_PERMISSION_VMI:
363 { const char *vmi = va_arg(args, const char *);
364 rc = PL_unify_term(formal,
365 PL_FUNCTOR, FUNCTOR_permission_error3,
366 PL_ATOM, ATOM_execute,
367 PL_ATOM, ATOM_vmi,
368 PL_CHARS, vmi);
369 break;
370 }
371 case ERR_NOT_IMPLEMENTED_PROC:
372 { const char *name = va_arg(args, const char *);
373 int arity = va_arg(args, int);
374
375 rc = PL_unify_term(formal,
376 PL_FUNCTOR, FUNCTOR_not_implemented2,
377 PL_ATOM, ATOM_procedure,
378 PL_FUNCTOR, FUNCTOR_divide2,
379 PL_CHARS, name,
380 PL_INT, arity);
381 break;
382 }
383 case ERR_IMPORT_PROC:
384 { predicate_t pred = va_arg(args, predicate_t);
385 atom_t dest = va_arg(args, atom_t);
386 atom_t old = va_arg(args, atom_t);
387 term_t pi = PL_new_term_ref();
388
389 rc = ( PL_unify_predicate(pi, pred, GP_NAMEARITY) &&
390 PL_unify_term(formal,
391 PL_FUNCTOR, FUNCTOR_permission_error3,
392 PL_FUNCTOR, FUNCTOR_import_into1,
393 PL_ATOM, dest,
394 PL_ATOM, ATOM_procedure,
395 PL_TERM, pi));
396
397 if ( rc && old )
398 { rc = ( (msgterm = PL_new_term_ref()) &&
399 PL_unify_term(msgterm,
400 PL_FUNCTOR_CHARS, "already_from", 1,
401 PL_ATOM, old) );
402 }
403
404 break;
405 }
406 case ERR_FAILED:
407 { term_t goal = va_arg(args, term_t);
408
409 rc = PL_unify_term(formal,
410 PL_FUNCTOR, FUNCTOR_failure_error1,
411 PL_TERM, goal);
412
413 break;
414 }
415 case ERR_EVALUATION:
416 { atom_t what = va_arg(args, atom_t);
417
418 rc = PL_unify_term(formal,
419 PL_FUNCTOR, FUNCTOR_evaluation_error1,
420 PL_ATOM, what);
421 break;
422 }
423 case ERR_NOT_EVALUABLE:
424 { functor_t f = va_arg(args, functor_t);
425 term_t actual = PL_new_term_ref();
426
427 rc = (put_name_arity(actual, f) &&
428 PL_unify_term(formal,
429 PL_FUNCTOR, FUNCTOR_type_error2,
430 PL_ATOM, ATOM_evaluable,
431 PL_TERM, actual));
432 break;
433 }
434 case ERR_DIV_BY_ZERO:
435 { rc = PL_unify_term(formal,
436 PL_FUNCTOR, FUNCTOR_evaluation_error1,
437 PL_ATOM, ATOM_zero_divisor);
438 break;
439 }
440 case ERR_PERMISSION:
441 { atom_t op = va_arg(args, atom_t);
442 atom_t type = va_arg(args, atom_t);
443 term_t obj = va_arg(args, term_t);
444
445 rc = PL_unify_term(formal,
446 PL_FUNCTOR, FUNCTOR_permission_error3,
447 PL_ATOM, op,
448 PL_ATOM, type,
449 PL_TERM, obj);
450
451 break;
452 }
453 case ERR_OCCURS_CHECK:
454 { Word p1 = va_arg(args, Word);
455 Word p2 = va_arg(args, Word);
456
457 rc = PL_unify_term(formal,
458 PL_FUNCTOR, FUNCTOR_occurs_check2,
459 PL_TERM, pushWordAsTermRef(p1),
460 PL_TERM, pushWordAsTermRef(p2));
461 popTermRef();
462 popTermRef();
463
464 break;
465 }
466 case ERR_TIMEOUT:
467 { atom_t op = va_arg(args, atom_t);
468 term_t obj = va_arg(args, term_t);
469
470 rc = PL_unify_term(formal,
471 PL_FUNCTOR, FUNCTOR_timeout_error2,
472 PL_ATOM, op,
473 PL_TERM, obj);
474
475 break;
476 }
477 case ERR_EXISTENCE:
478 { atom_t type = va_arg(args, atom_t);
479 term_t obj = va_arg(args, term_t);
480
481 rc = PL_unify_term(formal,
482 PL_FUNCTOR, FUNCTOR_existence_error2,
483 PL_ATOM, type,
484 PL_TERM, obj);
485
486 break;
487 }
488 case ERR_EXISTENCE3:
489 { atom_t type = va_arg(args, atom_t);
490 term_t obj = va_arg(args, term_t);
491 term_t in = va_arg(args, term_t);
492
493 rc = PL_unify_term(formal,
494 PL_FUNCTOR, FUNCTOR_existence_error3,
495 PL_ATOM, type,
496 PL_TERM, obj,
497 PL_TERM, in);
498
499 break;
500 }
501 case ERR_FILE_OPERATION:
502 { atom_t action = va_arg(args, atom_t);
503 atom_t type = va_arg(args, atom_t);
504 term_t file = va_arg(args, term_t);
505 atom_t repr = ATOM_max_path_length;
506
507 switch(errno)
508 { case EAGAIN:
509 action = ATOM_lock; /* Hack for file-locking*/
510 /*FALLTHROUGH*/
511 case EACCES:
512 case EPERM:
513 #ifdef EROFS
514 case EROFS:
515 #endif
516 case ENOTEMPTY:
517 rc = PL_unify_term(formal,
518 PL_FUNCTOR, FUNCTOR_permission_error3,
519 PL_ATOM, action,
520 PL_ATOM, type,
521 PL_TERM, file);
522 break;
523 case EMFILE:
524 case ENFILE:
525 rc = PL_unify_term(formal,
526 PL_FUNCTOR, FUNCTOR_resource_error1,
527 PL_ATOM, ATOM_max_files);
528 break;
529 #ifdef ELOOP
530 case ELOOP:
531 repr = ATOM_max_symbolic_links;
532 /*FALLTHROUGH*/
533 #endif
534 case ENAMETOOLONG:
535 rc = PL_unify_term(formal,
536 PL_FUNCTOR, FUNCTOR_representation_error1,
537 PL_ATOM, repr);
538 break;
539 #ifdef EPIPE
540 case EPIPE:
541 if ( !msg )
542 msg = "Broken pipe";
543 /*FALLTHROUGH*/
544 #endif
545 default: /* what about the other cases? */
546 rc = PL_unify_term(formal,
547 PL_FUNCTOR, FUNCTOR_existence_error2,
548 PL_ATOM, type,
549 PL_TERM, file);
550 break;
551 }
552
553 break;
554 }
555 case ERR_STREAM_OP:
556 { atom_t action = va_arg(args, atom_t);
557 term_t stream = va_arg(args, term_t);
558
559 rc = PL_unify_term(formal,
560 PL_FUNCTOR, FUNCTOR_io_error2,
561 PL_ATOM, action,
562 PL_TERM, stream);
563 break;
564 }
565 case ERR_DDE_OP:
566 { const char *op = va_arg(args, const char *);
567 const char *err = va_arg(args, const char *);
568
569 rc = PL_unify_term(formal,
570 PL_FUNCTOR, FUNCTOR_dde_error2,
571 PL_CHARS, op,
572 PL_CHARS, err);
573 break;
574 }
575 case ERR_SHARED_OBJECT_OP:
576 { atom_t action = va_arg(args, atom_t);
577 const char *err = va_arg(args, const char *);
578
579 rc = PL_unify_term(formal,
580 PL_FUNCTOR, FUNCTOR_shared_object2,
581 PL_ATOM, action,
582 PL_CHARS, err);
583 break;
584 }
585 case ERR_NOT_IMPLEMENTED: /* non-ISO */
586 { const char *what = va_arg(args, const char *);
587
588 rc = PL_unify_term(formal,
589 PL_FUNCTOR, FUNCTOR_not_implemented2,
590 PL_ATOM, ATOM_feature,
591 PL_CHARS, what);
592 break;
593 }
594 case ERR_RESOURCE:
595 { atom_t what = va_arg(args, atom_t);
596
597 rc = PL_unify_term(formal,
598 PL_FUNCTOR, FUNCTOR_resource_error1,
599 PL_ATOM, what);
600 break;
601 }
602 case ERR_SYNTAX:
603 { const char *what = va_arg(args, const char *);
604
605 rc = PL_unify_term(formal,
606 PL_FUNCTOR, FUNCTOR_syntax_error1,
607 PL_CHARS, what);
608 break;
609 }
610 case ERR_NOMEM:
611 { rc = PL_unify_term(formal,
612 PL_FUNCTOR, FUNCTOR_resource_error1,
613 PL_ATOM, ATOM_no_memory);
614
615 break;
616 }
617 case ERR_SYSCALL:
618 { const char *op = va_arg(args, const char *);
619
620 if ( !msg )
621 msg = op;
622
623 switch(errno)
624 { case ENOMEM:
625 rc = PL_unify_term(formal,
626 PL_FUNCTOR, FUNCTOR_resource_error1,
627 PL_ATOM, ATOM_no_memory);
628 break;
629 default:
630 rc = PL_unify_atom(formal, ATOM_system_error);
631 break;
632 }
633
634 break;
635 }
636 case ERR_SHELL_FAILED:
637 { term_t cmd = va_arg(args, term_t);
638
639 rc = PL_unify_term(formal,
640 PL_FUNCTOR, FUNCTOR_shell2,
641 PL_ATOM, ATOM_execute,
642 PL_TERM, cmd);
643 break;
644 }
645 case ERR_SHELL_SIGNALLED:
646 { term_t cmd = va_arg(args, term_t);
647 int sig = va_arg(args, int);
648
649 rc = PL_unify_term(formal,
650 PL_FUNCTOR, FUNCTOR_shell2,
651 PL_FUNCTOR, FUNCTOR_signal1,
652 PL_INT, sig,
653 PL_TERM, cmd);
654 break;
655 }
656 case ERR_SIGNALLED:
657 { int sig = va_arg(args, int);
658 char *signame = va_arg(args, char *);
659
660 rc = PL_unify_term(formal,
661 PL_FUNCTOR, FUNCTOR_signal2,
662 PL_CHARS, signame,
663 PL_INT, sig);
664 break;
665 }
666 case ERR_CLOSED_STREAM:
667 { IOSTREAM *s = va_arg(args, IOSTREAM *);
668
669 rc = PL_unify_term(formal,
670 PL_FUNCTOR, FUNCTOR_existence_error2,
671 PL_ATOM, ATOM_stream,
672 PL_POINTER, s);
673 do_throw = TRUE;
674 break;
675 }
676 case ERR_BUSY:
677 { atom_t type = va_arg(args, atom_t);
678 term_t mutex = va_arg(args, term_t);
679
680 rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_busy2, type, mutex);
681 break;
682 }
683 case ERR_FORMAT:
684 { const char *s = va_arg(args, const char*);
685
686 rc = PL_unify_term(formal,
687 PL_FUNCTOR_CHARS, "format", 1,
688 PL_CHARS, s);
689 break;
690 }
691 case ERR_FORMAT_ARG:
692 { const char *s = va_arg(args, const char*);
693 term_t arg = va_arg(args, term_t);
694
695 rc = PL_unify_term(formal,
696 PL_FUNCTOR_CHARS, "format_argument_type", 2,
697 PL_CHARS, s,
698 PL_TERM, arg);
699 break;
700 }
701 case ERR_DUPLICATE_KEY:
702 { term_t key = va_arg(args, term_t);
703
704 rc = PL_unify_term(formal,
705 PL_FUNCTOR, FUNCTOR_duplicate_key1,
706 PL_TERM, key);
707 break;
708 }
709 default:
710 rc = FALSE;
711 assert(0);
712 }
713 va_end(args);
714
715 /* build SWI-Prolog context term */
716 if ( rc && (pred || msg || msgterm || caller) )
717 { term_t predterm = PL_new_term_ref();
718
719 if ( !msgterm )
720 msgterm = PL_new_term_ref();
721
722 if ( pred )
723 { rc = PL_unify_term(predterm,
724 PL_FUNCTOR, FUNCTOR_divide2,
725 PL_CHARS, pred,
726 PL_INT, arity);
727 } else if ( caller )
728 { rc = unify_definition(MODULE_user, predterm, caller, 0, GP_NAMEARITY);
729 }
730
731 if ( rc && msg )
732 { rc = PL_put_atom_chars(msgterm, msg);
733 }
734
735 if ( rc )
736 rc = PL_unify_term(swi,
737 PL_FUNCTOR, FUNCTOR_context2,
738 PL_TERM, predterm,
739 PL_TERM, msgterm);
740 }
741
742 if ( rc )
743 rc = PL_unify_term(except,
744 PL_FUNCTOR, FUNCTOR_error2,
745 PL_TERM, formal,
746 PL_TERM, swi);
747
748 if ( !rc )
749 { nomem:
750 fatalError("Cannot report error: no memory");
751 }
752
753 if ( do_throw )
754 rc = PL_throw(except);
755 else
756 rc = PL_raise_exception(except);
757
758 PL_close_foreign_frame(fid);
759
760 return rc;
761 }
762
763
764 /*******************************
765 * TYPICAL ERRORS *
766 *******************************/
767
768 int
PL_instantiation_error(term_t actual)769 PL_instantiation_error(term_t actual)
770 { (void)actual;
771
772 return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
773 }
774
775 int
PL_uninstantiation_error(term_t actual)776 PL_uninstantiation_error(term_t actual)
777 { return PL_error(NULL, 0, NULL, ERR_UNINSTANTIATION, 0, actual);
778 }
779
780 int
PL_representation_error(const char * representation)781 PL_representation_error(const char *representation)
782 { atom_t r = PL_new_atom(representation);
783 int rc = PL_error(NULL, 0, NULL, ERR_REPRESENTATION, r);
784 PL_unregister_atom(r);
785
786 return rc;
787 }
788
789
790 int
PL_type_error(const char * expected,term_t actual)791 PL_type_error(const char *expected, term_t actual)
792 { return PL_error(NULL, 0, NULL, ERR_CHARS_TYPE, expected, actual);
793 }
794
795
796 int
PL_domain_error(const char * expected,term_t actual)797 PL_domain_error(const char *expected, term_t actual)
798 { atom_t a = PL_new_atom(expected);
799 int rc = PL_error(NULL, 0, NULL, ERR_DOMAIN, a, actual);
800 PL_unregister_atom(a);
801
802 return rc;
803 }
804
805
806 int
PL_existence_error(const char * type,term_t actual)807 PL_existence_error(const char *type, term_t actual)
808 { atom_t a = PL_new_atom(type);
809 int rc = PL_error(NULL, 0, NULL, ERR_EXISTENCE, a, actual);
810 PL_unregister_atom(a);
811
812 return rc;
813 }
814
815
816 int
PL_permission_error(const char * op,const char * type,term_t obj)817 PL_permission_error(const char *op, const char *type, term_t obj)
818 { atom_t t = PL_new_atom(type);
819 atom_t o = PL_new_atom(op);
820 int rc = PL_error(NULL, 0, NULL, ERR_PERMISSION, o, t, obj);
821
822 PL_unregister_atom(t);
823 PL_unregister_atom(o);
824
825 return rc;
826 }
827
828
829 int
PL_resource_error(const char * resource)830 PL_resource_error(const char *resource)
831 { atom_t r = PL_new_atom(resource);
832 int rc = PL_error(NULL, 0, NULL, ERR_RESOURCE, r);
833
834 PL_unregister_atom(r);
835
836 return rc;
837 }
838
839
840 int
PL_no_memory(void)841 PL_no_memory(void)
842 { return PL_error(NULL, 0, NULL, ERR_RESOURCE, ATOM_memory);
843 }
844
845
846 int
PL_syntax_error(const char * msg,IOSTREAM * in)847 PL_syntax_error(const char *msg, IOSTREAM *in)
848 { GET_LD
849 term_t ex, loc;
850
851 if ( (ex = PL_new_term_ref()) &&
852 (loc = PL_new_term_ref()) &&
853 PL_unify_term(ex, PL_FUNCTOR, FUNCTOR_error2,
854 PL_FUNCTOR, FUNCTOR_syntax_error1,
855 PL_CHARS, msg,
856 PL_TERM, loc) )
857 { if ( in )
858 { IOPOS *pos;
859 term_t s;
860
861 if ( (s=PL_new_term_ref()) &&
862 PL_unify_stream_or_alias(s, in) )
863 { if ( (pos=in->position) )
864 { if ( PL_unify_term(loc, PL_FUNCTOR, FUNCTOR_stream4,
865 PL_TERM, s,
866 PL_INT, pos->lineno,
867 PL_INT, pos->linepos,
868 PL_INT64, pos->charno) )
869 goto ok;
870 } else
871 { if ( PL_unify_term(loc, PL_FUNCTOR, FUNCTOR_stream1,
872 PL_TERM, s) )
873 goto ok;
874 }
875 }
876
877 return FALSE;
878 }
879
880 ok:
881 return PL_raise_exception(ex);
882 }
883
884 return FALSE;
885 }
886
887 /*******************************
888 * PRINTING MESSAGES *
889 *******************************/
890
891 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
892 printMessage(atom_t severity, ...)
893
894 Calls print_message(severity, term), where ... are arguments as for
895 PL_unify_term(). This predicate saves possible pending exceptions and
896 restores them to make the call from B_THROW possible.
897
898 Returns FALSE if there was an exception while executing printMessage()
899 and TRUE if the printing succeeded or merely failed.
900 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
901
902 #define OK_RECURSIVE 10
903
904 int
printMessage(atom_t severity,...)905 printMessage(atom_t severity, ...)
906 { GET_LD
907 wakeup_state wstate;
908 term_t av;
909 predicate_t pred = PROCEDURE_print_message2;
910 va_list args;
911 int rc;
912
913 if ( ++LD->in_print_message >= OK_RECURSIVE*3 )
914 fatalError("printMessage(): recursive call\n");
915 if ( !saveWakeup(&wstate, TRUE PASS_LD) )
916 { LD->in_print_message--;
917 return FALSE;
918 }
919
920 av = PL_new_term_refs(2);
921 va_start(args, severity);
922 PL_put_atom(av+0, severity);
923 rc = PL_unify_termv(av+1, args);
924 va_end(args);
925
926 if ( rc )
927 { if ( isDefinedProcedure(pred) && LD->in_print_message <= OK_RECURSIVE )
928 { rc = PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_PASS_EXCEPTION,
929 pred, av);
930 } else if ( LD->in_print_message <= OK_RECURSIVE*2 )
931 { Sfprintf(Serror, "print_message/2: recursive call: ");
932 if ( ReadingSource )
933 Sfprintf(Serror, "%s:%d ",
934 PL_atom_chars(source_file_name), (int)source_line_no);
935 rc = PL_write_term(Serror, av+1, 1200, 0);
936 Sfprintf(Serror, "\n");
937 PL_backtrace(5, 1);
938 } else /* in_print_message == 2 */
939 { Sfprintf(Serror, "printMessage(): recursive call\n");
940 }
941 }
942
943 if ( !rc && PL_exception(0) )
944 set(&wstate, WAKEUP_KEEP_URGENT_EXCEPTION);
945 else
946 rc = TRUE;
947
948 restoreWakeup(&wstate PASS_LD);
949 LD->in_print_message--;
950
951 return rc;
952 }
953
954
955 /*******************************
956 * ERROR-CHECKING *_get() *
957 *******************************/
958
959 int
PL_get_atom_ex__LD(term_t t,atom_t * a ARG_LD)960 PL_get_atom_ex__LD(term_t t, atom_t *a ARG_LD)
961 { if ( PL_get_atom(t, a) )
962 succeed;
963
964 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, t);
965 }
966
967
968 #undef PL_get_atom_ex
969 int
PL_get_atom_ex(term_t t,atom_t * a)970 PL_get_atom_ex(term_t t, atom_t *a)
971 { GET_LD
972
973 return PL_get_atom_ex__LD(t, a PASS_LD);
974 }
975 #define PL_get_atom_ex(t, a) PL_get_atom_ex__LD(t, a PASS_LD)
976
977
978 int
PL_get_integer_ex(term_t t,int * i)979 PL_get_integer_ex(term_t t, int *i)
980 { GET_LD
981
982 if ( PL_get_integer(t, i) )
983 succeed;
984
985 if ( PL_is_integer(t) )
986 return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_int);
987
988 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
989 }
990
991
992 int
PL_get_long_ex(term_t t,long * i)993 PL_get_long_ex(term_t t, long *i)
994 { GET_LD
995
996 if ( PL_get_long(t, i) )
997 succeed;
998
999 if ( PL_is_integer(t) )
1000 return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_long);
1001
1002 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
1003 }
1004
1005
1006 int
PL_get_int64_ex(term_t t,int64_t * i)1007 PL_get_int64_ex(term_t t, int64_t *i)
1008 { GET_LD
1009
1010 if ( PL_get_int64(t, i) )
1011 succeed;
1012
1013 if ( PL_is_integer(t) )
1014 return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_int64_t);
1015
1016 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
1017 }
1018
1019
1020 int
PL_get_intptr_ex(term_t t,intptr_t * i)1021 PL_get_intptr_ex(term_t t, intptr_t *i)
1022 {
1023 #if SIZEOF_LONG != SIZEOF_VOIDP && SIZEOF_VOIDP == 8
1024 return PL_get_int64_ex(t, i);
1025 #else
1026 return PL_get_long_ex(t, (long*)i);
1027 #endif
1028 }
1029
1030 #if SIZEOF_VOIDP < 8
1031 #ifndef UINTPTR_MAX
1032 #define UINTPTR_MAX ~(uintptr_t)0;
1033 #endif
1034
1035 static int
fits_size(int64_t val)1036 fits_size(int64_t val)
1037 { if ( (uintptr_t)val <= (uintptr_t)UINTPTR_MAX )
1038 return TRUE;
1039 return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_size_t);
1040 }
1041 #else
1042 #define fits_size(v) TRUE
1043 #endif
1044
1045 int
PL_get_size_ex__LD(term_t t,size_t * i ARG_LD)1046 PL_get_size_ex__LD(term_t t, size_t *i ARG_LD)
1047 { number n;
1048 Word p = valTermRef(t);
1049
1050 deRef(p);
1051 if ( isTaggedInt(*p) )
1052 { intptr_t v = valInt(*p);
1053
1054 if ( v >= 0 )
1055 { *i = v;
1056 return TRUE;
1057 }
1058 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
1059 ATOM_not_less_than_zero, t);
1060 }
1061
1062 if ( PL_get_number(t, &n) )
1063 { switch(n.type)
1064 { case V_INTEGER:
1065 if ( n.value.i >= 0 )
1066 { if ( fits_size(n.value.i) )
1067 { *i = n.value.i;
1068 return TRUE;
1069 }
1070 return FALSE;
1071 } else
1072 { return PL_error(NULL, 0, NULL, ERR_DOMAIN,
1073 ATOM_not_less_than_zero, t);
1074 }
1075 #if SIZEOF_VOIDP == 8 && defined(O_GMP)
1076 case V_MPZ:
1077 { uint64_t v;
1078
1079 switch(mpz_to_uint64(n.value.mpz, &v))
1080 { case 0:
1081 *i = v;
1082 return TRUE;
1083 case -1:
1084 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
1085 ATOM_not_less_than_zero, t);
1086 case 1:
1087 return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_size_t);
1088 default:
1089 assert(0);
1090 return FALSE;
1091 }
1092 }
1093 #else
1094 return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_size_t);
1095 #endif
1096 default:
1097 break;
1098 }
1099 }
1100
1101 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
1102 }
1103
1104
1105 int
PL_get_uint64_ex__LD(term_t t,uint64_t * i ARG_LD)1106 PL_get_uint64_ex__LD(term_t t, uint64_t *i ARG_LD)
1107 { number n;
1108 Word p = valTermRef(t);
1109
1110 deRef(p);
1111 if ( isTaggedInt(*p) )
1112 { intptr_t v = valInt(*p);
1113
1114 if ( v >= 0 )
1115 { *i = v;
1116 return TRUE;
1117 }
1118 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
1119 ATOM_not_less_than_zero, t);
1120 }
1121
1122 if ( PL_get_number(t, &n) )
1123 { switch(n.type)
1124 { case V_INTEGER:
1125 if ( n.value.i >= 0 )
1126 { *i = n.value.i;
1127 return TRUE;
1128 } else
1129 { return PL_error(NULL, 0, NULL, ERR_DOMAIN,
1130 ATOM_not_less_than_zero, t);
1131 }
1132 #if SIZEOF_VOIDP == 8 && defined(O_GMP)
1133 case V_MPZ:
1134 { uint64_t v;
1135
1136 switch(mpz_to_uint64(n.value.mpz, &v))
1137 { case 0:
1138 *i = v;
1139 return TRUE;
1140 case -1:
1141 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
1142 ATOM_not_less_than_zero, t);
1143 case 1:
1144 return PL_representation_error("uint64_t");
1145 default:
1146 assert(0);
1147 return FALSE;
1148 }
1149 }
1150 #else
1151 return PL_representation_error("uint64_t");
1152 #endif
1153 default:
1154 break;
1155 }
1156 }
1157
1158 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
1159 }
1160
1161
1162 #undef PL_get_size_ex
1163 int
PL_get_size_ex(term_t t,size_t * i)1164 PL_get_size_ex(term_t t, size_t *i)
1165 { GET_LD
1166 return PL_get_size_ex__LD(t, i PASS_LD);
1167 }
1168 #define PL_get_size_ex(t,i) PL_get_size_ex__LD(t,i PASS_LD)
1169
1170 int
PL_get_bool_ex(term_t t,int * i)1171 PL_get_bool_ex(term_t t, int *i)
1172 { if ( PL_get_bool(t, i) )
1173 succeed;
1174
1175 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_bool, t);
1176 }
1177
1178
1179 int
PL_get_float_ex(term_t t,double * f)1180 PL_get_float_ex(term_t t, double *f)
1181 { if ( PL_get_float(t, f) )
1182 succeed;
1183
1184 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_float, t);
1185 }
1186
1187
1188 int
PL_get_char_ex(term_t t,int * p,int eof)1189 PL_get_char_ex(term_t t, int *p, int eof)
1190 { if ( PL_get_char(t, p, eof) )
1191 succeed;
1192
1193 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_character, t);
1194 }
1195
1196
1197 int
PL_get_pointer_ex(term_t t,void ** addrp)1198 PL_get_pointer_ex(term_t t, void **addrp)
1199 { GET_LD
1200 if ( PL_get_pointer(t, addrp) )
1201 succeed;
1202
1203 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_address, t);
1204 }
1205
1206
1207 int
PL_unify_list_ex(term_t l,term_t h,term_t t)1208 PL_unify_list_ex(term_t l, term_t h, term_t t)
1209 { GET_LD
1210
1211 if ( PL_unify_list(l, h, t) )
1212 succeed;
1213
1214 if ( PL_get_nil(l) )
1215 fail;
1216
1217 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
1218 }
1219
1220
1221 int
PL_unify_nil_ex(term_t l)1222 PL_unify_nil_ex(term_t l)
1223 { if ( PL_unify_nil(l) )
1224 succeed;
1225
1226 if ( PL_is_list(l) )
1227 fail;
1228
1229 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
1230 }
1231
1232
1233 int
PL_get_list_ex(term_t l,term_t h,term_t t)1234 PL_get_list_ex(term_t l, term_t h, term_t t)
1235 { GET_LD
1236
1237 if ( PL_get_list(l, h, t) )
1238 succeed;
1239
1240 if ( PL_get_nil(l) )
1241 fail;
1242
1243 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
1244 }
1245
1246 int
PL_get_nil_ex(term_t l)1247 PL_get_nil_ex(term_t l)
1248 { if ( PL_get_nil(l) )
1249 succeed;
1250
1251 if ( PL_is_list(l) )
1252 fail;
1253
1254 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
1255 }
1256
1257 int
PL_unify_bool_ex(term_t t,int val)1258 PL_unify_bool_ex(term_t t, int val)
1259 { GET_LD
1260 bool v;
1261
1262 if ( PL_is_variable(t) )
1263 return PL_unify_atom(t, val ? ATOM_true : ATOM_false);
1264 if ( PL_get_bool(t, &v) )
1265 { if ( (!val && !v) || (val && v) )
1266 succeed;
1267 fail;
1268 }
1269
1270 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_bool, t);
1271 }
1272
1273
1274 int
PL_get_arg_ex(int n,term_t term,term_t arg)1275 PL_get_arg_ex(int n, term_t term, term_t arg)
1276 { GET_LD
1277
1278 if ( PL_get_arg(n, term, arg) )
1279 { succeed;
1280 } else
1281 { term_t a = PL_new_term_ref();
1282
1283 PL_put_integer(a, n);
1284
1285 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_natural, a);
1286 }
1287 }
1288
1289
1290 int
PL_get_module_ex(term_t name,Module * m)1291 PL_get_module_ex(term_t name, Module *m)
1292 { if ( !PL_get_module(name, m) )
1293 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, name);
1294
1295 succeed;
1296 }
1297