1 /*
2  * portapi.c - port common API
3  *
4  *   Copyright (c) 2000-2020  Shiro Kawai  <shiro@acm.org>
5  *
6  *   Redistribution and use in source and binary forms, with or without
7  *   modification, are permitted provided that the following conditions
8  *   are met:
9  *
10  *   1. Redistributions of source code must retain the above copyright
11  *      notice, this list of conditions and the following disclaimer.
12  *
13  *   2. Redistributions in binary form must reproduce the above copyright
14  *      notice, this list of conditions and the following disclaimer in the
15  *      documentation and/or other materials provided with the distribution.
16  *
17  *   3. Neither the name of the authors nor the names of its contributors
18  *      may be used to endorse or promote products derived from this
19  *      software without specific prior written permission.
20  *
21  *   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22  *   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23  *   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24  *   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25  *   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26  *   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27  *   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28  *   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29  *   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30  *   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31  *   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32  */
33 
34 /* This file is included _twice_ by port.c to define safe- and unsafe-
35  * variant of port common APIs.  It is to minimize the overhead of
36  * locking operations.
37  *
38  * The macro SHORTCUT allows 'safe' version to bypass lock/unlock
39  * stuff by calling 'unsafe' version when the port is already locked by
40  * the calling thread.
41  */
42 
43 /* [scratch and ungottern buffer]
44  *   It is always possible to mix binary and character i/o for Gauche's
45  *   ports.  To support peek operations in Scheme and 'unget' operations
46  *   in C, we need to buffer at most one character or its equivalent
47  *   byte sequence.   The 'ungotten' and 'scratch' fields are used for
48  *   character and binary buffering, respectively.
49  *   (This level of buffering is common to all input port types, and
50  *   distinct from the buffering of 'buffered' (file) port type.)
51  *
52  *   'Ungotten' field keeps SCM__CHAR_INVALID if there's no buffered
53  *   character.  Otherwise, its value is the buffered character.
54  *   The number of bytes in the 'scratch' array is kept in 'scrcnt'
55  *   field.  If 'scrcnt' field is not zero, there's data in the
56  *   'scratch' array.
57  *
58  *   In no cases there should be data in both ungotten and scratch
59  *   field.  The consistency is taken care of the routines defined here;
60  *   no other routine should touch these buffering field.
61  */
62 
63 #ifdef SAFE_PORT_OP
64 #define VMDECL        ScmVM *vm = Scm_VM()
65 #define LOCK(p)       PORT_LOCK(p, vm)
66 #define UNLOCK(p)     PORT_UNLOCK(p)
67 #define SAFE_CALL(p, exp) PORT_SAFE_CALL(p, exp, /*no cleanup*/)
68 #define SHORTCUT(p, unsafe) \
69   do { if (PORT_LOCKED(p, vm)) { unsafe; }} while (0)
70 #else
71 #define VMDECL        /*none*/
72 #define LOCK(p)       /*none*/
73 #define UNLOCK(p)     /*none*/
74 #define SAFE_CALL(p, exp) (exp)
75 #define SHORTCUT(p, unsafe) /* none */
76 #endif
77 
78 /* Convenience macro */
79 #ifndef CLOSE_CHECK
80 #define CLOSE_CHECK(port)                                               \
81     do {                                                                \
82         if (SCM_PORT_CLOSED_P(port)) {                                  \
83             UNLOCK(p);                                                  \
84             Scm_PortError((port), SCM_PORT_ERROR_CLOSED,                \
85                           "I/O attempted on closed port: %S", (port));  \
86         }                                                               \
87     } while (0)
88 #endif /* CLOSE_CHECK */
89 
90 #ifndef UNSAVE_POS
91 #define UNSAVE_POS(port) PORT_SAVED_POS(port) = SCM_UNBOUND
92 #endif  /* UNSAVE_POS */
93 
94 
95 /* In the walk pass of multi-pass writing (see write.c), we set
96    SCM_PORT_WALKING flag of the port.  Usually Scm_Write family recognizes
97    the flag and suppress output.  However, in case if low-level port API
98    is directly called during the walk pass, we just check the flag again.
99 */
100 #ifndef WALKER_CHECK
101 #define WALKER_CHECK(port)                      \
102     do {                                        \
103         if (PORT_WALKER_P(port)) return;        \
104     } while (0)
105 #endif /* WALKER_CHECK */
106 
107 /*=================================================================
108  * Putb
109  */
110 
111 #ifdef SAFE_PORT_OP
Scm_Putb(ScmByte b,ScmPort * p)112 void Scm_Putb(ScmByte b, ScmPort *p)
113 #else
114 void Scm_PutbUnsafe(ScmByte b, ScmPort *p)
115 #endif
116 {
117     VMDECL;
118     SHORTCUT(p, Scm_PutbUnsafe(b, p); return);
119     WALKER_CHECK(p);
120     LOCK(p);
121     CLOSE_CHECK(p);
122 
123     switch (SCM_PORT_TYPE(p)) {
124     case SCM_PORT_FILE:
125         if (PORT_BUF(p)->current >= PORT_BUF(p)->end) {
126             SAFE_CALL(p, bufport_flush(p, PORT_BUF(p)->current - PORT_BUF(p)->buffer, FALSE));
127         }
128         SCM_ASSERT(PORT_BUF(p)->current < PORT_BUF(p)->end);
129         *PORT_BUF(p)->current++ = b;
130         if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_NONE) {
131             SAFE_CALL(p, bufport_flush(p, 1, FALSE));
132         }
133         UNLOCK(p);
134         break;
135     case SCM_PORT_OSTR:
136         SCM_DSTRING_PUTB(PORT_OSTR(p), b);
137         UNLOCK(p);
138         break;
139     case SCM_PORT_PROC:
140         SAFE_CALL(p, PORT_VT(p)->Putb(b, p));
141         UNLOCK(p);
142         break;
143     default:
144         UNLOCK(p);
145         Scm_PortError(p, SCM_PORT_ERROR_OUTPUT,
146                       "bad port type for output: %S", p);
147     }
148 }
149 
150 /*=================================================================
151  * Putc
152  */
153 
154 #ifdef SAFE_PORT_OP
Scm_Putc(ScmChar c,ScmPort * p)155 void Scm_Putc(ScmChar c, ScmPort *p)
156 #else
157 void Scm_PutcUnsafe(ScmChar c, ScmPort *p)
158 #endif
159 {
160     VMDECL;
161     SHORTCUT(p, Scm_PutcUnsafe(c, p); return);
162     WALKER_CHECK(p);
163     LOCK(p);
164     CLOSE_CHECK(p);
165 
166     switch (SCM_PORT_TYPE(p)) {
167     case SCM_PORT_FILE: {
168         volatile int nb = SCM_CHAR_NBYTES(c);
169         if (PORT_BUF(p)->current+nb > PORT_BUF(p)->end) {
170             SAFE_CALL(p, bufport_flush(p, PORT_BUF(p)->current - PORT_BUF(p)->buffer, FALSE));
171         }
172         SCM_ASSERT(PORT_BUF(p)->current+nb <= PORT_BUF(p)->end);
173         SCM_CHAR_PUT(PORT_BUF(p)->current, c);
174         PORT_BUF(p)->current += nb;
175         if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_LINE) {
176             if (c == '\n') {
177                 SAFE_CALL(p, bufport_flush(p, nb, FALSE));
178             }
179         } else if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_NONE) {
180             SAFE_CALL(p, bufport_flush(p, nb, FALSE));
181         }
182         UNLOCK(p);
183         break;
184     }
185     case SCM_PORT_OSTR:
186         SCM_DSTRING_PUTC(PORT_OSTR(p), c);
187         UNLOCK(p);
188         break;
189     case SCM_PORT_PROC:
190         SAFE_CALL(p, PORT_VT(p)->Putc(c, p));
191         UNSAVE_POS(p);
192         UNLOCK(p);
193         break;
194     default:
195         UNLOCK(p);
196         Scm_PortError(p, SCM_PORT_ERROR_OUTPUT,
197                       "bad port type for output: %S", p);
198     }
199 }
200 
201 /*=================================================================
202  * Puts
203  */
204 
205 #ifdef SAFE_PORT_OP
Scm_Puts(ScmString * s,ScmPort * p)206 void Scm_Puts(ScmString *s, ScmPort *p)
207 #else
208 void Scm_PutsUnsafe(ScmString *s, ScmPort *p)
209 #endif
210 {
211     VMDECL;
212     SHORTCUT(p, Scm_PutsUnsafe(s, p); return);
213     WALKER_CHECK(p);
214     LOCK(p);
215     CLOSE_CHECK(p);
216 
217     switch (SCM_PORT_TYPE(p)) {
218     case SCM_PORT_FILE: {
219         ScmSmallInt size;
220         const char *ss = Scm_GetStringContent(s, &size, NULL, NULL);
221         SAFE_CALL(p, bufport_write(p, ss, size));
222 
223         if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_LINE) {
224             const char *cp = PORT_BUF(p)->current;
225             while (cp-- > PORT_BUF(p)->buffer) {
226                 if (*cp == '\n') {
227                     SAFE_CALL(p, bufport_flush(p, cp - PORT_BUF(p)->current, FALSE));
228                     break;
229                 }
230             }
231         } else if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_NONE) {
232             SAFE_CALL(p, bufport_flush(p, 0, TRUE));
233         }
234         UNLOCK(p);
235         break;
236     }
237     case SCM_PORT_OSTR:
238         Scm_DStringAdd(PORT_OSTR(p), s);
239         UNLOCK(p);
240         break;
241     case SCM_PORT_PROC:
242         SAFE_CALL(p, PORT_VT(p)->Puts(s, p));
243         UNSAVE_POS(p);
244         UNLOCK(p);
245         break;
246     default:
247         UNLOCK(p);
248         Scm_PortError(p, SCM_PORT_ERROR_OUTPUT,
249                       "bad port type for output: %S", p);
250     }
251 }
252 
253 /*=================================================================
254  * Putz
255  */
256 
257 #ifdef SAFE_PORT_OP
Scm_Putz(const char * s,volatile ScmSize siz,ScmPort * p)258 void Scm_Putz(const char *s, volatile ScmSize siz, ScmPort *p)
259 #else
260 void Scm_PutzUnsafe(const char *s, volatile ScmSize siz, ScmPort *p)
261 #endif
262 {
263     VMDECL;
264     SHORTCUT(p, Scm_PutzUnsafe(s, siz, p); return);
265     WALKER_CHECK(p);
266     LOCK(p);
267     CLOSE_CHECK(p);
268     if (siz < 0) siz = (ScmSize)strlen(s);
269     switch (SCM_PORT_TYPE(p)) {
270     case SCM_PORT_FILE:
271         SAFE_CALL(p, bufport_write(p, s, siz));
272         if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_LINE) {
273             const char *cp = PORT_BUF(p)->current;
274             while (cp-- > PORT_BUF(p)->buffer) {
275                 if (*cp == '\n') {
276                     SAFE_CALL(p, bufport_flush(p, (cp - PORT_BUF(p)->current), FALSE));
277                     break;
278                 }
279             }
280         } else if (PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_NONE) {
281             SAFE_CALL(p, bufport_flush(p, 0, TRUE));
282         }
283         UNLOCK(p);
284         break;
285     case SCM_PORT_OSTR:
286         Scm_DStringPutz(PORT_OSTR(p), s, siz);
287         UNLOCK(p);
288         break;
289     case SCM_PORT_PROC:
290         SAFE_CALL(p, PORT_VT(p)->Putz(s, siz, p));
291         UNSAVE_POS(p);
292         UNLOCK(p);
293         break;
294     default:
295         UNLOCK(p);
296         Scm_PortError(p, SCM_PORT_ERROR_OUTPUT,
297                       "bad port type for output: %S", p);
298     }
299 }
300 
301 /*=================================================================
302  * Flush
303  */
304 
305 #ifdef SAFE_PORT_OP
Scm_Flush(ScmPort * p)306 void Scm_Flush(ScmPort *p)
307 #else
308 void Scm_FlushUnsafe(ScmPort *p)
309 #endif
310 {
311     VMDECL;
312     SHORTCUT(p, Scm_FlushUnsafe(p); return);
313     WALKER_CHECK(p);
314     LOCK(p);
315     CLOSE_CHECK(p);
316     switch (SCM_PORT_TYPE(p)) {
317     case SCM_PORT_FILE:
318         SAFE_CALL(p, bufport_flush(p, 0, TRUE));
319         UNLOCK(p);
320         break;
321     case SCM_PORT_OSTR:
322         UNLOCK(p);
323         break;
324     case SCM_PORT_PROC:
325         SAFE_CALL(p, PORT_VT(p)->Flush(p));
326         UNLOCK(p);
327         break;
328     default:
329         UNLOCK(p);
330         Scm_PortError(p, SCM_PORT_ERROR_OUTPUT,
331                       "bad port type for output: %S", p);
332     }
333 }
334 
335 /*=================================================================
336  * Ungetc & PeekChar
337  */
338 
339 #ifdef SAFE_PORT_OP
Scm_Ungetc(ScmChar c,ScmPort * p)340 void Scm_Ungetc(ScmChar c, ScmPort *p)
341 #else
342 void Scm_UngetcUnsafe(ScmChar c, ScmPort *p)
343 #endif
344 {
345     VMDECL;
346     SHORTCUT(p, Scm_UngetcUnsafe(c, p); return);
347     LOCK(p);
348     if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID
349         || p->scrcnt != 0) {
350         UNLOCK(p);
351         Scm_PortError(p, SCM_PORT_ERROR_INPUT,
352                       "pushback buffer overflow on port %S", p);
353     }
354     UNSAVE_POS(p);
355     PORT_UNGOTTEN(p) = c;
356     UNLOCK(p);
357 }
358 
359 #ifdef SAFE_PORT_OP
Scm_Peekc(ScmPort * p)360 ScmChar Scm_Peekc(ScmPort *p)
361 #else
362 ScmChar Scm_PeekcUnsafe(ScmPort *p)
363 #endif
364 {
365     VMDECL;
366     SHORTCUT(p, return Scm_PeekcUnsafe(p));
367     LOCK(p);
368     ScmChar ch = PORT_UNGOTTEN(p);
369     if (ch == SCM_CHAR_INVALID) {
370         volatile ScmObj saved_pos = SCM_UNBOUND;
371         UNSAVE_POS(p);
372         if (SCM_PORT_TYPE(p) == SCM_PORT_PROC
373             && Scm_PortPositionable(p, FALSE)) {
374             SAFE_CALL(p, saved_pos = Scm_PortSeekUnsafe(p, SCM_MAKE_INT(0), SEEK_CUR));
375         }
376         SAFE_CALL(p, ch = Scm_GetcUnsafe(p));
377         PORT_UNGOTTEN(p) = ch;
378         if (!SCM_UNBOUNDP(saved_pos)) {
379             PORT_SAVED_POS(p) = saved_pos;
380         }
381     }
382     UNLOCK(p);
383     return ch;
384 }
385 
386 /* At this moment we only allow one character to be 'ungotten',
387    but we might change it in future, so this one returns a list. */
388 #ifdef SAFE_PORT_OP
Scm_UngottenChars(ScmPort * p)389 ScmObj Scm_UngottenChars(ScmPort *p)
390 #else
391 ScmObj Scm_UngottenCharsUnsafe(ScmPort *p)
392 #endif
393 {
394     VMDECL;
395     SHORTCUT(p, return Scm_UngottenCharsUnsafe(p));
396     LOCK(p);
397     ScmChar ch = PORT_UNGOTTEN(p);
398     UNLOCK(p);
399     if (ch == SCM_CHAR_INVALID) {
400         return SCM_NIL;
401     } else {
402         return SCM_LIST1(SCM_MAKE_CHAR(ch));
403     }
404 }
405 
406 /*=================================================================
407  * Ungetb & PeekByte
408  */
409 
410 #ifdef SAFE_PORT_OP
Scm_Ungetb(int b,ScmPort * p)411 void Scm_Ungetb(int b, ScmPort *p)
412 #else
413 void Scm_UngetbUnsafe(int b, ScmPort *p)
414 #endif
415 {
416     VMDECL;
417     SHORTCUT(p, Scm_UngetbUnsafe(b, p); return);
418     LOCK(p);
419     if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID
420         || p->scrcnt >= SCM_CHAR_MAX_BYTES) {
421         UNLOCK(p);
422         Scm_PortError(p, SCM_PORT_ERROR_INPUT,
423                       "pushback buffer overflow on port %S", p);
424     }
425     PORT_SCRATCH(p)[p->scrcnt++] = b;
426     UNLOCK(p);
427 }
428 
429 #ifdef SAFE_PORT_OP
Scm_Peekb(ScmPort * p)430 int Scm_Peekb(ScmPort *p)
431 #else
432 int Scm_PeekbUnsafe(ScmPort *p)
433 #endif
434 {
435     int b;
436     VMDECL;
437     SHORTCUT(p, return Scm_PeekbUnsafe(p));
438     LOCK(p);
439     if (p->scrcnt > 0) {
440         b = (unsigned char)PORT_SCRATCH(p)[0];
441     } else {
442         SCM_GETB(b, p);
443         if (b >= 0) {
444             if (p->scrcnt > 0) {
445                 /* unshift scratch buffer */
446                 SCM_ASSERT(p->scrcnt < SCM_CHAR_MAX_BYTES);
447                 for (int i=p->scrcnt; i>0; i--) {
448                     PORT_SCRATCH(p)[i] = PORT_SCRATCH(p)[i-1];
449                 }
450                 PORT_SCRATCH(p)[0] = b;
451                 p->scrcnt++;
452             } else {
453                 PORT_SCRATCH(p)[0] = b;
454                 p->scrcnt = 1;
455             }
456         }
457     }
458     UNLOCK(p);
459     return b;
460 }
461 
462 #ifdef SAFE_PORT_OP
Scm_UngottenBytes(ScmPort * p)463 ScmObj Scm_UngottenBytes(ScmPort *p)
464 #else
465 ScmObj Scm_UngottenBytesUnsafe(ScmPort *p)
466 #endif
467 {
468     VMDECL;
469     SHORTCUT(p, return Scm_UngottenBytesUnsafe(p));
470     char buf[SCM_CHAR_MAX_BYTES];
471     LOCK(p);
472     for (int i=0; i<p->scrcnt; i++) buf[i] = PORT_SCRATCH(p)[i];
473     int n = p->scrcnt;
474     UNLOCK(p);
475     ScmObj h = SCM_NIL, t = SCM_NIL;
476     for (int i=0; i<n; i++) {
477         SCM_APPEND1(h, t, SCM_MAKE_INT((unsigned char)buf[i]));
478     }
479     return h;
480 }
481 
482 /*=================================================================
483  * Getb
484  */
485 
486 #ifndef SHIFT_SCRATCH  /* we need to define this only once */
487 #define SHIFT_SCRATCH
488 
489 /* shift scratch buffer content */
shift_scratch(ScmPort * p,int off)490 static inline void shift_scratch(ScmPort *p, int off)
491 {
492     for (u_int i=0; i<p->scrcnt; i++) {
493         PORT_SCRATCH(p)[i] = PORT_SCRATCH(p)[i+off];
494     }
495 }
496 
497 /* handle the case that there's remaining data in the scratch buffer */
getb_scratch(ScmPort * p)498 static int getb_scratch(ScmPort *p)
499 {
500     int b = (unsigned char)PORT_SCRATCH(p)[0];
501     p->scrcnt--;
502     shift_scratch(p, 1);
503     return b;
504 }
505 
506 /* handle the case that there's an ungotten char */
getb_ungotten(ScmPort * p)507 static int getb_ungotten(ScmPort *p)
508 {
509     SCM_CHAR_PUT(PORT_SCRATCH(p), PORT_UNGOTTEN(p));
510     p->scrcnt = SCM_CHAR_NBYTES(PORT_UNGOTTEN(p));
511     PORT_UNGOTTEN(p) = SCM_CHAR_INVALID;
512     return getb_scratch(p);
513 }
514 #endif /*SHIFT_SCRATCH*/
515 
516 /* Getb body */
517 #ifdef SAFE_PORT_OP
Scm_Getb(ScmPort * p)518 int Scm_Getb(ScmPort *p)
519 #else
520 int Scm_GetbUnsafe(ScmPort *p)
521 #endif
522 {
523     int b = 0;
524     VMDECL;
525     SHORTCUT(p, return Scm_GetbUnsafe(p));
526     LOCK(p);
527     CLOSE_CHECK(p);
528 
529     /* check if there's "pushed back" stuff */
530     if (p->scrcnt) {
531         b = getb_scratch(p);
532     } else if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID) {
533         b = getb_ungotten(p);
534     } else {
535         switch (SCM_PORT_TYPE(p)) {
536         case SCM_PORT_FILE:
537             if (PORT_BUF(p)->current >= PORT_BUF(p)->end) {
538                 ScmSize r = 0;
539                 SAFE_CALL(p, r = bufport_fill(p, 1, FALSE));
540                 if (r == 0) {
541                     UNLOCK(p);
542                     return EOF;
543                 }
544             }
545             b = (unsigned char)*PORT_BUF(p)->current++;
546             break;
547         case SCM_PORT_ISTR:
548             if (PORT_ISTR(p)->current >= PORT_ISTR(p)->end) b = EOF;
549             else b = (unsigned char)*PORT_ISTR(p)->current++;
550             break;
551         case SCM_PORT_PROC:
552             SAFE_CALL(p, b = PORT_VT(p)->Getb(p));
553             break;
554         default:
555             UNLOCK(p);
556             Scm_PortError(p, SCM_PORT_ERROR_INPUT,
557                           "bad port type for input: %S", p);
558         }
559         PORT_BYTES(p)++;
560         /* we may mix binary/textual input, so we keep lines updated too. */
561         if (b == '\n') PORT_LINE(p)++;
562     }
563     UNLOCK(p);
564     return b;
565 }
566 
567 /*=================================================================
568  * Getc
569  */
570 
571 /* handle the case that there's data in scratch area */
572 #ifdef SAFE_PORT_OP
573 #define GETC_SCRATCH getc_scratch
getc_scratch(ScmPort * p)574 static int getc_scratch(ScmPort *p)
575 #else
576 #define GETC_SCRATCH getc_scratch_unsafe
577 static int getc_scratch_unsafe(ScmPort *p)
578 #endif
579 {
580     char tbuf[SCM_CHAR_MAX_BYTES];
581     int nb = SCM_CHAR_NFOLLOWS(PORT_SCRATCH(p)[0]);
582     int curr = p->scrcnt;
583 
584     memcpy(tbuf, PORT_SCRATCH(p), curr);
585     p->scrcnt = 0;
586     for (volatile int i=curr; i<=nb; i++) {
587         int r = EOF;
588         SAFE_CALL(p, r = Scm_Getb(p));
589         if (r == EOF) {
590             UNLOCK(p);
591             Scm_PortError(p, SCM_PORT_ERROR_INPUT,
592                           "encountered EOF in middle of a multibyte character from port %S", p);
593         }
594         tbuf[i] = (char)r;
595     }
596     int ch;
597     SCM_CHAR_GET(tbuf, ch);
598     if (ch == SCM_CHAR_INVALID) {
599         /* This can happen if the input contains invalid byte sequence.
600            We return the stray byte (which would eventually result
601            an incomplete string when accumulated), while keeping the
602            remaining bytes in the scrach buffer. */
603         ch = (ScmChar)(tbuf[0] & 0xff);
604         memcpy(PORT_SCRATCH(p), tbuf+1, nb);
605         p->scrcnt = nb;
606     }
607     return ch;
608 }
609 
610 /* Getc body */
611 #ifdef SAFE_PORT_OP
Scm_Getc(ScmPort * p)612 int Scm_Getc(ScmPort *p)
613 #else
614 int Scm_GetcUnsafe(ScmPort *p)
615 #endif
616 {
617     VMDECL;
618     SHORTCUT(p, return Scm_GetcUnsafe(p));
619     LOCK(p);
620     CLOSE_CHECK(p);
621     if (p->scrcnt > 0) {
622         int r = GETC_SCRATCH(p);
623         UNLOCK(p);
624         return r;
625     }
626     if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID) {
627         int c = PORT_UNGOTTEN(p);
628         PORT_UNGOTTEN(p) = SCM_CHAR_INVALID;
629         UNLOCK(p);
630         return c;
631     }
632 
633     switch (SCM_PORT_TYPE(p)) {
634     case SCM_PORT_FILE: {
635         int c = 0;
636         if (PORT_BUF(p)->current >= PORT_BUF(p)->end) {
637             ScmSize r = 0;
638             SAFE_CALL(p, r = bufport_fill(p, 1, FALSE));
639             if (r == 0) {
640                 UNLOCK(p);
641                 return EOF;
642             }
643         }
644         int first = (unsigned char)*PORT_BUF(p)->current++;
645         int nb = SCM_CHAR_NFOLLOWS(first);
646         PORT_BYTES(p)++;
647         if (nb > 0) {
648             if (PORT_BUF(p)->current + nb > PORT_BUF(p)->end) {
649                 /* The buffer doesn't have enough bytes to consist a char.
650                    move the incomplete char to the scratch buffer and try
651                    to fetch the rest of the char. */
652                 volatile int rest;
653                 volatile ScmSize filled = 0;
654                 p->scrcnt = (unsigned char)(PORT_BUF(p)->end - PORT_BUF(p)->current + 1);
655                 memcpy(PORT_SCRATCH(p), PORT_BUF(p)->current-1, p->scrcnt);
656                 PORT_BUF(p)->current = PORT_BUF(p)->end;
657                 rest = nb + 1 - p->scrcnt;
658                 for (;;) {
659                     SAFE_CALL(p, filled = bufport_fill(p, rest, FALSE));
660                     if (filled <= 0) {
661                         /* TODO: make this behavior customizable */
662                         UNLOCK(p);
663                         Scm_PortError(p, SCM_PORT_ERROR_INPUT,
664                                       "encountered EOF in middle of a multibyte character from port %S", p);
665                     }
666                     if (filled >= rest) {
667                         memcpy(PORT_SCRATCH(p)+p->scrcnt, PORT_BUF(p)->current, rest);
668                         p->scrcnt += rest;
669                         PORT_BUF(p)->current += rest;
670                         break;
671                     } else {
672                         memcpy(PORT_SCRATCH(p)+p->scrcnt, PORT_BUF(p)->current, filled);
673                         p->scrcnt += filled;
674                         PORT_BUF(p)->current = PORT_BUF(p)->end;
675                         rest -= filled;
676                     }
677                 }
678                 SCM_CHAR_GET(PORT_SCRATCH(p), c);
679                 p->scrcnt = 0;
680             } else {
681                 SCM_CHAR_GET(PORT_BUF(p)->current-1, c);
682                 PORT_BUF(p)->current += nb;
683             }
684             PORT_BYTES(p) += nb;
685         } else {
686             c = first;
687             if (c == '\n') PORT_LINE(p)++;
688         }
689         UNLOCK(p);
690         return c;
691     }
692     case SCM_PORT_ISTR: {
693         if (PORT_ISTR(p)->current >= PORT_ISTR(p)->end) {
694             UNLOCK(p);
695             return EOF;
696         }
697         int c = 0;
698         int first = (unsigned char)*PORT_ISTR(p)->current++;
699         int nb = SCM_CHAR_NFOLLOWS(first);
700         PORT_BYTES(p)++;
701         if (nb > 0) {
702             if (PORT_ISTR(p)->current + nb > PORT_ISTR(p)->end) {
703                 /* TODO: make this behavior customizable */
704                 UNLOCK(p);
705                 Scm_PortError(p, SCM_PORT_ERROR_INPUT,
706                               "encountered EOF in middle of a multibyte character from port %S", p);
707             }
708             SCM_CHAR_GET(PORT_ISTR(p)->current-1, c);
709             PORT_ISTR(p)->current += nb;
710             PORT_BYTES(p) += nb;
711         } else {
712             c = first;
713             if (c == '\n') PORT_LINE(p)++;
714         }
715         UNLOCK(p);
716         return c;
717     }
718     case SCM_PORT_PROC: {
719         int c = 0;
720         UNSAVE_POS(p);
721         SAFE_CALL(p, c = PORT_VT(p)->Getc(p));
722         if (c == '\n') PORT_LINE(p)++;
723         UNLOCK(p);
724         return c;
725     }
726     default:
727         UNLOCK(p);
728         Scm_PortError(p, SCM_PORT_ERROR_INPUT, "bad port type for input: %S", p);
729     }
730     return 0;/*dummy*/
731 }
732 
733 #undef GETC_SCRATCH
734 
735 /*=================================================================
736  * Getz - block read.
737  *   If the buffering mode is BUFFER_FULL, this reads BUFLEN bytes
738  *   unless it reaches EOF.  Otherwise, this reads less than BUFLEN
739  *   if the data is not immediately available.
740  */
741 
742 #ifdef SAFE_PORT_OP
743 #define GETZ_SCRATCH getz_scratch
getz_scratch(char * buf,ScmSize buflen,ScmPort * p)744 static ScmSize getz_scratch(char *buf, ScmSize buflen, ScmPort *p)
745 #else
746 #define GETZ_SCRATCH getz_scratch_unsafe
747 static ScmSize getz_scratch_unsafe(char *buf, ScmSize buflen, ScmPort *p)
748 #endif
749 {
750     if (p->scrcnt >= (size_t)buflen) {
751         memcpy(buf, PORT_SCRATCH(p), buflen);
752         p->scrcnt -= buflen;
753         shift_scratch(p, buflen);
754         return buflen;
755     } else {
756         memcpy(buf, PORT_SCRATCH(p), p->scrcnt);
757         ScmSize i = p->scrcnt;
758         p->scrcnt = 0;
759         ScmSize n = 0;
760         SAFE_CALL(p, n = Scm_Getz(buf+i, buflen-i, p));
761         return i + n;
762     }
763 }
764 
765 #ifndef GETZ_ISTR               /* common part */
766 #define GETZ_ISTR getz_istr
getz_istr(ScmPort * p,char * buf,ScmSize buflen)767 static ScmSize getz_istr(ScmPort *p, char *buf, ScmSize buflen)
768 {
769     if (PORT_ISTR(p)->current + buflen >= PORT_ISTR(p)->end) {
770         if (PORT_ISTR(p)->current >= PORT_ISTR(p)->end) return EOF;
771         ScmSize siz = PORT_ISTR(p)->end - PORT_ISTR(p)->current;
772         memcpy(buf, PORT_ISTR(p)->current, siz);
773         PORT_ISTR(p)->current = PORT_ISTR(p)->end;
774         return siz;
775     } else {
776         memcpy(buf, PORT_ISTR(p)->current, buflen);
777         PORT_ISTR(p)->current += buflen;
778         return buflen;
779     }
780 }
781 #endif /*!GETZ_ISTR*/
782 
783 #ifdef SAFE_PORT_OP
Scm_Getz(char * buf,ScmSize buflen,ScmPort * p)784 ScmSize Scm_Getz(char *buf, ScmSize buflen, ScmPort *p)
785 #else
786 ScmSize Scm_GetzUnsafe(char *buf, ScmSize buflen, ScmPort *p)
787 #endif
788 {
789     VMDECL;
790     SHORTCUT(p, return Scm_GetzUnsafe(buf, buflen, p));
791     LOCK(p);
792     CLOSE_CHECK(p);
793 
794     if (p->scrcnt) {
795         ScmSize r = GETZ_SCRATCH(buf, buflen, p);
796         UNLOCK(p);
797         return r;
798     }
799     if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID) {
800         p->scrcnt = SCM_CHAR_NBYTES(PORT_UNGOTTEN(p));
801         SCM_CHAR_PUT(PORT_SCRATCH(p), PORT_UNGOTTEN(p));
802         PORT_UNGOTTEN(p) = SCM_CHAR_INVALID;
803         ScmSize r = GETZ_SCRATCH(buf, buflen, p);
804         UNLOCK(p);
805         return r;
806     }
807 
808     switch (SCM_PORT_TYPE(p)) {
809     case SCM_PORT_FILE: {
810         ScmSize siz = 0;
811         SAFE_CALL(p, siz = bufport_read(p, buf, buflen));
812         PORT_BYTES(p) += siz;
813         UNLOCK(p);
814         if (siz == 0) return EOF;
815         else return siz;
816     }
817     case SCM_PORT_ISTR: {
818         ScmSize r = GETZ_ISTR(p, buf, buflen);
819         PORT_BYTES(p) += r;
820         UNLOCK(p);
821         return r;
822     }
823     case SCM_PORT_PROC: {
824         ScmSize r = 0;
825         UNSAVE_POS(p);
826         SAFE_CALL(p, r = PORT_VT(p)->Getz(buf, buflen, p));
827         PORT_BYTES(p) += r;
828         UNLOCK(p);
829         return r;
830     }
831     default:
832         UNLOCK(p);
833         Scm_PortError(p, SCM_PORT_ERROR_INPUT, "bad port type for input: %S", p);
834     }
835     return -1;                  /* dummy */
836 }
837 
838 #undef GETZ_SCRATCH
839 
840 /*=================================================================
841  * ReadLine
842  *   Reads up to EOL or EOF.
843  */
844 
845 /* Auxiliary procedures */
846 
847 /* NB: it may be further optimized by scanning the contents of buffer
848    when the port is a buffered port or an input string, which allows
849    us to avoid mb->wc->mb conversion.   See port.c, v 1.69 for some
850    attempt to do so.  The problem there is that if I have to take
851    into account the cases of the ungotten char and the scratch buffer,
852    code becomes ugly.  There might be some better approach. */
853 
854 #ifndef READLINE_AUX
855 #define READLINE_AUX
856 /* Assumes the port is locked, and the caller takes care of unlocking
857    even if an error is signalled within this body */
858 /* NB: this routine reads bytes, not chars.  It allows to readline
859    from a port in unknown character encoding (e.g. reading the first
860    line of xml doc to find out charset parameter). */
readline_body(ScmPort * p)861 ScmObj readline_body(ScmPort *p)
862 {
863     ScmDString ds;
864 
865     Scm_DStringInit(&ds);
866     int b1 = Scm_GetbUnsafe(p);
867     if (b1 == EOF) return SCM_EOF;
868     for (;;) {
869         if (b1 == EOF) return Scm_DStringGet(&ds, 0);
870         if (b1 == '\n') break;
871         if (b1 == '\r') {
872             int b2 = Scm_GetbUnsafe(p);
873             if (b2 == EOF || b2 == '\n') break;
874             Scm_UngetbUnsafe(b2, p);
875             break;
876         }
877         SCM_DSTRING_PUTB(&ds, b1);
878         b1 = Scm_GetbUnsafe(p);
879     }
880     PORT_LINE(p)++;
881     return Scm_DStringGet(&ds, 0);
882 }
883 #endif /* READLINE_AUX */
884 
885 #ifdef SAFE_PORT_OP
Scm_ReadLine(ScmPort * p)886 ScmObj Scm_ReadLine(ScmPort *p)
887 #else
888 ScmObj Scm_ReadLineUnsafe(ScmPort *p)
889 #endif
890 {
891     ScmObj r = SCM_UNDEFINED;
892     VMDECL;
893     SHORTCUT(p, return Scm_ReadLineUnsafe(p));
894 
895     LOCK(p);
896     SAFE_CALL(p, r = readline_body(p));
897     UNLOCK(p);
898     return r;
899 }
900 
901 /*=================================================================
902  * ByteReady
903  */
904 
905 #ifdef SAFE_PORT_OP
Scm_ByteReady(ScmPort * p)906 int Scm_ByteReady(ScmPort *p)
907 #else
908 int Scm_ByteReadyUnsafe(ScmPort *p)
909 #endif
910 {
911     int r = 0;
912     VMDECL;
913     SHORTCUT(p, return Scm_ByteReadyUnsafe(p));
914     if (!SCM_IPORTP(p)) Scm_Error("input port required, but got %S", p);
915     LOCK(p);
916     if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID
917         || p->scrcnt > 0) {
918         r = TRUE;
919     } else {
920         switch (SCM_PORT_TYPE(p)) {
921         case SCM_PORT_FILE:
922             if (PORT_BUF(p)->current < PORT_BUF(p)->end) r = TRUE;
923             else if (PORT_BUF(p)->ready == NULL) r = TRUE;
924             else {
925                 SAFE_CALL(p, r = (PORT_BUF(p)->ready(p) != SCM_FD_WOULDBLOCK));
926             }
927             break;
928         case SCM_PORT_PROC:
929             SAFE_CALL(p, r = PORT_VT(p)->Ready(p, FALSE));
930             break;
931         default:
932             r = TRUE;
933         }
934     }
935     UNLOCK(p);
936     return r;
937 }
938 
939 /*=================================================================
940  * CharReady
941  */
942 
943 #ifdef SAFE_PORT_OP
Scm_CharReady(ScmPort * p)944 int Scm_CharReady(ScmPort *p)
945 #else
946 int Scm_CharReadyUnsafe(ScmPort *p)
947 #endif
948 {
949     int r = 0;
950     VMDECL;
951     SHORTCUT(p, return Scm_CharReadyUnsafe(p));
952     if (!SCM_IPORTP(p)) Scm_Error("input port required, but got %S", p);
953     LOCK(p);
954     if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID) r = TRUE;
955     else {
956         switch (SCM_PORT_TYPE(p)) {
957         case SCM_PORT_FILE:
958             if (PORT_BUF(p)->current < PORT_BUF(p)->end) r = TRUE;
959             else if (PORT_BUF(p)->ready == NULL) r = TRUE;
960             else {
961                 SAFE_CALL(p, r = (PORT_BUF(p)->ready(p) != SCM_FD_WOULDBLOCK));
962             }
963             break;
964         case SCM_PORT_PROC:
965             SAFE_CALL(p, r = PORT_VT(p)->Ready(p, TRUE));
966             break;
967         default:
968             r = TRUE;
969         }
970     }
971     UNLOCK(p);
972     return r;
973 }
974 
975 /*=================================================================
976  * Port Positioning
977  */
978 
979 /* See the comment in port.h (Port Positioning Interface) */
980 
981 /* For the sake of seek/tell, we treat scratch buffer and ungotten char
982    (collectively we call them pending bytes here) as if it's a cache---
983    that is, we assume their content always mirrors the real content of
984    the underlying data.
985 
986    If port_pending_bytes() > 0, the "external" current position visible
987    from outside, and the "internal" current position that points into
988    the underlying data, differ.  We discard the pending bytes and adjust
989    the target offset, if the target offset is relative to the current
990    position (SEEK_CUR).
991 
992    One optimization, though; if whence == SEEK_CUR and offset = 0, we don't
993    need to move anything.  It's just to get the current offset.  For this
994    case, instead of adjusting offset, we adjust the result.
995 */
996 
997 #ifndef PORT_PENDING_BYTES       /* common part */
998 #define PORT_PENDING_BYTES port_pending_bytes
port_pending_bytes(ScmPort * p)999 static off_t port_pending_bytes(ScmPort *p)
1000 {
1001     off_t unread_bytes = p->scrcnt;
1002     if (PORT_UNGOTTEN(p) != SCM_CHAR_INVALID) {
1003         unread_bytes += SCM_CHAR_NBYTES(PORT_UNGOTTEN(p));
1004     }
1005     return unread_bytes;
1006 }
1007 #endif /*PORT_PENDING_BYTES*/
1008 
1009 #ifndef SEEK_ISTR               /* common part */
1010 #define SEEK_ISTR seek_istr
seek_istr(ScmPort * p,ScmObj off,int whence)1011 static ScmObj seek_istr(ScmPort *p, ScmObj off, int whence)
1012 {
1013     /* If the port is istr, offset must always be an integer. */
1014     off_t o = Scm_IntegerToOffset(off);
1015     off_t rr;
1016     if (whence == SEEK_CUR) {
1017         o += (off_t)(PORT_ISTR(p)->current - PORT_ISTR(p)->start);
1018     } else if (whence == SEEK_END) {
1019         o += (off_t)(PORT_ISTR(p)->end - PORT_ISTR(p)->start);
1020     }
1021     if (o < 0 || o > (off_t)(PORT_ISTR(p)->end - PORT_ISTR(p)->start)) {
1022         rr = (off_t)-1;
1023     } else {
1024         PORT_ISTR(p)->current = PORT_ISTR(p)->start + o;
1025         rr = (off_t)(PORT_ISTR(p)->current - PORT_ISTR(p)->start);
1026     }
1027     PORT_UNGOTTEN(p) = SCM_CHAR_INVALID;
1028     p->scrcnt = 0;
1029     if (rr == (off_t)-1) return SCM_FALSE;
1030     return Scm_OffsetToInteger(rr);
1031 }
1032 #endif /*SEEK_ISTR*/
1033 
1034 #ifdef SAFE_PORT_OP
Scm_GetPortPosition(ScmPort * p)1035 ScmObj Scm_GetPortPosition(ScmPort *p)
1036 #else
1037 ScmObj Scm_GetPortPositionUnsafe(ScmPort *p)
1038 #endif
1039 {
1040     VMDECL;
1041     SHORTCUT(p, return Scm_GetPortPositionUnsafe(p));
1042     if (SCM_PORT_CLOSED_P(p)) {
1043         Scm_PortError(p, SCM_PORT_ERROR_CLOSED,
1044                       "attempt to take a position of a closed port: %S", p);
1045     }
1046 
1047     ScmObj r = SCM_MAKE_INT(0);
1048     volatile off_t pending_bytes = port_pending_bytes(p);
1049     int err_disabled = FALSE;
1050     int err_badpos = FALSE;
1051 
1052     LOCK(p);
1053     switch (SCM_PORT_TYPE(p)) {
1054     case SCM_PORT_FILE:
1055         {
1056             off_t rr;
1057             if (PORT_BUF(p)->getpos) {
1058                 SAFE_CALL(p, r = PORT_BUF(p)->getpos(p));
1059                 if (!SCM_INTEGERP(r)) {
1060                     err_badpos = TRUE;
1061                     break;
1062                 }
1063                 rr = Scm_IntegerToOffset(r);
1064             } else if (PORT_BUF(p)->seeker) {
1065                 SAFE_CALL(p, rr = PORT_BUF(p)->seeker(p, 0, SEEK_CUR));
1066             } else {
1067                 err_disabled = TRUE;
1068                 break;
1069             }
1070 
1071             if (SCM_PORT_DIR(p)&SCM_PORT_INPUT) {
1072                 rr -= (off_t)(PORT_BUF(p)->end - PORT_BUF(p)->current);
1073             } else {
1074                 rr += (off_t)(PORT_BUF(p)->current - PORT_BUF(p)->buffer);
1075             }
1076             r = Scm_OffsetToInteger(rr);
1077         }
1078         break;
1079     case SCM_PORT_ISTR:
1080         r = Scm_OffsetToInteger(PORT_ISTR(p)->current - PORT_ISTR(p)->start);
1081         break;
1082     case SCM_PORT_OSTR:
1083         r = Scm_MakeInteger(Scm_DStringSize(PORT_OSTR(p)));
1084         break;
1085     case SCM_PORT_PROC:
1086         /* For procedural bytes, the positioning of pending bytes is
1087            taken care of by PORT_SAVED_POS, so we set pending_bytes to 0.*/
1088         pending_bytes = 0;
1089         if (PORT_VT(p)->GetPos) {
1090             r = PORT_SAVED_POS(p);
1091             if (SCM_UNBOUNDP(r)) {
1092                 SAFE_CALL(p, r = PORT_VT(p)->GetPos(p));
1093             }
1094         } else if (PORT_VT(p)->Seek) {
1095             off_t rr;
1096             UNSAVE_POS(p);
1097             SAFE_CALL(p, rr = PORT_VT(p)->Seek(p, 0, SEEK_CUR));
1098             r = Scm_OffsetToInteger(rr);
1099         } else {
1100             err_disabled = TRUE;
1101         }
1102         break;
1103     }
1104     UNLOCK(p);
1105 
1106     if (err_disabled) {
1107         Scm_PortError(p, SCM_PORT_ERROR_SEEK,
1108                       "getting port position is disabled");
1109     }
1110     if (err_badpos) {
1111         Scm_PortError(p, SCM_PORT_ERROR_SEEK,
1112                       "getpos method returned invalid position: %S", r);
1113     }
1114 
1115     if (pending_bytes > 0) {
1116         if (r == SCM_MAKE_INT(-1)) return SCM_FALSE;
1117         if (!SCM_INTEGERP(r)) return FALSE;
1118         r = Scm_Sub(r, Scm_OffsetToInteger(pending_bytes));
1119     }
1120     return r;
1121 }
1122 
1123 /* Common routine for Scm_SetPortPosition and Scm_PortSeek. */
1124 #ifndef SET_PORT_POSITION
1125 #define SET_PORT_POSITION
set_port_position(ScmPort * p,ScmObj pos,int whence)1126 static ScmObj set_port_position(ScmPort *p, ScmObj pos, int whence)
1127 {
1128     VMDECL;
1129 
1130     LOCK(p);
1131 
1132     volatile ScmObj off = pos;
1133     ScmObj r = SCM_UNDEFINED;
1134     int err_disabled = FALSE;
1135     off_t pending = port_pending_bytes(p);
1136     /* We discard pending bytes. */
1137     p->scrcnt = 0;
1138     PORT_UNGOTTEN(p) = SCM_CHAR_INVALID;
1139     /* ... and adjust offset, when it's relative.
1140        NB: This only matters if the port has seeker protocol, instead
1141        of getpos/setpos protocol. */
1142     if (SCM_PORT_TYPE(p) != SCM_PORT_PROC
1143         && whence == SEEK_CUR
1144         && SCM_INTEGERP(off)) {
1145         off = Scm_Sub(off, SCM_MAKE_INT(pending));
1146     }
1147 
1148     switch (SCM_PORT_TYPE(p)) {
1149     case SCM_PORT_FILE:
1150         if (PORT_BUF(p)->setpos && whence == SEEK_SET) {
1151             SAFE_CALL(p, PORT_BUF(p)->setpos(p, off));
1152             r = off;
1153             break;
1154         }
1155 
1156         /* NB: we might be able to skip calling seeker if we keep the
1157            # of bytes read or write so far, but such count may be off
1158            when the port has been experienced an error condition. */
1159         /* NB: the following doesn't work if we have bidirectional port.
1160            In such case we need to keep whether the last call of buffer
1161            handling routine was input or output. */
1162         if (PORT_BUF(p)->seeker) {
1163             /* NB: possible optimization: the specified position is within
1164                the current buffer, we can avoid calling seeker. */
1165             off_t rr;
1166             if (SCM_PORT_DIR(p)&SCM_PORT_INPUT) {
1167                 char *c = PORT_BUF(p)->current; /* save current ptr */
1168                 if (whence == SEEK_CUR) {
1169                     off = Scm_Sub(off, Scm_MakeIntegerU(PORT_BUF(p)->end - c));
1170                 }
1171                 PORT_BUF(p)->current = PORT_BUF(p)->end; /* invalidate buffer */
1172                 SAFE_CALL(p, rr = PORT_BUF(p)->seeker(p,
1173                                                       Scm_IntegerToOffset(off),
1174                                                       whence));
1175                 if (rr == (off_t)-1) {
1176                     /* This may happened if seeker somehow gave up */
1177                     PORT_BUF(p)->current = c;
1178                 }
1179             } else {
1180                 SAFE_CALL(p, bufport_flush(p, 0, TRUE));
1181                 SAFE_CALL(p, rr = PORT_BUF(p)->seeker(p,
1182                                                       Scm_IntegerToOffset(off),
1183                                                       whence));
1184             }
1185             if (rr == (off_t)-1) {
1186                 r = SCM_FALSE;
1187             } else {
1188                 r = Scm_OffsetToInteger(rr);
1189             }
1190         } else {
1191             err_disabled = TRUE;
1192         }
1193         break;
1194     case SCM_PORT_ISTR:
1195         r = SEEK_ISTR(p, off, whence);
1196         break;
1197     case SCM_PORT_OSTR:
1198         /* Not supported yet */
1199         r = SCM_FALSE;
1200         break;
1201     case SCM_PORT_PROC:
1202         if (PORT_VT(p)->SetPos && whence == SEEK_SET) {
1203             UNSAVE_POS(p);
1204             SAFE_CALL(p, PORT_VT(p)->SetPos(p, off));
1205             r = off;
1206         } else if (PORT_VT(p)->Seek) {
1207             UNSAVE_POS(p);
1208             off_t rr;
1209             SAFE_CALL(p, rr = PORT_VT(p)->Seek(p,
1210                                                Scm_IntegerToOffset(off),
1211                                                whence));
1212             r = Scm_OffsetToInteger(rr);
1213         } else {
1214             err_disabled = TRUE;
1215         }
1216         break;
1217     }
1218     UNLOCK(p);
1219 
1220     if (err_disabled) {
1221         Scm_PortError(p, SCM_PORT_ERROR_SEEK,
1222                       "setting port position is disabled");
1223     }
1224     return r;
1225 }
1226 
Scm_SetPortPosition(ScmPort * p,ScmObj pos)1227 ScmObj Scm_SetPortPosition(ScmPort *p, ScmObj pos)
1228 {
1229     return set_port_position(p, pos, SEEK_SET);
1230 }
1231 #endif  /* SET_PORT_POSITION  */
1232 
1233 
1234 /* srfi-181 allows port positions to be any Scheme object, so
1235    off argument and return value can be any Scheme object---if it's
1236    not an exact integer, it should be an object returned by getpos
1237    callback.
1238    If the port only has seeker callback, it must be an exact integer.
1239    If the port implements setpos callback, whence must be SEEK_SET
1240    for setting position.
1241  */
1242 #ifdef SAFE_PORT_OP
Scm_PortSeek(ScmPort * p,volatile ScmObj off,int whence)1243 ScmObj Scm_PortSeek(ScmPort *p, volatile ScmObj off, int whence)
1244 #else
1245 ScmObj Scm_PortSeekUnsafe(ScmPort *p, ScmObj off, int whence)
1246 #endif
1247 {
1248     if (whence == SEEK_CUR && off == SCM_MAKE_INT(0)) {
1249         return Scm_GetPortPosition(p);
1250     } else {
1251         return set_port_position(p, off, whence);
1252     }
1253 }
1254 
1255 /*=================================================================
1256  * Port Attributes
1257  *
1258  * Port attributes are stored in alist.  Each entry is either one
1259  * of the following form:
1260  *  (key value)          Just a value
1261  *  (key value . #f)     Just a value, read-only.  This is a system
1262  *                       attribute; no public interface to create this
1263  *                       kind of API is provided.  It is also undeletable.
1264  *                       (Currently, only the internal port constructor
1265  *                       creates this kind of attributes.)
1266  *  (key getter setter)  Procedurally handled value.  Getter will be
1267  *                       called as (getter port [fallback]), and Setter
1268  *                       will be called as (setter port value).
1269  *                       Setter can be #f if the attr is read-only.
1270  *                       Port is locked while getter and setter is called.
1271  *
1272  * The third type of attribute can be created by Scm_PortAttrCreate.
1273  *
1274  * TODO: probably we want deletable and undeletable procedural values.
1275  */
1276 
1277 #ifdef SAFE_PORT_OP
Scm_PortAttrGet(ScmPort * p,ScmObj key,ScmObj fallback)1278 ScmObj Scm_PortAttrGet(ScmPort *p, ScmObj key, ScmObj fallback)
1279 #else
1280 ScmObj Scm_PortAttrGetUnsafe(ScmPort *p, ScmObj key, ScmObj fallback)
1281 #endif
1282 {
1283     ScmObj r = SCM_UNBOUND;
1284     VMDECL;
1285     SHORTCUT(p, return Scm_PortAttrGetUnsafe(p, key, fallback););
1286     LOCK(p);
1287     ScmObj v = Scm_Assq(key, PORT_ATTRS(p));
1288     if (SCM_PAIRP(v)) {
1289         SCM_ASSERT(SCM_PAIRP(SCM_CDR(v)));
1290         if (SCM_PAIRP(SCM_CDDR(v))) {
1291             /* procedural */
1292             ScmObj getter = SCM_CADR(v);
1293             if (SCM_UNBOUNDP(fallback)) {
1294                 SAFE_CALL(p, r = Scm_ApplyRec1(getter, SCM_OBJ(p)));
1295             } else {
1296                 SAFE_CALL(p, r = Scm_ApplyRec2(getter, SCM_OBJ(p), fallback));
1297             }
1298         } else {
1299             r = SCM_CADR(v);
1300         }
1301     } else {
1302         r = fallback;
1303     }
1304     UNLOCK(p);
1305 
1306     if (SCM_UNBOUNDP(r)) {
1307         Scm_Error("No port attribute for key %S in port %S", key, SCM_OBJ(p));
1308     }
1309     return r;
1310 }
1311 
1312 
1313 #ifdef SAFE_PORT_OP
Scm_PortAttrSet(ScmPort * p,ScmObj key,ScmObj val)1314 ScmObj Scm_PortAttrSet(ScmPort *p, ScmObj key, ScmObj val)
1315 #else
1316 ScmObj Scm_PortAttrSetUnsafe(ScmPort *p, ScmObj key, ScmObj val)
1317 #endif
1318 {
1319     volatile int err_readonly = FALSE;
1320     volatile int exists = FALSE;
1321     VMDECL;
1322     SHORTCUT(p, return Scm_PortAttrSetUnsafe(p, key, val););
1323     LOCK(p);
1324     ScmObj v = Scm_Assq(key, PORT_ATTRS(p));
1325     if (SCM_PAIRP(v)) {
1326         SCM_ASSERT(SCM_PAIRP(SCM_CDR(v)));
1327         exists = TRUE;
1328         if (SCM_PAIRP(SCM_CDDR(v))) {
1329             /* procedural */
1330             ScmObj setter = SCM_CAR(SCM_CDDR(v));
1331             if (SCM_FALSEP(setter)) {
1332                 err_readonly = TRUE;
1333             } else {
1334                 SAFE_CALL(p, Scm_ApplyRec2(setter, SCM_OBJ(p), val));
1335             }
1336         } else if (SCM_NULLP(SCM_CDDR(v))) {
1337             SCM_SET_CAR_UNCHECKED(SCM_CDR(v), val);
1338         } else {
1339             err_readonly = TRUE;
1340         }
1341     } else {
1342         PORT_ATTRS(p) = Scm_Cons(SCM_LIST2(key, val), PORT_ATTRS(p));
1343     }
1344     UNLOCK(p);
1345     if (err_readonly) {
1346         Scm_Error("Port attribute '%A' is read-only in port: %S",
1347                   key, SCM_OBJ(p));
1348     }
1349     return SCM_MAKE_BOOL(exists);
1350 }
1351 
1352 #ifdef SAFE_PORT_OP
Scm_PortAttrCreate(ScmPort * p,ScmObj key,ScmObj get,ScmObj set)1353 ScmObj Scm_PortAttrCreate(ScmPort *p, ScmObj key, ScmObj get, ScmObj set)
1354 #else
1355 ScmObj Scm_PortAttrCreateUnsafe(ScmPort *p, ScmObj key, ScmObj get, ScmObj set)
1356 #endif
1357 {
1358     int err_exists = FALSE;
1359     VMDECL;
1360     SHORTCUT(p, return Scm_PortAttrCreateUnsafe(p, key, get, set););
1361 
1362     /* If get == #f, we create an ordinary attr entry.  Otherwise,
1363        we create a procedural entry. */
1364     ScmObj entry = (SCM_FALSEP(get)
1365                     ? SCM_LIST2(key, SCM_FALSE)
1366                     : SCM_LIST3(key, get, set));
1367     LOCK(p);
1368     ScmObj v = Scm_Assq(key, PORT_ATTRS(p));
1369     if (SCM_FALSEP(v)) {
1370         PORT_ATTRS(p) = Scm_Cons(entry, PORT_ATTRS(p));
1371     } else {
1372         err_exists = TRUE;
1373     }
1374     UNLOCK(p);
1375     if (err_exists) {
1376         Scm_Error("Couldn't create port attribute %A in %S: Named attribute already exists.",
1377                   key, SCM_OBJ(p));
1378     }
1379     return SCM_UNDEFINED;       /* we may return more useful info in future */
1380 }
1381 
1382 #ifdef SAFE_PORT_OP
Scm_PortAttrDelete(ScmPort * p,ScmObj key)1383 ScmObj Scm_PortAttrDelete(ScmPort *p, ScmObj key)
1384 #else
1385 ScmObj Scm_PortAttrDeleteUnsafe(ScmPort *p, ScmObj key)
1386 #endif
1387 {
1388     int err_undeletable = FALSE;
1389     VMDECL;
1390     SHORTCUT(p, return Scm_PortAttrDeleteUnsafe(p, key););
1391     LOCK(p);
1392     ScmObj v = Scm_Assq(key, PORT_ATTRS(p));
1393     if (SCM_PAIRP(v) && SCM_PAIRP(SCM_CDR(v)) && SCM_FALSEP(SCM_CDDR(v))) {
1394         err_undeletable = TRUE;
1395     } else {
1396         PORT_ATTRS(p) = Scm_AssocDelete(key, PORT_ATTRS(p), SCM_CMP_EQ);
1397     }
1398     UNLOCK(p);
1399     if (err_undeletable) {
1400         Scm_Error("Port attribute '%A' is not deletable from port: %S",
1401                   key, SCM_OBJ(p));
1402     }
1403     return SCM_UNDEFINED;       /* we may return more useful info in future */
1404 }
1405 
1406 #ifdef SAFE_PORT_OP
Scm_PortAttrs(ScmPort * p)1407 ScmObj Scm_PortAttrs(ScmPort *p)
1408 #else
1409 ScmObj Scm_PortAttrsUnsafe(ScmPort *p)
1410 #endif
1411 {
1412     ScmObj h = SCM_NIL, t = SCM_NIL;
1413     VMDECL;
1414     SHORTCUT(p, return Scm_PortAttrsUnsafe(p););
1415     LOCK(p);
1416     ScmObj cp;
1417     SCM_FOR_EACH(cp, PORT_ATTRS(p)) {
1418         ScmObj k = SCM_CAAR(cp);
1419         ScmObj v = Scm_PortAttrGetUnsafe(p, k, SCM_UNBOUND);
1420         SCM_APPEND1(h, t, Scm_Cons(k, v));
1421     }
1422     UNLOCK(p);
1423     return h;
1424 }
1425 
1426 
1427 #undef VMDECL
1428 #undef LOCK
1429 #undef UNLOCK
1430 #undef SAFE_CALL
1431 #undef SHORTCUT
1432 #undef CLOSE_CHECK
1433