home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / sbprolog / other.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-23  |  9.9 KB  |  384 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona, 1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24. /* other.c */
  25.  
  26. #include "builtin.h"
  27. #include  <errno.h>
  28. #include <ctype.h>
  29. #include  <sys/types.h>
  30. #include "syscall.h"
  31.  
  32. extern float    floatval();
  33. extern LONG_PTR insert();
  34. extern WORD     d_trace, d_hitrace;
  35. /* extern WORD     errno; */
  36. extern LONG     maxmem, maxpspace, maxtrail;
  37. extern LONG    simpath;
  38.  
  39. static BYTE perm = PERM;
  40.  
  41. FILE   *curr_in, *curr_out;   /* current input, output streams */
  42.  
  43. /*
  44. typedef union {
  45.        CHAR_PTR name;
  46.        LONG     num;
  47. } call_args;
  48. */
  49. typedef unsigned int call_args;
  50.  
  51. static call_args call_arg[10];
  52. static CHAR      s[256];
  53.  
  54. b_GET_SIMPATH() /* X */
  55. {
  56.     if (!unify(reg[1], simpath)) {FAIL0;}
  57. }
  58.  
  59. b_SYSTEM0()  /* reg1: a list of int (string) for CShell commands */
  60. {
  61.    register LONG     op1;
  62.    register LONG_PTR top;
  63.    CHAR     s[256];
  64.  
  65.    op1 = reg[1];  DEREF(op1);
  66.    namestring(GET_STR_PSC(op1), s);
  67.    if (!unify(MAKEINT(system(s)), reg[2]))
  68.       {FAIL0;}
  69. }
  70.  
  71.  
  72. getgenargs(rno)
  73. WORD rno;
  74. {  /* rno is number of register containing list of args
  75.     * This routine converts them into array cal_arg, and
  76.     * returns the number of args
  77.     */
  78.    register LONG     op2, op3;
  79.    register LONG_PTR top;
  80.    PSC_REC_PTR       psc_ptr;
  81.    WORD              i;
  82.  
  83.    op2 = reg[rno];  DEREF(op2);
  84.    i = 1;
  85.    while (!ISNIL(op2)) {
  86.       UNTAG(op2);
  87.       op3 = FOLLOW(op2);  DEREF(op3);
  88.       if (ISATOM(op3)) {
  89.          psc_ptr = GET_STR_PSC(op3);
  90.          if (IS_ORDI(psc_ptr)) {
  91.             namestring(psc_ptr, s);
  92.             call_arg[i] = (call_args) s;
  93.          } else if (IS_BUFF(psc_ptr))
  94.             call_arg[i] = (call_args) GET_NAME(psc_ptr);
  95.       }
  96.       else if (ISINTEGER(op3)) call_arg[i] = INTVAL(op3);
  97.       else
  98.          quit("Unknown syscall argument\n");
  99.       op2 += 4;
  100.       DEREF(op2);
  101.       i++;
  102.    }
  103.    return i;
  104. }
  105.  
  106.  
  107. b_SYSCALL()  /* reg1: call #; reg2: list of parameters; reg3: returned value */
  108. {
  109.     register LONG     op1;
  110.     register LONG_PTR top;
  111.     int               n, r;
  112.  
  113.     op1 = reg[1];  DEREF(op1);
  114.     n   = INTVAL(op1);              /* syscall number */
  115.     switch (getgenargs(2)) {
  116.       case  1: r = syscall(n);
  117.                break;
  118.       case  2: r = syscall(n, call_arg[1]);
  119.                break;
  120.       case  3: r = syscall(n, call_arg[1], call_arg[2]);
  121.                break;
  122.       case  4: r = syscall(n, call_arg[1], call_arg[2], call_arg[3]);
  123.                break;
  124.       case  5: r = syscall(n, call_arg[1], call_arg[2], call_arg[3],
  125.                               call_arg[4]);
  126.                break;
  127.       case  6: r = syscall(n, call_arg[1], call_arg[2], call_arg[3],
  128.                               call_arg[4], call_arg[5]);
  129.                break;
  130.       case  7: r = syscall(n, call_arg[1], call_arg[2], call_arg[3],
  131.                               call_arg[4], call_arg[5], call_arg[6]);
  132.                break;
  133.       default: quit( "Too many arguments for syscall\n" );
  134.                break;
  135.    }
  136.    if (!unify(reg[3], MAKEINT(r)))
  137.       {FAIL0;}
  138. }
  139.  
  140.  
  141. b_ERRNO()
  142. {
  143.    if (!unify( reg[1], MAKEINT(errno)))
  144.       {FAIL0;}
  145. }
  146.  
  147.  
  148. b_CALL()  /* reg1: The predicate to be called */
  149. {
  150.    callv_sub();  /* since cpreg has been saved by call "call",
  151.                     should not be saved again, the same as exec */
  152. }
  153.  
  154.  
  155. b_LOAD()
  156. {  /* reg1: the byte code file to be loaded
  157.     * reg2: the return code, 0 => success
  158.     */
  159.    register LONG     op1;
  160.    register LONG_PTR top;
  161.    PSC_REC_PTR         psc_ptr;
  162.  
  163.    op1 = reg[1];  DEREF(op1);
  164.    psc_ptr = GET_STR_PSC(op1);
  165.            
  166.    if (!unify(MAKEINT(dyn_loader(psc_ptr)), reg[2]))
  167.       {FAIL0;}
  168. }
  169.  
  170.  
  171. b_STATISTICS()
  172. {
  173.    print_statistics();
  174. }
  175.  
  176.  
  177. b_STATISTICS0()
  178. {
  179.    if (!unify(reg[1], MAKEINT(maxpspace*sizeof(LONG))))
  180.       {FAIL0;}     /* max program area */
  181.    if (!unify(reg[2], MAKEINT((((LONG)curr_fence-(LONG)pspace)))))
  182.       {FAIL0;}     /* program area in use */
  183.    if (!unify(reg[3], MAKEINT((hreg-heap_bottom))))
  184.       {FAIL0;}     /* global stack in use */
  185.    if (!unify(reg[4], MAKEINT((ereg<breg?ereg:breg)-hreg)))
  186.       {FAIL0;}     /* stack area (local, global) free */
  187.    if (!unify(reg[5], MAKEINT(local_bottom-(ereg<breg?ereg:breg))))
  188.       {FAIL0;}     /* local stack in use */
  189.    if (!unify(reg[6], MAKEINT(maxmem*sizeof(LONG))))
  190.       {FAIL0;}     /* total stack area size */
  191.    if (!unify(reg[7], MAKEINT(maxtrail*sizeof(LONG))))
  192.       {FAIL0;}     /* total trail size */
  193.    if (!unify(reg[8], MAKEINT(trreg-tstack)))
  194.       {FAIL0;}
  195. }
  196.  
  197.  
  198. b_TRACE()
  199. {
  200.    hitrace = 1;
  201. }
  202.  
  203.  
  204. b_PILTRACE()
  205. {
  206.    trace = 1;
  207. }
  208.  
  209.  
  210. b_UNTRACE()
  211. {
  212.    hitrace = trace = 0;
  213. }
  214.  
  215. /*
  216. b_DETRACE()
  217. {
  218.    hitrace = d_hitrace;
  219.    trace = d_trace;
  220. }
  221. */
  222.  
  223. b_SYMTYPE()  /* reg1 term, reg2 type field of psc-entry of root sym of term */
  224. {
  225.    register LONG     op1;
  226.    register LONG_PTR top;
  227.  
  228.    op1 = reg[1];
  229. typd:
  230.    switch (TAG(op1)) {
  231.       case FREE: NDEREF(op1, typd);
  232.       case LIST:
  233.       case NUM : quit("Symtype: illegal first arg\n");
  234.       case CS  : if (!unify(MAKEINT(GET_ETYPE(GET_STR_PSC(op1))), reg[2]))
  235.                     {FAIL0;}
  236.    }
  237. }
  238.  
  239.  
  240. b_HASHVAL()  /* reg1 Arg, reg2 size of hashtab, reg3 hashval for this arg */
  241. {
  242.    register LONG     op1, op2, op3;
  243.    register LONG_PTR top;
  244.  
  245.    op1 = reg[1];
  246.    op2 = reg[2];  DEREF(op2);  op2 = INTVAL(op2);
  247.    op3 = reg[3];  DEREF(op3);
  248. sotd0:
  249.    switch(TAG(op1)) {
  250.       case FREE: NDEREF(op1, sotd0);
  251.                  printf("Indexing for asserted predicate with var arg\n");
  252.                  FAIL0;
  253.       case NUM : if (ISINTEGER(op1))
  254.                     op1 = INTVAL(op1);
  255.                  else
  256.                     op1 = (LONG)(floatval(op1));
  257.                  break;
  258.       case LIST: op1 = *((LONG_PTR)UNTAGGED(list_str));
  259.                  break;
  260.       case CS  : op1 = (LONG)GET_STR_PSC(op1);
  261.                  break;
  262.    }
  263.    if (!unify(op3, MAKEINT(IHASH(op1, op2))))
  264.       {FAIL0;}
  265. }
  266.  
  267.  
  268. b_FLAGS()
  269. {  /* reg1 contains number of bit to get or set (must be integer);
  270.     * reg2 contains setting of 0 or 1,
  271.     * or is variable and setting will be returned
  272.     */
  273.    register LONG     op1, op2, res;
  274.    register LONG_PTR top;
  275.  
  276.    op1 = reg[1];  DEREF(op1);  op1 = INTVAL(op1);
  277.    op2 = reg[2];  DEREF(op2);
  278.    if (ISNONVAR(op2)) {
  279.       if (op1 > 9)
  280.          flags[op1-10] = op2;
  281.       else {
  282.          op2 = INTVAL(op2);
  283.          switch (op1) {
  284.             case 0: trace      = op2;  break;
  285.             case 1: hitrace    = op2;  break;
  286.             case 2: overflow_f = op2;  break;
  287.             case 3: trace_sta  = op2;  break;
  288.          }
  289.          call_intercept = hitrace | trace_sta;
  290.       }
  291.    } else {
  292.       if (op1 > 9)
  293.          res = flags[op1-10];
  294.       else {
  295.          switch (op1) {
  296.             case 0: res = trace;       break;
  297.             case 1: res = hitrace;     break;
  298.             case 2: res = overflow_f;  break;
  299.             case 3: res = trace_sta;   break;
  300.          }
  301.          res = MAKEINT(res);
  302.       }
  303.       FOLLOW(op2) = res;
  304.    }
  305. }
  306.  
  307.  
  308. print_statistics()
  309. {
  310.     LONG_PTR lstktop;
  311.  
  312.     if (breg < ereg)
  313.        lstktop = breg;
  314.     else
  315.        lstktop = ereg - *(cpreg-5);
  316.  
  317.     printf("Maximum available stack size: %d\n", maxmem);
  318.     printf("  Local stack: %d in use, %d max used.\n",
  319.            local_bottom-lstktop, local_bottom-mlocaltop);
  320.     printf("  Heap stack: %d in use, %d max used.\n",
  321.            hreg-heap_bottom, mheaptop-heap_bottom);
  322.  
  323.     printf("Permanent space: %d, %d in use.\n", maxpspace,
  324.            ((int) curr_fence - (int) pspace)/4);
  325.  
  326.     printf("Trail stack: %d, %d in use, %d max used.\n",
  327.            maxtrail, trail_bottom-trreg, trail_bottom-mtrailtop);
  328. }
  329.  
  330.  
  331. b_READNAME()
  332. {  /* Ch, Name, NextCh: reads a sequence of letters, digits
  333.     * dollar signs and underscores, makes the sequence into a
  334.     * constant and inserts it into the PSC table if necessary,
  335.     * and returns a pointer to the PSC entry as Name.  NextCh is
  336.     * the first character read which cannot join this sequence.
  337.     *
  338.     * It is assumed that reg1 contains a character; and that regs
  339.     * 2 and 3 are free.  No checking is done here.  This builtin
  340.     * is only supposed to be called from $read_tokens/3 anyway.
  341.     */
  342.  
  343.    register LONG     op;
  344.    register LONG_PTR top;
  345.    CHAR     pname[STR_LIM], ch;
  346.    CHAR_PTR name;
  347.    WORD     len = 1;
  348.    WORD     done = 0;
  349.    LONG     ptr;
  350.  
  351.    op = reg[1];  DEREF(op);  op = INTVAL(op);
  352.  
  353.    name = pname;
  354.    *name++ = (CHAR)op;   /* first character in the sequence */
  355.  
  356.    while (!done && len <= STR_LIM) {
  357.       ch = getc(curr_in);
  358.       if (isalpha(ch) || isdigit(ch) || ch == '$' || ch ==  '_') {
  359.          *name++ = ch;
  360.          len++;
  361.       } else {
  362.          *name = '\0';
  363.          done = 1;
  364.       }
  365.    }
  366.  
  367.    if (ch == EOF) {
  368.       clearerr(curr_in);
  369.       printf("! unexpected end of file after %s\n", pname);
  370.    }
  371.    if (len > STR_LIM) {
  372.       *name = '\0';
  373.       len--;
  374.       printf("*** Name of constant too long: %s\n", pname);
  375.    }
  376.  
  377.    ptr = (LONG)insert(pname, len, 0, &perm) | CS_TAG;
  378.    if (!unify(reg[2], ptr))
  379.        {FAIL0;}
  380.    op = reg[3];  DEREF(op);
  381.    FOLLOW(op) = MAKEINT(ch);
  382.    PUSHTRAIL(op);
  383. }
  384.