kernel/flk.c

   1 /* FLK loader program
   2
   3   Copyright (C) 1998 Lars Krueger
   4
   5   This file is part of FLK.
   6
   7   FLK is free software; you can redistribute it and/or
   8   modify it under the terms of the GNU General Public License
   9   as published by the Free Software Foundation; either version 2
  10   of the License, or (at your option) any later version.
  11
  12   This program is distributed in the hope that it will be useful,
  13   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15   GNU General Public License for more details.
  16
  17   You should have received a copy of the GNU General Public License
  18   along with this program; if not, write to the Free Software
  19   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20 */
  21
  22 /*
  23  * $Id: flk.c,v 1.25 1998/08/30 10:50:59 root Exp $
  24  *****************************************************************************
  25  * $Log: flk.c,v $
  26  * Revision 1.25  1998/08/30 10:50:59  root
  27  * added diagnostics
  28  *
  29  * Revision 1.24  1998/07/15 16:38:23  root
  30  * TERM=dumb bugss removed
  31  *
  32  * Revision 1.23  1998/07/09 19:16:41  root
  33  * fixed relocation to enable code size changes
  34  *
  35  * Revision 1.22  1998/06/24 05:30:46  root
  36  * corrected terminal setup and cleanup
  37  *
  38  * Revision 1.21  1998/06/03 07:55:16  root
  39  * corrected flush on exit
  40  *
  41  * Revision 1.20  1998/06/01 18:05:39  root
  42  * changed image search order (argv[0] doesn't contain a path)
  43  *
  44  * Revision 1.19  1998/06/01 17:51:42  root
  45  * GET-CWD added
  46  *
  47  * Revision 1.18  1998/05/24 18:43:16  root
  48  * delayed flush corrected
  49  *
  50  * Revision 1.17  1998/05/24 15:41:26  root
  51  * Delayed flush can be turned off
  52  *
  53  * Revision 1.16  1998/05/23 19:23:54  root
  54  * delayed flushing of stdout
  55  *
  56  * Revision 1.15  1998/05/21 19:24:49  root
  57  * XForms support
  58  *
  59  * Revision 1.14  1998/05/17 08:27:09  root
  60  * script mode, ODOES>
  61  *
  62  * Revision 1.13  1998/05/16 16:19:24  root
  63  * direct terminfo access
  64  *
  65  * Revision 1.12  1998/05/09 21:47:05  root
  66  * S, renamed to ,C
  67  * ,S included
  68  *
  69  * Revision 1.11  1998/05/02 15:05:55  root
  70  * CREATE-FILE corrected
  71  *
  72  * Revision 1.10  1998/05/01 18:13:33  root
  73  * Image search order changed to:
  74  * executable, ./flk.flk, default.flk
  75  *
  76  * Revision 1.9  1998/05/01 18:11:25  root
  77  * GNU license text added
  78  * comments checked
  79  *
  80  * Revision 1.8  1998/04/30 09:42:25  root
  81  * other image search order
  82  *
  83  * Revision 1.7  1998/04/29 18:26:32  root
  84  * SYSTEM, BELL, ALERT
  85  * TYPE fixed (was printf like, now puts like)
  86  *
  87  * Revision 1.6  1998/04/27 18:41:42  root
  88  * directory primitives
  89  *
  90  * Revision 1.5  1998/04/25 11:03:28  root
  91  * added flk.c to check in list
  92  *
  93  * Revision 1.4  1998/04/11 11:58:14  root
  94  * REPOSITION-FILE checked
  95  *
  96  * Revision 1.3  1998/04/10 14:42:50  root
  97  * new header format to ease SAVE-SAYSTEM
  98  *
  99  * Revision 1.2  1998/04/07 20:10:33  root
 100  * final .flk format, OS calls, image search
 101  *
 102  */
 103 #include <assert.h>
 104 #include <dirent.h>
 105 #include <dlfcn.h>
 106 #include <errno.h>
 107 #include <fcntl.h>
 108 #include <signal.h>
 109 #include <stdlib.h>
 110 #include <stdio.h>
 111 #include <string.h>
 112 #include <time.h>
 113 #include <unistd.h>
 114
 115 #include <sys/mman.h>
 116 #include <sys/stat.h>
 117 #include <sys/time.h>
 118 #include <sys/types.h>
 119
 120 #define NCURSES_INTERNALS
 121 #include <ncurses.h>
 122 #include <term.h>
 123
 124
 125 static int goobers = 0;
 126
 127
 128 static DIR *glob_dir = NULL;
 129 static struct dirent *glob_dirent = NULL;
 130 static struct termios shell_ios;
 131 static struct termios prog_ios;
 132
 133 #ifdef DELAY_FLUSH
 134 # define FLUSHBUFFERLEN  (5000)
 135 static char flushBuffer[FLUSHBUFFERLEN];
 136 static unsigned flushBufferInd;
 137
 138
 139 static void myFlush (void) {
 140   write(1, flushBuffer, flushBufferInd);
 141   flushBufferInd = 0;
 142 }
 143
 144
 145 static void myputp (const char *s) {
 146   unsigned int l;
 147   //
 148   assert(s);
 149   l = strlen(s);
 150   if (l+flushBufferInd >= FLUSHBUFFERLEN) {
 151     signal(SIGALRM, SIG_IGN);
 152     myFlush();
 153   }
 154   memcpy(flushBuffer+flushBufferInd, s, l);
 155   flushBufferInd += l;
 156 }
 157
 158
 159 static void flushHandler (int sig) {
 160   myFlush();
 161 }
 162
 163
 164 static void startFlusher (void) {
 165   if (flushBufferInd) {
 166     struct itimerval to;
 167     //
 168     to.it_value.tv_sec = 0;
 169     to.it_value.tv_usec = 40000;
 170     to.it_interval.tv_sec = 0;
 171     to.it_interval.tv_usec = 0;
 172     setitimer(ITIMER_REAL, &to, NULL);
 173     signal(SIGALRM, flushHandler);
 174   }
 175 }
 176
 177 #else
 178 # define myputp  putp
 179 # define startFlusher(...)  ((void)0)
 180 #endif
 181
 182
 183 /*==============================global constants==============================*/
 184 static const unsigned char headerID[] = "FLK Image 1.1";
 185 #define HEADER_ID_LEN  (sizeof(headerID)-1)
 186
 187 #define FTRUE  ((unsigned int)(~0))
 188
 189 #define STACK  unsigned int _stptr_ = 0
 190
 191 #define POP(var,erg)    do { erg=stack[_stptr_].var; _stptr_++; } while (0)
 192 #define PUSH(var, val)  do {_stptr_--; stack[_stptr_].var=val; } while (0)
 193 #define POPSTRING(erg)  do { unsigned int len; char *s; POP(uval, len); POP(caddr, s); erg=makeCString(s, len); } while (0)
 194 #define DPUSH(x)        do { PUSH(nval, x); PUSH(nval, (x<0) ? -1 : 0); } while (0)
 195 #define UDPUSH(x)       do { PUSH(uval, x); PUSH(uval, 0); } while (0)
 196
 197
 198 /*==============================global variables==============================*/
 199 static unsigned int *ReloTable;
 200 static unsigned int *ForthDataStack, *ForthCallStack;
 201 static unsigned int *Image;
 202 static unsigned int MemorySize = 0;
 203
 204
 205 /*==============================static functions==============================*/
 206 /* This could be done more eloquently, right? */
 207 static void printErrorBanner (void) {
 208   printf("FLK Error: ");
 209 }
 210
 211
 212 static char *makeCString (const char *fstr, unsigned int len) {
 213   char *res = (char *)malloc(len+1);
 214   //
 215   assert(res);
 216   memcpy(res, fstr, len);
 217   res[len] = 0;
 218   return res;
 219 }
 220
 221
 222 static void setupTerm (void) {
 223   setupterm(NULL, 1, NULL);
 224   def_shell_mode();
 225   tcgetattr(1, &shell_ios);
 226   prog_ios = shell_ios;
 227   prog_ios.c_lflag &= ~(ICANON | ECHO);
 228   prog_ios.c_iflag &= ~(ICRNL | INLCR);
 229   tcsetattr(1, TCSANOW, &prog_ios);
 230   tcflow(1, TCOON);
 231   def_prog_mode();
 232 #ifdef DELAY_FLUSH
 233   flushBufferInd = 0;
 234 #else
 235   setbuf(stdout, 0);
 236 #endif
 237 }
 238
 239
 240 static void cleanupTerm (void) {
 241   if (glob_dir) closedir(glob_dir);
 242   reset_shell_mode();
 243   tcsetattr(1, TCSADRAIN, &shell_ios);
 244 #ifdef DELAY_FLUSH
 245   signal(SIGALRM, SIG_IGN);
 246   myFlush();
 247 #endif
 248 }
 249
 250
 251 /*==============================system primitives=============================*/
 252 typedef union {
 253   unsigned int uval;
 254   int nval;
 255   char *caddr;
 256   void *vaddr;
 257 } Cell;
 258
 259 typedef void (*SystemPrimitive) (Cell *stack);
 260
 261
 262 /* x -- */
 263 static void EMIT (Cell *stack) {
 264   STACK;
 265   int x;
 266   char xx[2];
 267   //
 268   POP(nval, x);
 269   switch (x) {
 270     case -1: /* backspace */
 271       if (!cursor_left) myputp("\010"); else myputp(cursor_left);
 272       break;
 273     default:
 274       xx[0] = x;
 275       xx[1] = 0;
 276       myputp(xx);
 277       break;
 278   }
 279   startFlusher();
 280 }
 281
 282
 283 /* -- char */
 284 static void KEY (Cell *stack) {
 285   STACK;
 286   int key;
 287   //
 288   do {
 289     key = getchar();
 290   } while (!(32 <= key && key < 127));
 291   PUSH(nval, key);
 292 }
 293
 294
 295 /* c-addr n  --  */
 296 static void TYPE (Cell *stack) {
 297   STACK;
 298   char *str;
 299   //
 300   POPSTRING(str);
 301   myputp(str);
 302   startFlusher();
 303   free(str);
 304 }
 305
 306
 307 /*  --  */
 308 static void CR (Cell *stack) {
 309   if (newline) {
 310     myputp(newline);
 311   } else {
 312     myputp(cursor_down);
 313     myputp("\r");
 314   }
 315   startFlusher();
 316 }
 317
 318
 319 /* x y --  */
 320 static void AT_XY (Cell *stack) {
 321   STACK;
 322   int y, x;
 323   //
 324   POP(uval, y);
 325   POP(uval, x);
 326   if (cursor_address) {
 327     myputp(tgoto(cursor_address, x, y));
 328     startFlusher();
 329   }
 330 }
 331
 332
 333 /*  -- flag  */
 334 static void KEY_IF (Cell *stack) {
 335   STACK;
 336   fd_set set;
 337   struct timeval tv;
 338   //
 339   FD_ZERO(&set);
 340   FD_SET(1, &set);
 341   tv.tv_sec = 0;
 342   tv.tv_usec = 0;
 343   PUSH(nval, select(2, &set, NULL, NULL, &tv) ? FTRUE : 0);
 344 }
 345
 346
 347 /*  --  */
 348 static void PAGE (Cell *stack) {
 349   if (clear_screen) {
 350     myputp(clear_screen);
 351     startFlusher();
 352   }
 353 }
 354
 355
 356 /*  -- u  */
 357 static void EKEY (Cell *stack) {
 358   STACK;
 359   int key = getchar();
 360   PUSH(nval, key);
 361 }
 362
 363
 364 /* u  -- u false | char true */
 365 static void EKEY_2_CHAR (Cell *stack) {
 366   STACK;
 367   int key;
 368   //
 369   POP(nval, key);
 370   PUSH(nval, key);
 371   PUSH(uval, (32 <= key && key < 127) ? FTRUE : 0);
 372 }
 373
 374
 375 /* -- flag */
 376 static void EKEY_IF (Cell *stack) {
 377   KEY_IF(stack);
 378 }
 379
 380
 381 /* -- flag */
 382 static void EMIT_IF (Cell *stack) {
 383   STACK;
 384   PUSH(uval, FTRUE);
 385 }
 386
 387
 388 /* u -- */
 389 static void MS (Cell *stack) {
 390   STACK;
 391   unsigned int ms;
 392   struct timeval tv;
 393   //
 394   POP(uval, ms);
 395 #ifdef DELAY_FLUSH
 396   signal(SIGALRM, SIG_IGN);
 397   myFlush();
 398 #endif
 399   tv.tv_sec = ms/1000;
 400   tv.tv_usec = (ms%1000)*1000;
 401   select(0, 0, 0, 0, &tv);
 402 }
 403
 404
 405 /* -- sec min hr day mn yr */
 406 static void TIME_DATE (Cell *stack) {
 407   STACK;
 408   time_t t = time(NULL);
 409   struct tm *tms = localtime(&t);
 410   //
 411   assert(tms);
 412   PUSH(uval, tms->tm_sec);
 413   PUSH(uval, tms->tm_min);
 414   PUSH(uval, tms->tm_hour);
 415   PUSH(uval, tms->tm_mday);
 416   PUSH(uval, tms->tm_mon+1);
 417   PUSH(uval, tms->tm_year+1900);
 418 }
 419
 420
 421 /* u -- a-addr ior */
 422 static void ALLOCATE (Cell *stack) {
 423   STACK;
 424   unsigned cnt;
 425   void *p;
 426   //
 427   POP(uval, cnt);
 428   p = malloc(cnt);
 429   PUSH(vaddr, p);
 430   PUSH(uval, p ? 0 : -9);
 431 }
 432
 433
 434 /* u -- ior  */
 435 static void _FREE (Cell *stack) {
 436   STACK;
 437   void *buf;
 438   //
 439   POP(vaddr, buf);
 440   free(buf);
 441   PUSH(uval, 0);
 442 }
 443
 444
 445 /* addr u  -- addr2 ior */
 446 static void RESIZE (Cell *stack) {
 447   STACK;
 448   unsigned int u;
 449   void *p, *p2;
 450   //
 451   POP(uval, u);
 452   POP(vaddr, p);
 453   p2 = realloc(p, u);
 454   PUSH(vaddr, p2);
 455   PUSH(nval, p2 ? 0 : -9);
 456 }
 457
 458
 459 /* code -- */
 460 static void BYE (Cell *stack) {
 461   STACK;
 462   int ec;
 463   //
 464   POP(nval, ec);
 465   cleanupTerm();
 466   exit(ec);
 467 }
 468
 469
 470 /* -- rows */
 471 static void SCR_ROWS (Cell *stack) {
 472   STACK;
 473   PUSH(nval, LINES);
 474 }
 475
 476
 477 /* -- cols */
 478 static void SCR_COLS (Cell *stack) {
 479   STACK;
 480   PUSH(nval, COLS);
 481 }
 482
 483
 484 /* fid -- ior  */
 485 static void CLOSE_FILE (Cell *stack) {
 486   STACK;
 487   int fid;
 488   //
 489   POP(nval, fid);
 490   if (close(fid)) PUSH(nval, -37); else PUSH(nval, 0);
 491 }
 492
 493
 494 #define FM_RO   (1)
 495 #define FM_RW   (2)
 496 #define FM_BIN  (4)
 497 #define FM_WO   (8)
 498
 499 static int c_mode (int forth_mode) {
 500   int erg = 0;
 501   //
 502   if (forth_mode&FM_RO) erg = O_RDONLY;
 503   else if (forth_mode&FM_RW) erg = O_RDWR;
 504   else if (forth_mode&FM_WO) erg = O_WRONLY;
 505   return erg;
 506 }
 507
 508
 509 /* addr u mode -- fid ior */
 510 static void CREATE_FILE (Cell *stack) {
 511   STACK;
 512   int mode, fid, nmode;
 513   char *name;
 514   //
 515   POP(nval, mode);
 516   POPSTRING(name);
 517   nmode = c_mode(mode);
 518   fid = open(name, nmode|O_CREAT, 0666);
 519   PUSH(nval, fid);
 520   if (fid == -1) PUSH(nval, -37); else PUSH(nval, 0);
 521   free(name);
 522 }
 523
 524
 525 /* addr n -- ior  */
 526 static void DELETE_FILE (Cell *stack) {
 527   STACK;
 528   char *name;
 529   POPSTRING(name);
 530   //
 531   if (unlink(name) < 0) PUSH(nval, -37); else PUSH(nval, 0);
 532   free(name);
 533 }
 534
 535
 536 /* fid  -- ud ior */
 537 static void FILE_POSITION (Cell *stack) {
 538   STACK;
 539   int fid, where;
 540   //
 541   POP(nval, fid);
 542   where = lseek(fid, 0, SEEK_CUR);
 543   PUSH(uval, where);
 544   PUSH(nval, 0);
 545   if (where == -1) PUSH(nval, -37); else PUSH(nval, 0);
 546 }
 547
 548
 549 /* fid -- ud ior */
 550 static void FILE_SIZE (Cell *stack) {
 551   STACK;
 552   int fid;
 553   off_t where;
 554   //
 555   POP(nval, fid);
 556   where = lseek(fid, 0, SEEK_CUR);
 557   if (where == -1) {
 558     PUSH(nval, 0);
 559     PUSH(nval, 0);
 560     PUSH(nval, -37);
 561   } else {
 562     off_t end = lseek(fid, 0, SEEK_END);
 563     PUSH(uval, end);
 564     PUSH(nval, 0);
 565     if (-1 == lseek(fid, where, SEEK_SET)) PUSH(nval, -37); else PUSH(nval, 0);
 566   }
 567 }
 568
 569
 570 /* addr u mode -- fid ior */
 571 static void OPEN_FILE (Cell *stack) {
 572   STACK;
 573   int mode, fid, nmode;
 574   char *name;
 575   //
 576   POP(nval, mode);
 577   POPSTRING(name);
 578   nmode = c_mode(mode);
 579   fid = open(name, nmode);
 580   PUSH(nval, fid);
 581   if (fid == -1) PUSH(nval, -38); else PUSH(nval, 0);
 582   free(name);
 583 }
 584
 585
 586 /* addr u fid -- u2 ior */
 587 static void READ_FILE (Cell *stack) {
 588   STACK;
 589   int fid;
 590   unsigned int len, lread;
 591   char *buf;
 592   //
 593   POP(nval, fid);
 594   POP(uval, len);
 595   POP(caddr, buf);
 596   lread = read(fid, buf, len);
 597   PUSH(uval, lread);
 598   if (lread == -1) PUSH(nval, -37); else PUSH(nval, 0);
 599 }
 600
 601
 602 /* addr u fid -- u2 flag ior */
 603 static void READ_LINE (Cell *stack) {
 604   STACK;
 605   int fid, seek_res, len, lread, i;
 606   char *buf;
 607   //
 608   POP(nval, fid);
 609   POP(uval, len);
 610   POP(caddr, buf);
 611   lread = read(fid, buf, len);
 612   for(i = 0; i < lread && buf[i] != '\n'; i++);
 613   seek_res = lseek(fid, i-lread+1, SEEK_CUR);
 614   PUSH(nval, i);
 615   PUSH(nval, lread ? FTRUE : 0);
 616   PUSH(nval, (lread == -1 || seek_res == -1) ? -37 : 0);
 617 }
 618
 619
 620 /* ud fid -- ior  */
 621 static void REPOSITION_FILE (Cell *stack) {
 622   STACK;
 623   int fid, res = -1;
 624   unsigned int udh, udl;
 625   //
 626   POP(nval, fid);
 627   POP(uval, udh);
 628   POP(uval, udl);
 629   if (!udh) res = lseek(fid, udl, SEEK_SET);
 630   if (res < 0) PUSH(nval, -37); else PUSH(nval, 0);
 631 }
 632
 633
 634 /* ud fid -- ior  */
 635 static void RESIZE_FILE (Cell *stack) {
 636   STACK;
 637   int fid, res = -1;
 638   unsigned int udh, udl, flen;
 639   //
 640   POP(nval, fid);
 641   POP(uval, udh);
 642   POP(uval, udl);
 643   if (!udh) {
 644     flen = lseek(fid, 0, SEEK_END);
 645     if ((int)flen != -1) {
 646       if (udl > flen) {
 647         /* write some */
 648         char *buf = malloc(udl-flen);
 649         if (buf) {
 650           res = write(fid, buf, udl-flen);
 651           free(buf);
 652         }
 653       } else res = ftruncate(fid, udl);
 654     }
 655   }
 656   if (res < 0) PUSH(nval, -37); else PUSH(nval, 0);
 657 }
 658
 659
 660 /* a1 u1 a2 u2 -- ior  */
 661 static void RENAME_FILE (Cell *stack) {
 662   STACK;
 663   char *from, *to;
 664   //
 665   POPSTRING(from);
 666   POPSTRING(to);
 667   if (rename(from, to) < 0) PUSH(nval, -37); else PUSH(nval, 0);
 668   free(to);
 669   free(from);
 670 }
 671
 672
 673 /* addr u fid -- ior  */
 674 static void WRITE_FILE (Cell *stack) {
 675   STACK;
 676   int fid;
 677   unsigned int len;
 678   char *buf;
 679   //
 680   POP(nval, fid);
 681   POP(uval, len);
 682   POP(caddr, buf);
 683   if (write(fid, buf, len) != len) PUSH(nval, -37); else PUSH(nval, 0);
 684 }
 685
 686
 687 /* addr u fid -- ior  */
 688 static void WRITE_LINE (Cell *stack) {
 689   STACK;
 690   int fid;
 691   unsigned int len, lwr;
 692   char *buf, cr;
 693   //
 694   POP(nval, fid);
 695   POP(uval, len);
 696   POP(caddr, buf);
 697   lwr = write(fid, buf, len);
 698   if (lwr == len) {
 699     cr = '\n';
 700     if (1 != write(fid, &cr, 1)) lwr = -1;
 701   }
 702   if (lwr != len) PUSH(nval, -37); else PUSH(nval, 0);
 703 }
 704
 705
 706 /* addr u -- x ior */
 707 static void FILE_STATUS (Cell *stack) {
 708   STACK;
 709   char *name;
 710   static struct stat buf;
 711   int erg;
 712   //
 713   POPSTRING(name);
 714   erg = stat(name, &buf);
 715   PUSH(vaddr, &buf);
 716   if (erg == 0) PUSH(nval, 0); else PUSH(nval, -38);
 717   free(name);
 718 }
 719
 720
 721 /* fid -- ior  */
 722 static void FLUSH_FILE (Cell *stack) {
 723   STACK;
 724   int fid;
 725   //
 726   POP(nval, fid);
 727   if (-1 == fsync(fid)) PUSH(nval, -37); else PUSH(nval, 0);
 728   PUSH(nval, 0);
 729 }
 730
 731
 732 /* fstat -- flag */
 733 static void IS_DIRECTORY (Cell *stack) {
 734   STACK;
 735   struct stat *buf;
 736   //
 737   POP(vaddr, buf);
 738   if (S_ISDIR(buf->st_mode)) PUSH(uval, FTRUE); else PUSH(uval, 0);
 739 }
 740
 741
 742 /* -- */
 743 static void SCR_BELL (Cell *stack) {
 744   if (bell) {
 745     myputp(bell);
 746     startFlusher();
 747   }
 748 }
 749
 750
 751 /* -- */
 752 static void SCR_FLASH (Cell *stack) {
 753   if (flash_screen) {
 754     myputp(flash_screen);
 755     startFlusher();
 756   }
 757 }
 758
 759
 760 /* addr len -- retval */
 761 static void SYSTEM (Cell *stack) {
 762   STACK;
 763   char *cmd;
 764   //
 765   POPSTRING(cmd);
 766   reset_shell_mode();
 767   tcsetattr(1, TCSADRAIN, &shell_ios);
 768 #ifdef DELAY_FLUSH
 769   signal(SIGALRM, SIG_IGN);
 770   myFlush();
 771 #endif
 772   PUSH(nval, system(cmd));
 773   reset_prog_mode();
 774   tcsetattr(1, TCSADRAIN, &prog_ios);
 775   free(cmd);
 776 }
 777
 778
 779 #define READDIR  do { \
 780   if (!glob_dir) { \
 781     PUSH(uval, 0); \
 782     PUSH(uval, 0); \
 783     PUSH(uval, 0); \
 784   } else { \
 785     glob_dirent = readdir(glob_dir); \
 786     if (!glob_dirent) { \
 787       PUSH(uval, 0); \
 788       PUSH(uval, 0); \
 789       PUSH(uval, 0); \
 790       PUSH(uval, 0); \
 791       closedir(glob_dir); \
 792       glob_dir=0; \
 793     } else { \
 794       PUSH(caddr, glob_dirent->d_name); \
 795       PUSH(uval, strlen(glob_dirent->d_name)); \
 796       PUSH(uval, FTRUE); \
 797     } \
 798   } \
 799 } while (0)
 800
 801
 802 /* addr1 u1 -- addr2 u2 flag1 */
 803 static void FIND_FIRST (Cell *stack) {
 804   STACK;
 805   char *dir;
 806   //
 807   POPSTRING(dir);
 808   if (glob_dir) closedir(glob_dir);
 809   glob_dir = opendir(dir);
 810   READDIR;
 811   free(dir);
 812 }
 813
 814
 815 /* -- addr u flag1 */
 816 static void FIND_NEXT (Cell *stack) {
 817   STACK;
 818   READDIR;
 819 }
 820
 821
 822 /* -- secs usecs */
 823 static void TIME_OF_DAY (Cell *stack) {
 824   STACK;
 825   struct timeval tv;
 826   //
 827   gettimeofday(&tv, NULL);
 828   PUSH(uval, tv.tv_sec);
 829   PUSH(uval, tv.tv_usec);
 830 }
 831
 832
 833 /* addr len flag -- lib */
 834 static void OPENLIB (Cell *stack) {
 835   STACK;
 836   char *name;
 837   int flags;
 838   void *lib;
 839   //
 840   POP(nval, flags);
 841   POPSTRING(name);
 842   lib = dlopen(name, flags);
 843   PUSH(vaddr, lib);
 844   free(name);
 845 }
 846
 847
 848 /* -- cstring */
 849 static void LIBERROR (Cell *stack) {
 850   STACK;
 851   PUSH(caddr, (char *)dlerror());
 852 }
 853
 854
 855 /* lib addr len -- fct */
 856 static void LIBSYMBOL (Cell *stack) {
 857   STACK;
 858   void *lib, *sym;
 859   char *name;
 860   //
 861   POPSTRING(name);
 862   POP(vaddr, lib);
 863   sym = dlsym(lib, name);
 864   PUSH(vaddr, sym);
 865   free(name);
 866 }
 867
 868
 869 /* lib -- */
 870 static void CLOSELIB (Cell *stack) {
 871   STACK;
 872   void *lib;
 873   //
 874   POP(vaddr, lib);
 875   dlclose(lib);
 876 }
 877
 878
 879 /* -- bool-array-addr */
 880 static void TERM_BOOL (Cell *stack) {
 881   STACK;
 882   PUSH(vaddr, cur_term->type.Booleans);
 883 }
 884
 885
 886 /* -- short-array-addr */
 887 static void TERM_NUMBER (Cell *stack) {
 888   STACK;
 889   PUSH(vaddr, cur_term->type.Numbers);
 890 }
 891
 892
 893 /* -- char*-array-addr */
 894 static void TERM_STRING (Cell *stack) {
 895   STACK;
 896   PUSH(vaddr, cur_term->type.Strings);
 897 }
 898
 899
 900 /* -- cwd */
 901 static void GET_CWD (Cell *stack) {
 902   STACK;
 903   static char buf[PATH_MAX];
 904   //
 905   getcwd(buf, sizeof(buf));
 906   strcat(buf, "/");
 907   PUSH(vaddr, buf);
 908 }
 909
 910
 911 /* -- flag */
 912 static void IS_GOOBERSP (Cell *stack) {
 913   STACK;
 914   PUSH(nval, goobers);
 915 }
 916
 917
 918 /* -- bindir */
 919 static void GET_BIN_PATH (Cell *stack) {
 920   STACK;
 921   static char buf[PATH_MAX];
 922   //
 923   memset(buf, 0, sizeof(buf));
 924   if (readlink("/proc/self/exe", buf, sizeof(buf)-1) < 0) {
 925     strcpy(buf, "./");
 926   } else {
 927     char *p = strrchr(buf, '/');
 928     //
 929     if (p != NULL) p[1] = 0; else strcpy(buf, "./");
 930   }
 931   PUSH(vaddr, buf);
 932 }
 933
 934
 935 static const SystemPrimitive primitives[] = {
 936   (SystemPrimitive)(51), // # of primitives
 937   EMIT, KEY, TYPE, CR, AT_XY, KEY_IF, PAGE, EKEY, EKEY_2_CHAR, EKEY_IF,
 938   EMIT_IF, MS, TIME_DATE, ALLOCATE, _FREE, RESIZE, BYE, CLOSE_FILE,
 939   CREATE_FILE, DELETE_FILE, FILE_POSITION, FILE_SIZE, OPEN_FILE, READ_FILE,
 940   READ_LINE, REPOSITION_FILE, RESIZE_FILE, RENAME_FILE, WRITE_FILE,
 941   WRITE_LINE, FILE_STATUS, FLUSH_FILE, SCR_ROWS, SCR_COLS, FIND_FIRST,
 942   FIND_NEXT, IS_DIRECTORY, SCR_BELL, SCR_FLASH, SYSTEM, TIME_OF_DAY, OPENLIB,
 943   LIBERROR, LIBSYMBOL, CLOSELIB, TERM_BOOL, TERM_NUMBER, TERM_STRING, GET_CWD,
 944   IS_GOOBERSP, GET_BIN_PATH
 945 };
 946
 947
 948 /* Fill the global variables with values. */
 949 enum {
 950   HA_INIT_DATASTACK = 0, /* initial value of EBP */
 951   HA_INIT_CALLSTACK, /* initial value of ESP */
 952   HA_RELTABLE, /* address of relocation table */
 953   HA_LOADER, /* loader table address */
 954   HA_HERE_LIMIT, /* first byte after data area */
 955   HA_CHERE_LIMIT, /* first byte after code area */
 956   HA_IMAGE_BASE, /* base address of image */
 957   HA_INIT_HERE, /* initial value of HERE */
 958   HA_INIT_CHERE, /* initial value of CHERE */
 959   HA_BOOT_CODE, /* address of boot code */
 960   HA_ENTRY, /* address of entry_point */
 961   HA_CODESIZE, /* number of cells in code area */
 962   HA_DATASIZE, /* number of cells in data area */
 963   HA_DATA_CELLS, /* initial size of data stack in cells */
 964   HA_CALL_CELLS /* initial size of call stack in cells */
 965 }; /*14*/
 966
 967
 968 #define READCELL(x)  read(inFile, &x, sizeof(unsigned int))
 969
 970 static int readImage (int inFile, unsigned int offs) {
 971   unsigned int imglen, caLen, daLen, reloAlloc, reloCnt, caUse, daUse, imgBase, oldCaLen/*, oldDaLen*/;
 972   /* inFile is correctly positioned */
 973 #define FP  printf("%d\n", lseek(inFile, 0, SEEK_CUR));
 974   READCELL(reloCnt);
 975   reloAlloc = (3*reloCnt)/2;
 976   ReloTable = (unsigned int *)calloc(reloAlloc+2, sizeof(unsigned int));
 977   if (!ReloTable) return 0;
 978   ReloTable[0] = reloAlloc;
 979   ReloTable[1] = reloCnt;
 980   read(inFile, &ReloTable[2], reloCnt*sizeof(unsigned int));
 981   READCELL(caLen);
 982   READCELL(daLen);
 983   READCELL(caUse);
 984   READCELL(daUse);
 985   READCELL(imgBase);
 986   if (goobers) {
 987     printf("OK.\n");
 988   }
 989   if (MemorySize > caLen) {
 990     caLen = MemorySize;
 991     if (goobers) {
 992       printf("Memory size override for code area used.\n");
 993     }
 994   }
 995   if (MemorySize > daLen) {
 996     daLen = MemorySize;
 997     if (goobers) {
 998       printf("Memory size override for data area used.\n");
 999     }
1000   }
1001   imglen = caLen+daLen;
1002   //Image = (unsigned int *)calloc(imglen, sizeof(char));
1003   Image = (unsigned int *)mmap(NULL, imglen, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0);
1004   if (Image == MAP_FAILED) {
1005     if (goobers) {
1006       printf("Could not allocate memory for image.\n");
1007     }
1008     return 0;
1009   }
1010   memset(Image, 0, imglen);
1011   if (goobers) {
1012     printf("code area length: %d bytes; data area length: %d bytes; relocation records: %u\n", caLen, daLen, reloCnt);
1013   }
1014   read(inFile, Image, caUse);
1015   read(inFile, Image+caLen/sizeof(unsigned int), daUse);
1016   ForthDataStack = (unsigned int *)calloc(Image[HA_DATA_CELLS]+1, sizeof(unsigned int));
1017   if (ForthDataStack == NULL) return 0;
1018   ForthCallStack = (unsigned int *)calloc(Image[HA_CALL_CELLS], sizeof(unsigned int));
1019   if (ForthCallStack == NULL) return 0;
1020   Image[HA_INIT_DATASTACK] = (unsigned int) ForthDataStack+Image[HA_DATA_CELLS]*sizeof(unsigned int);
1021   Image[HA_INIT_CALLSTACK] = (unsigned int) ForthCallStack+Image[HA_CALL_CELLS]*sizeof(unsigned int);
1022   Image[HA_RELTABLE] = (unsigned int)ReloTable;
1023   Image[HA_LOADER] = (unsigned int)primitives;
1024   Image[HA_HERE_LIMIT] = (unsigned int)Image+imglen;
1025   Image[HA_CHERE_LIMIT] = (unsigned int)Image+caLen;
1026   Image[HA_IMAGE_BASE] = (unsigned int)Image;
1027   Image[HA_INIT_CHERE] = (unsigned int)Image+caUse;
1028   Image[HA_INIT_HERE] = (unsigned int)Image+daUse+caLen;
1029   oldCaLen = Image[HA_CODESIZE];
1030   //oldDaLen = Image[HA_DATASIZE];
1031   Image[HA_CODESIZE] = caLen;
1032   Image[HA_DATASIZE] = daLen;
1033   for (unsigned int i = 0; i < ReloTable[1]; ++i) {
1034     unsigned int *relAddr, origVal;
1035     char *cImage = (char *)Image;
1036     unsigned int relItem = ReloTable[i+2];
1037     //
1038     if (relItem >= oldCaLen) {
1039       relItem = relItem-oldCaLen+caLen;
1040       ReloTable[i+2] = relItem;
1041     }
1042     relAddr = (unsigned int *)(&cImage[relItem]);
1043     origVal = *relAddr-imgBase;
1044     if (origVal >= oldCaLen) {
1045       *relAddr = (unsigned int)Image+origVal-oldCaLen+caLen;
1046     } else {
1047       *relAddr = (unsigned int)Image+origVal;
1048     }
1049   }
1050   return 1;
1051 }
1052
1053
1054 /* Jump to the start of the image. */
1055 typedef void (*GoForth) (int argc, char **argv);
1056
1057
1058 static void startImage (int argc, char **argv) {
1059   GoForth goForth = (GoForth)Image[HA_BOOT_CODE];
1060   //
1061   goForth(argc, argv);
1062 }
1063
1064
1065 /* Free all allocated space. */
1066 #define DELETE(x)  if (x) { free(x); x=NULL; }
1067
1068 static void freeImage (void) {
1069   DELETE(ReloTable);
1070   DELETE(Image);
1071   DELETE(ForthCallStack);
1072   DELETE(ForthDataStack);
1073 }
1074
1075
1076 static int idFound (int fi, unsigned int offs) {
1077   unsigned char buf[HEADER_ID_LEN];
1078   //
1079   lseek(fi, offs, SEEK_SET);
1080   read(fi, buf, HEADER_ID_LEN);
1081   for (unsigned int i = 0; i < HEADER_ID_LEN; ++i) if (buf[i] != (headerID[i]|0x80)) return 0;
1082   return 1;
1083 }
1084
1085
1086 static int findImageHeader (int fi, unsigned int *offs) {
1087   unsigned int len = lseek(fi, 0, SEEK_END);
1088   //
1089   assert(offs);
1090   for (unsigned int i = 0; i < len; ++i) {
1091     if (idFound(fi, i)) {
1092       *offs = i;
1093       return 1;
1094     }
1095   }
1096   return 0;
1097 }
1098
1099
1100 /* The function needs no return value, because it does not return, if it is
1101    successful. Otherwise you may try to run a different image. */
1102 static void runImage (const char *fileName, int argc, char **argv) {
1103   /* we want to open a binary file, therefore we use handles, not FILEs,
1104      because some systems (e.g. NeXTStep 3.1 for Intel 386) can't open binary
1105      FILES, only binary handles. */
1106   int inFile;
1107   unsigned imageOk, offs;
1108   //
1109   assert(fileName);
1110   if (goobers) {
1111     printf("Trying image file '%s': ", fileName);
1112     fflush(stdout);
1113   }
1114   inFile = open(fileName, O_RDONLY);
1115   if (inFile == -1) {
1116     /* some error occured; tell what happened and return */
1117     if (goobers) {
1118       printf("%s\n", strerror(errno));
1119     }
1120     return;
1121   }
1122   imageOk = 0;
1123   if (findImageHeader(inFile, &offs)) {
1124     if (readImage(inFile, offs)) imageOk = 1;
1125     else if (goobers) printf("Error loading image.\n");
1126   } else if (goobers) printf("Contains no image.\n");
1127   close(inFile);
1128   if (imageOk) {
1129     setupTerm();
1130     if (goobers) {
1131       printf("Image started.\n");
1132     }
1133     /* this function never returns */
1134     startImage(argc, argv);
1135   }
1136   /* clean up */
1137   freeImage();
1138 }
1139
1140
1141 static void removeOptions (int *argc, char **argv, int pos, int cnt) {
1142   if (pos+cnt >= *argc) {
1143     *argc = 0;
1144   } else {
1145     for (int f = pos+cnt; f < *argc; ++f) argv[f-cnt] = argv[f];
1146     (*argc) -= cnt;
1147   }
1148 }
1149
1150
1151 static void processOptions (int *argc, char **argv) {
1152   for (int i = 1; i < *argc; ++i) {
1153     if (strcmp(argv[i], "-m") == 0) {
1154       if (i+1 < *argc) {
1155         MemorySize = (atoi(argv[i+1])+3)&~3;
1156         removeOptions(argc, argv, i, 2);
1157         --i;
1158         if (goobers) {
1159           printf("Memory size overrride: %d bytes\n", MemorySize);
1160         }
1161       }
1162     } else if (strcmp(argv[i], "-goobers") == 0) {
1163       goobers = 1;
1164       removeOptions(argc, argv, i, 1);
1165       --i;
1166     } else {
1167       return;
1168     }
1169   }
1170 }
1171
1172
1173 /*================================main program================================*/
1174 int main (int argc, char **argv) {
1175   char buf[4096]; // this should be enough for everyone
1176   //
1177   processOptions(&argc, argv);
1178   /* Try to find an image in this program. */
1179   memset(buf, 0, sizeof(buf));
1180   if (readlink("/proc/self/exe", buf, sizeof(buf)-1) < 0) {
1181     runImage(argv[0], argc, argv);
1182   } else {
1183     runImage(buf, argc, argv);
1184   }
1185   strcpy(buf, INSTALL_BIN_DIR);
1186   strcat(buf, argv[0]);
1187   runImage(buf, argc, argv);
1188   runImage("flk.flk", argc, argv);
1189   runImage(INSTALL_DIR "default.flk", argc, argv);
1190   /* No image could be found. This must be a User-too-stupid error. */
1191   printErrorBanner();
1192   printf("I could not load any image. This is all your fault.\n");
1193   return 1;
1194 }