1 /*
2 * CDDL HEADER START
3 *
4 * The contents of this file are subject to the terms of the
5 * Common Development and Distribution License (the "License").
6 * You may not use this file except in compliance with the License.
7 *
8 * You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
9 * or http://www.opensolaris.org/os/licensing.
10 * See the License for the specific language governing permissions
11 * and limitations under the License.
12 *
13 * When distributing Covered Code, include this CDDL HEADER in each
14 * file and include the License file at usr/src/OPENSOLARIS.LICENSE.
15 * If applicable, add the following below this CDDL HEADER, with the
16 * fields enclosed by brackets "[]" replaced with your own identifying
17 * information: Portions Copyright [yyyy] [name of copyright owner]
18 *
19 * CDDL HEADER END
20 */
21 /*
22 * Copyright 2007 Sun Microsystems, Inc. All rights reserved.
23 * Use is subject to license terms.
24 */
25
26 #pragma ident "%Z%%M% %I% %E% SMI"
27
28 #include <stdio.h>
29 #include <stdlib.h>
30 #include <string.h>
31 #include <stdarg.h>
32 #include <ctype.h>
33
34 #include <fcode/private.h>
35 #include <fcode/log.h>
36
37 void (*semi_ptr)(fcode_env_t *env) = do_semi;
38 void (*does_ptr)(fcode_env_t *env) = install_does;
39 void (*quote_ptr)(fcode_env_t *env) = do_quote;
40 void (*blit_ptr)(fcode_env_t *env) = do_literal;
41 void (*tlit_ptr)(fcode_env_t *env) = do_literal;
42 void (*do_bdo_ptr)(fcode_env_t *env) = do_bdo;
43 void (*do_bqdo_ptr)(fcode_env_t *env) = do_bqdo;
44 void (*create_ptr)(fcode_env_t *env) = do_creator;
45 void (*do_leave_ptr)(fcode_env_t *env) = do_bleave;
46 void (*do_loop_ptr)(fcode_env_t *env) = do_bloop;
47 void (*do_ploop_ptr)(fcode_env_t *env) = do_bploop;
48
49 void unaligned_lstore(fcode_env_t *);
50 void unaligned_wstore(fcode_env_t *);
51 void unaligned_lfetch(fcode_env_t *);
52 void unaligned_wfetch(fcode_env_t *);
53
54 /* start with the simple maths functions */
55
56
57 void
add(fcode_env_t * env)58 add(fcode_env_t *env)
59 {
60 fstack_t d;
61
62 CHECK_DEPTH(env, 2, "+");
63 d = POP(DS);
64 TOS += d;
65 }
66
67 void
subtract(fcode_env_t * env)68 subtract(fcode_env_t *env)
69 {
70 fstack_t d;
71
72 CHECK_DEPTH(env, 2, "-");
73 d = POP(DS);
74 TOS -= d;
75 }
76
77 void
multiply(fcode_env_t * env)78 multiply(fcode_env_t *env)
79 {
80 fstack_t d;
81
82 CHECK_DEPTH(env, 2, "*");
83 d = POP(DS);
84 TOS *= d;
85 }
86
87 void
slash_mod(fcode_env_t * env)88 slash_mod(fcode_env_t *env)
89 {
90 fstack_t d, o, t, rem;
91 int sign = 1;
92
93 CHECK_DEPTH(env, 2, "/mod");
94 d = POP(DS);
95 o = t = POP(DS);
96
97 if (d == 0) {
98 throw_from_fclib(env, 1, "/mod divide by zero");
99 }
100 sign = ((d ^ t) < 0);
101 if (d < 0) {
102 d = -d;
103 if (sign) {
104 t += (d-1);
105 }
106 }
107 if (t < 0) {
108 if (sign) {
109 t -= (d-1);
110 }
111 t = -t;
112 }
113 t = t / d;
114 if ((o ^ sign) < 0) {
115 rem = (t * d) + o;
116 } else {
117 rem = o - (t*d);
118 }
119 if (sign) {
120 t = -t;
121 }
122 PUSH(DS, rem);
123 PUSH(DS, t);
124 }
125
126 /*
127 * 'u/mod' Fcode implementation.
128 */
129 void
uslash_mod(fcode_env_t * env)130 uslash_mod(fcode_env_t *env)
131 {
132 u_lforth_t u1, u2;
133
134 CHECK_DEPTH(env, 2, "u/mod");
135 u2 = POP(DS);
136 u1 = POP(DS);
137
138 if (u2 == 0)
139 forth_abort(env, "u/mod: divide by zero");
140 PUSH(DS, u1 % u2);
141 PUSH(DS, u1 / u2);
142 }
143
144 void
divide(fcode_env_t * env)145 divide(fcode_env_t *env)
146 {
147 CHECK_DEPTH(env, 2, "/");
148 slash_mod(env);
149 nip(env);
150 }
151
152 void
mod(fcode_env_t * env)153 mod(fcode_env_t *env)
154 {
155 CHECK_DEPTH(env, 2, "mod");
156 slash_mod(env);
157 drop(env);
158 }
159
160 void
and(fcode_env_t * env)161 and(fcode_env_t *env)
162 {
163 fstack_t d;
164
165 CHECK_DEPTH(env, 2, "and");
166 d = POP(DS);
167 TOS &= d;
168 }
169
170 void
or(fcode_env_t * env)171 or(fcode_env_t *env)
172 {
173 fstack_t d;
174
175 CHECK_DEPTH(env, 2, "or");
176 d = POP(DS);
177 TOS |= d;
178 }
179
180 void
xor(fcode_env_t * env)181 xor(fcode_env_t *env)
182 {
183 fstack_t d;
184
185 CHECK_DEPTH(env, 2, "xor");
186 d = POP(DS);
187 TOS ^= d;
188 }
189
190 void
invert(fcode_env_t * env)191 invert(fcode_env_t *env)
192 {
193 CHECK_DEPTH(env, 1, "invert");
194 TOS = ~TOS;
195 }
196
197 void
lshift(fcode_env_t * env)198 lshift(fcode_env_t *env)
199 {
200 fstack_t d;
201
202 CHECK_DEPTH(env, 2, "lshift");
203 d = POP(DS);
204 TOS = TOS << d;
205 }
206
207 void
rshift(fcode_env_t * env)208 rshift(fcode_env_t *env)
209 {
210 fstack_t d;
211
212 CHECK_DEPTH(env, 2, "rshift");
213 d = POP(DS);
214 TOS = ((ufstack_t)TOS) >> d;
215 }
216
217 void
rshifta(fcode_env_t * env)218 rshifta(fcode_env_t *env)
219 {
220 fstack_t d;
221
222 CHECK_DEPTH(env, 2, ">>a");
223 d = POP(DS);
224 TOS = ((s_lforth_t)TOS) >> d;
225 }
226
227 void
negate(fcode_env_t * env)228 negate(fcode_env_t *env)
229 {
230 CHECK_DEPTH(env, 1, "negate");
231 TOS = -TOS;
232 }
233
234 void
f_abs(fcode_env_t * env)235 f_abs(fcode_env_t *env)
236 {
237 CHECK_DEPTH(env, 1, "abs");
238 if (TOS < 0) TOS = -TOS;
239 }
240
241 void
f_min(fcode_env_t * env)242 f_min(fcode_env_t *env)
243 {
244 fstack_t d;
245
246 CHECK_DEPTH(env, 2, "min");
247 d = POP(DS);
248 if (d < TOS) TOS = d;
249 }
250
251 void
f_max(fcode_env_t * env)252 f_max(fcode_env_t *env)
253 {
254 fstack_t d;
255
256 CHECK_DEPTH(env, 2, "max");
257 d = POP(DS);
258 if (d > TOS) TOS = d;
259 }
260
261 void
to_r(fcode_env_t * env)262 to_r(fcode_env_t *env)
263 {
264 CHECK_DEPTH(env, 1, ">r");
265 PUSH(RS, POP(DS));
266 }
267
268 void
from_r(fcode_env_t * env)269 from_r(fcode_env_t *env)
270 {
271 CHECK_RETURN_DEPTH(env, 1, "r>");
272 PUSH(DS, POP(RS));
273 }
274
275 void
rfetch(fcode_env_t * env)276 rfetch(fcode_env_t *env)
277 {
278 CHECK_RETURN_DEPTH(env, 1, "r@");
279 PUSH(DS, *RS);
280 }
281
282 void
f_exit(fcode_env_t * env)283 f_exit(fcode_env_t *env)
284 {
285 CHECK_RETURN_DEPTH(env, 1, "exit");
286 IP = (token_t *)POP(RS);
287 }
288
289 #define COMPARE(cmp, rhs) ((((s_lforth_t)TOS) cmp((s_lforth_t)(rhs))) ? \
290 TRUE : FALSE)
291 #define UCOMPARE(cmp, rhs) ((((u_lforth_t)TOS) cmp((u_lforth_t)(rhs))) ? \
292 TRUE : FALSE)
293 #define EQUALS ==
294 #define NOTEQUALS !=
295 #define LESSTHAN <
296 #define LESSEQUALS <=
297 #define GREATERTHAN >
298 #define GREATEREQUALS >=
299
300 void
zero_equals(fcode_env_t * env)301 zero_equals(fcode_env_t *env)
302 {
303 CHECK_DEPTH(env, 1, "0=");
304 TOS = COMPARE(EQUALS, 0);
305 }
306
307 void
zero_not_equals(fcode_env_t * env)308 zero_not_equals(fcode_env_t *env)
309 {
310 CHECK_DEPTH(env, 1, "0<>");
311 TOS = COMPARE(NOTEQUALS, 0);
312 }
313
314 void
zero_less(fcode_env_t * env)315 zero_less(fcode_env_t *env)
316 {
317 CHECK_DEPTH(env, 1, "0<");
318 TOS = COMPARE(LESSTHAN, 0);
319 }
320
321 void
zero_less_equals(fcode_env_t * env)322 zero_less_equals(fcode_env_t *env)
323 {
324 CHECK_DEPTH(env, 1, "0<=");
325 TOS = COMPARE(LESSEQUALS, 0);
326 }
327
328 void
zero_greater(fcode_env_t * env)329 zero_greater(fcode_env_t *env)
330 {
331 CHECK_DEPTH(env, 1, "0>");
332 TOS = COMPARE(GREATERTHAN, 0);
333 }
334
335 void
zero_greater_equals(fcode_env_t * env)336 zero_greater_equals(fcode_env_t *env)
337 {
338 CHECK_DEPTH(env, 1, "0>=");
339 TOS = COMPARE(GREATEREQUALS, 0);
340 }
341
342 void
less(fcode_env_t * env)343 less(fcode_env_t *env)
344 {
345 fstack_t d;
346
347 CHECK_DEPTH(env, 2, "<");
348 d = POP(DS);
349 TOS = COMPARE(LESSTHAN, d);
350 }
351
352 void
greater(fcode_env_t * env)353 greater(fcode_env_t *env)
354 {
355 fstack_t d;
356
357 CHECK_DEPTH(env, 2, ">");
358 d = POP(DS);
359 TOS = COMPARE(GREATERTHAN, d);
360 }
361
362 void
equals(fcode_env_t * env)363 equals(fcode_env_t *env)
364 {
365 fstack_t d;
366
367 CHECK_DEPTH(env, 2, "=");
368 d = POP(DS);
369 TOS = COMPARE(EQUALS, d);
370 }
371
372 void
not_equals(fcode_env_t * env)373 not_equals(fcode_env_t *env)
374 {
375 fstack_t d;
376
377 CHECK_DEPTH(env, 2, "<>");
378 d = POP(DS);
379 TOS = COMPARE(NOTEQUALS, d);
380 }
381
382
383 void
unsign_greater(fcode_env_t * env)384 unsign_greater(fcode_env_t *env)
385 {
386 ufstack_t d;
387
388 CHECK_DEPTH(env, 2, "u>");
389 d = POP(DS);
390 TOS = UCOMPARE(GREATERTHAN, d);
391 }
392
393 void
unsign_less_equals(fcode_env_t * env)394 unsign_less_equals(fcode_env_t *env)
395 {
396 ufstack_t d;
397
398 CHECK_DEPTH(env, 2, "u<=");
399 d = POP(DS);
400 TOS = UCOMPARE(LESSEQUALS, d);
401 }
402
403 void
unsign_less(fcode_env_t * env)404 unsign_less(fcode_env_t *env)
405 {
406 ufstack_t d;
407
408 CHECK_DEPTH(env, 2, "u<");
409 d = POP(DS);
410 TOS = UCOMPARE(LESSTHAN, d);
411 }
412
413 void
unsign_greater_equals(fcode_env_t * env)414 unsign_greater_equals(fcode_env_t *env)
415 {
416 ufstack_t d;
417
418 CHECK_DEPTH(env, 2, "u>=");
419 d = POP(DS);
420 TOS = UCOMPARE(GREATEREQUALS, d);
421 }
422
423 void
greater_equals(fcode_env_t * env)424 greater_equals(fcode_env_t *env)
425 {
426 fstack_t d;
427
428 CHECK_DEPTH(env, 2, ">=");
429 d = POP(DS);
430 TOS = COMPARE(GREATEREQUALS, d);
431 }
432
433 void
less_equals(fcode_env_t * env)434 less_equals(fcode_env_t *env)
435 {
436 fstack_t d;
437
438 CHECK_DEPTH(env, 2, "<=");
439 d = POP(DS);
440 TOS = COMPARE(LESSEQUALS, d);
441 }
442
443 void
between(fcode_env_t * env)444 between(fcode_env_t *env)
445 {
446 u_lforth_t hi, lo;
447
448 CHECK_DEPTH(env, 3, "between");
449 hi = (u_lforth_t)POP(DS);
450 lo = (u_lforth_t)POP(DS);
451 TOS = (((u_lforth_t)TOS >= lo) && ((u_lforth_t)TOS <= hi) ? -1 : 0);
452 }
453
454 void
within(fcode_env_t * env)455 within(fcode_env_t *env)
456 {
457 u_lforth_t lo, hi;
458
459 CHECK_DEPTH(env, 3, "within");
460 hi = (u_lforth_t)POP(DS);
461 lo = (u_lforth_t)POP(DS);
462 TOS = ((((u_lforth_t)TOS >= lo) && ((u_lforth_t)TOS < hi)) ? -1 : 0);
463 }
464
465 void
do_literal(fcode_env_t * env)466 do_literal(fcode_env_t *env)
467 {
468 PUSH(DS, *IP);
469 IP++;
470 }
471
472 void
literal(fcode_env_t * env)473 literal(fcode_env_t *env)
474 {
475 if (env->state) {
476 COMPILE_TOKEN(&blit_ptr);
477 compile_comma(env);
478 }
479 }
480
481 void
do_also(fcode_env_t * env)482 do_also(fcode_env_t *env)
483 {
484 token_t *d = *ORDER;
485
486 if (env->order_depth < (MAX_ORDER - 1)) {
487 env->order[++env->order_depth] = d;
488 debug_msg(DEBUG_CONTEXT, "CONTEXT:also: %d/%p/%p\n",
489 env->order_depth, CONTEXT, env->current);
490 } else
491 log_message(MSG_WARN, "Vocabulary search order exceeds: %d\n",
492 MAX_ORDER);
493 }
494
495 void
do_previous(fcode_env_t * env)496 do_previous(fcode_env_t *env)
497 {
498 if (env->order_depth) {
499 env->order_depth--;
500 debug_msg(DEBUG_CONTEXT, "CONTEXT:previous: %d/%p/%p\n",
501 env->order_depth, CONTEXT, env->current);
502 }
503 }
504
505 #ifdef DEBUG
506 void
do_order(fcode_env_t * env)507 do_order(fcode_env_t *env)
508 {
509 int i;
510
511 log_message(MSG_INFO, "Order: Depth: %ld: ", env->order_depth);
512 for (i = env->order_depth; i >= 0 && env->order[i]; i--)
513 log_message(MSG_INFO, "%p ", (void *)env->order[i]);
514 log_message(MSG_INFO, "\n");
515 }
516 #endif
517
518 void
noop(fcode_env_t * env)519 noop(fcode_env_t *env)
520 {
521 /* what a waste of cycles */
522 }
523
524
525 #define FW_PER_FL (sizeof (lforth_t)/sizeof (wforth_t))
526
527 void
lwsplit(fcode_env_t * env)528 lwsplit(fcode_env_t *env)
529 {
530 union {
531 u_wforth_t l_wf[FW_PER_FL];
532 u_lforth_t l_lf;
533 } d;
534 int i;
535
536 CHECK_DEPTH(env, 1, "lwsplit");
537 d.l_lf = POP(DS);
538 for (i = 0; i < FW_PER_FL; i++)
539 PUSH(DS, d.l_wf[(FW_PER_FL - 1) - i]);
540 }
541
542 void
wljoin(fcode_env_t * env)543 wljoin(fcode_env_t *env)
544 {
545 union {
546 u_wforth_t l_wf[FW_PER_FL];
547 u_lforth_t l_lf;
548 } d;
549 int i;
550
551 CHECK_DEPTH(env, FW_PER_FL, "wljoin");
552 for (i = 0; i < FW_PER_FL; i++)
553 d.l_wf[i] = POP(DS);
554 PUSH(DS, d.l_lf);
555 }
556
557 void
lwflip(fcode_env_t * env)558 lwflip(fcode_env_t *env)
559 {
560 union {
561 u_wforth_t l_wf[FW_PER_FL];
562 u_lforth_t l_lf;
563 } d, c;
564 int i;
565
566 CHECK_DEPTH(env, 1, "lwflip");
567 d.l_lf = POP(DS);
568 for (i = 0; i < FW_PER_FL; i++)
569 c.l_wf[i] = d.l_wf[(FW_PER_FL - 1) - i];
570 PUSH(DS, c.l_lf);
571 }
572
573 void
lbsplit(fcode_env_t * env)574 lbsplit(fcode_env_t *env)
575 {
576 union {
577 uchar_t l_bytes[sizeof (lforth_t)];
578 u_lforth_t l_lf;
579 } d;
580 int i;
581
582 CHECK_DEPTH(env, 1, "lbsplit");
583 d.l_lf = POP(DS);
584 for (i = 0; i < sizeof (lforth_t); i++)
585 PUSH(DS, d.l_bytes[(sizeof (lforth_t) - 1) - i]);
586 }
587
588 void
bljoin(fcode_env_t * env)589 bljoin(fcode_env_t *env)
590 {
591 union {
592 uchar_t l_bytes[sizeof (lforth_t)];
593 u_lforth_t l_lf;
594 } d;
595 int i;
596
597 CHECK_DEPTH(env, sizeof (lforth_t), "bljoin");
598 for (i = 0; i < sizeof (lforth_t); i++)
599 d.l_bytes[i] = POP(DS);
600 PUSH(DS, (fstack_t)d.l_lf);
601 }
602
603 void
lbflip(fcode_env_t * env)604 lbflip(fcode_env_t *env)
605 {
606 union {
607 uchar_t l_bytes[sizeof (lforth_t)];
608 u_lforth_t l_lf;
609 } d, c;
610 int i;
611
612 CHECK_DEPTH(env, 1, "lbflip");
613 d.l_lf = POP(DS);
614 for (i = 0; i < sizeof (lforth_t); i++)
615 c.l_bytes[i] = d.l_bytes[(sizeof (lforth_t) - 1) - i];
616 PUSH(DS, c.l_lf);
617 }
618
619 void
wbsplit(fcode_env_t * env)620 wbsplit(fcode_env_t *env)
621 {
622 union {
623 uchar_t w_bytes[sizeof (wforth_t)];
624 u_wforth_t w_wf;
625 } d;
626 int i;
627
628 CHECK_DEPTH(env, 1, "wbsplit");
629 d.w_wf = POP(DS);
630 for (i = 0; i < sizeof (wforth_t); i++)
631 PUSH(DS, d.w_bytes[(sizeof (wforth_t) - 1) - i]);
632 }
633
634 void
bwjoin(fcode_env_t * env)635 bwjoin(fcode_env_t *env)
636 {
637 union {
638 uchar_t w_bytes[sizeof (wforth_t)];
639 u_wforth_t w_wf;
640 } d;
641 int i;
642
643 CHECK_DEPTH(env, sizeof (wforth_t), "bwjoin");
644 for (i = 0; i < sizeof (wforth_t); i++)
645 d.w_bytes[i] = POP(DS);
646 PUSH(DS, d.w_wf);
647 }
648
649 void
wbflip(fcode_env_t * env)650 wbflip(fcode_env_t *env)
651 {
652 union {
653 uchar_t w_bytes[sizeof (wforth_t)];
654 u_wforth_t w_wf;
655 } c, d;
656 int i;
657
658 CHECK_DEPTH(env, 1, "wbflip");
659 d.w_wf = POP(DS);
660 for (i = 0; i < sizeof (wforth_t); i++)
661 c.w_bytes[i] = d.w_bytes[(sizeof (wforth_t) - 1) - i];
662 PUSH(DS, c.w_wf);
663 }
664
665 void
upper_case(fcode_env_t * env)666 upper_case(fcode_env_t *env)
667 {
668 CHECK_DEPTH(env, 1, "upc");
669 TOS = toupper(TOS);
670 }
671
672 void
lower_case(fcode_env_t * env)673 lower_case(fcode_env_t *env)
674 {
675 CHECK_DEPTH(env, 1, "lcc");
676 TOS = tolower(TOS);
677 }
678
679 void
pack_str(fcode_env_t * env)680 pack_str(fcode_env_t *env)
681 {
682 char *buf;
683 size_t len;
684 char *str;
685
686 CHECK_DEPTH(env, 3, "pack");
687 buf = (char *)POP(DS);
688 len = (size_t)POP(DS);
689 str = (char *)TOS;
690 TOS = (fstack_t)buf;
691 *buf++ = (uchar_t)len;
692 strncpy(buf, str, (len&0xff));
693 }
694
695 void
count_str(fcode_env_t * env)696 count_str(fcode_env_t *env)
697 {
698 uchar_t *len;
699
700 CHECK_DEPTH(env, 1, "count");
701 len = (uchar_t *)TOS;
702 TOS += 1;
703 PUSH(DS, *len);
704 }
705
706 void
to_body(fcode_env_t * env)707 to_body(fcode_env_t *env)
708 {
709 CHECK_DEPTH(env, 1, ">body");
710 TOS = (fstack_t)(((acf_t)TOS)+1);
711 }
712
713 void
to_acf(fcode_env_t * env)714 to_acf(fcode_env_t *env)
715 {
716 CHECK_DEPTH(env, 1, "body>");
717 TOS = (fstack_t)(((acf_t)TOS)-1);
718 }
719
720 /*
721 * 'unloop' Fcode implementation, drop 3 loop ctrl elements off return stack.
722 */
723 static void
unloop(fcode_env_t * env)724 unloop(fcode_env_t *env)
725 {
726 CHECK_RETURN_DEPTH(env, 3, "unloop");
727 RS -= 3;
728 }
729
730 /*
731 * 'um*' Fcode implementation.
732 */
733 static void
um_multiply(fcode_env_t * env)734 um_multiply(fcode_env_t *env)
735 {
736 ufstack_t u1, u2;
737 dforth_t d;
738
739 CHECK_DEPTH(env, 2, "um*");
740 u1 = POP(DS);
741 u2 = POP(DS);
742 d = u1 * u2;
743 push_double(env, d);
744 }
745
746 /*
747 * um/mod (d.lo d.hi u -- urem uquot)
748 */
749 static void
um_slash_mod(fcode_env_t * env)750 um_slash_mod(fcode_env_t *env)
751 {
752 u_dforth_t d;
753 uint32_t u, urem, uquot;
754
755 CHECK_DEPTH(env, 3, "um/mod");
756 u = (uint32_t)POP(DS);
757 d = pop_double(env);
758 urem = d % u;
759 uquot = d / u;
760 PUSH(DS, urem);
761 PUSH(DS, uquot);
762 }
763
764 /*
765 * d+ (d1.lo d1.hi d2.lo d2.hi -- dsum.lo dsum.hi)
766 */
767 static void
d_plus(fcode_env_t * env)768 d_plus(fcode_env_t *env)
769 {
770 dforth_t d1, d2;
771
772 CHECK_DEPTH(env, 4, "d+");
773 d2 = pop_double(env);
774 d1 = pop_double(env);
775 d1 += d2;
776 push_double(env, d1);
777 }
778
779 /*
780 * d- (d1.lo d1.hi d2.lo d2.hi -- ddif.lo ddif.hi)
781 */
782 static void
d_minus(fcode_env_t * env)783 d_minus(fcode_env_t *env)
784 {
785 dforth_t d1, d2;
786
787 CHECK_DEPTH(env, 4, "d-");
788 d2 = pop_double(env);
789 d1 = pop_double(env);
790 d1 -= d2;
791 push_double(env, d1);
792 }
793
794 void
set_here(fcode_env_t * env,uchar_t * new_here,char * where)795 set_here(fcode_env_t *env, uchar_t *new_here, char *where)
796 {
797 if (new_here < HERE) {
798 if (strcmp(where, "temporary_execute")) {
799 /*
800 * Other than temporary_execute, no one should set
801 * here backwards.
802 */
803 log_message(MSG_WARN, "Warning: set_here(%s) back: old:"
804 " %p new: %p\n", where, HERE, new_here);
805 }
806 }
807 if (new_here >= env->base + dict_size)
808 forth_abort(env, "Here (%p) set past dictionary end (%p)",
809 new_here, env->base + dict_size);
810 HERE = new_here;
811 }
812
813 static void
unaligned_store(fcode_env_t * env)814 unaligned_store(fcode_env_t *env)
815 {
816 extern void unaligned_xstore(fcode_env_t *);
817
818 if (sizeof (fstack_t) == sizeof (lforth_t))
819 unaligned_lstore(env);
820 else
821 unaligned_xstore(env);
822 }
823
824 static void
unaligned_fetch(fcode_env_t * env)825 unaligned_fetch(fcode_env_t *env)
826 {
827 extern void unaligned_xfetch(fcode_env_t *);
828
829 if (sizeof (fstack_t) == sizeof (lforth_t))
830 unaligned_lfetch(env);
831 else
832 unaligned_xfetch(env);
833 }
834
835 void
comma(fcode_env_t * env)836 comma(fcode_env_t *env)
837 {
838 CHECK_DEPTH(env, 1, ",");
839 DEBUGF(COMMA, dump_comma(env, ","));
840 PUSH(DS, (fstack_t)HERE);
841 unaligned_store(env);
842 set_here(env, HERE + sizeof (fstack_t), "comma");
843 }
844
845 void
lcomma(fcode_env_t * env)846 lcomma(fcode_env_t *env)
847 {
848 CHECK_DEPTH(env, 1, "l,");
849 DEBUGF(COMMA, dump_comma(env, "l,"));
850 PUSH(DS, (fstack_t)HERE);
851 unaligned_lstore(env);
852 set_here(env, HERE + sizeof (u_lforth_t), "lcomma");
853 }
854
855 void
wcomma(fcode_env_t * env)856 wcomma(fcode_env_t *env)
857 {
858 CHECK_DEPTH(env, 1, "w,");
859 DEBUGF(COMMA, dump_comma(env, "w,"));
860 PUSH(DS, (fstack_t)HERE);
861 unaligned_wstore(env);
862 set_here(env, HERE + sizeof (u_wforth_t), "wcomma");
863 }
864
865 void
ccomma(fcode_env_t * env)866 ccomma(fcode_env_t *env)
867 {
868 CHECK_DEPTH(env, 1, "c,");
869 DEBUGF(COMMA, dump_comma(env, "c,"));
870 PUSH(DS, (fstack_t)HERE);
871 cstore(env);
872 set_here(env, HERE + sizeof (uchar_t), "ccomma");
873 }
874
875 void
token_roundup(fcode_env_t * env,char * where)876 token_roundup(fcode_env_t *env, char *where)
877 {
878 if ((((token_t)HERE) & (sizeof (token_t) - 1)) != 0) {
879 set_here(env, (uchar_t *)TOKEN_ROUNDUP(HERE), where);
880 }
881 }
882
883 void
compile_comma(fcode_env_t * env)884 compile_comma(fcode_env_t *env)
885 {
886 CHECK_DEPTH(env, 1, "compile,");
887 DEBUGF(COMMA, dump_comma(env, "compile,"));
888 token_roundup(env, "compile,");
889 PUSH(DS, (fstack_t)HERE);
890 unaligned_store(env);
891 set_here(env, HERE + sizeof (fstack_t), "compile,");
892 }
893
894 void
unaligned_lfetch(fcode_env_t * env)895 unaligned_lfetch(fcode_env_t *env)
896 {
897 fstack_t addr;
898 int i;
899
900 CHECK_DEPTH(env, 1, "unaligned-l@");
901 addr = POP(DS);
902 for (i = 0; i < sizeof (lforth_t); i++, addr++) {
903 PUSH(DS, addr);
904 cfetch(env);
905 }
906 bljoin(env);
907 lbflip(env);
908 }
909
910 void
unaligned_lstore(fcode_env_t * env)911 unaligned_lstore(fcode_env_t *env)
912 {
913 fstack_t addr;
914 int i;
915
916 CHECK_DEPTH(env, 2, "unaligned-l!");
917 addr = POP(DS);
918 lbsplit(env);
919 for (i = 0; i < sizeof (lforth_t); i++, addr++) {
920 PUSH(DS, addr);
921 cstore(env);
922 }
923 }
924
925 void
unaligned_wfetch(fcode_env_t * env)926 unaligned_wfetch(fcode_env_t *env)
927 {
928 fstack_t addr;
929 int i;
930
931 CHECK_DEPTH(env, 1, "unaligned-w@");
932 addr = POP(DS);
933 for (i = 0; i < sizeof (wforth_t); i++, addr++) {
934 PUSH(DS, addr);
935 cfetch(env);
936 }
937 bwjoin(env);
938 wbflip(env);
939 }
940
941 void
unaligned_wstore(fcode_env_t * env)942 unaligned_wstore(fcode_env_t *env)
943 {
944 fstack_t addr;
945 int i;
946
947 CHECK_DEPTH(env, 2, "unaligned-w!");
948 addr = POP(DS);
949 wbsplit(env);
950 for (i = 0; i < sizeof (wforth_t); i++, addr++) {
951 PUSH(DS, addr);
952 cstore(env);
953 }
954 }
955
956 /*
957 * 'lbflips' Fcode implementation.
958 */
959 static void
lbflips(fcode_env_t * env)960 lbflips(fcode_env_t *env)
961 {
962 fstack_t len, addr;
963 int i;
964
965 CHECK_DEPTH(env, 2, "lbflips");
966 len = POP(DS);
967 addr = POP(DS);
968 for (i = 0; i < len; i += sizeof (lforth_t),
969 addr += sizeof (lforth_t)) {
970 PUSH(DS, addr);
971 unaligned_lfetch(env);
972 lbflip(env);
973 PUSH(DS, addr);
974 unaligned_lstore(env);
975 }
976 }
977
978 /*
979 * 'wbflips' Fcode implementation.
980 */
981 static void
wbflips(fcode_env_t * env)982 wbflips(fcode_env_t *env)
983 {
984 fstack_t len, addr;
985 int i;
986
987 CHECK_DEPTH(env, 2, "wbflips");
988 len = POP(DS);
989 addr = POP(DS);
990 for (i = 0; i < len; i += sizeof (wforth_t),
991 addr += sizeof (wforth_t)) {
992 PUSH(DS, addr);
993 unaligned_wfetch(env);
994 wbflip(env);
995 PUSH(DS, addr);
996 unaligned_wstore(env);
997 }
998 }
999
1000 /*
1001 * 'lwflips' Fcode implementation.
1002 */
1003 static void
lwflips(fcode_env_t * env)1004 lwflips(fcode_env_t *env)
1005 {
1006 fstack_t len, addr;
1007 int i;
1008
1009 CHECK_DEPTH(env, 2, "lwflips");
1010 len = POP(DS);
1011 addr = POP(DS);
1012 for (i = 0; i < len; i += sizeof (lforth_t),
1013 addr += sizeof (lforth_t)) {
1014 PUSH(DS, addr);
1015 unaligned_lfetch(env);
1016 lwflip(env);
1017 PUSH(DS, addr);
1018 unaligned_lstore(env);
1019 }
1020 }
1021
1022 void
base(fcode_env_t * env)1023 base(fcode_env_t *env)
1024 {
1025 PUSH(DS, (fstack_t)&env->num_base);
1026 }
1027
1028 void
dot_s(fcode_env_t * env)1029 dot_s(fcode_env_t *env)
1030 {
1031 output_data_stack(env, MSG_INFO);
1032 }
1033
1034 void
state(fcode_env_t * env)1035 state(fcode_env_t *env)
1036 {
1037 PUSH(DS, (fstack_t)&env->state);
1038 }
1039
1040 int
is_digit(char digit,int num_base,fstack_t * dptr)1041 is_digit(char digit, int num_base, fstack_t *dptr)
1042 {
1043 int error = 0;
1044 char base;
1045
1046 if (num_base < 10) {
1047 base = '0' + (num_base-1);
1048 } else {
1049 base = 'a' + (num_base - 10);
1050 }
1051
1052 *dptr = 0;
1053 if (digit > '9') digit |= 0x20;
1054 if (((digit < '0') || (digit > base)) ||
1055 ((digit > '9') && (digit < 'a') && (num_base > 10)))
1056 error = 1;
1057 else {
1058 if (digit <= '9')
1059 digit -= '0';
1060 else
1061 digit = digit - 'a' + 10;
1062 *dptr = digit;
1063 }
1064 return (error);
1065 }
1066
1067 void
dollar_number(fcode_env_t * env)1068 dollar_number(fcode_env_t *env)
1069 {
1070 char *buf;
1071 fstack_t value;
1072 int len, sign = 1, error = 0;
1073
1074 CHECK_DEPTH(env, 2, "$number");
1075 buf = pop_a_string(env, &len);
1076 if (*buf == '-') {
1077 sign = -1;
1078 buf++;
1079 len--;
1080 }
1081 value = 0;
1082 while (len-- && !error) {
1083 fstack_t digit;
1084
1085 if (*buf == '.') {
1086 buf++;
1087 continue;
1088 }
1089 value *= env->num_base;
1090 error = is_digit(*buf++, env->num_base, &digit);
1091 value += digit;
1092 }
1093 if (error) {
1094 PUSH(DS, -1);
1095 } else {
1096 value *= sign;
1097 PUSH(DS, value);
1098 PUSH(DS, 0);
1099 }
1100 }
1101
1102 void
digit(fcode_env_t * env)1103 digit(fcode_env_t *env)
1104 {
1105 fstack_t base;
1106 fstack_t value;
1107
1108 CHECK_DEPTH(env, 2, "digit");
1109 base = POP(DS);
1110 if (is_digit(TOS, base, &value))
1111 PUSH(DS, 0);
1112 else {
1113 TOS = value;
1114 PUSH(DS, -1);
1115 }
1116 }
1117
1118 void
space(fcode_env_t * env)1119 space(fcode_env_t *env)
1120 {
1121 PUSH(DS, ' ');
1122 }
1123
1124 void
backspace(fcode_env_t * env)1125 backspace(fcode_env_t *env)
1126 {
1127 PUSH(DS, '\b');
1128 }
1129
1130 void
bell(fcode_env_t * env)1131 bell(fcode_env_t *env)
1132 {
1133 PUSH(DS, '\a');
1134 }
1135
1136 void
fc_bounds(fcode_env_t * env)1137 fc_bounds(fcode_env_t *env)
1138 {
1139 fstack_t lo, hi;
1140
1141 CHECK_DEPTH(env, 2, "bounds");
1142 lo = DS[-1];
1143 hi = TOS;
1144 DS[-1] = lo+hi;
1145 TOS = lo;
1146 }
1147
1148 void
here(fcode_env_t * env)1149 here(fcode_env_t *env)
1150 {
1151 PUSH(DS, (fstack_t)HERE);
1152 }
1153
1154 void
aligned(fcode_env_t * env)1155 aligned(fcode_env_t *env)
1156 {
1157 ufstack_t a;
1158
1159 CHECK_DEPTH(env, 1, "aligned");
1160 a = (TOS & (sizeof (lforth_t) - 1));
1161 if (a)
1162 TOS += (sizeof (lforth_t) - a);
1163 }
1164
1165 void
instance(fcode_env_t * env)1166 instance(fcode_env_t *env)
1167 {
1168 env->instance_mode |= 1;
1169 }
1170
1171 void
semi(fcode_env_t * env)1172 semi(fcode_env_t *env)
1173 {
1174
1175 env->state &= ~1;
1176 COMPILE_TOKEN(&semi_ptr);
1177
1178 /*
1179 * check if we need to supress expose action;
1180 * If so this is an internal word and has no link field
1181 * or it is a temporary compile
1182 */
1183
1184 if (env->state == 0) {
1185 expose_acf(env, "<semi>");
1186 }
1187 if (env->state & 8) {
1188 env->state ^= 8;
1189 }
1190 }
1191
1192 void
do_create(fcode_env_t * env)1193 do_create(fcode_env_t *env)
1194 {
1195 PUSH(DS, (fstack_t)WA);
1196 }
1197
1198 void
drop(fcode_env_t * env)1199 drop(fcode_env_t *env)
1200 {
1201 CHECK_DEPTH(env, 1, "drop");
1202 (void) POP(DS);
1203 }
1204
1205 void
f_dup(fcode_env_t * env)1206 f_dup(fcode_env_t *env)
1207 {
1208 fstack_t d;
1209
1210 CHECK_DEPTH(env, 1, "dup");
1211 d = TOS;
1212 PUSH(DS, d);
1213 }
1214
1215 void
over(fcode_env_t * env)1216 over(fcode_env_t *env)
1217 {
1218 fstack_t d;
1219
1220 CHECK_DEPTH(env, 2, "over");
1221 d = DS[-1];
1222 PUSH(DS, d);
1223 }
1224
1225 void
swap(fcode_env_t * env)1226 swap(fcode_env_t *env)
1227 {
1228 fstack_t d;
1229
1230 CHECK_DEPTH(env, 2, "swap");
1231 d = DS[-1];
1232 DS[-1] = DS[0];
1233 DS[0] = d;
1234 }
1235
1236
1237 void
rot(fcode_env_t * env)1238 rot(fcode_env_t *env)
1239 {
1240 fstack_t d;
1241
1242 CHECK_DEPTH(env, 3, "rot");
1243 d = DS[-2];
1244 DS[-2] = DS[-1];
1245 DS[-1] = TOS;
1246 TOS = d;
1247 }
1248
1249 void
minus_rot(fcode_env_t * env)1250 minus_rot(fcode_env_t *env)
1251 {
1252 fstack_t d;
1253
1254 CHECK_DEPTH(env, 3, "-rot");
1255 d = TOS;
1256 TOS = DS[-1];
1257 DS[-1] = DS[-2];
1258 DS[-2] = d;
1259 }
1260
1261 void
tuck(fcode_env_t * env)1262 tuck(fcode_env_t *env)
1263 {
1264 fstack_t d;
1265
1266 CHECK_DEPTH(env, 2, "tuck");
1267 d = TOS;
1268 swap(env);
1269 PUSH(DS, d);
1270 }
1271
1272 void
nip(fcode_env_t * env)1273 nip(fcode_env_t *env)
1274 {
1275 CHECK_DEPTH(env, 2, "nip");
1276 swap(env);
1277 drop(env);
1278 }
1279
1280 void
qdup(fcode_env_t * env)1281 qdup(fcode_env_t *env)
1282 {
1283 fstack_t d;
1284
1285 CHECK_DEPTH(env, 1, "?dup");
1286 d = TOS;
1287 if (d)
1288 PUSH(DS, d);
1289 }
1290
1291 void
depth(fcode_env_t * env)1292 depth(fcode_env_t *env)
1293 {
1294 fstack_t d;
1295
1296 d = DS - env->ds0;
1297 PUSH(DS, d);
1298 }
1299
1300 void
pick(fcode_env_t * env)1301 pick(fcode_env_t *env)
1302 {
1303 fstack_t p;
1304
1305 CHECK_DEPTH(env, 1, "pick");
1306 p = POP(DS);
1307 if (p < 0 || p >= (env->ds - env->ds0))
1308 forth_abort(env, "pick: invalid pick value: %d\n", (int)p);
1309 p = DS[-p];
1310 PUSH(DS, p);
1311 }
1312
1313 void
roll(fcode_env_t * env)1314 roll(fcode_env_t *env)
1315 {
1316 fstack_t d, r;
1317
1318 CHECK_DEPTH(env, 1, "roll");
1319 r = POP(DS);
1320 if (r <= 0 || r >= (env->ds - env->ds0))
1321 forth_abort(env, "roll: invalid roll value: %d\n", (int)r);
1322
1323 d = DS[-r];
1324 while (r) {
1325 DS[-r] = DS[ -(r-1) ];
1326 r--;
1327 }
1328 TOS = d;
1329 }
1330
1331 void
two_drop(fcode_env_t * env)1332 two_drop(fcode_env_t *env)
1333 {
1334 CHECK_DEPTH(env, 2, "2drop");
1335 DS -= 2;
1336 }
1337
1338 void
two_dup(fcode_env_t * env)1339 two_dup(fcode_env_t *env)
1340 {
1341 CHECK_DEPTH(env, 2, "2dup");
1342 DS[1] = DS[-1];
1343 DS[2] = TOS;
1344 DS += 2;
1345 }
1346
1347 void
two_over(fcode_env_t * env)1348 two_over(fcode_env_t *env)
1349 {
1350 fstack_t a, b;
1351
1352 CHECK_DEPTH(env, 4, "2over");
1353 a = DS[-3];
1354 b = DS[-2];
1355 PUSH(DS, a);
1356 PUSH(DS, b);
1357 }
1358
1359 void
two_swap(fcode_env_t * env)1360 two_swap(fcode_env_t *env)
1361 {
1362 fstack_t a, b;
1363
1364 CHECK_DEPTH(env, 4, "2swap");
1365 a = DS[-3];
1366 b = DS[-2];
1367 DS[-3] = DS[-1];
1368 DS[-2] = TOS;
1369 DS[-1] = a;
1370 TOS = b;
1371 }
1372
1373 void
two_rot(fcode_env_t * env)1374 two_rot(fcode_env_t *env)
1375 {
1376 fstack_t a, b;
1377
1378 CHECK_DEPTH(env, 6, "2rot");
1379 a = DS[-5];
1380 b = DS[-4];
1381 DS[-5] = DS[-3];
1382 DS[-4] = DS[-2];
1383 DS[-3] = DS[-1];
1384 DS[-2] = TOS;
1385 DS[-1] = a;
1386 TOS = b;
1387 }
1388
1389 void
two_slash(fcode_env_t * env)1390 two_slash(fcode_env_t *env)
1391 {
1392 CHECK_DEPTH(env, 1, "2/");
1393 TOS = TOS >> 1;
1394 }
1395
1396 void
utwo_slash(fcode_env_t * env)1397 utwo_slash(fcode_env_t *env)
1398 {
1399 CHECK_DEPTH(env, 1, "u2/");
1400 TOS = (ufstack_t)((ufstack_t)TOS) >> 1;
1401 }
1402
1403 void
two_times(fcode_env_t * env)1404 two_times(fcode_env_t *env)
1405 {
1406 CHECK_DEPTH(env, 1, "2*");
1407 TOS = (ufstack_t)((ufstack_t)TOS) << 1;
1408 }
1409
1410 void
slash_c(fcode_env_t * env)1411 slash_c(fcode_env_t *env)
1412 {
1413 PUSH(DS, sizeof (char));
1414 }
1415
1416 void
slash_w(fcode_env_t * env)1417 slash_w(fcode_env_t *env)
1418 {
1419 PUSH(DS, sizeof (wforth_t));
1420 }
1421
1422 void
slash_l(fcode_env_t * env)1423 slash_l(fcode_env_t *env)
1424 {
1425 PUSH(DS, sizeof (lforth_t));
1426 }
1427
1428 void
slash_n(fcode_env_t * env)1429 slash_n(fcode_env_t *env)
1430 {
1431 PUSH(DS, sizeof (fstack_t));
1432 }
1433
1434 void
ca_plus(fcode_env_t * env)1435 ca_plus(fcode_env_t *env)
1436 {
1437 fstack_t d;
1438
1439 CHECK_DEPTH(env, 2, "ca+");
1440 d = POP(DS);
1441 TOS += d * sizeof (char);
1442 }
1443
1444 void
wa_plus(fcode_env_t * env)1445 wa_plus(fcode_env_t *env)
1446 {
1447 fstack_t d;
1448
1449 CHECK_DEPTH(env, 2, "wa+");
1450 d = POP(DS);
1451 TOS += d * sizeof (wforth_t);
1452 }
1453
1454 void
la_plus(fcode_env_t * env)1455 la_plus(fcode_env_t *env)
1456 {
1457 fstack_t d;
1458
1459 CHECK_DEPTH(env, 2, "la+");
1460 d = POP(DS);
1461 TOS += d * sizeof (lforth_t);
1462 }
1463
1464 void
na_plus(fcode_env_t * env)1465 na_plus(fcode_env_t *env)
1466 {
1467 fstack_t d;
1468
1469 CHECK_DEPTH(env, 2, "na+");
1470 d = POP(DS);
1471 TOS += d * sizeof (fstack_t);
1472 }
1473
1474 void
char_plus(fcode_env_t * env)1475 char_plus(fcode_env_t *env)
1476 {
1477 CHECK_DEPTH(env, 1, "char+");
1478 TOS += sizeof (char);
1479 }
1480
1481 void
wa1_plus(fcode_env_t * env)1482 wa1_plus(fcode_env_t *env)
1483 {
1484 CHECK_DEPTH(env, 1, "wa1+");
1485 TOS += sizeof (wforth_t);
1486 }
1487
1488 void
la1_plus(fcode_env_t * env)1489 la1_plus(fcode_env_t *env)
1490 {
1491 CHECK_DEPTH(env, 1, "la1+");
1492 TOS += sizeof (lforth_t);
1493 }
1494
1495 void
cell_plus(fcode_env_t * env)1496 cell_plus(fcode_env_t *env)
1497 {
1498 CHECK_DEPTH(env, 1, "cell+");
1499 TOS += sizeof (fstack_t);
1500 }
1501
1502 void
do_chars(fcode_env_t * env)1503 do_chars(fcode_env_t *env)
1504 {
1505 CHECK_DEPTH(env, 1, "chars");
1506 }
1507
1508 void
slash_w_times(fcode_env_t * env)1509 slash_w_times(fcode_env_t *env)
1510 {
1511 CHECK_DEPTH(env, 1, "/w*");
1512 TOS *= sizeof (wforth_t);
1513 }
1514
1515 void
slash_l_times(fcode_env_t * env)1516 slash_l_times(fcode_env_t *env)
1517 {
1518 CHECK_DEPTH(env, 1, "/l*");
1519 TOS *= sizeof (lforth_t);
1520 }
1521
1522 void
cells(fcode_env_t * env)1523 cells(fcode_env_t *env)
1524 {
1525 CHECK_DEPTH(env, 1, "cells");
1526 TOS *= sizeof (fstack_t);
1527 }
1528
1529 void
do_on(fcode_env_t * env)1530 do_on(fcode_env_t *env)
1531 {
1532 variable_t *d;
1533
1534 CHECK_DEPTH(env, 1, "on");
1535 d = (variable_t *)POP(DS);
1536 *d = -1;
1537 }
1538
1539 void
do_off(fcode_env_t * env)1540 do_off(fcode_env_t *env)
1541 {
1542 variable_t *d;
1543
1544 CHECK_DEPTH(env, 1, "off");
1545 d = (variable_t *)POP(DS);
1546 *d = 0;
1547 }
1548
1549 void
fetch(fcode_env_t * env)1550 fetch(fcode_env_t *env)
1551 {
1552 CHECK_DEPTH(env, 1, "@");
1553 TOS = *((variable_t *)TOS);
1554 }
1555
1556 void
lfetch(fcode_env_t * env)1557 lfetch(fcode_env_t *env)
1558 {
1559 CHECK_DEPTH(env, 1, "l@");
1560 TOS = *((lforth_t *)TOS);
1561 }
1562
1563 void
wfetch(fcode_env_t * env)1564 wfetch(fcode_env_t *env)
1565 {
1566 CHECK_DEPTH(env, 1, "w@");
1567 TOS = *((wforth_t *)TOS);
1568 }
1569
1570 void
swfetch(fcode_env_t * env)1571 swfetch(fcode_env_t *env)
1572 {
1573 CHECK_DEPTH(env, 1, "<w@");
1574 TOS = *((s_wforth_t *)TOS);
1575 }
1576
1577 void
cfetch(fcode_env_t * env)1578 cfetch(fcode_env_t *env)
1579 {
1580 CHECK_DEPTH(env, 1, "c@");
1581 TOS = *((uchar_t *)TOS);
1582 }
1583
1584 void
store(fcode_env_t * env)1585 store(fcode_env_t *env)
1586 {
1587 variable_t *dptr;
1588
1589 CHECK_DEPTH(env, 2, "!");
1590 dptr = (variable_t *)POP(DS);
1591 *dptr = POP(DS);
1592 }
1593
1594 void
addstore(fcode_env_t * env)1595 addstore(fcode_env_t *env)
1596 {
1597 variable_t *dptr;
1598
1599 CHECK_DEPTH(env, 2, "+!");
1600 dptr = (variable_t *)POP(DS);
1601 *dptr = POP(DS) + *dptr;
1602 }
1603
1604 void
lstore(fcode_env_t * env)1605 lstore(fcode_env_t *env)
1606 {
1607 lforth_t *dptr;
1608
1609 CHECK_DEPTH(env, 2, "l!");
1610 dptr = (lforth_t *)POP(DS);
1611 *dptr = (lforth_t)POP(DS);
1612 }
1613
1614 void
wstore(fcode_env_t * env)1615 wstore(fcode_env_t *env)
1616 {
1617 wforth_t *dptr;
1618
1619 CHECK_DEPTH(env, 2, "w!");
1620 dptr = (wforth_t *)POP(DS);
1621 *dptr = (wforth_t)POP(DS);
1622 }
1623
1624 void
cstore(fcode_env_t * env)1625 cstore(fcode_env_t *env)
1626 {
1627 uchar_t *dptr;
1628
1629 CHECK_DEPTH(env, 2, "c!");
1630 dptr = (uchar_t *)POP(DS);
1631 *dptr = (uchar_t)POP(DS);
1632 }
1633
1634 void
two_fetch(fcode_env_t * env)1635 two_fetch(fcode_env_t *env)
1636 {
1637 variable_t *d;
1638
1639 CHECK_DEPTH(env, 1, "2@");
1640 d = (variable_t *)POP(DS);
1641 PUSH(DS, (fstack_t)(d + 1));
1642 unaligned_fetch(env);
1643 PUSH(DS, (fstack_t)d);
1644 unaligned_fetch(env);
1645 }
1646
1647 void
two_store(fcode_env_t * env)1648 two_store(fcode_env_t *env)
1649 {
1650 variable_t *d;
1651
1652 CHECK_DEPTH(env, 3, "2!");
1653 d = (variable_t *)POP(DS);
1654 PUSH(DS, (fstack_t)d);
1655 unaligned_store(env);
1656 PUSH(DS, (fstack_t)(d + 1));
1657 unaligned_store(env);
1658 }
1659
1660 /*
1661 * 'move' Fcode reimplemented in fcdriver to check for mapped addresses.
1662 */
1663 void
fc_move(fcode_env_t * env)1664 fc_move(fcode_env_t *env)
1665 {
1666 void *dest, *src;
1667 size_t len;
1668
1669 CHECK_DEPTH(env, 3, "move");
1670 len = (size_t)POP(DS);
1671 dest = (void *)POP(DS);
1672 src = (void *)POP(DS);
1673
1674 memmove(dest, src, len);
1675 }
1676
1677 void
fc_fill(fcode_env_t * env)1678 fc_fill(fcode_env_t *env)
1679 {
1680 void *dest;
1681 uchar_t val;
1682 size_t len;
1683
1684 CHECK_DEPTH(env, 3, "fill");
1685 val = (uchar_t)POP(DS);
1686 len = (size_t)POP(DS);
1687 dest = (void *)POP(DS);
1688 memset(dest, val, len);
1689 }
1690
1691 void
fc_comp(fcode_env_t * env)1692 fc_comp(fcode_env_t *env)
1693 {
1694 char *str1, *str2;
1695 size_t len;
1696 int res;
1697
1698 CHECK_DEPTH(env, 3, "comp");
1699 len = (size_t)POP(DS);
1700 str1 = (char *)POP(DS);
1701 str2 = (char *)POP(DS);
1702 res = memcmp(str2, str1, len);
1703 if (res > 0)
1704 res = 1;
1705 else if (res < 0)
1706 res = -1;
1707 PUSH(DS, res);
1708 }
1709
1710 void
set_temporary_compile(fcode_env_t * env)1711 set_temporary_compile(fcode_env_t *env)
1712 {
1713 if (!env->state) {
1714 token_roundup(env, "set_temporary_compile");
1715 PUSH(RS, (fstack_t)HERE);
1716 env->state = 3;
1717 COMPILE_TOKEN(&do_colon);
1718 }
1719 }
1720
1721 void
bmark(fcode_env_t * env)1722 bmark(fcode_env_t *env)
1723 {
1724 set_temporary_compile(env);
1725 env->level++;
1726 PUSH(DS, (fstack_t)HERE);
1727 }
1728
1729 void
temporary_execute(fcode_env_t * env)1730 temporary_execute(fcode_env_t *env)
1731 {
1732 uchar_t *saved_here;
1733
1734 if ((env->level == 0) && (env->state & 2)) {
1735 fstack_t d = POP(RS);
1736
1737 semi(env);
1738
1739 saved_here = HERE;
1740 /* execute the temporary definition */
1741 env->state &= ~2;
1742 PUSH(DS, d);
1743 execute(env);
1744
1745 /* now wind the dictionary back! */
1746 if (saved_here != HERE) {
1747 debug_msg(DEBUG_COMMA, "Ignoring set_here in"
1748 " temporary_execute\n");
1749 } else
1750 set_here(env, (uchar_t *)d, "temporary_execute");
1751 }
1752 }
1753
1754 void
bresolve(fcode_env_t * env)1755 bresolve(fcode_env_t *env)
1756 {
1757 token_t *prev = (token_t *)POP(DS);
1758
1759 env->level--;
1760 *prev = (token_t)HERE;
1761 temporary_execute(env);
1762 }
1763
1764 #define BRANCH_IP(ipp) ((token_t *)(*((token_t *)(ipp))))
1765
1766 void
do_bbranch(fcode_env_t * env)1767 do_bbranch(fcode_env_t *env)
1768 {
1769 IP = BRANCH_IP(IP);
1770 }
1771
1772 void
do_bqbranch(fcode_env_t * env)1773 do_bqbranch(fcode_env_t *env)
1774 {
1775 fstack_t flag;
1776
1777 CHECK_DEPTH(env, 1, "b?branch");
1778 flag = POP(DS);
1779 if (flag) {
1780 IP++;
1781 } else {
1782 IP = BRANCH_IP(IP);
1783 }
1784 }
1785
1786 void
do_bofbranch(fcode_env_t * env)1787 do_bofbranch(fcode_env_t *env)
1788 {
1789 fstack_t d;
1790
1791 CHECK_DEPTH(env, 2, "bofbranch");
1792 d = POP(DS);
1793 if (d == TOS) {
1794 (void) POP(DS);
1795 IP++;
1796 } else {
1797 IP = BRANCH_IP(IP);
1798 }
1799 }
1800
1801 void
do_bleave(fcode_env_t * env)1802 do_bleave(fcode_env_t *env)
1803 {
1804 CHECK_RETURN_DEPTH(env, 3, "do_bleave");
1805 (void) POP(RS);
1806 (void) POP(RS);
1807 IP = (token_t *)POP(RS);
1808 }
1809
1810 void
loop_inc(fcode_env_t * env,fstack_t inc)1811 loop_inc(fcode_env_t *env, fstack_t inc)
1812 {
1813 ufstack_t a;
1814
1815 CHECK_RETURN_DEPTH(env, 2, "loop_inc");
1816
1817 /*
1818 * Note: end condition is when the sign bit of R[0] changes.
1819 */
1820 a = RS[0];
1821 RS[0] += inc;
1822 if (((a ^ RS[0]) & SIGN_BIT) == 0) {
1823 IP = BRANCH_IP(IP);
1824 } else {
1825 do_bleave(env);
1826 }
1827 }
1828
1829 void
do_bloop(fcode_env_t * env)1830 do_bloop(fcode_env_t *env)
1831 {
1832 loop_inc(env, 1);
1833 }
1834
1835 void
do_bploop(fcode_env_t * env)1836 do_bploop(fcode_env_t *env)
1837 {
1838 fstack_t d;
1839
1840 CHECK_DEPTH(env, 1, "+loop");
1841 d = POP(DS);
1842 loop_inc(env, d);
1843 }
1844
1845 void
loop_common(fcode_env_t * env,fstack_t ptr)1846 loop_common(fcode_env_t *env, fstack_t ptr)
1847 {
1848 short offset = get_short(env);
1849
1850 COMPILE_TOKEN(ptr);
1851 env->level--;
1852 compile_comma(env);
1853 bresolve(env);
1854 }
1855
1856 void
bloop(fcode_env_t * env)1857 bloop(fcode_env_t *env)
1858 {
1859 loop_common(env, (fstack_t)&do_loop_ptr);
1860 }
1861
1862 void
bplusloop(fcode_env_t * env)1863 bplusloop(fcode_env_t *env)
1864 {
1865 loop_common(env, (fstack_t)&do_ploop_ptr);
1866 }
1867
1868 void
common_do(fcode_env_t * env,fstack_t endpt,fstack_t start,fstack_t limit)1869 common_do(fcode_env_t *env, fstack_t endpt, fstack_t start, fstack_t limit)
1870 {
1871 ufstack_t i, l;
1872
1873 /*
1874 * Same computation as OBP, sets up so that loop_inc will terminate
1875 * when the sign bit of RS[0] changes.
1876 */
1877 i = (start - limit) - SIGN_BIT;
1878 l = limit + SIGN_BIT;
1879 PUSH(RS, endpt);
1880 PUSH(RS, l);
1881 PUSH(RS, i);
1882 }
1883
1884 void
do_bdo(fcode_env_t * env)1885 do_bdo(fcode_env_t *env)
1886 {
1887 fstack_t lo, hi;
1888 fstack_t endpt;
1889
1890 CHECK_DEPTH(env, 2, "bdo");
1891 endpt = (fstack_t)BRANCH_IP(IP);
1892 IP++;
1893 lo = POP(DS);
1894 hi = POP(DS);
1895 common_do(env, endpt, lo, hi);
1896 }
1897
1898 void
do_bqdo(fcode_env_t * env)1899 do_bqdo(fcode_env_t *env)
1900 {
1901 fstack_t lo, hi;
1902 fstack_t endpt;
1903
1904 CHECK_DEPTH(env, 2, "b?do");
1905 endpt = (fstack_t)BRANCH_IP(IP);
1906 IP++;
1907 lo = POP(DS);
1908 hi = POP(DS);
1909 if (lo == hi) {
1910 IP = (token_t *)endpt;
1911 } else {
1912 common_do(env, endpt, lo, hi);
1913 }
1914 }
1915
1916 void
compile_do_common(fcode_env_t * env,fstack_t ptr)1917 compile_do_common(fcode_env_t *env, fstack_t ptr)
1918 {
1919 set_temporary_compile(env);
1920 COMPILE_TOKEN(ptr);
1921 bmark(env);
1922 COMPILE_TOKEN(0);
1923 bmark(env);
1924 }
1925
1926 void
bdo(fcode_env_t * env)1927 bdo(fcode_env_t *env)
1928 {
1929 short offset = (short)get_short(env);
1930 compile_do_common(env, (fstack_t)&do_bdo_ptr);
1931 }
1932
1933 void
bqdo(fcode_env_t * env)1934 bqdo(fcode_env_t *env)
1935 {
1936 short offset = (short)get_short(env);
1937 compile_do_common(env, (fstack_t)&do_bqdo_ptr);
1938 }
1939
1940 void
loop_i(fcode_env_t * env)1941 loop_i(fcode_env_t *env)
1942 {
1943 fstack_t i;
1944
1945 CHECK_RETURN_DEPTH(env, 2, "i");
1946 i = RS[0] + RS[-1];
1947 PUSH(DS, i);
1948 }
1949
1950 void
loop_j(fcode_env_t * env)1951 loop_j(fcode_env_t *env)
1952 {
1953 fstack_t j;
1954
1955 CHECK_RETURN_DEPTH(env, 5, "j");
1956 j = RS[-3] + RS[-4];
1957 PUSH(DS, j);
1958 }
1959
1960 void
bleave(fcode_env_t * env)1961 bleave(fcode_env_t *env)
1962 {
1963
1964 if (env->state) {
1965 COMPILE_TOKEN(&do_leave_ptr);
1966 }
1967 }
1968
1969 void
push_string(fcode_env_t * env,char * str,int len)1970 push_string(fcode_env_t *env, char *str, int len)
1971 {
1972 #define NSTRINGS 16
1973 static int string_count = 0;
1974 static int buflen[NSTRINGS];
1975 static char *buffer[NSTRINGS];
1976 char *dest;
1977
1978 if (!len) {
1979 PUSH(DS, 0);
1980 PUSH(DS, 0);
1981 return;
1982 }
1983 if (len != buflen[string_count]) {
1984 if (buffer[string_count]) FREE(buffer[string_count]);
1985 buffer[ string_count ] = (char *)MALLOC(len+1);
1986 buflen[ string_count ] = len;
1987 }
1988 dest = buffer[ string_count++ ];
1989 string_count = string_count%NSTRINGS;
1990 memcpy(dest, str, len);
1991 *(dest+len) = 0;
1992 PUSH(DS, (fstack_t)dest);
1993 PUSH(DS, len);
1994 #undef NSTRINGS
1995 }
1996
1997 void
parse_word(fcode_env_t * env)1998 parse_word(fcode_env_t *env)
1999 {
2000 int len = 0;
2001 char *next, *dest, *here = "";
2002
2003 if (env->input) {
2004 here = env->input->scanptr;
2005 while (*here == env->input->separator) here++;
2006 next = strchr(here, env->input->separator);
2007 if (next) {
2008 len = next - here;
2009 while (*next == env->input->separator) next++;
2010 } else {
2011 len = strlen(here);
2012 next = here + len;
2013 }
2014 env->input->scanptr = next;
2015 }
2016 push_string(env, here, len);
2017 }
2018
2019 void
install_does(fcode_env_t * env)2020 install_does(fcode_env_t *env)
2021 {
2022 token_t *dptr;
2023
2024 dptr = (token_t *)LINK_TO_ACF(env->lastlink);
2025
2026 log_message(MSG_WARN, "install_does: Last acf at: %p\n", (void *)dptr);
2027
2028 *dptr = ((token_t)(IP+1)) | 1;
2029 }
2030
2031 void
does(fcode_env_t * env)2032 does(fcode_env_t *env)
2033 {
2034 token_t *dptr;
2035
2036 token_roundup(env, "does");
2037
2038 if (env->state) {
2039 COMPILE_TOKEN(&does_ptr);
2040 COMPILE_TOKEN(&semi_ptr);
2041 } else {
2042 dptr = (token_t *)LINK_TO_ACF(env->lastlink);
2043 log_message(MSG_WARN, "does: Last acf at: %p\n", (void *)dptr);
2044 *dptr = ((token_t)(HERE)) | 1;
2045 env->state |= 1;
2046 }
2047 COMPILE_TOKEN(&do_colon);
2048 }
2049
2050 void
do_current(fcode_env_t * env)2051 do_current(fcode_env_t *env)
2052 {
2053 debug_msg(DEBUG_CONTEXT, "CONTEXT:pushing &CURRENT\n");
2054 PUSH(DS, (fstack_t)&env->current);
2055 }
2056
2057 void
do_context(fcode_env_t * env)2058 do_context(fcode_env_t *env)
2059 {
2060 debug_msg(DEBUG_CONTEXT, "CONTEXT:pushing &CONTEXT\n");
2061 PUSH(DS, (fstack_t)&CONTEXT);
2062 }
2063
2064 void
do_definitions(fcode_env_t * env)2065 do_definitions(fcode_env_t *env)
2066 {
2067 env->current = CONTEXT;
2068 debug_msg(DEBUG_CONTEXT, "CONTEXT:definitions: %d/%p/%p\n",
2069 env->order_depth, CONTEXT, env->current);
2070 }
2071
2072 void
make_header(fcode_env_t * env,int flags)2073 make_header(fcode_env_t *env, int flags)
2074 {
2075 int len;
2076 char *name;
2077
2078 name = parse_a_string(env, &len);
2079 header(env, name, len, flags);
2080 }
2081
2082 void
do_creator(fcode_env_t * env)2083 do_creator(fcode_env_t *env)
2084 {
2085 make_header(env, 0);
2086 COMPILE_TOKEN(&do_create);
2087 expose_acf(env, "<create>");
2088 }
2089
2090 void
create(fcode_env_t * env)2091 create(fcode_env_t *env)
2092 {
2093 if (env->state) {
2094 COMPILE_TOKEN(&create_ptr);
2095 } else
2096 do_creator(env);
2097 }
2098
2099 void
colon(fcode_env_t * env)2100 colon(fcode_env_t *env)
2101 {
2102 make_header(env, 0);
2103 env->state |= 1;
2104 COMPILE_TOKEN(&do_colon);
2105 }
2106
2107 void
recursive(fcode_env_t * env)2108 recursive(fcode_env_t *env)
2109 {
2110 expose_acf(env, "<recursive>");
2111 }
2112
2113 void
compile_string(fcode_env_t * env)2114 compile_string(fcode_env_t *env)
2115 {
2116 int len;
2117 uchar_t *str, *tostr;
2118
2119 COMPILE_TOKEN("e_ptr);
2120 len = POP(DS);
2121 str = (uchar_t *)POP(DS);
2122 tostr = HERE;
2123 *tostr++ = len;
2124 while (len--)
2125 *tostr++ = *str++;
2126 *tostr++ = '\0';
2127 set_here(env, tostr, "compile_string");
2128 token_roundup(env, "compile_string");
2129 }
2130
2131 void
run_quote(fcode_env_t * env)2132 run_quote(fcode_env_t *env)
2133 {
2134 char osep;
2135
2136 osep = env->input->separator;
2137 env->input->separator = '"';
2138 parse_word(env);
2139 env->input->separator = osep;
2140
2141 if (env->state) {
2142 compile_string(env);
2143 }
2144 }
2145
2146 void
does_vocabulary(fcode_env_t * env)2147 does_vocabulary(fcode_env_t *env)
2148 {
2149 CONTEXT = WA;
2150 debug_msg(DEBUG_CONTEXT, "CONTEXT:vocabulary: %d/%p/%p\n",
2151 env->order_depth, CONTEXT, env->current);
2152 }
2153
2154 void
do_vocab(fcode_env_t * env)2155 do_vocab(fcode_env_t *env)
2156 {
2157 make_header(env, 0);
2158 COMPILE_TOKEN(does_vocabulary);
2159 PUSH(DS, 0);
2160 compile_comma(env);
2161 expose_acf(env, "<vocabulary>");
2162 }
2163
2164 void
do_forth(fcode_env_t * env)2165 do_forth(fcode_env_t *env)
2166 {
2167 CONTEXT = (token_t *)(&env->forth_voc_link);
2168 debug_msg(DEBUG_CONTEXT, "CONTEXT:forth: %d/%p/%p\n",
2169 env->order_depth, CONTEXT, env->current);
2170 }
2171
2172 acf_t
voc_find(fcode_env_t * env)2173 voc_find(fcode_env_t *env)
2174 {
2175 token_t *voc;
2176 token_t *dptr;
2177 char *find_name, *name;
2178
2179 voc = (token_t *)POP(DS);
2180 find_name = pop_a_string(env, NULL);
2181
2182 for (dptr = (token_t *)(*voc); dptr; dptr = (token_t *)(*dptr)) {
2183 if ((name = get_name(dptr)) == NULL)
2184 continue;
2185 if (strcmp(find_name, name) == 0) {
2186 debug_msg(DEBUG_VOC_FIND, "%s -> %p\n", find_name,
2187 LINK_TO_ACF(dptr));
2188 return (LINK_TO_ACF(dptr));
2189 }
2190 }
2191 debug_msg(DEBUG_VOC_FIND, "%s not found\n", find_name);
2192 return (NULL);
2193 }
2194
2195 void
dollar_find(fcode_env_t * env)2196 dollar_find(fcode_env_t *env)
2197 {
2198 acf_t acf = NULL;
2199 int i;
2200
2201 CHECK_DEPTH(env, 2, "$find");
2202 for (i = env->order_depth; i >= 0 && env->order[i] && !acf; i--) {
2203 two_dup(env);
2204 PUSH(DS, (fstack_t)env->order[i]);
2205 acf = voc_find(env);
2206 }
2207 if (acf) {
2208 two_drop(env);
2209 PUSH(DS, (fstack_t)acf);
2210 PUSH(DS, TRUE);
2211 } else
2212 PUSH(DS, FALSE);
2213 }
2214
2215 void
interpret(fcode_env_t * env)2216 interpret(fcode_env_t *env)
2217 {
2218 char *name;
2219
2220 parse_word(env);
2221 while (TOS) {
2222 two_dup(env);
2223 dollar_find(env);
2224 if (TOS) {
2225 flag_t *flags;
2226
2227 drop(env);
2228 nip(env);
2229 nip(env);
2230 flags = LINK_TO_FLAGS(ACF_TO_LINK(TOS));
2231
2232 if ((env->state) &&
2233 ((*flags & IMMEDIATE) == 0)) {
2234 /* Compile in references */
2235 compile_comma(env);
2236 } else {
2237 execute(env);
2238 }
2239 } else {
2240 int bad;
2241 drop(env);
2242 dollar_number(env);
2243 bad = POP(DS);
2244 if (bad) {
2245 two_dup(env);
2246 name = pop_a_string(env, NULL);
2247 log_message(MSG_INFO, "%s?\n", name);
2248 break;
2249 } else {
2250 nip(env);
2251 nip(env);
2252 literal(env);
2253 }
2254 }
2255 parse_word(env);
2256 }
2257 two_drop(env);
2258 }
2259
2260 void
evaluate(fcode_env_t * env)2261 evaluate(fcode_env_t *env)
2262 {
2263 input_typ *old_input = env->input;
2264 input_typ *eval_bufp = MALLOC(sizeof (input_typ));
2265
2266 CHECK_DEPTH(env, 2, "evaluate");
2267 eval_bufp->separator = ' ';
2268 eval_bufp->maxlen = POP(DS);
2269 eval_bufp->buffer = (char *)POP(DS);
2270 eval_bufp->scanptr = eval_bufp->buffer;
2271 env->input = eval_bufp;
2272 interpret(env);
2273 FREE(eval_bufp);
2274 env->input = old_input;
2275 }
2276
2277 void
make_common_access(fcode_env_t * env,char * name,int len,int ncells,int instance_mode,void (* acf_instance)(fcode_env_t * env),void (* acf_static)(fcode_env_t * env),void (* set_action)(fcode_env_t * env,int))2278 make_common_access(fcode_env_t *env,
2279 char *name, int len,
2280 int ncells,
2281 int instance_mode,
2282 void (*acf_instance)(fcode_env_t *env),
2283 void (*acf_static)(fcode_env_t *env),
2284 void (*set_action)(fcode_env_t *env, int))
2285 {
2286 if (instance_mode && !MYSELF) {
2287 system_message(env, "No instance context");
2288 }
2289
2290 debug_msg(DEBUG_ACTIONS, "make_common_access:%s '%s', %d\n",
2291 (instance_mode ? "instance" : ""),
2292 (name ? name : ""), ncells);
2293
2294 if (len)
2295 header(env, name, len, 0);
2296 if (instance_mode) {
2297 token_t *dptr;
2298 int offset;
2299
2300 COMPILE_TOKEN(acf_instance);
2301 dptr = alloc_instance_data(env, INIT_DATA, ncells, &offset);
2302 debug_msg(DEBUG_ACTIONS, "Data: %p, offset %d\n", (char *)dptr,
2303 offset);
2304 PUSH(DS, offset);
2305 compile_comma(env);
2306 while (ncells--)
2307 *dptr++ = MYSELF->data[INIT_DATA][offset++] = POP(DS);
2308 env->instance_mode = 0;
2309 } else {
2310 COMPILE_TOKEN(acf_static);
2311 while (ncells--)
2312 compile_comma(env);
2313 }
2314 expose_acf(env, name);
2315 if (set_action)
2316 set_action(env, instance_mode);
2317 }
2318
2319 void
do_constant(fcode_env_t * env)2320 do_constant(fcode_env_t *env)
2321 {
2322 PUSH(DS, (variable_t)(*WA));
2323 }
2324
2325 void
do_crash(fcode_env_t * env)2326 do_crash(fcode_env_t *env)
2327 {
2328 forth_abort(env, "Unitialized defer");
2329 }
2330
2331 /*
2332 * 'behavior' Fcode retrieve execution behavior for a defer word.
2333 */
2334 static void
behavior(fcode_env_t * env)2335 behavior(fcode_env_t *env)
2336 {
2337 acf_t defer_xt;
2338 token_t token;
2339 acf_t contents_xt;
2340
2341 CHECK_DEPTH(env, 1, "behavior");
2342 defer_xt = (acf_t)POP(DS);
2343 token = *defer_xt;
2344 contents_xt = (token_t *)(token & ~1);
2345 if ((token & 1) == 0 || *contents_xt != (token_t)&do_default_action)
2346 forth_abort(env, "behavior: bad xt: %p indir: %x/%p\n",
2347 defer_xt, token & 1, *contents_xt);
2348 defer_xt++;
2349 PUSH(DS, *((variable_t *)defer_xt));
2350 }
2351
2352 void
fc_abort(fcode_env_t * env,char * type)2353 fc_abort(fcode_env_t *env, char *type)
2354 {
2355 forth_abort(env, "%s Fcode '%s' Executed", type,
2356 acf_to_name(env, WA - 1));
2357 }
2358
2359 void
f_abort(fcode_env_t * env)2360 f_abort(fcode_env_t *env)
2361 {
2362 fc_abort(env, "Abort");
2363 }
2364
2365 /*
2366 * Fcodes chosen not to support.
2367 */
2368 void
fc_unimplemented(fcode_env_t * env)2369 fc_unimplemented(fcode_env_t *env)
2370 {
2371 fc_abort(env, "Unimplemented");
2372 }
2373
2374 /*
2375 * Fcodes that are Obsolete per P1275-1994.
2376 */
2377 void
fc_obsolete(fcode_env_t * env)2378 fc_obsolete(fcode_env_t *env)
2379 {
2380 fc_abort(env, "Obsolete");
2381 }
2382
2383 /*
2384 * Fcodes that are Historical per P1275-1994
2385 */
2386 void
fc_historical(fcode_env_t * env)2387 fc_historical(fcode_env_t *env)
2388 {
2389 fc_abort(env, "Historical");
2390 }
2391
2392 void
catch(fcode_env_t * env)2393 catch(fcode_env_t *env)
2394 {
2395 error_frame *new;
2396
2397 CHECK_DEPTH(env, 1, "catch");
2398 new = MALLOC(sizeof (error_frame));
2399 new->ds = DS-1;
2400 new->rs = RS;
2401 new->myself = MYSELF;
2402 new->next = env->catch_frame;
2403 new->code = 0;
2404 env->catch_frame = new;
2405 execute(env);
2406 PUSH(DS, new->code);
2407 env->catch_frame = new->next;
2408 FREE(new);
2409 }
2410
2411 void
throw_from_fclib(fcode_env_t * env,fstack_t errcode,char * fmt,...)2412 throw_from_fclib(fcode_env_t *env, fstack_t errcode, char *fmt, ...)
2413 {
2414 error_frame *efp;
2415 va_list ap;
2416 char msg[256];
2417
2418 va_start(ap, fmt);
2419 vsprintf(msg, fmt, ap);
2420
2421 if (errcode) {
2422
2423 env->last_error = errcode;
2424
2425 /*
2426 * No catch frame set => fatal error
2427 */
2428 efp = env->catch_frame;
2429 if (!efp)
2430 forth_abort(env, "%s: No catch frame", msg);
2431
2432 debug_msg(DEBUG_TRACING, "throw_from_fclib: throw: %s\n", msg);
2433
2434 /*
2435 * Setting IP=0 will force the unwinding of the calls
2436 * (see execute) which is how we will return (eventually)
2437 * to the test in catch that follows 'execute'.
2438 */
2439 DS = efp->ds;
2440 RS = efp->rs;
2441 MYSELF = efp->myself;
2442 IP = 0;
2443 efp->code = errcode;
2444 }
2445 }
2446
2447 void
throw(fcode_env_t * env)2448 throw(fcode_env_t *env)
2449 {
2450 fstack_t t;
2451
2452 CHECK_DEPTH(env, 1, "throw");
2453 t = POP(DS);
2454 if (t >= -20 && t <= 20)
2455 throw_from_fclib(env, t, "throw Fcode errcode: 0x%x", (int)t);
2456 else {
2457 if (t)
2458 log_message(MSG_ERROR, "throw: errcode: 0x%x\n",
2459 (int)t);
2460 throw_from_fclib(env, t, "throw Fcode err: %s", (char *)t);
2461 }
2462 }
2463
2464 void
tick_literal(fcode_env_t * env)2465 tick_literal(fcode_env_t *env)
2466 {
2467 if (env->state) {
2468 COMPILE_TOKEN(&tlit_ptr);
2469 compile_comma(env);
2470 }
2471 }
2472
2473 void
do_tick(fcode_env_t * env)2474 do_tick(fcode_env_t *env)
2475 {
2476 parse_word(env);
2477 dollar_find(env);
2478 invert(env);
2479 throw(env);
2480 tick_literal(env);
2481 }
2482
2483 void
bracket_tick(fcode_env_t * env)2484 bracket_tick(fcode_env_t *env)
2485 {
2486 do_tick(env);
2487 }
2488
2489 #pragma init(_init)
2490
2491 static void
_init(void)2492 _init(void)
2493 {
2494 fcode_env_t *env = initial_env;
2495
2496 NOTICE;
2497 ASSERT(env);
2498
2499 ANSI(0x019, 0, "i", loop_i);
2500 ANSI(0x01a, 0, "j", loop_j);
2501 ANSI(0x01d, 0, "execute", execute);
2502 ANSI(0x01e, 0, "+", add);
2503 ANSI(0x01f, 0, "-", subtract);
2504 ANSI(0x020, 0, "*", multiply);
2505 ANSI(0x021, 0, "/", divide);
2506 ANSI(0x022, 0, "mod", mod);
2507 FORTH(0, "/mod", slash_mod);
2508 ANSI(0x023, 0, "and", and);
2509 ANSI(0x024, 0, "or", or);
2510 ANSI(0x025, 0, "xor", xor);
2511 ANSI(0x026, 0, "invert", invert);
2512 ANSI(0x027, 0, "lshift", lshift);
2513 ANSI(0x028, 0, "rshift", rshift);
2514 ANSI(0x029, 0, ">>a", rshifta);
2515 ANSI(0x02a, 0, "/mod", slash_mod);
2516 ANSI(0x02b, 0, "u/mod", uslash_mod);
2517 ANSI(0x02c, 0, "negate", negate);
2518 ANSI(0x02d, 0, "abs", f_abs);
2519 ANSI(0x02e, 0, "min", f_min);
2520 ANSI(0x02f, 0, "max", f_max);
2521 ANSI(0x030, 0, ">r", to_r);
2522 ANSI(0x031, 0, "r>", from_r);
2523 ANSI(0x032, 0, "r@", rfetch);
2524 ANSI(0x033, 0, "exit", f_exit);
2525 ANSI(0x034, 0, "0=", zero_equals);
2526 ANSI(0x035, 0, "0<>", zero_not_equals);
2527 ANSI(0x036, 0, "0<", zero_less);
2528 ANSI(0x037, 0, "0<=", zero_less_equals);
2529 ANSI(0x038, 0, "0>", zero_greater);
2530 ANSI(0x039, 0, "0>=", zero_greater_equals);
2531 ANSI(0x03a, 0, "<", less);
2532 ANSI(0x03b, 0, ">", greater);
2533 ANSI(0x03c, 0, "=", equals);
2534 ANSI(0x03d, 0, "<>", not_equals);
2535 ANSI(0x03e, 0, "u>", unsign_greater);
2536 ANSI(0x03f, 0, "u<=", unsign_less_equals);
2537 ANSI(0x040, 0, "u<", unsign_less);
2538 ANSI(0x041, 0, "u>=", unsign_greater_equals);
2539 ANSI(0x042, 0, ">=", greater_equals);
2540 ANSI(0x043, 0, "<=", less_equals);
2541 ANSI(0x044, 0, "between", between);
2542 ANSI(0x045, 0, "within", within);
2543 ANSI(0x046, 0, "drop", drop);
2544 ANSI(0x047, 0, "dup", f_dup);
2545 ANSI(0x048, 0, "over", over);
2546 ANSI(0x049, 0, "swap", swap);
2547 ANSI(0x04a, 0, "rot", rot);
2548 ANSI(0x04b, 0, "-rot", minus_rot);
2549 ANSI(0x04c, 0, "tuck", tuck);
2550 ANSI(0x04d, 0, "nip", nip);
2551 ANSI(0x04e, 0, "pick", pick);
2552 ANSI(0x04f, 0, "roll", roll);
2553 ANSI(0x050, 0, "?dup", qdup);
2554 ANSI(0x051, 0, "depth", depth);
2555 ANSI(0x052, 0, "2drop", two_drop);
2556 ANSI(0x053, 0, "2dup", two_dup);
2557 ANSI(0x054, 0, "2over", two_over);
2558 ANSI(0x055, 0, "2swap", two_swap);
2559 ANSI(0x056, 0, "2rot", two_rot);
2560 ANSI(0x057, 0, "2/", two_slash);
2561 ANSI(0x058, 0, "u2/", utwo_slash);
2562 ANSI(0x059, 0, "2*", two_times);
2563 ANSI(0x05a, 0, "/c", slash_c);
2564 ANSI(0x05b, 0, "/w", slash_w);
2565 ANSI(0x05c, 0, "/l", slash_l);
2566 ANSI(0x05d, 0, "/n", slash_n);
2567 ANSI(0x05e, 0, "ca+", ca_plus);
2568 ANSI(0x05f, 0, "wa+", wa_plus);
2569 ANSI(0x060, 0, "la+", la_plus);
2570 ANSI(0x061, 0, "na+", na_plus);
2571 ANSI(0x062, 0, "char+", char_plus);
2572 ANSI(0x063, 0, "wa1+", wa1_plus);
2573 ANSI(0x064, 0, "la1+", la1_plus);
2574 ANSI(0x065, 0, "cell+", cell_plus);
2575 ANSI(0x066, 0, "chars", do_chars);
2576 ANSI(0x067, 0, "/w*", slash_w_times);
2577 ANSI(0x068, 0, "/l*", slash_l_times);
2578 ANSI(0x069, 0, "cells", cells);
2579 ANSI(0x06a, 0, "on", do_on);
2580 ANSI(0x06b, 0, "off", do_off);
2581 ANSI(0x06c, 0, "+!", addstore);
2582 ANSI(0x06d, 0, "@", fetch);
2583 ANSI(0x06e, 0, "l@", lfetch);
2584 ANSI(0x06f, 0, "w@", wfetch);
2585 ANSI(0x070, 0, "<w@", swfetch);
2586 ANSI(0x071, 0, "c@", cfetch);
2587 ANSI(0x072, 0, "!", store);
2588 ANSI(0x073, 0, "l!", lstore);
2589 ANSI(0x074, 0, "w!", wstore);
2590 ANSI(0x075, 0, "c!", cstore);
2591 ANSI(0x076, 0, "2@", two_fetch);
2592 ANSI(0x077, 0, "2!", two_store);
2593 ANSI(0x078, 0, "move", fc_move);
2594 ANSI(0x079, 0, "fill", fc_fill);
2595 ANSI(0x07a, 0, "comp", fc_comp);
2596 ANSI(0x07b, 0, "noop", noop);
2597 ANSI(0x07c, 0, "lwsplit", lwsplit);
2598 ANSI(0x07d, 0, "wljoin", wljoin);
2599 ANSI(0x07e, 0, "lbsplit", lbsplit);
2600 ANSI(0x07f, 0, "bljoin", bljoin);
2601 ANSI(0x080, 0, "wbflip", wbflip);
2602 ANSI(0x081, 0, "upc", upper_case);
2603 ANSI(0x082, 0, "lcc", lower_case);
2604 ANSI(0x083, 0, "pack", pack_str);
2605 ANSI(0x084, 0, "count", count_str);
2606 ANSI(0x085, 0, "body>", to_acf);
2607 ANSI(0x086, 0, ">body", to_body);
2608
2609 ANSI(0x089, 0, "unloop", unloop);
2610
2611 ANSI(0x09f, 0, ".s", dot_s);
2612 ANSI(0x0a0, 0, "base", base);
2613 FCODE(0x0a1, 0, "convert", fc_historical);
2614 ANSI(0x0a2, 0, "$number", dollar_number);
2615 ANSI(0x0a3, 0, "digit", digit);
2616
2617 ANSI(0x0a9, 0, "bl", space);
2618 ANSI(0x0aa, 0, "bs", backspace);
2619 ANSI(0x0ab, 0, "bell", bell);
2620 ANSI(0x0ac, 0, "bounds", fc_bounds);
2621 ANSI(0x0ad, 0, "here", here);
2622
2623 ANSI(0x0af, 0, "wbsplit", wbsplit);
2624 ANSI(0x0b0, 0, "bwjoin", bwjoin);
2625
2626 P1275(0x0cb, 0, "$find", dollar_find);
2627
2628 ANSI(0x0d0, 0, "c,", ccomma);
2629 ANSI(0x0d1, 0, "w,", wcomma);
2630 ANSI(0x0d2, 0, "l,", lcomma);
2631 ANSI(0x0d3, 0, ",", comma);
2632 ANSI(0x0d4, 0, "um*", um_multiply);
2633 ANSI(0x0d5, 0, "um/mod", um_slash_mod);
2634
2635 ANSI(0x0d8, 0, "d+", d_plus);
2636 ANSI(0x0d9, 0, "d-", d_minus);
2637
2638 ANSI(0x0dc, 0, "state", state);
2639 ANSI(0x0de, 0, "behavior", behavior);
2640 ANSI(0x0dd, 0, "compile,", compile_comma);
2641
2642 ANSI(0x216, 0, "abort", f_abort);
2643 ANSI(0x217, 0, "catch", catch);
2644 ANSI(0x218, 0, "throw", throw);
2645
2646 ANSI(0x226, 0, "lwflip", lwflip);
2647 ANSI(0x227, 0, "lbflip", lbflip);
2648 ANSI(0x228, 0, "lbflips", lbflips);
2649
2650 ANSI(0x236, 0, "wbflips", wbflips);
2651 ANSI(0x237, 0, "lwflips", lwflips);
2652
2653 FORTH(0, "forth", do_forth);
2654 FORTH(0, "current", do_current);
2655 FORTH(0, "context", do_context);
2656 FORTH(0, "definitions", do_definitions);
2657 FORTH(0, "vocabulary", do_vocab);
2658 FORTH(IMMEDIATE, ":", colon);
2659 FORTH(IMMEDIATE, ";", semi);
2660 FORTH(IMMEDIATE, "create", create);
2661 FORTH(IMMEDIATE, "does>", does);
2662 FORTH(IMMEDIATE, "recursive", recursive);
2663 FORTH(0, "parse-word", parse_word);
2664 FORTH(IMMEDIATE, "\"", run_quote);
2665 FORTH(IMMEDIATE, "order", do_order);
2666 FORTH(IMMEDIATE, "also", do_also);
2667 FORTH(IMMEDIATE, "previous", do_previous);
2668 FORTH(IMMEDIATE, "'", do_tick);
2669 FORTH(IMMEDIATE, "[']", bracket_tick);
2670 FORTH(0, "unaligned-l@", unaligned_lfetch);
2671 FORTH(0, "unaligned-l!", unaligned_lstore);
2672 FORTH(0, "unaligned-w@", unaligned_wfetch);
2673 FORTH(0, "unaligned-w!", unaligned_wstore);
2674 }
2675