1 /* read.c: Input functions and primitives; the Scheme reader/parser.
2 *
3 * $Id$
4 *
5 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
6 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris
7 *
8 * This software was derived from Elk 1.2, which was Copyright 1987, 1988,
9 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
10 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
11 * between TELES and Nixdorf Microprocessor Engineering, Berlin).
12 *
13 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
14 * owners or individual owners of copyright in this software, grant to any
15 * person or company a worldwide, royalty free, license to
16 *
17 * i) copy this software,
18 * ii) prepare derivative works based on this software,
19 * iii) distribute copies of this software or derivative works,
20 * iv) perform this software, or
21 * v) display this software,
22 *
23 * provided that this notice is not removed and that neither Oliver Laumann
24 * nor Teles nor Nixdorf are deemed to have made any representations as to
25 * the suitability of this software for any purpose nor are held responsible
26 * for any defects of this software.
27 *
28 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
29 */
30
31 #include "config.h"
32
33 #include <ctype.h>
34 #include <limits.h>
35 #include <string.h>
36
37 #if defined(HAVE_TERMIO_H)
38 # include <termio.h>
39 #elif defined(HAVE_TERMIOS_H)
40 # include <termios.h>
41 #endif
42
43 #if defined(HAVE_SYS_IOCTL_H)
44 # include <sys/ioctl.h>
45 #endif
46
47 #if defined(HAVE_SYS_FILIO_H)
48 # include <sys/filio.h>
49 #endif
50
51 #include "kernel.h"
52
53 extern void Flush_Output (Object);
54
55 extern double atof();
56
57 int Skip_Comment (Object);
58 void Reader_Error (Object, char *) elk_attribute(__noreturn__);
59
60 Object Sym_Quote,
61 Sym_Quasiquote,
62 Sym_Unquote,
63 Sym_Unquote_Splicing;
64
65 #define Octal(c) ((c) >= '0' && (c) <= '7')
66
67 static READFUN Readers[256];
68
69 static char *Read_Buf;
70 static int Read_Size, Read_Max;
71
72 #define Read_Reset() (Read_Size = 0)
73 #define Read_Store(c) (Read_Size == Read_Max ? \
74 (Read_Grow(), Read_Buf[Read_Size++] = (c)) : (Read_Buf[Read_Size++] = (c)))
75
Read_Grow()76 static void Read_Grow () {
77 Read_Max *= 2;
78 Read_Buf = Safe_Realloc (Read_Buf, Read_Max);
79 }
80
81 Object General_Read(), Read_Sequence(), Read_Atom(), Read_Special();
82 Object Read_String(), Read_Sharp(), Read_True(), Read_False(), Read_Void();
83 Object Read_Kludge(), Read_Vector_Paren(), Read_Vector_Bracket(), Read_Radix(), Read_Char();
84
Init_Read()85 void Init_Read () {
86 Define_Symbol (&Sym_Quote, "quote");
87 Define_Symbol (&Sym_Quasiquote, "quasiquote");
88 Define_Symbol (&Sym_Unquote, "unquote");
89 Define_Symbol (&Sym_Unquote_Splicing, "unquote-splicing");
90
91 Readers['t'] = Readers['T'] = Read_True;
92 Readers['f'] = Readers['F'] = Read_False;
93 Readers['v'] = Readers['V'] = Read_Void;
94 Readers['!'] = Read_Kludge; /* for interpreter files */
95 Readers['('] = Read_Vector_Paren;
96 Readers['['] = Read_Vector_Bracket;
97 Readers['b'] = Readers['B'] =
98 Readers['o'] = Readers['O'] =
99 Readers['d'] = Readers['D'] =
100 Readers['x'] = Readers['X'] =
101 Readers['e'] = Readers['E'] =
102 Readers['i'] = Readers['I'] = Read_Radix;
103 Readers['\\'] = Read_Char;
104
105 Read_Max = 128;
106 Read_Buf = Safe_Malloc (Read_Max);
107 }
108
String_Getc(Object port)109 int String_Getc (Object port) {
110 register struct S_Port *p;
111 register struct S_String *s;
112
113 p = PORT(port);
114 if (p->flags & P_UNREAD) {
115 p->flags &= ~P_UNREAD;
116 return p->unread;
117 }
118 s = STRING(p->name);
119 return p->ptr >= s->size ? EOF : s->data[p->ptr++];
120 }
121
String_Ungetc(Object port,register int c)122 void String_Ungetc (Object port, register int c) {
123 PORT(port)->flags |= P_UNREAD;
124 PORT(port)->unread = c;
125 }
126
Check_Input_Port(Object port)127 void Check_Input_Port (Object port) {
128 Check_Type (port, T_Port);
129 if (!(PORT(port)->flags & P_OPEN))
130 Primitive_Error ("port has been closed: ~s", port);
131 if (!IS_INPUT(port))
132 Primitive_Error ("not an input port: ~s", port);
133 }
134
P_Clear_Input_Port(int argc,Object * argv)135 Object P_Clear_Input_Port (int argc, Object *argv) {
136 Discard_Input (argc == 1 ? argv[0] : Curr_Input_Port);
137 return Void;
138 }
139
Discard_Input(Object port)140 void Discard_Input (Object port) {
141 register FILE *f;
142
143 Check_Input_Port (port);
144 if (PORT(port)->flags & P_STRING)
145 return;
146 f = PORT(port)->file;
147 #if defined(HAVE_FPURGE)
148 (void)fpurge (f);
149 #elif defined(HAVE_BSD_FLUSH)
150 f->_cnt = 0;
151 f->_ptr = f->_base;
152 #endif
153
154 #if defined(TIOCFLUSH)
155 (void)ioctl (fileno (f), TIOCFLUSH, (char *)0);
156 #elif defined(TCFLSH)
157 (void)ioctl (fileno (f), TCFLSH, (char *)0);
158 #endif
159 }
160
P_Unread_Char(int argc,Object * argv)161 Object P_Unread_Char (int argc, Object *argv) {
162 Object port, ch;
163 register struct S_Port *p;
164
165 ch = argv[0];
166 Check_Type (ch, T_Character);
167 port = argc == 2 ? argv[1] : Curr_Input_Port;
168 Check_Input_Port (port);
169 p = PORT(port);
170 if (p->flags & P_STRING) {
171 if (p->flags & P_UNREAD)
172 Primitive_Error ("cannot push back more than one char");
173 String_Ungetc (port, CHAR(ch));
174 } else {
175 if (ungetc (CHAR(ch), p->file) == EOF)
176 Primitive_Error ("failed to push back char");
177 }
178 if (CHAR(ch) == '\n' && PORT(port)->lno > 1) PORT(port)->lno--;
179 return ch;
180 }
181
P_Read_Char(int argc,Object * argv)182 Object P_Read_Char (int argc, Object *argv) {
183 Object port;
184 register FILE *f;
185 register int c, str, flags;
186
187 port = argc == 1 ? argv[0] : Curr_Input_Port;
188 Check_Input_Port (port);
189 f = PORT(port)->file;
190 flags = PORT(port)->flags;
191 str = flags & P_STRING;
192 Reader_Getc;
193 Reader_Tweak_Stream;
194 return c == EOF ? Eof : Make_Char (c);
195 }
196
P_Peek_Char(int argc,Object * argv)197 Object P_Peek_Char (int argc, Object *argv) {
198 Object a[2];
199
200 a[0] = P_Read_Char (argc, argv);
201 if (argc == 1)
202 a[1] = argv[0];
203 return EQ(a[0], Eof) ? Eof : P_Unread_Char (argc+1, a);
204 }
205
206 /* char-ready? cannot be implemented correctly based on FILE pointers.
207 * The following is only an approximation; even if FIONREAD is supported,
208 * the primitive may return #f although a call to read-char would not block.
209 */
P_Char_Readyp(int argc,Object * argv)210 Object P_Char_Readyp (int argc, Object *argv) {
211 Object port;
212
213 port = argc == 1 ? argv[0] : Curr_Input_Port;
214 Check_Input_Port (port);
215 if (PORT(port)->flags & P_STRING || feof (PORT(port)->file))
216 return True;
217 #ifdef FIONREAD
218 {
219 long num = 0;
220 (void)ioctl (fileno (PORT(port)->file), FIONREAD, (char *)&num);
221 if (num != 0)
222 return True;
223 }
224 #endif
225 return False;
226 }
227
P_Read_String(int argc,Object * argv)228 Object P_Read_String (int argc, Object *argv) {
229 Object port;
230 register FILE *f;
231 register int c, str;
232
233 port = argc == 1 ? argv[0] : Curr_Input_Port;
234 Check_Input_Port (port);
235 f = PORT(port)->file;
236 str = PORT(port)->flags & P_STRING;
237 Read_Reset ();
238 while (1) {
239 Reader_Getc;
240 if (c == '\n' || c == EOF)
241 break;
242 Read_Store (c);
243 }
244 Reader_Tweak_Stream;
245 return c == EOF ? Eof : Make_String (Read_Buf, Read_Size);
246 }
247
P_Read(int argc,Object * argv)248 Object P_Read (int argc, Object *argv) {
249 return General_Read (argc == 1 ? argv[0] : Curr_Input_Port, 0);
250 }
251
General_Read(Object port,int konst)252 Object General_Read (Object port, int konst) {
253 register FILE *f;
254 register int c, str;
255 Object ret;
256
257 Check_Input_Port (port);
258 Flush_Output (Curr_Output_Port);
259 f = PORT(port)->file;
260 str = PORT(port)->flags & P_STRING;
261 while (1) {
262 Reader_Getc;
263 if (c == EOF) {
264 ret = Eof;
265 break;
266 }
267 if (Whitespace (c))
268 continue;
269 if (c == ';') {
270 comment:
271 if (Skip_Comment (port) == EOF) {
272 ret = Eof;
273 break;
274 }
275 continue;
276 }
277 if (c == '(' || c == '[') {
278 ret = Read_Sequence (port, 0, konst, c);
279 } else if (c == '#') {
280 ret = Read_Sharp (port, konst);
281 if (TYPE(ret) == T_Special) /* it was a #! */
282 goto comment;
283 } else {
284 Reader_Ungetc;
285 ret = Read_Atom (port, konst);
286 }
287 break;
288 }
289 Reader_Tweak_Stream;
290 return ret;
291 }
292
Skip_Comment(Object port)293 int Skip_Comment (Object port) {
294 register FILE *f;
295 register int c, str;
296
297 f = PORT(port)->file;
298 str = PORT(port)->flags & P_STRING;
299 do {
300 Reader_Getc;
301 } while (c != '\n' && c != EOF);
302 return c;
303 }
304
Read_Atom(Object port,int konst)305 Object Read_Atom (Object port, int konst) {
306 Object ret;
307
308 ret = Read_Special (port, konst);
309 if (TYPE(ret) == T_Special)
310 Reader_Error (port, "syntax error");
311 return ret;
312 }
313
Read_Special(Object port,int konst)314 Object Read_Special (Object port, int konst) {
315 Object ret;
316 register int c, str;
317 register FILE *f;
318
319 #define READ_QUOTE(sym) \
320 ( ret = Read_Atom (port, konst),\
321 konst ? (ret = Const_Cons (ret, Null), Const_Cons (sym, ret))\
322 : (ret = Cons (ret, Null), Cons (sym, ret)))
323
324 f = PORT(port)->file;
325 str = PORT(port)->flags & P_STRING;
326 again:
327 Reader_Getc;
328 switch (c) {
329 case EOF:
330 eof:
331 Reader_Tweak_Stream;
332 Reader_Error (port, "premature end of file");
333 case ';':
334 if (Skip_Comment (port) == EOF)
335 goto eof;
336 goto again;
337 case ']':
338 case ')':
339 SET(ret, T_Special, c);
340 return ret;
341 case '[':
342 case '(':
343 return Read_Sequence (port, 0, konst, c);
344 case '\'':
345 return READ_QUOTE(Sym_Quote);
346 case '`':
347 return READ_QUOTE(Sym_Quasiquote);
348 case ',':
349 Reader_Getc;
350 if (c == EOF)
351 goto eof;
352 if (c == '@') {
353 return READ_QUOTE(Sym_Unquote_Splicing);
354 } else {
355 Reader_Ungetc;
356 return READ_QUOTE(Sym_Unquote);
357 }
358 case '"':
359 return Read_String (port, konst);
360 case '#':
361 ret = Read_Sharp (port, konst);
362 if (TYPE(ret) == T_Special)
363 goto again;
364 return ret;
365 default:
366 if (Whitespace (c))
367 goto again;
368 Read_Reset ();
369 if (c == '.') {
370 Reader_Getc;
371 if (c == EOF)
372 goto eof;
373 if (Whitespace (c)) {
374 Reader_Ungetc;
375 SET(ret, T_Special, '.');
376 return ret;
377 }
378 Read_Store ('.');
379 }
380 while (!Whitespace (c) && !Delimiter (c) && c != EOF) {
381 if (c == '\\') {
382 Reader_Getc;
383 if (c == EOF)
384 break;
385 }
386 Read_Store (c);
387 Reader_Getc;
388 }
389 Read_Store ('\0');
390 if (c != EOF)
391 Reader_Ungetc;
392 ret = Parse_Number (port, Read_Buf, 10);
393 if (Nullp (ret))
394 ret = Intern (Read_Buf);
395 return ret;
396 }
397 /*NOTREACHED*/
398 }
399
Read_Sequence(Object port,int vec,int konst,int start_chr)400 Object Read_Sequence (Object port, int vec, int konst, int start_chr) {
401 Object ret, e, tail, t;
402 GC_Node3;
403
404 ret = tail = Null;
405 GC_Link3 (ret, tail, port);
406 while (1) {
407 e = Read_Special (port, konst);
408 if (TYPE(e) == T_Special) {
409 if (CHAR(e) == ')' || CHAR(e) == ']') {
410 if ((start_chr == '(' && CHAR(e) == ']')
411 || (start_chr == '[' && CHAR(e) == ')')) {
412 char buf[64];
413 sprintf(buf, "expression starts with '%c' but ends "
414 "with '%c'", start_chr, CHAR(e));
415 Reader_Error (port, buf);
416 }
417 GC_Unlink;
418 return ret;
419 }
420 if (vec)
421 Reader_Error (port, "wrong syntax in vector");
422 if (CHAR(e) == '.') {
423 if (Nullp (tail)) {
424 ret = Read_Atom (port, konst);
425 } else {
426 e = Read_Atom (port, konst);
427 /*
428 * Possibly modifying pure cons. Must be fixed!
429 */
430 Cdr (tail) = e;
431 }
432 e = Read_Special (port, konst);
433 if (TYPE(e) == T_Special && (CHAR(e) == ')' || CHAR(e) == ']')) {
434 GC_Unlink;
435 return ret;
436 }
437 Reader_Error (port, "dot in wrong context");
438 }
439 Reader_Error (port, "syntax error");
440 }
441 if (konst) t = Const_Cons (e, Null); else t = Cons (e, Null);
442 if (!Nullp (tail))
443 /*
444 * Possibly modifying pure cons. Must be fixed!
445 */
446 Cdr (tail) = t;
447 else
448 ret = t;
449 tail = t;
450 }
451 /*NOTREACHED*/
452 }
453
Read_String(Object port,int konst)454 Object Read_String (Object port, int konst) {
455 register FILE *f;
456 register int n, c, oc, str;
457
458 Read_Reset ();
459 f = PORT(port)->file;
460 str = PORT(port)->flags & P_STRING;
461 while (1) {
462 Reader_Getc;
463 if (c == EOF) {
464 eof:
465 Reader_Tweak_Stream;
466 Reader_Error (port, "end of file in string");
467 }
468 if (c == '\\') {
469 Reader_Getc;
470 switch (c) {
471 case EOF: goto eof;
472 case 'b': c = '\b'; break;
473 case 't': c = '\t'; break;
474 case 'r': c = '\r'; break;
475 case 'n': c = '\n'; break;
476 case '0': case '1': case '2': case '3':
477 case '4': case '5': case '6': case '7':
478 oc = n = 0;
479 do {
480 oc <<= 3; oc += c - '0';
481 Reader_Getc;
482 if (c == EOF) goto eof;
483 } while (Octal (c) && ++n <= 2);
484 Reader_Ungetc;
485 c = oc;
486 }
487 } else if (c == '"')
488 break;
489 Read_Store (c);
490 }
491 return General_Make_String (Read_Buf, Read_Size, konst);
492 }
493
Read_Sharp(Object port,int konst)494 Object Read_Sharp (Object port, int konst) {
495 int c, str;
496 FILE *f;
497 char buf[32];
498
499 f = PORT(port)->file;
500 str = PORT(port)->flags & P_STRING;
501 Reader_Getc;
502 if (c == EOF)
503 Reader_Sharp_Eof;
504 if (!Readers[c]) {
505 sprintf (buf, "no reader for syntax #%c", c);
506 Reader_Error (port, buf);
507 }
508 return Readers[c](port, c, konst);
509 }
510
511 /*ARGSUSED*/
Read_True(Object port,int chr,int konst)512 Object Read_True (Object port, int chr, int konst) {
513 return True;
514 }
515
516 /*ARGSUSED*/
Read_False(Object port,int chr,int konst)517 Object Read_False (Object port, int chr, int konst) {
518 return False;
519 }
520
521 /*ARGSUSED*/
Read_Void(Object port,int chr,int konst)522 Object Read_Void (Object port, int chr, int konst) {
523 Object ret;
524
525 ret = Const_Cons (Void, Null);
526 return Const_Cons (Sym_Quote, ret);
527 }
528
529 /*ARGSUSED*/
Read_Kludge(Object port,int chr,int konst)530 Object Read_Kludge (Object port, int chr, int konst) {
531 return Special;
532 }
533
534 /*ARGSUSED*/
Read_Vector_Paren(Object port,int chr,int konst)535 Object Read_Vector_Paren (Object port, int chr, int konst) {
536 return List_To_Vector (Read_Sequence (port, 1, konst, '('), konst);
537 }
538
539 /*ARGSUSED*/
Read_Vector_Bracket(Object port,int chr,int konst)540 Object Read_Vector_Bracket (Object port, int chr, int konst) {
541 return List_To_Vector (Read_Sequence (port, 1, konst, '['), konst);
542 }
543
544 /*ARGSUSED*/
Read_Radix(Object port,int chr,int konst)545 Object Read_Radix (Object port, int chr, int konst) {
546 int c, str;
547 FILE *f;
548 Object ret;
549
550 Read_Reset ();
551 f = PORT(port)->file;
552 str = PORT(port)->flags & P_STRING;
553 Read_Store ('#'); Read_Store (chr);
554 while (1) {
555 Reader_Getc;
556 if (c == EOF)
557 Reader_Sharp_Eof;
558 if (Whitespace (c) || Delimiter (c))
559 break;
560 Read_Store (c);
561 }
562 Reader_Ungetc;
563 Read_Store ('\0');
564 ret = Parse_Number (port, Read_Buf, 10);
565 if (Nullp (ret))
566 Reader_Error (port, "radix not followed by a valid number");
567 return ret;
568 }
569
570 /*ARGSUSED*/
Read_Char(Object port,int chr,int konst)571 Object Read_Char (Object port, int chr, int konst) {
572 int c, str;
573 FILE *f;
574 char buf[10], *p = buf;
575
576 f = PORT(port)->file;
577 str = PORT(port)->flags & P_STRING;
578 Reader_Getc;
579 if (c == EOF)
580 Reader_Sharp_Eof;
581 *p++ = c;
582 while (1) {
583 Reader_Getc;
584 if (c == EOF)
585 Reader_Sharp_Eof;
586 if (Whitespace (c) || Delimiter (c))
587 break;
588 if (p == buf+9)
589 Reader_Error (port, "syntax error in character constant");
590 *p++ = c;
591 }
592 Reader_Ungetc;
593 if (p == buf+1)
594 return Make_Char (*buf);
595 *p = '\0';
596 if (p == buf+3) {
597 for (c = 0, p = buf; p < buf+3 && Octal (*p); p++)
598 c = c << 3 | (*p - '0');
599 if (p == buf+3)
600 return Make_Char (c);
601 }
602 for (p = buf; *p; p++)
603 if (isupper (*p))
604 *p = tolower (*p);
605 if (strcmp (buf, "space") == 0)
606 return Make_Char (' ');
607 if (strcmp (buf, "newline") == 0)
608 return Make_Char ('\n');
609 if (strcmp (buf, "return") == 0)
610 return Make_Char ('\r');
611 if (strcmp (buf, "tab") == 0)
612 return Make_Char ('\t');
613 if (strcmp (buf, "formfeed") == 0)
614 return Make_Char ('\f');
615 if (strcmp (buf, "backspace") == 0)
616 return Make_Char ('\b');
617 Reader_Error (port, "syntax error in character constant");
618 /*NOTREACHED*/
619 }
620
Define_Reader(int c,READFUN fun)621 void Define_Reader (int c, READFUN fun) {
622 if (Readers[c] && Readers[c] != fun)
623 Primitive_Error ("reader for `~a' already defined", Make_Char (c));
624 Readers[c] = fun;
625 }
626
Parse_Number(Object port,char const * buf,int radix)627 Object Parse_Number (Object port, char const *buf, int radix) {
628 char const *p;
629 int c, i;
630 int mdigit = 0, edigit = 0, expo = 0, neg = 0, point = 0;
631 int gotradix = 0, exact = 0, inexact = 0;
632 unsigned int max;
633 int maxdig;
634 Object ret;
635
636 for ( ; *buf == '#'; buf++) {
637 switch (*++buf) {
638 case 'b': case 'B':
639 if (gotradix++) return Null;
640 radix = 2;
641 break;
642 case 'o': case 'O':
643 if (gotradix++) return Null;
644 radix = 8;
645 break;
646 case 'd': case 'D':
647 if (gotradix++) return Null;
648 radix = 10;
649 break;
650 case 'x': case 'X':
651 if (gotradix++) return Null;
652 radix = 16;
653 break;
654 case 'e': case 'E':
655 if (exact++ || inexact) return Null;
656 break;
657 case 'i': case 'I':
658 if (inexact++ || exact) return Null;
659 break;
660 default:
661 return Null;
662 }
663 }
664 p = buf;
665 if (*p == '+' || (neg = *p == '-'))
666 p++;
667 for ( ; (c = *p); p++) {
668 if (c == '.') {
669 if (expo || point++)
670 return Null;
671 } else if (radix != 16 && (c == 'e' || c == 'E')) {
672 if (expo++)
673 return Null;
674 if (p[1] == '+' || p[1] == '-')
675 p++;
676 #ifdef HAVE_INDEX
677 } else if (radix == 16 && !index ("0123456789abcdefABCDEF", c)) {
678 #else
679 } else if (radix == 16 && !strchr ("0123456789abcdefABCDEF", c)) {
680 #endif
681 return Null;
682 } else if (radix < 16 && (c < '0' || c > '0' + radix-1)) {
683 return Null;
684 } else {
685 if (expo) edigit++; else mdigit++;
686 }
687 }
688 if (!mdigit || (expo && !edigit))
689 return Null;
690 if (point || expo) {
691 if (radix != 10) {
692 if (Nullp (port))
693 return Null;
694 Reader_Error (port, "reals must be given in decimal");
695 }
696 /* Lacking ratnums, there's nothing we can do if #e has been
697 * specified-- just return the inexact number.
698 */
699 return Make_Flonum (atof (buf));
700 }
701 max = (neg ? -(unsigned int)INT_MIN : INT_MAX);
702 maxdig = max % radix;
703 max /= radix;
704 for (i = 0, p = buf; (c = *p); p++) {
705 if (c == '-' || c == '+') {
706 buf++;
707 continue;
708 }
709 if (radix == 16) {
710 if (isupper (c))
711 c = tolower (c);
712 if (c >= 'a')
713 c = '9' + c - 'a' + 1;
714 }
715 c -= '0';
716 if ((unsigned int)i > max || ((unsigned int)i == max && c > maxdig)) {
717 ret = Make_Bignum (buf, neg, radix);
718 return inexact ? Make_Flonum (Bignum_To_Double (ret)) : ret;
719 }
720 i *= radix; i += c;
721 }
722 if (neg)
723 i = -i;
724 return inexact ? Make_Flonum ((double)i) : Make_Integer (i);
725 }
726
Reader_Error(Object port,char * msg)727 void Reader_Error (Object port, char *msg) {
728 char buf[100];
729
730 if (PORT(port)->flags & P_STRING) {
731 sprintf (buf, "[string-port]: %u: %s", PORT(port)->lno, msg);
732 Primitive_Error (buf);
733 } else {
734 sprintf (buf, "~s: %u: %s", PORT(port)->lno, msg);
735 Primitive_Error (buf, PORT(port)->name);
736 }
737 }
738