stand/ficl/loader.c

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