home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / C and C++ / Compilers⁄Interps / kevoSource / prim.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-05-18  |  73.2 KB  |  2,981 lines  |  [TEXT/KAHL]
  1. /* Kevo -- a prototype-based object-oriented language */
  2. /* (c) Antero Taivalsaari 1991-1993                   */
  3. /* Some parts (c) Antero Taivalsaari 1986-1988           */
  4. /* prim.c: Portable system primitives                  */
  5.  
  6. #include "global.h"
  7. #include "portGlobal.h"
  8.  
  9. /*---------------------------------------------------------------------------*/
  10. /* Special user-level execution primitives */ 
  11.  
  12. /*
  13.    Most of the definitions in this file are visible to the user via 
  14.    the 'SystemRoot' context, although many of the primitives should not 
  15.    be invoked directly. The definitions whose names have been put within 
  16.    parentheses (xxx) or square brackets <xxx> are those that should be invoked 
  17.    only if you relly know what you are doing. Direct invocation of these primitives
  18.    will probably crash the system.
  19. */
  20.  
  21. /* execute    ( object --  ) */
  22. /* execute an object given its identity */
  23. void pExecute()
  24. {
  25.   execute((OBJECT*)popData());
  26. }
  27.     
  28.  
  29. /* <executeStore>    ( store --  ) */
  30. /* execute code given the memory address where the code begins */
  31. /* This operation should not normally be called directly, because */
  32. /* resizing etc. may physically move the location of code */
  33. void pExecStore()
  34. {
  35.   pushReturn((int*)ip);
  36.   ip = (int**)popData();
  37. }
  38.     
  39.  
  40. /* exit        (  --  ) */
  41. /* end the execution of a thread and return to the next level */
  42. void pExit()
  43. {
  44.   ip = (int**)popReturn();
  45. }
  46.  
  47.  
  48. /* freeExit        ( storeAddress --  ) */
  49. /* end the execution of a thread and return to the next level */
  50. /* deallocate the store space of the code, too */
  51. /* This operation is used to finalize the execution of */
  52. /* interactively typed code */
  53. void pFreeExit()
  54. {
  55.   free((void*)popData());
  56.   ip = (int**)popReturn();
  57. }
  58.  
  59.  
  60. /*---------------------------------------------------------------------------*/
  61. /* Data access primitives */ 
  62.  
  63. /* (=sharedVar)    ( -- addr ) */
  64. /* return the address of a task-independent (shared) variable */
  65. void pSharedVar()
  66. {
  67.   pushData((int)ip);
  68.   ip = (int**)popReturn();
  69. }
  70.  
  71.  
  72. /* (=taskVar)    ( -- addr ) */
  73. /* return the address of a task-specific variable */
  74. /* '*up' is a shorthand for getting the address of up's store part (->mfa)' */
  75. void pTaskVar()
  76. {
  77.   pushData((int)((int*)*up + (int)*ip));    
  78.   ip = (int**)popReturn();
  79. }
  80.  
  81.  
  82. /* (=sharedConst)    ( -- value ) */
  83. /* return the value of a task-independent (shared) constant */
  84. void pSharedConst()
  85. {
  86.   pushData((int)*ip);
  87.   ip = (int**)popReturn();
  88. }
  89.  
  90.   
  91. /* (=taskConst)        ( -- value ) */
  92. /* return the value of a task-specific constant */
  93. void pTaskConst()
  94. {
  95.   pushData(*((int*)*up + (int)*ip));
  96.   ip = (int**)popReturn();
  97. }
  98.  
  99.  
  100. /* (=context)    ( -- object ) */
  101. /* return the identity (self) of a context object (object-oriented object) */
  102. void pContext()
  103. {
  104.     /* 'op' is a pointer to latest object (handle). */
  105.     /* It is updated by the inner interpreter */
  106.     ip = (int**)popReturn();
  107.     pushData((int)op);
  108.  
  109. /*
  110.     Old implementation:
  111.     Comment: This implementation does not yield the same result 
  112.     when executed directly and via "' xxx execute". I haven't noticed 
  113.     this to cause any trouble, but 'op' is safer.
  114.  
  115.     ip = (int**)popReturn();
  116.     pushData((int)*(ip-1));
  117. */
  118. }
  119.   
  120.  
  121. /* (=REF)        (  -- value ) <or> ( value --  ) */
  122. /* return/assign value from/to a shared to-variable */
  123. void pREF()
  124. {
  125.     if ((*up)->assigning) {
  126.         /* Store the value to the slot */
  127.         *ip = (int*)popData();
  128.         (*up)->assigning--;
  129.     }
  130.     else {
  131.         /* Fetch the value from the slot */
  132.         pushData((int)*ip);
  133.     }
  134.      ip = (int**)popReturn();
  135. }
  136.  
  137.  
  138. /* (=VAR)         (  -- value ) <or> ( value --  ) */
  139. /* return/assign value from/to an OOP object-specific to-variable */
  140. void pVAR()
  141. {
  142.   int* address = (int*)*topContext + (int)*ip;
  143.   
  144.     if ((*up)->assigning) {
  145.           /* Store the value to the slot */
  146.         *address = popData();
  147.         (*up)->assigning--;
  148.     }
  149.     else {
  150.         /* Fetch the value from the slot */
  151.         pushData(*address);
  152.     }
  153.      ip = (int**)popReturn();
  154. }
  155.  
  156.  
  157. /* (->)        (  --  ) */
  158. /* Increment the value of the 'assigning' variable so as to */
  159. /* enforce assigment next time (=REF) or (=VAR) is executed */
  160. void pIncAss()
  161. {
  162.     (*up)->assigning++;
  163. }
  164.  
  165.  
  166. /* (lit)     ( -- l ) */
  167. /* load a literal to the data stack */
  168. void pLit()
  169. {
  170.   pushData((int)*ip++);
  171. }
  172.  
  173.  
  174. /* ("lit)     ( -- straddr ) */
  175. /* load a string literal (address) to the data stack */
  176. /* Remember: string literals should not contain double carats (^^) or */
  177. /* carriage returns: image files containing such characters will not read */
  178. void pStrLit()
  179. {
  180.   pushData((int)*ip++);
  181. }
  182.  
  183.  
  184. /* (=sharedVector)    (  --  ) */
  185. void pSharedVector()
  186. /* task-independent (shared) vector execution (vector is a memory  */
  187. /* location which contains a pointer to an executable code object) */
  188. {
  189.   OBJECT* object = (OBJECT*)*ip;
  190.   ip = (int**)popReturn();;
  191.   execute(object);
  192. }
  193.   
  194.  
  195. /* (=taskVector)    (  --  ) */
  196. /* task-specific vectored execution */ 
  197. /* '*up' is a shorthand for getting the address of up's store part (->mfa)' */
  198. void pTaskVector()
  199. {
  200.   OBJECT* object = (OBJECT*)(*((int*)*up + (int)*ip));
  201.   ip = (int**)popReturn();
  202.   execute(object);
  203. }
  204.  
  205.  
  206. /*---------------------------------------------------------------------------*/
  207. /* Temporary variable (block) operations */ 
  208.  
  209. /* These operations allow the definition of temporary variables (blocks). */
  210. /* They allow you to considerably reduce the need for stack juggling operations */
  211.  
  212. /* Note that in the current implementation blocks should not be nested */
  213. /* because the references to temporaries have access to the latest frame */
  214. /* only; thus, references from within blocks to temporaries defined in outer */
  215. /* blocks will be incorrect. Otherwise, blocks work just fine (even with DO-LOOPs). */
  216.  
  217. /* Also keep in mind that the return stack is by default quite small */
  218. /* and it DOESN'T grow automatically. Thus, if you use a lot of temps, */
  219. /* you'd better allocate enough space using 'resizeReturnStack'. */
  220.  
  221. /* ({)        (  --  ) */
  222. /* Open a frame for temporary variables (runtime operation) */
  223. void pOpenFrame()
  224. {
  225.     pushReturn((int*)(*up)->fp); /* Store the previous frame pointer to RStack */
  226.     (*up)->fp = returnSp;         /* Set the frame pointer */
  227. }
  228.  
  229.  
  230. /* (})        (  --  ) */
  231. /* Close the current frame (runtime operation) */
  232. void pCloseFrame()
  233. {
  234.     returnSp = (*up)->fp;
  235.     (*up)->fp = (int**)popReturn();
  236. }
  237.  
  238.  
  239. /* <temp>    ( data --  ) <or> (  --  ) */
  240. /* Allocate a temporary variable within the current frame (runtime operation) */
  241. /* This is a to-operation, which either initializes the temporary variable */
  242. /* with the desired value, or alternatively initializes it to zero */
  243. void pAllocTemp()
  244. {
  245.     if ((*up)->assigning) {
  246.         pushReturn((int*)popData());
  247.         (*up)->assigning--;
  248.     }
  249.     else pushReturn(0);
  250. } 
  251.  
  252.  
  253. /* temp:    ( data --  ) <or> (  -- data ) */
  254. /* Access the value of a temporary variable (runtime operation) */
  255. /* using the index which is given as a literal parameter (follows this */
  256. /* operation in the thread). This too is a to-variable, which either */
  257. /* stores or fetches the value depending on the assignment counter. */
  258. void pAccessTemp()
  259. {
  260.   int* address = (int*)(*up)->fp + (int)*ip;
  261.   
  262.     if ((*up)->assigning) {
  263.           /* Store the value to the slot in the frame */
  264.         *address = popData();
  265.         (*up)->assigning--;
  266.     }
  267.     else {
  268.         /* Fetch the value from the slot in the frame */
  269.         pushData(*address);
  270.     }
  271.  
  272.     /* Skip the offset value */
  273.      ip++;
  274. }    
  275.     
  276.  
  277. /*---------------------------------------------------------------------------*/
  278. /* Data stack operations */ 
  279.  
  280. /* Kevo implements most of Forth's traditional data stack operations */
  281. /* Owing to the presence of temporary variables (blocks), most of these */
  282. /* operations are not however needed too often */
  283.  
  284. /* drop        ( l -- ) */
  285. /* drop the topmost item in the data stack */
  286. void pDrop()
  287. {
  288.   nPopData(1);
  289. }
  290.  
  291.  
  292. /* 2drop    ( l1 l2 -- ) */
  293. /* drop two topmost items in the data stack */
  294. void pDrop2()
  295. {
  296.   nPopData(2);    /* This is a macro (see 'global.h') */
  297. }
  298.  
  299.  
  300. /* over     ( l1 l2 -- l1 l2 l1 ) */
  301. /* copy the second item in the stack to the top */
  302. void pOver()
  303. {
  304.   pushData(secondData);
  305. }
  306.  
  307.  
  308. /* 2over     ( l1 l2 l3 l4 -- l1 l2 l3 l4 l1 l2 ) */
  309. /* the same as 'over' but do two items at a time */
  310. void pOver2()
  311. {
  312.   int a = thirdData;
  313.   int b = fourthData;
  314.   pushData(b);
  315.   pushData(a);
  316. }
  317.  
  318.  
  319. /* dup        ( l -- l l ) */
  320. /* duplicate the topmost stack item */
  321. void pDup()
  322. {
  323.   pushData(topData);
  324. }
  325.  
  326.  
  327. /* 2dup     ( l1 l2  -- l1 l2 l1 l2 ) */
  328. /* duplicate two topmost stack items */
  329. void pDup2()
  330. {
  331.   int a = topData;
  332.   int b = secondData;
  333.   pushData(b);
  334.   pushData(a);
  335. }
  336.  
  337.  
  338. /* ?dup         ( l -- l l ) tai ( 0 -- 0 ) */
  339. /* duplicate the topmost stack item if it is nonzero */
  340. void pQDup()
  341. {
  342.   if (topData) pushData(topData);
  343. }
  344.  
  345.  
  346. /* nip        ( l1 l2 -- l2 ) */
  347. /* drop the second item in the data stack */
  348. void pNip()
  349. {
  350.   int temp = popData();
  351.   topData = temp;
  352. }
  353.  
  354.  
  355. /* tuck     ( l1 l2 -- l2 l1 l2 ) */
  356. /* copy the topmost stack item and tuck in under the second one */
  357. void pTuck()
  358. {
  359.   int a = topData;
  360.   int b = secondData;
  361.   secondData = a;
  362.   topData = b;
  363.   pushData(a);
  364. }
  365.  
  366.  
  367. /* swap        ( l1 l2 -- l2 l1 ) */
  368. /* change the two topmost stack items with each other */
  369. void pSwap()
  370. {
  371.   int a = topData;
  372.   int b = secondData;
  373.   topData = b;
  374.   secondData = a;
  375. }
  376.  
  377.  
  378. /* 2swap     ( l1 l2 l3 l4 -- l3 l4 l1 l2 ) */
  379. /* same as 'swap' but do two items at a time */
  380. void pSwap2()
  381. {
  382.   int a = topData;
  383.   int b = secondData;
  384.   int c = thirdData;
  385.   int d = fourthData;
  386.   fourthData = b;
  387.   thirdData = a;
  388.   secondData = d;
  389.   topData = c;
  390. }
  391.  
  392.  
  393. /* rot        ( l1 l2 l3 -- l2 l3 l1 ) */
  394. /* rotate the third topmost item in the stack to the top */
  395. void pRot()
  396. {
  397.   int a = topData;
  398.   int b = secondData;
  399.   int c = thirdData;
  400.   thirdData = b;
  401.   secondData = a;
  402.   topData = c;
  403. }
  404.  
  405.  
  406. /* -rot        ( l1 l2 l3 -- l3 l1 l2 ) */
  407. /* rotate the topmost item in the stack to the third position */
  408. void pRor()
  409. {
  410.   int a = topData;
  411.   int b = secondData;
  412.   int c = thirdData;
  413.   thirdData = a;
  414.   secondData = c;
  415.   topData = b;
  416. }
  417.  
  418.  
  419. /* pick       ( l -- l ) */
  420. /* pick the nth item in the data stack and copy it to the top */
  421. /* top of the stack = 1, next = 2, etc. */
  422. /* Note that indexing is different than in ANSI Forth */
  423. void pPick()
  424. {
  425.   int temp;
  426.   int n = topData;
  427.   nPopData(n);        /* Macro: see 'global.h' */
  428.   temp = topData; 
  429.   nPushData(n);        /*         - " -              */
  430.   topData = temp;
  431. }
  432.  
  433.  
  434. /* roll        ( n --  ) */
  435. /* 
  436.     If n > 0, bring the n'th item in the data stack to the top
  437.     by rolling the first n items 
  438.     e.g., 1 2 3 4 5 -> 5 roll -> 2 3 4 5 1
  439.     
  440.     If n < 0, move the top item in the stack to the -n'th place
  441.     e.g., 1 2 3 4 5 -> -5 roll -> 5 1 2 3 4
  442. */
  443. void pRoll()
  444. {
  445.   int* tempSp;
  446.   int  temp;
  447.   int  n = popData();
  448.  
  449.     if (n == 0) return;
  450.  
  451.     if (n > 0) {
  452.         tempSp = dataSp - n + 1;
  453.         temp = *tempSp++;
  454.  
  455.         while (tempSp <= dataSp) {
  456.             n = *tempSp--;
  457.             *tempSp = n; tempSp += 2;
  458.         }
  459.         topData = temp;
  460.     }
  461.     else {
  462.         tempSp = dataSp + n + 1;
  463.         temp = *dataSp;
  464.         
  465.         while (tempSp <= dataSp) {
  466.             n = *tempSp;
  467.             *tempSp = temp;
  468.             tempSp++; temp = n;
  469.         }
  470.     }
  471. }
  472.  
  473.  
  474. /* depth    (  -- l ) */
  475. /* push the depth of data stack to the top of data stack */
  476. /* (depth itself is not included in the count) */
  477. void pDepth()
  478. {
  479.   pushData(dataSp - dataStackBottom());
  480. }
  481.  
  482.  
  483. /* .s        (  --  ) */
  484. /* Print the contents of data stack to outfile, */
  485. /* trying to decompile possible names and types. */
  486. void pPrintStack()
  487. {
  488.   int* ptr = dataStackBottom();
  489.   if (dataSp <= dataStackBottom()) return; 
  490.  
  491.   while (dataSp >= ++ptr) {
  492.       PAIR* pair = findNameForward(*ptr);
  493.  
  494.       if (pair) ownPrintf("%s ", pair->nfa);
  495.     else {
  496.         pair = findTypeForward(*ptr);
  497.         if (pair) {
  498.             ownPrintf("%s:", pair->nfa);
  499.             ownPrintf("%d ", *ptr);
  500.         }
  501.         else ownPrintf("%d ", *ptr);
  502.     }
  503.   }
  504. }
  505.     
  506.  
  507. /* resizeDataStack    ( newSize task --  ) */
  508. /* resize the data stack of the given task */
  509. void pResizeData()
  510. {
  511.   TASK** thisTask = (TASK**)popData();
  512.   int    newSize  = popData();
  513.  
  514.     resizeDataStack(thisTask, newSize);
  515. }
  516.  
  517.  
  518. /*---------------------------------------------------------------------------*/
  519. /* Return stack operations */ 
  520.  
  521. /*
  522.    These should not be used (except for i, j, rdepth and .rs),
  523.    unless you really know what you are doing.
  524. */
  525.  
  526. /* >r        ( l -- ) */
  527. /* push a value to the return stack */
  528. void pToR()
  529. {
  530.   pushReturn((int*)popData());
  531. }
  532.  
  533.  
  534. /* r@        ( -- l ) */
  535. /* fetch the value of the topmost item in the return stack */
  536. void pRFetch()
  537. {
  538.   pushData((int)topReturn);
  539. }
  540.  
  541.  
  542. /* r>         ( -- l ) */
  543. /* pop the topmost item in the return stack to the data stack */
  544. void pRFrom()
  545. {
  546.   pushData((int)popReturn());
  547. }
  548.  
  549.  
  550. /* i        ( -- l ) */
  551. /* fetch the value of the topmost item in the return stack */
  552. void pI()
  553. {
  554.   pushData((int)topReturn);
  555. }
  556.  
  557.  
  558. /* j         ( -- l ) */
  559. /* push the index of the second nested loop to the data stack */
  560. void pJ()
  561. {
  562.   pushData((int)fourthReturn);
  563. }
  564.  
  565.  
  566. /* rdepth    (  -- l ) */
  567. /* push the depth of the return stack to the data stack */
  568. void pRDepth()
  569. {
  570.   pushData(returnSp - returnStackBottom());
  571. }
  572.  
  573.  
  574. /* dup>r        ( l -- l ) */
  575. /* push a value to the return stack without deleting it from data stack */
  576. void pDupToR()
  577. {
  578.   pushReturn((int*)topData);
  579. }
  580.  
  581.  
  582. /* r>drop        (  --  ) */
  583. /* drop a value from the return stack */
  584. void pRFromDrop()
  585. {
  586.   nPopReturn(1);
  587. }
  588.  
  589.  
  590. /* .rs        (  --  ) */
  591. /* print the contents of the return stack to outfile */
  592. /* in decompiled form. Segmentation violations may cause */
  593. /* some problems (in Unix) */
  594. void pPrintRStack()
  595. {
  596.   int** ptr = returnStackBottom();
  597.  
  598.     if (returnSp <= returnStackBottom()) return; 
  599.  
  600.     while (returnSp >= ++ptr) {
  601.         PAIR* pair = findNameForward(maskedFetch(*ptr));
  602.  
  603.         if (pair) ownPrintf("%s ", pair->nfa);
  604.         else ownPrintf("%d ", *ptr);
  605.   }
  606. }
  607.  
  608.  
  609. /* resizeReturnStack    ( newSize task --  ) */
  610. /* resize the return stack of the given task */
  611. void pResizeReturn()
  612. {
  613.   TASK** thisTask = (TASK**)popData();
  614.   int    newSize = popData();
  615.  
  616.     resizeReturnStack(thisTask, newSize);
  617. }
  618.  
  619.  
  620. /*---------------------------------------------------------------------------*/
  621. /* Memory operations */ 
  622.  
  623. /* @        ( adr -- l ) */
  624. /* fetch the contents of a memory location to data stack */
  625. void pFetch()
  626. {
  627.   int* address = (int*)topData;
  628.   topData = *address;
  629. }
  630.  
  631.  
  632. /* !        ( l adr -- ) */
  633. /* store a value to a certain memory location */
  634. void pStore()
  635. {
  636.   int* address = (int*)popData();
  637.   *address = popData(); 
  638. }
  639.  
  640.  
  641. /* +!        ( l adr -- ) */
  642. /* add a value to a certain memory location */
  643. void pAddStore()
  644. {
  645.   int* address = (int*)popData(); 
  646.   *address += popData();
  647. }
  648.  
  649.  
  650. /* b@        ( adr -- b ) */
  651. /* fetch the contents of a certain byte in memory */
  652. void pBFetch()
  653. {
  654.   char* address = (char*)topData;
  655.   topData = (int)(*address & 0xff);
  656. }
  657.  
  658.  
  659. /* b!        ( b adr -- ) */
  660. /* store a value to a certain byte in memory */
  661. void pBStore()
  662. {
  663.   char* address = (char*)popData(); 
  664.   *address = (char)popData(); 
  665. }
  666.  
  667.  
  668. /* b+!        ( b adr -- ) */
  669. /* add a value to a certain byte in memory */
  670. void pBAddStore()
  671. {
  672.   char* address = (char*)popData(); 
  673.   *address += (char)popData();
  674. }
  675.  
  676.  
  677. /* w@        ( adr -- w ) */
  678. /* fetch the contents of a certain word (16 bits) in memory */
  679. void pWFetch()
  680. {
  681.   short* address = (short*)topData;
  682.   topData = (int)(*address & 0xffff);
  683. }
  684.  
  685.  
  686. /* w!        ( w adr -- ) */
  687. /* store a value to a certain word (16 bits) in memory */
  688. void pWStore()
  689. {
  690.   short* address = (short*)popData(); 
  691.   *address = (short)popData(); 
  692. }
  693.  
  694.  
  695. /* w+!        ( w adr -- ) */
  696. /* add a value to a certain word (16 bits) in memory */
  697. void pWAddStore()
  698. {
  699.   short* address = (short*)popData(); 
  700.   *address += (short)popData();
  701. }
  702.  
  703.  
  704. /* align    ( l -- l ) */
  705. /* given an address, return the address of the next aligned memory location */
  706. void pAlign()
  707. {
  708.   topData = ((topData+CELL-1)/CELL)*CELL;
  709. }
  710.  
  711.  
  712. /* on        ( addr -- ) */
  713. /* set a certain memory location to TRUE (-1) */
  714. void pOn()
  715. {
  716.   int* address = (int*)popData();
  717.   *address = TRUE;
  718. }
  719.  
  720.  
  721. /* off        ( addr -- ) */
  722. /* set a certain memory location to FALSE (0) */
  723. void pOff()
  724. {
  725.   int* address = (int*)popData();
  726.   *address = FALSE;
  727. }
  728.  
  729.  
  730. /* boff        ( addr -- ) */
  731. /* set a certain byte to zero */
  732. void pBOff()
  733. {
  734.   char* address = (char*)popData();
  735.   *address = 0;
  736. }
  737.  
  738.  
  739. /* woff        ( addr -- ) */
  740. /* set a certain word (16 bits) to zero */
  741. void pWOff()
  742. {
  743.   short* address = (short*)popData();
  744.   *address = 0;
  745. }
  746.  
  747.  
  748. /* ++        ( addr -- ) */
  749. /* increment a certain memory location by one */
  750. void pInc()
  751. {
  752.   int* address = (int*)popData();
  753.   (*address)++;
  754. }
  755.  
  756.  
  757. /* cell++        ( addr -- ) */
  758. /* increment a certain memory location by CELL (typically 4) */
  759. void pCellInc()
  760. {
  761.   int** address = (int**)popData();
  762.   (*address)++;
  763. }
  764.  
  765.  
  766. /* --        ( addr -- ) */
  767. /* decrement a certain memory location by one */
  768. void pDec()
  769. {
  770.   int* address = (int*)popData();
  771.   (*address)--;
  772. }
  773.  
  774.  
  775. /* cell--        ( addr -- ) */
  776. /* decrement a certain memory location by CELL (typically 4) */
  777. void pCellDec()
  778. {
  779.   int** address = (int**)popData();
  780.   (*address)--;
  781. }
  782.  
  783.  
  784. /* toggle    ( l adr -- ) */
  785. /* set bits in a certain memory location */
  786. void pToggle()
  787. {
  788.   int* addr = (int*)popData();
  789.   *addr |= popData();
  790. }
  791.  
  792.  
  793. /* untoggle    ( l adr -- ) */
  794. /* clear bits in a certain memory location */
  795. void pUntoggle()
  796. {
  797.   int* addr = (int*)popData();
  798.   *addr &= ~popData();
  799. }
  800.  
  801.  
  802. /* btoggle    ( l adr -- ) */
  803. /* set bits in a certain byte in memory */
  804. void pBToggle()
  805. {
  806.   char* addr = (char*)popData();
  807.   *addr |= (char)popData();
  808. }
  809.  
  810.  
  811. /* buntoggle    ( l adr -- ) */
  812. /* clear bits in a certain byte in memory */
  813. void pBUntoggle()
  814. {
  815.   char* addr = (char*)popData();
  816.   *addr &= ~(char)popData();
  817. }
  818.  
  819.  
  820. /* move        ( adr1 len adr2 -- ) */
  821. /* move a memory region of certain length (in bytes) to another address, */
  822. /* ensuring that no overlapping will occur */
  823. void pMove()
  824. {
  825.   char* target = (char*)popData();
  826.   int n        = popData();
  827.   char* source = (char*)popData();
  828.   char *cp;
  829.  
  830.   /* There was no 'memmove()' standard function in SUN libraries, */
  831.   /* so I had to write one myself */
  832.  
  833.     if (target == source || n <= 0) return;
  834.  
  835.     if (target < source) {
  836.         for (cp = target; n--;) *cp++ = *source++;
  837.     }
  838.     else {
  839.         source += n;
  840.         for (cp = target + n; n--;) *--cp = *--source;
  841.     }
  842. }
  843.  
  844.  
  845. /* fill        ( adr len ch -- ) */
  846. /* fill a memory area of certain length (in bytes) with a certain character */
  847. void pFill()
  848. {
  849.   char c = (char)popData();
  850.   int  n = popData();
  851.   char* target = (char*)popData();
  852.  
  853.     if (n <= 0) return;
  854.     for (; n--;) *target++ = c;
  855. }
  856.  
  857.  
  858. /*---------------------------------------------------------------------------*/
  859. /* String management */
  860.  
  861. /* count    ( adr -- adr len ) */
  862. /* return the length of a null-terminated (ASCIZ) string */
  863. void pCount()
  864. {
  865.   pushData(strlen((char*)topData));
  866. }
  867.  
  868.  
  869. /* match    ( adr1 addr2 -- -1 <OR> 0 <OR> 1 ) */
  870. /* compare two ASCIZ strings */
  871. void pMatch()
  872. {
  873.   char* addr2 = (char*)popData();
  874.   char* addr1 = (char*)topData;
  875.   topData = strcmp(addr1, addr2);
  876. }
  877.  
  878.  
  879. /* scan        ( addr char -- addr ) */
  880. /* Find first matching character starting from an address */
  881. /* Scan until found or end of string (null char) */
  882. void pScan()
  883. {
  884.   char c     = (char)popData();
  885.   char* address = (char*)topData;
  886.  
  887.   while(*address != c && *address) address++;
  888.   topData = (int)address;
  889. }    
  890.  
  891.  
  892. /* scanWhite    ( addr -- addr ) */
  893. /* Find first whitespace character starting from an address */
  894. /* Scan until found or end of string (null char) */
  895. void pScanWhite()
  896. {
  897.   char* address = (char*)topData;
  898.  
  899.   while (*address != ' ' && *address != '\t' && *address) address++;
  900.   topData = (int)address;
  901. }    
  902.  
  903.  
  904. /* skip        ( addr char -- addr ) */
  905. /* Find first character which is not "char" starting from an address
  906.    and return its address */
  907. void pSkip()
  908. {
  909.   char c     = (char)popData();
  910.   char* address = (char*)topData;
  911.  
  912.   while (*address == c) address++;
  913.   topData = (int)address;
  914. }    
  915.  
  916.  
  917. /* skipWhite        ( addr -- addr ) */
  918. /* Skip all white space characters starting from an address */
  919. void pSkipWhite()
  920. {
  921.   char* address = (char*)topData;
  922.  
  923.   while (*address == ' ' || *address == '\t') address++;
  924.   topData = (int)address;
  925. }    
  926.  
  927.  
  928. /* enclose        ( addr char --  ) */
  929. /* Find first matching character starting from an address */
  930. /* and replace that character by a zero (thus forming an */
  931. /* ASCIZ string). */
  932. void pEnclose()
  933. {
  934.   char c     = (char)popData();
  935.   char* address = (char*)popData();
  936.  
  937.   while (*address != c && *address) address++;
  938.   *address = 0;
  939. }    
  940.  
  941.  
  942. /*---------------------------------------------------------------------------*/
  943. /* Arithmetics */
  944.  
  945. /* +          ( l1 l2 -- l1+l2 ) */
  946. /* add two topmost data stack items */
  947. void pPlus()
  948. {
  949.   topData = popData() + topData;
  950. }
  951.  
  952.  
  953. /* -           ( l1 l2  -- l1-l2 ) */
  954. /* subtract the topmost item in the data stack from the second topmost one */
  955. void pMinus()
  956. {
  957.   int temp = popData();
  958.   topData -= temp;
  959. }
  960.  
  961.  
  962. /* *           ( l1 l2 -- l1*l2 ) */
  963. /* multiply two topmost items in the data stack */
  964. void pMultiply()
  965. {
  966.   topData = popData() * topData;
  967. }
  968.  
  969.  
  970. /* /         ( l1 l2 -- l1/l2 ) */
  971. /* divide the second topmost item in the datastack by the topmost one */
  972. void pDivide()
  973. {
  974.   int temp = popData();
  975.   if (!temp) {
  976.       ownPrintf("-- Division by zero");
  977.       execute((*up)->errorVector);
  978.   }
  979.   else topData /= temp;
  980. }
  981.  
  982.  
  983. /* mod        ( l1 l2 -- mod(l1/l2) ) */
  984. /* save as '/', but return modulus instead */
  985. void pModulo()
  986. {
  987.   int temp = popData();
  988.   topData %= temp;
  989. }
  990.  
  991.  
  992. /* /mod        ( l l -- mod quot ) */
  993. /* same as '/' or 'mod', but return both modulus and quotient */
  994. void pDivMod()
  995. {
  996.   int divisor = topData;
  997.   int dividend = secondData;
  998.   secondData = dividend % divisor; 
  999.   topData = dividend / divisor;
  1000. }
  1001.  
  1002.  
  1003. /* u/        ( l1 l2 -- l1/l2 ) */
  1004. /* unsigned division */
  1005. void pUDivide()
  1006. {
  1007.   unsigned temp = popData();
  1008.   topData /= temp;
  1009. }
  1010.  
  1011.  
  1012. /* umod        ( l1 l2 -- umod(l1/l2) ) */
  1013. /* unsigned modulus */
  1014. void pUModulo()
  1015. {
  1016.   unsigned temp = popData();
  1017.   topData %= temp;
  1018. }
  1019.  
  1020.  
  1021. /* u/mod    ( l1 l2 -- mod quot ) */
  1022. /* unsigned modulus and division */
  1023. void pUDivMod()
  1024. {
  1025.   unsigned divisor = topData;
  1026.   unsigned dividend = secondData;
  1027.   secondData = dividend % divisor; 
  1028.   topData = dividend / divisor;
  1029. }
  1030.  
  1031.  
  1032. /* 1+       ( l -- l+1 ) */
  1033. /* add one to the topmost item in the data stack */
  1034. void pAdd1()
  1035. {
  1036.   topData += 1;
  1037. }
  1038.  
  1039.  
  1040. /* 2+       ( l -- l+2 ) */
  1041. /* add two to the topmost item in the data stack */
  1042. void pAdd2()
  1043. {
  1044.   topData += 2;
  1045. }
  1046.  
  1047.  
  1048. /* CELL+       ( l -- l+CELL ) */
  1049. /* add CELL to the topmost item in the data stack */
  1050. void pAddCell()
  1051. {
  1052.   topData += CELL;
  1053. }
  1054.  
  1055.  
  1056. /* 1-          ( l -- l-1 ) */
  1057. /* subtract one from the topmost item in the data stack */
  1058. void pSub1()
  1059. {
  1060.   topData -= 1;
  1061. }
  1062.  
  1063.  
  1064. /* 2-       ( l -- l-2 ) */
  1065. /* subtract two from the topmost item in the data stack */
  1066. void pSub2()
  1067. {
  1068.   topData -= 2;
  1069. }
  1070.  
  1071.  
  1072. /* CELL-       ( l -- l-CELL ) */
  1073. /* subtract CELL from the topmost item in the data stack */
  1074. void pSubCell()
  1075. {
  1076.   topData -= CELL;
  1077. }
  1078.  
  1079.  
  1080. /* 2*       ( l1 -- l1*2 ) */
  1081. /* multiply the topmost item in the data stack by two */
  1082. void pMul2()
  1083. {
  1084.   topData *= 2;
  1085. }
  1086.  
  1087.  
  1088. /* 2/        ( l1 -- l1/2 ) */
  1089. /* divide the topmost item in the data stack by two */
  1090. void pDiv2()
  1091. {
  1092.   topData /= 2;
  1093. }
  1094.  
  1095.  
  1096. /* CELL*       ( l1 -- l1*CELL ) */
  1097. /* multiply the topmost item in the data stack by CELL */
  1098. void pMulCell()
  1099. {
  1100.   topData *= CELL;
  1101. }
  1102.  
  1103.  
  1104. /* CELL/        ( l1 -- l1/CELL) */
  1105. /* divide the topmost item in the data stack by CELL */
  1106. void pDivCell()
  1107. {
  1108.   topData /= CELL;
  1109. }
  1110.  
  1111.  
  1112. /* abs        ( l -- l ) */
  1113. /* absolute value the topmost item in the data stack */
  1114. void pAbs()
  1115. {
  1116.   topData = abs(topData);
  1117. }
  1118.  
  1119.  
  1120. /* negate  +/-        ( l -- -l ) */
  1121. /* negate (two's complement) the topmost item in the data stack */
  1122. void pNegate()
  1123. {
  1124.   topData = 0 - topData;
  1125. }
  1126.  
  1127.  
  1128. /* min        ( l l -- l ) */
  1129. /* return the minimum of the two topmost items in the data stack */
  1130. void pMin()
  1131. {
  1132.   int a = popData();
  1133.   int b = topData;
  1134.   topData = (a < b) ? a : b;
  1135. }
  1136.  
  1137.  
  1138. /* max        ( l l -- l ) */
  1139. /* return the maximum of the two topmost items in the data stack */
  1140. void pMax()
  1141. {
  1142.   int a = popData();
  1143.   int b = topData;
  1144.   topData = (a > b) ? a : b;
  1145. }
  1146.  
  1147.  
  1148. /* between    ( l low high -- f ) */
  1149. /* return a flag telling whether a value is between/including certain values */
  1150. void pBetween()
  1151. {
  1152.   int high = popData();
  1153.   int low  = popData();
  1154.   int val  = topData;
  1155.   topData = (val >= low && val <= high) ? TRUE : FALSE;
  1156. }
  1157.  
  1158.  
  1159. /*---------------------------------------------------------------------------*/
  1160. /* Literals */ 
  1161.  
  1162. /* 0        ( -- 0 ) */
  1163. /* load zero to the data stack */
  1164. void pZero()
  1165. {
  1166.   pushData(0);
  1167. }
  1168.  
  1169.  
  1170. /* 1        ( -- 1 ) */
  1171. /* load one to the data stack */
  1172. void pOne()
  1173. {
  1174.   pushData(1);
  1175. }
  1176.  
  1177.  
  1178. /* 2        ( -- 2 ) */
  1179. /* load two to the data stack */
  1180. void pTwo()
  1181. {
  1182.   pushData(2);
  1183. }
  1184.  
  1185.  
  1186. /* CELL        ( -- CELL ) */
  1187. /* load CELL to the data stack */
  1188. void pCell()
  1189. {
  1190.   pushData(CELL);
  1191. }
  1192.  
  1193.  
  1194. /* false    ( -- false ) */
  1195. /* load FALSE (0) to the data stack */
  1196. void pFalse()
  1197. {
  1198.   pushData(FALSE);
  1199. }
  1200.  
  1201.  
  1202. /* true        ( -- true ) */
  1203. /* load TRUE (-1) to the data stack */
  1204. void pTrue()
  1205. {
  1206.   pushData(TRUE);
  1207. }
  1208.  
  1209.  
  1210. /* "immediate"    (  -- ImmedFlag ) */
  1211. /* load the immediate flag to the data stack */
  1212. void pImmedFlag()
  1213. {
  1214.   pushData(ImmedFlag);
  1215. }
  1216.  
  1217.  
  1218. /* "hidden"    (  -- hiddenFlag ) */
  1219. /* load the hidden flag to the data stack */
  1220. void pHiddenFlag()
  1221. {
  1222.   pushData(HiddenFlag);
  1223. }
  1224.  
  1225.  
  1226. /* "smudge"    (  -- SmudgeFlag ) */
  1227. /* load the smudge flag to the data stack */
  1228. void pSmudgeFlag()
  1229. {
  1230.   pushData(SmudgeFlag);
  1231. }
  1232.  
  1233.  
  1234. /* #threads    (  -- #threads ) */
  1235. /* return the number of threads in the hashed dictionary structure */
  1236. void pThreads()
  1237. {
  1238.   pushData(CONTEXTSIZE);
  1239. }
  1240.  
  1241.  
  1242. /* "thisOnly"        (  -- literal ) */
  1243. /* Return a literal denoting that one object only should be modified */
  1244. void pLitThisOnly()
  1245. {
  1246.     pushData(THIS_ONLY);
  1247. }
  1248.  
  1249.  
  1250. /* "wholeFamily"    (  -- literal ) */
  1251. /* Return a literal denoting that whole family should be modified */
  1252. void pLitWholeFamily()
  1253. {
  1254.     pushData(WHOLE_FAMILY);
  1255. }
  1256.  
  1257.  
  1258. /* "derivatives"        (  -- literal ) */
  1259. /* Return a literal denoting that all derivatives should be modified */
  1260. void pLitDerivatives()
  1261. {
  1262.     pushData(DERIVATIVES);
  1263. }
  1264.  
  1265.  
  1266. /*---------------------------------------------------------------------------*/
  1267. /* Conditional tests */ 
  1268.  
  1269. /* 0=         ( l -- f ) */
  1270. /* return true if the topmost item in data stack is zero, false otherwise */
  1271. void pEqual0()
  1272. {
  1273.   topData = (!topData) ? TRUE : FALSE;
  1274. }
  1275.  
  1276.  
  1277. /* 0<>        ( l -- f ) */
  1278. /* return true if the topmost item in data stack is <> 0, false otherwise */
  1279. void pNotEqual0()
  1280. {
  1281.   topData = topData ? TRUE : FALSE;
  1282. }
  1283.  
  1284.  
  1285. /* 0>        ( l -- f ) */
  1286. /* return true if the topmost item in data stack is > 0, false otherwise */
  1287. void pGreater0()
  1288. {
  1289.   topData = (topData > 0) ? TRUE : FALSE;
  1290. }
  1291.  
  1292.  
  1293. /* 0<        ( l -- f ) */
  1294. /* return true if the topmost item in data stack is < 0, false otherwise */
  1295. void pLess0()
  1296. {
  1297.   topData = (topData < 0) ? TRUE : FALSE;
  1298. }
  1299.  
  1300.  
  1301. /* =        ( l l -- f ) */
  1302. /* return true if two topmost items in data stack are equal, false otherwise */
  1303. void pEqual()
  1304. { 
  1305.   int temp = popData();
  1306.   topData = (topData == temp) ? TRUE : FALSE;
  1307. }
  1308.  
  1309.  
  1310. /* <>        ( l l -- f ) */
  1311. /* return true if two topmost items in stack are not equal, false otherwise */
  1312. void pNotEqual()
  1313. { 
  1314.   int temp = popData();
  1315.   topData = (topData != temp) ? TRUE : FALSE;
  1316. }
  1317.  
  1318.  
  1319. /* <        ( l l -- f ) */
  1320. /* return true if the second topmost item is less than the topmost one */
  1321. void pLess()
  1322. {
  1323.   int temp = popData();
  1324.   topData = (topData < temp) ? TRUE : FALSE;
  1325. }
  1326.  
  1327.  
  1328. /* <=        ( l l -- f ) */
  1329. /* return true if the second topmost item is <= than the topmost one */
  1330. void pLessEq()
  1331. {
  1332.   int temp = popData();
  1333.   topData = (topData <= temp) ? TRUE : FALSE;
  1334. }
  1335.  
  1336.  
  1337. /* >        ( l l -- f ) */
  1338. /* return true if the second topmost item is greater than the topmost one */
  1339. void pGreater()
  1340. {
  1341.   int temp = popData();
  1342.   topData = (topData > temp) ? TRUE : FALSE;
  1343. }
  1344.  
  1345.  
  1346. /* >=        ( l l -- f ) */
  1347. /* return true if the second topmost item is >= than the topmost one */
  1348. void pGreaterEq()
  1349. {
  1350.   int temp = popData();
  1351.   topData = (topData >= temp) ? TRUE : FALSE;
  1352. }
  1353.  
  1354.  
  1355. /* u<        ( l l -- f ) */
  1356. /* same as '<' but unsigned */
  1357. void pULess()
  1358. {
  1359.   unsigned temp = popData();
  1360.   topData = ((unsigned)topData < temp) ? TRUE : FALSE;
  1361. }
  1362.  
  1363.  
  1364. /* u>        ( l l -- f ) */
  1365. /* same as '>' but unsigned */
  1366. void pUGreater()
  1367. {
  1368.   unsigned temp = popData();
  1369.   topData = ((unsigned)topData > temp) ? TRUE : FALSE;
  1370. }
  1371.  
  1372.  
  1373. /*---------------------------------------------------------------------------*/
  1374. /* Logical operations */ 
  1375.  
  1376. /* and        ( l l -- l ) */
  1377. /* return the logical AND of the two topmost items in the data stack */
  1378. void pAnd()
  1379. {
  1380.   int temp = popData();
  1381.   topData &= temp;
  1382. }
  1383.  
  1384.  
  1385. /* or        ( l l -- l ) */
  1386. /* return the logical OR of the two topmost items in the data stack */
  1387. void pOr()
  1388. {
  1389.   int temp = popData();
  1390.   topData |= temp;
  1391. }
  1392.  
  1393.  
  1394. /* xor        ( l l -- l ) */
  1395. /* return the logical XOR of the two topmost items in the data stack */
  1396. void pXor()
  1397. {
  1398.   int temp = popData();
  1399.   topData ^= temp;
  1400. }
  1401.  
  1402.                 
  1403. /* not        ( l -- ~l ) */
  1404. /* return one's complement */
  1405. void pNot()
  1406. {
  1407.   topData = ~topData;
  1408. }
  1409.  
  1410.  
  1411. /* <<        ( l -- l ) */
  1412. /* Shift left */
  1413. void pShiftLeft()
  1414. {
  1415.   topData <<= 1;
  1416. }
  1417.  
  1418.  
  1419. /* >>        ( l -- l ) */
  1420. /* Shift right */
  1421. void pShiftRight()
  1422. {
  1423.   topData >>= 1;
  1424. }
  1425.  
  1426.  
  1427. /*---------------------------------------------------------------------------*/
  1428. /* Control structure primitives */ 
  1429.  
  1430. /* (branch)    (  --  ) */
  1431. /* unconditional branch */
  1432. void pBranch()
  1433. {
  1434.   ip += (int)*ip;
  1435. }
  1436.  
  1437.  
  1438. /* (if)        ( f -- ) */
  1439. /* conditional branch: branch if the topmost item in the data stack is <> 0 */
  1440. void poIf()
  1441. {
  1442.   if (popData()) ip++;
  1443.   else ip += (int)*ip;
  1444. }
  1445.  
  1446.  
  1447. /* (do)        ( high low -- ) */
  1448. /* loop beginning: push loop index and limit to return stack */
  1449. /* if initial index higher than limit, branch */
  1450. void poDo()
  1451. {
  1452.   register int low = popData();
  1453.   register int limit = popData();
  1454.  
  1455.   if (low > limit) ip += (int)*ip;
  1456.   else {
  1457.      pushReturn((int*)(ip+(int)*ip)); /* Push loop exit address (for 'leave') */
  1458.      pushReturn((int*)limit);         /* Push loop index limit */
  1459.      pushReturn((int*)low);             /* Push loop start index */
  1460.      ip++;                             /* Skip the offset */
  1461.   }
  1462. }
  1463.  
  1464.  
  1465. /* (-do)        ( high low -- ) */
  1466. /* loop beginning: push loop index and limit to return stack */
  1467. /* this version does not have initial checks, so it can be used */
  1468. /* for +LOOPs with negative increments */
  1469. void poStraightDo()
  1470. {
  1471.   register int low = popData();
  1472.   register int limit = popData();
  1473.  
  1474.      pushReturn((int*)(ip+(int)*ip)); /* Push loop exit address (for 'leave') */
  1475.      pushReturn((int*)limit);         /* Push loop index limit */
  1476.      pushReturn((int*)low);             /* Push loop start index */
  1477.      ip++;                             /* Skip the offset */
  1478. }
  1479.  
  1480.  
  1481. /* (loop)    ( -- ) */
  1482. /* loop end: if index is greater than limit, end loop */
  1483. /* else increment index by one */
  1484. void poLoop()
  1485. {
  1486.   register int  index = (int)topReturn;
  1487.   register int  limit = (int)secondReturn;
  1488.  
  1489.   if (index < limit) {            /* If index is still below the limit */
  1490.     topReturn=(int*)(index+1); /* Increment index */
  1491.     ip += (int)*ip;         /* and go back to the beginning of the loop */
  1492.   } 
  1493.   else { 
  1494.     nPopReturn(3);        /* Otherwise remove return stack effects */
  1495.     ip++;                /* and continue (skip the address) */
  1496.   }
  1497. }
  1498.  
  1499.  
  1500. /* (+loop)    ( l -- ) */
  1501. /* loop end: if index is greater than limit, end loop */
  1502. /* else increment index by the topmost item in the data stack */
  1503. void poAddLoop()    
  1504. {
  1505. /* This is otherwise the same as (loop) above but index increment 
  1506.    does not necessarily have to be 1 (increment is taken from the 
  1507.    data stack) */
  1508.   register int  incr  = popData();
  1509.   register int  index = (int)topReturn;
  1510.   register int  limit = (int)secondReturn;
  1511.  
  1512.   if (incr > 0) {
  1513.     if (index < limit) {               /* If index is still below the limit */
  1514.         topReturn=(int*)(index+incr); /* Increment index */
  1515.         ip += (int)*ip;                  /* and go back to the beginning of the loop */
  1516.     } 
  1517.     else { 
  1518.         nPopReturn(3);        /* Otherwise remove return stack effects */
  1519.         ip++;                /* and continue (skip the address) */
  1520.     }
  1521.   }
  1522.   else {
  1523.     if (index > limit) {               /* If index is still over the limit */
  1524.         topReturn=(int*)(index+incr); /* Increment index */
  1525.         ip += (int)*ip;                  /* and go back to the beginning of the loop */
  1526.     } 
  1527.     else { 
  1528.         nPopReturn(3);        /* Otherwise remove return stack effects */
  1529.         ip++;                /* and continue (skip the address) */
  1530.     }  
  1531.   }
  1532. }
  1533.  
  1534.  
  1535. /* unloop        (  --  ) */
  1536. /* remove the loop parameters from the return stack */
  1537. /* This operation can be used before forcing an 'exit' from within a DO-loop */
  1538. void pUnloop()
  1539. {
  1540.     nPopReturn(3);
  1541. }
  1542.  
  1543.  
  1544. /* leave    ( -- ) */
  1545. /* Jump to the end of the loop (continue normal execution) */
  1546. void pLeave()
  1547. {
  1548.     /* 
  1549.     Old implementation:
  1550.     topReturn = secondReturn;    Copy limit to index.
  1551.     */
  1552.  
  1553.     /* New implementation */
  1554.     ip = (int**)thirdReturn;    /* Force jump */
  1555.     nPopReturn(3);                /* Remove stack effects */
  1556. }
  1557.  
  1558.  
  1559. /*---------------------------------------------------------------------------*/
  1560. /* Auxiliary system operations */ 
  1561.  
  1562. /* reboot        ( -- ) */
  1563. /* 
  1564.     Empty the return stack and reboot the system starting with the 
  1565.     next operation in the current thread. Note that 'debugTask' will be 
  1566.     reset, because after initializing the return stack, resume operation 
  1567.     would no longer operate correctly.
  1568. */
  1569. void pReboot()
  1570. {
  1571.   OBJECT* bootObj = (OBJECT*)*ip;
  1572.  
  1573.     resetReturn();
  1574.     ip = (int**)bootObj->mfa;
  1575.     debugTask = NIL;
  1576.     ownLongJmp();
  1577. }
  1578.  
  1579.  
  1580. /* This is one of the most important operations in computer programming :-) */
  1581. /* noop        (  --  ) */
  1582. /* do nothing */
  1583. void pNoop()
  1584. { }
  1585.  
  1586.  
  1587. /*---------------------------------------------------------------------------*/
  1588. /* Multitasker primitives */ 
  1589.  
  1590. /* up        (  -- addr ) */
  1591. /* User task area pointer */
  1592. /* Denotes the currently executing task */
  1593. void pUp()
  1594. {
  1595.   pushData((int)&up);
  1596. }
  1597.  
  1598.  
  1599. /* multitasking    (  -- addr ) */
  1600. /* This primitive variable determines whether multitasking is allowed or not */
  1601. pMultitasking()
  1602. {
  1603.   pushData((int)&multitasking);
  1604. }
  1605.  
  1606.  
  1607. /* running    ( task -- flag ) */  
  1608. /* Check if a certain task is currently running (TRUE) or suspended (FALSE) */
  1609. void pRunning()
  1610. {
  1611.   topData = isActivated((TASK**)topData);
  1612. }
  1613.  
  1614.  
  1615. /* #tasks    (  -- number ) */  
  1616. /* How many tasks there are currently in total */
  1617. void pCountTasks()
  1618. {
  1619.   pushData(taskCount);
  1620. }
  1621.  
  1622.  
  1623. /* #running    (  -- number ) */  
  1624. /* How many tasks there are currently running */
  1625. void pCountRunningTasks()
  1626. {
  1627.   pushData(runningCount);
  1628. }
  1629.  
  1630.  
  1631. /* basePriority    (  -- addressOfBasePriority ) */  
  1632. /* How many tasks there are currently running */
  1633. void pBasePriority()
  1634. {
  1635.   pushData((int)&basePriority);
  1636. }
  1637.  
  1638.  
  1639. /* taskingMode    (  -- mode ) */  
  1640. /* return FALSE if the multitasking is preemptive */
  1641. void pMtaskMode()
  1642. {
  1643.   pushData(mtaskMode);
  1644. }
  1645.  
  1646.  
  1647. /* preemptive    (  --  ) */
  1648. /* Set preemptive multitasking mode */
  1649. pPreemptive()
  1650. {
  1651.     if (mtaskMode != PREEMPTIVE) longjmp(p_inner, TRUE);
  1652. }
  1653.  
  1654.  
  1655. /* cooperative     (  --  ) */
  1656. /* Set cooperative multitasking mode */
  1657. pCooperative()
  1658. {
  1659.     if (mtaskMode != COOPERATIVE) cooperativeInterpreter();
  1660. }
  1661.  
  1662.  
  1663. /* <|    (  --  ) */
  1664. /* disable multitasking (starts a critical region) */
  1665. pIOff()
  1666. {
  1667.     if (!inProtRegion) mtStore = multitasking;
  1668.     inProtRegion++;
  1669.     multitasking = FALSE;
  1670. }
  1671.  
  1672.  
  1673. /* |>    (  --  ) */
  1674. /* enable multitasking (ends a critical region). Does 'yield' automatically */
  1675. pIOn()
  1676. {
  1677.     if (inProtRegion > 0) {
  1678.         if (--inProtRegion == 0) {
  1679.             multitasking = mtStore;
  1680.               yield();
  1681.         }
  1682.     }
  1683. }
  1684.  
  1685.  
  1686. /* activate    ( task --  ) */
  1687. /* Activate a task (allow the task to continue its previous execution) */
  1688. void pActivate()
  1689. {
  1690.     /* See 'tasks.c' */
  1691.     activateTask((TASK**)popData());
  1692. }
  1693.  
  1694.  
  1695. /* suspend    ( task --  ) */
  1696. /* Suspend a task (cancel its execution until it is reactivated) by */
  1697. /* removing it from the round-robin chain. This operation operates */
  1698. /* only if the task is in the round-robin chain, and the task is */
  1699. /* not the only running task in the system (because otherwise */
  1700. /* the system would die). */ 
  1701. void pSuspend()
  1702. {
  1703.     suspendTask((TASK**)popData());
  1704. }
  1705.     
  1706.  
  1707. /* does        ( operation task -- ) */  
  1708. /* Reset the behavior of a task. The task must be suspended. */
  1709. void pTaskDoes()
  1710. {
  1711.   TASK**  newTask  = (TASK**)popData();
  1712.   OBJECT* bootOper = (OBJECT*)popData();
  1713.  
  1714.     setTaskBehavior(newTask, bootOper);
  1715. }
  1716.  
  1717.  
  1718. /* <buildBGTask>    (  -- task ) */  
  1719. /* Create a new background task by copying the current one */
  1720. /* The task shares the window with its creator */
  1721. void pBuildBGTask()
  1722. {
  1723.     pushData((int)buildTask());
  1724. }
  1725.  
  1726.  
  1727. /* <deleteTask>    ( task --  ) */
  1728. /* Delete a task provided that it is not running */
  1729. void pDeleteTask()
  1730. {
  1731.     if (!deleteTask((TASK**)popData()))
  1732.         fprintf(confile, "== Cannot delete the only active task in the system ==\n");
  1733. }
  1734.  
  1735.  
  1736. /* <killTask>    ( task --  ) */
  1737. /* 
  1738.     This is a stronger version of <deleteTask> which will delete a task
  1739.     even if the task was current active.
  1740. */
  1741. void pKillTask()
  1742. {
  1743.     if (!killTask((TASK**)popData()))
  1744.         fprintf(confile, "== Cannot kill the only active task in the system ==\n");
  1745. }
  1746.  
  1747.  
  1748. /* raisePriority     ( task --  ) */
  1749. /* Multiply (raise) the priority of the requested task by two */
  1750. void pRaisePriority()
  1751. {
  1752.   TASK** thisTask = (TASK**)popData();
  1753.   (*thisTask)->priority *= 2;
  1754. }
  1755.  
  1756.  
  1757. /* lowerPriority     ( task --  ) */
  1758. /* Divide (lower) the priority of the requested task by two */
  1759. /* Don't do to zero priority, though */
  1760. void pLowerPriority()
  1761. {
  1762.   TASK** thisTask = (TASK**)popData();
  1763.   int pr = (*thisTask)->priority;
  1764.   if (pr && pr > 1) (*thisTask)->priority /= 2;
  1765.   else (*thisTask)->priority = 1;
  1766. }
  1767.  
  1768.  
  1769. /* resetPriorities     (  --  ) */
  1770. /* Reset the priority of all the tasks to 'basePriority' */
  1771. void pResetPriorities()
  1772. {
  1773.   TASK** thisTask = firstTask;
  1774.   
  1775.     fprintf(confile, "== Setting the priority of all tasks to %d (current base priority) ==\n",
  1776.               basePriority);
  1777.               
  1778.     while(thisTask) {
  1779.           (*thisTask)->priority = basePriority;
  1780.           thisTask = (*thisTask)->nextTask;
  1781.     }
  1782. }
  1783.  
  1784.  
  1785. /* 
  1786.    These special stack operations are needed to allow the data and context
  1787.    stacks of tasks to be initialized from other tasks.
  1788. */
  1789.  
  1790. /* >taskData    ( data task -- ) */
  1791. /* Push a value to another task's data stack */
  1792. void pToTaskData()
  1793. {
  1794.   TASK** targetTask = (TASK**)popData();
  1795.   int data = popData();
  1796.  
  1797.     toTaskData(targetTask, data);
  1798. }
  1799.  
  1800.  
  1801. /* >taskReturn    ( data task -- ) */
  1802. /* Push a value to another task's return stack */
  1803. /* The task must not be active at the moment */
  1804. void pToTaskReturn()
  1805. {
  1806.   TASK** targetTask = (TASK**)popData();
  1807.   int data = popData();
  1808.  
  1809.     toTaskReturn(targetTask, data);
  1810. }
  1811.  
  1812.  
  1813. /* >taskContext    ( data task -- ) */
  1814. /* Push a value to another task's context stack */
  1815. /* The task must not be active at the moment */
  1816. void pToTaskCtxt()
  1817. {
  1818.   TASK** targetTask = (TASK**)popData();
  1819.   int data = popData();
  1820.  
  1821.     toTaskCtxt(targetTask,data);
  1822. }
  1823.     
  1824.  
  1825. /*---------------------------------------------------------------------------*/
  1826. /* Context (dictionary) management */ 
  1827.  
  1828. /* searchThis    ( str contextObj -- pair TRUE <or> FALSE ) */
  1829. /* Search if a certain name can be found in a certain context */
  1830. void pSearchThis()
  1831. {
  1832.   OBJECT* ctxtObj = (OBJECT*)popData();
  1833.   char*   str     = (char*)popData(); 
  1834.   PAIR*   pair;
  1835.  
  1836.     pushData((int)(pair = findPairInThis(getContext(ctxtObj), str)));
  1837.     if (pair) pushData(TRUE);
  1838. }
  1839.  
  1840.  
  1841. /* search    ( str -- pair TRUE <or> FALSE ) */
  1842. /* Search if a certain name can be found in the predefined search path */
  1843. void pSearch()
  1844. {
  1845.   char*   str     = (char*)popData(); 
  1846.   PAIR*   pair;
  1847.  
  1848.     pushData((int)(pair = findPairBackward(str)));
  1849.     if (pair) pushData(TRUE);
  1850. }
  1851.  
  1852.  
  1853. /* immediate?    ( pair -- TRUE/FALSE ) */
  1854. /* check if a certain name is designated immediate */
  1855. void pQImmed()
  1856. {
  1857.   PAIR* pair = (PAIR*)topData;
  1858.   topData = (pair->ffa & ImmedFlag) > 0 ? TRUE : FALSE;
  1859. } 
  1860.  
  1861.  
  1862. /*---------------------------------------------------------------------------*/
  1863. /* Number management */ 
  1864.  
  1865. /* number    ( addr -- number TRUE <or> FALSE ) */
  1866. /* check if the string in an address is a valid decimal, octal or hex number */
  1867. void pNumber()
  1868. {
  1869.   char* addr = (char*)topData;
  1870.  
  1871.   char*  temp;
  1872.   char** endPtr = &temp;
  1873.  
  1874.   int result = strtol(addr, endPtr, 0);
  1875.   if (!**endPtr) {
  1876.     topData = result;
  1877.     pushData(TRUE);
  1878.   }
  1879.   else topData = FALSE;
  1880. }
  1881.  
  1882.  
  1883. /*---------------------------------------------------------------------------*/
  1884. /* Implementation structure management primitives */
  1885.  
  1886. /* <buildContext> ( object -- context ) */
  1887. /* build a new context and return its address */
  1888. /* The first member of the clone family will be 'object' */
  1889. void pBuildCtxt()
  1890. {
  1891.   OBJECT* object = (OBJECT*)topData; 
  1892.   CONTEXT* context = createContext();
  1893.   addToList(context->cloneFamily, object);
  1894.   topData = (int)context;
  1895. }
  1896.  
  1897.  
  1898. /* <buildName>    ( straddr contextObject -- pair ) */
  1899. /* build a name part and include it in a context */
  1900. void pBuildPair()
  1901. {
  1902.   OBJECT* ctxtObj = (OBJECT*)popData();
  1903.   char* name = (char*)popData();
  1904.   char* newName;
  1905.   newName = allocStrCpy(name);
  1906.   pushData((int)addPair(getContext(ctxtObj), newName, NIL)); 
  1907. }
  1908.  
  1909.  
  1910. /* <buildObject>    ( size -- object ) */
  1911. /* build a new object of given size, initializing its memory to zeros */
  1912. void pBuildObj()
  1913. {
  1914.   int size = popData();
  1915.   pushData((int)createClosure(size));
  1916. }  
  1917.  
  1918.  
  1919. /* <mkdir>    (  -- object ) */
  1920. /* build a new object-oriented object with a clone family */
  1921. /* the only member of the clone family will be the object itself */
  1922. void pBuildDir()
  1923. {
  1924.   OBJECT* object = createClosure(2);
  1925.   CONTEXT* context = createContext();
  1926.   object->mfa->efa = (int*)oContext;
  1927.   object->mfa->pfa = (int*)context;
  1928.   addToList(context->cloneFamily, object);
  1929.   pushData((int)object);  
  1930. }  
  1931.  
  1932.  
  1933. /* <buildStore>        ( size -- store ) */
  1934. /* build a new storage part of an object, initialized to zeros */
  1935. void pBuildStore()
  1936. {
  1937.   int size = popData();
  1938.   pushData((int)createStore(size));
  1939. }  
  1940.  
  1941.  
  1942. /* <buildString>    ( straddr -- straddr ) */
  1943. /* allocate a string */
  1944. void pBuildStr()
  1945. {
  1946.   char* addr = (char*)popData();
  1947.   pushData((int)allocStrCpy(addr));
  1948. }  
  1949.  
  1950.  
  1951. /* <deleteName>        ( pair --  ) */
  1952. /* remove a name from its context */
  1953. void pDeleteName()
  1954. {
  1955.   PAIR* pair = (PAIR*)popData();
  1956.   
  1957.     unlinkPair(pair);
  1958.     free(pair);
  1959. }  
  1960.  
  1961.  
  1962. /* <renameName>        ( pair newNameString --  ) */
  1963. /* rename a pair */
  1964. void pRenameName()
  1965. {
  1966.   char* newName = (char*)popData();
  1967.   PAIR* pair    = (PAIR*)popData();
  1968.  
  1969.     renamePair(pair, newName);
  1970. }
  1971.  
  1972.  
  1973. /* <shallowCopy>        ( oldObject -- newObject ) */
  1974. /* shallow copy an existing OOP object */
  1975. void pShallowCopyObj()
  1976. {
  1977.     topData = (int)cloneObject((OBJECT*)topData);
  1978. }
  1979.  
  1980.  
  1981. /* <derive>            ( object --  ) */
  1982. /* ensure the individuality of the OOP object before the object is modified */
  1983. /* by duplicating its context if there are multiple copies of the object */
  1984. void pDeriveObject()
  1985. {
  1986.     deriveObject((OBJECT*)popData());
  1987. }
  1988.  
  1989.  
  1990. /* <resize>        ( newsize object -- ) */
  1991. /* resize an existing object. If new size is more than old size, */
  1992. /* the newly allocated extra memory is initialized to zeros */
  1993. /* Size are given in CELLs */
  1994. void pResizeObj()
  1995. {
  1996.   OBJECT* object = (OBJECT*)popData();
  1997.   int newsize = popData();
  1998.  
  1999.     resizeClosure(object, newsize);
  2000. }
  2001.  
  2002.  
  2003. /* <expand>        ( more object -- ) */
  2004. /* expand the size of an existing object, initializing the extra memory to 0 */
  2005. /* Size is given in CELLs */
  2006. void pExpandObj()
  2007. {
  2008.   OBJECT* object = (OBJECT*)popData();
  2009.   int more = popData();
  2010.  
  2011.     if (more > 0) resizeClosure(object, object->sfa+more);
  2012. }
  2013.  
  2014.  
  2015. /* <expandFamily>        ( more object -- ) */
  2016. /* expand the size of all the objects in the clone family of the given object */
  2017. /* initializing the extra memory to 0 */
  2018. void pExpandFamily()
  2019. {
  2020.   OBJECT* object = (OBJECT*)popData();
  2021.   int more = popData();
  2022.  
  2023.     if (more > 0) resizeFamilyMembers(object, object->sfa+more);
  2024. }
  2025.  
  2026.  
  2027. /* <optimize>        ( object -- ) */
  2028. /* optimize the memory consumption of an object by removing all the trailing */
  2029. /* zeros from its end. This op should be used for closure objects only */
  2030. void pOptimizeObj()
  2031. {
  2032.   OBJECT* object = (OBJECT*)popData();
  2033.   int     size = object->sfa;
  2034.   int*     addr = (int*)object->mfa + size - 1;
  2035.  
  2036.     /* If primitive, do nothing */
  2037.     if (size == 0) return;
  2038.  
  2039.     while (!*addr) addr--;
  2040.     size = addr - (int*)object->mfa + 1;
  2041.  
  2042.     if (size > 0) resizeClosure(object, size);
  2043. }
  2044.  
  2045.  
  2046. /* <dispose>        ( object --  ) */
  2047. /* dispose of OOP object by removing it from its clone family */
  2048. /* and by deallocating its storage space */ 
  2049. void pDisposeObject()
  2050. {
  2051.   OBJECT* object = (OBJECT*)popData();
  2052.   WindowPtr browserWindow;
  2053.  
  2054.     /*
  2055.         Remove the object from its clone family, deleting the clone family 
  2056.         and reorganizing the family hierarchy if needed.
  2057.     */
  2058.     removeFromItsFamily(object);
  2059.     
  2060.     /* yyy warning: the code below is non-portable */
  2061.     /* To ensure integrity, we must close the possible browser to this object */
  2062.     browserWindow = findBrowser(object);
  2063.     if (browserWindow) deleteBrowser(browserWindow);
  2064.  
  2065.     free(object);
  2066. }
  2067.  
  2068.  
  2069. /* <free>    ( addr -- ) */
  2070. /* Free heap memory (this is the same as 'free' in C */
  2071. void pFree()
  2072. {
  2073.     free((void*)popData());
  2074. }
  2075.  
  2076.  
  2077. /* <freeStore>     ( object --  ) */
  2078. /* Free the store part of an object, provided that the object is not a primitive */
  2079. /* (primitives do not have a store part) */
  2080. void pFreeStore()
  2081. {
  2082.   OBJECT* object = (OBJECT*)popData();
  2083.  
  2084.     if (object->sfa) free(object->mfa);
  2085. }
  2086.  
  2087.  
  2088. /* <recompile>        ( oldProperty changedPair --  ) */
  2089. /* starting from a (changed) pair, rebind all the references to the */
  2090. /* old property in the corresponding object to the new property */
  2091. void pRecompile()
  2092. {
  2093.   PAIR* changedPair = (PAIR*)popData();
  2094.   OBJECT* oldProperty = (OBJECT*)popData();
  2095.   
  2096.       recompileProperty(changedPair, oldProperty);
  2097. }
  2098.  
  2099.  
  2100. /* <rebind>        ( fromPair --  ) */
  2101. /* starting from the given pair, check the early bindings and */
  2102. /* rebind if necessary */
  2103. void pRebind()
  2104. {
  2105.   PAIR* fromPair = (PAIR*)popData();
  2106.   
  2107.       rebindContext(fromPair, NIL, NIL);
  2108. }
  2109.  
  2110.  
  2111. /* <reorganize>        ( whoToModify object --  ) */
  2112. /* Notify the system that the given object has changed, and its location */
  2113. /* in the clone family hierarchy must be taken into reconsideration */
  2114. void pReorganize()
  2115. {
  2116.   OBJECT* object = (OBJECT*)popData();
  2117.   int whoToModify = popData();
  2118.  
  2119.     confirmObjectType(object, whoToModify, REMOVING_SOMETHING);
  2120. }  
  2121.  
  2122.  
  2123. /* <rePair>    ( pair object -- pair ) */
  2124. /* This is a temporary implementation:
  2125.     Since 'pair' may no longer be in the context of 'object' after executing
  2126.     <derive>, we must find the first pair in 'object's context with the same
  2127.     ofa field as in 'pair'.
  2128. */
  2129. void pRePair()
  2130. {
  2131.   OBJECT* object = (OBJECT*)popData();
  2132.   PAIR*   pair = (PAIR*)topData;
  2133.  
  2134.   CONTEXT* context = getContext(object);
  2135.   OBJECT* target = pair->ofa;
  2136.   PAIR* thisPair = context->firstPair;
  2137.  
  2138.     while (thisPair) {
  2139.         if (thisPair->ofa == target) {
  2140.             topData = (int)thisPair;
  2141.             return;
  2142.         }
  2143.         thisPair = thisPair->sfa;
  2144.     }
  2145.     
  2146.     topData = NIL;
  2147.       fprintf(confile, "== Integrity error detected: pair not found in '<rePair>' ==\n");
  2148.     reportIntegrityError();
  2149.     ownLongJmp();
  2150. }
  2151.     
  2152.  
  2153. /*---------------------------------------------------------------------------*/
  2154. /* Implementation structure offsets */
  2155.  
  2156. /* name>object    ( pair -- object ) */
  2157. /* given a name part, return the identity of the corresponding object */
  2158. void pPairToObj()
  2159. {
  2160.   PAIR* pair = (PAIR*)topData;
  2161.   topData = (int)pair->ofa;
  2162. }
  2163.  
  2164.  
  2165. /* name'object    ( pair -- ofa ) */
  2166. /* return the address of the 'object' (OFA) field in a name part */
  2167. void pPairOFA()
  2168. {
  2169.   PAIR* pair = (PAIR*)topData;
  2170.   topData = (int)&pair->ofa;
  2171. }
  2172.  
  2173.  
  2174. /* name'name    ( pair -- nfa ) */
  2175. /* return the address of the 'name' (NFA) field in a name part */
  2176. void pPairNFA()
  2177. {
  2178.   PAIR* pair = (PAIR*)topData;
  2179.   topData = (int)&pair->nfa;
  2180. }
  2181.  
  2182.  
  2183. /* name'flags    ( pair -- ffa ) */
  2184. /* return the address of the 'flags' (FFA) field in a name part */
  2185. void pPairFFA()
  2186. {
  2187.   PAIR* pair = (PAIR*)topData;
  2188.   topData = (int)&pair->ffa;
  2189. }
  2190.  
  2191.  
  2192. /* name'prev    ( pair -- lfa ) */
  2193. /* return the address of the 'prev' (LFA) field in a name part */
  2194. void pPairLFA()
  2195. {
  2196.   PAIR* pair = (PAIR*)topData;
  2197.   topData = (int)&pair->lfa;
  2198. }
  2199.  
  2200.  
  2201. /* name'succ    ( pair -- lfa ) */
  2202. /* return the address of the 'succ' (SFA) field in a name part */
  2203. void pPairSFA()
  2204. {
  2205.   PAIR* pair = (PAIR*)topData;
  2206.   topData = (int)&pair->sfa;
  2207. }
  2208.  
  2209.  
  2210. /* name'context    ( pair -- cfa ) */
  2211. /* return the address of the 'context' (CFA) field in a name part */
  2212. void pPairCFA()
  2213. {
  2214.   PAIR* pair = (PAIR*)topData;
  2215.   topData = (int)&pair->cfa;
  2216. }
  2217.  
  2218.  
  2219. /* object>name    ( object -- pair TRUE <OR> FALSE ) */
  2220. /* given an object, return the possible corresponding name part */
  2221. void pObjToPair()
  2222. {
  2223.   OBJECT* object = (OBJECT*)topData;
  2224.   PAIR* pair;
  2225.  
  2226.   topData = (int)(pair = findNameBackward(object));
  2227.   if (pair) pushData(TRUE);
  2228. }
  2229.  
  2230.  
  2231. /* object>typename    ( object -- pair TRUE <OR> FALSE ) */
  2232. /* given an OOP object, return the first possible corresponding name part */
  2233. /* which refers to the same context as the given object. This can be */
  2234. /* regarded as the "type" of that OOP object. */
  2235. void pObjToTypeName()
  2236. {
  2237.   OBJECT* ctxtObject = (OBJECT*)topData;
  2238.   PAIR* pair;
  2239.  
  2240.   topData = (int)(pair = findTypeForward(ctxtObject));
  2241.   if (pair) pushData(TRUE);
  2242. }
  2243.  
  2244.  
  2245. /* object>store    ( object -- store ) */
  2246. /* given an object, return the address of its store part */
  2247. void pObjToStore()
  2248. {
  2249.   OBJECT* object = (OBJECT*)topData;
  2250.   topData = (int)object->mfa;
  2251. }
  2252.  
  2253.  
  2254. /* object'store    ( object -- mfa ) */
  2255. /* return the address of the 'store' (MFA) field in an object header */
  2256. void pObjectMFA()
  2257. {
  2258.   OBJECT* object = (OBJECT*)topData;
  2259.   topData = (int)&object->mfa;
  2260. }
  2261.  
  2262.  
  2263. /* object'size    ( object -- sfa ) */
  2264. /* return the address of the 'size' (SFA) field in an object header */
  2265. void pObjectSFA()
  2266. {
  2267.   OBJECT* object = (OBJECT*)topData;
  2268.   topData = (int)&object->sfa;
  2269. }
  2270.  
  2271.  
  2272. /* object>context    ( contextObject -- context ) */
  2273. /* return the context of the given OOP object */
  2274. /* ensuring that the object really is a valid OOP object */
  2275. /* with its own context. */
  2276. void pObjToContext()
  2277. {
  2278.   OBJECT* object = (OBJECT*)topData;
  2279.  
  2280.     if (!isContextObject(object)) {
  2281.         ownPrintf("-- Invalid parameter received by 'object>context'");
  2282.         execute((*up)->errorVector);
  2283.     }
  2284.     else topData = (int)getContext(object);
  2285. }
  2286.  
  2287.  
  2288. /* context'thread    ( thread context -- pairAddr ) */
  2289. /* return the name referred to from the n'th thread in a context */
  2290. /* Indexing starts from zero */
  2291. void pContextThread()
  2292. {
  2293.   CONTEXT* context  = (CONTEXT*)popData();
  2294.   int thread = topData;
  2295.  
  2296.     topData = (int)&(context->lastPair[thread]);
  2297. }
  2298.  
  2299.  
  2300. /* context'first    ( context -- pairAddr ) */
  2301. /* return the first name in a context (beginning of succ link) */
  2302. void pContextFirst()
  2303. {
  2304.   CONTEXT* context = (CONTEXT*)topData;
  2305.   
  2306.     topData = (int)&context->firstPair;
  2307. }
  2308.  
  2309.  
  2310. /* context'latest    ( context -- pairAddr ) */
  2311. /* return the latest defined name in a context */
  2312. void pContextLatest()
  2313. {
  2314.   CONTEXT* context = (CONTEXT*)topData;
  2315.   
  2316.     topData = (int)&context->latestPair;
  2317. }
  2318.  
  2319.  
  2320. /* context'family    ( context -- cloneFamily ) */
  2321. /* this is needed for concatenation-based object-oriented programming: */
  2322. /* return the clone family of the given OOP object */
  2323. /* clone family is represented as a LIST object (lists.c) */
  2324. void pContextFamily()
  2325. {
  2326.   CONTEXT* context = (CONTEXT*)topData;
  2327.   
  2328.     topData = (int)&context->cloneFamily;
  2329. }
  2330.  
  2331.  
  2332. /* context'parents    ( context -- parentFamilyList ) */
  2333. /* return the LIST object containing the parent families of the given OOP object */
  2334. void pContextParents()
  2335. {
  2336.   CONTEXT* context = (CONTEXT*)topData;
  2337.   
  2338.     topData = (int)&context->parentFamilies;
  2339. }
  2340.  
  2341.  
  2342. /* context'children    ( context -- childFamilyList ) */
  2343. /* return the LIST object containing the child families of the given OOP object */
  2344. void pContextChildren()
  2345. {
  2346.   CONTEXT* context = (CONTEXT*)topData;
  2347.   
  2348.     topData = (int)&context->childFamilies;
  2349. }
  2350.  
  2351.  
  2352. /* checkSystemValidity    (  --  ) */
  2353. /* Perform integrity checks for every context in the system */
  2354. /* This allows us to recognize memory leaks, dangling pointers etc. */
  2355. void pCheckSystem()
  2356. {
  2357.   /* The first context in the context list is always 'rootContext' */
  2358.   /* However, since rootContext is so big (= time-consuming to check) */
  2359.   /* we start from the next context */
  2360.   CONTEXT* thisContext = rootContext->nextContext; 
  2361.  
  2362.     while (thisContext) {
  2363.         checkIntegrity(thisContext);
  2364.         thisContext = thisContext->nextContext;
  2365.     }
  2366. }
  2367.  
  2368.  
  2369. /*---------------------------------------------------------------------------*/
  2370. /* Debugging, decompilation, and tracing primitives */ 
  2371. /* Most of these primitives can be found from separate files */
  2372.  
  2373. /* see        ( object -- ) */
  2374. /* decompile the definition of an object */
  2375. void pSee()
  2376. {
  2377.     /* See 'image.c' */
  2378.     decompile((OBJECT*)popData());
  2379.     yield();
  2380. }
  2381.  
  2382.  
  2383. /*---------------------------------------------------------------------------*/
  2384. /* Basic file interface */
  2385.  
  2386. /* "write"    ( -- "write" ) */
  2387. /* return address of a string denoting file "write" mode */
  2388. void pWriteMode()
  2389. {
  2390.   pushData((int)"w");
  2391. }
  2392.  
  2393.  
  2394. /* "append"    ( -- "append" ) */
  2395. /* return address of a string denoting file "append" mode */
  2396. void pAppendMode()
  2397. {
  2398.   pushData((int)"a");
  2399. }
  2400.  
  2401.  
  2402. /* pushInfile    ( string --  ) */
  2403. /* push current input file to the task-specific file stack, and  */
  2404. /* open a new file for reading instead. */
  2405. void pPushInfile()
  2406. {
  2407.   char* fileName = (char*)popData();
  2408.  
  2409.     pushInfile(fileName);
  2410. }
  2411.  
  2412.  
  2413. /* popInfile    (  --  ) */
  2414. /* Close the current input file and return to the previous one */
  2415. /* Do not close 'stdin', though. */
  2416. void pPopInfile()
  2417. {
  2418.     popInfile();
  2419. }
  2420.  
  2421.  
  2422. /* resetInfiles    (  --  ) */
  2423. /* Reset the input file stack. */
  2424. /* Close all the input files except the first. */
  2425. void pResetInfiles()
  2426. {
  2427.     while(infileSp > 0) popInfile();
  2428. }
  2429.  
  2430.  
  2431. /* pushOutfile    ( string mode --  ) */
  2432. /* push current output file to the task-specific file stack, and  */
  2433. /* open a new file for writing or appending instead. */
  2434. void pPushOutfile()
  2435. {
  2436.   char* mode = (char*)popData();
  2437.   char* fileName = (char*)popData();
  2438.  
  2439.     pushOutfile(fileName, mode);
  2440. }
  2441.  
  2442.  
  2443. /* popOutfile    (  --  ) */
  2444. /* Close the current output file and return to the previous one */
  2445. /* Do not close stdout or stderr, though. */
  2446. void pPopOutfile()
  2447. {
  2448.     popOutfile();
  2449. }
  2450.  
  2451.  
  2452. /* resetOutfiles    (  --  ) */
  2453. /* Reset output file stack. */
  2454. /* Close all the output files except the first. */
  2455. void pResetOutfiles()
  2456. {
  2457.     while(outfileSp > 0) popOutfile();
  2458. }
  2459.  
  2460.  
  2461. /* errorTo        (  --  ) */
  2462. /* Push error file to outfile stack. */
  2463. /* This allows a task to print to the screen even though it was */
  2464. /* currently loading a file */
  2465. void pErrfilePush()
  2466. {
  2467.     pushToOFS(errfile);
  2468. }
  2469.  
  2470.  
  2471. /* consoleTo        (  --  ) */
  2472. /* Push console file to outfile stack */
  2473. /* This allows tasks to print to the console window. */
  2474. void pConfilePush()
  2475. {
  2476.     pushToOFS(confile);
  2477. }
  2478.  
  2479.  
  2480. /*---------------------------------------------------------------------------*/
  2481. /* Object-oriented primitives */
  2482.  
  2483. /* self        (  -- self ) */
  2484. /* return self */
  2485. void pSelf()
  2486. {
  2487.   pushData((int)topContext);
  2488. }
  2489.  
  2490.  
  2491. /* &        (  -- self ) */
  2492. /* return the identity of the receiver of the previous message */
  2493. void pPrevSelf()
  2494. {
  2495.   pushData((int)prevContext);
  2496. }
  2497.  
  2498.  
  2499. /* >self    ( object --  ) */
  2500. /* push an item to the context stack */
  2501. void pToSelf()
  2502. {
  2503.   pushContext((int*)popData());
  2504. }
  2505.  
  2506.  
  2507. /* self>    (  -- object ) */
  2508. /* pop an item from the context stack */
  2509. void pSelfFrom()
  2510. {
  2511.   pushData((int)popContext());
  2512. }
  2513.  
  2514.  
  2515. /* self>drop    (  --  ) */
  2516. /* drop an item from the context stack */
  2517. void pSelfDrop()
  2518. {
  2519.   (void)popContext();
  2520. }
  2521.  
  2522.  
  2523. /* cdepth    (  -- l ) */
  2524. /* push the depth of context stack to the top of data stack */
  2525. void pCDepth()
  2526. {
  2527.   pushData(contextSp - contextStackBottom());
  2528. }
  2529.  
  2530.  
  2531. /* .cs        (  --  ) */
  2532. /* print the contents of context stack to outfile */
  2533. /* try to decompile possible object types */
  2534. void pPrintCStack()
  2535. {
  2536.   int* ptr = (int*)contextStackBottom();
  2537.  
  2538.     if (contextSp <= contextStackBottom()) return; 
  2539.  
  2540.     while ((int*)contextSp >= ++ptr) { 
  2541.           PAIR* pair = findTypeForward(*ptr);
  2542.  
  2543.           if (pair) {
  2544.               ownPrintf("%s:", pair->nfa);
  2545.             ownPrintf("%d ", *ptr);
  2546.         }
  2547.         else {
  2548.             pair = findNameForward(*ptr);
  2549.             if (pair) ownPrintf("%s ", pair->nfa);
  2550.             else ownPrintf("%d ", *ptr);
  2551.         }
  2552.     }
  2553. }
  2554.     
  2555.  
  2556. /* resizeContextStack    ( newSize task --  ) */
  2557. /* resize the context stack of the given task */
  2558. void pResizeContext()
  2559. {
  2560.   TASK** thisTask = (TASK**)popData();
  2561.   int    newSize = popData();
  2562.  
  2563.     resizeContextStack(thisTask, newSize);
  2564. }
  2565.  
  2566.  
  2567. /* >send    ( object messageString --  ) */
  2568. /* Send a message to an object */
  2569. /* Note that context stack must be popped after a call to '>send' */
  2570. /* This cannot be done here, because we need to execute threaded code */
  2571. void pSend()
  2572. {
  2573.   char*   string = (char*)popData();
  2574.   OBJECT* object = (OBJECT*)popData();
  2575.   PAIR*   pair = messageLookUp(object, string);
  2576.  
  2577.   pushContext((int*)object);
  2578.  
  2579.   if (pair) execute(pair->ofa);
  2580.   else {
  2581.     fprintf(confile, "== Message binding error."); showTaskID();
  2582.     ownPrintf("-- Cannot bind \"%s\"", string);
  2583.     execute((*up)->errorVector);
  2584.   }
  2585. }
  2586.  
  2587.  
  2588. /* >resend    ( thisPair --  ) */
  2589. /* Resend a message to the current object, starting from 'thisPair' */
  2590. /* This operations is the equivalent of super-reference in Smalltalk */
  2591. /* Unlike Smalltalk, >resend does not take any identifier as an argument */
  2592. /* (previous identifier is used implicitly) */
  2593. void pResend()
  2594. {
  2595.   PAIR* prevPair = (PAIR*)popData();
  2596.   PAIR* superPair = selfLookUp(prevPair->lfa, prevPair->nfa);
  2597.   
  2598.   if (superPair) execute(superPair->ofa);
  2599.   else {
  2600.     fprintf(confile, "== Message binding error."); showTaskID();
  2601.     ownPrintf("-- Cannot bind (resend) \"%s\"", prevPair->nfa);
  2602.     execute((*up)->errorVector);
  2603.   }
  2604. }
  2605.  
  2606.  
  2607. /* respondsTo    ( string object -- flag ) */
  2608. /* Check if the object is capable of answering to the requested message */
  2609. /* (given as a string). Note that the result value is actually not a flag, */
  2610. /* but the address of the found pair (or NIL) */
  2611. void pRespondsTo()
  2612. {
  2613.   OBJECT* object = (OBJECT*)popData();
  2614.   char* message = (char*)popData();
  2615.   
  2616.     pushData((int)respondsTo(object, message));
  2617. }
  2618.  
  2619.  
  2620. /* hasContext    ( object -- flag ) */
  2621. /* Check if the given address is a valid OOP object identity */
  2622. void pHasContext()
  2623. {
  2624.     topData = isContextObject((OBJECT*)topData);
  2625. }
  2626.  
  2627.  
  2628. /* >area        ( object -- addrOfFirstDataSlot )
  2629. /* Return the address of the first data slot of an object */
  2630. /* DATAOFFSET is a macro that tells how many cells each instance has */
  2631. /* before the actual data slots begin */
  2632. pToArea()
  2633. {
  2634.     topData = (int)((int*)((OBJECT*)topData)->mfa + DATAOFFSET);
  2635. }
  2636.  
  2637.  
  2638. /* area0            (  -- addrOfFirstDataSlot ) */
  2639. /* Return the address of the first data slot of the current object */
  2640. pAreaZero()
  2641. {
  2642.     pushData((int)((int*)((OBJECT*)topContext)->mfa + DATAOFFSET));
  2643. }
  2644.  
  2645.  
  2646. /* area#            (  -- sizeOfArea ) */
  2647. /* Return the size of the current object's data area (in cells) */
  2648. pAreaSize()
  2649. {
  2650.     pushData(((OBJECT*)topContext)->sfa - DATAOFFSET);
  2651. }
  2652.  
  2653.  
  2654. /*---------------------------------------------------------------------------*/
  2655. /* InitPrimitives(): initialize the name space (primitive operations) */
  2656.  
  2657. void initPrimitives()
  2658. {
  2659.   /* Execution primitives */
  2660.   addPair(rootContext, "exit",        oExit = createPrimitive(pExit));
  2661.   addPair(rootContext, "freeExit",    createPrimitive(pFreeExit)); hide();
  2662.   addPair(rootContext, "<executeStore>",createPrimitive(pExecStore)); hide();
  2663.   addPair(rootContext, "execute",    createPrimitive(pExecute));
  2664.  
  2665.  
  2666.   /* Data access primitives */
  2667.   addPair(rootContext, "(=sharedVar)",    oSharedVar     = createPrimitive(pSharedVar)); hide();
  2668.   addPair(rootContext, "(=taskVar)",    oTaskVar    = createPrimitive(pTaskVar)); hide();
  2669.   addPair(rootContext, "(=sharedConst)",oSharedConst= createPrimitive(pSharedConst)); hide();
  2670.   addPair(rootContext, "(=taskConst)",  oTaskConst     = createPrimitive(pTaskConst)); hide();
  2671.   addPair(rootContext, "(=context)",    oContext    = createPrimitive(pContext)); hide();
  2672.   addPair(rootContext, "(=REF)",        oREF        = createPrimitive(pREF)); hide();
  2673.   addPair(rootContext, "(=VAR)",        oVAR        = createPrimitive(pVAR)); hide();
  2674.   addPair(rootContext, "(->)",                          createPrimitive(pIncAss)); hide();
  2675.   addPair(rootContext, "(lit)",         oLit         = createPrimitive(pLit)); hide();
  2676.   addPair(rootContext, "(\"lit)",        oStrLit        = createPrimitive(pStrLit)); hide();
  2677.   addPair(rootContext, "(=sharedVector)", createPrimitive(pSharedVector)); hide();
  2678.   addPair(rootContext, "(=taskVector)",    createPrimitive(pTaskVector)); hide();
  2679.  
  2680.  
  2681.   /* Data stack primitives */
  2682.   addPair(rootContext, "dup",         createPrimitive(pDup));
  2683.   addPair(rootContext, "2dup",         createPrimitive(pDup2));
  2684.   addPair(rootContext, "?dup",         createPrimitive(pQDup));
  2685.   addPair(rootContext, "drop",         createPrimitive(pDrop));
  2686.   addPair(rootContext, "2drop",     createPrimitive(pDrop2));
  2687.   addPair(rootContext, "swap",         createPrimitive(pSwap));
  2688.   addPair(rootContext, "2swap",     createPrimitive(pSwap2));
  2689.   addPair(rootContext, "over",         createPrimitive(pOver));
  2690.   addPair(rootContext, "2over",     createPrimitive(pOver2));
  2691.   addPair(rootContext, "rot",         createPrimitive(pRot));
  2692.   addPair(rootContext, "-rot",         createPrimitive(pRor));
  2693.   addPair(rootContext, "nip",         createPrimitive(pNip));
  2694.   addPair(rootContext, "tuck",         createPrimitive(pTuck));
  2695.   addPair(rootContext, "pick",         createPrimitive(pPick));
  2696.   addPair(rootContext, "roll",         createPrimitive(pRoll));
  2697.   addPair(rootContext, "depth",     createPrimitive(pDepth));
  2698.   addPair(rootContext, "resetSp",     createPrimitive(resetData));
  2699.   addPair(rootContext, ".s",        createPrimitive(pPrintStack));
  2700.   addPair(rootContext, "resizeDataStack",createPrimitive(pResizeData));
  2701.  
  2702.  
  2703.   /* Return stack primitives */
  2704.   addPair(rootContext, ">r",        createPrimitive(pToR));
  2705.   addPair(rootContext, "r@",         createPrimitive(pRFetch));
  2706.   addPair(rootContext, "r>",         createPrimitive(pRFrom));
  2707.   addPair(rootContext, "i",         createPrimitive(pI));
  2708.   addPair(rootContext, "j",             createPrimitive(pJ));
  2709.   addPair(rootContext, "rdepth",     createPrimitive(pRDepth));
  2710.   addPair(rootContext, "dup>r",     createPrimitive(pDupToR));
  2711.   addPair(rootContext, "r>drop",     createPrimitive(pRFromDrop));
  2712.   addPair(rootContext, ".rs",        createPrimitive(pPrintRStack));
  2713.   addPair(rootContext, "resizeReturnStack",createPrimitive(pResizeReturn));
  2714.  
  2715.  
  2716.   /* Temporary variable (block) primitives */
  2717.   addPair(rootContext, "({)",        createPrimitive(pOpenFrame));
  2718.   addPair(rootContext, "(})",        createPrimitive(pCloseFrame));
  2719.   addPair(rootContext, "<temp>",    createPrimitive(pAllocTemp));
  2720.   addPair(rootContext, "temp:",        createPrimitive(pAccessTemp));
  2721.  
  2722.  
  2723.   /* Memory primitives */
  2724.   addPair(rootContext, "@",         createPrimitive(pFetch));
  2725.   addPair(rootContext, "!",             createPrimitive(pStore));
  2726.   addPair(rootContext, "+!",        createPrimitive(pAddStore));
  2727.   addPair(rootContext, "b@",        createPrimitive(pBFetch));
  2728.   addPair(rootContext, "b!",         createPrimitive(pBStore));
  2729.   addPair(rootContext, "b+!",         createPrimitive(pBAddStore));
  2730.   addPair(rootContext, "w@",        createPrimitive(pWFetch));
  2731.   addPair(rootContext, "w!",         createPrimitive(pWStore));
  2732.   addPair(rootContext, "w+!",         createPrimitive(pWAddStore));
  2733.   addPair(rootContext, "on",        createPrimitive(pOn));
  2734.   addPair(rootContext, "off",        createPrimitive(pOff));
  2735.   addPair(rootContext, "boff",        createPrimitive(pBOff));
  2736.   addPair(rootContext, "woff",        createPrimitive(pWOff));
  2737.   addPair(rootContext, "++",        createPrimitive(pInc));
  2738.   addPair(rootContext, "cell++",    createPrimitive(pCellInc));
  2739.   addPair(rootContext, "--",        createPrimitive(pDec));
  2740.   addPair(rootContext, "cell--",    createPrimitive(pCellDec));
  2741.   addPair(rootContext, "toggle",     createPrimitive(pToggle));
  2742.   addPair(rootContext, "untoggle",     createPrimitive(pUntoggle));
  2743.   addPair(rootContext, "btoggle",     createPrimitive(pBToggle));
  2744.   addPair(rootContext, "buntoggle", createPrimitive(pBUntoggle));
  2745.   addPair(rootContext, "align",        createPrimitive(pAlign));
  2746.   addPair(rootContext, "move",         createPrimitive(pMove));
  2747.   addPair(rootContext, "fill",         createPrimitive(pFill));
  2748.  
  2749.  
  2750.   /* String primitives */
  2751.   addPair(rootContext, "count",     createPrimitive(pCount));
  2752.   addPair(rootContext, "match",     createPrimitive(pMatch));
  2753.   addPair(rootContext, "scan",         createPrimitive(pScan));
  2754.   addPair(rootContext, "scanWhite", createPrimitive(pScanWhite));
  2755.   addPair(rootContext, "skip",         createPrimitive(pSkip));
  2756.   addPair(rootContext, "skipWhite",    createPrimitive(pSkipWhite));
  2757.   addPair(rootContext, "enclose",    createPrimitive(pEnclose));
  2758.  
  2759.  
  2760.   /* Integer arithmetic primitives */
  2761.   addPair(rootContext, "+",         createPrimitive(pPlus));
  2762.   addPair(rootContext, "-",             createPrimitive(pMinus));
  2763.   addPair(rootContext, "*",            createPrimitive(pMultiply));
  2764.   addPair(rootContext, "/",             createPrimitive(pDivide));
  2765.   addPair(rootContext, "mod",        createPrimitive(pModulo));
  2766.   addPair(rootContext, "/mod",        createPrimitive(pDivMod));
  2767.   addPair(rootContext, "u/",         createPrimitive(pUDivide));
  2768.   addPair(rootContext, "umod",         createPrimitive(pUModulo));
  2769.   addPair(rootContext, "u/mod",     createPrimitive(pUDivMod));
  2770.   addPair(rootContext, "1+",         createPrimitive(pAdd1));
  2771.   addPair(rootContext, "2+",         createPrimitive(pAdd2));
  2772.   addPair(rootContext, "cell+",     createPrimitive(pAddCell));
  2773.   addPair(rootContext, "1-",         createPrimitive(pSub1));
  2774.   addPair(rootContext, "2-",         createPrimitive(pSub2));
  2775.   addPair(rootContext, "cell-",     createPrimitive(pSubCell));
  2776.   addPair(rootContext, "2*",         createPrimitive(pMul2));
  2777.   addPair(rootContext, "2/",         createPrimitive(pDiv2));
  2778.   addPair(rootContext, "cell*",     createPrimitive(pMulCell));
  2779.   addPair(rootContext, "cell/",     createPrimitive(pDivCell));
  2780.   addPair(rootContext, "abs",         createPrimitive(pAbs));
  2781.   addPair(rootContext, "negate",     createPrimitive(pNegate));
  2782.   addPair(rootContext, "+/-",         createPrimitive(pNegate));
  2783.  
  2784.  
  2785.   /* Literal primitives */
  2786.   addPair(rootContext, "zero",        createPrimitive(pZero));
  2787.   addPair(rootContext, "one",         createPrimitive(pOne));
  2788.   addPair(rootContext, "cell",         createPrimitive(pCell));
  2789.   addPair(rootContext, "false",        createPrimitive(pFalse));
  2790.   addPair(rootContext, "true",        createPrimitive(pTrue));
  2791.   addPair(rootContext, "\"write\"",    createPrimitive(pWriteMode));
  2792.   addPair(rootContext, "\"append\"",    createPrimitive(pAppendMode));
  2793.   addPair(rootContext, "\"immediate\"",    createPrimitive(pImmedFlag));
  2794.   addPair(rootContext, "\"hidden\"",    createPrimitive(pHiddenFlag));
  2795.   addPair(rootContext, "\"smudge\"",    createPrimitive(pSmudgeFlag));
  2796.   addPair(rootContext, "#threads",    createPrimitive(pThreads));
  2797.   addPair(rootContext, "\"thisOnly\"",createPrimitive(pLitThisOnly)); hide();
  2798.   addPair(rootContext, "\"wholeFamily\"",createPrimitive(pLitWholeFamily)); hide();
  2799.   addPair(rootContext, "\"derivatives\"",createPrimitive(pLitDerivatives)); hide();
  2800.  
  2801.  
  2802.   /* Comparison primitives */
  2803.   addPair(rootContext, "0=",         createPrimitive(pEqual0));
  2804.   addPair(rootContext, "0<>",         createPrimitive(pNotEqual0));
  2805.   addPair(rootContext, "0<",         createPrimitive(pLess0));
  2806.   addPair(rootContext, "0>",         createPrimitive(pGreater0));
  2807.   addPair(rootContext, "=",         createPrimitive(pEqual));
  2808.   addPair(rootContext, "<>",        createPrimitive(pNotEqual));
  2809.   addPair(rootContext, "<",         createPrimitive(pLess));
  2810.   addPair(rootContext, "<=",         createPrimitive(pLessEq));
  2811.   addPair(rootContext, ">",         createPrimitive(pGreater));
  2812.   addPair(rootContext, ">=",         createPrimitive(pGreaterEq));
  2813.   addPair(rootContext, "u<",         createPrimitive(pULess));
  2814.   addPair(rootContext, "u>",         createPrimitive(pUGreater));
  2815.   addPair(rootContext, "min",         createPrimitive(pMin));
  2816.   addPair(rootContext, "max",         createPrimitive(pMax));
  2817.   addPair(rootContext, "between",     createPrimitive(pBetween));
  2818.  
  2819.  
  2820.   /* Logical primitives */
  2821.   addPair(rootContext, "and",         createPrimitive(pAnd));
  2822.   addPair(rootContext, "or",         createPrimitive(pOr));
  2823.   addPair(rootContext, "xor",         createPrimitive(pXor));
  2824.   addPair(rootContext, "not",         createPrimitive(pNot));
  2825.   addPair(rootContext, "<<",        createPrimitive(pShiftLeft));
  2826.   addPair(rootContext, ">>",        createPrimitive(pShiftRight));
  2827.  
  2828.  
  2829.   /* Control structure primitives */
  2830.   addPair(rootContext, "(branch)",    createPrimitive(pBranch)); hide();
  2831.   addPair(rootContext, "(if)",         createPrimitive(poIf)); hide();
  2832.   addPair(rootContext, "(do)",         createPrimitive(poDo)); hide();
  2833.   addPair(rootContext, "(-do)",     createPrimitive(poStraightDo)); hide();
  2834.   addPair(rootContext, "(loop)",     createPrimitive(poLoop)); hide();
  2835.   addPair(rootContext, "(+loop)",     createPrimitive(poAddLoop)); hide();
  2836.   addPair(rootContext, "unloop",    createPrimitive(pUnloop));
  2837.   addPair(rootContext, "leave",     createPrimitive(pLeave)); 
  2838.  
  2839.  
  2840.   /* System primitives */
  2841.   addPair(rootContext, "reboot",     createPrimitive(pReboot)); hide();
  2842.   addPair(rootContext, "noop",        createPrimitive(pNoop));
  2843.  
  2844.  
  2845.   /* Debugging, decompilation, and tracing primitives */
  2846.   addPair(rootContext, "debugExit", createPrimitive(debugExit)); hide();
  2847.   addPair(rootContext, "resume",     createPrimitive(resume)); 
  2848.   addPair(rootContext, "trace",        createPrimitive(traceInterpreter));
  2849.   addPair(rootContext, "fullTrace",    createPrimitive(fullTraceInterpreter));
  2850.   addPair(rootContext, "endTrace",    createPrimitive(ownLongJmp));
  2851.   addPair(rootContext, "see",        createPrimitive(pSee));
  2852. /*  addPair(rootContext, "image",        createPrimitive(pImage)); */
  2853.  
  2854.  
  2855.   /* Multitasker primitives */
  2856.   addPair(rootContext, "up",        createPrimitive(pUp));
  2857.   addPair(rootContext, "multitasking",createPrimitive(pMultitasking));
  2858.   addPair(rootContext, "running",    createPrimitive(pRunning));
  2859.   addPair(rootContext, "#tasks",    createPrimitive(pCountTasks));
  2860.   addPair(rootContext, "#running",    createPrimitive(pCountRunningTasks));
  2861.   addPair(rootContext, "basePriority",createPrimitive(pBasePriority));
  2862.   addPair(rootContext, "taskingMode",createPrimitive(pMtaskMode));
  2863.   addPair(rootContext, "preemptive", createPrimitive(pPreemptive));
  2864.   addPair(rootContext, "cooperative",createPrimitive(pCooperative));
  2865.   addPair(rootContext, "yield",     createPrimitive(yield));
  2866.   addPair(rootContext, "<|",         createPrimitive(pIOff));
  2867.   addPair(rootContext, "|>",         createPrimitive(pIOn));
  2868.   addPair(rootContext, "activate",     createPrimitive(pActivate));
  2869.   addPair(rootContext, "suspend",     createPrimitive(pSuspend));
  2870.   addPair(rootContext, "does",        createPrimitive(pTaskDoes));
  2871.   addPair(rootContext, "raisePriority",    createPrimitive(pRaisePriority));
  2872.   addPair(rootContext, "lowerPriority",    createPrimitive(pLowerPriority));
  2873.   addPair(rootContext, "resetPriorities",createPrimitive(pResetPriorities));
  2874.   addPair(rootContext, ">taskData",        createPrimitive(pToTaskData));
  2875.   addPair(rootContext, ">taskReturn",    createPrimitive(pToTaskReturn));
  2876.   addPair(rootContext, ">taskContext",    createPrimitive(pToTaskCtxt));
  2877.  
  2878.  
  2879.   /* File primitives */
  2880.   addPair(rootContext, "pushInfile",    createPrimitive(pPushInfile));
  2881.   addPair(rootContext, "popInfile",        createPrimitive(pPopInfile));
  2882.   addPair(rootContext, "resetInfiles",    createPrimitive(pResetInfiles));
  2883.   addPair(rootContext, "pushOutfile",    createPrimitive(pPushOutfile));
  2884.   addPair(rootContext, "popOutfile",    createPrimitive(pPopOutfile));
  2885.   addPair(rootContext, "resetOutfiles",    createPrimitive(pResetOutfiles));
  2886.   addPair(rootContext, "errorTo",        createPrimitive(pErrfilePush));
  2887.   addPair(rootContext, "consoleTo",        createPrimitive(pConfilePush));
  2888.  
  2889.  
  2890.   /* Block file primitives */
  2891.   /* (defined in a separate file) */
  2892.   addPair(rootContext, "open-blockfile",createPrimitive(pOpenBlockFile));
  2893.   addPair(rootContext, "close-blockfile",createPrimitive(pCloseBlockFile));
  2894.   addPair(rootContext, "block",            createPrimitive(pBlock));
  2895.   addPair(rootContext, "update",        createPrimitive(pUpdate));
  2896.   addPair(rootContext, "discard",        createPrimitive(pDiscard));
  2897.   addPair(rootContext, "save-buffers",    createPrimitive(pSaveBuffers));
  2898.   addPair(rootContext, "empty-buffers",    createPrimitive(pEmptyBuffers));
  2899.   addPair(rootContext, "more",            createPrimitive(pMore));
  2900.   addPair(rootContext, "capacity",        createPrimitive(pCapacity));
  2901.  
  2902.  
  2903.   /* Dictionary primitives */
  2904.   addPair(rootContext, "number",        createPrimitive(pNumber));
  2905.   addPair(rootContext, "search",         createPrimitive(pSearch));
  2906.   addPair(rootContext, "searchThis",     createPrimitive(pSearchThis));
  2907.   addPair(rootContext, "immediate?",    createPrimitive(pQImmed));
  2908.  
  2909.  
  2910.   /* Internal structure primitives */
  2911.   addPair(rootContext, "<buildContext>",createPrimitive(pBuildCtxt)); hide();
  2912.   addPair(rootContext, "<buildName>",     createPrimitive(pBuildPair)); hide();
  2913.   addPair(rootContext, "<buildObject>",    createPrimitive(pBuildObj)); hide();
  2914.   addPair(rootContext, "<buildStore>",    createPrimitive(pBuildStore)); hide();
  2915.   addPair(rootContext, "<buildString>",    createPrimitive(pBuildStr)); hide();
  2916.   addPair(rootContext, "<buildBGTask>",    createPrimitive(pBuildBGTask)); hide();
  2917.   addPair(rootContext, "<deleteTask>",    createPrimitive(pDeleteTask)); hide();
  2918.   addPair(rootContext, "<killTask>",    createPrimitive(pKillTask)); hide();
  2919.   addPair(rootContext, "<deleteName>",    createPrimitive(pDeleteName)); hide();
  2920.   addPair(rootContext, "<renameName>",    createPrimitive(pRenameName)); hide();
  2921.   addPair(rootContext, "<mkdir>",        createPrimitive(pBuildDir)); hide();
  2922.   addPair(rootContext, "<shallowCopy>",    createPrimitive(pShallowCopyObj)); hide();
  2923.   addPair(rootContext, "<derive>",        createPrimitive(pDeriveObject)); hide();
  2924.   addPair(rootContext, "<resize>",        createPrimitive(pResizeObj)); hide();
  2925.   addPair(rootContext, "<expand>",        createPrimitive(pExpandObj)); hide();
  2926.   addPair(rootContext, "<expandFamily>",createPrimitive(pExpandFamily)); hide();
  2927.   addPair(rootContext, "<optimize>",    createPrimitive(pOptimizeObj)); hide();
  2928.   addPair(rootContext, "<dispose>",        createPrimitive(pDisposeObject)); hide();
  2929.   addPair(rootContext, "<free>",        createPrimitive(pFree)); hide();
  2930.   addPair(rootContext, "<freeStore>",    createPrimitive(pFreeStore)); hide();
  2931.   addPair(rootContext, "<recompile>",    createPrimitive(pRecompile)); hide();
  2932.   addPair(rootContext, "<rebind>",        createPrimitive(pRebind)); hide();
  2933.   addPair(rootContext, "<reorganize>",    createPrimitive(pReorganize)); hide();
  2934.   addPair(rootContext, "<rePair>",        createPrimitive(pRePair)); hide();
  2935.  
  2936.  
  2937.   /* Internal structure offsets */
  2938.   addPair(rootContext, "name>object",    createPrimitive(pPairToObj)); hide();
  2939.   addPair(rootContext, "name'object",    createPrimitive(pPairOFA)); hide();
  2940.   addPair(rootContext, "name'name",        createPrimitive(pPairNFA)); hide();
  2941.   addPair(rootContext, "name'flags",    createPrimitive(pPairFFA)); hide();
  2942.   addPair(rootContext, "name'prev",        createPrimitive(pPairLFA)); hide();
  2943.   addPair(rootContext, "name'succ",        createPrimitive(pPairSFA)); hide();
  2944.   addPair(rootContext, "name'context",    createPrimitive(pPairCFA)); hide();
  2945.   addPair(rootContext, "object>name",    createPrimitive(pObjToPair)); hide();
  2946.   addPair(rootContext, "object>typename",createPrimitive(pObjToTypeName)); hide();
  2947.   addPair(rootContext, "object>store",    createPrimitive(pObjToStore)); hide();
  2948.   addPair(rootContext, "object'store",    createPrimitive(pObjectMFA)); hide();
  2949.   addPair(rootContext, "object'size",    createPrimitive(pObjectSFA)); hide();
  2950.   addPair(rootContext, "object>context",createPrimitive(pObjToContext)); hide();
  2951.   addPair(rootContext, "context'thread",createPrimitive(pContextThread)); hide();
  2952.   addPair(rootContext, "context'first", createPrimitive(pContextFirst)); hide();
  2953.   addPair(rootContext, "context'latest",createPrimitive(pContextLatest)); hide();
  2954.   addPair(rootContext, "context'family",createPrimitive(pContextFamily)); hide();
  2955.   addPair(rootContext, "context'parents",createPrimitive(pContextParents)); hide();
  2956.   addPair(rootContext, "context'children",createPrimitive(pContextChildren)); hide();
  2957.   addPair(rootContext, "checkSystemValidity",createPrimitive(pCheckSystem)); 
  2958.  
  2959.  
  2960.   /* Object-oriented primitives */
  2961.   addPair(rootContext, "self",        createPrimitive(pSelf));
  2962.   addPair(rootContext, "&",            createPrimitive(pPrevSelf));
  2963.   addPair(rootContext, ">self",        createPrimitive(pToSelf)); hide();
  2964.   addPair(rootContext, "self>",        createPrimitive(pSelfFrom)); hide();
  2965.   addPair(rootContext, "self>drop",    createPrimitive(pSelfDrop)); hide();
  2966.   addPair(rootContext, "resetCp",    createPrimitive(resetContext)); hide();
  2967.   addPair(rootContext, "cdepth",    createPrimitive(pCDepth));
  2968.   addPair(rootContext, ".cs",        createPrimitive(pPrintCStack));
  2969.   addPair(rootContext, "resizeContextStack",createPrimitive(pResizeContext));
  2970.   addPair(rootContext, ">send",        createPrimitive(pSend)); hide();
  2971.   addPair(rootContext, ">resend",    createPrimitive(pResend)); hide();
  2972.   addPair(rootContext, "respondsTo",createPrimitive(pRespondsTo));
  2973.   addPair(rootContext, "hasContext", createPrimitive(pHasContext));
  2974.   addPair(rootContext, ">area",     createPrimitive(pToArea));
  2975.   addPair(rootContext, "area0",     createPrimitive(pAreaZero));
  2976.   addPair(rootContext, "area#",     createPrimitive(pAreaSize));
  2977.  
  2978. }
  2979.  
  2980.  
  2981.