home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / dev / alst-3.04.lha / ALSt-3.04 / src / primitive.c < prev    next >
C/C++ Source or Header  |  1994-05-14  |  16KB  |  663 lines

  1. /*
  2.     Little Smalltalk, version 3
  3.     Written by Tim Budd, Oregon State University, July 1988
  4.  
  5.     Primitive processor
  6.  
  7.     primitives are how actions are ultimately executed in the Smalltalk 
  8.     system.
  9.     unlike ST-80, Little Smalltalk primitives cannot fail (although
  10.     they can return nil, and methods can take this as an indication
  11.     of failure).  In this respect primitives in Little Smalltalk are
  12.     much more like traditional system calls.
  13.  
  14.     Primitives are combined into groups of 10 according to 
  15.     argument count and type, and in some cases type checking is performed.
  16.  
  17.     IMPORTANT NOTE:
  18.         The technique used to tell if an arithmetic operation
  19.         has overflowed in intBinary() depends upon integers
  20.         being 16 bits.  If this is not true, other techniques
  21.         may be required.
  22.     
  23.     system specific I/O primitives are found in a different file.
  24. */
  25.  
  26. # include <stdio.h>
  27. # include <math.h>
  28. # include "env.h"
  29. # include "memory.h"
  30. # include "names.h"
  31. # ifdef STRING
  32. # include <string.h>
  33. # endif
  34. # ifdef STRINGS
  35. # include <strings.h>
  36. # endif
  37.  
  38. # ifdef SIGNAL
  39. # include <signal.h>
  40. # include <setjmp.h>
  41. # endif
  42. # ifdef CTRLBRK
  43. # include <dos.h>
  44. # include <signal.h>
  45. # include <setjmp.h>
  46. # endif
  47.  
  48. extern object processStack;
  49. extern int linkPointer;
  50.  
  51. #ifdef AZTEC_C
  52. extern double frexp(double, int *), ldexp(double, int);
  53. #else
  54. extern double frexp(), ldexp();
  55. #endif
  56.  
  57. extern long time();
  58. extern object ioPrimitive(INT X OBJP);
  59. extern object sysPrimitive(INT X OBJP);
  60.  
  61. # ifdef SIGNAL
  62. static jmp_buf jb;
  63. brkfun() { longjmp(jb, 1); }
  64. brkignore() {;}
  65. # endif
  66. # ifdef CTRLBRK
  67. static jmp_buf jb;
  68. brkfun() { longjmp(jb, 1); }
  69. brkignore() {;}
  70. # endif
  71.  
  72. static object zeroaryPrims(number)
  73. int number;
  74. {    short i;
  75.     object returnedObject;
  76.     int objectCount();
  77.  
  78.     returnedObject = nilobj;
  79.     switch(number) {
  80.  
  81.         case 1:
  82.             fprintf(stderr,"did primitive 1\n");
  83.             break;
  84.  
  85.         case 2:
  86.             fprintf(stderr,"object count %d\n", objectCount());
  87.             break;
  88.  
  89.         case 3:            /* return a random number */
  90.             /* this is hacked because of the representation */
  91.             /* of integers as shorts */
  92.             i = rand() >> 8;    /* strip off lower bits */
  93.             if (i < 0) i = - i;
  94.             returnedObject = newInteger(i>>1);
  95.             break;
  96.  
  97.         case 4:        /* return time in seconds */
  98.             i = (short) time((long *) 0);
  99.             returnedObject = newInteger(i);
  100.             break;
  101.  
  102.         case 5:        /* flip watch - done in interp */
  103.             break;
  104.  
  105.         case 9:
  106.             exit(0);
  107.  
  108.         default:        /* unknown primitive */
  109.             sysError("unknown primitive","zeroargPrims");
  110.             break;
  111.     }
  112.     return(returnedObject);
  113. }
  114.  
  115. static int unaryPrims(number, firstarg)
  116. int number;
  117. object firstarg;
  118. {    int i, j, saveLinkPointer;
  119.     object returnedObject, saveProcessStack;
  120.  
  121.     returnedObject = firstarg;
  122.     switch(number) {
  123.         case 1:        /* class of object */
  124.             returnedObject = getClass(firstarg);
  125.             break;
  126.  
  127.         case 2:        /* basic size of object */
  128.             if (isInteger(firstarg))
  129.                 i = 0;
  130.             else {
  131.                 i = sizeField(firstarg);
  132.                 /* byte objects have negative size */
  133.                 if (i < 0) i = (-i);
  134.                 }
  135.             returnedObject = newInteger(i);
  136.             break;
  137.  
  138.         case 3:        /* hash value of object */
  139.             if (isInteger(firstarg))
  140.                 returnedObject = firstarg;
  141.             else
  142.                 returnedObject = newInteger(firstarg);
  143.             break;
  144.  
  145.         case 4:        /* debugging print */
  146.             fprintf(stderr,"primitive 14 %d\n", firstarg);
  147.             break;
  148.  
  149.         case 8:        /* change return point - block return */
  150.             /* first get previous link pointer */
  151.             i = intValue(basicAt(processStack, linkPointer));
  152.             /* then creating context pointer */
  153.             j = intValue(basicAt(firstarg, 1));
  154.             if (basicAt(processStack, j+1) != firstarg) {
  155.                 returnedObject = falseobj;
  156.                 break;
  157.                 }
  158.             /* first change link pointer to that of creator */
  159.             fieldAtPut(processStack, i, 
  160.                 basicAt(processStack, j));
  161.             /* then change return point to that of creator */
  162.             fieldAtPut(processStack, i+2, 
  163.                 basicAt(processStack, j+2));
  164.             returnedObject = trueobj;
  165.             break;
  166.  
  167.         case 9:            /* process execute */
  168.             /* first save the values we are about to clobber */
  169.             saveProcessStack = processStack;
  170.             saveLinkPointer = linkPointer;
  171. # ifdef SIGNAL
  172.             /* trap control-C */
  173.             signal(SIGINT, brkfun);
  174.             if (setjmp(jb)) {
  175.                 returnedObject = falseobj;
  176.                 }
  177.             else
  178. # endif
  179. # ifdef CRTLBRK
  180.             /* trap control-C using dos ctrlbrk routine */
  181.             ctrlbrk(brkfun);
  182.             if (setjmp(jb)) {
  183.                 returnedObject = falseobj;
  184.                 }
  185.             else
  186. # endif
  187.             if (execute(firstarg, 5000))
  188.                 returnedObject = trueobj;
  189.             else
  190.                 returnedObject = falseobj;
  191.             /* then restore previous environment */
  192.             processStack = saveProcessStack;
  193.             linkPointer = saveLinkPointer;
  194. # ifdef SIGNAL
  195.             signal(SIGINT, brkignore);
  196. # endif
  197. # ifdef CTRLBRK
  198.             ctrlbrk(brkignore);
  199. # endif
  200.             break;
  201.  
  202.         default:        /* unknown primitive */
  203.             sysError("unknown primitive","unaryPrims");
  204.             break;
  205.     }
  206.     return(returnedObject);
  207. }
  208.  
  209. static int binaryPrims(number, firstarg, secondarg)
  210. int number;
  211. object firstarg, secondarg;
  212. {    char buffer[2000];
  213.     int i;
  214.     object returnedObject;
  215.  
  216.     returnedObject = firstarg;
  217.     switch(number) {
  218.         case 1:        /* object identity test */
  219.             if (firstarg == secondarg)
  220.                 returnedObject = trueobj;
  221.             else
  222.                 returnedObject = falseobj;
  223.             break;
  224.  
  225.         case 2:        /* set class of object */
  226.             decr(classField(firstarg));
  227.             setClass(firstarg, secondarg);
  228.             returnedObject = firstarg;
  229.             break;
  230.  
  231.         case 3:        /* debugging stuff */
  232.             fprintf(stderr,"primitive 23 %d %d\n", firstarg, secondarg);
  233.             break;
  234.  
  235.         case 4:        /* string cat */
  236.             ignore strcpy(buffer, charPtr(firstarg));
  237.             ignore strcat(buffer, charPtr(secondarg));
  238.             returnedObject = newStString(buffer);
  239.             break;
  240.         
  241.         case 5:        /* basicAt: */
  242.             if (! isInteger(secondarg))
  243.                 sysError("non integer index","basicAt:");
  244.             returnedObject = basicAt(firstarg, intValue(secondarg));
  245.             break;
  246.  
  247.         case 6:        /* byteAt: */
  248.             if (! isInteger(secondarg))
  249.                 sysError("non integer index","byteAt:");
  250.             i = byteAt(firstarg, intValue(secondarg));
  251.             if (i < 0) i += 256;
  252.             returnedObject = newInteger(i);
  253.             break;
  254.  
  255.         case 7:        /* symbol set */
  256.             nameTableInsert(symbols, strHash(charPtr(firstarg)),
  257.                     firstarg, secondarg);
  258.             break;
  259.             
  260.         case 8:        /* block start */
  261.             /* first get previous link */
  262.             i = intValue(basicAt(processStack, linkPointer));
  263.             /* change context and byte pointer */
  264.             fieldAtPut(processStack, i+1, firstarg);
  265.             fieldAtPut(processStack, i+4, secondarg);
  266.             break;
  267.  
  268.         case 9:        /* duplicate a block, adding a new context to it */
  269.             returnedObject = newBlock();
  270.             basicAtPut(returnedObject, 1, secondarg);
  271.             basicAtPut(returnedObject, 2, basicAt(firstarg, 2));
  272.             basicAtPut(returnedObject, 3, basicAt(firstarg, 3));
  273.             basicAtPut(returnedObject, 4, basicAt(firstarg, 4));
  274.             break;
  275.  
  276.         default:        /* unknown primitive */
  277.             sysError("unknown primitive","binaryPrims");
  278.             break;
  279.  
  280.     }
  281.     return(returnedObject);
  282. }
  283.  
  284. static int trinaryPrims(number, firstarg, secondarg, thirdarg)
  285. int number;
  286. object firstarg, secondarg, thirdarg;
  287. {    char *bp, *tp, buffer[256];
  288.     int i, j;
  289.     object returnedObject;
  290.  
  291.     returnedObject = firstarg;
  292.     switch(number) {
  293.         case 1:            /* basicAt:Put: */
  294.             if (! isInteger(secondarg))
  295.                 sysError("non integer index","basicAtPut");
  296. fprintf(stderr,"IN BASICATPUT %d %d %d\n", firstarg, intValue(secondarg), thirdarg);
  297.             fieldAtPut(firstarg, intValue(secondarg), thirdarg);
  298.             break;
  299.  
  300.         case 2:            /* basicAt:Put: for bytes */
  301.             if (! isInteger(secondarg))
  302.                 sysError("non integer index","byteAtPut");
  303.             if (! isInteger(thirdarg))
  304.                 sysError("assigning non int","to byte");
  305.             byteAtPut(firstarg, intValue(secondarg),
  306.                     intValue(thirdarg));
  307.             break;
  308.  
  309.         case 3:            /* string copyFrom:to: */
  310.             bp = charPtr(firstarg);
  311.             if ((! isInteger(secondarg)) || (! isInteger(thirdarg)))
  312.                 sysError("non integer index","copyFromTo");
  313.             i = intValue(secondarg);
  314.             j = intValue(thirdarg);
  315.             tp = buffer;
  316.             if (i <= strlen(bp))
  317.                 for ( ; (i <= j) && bp[i-1]; i++)
  318.                     *tp++ = bp[i-1];
  319.             *tp = '\0';
  320.             returnedObject = newStString(buffer);
  321.             break;
  322.  
  323.         case 9:            /* compile method */
  324.             setInstanceVariables(firstarg);
  325.             if (parse(thirdarg, charPtr(secondarg), false)) {
  326.                 flushCache(basicAt(thirdarg, messageInMethod), firstarg);
  327.                 returnedObject = trueobj;
  328.                 }
  329.             else
  330.                 returnedObject = falseobj;
  331.             break;
  332.         
  333.         default:        /* unknown primitive */
  334.             sysError(