/* * portapi.c - port common API * * Copyright (c) 2000-2020 Shiro Kawai * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * 3. Neither the name of the authors nor the names of its contributors * may be used to endorse or promote products derived from this * software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* This file is included _twice_ by port.c to define safe- and unsafe- * variant of port common APIs. It is to minimize the overhead of * locking operations. * * The macro SHORTCUT allows 'safe' version to bypass lock/unlock * stuff by calling 'unsafe' version when the port is already locked by * the calling thread. */ /* [scratch and ungottern buffer] * It is always possible to mix binary and character i/o for Gauche's * ports. To support peek operations in Scheme and 'unget' operations * in C, we need to buffer at most one character or its equivalent * byte sequence. The 'ungotten' and 'scratch' fields are used for * character and binary buffering, respectively. * (This level of buffering is common to all input port types, and * distinct from the buffering of 'buffered' (file) port type.) * * 'Ungotten' field keeps SCM__CHAR_INVALID if there's no buffered * character. Otherwise, its value is the buffered character. * The number of bytes in the 'scratch' array is kept in 'scrcnt' * field. If 'scrcnt' field is not zero, there's data in the * 'scratch' array. * * In no cases there should be data in both ungotten and scratch * field. The consistency is taken care of the routines defined here; * no other routine should touch these buffering field. */ #ifdef SAFE_PORT_OP #define VMDECL ScmVM *vm = Scm_VM() #define LOCK(p) PORT_LOCK(p, vm) #define UNLOCK(p) PORT_UNLOCK(p) #define SAFE_CALL(p, exp) PORT_SAFE_CALL(p, exp, /*no cleanup*/) #define SHORTCUT(p, unsafe) \ do { if (PORT_LOCKED(p, vm)) { unsafe; }} while (0) #else #define VMDECL /*none*/ #define LOCK(p) /*none*/ #define UNLOCK(p) /*none*/ #define SAFE_CALL(p, exp) (exp) #define SHORTCUT(p, unsafe) /* none */ #endif /* Convenience macro */ #ifndef CLOSE_CHECK #define CLOSE_CHECK(port) \ do { \ if (SCM_PORT_CLOSED_P(port)) { \ UNLOCK(p); \ Scm_PortError((port), SCM_PORT_ERROR_CLOSED, \ "I/O attempted on closed port: %S", (port)); \ } \ } while (0) #endif /* CLOSE_CHECK */ #ifndef UNSAVE_POS #define UNSAVE_POS(port) PORT_SAVED_POS(port) = SCM_UNBOUND #endif /* UNSAVE_POS */ /* In the walk pass of multi-pass writing (see write.c), we set SCM_PORT_WALKING flag of the port. Usually Scm_Write family recognizes the flag and suppress output. However, in case if low-level port API is directly called during the walk pass, we just check the flag again. */ #ifndef WALKER_CHECK #define WALKER_CHECK(port) \ do { \ if (PORT_WALKER_P(port)) return; \ } while (0) #endif /* WALKER_CHECK */ /*================================================================= * Putb */ #ifdef SAFE_PORT_OP void Scm_Putb(ScmByte b, ScmPort *p) #else void Scm_PutbUnsafe(ScmByte b, ScmPort *p) #endif { VMDECL; SHORTCUT(p, Scm_PutbUnsafe(b, p); return); WALKER_CHECK(p); LOCK(p); CLOSE_CHECK(p); switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: if (PORT_BUF(p)->current >= PORT_BUF(p)->end) { SAFE_CALL(p, bufport_flush(p, PORT_BUF(p)->current - PORT_BUF(p)->buffer, FALSE)); } SCM_ASSERT(PORT_BUF(p)->current < PORT_BUF(p)->end); *PORT_BUF(p)->current++ = b; if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_NONE) { SAFE_CALL(p, bufport_flush(p, 1, FALSE)); } UNLOCK(p); break; case SCM_PORT_OSTR: SCM_DSTRING_PUTB(PORT_OSTR(p), b); UNLOCK(p); break; case SCM_PORT_PROC: SAFE_CALL(p, PORT_VT(p)->Putb(b, p)); UNLOCK(p); break; default: UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_OUTPUT, "bad port type for output: %S", p); } } /*================================================================= * Putc */ #ifdef SAFE_PORT_OP void Scm_Putc(ScmChar c, ScmPort *p) #else void Scm_PutcUnsafe(ScmChar c, ScmPort *p) #endif { VMDECL; SHORTCUT(p, Scm_PutcUnsafe(c, p); return); WALKER_CHECK(p); LOCK(p); CLOSE_CHECK(p); switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: { volatile int nb = SCM_CHAR_NBYTES(c); if (PORT_BUF(p)->current+nb > PORT_BUF(p)->end) { SAFE_CALL(p, bufport_flush(p, PORT_BUF(p)->current - PORT_BUF(p)->buffer, FALSE)); } SCM_ASSERT(PORT_BUF(p)->current+nb <= PORT_BUF(p)->end); SCM_CHAR_PUT(PORT_BUF(p)->current, c); PORT_BUF(p)->current += nb; if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_LINE) { if (c == '\n') { SAFE_CALL(p, bufport_flush(p, nb, FALSE)); } } else if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_NONE) { SAFE_CALL(p, bufport_flush(p, nb, FALSE)); } UNLOCK(p); break; } case SCM_PORT_OSTR: SCM_DSTRING_PUTC(PORT_OSTR(p), c); UNLOCK(p); break; case SCM_PORT_PROC: SAFE_CALL(p, PORT_VT(p)->Putc(c, p)); UNSAVE_POS(p); UNLOCK(p); break; default: UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_OUTPUT, "bad port type for output: %S", p); } } /*================================================================= * Puts */ #ifdef SAFE_PORT_OP void Scm_Puts(ScmString *s, ScmPort *p) #else void Scm_PutsUnsafe(ScmString *s, ScmPort *p) #endif { VMDECL; SHORTCUT(p, Scm_PutsUnsafe(s, p); return); WALKER_CHECK(p); LOCK(p); CLOSE_CHECK(p); switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: { ScmSmallInt size; const char *ss = Scm_GetStringContent(s, &size, NULL, NULL); SAFE_CALL(p, bufport_write(p, ss, size)); if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_LINE) { const char *cp = PORT_BUF(p)->current; while (cp-- > PORT_BUF(p)->buffer) { if (*cp == '\n') { SAFE_CALL(p, bufport_flush(p, cp - PORT_BUF(p)->current, FALSE)); break; } } } else if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_NONE) { SAFE_CALL(p, bufport_flush(p, 0, TRUE)); } UNLOCK(p); break; } case SCM_PORT_OSTR: Scm_DStringAdd(PORT_OSTR(p), s); UNLOCK(p); break; case SCM_PORT_PROC: SAFE_CALL(p, PORT_VT(p)->Puts(s, p)); UNSAVE_POS(p); UNLOCK(p); break; default: UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_OUTPUT, "bad port type for output: %S", p); } } /*================================================================= * Putz */ #ifdef SAFE_PORT_OP void Scm_Putz(const char *s, volatile ScmSize siz, ScmPort *p) #else void Scm_PutzUnsafe(const char *s, volatile ScmSize siz, ScmPort *p) #endif { VMDECL; SHORTCUT(p, Scm_PutzUnsafe(s, siz, p); return); WALKER_CHECK(p); LOCK(p); CLOSE_CHECK(p); if (siz < 0) siz = (ScmSize)strlen(s); switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: SAFE_CALL(p, bufport_write(p, s, siz)); if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_LINE) { const char *cp = PORT_BUF(p)->current; while (cp-- > PORT_BUF(p)->buffer) { if (*cp == '\n') { SAFE_CALL(p, bufport_flush(p, (cp - PORT_BUF(p)->current), FALSE)); break; } } } else if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_NONE) { SAFE_CALL(p, bufport_flush(p, 0, TRUE)); } UNLOCK(p); break; case SCM_PORT_OSTR: Scm_DStringPutz(PORT_OSTR(p), s, siz); UNLOCK(p); break; case SCM_PORT_PROC: SAFE_CALL(p, PORT_VT(p)->Putz(s, siz, p)); UNSAVE_POS(p); UNLOCK(p); break; default: UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_OUTPUT, "bad port type for output: %S", p); } } /*================================================================= * Flush */ #ifdef SAFE_PORT_OP void Scm_Flush(ScmPort *p) #else void Scm_FlushUnsafe(ScmPort *p) #endif { VMDECL; SHORTCUT(p, Scm_FlushUnsafe(p); return); WALKER_CHECK(p); LOCK(p); CLOSE_CHECK(p); switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: SAFE_CALL(p, bufport_flush(p, 0, TRUE)); UNLOCK(p); break; case SCM_PORT_OSTR: UNLOCK(p); break; case SCM_PORT_PROC: SAFE_CALL(p, PORT_VT(p)->Flush(p)); UNLOCK(p); break; default: UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_OUTPUT, "bad port type for output: %S", p); } } /*================================================================= * Ungetc & PeekChar */ #ifdef SAFE_PORT_OP void Scm_Ungetc(ScmChar c, ScmPort *p) #else void Scm_UngetcUnsafe(ScmChar c, ScmPort *p) #endif { VMDECL; SHORTCUT(p, Scm_UngetcUnsafe(c, p); return); LOCK(p); if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID || p->scrcnt != 0) { UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_INPUT, "pushback buffer overflow on port %S", p); } UNSAVE_POS(p); PORT_UNGOTTEN(p) = c; UNLOCK(p); } #ifdef SAFE_PORT_OP ScmChar Scm_Peekc(ScmPort *p) #else ScmChar Scm_PeekcUnsafe(ScmPort *p) #endif { VMDECL; SHORTCUT(p, return Scm_PeekcUnsafe(p)); LOCK(p); ScmChar ch = PORT_UNGOTTEN(p); if (ch == SCM_CHAR_INVALID) { volatile ScmObj saved_pos = SCM_UNBOUND; UNSAVE_POS(p); if (SCM_PORT_TYPE(p) == SCM_PORT_PROC && Scm_PortPositionable(p, FALSE)) { SAFE_CALL(p, saved_pos = Scm_PortSeekUnsafe(p, SCM_MAKE_INT(0), SEEK_CUR)); } SAFE_CALL(p, ch = Scm_GetcUnsafe(p)); PORT_UNGOTTEN(p) = ch; if (!SCM_UNBOUNDP(saved_pos)) { PORT_SAVED_POS(p) = saved_pos; } } UNLOCK(p); return ch; } /* At this moment we only allow one character to be 'ungotten', but we might change it in future, so this one returns a list. */ #ifdef SAFE_PORT_OP ScmObj Scm_UngottenChars(ScmPort *p) #else ScmObj Scm_UngottenCharsUnsafe(ScmPort *p) #endif { VMDECL; SHORTCUT(p, return Scm_UngottenCharsUnsafe(p)); LOCK(p); ScmChar ch = PORT_UNGOTTEN(p); UNLOCK(p); if (ch == SCM_CHAR_INVALID) { return SCM_NIL; } else { return SCM_LIST1(SCM_MAKE_CHAR(ch)); } } /*================================================================= * Ungetb & PeekByte */ #ifdef SAFE_PORT_OP void Scm_Ungetb(int b, ScmPort *p) #else void Scm_UngetbUnsafe(int b, ScmPort *p) #endif { VMDECL; SHORTCUT(p, Scm_UngetbUnsafe(b, p); return); LOCK(p); if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID || p->scrcnt >= SCM_CHAR_MAX_BYTES) { UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_INPUT, "pushback buffer overflow on port %S", p); } PORT_SCRATCH(p)[p->scrcnt++] = b; UNLOCK(p); } #ifdef SAFE_PORT_OP int Scm_Peekb(ScmPort *p) #else int Scm_PeekbUnsafe(ScmPort *p) #endif { int b; VMDECL; SHORTCUT(p, return Scm_PeekbUnsafe(p)); LOCK(p); if (p->scrcnt > 0) { b = (unsigned char)PORT_SCRATCH(p)[0]; } else { SCM_GETB(b, p); if (b >= 0) { if (p->scrcnt > 0) { /* unshift scratch buffer */ SCM_ASSERT(p->scrcnt < SCM_CHAR_MAX_BYTES); for (int i=p->scrcnt; i>0; i--) { PORT_SCRATCH(p)[i] = PORT_SCRATCH(p)[i-1]; } PORT_SCRATCH(p)[0] = b; p->scrcnt++; } else { PORT_SCRATCH(p)[0] = b; p->scrcnt = 1; } } } UNLOCK(p); return b; } #ifdef SAFE_PORT_OP ScmObj Scm_UngottenBytes(ScmPort *p) #else ScmObj Scm_UngottenBytesUnsafe(ScmPort *p) #endif { VMDECL; SHORTCUT(p, return Scm_UngottenBytesUnsafe(p)); char buf[SCM_CHAR_MAX_BYTES]; LOCK(p); for (int i=0; iscrcnt; i++) buf[i] = PORT_SCRATCH(p)[i]; int n = p->scrcnt; UNLOCK(p); ScmObj h = SCM_NIL, t = SCM_NIL; for (int i=0; iscrcnt; i++) { PORT_SCRATCH(p)[i] = PORT_SCRATCH(p)[i+off]; } } /* handle the case that there's remaining data in the scratch buffer */ static int getb_scratch(ScmPort *p) { int b = (unsigned char)PORT_SCRATCH(p)[0]; p->scrcnt--; shift_scratch(p, 1); return b; } /* handle the case that there's an ungotten char */ static int getb_ungotten(ScmPort *p) { SCM_CHAR_PUT(PORT_SCRATCH(p), PORT_UNGOTTEN(p)); p->scrcnt = SCM_CHAR_NBYTES(PORT_UNGOTTEN(p)); PORT_UNGOTTEN(p) = SCM_CHAR_INVALID; return getb_scratch(p); } #endif /*SHIFT_SCRATCH*/ /* Getb body */ #ifdef SAFE_PORT_OP int Scm_Getb(ScmPort *p) #else int Scm_GetbUnsafe(ScmPort *p) #endif { int b = 0; VMDECL; SHORTCUT(p, return Scm_GetbUnsafe(p)); LOCK(p); CLOSE_CHECK(p); /* check if there's "pushed back" stuff */ if (p->scrcnt) { b = getb_scratch(p); } else if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID) { b = getb_ungotten(p); } else { switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: if (PORT_BUF(p)->current >= PORT_BUF(p)->end) { ScmSize r = 0; SAFE_CALL(p, r = bufport_fill(p, 1, FALSE)); if (r == 0) { UNLOCK(p); return EOF; } } b = (unsigned char)*PORT_BUF(p)->current++; break; case SCM_PORT_ISTR: if (PORT_ISTR(p)->current >= PORT_ISTR(p)->end) b = EOF; else b = (unsigned char)*PORT_ISTR(p)->current++; break; case SCM_PORT_PROC: SAFE_CALL(p, b = PORT_VT(p)->Getb(p)); break; default: UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_INPUT, "bad port type for input: %S", p); } PORT_BYTES(p)++; /* we may mix binary/textual input, so we keep lines updated too. */ if (b == '\n') PORT_LINE(p)++; } UNLOCK(p); return b; } /*================================================================= * Getc */ /* handle the case that there's data in scratch area */ #ifdef SAFE_PORT_OP #define GETC_SCRATCH getc_scratch static int getc_scratch(ScmPort *p) #else #define GETC_SCRATCH getc_scratch_unsafe static int getc_scratch_unsafe(ScmPort *p) #endif { char tbuf[SCM_CHAR_MAX_BYTES]; int nb = SCM_CHAR_NFOLLOWS(PORT_SCRATCH(p)[0]); int curr = p->scrcnt; memcpy(tbuf, PORT_SCRATCH(p), curr); p->scrcnt = 0; for (volatile int i=curr; i<=nb; i++) { int r = EOF; SAFE_CALL(p, r = Scm_Getb(p)); if (r == EOF) { UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_INPUT, "encountered EOF in middle of a multibyte character from port %S", p); } tbuf[i] = (char)r; } int ch; SCM_CHAR_GET(tbuf, ch); if (ch == SCM_CHAR_INVALID) { /* This can happen if the input contains invalid byte sequence. We return the stray byte (which would eventually result an incomplete string when accumulated), while keeping the remaining bytes in the scrach buffer. */ ch = (ScmChar)(tbuf[0] & 0xff); memcpy(PORT_SCRATCH(p), tbuf+1, nb); p->scrcnt = nb; } return ch; } /* Getc body */ #ifdef SAFE_PORT_OP int Scm_Getc(ScmPort *p) #else int Scm_GetcUnsafe(ScmPort *p) #endif { VMDECL; SHORTCUT(p, return Scm_GetcUnsafe(p)); LOCK(p); CLOSE_CHECK(p); if (p->scrcnt > 0) { int r = GETC_SCRATCH(p); UNLOCK(p); return r; } if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID) { int c = PORT_UNGOTTEN(p); PORT_UNGOTTEN(p) = SCM_CHAR_INVALID; UNLOCK(p); return c; } switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: { int c = 0; if (PORT_BUF(p)->current >= PORT_BUF(p)->end) { ScmSize r = 0; SAFE_CALL(p, r = bufport_fill(p, 1, FALSE)); if (r == 0) { UNLOCK(p); return EOF; } } int first = (unsigned char)*PORT_BUF(p)->current++; int nb = SCM_CHAR_NFOLLOWS(first); PORT_BYTES(p)++; if (nb > 0) { if (PORT_BUF(p)->current + nb > PORT_BUF(p)->end) { /* The buffer doesn't have enough bytes to consist a char. move the incomplete char to the scratch buffer and try to fetch the rest of the char. */ volatile int rest; volatile ScmSize filled = 0; p->scrcnt = (unsigned char)(PORT_BUF(p)->end - PORT_BUF(p)->current + 1); memcpy(PORT_SCRATCH(p), PORT_BUF(p)->current-1, p->scrcnt); PORT_BUF(p)->current = PORT_BUF(p)->end; rest = nb + 1 - p->scrcnt; for (;;) { SAFE_CALL(p, filled = bufport_fill(p, rest, FALSE)); if (filled <= 0) { /* TODO: make this behavior customizable */ UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_INPUT, "encountered EOF in middle of a multibyte character from port %S", p); } if (filled >= rest) { memcpy(PORT_SCRATCH(p)+p->scrcnt, PORT_BUF(p)->current, rest); p->scrcnt += rest; PORT_BUF(p)->current += rest; break; } else { memcpy(PORT_SCRATCH(p)+p->scrcnt, PORT_BUF(p)->current, filled); p->scrcnt += filled; PORT_BUF(p)->current = PORT_BUF(p)->end; rest -= filled; } } SCM_CHAR_GET(PORT_SCRATCH(p), c); p->scrcnt = 0; } else { SCM_CHAR_GET(PORT_BUF(p)->current-1, c); PORT_BUF(p)->current += nb; } PORT_BYTES(p) += nb; } else { c = first; if (c == '\n') PORT_LINE(p)++; } UNLOCK(p); return c; } case SCM_PORT_ISTR: { if (PORT_ISTR(p)->current >= PORT_ISTR(p)->end) { UNLOCK(p); return EOF; } int c = 0; int first = (unsigned char)*PORT_ISTR(p)->current++; int nb = SCM_CHAR_NFOLLOWS(first); PORT_BYTES(p)++; if (nb > 0) { if (PORT_ISTR(p)->current + nb > PORT_ISTR(p)->end) { /* TODO: make this behavior customizable */ UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_INPUT, "encountered EOF in middle of a multibyte character from port %S", p); } SCM_CHAR_GET(PORT_ISTR(p)->current-1, c); PORT_ISTR(p)->current += nb; PORT_BYTES(p) += nb; } else { c = first; if (c == '\n') PORT_LINE(p)++; } UNLOCK(p); return c; } case SCM_PORT_PROC: { int c = 0; UNSAVE_POS(p); SAFE_CALL(p, c = PORT_VT(p)->Getc(p)); if (c == '\n') PORT_LINE(p)++; UNLOCK(p); return c; } default: UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_INPUT, "bad port type for input: %S", p); } return 0;/*dummy*/ } #undef GETC_SCRATCH /*================================================================= * Getz - block read. * If the buffering mode is BUFFER_FULL, this reads BUFLEN bytes * unless it reaches EOF. Otherwise, this reads less than BUFLEN * if the data is not immediately available. */ #ifdef SAFE_PORT_OP #define GETZ_SCRATCH getz_scratch static ScmSize getz_scratch(char *buf, ScmSize buflen, ScmPort *p) #else #define GETZ_SCRATCH getz_scratch_unsafe static ScmSize getz_scratch_unsafe(char *buf, ScmSize buflen, ScmPort *p) #endif { if (p->scrcnt >= (size_t)buflen) { memcpy(buf, PORT_SCRATCH(p), buflen); p->scrcnt -= buflen; shift_scratch(p, buflen); return buflen; } else { memcpy(buf, PORT_SCRATCH(p), p->scrcnt); ScmSize i = p->scrcnt; p->scrcnt = 0; ScmSize n = 0; SAFE_CALL(p, n = Scm_Getz(buf+i, buflen-i, p)); return i + n; } } #ifndef GETZ_ISTR /* common part */ #define GETZ_ISTR getz_istr static ScmSize getz_istr(ScmPort *p, char *buf, ScmSize buflen) { if (PORT_ISTR(p)->current + buflen >= PORT_ISTR(p)->end) { if (PORT_ISTR(p)->current >= PORT_ISTR(p)->end) return EOF; ScmSize siz = PORT_ISTR(p)->end - PORT_ISTR(p)->current; memcpy(buf, PORT_ISTR(p)->current, siz); PORT_ISTR(p)->current = PORT_ISTR(p)->end; return siz; } else { memcpy(buf, PORT_ISTR(p)->current, buflen); PORT_ISTR(p)->current += buflen; return buflen; } } #endif /*!GETZ_ISTR*/ #ifdef SAFE_PORT_OP ScmSize Scm_Getz(char *buf, ScmSize buflen, ScmPort *p) #else ScmSize Scm_GetzUnsafe(char *buf, ScmSize buflen, ScmPort *p) #endif { VMDECL; SHORTCUT(p, return Scm_GetzUnsafe(buf, buflen, p)); LOCK(p); CLOSE_CHECK(p); if (p->scrcnt) { ScmSize r = GETZ_SCRATCH(buf, buflen, p); UNLOCK(p); return r; } if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID) { p->scrcnt = SCM_CHAR_NBYTES(PORT_UNGOTTEN(p)); SCM_CHAR_PUT(PORT_SCRATCH(p), PORT_UNGOTTEN(p)); PORT_UNGOTTEN(p) = SCM_CHAR_INVALID; ScmSize r = GETZ_SCRATCH(buf, buflen, p); UNLOCK(p); return r; } switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: { ScmSize siz = 0; SAFE_CALL(p, siz = bufport_read(p, buf, buflen)); PORT_BYTES(p) += siz; UNLOCK(p); if (siz == 0) return EOF; else return siz; } case SCM_PORT_ISTR: { ScmSize r = GETZ_ISTR(p, buf, buflen); PORT_BYTES(p) += r; UNLOCK(p); return r; } case SCM_PORT_PROC: { ScmSize r = 0; UNSAVE_POS(p); SAFE_CALL(p, r = PORT_VT(p)->Getz(buf, buflen, p)); PORT_BYTES(p) += r; UNLOCK(p); return r; } default: UNLOCK(p); Scm_PortError(p, SCM_PORT_ERROR_INPUT, "bad port type for input: %S", p); } return -1; /* dummy */ } #undef GETZ_SCRATCH /*================================================================= * ReadLine * Reads up to EOL or EOF. */ /* Auxiliary procedures */ /* NB: it may be further optimized by scanning the contents of buffer when the port is a buffered port or an input string, which allows us to avoid mb->wc->mb conversion. See port.c, v 1.69 for some attempt to do so. The problem there is that if I have to take into account the cases of the ungotten char and the scratch buffer, code becomes ugly. There might be some better approach. */ #ifndef READLINE_AUX #define READLINE_AUX /* Assumes the port is locked, and the caller takes care of unlocking even if an error is signalled within this body */ /* NB: this routine reads bytes, not chars. It allows to readline from a port in unknown character encoding (e.g. reading the first line of xml doc to find out charset parameter). */ ScmObj readline_body(ScmPort *p) { ScmDString ds; Scm_DStringInit(&ds); int b1 = Scm_GetbUnsafe(p); if (b1 == EOF) return SCM_EOF; for (;;) { if (b1 == EOF) return Scm_DStringGet(&ds, 0); if (b1 == '\n') break; if (b1 == '\r') { int b2 = Scm_GetbUnsafe(p); if (b2 == EOF || b2 == '\n') break; Scm_UngetbUnsafe(b2, p); break; } SCM_DSTRING_PUTB(&ds, b1); b1 = Scm_GetbUnsafe(p); } PORT_LINE(p)++; return Scm_DStringGet(&ds, 0); } #endif /* READLINE_AUX */ #ifdef SAFE_PORT_OP ScmObj Scm_ReadLine(ScmPort *p) #else ScmObj Scm_ReadLineUnsafe(ScmPort *p) #endif { ScmObj r = SCM_UNDEFINED; VMDECL; SHORTCUT(p, return Scm_ReadLineUnsafe(p)); LOCK(p); SAFE_CALL(p, r = readline_body(p)); UNLOCK(p); return r; } /*================================================================= * ByteReady */ #ifdef SAFE_PORT_OP int Scm_ByteReady(ScmPort *p) #else int Scm_ByteReadyUnsafe(ScmPort *p) #endif { int r = 0; VMDECL; SHORTCUT(p, return Scm_ByteReadyUnsafe(p)); if (!SCM_IPORTP(p)) Scm_Error("input port required, but got %S", p); LOCK(p); if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID || p->scrcnt > 0) { r = TRUE; } else { switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: if (PORT_BUF(p)->current < PORT_BUF(p)->end) r = TRUE; else if (PORT_BUF(p)->ready == NULL) r = TRUE; else { SAFE_CALL(p, r = (PORT_BUF(p)->ready(p) != SCM_FD_WOULDBLOCK)); } break; case SCM_PORT_PROC: SAFE_CALL(p, r = PORT_VT(p)->Ready(p, FALSE)); break; default: r = TRUE; } } UNLOCK(p); return r; } /*================================================================= * CharReady */ #ifdef SAFE_PORT_OP int Scm_CharReady(ScmPort *p) #else int Scm_CharReadyUnsafe(ScmPort *p) #endif { int r = 0; VMDECL; SHORTCUT(p, return Scm_CharReadyUnsafe(p)); if (!SCM_IPORTP(p)) Scm_Error("input port required, but got %S", p); LOCK(p); if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID) r = TRUE; else { switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: if (PORT_BUF(p)->current < PORT_BUF(p)->end) r = TRUE; else if (PORT_BUF(p)->ready == NULL) r = TRUE; else { SAFE_CALL(p, r = (PORT_BUF(p)->ready(p) != SCM_FD_WOULDBLOCK)); } break; case SCM_PORT_PROC: SAFE_CALL(p, r = PORT_VT(p)->Ready(p, TRUE)); break; default: r = TRUE; } } UNLOCK(p); return r; } /*================================================================= * Port Positioning */ /* See the comment in port.h (Port Positioning Interface) */ /* For the sake of seek/tell, we treat scratch buffer and ungotten char (collectively we call them pending bytes here) as if it's a cache--- that is, we assume their content always mirrors the real content of the underlying data. If port_pending_bytes() > 0, the "external" current position visible from outside, and the "internal" current position that points into the underlying data, differ. We discard the pending bytes and adjust the target offset, if the target offset is relative to the current position (SEEK_CUR). One optimization, though; if whence == SEEK_CUR and offset = 0, we don't need to move anything. It's just to get the current offset. For this case, instead of adjusting offset, we adjust the result. */ #ifndef PORT_PENDING_BYTES /* common part */ #define PORT_PENDING_BYTES port_pending_bytes static off_t port_pending_bytes(ScmPort *p) { off_t unread_bytes = p->scrcnt; if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID) { unread_bytes += SCM_CHAR_NBYTES(PORT_UNGOTTEN(p)); } return unread_bytes; } #endif /*PORT_PENDING_BYTES*/ #ifndef SEEK_ISTR /* common part */ #define SEEK_ISTR seek_istr static ScmObj seek_istr(ScmPort *p, ScmObj off, int whence) { /* If the port is istr, offset must always be an integer. */ off_t o = Scm_IntegerToOffset(off); off_t rr; if (whence == SEEK_CUR) { o += (off_t)(PORT_ISTR(p)->current - PORT_ISTR(p)->start); } else if (whence == SEEK_END) { o += (off_t)(PORT_ISTR(p)->end - PORT_ISTR(p)->start); } if (o < 0 || o > (off_t)(PORT_ISTR(p)->end - PORT_ISTR(p)->start)) { rr = (off_t)-1; } else { PORT_ISTR(p)->current = PORT_ISTR(p)->start + o; rr = (off_t)(PORT_ISTR(p)->current - PORT_ISTR(p)->start); } PORT_UNGOTTEN(p) = SCM_CHAR_INVALID; p->scrcnt = 0; if (rr == (off_t)-1) return SCM_FALSE; return Scm_OffsetToInteger(rr); } #endif /*SEEK_ISTR*/ #ifdef SAFE_PORT_OP ScmObj Scm_GetPortPosition(ScmPort *p) #else ScmObj Scm_GetPortPositionUnsafe(ScmPort *p) #endif { VMDECL; SHORTCUT(p, return Scm_GetPortPositionUnsafe(p)); if (SCM_PORT_CLOSED_P(p)) { Scm_PortError(p, SCM_PORT_ERROR_CLOSED, "attempt to take a position of a closed port: %S", p); } ScmObj r = SCM_MAKE_INT(0); volatile off_t pending_bytes = port_pending_bytes(p); int err_disabled = FALSE; int err_badpos = FALSE; LOCK(p); switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: { off_t rr; if (PORT_BUF(p)->getpos) { SAFE_CALL(p, r = PORT_BUF(p)->getpos(p)); if (!SCM_INTEGERP(r)) { err_badpos = TRUE; break; } rr = Scm_IntegerToOffset(r); } else if (PORT_BUF(p)->seeker) { SAFE_CALL(p, rr = PORT_BUF(p)->seeker(p, 0, SEEK_CUR)); } else { err_disabled = TRUE; break; } if (SCM_PORT_DIR(p)&SCM_PORT_INPUT) { rr -= (off_t)(PORT_BUF(p)->end - PORT_BUF(p)->current); } else { rr += (off_t)(PORT_BUF(p)->current - PORT_BUF(p)->buffer); } r = Scm_OffsetToInteger(rr); } break; case SCM_PORT_ISTR: r = Scm_OffsetToInteger(PORT_ISTR(p)->current - PORT_ISTR(p)->start); break; case SCM_PORT_OSTR: r = Scm_MakeInteger(Scm_DStringSize(PORT_OSTR(p))); break; case SCM_PORT_PROC: /* For procedural bytes, the positioning of pending bytes is taken care of by PORT_SAVED_POS, so we set pending_bytes to 0.*/ pending_bytes = 0; if (PORT_VT(p)->GetPos) { r = PORT_SAVED_POS(p); if (SCM_UNBOUNDP(r)) { SAFE_CALL(p, r = PORT_VT(p)->GetPos(p)); } } else if (PORT_VT(p)->Seek) { off_t rr; UNSAVE_POS(p); SAFE_CALL(p, rr = PORT_VT(p)->Seek(p, 0, SEEK_CUR)); r = Scm_OffsetToInteger(rr); } else { err_disabled = TRUE; } break; } UNLOCK(p); if (err_disabled) { Scm_PortError(p, SCM_PORT_ERROR_SEEK, "getting port position is disabled"); } if (err_badpos) { Scm_PortError(p, SCM_PORT_ERROR_SEEK, "getpos method returned invalid position: %S", r); } if (pending_bytes > 0) { if (r == SCM_MAKE_INT(-1)) return SCM_FALSE; if (!SCM_INTEGERP(r)) return FALSE; r = Scm_Sub(r, Scm_OffsetToInteger(pending_bytes)); } return r; } /* Common routine for Scm_SetPortPosition and Scm_PortSeek. */ #ifndef SET_PORT_POSITION #define SET_PORT_POSITION static ScmObj set_port_position(ScmPort *p, ScmObj pos, int whence) { VMDECL; LOCK(p); volatile ScmObj off = pos; ScmObj r = SCM_UNDEFINED; int err_disabled = FALSE; off_t pending = port_pending_bytes(p); /* We discard pending bytes. */ p->scrcnt = 0; PORT_UNGOTTEN(p) = SCM_CHAR_INVALID; /* ... and adjust offset, when it's relative. NB: This only matters if the port has seeker protocol, instead of getpos/setpos protocol. */ if (SCM_PORT_TYPE(p) != SCM_PORT_PROC && whence == SEEK_CUR && SCM_INTEGERP(off)) { off = Scm_Sub(off, SCM_MAKE_INT(pending)); } switch (SCM_PORT_TYPE(p)) { case SCM_PORT_FILE: if (PORT_BUF(p)->setpos && whence == SEEK_SET) { SAFE_CALL(p, PORT_BUF(p)->setpos(p, off)); r = off; break; } /* NB: we might be able to skip calling seeker if we keep the # of bytes read or write so far, but such count may be off when the port has been experienced an error condition. */ /* NB: the following doesn't work if we have bidirectional port. In such case we need to keep whether the last call of buffer handling routine was input or output. */ if (PORT_BUF(p)->seeker) { /* NB: possible optimization: the specified position is within the current buffer, we can avoid calling seeker. */ off_t rr; if (SCM_PORT_DIR(p)&SCM_PORT_INPUT) { char *c = PORT_BUF(p)->current; /* save current ptr */ if (whence == SEEK_CUR) { off = Scm_Sub(off, Scm_MakeIntegerU(PORT_BUF(p)->end - c)); } PORT_BUF(p)->current = PORT_BUF(p)->end; /* invalidate buffer */ SAFE_CALL(p, rr = PORT_BUF(p)->seeker(p, Scm_IntegerToOffset(off), whence)); if (rr == (off_t)-1) { /* This may happened if seeker somehow gave up */ PORT_BUF(p)->current = c; } } else { SAFE_CALL(p, bufport_flush(p, 0, TRUE)); SAFE_CALL(p, rr = PORT_BUF(p)->seeker(p, Scm_IntegerToOffset(off), whence)); } if (rr == (off_t)-1) { r = SCM_FALSE; } else { r = Scm_OffsetToInteger(rr); } } else { err_disabled = TRUE; } break; case SCM_PORT_ISTR: r = SEEK_ISTR(p, off, whence); break; case SCM_PORT_OSTR: /* Not supported yet */ r = SCM_FALSE; break; case SCM_PORT_PROC: if (PORT_VT(p)->SetPos && whence == SEEK_SET) { UNSAVE_POS(p); SAFE_CALL(p, PORT_VT(p)->SetPos(p, off)); r = off; } else if (PORT_VT(p)->Seek) { UNSAVE_POS(p); off_t rr; SAFE_CALL(p, rr = PORT_VT(p)->Seek(p, Scm_IntegerToOffset(off), whence)); r = Scm_OffsetToInteger(rr); } else { err_disabled = TRUE; } break; } UNLOCK(p); if (err_disabled) { Scm_PortError(p, SCM_PORT_ERROR_SEEK, "setting port position is disabled"); } return r; } ScmObj Scm_SetPortPosition(ScmPort *p, ScmObj pos) { return set_port_position(p, pos, SEEK_SET); } #endif /* SET_PORT_POSITION */ /* srfi-181 allows port positions to be any Scheme object, so off argument and return value can be any Scheme object---if it's not an exact integer, it should be an object returned by getpos callback. If the port only has seeker callback, it must be an exact integer. If the port implements setpos callback, whence must be SEEK_SET for setting position. */ #ifdef SAFE_PORT_OP ScmObj Scm_PortSeek(ScmPort *p, volatile ScmObj off, int whence) #else ScmObj Scm_PortSeekUnsafe(ScmPort *p, ScmObj off, int whence) #endif { if (whence == SEEK_CUR && off == SCM_MAKE_INT(0)) { return Scm_GetPortPosition(p); } else { return set_port_position(p, off, whence); } } /*================================================================= * Port Attributes * * Port attributes are stored in alist. Each entry is either one * of the following form: * (key value) Just a value * (key value . #f) Just a value, read-only. This is a system * attribute; no public interface to create this * kind of API is provided. It is also undeletable. * (Currently, only the internal port constructor * creates this kind of attributes.) * (key getter setter) Procedurally handled value. Getter will be * called as (getter port [fallback]), and Setter * will be called as (setter port value). * Setter can be #f if the attr is read-only. * Port is locked while getter and setter is called. * * The third type of attribute can be created by Scm_PortAttrCreate. * * TODO: probably we want deletable and undeletable procedural values. */ #ifdef SAFE_PORT_OP ScmObj Scm_PortAttrGet(ScmPort *p, ScmObj key, ScmObj fallback) #else ScmObj Scm_PortAttrGetUnsafe(ScmPort *p, ScmObj key, ScmObj fallback) #endif { ScmObj r = SCM_UNBOUND; VMDECL; SHORTCUT(p, return Scm_PortAttrGetUnsafe(p, key, fallback);); LOCK(p); ScmObj v = Scm_Assq(key, PORT_ATTRS(p)); if (SCM_PAIRP(v)) { SCM_ASSERT(SCM_PAIRP(SCM_CDR(v))); if (SCM_PAIRP(SCM_CDDR(v))) { /* procedural */ ScmObj getter = SCM_CADR(v); if (SCM_UNBOUNDP(fallback)) { SAFE_CALL(p, r = Scm_ApplyRec1(getter, SCM_OBJ(p))); } else { SAFE_CALL(p, r = Scm_ApplyRec2(getter, SCM_OBJ(p), fallback)); } } else { r = SCM_CADR(v); } } else { r = fallback; } UNLOCK(p); if (SCM_UNBOUNDP(r)) { Scm_Error("No port attribute for key %S in port %S", key, SCM_OBJ(p)); } return r; } #ifdef SAFE_PORT_OP ScmObj Scm_PortAttrSet(ScmPort *p, ScmObj key, ScmObj val) #else ScmObj Scm_PortAttrSetUnsafe(ScmPort *p, ScmObj key, ScmObj val) #endif { volatile int err_readonly = FALSE; volatile int exists = FALSE; VMDECL; SHORTCUT(p, return Scm_PortAttrSetUnsafe(p, key, val);); LOCK(p); ScmObj v = Scm_Assq(key, PORT_ATTRS(p)); if (SCM_PAIRP(v)) { SCM_ASSERT(SCM_PAIRP(SCM_CDR(v))); exists = TRUE; if (SCM_PAIRP(SCM_CDDR(v))) { /* procedural */ ScmObj setter = SCM_CAR(SCM_CDDR(v)); if (SCM_FALSEP(setter)) { err_readonly = TRUE; } else { SAFE_CALL(p, Scm_ApplyRec2(setter, SCM_OBJ(p), val)); } } else if (SCM_NULLP(SCM_CDDR(v))) { SCM_SET_CAR_UNCHECKED(SCM_CDR(v), val); } else { err_readonly = TRUE; } } else { PORT_ATTRS(p) = Scm_Cons(SCM_LIST2(key, val), PORT_ATTRS(p)); } UNLOCK(p); if (err_readonly) { Scm_Error("Port attribute '%A' is read-only in port: %S", key, SCM_OBJ(p)); } return SCM_MAKE_BOOL(exists); } #ifdef SAFE_PORT_OP ScmObj Scm_PortAttrCreate(ScmPort *p, ScmObj key, ScmObj get, ScmObj set) #else ScmObj Scm_PortAttrCreateUnsafe(ScmPort *p, ScmObj key, ScmObj get, ScmObj set) #endif { int err_exists = FALSE; VMDECL; SHORTCUT(p, return Scm_PortAttrCreateUnsafe(p, key, get, set);); /* If get == #f, we create an ordinary attr entry. Otherwise, we create a procedural entry. */ ScmObj entry = (SCM_FALSEP(get) ? SCM_LIST2(key, SCM_FALSE) : SCM_LIST3(key, get, set)); LOCK(p); ScmObj v = Scm_Assq(key, PORT_ATTRS(p)); if (SCM_FALSEP(v)) { PORT_ATTRS(p) = Scm_Cons(entry, PORT_ATTRS(p)); } else { err_exists = TRUE; } UNLOCK(p); if (err_exists) { Scm_Error("Couldn't create port attribute %A in %S: Named attribute already exists.", key, SCM_OBJ(p)); } return SCM_UNDEFINED; /* we may return more useful info in future */ } #ifdef SAFE_PORT_OP ScmObj Scm_PortAttrDelete(ScmPort *p, ScmObj key) #else ScmObj Scm_PortAttrDeleteUnsafe(ScmPort *p, ScmObj key) #endif { int err_undeletable = FALSE; VMDECL; SHORTCUT(p, return Scm_PortAttrDeleteUnsafe(p, key);); LOCK(p); ScmObj v = Scm_Assq(key, PORT_ATTRS(p)); if (SCM_PAIRP(v) && SCM_PAIRP(SCM_CDR(v)) && SCM_FALSEP(SCM_CDDR(v))) { err_undeletable = TRUE; } else { PORT_ATTRS(p) = Scm_AssocDelete(key, PORT_ATTRS(p), SCM_CMP_EQ); } UNLOCK(p); if (err_undeletable) { Scm_Error("Port attribute '%A' is not deletable from port: %S", key, SCM_OBJ(p)); } return SCM_UNDEFINED; /* we may return more useful info in future */ } #ifdef SAFE_PORT_OP ScmObj Scm_PortAttrs(ScmPort *p) #else ScmObj Scm_PortAttrsUnsafe(ScmPort *p) #endif { ScmObj h = SCM_NIL, t = SCM_NIL; VMDECL; SHORTCUT(p, return Scm_PortAttrsUnsafe(p);); LOCK(p); ScmObj cp; SCM_FOR_EACH(cp, PORT_ATTRS(p)) { ScmObj k = SCM_CAAR(cp); ScmObj v = Scm_PortAttrGetUnsafe(p, k, SCM_UNBOUND); SCM_APPEND1(h, t, Scm_Cons(k, v)); } UNLOCK(p); return h; } #undef VMDECL #undef LOCK #undef UNLOCK #undef SAFE_CALL #undef SHORTCUT #undef CLOSE_CHECK