1 /*-
2 * Copyright (c) 2005-2018 Michael Scholz <mi-scholz@users.sourceforge.net>
3 * All rights reserved.
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 * 1. Redistributions of source code must retain the above copyright
9 * notice, this list of conditions and the following disclaimer.
10 * 2. Redistributions in binary form must reproduce the above copyright
11 * notice, this list of conditions and the following disclaimer in the
12 * documentation and/or other materials provided with the distribution.
13 *
14 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
15 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
18 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
19 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
20 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
21 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
22 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
23 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
24 * SUCH DAMAGE.
25 *
26 * @(#)symbol.c 2.1 1/2/18
27 */
28
29 #if defined(HAVE_CONFIG_H)
30 #include "config.h"
31 #endif
32
33 #include "fth.h"
34 #include "utils.h"
35
36 /* === SYMBOL === */
37
38 /* symbol */
39 static void ficl_create_symbol(ficlVm *);
40 static void ficl_print_symbol(ficlVm *);
41 static void ficl_symbol_intern_im(ficlVm *);
42 static void ficl_symbol_name(ficlVm *);
43 static void ficl_symbol_p(ficlVm *);
44 static void ficl_symbol_paren(ficlVm *);
45 static int fth_any_symbol_p(const char *, int);
46 static FTH fth_make_symbol(FTH);
47 static FTH make_symbol(const char *, const char *, char, int);
48
49 /* keyword */
50 static void ficl_create_keyword(ficlVm *);
51 static void ficl_keyword_intern_im(ficlVm *);
52 static void ficl_keyword_name(ficlVm *);
53 static void ficl_keyword_p(ficlVm *);
54 static void ficl_keyword_paren(ficlVm *);
55 static void ficl_print_keyword(ficlVm *);
56 static FTH fth_make_keyword(FTH);
57
58 /* exception */
59 static void ficl_create_exception(ficlVm *);
60 static void ficl_exception_last_message_ref(ficlVm *);
61 static void ficl_exception_last_message_set(ficlVm *);
62 static void ficl_exception_message_ref(ficlVm *);
63 static void ficl_exception_message_set(ficlVm *);
64 static void ficl_exception_name(ficlVm *);
65 static void ficl_exception_p(ficlVm *);
66 static void ficl_make_exception(ficlVm *);
67 static void ficl_print_exception(ficlVm *);
68
69 #define MAKE_REF_AND_EQUAL_P(name, NAME) \
70 char * \
71 fth_ ## name ## _ref(FTH obj) \
72 { \
73 return (FTH_ ## NAME ## _P(obj) ? \
74 (FICL_WORD_NAME(obj) + 1) : NULL); \
75 } \
76 int \
77 fth_ ## name ## _equal_p(FTH obj1, FTH obj2) \
78 { \
79 return (FTH_ ## NAME ## _P(obj1) && \
80 (obj1 == obj2 || \
81 strcmp(FICL_WORD_NAME(obj1), FICL_WORD_NAME(obj2)) == 0)); \
82 } \
83 static void \
84 ficl_ ## name ## _equal_p(ficlVm *vm) \
85 { \
86 FTH obj1, obj2; \
87 int flag; \
88 \
89 FTH_STACK_CHECK(vm, 2, 0); \
90 obj2 = ficlStackPopFTH(vm->dataStack); \
91 obj1 = ficlStackPopFTH(vm->dataStack); \
92 flag = fth_ ## name ## _equal_p(obj1, obj2); \
93 ficlStackPushBoolean(vm->dataStack, flag); \
94 } \
95 static char* h_ ## name ## _equal_p = "( obj1 obj2 -- f ) compare\n\
96 'test :test " #name "= #f\n\
97 Return #t if OBJ1 and OBJ2 are " #name "s with identical name, otherwise #f."
98
99 /*-
100 * MAKE_REF_AND_EQUAL_P(name, NAME) builds:
101 *
102 * char *fth_symbol_ref(FTH obj);
103 * int fth_symbol_equal_p(FTH obj1, FTH obj2);
104 * static void ficl_symbol_equal_p(ficlVm *vm);
105 * static char *h_symbol_equal_p = "help string";
106 *
107 * char *fth_keyword_ref(FTH obj);
108 * int fth_keyword_equal_p(FTH obj1, FTH obj2);
109 * static void ficl_keyword_equal_p(ficlVm *vm);
110 * static char *h_keyword_equal_p = "help string";
111 *
112 * char *fth_exception_ref(FTH obj);
113 * int fth_exception_equal_p(FTH obj1, FTH obj2);
114 * static void ficl_exception_equal_p(ficlVm *vm);
115 * static char *h_exception_equal_p = "help string";
116 */
117
118 MAKE_REF_AND_EQUAL_P(symbol, SYMBOL);
119 MAKE_REF_AND_EQUAL_P(keyword, KEYWORD);
120 MAKE_REF_AND_EQUAL_P(exception, EXCEPTION);
121
122 char *
fth_string_or_symbol_ref(FTH obj)123 fth_string_or_symbol_ref(FTH obj)
124 {
125 if (FTH_STRING_P(obj))
126 return (fth_string_ref(obj));
127 return (fth_symbol_ref(obj));
128 }
129
130 int
fth_string_or_symbol_p(FTH obj)131 fth_string_or_symbol_p(FTH obj)
132 {
133 return (FTH_STRING_P(obj) || FTH_SYMBOL_P(obj));
134 }
135
136 static int
fth_any_symbol_p(const char * name,int kind)137 fth_any_symbol_p(const char *name, int kind)
138 {
139 int flag;
140
141 flag = 0;
142
143 if (name != NULL && *name != '\0') {
144 if (name[0] == kind)
145 flag = FICL_NAME_DEFINED_P(name);
146 else {
147 char sname[FICL_PAD_SIZE];
148
149 snprintf(sname, sizeof(sname), "%c%s", kind, name);
150 flag = FICL_NAME_DEFINED_P(sname);
151 }
152
153 }
154 return (flag);
155 }
156
157 #define h_list_of_symbol_functions "\
158 *** SYMBOL PRIMITIVES ***\n\
159 .symbol ( sym -- )\n\
160 create-symbol ( \"name\" -- )\n\
161 make-symbol ( name -- sym )\n\
162 symbol-name ( sym -- name )\n\
163 symbol= ( obj1 obj2 -- f )\n\
164 symbol? ( obj -- f )"
165
166 #define SYMBOL_PREFIX '\''
167
168 int
fth_symbol_p(const char * name)169 fth_symbol_p(const char *name)
170 {
171 return (fth_any_symbol_p(name, SYMBOL_PREFIX));
172 }
173
174 static void
ficl_symbol_p(ficlVm * vm)175 ficl_symbol_p(ficlVm *vm)
176 {
177 #define h_symbol_p "( obj -- f ) test if OBJ is a symbol\n\
178 'test symbol? => #t\n\
179 \"test\" symbol? =? #f\n\
180 Return #t if OBJ is a symbol, otherwise #f."
181 FTH obj;
182
183 FTH_STACK_CHECK(vm, 1, 1);
184 obj = ficlStackPopFTH(vm->dataStack);
185 ficlStackPushBoolean(vm->dataStack, FTH_SYMBOL_P(obj));
186 }
187
188 static FTH
make_symbol(const char * name,const char * message,char prefix,int kind)189 make_symbol(const char *name, const char *message, char prefix, int kind)
190 {
191 char *sname;
192 ficlWord *word;
193
194 if (name == NULL || *name == '\0') {
195 FTH_ASSERT_STRING(0);
196 return (FTH_FALSE);
197 }
198 sname = (*name != prefix) ?
199 fth_format("%c%s", prefix, name) :
200 FTH_STRDUP(name);
201
202 word = ficlDictionarySetConstant(FTH_FICL_DICT(), sname, 0L);
203 FTH_FREE(sname);
204
205 if (word != NULL) {
206 word->kind = kind;
207 CELL_VOIDP_SET(word->param, word);
208
209 if (kind == FW_EXCEPTION && message != NULL)
210 fth_word_property_set((FTH) word,
211 FTH_SYMBOL_MESSAGE, fth_make_string(message));
212 return ((FTH) word);
213 }
214 FTH_SYSTEM_ERROR_ARG_THROW(make_symbol, FTH_STR_SYMBOL);
215 return (FTH_FALSE);
216 }
217
218 /*
219 * Return value, the word address, of symbol NAME; if symbol doesn't
220 * exist, creat it.
221 */
222 FTH
fth_symbol(const char * name)223 fth_symbol(const char *name)
224 {
225 return (make_symbol(name, NULL, SYMBOL_PREFIX, FW_SYMBOL));
226 }
227
228 static void
ficl_create_symbol(ficlVm * vm)229 ficl_create_symbol(ficlVm *vm)
230 {
231 #define h_create_symbol "( \"name\" -- ) create symbol (parse word)\n\
232 create-symbol new-symbol\n\
233 'new-symbol => 'new-symbol\n\
234 Create symbol NAME prepended by '. \
235 Symbols are actually values (variables) named 'NAME.\n\
236 See also make-symbol and symbol-intern."
237 ficlVmGetWordToPad(vm);
238 fth_symbol(vm->pad);
239 }
240
241 static FTH
fth_make_symbol(FTH name)242 fth_make_symbol(FTH name)
243 {
244 #define h_make_symbol "( name -- sym ) return symbol\n\
245 \"new-symbol\" make-symbol drop\n\
246 'new-symbol => 'new-symbol\n\
247 An alternative way to create symbols is:\n\
248 'NAME => 'NAME\n\
249 Return symbol NAME prepended by '. \
250 Symbols are actually values (variables) named 'NAME.\n\
251 See also create-symbol and symbol-intern."
252 FTH_ASSERT_ARGS(FTH_STRING_P(name), name, FTH_ARG1, "a string");
253 return (fth_symbol(fth_string_ref(name)));
254 }
255
256 static void
ficl_print_symbol(ficlVm * vm)257 ficl_print_symbol(ficlVm *vm)
258 {
259 #define h_print_symbol "( sym -- ) print symbol\n\
260 'test .symbol => test\n\
261 Print symbol SYM to current output."
262 FTH obj;
263
264 FTH_STACK_CHECK(vm, 1, 0);
265 obj = ficlStackPopFTH(vm->dataStack);
266
267 if (FTH_SYMBOL_P(obj))
268 fth_print(fth_symbol_ref(obj));
269 else
270 fth_print("not a symbol");
271 }
272
273 static void
ficl_symbol_name(ficlVm * vm)274 ficl_symbol_name(ficlVm *vm)
275 {
276 #define h_symbol_name "( sym -- name ) return symbol name\n\
277 'test symbol-name => \"test\"\n\
278 Return name of symbol SYM."
279 FTH obj;
280
281 FTH_STACK_CHECK(vm, 1, 0);
282 obj = ficlStackPopFTH(vm->dataStack);
283 FTH_ASSERT_ARGS(fth_symbol_or_exception_p(obj), obj, FTH_ARG1,
284 "a symbol or exception");
285 push_cstring(vm, fth_symbol_ref(obj));
286 }
287
288 static void
ficl_symbol_paren(ficlVm * vm)289 ficl_symbol_paren(ficlVm *vm)
290 {
291 #define h_symbol_paren "( str -- sym ) return symbol\n\
292 In compile state SYMBOL-INTERN used to create a symbol."
293 FTH_STACK_CHECK(vm, 1, 1);
294 ficlStackPushFTH(vm->dataStack, fth_symbol(pop_cstring(vm)));
295 }
296
297 static ficlWord *symbol_paren;
298
299 static void
ficl_symbol_intern_im(ficlVm * vm)300 ficl_symbol_intern_im(ficlVm *vm)
301 {
302 #define h_symbol_intern_im "( \"str\" -- sym ) return symbol\n\
303 'test symbol? => #t\n\
304 Prefix word; return new or existing symbol. \
305 Predefined is:\n\
306 : ' postpone symbol-intern ; immediate\n\
307 See also create-symbol and make-symbol."
308 ficlVmGetWordToPad(vm);
309
310 if (vm->state == FICL_VM_STATE_COMPILE) {
311 ficlDictionary *dict;
312 ficlUnsigned u;
313
314 dict = ficlVmGetDictionary(vm);
315 u = (ficlUnsigned) ficlInstructionLiteralParen;
316 ficlDictionaryAppendUnsigned(dict, u);
317 ficlDictionaryAppendFTH(dict, fth_make_string(vm->pad));
318 ficlDictionaryAppendPointer(dict, symbol_paren);
319 } else
320 ficlStackPushFTH(vm->dataStack, fth_symbol(vm->pad));
321 }
322
323 /* === KEYWORD === */
324
325 #define h_list_of_keyword_functions "\
326 *** KEYWORD PRIMITIVES ***\n\
327 .keyword ( kw -- )\n\
328 create-keyword ( \"name\" -- )\n\
329 keyword-name ( kw -- name )\n\
330 keyword= ( obj1 obj2 -- f )\n\
331 keyword? ( obj -- f )\n\
332 make-keyword ( name -- kw )"
333
334 #define KEYWORD_PREFIX ':'
335
336 int
fth_keyword_p(const char * name)337 fth_keyword_p(const char *name)
338 {
339 return (fth_any_symbol_p(name, KEYWORD_PREFIX));
340 }
341
342 static void
ficl_keyword_p(ficlVm * vm)343 ficl_keyword_p(ficlVm *vm)
344 {
345 #define h_keyword_p "( obj -- f ) test if OBJ is a keyword\n\
346 :test keyword? => #t\n\
347 \"test\" keyword? => #f\n\
348 Return #t if OBJ is a keyword, otherwise #f."
349 FTH obj;
350
351 FTH_STACK_CHECK(vm, 1, 1);
352 obj = ficlStackPopFTH(vm->dataStack);
353 ficlStackPushBoolean(vm->dataStack, FTH_KEYWORD_P(obj));
354 }
355
356 FTH
fth_keyword(const char * name)357 fth_keyword(const char *name)
358 {
359 return (make_symbol(name, NULL, KEYWORD_PREFIX, FW_KEYWORD));
360 }
361
362 static void
ficl_create_keyword(ficlVm * vm)363 ficl_create_keyword(ficlVm *vm)
364 {
365 #define h_create_keyword "( \"name\" -- ) create keyword (parse word)\n\
366 create-keyword new-keyword\n\
367 :new-keyword => :new-keyword\n\
368 An alternative way to create keywords is:\n\
369 :NAME => :NAME\n\
370 Create keyword NAME prepended by a :. \
371 Keywords are actually values (variables) named :NAME.\n\
372 See also make-keyword and keyword-intern."
373 ficlVmGetWordToPad(vm);
374 fth_keyword(vm->pad);
375 }
376
377 static FTH
fth_make_keyword(FTH name)378 fth_make_keyword(FTH name)
379 {
380 #define h_make_keyword "( name -- kw ) return keyword\n\
381 \"new-keyword\" make-keyword drop\n\
382 :new-keyword => :new-keyword\n\
383 An alternative way to create keywords is:\n\
384 :NAME => :NAME\n\
385 Return keyword NAME prepended by a :. \
386 Keywords are actually values (variables) named :NAME.\n\
387 See also create-keyword and keyword-intern."
388 FTH_ASSERT_ARGS(FTH_STRING_P(name), name, FTH_ARG1, "a string");
389 return (fth_keyword(fth_string_ref(name)));
390 }
391
392 static void
ficl_print_keyword(ficlVm * vm)393 ficl_print_keyword(ficlVm *vm)
394 {
395 #define h_print_keyword "( kw -- ) print keyword\n\
396 :test .keyword => test\n\
397 Print keyword KW to current output."
398 FTH obj;
399
400 FTH_STACK_CHECK(vm, 1, 0);
401 obj = ficlStackPopFTH(vm->dataStack);
402
403 if (FTH_KEYWORD_P(obj))
404 fth_print(fth_keyword_ref(obj));
405 else
406 fth_print("not a keyword");
407 }
408
409 static void
ficl_keyword_name(ficlVm * vm)410 ficl_keyword_name(ficlVm *vm)
411 {
412 #define h_keyword_name "( kw -- name ) return keyword name\n\
413 :test keyword-name => \"test\"\n\
414 Return name of keyword KW."
415 FTH obj;
416
417 FTH_STACK_CHECK(vm, 1, 0);
418 obj = ficlStackPopFTH(vm->dataStack);
419 FTH_ASSERT_ARGS(FTH_KEYWORD_P(obj), obj, FTH_ARG1, "a keyword");
420 push_cstring(vm, fth_keyword_ref(obj));
421 }
422
423 static void
ficl_keyword_paren(ficlVm * vm)424 ficl_keyword_paren(ficlVm *vm)
425 {
426 #define h_keyword_paren "( str -- kw ) return keyword\n\
427 In compile state KEYWORD-INTERN used to create a keyword."
428 FTH_STACK_CHECK(vm, 1, 1);
429 ficlStackPushFTH(vm->dataStack, fth_keyword(pop_cstring(vm)));
430 }
431
432 static ficlWord *keyword_paren;
433
434 static void
ficl_keyword_intern_im(ficlVm * vm)435 ficl_keyword_intern_im(ficlVm *vm)
436 {
437 #define h_keyword_intern_im "( \"str\" -- sym ) return keyword\n\
438 :hello keyword? => #t\n\
439 Prefix word; return new or existing keyword. \
440 Predefined is:\n\
441 : : postpone keyword-intern ; immediate\n\
442 See also create-keyword and make-keyword."
443 ficlVmGetWordToPad(vm);
444
445 if (vm->state == FICL_VM_STATE_COMPILE) {
446 ficlDictionary *dict;
447 ficlUnsigned u;
448
449 dict = ficlVmGetDictionary(vm);
450 u = (ficlUnsigned) ficlInstructionLiteralParen;
451 ficlDictionaryAppendUnsigned(dict, u);
452 ficlDictionaryAppendFTH(dict, fth_make_string(vm->pad));
453 ficlDictionaryAppendPointer(dict, keyword_paren);
454 } else
455 ficlStackPushFTH(vm->dataStack, fth_keyword(vm->pad));
456 }
457
458 /* === EXCEPTION === */
459
460 FTH
fth_symbol_or_exception_ref(FTH obj)461 fth_symbol_or_exception_ref(FTH obj)
462 {
463 if (FTH_SYMBOL_P(obj))
464 return (fth_symbol_to_exception(obj));
465
466 if (FTH_EXCEPTION_P(obj))
467 return (obj);
468
469 return (FTH_FALSE);
470 }
471
472 int
fth_symbol_or_exception_p(FTH obj)473 fth_symbol_or_exception_p(FTH obj)
474 {
475 return (FTH_SYMBOL_P(obj) || FTH_EXCEPTION_P(obj));
476 }
477
478 #define h_list_of_exception_functions "\
479 *** EXCEPTION PRIMITIVES ***\n\
480 .exception ( ex -- )\n\
481 create-exception ( msg \"name\" -- )\n\
482 exception-last-message-ref ( ex -- msg )\n\
483 exception-last-message-set! ( ex msg -- )\n\
484 exception-message-ref ( ex -- msg )\n\
485 exception-message-set! ( ex msg -- )\n\
486 exception-name ( ex -- name )\n\
487 exception= ( obj1 obj2 -- f )\n\
488 exception? ( obj -- f )\n\
489 make-exception ( name msg -- ex )\n\
490 symbol->exception ( sym -- ex )\n\
491 *** VARIABLE ***\n\
492 *last-exception*"
493
494 static void
ficl_exception_p(ficlVm * vm)495 ficl_exception_p(ficlVm *vm)
496 {
497 #define h_exception_p "( obj -- f ) test if OBJ is an exception\n\
498 'test symbol->exception exception? => #t\n\
499 \"test\" exception? => #f\n\
500 Return #t if OBJ is an exception, otherwise #f."
501 FTH obj;
502
503 FTH_STACK_CHECK(vm, 1, 1);
504 obj = ficlStackPopFTH(vm->dataStack);
505 ficlStackPushBoolean(vm->dataStack, FTH_EXCEPTION_P(obj));
506 }
507
508 static FTH exception_list;
509
510 FTH
fth_make_exception(const char * name,const char * message)511 fth_make_exception(const char *name, const char *message)
512 {
513 FTH ex;
514
515 ex = make_symbol(name, message, SYMBOL_PREFIX, FW_EXCEPTION);
516
517 if (!fth_array_member_p(exception_list, ex))
518 fth_array_push(exception_list, ex);
519
520 return (ex);
521 }
522
523 /*
524 * Return a new Exception object NAME.
525 */
526 FTH
fth_exception(const char * name)527 fth_exception(const char *name)
528 {
529 return (fth_make_exception(name, NULL));
530 }
531
532 static void
ficl_create_exception(ficlVm * vm)533 ficl_create_exception(ficlVm *vm)
534 {
535 #define h_create_exception "( msg \"name\" -- ) create exception\n\
536 \"a special exception\" create-exception special-exception\n\
537 'special-exception exception-message-ref => \"a special exception\"\n\
538 #f create-exception exception-w/o-message\n\
539 'exception-w/o-message exception-message-ref => #f\n\
540 Create exception named NAME with message MSG, MSG can be #f. \
541 The exception has a symbol name, that means it has prefix ' before NAME.\n\
542 See also make-exception."
543 FTH_STACK_CHECK(vm, 1, 0);
544 ficlVmGetWordToPad(vm);
545 /* msg may be a string or #f */
546 fth_make_exception(vm->pad, fth_string_ref(fth_pop_ficl_cell(vm)));
547 }
548
549 static void
ficl_make_exception(ficlVm * vm)550 ficl_make_exception(ficlVm *vm)
551 {
552 #define h_make_exception "( name msg -- ex ) return exception\n\
553 \"special-excpetion\" \"a special exception\" make-exception drop\n\
554 'special-exception exception-message-ref => \"a special exception\"\n\
555 \"exception-w/o-message\" #f make-exception drop\n\
556 'exception-w/o-message exception-message-ref => #f\n\
557 Return exception named NAME with message MSG, MSG can be #f. \
558 The exception has a symbol name, that means it has prefix ' before NAME.\n\
559 See also create-exception."
560 char *name;
561 FTH msg, ex;
562
563 FTH_STACK_CHECK(vm, 2, 1);
564 /* msg may be a string or #f */
565 msg = fth_pop_ficl_cell(vm);
566 name = pop_cstring(vm);
567 ex = fth_make_exception(name, fth_string_ref(msg));
568 ficlStackPushFTH(vm->dataStack, ex);
569 }
570
571 FTH
fth_symbol_to_exception(FTH symbol)572 fth_symbol_to_exception(FTH symbol)
573 {
574 #define h_symbol_to_exception "( sym -- ex ) return exception\n\
575 'test symbol? => #t\n\
576 'test symbol->exception => 'test\n\
577 'test exception? => #t\n\
578 'test symbol? => #f\n\
579 Return symbol SYM as exception."
580 ficlWord *sym;
581
582 if (FTH_EXCEPTION_P(symbol))
583 return (symbol);
584
585 if (!FTH_SYMBOL_P(symbol)) {
586 FTH_ASSERT_ARGS(FTH_SYMBOL_P(symbol), symbol, FTH_ARG1,
587 "an exception or symbol");
588 /* NOTREACHED */
589 return (FTH_FALSE);
590 }
591 sym = FICL_WORD_REF(fth_symbol(FICL_WORD_NAME(symbol)));
592
593 if (sym == NULL)
594 return (FTH_FALSE);
595
596 sym->kind = FW_EXCEPTION;
597 return ((FTH) sym);
598 }
599
600 static void
ficl_print_exception(ficlVm * vm)601 ficl_print_exception(ficlVm *vm)
602 {
603 #define h_print_exception "( ex -- ) print exception\n\
604 'test .exception => test\n\
605 Print exception EX to current output."
606 FTH obj;
607
608 FTH_STACK_CHECK(vm, 1, 0);
609 obj = ficlStackPopFTH(vm->dataStack);
610
611 if (FTH_EXCEPTION_P(obj))
612 fth_print(fth_exception_ref(obj));
613 else
614 fth_print("not an exception");
615 }
616
617 static void
ficl_exception_name(ficlVm * vm)618 ficl_exception_name(ficlVm *vm)
619 {
620 #define h_exception_name "( ex -- name ) return exception name\n\
621 'test exception-name => \"test\"\n\
622 Return name of exception EX."
623 FTH obj;
624
625 FTH_STACK_CHECK(vm, 1, 0);
626 obj = ficlStackPopFTH(vm->dataStack);
627 FTH_ASSERT_ARGS(fth_symbol_or_exception_p(obj), obj, FTH_ARG1,
628 "an exception or symbol");
629 push_cstring(vm, fth_exception_ref(obj));
630 }
631
632 FTH
fth_exception_message_ref(FTH exc)633 fth_exception_message_ref(FTH exc)
634 {
635 return (fth_word_property_ref(exc, FTH_SYMBOL_MESSAGE));
636 }
637
638 static void
ficl_exception_message_ref(ficlVm * vm)639 ficl_exception_message_ref(ficlVm *vm)
640 {
641 #define h_exc_msg_ref "( ex -- msg ) return exception message\n\
642 'test exception-message-ref => \"test's special message\"\n\
643 Return message of exception EX.\n\
644 See also exception-message-set!."
645 FTH msg;
646
647 FTH_STACK_CHECK(vm, 1, 1);
648 /* msg may be a string or #f */
649 msg = fth_exception_message_ref(ficlStackPopFTH(vm->dataStack));
650 fth_push_ficl_cell(vm, msg);
651 }
652
653 void
fth_exception_message_set(FTH exc,FTH msg)654 fth_exception_message_set(FTH exc, FTH msg)
655 {
656 fth_word_property_set(exc, FTH_SYMBOL_MESSAGE, msg);
657 }
658
659 static void
ficl_exception_message_set(ficlVm * vm)660 ficl_exception_message_set(ficlVm *vm)
661 {
662 #define h_exc_msg_set "( ex msg|#f -- ) set exception message\n\
663 'test \"new special message\" exception-message-set!\n\
664 'test #f exception-message-set!\n\
665 Set MSG, a string or #f, to exception EX. \
666 See also exception-message-ref."
667 FTH exc, msg;
668
669 FTH_STACK_CHECK(vm, 2, 0);
670 /* msg may be a string or #f */
671 msg = fth_pop_ficl_cell(vm);
672 exc = ficlStackPopFTH(vm->dataStack);
673 fth_exception_message_set(exc, msg);
674 }
675
676 /* Last message is the output string built from args in fth_throw(). */
677 FTH
fth_exception_last_message_ref(FTH exc)678 fth_exception_last_message_ref(FTH exc)
679 {
680 FTH msg;
681
682 msg = fth_word_property_ref(exc, FTH_SYMBOL_LAST_MESSAGE);
683
684 if (FTH_FALSE_P(msg))
685 msg = fth_word_property_ref(exc, FTH_SYMBOL_MESSAGE);
686
687 return (msg);
688 }
689
690 static void
ficl_exception_last_message_ref(ficlVm * vm)691 ficl_exception_last_message_ref(ficlVm *vm)
692 {
693 #define h_exc_last_msg_ref "( ex -- msg ) return last message\n\
694 'test exception-last-message-ref => #f\n\
695 'test #( \"testing: %s\" \"checking last message\" ) fth-throw\n\
696 'test exception-last-message-ref => \"testing: checking last message\"\n\
697 Return last message of exception EX. \
698 Last message was set after an exception was thrown \
699 with e.g. fth-throw or fth-raise.\n\
700 See also exception-last-message-set!."
701 FTH msg;
702
703 FTH_STACK_CHECK(vm, 1, 1);
704 /* msg may be a string or #f */
705 msg = fth_exception_last_message_ref(ficlStackPopFTH(vm->dataStack));
706 fth_push_ficl_cell(vm, msg);
707 }
708
709 void
fth_exception_last_message_set(FTH exc,FTH msg)710 fth_exception_last_message_set(FTH exc, FTH msg)
711 {
712 fth_word_property_set(exc, FTH_SYMBOL_LAST_MESSAGE, msg);
713 }
714
715 static void
ficl_exception_last_message_set(ficlVm * vm)716 ficl_exception_last_message_set(ficlVm *vm)
717 {
718 #define h_exc_last_msg_set "( ex msg -- ) set last message\n\
719 'test \"new special message\" exception-last-message-set!\n\
720 'test #f exception-last-message-set!\n\
721 Set MSG, a string or #f, as last message of exception EX. \
722 This will be set automatically after an exception was thrown \
723 with e.g. fth-throw or fth-raise.\n\
724 See also exception-last-message-ref."
725 FTH exc, msg;
726
727 FTH_STACK_CHECK(vm, 2, 0);
728 /* msg may be a string or #f */
729 msg = fth_pop_ficl_cell(vm);
730 exc = ficlStackPopFTH(vm->dataStack);
731 fth_exception_last_message_set(exc, msg);
732 }
733
734 static FTH ans_exc_list[FICL_VM_STATUS_LAST_ANS];
735 static FTH ficl_exc_list[FICL_VM_STATUS_LAST_FICL];
736
737 FTH
ficl_ans_real_exc(int exc)738 ficl_ans_real_exc(int exc)
739 {
740 if (exc <= FICL_VM_STATUS_ABORT &&
741 exc > FICL_VM_STATUS_LAST_ERROR)
742 return (ans_exc_list[-exc]);
743
744 if (exc <= FICL_VM_STATUS_INNER_EXIT &&
745 exc > FICL_VM_STATUS_LAST_FICL_ERROR) {
746 exc += FICL_VM_STATUS_OFFSET;
747 return (ficl_exc_list[-exc]);
748 }
749 return (FTH_FALSE);
750 }
751
752 void
init_symbol(void)753 init_symbol(void)
754 {
755 /* symbol */
756 FTH_SYMBOL_DOCUMENTATION;
757 FTH_SYMBOL_LAST_MESSAGE;
758 FTH_SYMBOL_MESSAGE;
759 FTH_SYMBOL_SOURCE;
760 FTH_SYMBOL_TRACE_VAR;
761 FTH_PRI1("symbol?", ficl_symbol_p, h_symbol_p);
762 FTH_PRI1("symbol=", ficl_symbol_equal_p, h_symbol_equal_p);
763 FTH_PRI1("create-symbol", ficl_create_symbol, h_create_symbol);
764 FTH_PROC("make-symbol", fth_make_symbol, 1, 0, 0, h_make_symbol);
765 FTH_PRI1(".symbol", ficl_print_symbol, h_print_symbol);
766 FTH_PRI1("symbol-name", ficl_symbol_name, h_symbol_name);
767 FTH_PRIM_IM("symbol-intern", ficl_symbol_intern_im,
768 h_symbol_intern_im);
769 symbol_paren = ficlDictionaryAppendPrimitive(FTH_FICL_DICT(),
770 "(symbol)", ficl_symbol_paren, FICL_WORD_DEFAULT);
771 FTH_ADD_FEATURE_AND_INFO(FTH_STR_SYMBOL, h_list_of_symbol_functions);
772
773 /* keyword */
774 FTH_KEYWORD_CLOSE;
775 FTH_KEYWORD_COMMAND;
776 FTH_KEYWORD_COUNT;
777 FTH_KEYWORD_DOMAIN;
778 FTH_KEYWORD_FAM;
779 FTH_KEYWORD_FILENAME;
780 FTH_KEYWORD_FLUSH;
781 FTH_KEYWORD_IF_EXISTS;
782 FTH_KEYWORD_INIT;
783 FTH_KEYWORD_N;
784 FTH_KEYWORD_PORT;
785 FTH_KEYWORD_PORT_NAME;
786 FTH_KEYWORD_RANGE;
787 FTH_KEYWORD_READ_CHAR;
788 FTH_KEYWORD_READ_LINE;
789 FTH_KEYWORD_REPS;
790 FTH_KEYWORD_SOCKET;
791 FTH_KEYWORD_SOFT_PORT;
792 FTH_KEYWORD_START;
793 FTH_KEYWORD_STRING;
794 FTH_KEYWORD_WHENCE;
795 FTH_KEYWORD_WRITE_CHAR;
796 FTH_KEYWORD_WRITE_LINE;
797 FTH_PRI1("keyword?", ficl_keyword_p, h_keyword_p);
798 FTH_PRI1("keyword=", ficl_keyword_equal_p, h_keyword_equal_p);
799 FTH_PRI1("create-keyword", ficl_create_keyword, h_create_keyword);
800 FTH_PROC("make-keyword", fth_make_keyword, 1, 0, 0, h_make_keyword);
801 FTH_PRI1(".keyword", ficl_print_keyword, h_print_keyword);
802 FTH_PRI1("keyword-name", ficl_keyword_name, h_keyword_name);
803 FTH_PRIM_IM("keyword-intern", ficl_keyword_intern_im,
804 h_keyword_intern_im);
805 keyword_paren = ficlDictionaryAppendPrimitive(FTH_FICL_DICT(),
806 "(keyword)", ficl_keyword_paren, FICL_WORD_DEFAULT);
807 FTH_ADD_FEATURE_AND_INFO(FTH_STR_KEYWORD, h_list_of_keyword_functions);
808
809 /* exceptions */
810 exception_list = fth_make_empty_array();
811 fth_define_variable("*exception-list*", exception_list,
812 "( -- exceptions-array )");
813 fth_make_exception(STR_BAD_ARITY, "proc has bad arity");
814 fth_make_exception(STR_BAD_SYNTAX, "syntax error");
815 fth_make_exception(STR_BIGNUM_ERROR, "bignum error");
816 fth_make_exception(STR_CATCH_ERROR, "catch--throw mismatch");
817 fth_make_exception(STR_EVAL_ERROR, "evaluation error");
818 fth_make_exception(STR_FICL_ERROR, "Ficl error");
819 fth_make_exception(STR_FORTH_ERROR, "Forth error");
820 fth_make_exception(STR_LOAD_ERROR, "load error");
821 fth_make_exception(STR_MATH_ERROR, "math error");
822 fth_make_exception(STR_NULL_STRING, "null string");
823 fth_make_exception(STR_NO_MEMORY_ERROR, "no more memory available");
824 fth_make_exception(STR_OPTKEY_ERROR, "optkey error");
825 fth_make_exception(STR_OUT_OF_RANGE, "args out of range");
826 fth_make_exception(STR_REGEXP_ERROR, "regular expression error");
827 fth_make_exception(STR_SIGNAL_CAUGHT, "signal received");
828 fth_make_exception(STR_SO_FILE_ERROR, "dynamic library load error");
829 fth_make_exception(STR_SYSTEM_ERROR, "system error");
830 fth_make_exception(STR_WRONG_NUMBER_OF_ARGS,
831 "wrong number of arguments");
832 fth_make_exception(STR_WRONG_TYPE_ARG, "wrong argument type");
833
834 {
835 char *n, *m;
836 int i, j;
837
838 ans_exc_list[0] = FTH_FALSE;
839 /* ANS Exceptions. */
840 j = -1;
841 for (i = 1; i < FICL_VM_STATUS_LAST_ANS; i++, j--) {
842 n = ficl_ans_exc_name(j);
843 m = ficl_ans_exc_msg(j);
844 ans_exc_list[i] = fth_make_exception(n, m);
845 }
846 /* Ficl Exceptions. */
847 j = -FICL_VM_STATUS_OFFSET;
848 for (i = 0; i < FICL_VM_STATUS_LAST_FICL; i++, j--) {
849 n = ficl_ans_exc_name(j);
850 m = ficl_ans_exc_msg(j);
851 ficl_exc_list[i] = fth_make_exception(n, m);
852 }
853 }
854
855 FTH_PRI1("exception?", ficl_exception_p, h_exception_p);
856 FTH_PRI1("exception=", ficl_exception_equal_p, h_exception_equal_p);
857 FTH_PRI1("create-exception", ficl_create_exception,
858 h_create_exception);
859 FTH_PRI1("make-exception", ficl_make_exception, h_make_exception);
860 FTH_PROC("symbol->exception", fth_symbol_to_exception,
861 1, 0, 0, h_symbol_to_exception);
862 FTH_PRI1(".exception", ficl_print_exception, h_print_exception);
863 FTH_PRI1("exception-name", ficl_exception_name, h_exception_name);
864 FTH_PRI1("exception-message-ref", ficl_exception_message_ref,
865 h_exc_msg_ref);
866 FTH_PRI1("exception-message-set!", ficl_exception_message_set,
867 h_exc_msg_set);
868 FTH_PRI1("exception-last-message-ref", ficl_exception_last_message_ref,
869 h_exc_last_msg_ref);
870 FTH_PRI1("exception-last-message-set!", ficl_exception_last_message_set,
871 h_exc_last_msg_set);
872 fth_define_variable("*last-exception*", fth_last_exception,
873 "( -- last set exc )");
874 FTH_ADD_FEATURE_AND_INFO(FTH_STR_EXCEPTION,
875 h_list_of_exception_functions);
876 }
877
878 /*
879 * symbol.c ends here
880 */
881