xref: /titanic_41/usr/src/lib/efcode/engine/forth.c (revision 3aa1cd26bc498bd7a8d002259dabfe984ccc90d1)
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(&quote_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