home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1996 February / PCWK0296.iso / sharewar / dos / program / gs300sr1 / gs300sr1.exe / ZFILEIO.C < prev    next >
Encoding:
C/C++ Source or Header  |  1994-07-27  |  19.2 KB  |  789 lines
  1. /* Copyright (C) 1989, 1992, 1993, 1994 Aladdin Enterprises.  All rights reserved.
  2.   
  3.   This file is part of Aladdin Ghostscript.
  4.   
  5.   Aladdin Ghostscript is distributed with NO WARRANTY OF ANY KIND.  No author
  6.   or distributor accepts any responsibility for the consequences of using it,
  7.   or for whether it serves any particular purpose or works at all, unless he
  8.   or she says so in writing.  Refer to the Aladdin Ghostscript Free Public
  9.   License (the "License") for full details.
  10.   
  11.   Every copy of Aladdin Ghostscript must include a copy of the License,
  12.   normally in a plain ASCII text file named PUBLIC.  The License grants you
  13.   the right to copy, modify and redistribute Aladdin Ghostscript, but only
  14.   under certain conditions described in the License.  Among other things, the
  15.   License requires that the copyright notice and this notice be preserved on
  16.   all copies.
  17. */
  18.  
  19. /* zfileio.c */
  20. /* File I/O operators */
  21. #include "ghost.h"
  22. #include "gp.h"
  23. #include "errors.h"
  24. #include "oper.h"
  25. #include "stream.h"
  26. #include "files.h"
  27. #include "store.h"
  28. #include "strimpl.h"            /* for ifilter.h */
  29. #include "ifilter.h"            /* for procedure streams */
  30. #include "gsmatrix.h"            /* for gxdevice.h */
  31. #include "gxdevice.h"
  32. #include "gxdevmem.h"
  33.  
  34. /* Imported from gsfile.c */
  35. extern int gs_writeppmfile(P2(gx_device_memory *, FILE *));
  36.  
  37. /* Forward references */
  38. private int write_string(P2(ref *, stream *));
  39. private int handle_read_status(P5(stream *, int, const ref *,
  40.   const uint *, int (*)(P1(os_ptr))));
  41. private int handle_write_status(P5(stream *, int, const ref *,
  42.   const uint *, int (*)(P1(os_ptr))));
  43.  
  44. /* ------ Operators ------ */
  45.  
  46. /* <file> closefile - */
  47. int
  48. zclosefile(register os_ptr op)
  49. {    stream *s;
  50.     check_type(*op, t_file);
  51.     if ( file_is_valid(s, op) )    /* closing a closed file is a no-op */
  52.     {    int status = sclose(s);
  53.         if ( status != 0 )
  54.           { if ( s_is_writing(s) )
  55.               return handle_write_status(s, status, op, NULL,
  56.                          zclosefile);
  57.             else
  58.               return handle_read_status(s, status, op, NULL,
  59.                         zclosefile);
  60.           }
  61.     }
  62.     pop(1);
  63.     return 0;
  64. }
  65.  
  66. /* <file> read <int> -true- */
  67. /* <file> read -false- */
  68. int
  69. zread(register os_ptr op)
  70. {    stream *s;
  71.     int ch;
  72.     check_read_file(s, op);
  73.     ch = sgetc(s);
  74.     if ( ch >= 0 )
  75.     {    push(1);
  76.         make_int(op - 1, ch);
  77.         make_bool(op, 1);
  78.     }
  79.     else if ( ch == EOFC )
  80.         make_bool(op, 0);
  81.     else
  82.         return handle_read_status(s, ch, op, NULL, zread);
  83.     return 0;
  84. }
  85.  
  86. /* <file> <int> write - */
  87. int
  88. zwrite(register os_ptr op)
  89. {    stream *s;
  90.     byte ch;
  91.     int status;
  92.     check_write_file(s, op - 1);
  93.     check_type(*op, t_integer);
  94.     ch = (byte)op->value.intval;
  95.     status = sputc(s, (byte)ch);
  96.     if ( status >= 0 )
  97.     {    pop(2);
  98.         return 0;
  99.     }
  100.     return handle_write_status(s, status, op - 1, NULL, zwrite);
  101. }
  102.  
  103. /* <file> <string> readhexstring <substring> <filled_bool> */
  104. private int zreadhexstring_continue(P1(os_ptr));
  105. /* We keep track of the odd digit in the next byte of the string */
  106. /* beyond the bytes already used.  (This is just for convenience; */
  107. /* we could do the same thing by passing 2 state parameters to the */
  108. /* continuation procedure instead of 1.) */
  109. private int
  110. zreadhexstring_at(register os_ptr op, uint start)
  111. {    stream *s;
  112.     uint len, nread;
  113.     byte *str;
  114.     int odd = -1;
  115.     stream_cursor_write cw;
  116.     int status;
  117.     bool result;
  118.     check_read_file(s, op - 1);
  119.     check_write_type(*op, t_string);
  120.     str = op->value.bytes;
  121.     len = r_size(op);
  122.     if ( start < len )
  123.       {    odd = str[start];
  124.         if ( odd > 0xf ) odd = -1;
  125.       }
  126.     else
  127.       odd = -1;
  128.     cw.ptr = str + start - 1;
  129.     cw.limit = str + len - 1;
  130.     for ( ; ; )
  131.     {    stream_cursor_read cr;
  132.         cr.ptr = s->srptr;
  133.         cr.limit = s->srlimit;
  134.         status = s_hex_process(&cr, &cw, &odd, true);
  135.         s->srptr = (byte *)cr.ptr;    /* remove const */
  136.         if ( status != 0 )        /* error or filled string */
  137.             break;
  138.         status = spgetc(s);
  139.         if ( status < 0 )        /* error or EOF */
  140.             break;
  141.         sputback(s);
  142.     }
  143.     nread = cw.ptr + 1 - str;
  144.     if ( status >= 0 )
  145.       status = 0;
  146.     switch ( status )
  147.     {
  148.     case EOFC:
  149.         /* Reached end-of-file before filling the string. */
  150.         /* Return an appropriate substring. */
  151.         r_set_size(op, nread);
  152.         result = false;
  153.         break;
  154.     case 0:
  155.         /* Filled the string. */
  156.         result = true;
  157.         break;
  158.     default:
  159.         if ( nread < len )
  160.           str[nread] = (odd < 0 ? 0x10 : odd);
  161.         return handle_read_status(s, status, op - 1, &nread,
  162.                       zreadhexstring_continue);
  163.     }
  164.     ref_assign_inline(op - 1, op);
  165.     make_bool(op, result);
  166.     return 0;
  167. }
  168. private int
  169. zreadhexstring(os_ptr op)
  170. {    check_write_type(*op, t_string);
  171.     if ( r_size(op) > 0 )
  172.       *op->value.bytes = 0x10;
  173.     return zreadhexstring_at(op, 0);
  174. }
  175. /* Continue a readhexstring operation after a callout. */
  176. /* *op is the index within the string. */
  177. private int
  178. zreadhexstring_continue(register os_ptr op)
  179. {    int code;
  180.     check_type(*op, t_integer);
  181.     if ( op->value.intval < 0 || op->value.intval > r_size(op - 1) )
  182.       return_error(e_rangecheck);
  183.     code = zreadhexstring_at(op - 1, (uint)op->value.intval);
  184.     if ( code >= 0 )
  185.       pop(1);
  186.     return code;
  187. }
  188.  
  189. /* <file> <string> writehexstring - */
  190. private int zwritehexstring_continue(P1(os_ptr));
  191. private int
  192. zwritehexstring_at(register os_ptr op, uint odd)
  193. {    register stream *s;
  194.     register byte ch;
  195.     register const byte *p;
  196.     register const char _ds *hex_digits = "0123456789abcdef";
  197.     register uint len;
  198.     int status;
  199. #define max_hex 128
  200.     byte buf[max_hex];
  201.     check_write_file(s, op - 1);
  202.     check_read_type(*op, t_string);
  203.     p = op->value.bytes;
  204.     len = r_size(op);
  205.     while ( len )
  206.     {    uint len1 = min(len, max_hex / 2);
  207.         register byte *q = buf;
  208.         uint count = len1;
  209.         ref rbuf;
  210.         do
  211.         {    ch = *p++;
  212.             *q++ = hex_digits[ch >> 4];
  213.             *q++ = hex_digits[ch & 0xf];
  214.         }
  215.         while ( --count );
  216.         r_set_size(&rbuf, (len1 << 1) - odd);
  217.         rbuf.value.bytes = buf + odd;
  218.         status = write_string(&rbuf, s);
  219.         switch ( status )
  220.         {
  221.         default:
  222.             return_error(e_ioerror);
  223.         case 0:
  224.             len -= len1;
  225.             odd = 0;
  226.             continue;
  227.         case INTC:
  228.         case CALLC:
  229.             count = rbuf.value.bytes - buf;
  230.             op->value.bytes += count >> 1;
  231.             r_set_size(op, len - (count >> 1));
  232.             count &= 1;
  233.             return handle_write_status(s, status, op - 1, &count,
  234.                            zwritehexstring_continue);
  235.         }
  236.     }
  237.     pop(2);
  238.     return 0;
  239. #undef max_hex
  240. }
  241. private int
  242. zwritehexstring(os_ptr op)
  243. {    return zwritehexstring_at(op, 0);
  244. }
  245. /* Continue a writehexstring operation after a callout. */
  246. /* *op is the odd/even hex digit flag for the first byte. */
  247. private int
  248. zwritehexstring_continue(register os_ptr op)
  249. {    int code;
  250.     check_type(*op, t_integer);
  251.     if ( (op->value.intval & ~1) != 0 )
  252.       return_error(e_rangecheck);
  253.     code = zwritehexstring_at(op - 1, (uint)op->value.intval);
  254.     if ( code >= 0 )
  255.       pop(1);
  256.     return code;
  257. }
  258.  
  259. /* <file> <string> readstring <substring> <filled_bool> */
  260. private int zreadstring_continue(P1(os_ptr));
  261. private int
  262. zreadstring_at(register os_ptr op, uint start)
  263. {    stream *s;
  264.     uint len, rlen;
  265.     int status;
  266.     check_read_file(s, op - 1);
  267.     check_write_type(*op, t_string);
  268.     len = r_size(op);
  269.     status = sgets(s, op->value.bytes + start, len - start, &rlen);
  270.     rlen += start;
  271.     switch ( status )
  272.     {
  273.     case EOFC:
  274.     case 0:
  275.         break;
  276.     default:
  277.         return handle_read_status(s, status, op - 1, &rlen,
  278.                       zreadstring_continue);
  279.     }
  280.     r_set_size(op, rlen);
  281.     op[-1] = *op;
  282.     make_bool(op, (rlen == len ? 1 : 0));
  283.     return 0;
  284. }
  285. private int
  286. zreadstring(os_ptr op)
  287. {    return zreadstring_at(op, 0);
  288. }
  289. /* Continue a readstring operation after a callout. */
  290. /* *op is the index within the string. */
  291. private int
  292. zreadstring_continue(register os_ptr op)
  293. {    int code;
  294.     check_type(*op, t_integer);
  295.     if ( op->value.intval < 0 || op->value.intval > r_size(op - 1) )
  296.       return_error(e_rangecheck);
  297.     code = zreadstring_at(op - 1, (uint)op->value.intval);
  298.     if ( code >= 0 )
  299.       pop(1);
  300.     return code;
  301. }
  302.  
  303. /* <file> <string> writestring - */
  304. int
  305. zwritestring(register os_ptr op)
  306. {    stream *s;
  307.     int status;
  308.     check_write_file(s, op - 1);
  309.     check_read_type(*op, t_string);
  310.     status = write_string(op, s);
  311.     if ( status >= 0 )
  312.     {    pop(2);
  313.         return 0;
  314.     }
  315.     return handle_write_status(s, status, op - 1, NULL, zwritestring);
  316. }
  317.  
  318. /* <file> <string> readline <substring> <bool> */
  319. private int zreadline(P1(os_ptr));
  320. private int zreadline_continue(P1(os_ptr));
  321. /*
  322.  * We could handle readline the same way as readstring,
  323.  * except for the anomalous situation where we get interrupted
  324.  * between the CR and the LF of an end-of-line marker.
  325.  * We hack around this in the following way: if we get interrupted
  326.  * before we've read any characters, we just restart the readline;
  327.  * if we get interrupted at any other time, we use readline_continue;
  328.  * we use start=0 (which we have just ruled out as a possible start value
  329.  * for readline_continue) to indicate interruption after the CR.
  330.  */
  331. private int
  332. zreadline_at(register os_ptr op, uint count, bool in_eol)
  333. {    stream *s;
  334.     byte *ptr;
  335.     uint len;
  336.     int status;
  337.     check_read_file(s, op - 1);
  338.     check_write_type(*op, t_string);
  339.     ptr = op->value.bytes;
  340.     len = r_size(op);
  341.     status = zreadline_from(s, ptr, len, &count, &in_eol);
  342.     switch ( status )
  343.     {
  344.     case 0:
  345.     case EOFC:
  346.         break;
  347.     case 1:
  348.         return_error(e_rangecheck);
  349.     default:
  350.         if ( count == 0 && !in_eol )
  351.           return handle_read_status(s, status, op - 1, NULL,
  352.                         zreadline);
  353.         else
  354.           { if ( in_eol )
  355.               { r_set_size(op, count);
  356.             count = 0;
  357.               }
  358.             return handle_read_status(s, status, op - 1, &count,
  359.                           zreadline_continue);
  360.         }
  361.     }
  362.     r_set_size(op, count);
  363.     op[-1] = *op;
  364.     make_bool(op, status == 0);
  365.     return 0;
  366. }
  367. private int
  368. zreadline(register os_ptr op)
  369. {    return zreadline_at(op, 0, false);
  370. }
  371. /* Continue a readline operation after a callout. */
  372. /* *op is the index within the string, or 0 for an interrupt after a CR. */
  373. private int
  374. zreadline_continue(register os_ptr op)
  375. {    uint start;
  376.     int code;
  377.     check_type(*op, t_integer);
  378.     if ( op->value.intval < 0 || op->value.intval > r_size(op - 1) )
  379.       return_error(e_rangecheck);
  380.     start = (uint)op->value.intval;
  381.     code = (start == 0 ? zreadline_at(op - 1, 0, true) :
  382.         zreadline_at(op - 1, start, false));
  383.     if ( code >= 0 )
  384.       pop(1);
  385.     return code;
  386. }
  387.  
  388. /* Internal readline routine. */
  389. /* Returns a stream status value, or 1 if we overflowed the string. */
  390. /* This is exported for %lineedit. */
  391. int
  392. zreadline_from(stream *s, byte *ptr, uint size, uint *pcount, bool *pin_eol)
  393. {    uint count = *pcount;
  394.  
  395.     /* Most systems define \n as 0xa and \r as 0xd; however, */
  396.     /* OS-9 has \n == \r == 0xd and \l == 0xa.  The following */
  397.     /* code works properly regardless of environment. */
  398. #if '\n' == '\r'
  399. #  define LF 0xa
  400. #else
  401. #  define LF '\n'
  402. #endif
  403.  
  404. top:    if ( *pin_eol )
  405.     {    /* We were interrupted in the middle of checking for */
  406.         /* a two-character end-of-line sequence. */
  407.         int ch = sgetc(s);
  408.         if ( ch < 0 )        /* EOF or exception */
  409.             return ch;
  410.         if ( ch != LF )
  411.             sputback(s);
  412.         *pin_eol = false;
  413.         return 0;
  414.     }
  415.     for ( ; ; )
  416.     {    int ch = sgetc(s);
  417.         if ( ch < 0 )        /* EOF or exception */
  418.         {    *pcount = count;
  419.             return ch;
  420.         }
  421.  
  422.         switch ( ch )
  423.         {
  424.         case '\r':
  425. #if '\n' == '\r'            /* OS-9 or similar */
  426.             if ( s != gs_stream_stdin )
  427. #endif
  428.             {    *pcount = count;
  429.                 *pin_eol = true;
  430.                 goto top;
  431.             }
  432.             /* falls through */
  433.         case LF:
  434. #undef LF
  435.             *pcount = count;
  436.             return 0;
  437.         }
  438.         if ( count >= size )    /* filled the string */
  439.         {    sputback(s);
  440.             return 1;
  441.         }
  442.         ptr[count++] = ch;
  443.     }
  444.     /*return 0;*/        /* not reached */
  445. }
  446.  
  447. /* <file> bytesavailable <int> */
  448. int
  449. zbytesavailable(register os_ptr op)
  450. {    stream *s;
  451.     long avail;
  452.     check_read_file(s, op);
  453.     if ( savailable(s, &avail) < 0 )
  454.         return_error(e_ioerror);
  455.     make_int(op, avail);
  456.     return 0;
  457. }
  458.  
  459. /* - flush - */
  460. int
  461. zflush(register os_ptr op)
  462. {    sflush(gs_stream_stdout);
  463.     return 0;
  464. }
  465.  
  466. /* <file> flushfile - */
  467. int
  468. zflushfile(register os_ptr op)
  469. {    stream *s;
  470.     int status;
  471.     check_file(s, op);
  472.     status = sflush(s);
  473.     if ( status == 0 )
  474.     {    pop(1);
  475.         return 0;
  476.     }
  477.     return handle_write_status(s, status, op, NULL, zflushfile);
  478. }
  479.  
  480. /* <file> resetfile - */
  481. int
  482. zresetfile(register os_ptr op)
  483. {    stream *s;
  484.     check_file(s, op);
  485.     sreset(s);
  486.     pop(1);
  487.     return 0;
  488. }
  489.  
  490. /* <string> print - */
  491. int
  492. zprint(register os_ptr op)
  493. {    int status;
  494.     ref rstdout;
  495.     int code;
  496.     check_read_type(*op, t_string);
  497.     status = write_string(op, gs_stream_stdout);
  498.     if ( status >= 0 )
  499.     {    pop(1);
  500.         return 0;
  501.     }
  502.     /* Convert print to writestring on the fly. */
  503.     make_stream_file(&rstdout, gs_stream_stdout, "w");
  504.     code = handle_write_status(gs_stream_stdout, status, &rstdout,
  505.                    NULL, zwritestring);
  506.     if ( code != o_push_estack )
  507.       return code;
  508.     push(1);
  509.     *op = op[-1];
  510.     op[-1] = rstdout;
  511.     return code;
  512. }
  513.  
  514. /* <bool> echo - */
  515. int
  516. zecho(register os_ptr op)
  517. {    check_type(*op, t_boolean);
  518.     /****** NOT IMPLEMENTED YET ******/
  519.     pop(1);
  520.     return 0;
  521. }
  522.  
  523. /* ------ Level 2 extensions ------ */
  524.  
  525. /* <file> fileposition <int> */
  526. int
  527. zfileposition(register os_ptr op)
  528. {    stream *s;
  529.     check_file(s, op);
  530.     make_int(op, stell(s));
  531.     return 0;
  532. }
  533.  
  534. /* <file> <int> setfileposition - */
  535. int
  536. zsetfileposition(register os_ptr op)
  537. {    stream *s;
  538.     check_file(s, op - 1);
  539.     check_type(*op, t_integer);
  540.     if ( sseek(s, op->value.intval) < 0 )
  541.         return_error(e_ioerror);
  542.     pop(2);
  543.     return 0;
  544. }
  545.  
  546. /* ------ Non-standard extensions ------ */
  547.  
  548. /* <file> <int> unread - */
  549. int
  550. zunread(register os_ptr op)
  551. {    stream *s;
  552.     ulong ch;
  553.     check_read_file(s, op - 1);
  554.     check_type(*op, t_integer);
  555.     ch = op->value.intval;
  556.     if ( ch > 0xff )
  557.         return_error(e_rangecheck);
  558.     if ( sungetc(s, (byte)ch) < 0 )
  559.         return_error(e_ioerror);
  560.     pop(2);
  561.     return 0;
  562. }
  563.  
  564. /* <file> <object> .writecvs - */
  565. private int zwritecvs_continue(P1(os_ptr));
  566. private int
  567. zwritecvs_at(register os_ptr op, uint start)
  568. {    stream *s;
  569. #define max_cvs 128
  570.     byte str[max_cvs];
  571.     ref rstr;
  572.     byte *pchars = str;
  573.     uint len;
  574.     int code, status;
  575.     check_write_file(s, op - 1);
  576.     code = obj_cvs(op, str, max_cvs, &len, &pchars);
  577.     if ( code < 0 )
  578.     {    if ( pchars == str )
  579.             return code;
  580.     }
  581.     if ( start > len )
  582.         return_error(e_rangecheck);
  583.     r_set_size(&rstr, len - start);
  584.     rstr.value.bytes = pchars + start;
  585.     status = write_string(&rstr, s);
  586.     switch ( status )
  587.     {
  588.     default:
  589.         return_error(e_ioerror);
  590.     case 0:
  591.         break;
  592.     case INTC:
  593.     case CALLC:
  594.         len -= r_size(&rstr);
  595.         return handle_write_status(s, status, op - 1, &len,
  596.                        zwritecvs_continue);
  597.     }
  598.     pop(2);
  599.     return 0;
  600. #undef max_cvs
  601. }
  602. private int
  603. zwritecvs(os_ptr op)
  604. {    return zwritecvs_at(op, 0);
  605. }
  606. /* Continue a .writecvs after a callout. */
  607. /* *op is the index within the string. */
  608. private int
  609. zwritecvs_continue(os_ptr op)
  610. {    int code;
  611.     check_type(*op, t_integer);
  612.     if ( op->value.intval != (uint)op->value.intval )
  613.       return_error(e_rangecheck);
  614.     code = zwritecvs_at(op - 1, (uint)op->value.intval);
  615.     if ( code >= 0 )
  616.       pop(1);
  617.     return code;
  618. }
  619.  
  620. /* <file> <device> writeppmfile - */
  621. int
  622. zwriteppmfile(register os_ptr op)
  623. {    stream *s;
  624.     int code;
  625.     check_write_file(s, op - 1);
  626.     check_type(*op, t_device);
  627.     if ( !gs_device_is_memory(op->value.pdevice) )
  628.         return_error(e_typecheck);
  629.     sflush(s);
  630.     code = gs_writeppmfile((gx_device_memory *)(op->value.pdevice), s->file);
  631.     if ( code >= 0 ) pop(2);
  632.     return code;
  633. }
  634.  
  635. /* ------ Initialization procedure ------ */
  636.  
  637. op_def zfileio_op_defs[] = {
  638.     {"1bytesavailable", zbytesavailable},
  639.     {"1closefile", zclosefile},
  640.         /* currentfile is in zcontrol.c */
  641.     {"1echo", zecho},
  642.     {"1fileposition", zfileposition},
  643.     {"0flush", zflush},
  644.     {"1flushfile", zflushfile},
  645.     {"1print", zprint},
  646.     {"1read", zread},
  647.     {"2readhexstring", zreadhexstring},
  648.     {"2readline", zreadline},
  649.     {"2readstring", zreadstring},
  650.     {"1resetfile", zresetfile},
  651.     {"2setfileposition", zsetfileposition},
  652.     {"2unread", zunread},
  653.     {"2write", zwrite},
  654.     {"2.writecvs", zwritecvs},
  655.     {"2writehexstring", zwritehexstring},
  656.     {"2writeppmfile", zwriteppmfile},
  657.     {"2writestring", zwritestring},
  658.     op_def_end(0)
  659. };
  660.  
  661. /* ------ Non-operator routines ------ */
  662.  
  663. /* Check a file for reading. */
  664. /* The interpreter calls this to check an executable file. */
  665. int
  666. file_check_read(ref *op, stream **ps)
  667. {    stream *s;
  668.     check_read_known_file(s, op, s = invalid_file_entry);
  669.     *ps = s;
  670.     return 0;
  671. }
  672.  
  673. /* Switch a file open for read/write access but currently in write mode */
  674. /* to read mode. */
  675. int
  676. file_switch_to_read(ref *op)
  677. {    stream *s = fptr(op);
  678.     uint modes = s->modes;
  679.     long pos;
  680.     if ( s->write_id != r_size(op) )    /* not valid */
  681.         return_error(e_invalidaccess);
  682.     pos = stell(s);
  683.     if ( sflush(s) < 0 )
  684.         return_error(e_ioerror);
  685.     s->read_id = s->write_id;        /* enable reading */
  686.     s->write_id = 0;            /* disable writing */
  687.     sread_file(s, s->file, s->cbuf, s->cbsize);
  688.     fseek(s->file, 0L, SEEK_CUR);        /* pacify C library */
  689.     s->modes |= modes & s_mode_append;    /* don't lose append info */
  690.     s->position = pos;
  691.     return 0;
  692. }
  693.  
  694. /* Switch a file open for read/write access but currently in read mode */
  695. /* to write mode. */
  696. int
  697. file_switch_to_write(ref *op)
  698. {    stream *s = fptr(op);
  699.     uint modes = s->modes;
  700.     long pos;
  701.     if ( s->read_id != r_size(op) )        /* not valid */
  702.         return_error(e_invalidaccess);
  703.     pos = stell(s);
  704.     s->write_id = s->read_id;        /* enable writing */
  705.     s->read_id = 0;                /* disable reading */
  706.     fseek(s->file, pos, SEEK_SET);        /* pacify C library */
  707.     if ( modes & s_mode_append )
  708.         sappend_file(s, s->file, s->cbuf, s->cbsize);    /* sets position */
  709.     else
  710.     {    swrite_file(s, s->file, s->cbuf, s->cbsize);
  711.         s->position = pos;
  712.     }
  713.     return 0;
  714. }
  715.  
  716. /* ------ Internal routines ------ */
  717.  
  718. /* Write a string on a file.  The file and string have been validated. */
  719. /* If the status is INTC or CALLC, updates the string on the o-stack. */
  720. private int
  721. write_string(ref *op, stream *s)
  722. {    const byte *data = op->value.const_bytes;
  723.     uint len = r_size(op);
  724.     uint wlen;
  725.     int status = sputs(s, data, len, &wlen);
  726.     switch ( status )
  727.     {
  728.     case INTC:
  729.     case CALLC:
  730.         op->value.const_bytes = data + wlen;
  731.         r_set_size(op, len - wlen);
  732.         /* falls through */
  733.     default:        /* 0, EOFC, ERRC */
  734.         return status;
  735.     }
  736. }
  737.  
  738. /* Handle an exceptional status return from a read stream. */
  739. /* ch may be any stream exceptional value. */
  740. /* Return 0, 1 (EOF), o_push_estack, or an error. */
  741. private int
  742. handle_read_status(stream *s, int ch, const ref *fop,
  743.   const uint *pindex, int (*cont)(P1(os_ptr)))
  744. {    ref index;
  745.     const ref *pstate;
  746.     if ( pindex )
  747.       {    make_int(&index, *pindex);
  748.         pstate = &index;
  749.       }
  750.     else
  751.         pstate = NULL;
  752.     switch ( ch )
  753.     {
  754.     default:        /* error */
  755.         return_error(e_ioerror);
  756.     case EOFC:
  757.         return 1;
  758.     case INTC:
  759.         return s_handle_intc(pstate, cont);
  760.     case CALLC:
  761.         return s_proc_read_call(s, fop, pstate, cont);
  762.     }
  763. }
  764.  
  765. /* Handle an exceptional status return from a write stream. */
  766. /* ch may be any stream exceptional value. */
  767. /* Return 0, o_push_estack, or an error. */
  768. private int
  769. handle_write_status(stream *s, int ch, const ref *fop,
  770.   const uint *pindex, int (*cont)(P1(os_ptr)))
  771. {    ref index;
  772.     const ref *pstate;
  773.     if ( pindex )
  774.       {    make_int(&index, *pindex);
  775.         pstate = &index;
  776.       }
  777.     else
  778.         pstate = NULL;
  779.     switch ( ch )
  780.     {
  781.     default:        /* error */
  782.         return_error(e_ioerror);
  783.     case INTC:
  784.         return s_handle_intc(pstate, cont);
  785.     case CALLC:
  786.         return s_proc_write_call(s, fop, pstate, cont);
  787.     }
  788. }
  789.