xref: /freebsd/stand/ficl/loader.c (revision 2e3507c25e42292b45a5482e116d278f5515d04d) 
1 /*-
2  * Copyright (c) 2000 Daniel Capo Sobral
3  * All rights reserved.
4  *
5  * Redistribution and use in source and binary forms, with or without
6  * modification, are permitted provided that the following conditions
7  * are met:
8  * 1. Redistributions of source code must retain the above copyright
9  *    notice, this list of conditions and the following disclaimer.
10  * 2. Redistributions in binary form must reproduce the above copyright
11  *    notice, this list of conditions and the following disclaimer in the
12  *    documentation and/or other materials provided with the distribution.
13  *
14  * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
15  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17  * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
18  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
19  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
20  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
21  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
22  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
23  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
24  * SUCH DAMAGE.
25  */
26 
27 /*******************************************************************
28 ** l o a d e r . c
29 ** Additional FICL words designed for FreeBSD's loader
30 **
31 *******************************************************************/
32 
33 #ifdef TESTMAIN
34 #include <sys/types.h>
35 #include <sys/stat.h>
36 #include <dirent.h>
37 #include <fcntl.h>
38 #include <stdio.h>
39 #include <stdlib.h>
40 #include <unistd.h>
41 #else
42 #include <stand.h>
43 #endif
44 #include "bootstrap.h"
45 #include <string.h>
46 #include <uuid.h>
47 #include <gfx_fb.h>
48 #include <pnglite.h>
49 #include "ficl.h"
50 
51 /*		FreeBSD's loader interaction words and extras
52  *
53  * 		setenv      ( value n name n' -- )
54  * 		setenv?     ( value n name n' flag -- )
55  * 		getenv      ( addr n -- addr' n' | -1 )
56  * 		unsetenv    ( addr n -- )
57  * 		copyin      ( addr addr' len -- )
58  * 		copyout     ( addr addr' len -- )
59  * 		findfile    ( name len type len' -- addr )
60  * 		pnpdevices  ( -- addr )
61  * 		pnphandlers ( -- addr )
62  * 		ccall       ( [[...[p10] p9] ... p1] n addr -- result )
63  *		uuid-from-string ( addr n -- addr' )
64  *		uuid-to-string ( addr' -- addr n )
65  * 		.#	    ( value -- )
66  */
67 
68 #ifndef TESTMAIN
69 /* ( flags x1 y1 x2 y2 -- flag ) */
70 void
71 ficl_term_putimage(FICL_VM *pVM)
72 {
73         char *namep, *name;
74         int names;
75         unsigned long ret = FICL_FALSE;
76         uint32_t x1, y1, x2, y2, f;
77         png_t png;
78 	int error;
79 
80 #if FICL_ROBUST > 1
81 	vmCheckStack(pVM, 7, 1);
82 #endif
83         names = stackPopINT(pVM->pStack);
84         namep = (char *) stackPopPtr(pVM->pStack);
85         y2 = stackPopINT(pVM->pStack);
86         x2 = stackPopINT(pVM->pStack);
87         y1 = stackPopINT(pVM->pStack);
88         x1 = stackPopINT(pVM->pStack);
89         f = stackPopINT(pVM->pStack);
90 
91 	x1 = gfx_state.tg_origin.tp_col + x1 * gfx_state.tg_font.vf_width;
92 	y1 = gfx_state.tg_origin.tp_row + y1 * gfx_state.tg_font.vf_height;
93 	if (x2 != 0) {
94 		x2 = gfx_state.tg_origin.tp_col +
95 		    x2 * gfx_state.tg_font.vf_width;
96 	}
97 	if (y2 != 0) {
98 		y2 = gfx_state.tg_origin.tp_row +
99 		    y2 * gfx_state.tg_font.vf_height;
100 	}
101 
102         name = ficlMalloc(names + 1);
103         if (!name)
104 		vmThrowErr(pVM, "Error: out of memory");
105         (void) strncpy(name, namep, names);
106         name[names] = '\0';
107 
108         if ((error = png_open(&png, name)) != PNG_NO_ERROR) {
109 		if (f & FL_PUTIMAGE_DEBUG)
110 			printf("%s\n", png_error_string(error));
111 	} else {
112                 if (gfx_fb_putimage(&png, x1, y1, x2, y2, f) == 0)
113                         ret = FICL_TRUE;        /* success */
114                 (void) png_close(&png);
115 	}
116         ficlFree(name);
117 	stackPushUNS(pVM->pStack, ret);
118 }
119 
120 /* ( flags x1 y1 x2 y2 -- flag ) */
121 void
122 ficl_fb_putimage(FICL_VM *pVM)
123 {
124         char *namep, *name;
125         int names;
126         unsigned long ret = FICL_FALSE;
127         uint32_t x1, y1, x2, y2, f;
128         png_t png;
129 	int error;
130 
131 #if FICL_ROBUST > 1
132 	vmCheckStack(pVM, 7, 1);
133 #endif
134         names = stackPopINT(pVM->pStack);
135         namep = (char *) stackPopPtr(pVM->pStack);
136         y2 = stackPopINT(pVM->pStack);
137         x2 = stackPopINT(pVM->pStack);
138         y1 = stackPopINT(pVM->pStack);
139         x1 = stackPopINT(pVM->pStack);
140         f = stackPopINT(pVM->pStack);
141 
142         name = ficlMalloc(names + 1);
143         if (!name)
144 		vmThrowErr(pVM, "Error: out of memory");
145         (void) strncpy(name, namep, names);
146         name[names] = '\0';
147 
148         if ((error = png_open(&png, name)) != PNG_NO_ERROR) {
149 		if (f & FL_PUTIMAGE_DEBUG)
150 			printf("%s\n", png_error_string(error));
151 	} else {
152                 if (gfx_fb_putimage(&png, x1, y1, x2, y2, f) == 0)
153                         ret = FICL_TRUE;        /* success */
154                 (void) png_close(&png);
155 	}
156         ficlFree(name);
157 	stackPushUNS(pVM->pStack, ret);
158 }
159 
160 void
161 ficl_fb_setpixel(FICL_VM *pVM)
162 {
163         FICL_UNS x, y;
164 
165 #if FICL_ROBUST > 1
166 	vmCheckStack(pVM, 2, 0);
167 #endif
168 
169         y = stackPopUNS(pVM->pStack);
170         x = stackPopUNS(pVM->pStack);
171         gfx_fb_setpixel(x, y);
172 }
173 
174 void
175 ficl_fb_line(FICL_VM *pVM)
176 {
177 	FICL_UNS x0, y0, x1, y1, wd;
178 
179 #if FICL_ROBUST > 1
180 	vmCheckStack(pVM, 5, 0);
181 #endif
182 
183 	wd = stackPopUNS(pVM->pStack);
184 	y1 = stackPopUNS(pVM->pStack);
185 	x1 = stackPopUNS(pVM->pStack);
186 	y0 = stackPopUNS(pVM->pStack);
187 	x0 = stackPopUNS(pVM->pStack);
188 	gfx_fb_line(x0, y0, x1, y1, wd);
189 }
190 
191 void
192 ficl_fb_bezier(FICL_VM *pVM)
193 {
194 	FICL_UNS x0, y0, x1, y1, x2, y2, width;
195 
196 #if FICL_ROBUST > 1
197 	vmCheckStack(pVM, 7, 0);
198 #endif
199 
200 	width = stackPopUNS(pVM->pStack);
201 	y2 = stackPopUNS(pVM->pStack);
202 	x2 = stackPopUNS(pVM->pStack);
203 	y1 = stackPopUNS(pVM->pStack);
204 	x1 = stackPopUNS(pVM->pStack);
205 	y0 = stackPopUNS(pVM->pStack);
206 	x0 = stackPopUNS(pVM->pStack);
207 	gfx_fb_bezier(x0, y0, x1, y1, x2, y2, width);
208 }
209 
210 void
211 ficl_fb_drawrect(FICL_VM *pVM)
212 {
213 	FICL_UNS x1, x2, y1, y2, fill;
214 
215 #if FICL_ROBUST > 1
216 	vmCheckStack(pVM, 5, 0);
217 #endif
218 
219 	fill = stackPopUNS(pVM->pStack);
220 	y2 = stackPopUNS(pVM->pStack);
221 	x2 = stackPopUNS(pVM->pStack);
222 	y1 = stackPopUNS(pVM->pStack);
223 	x1 = stackPopUNS(pVM->pStack);
224 	gfx_fb_drawrect(x1, y1, x2, y2, fill);
225 }
226 
227 void
228 ficl_term_drawrect(FICL_VM *pVM)
229 {
230 	FICL_UNS x1, x2, y1, y2;
231 
232 #if FICL_ROBUST > 1
233 	vmCheckStack(pVM, 4, 0);
234 #endif
235 
236 	y2 = stackPopUNS(pVM->pStack);
237 	x2 = stackPopUNS(pVM->pStack);
238 	y1 = stackPopUNS(pVM->pStack);
239 	x1 = stackPopUNS(pVM->pStack);
240 	gfx_term_drawrect(x1, y1, x2, y2);
241 }
242 #endif	/* TESTMAIN */
243 
244 void
245 ficlSetenv(FICL_VM *pVM)
246 {
247 #ifndef TESTMAIN
248 	char	*name, *value;
249 #endif
250 	char	*namep, *valuep;
251 	int	names, values;
252 
253 #if FICL_ROBUST > 1
254 	vmCheckStack(pVM, 4, 0);
255 #endif
256 	names = stackPopINT(pVM->pStack);
257 	namep = (char*) stackPopPtr(pVM->pStack);
258 	values = stackPopINT(pVM->pStack);
259 	valuep = (char*) stackPopPtr(pVM->pStack);
260 
261 #ifndef TESTMAIN
262 	name = (char*) ficlMalloc(names+1);
263 	if (!name)
264 		vmThrowErr(pVM, "Error: out of memory");
265 	strncpy(name, namep, names);
266 	name[names] = '\0';
267 	value = (char*) ficlMalloc(values+1);
268 	if (!value)
269 		vmThrowErr(pVM, "Error: out of memory");
270 	strncpy(value, valuep, values);
271 	value[values] = '\0';
272 
273 	setenv(name, value, 1);
274 	ficlFree(name);
275 	ficlFree(value);
276 #endif
277 
278 	return;
279 }
280 
281 void
282 ficlSetenvq(FICL_VM *pVM)
283 {
284 #ifndef TESTMAIN
285 	char	*name, *value;
286 #endif
287 	char	*namep, *valuep;
288 	int	names, values, overwrite;
289 
290 #if FICL_ROBUST > 1
291 	vmCheckStack(pVM, 5, 0);
292 #endif
293 	overwrite = stackPopINT(pVM->pStack);
294 	names = stackPopINT(pVM->pStack);
295 	namep = (char*) stackPopPtr(pVM->pStack);
296 	values = stackPopINT(pVM->pStack);
297 	valuep = (char*) stackPopPtr(pVM->pStack);
298 
299 #ifndef TESTMAIN
300 	name = (char*) ficlMalloc(names+1);
301 	if (!name)
302 		vmThrowErr(pVM, "Error: out of memory");
303 	strncpy(name, namep, names);
304 	name[names] = '\0';
305 	value = (char*) ficlMalloc(values+1);
306 	if (!value)
307 		vmThrowErr(pVM, "Error: out of memory");
308 	strncpy(value, valuep, values);
309 	value[values] = '\0';
310 
311 	setenv(name, value, overwrite);
312 	ficlFree(name);
313 	ficlFree(value);
314 #endif
315 
316 	return;
317 }
318 
319 void
320 ficlGetenv(FICL_VM *pVM)
321 {
322 #ifndef TESTMAIN
323 	char	*name, *value;
324 #endif
325 	char	*namep;
326 	int	names;
327 
328 #if FICL_ROBUST > 1
329 	vmCheckStack(pVM, 2, 2);
330 #endif
331 	names = stackPopINT(pVM->pStack);
332 	namep = (char*) stackPopPtr(pVM->pStack);
333 
334 #ifndef TESTMAIN
335 	name = (char*) ficlMalloc(names+1);
336 	if (!name)
337 		vmThrowErr(pVM, "Error: out of memory");
338 	strncpy(name, namep, names);
339 	name[names] = '\0';
340 
341 	value = getenv(name);
342 	ficlFree(name);
343 
344 	if(value != NULL) {
345 		stackPushPtr(pVM->pStack, value);
346 		stackPushINT(pVM->pStack, strlen(value));
347 	} else
348 #endif
349 		stackPushINT(pVM->pStack, -1);
350 
351 	return;
352 }
353 
354 void
355 ficlUnsetenv(FICL_VM *pVM)
356 {
357 #ifndef TESTMAIN
358 	char	*name;
359 #endif
360 	char	*namep;
361 	int	names;
362 
363 #if FICL_ROBUST > 1
364 	vmCheckStack(pVM, 2, 0);
365 #endif
366 	names = stackPopINT(pVM->pStack);
367 	namep = (char*) stackPopPtr(pVM->pStack);
368 
369 #ifndef TESTMAIN
370 	name = (char*) ficlMalloc(names+1);
371 	if (!name)
372 		vmThrowErr(pVM, "Error: out of memory");
373 	strncpy(name, namep, names);
374 	name[names] = '\0';
375 
376 	unsetenv(name);
377 	ficlFree(name);
378 #endif
379 
380 	return;
381 }
382 
383 void
384 ficlCopyin(FICL_VM *pVM)
385 {
386 	void*		src;
387 	vm_offset_t	dest;
388 	size_t		len;
389 
390 #if FICL_ROBUST > 1
391 	vmCheckStack(pVM, 3, 0);
392 #endif
393 
394 	len = stackPopINT(pVM->pStack);
395 	dest = stackPopINT(pVM->pStack);
396 	src = stackPopPtr(pVM->pStack);
397 
398 #ifndef TESTMAIN
399 	archsw.arch_copyin(src, dest, len);
400 #endif
401 
402 	return;
403 }
404 
405 void
406 ficlCopyout(FICL_VM *pVM)
407 {
408 	void*		dest;
409 	vm_offset_t	src;
410 	size_t		len;
411 
412 #if FICL_ROBUST > 1
413 	vmCheckStack(pVM, 3, 0);
414 #endif
415 
416 	len = stackPopINT(pVM->pStack);
417 	dest = stackPopPtr(pVM->pStack);
418 	src = stackPopINT(pVM->pStack);
419 
420 #ifndef TESTMAIN
421 	archsw.arch_copyout(src, dest, len);
422 #endif
423 
424 	return;
425 }
426 
427 void
428 ficlFindfile(FICL_VM *pVM)
429 {
430 #ifndef TESTMAIN
431 	char	*name, *type;
432 #endif
433 	char	*namep, *typep;
434 	struct	preloaded_file* fp;
435 	int	names, types;
436 
437 #if FICL_ROBUST > 1
438 	vmCheckStack(pVM, 4, 1);
439 #endif
440 
441 	types = stackPopINT(pVM->pStack);
442 	typep = (char*) stackPopPtr(pVM->pStack);
443 	names = stackPopINT(pVM->pStack);
444 	namep = (char*) stackPopPtr(pVM->pStack);
445 #ifndef TESTMAIN
446 	name = (char*) ficlMalloc(names+1);
447 	if (!name)
448 		vmThrowErr(pVM, "Error: out of memory");
449 	strncpy(name, namep, names);
450 	name[names] = '\0';
451 	type = (char*) ficlMalloc(types+1);
452 	if (!type)
453 		vmThrowErr(pVM, "Error: out of memory");
454 	strncpy(type, typep, types);
455 	type[types] = '\0';
456 
457 	fp = file_findfile(name, type);
458 #else
459 	fp = NULL;
460 #endif
461 	stackPushPtr(pVM->pStack, fp);
462 
463 	return;
464 }
465 
466 #ifndef TESTMAIN
467 
468 /*	isvirtualized? - Return whether the loader runs under a
469  *			hypervisor.
470  *
471  * isvirtualized? ( -- flag )
472  */
473 static void
474 ficlIsvirtualizedQ(FICL_VM *pVM)
475 {
476 	FICL_INT flag;
477 	const char *hv;
478 
479 #if FICL_ROBUST > 1
480 	vmCheckStack(pVM, 0, 1);
481 #endif
482 
483 	hv = (archsw.arch_hypervisor != NULL)
484 	    ? (*archsw.arch_hypervisor)()
485 	    : NULL;
486 	flag = (hv != NULL) ? FICL_TRUE : FICL_FALSE;
487 	stackPushINT(pVM->pStack, flag);
488 }
489 
490 #endif /* ndef TESTMAIN */
491 
492 void
493 ficlCcall(FICL_VM *pVM)
494 {
495 	int (*func)(int, ...);
496 	int result, p[10];
497 	int nparam, i;
498 
499 #if FICL_ROBUST > 1
500 	vmCheckStack(pVM, 2, 0);
501 #endif
502 
503 	func = stackPopPtr(pVM->pStack);
504 	nparam = stackPopINT(pVM->pStack);
505 
506 #if FICL_ROBUST > 1
507 	vmCheckStack(pVM, nparam, 1);
508 #endif
509 
510 	for (i = 0; i < nparam; i++)
511 		p[i] = stackPopINT(pVM->pStack);
512 
513 	result = func(p[0], p[1], p[2], p[3], p[4], p[5], p[6], p[7], p[8],
514 	    p[9]);
515 
516 	stackPushINT(pVM->pStack, result);
517 
518 	return;
519 }
520 
521 void
522 ficlUuidFromString(FICL_VM *pVM)
523 {
524 #ifndef	TESTMAIN
525 	char	*uuid;
526 	uint32_t status;
527 #endif
528 	char	*uuidp;
529 	int	uuids;
530 	uuid_t	*u;
531 
532 #if FICL_ROBUST > 1
533 	vmCheckStack(pVM, 2, 0);
534 #endif
535 
536 	uuids = stackPopINT(pVM->pStack);
537 	uuidp = (char *) stackPopPtr(pVM->pStack);
538 
539 #ifndef	TESTMAIN
540 	uuid = (char *)ficlMalloc(uuids + 1);
541 	if (!uuid)
542 		vmThrowErr(pVM, "Error: out of memory");
543 	strncpy(uuid, uuidp, uuids);
544 	uuid[uuids] = '\0';
545 
546 	u = (uuid_t *)ficlMalloc(sizeof (*u));
547 
548 	uuid_from_string(uuid, u, &status);
549 	ficlFree(uuid);
550 	if (status != uuid_s_ok) {
551 		ficlFree(u);
552 		u = NULL;
553 	}
554 #else
555 	u = NULL;
556 #endif
557 	stackPushPtr(pVM->pStack, u);
558 
559 
560 	return;
561 }
562 
563 void
564 ficlUuidToString(FICL_VM *pVM)
565 {
566 #ifndef	TESTMAIN
567 	char	*uuid;
568 	uint32_t status;
569 #endif
570 	uuid_t	*u;
571 
572 #if FICL_ROBUST > 1
573 	vmCheckStack(pVM, 1, 0);
574 #endif
575 
576 	u = (uuid_t *)stackPopPtr(pVM->pStack);
577 
578 #ifndef	TESTMAIN
579 	uuid_to_string(u, &uuid, &status);
580 	if (status != uuid_s_ok) {
581 		stackPushPtr(pVM->pStack, uuid);
582 		stackPushINT(pVM->pStack, strlen(uuid));
583 	} else
584 #endif
585 		stackPushINT(pVM->pStack, -1);
586 
587 	return;
588 }
589 
590 /**************************************************************************
591                         f i c l E x e c F D
592 ** reads in text from file fd and passes it to ficlExec()
593  * returns VM_OUTOFTEXT on success or the ficlExec() error code on
594  * failure.
595  */
596 #define nLINEBUF 256
597 int ficlExecFD(FICL_VM *pVM, int fd)
598 {
599     char    cp[nLINEBUF];
600     int     nLine = 0, rval = VM_OUTOFTEXT;
601     char    ch;
602     CELL    id;
603 
604     id = pVM->sourceID;
605     pVM->sourceID.i = fd;
606 
607     /* feed each line to ficlExec */
608     while (1) {
609 	int status, i;
610 
611 	i = 0;
612 	while ((status = read(fd, &ch, 1)) > 0 && ch != '\n')
613 	    cp[i++] = ch;
614         nLine++;
615 	if (!i) {
616 	    if (status < 1)
617 		break;
618 	    continue;
619 	}
620         rval = ficlExecC(pVM, cp, i);
621 	if(rval != VM_QUIT && rval != VM_USEREXIT && rval != VM_OUTOFTEXT)
622         {
623             pVM->sourceID = id;
624             return rval;
625         }
626     }
627     /*
628     ** Pass an empty line with SOURCE-ID == -1 to flush
629     ** any pending REFILLs (as required by FILE wordset)
630     */
631     pVM->sourceID.i = -1;
632     ficlExec(pVM, "");
633 
634     pVM->sourceID = id;
635     return rval;
636 }
637 
638 static void displayCellNoPad(FICL_VM *pVM)
639 {
640     CELL c;
641 #if FICL_ROBUST > 1
642     vmCheckStack(pVM, 1, 0);
643 #endif
644     c = stackPop(pVM->pStack);
645     ltoa((c).i, pVM->pad, pVM->base);
646     vmTextOut(pVM, pVM->pad, 0);
647     return;
648 }
649 
650 /*      isdir? - Return whether an fd corresponds to a directory.
651  *
652  * isdir? ( fd -- bool )
653  */
654 static void isdirQuestion(FICL_VM *pVM)
655 {
656     struct stat sb;
657     FICL_INT flag;
658     int fd;
659 
660 #if FICL_ROBUST > 1
661     vmCheckStack(pVM, 1, 1);
662 #endif
663 
664     fd = stackPopINT(pVM->pStack);
665     flag = FICL_FALSE;
666     do {
667         if (fd < 0)
668             break;
669         if (fstat(fd, &sb) < 0)
670             break;
671         if (!S_ISDIR(sb.st_mode))
672             break;
673         flag = FICL_TRUE;
674     } while (0);
675     stackPushINT(pVM->pStack, flag);
676 }
677 
678 /*          fopen - open a file and return new fd on stack.
679  *
680  * fopen ( ptr count mode -- fd )
681  */
682 static void pfopen(FICL_VM *pVM)
683 {
684     int     mode, fd, count;
685     char    *ptr, *name;
686 
687 #if FICL_ROBUST > 1
688     vmCheckStack(pVM, 3, 1);
689 #endif
690 
691     mode = stackPopINT(pVM->pStack);    /* get mode */
692     count = stackPopINT(pVM->pStack);   /* get count */
693     ptr = stackPopPtr(pVM->pStack);     /* get ptr */
694 
695     if ((count < 0) || (ptr == NULL)) {
696         stackPushINT(pVM->pStack, -1);
697         return;
698     }
699 
700     /* ensure that the string is null terminated */
701     name = (char *)malloc(count+1);
702     bcopy(ptr,name,count);
703     name[count] = 0;
704 
705     /* open the file */
706     fd = open(name, mode);
707 #ifdef LOADER_VERIEXEC
708     if (fd >= 0) {
709 	if (verify_file(fd, name, 0, VE_GUESS, __func__) < 0) {
710 	    /* not verified writing ok but reading is not */
711 	    if ((mode & O_ACCMODE) != O_WRONLY) {
712 		close(fd);
713 		fd = -1;
714 	    }
715 	} else {
716 	    /* verified reading ok but writing is not */
717 	    if ((mode & O_ACCMODE) != O_RDONLY) {
718 		close(fd);
719 		fd = -1;
720 	    }
721 	}
722     }
723 #endif
724     free(name);
725     stackPushINT(pVM->pStack, fd);
726     return;
727 }
728 
729 /*          fclose - close a file who's fd is on stack.
730  *
731  * fclose ( fd -- )
732  */
733 static void pfclose(FICL_VM *pVM)
734 {
735     int fd;
736 
737 #if FICL_ROBUST > 1
738     vmCheckStack(pVM, 1, 0);
739 #endif
740     fd = stackPopINT(pVM->pStack); /* get fd */
741     if (fd != -1)
742 	close(fd);
743     return;
744 }
745 
746 /*          fread - read file contents
747  *
748  * fread  ( fd buf nbytes  -- nread )
749  */
750 static void pfread(FICL_VM *pVM)
751 {
752     int     fd, len;
753     char *buf;
754 
755 #if FICL_ROBUST > 1
756     vmCheckStack(pVM, 3, 1);
757 #endif
758     len = stackPopINT(pVM->pStack); /* get number of bytes to read */
759     buf = stackPopPtr(pVM->pStack); /* get buffer */
760     fd = stackPopINT(pVM->pStack); /* get fd */
761     if (len > 0 && buf && fd != -1)
762 	stackPushINT(pVM->pStack, read(fd, buf, len));
763     else
764 	stackPushINT(pVM->pStack, -1);
765     return;
766 }
767 
768 /*      freaddir - read directory contents
769  *
770  * freaddir ( fd -- ptr len TRUE | FALSE )
771  */
772 static void pfreaddir(FICL_VM *pVM)
773 {
774 #ifdef TESTMAIN
775     static struct dirent dirent;
776     struct stat sb;
777     char *buf;
778     off_t off, ptr;
779     u_int blksz;
780     int bufsz;
781 #endif
782     struct dirent *d;
783     int fd;
784 
785 #if FICL_ROBUST > 1
786     vmCheckStack(pVM, 1, 3);
787 #endif
788 
789     fd = stackPopINT(pVM->pStack);
790 #if TESTMAIN
791     /*
792      * The readdirfd() function is specific to the loader environment.
793      * We do the best we can to make freaddir work, but it's not at
794      * all guaranteed.
795      */
796     d = NULL;
797     buf = NULL;
798     do {
799 	if (fd == -1)
800 	    break;
801 	if (fstat(fd, &sb) == -1)
802 	    break;
803 	blksz = (sb.st_blksize) ? sb.st_blksize : getpagesize();
804 	if ((blksz & (blksz - 1)) != 0)
805 	    break;
806 	buf = malloc(blksz);
807 	if (buf == NULL)
808 	    break;
809 	off = lseek(fd, 0LL, SEEK_CUR);
810 	if (off == -1)
811 	    break;
812 	ptr = off;
813 	if (lseek(fd, 0, SEEK_SET) == -1)
814 	    break;
815 	bufsz = getdents(fd, buf, blksz);
816 	while (bufsz > 0 && bufsz <= ptr) {
817 	    ptr -= bufsz;
818 	    bufsz = getdents(fd, buf, blksz);
819 	}
820 	if (bufsz <= 0)
821 	    break;
822 	d = (void *)(buf + ptr);
823 	dirent = *d;
824 	off += d->d_reclen;
825 	d = (lseek(fd, off, SEEK_SET) != off) ? NULL : &dirent;
826     } while (0);
827     if (buf != NULL)
828 	free(buf);
829 #else
830     d = readdirfd(fd);
831 #endif
832     if (d != NULL) {
833         stackPushPtr(pVM->pStack, d->d_name);
834         stackPushINT(pVM->pStack, strlen(d->d_name));
835         stackPushINT(pVM->pStack, FICL_TRUE);
836     } else {
837         stackPushINT(pVM->pStack, FICL_FALSE);
838     }
839 }
840 
841 /*          fload - interpret file contents
842  *
843  * fload  ( fd -- )
844  */
845 static void pfload(FICL_VM *pVM)
846 {
847     int     fd;
848 
849 #if FICL_ROBUST > 1
850     vmCheckStack(pVM, 1, 0);
851 #endif
852     fd = stackPopINT(pVM->pStack); /* get fd */
853     if (fd != -1)
854 	ficlExecFD(pVM, fd);
855     return;
856 }
857 
858 /*          fwrite - write file contents
859  *
860  * fwrite  ( fd buf nbytes  -- nwritten )
861  */
862 static void pfwrite(FICL_VM *pVM)
863 {
864     int     fd, len;
865     char *buf;
866 
867 #if FICL_ROBUST > 1
868     vmCheckStack(pVM, 3, 1);
869 #endif
870     len = stackPopINT(pVM->pStack); /* get number of bytes to read */
871     buf = stackPopPtr(pVM->pStack); /* get buffer */
872     fd = stackPopINT(pVM->pStack); /* get fd */
873     if (len > 0 && buf && fd != -1)
874 	stackPushINT(pVM->pStack, write(fd, buf, len));
875     else
876 	stackPushINT(pVM->pStack, -1);
877     return;
878 }
879 
880 /*          fseek - seek to a new position in a file
881  *
882  * fseek  ( fd ofs whence  -- pos )
883  */
884 static void pfseek(FICL_VM *pVM)
885 {
886     int     fd, pos, whence;
887 
888 #if FICL_ROBUST > 1
889     vmCheckStack(pVM, 3, 1);
890 #endif
891     whence = stackPopINT(pVM->pStack);
892     pos = stackPopINT(pVM->pStack);
893     fd = stackPopINT(pVM->pStack);
894     stackPushINT(pVM->pStack, lseek(fd, pos, whence));
895     return;
896 }
897 
898 /*           key - get a character from stdin
899  *
900  * key ( -- char )
901  */
902 static void key(FICL_VM *pVM)
903 {
904 #if FICL_ROBUST > 1
905     vmCheckStack(pVM, 0, 1);
906 #endif
907     stackPushINT(pVM->pStack, getchar());
908     return;
909 }
910 
911 /*           key? - check for a character from stdin (FACILITY)
912  *
913  * key? ( -- flag )
914  */
915 static void keyQuestion(FICL_VM *pVM)
916 {
917 #if FICL_ROBUST > 1
918     vmCheckStack(pVM, 0, 1);
919 #endif
920 #ifdef TESTMAIN
921     /* XXX Since we don't fiddle with termios, let it always succeed... */
922     stackPushINT(pVM->pStack, FICL_TRUE);
923 #else
924     /* But here do the right thing. */
925     stackPushINT(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE);
926 #endif
927     return;
928 }
929 
930 /* seconds - gives number of seconds since beginning of time
931  *
932  * beginning of time is defined as:
933  *
934  *	BTX	- number of seconds since midnight
935  *	FreeBSD	- number of seconds since Jan 1 1970
936  *
937  * seconds ( -- u )
938  */
939 static void pseconds(FICL_VM *pVM)
940 {
941 #if FICL_ROBUST > 1
942     vmCheckStack(pVM,0,1);
943 #endif
944     stackPushUNS(pVM->pStack, (FICL_UNS) time(NULL));
945     return;
946 }
947 
948 /* ms - wait at least that many milliseconds (FACILITY)
949  *
950  * ms ( u -- )
951  *
952  */
953 static void ms(FICL_VM *pVM)
954 {
955 #if FICL_ROBUST > 1
956     vmCheckStack(pVM,1,0);
957 #endif
958 #ifdef TESTMAIN
959     usleep(stackPopUNS(pVM->pStack)*1000);
960 #else
961     delay(stackPopUNS(pVM->pStack)*1000);
962 #endif
963     return;
964 }
965 
966 /*           fkey - get a character from a file
967  *
968  * fkey ( file -- char )
969  */
970 static void fkey(FICL_VM *pVM)
971 {
972     int i, fd;
973     char ch;
974 
975 #if FICL_ROBUST > 1
976     vmCheckStack(pVM, 1, 1);
977 #endif
978     fd = stackPopINT(pVM->pStack);
979     i = read(fd, &ch, 1);
980     stackPushINT(pVM->pStack, i > 0 ? ch : -1);
981     return;
982 }
983 
984 
985 /*
986 ** Retrieves free space remaining on the dictionary
987 */
988 
989 static void freeHeap(FICL_VM *pVM)
990 {
991     stackPushINT(pVM->pStack, dictCellsAvail(ficlGetDict(pVM->pSys)));
992 }
993 
994 
995 /******************* Increase dictionary size on-demand ******************/
996 
997 static void ficlDictThreshold(FICL_VM *pVM)
998 {
999     stackPushPtr(pVM->pStack, &dictThreshold);
1000 }
1001 
1002 static void ficlDictIncrease(FICL_VM *pVM)
1003 {
1004     stackPushPtr(pVM->pStack, &dictIncrease);
1005 }
1006 
1007 /**************************************************************************
1008                         f i c l C o m p i l e P l a t f o r m
1009 ** Build FreeBSD platform extensions into the system dictionary
1010 **************************************************************************/
1011 void ficlCompilePlatform(FICL_SYSTEM *pSys)
1012 {
1013     ficlCompileFcn **fnpp;
1014     FICL_DICT *dp = pSys->dp;
1015     assert (dp);
1016 
1017     dictAppendWord(dp, ".#",        displayCellNoPad,    FW_DEFAULT);
1018     dictAppendWord(dp, "isdir?",    isdirQuestion,  FW_DEFAULT);
1019     dictAppendWord(dp, "fopen",	    pfopen,	    FW_DEFAULT);
1020     dictAppendWord(dp, "fclose",    pfclose,	    FW_DEFAULT);
1021     dictAppendWord(dp, "fread",	    pfread,	    FW_DEFAULT);
1022     dictAppendWord(dp, "freaddir",  pfreaddir,	    FW_DEFAULT);
1023     dictAppendWord(dp, "fload",	    pfload,	    FW_DEFAULT);
1024     dictAppendWord(dp, "fkey",	    fkey,	    FW_DEFAULT);
1025     dictAppendWord(dp, "fseek",     pfseek,	    FW_DEFAULT);
1026     dictAppendWord(dp, "fwrite",    pfwrite,	    FW_DEFAULT);
1027     dictAppendWord(dp, "key",	    key,	    FW_DEFAULT);
1028     dictAppendWord(dp, "key?",	    keyQuestion,    FW_DEFAULT);
1029     dictAppendWord(dp, "ms",        ms,             FW_DEFAULT);
1030     dictAppendWord(dp, "seconds",   pseconds,       FW_DEFAULT);
1031     dictAppendWord(dp, "heap?",     freeHeap,       FW_DEFAULT);
1032     dictAppendWord(dp, "dictthreshold", ficlDictThreshold, FW_DEFAULT);
1033     dictAppendWord(dp, "dictincrease", ficlDictIncrease, FW_DEFAULT);
1034 
1035     dictAppendWord(dp, "setenv",    ficlSetenv,	    FW_DEFAULT);
1036     dictAppendWord(dp, "setenv?",   ficlSetenvq,    FW_DEFAULT);
1037     dictAppendWord(dp, "getenv",    ficlGetenv,	    FW_DEFAULT);
1038     dictAppendWord(dp, "unsetenv",  ficlUnsetenv,   FW_DEFAULT);
1039     dictAppendWord(dp, "copyin",    ficlCopyin,	    FW_DEFAULT);
1040     dictAppendWord(dp, "copyout",   ficlCopyout,    FW_DEFAULT);
1041     dictAppendWord(dp, "findfile",  ficlFindfile,   FW_DEFAULT);
1042     dictAppendWord(dp, "ccall",	    ficlCcall,	    FW_DEFAULT);
1043     dictAppendWord(dp, "uuid-from-string", ficlUuidFromString, FW_DEFAULT);
1044     dictAppendWord(dp, "uuid-to-string", ficlUuidToString, FW_DEFAULT);
1045 #ifndef TESTMAIN
1046     dictAppendWord(dp, "fb-setpixel", ficl_fb_setpixel, FW_DEFAULT);
1047     dictAppendWord(dp, "fb-line", ficl_fb_line, FW_DEFAULT);
1048     dictAppendWord(dp, "fb-bezier", ficl_fb_bezier, FW_DEFAULT);
1049     dictAppendWord(dp, "fb-drawrect", ficl_fb_drawrect, FW_DEFAULT);
1050     dictAppendWord(dp, "fb-putimage", ficl_fb_putimage, FW_DEFAULT);
1051     dictAppendWord(dp, "term-drawrect", ficl_term_drawrect, FW_DEFAULT);
1052     dictAppendWord(dp, "term-putimage", ficl_term_putimage, FW_DEFAULT);
1053     dictAppendWord(dp, "isvirtualized?",ficlIsvirtualizedQ, FW_DEFAULT);
1054 #endif
1055 
1056     SET_FOREACH(fnpp, Xficl_compile_set)
1057 	(*fnpp)(pSys);
1058 
1059 #if defined(__i386__)
1060     ficlSetEnv(pSys, "arch-i386",         FICL_TRUE);
1061     ficlSetEnv(pSys, "arch-powerpc",      FICL_FALSE);
1062 #elif defined(__powerpc__)
1063     ficlSetEnv(pSys, "arch-i386",         FICL_FALSE);
1064     ficlSetEnv(pSys, "arch-powerpc",      FICL_TRUE);
1065 #endif
1066 
1067     return;
1068 }
1069