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