home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 116.lha / SmallTalk / Sources / PRIMITIVE.C < prev    next >
Encoding:
C/C++ Source or Header  |  1986-11-20  |  14.2 KB  |  635 lines
  1. /*
  2.     Little Smalltalk, version 2
  3.     Written by Tim Budd, Oregon State University, July 1987
  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.  
  24. # include <stdio.h>
  25. # include <math.h>
  26. # include "env.h"
  27. # include "memory.h"
  28. # include "names.h"
  29. # include "process.h"
  30. # ifdef STRING
  31. # include <string.h>
  32. # endif
  33. # ifdef STRINGS
  34. # include <strings.h>
  35. # endif
  36.  
  37. # define normalresult 1
  38. # define counterror 2
  39. # define typeerror  3
  40. # define quitinterp 4
  41.  
  42. extern object doInterp(OBJ);
  43. extern noreturn flushMessageCache();
  44. extern double modf();
  45. extern char *getenv();
  46.  
  47. static int zeroaryPrims(number)
  48. int number;
  49. {     short i;
  50.  
  51.     returnedObject = nilobj;
  52.     switch(number) {
  53.         case 2:
  54.             flushMessageCache();
  55.             break;
  56.  
  57.         case 3:            /* return a random number */
  58.             /* this is hacked because of the representation */
  59.             /* of integers as shorts */
  60.             i = rand() >> 8;    /* strip off lower bits */
  61.             if (i < 0) i = - i;
  62.             returnedObject = newInteger(i>>1);
  63.             break;
  64.  
  65.         default:        /* unknown primitive */
  66.             sysError("unknown primitive","zeroargPrims");
  67.             break;
  68.     }
  69.     return(normalresult);
  70. }
  71.  
  72. static int unaryPrims(number, firstarg)
  73. int number;
  74. object firstarg;
  75. {
  76.  
  77.     returnedObject = firstarg;
  78.     switch(number) {
  79.         case 1:        /* class of object */
  80.             returnedObject = getClass(firstarg);
  81.             break;
  82.  
  83.         case 2:        /* basic size of object */
  84.             if (isInteger(firstarg))
  85.                 returnedObject = newInteger(0);
  86.             else
  87.                 returnedObject = newInteger(objectSize(firstarg));
  88.             break;
  89.  
  90.         case 3:        /* hash value of object */
  91.             if (isInteger(firstarg))
  92.                 returnedObject = firstarg;
  93.             else
  94.                 returnedObject = newInteger(firstarg);
  95.             break;
  96.  
  97.         case 9:        /* interpreter bytecodes */
  98.             returnedObject = doInterp(firstarg);
  99.             break;
  100.  
  101.         default:        /* unknown primitive */
  102.             sysError("unknown primitive","unaryPrims");
  103.             break;
  104.     }
  105.     return(normalresult);
  106. }
  107.  
  108. static int binaryPrims(number, firstarg, secondarg)
  109. int number;
  110. object firstarg, secondarg;
  111. {    char buffer[512];
  112.     int i;
  113.  
  114.     returnedObject = firstarg;
  115.     switch(number) {
  116.         case 1:        /* object identity test */
  117.             if (firstarg == secondarg)
  118.                 returnedObject = trueobj;
  119.             else
  120.                 returnedObject = falseobj;
  121.             break;
  122.  
  123.         case 2:        /* set class of object */
  124.             decr(classField(firstarg));
  125.             setClass(firstarg, secondarg);
  126.             returnedObject = firstarg;
  127.             break;
  128.  
  129.         case 4:        /* string cat */
  130.             ignore strcpy(buffer, charPtr(firstarg));
  131.             ignore strcat(buffer, charPtr(secondarg));
  132.             returnedObject = newStString(buffer);
  133.             break;
  134.         
  135.         case 5:        /* basicAt: */
  136.             if (! isInteger(secondarg))
  137.                 sysError("non integer index","basicAt:");
  138.             returnedObject = basicAt(firstarg, intValue(secondarg));
  139.             break;
  140.  
  141.         case 6:        /* byteAt: */
  142.             if (! isInteger(secondarg))
  143.                 sysError("non integer index","bytAte:");
  144.             i = byteAt(firstarg, intValue(secondarg));
  145.             if (i < 0) i += 256;
  146.             returnedObject = newInteger(i);
  147.             break;
  148.  
  149.         default:        /* unknown primitive */
  150.             sysError("unknown primitive","binaryPrims");
  151.             break;
  152.  
  153.     }
  154.     return(normalresult);
  155. }
  156.  
  157. static int trinaryPrims(number, firstarg, secondarg, thirdarg)
  158. int number;
  159. object firstarg, secondarg, thirdarg;
  160. {    char *bp, *tp, buffer[256];
  161.     int i, j;
  162.  
  163.     returnedObject = firstarg;
  164.     switch(number) {
  165.         case 1:            /* basicAt:Put: */
  166.             if (! isInteger(secondarg))
  167.                 sysError("non integer index","basicAtPut");
  168.             basicAtPut(firstarg, intValue(secondarg), thirdarg);
  169.             break;
  170.  
  171.         case 2:            /* basicAt:Put: for bytes */
  172.             if (! isInteger(secondarg))
  173.                 sysError("non integer index","byteAtPut");
  174.             if (! isInteger(thirdarg))
  175.                 sysError("assigning non int","to byte");
  176.             byteAtPut(firstarg, intValue(secondarg),
  177.                     intValue(thirdarg));
  178.             break;
  179.  
  180.         case 3:            /* string copyFrom:to: */
  181.             bp = charPtr(firstarg);
  182.             if ((! isInteger(secondarg)) || (! isInteger(thirdarg)))
  183.                 sysError("non integer index","copyFromTo");
  184.             i = intValue(secondarg);
  185.             j = intValue(thirdarg);
  186.             tp = buffer;
  187.             if (i <= strlen(bp))
  188.                 for ( ; (i <= j) && bp[i-1]; i++)
  189.                     *tp++ = bp[i-1];
  190.             *tp = '\0';
  191.             returnedObject = newStString(buffer);
  192.             break;
  193.  
  194.         case 8:        /* execute a context */
  195.             messageToSend = firstarg;
  196.             if (! isInteger(secondarg))
  197.                 sysError("non integer index","executeAt:");
  198.             argumentsOnStack = intValue(secondarg);
  199.             creator = thirdarg;
  200.             finalTask = ContextExecuteTask;
  201.             return(quitinterp);
  202.  
  203.         case 9:            /* compile method */
  204.             setInstanceVariables(firstarg);
  205.             if (parse(thirdarg, charPtr(secondarg)))
  206.                 returnedObject = trueobj;
  207.             else
  208.                 returnedObject = falseobj;
  209.             break;
  210.         
  211.         default:        /* unknown primitive */
  212.             sysError("unknown primitive","trinaryPrims");
  213.             break;
  214.         }
  215.     return(normalresult);
  216. }
  217.  
  218. static int intUnary(number, firstarg)
  219. int number, firstarg;
  220. {    char buffer[20];
  221.  
  222.     switch(number) {
  223.         case 1:        /* float equiv of integer */
  224.             returnedObject = newFloat((double) firstarg);
  225.             break;
  226.  
  227.         case 5:        /* set random number */
  228.             ignore srand((unsigned) firstarg);
  229.             returnedObject = nilobj;
  230.             break;
  231.  
  232.         case 7:        /* string equiv of number */
  233.             ignore sprintf(buffer,"%d",firstarg);
  234.             returnedObject = newStString(buffer);
  235.             break;
  236.  
  237.         case 8:
  238.             returnedObject = allocObject(firstarg);
  239.             break;
  240.  
  241.         case 9:
  242.             returnedObject = allocByte(firstarg);
  243.             break;
  244.  
  245.         default:
  246.             sysError("intUnary primitive","not implemented yet");
  247.         }
  248.     return(normalresult);
  249. }
  250.  
  251. int intBinary(number, firstarg, secondarg)
  252. register int firstarg, secondarg;
  253. int number;
  254. {    boolean binresult;
  255.     long longresult;
  256.  
  257.     switch(number) {
  258.         case 0:        /* addition */
  259.             longresult = firstarg;
  260.             longresult += secondarg;
  261.             if (longCanBeInt(longresult))
  262.                 firstarg = longresult; 
  263.             else
  264.                 goto overflow;
  265.             break;
  266.         case 1:        /* subtraction */
  267.             longresult = firstarg;
  268.             longresult -= secondarg;
  269.             if (longCanBeInt(longresult))
  270.                 firstarg = longresult;
  271.             else
  272.                 goto overflow;
  273.             break;
  274.  
  275.         case 2:        /* relationals */
  276.             binresult = firstarg < secondarg; break;
  277.         case 3:
  278.             binresult = firstarg > secondarg; break;
  279.         case 4:
  280.             binresult = firstarg <= secondarg; break;
  281.         case 5:
  282.             binresult = firstarg >= secondarg; break;
  283.         case 6:
  284.             binresult = firstarg == secondarg; break;
  285.         case 7:
  286.             binresult = firstarg != secondarg; break;
  287.  
  288.         case 8:        /* multiplication */
  289.             longresult = firstarg;
  290.             longresult *= secondarg;
  291.             if (longCanBeInt(longresult))
  292.                 firstarg = longresult;
  293.             else
  294.                 goto overflow;
  295.             break;
  296.  
  297.         case 9:        /* quo: */
  298.             if (secondarg == 0) goto overflow;
  299.             firstarg /= secondarg; break;
  300.  
  301.         case 10:    /* rem: */
  302.             if (secondarg == 0) goto overflow;
  303.             firstarg %= secondarg; break;
  304.  
  305.         case 11:    /* bit operations */
  306.             firstarg &= secondarg; break;
  307.         case 12:
  308.             firstarg ^= secondarg; break;
  309.             
  310.         case 19:    /* shifts */
  311.             if (secondarg < 0)
  312.                 firstarg >>= (- secondarg);
  313.             else
  314.                 firstarg <<= secondarg;
  315.             break;
  316.     }
  317.     if ((number >= 2) && (number <= 7))
  318.         if (binresult)
  319.             returnedObject = trueobj;
  320.         else
  321.             returnedObject = falseobj;
  322.     else
  323.         returnedObject = newInteger(firstarg);
  324.     return(normalresult);
  325.  
  326.         /* on overflow, return nil and let smalltalk code */
  327.         /* figure out what to do */
  328. overflow:
  329.     returnedObject = nilobj;
  330.     return(normalresult);
  331. }
  332.  
  333. static int strUnary(number, firstargument)
  334. int number;
  335. char *firstargument;
  336. {
  337.     switch(number) {
  338.         case 1:        /* length of string */
  339.             returnedObject = newInteger(strlen(firstargument));
  340.             break;
  341.  
  342.         case 3:        /* string as symbol */
  343.             returnedObject = newSymbol(firstargument);
  344.             break;
  345.  
  346.         case 8:        /* do a system call */
  347.             returnedObject = newInteger(system(firstargument));
  348.             break;
  349.  
  350.         default:
  351.             sysError("unknown primitive", "strUnary");
  352.             break;
  353.         }
  354.  
  355.     return(normalresult);
  356. }
  357.  
  358. static int floatUnary(number, firstarg)
  359. int number;
  360. double firstarg;
  361. {    char buffer[20];
  362.     double temp;
  363.  
  364.     switch(number) {
  365.         case 1:        /* asString */
  366.             ignore sprintf(buffer,"%g", firstarg);
  367.             returnedObject = newStString(buffer);
  368.             break;
  369.  
  370.         case 2:        /* log */
  371.             returnedObject = newFloat(log(firstarg));
  372.             break;
  373.  
  374.         case 3:        /* exp */
  375.             returnedObject = newFloat(exp(firstarg));
  376.             break;
  377.  
  378.         case 4:        /* sqrt */
  379.             returnedObject = newFloat(sqrt(firstarg));
  380.             break;
  381.  
  382.         case 6:        /* integer part */
  383.             ignore modf(firstarg, &temp);
  384.             returnedObject = newInteger((int) temp);
  385.             break;
  386.  
  387.         default:
  388.             sysError("unknown primitive","floatUnary");
  389.             break;
  390.         }
  391.  
  392.     return(normalresult);
  393. }
  394.  
  395. int floatBinary(number, first, second)
  396. int number;
  397. double first, second;
  398. {     boolean binResult;
  399.  
  400.     switch(number) {
  401.         case 0: first += second; break;
  402.  
  403.         case 1:    first -= second; break;
  404.         case 2: binResult = (first < second); break;
  405.         case 3: binResult = (first > second); break;
  406.         case 4: binResult = (first <= second); break;
  407.         case 5: binResult = (first >= second); break;
  408.         case 6: binResult = (first == second); break;
  409.         case 7: binResult = (first != second); break;
  410.         case 8: first *= second; break;
  411.         case 9: first /= second; break;
  412.         default:    
  413.             sysError("unknown primitive", "floatBinary");
  414.             break;
  415.         }
  416.  
  417.     if ((number >= 2) && (number <= 7))
  418.         if (binResult)
  419.             returnedObject = trueobj;
  420.         else
  421.             returnedObject = falseobj;
  422.     else
  423.         returnedObject = newFloat(first);
  424.     return(normalresult);
  425. }
  426.  
  427. /* file primitives - necessaryily rather UNIX dependent;
  428.     basically, files are all kept in a large array.
  429.     File operations then just give an index into this array 
  430. */
  431. # define MAXFILES 20
  432. /* we assume this is initialized to NULL */
  433. static FILE *filepointers[MAXFILES];
  434.  
  435. static int filePrimitive(number, arguments, size)
  436. int number, size;
  437. object *arguments;
  438. {    int i;
  439.     char *p, buffer[512];
  440.  
  441.     returnedObject = nilobj;
  442.  
  443.     if (number) {        /* not an open, we can get file number*/
  444.         if (! isInteger(arguments[0]))
  445.             return(typeerror);
  446.         i = intValue(arguments[0]);
  447.         }
  448.  
  449.     switch(number) {
  450.         case 0:        /* file open */
  451.                 /* first find a free slot */
  452.             for (i = 0; i < MAXFILES; i++)
  453.                 if (filepointers[i] == NULL)
  454.                     break;
  455.             if (i >= MAXFILES)
  456.                 sysError("too many open files","primitive");
  457.  
  458.             p = charPtr(arguments[0]);
  459.             if (streq(p, "stdin")) 
  460.                 filepointers[i] = stdin;
  461.             else if (streq(p, "stdout"))
  462.                 filepointers[i] = stdout;
  463.             else if (streq(p, "stderr"))
  464.                 filepointers[i] = stderr;
  465.             else {
  466.                 filepointers[i] = fopen(p, charPtr(arguments[1]));
  467.                 }
  468.             if (filepointers[i] == NULL)
  469.                 returnedObject = nilobj;
  470.             else
  471.                 returnedObject = newInteger(i);
  472.             break;
  473.  
  474.         case 1:        /* file close - recover slot */
  475.             ignore fclose(filepointers[i]);
  476.             filepointers[i] = NULL;
  477.             break;
  478.  
  479.         case 2:        /* file size */
  480.         case 3:        /* file seek */
  481.         case 4:        /* get character */
  482.             sysError("file operation not implemented yet","");
  483.  
  484.         case 5:        /* get string */
  485.             if (fgets(buffer, 512, filepointers[i]) != NULL) {
  486.                 if (filepointers[i] == stdin) {
  487.                     /* delete the newline */
  488.                     i = strlen(buffer);
  489.                     if (buffer[i-1] == '\n')
  490.                         buffer[i-1] = '\0';
  491.                     }
  492.                 returnedObject = newStString(buffer);
  493.                 }
  494.             break;
  495.  
  496.         case 7:        /* write an object image */
  497.             imageWrite(filepointers[i]);
  498.             returnedObject = trueobj;
  499.             break;
  500.  
  501.         case 8:        /* print no return */
  502.         case 9:        /* print string */
  503.             ignore fputs(charPtr(arguments[1]), filepointers[i]);
  504.             if (number == 8)
  505.                 ignore fflush(filepointers[i]);
  506.             else
  507.                 ignore fputc('\n', filepointers[i]);
  508.             break;
  509.  
  510.         default:
  511.             sysError("unknown primitive","filePrimitive");
  512.         }
  513.  
  514.     return(normalresult);
  515. }
  516.  
  517. /* primitive -
  518.     the main driver for the primitive handler
  519. */
  520. boolean primitive(primitiveNumber, arguments, size)
  521. int primitiveNumber, size;
  522. object *arguments;
  523. {    int primitiveGroup;
  524.     boolean done = false;
  525.     int response;
  526.  
  527.     primitiveGroup = primitiveNumber / 10;
  528.     response = normalresult;
  529.     switch(primitiveGroup) {
  530.         case 0: case 1: case 2: case 3:
  531.             if (size != primitiveGroup)
  532.                 response = counterror;
  533.             else {
  534.                 switch(primitiveGroup) {
  535.                     case 0:
  536.                         response = zeroaryPrims(primitiveNumber);
  537.                         break;
  538.                     case 1:
  539.                         response = unaryPrims(primitiveNumber - 10, arguments[0]);
  540.                         break;
  541.                     case 2:
  542.                         response = binaryPrims(primitiveNumber-20, arguments[0], arguments[1]);
  543.                         break;
  544.                     case 3:
  545.                         response = trinaryPrims(primitiveNumber-30, arguments[0], arguments[1], arguments[2]);
  546.                         break;
  547.                 }
  548.             }
  549.             break;
  550.  
  551.  
  552.         case 5:            /* integer unary operations */
  553.             if (size != 1)
  554.                 response = counterror;
  555.             else if (! isInteger(arguments[0]))
  556.                 response = typeerror;
  557.             else
  558.                 response = intUnary(primitiveNumber-50,
  559.                         intValue(arguments[0]));
  560.             break;
  561.  
  562.         case 6: case 7:        /* integer binary operations */
  563.             if (size != 2)
  564.                 response = counterror;
  565.             else if ((! isInteger(arguments[0])) || 
  566.                   ! isInteger(arguments[1]))
  567.                 response = typeerror;
  568.             else
  569.                 response = intBinary(primitiveNumber-60,
  570.                     intValue(arguments[0]), 
  571.                     intValue(arguments[1]));
  572.             break;
  573.  
  574.         case 8:            /* string unary */
  575.             if (size != 1)
  576.                 response = counterror;
  577.             else if (! isString(arguments[0]))
  578.                 response = typeerror;
  579.             else
  580.                 response = strUnary(primitiveNumber-80,
  581.                     charPtr(arguments[0]));
  582.             break;
  583.  
  584.         case 10:        /* float unary */
  585.             if (size != 1)
  586.                 response = counterror;
  587.             else if (! isFloat(arguments[0]))
  588.                 response = typeerror;
  589.             else
  590.                 response = floatUnary(primitiveNumber-100,
  591.                     floatValue(arguments[0]));
  592.             break;
  593.  
  594.         case 11:        /* float binary */
  595.             if (size != 2)
  596.                 response = counterror;
  597.             else if ((! isFloat(arguments[0])) ||
  598.                  (! isFloat(arguments[1])))
  599.                 response = typeerror;
  600.             else
  601.                 response = floatBinary(primitiveNumber-110,
  602.                     floatValue(arguments[0]),
  603.                     floatValue(arguments[1]));
  604.             break;
  605.  
  606.         case 12:        /* file operations */
  607.             response = filePrimitive(primitiveNumber-120,
  608.                 arguments, size);
  609.             break;
  610.     }
  611.  
  612.     /* now check return code */
  613.     switch(response) {
  614.         case normalresult:
  615.             break;
  616.         case quitinterp:
  617.             done = true;
  618.             break;
  619.         case counterror:
  620.             sysError("count error","in primitive");
  621.             break;
  622.         case typeerror:
  623.             sysError("type error","in primitive");
  624.             returnedObject = nilobj;
  625.             break;
  626.  
  627.         default:
  628.             sysError("unknown return code","in primitive");
  629.             returnedObject = nilobj;
  630.             break;
  631.     }
  632.     return (done);
  633. }
  634.  
  635.