xref: /freebsd/stand/ficl/loader.c (revision 0921a771da8a9117edf26352a8a047bacbfcee45) 
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 "ficl.h"
48 
49 /*		FreeBSD's loader interaction words and extras
50  *
51  * 		setenv      ( value n name n' -- )
52  * 		setenv?     ( value n name n' flag -- )
53  * 		getenv      ( addr n -- addr' n' | -1 )
54  * 		unsetenv    ( addr n -- )
55  * 		copyin      ( addr addr' len -- )
56  * 		copyout     ( addr addr' len -- )
57  * 		findfile    ( name len type len' -- addr )
58  * 		pnpdevices  ( -- addr )
59  * 		pnphandlers ( -- addr )
60  * 		ccall       ( [[...[p10] p9] ... p1] n addr -- result )
61  *		uuid-from-string ( addr n -- addr' )
62  *		uuid-to-string ( addr' -- addr n )
63  * 		.#	    ( value -- )
64  */
65 
66 void
67 ficlSetenv(FICL_VM *pVM)
68 {
69 #ifndef TESTMAIN
70 	char	*name, *value;
71 #endif
72 	char	*namep, *valuep;
73 	int	names, values;
74 
75 #if FICL_ROBUST > 1
76 	vmCheckStack(pVM, 4, 0);
77 #endif
78 	names = stackPopINT(pVM->pStack);
79 	namep = (char*) stackPopPtr(pVM->pStack);
80 	values = stackPopINT(pVM->pStack);
81 	valuep = (char*) stackPopPtr(pVM->pStack);
82 
83 #ifndef TESTMAIN
84 	name = (char*) ficlMalloc(names+1);
85 	if (!name)
86 		vmThrowErr(pVM, "Error: out of memory");
87 	strncpy(name, namep, names);
88 	name[names] = '\0';
89 	value = (char*) ficlMalloc(values+1);
90 	if (!value)
91 		vmThrowErr(pVM, "Error: out of memory");
92 	strncpy(value, valuep, values);
93 	value[values] = '\0';
94 
95 	setenv(name, value, 1);
96 	ficlFree(name);
97 	ficlFree(value);
98 #endif
99 
100 	return;
101 }
102 
103 void
104 ficlSetenvq(FICL_VM *pVM)
105 {
106 #ifndef TESTMAIN
107 	char	*name, *value;
108 #endif
109 	char	*namep, *valuep;
110 	int	names, values, overwrite;
111 
112 #if FICL_ROBUST > 1
113 	vmCheckStack(pVM, 5, 0);
114 #endif
115 	overwrite = stackPopINT(pVM->pStack);
116 	names = stackPopINT(pVM->pStack);
117 	namep = (char*) stackPopPtr(pVM->pStack);
118 	values = stackPopINT(pVM->pStack);
119 	valuep = (char*) stackPopPtr(pVM->pStack);
120 
121 #ifndef TESTMAIN
122 	name = (char*) ficlMalloc(names+1);
123 	if (!name)
124 		vmThrowErr(pVM, "Error: out of memory");
125 	strncpy(name, namep, names);
126 	name[names] = '\0';
127 	value = (char*) ficlMalloc(values+1);
128 	if (!value)
129 		vmThrowErr(pVM, "Error: out of memory");
130 	strncpy(value, valuep, values);
131 	value[values] = '\0';
132 
133 	setenv(name, value, overwrite);
134 	ficlFree(name);
135 	ficlFree(value);
136 #endif
137 
138 	return;
139 }
140 
141 void
142 ficlGetenv(FICL_VM *pVM)
143 {
144 #ifndef TESTMAIN
145 	char	*name, *value;
146 #endif
147 	char	*namep;
148 	int	names;
149 
150 #if FICL_ROBUST > 1
151 	vmCheckStack(pVM, 2, 2);
152 #endif
153 	names = stackPopINT(pVM->pStack);
154 	namep = (char*) stackPopPtr(pVM->pStack);
155 
156 #ifndef TESTMAIN
157 	name = (char*) ficlMalloc(names+1);
158 	if (!name)
159 		vmThrowErr(pVM, "Error: out of memory");
160 	strncpy(name, namep, names);
161 	name[names] = '\0';
162 
163 	value = getenv(name);
164 	ficlFree(name);
165 
166 	if(value != NULL) {
167 		stackPushPtr(pVM->pStack, value);
168 		stackPushINT(pVM->pStack, strlen(value));
169 	} else
170 #endif
171 		stackPushINT(pVM->pStack, -1);
172 
173 	return;
174 }
175 
176 void
177 ficlUnsetenv(FICL_VM *pVM)
178 {
179 #ifndef TESTMAIN
180 	char	*name;
181 #endif
182 	char	*namep;
183 	int	names;
184 
185 #if FICL_ROBUST > 1
186 	vmCheckStack(pVM, 2, 0);
187 #endif
188 	names = stackPopINT(pVM->pStack);
189 	namep = (char*) stackPopPtr(pVM->pStack);
190 
191 #ifndef TESTMAIN
192 	name = (char*) ficlMalloc(names+1);
193 	if (!name)
194 		vmThrowErr(pVM, "Error: out of memory");
195 	strncpy(name, namep, names);
196 	name[names] = '\0';
197 
198 	unsetenv(name);
199 	ficlFree(name);
200 #endif
201 
202 	return;
203 }
204 
205 void
206 ficlCopyin(FICL_VM *pVM)
207 {
208 	void*		src;
209 	vm_offset_t	dest;
210 	size_t		len;
211 
212 #if FICL_ROBUST > 1
213 	vmCheckStack(pVM, 3, 0);
214 #endif
215 
216 	len = stackPopINT(pVM->pStack);
217 	dest = stackPopINT(pVM->pStack);
218 	src = stackPopPtr(pVM->pStack);
219 
220 #ifndef TESTMAIN
221 	archsw.arch_copyin(src, dest, len);
222 #endif
223 
224 	return;
225 }
226 
227 void
228 ficlCopyout(FICL_VM *pVM)
229 {
230 	void*		dest;
231 	vm_offset_t	src;
232 	size_t		len;
233 
234 #if FICL_ROBUST > 1
235 	vmCheckStack(pVM, 3, 0);
236 #endif
237 
238 	len = stackPopINT(pVM->pStack);
239 	dest = stackPopPtr(pVM->pStack);
240 	src = stackPopINT(pVM->pStack);
241 
242 #ifndef TESTMAIN
243 	archsw.arch_copyout(src, dest, len);
244 #endif
245 
246 	return;
247 }
248 
249 void
250 ficlFindfile(FICL_VM *pVM)
251 {
252 #ifndef TESTMAIN
253 	char	*name, *type;
254 #endif
255 	char	*namep, *typep;
256 	struct	preloaded_file* fp;
257 	int	names, types;
258 
259 #if FICL_ROBUST > 1
260 	vmCheckStack(pVM, 4, 1);
261 #endif
262 
263 	types = stackPopINT(pVM->pStack);
264 	typep = (char*) stackPopPtr(pVM->pStack);
265 	names = stackPopINT(pVM->pStack);
266 	namep = (char*) stackPopPtr(pVM->pStack);
267 #ifndef TESTMAIN
268 	name = (char*) ficlMalloc(names+1);
269 	if (!name)
270 		vmThrowErr(pVM, "Error: out of memory");
271 	strncpy(name, namep, names);
272 	name[names] = '\0';
273 	type = (char*) ficlMalloc(types+1);
274 	if (!type)
275 		vmThrowErr(pVM, "Error: out of memory");
276 	strncpy(type, typep, types);
277 	type[types] = '\0';
278 
279 	fp = file_findfile(name, type);
280 #else
281 	fp = NULL;
282 #endif
283 	stackPushPtr(pVM->pStack, fp);
284 
285 	return;
286 }
287 
288 #ifndef TESTMAIN
289 
290 /*	isvirtualized? - Return whether the loader runs under a
291  *			hypervisor.
292  *
293  * isvirtualized? ( -- flag )
294  */
295 static void
296 ficlIsvirtualizedQ(FICL_VM *pVM)
297 {
298 	FICL_INT flag;
299 	const char *hv;
300 
301 #if FICL_ROBUST > 1
302 	vmCheckStack(pVM, 0, 1);
303 #endif
304 
305 	hv = (archsw.arch_hypervisor != NULL)
306 	    ? (*archsw.arch_hypervisor)()
307 	    : NULL;
308 	flag = (hv != NULL) ? FICL_TRUE : FICL_FALSE;
309 	stackPushINT(pVM->pStack, flag);
310 }
311 
312 #endif /* ndef TESTMAIN */
313 
314 void
315 ficlCcall(FICL_VM *pVM)
316 {
317 	int (*func)(int, ...);
318 	int result, p[10];
319 	int nparam, i;
320 
321 #if FICL_ROBUST > 1
322 	vmCheckStack(pVM, 2, 0);
323 #endif
324 
325 	func = stackPopPtr(pVM->pStack);
326 	nparam = stackPopINT(pVM->pStack);
327 
328 #if FICL_ROBUST > 1
329 	vmCheckStack(pVM, nparam, 1);
330 #endif
331 
332 	for (i = 0; i < nparam; i++)
333 		p[i] = stackPopINT(pVM->pStack);
334 
335 	result = func(p[0], p[1], p[2], p[3], p[4], p[5], p[6], p[7], p[8],
336 	    p[9]);
337 
338 	stackPushINT(pVM->pStack, result);
339 
340 	return;
341 }
342 
343 void
344 ficlUuidFromString(FICL_VM *pVM)
345 {
346 #ifndef	TESTMAIN
347 	char	*uuid;
348 	uint32_t status;
349 #endif
350 	char	*uuidp;
351 	int	uuids;
352 	uuid_t	*u;
353 
354 #if FICL_ROBUST > 1
355 	vmCheckStack(pVM, 2, 0);
356 #endif
357 
358 	uuids = stackPopINT(pVM->pStack);
359 	uuidp = (char *) stackPopPtr(pVM->pStack);
360 
361 #ifndef	TESTMAIN
362 	uuid = (char *)ficlMalloc(uuids + 1);
363 	if (!uuid)
364 		vmThrowErr(pVM, "Error: out of memory");
365 	strncpy(uuid, uuidp, uuids);
366 	uuid[uuids] = '\0';
367 
368 	u = (uuid_t *)ficlMalloc(sizeof (*u));
369 
370 	uuid_from_string(uuid, u, &status);
371 	ficlFree(uuid);
372 	if (status != uuid_s_ok) {
373 		ficlFree(u);
374 		u = NULL;
375 	}
376 #else
377 	u = NULL;
378 #endif
379 	stackPushPtr(pVM->pStack, u);
380 
381 
382 	return;
383 }
384 
385 void
386 ficlUuidToString(FICL_VM *pVM)
387 {
388 #ifndef	TESTMAIN
389 	char	*uuid;
390 	uint32_t status;
391 #endif
392 	uuid_t	*u;
393 
394 #if FICL_ROBUST > 1
395 	vmCheckStack(pVM, 1, 0);
396 #endif
397 
398 	u = (uuid_t *)stackPopPtr(pVM->pStack);
399 
400 #ifndef	TESTMAIN
401 	uuid_to_string(u, &uuid, &status);
402 	if (status != uuid_s_ok) {
403 		stackPushPtr(pVM->pStack, uuid);
404 		stackPushINT(pVM->pStack, strlen(uuid));
405 	} else
406 #endif
407 		stackPushINT(pVM->pStack, -1);
408 
409 	return;
410 }
411 
412 /**************************************************************************
413                         f i c l E x e c F D
414 ** reads in text from file fd and passes it to ficlExec()
415  * returns VM_OUTOFTEXT on success or the ficlExec() error code on
416  * failure.
417  */
418 #define nLINEBUF 256
419 int ficlExecFD(FICL_VM *pVM, int fd)
420 {
421     char    cp[nLINEBUF];
422     int     nLine = 0, rval = VM_OUTOFTEXT;
423     char    ch;
424     CELL    id;
425 
426     id = pVM->sourceID;
427     pVM->sourceID.i = fd;
428 
429     /* feed each line to ficlExec */
430     while (1) {
431 	int status, i;
432 
433 	i = 0;
434 	while ((status = read(fd, &ch, 1)) > 0 && ch != '\n')
435 	    cp[i++] = ch;
436         nLine++;
437 	if (!i) {
438 	    if (status < 1)
439 		break;
440 	    continue;
441 	}
442         rval = ficlExecC(pVM, cp, i);
443 	if(rval != VM_QUIT && rval != VM_USEREXIT && rval != VM_OUTOFTEXT)
444         {
445             pVM->sourceID = id;
446             return rval;
447         }
448     }
449     /*
450     ** Pass an empty line with SOURCE-ID == -1 to flush
451     ** any pending REFILLs (as required by FILE wordset)
452     */
453     pVM->sourceID.i = -1;
454     ficlExec(pVM, "");
455 
456     pVM->sourceID = id;
457     return rval;
458 }
459 
460 static void displayCellNoPad(FICL_VM *pVM)
461 {
462     CELL c;
463 #if FICL_ROBUST > 1
464     vmCheckStack(pVM, 1, 0);
465 #endif
466     c = stackPop(pVM->pStack);
467     ltoa((c).i, pVM->pad, pVM->base);
468     vmTextOut(pVM, pVM->pad, 0);
469     return;
470 }
471 
472 /*      isdir? - Return whether an fd corresponds to a directory.
473  *
474  * isdir? ( fd -- bool )
475  */
476 static void isdirQuestion(FICL_VM *pVM)
477 {
478     struct stat sb;
479     FICL_INT flag;
480     int fd;
481 
482 #if FICL_ROBUST > 1
483     vmCheckStack(pVM, 1, 1);
484 #endif
485 
486     fd = stackPopINT(pVM->pStack);
487     flag = FICL_FALSE;
488     do {
489         if (fd < 0)
490             break;
491         if (fstat(fd, &sb) < 0)
492             break;
493         if (!S_ISDIR(sb.st_mode))
494             break;
495         flag = FICL_TRUE;
496     } while (0);
497     stackPushINT(pVM->pStack, flag);
498 }
499 
500 /*          fopen - open a file and return new fd on stack.
501  *
502  * fopen ( ptr count mode -- fd )
503  */
504 static void pfopen(FICL_VM *pVM)
505 {
506     int     mode, fd, count;
507     char    *ptr, *name;
508 
509 #if FICL_ROBUST > 1
510     vmCheckStack(pVM, 3, 1);
511 #endif
512 
513     mode = stackPopINT(pVM->pStack);    /* get mode */
514     count = stackPopINT(pVM->pStack);   /* get count */
515     ptr = stackPopPtr(pVM->pStack);     /* get ptr */
516 
517     if ((count < 0) || (ptr == NULL)) {
518         stackPushINT(pVM->pStack, -1);
519         return;
520     }
521 
522     /* ensure that the string is null terminated */
523     name = (char *)malloc(count+1);
524     bcopy(ptr,name,count);
525     name[count] = 0;
526 
527     /* open the file */
528     fd = open(name, mode);
529 #ifdef LOADER_VERIEXEC
530     if (fd >= 0) {
531 	if (verify_file(fd, name, 0, VE_GUESS, __func__) < 0) {
532 	    /* not verified writing ok but reading is not */
533 	    if ((mode & O_ACCMODE) != O_WRONLY) {
534 		close(fd);
535 		fd = -1;
536 	    }
537 	} else {
538 	    /* verified reading ok but writing is not */
539 	    if ((mode & O_ACCMODE) != O_RDONLY) {
540 		close(fd);
541 		fd = -1;
542 	    }
543 	}
544     }
545 #endif
546     free(name);
547     stackPushINT(pVM->pStack, fd);
548     return;
549 }
550 
551 /*          fclose - close a file who's fd is on stack.
552  *
553  * fclose ( fd -- )
554  */
555 static void pfclose(FICL_VM *pVM)
556 {
557     int fd;
558 
559 #if FICL_ROBUST > 1
560     vmCheckStack(pVM, 1, 0);
561 #endif
562     fd = stackPopINT(pVM->pStack); /* get fd */
563     if (fd != -1)
564 	close(fd);
565     return;
566 }
567 
568 /*          fread - read file contents
569  *
570  * fread  ( fd buf nbytes  -- nread )
571  */
572 static void pfread(FICL_VM *pVM)
573 {
574     int     fd, len;
575     char *buf;
576 
577 #if FICL_ROBUST > 1
578     vmCheckStack(pVM, 3, 1);
579 #endif
580     len = stackPopINT(pVM->pStack); /* get number of bytes to read */
581     buf = stackPopPtr(pVM->pStack); /* get buffer */
582     fd = stackPopINT(pVM->pStack); /* get fd */
583     if (len > 0 && buf && fd != -1)
584 	stackPushINT(pVM->pStack, read(fd, buf, len));
585     else
586 	stackPushINT(pVM->pStack, -1);
587     return;
588 }
589 
590 /*      freaddir - read directory contents
591  *
592  * freaddir ( fd -- ptr len TRUE | FALSE )
593  */
594 static void pfreaddir(FICL_VM *pVM)
595 {
596 #ifdef TESTMAIN
597     static struct dirent dirent;
598     struct stat sb;
599     char *buf;
600     off_t off, ptr;
601     u_int blksz;
602     int bufsz;
603 #endif
604     struct dirent *d;
605     int fd;
606 
607 #if FICL_ROBUST > 1
608     vmCheckStack(pVM, 1, 3);
609 #endif
610 
611     fd = stackPopINT(pVM->pStack);
612 #if TESTMAIN
613     /*
614      * The readdirfd() function is specific to the loader environment.
615      * We do the best we can to make freaddir work, but it's not at
616      * all guaranteed.
617      */
618     d = NULL;
619     buf = NULL;
620     do {
621 	if (fd == -1)
622 	    break;
623 	if (fstat(fd, &sb) == -1)
624 	    break;
625 	blksz = (sb.st_blksize) ? sb.st_blksize : getpagesize();
626 	if ((blksz & (blksz - 1)) != 0)
627 	    break;
628 	buf = malloc(blksz);
629 	if (buf == NULL)
630 	    break;
631 	off = lseek(fd, 0LL, SEEK_CUR);
632 	if (off == -1)
633 	    break;
634 	ptr = off;
635 	if (lseek(fd, 0, SEEK_SET) == -1)
636 	    break;
637 	bufsz = getdents(fd, buf, blksz);
638 	while (bufsz > 0 && bufsz <= ptr) {
639 	    ptr -= bufsz;
640 	    bufsz = getdents(fd, buf, blksz);
641 	}
642 	if (bufsz <= 0)
643 	    break;
644 	d = (void *)(buf + ptr);
645 	dirent = *d;
646 	off += d->d_reclen;
647 	d = (lseek(fd, off, SEEK_SET) != off) ? NULL : &dirent;
648     } while (0);
649     if (buf != NULL)
650 	free(buf);
651 #else
652     d = readdirfd(fd);
653 #endif
654     if (d != NULL) {
655         stackPushPtr(pVM->pStack, d->d_name);
656         stackPushINT(pVM->pStack, strlen(d->d_name));
657         stackPushINT(pVM->pStack, FICL_TRUE);
658     } else {
659         stackPushINT(pVM->pStack, FICL_FALSE);
660     }
661 }
662 
663 /*          fload - interpret file contents
664  *
665  * fload  ( fd -- )
666  */
667 static void pfload(FICL_VM *pVM)
668 {
669     int     fd;
670 
671 #if FICL_ROBUST > 1
672     vmCheckStack(pVM, 1, 0);
673 #endif
674     fd = stackPopINT(pVM->pStack); /* get fd */
675     if (fd != -1)
676 	ficlExecFD(pVM, fd);
677     return;
678 }
679 
680 /*          fwrite - write file contents
681  *
682  * fwrite  ( fd buf nbytes  -- nwritten )
683  */
684 static void pfwrite(FICL_VM *pVM)
685 {
686     int     fd, len;
687     char *buf;
688 
689 #if FICL_ROBUST > 1
690     vmCheckStack(pVM, 3, 1);
691 #endif
692     len = stackPopINT(pVM->pStack); /* get number of bytes to read */
693     buf = stackPopPtr(pVM->pStack); /* get buffer */
694     fd = stackPopINT(pVM->pStack); /* get fd */
695     if (len > 0 && buf && fd != -1)
696 	stackPushINT(pVM->pStack, write(fd, buf, len));
697     else
698 	stackPushINT(pVM->pStack, -1);
699     return;
700 }
701 
702 /*          fseek - seek to a new position in a file
703  *
704  * fseek  ( fd ofs whence  -- pos )
705  */
706 static void pfseek(FICL_VM *pVM)
707 {
708     int     fd, pos, whence;
709 
710 #if FICL_ROBUST > 1
711     vmCheckStack(pVM, 3, 1);
712 #endif
713     whence = stackPopINT(pVM->pStack);
714     pos = stackPopINT(pVM->pStack);
715     fd = stackPopINT(pVM->pStack);
716     stackPushINT(pVM->pStack, lseek(fd, pos, whence));
717     return;
718 }
719 
720 /*           key - get a character from stdin
721  *
722  * key ( -- char )
723  */
724 static void key(FICL_VM *pVM)
725 {
726 #if FICL_ROBUST > 1
727     vmCheckStack(pVM, 0, 1);
728 #endif
729     stackPushINT(pVM->pStack, getchar());
730     return;
731 }
732 
733 /*           key? - check for a character from stdin (FACILITY)
734  *
735  * key? ( -- flag )
736  */
737 static void keyQuestion(FICL_VM *pVM)
738 {
739 #if FICL_ROBUST > 1
740     vmCheckStack(pVM, 0, 1);
741 #endif
742 #ifdef TESTMAIN
743     /* XXX Since we don't fiddle with termios, let it always succeed... */
744     stackPushINT(pVM->pStack, FICL_TRUE);
745 #else
746     /* But here do the right thing. */
747     stackPushINT(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE);
748 #endif
749     return;
750 }
751 
752 /* seconds - gives number of seconds since beginning of time
753  *
754  * beginning of time is defined as:
755  *
756  *	BTX	- number of seconds since midnight
757  *	FreeBSD	- number of seconds since Jan 1 1970
758  *
759  * seconds ( -- u )
760  */
761 static void pseconds(FICL_VM *pVM)
762 {
763 #if FICL_ROBUST > 1
764     vmCheckStack(pVM,0,1);
765 #endif
766     stackPushUNS(pVM->pStack, (FICL_UNS) time(NULL));
767     return;
768 }
769 
770 /* ms - wait at least that many milliseconds (FACILITY)
771  *
772  * ms ( u -- )
773  *
774  */
775 static void ms(FICL_VM *pVM)
776 {
777 #if FICL_ROBUST > 1
778     vmCheckStack(pVM,1,0);
779 #endif
780 #ifdef TESTMAIN
781     usleep(stackPopUNS(pVM->pStack)*1000);
782 #else
783     delay(stackPopUNS(pVM->pStack)*1000);
784 #endif
785     return;
786 }
787 
788 /*           fkey - get a character from a file
789  *
790  * fkey ( file -- char )
791  */
792 static void fkey(FICL_VM *pVM)
793 {
794     int i, fd;
795     char ch;
796 
797 #if FICL_ROBUST > 1
798     vmCheckStack(pVM, 1, 1);
799 #endif
800     fd = stackPopINT(pVM->pStack);
801     i = read(fd, &ch, 1);
802     stackPushINT(pVM->pStack, i > 0 ? ch : -1);
803     return;
804 }
805 
806 
807 /*
808 ** Retrieves free space remaining on the dictionary
809 */
810 
811 static void freeHeap(FICL_VM *pVM)
812 {
813     stackPushINT(pVM->pStack, dictCellsAvail(ficlGetDict(pVM->pSys)));
814 }
815 
816 
817 /******************* Increase dictionary size on-demand ******************/
818 
819 static void ficlDictThreshold(FICL_VM *pVM)
820 {
821     stackPushPtr(pVM->pStack, &dictThreshold);
822 }
823 
824 static void ficlDictIncrease(FICL_VM *pVM)
825 {
826     stackPushPtr(pVM->pStack, &dictIncrease);
827 }
828 
829 /**************************************************************************
830                         f i c l C o m p i l e P l a t f o r m
831 ** Build FreeBSD platform extensions into the system dictionary
832 **************************************************************************/
833 void ficlCompilePlatform(FICL_SYSTEM *pSys)
834 {
835     ficlCompileFcn **fnpp;
836     FICL_DICT *dp = pSys->dp;
837     assert (dp);
838 
839     dictAppendWord(dp, ".#",        displayCellNoPad,    FW_DEFAULT);
840     dictAppendWord(dp, "isdir?",    isdirQuestion,  FW_DEFAULT);
841     dictAppendWord(dp, "fopen",	    pfopen,	    FW_DEFAULT);
842     dictAppendWord(dp, "fclose",    pfclose,	    FW_DEFAULT);
843     dictAppendWord(dp, "fread",	    pfread,	    FW_DEFAULT);
844     dictAppendWord(dp, "freaddir",  pfreaddir,	    FW_DEFAULT);
845     dictAppendWord(dp, "fload",	    pfload,	    FW_DEFAULT);
846     dictAppendWord(dp, "fkey",	    fkey,	    FW_DEFAULT);
847     dictAppendWord(dp, "fseek",     pfseek,	    FW_DEFAULT);
848     dictAppendWord(dp, "fwrite",    pfwrite,	    FW_DEFAULT);
849     dictAppendWord(dp, "key",	    key,	    FW_DEFAULT);
850     dictAppendWord(dp, "key?",	    keyQuestion,    FW_DEFAULT);
851     dictAppendWord(dp, "ms",        ms,             FW_DEFAULT);
852     dictAppendWord(dp, "seconds",   pseconds,       FW_DEFAULT);
853     dictAppendWord(dp, "heap?",     freeHeap,       FW_DEFAULT);
854     dictAppendWord(dp, "dictthreshold", ficlDictThreshold, FW_DEFAULT);
855     dictAppendWord(dp, "dictincrease", ficlDictIncrease, FW_DEFAULT);
856 
857     dictAppendWord(dp, "setenv",    ficlSetenv,	    FW_DEFAULT);
858     dictAppendWord(dp, "setenv?",   ficlSetenvq,    FW_DEFAULT);
859     dictAppendWord(dp, "getenv",    ficlGetenv,	    FW_DEFAULT);
860     dictAppendWord(dp, "unsetenv",  ficlUnsetenv,   FW_DEFAULT);
861     dictAppendWord(dp, "copyin",    ficlCopyin,	    FW_DEFAULT);
862     dictAppendWord(dp, "copyout",   ficlCopyout,    FW_DEFAULT);
863     dictAppendWord(dp, "findfile",  ficlFindfile,   FW_DEFAULT);
864     dictAppendWord(dp, "ccall",	    ficlCcall,	    FW_DEFAULT);
865     dictAppendWord(dp, "uuid-from-string", ficlUuidFromString, FW_DEFAULT);
866     dictAppendWord(dp, "uuid-to-string", ficlUuidToString, FW_DEFAULT);
867 
868     SET_FOREACH(fnpp, Xficl_compile_set)
869 	(*fnpp)(pSys);
870 
871 #if defined(__i386__)
872     ficlSetEnv(pSys, "arch-i386",         FICL_TRUE);
873     ficlSetEnv(pSys, "arch-powerpc",      FICL_FALSE);
874 #elif defined(__powerpc__)
875     ficlSetEnv(pSys, "arch-i386",         FICL_FALSE);
876     ficlSetEnv(pSys, "arch-powerpc",      FICL_TRUE);
877 #endif
878 
879     return;
880 }
881