home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / sbprolog / file.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-23  |  10.3 KB  |  489 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. /* file.c */
  25.  
  26. #include  "builtin.h"
  27. #include  <stdio.h>
  28. #include  <sys/file.h>
  29.  
  30. #define  PMODE  0644
  31.  
  32. extern double floatval();
  33.  
  34. static int         n, a;
  35. static WORD        fileerrors = 0;   /* abort, or not on file errors */
  36. static PSC_REC_PTR user_psc_ptr, stderr_psc_ptr, psc_ptr;
  37. static FILE        *tempfile;
  38. static CHAR        s[256];
  39.  
  40. static LONG        user_word, con_word, stderr_word;
  41.  
  42. struct ftab_ent
  43. {
  44.    int   inout;      /* 1 if input, 0 if output */
  45.    LONG  p_ptr;      /* tagged ptr to psc_ptr of constant */
  46.    FILE *fdes;       /* file descriptor for this constant */
  47. };
  48.  
  49. /* table of open files; 0 is always stdin, 1 is always stdout, 
  50.    2 is always stderr */
  51. static struct ftab_ent file_table[20];
  52. static int file_tab_end = 0; /* last used entry in file_table */
  53.  
  54. /* index of current input (output) stream in file_table */
  55. static int in_file_i, out_file_i;
  56. extern FILE *curr_in, *curr_out;
  57.  
  58. static struct hostent *hp;
  59.  
  60.  
  61. get_file_index(cword, io)
  62. LONG cword;
  63. int  io;
  64. {
  65.    int i;
  66.  
  67.    for (i = 0; i <= file_tab_end; i++) {
  68.       if (file_table[i].p_ptr == cword)
  69.          if (io == file_table[i].inout || io > 1)
  70.             return i;
  71.    }
  72.    return -1;
  73. }
  74.  
  75.  
  76. b_FILEERRORS()
  77. {
  78.    fileerrors = 1;
  79. }
  80.  
  81.  
  82. b_NOFILEERRORS()
  83. {
  84.    fileerrors = 0;
  85. }
  86.  
  87.  
  88. b_PUT()  /* (N) */
  89. {
  90.    register LONG     op;
  91.    register LONG_PTR top;
  92.  
  93.    op = reg[1];  DEREF(op);
  94.    if (!ISINTEGER(op))
  95.       {FAIL0;}
  96.    else putc(INTVAL(op), curr_out);
  97. }
  98.  
  99.  
  100. b_GET0()  /* (N) */
  101. {
  102.    register LONG     op;
  103.    register LONG_PTR top;
  104.  
  105.    n = getc(curr_in);
  106.  
  107.    if (n == EOF)
  108.       clearerr(curr_in);
  109.  
  110.    op = reg[1];  DEREF(op);
  111.    if (ISNONVAR(op)) {
  112.       if (!unify(op, MAKEINT(n)))
  113.          {FAIL0;}
  114.    } else {
  115.       FOLLOW(op) = MAKEINT(n);
  116.       PUSHTRAIL(op);
  117.    }
  118. }
  119.  
  120.  
  121. b_GET()  /* (N) */
  122. {
  123.    register LONG     op;
  124.    register LONG_PTR top;
  125.  
  126.    do {
  127.      n = getc(curr_in);
  128.    } while (n != EOF && n < 16 && n >= 112);
  129.    if (n == EOF) {
  130.       clearerr(curr_in);
  131.       FAIL0;
  132.       return;
  133.    }
  134.    op = reg[1];  DEREF(op);
  135.    if (ISNONVAR(op)) {
  136.       if (!unify(op, MAKEINT(n)))
  137.          {FAIL0;}
  138.    } else {
  139.       FOLLOW(op) = MAKEINT(n);
  140.       PUSHTRAIL(op);
  141.    }
  142. }
  143.  
  144.  
  145. b_SKIP()  /* (N) */
  146. {
  147.    register LONG     op;
  148.    register LONG_PTR top;
  149.  
  150.    op = reg[1];  DEREF(op);
  151.    if (!ISINTEGER(op)) {
  152.       FAIL0;
  153.       return;
  154.    }
  155.    a = INTVAL(op);
  156.    if (a < 16 || a >= 112)
  157.       {FAIL0;}
  158.    else {
  159.       do {
  160.          n = getc(curr_in);
  161.       } while (n != EOF && n != a);
  162.       if (n = EOF) {
  163.          if (fileerrors)
  164.             quit("end of file encountered.\n");
  165.          else
  166.             {FAIL0;}
  167.       }
  168.    }
  169. }
  170.  
  171.  
  172. b_TAB()  /* (N) */
  173. {
  174.    register LONG     op;
  175.    register LONG_PTR top;
  176.  
  177.    op = reg[1];  DEREF(op);
  178.    if (!ISINTEGER(op)) {
  179.       FAIL0;
  180.       return;
  181.    }
  182.    a = INTVAL(op);
  183.    if (a < 0) {
  184.       FAIL0;
  185.       return;
  186.    }
  187.    for ( ; a > 0; a--)
  188.       putc(' ', curr_out);
  189. }
  190.  
  191.  
  192. b_NL()  /* () */
  193. {
  194.    putc('\n', curr_out);
  195.    fflush(curr_out);
  196. }
  197.  
  198.  
  199. b_WRITENAME()  /* (X) */
  200. {
  201.    register LONG     op;
  202.    register LONG_PTR top;
  203.  
  204.    op = reg[1];
  205. wnd:
  206.    switch (TAG(op)) {
  207.      case FREE: NDEREF(op, wnd);
  208.                 fprintf(curr_out, "_%d", UNTAGGED(op));
  209.                 break;
  210.      case LIST: fprintf(curr_out, ".");
  211.                 break;
  212.      case CS  : psc_ptr = GET_STR_PSC(op);
  213.                 if (IS_BUFF(psc_ptr)) 
  214.                printf("Buffer_%x", GET_NAME(psc_ptr));
  215.                 else
  216.                    writepname(curr_out, GET_NAME(psc_ptr), GET_LENGTH(psc_ptr));
  217.                 break;
  218.      case NUM : write_tnum(op, curr_out); 
  219.                 break;
  220.    }
  221. }
  222.  
  223.  
  224. b_WRITEQNAME()  /* (X) */
  225. {
  226.    register LONG     op;
  227.    register LONG_PTR top;
  228.  
  229.    op = reg[1];
  230. wnd:
  231.    switch (TAG(op)) {
  232.      case FREE: NDEREF(op, wnd);
  233.                 fprintf(curr_out, "_%d", UNTAGGED(op));
  234.                 break;
  235.      case LIST: fprintf(curr_out, ".");
  236.                 break;
  237.      case CS  : psc_ptr = GET_STR_PSC(op);
  238.                 if (IS_BUFF(psc_ptr))
  239.                printf("Buffer_%x", GET_NAME(psc_ptr));
  240.                 else
  241.                    writeqname(curr_out, GET_NAME(psc_ptr), GET_LENGTH(psc_ptr));
  242.                 break;
  243.      case NUM : write_tnum(op, curr_out);
  244.                 break;
  245.    }
  246. }
  247.  
  248.  
  249. b_RESET()  /* () */
  250. {
  251.    quit("RESET not implemented\n");
  252.  
  253. /*
  254.    fop = reg[1];
  255.    get_file_psc();
  256.    if (p == user_psc_ptr)
  257.       set_file_ptr(p, stdin);
  258.    else {
  259.        namestring(p, s);
  260.        set_file_ptr(p, fopen(s, "r"));
  261.        if (get_file_ptr(p) == 0)
  262.           {FAIL0;}
  263.    }
  264. */
  265. }
  266.  
  267.  
  268. b_REWRITE()
  269. {
  270.    quit("REWRITE not implemented\n");
  271. /*
  272.    fop = reg[1];
  273.    get_file_psc();
  274.    if (p == user_psc_ptr)
  275.       set_file_ptr(p, stdout);
  276.    else {
  277.       namestring(p, s);
  278.       set_file_ptr(p, fopen(s, "w"));
  279.       if (get_file_ptr(p) == 0)
  280.          {FAIL0;}
  281.    }
  282. */
  283. }
  284.  
  285.  
  286. b_CLOSE()
  287. {
  288.    register LONG     fop;
  289.    register LONG_PTR top;
  290.    int     i;
  291.  
  292.    fop = reg[1];  DEREF(fop);
  293.    i = get_file_index(fop, 2);
  294.    if (i > 2) {    /* not user, stderr */
  295.       fclose(file_table[i].fdes);
  296.       for ( ; i < file_tab_end; i++)
  297.          file_table[i] = file_table[i+1];
  298.       file_tab_end--;
  299.    }
  300. }
  301.  
  302.  
  303. b_SEE()  /* reg1: file name */
  304. {
  305.    register LONG     fop;
  306.    register LONG_PTR top;
  307.    int      temp_in_file_i;
  308.  
  309.    fop = reg[1];  DEREF(fop);
  310.    temp_in_file_i = get_file_index(fop, 1);
  311.    if (temp_in_file_i < 0) {    /* not in table */
  312.        namestring(GET_STR_PSC(fop), s);
  313.        tempfile = fopen(s, "r");
  314.        if (!tempfile) {
  315.           FAIL0;          /* leaving in_file_i unchanged */
  316.           return;
  317.        }
  318.        in_file_i = ++file_tab_end;
  319.        file_table[in_file_i].inout = 1;
  320.        file_table[in_file_i].p_ptr = fop;
  321.        file_table[in_file_i].fdes  = tempfile;
  322.    }
  323.    else in_file_i = temp_in_file_i;    /* take it from table */
  324.    curr_in = file_table[in_file_i].fdes;
  325. }
  326.  
  327.  
  328. b_TELL()  /* reg1: file name */
  329. {         /* reg2: 0 -> open `w'-write; 1 -> open `a'-append */
  330.  
  331.    register LONG     sop, fop;
  332.    register LONG_PTR top;
  333.  
  334.    fop = reg[1];  DEREF(fop);
  335.    sop = reg[2];  DEREF(sop);
  336.    out_file_i = get_file_index(fop, 0);
  337.    if (out_file_i < 0) {                 /* not in table */
  338.        namestring(GET_STR_PSC(fop), s);
  339.        if(INTVAL(sop))
  340.           tempfile = fopen(s, "a");
  341.        else
  342.           tempfile = fopen(s, "w");
  343.        if (!tempfile) {
  344.           FAIL0;
  345.           return;
  346.        }
  347.        out_file_i = ++file_tab_end;
  348.        file_table[out_file_i].inout = 0;
  349.        file_table[out_file_i].p_ptr = fop;
  350.        file_table[out_file_i].fdes  = tempfile;
  351.    }
  352.    curr_out = file_table[out_file_i].fdes;
  353. }
  354.  
  355.  
  356. b_SEEING()  /* reg1: unified with the current input file name */
  357. {
  358.    if (!unify(reg[1], file_table[in_file_i].p_ptr))
  359.       {FAIL0;}
  360. }
  361.  
  362.  
  363. b_TELLING()  /* reg1: unified with the current out put file name */
  364. {
  365.    if (!unify(reg[1], file_table[out_file_i].p_ptr))
  366.       {FAIL0;}
  367. }
  368.  
  369.  
  370. b_SEEN()
  371. {
  372.    if (in_file_i > 2) {
  373.       fclose(curr_in);
  374.       for ( ; in_file_i < file_tab_end; in_file_i++)
  375.           file_table[in_file_i] = file_table[in_file_i+1];
  376.       file_tab_end--;
  377.    }
  378.    in_file_i = 0;    /* reset to user */
  379.    curr_in = file_table[in_file_i].fdes;
  380. }
  381.  
  382.  
  383. b_TOLD()
  384. {
  385.    if (out_file_i > 2) {
  386.       fclose(file_table[out_file_i].fdes);
  387.       for ( ; out_file_i < file_tab_end; out_file_i++)
  388.          file_table[out_file_i] = file_table[out_file_i+1];
  389.       file_tab_end--;
  390.    }
  391.    out_file_i = 1;       /* reset to user */
  392.    curr_out = file_table[out_file_i].fdes;
  393. }
  394.  
  395. static BYTE perm = PERM;
  396.  
  397. file_init()
  398. {
  399.     LONG temp;
  400.     CHAR arity = 0;
  401.  
  402.     temp = insert("user", 4, arity, &perm);
  403.     user_psc_ptr = (PSC_REC_PTR)FOLLOW(temp);
  404.     user_word = temp | CS_TAG;
  405.  
  406.     temp = insert("stderr", 6, arity, &perm);
  407.     stderr_psc_ptr = (PSC_REC_PTR)(FOLLOW(temp));
  408.     stderr_word = temp | CS_TAG;
  409.  
  410.     file_table[0].inout = 1;
  411.     file_table[0].p_ptr = user_word;
  412.     file_table[0].fdes  = stdin;
  413.     in_file_i = 0;
  414.     curr_in   = stdin;
  415.  
  416.     file_table[1].inout = 0;
  417.     file_table[1].p_ptr = user_word;
  418.     file_table[1].fdes  = stdout;
  419.     out_file_i = 1;
  420.     curr_out   = stdout;
  421.  
  422.     file_table[2].inout = 0;
  423.     file_table[2].p_ptr = stderr_word;
  424.     file_table[2].fdes = stderr;
  425.  
  426.     file_tab_end = 2;
  427. }
  428.  
  429.  
  430. b_ACCESS()
  431. {
  432.     register LONG     op1, op2;
  433.     int mode, r;
  434.     char name[256], *s;
  435.     register LONG_PTR top;
  436.     PSC_REC_PTR psc_ptr;
  437.  
  438.     op1 = reg[1]; DEREF(op1);
  439.     op2 = reg[2]; DEREF(op2);
  440.  
  441.     if (ISATOM(op1)) {
  442.       psc_ptr = GET_STR_PSC(op1);
  443.       if (IS_ORDI(psc_ptr)) {
  444.     namestring(psc_ptr, name);
  445.     s = name;
  446.       }
  447.       else if (IS_BUFF(psc_ptr)) s = GET_NAME(psc_ptr);
  448.       else {
  449.     printf("access: illegal first argument\n");
  450.     FAIL0;
  451.       }
  452.     };
  453.     if (ISINTEGER(op2)) mode = INTVAL(op2);
  454.     else {
  455.       fprintf(stderr, "access: second argument must be an integer\n");
  456.       FAIL0;
  457.     };
  458.     r = access(s, mode);
  459.     if (!unify(reg[3], MAKEINT(r))) {FAIL0;}
  460. }
  461.  
  462.  
  463. b_WRITE4() 
  464. {   /* reg1 contains a bit string that is written out in 4 bytes */
  465.  
  466.     register LONG     op, wbyte;
  467.     register LONG_PTR top;
  468.     WORD     i;
  469.  
  470.     op = reg[1];  DEREF(op);
  471.     for (i = 1; i <= 4; i++) {
  472.        wbyte = ((op & 0xff000000) >> 24);
  473.        op = op << 8;
  474.        putc(wbyte, curr_out);
  475.     }
  476. }
  477.  
  478.  
  479. b_WRITEPTR()
  480. {
  481.     register LONG     op;  
  482.     register LONG_PTR top;
  483.  
  484.     op = reg[1];  DEREF(op);
  485.  
  486.     printf("%08x", op & ~ CS_TAG);
  487. }
  488.  
  489.