home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / pd3.lzh / SBPROLOG2.2 / SIM / BUILTIN / other.c < prev    next >
Text File  |  1991-08-10  |  10KB  |  346 lines
  1. /************************************************************************
  2. *                                    *
  3. *    The SB-Prolog System                        *
  4. *    Copyright SUNY at Stony Brook, 1986                *
  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.  
  25. /* other.c */
  26.  
  27. #include "builtin.h"
  28. #include <errno.h>
  29. #ifndef OS9
  30. #include <sys/types.h>
  31. #include <netdb.h>
  32. #include <sys/socket.h>
  33. #include <netinet/in.h>
  34. #include <arpa/inet.h>
  35. #endif
  36.  
  37. extern float floatval();
  38. extern int d_trace, d_hitrace;
  39. extern word flags[10];
  40. extern int errno;
  41.  
  42. typedef union {
  43.         char *name;
  44.         int num;
  45.     } call_args;
  46.  
  47. static call_args call_arg[10];
  48. static char s[256];
  49.  
  50. b_SYSTEM0()  /* r1: a list of int (string) for CShell commands */
  51. {
  52.     register word op1;
  53.     register pw top;
  54.     char s[256];
  55.  
  56.     op1 = gregc(1); deref(op1);
  57.     namestring(get_str_psc(op1), s);
  58.     if (!unify(makeint(system(s)), gregc(2))) {Fail0;}
  59. }
  60.  
  61.  
  62. /* rno is number of register containing list of args 
  63.    This routine converts them into array cal_arg, and 
  64.    returns the number of args */
  65. getgenargs(rno) 
  66. int rno;
  67. {
  68.     int i;
  69.     register word op2, op3;
  70.     register pw top;
  71.     struct psc_rec *ptr;
  72.  
  73.     op2 = gregc(rno); deref(op2);
  74.     i = 1;
  75.     while (!(isnil(op2))) {
  76.     untag(op2);
  77.     op3 = follow(op2);
  78.     deref(op3);
  79.     if (isatom(op3)) {
  80.         ptr = get_str_psc(op3);
  81.         if ( get_etype(ptr) == T_ORDI ) {
  82.         namestring(ptr, s);
  83.         call_arg[i].name = s;
  84.         }
  85.         else if (get_etype(ptr) == T_BUFF) {
  86.             call_arg[i].name = get_name(ptr);
  87.         }
  88.     } 
  89.     else if (isinteger(op3)) call_arg[i].num = intval(op3);
  90.     else quit("Unknown syscall argument\n");
  91.     op2 += 4;
  92.     deref(op2);
  93.     i++;
  94.     }
  95.     return(i);
  96. }
  97.  
  98. b_SYSCALL()  /* r1: call # ; R2: a list of parameters; R3: returned value */
  99. {
  100.     int n, r;
  101.     register word op1;
  102.     register pw top;
  103.  
  104.     op1 = gregc(1); deref(op1);
  105.     n = intval(op1);  /* syscall number */
  106.     switch (getgenargs(2)) {
  107.     case 1:    r = syscall(n); break;
  108. #ifndef OS9
  109.     case 2:    r = syscall(n, call_arg[1]); break;
  110.     case 3:    r = syscall(n, call_arg[1], call_arg[2]); break;
  111.     case 4:    r = syscall(n, call_arg[1], call_arg[2], call_arg[3]); break;
  112.     case 5:    r = syscall(n, call_arg[1], call_arg[2], call_arg[3],
  113.             call_arg[4]); break;
  114.     case 6:    r = syscall(n, call_arg[1], call_arg[2], call_arg[3],
  115.             call_arg[4], call_arg[5]); break;
  116.     case 7:    r = syscall(n, call_arg[1], call_arg[2], call_arg[3],
  117.             call_arg[4], call_arg[5], call_arg[6]); break;
  118. #else
  119.     /* int and char* are of the same size in OS9 Microware C */
  120.     case 2:    r = syscall(n, call_arg[1].num); break;
  121.     case 3:    r = syscall(n, call_arg[1].num, call_arg[2].num); break;
  122.     case 4:    r = syscall(n, call_arg[1].num, call_arg[2].num,
  123.             call_arg[3].num); break;
  124.     case 5:    r = syscall(n, call_arg[1].num, call_arg[2].num, call_arg[3].num,
  125.             call_arg[4].num); break;
  126.     case 6:    r = syscall(n, call_arg[1].num, call_arg[2].num, call_arg[3].num,
  127.             call_arg[4].num, call_arg[5].num); break;
  128.     case 7:    r = syscall(n, call_arg[1].num, call_arg[2].num, call_arg[3].num,
  129.             call_arg[4].num, call_arg[5].num, call_arg[6].num); break;
  130. #endif
  131.     default: quit("Too many arguments for syscall\n");
  132.             break;
  133.     }
  134.     if (!unify(gregc(3), makeint(r))) {Fail0;}
  135. }
  136.  
  137.  
  138. b_BROCALL() /*    R1: call #; 
  139.         R2: buffer containing args in 4 byte fields;
  140.             R3: buffer to put return value in. */
  141. {
  142.     struct psc_rec *rptr;
  143.     pw aptr;
  144.     register word op1, op;
  145.     register pw top;
  146.  
  147.     op1 = gregc(1); deref(op1);  /* brocall number */
  148.     op = gregc(2); deref(op); 
  149.     aptr = (pw)get_name(get_str_psc(op)); /* buff with args */
  150.     op = gregc(3); deref(op); rptr = get_str_psc(op); /* buff for result */
  151.     switch ((int)(intval(op1))) {
  152.  
  153.     case 2:    *(pw)get_name(rptr) = (word) getenv(*aptr); break;
  154.  
  155. /* Communication subsystem system calls. Have not included byteorder (ntohl,
  156.    ntohs, htonl, htons). Each call is from manual entry 3N,  except 
  157.    getpeername,  which is from 2.
  158. */
  159.  
  160. /*    case 21: *(pw)get_name(rptr) = (word) gethostent(); break;
  161.     case 22: *(pw)get_name(rptr) = (word) gethostbyname(*aptr); break;
  162.     case 23: *(pw)get_name(rptr) = (word) gethostbyaddr(*aptr); break;
  163.     case 24: *(pw)get_name(rptr) = (word) sethostent(*aptr); break;
  164.     case 25: *(pw)get_name(rptr) = (word) endhostent(); break;
  165.  
  166.     case 26: *(pw)get_name(rptr) = (word) getnetent(); break;
  167.     case 27: *(pw)get_name(rptr) = (word) getnetbyname(*aptr); break;
  168.     case 28: *(pw)get_name(rptr) = (word) getnetbyaddr(*aptr); break;
  169.     case 29: *(pw)get_name(rptr) = (word) setnetent(*aptr); break;
  170.     case 30: *(pw)get_name(rptr) = (word) endnetent(); break;
  171.  
  172.     case 31: *(pw)get_name(rptr) = (word) getprotoent(); break;
  173.     case 32: *(pw)get_name(rptr) = (word) getprotobyname(*aptr); break;
  174.     case 33: *(pw)get_name(rptr) = (word) getprotobynumber(*aptr); break;
  175.     case 34: *(pw)get_name(rptr) = (word) setprotoent(*aptr); break;
  176.     case 35: *(pw)get_name(rptr) = (word) endprotoent(); break;
  177.  
  178.     case 36: *(pw)get_name(rptr) = (word) getservent(); break;
  179.     case 37: *(pw)get_name(rptr) = (word) getservbyname(*aptr); break;
  180.     case 38: *(pw)get_name(rptr) = (word) getservbyport(*aptr); break;
  181.     case 39: *(pw)get_name(rptr) = (word) setservent(*aptr); break;
  182.     case 40: *(pw)get_name(rptr) = (word) endservent(); break;
  183.  
  184.     case 41: *(pw)get_name(rptr) = (word) inet_addr(*aptr); break;
  185.     case 42: *(pw)get_name(rptr) = (word) inet_network(*aptr); break;
  186.     case 43: *(pw)get_name(rptr) = (word) inet_ntoa(*aptr); break;
  187.     case 44: *(pw)get_name(rptr) = (word) inet_makeaddr(*aptr); break;
  188.     case 45: *(pw)get_name(rptr) = (word) inet_lnaof(*aptr); break;
  189.     case 46: *(pw)get_name(rptr) = (word) inet_netof(*aptr); break;
  190.  
  191.     case 47: *(pw)get_name(rptr) = (word) get_peername(*aptr); break;
  192.     case 50: *(pw)get_name(rptr) = (word) perror(*aptr); break; */
  193.  
  194.     default: printf("Illegal brocall number\n"); Fail0; return;
  195.     }
  196. }
  197.  
  198. b_ERRNO()
  199. { 
  200.     if (!unify(gregc(1), makeint(errno))) {Fail0;}
  201. }
  202.  
  203. b_CALL()    /* R1: The predicate to be called */
  204. {
  205.     callv_sub();  /* since cpreg has been saved by call "call",
  206.                 should not be saved again, the same as exec */
  207. }
  208.  
  209. b_LOAD()    /* R1: the byte code file to be loaded */
  210.         /* R2: the return code, 0 => success */
  211. {
  212.     register word op1;
  213.     register pw top;
  214.  
  215.     op1 = gregc(1); deref(op1);
  216.     if (!unify(makeint(dyn_loader(get_str_psc(op1))), gregc(2))) {Fail0;}
  217. }
  218.  
  219. b_STATISTICS()
  220. {
  221.     print_statistics();
  222. }
  223.  
  224. b_TRACE()
  225. {
  226.     hitrace = 1;
  227. }
  228.  
  229. b_PILTRACE()
  230. {
  231.     trace = 1;
  232. }
  233.  
  234. b_UNTRACE()
  235. {
  236.     hitrace = trace = 0;
  237. }
  238.  
  239. /* b_DETRACE()
  240. {
  241.     hitrace = d_hitrace;
  242.     trace = d_trace;
  243. } */
  244.  
  245. b_SYMTYPE()    /* R1 term, R2 type field of psc-entry of root sym of term */
  246. {
  247.     register word op1;
  248.     register pw top;
  249.  
  250.     op1 = gregc(1);
  251.     typd: switch ((int)(op1&3)) {
  252.     case FREE:
  253.         nderef(op1, typd);
  254.     case LIST:
  255.     case NUM:
  256.         quit("Symtype: illegal first arg");
  257.     case CS:
  258.         if (!unify(makeint(get_etype(get_str_psc(op1))), gregc(2))) 
  259.         {Fail0;}
  260.     }
  261. }
  262.  
  263. b_HASHVAL()    /* R1 Arg, R2 size of hashtab, R3 hashval for this arg     */
  264. {
  265.     register word op1, op2, op3;
  266.     register pw top;
  267.  
  268.     op1 = gregc(1);
  269.     op2 = gregc(2); deref(op2); op2 = intval(op2);
  270.     op3 = gregc(3); deref(op3);
  271.     sotd0: switch((int)(op1&3)) {
  272.     case FREE: nderef(op1, sotd0);
  273.            printf("Indexing for asserted predicate with var arg\n");
  274.            Fail0;
  275.     case NUM:
  276.         if (isinteger(op1))
  277.             op1 = intval(op1);
  278.         else op1 = (int)(floatval(op1));
  279.         break;
  280.     case LIST:
  281.         op1 = *((pw)untagged(list_str));
  282.         break;
  283.     case CS:
  284.         op1 = (word)get_str_psc(op1);
  285.         break;
  286.     }
  287.     if (! unify(op3, makeint(ihash(op1, op2)))) {Fail0;}
  288. }
  289.  
  290. b_FLAGS()  /* R1 contains number of bit to get or set (must be integer);
  291.           R2 contains setting of 0 or 1, 
  292.             or is variable and setting will be returned */
  293. {
  294.     register word op1, op2, res;
  295.     register pw top;
  296.  
  297.     op1 = gregc(1); deref(op1); op1 = intval(op1);
  298.     op2 = gregc(2); deref(op2); 
  299.     if (isnonvar(op2)) {
  300.     if (op1>9) flags[op1-10] = op2;
  301.     else {
  302.         op2 = intval(op2);
  303.         switch ((int)(op1)) {
  304.             case 0: trace = op2; break;
  305.             case 1: hitrace = op2; break;
  306.             case 2: overflow_f = op2; break;
  307.             case 3: trace_sta = op2; break;
  308.         }
  309.         call_intercept = hitrace | trace_sta;
  310.     }
  311.     }
  312.     else {  
  313.         if (op1>9) res = flags[op1-10];
  314.         else {
  315.         switch ((int)(op1)) {
  316.             case 0: res = trace; break;
  317.             case 1: res = hitrace; break;
  318.             case 2: res = overflow_f; break;
  319.             case 3: res = trace_sta; break;
  320.         }
  321.         res = makeint(res);
  322.         }
  323.         follow(op2) = res;
  324.     }
  325. }
  326.  
  327. print_statistics()
  328. {
  329.     pw lstktop;
  330.  
  331.     if (breg < ereg) lstktop = breg;
  332.     else lstktop = ereg - *(cpreg-5);
  333.  
  334.     printf("Maximum available stack size: %d\n", maxmem);
  335.     printf("  Local stack: %d in use, %d max used.\n", 
  336.     local_bottom-lstktop, local_bottom-mlocaltop);
  337.     printf("  Heap stack: %d in use, %d max used.\n", 
  338.     hreg-heap_bottom, mheaptop-heap_bottom);
  339.  
  340.     printf("Permanent space: %d, %d in use.\n", maxpspace,
  341.         ((int) curr_fence - (int) pspace)/4);
  342.  
  343.     printf("Trail stack: %d, %d in use, %d max used.\n", 
  344.     maxtrail, trail_bottom-trreg, trail_bottom-mtrailtop);
  345. }
  346.