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