home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / forth / pfe-0.000 / pfe-0 / pfe-0.9.13 / src / misc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-07-17  |  25.7 KB  |  1,211 lines
  1. /*
  2.  * This file is part of the portable Forth environment written in ANSI C.
  3.  * Copyright (C) 1995  Dirk Uwe Zoller
  4.  *
  5.  * This library is free software; you can redistribute it and/or
  6.  * modify it under the terms of the GNU Library General Public
  7.  * License as published by the Free Software Foundation; either
  8.  * version 2 of the License, or (at your option) any later version.
  9.  *
  10.  * This library is distributed in the hope that it will be useful,
  11.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13.  * See the GNU Library General Public License for more details.
  14.  *
  15.  * You should have received a copy of the GNU Library General Public
  16.  * License along with this library; if not, write to the Free
  17.  * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  *
  19.  * This file is version 0.9.13 of 17-July-95
  20.  * Check for the latest version of this package via anonymous ftp at
  21.  *    roxi.rz.fht-mannheim.de:/pub/languages/forth/pfe-VERSION.tar.gz
  22.  * or    sunsite.unc.edu:/pub/languages/forth/pfe-VERSION.tar.gz
  23.  * or    ftp.cygnus.com:/pub/forth/pfe-VERSION.tar.gz
  24.  *
  25.  * Please direct any comments via internet to
  26.  *    duz@roxi.rz.fht-mannheim.de.
  27.  * Thank You.
  28.  */
  29. /*
  30.  * misc.c --- Compatiblity with former standards, miscellaneous useful words.
  31.  * (duz 09Jul93)
  32.  */
  33.  
  34. #include "forth.h"
  35. #include "support.h"
  36. #include "compiler.h"
  37. #include "dblsub.h"
  38. #include "term.h"
  39. #include "help.h"
  40.  
  41. #include <stdlib.h>
  42. #include <string.h>
  43. #include <setjmp.h>
  44. #include <errno.h>
  45.  
  46. #include "missing.h"
  47.  
  48. /************************************************************************/
  49. /* FIG Forth compatibility                                              */
  50. /************************************************************************/
  51.  
  52. Code (cold)
  53. {
  54.   close_all_files_ ();
  55.   initialize_system ();
  56.  
  57.   /* If it's a turnkey-application, start it: */
  58.   if (APPLICATION)
  59.     {
  60.       run_forth (APPLICATION);
  61.       exit (0);
  62.     }
  63.   if (option.verbose)
  64.     dot_memory_ ();
  65.   longjmp (abort_dest, 1);
  66. }
  67.  
  68. Code (dot_line)            /* .LINE (line# block# --) */
  69. {
  70.   dot_line (BLOCK_FILE, sp[0], sp[1]);
  71.   sp += 2;
  72. }
  73.  
  74. code (store_csp)        /* !CSP */
  75. {
  76.   CSP = sp;
  77. }
  78.  
  79. code (question_csp)        /* ?CSP */
  80. {
  81.   if (sp != CSP)
  82.     tHrow (THROW_CONTROL_MISMATCH);
  83. }
  84.  
  85. code (question_comp)        /* ?COMP */
  86. {
  87.   if (!STATE)
  88.     tHrow (THROW_COMPILE_ONLY);
  89. }
  90.  
  91. code (question_exec)        /* ?EXEC */
  92. {
  93.   if (STATE)
  94.     tHrow (THROW_COMPILER_NESTING);
  95. }
  96.  
  97. code (question_file)        /* ?FILE */
  98. {
  99.   int ior = *sp++;
  100.  
  101.   if (ior)
  102.     file_errorz ("");
  103. }
  104.  
  105. code (question_loading)        /* ?LOADING */
  106. {
  107.   if (BLK == 0)
  108.     tHrow (THROW_INVALID_BLOCK);
  109. }
  110.  
  111. code (question_pairs)        /* ?PAIRS */
  112. {
  113.   question_comp_ ();
  114.   question_pairs (*sp++);
  115. }
  116.  
  117. code (question_stack)        /* ?STACK */
  118. {
  119.   /* *INDENT-OFF* */
  120.   if (sp > sys.s0)        tHrow (THROW_STACK_UNDER);
  121.   if (sp < membot.stack)    tHrow (THROW_STACK_OVER);
  122.   if (fp > sys.f0)        tHrow (THROW_FSTACK_UNDER);
  123.   if (fp < membot.fstack)    tHrow (THROW_FSTACK_OVER);
  124.   if (rp > sys.r0)        tHrow (THROW_RSTACK_UNDER);
  125.   if (rp < membot.rstack)    tHrow (THROW_RSTACK_OVER);
  126.   /* *INDENT-ON* */
  127.  
  128. }
  129.  
  130. Code (toggle)            /* TOGGLE ( c-addr char --- ) */
  131. {
  132.   *(Byte *) sp[1] ^= (Byte) sp[0];
  133.   sp += 2;
  134. }
  135.  
  136. Code (latest)            /* LATEST */
  137. {
  138.   *--sp = (Cell) latest ();
  139. }
  140.  
  141. code (smudge)            /* SMUDGE (modified from FIG definition) */
  142. {                /* FIG definition toggles the bit! */
  143.   if (LAST)
  144.     *LAST |= SMUDGED;
  145.   else
  146.     tHrow (THROW_ARG_TYPE);
  147. }
  148.  
  149. code (unsmudge)            /* UNSMUDGE (turn smudge-bit off) */
  150. {                /* neccessary because SMUDGE modified */
  151.   if (LAST)
  152.     *LAST &= ~SMUDGED;
  153.   else
  154.     tHrow (THROW_ARG_TYPE);
  155. }
  156.  
  157. /************************************************************************/
  158. /* some well known words without pedigree                               */
  159. /************************************************************************/
  160.  
  161. Code (u_d_dot_r)        /* UD.R */
  162. {
  163. #if defined REGSP
  164.   Cell w;            /* this hack avoids wrong code generated */
  165.  
  166.   sp++;                /* by gcc <= 2.6.0 */
  167.   w = sp[-1];            /* when sp is register variable */
  168. #else
  169.   Cell w = *sp++;
  170.  
  171. #endif
  172.   less_number_sign_ ();
  173.   number_sign_s_ ();
  174.   number_sign_greater_ ();
  175.   spaces (w - *sp);
  176.   type_ ();
  177. }
  178.  
  179. Code (u_d_dot)            /* UD. */
  180. {
  181.   *--sp = 0;
  182.   u_d_dot_r_ ();
  183.   space_ ();
  184. }
  185.  
  186. Code (dot_name)            /* .NAME */
  187. {
  188.   dot_name ((char *) *sp++);
  189. }
  190.  
  191. Code (dash_roll)        /* -ROLL */
  192. {
  193.   Cell n = *sp++;
  194.   Cell h, i;
  195.  
  196.   h = sp[0];
  197.   for (i = 0; i < n; i++)
  198.     sp[i] = sp[i + 1];
  199.   sp[i] = h;
  200. }
  201.  
  202. Code (r_from_drop)        /* R>DROP       shortcut I saw in CSI-Forth */
  203. {
  204.   rp++;
  205. }
  206.  
  207. Code (dup_to_r)            /* DUP>R        dito */
  208. {
  209.   RPUSH (*sp);
  210. }
  211.  
  212. Code (random)            /* RANDOM ( n1 --- n2 ) */
  213. {                /* returns random number within [0,n1) */
  214. /* some systems (BSD) have a better random number generator than
  215.    standard unix' rand() */
  216. #if defined HAVE_RANDOM
  217. # define _rand_ random
  218. #else
  219. # define _rand_ rand
  220. #endif
  221.  
  222.   if (*sp == 0)
  223.     *sp = _rand_ ();
  224.   else
  225.     *sp = ummul (*sp, _rand_ () << 1).hi;
  226.  
  227. #undef rand
  228. }
  229.  
  230. Code (srand)            /* SRAND ( n --- ) */
  231. {
  232. #if defined HAVE_RANDOM
  233.   srandom (*sp++);
  234. #else
  235.   srand (*sp++);
  236. #endif
  237. }
  238.  
  239. Code (under_plus)        /* n1 n2 --- n1+n2 n2 */
  240. {                /* same as TUCK + SWAP */
  241.   sp[1] += sp[0];
  242. }
  243.  
  244. /************************************************************************/
  245. /* more local variables                                                 */
  246. /************************************************************************/
  247.  
  248. code (plus_to_execution)    /* add to current contents of inline */
  249. {                /* following VALUE */
  250.   *TO_BODY (*ip++) += *sp++;
  251. }
  252.  
  253. code (plus_to_local_execution)    /* add to current value of local variable */
  254. {
  255.   lp[(Cell) *ip++] += *sp++;
  256. }
  257.  
  258. Code (plus_to)
  259. {
  260.   if (STATE)
  261.     {
  262.       char *p;
  263.       int l, n;
  264.  
  265.       p = word (' ');
  266.       l = *(Byte *) p++;
  267.       if (sys.locals && (n = find_local (p, l)) != 0)
  268.     {
  269.       compile2 ();
  270.       COMMA (n);
  271.     }
  272.       else
  273.     {
  274.       if ((p = find (p, l)) == NULL)
  275.         tHrow (THROW_UNDEFINED);
  276.       compile1 ();
  277.       COMMA (name_from (p));
  278.     }
  279.     }
  280.   else
  281.     {
  282.       Xt xt;
  283.  
  284.       tick (&xt);
  285.       *TO_BODY (xt) += *sp++;
  286.     }
  287. }
  288. COMPILES2 (plus_to, plus_to_execution, plus_to_local_execution,
  289.        SKIPS_CELL, DEFAULT_STYLE);
  290.  
  291. /************************************************************************/
  292. /* data structures                                                      */
  293. /************************************************************************/
  294.  
  295. Code (build_array)        /* n1 n2 ... nX X --- n */
  296. {                /* writes X, n1, ... nX into the dictionary */
  297.   Cell i = *sp++;        /* returns product n1 * n2 * ... * nX */
  298.   uCell n = 1;
  299.  
  300.   COMMA (i);
  301.   while (--i >= 0)
  302.     {
  303.       COMMA (*sp);
  304.       n *= *sp++;
  305.     }
  306.   *--sp = n;
  307. }
  308.  
  309. Code (access_array)        /* i1 i2 ... iX addr1 --- addr2 n */
  310. {
  311.   uCell *p = (uCell *) *sp++, n = 0;
  312.   Cell i = *p++;
  313.  
  314.   for (;;)
  315.     {
  316.       if (*p++ <= *sp)
  317.     tHrow (THROW_INDEX_RANGE);
  318.       n += *sp++;
  319.       if (--i <= 0)
  320.     break;
  321.       n *= *p;
  322.     }
  323.   *--sp = (Cell) p;
  324.   *--sp = n;
  325. }
  326.  
  327. /************************************************************************/
  328. /* more comparision operators                                           */
  329. /************************************************************************/
  330.  
  331. Code (zero_less_equal)
  332. {
  333.   *sp = FLAG (*sp <= 0);
  334. }
  335.  
  336. Code (zero_greater_equal)
  337. {
  338.   *sp = FLAG (*sp >= 0);
  339. }
  340.  
  341. Code (less_equal)
  342. {
  343.   sp[1] = FLAG (sp[1] <= sp[0]);
  344.   sp++;
  345. }
  346.  
  347. Code (greater_equal)
  348. {
  349.   sp[1] = FLAG (sp[1] >= sp[0]);
  350.   sp++;
  351. }
  352.  
  353. Code (u_less_equal)
  354. {
  355.   sp[1] = FLAG ((uCell) sp[1] <= (uCell) sp[0]);
  356.   sp++;
  357. }
  358.  
  359. Code (u_greater_equal)
  360. {
  361.   sp[1] = FLAG ((uCell) sp[1] >= (uCell) sp[0]);
  362.   sp++;
  363. }
  364.  
  365. Code (u_max)
  366. {
  367.   if ((uCell) sp[0] > (uCell) sp[1])
  368.     sp[1] = sp[0];
  369.   sp++;
  370. }
  371.  
  372. Code (u_min)
  373. {
  374.   if ((uCell) sp[0] < (uCell) sp[1])
  375.     sp[1] = sp[0];
  376.   sp++;
  377. }
  378.  
  379. /************************************************************************/
  380. /* implementation                                                       */
  381. /************************************************************************/
  382.  
  383. Code (f_p_fetch)        /* FP@ (--- addr) */
  384. {                /* returns floating point stack pointer */
  385.   *--sp = (Cell) fp;
  386. }
  387.  
  388. Code (f_p_store)        /* FP! (addr ---) */
  389. {                /* sets floating point stack pointer */
  390.   fp = (double *) *sp++;
  391. }
  392.  
  393. Code (source_line)        /* SOURCE-LINE (--- n) */
  394. {
  395.   switch (SOURCE_ID)
  396.     {
  397.     case 0:
  398.       if (BLK)
  399.     *--sp = TO_IN / 64 + 1;    /* source line from BLOCK */
  400.       else
  401.     case -1:            /* string from EVALUATE */
  402.     *--sp = 0;        /* or from QUERY (0/BLK==0) */
  403.       break;
  404.     default:            /* source line from text file */
  405.       *--sp = SOURCE_FILE->n + 1;
  406.     }
  407. }
  408.  
  409. code (pocket)            /* POCKET ( n --- addr u) */
  410. {                /* returns string in the specified pocket */
  411.   int n = *sp;
  412.  
  413.   sp -= 1;
  414.   sp[1] = (Cell) membot.pocket[n] + 1;
  415.   sp[0] = *(Byte *) membot.pocket[n];
  416. }
  417.  
  418. Code (wl_hash)            /* WL-HASH ( c-addr n1 -- n2 ) */
  419. {                /* calc hash-code for selection of thread */
  420.   sp[1] = wl_hash ((char *) sp[1], sp[0]);
  421.   sp++;
  422. }
  423.  
  424. Code (topmost)            /* TOPMOST ( wid --- a-addr ) */
  425. {
  426.   *sp = (Cell) topmost ((Wordl *) *sp);
  427. }
  428.  
  429. static void
  430. wwords (char *cat)
  431. {
  432.   Wordl *wl = CONTEXT[0] ? CONTEXT[0] : ONLY;
  433.   char *pattern = word (' ');
  434.  
  435.   if (*pattern == 0)
  436.     strcpy (pattern, "\001*");
  437.   else if (LOWER_CASE)
  438.     upper (pattern + 1, *pattern);
  439.   outf ("\nWords matching %s:", pattern + 1);
  440.   wild_words (wl, pattern + 1, cat);
  441. }
  442.  
  443. Code (wwords)        { wwords (NULL); }
  444. Code (primitives)    { wwords ("p"); }
  445. Code (cdefs)        { wwords (":"); }
  446. Code (ddefs)        { wwords ("D"); }
  447. Code (constants)    { wwords ("cC"); }
  448. Code (variables)    { wwords ("vV"); }
  449. Code (vocabularies)    { wwords ("W"); }
  450. Code (markers)        { wwords ("M"); }
  451.  
  452. Code (w_fetch)            /* W@ */
  453. {
  454.   *sp = *(short *) *sp;
  455. }
  456.  
  457. Code (w_store)            /* W! */
  458. {
  459.   *(short *) sp[0] = (short) sp[1];
  460.   sp += 2;
  461. }
  462.  
  463. Code (w_plus_store)        /* W+! */
  464. {
  465.   *(short *) sp[0] += (short) sp[1];
  466.   sp += 2;
  467. }
  468.  
  469. Code (paren_forget)        /* (FORGET) (addr ---) */
  470. {                /* forgets everything above addr */
  471.   forget ((char *) *sp++);
  472. }
  473.  
  474. Code (tab)            /* TAB (n --)   jump to next column */
  475. {                /*              divisible by n */
  476.   tab (*sp++);
  477. }
  478.  
  479. code (backspace)        /* BACKSPACE (--) reverse of SPACE */
  480. {
  481.   outs ("\b \b");
  482. }
  483.  
  484. Code (question_stop)        /* ?STOP (-- flag) check for 'q' pressed */
  485. {
  486.   *--sp = FLAG (question_stop ());
  487. }
  488.  
  489. code (start_question_cr)    /* START?CR */
  490. {                /* initialize for more-like effect */
  491.   sys.more = rows - 2;
  492.   sys.lines = 0;
  493. }
  494.  
  495. Code (question_cr)        /* ?CR */
  496. {                /* like CR, stop 25 lines past START?CR */
  497.   *--sp = question_cr ();
  498. }
  499.  
  500. code (close_all_files)        /* CLOSE-ALL-FILES */
  501. {
  502.   File *f;
  503.  
  504.   for (f = membot.files; f < memtop.files - 3; f++)
  505.     if (f->f)
  506.       {
  507.     if (f->updated)
  508.       read_write (f, f->buffer, f->n, FALSE);
  509.     fclose (f->f);
  510.       }
  511. }
  512.  
  513. code (dot_memory)
  514. {
  515.   outf ("\nDictionary space:    %7ld Bytes, in use: %7ld Bytes\n"
  516.     "Stack space:         %7ld cells\n"
  517.     "Floating stack space:%7ld floats\n"
  518.     "Return stack space:  %7ld cells\n",
  519.     (long) memsiz.dict,
  520.     (long) ((char *) DP - (char *) sys.dict),
  521.     (long) (memsiz.stack / sizeof (Cell)),
  522.     (long) (memsiz.fstack / sizeof (double)),
  523.     (long) (memsiz.rstack / sizeof (void *)));
  524. }
  525.  
  526. Code (dot_version)
  527. {
  528.   outs (version_string);
  529. }
  530.  
  531. Code (dot_pfe_date)
  532. {
  533.   outf ("PFE compiled %s, %s ",
  534.     compile_date, compile_time);
  535. }
  536.  
  537. Code (license)
  538. {
  539.   outs (license_string);
  540. }
  541.  
  542. Code (warranty)
  543. {
  544.   outs (warranty_string);
  545. }
  546.  
  547. Code (show_status)        /* ( --- ) display internal variables */
  548. {
  549.   cr_();
  550.   dot_version_();
  551.   cr_();
  552.   dot_pfe_date_();
  553.   cr_();
  554.   outf ("\nMemory overview:");
  555.   dot_memory_();
  556.   outf ("\nsearch path for source files:         %s", option.incpaths);
  557.   outf ("\nextensions for source files:          %s", option.incext);
  558.   outf ("\nsearch path for block files:          %s", option.blkpaths);
  559.   outf ("\nextensions for block files:           %s", option.blkext);
  560.   outf ("\nsearching help files in:              %s", HELPDIR);
  561.   outf ("\neditor called by EDIT-TEXT:           %s", option.editor);
  562.   cr_();
  563.   outf ("\nmaximum number of open files:         %u", option.max_files);
  564.   outf ("\nmaximum simultaneous interpretive S\"  %u", option.pockets);
  565.   outf ("\ndictionary threads configured         %u", 1<<LD_THREADS);
  566.   outf ("\nmaximum length of search order        %u", ORDER_LEN);
  567.   cr_();
  568.   outf ("\nText screen size:                     %dx%d", rows, cols);
  569.   cr_();
  570. #define flag(X) ((X) ? "ON" : "OFF")
  571.   outf ("\nLOWER-CASE    %s", flag (LOWER_CASE));
  572.   outf ("\nLOWER-CASE-FN %s", flag (LOWER_CASE_FN));
  573.   outf ("\nRESET-ORDER   %s", flag (RESET_ORDER));
  574.   outf ("\nREDEFINED-MSG %s", flag (REDEFINED_MSG));
  575.   outf ("\nFLOAT-INPUT   %s", flag (FLOAT_INPUT));
  576. #undef flag
  577.   outf ("\nPRECISION     %d", PRECISION);
  578.   space_();
  579. }
  580.  
  581. /************************************************************************/
  582. /* vectorized I/O                                                       */
  583. /************************************************************************/
  584.  
  585. Code (paren_emit)
  586. {
  587.   outc ((char) *sp++);
  588. }
  589.  
  590. Code (paren_expect)
  591. {
  592.   expect ((char *) sp[1], sp[0]);
  593.   sp += 2;
  594. }
  595.  
  596. Code (paren_key)
  597. {
  598.   int c;
  599.  
  600.   do
  601.     c = getekey ();
  602.   while (c >= 0x100);
  603.   *--sp = c;
  604. }
  605.  
  606. Code (paren_type)
  607. {
  608.   type ((char *) sp[1], sp[0]);
  609.   sp += 2;
  610. }
  611.  
  612. code (standard_io)
  613. {
  614.   static pCode paren_emit_cfa = paren_emit_;
  615.   static pCode paren_expect_cfa = paren_expect_;
  616.   static pCode paren_key_cfa = paren_key_;
  617.   static pCode paren_type_cfa = paren_type_;
  618.  
  619.   sys.emit = &paren_emit_cfa;
  620.   sys.expect = &paren_expect_cfa;
  621.   sys.key = &paren_key_cfa;
  622.   sys.type = &paren_type_cfa;
  623. }
  624.  
  625. /************************************************************************/
  626. /* more advanced screen control                                         */
  627. /************************************************************************/
  628.  
  629. Code (gotoxy)            /* GOTOXY (x y --) */
  630. {
  631.   c_gotoxy (sp[1], sp[0]);
  632.   sp += 2;
  633. }
  634.  
  635. Code (question_xy)        /* ?XY (-- x y) */
  636. {                /* returns cursor position on screen */
  637.   int x, y;
  638.  
  639.   c_wherexy (&x, &y);
  640.   sp -= 2;
  641.   sp[1] = x;
  642.   sp[0] = y;
  643. }
  644.  
  645. /* these are defined in the driver term.c. */
  646. /* They are renamed here to satisfy the macro CO(char *, pCode) */
  647.  
  648. #define    cls_            c_clrscr
  649. #define    clreol_            c_clreol
  650. #define    home_            c_home
  651. #define bell_            c_bell
  652. #define highlight_        c_standout_on
  653. #define minus_highlight_    c_standout_off
  654. #define underline_        c_underline_on
  655. #define minus_underline_    c_underline_off
  656. #define intensity_        c_bright
  657. #define minus_intensity_    c_normal
  658. #define blink_            c_blinking
  659. #define minus_blink_        c_normal
  660. #define reverse_        c_reverse
  661. #define minus_reverse_        c_normal
  662. #define normal_            c_normal
  663.  
  664. /************************************************************************/
  665. /* Function keys on the commandline                                     */
  666. /************************************************************************/
  667.  
  668. static Xt fkey_executes_xt[10] =
  669. {NULL};
  670.  
  671. void
  672. accept_executes_xt (int n)
  673. {
  674.   if (fkey_executes_xt[n])
  675.     call_forth (fkey_executes_xt[n]);
  676. }
  677.  
  678. static void
  679. store_execution (Xt xt, int key)
  680. {
  681.   if (key < EKEY_k1 || EKEY_k0 < key)
  682.     tHrow (THROW_ARG_TYPE);
  683.   fkey_executes_xt[key - EKEY_k1] = xt;
  684. }
  685.  
  686. Code (executes_execution)
  687. {
  688.   store_execution (*ip++, *sp++);
  689. }
  690. Code (executes)
  691. {
  692.   if (STATE)
  693.     {
  694.       compile1 ();
  695.       bracket_compile_ ();
  696.     }
  697.   else
  698.     {
  699.       Xt xt;
  700.  
  701.       tick (&xt);
  702.       store_execution (xt, *sp++);
  703.     }
  704. }
  705. COMPILES (executes, executes_execution,
  706.       SKIPS_NOTHING, DEFAULT_STYLE);
  707.  
  708. /************************************************************************/
  709. /* display help                                                         */
  710. /************************************************************************/
  711.  
  712. Code (help)
  713. {
  714.   char *p, buf[80];
  715.   uCell n;
  716.  
  717.   skip_delimiter (' ');
  718.   parse (' ', &p, &n);
  719.   store_c_string (p, n, buf, sizeof buf);
  720.   if (LOWER_CASE)
  721.     upper (buf, n);
  722.   cr_ ();
  723.   print_help (buf);
  724. }
  725.  
  726. /************************************************************************/
  727. /* more file manipulation                                               */
  728. /************************************************************************/
  729.  
  730. Code (copy_file)        /* like RENAME-FILE, copies file */
  731. {
  732.   char src[PATH_LENGTH], dst[PATH_LENGTH];
  733.  
  734.   store_filename ((char *) sp[3], sp[2], src, sizeof src);
  735.   store_filename ((char *) sp[1], sp[0], dst, sizeof dst);
  736.   sp += 3;
  737.   *sp = copy (src, dst, LONG_MAX) ? errno : 0;
  738. }
  739.  
  740. Code (move_file)        /* like RENAME-FILE, across volumes */
  741. {
  742.   char src[PATH_LENGTH], dst[PATH_LENGTH];
  743.  
  744.   store_filename ((char *) sp[3], sp[2], src, sizeof src);
  745.   store_filename ((char *) sp[1], sp[0], dst, sizeof dst);
  746.   sp += 3;
  747.   *sp = move (src, dst) ? errno : 0;
  748. }
  749.  
  750. Code (file_rw)            /* FILE-R/W ( addr blk f fid --- ) */
  751. {                /* like FIG Forth R/W */
  752.   read_write ((File *) sp[0],    /* file to read from */
  753.           (char *) sp[3],    /* buffer address, 1K */
  754.           (uCell) sp[2],    /* block number */
  755.           sp[0]);        /* readflag */
  756.   sp += 4;
  757. }
  758.  
  759. Code (file_block)
  760. {
  761.   File *fid = (File *) *sp++;
  762.  
  763.   *sp = (Cell) block (fid, *sp);
  764. }
  765.  
  766. Code (file_buffer)
  767. {
  768.   File *fid = (File *) *sp++;
  769.   int n;
  770.  
  771.   *sp = (Cell) buffer (fid, *sp, &n);
  772. }
  773.  
  774. Code (file_empty_buffers)
  775. {
  776.   empty_buffers ((File *) *sp++);
  777. }
  778.  
  779. Code (file_flush)
  780. {
  781.   File *fid = (File *) *sp++;
  782.  
  783.   save_buffers (fid);
  784.   empty_buffers (fid);
  785. }
  786.  
  787. Code (file_list)
  788. {
  789.   File *fid = (File *) *sp++;
  790.  
  791.   list (fid, SCR = *sp++);
  792. }
  793.  
  794. Code (file_load)
  795. {
  796.   File *fid = (File *) *sp++;
  797.  
  798.   load (fid, *sp++);
  799. }
  800.  
  801. code (file_save_buffers)
  802. {
  803.   File *fid = (File *) *sp++;
  804.  
  805.   save_buffers (fid);
  806. }
  807.  
  808. Code (file_thru)
  809. {
  810.   File *fid = (File *) *sp++;
  811.   int hi = *sp++;
  812.   int lo = *sp++;
  813.  
  814.   thru (fid, lo, hi);
  815. }
  816.  
  817. code (file_update)
  818. {
  819.   update ((File *) *sp++);
  820. }
  821.  
  822. /************************************************************************/
  823. /* hooks to editors and os services                                     */
  824. /************************************************************************/
  825.  
  826. Code (argv)            /* ( n --- addr cnt ) */
  827. {
  828.   uCell n = *sp++;
  829.  
  830.   if (n < app_argc)
  831.     strpush (app_argv [n]);
  832.   else
  833.     strpush (NULL);
  834. }
  835.  
  836. Code (expand_fn)        /* EXPAND-FN */
  837. {                /* ( addr1 cnt1 addr2 --- addr2 cnt2 ) */
  838.   char *nm = (char *) sp[2];
  839.   char *fn = (char *) sp[0];
  840.   int len = sp[1];
  841.   char buf[0x100];
  842.  
  843.   store_filename (nm, len, buf, sizeof buf);
  844.   expand_filename (buf, option.incpaths, option.incext, fn);
  845.   sp++;
  846.   sp[1] = (Cell) fn;
  847.   sp[0] = strlen (fn);
  848. }
  849.  
  850. Code (using)
  851. {
  852.   char *fn;
  853.   uCell len;
  854.  
  855.   skip_delimiter (' ');
  856.   parse (' ', &fn, &len);
  857.   if (len == 0)
  858.     tHrow (THROW_INVALID_NAME);
  859.   if (!use_block_file (fn, len))
  860.     file_error (fn, len);
  861. }
  862.  
  863. Code (using_new)
  864. {
  865.   char *fn;
  866.   uCell len;
  867.   File *fid;
  868.  
  869.   skip_delimiter (' ');
  870.   parse (' ', &fn, &len);
  871.   if (len == 0)
  872.     tHrow (THROW_INVALID_NAME);
  873.   switch (file_access (fn, len))
  874.     {
  875.     case -1:
  876.     case 0:
  877.       fid = create_file (fn, len, FMODE_RWB);
  878.       if (fid == NULL)
  879.     file_error (fn, len);
  880.       close_file (fid);
  881.     }
  882.   if (!use_block_file (fn, len))
  883.     file_error (fn, len);
  884. }
  885.  
  886. Code (load_quote_execution)
  887. {
  888.   char *p = (char *) ip;
  889.   int n = (Byte) *p++;
  890.  
  891.   SKIP_STRING;
  892.   load_file (p, n, *sp++);
  893. }
  894.  
  895. Code (load_quote)
  896. {
  897.   if (STATE)
  898.     {
  899.       compile1 ();
  900.       alloc_parsed_string ('"');
  901.     }
  902.   else
  903.     {
  904.       char *p;
  905.       uCell n;
  906.  
  907.       skip_delimiter (' ');
  908.       parse ('"', &p, &n);
  909.       load_file (p, n, *sp++);
  910.     }
  911. }
  912.  
  913. COMPILES (load_quote, load_quote_execution,
  914.       SKIPS_STRING, DEFAULT_STYLE);
  915.  
  916. void edit (int n, int r, int c);
  917.  
  918. Code (edit_block)
  919. {
  920.   edit (*sp++, 0, 0);
  921. }
  922.  
  923. Code (edit_text)
  924. {
  925.   char *nm, fn[0x100];
  926.  
  927.   nm = word (' ');
  928.   if (*nm == '\0')
  929.     tHrow (THROW_FILE_NEX);
  930.   expand_filename (nm + 1, option.incpaths, option.incext, fn);
  931.   systemf ("%s %s", option.editor, fn);
  932. }
  933.  
  934. Code (edit_error)
  935. {
  936.   switch (sys.input_err.source_id)
  937.     {
  938.     case 0:
  939.       if (sys.input_err.blk)
  940.     {
  941.       edit (sys.input_err.blk,
  942.         sys.input_err.to_in / 64,
  943.         sys.input_err.to_in % 64);
  944.       break;
  945.     }
  946.     case -1:
  947.       c_bell ();
  948.       break;
  949.     default:
  950.       {
  951.     File *f = (File *) sys.input_err.source_id;
  952.  
  953.     systemf ("%s +%d %s", option.editor, (int) f->n + 1, f->name);
  954.     break;
  955.       }
  956.     }
  957. }
  958.  
  959. Code (include)
  960. {
  961.   char *fn = word (' ');
  962.  
  963.   included (fn + 1, *(Byte *) fn);
  964. }
  965.  
  966. Code (system)
  967. {
  968.   sp[1] = systemf ("%.*s", (int) sp[0], (char *) sp[1]);
  969.   sp++;
  970. }
  971.  
  972. code (system_quote_execution)
  973. {
  974.   char *p = (char *) ip;
  975.  
  976.   SKIP_STRING;
  977.   *--sp = systemf ("%.*s", *p, p + 1);
  978. }
  979.  
  980. Code (system_quote)
  981. {
  982.   if (STATE)
  983.     {
  984.       compile1 ();
  985.       alloc_parsed_string ('"');
  986.     }
  987.   else
  988.     {
  989.       char *p;
  990.       uCell l;
  991.  
  992.       parse ('"', &p, &l);
  993.       *--sp = systemf ("%.*s", l, p);
  994.     }
  995. }
  996. COMPILES (system_quote, system_quote_execution,
  997.       SKIPS_STRING, DEFAULT_STYLE);
  998.  
  999. Code (raise)            /* sends signal to itself */
  1000. {
  1001.   raise (*sp++);
  1002. }
  1003.  
  1004. Code (signal)            /* xt1 n --- xt2 ; install signal handler */
  1005. {                /* return old signal handler */
  1006.   sp[1] = (Cell) forth_signal (sp[0], (Xt) sp[1]);
  1007.   sp++;
  1008. }
  1009.  
  1010. /* *INDENT-OFF* */
  1011. LISTWORDS (misc) =
  1012. {
  1013.   /* FIG-Forth */
  1014.   OC ("0",        0),
  1015.   OC ("1",        1),
  1016.   OC ("2",        2),
  1017.   OC ("3",        3),
  1018.   CO ("COLD",        cold),
  1019.   CO ("LIT",        literal_execution),
  1020.   CO (".LINE",        dot_line),
  1021.   SV ("CSP",        CSP),
  1022.   CO ("!CSP",        store_csp),
  1023.   CO ("?CSP",        question_csp),
  1024.   CO ("?COMP",        question_comp),
  1025.   CO ("?EXEC",        question_exec),
  1026.   CO ("?FILE",        question_file),
  1027.   CO ("?LOADING",    question_loading),
  1028.   CO ("?PAIRS",        question_pairs),
  1029.   CO ("?STACK",        question_stack),
  1030.   CO ("TOGGLE",        toggle),
  1031.   CO ("LATEST",        latest),
  1032.   SV ("OUT",        OUT),
  1033.   DV ("DP",        dp),
  1034.   DV ("HLD",        hld),
  1035.   SV ("R0",        sys.r0),
  1036.   SV ("S0",        sys.s0),
  1037.   CO ("SMUDGE",        smudge),
  1038.   CO ("UNSMUDGE",    unsmudge),
  1039.  
  1040.   /* words without pedigree */
  1041.   CO ("UD.R",        u_d_dot_r),
  1042.   CO ("UD.",        u_d_dot),
  1043.   CO (".NAME",        dot_name),
  1044.   CO ("-ROLL",        dash_roll),
  1045.   CO ("R>DROP",        r_from_drop),
  1046.   CO ("DUP>R",        dup_to_r),
  1047.   CO ("RANDOM",        random),
  1048.   CO ("SRAND",        srand),
  1049.   CO ("UNDER+",        under_plus),
  1050.  
  1051.   /* more local variables */
  1052.   CS ("+TO",        plus_to),
  1053.   /* data structures */
  1054.   CO ("BUILD-ARRAY",    build_array),
  1055.   CO ("ACCESS-ARRAY",    access_array),
  1056.  
  1057.   /* more comparision */
  1058.   CO ("0<=",        zero_less_equal),
  1059.   CO ("0>=",        zero_greater_equal),
  1060.   CO ("<=",        less_equal),
  1061.   CO (">=",        greater_equal),
  1062.   CO ("U<=",        u_less_equal),
  1063.   CO ("U>=",        u_greater_equal),
  1064.   CO ("UMIN",        u_min),
  1065.   CO ("UMAX",        u_max),
  1066.  
  1067.   /* implementation */
  1068.   OC ("EXCEPTION_MAGIC",EXCEPTION_MAGIC),
  1069.   OC ("INPUT_MAGIC",    INPUT_MAGIC),
  1070.   OC ("DEST_MAGIC",    DEST_MAGIC),
  1071.   OC ("ORIG_MAGIC",    ORIG_MAGIC),
  1072.   OC ("LOOP_MAGIC",    LOOP_MAGIC),
  1073.   OC ("CASE_MAGIC",    CASE_MAGIC),
  1074.   OC ("OF_MAGIC",    OF_MAGIC),
  1075.   CO ("FLIT",        f_literal_execution),
  1076.   SV ("F0",        sys.f0),
  1077.   CO ("SHOW-STATUS",    show_status),
  1078.   SV ("LOWER-CASE",    LOWER_CASE),
  1079.   SV ("LOWER-CASE-FN",    LOWER_CASE_FN),
  1080.   SV ("REDEFINED-MSG",    REDEFINED_MSG),
  1081.   SV ("FLOAT-INPUT",    FLOAT_INPUT),
  1082.   DV ("APPLICATION",    application),
  1083.   CO ("FP@",        f_p_fetch),
  1084.   CO ("FP!",        f_p_store),
  1085.   CO ("SOURCE-LINE",    source_line),
  1086.   CO ("POCKET",        pocket),
  1087.   OC ("WSIZE",        sizeof (Cell)),
  1088.   CO ("W@",        w_fetch),
  1089.   CO ("W!",        w_store),
  1090.   CO ("W+!",        w_plus_store),
  1091.   CO ("WL-HASH",    wl_hash),
  1092.   DV ("LAST",        last),
  1093.   CO ("TOPMOST",    topmost),
  1094.  
  1095.   CO ("WWORDS",        wwords),
  1096.   CO ("PRIMITIVES",    primitives),
  1097.   CO ("DEFINITONS",    cdefs),
  1098.   CO ("DOES-DEFS",    ddefs),
  1099.   CO ("CONSTANTS",    constants),
  1100.   CO ("VARIABLES",    variables),
  1101.   CO ("VOCABULARIES",    vocabularies),
  1102.   CO ("MARKERS",    markers),
  1103.  
  1104.   CO ("(FORGET)",    paren_forget),
  1105.   CO ("BELL",        bell),
  1106.   CO ("TAB",        tab),
  1107.   CO ("BACKSPACE",    backspace),
  1108.   CO ("?STOP",        question_stop),
  1109.   CO ("START?CR",    start_question_cr),
  1110.   CO ("?CR",        question_cr),
  1111.   CO ("CLOSE-ALL-FILES",close_all_files),
  1112.   CO (".MEMORY",    dot_memory),
  1113.   CO (".VERSION",    dot_version),
  1114.   CO (".PFE-DATE",    dot_pfe_date),
  1115.   CO ("LICENSE",    license),
  1116.   CO ("WARRANTY",    warranty),
  1117.  
  1118.   /* vectorized i/o */
  1119.   SV ("*EMIT*",        sys.emit),
  1120.   SV ("*EXPECT*",    sys.expect),
  1121.   SV ("*KEY*",        sys.key),
  1122.   SV ("*TYPE*",        sys.type),
  1123.   CO ("(EMIT)",        paren_emit),
  1124.   CO ("(EXPECT)",    paren_expect),
  1125.   CO ("(KEY)",        paren_key),
  1126.   CO ("(TYPE)",        paren_type),
  1127.   CO ("STANDARD-I/O",    standard_io),
  1128.  
  1129.   /* more advanced screen control */
  1130.   SC ("ROWS",        rows),
  1131.   SC ("COLS",        cols),
  1132.   SC ("XMAX",        xmax),
  1133.   SC ("YMAX",        ymax),
  1134.   CO ("GOTOXY",        gotoxy),
  1135.   CO ("?XY",        question_xy),
  1136.   CO ("CLS",        cls),
  1137.   CO ("CLREOL",        clreol),
  1138.   CO ("HOME",        home),
  1139.   CO ("HIGHLIGHT",    highlight),
  1140.   CO ("-HIGHLIGHT",    minus_highlight),
  1141.   CO ("UNDERLINE",    underline),
  1142.   CO ("-UNDERLINE",    minus_underline),
  1143.   CO ("INTENSITY",    intensity),
  1144.   CO ("-INTENSITY",    minus_intensity),
  1145.   CO ("BLINKING",    blink),
  1146.   CO ("-BLINKING",    minus_blink),
  1147.   CO ("REVERSE",    reverse),
  1148.   CO ("-REVERSE",    minus_reverse),
  1149.   CO ("NORMAL",        normal),
  1150.  
  1151.   /* EKEY return codes for function keys: */
  1152.   OC ("K-LEFT",        EKEY_kl),
  1153.   OC ("K-RIGHT",    EKEY_kr),
  1154.   OC ("K-UP",        EKEY_ku),
  1155.   OC ("K-DOWN",        EKEY_kd),
  1156.   OC ("K-HOME",        EKEY_kh),
  1157.   OC ("K-END",        EKEY_kH),
  1158.   OC ("K-PRIOR",    EKEY_kP),
  1159.   OC ("K-NEXT",        EKEY_kN),
  1160.   OC ("K1",        EKEY_k1),
  1161.   OC ("K2",        EKEY_k2),
  1162.   OC ("K3",        EKEY_k3),
  1163.   OC ("K4",        EKEY_k4),
  1164.   OC ("K5",        EKEY_k5),
  1165.   OC ("K6",        EKEY_k6),
  1166.   OC ("K7",        EKEY_k7),
  1167.   OC ("K8",        EKEY_k8),
  1168.   OC ("K9",        EKEY_k9),
  1169.   OC ("K10",        EKEY_k0),
  1170.   CS ("EXECUTES",    executes),
  1171.  
  1172.   /* show online help: */
  1173.   CO ("HELP",        help),
  1174.  
  1175.   /* more file-manipulation */
  1176.   CO ("COPY-FILE",    copy_file),
  1177.   CO ("MOVE-FILE",    move_file),
  1178.   CO ("FILE-R/W",    file_rw),
  1179.   SC ("BLOCK-FILE",    BLOCK_FILE),
  1180.   CO ("FILE-BLOCK",    file_block),
  1181.   CO ("FILE-BUFFER",    file_buffer),
  1182.   CO ("FILE-EMPTY-BUFFERS", file_empty_buffers),
  1183.   CO ("FILE-FLUSH",    file_flush),
  1184.   CO ("FILE-LIST",    file_list),
  1185.   CO ("FILE-LOAD",    file_load),
  1186.   CO ("FILE-SAVE-BUFFERS", file_save_buffers),
  1187.   CO ("FILE-THRU",    file_thru),
  1188.   CO ("FILE-UPDATE",    file_update),
  1189.  
  1190.   /* editors and system hooks: */
  1191.   SC ("ARGC",           app_argc),
  1192.   CO ("ARGV",           argv),
  1193.   SV ("EXITCODE",    exitcode),
  1194.   SC ("STDIN",        sys.stdIn),    /* --- fid */
  1195.   SC ("STDOUT",        sys.stdOut),    /* --- fid */
  1196.   SC ("STDERR",        sys.stdErr),    /* --- fid */
  1197.   CO ("EXPAND-FN",    expand_fn),
  1198.   CO ("USING",        using),
  1199.   CO ("USING-NEW",    using_new),
  1200.   CS ("LOAD\"",        load_quote),
  1201.   CO ("EDIT-BLOCK",    edit_block),
  1202.   CO ("EDIT-TEXT",    edit_text),
  1203.   CO ("EDIT-ERROR",    edit_error),
  1204.   CO ("INCLUDE",    include),
  1205.   CO ("SYSTEM",        system),
  1206.   CS ("SYSTEM\"",    system_quote),
  1207.   CO ("RAISE",        raise),
  1208.   CO ("SIGNAL",        signal),
  1209. };
  1210. COUNTWORDS (misc, "Compatibility + miscellaneous");
  1211.