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