1 /*************************************************************************
2 * *
3 * YAP Prolog *
4 * *
5 * Yap Prolog was developed at NCCUP - Universidade do Porto *
6 * *
7 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
8 * *
9 **************************************************************************
10 * *
11 * File: iopreds.c *
12 * Last rev: 5/2/88 *
13 * mods: *
14 * comments: Input/Output C implemented predicates *
15 * *
16 *************************************************************************/
17 #ifdef SCCS
18 static char SccsId[] = "%W% %G%";
19 #endif
20
21 /*
22 * This file includes the definition of a miscellania of standard predicates
23 * for yap refering to: Files and Streams, Simple Input/Output,
24 *
25 */
26
27 #include "Yap.h"
28 #include "Yatom.h"
29 #include "YapHeap.h"
30 #include "yapio.h"
31 #include "eval.h"
32 #include <stdlib.h>
33 #if HAVE_STDARG_H
34 #include <stdarg.h>
35 #endif
36 #if HAVE_CTYPE_H
37 #include <ctype.h>
38 #endif
39 #if HAVE_WCTYPE_H
40 #include <wctype.h>
41 #endif
42 #if HAVE_SYS_TIME_H
43 #include <sys/time.h>
44 #endif
45 #if HAVE_SYS_TYPES_H
46 #include <sys/types.h>
47 #endif
48 #ifdef HAVE_SYS_STAT_H
49 #include <sys/stat.h>
50 #endif
51 #if HAVE_SYS_SELECT_H && !_MSC_VER && !defined(__MINGW32__)
52 #include <sys/select.h>
53 #endif
54 #ifdef HAVE_UNISTD_H
55 #include <unistd.h>
56 #endif
57 #if HAVE_STRING_H
58 #include <string.h>
59 #endif
60 #if HAVE_SIGNAL_H
61 #include <signal.h>
62 #endif
63 #if HAVE_FCNTL_H
64 /* for O_BINARY and O_TEXT in WIN32 */
65 #include <fcntl.h>
66 #endif
67 #ifdef _WIN32
68 #if HAVE_IO_H
69 /* Windows */
70 #include <io.h>
71 #endif
72 #endif
73 #if !HAVE_STRNCAT
74 #define strncat(X,Y,Z) strcat(X,Y)
75 #endif
76 #if !HAVE_STRNCPY
77 #define strncpy(X,Y,Z) strcpy(X,Y)
78 #endif
79 #if _MSC_VER || defined(__MINGW32__)
80 #if USE_SOCKET
81 #include <winsock2.h>
82 #endif
83 #include <windows.h>
84 #ifndef S_ISDIR
85 #define S_ISDIR(x) (((x)&_S_IFDIR)==_S_IFDIR)
86 #endif
87 #endif
88 #include "iopreds.h"
89
90 STATIC_PROTO (Int PlIOError, (yap_error_number, Term, char *));
91 STATIC_PROTO (int FilePutc, (int, int));
92 STATIC_PROTO (int MemPutc, (int, int));
93 STATIC_PROTO (int console_post_process_read_char, (int, StreamDesc *));
94 STATIC_PROTO (int console_post_process_eof, (StreamDesc *));
95 STATIC_PROTO (int post_process_read_char, (int, StreamDesc *));
96 STATIC_PROTO (int post_process_eof, (StreamDesc *));
97 #if USE_SOCKET
98 STATIC_PROTO (int SocketPutc, (int, int));
99 STATIC_PROTO (int ConsoleSocketPutc, (int, int));
100 #endif
101 STATIC_PROTO (int PipePutc, (int, int));
102 STATIC_PROTO (int ConsolePipePutc, (int, int));
103 STATIC_PROTO (int NullPutc, (int, int));
104 STATIC_PROTO (int ConsolePutc, (int, int));
105 STATIC_PROTO (Int p_setprompt, (void));
106 STATIC_PROTO (Int p_prompt, (void));
107 STATIC_PROTO (int PlGetc, (int));
108 STATIC_PROTO (int DefaultGets, (int,UInt,char*));
109 STATIC_PROTO (int PlGets, (int,UInt,char*));
110 STATIC_PROTO (int MemGetc, (int));
111 STATIC_PROTO (int ISOWGetc, (int));
112 STATIC_PROTO (int ConsoleGetc, (int));
113 STATIC_PROTO (int PipeGetc, (int));
114 STATIC_PROTO (int ConsolePipeGetc, (int));
115 #if USE_SOCKET
116 STATIC_PROTO (int SocketGetc, (int));
117 STATIC_PROTO (int ConsoleSocketGetc, (int));
118 #endif
119 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
120 STATIC_PROTO (int ReadlineGetc, (int));
121 STATIC_PROTO (int ReadlinePutc, (int,int));
122 #endif
123 STATIC_PROTO (int PlUnGetc, (int));
124 STATIC_PROTO (Term MkStream, (int));
125 STATIC_PROTO (Int p_stream_flags, (void));
126 STATIC_PROTO (int find_csult_file, (char *, char *, StreamDesc *, char *));
127 STATIC_PROTO (Int p_open, (void));
128 STATIC_PROTO (int AddAlias, (Atom, int));
129 STATIC_PROTO (void SetAlias, (Atom, int));
130 STATIC_PROTO (void PurgeAlias, (int));
131 STATIC_PROTO (int CheckAlias, (Atom));
132 STATIC_PROTO (Atom FetchAlias, (int));
133 STATIC_PROTO (int FindAliasForStream, (int, Atom));
134 STATIC_PROTO (int FindStreamForAlias, (Atom));
135 STATIC_PROTO (int CheckStream, (Term, int, char *));
136 STATIC_PROTO (Int p_check_stream, (void));
137 STATIC_PROTO (Int p_check_if_stream, (void));
138 STATIC_PROTO (Int init_cur_s, (void));
139 STATIC_PROTO (Int cont_cur_s, (void));
140 STATIC_PROTO (Int p_close, (void));
141 STATIC_PROTO (Int p_set_input, (void));
142 STATIC_PROTO (Int p_set_output, (void));
143 STATIC_PROTO (Int p_current_input, (void));
144 STATIC_PROTO (Int p_current_output, (void));
145 STATIC_PROTO (Int p_write, (void));
146 STATIC_PROTO (Int p_write2, (void));
147 STATIC_PROTO (Int p_set_read_error_handler, (void));
148 STATIC_PROTO (Int p_get_read_error_handler, (void));
149 STATIC_PROTO (Int p_read, (void));
150 STATIC_PROTO (Int p_cur_line_no, (void));
151 STATIC_PROTO (Int p_get, (void));
152 STATIC_PROTO (Int p_get0, (void));
153 STATIC_PROTO (Int p_get_byte, (void));
154 STATIC_PROTO (Int p_peek, (void));
155 STATIC_PROTO (Int p_past_eof, (void));
156 STATIC_PROTO (Int p_put, (void));
157 STATIC_PROTO (Int p_put_byte, (void));
158 STATIC_PROTO (Int p_skip, (void));
159 STATIC_PROTO (Int p_flush, (void));
160 STATIC_PROTO (Int p_flush_all_streams, (void));
161 STATIC_PROTO (Int p_write_depth, (void));
162 STATIC_PROTO (Int p_open_null_stream, (void));
163 STATIC_PROTO (Int p_user_file_name, (void));
164 STATIC_PROTO (Int p_line_position, (void));
165 STATIC_PROTO (Int p_character_count, (void));
166 STATIC_PROTO (Int p_show_stream_flags, (void));
167 STATIC_PROTO (Int p_show_stream_position, (void));
168 STATIC_PROTO (Int p_set_stream_position, (void));
169 STATIC_PROTO (Int p_add_alias_to_stream, (void));
170 STATIC_PROTO (Int p_change_alias_to_stream, (void));
171 STATIC_PROTO (Int p_check_if_valid_new_alias, (void));
172 STATIC_PROTO (Int p_fetch_stream_alias, (void));
173 STATIC_PROTO (Int p_format, (void));
174 STATIC_PROTO (Int p_startline, (void));
175 STATIC_PROTO (Int p_change_type_of_char, (void));
176 STATIC_PROTO (Int p_type_of_char, (void));
177 STATIC_PROTO (void CloseStream, (int));
178 STATIC_PROTO (int get_wchar, (int));
179 STATIC_PROTO (int put_wchar, (int,wchar_t));
180 STATIC_PROTO (Term StreamPosition, (int));
181
182 static encoding_t
DefaultEncoding(void)183 DefaultEncoding(void)
184 {
185 char *s = getenv("LANG");
186 size_t sz;
187
188 /* if we don't have a LANG then just use ISO_LATIN1 */
189 if (s == NULL)
190 s = getenv("LC_CTYPE");
191 if (s == NULL)
192 return ENC_ISO_LATIN1;
193 sz = strlen(s);
194 if (sz >= 5) {
195 if (s[sz-5] == 'U' &&
196 s[sz-4] == 'T' &&
197 s[sz-3] == 'F' &&
198 s[sz-2] == '-' &&
199 s[sz-1] == '8') {
200 return ENC_ISO_UTF8;
201 }
202 }
203 return ENC_ISO_ANSI;
204 }
205
206 static int
GetFreeStreamD(void)207 GetFreeStreamD(void)
208 {
209 int sno;
210
211 for (sno = 0; sno < MaxStreams; ++sno) {
212 LOCK(Stream[sno].streamlock);
213 if (Stream[sno].status & Free_Stream_f) {
214 break;
215 }
216 UNLOCK(Stream[sno].streamlock);
217 }
218 if (sno == MaxStreams) {
219 return -1;
220 }
221 Stream[sno].encoding = DefaultEncoding();
222 return sno;
223 }
224
225 int
Yap_GetFreeStreamD(void)226 Yap_GetFreeStreamD(void)
227 {
228 return GetFreeStreamD();
229 }
230
231 /* used from C-interface */
232 int
Yap_GetFreeStreamDForReading(void)233 Yap_GetFreeStreamDForReading(void)
234 {
235 int sno = GetFreeStreamD();
236 StreamDesc *s;
237
238 if (sno < 0) return sno;
239 s = Stream+sno;
240 s->status |= User_Stream_f|Input_Stream_f;
241 s->charcount = 0;
242 s->linecount = 1;
243 s->linepos = 0;
244 s->stream_wgetc = get_wchar;
245 s->encoding = DefaultEncoding();
246 if (CharConversionTable != NULL)
247 s->stream_wgetc_for_read = ISOWGetc;
248 else
249 s->stream_wgetc_for_read = s->stream_wgetc;
250 UNLOCK(s->streamlock);
251 return sno;
252 }
253
254
255 static int
yap_fflush(int sno)256 yap_fflush(int sno)
257 {
258 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
259 if (Stream[sno].status & Tty_Stream_f &&
260 Stream[sno].status & Output_Stream_f) {
261 if (ReadlinePos != ReadlineBuf) {
262 ReadlinePos[0] = '\0';
263 fputs( ReadlineBuf, Stream[sno].u.file.file);
264 }
265 ReadlinePos = ReadlineBuf;
266 }
267 #endif
268 if ( (Stream[sno].status & Output_Stream_f) &&
269 ! (Stream[sno].status &
270 (Null_Stream_f|
271 InMemory_Stream_f|
272 Socket_Stream_f|
273 Pipe_Stream_f|
274 Free_Stream_f)) ) {
275 if (Stream[sno].status & SWI_Stream_f) {
276 return SWIFlush(Stream[sno].u.swi_stream.swi_ptr);
277 }
278 return(fflush(Stream[sno].u.file.file));
279 } else
280 return(0);
281 }
282
283 static void
unix_upd_stream_info(StreamDesc * s)284 unix_upd_stream_info (StreamDesc * s)
285 {
286 if (s->status & InMemory_Stream_f) {
287 s->status |= Seekable_Stream_f;
288 return;
289 }
290 #if USE_SOCKET
291 if (Yap_sockets_io &&
292 s->u.file.file == NULL)
293 {
294 s->status |= Socket_Stream_f;
295 s->u.socket.domain = af_inet;
296 s->u.socket.flags = client_socket;
297 s->u.socket.fd = 0;
298 return;
299 }
300 #endif /* USE_SOCKET */
301 #if _MSC_VER || defined(__MINGW32__)
302 {
303 if (
304 _isatty(_fileno(s->u.file.file))
305 ) {
306 s->status |= Tty_Stream_f|Reset_Eof_Stream_f|Promptable_Stream_f;
307 /* make all console descriptors unbuffered */
308 setvbuf(s->u.file.file, NULL, _IONBF, 0);
309 return;
310 }
311 #if _MSC_VER
312 /* standard error stream should never be buffered */
313 else if (StdErrStream == s-Stream) {
314 setvbuf(s->u.file.file, NULL, _IONBF, 0);
315 }
316 #endif
317 s->status |= Seekable_Stream_f;
318 return;
319 }
320 #else
321 #if HAVE_ISATTY
322 #if __simplescalar__
323 /* isatty does not seem to work with simplescar. I'll assume the first
324 three streams will probably be ttys (pipes are not thatg different) */
325 if (s-Stream < 3) {
326 s->u.file.name = AtomTty;
327 s->status |= Tty_Stream_f|Reset_Eof_Stream_f|Promptable_Stream_f;
328 }
329 #else
330 {
331 int filedes; /* visualc */
332 filedes = YP_fileno (s->u.file.file);
333 if (isatty (filedes)) {
334 #if HAVE_TTYNAME
335 char *ttys = ttyname(filedes);
336 if (ttys == NULL)
337 s->u.file.name = AtomTty;
338 else
339 s->u.file.name = AtomTtys;
340 #else
341 s->u.file.name = AtomTty;
342 #endif
343 s->status |= Tty_Stream_f|Reset_Eof_Stream_f|Promptable_Stream_f;
344 return;
345 }
346 }
347 #endif
348 #endif /* HAVE_ISATTY */
349 #endif /* _MSC_VER */
350 s->status |= Seekable_Stream_f;
351 }
352
353 static Int
p_always_prompt_user(void)354 p_always_prompt_user(void)
355 {
356 StreamDesc *s = Stream+StdInStream;
357
358 s->status |= Promptable_Stream_f;
359 s->stream_gets = DefaultGets;
360 #if USE_SOCKET
361 if (s->status & Socket_Stream_f) {
362 s->stream_getc = ConsoleSocketGetc;
363 } else
364 #endif
365 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
366 if (s->status & Tty_Stream_f) {
367 s->stream_getc = ReadlineGetc;
368 if (Stream[0].status & Tty_Stream_f &&
369 s->u.file.name == Stream[0].u.file.name)
370 s->stream_putc = ReadlinePutc;
371 s->stream_wputc = put_wchar;
372 } else
373 #endif
374 {
375 /* else just PlGet plus checking for prompt */
376 s->stream_getc = ConsoleGetc;
377 }
378 return(TRUE);
379 }
380
381 static int
is_same_tty(YP_File f1,YP_File f2)382 is_same_tty(YP_File f1, YP_File f2)
383 {
384 #if HAVE_TTYNAME
385 return(ttyname(YP_fileno(f1)) == ttyname(YP_fileno(f2)));
386 #else
387 return(TRUE);
388 #endif
389 }
390
391 static GetsFunc
PlGetsFunc(void)392 PlGetsFunc(void)
393 {
394 if (CharConversionTable)
395 return DefaultGets;
396 else
397 return PlGets;
398 }
399
400 static void
InitFileIO(StreamDesc * s)401 InitFileIO(StreamDesc *s)
402 {
403 s->stream_gets = PlGetsFunc();
404 #if USE_SOCKET
405 if (s->status & Socket_Stream_f) {
406 /* Console is a socket and socket will prompt */
407 s->stream_putc = ConsoleSocketPutc;
408 s->stream_wputc = put_wchar;
409 s->stream_getc = ConsoleSocketGetc;
410 } else
411 #endif
412 if (s->status & Pipe_Stream_f) {
413 /* Console is a socket and socket will prompt */
414 s->stream_putc = ConsolePipePutc;
415 s->stream_wputc = put_wchar;
416 s->stream_getc = ConsolePipeGetc;
417 } else if (s->status & InMemory_Stream_f) {
418 s->stream_putc = MemPutc;
419 s->stream_wputc = put_wchar;
420 s->stream_getc = MemGetc;
421 } else {
422 /* check if our console is promptable: may be tty or pipe */
423 if (s->status & (Promptable_Stream_f)) {
424 /* the putc routine only has to check it is putting out a newline */
425 s->stream_putc = ConsolePutc;
426 s->stream_wputc = put_wchar;
427 /* if a tty have a special routine to call readline */
428 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
429 if (s->status & Tty_Stream_f) {
430 if (Stream[0].status & Tty_Stream_f &&
431 is_same_tty(s->u.file.file,Stream[0].u.file.file))
432 s->stream_putc = ReadlinePutc;
433 s->stream_wputc = put_wchar;
434 s->stream_getc = ReadlineGetc;
435 } else
436 #endif
437 {
438 /* else just PlGet plus checking for prompt */
439 s->stream_getc = ConsoleGetc;
440 }
441 } else {
442 /* we are reading from a file, no need to check for prompts */
443 s->stream_putc = FilePutc;
444 s->stream_wputc = put_wchar;
445 s->stream_getc = PlGetc;
446 s->stream_gets = PlGetsFunc();
447 }
448 }
449 s->stream_wgetc = get_wchar;
450 }
451
452
453 static void
InitStdStream(int sno,SMALLUNSGN flags,YP_File file)454 InitStdStream (int sno, SMALLUNSGN flags, YP_File file)
455 {
456 StreamDesc *s = &Stream[sno];
457 s->u.file.file = file;
458 s->status = flags;
459 s->linepos = 0;
460 s->linecount = 1;
461 s->charcount = 0;
462 s->encoding = DefaultEncoding();
463 INIT_LOCK(s->streamlock);
464 unix_upd_stream_info(s);
465 /* Getting streams to prompt is a mess because we need for cooperation
466 between readers and writers to the stream :-(
467 */
468 InitFileIO(s);
469 switch(sno) {
470 case 0:
471 s->u.file.name=AtomUserIn;
472 break;
473 case 1:
474 s->u.file.name=AtomUserOut;
475 break;
476 default:
477 s->u.file.name=AtomUserErr;
478 break;
479 }
480 s->u.file.user_name = MkAtomTerm (s->u.file.name);
481 if (CharConversionTable != NULL)
482 s->stream_wgetc_for_read = ISOWGetc;
483 else
484 s->stream_wgetc_for_read = s->stream_wgetc;
485 #if LIGHT
486 s->status |= Tty_Stream_f|Promptable_Stream_f;
487 #endif
488 #if HAVE_SETBUF
489 if (s->status & Tty_Stream_f &&
490 sno == 0) {
491 /* make sure input is unbuffered if it comes from stdin, this
492 makes life simpler for interrupt handling */
493 YP_setbuf (stdin, NULL);
494 // fprintf(stderr,"here I am\n");
495 }
496 #endif /* HAVE_SETBUF */
497
498 }
499
500
501 static void
InitStdStreams(void)502 InitStdStreams (void)
503 {
504 if (Yap_sockets_io) {
505 InitStdStream (StdInStream, Input_Stream_f, NULL);
506 InitStdStream (StdOutStream, Output_Stream_f, NULL);
507 InitStdStream (StdErrStream, Output_Stream_f, NULL);
508 } else {
509 InitStdStream (StdInStream, Input_Stream_f, stdin);
510 InitStdStream (StdOutStream, Output_Stream_f, stdout);
511 InitStdStream (StdErrStream, Output_Stream_f, stderr);
512 }
513 Yap_c_input_stream = StdInStream;
514 Yap_c_output_stream = StdOutStream;
515 Yap_c_error_stream = StdErrStream;
516 /* init standard aliases */
517 FileAliases[0].name = AtomUserIn;
518 FileAliases[0].alias_stream = 0;
519 FileAliases[1].name = AtomUserOut;
520 FileAliases[1].alias_stream = 1;
521 FileAliases[2].name = AtomUserErr;
522 FileAliases[2].alias_stream = 2;
523 NOfFileAliases = 3;
524 SzOfFileAliases = ALIASES_BLOCK_SIZE;
525 }
526
527 void
Yap_InitStdStreams(void)528 Yap_InitStdStreams (void)
529 {
530 InitStdStreams();
531 }
532
533 static void
InitPlIO(void)534 InitPlIO (void)
535 {
536 Int i;
537
538 for (i = 0; i < MaxStreams; ++i) {
539 INIT_LOCK(Stream[i].streamlock);
540 Stream[i].status = Free_Stream_f;
541 }
542 /* alloca alias array */
543 if (!FileAliases)
544 FileAliases = (AliasDesc)Yap_AllocCodeSpace(sizeof(struct AliasDescS)*ALIASES_BLOCK_SIZE);
545 InitStdStreams();
546 }
547
548 void
Yap_InitPlIO(void)549 Yap_InitPlIO (void)
550 {
551 InitPlIO ();
552 }
553
554 static Int
PlIOError(yap_error_number type,Term culprit,char * who)555 PlIOError (yap_error_number type, Term culprit, char *who)
556 {
557 if (Yap_GetValue(AtomFileerrors) == MkIntTerm(1) ||
558 type == RESOURCE_ERROR_MAX_STREAMS /* do not catch resource errors */) {
559 Yap_Error(type, culprit, who);
560 /* and fail */
561 return FALSE;
562 } else {
563 return FALSE;
564 }
565 }
566
567 /*
568 * Used by the prompts to check if they are after a newline, and then a
569 * prompt should be output, or if we are in the middle of a line.
570 */
571 static int newline = TRUE;
572
573 static void
count_output_char(int ch,StreamDesc * s)574 count_output_char(int ch, StreamDesc *s)
575 {
576 if (ch == '\n')
577 {
578 #if MPWSHELL
579 if (mpwshell && (sno == StdOutStream || sno ==
580 StdErrStream) &&
581 !(s->status & Null_Stream_f))
582 {
583 putc (MPWSEP, s->u.file.file);
584 if (!(Stream[Yap_c_output_stream].status & Null_Stream_f))
585 fflush (stdout);
586 }
587 #endif
588 /* Inform that we have written a newline */
589 ++s->charcount;
590 ++s->linecount;
591 s->linepos = 0;
592 }
593 else {
594 #if MAC
595 if ((sno == StdOutStream || sno == StdErrStream)
596 && s->linepos > 200)
597 sno->stream_putc(sno, '\n');
598 #endif
599 ++s->charcount;
600 ++s->linepos;
601 }
602 }
603
604 static void
console_count_output_char(int ch,StreamDesc * s)605 console_count_output_char(int ch, StreamDesc *s)
606 {
607 if (ch == '\n')
608 {
609 #if MPWSHELL
610 if (mpwshell && (sno == StdOutStream || sno ==
611 StdErrStream) &&
612 !(s->status & Null_Stream_f))
613 {
614 putc (MPWSEP, s->u.file.file);
615 if (!(Stream[Yap_c_output_stream].status & Null_Stream_f))
616 fflush (stdout);
617 }
618 #endif
619 ++s->charcount;
620 ++s->linecount;
621 s->linepos = 0;
622 newline = TRUE;
623 /* Inform we are not at the start of a newline */
624 }
625 else {
626 newline = FALSE;
627 #if MAC
628 if ((sno == StdOutStream || sno == StdErrStream)
629 && s->linepos > 200)
630 sno->stream_putc(sno, '\n');
631 #endif
632 ++s->charcount;
633 ++s->linepos;
634 }
635 }
636
637 #ifdef DEBUG
638
639 static int eolflg = 1;
640
641
642
643 static char my_line[200] = {0};
644 static char *lp = my_line;
645
646 static YP_File curfile;
647
648 #ifdef MACC
649
650 static void
InTTYLine(char * line)651 InTTYLine(char *line)
652 {
653 char *p = line;
654 char ch;
655 while ((ch = InKey()) != '\n' && ch != '\r')
656 if (ch == 8) {
657 if (line < p)
658 BackupTTY(*--p);
659 } else
660 TTYChar(*p++ = ch);
661 TTYChar('\n');
662 *p = 0;
663 }
664
665 #endif
666
667 void
Yap_DebugSetIFile(char * fname)668 Yap_DebugSetIFile(char *fname)
669 {
670 if (curfile)
671 YP_fclose(curfile);
672 curfile = YP_fopen(fname, "r");
673 if (curfile == NULL) {
674 curfile = stdin;
675 fprintf(stderr,"%% YAP Warning: can not open %s for input\n", fname);
676 }
677 }
678
679 void
Yap_DebugEndline()680 Yap_DebugEndline()
681 {
682 *lp = 0;
683
684 }
685
686 int
Yap_DebugGetc()687 Yap_DebugGetc()
688 {
689 int ch;
690 if (eolflg) {
691 if (curfile != NULL) {
692 if (YP_fgets(my_line, 200, curfile) == 0)
693 curfile = NULL;
694 }
695 if (curfile == NULL)
696 if (YP_fgets(my_line, 200, stdin) == NULL) {
697 return EOF;
698 }
699 eolflg = 0;
700 lp = my_line;
701 }
702 if ((ch = *lp++) == 0)
703 ch = '\n', eolflg = 1;
704 if (Yap_Option['l' - 96])
705 putc(ch, Yap_logfile);
706 return (ch);
707 }
708
709 int
Yap_DebugPutc(int sno,wchar_t ch)710 Yap_DebugPutc(int sno, wchar_t ch)
711 {
712 if (Yap_Option['l' - 96])
713 (void) putc(ch, Yap_logfile);
714 return (putc(ch, Yap_stderr));
715 }
716
717 void
Yap_DebugPlWrite(Term t)718 Yap_DebugPlWrite(Term t)
719 {
720 Yap_plwrite(t, Yap_DebugPutc, 0, 1200);
721 }
722
723 void
Yap_DebugErrorPutc(int c)724 Yap_DebugErrorPutc(int c)
725 {
726 Yap_DebugPutc (Yap_c_error_stream, c);
727 }
728
729 #endif
730
731 /* static */
732 static int
FilePutc(int sno,int ch)733 FilePutc(int sno, int ch)
734 {
735 StreamDesc *s = &Stream[sno];
736 #if MAC || _MSC_VER
737 if (ch == 10)
738 {
739 ch = '\n';
740 }
741 #endif
742 putc(ch, s->u.file.file);
743 #if MAC || _MSC_VER
744 if (ch == 10)
745 {
746 fflush(s->u.file.file);
747 }
748 #endif
749 count_output_char(ch,s);
750 return ((int) ch);
751 }
752
753 /* static */
754 static int
MemPutc(int sno,int ch)755 MemPutc(int sno, int ch)
756 {
757 StreamDesc *s = &Stream[sno];
758 #if MAC || _MSC_VER
759 if (ch == 10)
760 {
761 ch = '\n';
762 }
763 #endif
764 s->u.mem_string.buf[s->u.mem_string.pos++] = ch;
765 if (s->u.mem_string.pos >= s->u.mem_string.max_size -256) {
766 extern int Yap_page_size;
767 int old_src = s->u.mem_string.src, new_src;
768
769 /* oops, we have reached an overflow */
770 Int new_max_size = s->u.mem_string.max_size + Yap_page_size;
771 char *newbuf;
772
773 if ((newbuf = Yap_AllocAtomSpace(new_max_size*sizeof(char))) != NULL) {
774 new_src = MEM_BUF_CODE;
775 #if !USE_SYSTEM_MALLOC
776 } else if ((newbuf = (ADDR)malloc(new_max_size*sizeof(char))) != NULL) {
777 new_src = MEM_BUF_MALLOC;
778 #endif
779 } else {
780 if (Stream[sno].u.mem_string.error_handler) {
781 Yap_Error_Size = new_max_size*sizeof(char);
782 save_machine_regs();
783 longjmp(*(jmp_buf *)Stream[sno].u.mem_string.error_handler,1);
784 } else {
785 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "YAP could not grow heap for writing to string");
786 }
787 return -1;
788 }
789 #if HAVE_MEMMOVE
790 memmove((void *)newbuf, (void *)s->u.mem_string.buf, (size_t)((s->u.mem_string.pos)*sizeof(char)));
791 #else
792 {
793 Int n = s->u.mem_string.pos;
794 char *to = newbuf;
795 char *from = s->u.mem_string.buf;
796 while (n-- >= 0) {
797 *to++ = *from++;
798 }
799 }
800 #endif
801 if (old_src == MEM_BUF_CODE) {
802 Yap_FreeAtomSpace(s->u.mem_string.buf);
803 } else {
804 free(s->u.mem_string.buf);
805 }
806 s->u.mem_string.buf = newbuf;
807 s->u.mem_string.max_size = new_max_size;
808 s->u.mem_string.src = new_src;
809 }
810 count_output_char(ch,s);
811 return ((int) ch);
812 }
813
814 /* static */
815 static int
IOSWIPutc(int sno,int ch)816 IOSWIPutc(int sno, int ch)
817 {
818 int i;
819 Yap_StartSlots();
820 i = (SWIPutc)(ch, Stream[sno].u.swi_stream.swi_ptr);
821 Yap_CloseSlots();
822 YENV = ENV;
823 return i;
824 }
825
826 /* static */
827 static int
IOSWIGetc(int sno)828 IOSWIGetc(int sno)
829 {
830 int ch;
831 Yap_StartSlots();
832 ch = (SWIGetc)(Stream[sno].u.swi_stream.swi_ptr);
833 if (ch == EOF) {
834 return post_process_eof(Stream+sno);
835 }
836 return post_process_read_char(ch, Stream+sno);
837 Yap_CloseSlots();
838 YENV = ENV;
839 return ch;
840 }
841
842 /* static */
843 static int
IOSWIWidePutc(int sno,int ch)844 IOSWIWidePutc(int sno, int ch)
845 {
846 int i;
847 Yap_StartSlots();
848 i = (SWIWidePutc)(ch, Stream[sno].u.swi_stream.swi_ptr);
849 Yap_CloseSlots();
850 YENV = ENV;
851 return i;
852 }
853
854 /* static */
855 static int
IOSWIWideGetc(int sno)856 IOSWIWideGetc(int sno)
857 {
858 int ch;
859 Yap_StartSlots();
860 ch = (SWIWideGetc)(Stream[sno].u.swi_stream.swi_ptr);
861 if (ch == EOF) {
862 return post_process_eof(Stream+sno);
863 }
864 return post_process_read_char(ch, Stream+sno);
865 Yap_CloseSlots();
866 YENV = ENV;
867 return ch;
868 }
869
870 #if USE_SOCKET
871 /* static */
872 static int
ConsoleSocketPutc(int sno,int ch)873 ConsoleSocketPutc (int sno, int ch)
874 {
875 StreamDesc *s = &Stream[sno];
876 char c = ch;
877 #if MAC || _MSC_VER
878 if (ch == 10)
879 {
880 ch = '\n';
881 }
882 #endif
883 #if _MSC_VER || defined(__MINGW32__)
884 send(s->u.socket.fd, &c, sizeof(c), 0);
885 #else
886 if (write(s->u.socket.fd, &c, sizeof(c)) < 0) {
887 #if HAVE_STRERROR
888 Yap_Error(FATAL_ERROR, TermNil, "no access to console: %s", strerror(errno));
889 #else
890 Yap_Error(FATAL_ERROR, TermNil, "no access to console");
891 #endif
892 }
893 #endif
894 count_output_char(ch,s);
895 return ((int) ch);
896 }
897
898 static int
SocketPutc(int sno,int ch)899 SocketPutc (int sno, int ch)
900 {
901 StreamDesc *s = &Stream[sno];
902 char c = ch;
903 #if MAC || _MSC_VER
904 if (ch == 10)
905 {
906 ch = '\n';
907 }
908 #endif
909 #if _MSC_VER || defined(__MINGW32__)
910 send(s->u.socket.fd, &c, sizeof(c), 0);
911 #else
912 {
913 int out = 0;
914 while (!out) {
915 out = write(s->u.socket.fd, &c, sizeof(c));
916 if (out <0) {
917 #if HAVE_STRERROR
918 Yap_Error(PERMISSION_ERROR_INPUT_STREAM, TermNil, "error writing stream socket: %s", strerror(errno));
919 #else
920 Yap_Error(PERMISSION_ERROR_INPUT_STREAM, TermNil, "error writing stream socket");
921 #endif
922 }
923 }
924 }
925 #endif
926 return (int) ch;
927 }
928
929 #endif
930
931 /* static */
932 static int
ConsolePipePutc(int sno,int ch)933 ConsolePipePutc (int sno, int ch)
934 {
935 StreamDesc *s = &Stream[sno];
936 char c = ch;
937 #if MAC || _MSC_VER
938 if (ch == 10)
939 {
940 ch = '\n';
941 }
942 #endif
943 #if _MSC_VER || defined(__MINGW32__)
944 {
945 DWORD written;
946 if (WriteFile(s->u.pipe.hdl, &c, sizeof(c), &written, NULL) == FALSE) {
947 PlIOError (SYSTEM_ERROR,TermNil, "write to pipe returned error");
948 return EOF;
949 }
950 }
951 #else
952 {
953 int out = 0;
954 while (!out) {
955 out = write(s->u.pipe.fd, &c, sizeof(c));
956 if (out <0) {
957 #if HAVE_STRERROR
958 Yap_Error(PERMISSION_ERROR_INPUT_STREAM, TermNil, "error writing stream pipe: %s", strerror(errno));
959 #else
960 Yap_Error(PERMISSION_ERROR_INPUT_STREAM, TermNil, "error writing stream pipe");
961 #endif
962 }
963 }
964 }
965 #endif
966 count_output_char(ch,s);
967 return ((int) ch);
968 }
969
970 static int
PipePutc(int sno,int ch)971 PipePutc (int sno, int ch)
972 {
973 StreamDesc *s = &Stream[sno];
974 char c = ch;
975 #if MAC || _MSC_VER
976 if (ch == 10)
977 {
978 ch = '\n';
979 }
980 #endif
981 #if _MSC_VER || defined(__MINGW32__)
982 {
983 DWORD written;
984 if (WriteFile(s->u.pipe.hdl, &c, sizeof(c), &written, NULL) == FALSE) {
985 PlIOError (SYSTEM_ERROR,TermNil, "write to pipe returned error");
986 return EOF;
987 }
988 }
989 #else
990 {
991 int out = 0;
992 while (!out) {
993 out = write(s->u.pipe.fd, &c, sizeof(c));
994 if (out <0) {
995 #if HAVE_STRERROR
996 Yap_Error(PERMISSION_ERROR_INPUT_STREAM, TermNil, "error writing stream pipe: %s", strerror(errno));
997 #else
998 Yap_Error(PERMISSION_ERROR_INPUT_STREAM, TermNil, "error writing stream pipe");
999 #endif
1000 }
1001 }
1002 }
1003 #endif
1004 console_count_output_char(ch,s);
1005 return ((int) ch);
1006 }
1007
1008 static int
NullPutc(int sno,int ch)1009 NullPutc (int sno, int ch)
1010 {
1011 StreamDesc *s = &Stream[sno];
1012 #if MAC || _MSC_VER
1013 if (ch == 10)
1014 {
1015 ch = '\n';
1016 }
1017 #endif
1018 count_output_char(ch,s);
1019 return ((int) ch);
1020 }
1021
1022 /* static */
1023 static int
ConsolePutc(int sno,int ch)1024 ConsolePutc (int sno, int ch)
1025 {
1026 StreamDesc *s = &Stream[sno];
1027 #if MAC || _MSC_VER || defined(__MINGW32__)
1028 if (ch == 10)
1029 {
1030 putc ('\n', s->u.file.file);
1031 }
1032 else
1033 #endif
1034 putc (ch, s->u.file.file);
1035 console_count_output_char(ch,s);
1036 return ((int) ch);
1037 }
1038
1039 static Int
p_setprompt(void)1040 p_setprompt (void)
1041 { /* 'prompt(Atom) */
1042 Term t = Deref(ARG1);
1043 if (IsVarTerm (t) || !IsAtomTerm (t))
1044 return (FALSE);
1045 AtPrompt = AtomOfTerm (t);
1046 return (TRUE);
1047 }
1048
1049 static Int
p_is_same_tty(void)1050 p_is_same_tty (void)
1051 { /* 'prompt(Atom) */
1052 int sni = CheckStream (ARG1, Input_Stream_f, "put/2");
1053 int sno = CheckStream (ARG2, Output_Stream_f, "put/2");
1054 int out = (Stream[sni].status & Tty_Stream_f) &&
1055 (Stream[sno].status & Tty_Stream_f) &&
1056 is_same_tty(Stream[sno].u.file.file,Stream[sni].u.file.file);
1057 UNLOCK(Stream[sno].streamlock);
1058 UNLOCK(Stream[sni].streamlock);
1059 return out;
1060 }
1061
1062 static Int
p_prompt(void)1063 p_prompt (void)
1064 { /* prompt(Old,New) */
1065 Term t = Deref (ARG2);
1066 Atom a;
1067 if (!Yap_unify_constant (ARG1, MkAtomTerm (AtPrompt)))
1068 return (FALSE);
1069 if (IsVarTerm (t) || !IsAtomTerm (t))
1070 return (FALSE);
1071 a = AtomOfTerm (t);
1072 if (strlen (RepAtom (a)->StrOfAE) > MAX_PROMPT) {
1073 Yap_Error(SYSTEM_ERROR,t,"prompt %s is too long", RepAtom (a)->StrOfAE);
1074 return(FALSE);
1075 }
1076 strncpy(Prompt, RepAtom (a)->StrOfAE, MAX_PROMPT);
1077 AtPrompt = a;
1078 return (TRUE);
1079 }
1080
1081 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
1082
1083 #include <readline/readline.h>
1084 #include <readline/history.h>
1085
1086 static char *ttyptr = NULL;
1087
1088 static char *myrl_line = (char *) NULL;
1089
1090 static int cur_out_sno = 2;
1091
1092 #define READLINE_OUT_BUF_MAX 256
1093
1094 static void
InitReadline(void)1095 InitReadline(void) {
1096 ReadlineBuf = (char *)Yap_AllocAtomSpace(READLINE_OUT_BUF_MAX+1);
1097 ReadlinePos = ReadlineBuf;
1098 #if _MSC_VER || defined(__MINGW32__)
1099 rl_instream = stdin;
1100 rl_outstream = stdout;
1101 #endif
1102 }
1103
1104 static int
ReadlinePutc(int sno,int ch)1105 ReadlinePutc (int sno, int ch)
1106 {
1107 if (ReadlinePos != ReadlineBuf &&
1108 (ReadlinePos - ReadlineBuf == READLINE_OUT_BUF_MAX-1 /* overflow */ ||
1109 #if MAC || _MSC_VER
1110 ch == 10 ||
1111 #endif
1112 ch == '\n')) {
1113 #if MAC || _MSC_VER
1114 if (ch == 10)
1115 {
1116 ch = '\n';
1117 }
1118 #endif
1119 if (ch == '\n') {
1120 ReadlinePos[0] = '\n';
1121 ReadlinePos++;
1122 }
1123 ReadlinePos[0] = '\0';
1124 fputs( ReadlineBuf, Stream[sno].u.file.file);
1125 ReadlinePos = ReadlineBuf;
1126 if (ch == '\n') {
1127 console_count_output_char(ch,Stream+sno);
1128 return((int) '\n');
1129 }
1130 }
1131 *ReadlinePos++ = ch;
1132 console_count_output_char(ch,Stream+sno);
1133 return ((int) ch);
1134 }
1135
1136 /*
1137 reading from the console is complicated because we need to
1138 know whether to prompt and so on...
1139 */
1140 static int
ReadlineGetc(int sno)1141 ReadlineGetc(int sno)
1142 {
1143 register StreamDesc *s = &Stream[sno];
1144 register wchar_t ch;
1145
1146 while (ttyptr == NULL) {
1147 /* Only sends a newline if we are at the start of a line */
1148 if (myrl_line) {
1149 free (myrl_line);
1150 myrl_line = NULL;
1151 }
1152 rl_instream = Stream[sno].u.file.file;
1153 rl_outstream = Stream[cur_out_sno].u.file.file;
1154 /* window of vulnerability opened */
1155 if (newline) {
1156 char *cptr = Prompt, ch;
1157
1158 if ((Stream[FileAliases[2].alias_stream].status & Tty_Stream_f) &&
1159 Stream[FileAliases[0].alias_stream].u.file.name == Stream[sno].u.file.name) {
1160 /* don't just output the prompt */
1161 while ((ch = *cptr++) != '\0') {
1162 console_count_output_char(ch,Stream+StdErrStream);
1163 }
1164 Yap_PrologMode |= ConsoleGetcMode;
1165 myrl_line = readline (Prompt);
1166 } else {
1167 Yap_PrologMode |= ConsoleGetcMode;
1168 myrl_line = readline (NULL);
1169 }
1170 } else {
1171 if (ReadlinePos != ReadlineBuf) {
1172 ReadlinePos[0] = '\0';
1173 ReadlinePos = ReadlineBuf;
1174 Yap_PrologMode |= ConsoleGetcMode;
1175 myrl_line = readline (ReadlineBuf);
1176 } else {
1177 Yap_PrologMode |= ConsoleGetcMode;
1178 myrl_line = readline (NULL);
1179 }
1180 }
1181 /* Do it the gnu way */
1182 if (Yap_PrologMode & InterruptMode) {
1183 Yap_PrologMode &= ~InterruptMode;
1184 Yap_ProcessSIGINT();
1185 Yap_PrologMode &= ~ConsoleGetcMode;
1186 if (Yap_PrologMode & AbortMode) {
1187 Yap_Error(PURE_ABORT, TermNil, "");
1188 Yap_ErrorMessage = "Abort";
1189 return console_post_process_eof(s);
1190 }
1191 continue;
1192 } else {
1193 Yap_PrologMode &= ~ConsoleGetcMode;
1194 }
1195 newline=FALSE;
1196 strncpy (Prompt, RepAtom (AtPrompt)->StrOfAE, MAX_PROMPT);
1197 /* window of vulnerability closed */
1198 if (myrl_line == NULL)
1199 return console_post_process_eof(s);
1200 if (myrl_line[0] != '\0' && myrl_line[1] != '\0')
1201 add_history (myrl_line);
1202 ttyptr = myrl_line;
1203 }
1204 if (*ttyptr == '\0') {
1205 ttyptr = NIL;
1206 ch = '\n';
1207 } else {
1208 ch = *((unsigned char *)ttyptr);
1209 ttyptr++;
1210 }
1211 return console_post_process_read_char(ch, s);
1212 }
1213
1214 #endif /* HAVE_LIBREADLINE */
1215
1216 static Int
p_has_readline(void)1217 p_has_readline(void)
1218 {
1219 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
1220 return TRUE;
1221 #else
1222 return FALSE;
1223 #endif
1224 }
1225
1226
1227 int
Yap_GetCharForSIGINT(void)1228 Yap_GetCharForSIGINT(void)
1229 {
1230 int ch;
1231 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
1232 if ((Yap_PrologMode & ConsoleGetcMode) && myrl_line != (char *) NULL) {
1233 ch = myrl_line[0];
1234 free(myrl_line);
1235 myrl_line = NULL;
1236 } else {
1237 myrl_line = readline ("Action (h for help): ");
1238 if (!myrl_line) {
1239 ch = EOF;
1240 } else {
1241 ch = myrl_line[0];
1242 free(myrl_line);
1243 myrl_line = NULL;
1244 }
1245 }
1246 #else
1247 /* ask for a new line */
1248 fprintf(stderr, "Action (h for help): ");
1249 ch = getc(stdin);
1250 /* first process up to end of line */
1251 while ((fgetc(stdin)) != '\n');
1252 #endif
1253 newline = TRUE;
1254 return ch;
1255 }
1256
1257 static int
ResetEOF(StreamDesc * s)1258 ResetEOF(StreamDesc *s) {
1259 if (s->status & Eof_Error_Stream_f) {
1260 Yap_Error(PERMISSION_ERROR_INPUT_PAST_END_OF_STREAM,MkAtomTerm(s->u.file.name),
1261 "GetC");
1262 return FALSE;
1263 } else if (s->status & Reset_Eof_Stream_f) {
1264 /* reset the eof indicator on file */
1265 if (YP_feof (s->u.file.file))
1266 YP_clearerr (s->u.file.file);
1267 /* reset our function for reading input */
1268 #if USE_SOCKET
1269 if (s->status & Socket_Stream_f) {
1270 if (s->status & Promptable_Stream_f)
1271 s->stream_putc = ConsoleSocketPutc;
1272 else
1273 s->stream_putc = SocketPutc;
1274 s->stream_wputc = put_wchar;
1275 } else
1276 #endif
1277 if (s->status & Pipe_Stream_f) {
1278 if (s->status & Promptable_Stream_f)
1279 s->stream_putc = ConsolePipePutc;
1280 else
1281 s->stream_putc = PipePutc;
1282 s->stream_wputc = put_wchar;
1283 } else if (s->status & InMemory_Stream_f) {
1284 s->stream_getc = MemGetc;
1285 s->stream_putc = MemPutc;
1286 s->stream_wputc = put_wchar;
1287 } else if (s->status & Promptable_Stream_f) {
1288 s->stream_putc = ConsolePutc;
1289 s->stream_wputc = put_wchar;
1290 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
1291 if (s->status & Tty_Stream_f) {
1292 s->stream_getc = ReadlineGetc;
1293 if (Stream[0].status & Tty_Stream_f &&
1294 is_same_tty(s->u.file.file,Stream[0].u.file.file))
1295 s->stream_putc = ReadlinePutc;
1296 } else
1297 #endif
1298 {
1299 s->stream_getc = ConsoleGetc;
1300 }
1301 } else {
1302 s->stream_getc = PlGetc;
1303 s->stream_gets = PlGetsFunc();
1304 }
1305 if (s->status & SWI_Stream_f)
1306 s->stream_wgetc = IOSWIWideGetc;
1307 else
1308 s->stream_wgetc = get_wchar;
1309 if (CharConversionTable != NULL)
1310 s->stream_wgetc_for_read = ISOWGetc;
1311 else
1312 s->stream_wgetc_for_read = s->stream_wgetc;
1313 /* next, reset our own error indicator */
1314 s->status &= ~Eof_Stream_f;
1315 /* try reading again */
1316 return TRUE;
1317 } else {
1318 s->status |= Past_Eof_Stream_f;
1319 return FALSE;
1320 }
1321 }
1322
1323 /* handle reading from a stream after having found an EOF */
1324 static int
EOFGetc(int sno)1325 EOFGetc(int sno)
1326 {
1327 register StreamDesc *s = &Stream[sno];
1328
1329 if (s->status & Push_Eof_Stream_f) {
1330 /* ok, we have pushed an EOF, send it away */
1331 s->status &= ~Push_Eof_Stream_f;
1332 return EOF;
1333 }
1334 if (ResetEOF(s)) {
1335 return(s->stream_getc(sno));
1336 }
1337 return EOF;
1338 }
1339
1340 /* check if we read a newline or an EOF */
1341 static int
post_process_read_char(int ch,StreamDesc * s)1342 post_process_read_char(int ch, StreamDesc *s)
1343 {
1344 ++s->charcount;
1345 ++s->linepos;
1346 if (ch == '\n') {
1347 ++s->linecount;
1348 s->linepos = 0;
1349 /* don't convert if the stream is binary */
1350 if (!(s->status & Binary_Stream_f))
1351 ch = 10;
1352 }
1353 return ch;
1354 }
1355
1356 /* check if we read a newline or an EOF */
1357 static int
post_process_eof(StreamDesc * s)1358 post_process_eof(StreamDesc *s)
1359 {
1360 s->status |= Eof_Stream_f;
1361 s->stream_getc = EOFGetc;
1362 s->stream_wgetc = get_wchar;
1363 if (CharConversionTable != NULL)
1364 s->stream_wgetc_for_read = ISOWGetc;
1365 else
1366 s->stream_wgetc_for_read = s->stream_wgetc;
1367 return EOFCHAR;
1368 }
1369
1370 /* check if we read a newline or an EOF */
1371 static int
console_post_process_read_char(int ch,StreamDesc * s)1372 console_post_process_read_char(int ch, StreamDesc *s)
1373 {
1374 /* the character is also going to be output by the console handler */
1375 console_count_output_char(ch,Stream+StdErrStream);
1376 if (ch == '\n') {
1377 ++s->linecount;
1378 ++s->charcount;
1379 s->linepos = 0;
1380 newline = TRUE;
1381 } else {
1382 ++s->charcount;
1383 ++s->linepos;
1384 newline = FALSE;
1385 }
1386 return ch;
1387 }
1388
1389 /* check if we read a newline or an EOF */
1390 static int
console_post_process_eof(StreamDesc * s)1391 console_post_process_eof(StreamDesc *s)
1392 {
1393 s->status |= Eof_Stream_f;
1394 s->stream_getc = EOFGetc;
1395 s->stream_wgetc = get_wchar;
1396 if (CharConversionTable != NULL)
1397 s->stream_wgetc_for_read = ISOWGetc;
1398 else
1399 s->stream_wgetc_for_read = s->stream_wgetc;
1400 newline = FALSE;
1401 return EOFCHAR;
1402 }
1403
1404 #if USE_SOCKET
1405 /*
1406 sockets cannot use standard FILE *, we have to go through fds, and in the
1407 case of VC++, we have to use the receive routines...
1408 */
1409 static int
SocketGetc(int sno)1410 SocketGetc(int sno)
1411 {
1412 register StreamDesc *s = &Stream[sno];
1413 register Int ch;
1414 char c;
1415 int count;
1416 /* should be able to use a buffer */
1417 #if _MSC_VER || defined(__MINGW32__)
1418 count = recv(s->u.socket.fd, &c, sizeof(char), 0);
1419 #else
1420 count = read(s->u.socket.fd, &c, sizeof(char));
1421 #endif
1422 if (count == 0) {
1423 s->u.socket.flags = closed_socket;
1424 return post_process_eof(s);
1425 } else if (count > 0) {
1426 ch = c;
1427 } else {
1428 #if HAVE_STRERROR
1429 Yap_Error(SYSTEM_ERROR, TermNil,
1430 "( socket_getc: %s)", strerror(errno));
1431 #else
1432 Yap_Error(SYSTEM_ERROR, TermNil,
1433 "(socket_getc)");
1434 #endif
1435 return post_process_eof(s);
1436 }
1437 return post_process_read_char(ch, s);
1438 }
1439
1440 /*
1441 Basically, the same as console but also sends a prompt and takes care of
1442 finding out whether we are at the start of a newline.
1443 */
1444 static int
ConsoleSocketGetc(int sno)1445 ConsoleSocketGetc(int sno)
1446 {
1447 register StreamDesc *s = &Stream[sno];
1448 int ch;
1449 Int c;
1450 int count;
1451
1452 /* send the prompt away */
1453 if (newline) {
1454 char *cptr = Prompt, ch;
1455 /* use the default routine */
1456 while ((ch = *cptr++) != '\0') {
1457 Stream[StdErrStream].stream_putc(StdErrStream, ch);
1458 }
1459 strncpy(Prompt, RepAtom (AtPrompt)->StrOfAE, MAX_PROMPT);
1460 newline = FALSE;
1461 }
1462 /* should be able to use a buffer */
1463 Yap_PrologMode |= ConsoleGetcMode;
1464 #if _MSC_VER || defined(__MINGW32__)
1465 count = recv(s->u.socket.fd, (void *)&c, sizeof(char), 0);
1466 #else
1467 count = read(s->u.socket.fd, &c, sizeof(char));
1468 #endif
1469 Yap_PrologMode &= ~ConsoleGetcMode;
1470 if (count == 0) {
1471 return console_post_process_eof(s);
1472 } else if (count > 0) {
1473 ch = c;
1474 } else {
1475 Yap_Error(SYSTEM_ERROR, TermNil, "read");
1476 return console_post_process_eof(s);
1477 }
1478 return console_post_process_read_char(ch, s);
1479 }
1480 #endif
1481
1482 static int
PipeGetc(int sno)1483 PipeGetc(int sno)
1484 {
1485 StreamDesc *s = &Stream[sno];
1486 Int ch;
1487 char c;
1488
1489 /* should be able to use a buffer */
1490 #if _MSC_VER || defined(__MINGW32__)
1491 DWORD count;
1492 if (ReadFile(s->u.pipe.hdl, &c, sizeof(c), &count, NULL) == FALSE) {
1493 Yap_WinError("read from pipe returned error");
1494 return EOF;
1495 }
1496 #else
1497 int count;
1498 count = read(s->u.pipe.fd, &c, sizeof(char));
1499 #endif
1500 if (count == 0) {
1501 return post_process_eof(s);
1502 } else if (count > 0) {
1503 ch = c;
1504 } else {
1505 #if HAVE_STRERROR
1506 Yap_Error(SYSTEM_ERROR, TermNil, "at pipe getc: %s", strerror(errno));
1507 #else
1508 Yap_Error(SYSTEM_ERROR, TermNil, "at pipe getc");
1509 #endif
1510 return post_process_eof(s);
1511 }
1512 return post_process_read_char(ch, s);
1513 }
1514
1515 /*
1516 Basically, the same as console but also sends a prompt and takes care of
1517 finding out whether we are at the start of a newline.
1518 */
1519 static int
ConsolePipeGetc(int sno)1520 ConsolePipeGetc(int sno)
1521 {
1522 StreamDesc *s = &Stream[sno];
1523 int ch;
1524 char c;
1525 #if _MSC_VER || defined(__MINGW32__)
1526 DWORD count;
1527 #else
1528 int count;
1529 #endif
1530
1531 /* send the prompt away */
1532 if (newline) {
1533 char *cptr = Prompt, ch;
1534 /* use the default routine */
1535 while ((ch = *cptr++) != '\0') {
1536 Stream[StdErrStream].stream_putc(StdErrStream, ch);
1537 }
1538 strncpy(Prompt, RepAtom (AtPrompt)->StrOfAE, MAX_PROMPT);
1539 newline = FALSE;
1540 }
1541 #if _MSC_VER || defined(__MINGW32__)
1542 if (ReadFile(s->u.pipe.hdl, &c, sizeof(c), &count, NULL) == FALSE) {
1543 Yap_PrologMode |= ConsoleGetcMode;
1544 Yap_WinError("read from console pipe returned error");
1545 Yap_PrologMode &= ~ConsoleGetcMode;
1546 return console_post_process_eof(s);
1547 }
1548 #else
1549 /* should be able to use a buffer */
1550 Yap_PrologMode |= ConsoleGetcMode;
1551 count = read(s->u.pipe.fd, &c, sizeof(char));
1552 Yap_PrologMode &= ~ConsoleGetcMode;
1553 #endif
1554 if (count == 0) {
1555 return console_post_process_eof(s);
1556 } else if (count > 0) {
1557 ch = c;
1558 } else {
1559 Yap_Error(SYSTEM_ERROR, TermNil, "read");
1560 return console_post_process_eof(s);
1561 }
1562 return console_post_process_read_char(ch, s);
1563 }
1564
1565 /* standard routine, it should read from anything pointed by a FILE *.
1566 It could be made more efficient by doing our own buffering and avoiding
1567 post_process_read_char, something to think about */
1568 static int
PlGetc(int sno)1569 PlGetc (int sno)
1570 {
1571 StreamDesc *s = &Stream[sno];
1572 Int ch;
1573
1574 ch = YP_getc (s->u.file.file);
1575 if (ch == EOF) {
1576 return post_process_eof(s);
1577 }
1578 return post_process_read_char(ch, s);
1579 }
1580
1581 /* standard routine, it should read from anything pointed by a FILE *.
1582 It could be made more efficient by doing our own buffering and avoiding
1583 post_process_read_char, something to think about */
1584 static int
PlGets(int sno,UInt size,char * buf)1585 PlGets (int sno, UInt size, char *buf)
1586 {
1587 register StreamDesc *s = &Stream[sno];
1588 UInt len;
1589
1590 if (fgets (buf, size, s->u.file.file) == NULL) {
1591 return post_process_eof(s);
1592 }
1593 len = strlen(buf);
1594 s->charcount += len-1;
1595 post_process_read_char(buf[len-2], s);
1596 return strlen(buf);
1597 }
1598
1599 /* standard routine, it should read from anything pointed by a FILE *.
1600 It could be made more efficient by doing our own buffering and avoiding
1601 post_process_read_char, something to think about */
1602 static int
DefaultGets(int sno,UInt size,char * buf)1603 DefaultGets (int sno, UInt size, char *buf)
1604 {
1605 StreamDesc *s = &Stream[sno];
1606 char ch;
1607 char *pt = buf;
1608
1609
1610 if (!size)
1611 return 0;
1612 while((ch = *buf++ = s->stream_getc(sno)) !=
1613 -1 && ch != 10 && --size);
1614 *buf++ = '\0';
1615 return (buf-pt)-1;
1616 }
1617
1618 /* read from memory */
1619 static int
MemGetc(int sno)1620 MemGetc (int sno)
1621 {
1622 register StreamDesc *s = &Stream[sno];
1623 Int ch;
1624 int spos;
1625
1626 spos = s->u.mem_string.pos;
1627 if (spos == s->u.mem_string.max_size) {
1628 return post_process_eof(s);
1629 } else {
1630 ch = s->u.mem_string.buf[spos];
1631 s->u.mem_string.pos = ++spos;
1632 }
1633 return post_process_read_char(ch, s);
1634 }
1635
1636 /* I dispise this code!!!!! */
1637 static int
ISOWGetc(int sno)1638 ISOWGetc (int sno)
1639 {
1640 int ch = Stream[sno].stream_wgetc(sno);
1641 if (ch != EOF && CharConversionTable != NULL) {
1642
1643 if (ch < NUMBER_OF_CHARS) {
1644 /* only do this in ASCII */
1645 return CharConversionTable[ch];
1646 }
1647 }
1648 return ch;
1649 }
1650
1651 /* send a prompt, and use the system for internal buffering. Speed is
1652 not of the essence here !!! */
1653 static int
ConsoleGetc(int sno)1654 ConsoleGetc(int sno)
1655 {
1656 register StreamDesc *s = &Stream[sno];
1657 int ch;
1658
1659 restart:
1660 /* keep the prompt around, just in case, but don't actually
1661 show it in silent mode */
1662 if (newline) {
1663 if (!yap_flags[QUIET_MODE_FLAG]) {
1664 char *cptr = Prompt, ch;
1665
1666 /* use the default routine */
1667 while ((ch = *cptr++) != '\0') {
1668 Stream[StdErrStream].stream_putc(StdErrStream, ch);
1669 }
1670 }
1671 strncpy (Prompt, RepAtom (AtPrompt)->StrOfAE, MAX_PROMPT);
1672 newline = FALSE;
1673 }
1674 #if HAVE_SIGINTERRUPT
1675 siginterrupt(SIGINT, TRUE);
1676 #endif
1677 Yap_PrologMode |= ConsoleGetcMode;
1678 ch = YP_fgetc(s->u.file.file);
1679 #if HAVE_SIGINTERRUPT
1680 siginterrupt(SIGINT, FALSE);
1681 #endif
1682 if (Yap_PrologMode & InterruptMode) {
1683 Yap_PrologMode &= ~InterruptMode;
1684 Yap_ProcessSIGINT();
1685 Yap_PrologMode &= ~ConsoleGetcMode;
1686 newline = TRUE;
1687 if (Yap_PrologMode & AbortMode) {
1688 Yap_Error(PURE_ABORT, TermNil, "");
1689 Yap_ErrorMessage = "Abort";
1690 return console_post_process_eof(s);
1691 }
1692 goto restart;
1693 } else {
1694 Yap_PrologMode &= ~ConsoleGetcMode;
1695 }
1696 if (ch == EOF)
1697 return console_post_process_eof(s);
1698 return console_post_process_read_char(ch, s);
1699 }
1700
1701 /* reads a character from a buffer and does the rest */
1702 static int
PlUnGetc(int sno)1703 PlUnGetc (int sno)
1704 {
1705 register StreamDesc *s = &Stream[sno];
1706 Int ch;
1707
1708 if (s->stream_getc != PlUnGetc)
1709 return(s->stream_getc(sno));
1710 ch = s->och;
1711 if (s->status & InMemory_Stream_f) {
1712 s->stream_getc = MemGetc;
1713 s->stream_putc = MemPutc;
1714 s->stream_wputc = put_wchar;
1715 } else if (s->status & Socket_Stream_f) {
1716 s->stream_getc = SocketGetc;
1717 s->stream_putc = SocketPutc;
1718 s->stream_wputc = put_wchar;
1719 } else if (s->status & Promptable_Stream_f) {
1720 s->stream_putc = ConsolePutc;
1721 s->stream_wputc = put_wchar;
1722 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
1723 if (s->status & Tty_Stream_f) {
1724 s->stream_getc = ReadlineGetc;
1725 if (Stream[0].status & Tty_Stream_f &&
1726 is_same_tty(s->u.file.file,Stream[0].u.file.file))
1727 s->stream_putc = ReadlinePutc;
1728 s->stream_wputc = put_wchar;
1729 } else
1730 #endif
1731 {
1732 s->stream_getc = ConsoleGetc;
1733 }
1734 } else {
1735 s->stream_getc = PlGetc;
1736 s->stream_gets = PlGetsFunc();
1737 }
1738 return(ch);
1739 }
1740
1741 /* give back 0376+ch */
1742 static int
PlUnGetc376(int sno)1743 PlUnGetc376 (int sno)
1744 {
1745 register StreamDesc *s = &Stream[sno];
1746 Int ch;
1747
1748 if (s->stream_getc != PlUnGetc376)
1749 return(s->stream_getc(sno));
1750 s->stream_getc = PlUnGetc;
1751 ch = s->och;
1752 s->och = 0xFE;
1753 return ch;
1754 }
1755
1756 /* give back 0376+ch */
1757 static int
PlUnGetc00(int sno)1758 PlUnGetc00 (int sno)
1759 {
1760 register StreamDesc *s = &Stream[sno];
1761 Int ch;
1762
1763 if (s->stream_getc != PlUnGetc00)
1764 return(s->stream_getc(sno));
1765 s->stream_getc = PlUnGetc;
1766 ch = s->och;
1767 s->och = 0x00;
1768 return ch;
1769 }
1770
1771 /* give back 0377+ch */
1772 static int
PlUnGetc377(int sno)1773 PlUnGetc377 (int sno)
1774 {
1775 register StreamDesc *s = &Stream[sno];
1776 Int ch;
1777
1778 if (s->stream_getc != PlUnGetc377)
1779 return(s->stream_getc(sno));
1780 s->stream_getc = PlUnGetc;
1781 ch = s->och;
1782 s->och = 0xFF;
1783 return ch;
1784 }
1785
1786 /* give back 0357+ch */
1787 static int
PlUnGetc357(int sno)1788 PlUnGetc357 (int sno)
1789 {
1790 register StreamDesc *s = &Stream[sno];
1791 Int ch;
1792
1793 if (s->stream_getc != PlUnGetc357)
1794 return(s->stream_getc(sno));
1795 s->stream_getc = PlUnGetc;
1796 ch = s->och;
1797 s->och = 0xEF;
1798 return ch;
1799 }
1800
1801 /* give back 0357+0273+ch */
1802 static int
PlUnGetc357273(int sno)1803 PlUnGetc357273 (int sno)
1804 {
1805 register StreamDesc *s = &Stream[sno];
1806 Int ch;
1807
1808 if (s->stream_getc != PlUnGetc357273)
1809 return(s->stream_getc(sno));
1810 s->stream_getc = PlUnGetc357;
1811 ch = s->och;
1812 s->och = 0xBB;
1813 return ch;
1814 }
1815
1816 /* give back 000+000+ch */
1817 static int
PlUnGetc0000(int sno)1818 PlUnGetc0000 (int sno)
1819 {
1820 register StreamDesc *s = &Stream[sno];
1821 Int ch;
1822
1823 if (s->stream_getc != PlUnGetc0000)
1824 return(s->stream_getc(sno));
1825 s->stream_getc = PlUnGetc00;
1826 ch = s->och;
1827 s->och = 0x00;
1828 return ch;
1829 }
1830
1831 /* give back 000+000+ch */
1832 static int
PlUnGetc0000fe(int sno)1833 PlUnGetc0000fe (int sno)
1834 {
1835 register StreamDesc *s = &Stream[sno];
1836 Int ch;
1837
1838 if (s->stream_getc != PlUnGetc0000fe)
1839 return(s->stream_getc(sno));
1840 s->stream_getc = PlUnGetc0000;
1841 ch = s->och;
1842 s->och = 0xfe;
1843 return ch;
1844 }
1845
1846 /* give back 0377+0376+ch */
1847 static int
PlUnGetc377376(int sno)1848 PlUnGetc377376 (int sno)
1849 {
1850 register StreamDesc *s = &Stream[sno];
1851 Int ch;
1852
1853 if (s->stream_getc != PlUnGetc377376)
1854 return(s->stream_getc(sno));
1855 s->stream_getc = PlUnGetc377;
1856 ch = s->och;
1857 s->och = 0xFE;
1858 return ch;
1859 }
1860
1861 /* give back 0377+0376+000+ch */
1862 static int
PlUnGetc37737600(int sno)1863 PlUnGetc37737600 (int sno)
1864 {
1865 register StreamDesc *s = &Stream[sno];
1866 Int ch;
1867
1868 if (s->stream_getc != PlUnGetc37737600)
1869 return(s->stream_getc(sno));
1870 s->stream_getc = PlUnGetc377376;
1871 ch = s->och;
1872 s->och = 0x00;
1873 return ch;
1874 }
1875
1876 static int
utf8_nof(char ch)1877 utf8_nof(char ch)
1878 {
1879 if (!(ch & 0x20))
1880 return 1;
1881 if (!(ch & 0x10))
1882 return 2;
1883 if (!(ch & 0x08))
1884 return 3;
1885 if (!(ch & 0x04))
1886 return 4;
1887 return 5;
1888 }
1889
1890 static int
get_wchar(int sno)1891 get_wchar(int sno)
1892 {
1893 int ch;
1894 wchar_t wch;
1895 int how_many = 0;
1896
1897 while (TRUE) {
1898 ch = Stream[sno].stream_getc(sno);
1899 if (ch == -1) {
1900 if (how_many) {
1901 /* error */
1902 }
1903 return EOF;
1904 }
1905 switch (Stream[sno].encoding) {
1906 case ENC_OCTET:
1907 return ch;
1908 case ENC_ISO_LATIN1:
1909 return ch;
1910 case ENC_ISO_ASCII:
1911 if (ch & 0x80) {
1912 /* error */
1913 }
1914 return ch;
1915 case ENC_ISO_ANSI:
1916 {
1917 char buf[1];
1918 int out;
1919
1920 if (!how_many) {
1921 memset((void *)&(Stream[sno].mbstate), 0, sizeof(mbstate_t));
1922 }
1923 buf[0] = ch;
1924 if ((out = mbrtowc(&wch, buf, 1, &(Stream[sno].mbstate))) == 1)
1925 return wch;
1926 if (out == -1) {
1927 /* error */
1928 }
1929 how_many++;
1930 break;
1931 }
1932 case ENC_ISO_UTF8:
1933 {
1934 if (!how_many) {
1935 if (ch & 0x80) {
1936 how_many = utf8_nof(ch);
1937 /*
1938 keep a backup of the start character in case we meet an error,
1939 useful if we are scanning ISO files.
1940 */
1941 Stream[sno].och = ch;
1942 wch = (ch & ((1<<(6-how_many))-1))<<(6*how_many);
1943 } else {
1944 return ch;
1945 }
1946 } else {
1947 how_many--;
1948 if ((ch & 0xc0) == 0x80) {
1949 wch += (ch & ~0xc0) << (how_many*6);
1950 } else {
1951 /* error */
1952 /* try to recover character, assume this is our first character */
1953 wchar_t och = Stream[sno].och;
1954
1955 Stream[sno].och = ch;
1956 Stream[sno].stream_getc = PlUnGetc;
1957 Stream[sno].stream_wgetc = get_wchar;
1958 Stream[sno].stream_gets = DefaultGets;
1959 return och;
1960 }
1961 if (!how_many) {
1962 return wch;
1963 }
1964 }
1965 }
1966 break;
1967 case ENC_UNICODE_BE:
1968 if (how_many) {
1969 return wch+ch;
1970 }
1971 how_many=1;
1972 wch = ch << 8;
1973 break;
1974 case ENC_UNICODE_LE:
1975 if (how_many) {
1976 return wch+(ch<<8);
1977 }
1978 how_many=1;
1979 wch = ch;
1980 break;
1981 case ENC_ISO_UTF32_LE:
1982 if (!how_many) {
1983 how_many = 4;
1984 wch = 0;
1985 }
1986 how_many--;
1987 wch += ((unsigned char) (ch & 0xff)) << (how_many*8);
1988 if (how_many == 0)
1989 return wch;
1990 break;
1991 case ENC_ISO_UTF32_BE:
1992 if (!how_many) {
1993 how_many = 4;
1994 wch = 0;
1995 }
1996 how_many--;
1997 wch += ((unsigned char) (ch & 0xff)) << ((3-how_many)*8);
1998 if (how_many == 0)
1999 return wch;
2000 break;
2001 }
2002 }
2003 return EOF;
2004 }
2005
2006 #ifndef MB_LEN_MAX
2007 #define MB_LEN_MAX 6
2008 #endif
2009
2010 static int
handle_write_encoding_error(int sno,wchar_t ch)2011 handle_write_encoding_error(int sno, wchar_t ch)
2012 {
2013 if (Stream[sno].status & RepError_Xml_f) {
2014 /* use HTML/XML encoding in ASCII */
2015 int i = ch, digits = 1;
2016 Stream[sno].stream_putc(sno, '&');
2017 Stream[sno].stream_putc(sno, '#');
2018 while (digits < i)
2019 digits *= 10;
2020 if (digits > i)
2021 digits /= 10;
2022 while (i) {
2023 Stream[sno].stream_putc(sno, i/digits);
2024 i %= 10;
2025 digits /= 10;
2026 }
2027 Stream[sno].stream_putc(sno, ';');
2028 return ch;
2029 } else if (Stream[sno].status & RepError_Prolog_f) {
2030 /* write quoted */
2031 Stream[sno].stream_putc(sno, '\\');
2032 Stream[sno].stream_putc(sno, 'u');
2033 Stream[sno].stream_putc(sno, ch>>24);
2034 Stream[sno].stream_putc(sno, 256&(ch>>16));
2035 Stream[sno].stream_putc(sno, 256&(ch>>8));
2036 Stream[sno].stream_putc(sno, 256&ch);
2037 return ch;
2038 } else {
2039 Yap_Error(REPRESENTATION_ERROR_CHARACTER, MkIntegerTerm(ch),"charater %ld cannot be encoded in stream %d",(unsigned long int)ch,sno);
2040 return -1;
2041 }
2042 }
2043
2044 static int
put_wchar(int sno,wchar_t ch)2045 put_wchar(int sno, wchar_t ch)
2046 {
2047
2048 /* pass the bug if we can */
2049 switch (Stream[sno].encoding) {
2050 case ENC_OCTET:
2051 return Stream[sno].stream_putc(sno, ch);
2052 case ENC_ISO_LATIN1:
2053 if (ch >= 0xff) {
2054 return handle_write_encoding_error(sno,ch);
2055 }
2056 return Stream[sno].stream_putc(sno, ch);
2057 case ENC_ISO_ASCII:
2058 if (ch >= 0x80) {
2059 return handle_write_encoding_error(sno,ch);
2060 }
2061 return Stream[sno].stream_putc(sno, ch);
2062 case ENC_ISO_ANSI:
2063 {
2064 char buf[MB_LEN_MAX];
2065 int n;
2066
2067 memset((void *)&(Stream[sno].mbstate), 0, sizeof(mbstate_t));
2068 if ( (n = wcrtomb(buf, ch, &(Stream[sno].mbstate))) < 0 ) {
2069 /* error */
2070 Stream[sno].stream_putc(sno, ch);
2071 return -1;
2072 } else {
2073 int i;
2074
2075 for (i =0; i< n; i++) {
2076 Stream[sno].stream_putc(sno, buf[i]);
2077 }
2078 return ch;
2079 }
2080 case ENC_ISO_UTF8:
2081 if (ch < 0x80) {
2082 return Stream[sno].stream_putc(sno, ch);
2083 } else if (ch < 0x800) {
2084 Stream[sno].stream_putc(sno, 0xC0 | ch>>6);
2085 return Stream[sno].stream_putc(sno, 0x80 | (ch & 0x3F));
2086 }
2087 else if (ch < 0x10000) {
2088 Stream[sno].stream_putc(sno, 0xE0 | ch>>12);
2089 Stream[sno].stream_putc(sno, 0x80 | (ch>>6 & 0x3F));
2090 return Stream[sno].stream_putc(sno, 0x80 | (ch & 0x3F));
2091 } else if (ch < 0x200000) {
2092 Stream[sno].stream_putc(sno, 0xF0 | ch>>18);
2093 Stream[sno].stream_putc(sno, 0x80 | (ch>>12 & 0x3F));
2094 Stream[sno].stream_putc(sno, 0x80 | (ch>>6 & 0x3F));
2095 return Stream[sno].stream_putc(sno, 0x80 | (ch & 0x3F));
2096 } else {
2097 /* should never happen */
2098 return -1;
2099 }
2100 break;
2101 case ENC_UNICODE_BE:
2102 Stream[sno].stream_putc(sno, (ch>>8));
2103 return Stream[sno].stream_putc(sno, (ch&0xff));
2104 case ENC_UNICODE_LE:
2105 Stream[sno].stream_putc(sno, (ch&0xff));
2106 return Stream[sno].stream_putc(sno, (ch>>8));
2107 case ENC_ISO_UTF32_BE:
2108 Stream[sno].stream_putc(sno, (ch>>24) & 0xff);
2109 Stream[sno].stream_putc(sno, (ch>>16) &0xff);
2110 Stream[sno].stream_putc(sno, (ch>>8) & 0xff);
2111 return Stream[sno].stream_putc(sno, ch&0xff);
2112 case ENC_ISO_UTF32_LE:
2113 Stream[sno].stream_putc(sno, ch&0xff);
2114 Stream[sno].stream_putc(sno, (ch>>8) & 0xff);
2115 Stream[sno].stream_putc(sno, (ch>>16) &0xff);
2116 return Stream[sno].stream_putc(sno, (ch>>24) & 0xff);
2117 }
2118 }
2119 return -1;
2120 }
2121
2122 /* used by user-code to read characters from the current input stream */
2123 int
Yap_PlGetchar(void)2124 Yap_PlGetchar (void)
2125 {
2126 return(Stream[Yap_c_input_stream].stream_getc(Yap_c_input_stream));
2127 }
2128
2129 int
Yap_PlGetWchar(void)2130 Yap_PlGetWchar (void)
2131 {
2132 return get_wchar(Yap_c_input_stream);
2133 }
2134
2135 /* avoid using a variable to call a function */
2136 int
Yap_PlFGetchar(void)2137 Yap_PlFGetchar (void)
2138 {
2139 return(PlGetc(Yap_c_input_stream));
2140 }
2141
2142
2143 static Term
MkStream(int n)2144 MkStream (int n)
2145 {
2146 Term t[1];
2147 t[0] = MkIntTerm (n);
2148 return (Yap_MkApplTerm (FunctorStream, 1, t));
2149 }
2150
2151 static Int
p_stream_flags(void)2152 p_stream_flags (void)
2153 { /* '$stream_flags'(+N,-Flags) */
2154 Term trm;
2155 trm = Deref (ARG1);
2156 if (IsVarTerm (trm) || !IsIntTerm (trm))
2157 return (FALSE);
2158 return (Yap_unify_constant (ARG2, MkIntTerm (Stream[IntOfTerm (trm)].status)));
2159 }
2160
2161 static int
find_csult_file(char * source,char * buf,StreamDesc * st,char * io_mode)2162 find_csult_file (char *source, char *buf, StreamDesc * st, char *io_mode)
2163 {
2164
2165 char *cp = source, ch;
2166 while (*cp++);
2167 while ((ch = *--cp) != '.' && !Yap_dir_separator((int)ch) && cp != source);
2168 if (ch == '.')
2169 return (FALSE);
2170 strncpy (buf, source, YAP_FILENAME_MAX);
2171 strncat (buf, ".yap", YAP_FILENAME_MAX);
2172 if ((st->u.file.file = YP_fopen (buf, io_mode)) != YAP_ERROR)
2173 return (TRUE);
2174 strncpy (buf, source, YAP_FILENAME_MAX);
2175 strncat (buf, ".pl", YAP_FILENAME_MAX);
2176 if ((st->u.file.file = YP_fopen (buf, io_mode)) != YAP_ERROR)
2177 return (TRUE);
2178 return (FALSE);
2179 }
2180
2181 /* given a stream index, get the corresponding fd */
2182 static Int
GetStreamFd(int sno)2183 GetStreamFd(int sno)
2184 {
2185 #if USE_SOCKET
2186 if (Stream[sno].status & Socket_Stream_f) {
2187 return(Stream[sno].u.socket.fd);
2188 } else
2189 #endif
2190 if (Stream[sno].status & Pipe_Stream_f) {
2191 #if _MSC_VER || defined(__MINGW32__)
2192 return((Int)(Stream[sno].u.pipe.hdl));
2193 #else
2194 return(Stream[sno].u.pipe.fd);
2195 #endif
2196 } else if (Stream[sno].status & InMemory_Stream_f) {
2197 return(-1);
2198 }
2199 return(YP_fileno(Stream[sno].u.file.file));
2200 }
2201
2202 Int
Yap_GetStreamFd(int sno)2203 Yap_GetStreamFd(int sno)
2204 {
2205 return GetStreamFd(sno);
2206 }
2207
2208 /* given a socket file descriptor, get the corresponding stream descripor */
2209 int
Yap_CheckIOStream(Term stream,char * error)2210 Yap_CheckIOStream(Term stream, char * error)
2211 {
2212 int sno = CheckStream(stream, Input_Stream_f|Output_Stream_f|Socket_Stream_f, error);
2213 UNLOCK(Stream[sno].streamlock);
2214 return(sno);
2215 }
2216
2217 #if USE_SOCKET
2218
2219 Term
Yap_InitSocketStream(int fd,socket_info flags,socket_domain domain)2220 Yap_InitSocketStream(int fd, socket_info flags, socket_domain domain) {
2221 StreamDesc *st;
2222 int sno;
2223
2224 sno = GetFreeStreamD();
2225 if (sno < 0) {
2226 PlIOError (SYSTEM_ERROR,TermNil, "new stream not available for socket/4");
2227 return(TermNil);
2228 }
2229 st = &Stream[sno];
2230 st->u.socket.domain = domain;
2231 st->u.socket.flags = flags;
2232 if (flags & (client_socket|server_session_socket)) {
2233 /* I can read and write from these sockets */
2234 st->status = (Socket_Stream_f|Input_Stream_f|Output_Stream_f);
2235 } else {
2236 /* oops, I cannot */
2237 st->status = Socket_Stream_f;
2238 }
2239 st->u.socket.fd = fd;
2240 st->charcount = 0;
2241 st->linecount = 1;
2242 st->linepos = 0;
2243 st->stream_putc = SocketPutc;
2244 st->stream_wputc = put_wchar;
2245 st->stream_getc = SocketGetc;
2246 st->stream_gets = DefaultGets;
2247 st->stream_wgetc = get_wchar;
2248 if (CharConversionTable != NULL)
2249 st->stream_wgetc_for_read = ISOWGetc;
2250 else
2251 st->stream_wgetc_for_read = st->stream_wgetc;
2252 UNLOCK(st->streamlock);
2253 return(MkStream(sno));
2254 }
2255
2256 /* given a socket file descriptor, get the corresponding stream descripor */
2257 int
Yap_CheckSocketStream(Term stream,char * error)2258 Yap_CheckSocketStream(Term stream, char * error)
2259 {
2260 int sno = CheckStream(stream, Socket_Stream_f, error);
2261 UNLOCK(Stream[sno].streamlock);
2262 return sno;
2263 }
2264
2265 /* given a stream index, get the corresponding domain */
2266 socket_domain
Yap_GetSocketDomain(int sno)2267 Yap_GetSocketDomain(int sno)
2268 {
2269 return(Stream[sno].u.socket.domain);
2270 }
2271
2272 /* given a stream index, get the corresponding status */
2273 socket_info
Yap_GetSocketStatus(int sno)2274 Yap_GetSocketStatus(int sno)
2275 {
2276 return(Stream[sno].u.socket.flags);
2277 }
2278
2279 /* update info on a socket, eg, new->server or new->client */
2280 void
Yap_UpdateSocketStream(int sno,socket_info flags,socket_domain domain)2281 Yap_UpdateSocketStream(int sno, socket_info flags, socket_domain domain) {
2282 StreamDesc *st;
2283
2284 st = &Stream[sno];
2285 st->u.socket.domain = domain;
2286 st->u.socket.flags = flags;
2287 if (flags & (client_socket|server_session_socket)) {
2288 /* I can read and write from these sockets */
2289 st->status = (Socket_Stream_f|Input_Stream_f|Output_Stream_f);
2290 } else {
2291 /* oops, I cannot */
2292 st->status = Socket_Stream_f;
2293 }
2294 }
2295
2296 #endif /* USE_SOCKET */
2297
2298 static int
binary_file(char * file_name)2299 binary_file(char *file_name)
2300 {
2301 #if HAVE_STAT
2302 #if _MSC_VER || defined(__MINGW32__)
2303 struct _stat ss;
2304 if (_stat(file_name, &ss) != 0) {
2305 #else
2306 struct stat ss;
2307 if (stat(file_name, &ss) != 0) {
2308 #endif
2309 /* ignore errors while checking a file */
2310 return(FALSE);
2311 }
2312 return (S_ISDIR(ss.st_mode));
2313 #else
2314 return(FALSE);
2315 #endif
2316 }
2317
2318 static int
2319 write_bom(int sno, StreamDesc *st)
2320 {
2321 /* dump encoding */
2322 switch (st->encoding) {
2323 case ENC_ISO_UTF8:
2324 if (st->stream_putc(sno,0xEF)<0)
2325 return FALSE;
2326 if (st->stream_putc(sno,0xBB)<0)
2327 return FALSE;
2328 if (st->stream_putc(sno,0xBF)<0)
2329 return FALSE;
2330 st->status |= HAS_BOM_f;
2331 return TRUE;
2332 case ENC_UNICODE_BE:
2333 if (st->stream_putc(sno,0xFE)<0)
2334 return FALSE;
2335 if (st->stream_putc(sno,0xFF)<0)
2336 return FALSE;
2337 st->status |= HAS_BOM_f;
2338 return TRUE;
2339 case ENC_UNICODE_LE:
2340 if (st->stream_putc(sno,0xFF)<0)
2341 return FALSE;
2342 if (st->stream_putc(sno,0xFE)<0)
2343 return FALSE;
2344 case ENC_ISO_UTF32_BE:
2345 if (st->stream_putc(sno,0x00)<0)
2346 return FALSE;
2347 if (st->stream_putc(sno,0x00)<0)
2348 return FALSE;
2349 if (st->stream_putc(sno,0xFE)<0)
2350 return FALSE;
2351 if (st->stream_putc(sno,0xFF)<0)
2352 return FALSE;
2353 case ENC_ISO_UTF32_LE:
2354 if (st->stream_putc(sno,0xFF)<0)
2355 return FALSE;
2356 if (st->stream_putc(sno,0xFE)<0)
2357 return FALSE;
2358 if (st->stream_putc(sno,0x00)<0)
2359 return FALSE;
2360 if (st->stream_putc(sno,0x00)<0)
2361 return FALSE;
2362 default:
2363 return TRUE;
2364 }
2365 }
2366
2367
2368 static int
2369 check_bom(int sno, StreamDesc *st)
2370 {
2371
2372 int ch;
2373
2374 ch = st->stream_getc(sno);
2375 if (ch == EOFCHAR) {
2376 st->och = ch;
2377 st->stream_getc = PlUnGetc;
2378 st->stream_wgetc = get_wchar;
2379 st->stream_gets = DefaultGets;
2380 return TRUE;
2381 }
2382 switch(ch) {
2383 case 0x00:
2384 {
2385 ch = st->stream_getc(sno);
2386 if (ch == EOFCHAR || ch != 0x00) {
2387 st->och = ch;
2388 st->stream_getc = PlUnGetc00;
2389 st->stream_wgetc = get_wchar;
2390 st->stream_gets = DefaultGets;
2391 return TRUE;
2392 } else {
2393 ch = st->stream_getc(sno);
2394 if (ch == EOFCHAR || ch != 0xFE) {
2395 st->och = ch;
2396 st->stream_getc = PlUnGetc0000;
2397 st->stream_wgetc = get_wchar;
2398 st->stream_gets = DefaultGets;
2399 return TRUE;
2400 } else {
2401 ch = st->stream_getc(sno);
2402 if (ch == EOFCHAR || ch != 0xFF) {
2403 st->och = ch;
2404 st->stream_getc = PlUnGetc0000fe;
2405 st->stream_wgetc = get_wchar;
2406 st->stream_gets = DefaultGets;
2407 return TRUE;
2408 } else {
2409 st->status |= HAS_BOM_f;
2410 st->encoding = ENC_ISO_UTF32_BE;
2411 return TRUE;
2412 }
2413 }
2414 }
2415 }
2416 case 0xFE:
2417 {
2418 ch = st->stream_getc(sno);
2419 if (ch != 0xFF) {
2420 st->och = ch;
2421 st->stream_getc = PlUnGetc376;
2422 st->stream_wgetc = get_wchar;
2423 st->stream_gets = DefaultGets;
2424 return TRUE;
2425 } else {
2426 st->status |= HAS_BOM_f;
2427 st->encoding = ENC_UNICODE_BE;
2428 return TRUE;
2429 }
2430 }
2431 case 0xFF:
2432 {
2433 ch = st->stream_getc(sno);
2434 if (ch != 0xFE) {
2435 st->och = ch;
2436 st->stream_getc = PlUnGetc377;
2437 st->stream_wgetc = get_wchar;
2438 st->stream_gets = DefaultGets;
2439 return TRUE;
2440 } else {
2441 ch = st->stream_getc(sno);
2442 if (ch == EOFCHAR || ch != 0x00) {
2443 st->och = ch;
2444 st->stream_getc = PlUnGetc377376;
2445 st->stream_wgetc = get_wchar;
2446 st->stream_gets = DefaultGets;
2447 } else {
2448 ch = st->stream_getc(sno);
2449 if (ch == EOFCHAR || ch != 0x00) {
2450 st->och = ch;
2451 st->stream_getc = PlUnGetc37737600;
2452 st->stream_wgetc = get_wchar;
2453 st->stream_gets = DefaultGets;
2454 } else {
2455 st->status |= HAS_BOM_f;
2456 st->encoding = ENC_ISO_UTF32_LE;
2457 return TRUE;
2458 }
2459 }
2460 st->status |= HAS_BOM_f;
2461 st->encoding = ENC_UNICODE_LE;
2462 return TRUE;
2463 }
2464 }
2465 case 0xEF:
2466 ch = st->stream_getc(sno);
2467 if (ch != 0xBB) {
2468 st->och = ch;
2469 st->stream_getc = PlUnGetc357;
2470 st->stream_wgetc = get_wchar;
2471 st->stream_gets = DefaultGets;
2472 return TRUE;
2473 } else {
2474 ch = st->stream_getc(sno);
2475 if (ch != 0xBF) {
2476 st->och = ch;
2477 st->stream_getc = PlUnGetc357273;
2478 st->stream_wgetc = get_wchar;
2479 st->stream_gets = DefaultGets;
2480 return TRUE;
2481 } else {
2482 st->status |= HAS_BOM_f;
2483 st->encoding = ENC_ISO_UTF8;
2484 return TRUE;
2485 }
2486 }
2487 default:
2488 st->och = ch;
2489 st->stream_getc = PlUnGetc;
2490 st->stream_wgetc = get_wchar;
2491 st->stream_gets = DefaultGets;
2492 return TRUE;
2493 }
2494 }
2495
2496 #if _MSC_VER || defined(__MINGW32__)
2497 #define SYSTEM_STAT _stat
2498 #else
2499 #define SYSTEM_STAT stat
2500 #endif
2501
2502 static Int
2503 p_access(void)
2504 {
2505 Term tname = Deref(ARG1);
2506 char *file_name;
2507
2508 if (IsVarTerm(tname)) {
2509 Yap_Error(INSTANTIATION_ERROR, tname, "access");
2510 return FALSE;
2511 } else if (!IsAtomTerm (tname)) {
2512 Yap_Error(TYPE_ERROR_ATOM, tname, "access");
2513 return FALSE;
2514 } else {
2515 #if HAVE_STAT
2516 struct SYSTEM_STAT ss;
2517
2518 file_name = RepAtom(AtomOfTerm(tname))->StrOfAE;
2519 if (SYSTEM_STAT(file_name, &ss) != 0) {
2520 /* ignore errors while checking a file */
2521 return FALSE;
2522 }
2523 return TRUE;
2524 #else
2525 return FALSE;
2526 #endif
2527 }
2528 }
2529
2530 static Int
2531 p_access2(void)
2532 {
2533 Term tname = Deref(ARG1);
2534 Term tmode = Deref(ARG2);
2535 char ares[YAP_FILENAME_MAX];
2536 Atom atmode;
2537
2538 if (IsVarTerm(tmode)) {
2539 Yap_Error(INSTANTIATION_ERROR, tmode, "access");
2540 return FALSE;
2541 } else if (!IsAtomTerm (tmode)) {
2542 Yap_Error(TYPE_ERROR_ATOM, tname, "access");
2543 return FALSE;
2544 }
2545 atmode = AtomOfTerm(tmode);
2546 if (IsVarTerm(tname)) {
2547 Yap_Error(INSTANTIATION_ERROR, tname, "access");
2548 return FALSE;
2549 } else if (!IsAtomTerm (tname)) {
2550 Yap_Error(TYPE_ERROR_ATOM, tname, "access");
2551 return FALSE;
2552 } else {
2553 if (atmode == AtomNone)
2554 return TRUE;
2555 if (!Yap_TrueFileName (RepAtom(AtomOfTerm(tname))->StrOfAE, ares, (atmode == AtomCsult)))
2556 return FALSE;
2557 }
2558 #if HAVE_ACCESS
2559 {
2560 int mode;
2561
2562 if (atmode == AtomExist)
2563 mode = F_OK;
2564 else if (atmode == AtomWrite)
2565 mode = W_OK;
2566 else if (atmode == AtomRead)
2567 mode = R_OK;
2568 else if (atmode == AtomAppend)
2569 mode = W_OK;
2570 else if (atmode == AtomCsult)
2571 mode = R_OK;
2572 else if (atmode == AtomExecute)
2573 mode = X_OK;
2574 else {
2575 Yap_Error(DOMAIN_ERROR_IO_MODE, tmode, "access_file/2");
2576 return FALSE;
2577 }
2578 if (access(ares, mode) != 0) {
2579 /* ignore errors while checking a file */
2580 return FALSE;
2581 }
2582 return TRUE;
2583 }
2584 #elif HAVE_STAT
2585 {
2586 struct SYSTEM_STAT ss;
2587
2588 if (SYSTEM_STAT(ares, &ss) != 0) {
2589 /* ignore errors while checking a file */
2590 return FALSE;
2591 }
2592 return TRUE;
2593 }
2594 #else
2595 return FALSE;
2596 #endif
2597 }
2598
2599 static Int
2600 p_exists_directory(void)
2601 {
2602 Term tname = Deref(ARG1);
2603 char *file_name;
2604
2605 if (IsVarTerm(tname)) {
2606 Yap_Error(INSTANTIATION_ERROR, tname, "exists_directory/1");
2607 return FALSE;
2608 } else if (!IsAtomTerm (tname)) {
2609 Yap_Error(TYPE_ERROR_ATOM, tname, "exists_directory/1");
2610 return FALSE;
2611 } else {
2612 #if HAVE_STAT
2613 struct SYSTEM_STAT ss;
2614
2615 file_name = RepAtom(AtomOfTerm(tname))->StrOfAE;
2616 if (SYSTEM_STAT(file_name, &ss) != 0) {
2617 /* ignore errors while checking a file */
2618 return FALSE;
2619 }
2620 return (S_ISDIR(ss.st_mode));
2621 #else
2622 return FALSE;
2623 #endif
2624 }
2625 }
2626
2627 static Int
2628 p_open (void)
2629 { /* '$open'(+File,+Mode,?Stream,-ReturnCode) */
2630 Term file_name, t, t2, topts, tenc;
2631 Atom open_mode;
2632 int sno;
2633 SMALLUNSGN s;
2634 char io_mode[8];
2635 StreamDesc *st;
2636 Int opts;
2637 UInt encoding;
2638 int needs_bom = FALSE, avoid_bom = FALSE;
2639
2640 file_name = Deref(ARG1);
2641 /* we know file_name is bound */
2642 if (!IsAtomTerm (file_name)) {
2643 Yap_Error(DOMAIN_ERROR_SOURCE_SINK,file_name, "open/3");
2644 return(FALSE);
2645 }
2646 t2 = Deref (ARG2);
2647 if (!IsAtomTerm (t2)) {
2648 Yap_Error(TYPE_ERROR_ATOM,t2, "open/3");
2649 return(FALSE);
2650 }
2651 open_mode = AtomOfTerm (t2);
2652 if (open_mode == AtomRead || open_mode == AtomCsult) {
2653 if (open_mode == AtomCsult && AtomOfTerm(file_name) == AtomUserIn) {
2654 return(Yap_unify(MkStream(FileAliases[0].alias_stream), ARG3));
2655 }
2656 strncpy(io_mode,"rb", 8);
2657 s = Input_Stream_f;
2658 } else if (open_mode == AtomWrite) {
2659 strncpy(io_mode,"w",8);
2660 s = Output_Stream_f;
2661 } else if (open_mode == AtomAppend) {
2662 strncpy(io_mode,"a",8);
2663 s = Append_Stream_f | Output_Stream_f;
2664 } else {
2665 Yap_Error(DOMAIN_ERROR_IO_MODE, t2, "open/3");
2666 return(FALSE);
2667 }
2668 /* can never happen */
2669 topts = Deref(ARG4);
2670 if (IsVarTerm(topts) || !IsIntegerTerm(topts))
2671 return(FALSE);
2672 opts = IntegerOfTerm(topts);
2673 if (!strncpy(Yap_FileNameBuf, RepAtom (AtomOfTerm (file_name))->StrOfAE, YAP_FILENAME_MAX))
2674 return (PlIOError (SYSTEM_ERROR,file_name,"file name is too long in open/3"));
2675 sno = GetFreeStreamD();
2676 if (sno < 0)
2677 return (PlIOError (RESOURCE_ERROR_MAX_STREAMS,TermNil, "open/3"));
2678 st = &Stream[sno];
2679 /* can never happen */
2680 tenc = Deref(ARG5);
2681 if (IsVarTerm(tenc) || !IsIntegerTerm(tenc)) {
2682 UNLOCK(st->streamlock);
2683 return FALSE;
2684 }
2685 encoding = IntegerOfTerm(tenc);
2686 #ifdef _WIN32
2687 if (opts & 2) {
2688 strncat(io_mode, "b", 8);
2689 } else {
2690 strncat(io_mode, "t", 8);
2691 }
2692 #endif
2693 if ((st->u.file.file = YP_fopen (Yap_FileNameBuf, io_mode)) == YAP_ERROR ||
2694 (!(opts & 2 /* binary */) && binary_file(Yap_FileNameBuf)))
2695 {
2696 UNLOCK(st->streamlock);
2697 if (open_mode == AtomCsult)
2698 {
2699 if (!find_csult_file (Yap_FileNameBuf, Yap_FileNameBuf2, st, io_mode))
2700 return (PlIOError (EXISTENCE_ERROR_SOURCE_SINK, ARG6, "open/3"));
2701 strncpy (Yap_FileNameBuf, Yap_FileNameBuf2, YAP_FILENAME_MAX);
2702 }
2703 else {
2704 if (errno == ENOENT)
2705 return (PlIOError(EXISTENCE_ERROR_SOURCE_SINK,ARG6,"open/3"));
2706 else
2707 return (PlIOError(PERMISSION_ERROR_OPEN_SOURCE_SINK,file_name,"open/3"));
2708 }
2709 }
2710 #if MAC
2711 if (open_mode == AtomWrite)
2712 {
2713 Yap_SetTextFile (RepAtom (AtomOfTerm (file_name))->StrOfAE);
2714 }
2715 #endif
2716 st->status = s;
2717 st->charcount = 0;
2718 st->linecount = 1;
2719 st->linepos = 0;
2720 st->u.file.name = Yap_LookupAtom (Yap_FileNameBuf);
2721 if (IsAtomTerm(Deref(ARG6)))
2722 st->u.file.user_name = Deref(ARG6);
2723 else
2724 st->u.file.user_name = file_name;
2725 st->stream_putc = FilePutc;
2726 st->stream_wputc = put_wchar;
2727 st->stream_getc = PlGetc;
2728 st->stream_gets = PlGetsFunc();
2729 if (st->status & Binary_Stream_f) {
2730 st->encoding = ENC_OCTET;
2731 } else {
2732 st->encoding = encoding;
2733 }
2734 unix_upd_stream_info (st);
2735 if (opts != 0) {
2736 if (opts & 2) {
2737 st->status |= Binary_Stream_f;
2738 /* we should not search for a byter order mark on a binary file */
2739 avoid_bom = TRUE;
2740 }
2741 if (opts & 4) {
2742 if (st->status & (Tty_Stream_f|Socket_Stream_f|InMemory_Stream_f)) {
2743 Term ta[1], t;
2744
2745 #if USE_SOCKET
2746 if (st->status & Socket_Stream_f) {
2747 st->stream_putc = SocketPutc;
2748 st->stream_wputc = put_wchar;
2749 st->stream_getc = SocketGetc;
2750 st->stream_gets = DefaultGets;
2751 } else
2752 #endif
2753 if (st->status & Pipe_Stream_f) {
2754 st->stream_putc = PipePutc;
2755 st->stream_wputc = put_wchar;
2756 st->stream_getc = PipeGetc;
2757 st->stream_gets = DefaultGets;
2758 } else if (st->status & InMemory_Stream_f) {
2759 st->stream_putc = MemPutc;
2760 st->stream_wputc = put_wchar;
2761 st->stream_getc = MemGetc;
2762 st->stream_gets = DefaultGets;
2763 } else {
2764 st->stream_putc = ConsolePutc;
2765 st->stream_wputc = put_wchar;
2766 st->stream_getc = PlGetc;
2767 st->stream_gets = PlGetsFunc();
2768 }
2769 UNLOCK(st->streamlock);
2770 ta[1] = MkAtomTerm(AtomTrue);
2771 t = Yap_MkApplTerm(Yap_MkFunctor(AtomReposition,1),1,ta);
2772 Yap_Error(PERMISSION_ERROR_OPEN_SOURCE_SINK,t,"open/4");
2773 return FALSE;
2774 }
2775 /* useless crap */
2776 st->status |= Seekable_Stream_f;
2777 }
2778 if (opts & 8) {
2779 /* There may be one reason why one wouldn't want to seek in a
2780 file, maybe .... */
2781 st->status &= ~Seekable_Stream_f;
2782 }
2783 if (opts & 16) {
2784 st->status &= ~Reset_Eof_Stream_f;
2785 st->status |= Eof_Error_Stream_f;
2786 }
2787 if (opts & 32) {
2788 st->status &= ~Reset_Eof_Stream_f;
2789 st->status &= ~Eof_Error_Stream_f;
2790 }
2791 if (opts & 64) {
2792 st->status &= ~Eof_Error_Stream_f;
2793 st->status |= Reset_Eof_Stream_f;
2794 }
2795 if (opts & 128) {
2796 needs_bom = TRUE;
2797 }
2798 if (opts & 256) {
2799 avoid_bom = TRUE;
2800 }
2801 if (opts & 512) {
2802 st->status |= RepError_Prolog_f;
2803 }
2804 if (opts & 1024) {
2805 st->status |= RepError_Xml_f;
2806 }
2807 }
2808 st->stream_wgetc = get_wchar;
2809 if (CharConversionTable != NULL)
2810 st->stream_wgetc_for_read = ISOWGetc;
2811 else
2812 st->stream_wgetc_for_read = st->stream_wgetc;
2813 UNLOCK(st->streamlock);
2814 t = MkStream (sno);
2815 if (open_mode == AtomWrite ) {
2816 if (needs_bom && !write_bom(sno,st))
2817 return FALSE;
2818 } else if ((open_mode == AtomRead || open_mode == AtomCsult) &&
2819 !avoid_bom &&
2820 (needs_bom || (st->status & Seekable_Stream_f))) {
2821 if (!check_bom(sno, st))
2822 return FALSE;
2823 if (st->encoding == ENC_ISO_UTF32_BE) {
2824 Yap_Error(DOMAIN_ERROR_STREAM_ENCODING, ARG1, "UTF-32 (BE) stream encoding unsupported");
2825 return FALSE;
2826 } else if (st->encoding == ENC_ISO_UTF32_LE) {
2827 Yap_Error(DOMAIN_ERROR_STREAM_ENCODING, ARG1, "UTF-32 (LE) stream encoding unsupported");
2828 return FALSE;
2829 }
2830 }
2831 st->status &= ~(Free_Stream_f);
2832 return (Yap_unify (ARG3, t));
2833 }
2834
2835
2836 static Int
2837 p_file_expansion (void)
2838 { /* '$file_expansion'(+File,-Name) */
2839 Term file_name = Deref(ARG1);
2840
2841 /* we know file_name is bound */
2842 if (!IsAtomTerm (file_name)) {
2843 PlIOError(TYPE_ERROR_ATOM, file_name, "absolute_file_name/3");
2844 return(FALSE);
2845 }
2846 if (!Yap_TrueFileName (RepAtom (AtomOfTerm (file_name))->StrOfAE, Yap_FileNameBuf, FALSE))
2847 return (PlIOError (EXISTENCE_ERROR_SOURCE_SINK,file_name,"absolute_file_name/3"));
2848 return(Yap_unify(ARG2,MkAtomTerm(Yap_LookupAtom(Yap_FileNameBuf))));
2849 }
2850
2851
2852 static Int p_add_alias_to_stream (void)
2853 {
2854 Term tname = Deref(ARG1);
2855 Term tstream = Deref(ARG2);
2856 Atom at;
2857 Int sno;
2858
2859 if (IsVarTerm(tname)) {
2860 Yap_Error(INSTANTIATION_ERROR, tname, "$add_alias_to_stream");
2861 return (FALSE);
2862 } else if (!IsAtomTerm (tname)) {
2863 Yap_Error(TYPE_ERROR_ATOM, tname, "$add_alias_to_stream");
2864 return (FALSE);
2865 }
2866 if (IsVarTerm(tstream)) {
2867 Yap_Error(INSTANTIATION_ERROR, tstream, "$add_alias_to_stream");
2868 return (FALSE);
2869 } else if (!IsApplTerm (tstream) || FunctorOfTerm (tstream) != FunctorStream ||
2870 !IsIntTerm(ArgOfTerm(1,tstream))) {
2871 Yap_Error(DOMAIN_ERROR_STREAM_OR_ALIAS, tstream, "$add_alias_to_stream");
2872 return (FALSE);
2873 }
2874 at = AtomOfTerm(tname);
2875 sno = (int)IntOfTerm(ArgOfTerm(1,tstream));
2876 if (AddAlias(at, sno))
2877 return(TRUE);
2878 /* we could not create the alias, time to close the stream */
2879 CloseStream(sno);
2880 Yap_Error(PERMISSION_ERROR_NEW_ALIAS_FOR_STREAM, tname, "open/3");
2881 return (FALSE);
2882 }
2883
2884 static Int p_change_alias_to_stream (void)
2885 {
2886 Term tname = Deref(ARG1);
2887 Term tstream = Deref(ARG2);
2888 Atom at;
2889 Int sno;
2890
2891 if (IsVarTerm(tname)) {
2892 Yap_Error(INSTANTIATION_ERROR, tname, "$change_alias_to_stream/2");
2893 return (FALSE);
2894 } else if (!IsAtomTerm (tname)) {
2895 Yap_Error(TYPE_ERROR_ATOM, tname, "$change_alias_to_stream/2");
2896 return (FALSE);
2897 }
2898 at = AtomOfTerm(tname);
2899 if ((sno = CheckStream (tstream, Input_Stream_f | Output_Stream_f | Append_Stream_f | Socket_Stream_f, "change_stream_alias/2")) == -1) {
2900 UNLOCK(Stream[sno].streamlock);
2901 return(FALSE);
2902 }
2903 SetAlias(at, sno);
2904 UNLOCK(Stream[sno].streamlock);
2905 return(TRUE);
2906 }
2907
2908 static Int p_check_if_valid_new_alias (void)
2909 {
2910 Term tname = Deref(ARG1);
2911 Atom at;
2912
2913 if (IsVarTerm(tname)) {
2914 Yap_Error(INSTANTIATION_ERROR, tname, "$add_alias_to_stream");
2915 return (FALSE);
2916 } else if (!IsAtomTerm (tname)) {
2917 Yap_Error(TYPE_ERROR_ATOM, tname, "$add_alias_to_stream");
2918 return (FALSE);
2919 }
2920 at = AtomOfTerm(tname);
2921 return(CheckAlias(at) == -1);
2922 }
2923
2924
2925 static Int
2926 p_fetch_stream_alias (void)
2927 { /* '$fetch_stream_alias'(Stream,Alias) */
2928 int sno;
2929 Term t2 = Deref(ARG2);
2930 Term t1 = Deref(ARG1);
2931
2932 if (IsVarTerm(t1)) {
2933 return Yap_unify(ARG1,MkStream(FindStreamForAlias(AtomOfTerm(t2))));
2934 }
2935 if ((sno = CheckStream (t1, Input_Stream_f | Output_Stream_f,
2936 "fetch_stream_alias/2")) == -1)
2937 return FALSE;
2938 if (IsVarTerm(t2)) {
2939 Atom at = FetchAlias(sno);
2940 UNLOCK(Stream[sno].streamlock);
2941 if (at == AtomFoundVar)
2942 return FALSE;
2943 else
2944 return Yap_unify_constant(t2, MkAtomTerm(at));
2945 } else if (IsAtomTerm(t2)) {
2946 Atom at = AtomOfTerm(t2);
2947 Int out = (Int)FindAliasForStream(sno,at);
2948 UNLOCK(Stream[sno].streamlock);
2949 return out;
2950 } else {
2951 UNLOCK(Stream[sno].streamlock);
2952 Yap_Error(TYPE_ERROR_ATOM, t2, "fetch_stream_alias/2");
2953 return FALSE;
2954 }
2955 }
2956
2957 static Int
2958 p_open_null_stream (void)
2959 {
2960 Term t;
2961 StreamDesc *st;
2962 int sno = GetFreeStreamD();
2963 if (sno < 0)
2964 return (PlIOError (SYSTEM_ERROR,TermNil, "new stream not available for open_null_stream/1"));
2965 st = &Stream[sno];
2966 st->status = Append_Stream_f | Output_Stream_f | Null_Stream_f;
2967 st->linepos = 0;
2968 st->charcount = 0;
2969 st->linecount = 1;
2970 st->stream_putc = NullPutc;
2971 st->stream_wputc = put_wchar;
2972 st->stream_getc = PlGetc;
2973 st->stream_gets = PlGetsFunc();
2974 st->stream_wgetc = get_wchar;
2975 st->stream_wgetc_for_read = get_wchar;
2976 st->u.file.user_name = MkAtomTerm (st->u.file.name = AtomDevNull);
2977 UNLOCK(st->streamlock);
2978 t = MkStream (sno);
2979 return (Yap_unify (ARG1, t));
2980 }
2981
2982 Term
2983 Yap_OpenStream(FILE *fd, char *name, Term file_name, int flags)
2984 {
2985 Term t;
2986 StreamDesc *st;
2987 int sno;
2988
2989 sno = GetFreeStreamD();
2990 if (sno < 0)
2991 return (PlIOError (RESOURCE_ERROR_MAX_STREAMS,TermNil, "new stream not available for open_null_stream/1"));
2992 st = &Stream[sno];
2993 st->status = 0;
2994 if (flags & YAP_INPUT_STREAM)
2995 st->status |= Input_Stream_f;
2996 if (flags & YAP_OUTPUT_STREAM)
2997 st->status |= Output_Stream_f;
2998 if (flags & YAP_APPEND_STREAM)
2999 st->status |= Append_Stream_f;
3000 /*
3001 pipes assume an integer file descriptor, not a FILE *:
3002 if (flags & YAP_PIPE_STREAM)
3003 st->status |= Pipe_Stream_f;
3004 */
3005 if (flags & YAP_TTY_STREAM)
3006 st->status |= Tty_Stream_f;
3007 if (flags & YAP_POPEN_STREAM)
3008 st->status |= Popen_Stream_f;
3009 if (flags & YAP_BINARY_STREAM)
3010 st->status |= Binary_Stream_f;
3011 if (flags & YAP_SEEKABLE_STREAM)
3012 st->status |= Seekable_Stream_f;
3013 st->charcount = 0;
3014 st->linecount = 1;
3015 st->u.file.name = Yap_LookupAtom(name);
3016 st->u.file.user_name = file_name;
3017 st->u.file.file = fd;
3018 st->linepos = 0;
3019 st->stream_gets = PlGetsFunc();
3020 if (flags & YAP_PIPE_STREAM) {
3021 st->stream_putc = PipePutc;
3022 st->stream_wputc = put_wchar;
3023 st->stream_getc = PipeGetc;
3024 } else if (flags & YAP_TTY_STREAM) {
3025 st->stream_putc = ConsolePutc;
3026 st->stream_wputc = put_wchar;
3027 st->stream_getc = ConsoleGetc;
3028 } else {
3029 st->stream_putc = FilePutc;
3030 st->stream_wputc = put_wchar;
3031 st->stream_getc = PlGetc;
3032 unix_upd_stream_info (st);
3033 }
3034 st->stream_wgetc = get_wchar;
3035 if (CharConversionTable != NULL)
3036 st->stream_wgetc_for_read = ISOWGetc;
3037 else
3038 st->stream_wgetc_for_read = st->stream_wgetc;
3039 UNLOCK(st->streamlock);
3040 t = MkStream (sno);
3041 return t;
3042 }
3043
3044 static Int
3045 p_open_pipe_stream (void)
3046 {
3047 Term t1, t2;
3048 StreamDesc *st;
3049 int sno;
3050 #if _MSC_VER || defined(__MINGW32__)
3051 HANDLE ReadPipe, WritePipe;
3052 SECURITY_ATTRIBUTES satt;
3053
3054 satt.nLength = sizeof(satt);
3055 satt.lpSecurityDescriptor = NULL;
3056 satt.bInheritHandle = TRUE;
3057 if (!CreatePipe(&ReadPipe, &WritePipe, &satt, 0))
3058 {
3059 return (PlIOError (SYSTEM_ERROR,TermNil, "open_pipe_stream/2 could not create pipe"));
3060 }
3061 #else
3062 int filedes[2];
3063
3064 if (pipe(filedes) != 0)
3065 {
3066 return (PlIOError (SYSTEM_ERROR,TermNil, "open_pipe_stream/2 could not create pipe"));
3067 }
3068 #endif
3069 sno = GetFreeStreamD();
3070 if (sno < 0)
3071 return (PlIOError (RESOURCE_ERROR_MAX_STREAMS,TermNil, "new stream not available for open_pipe_stream/2"));
3072 t1 = MkStream (sno);
3073 st = &Stream[sno];
3074 st->status = Input_Stream_f | Pipe_Stream_f;
3075 st->linepos = 0;
3076 st->charcount = 0;
3077 st->linecount = 1;
3078 st->stream_putc = PipePutc;
3079 st->stream_wputc = put_wchar;
3080 st->stream_getc = PipeGetc;
3081 st->stream_gets = DefaultGets;
3082 st->stream_wgetc = get_wchar;
3083 if (CharConversionTable != NULL)
3084 st->stream_wgetc_for_read = ISOWGetc;
3085 else
3086 st->stream_wgetc_for_read = st->stream_wgetc;
3087 #if _MSC_VER || defined(__MINGW32__)
3088 st->u.pipe.hdl = ReadPipe;
3089 #else
3090 st->u.pipe.fd = filedes[0];
3091 #endif
3092 UNLOCK(st->streamlock);
3093 sno = GetFreeStreamD();
3094 if (sno < 0)
3095 return (PlIOError (RESOURCE_ERROR_MAX_STREAMS,TermNil, "new stream not available for open_pipe_stream/2"));
3096 st = &Stream[sno];
3097 st->status = Output_Stream_f | Pipe_Stream_f;
3098 st->linepos = 0;
3099 st->charcount = 0;
3100 st->linecount = 1;
3101 st->stream_putc = PipePutc;
3102 st->stream_wputc = put_wchar;
3103 st->stream_getc = PipeGetc;
3104 st->stream_gets = DefaultGets;
3105 st->stream_wgetc = get_wchar;
3106 if (CharConversionTable != NULL)
3107 st->stream_wgetc_for_read = ISOWGetc;
3108 else
3109 st->stream_wgetc_for_read = st->stream_wgetc;
3110 #if _MSC_VER || defined(__MINGW32__)
3111 st->u.pipe.hdl = WritePipe;
3112 #else
3113 st->u.pipe.fd = filedes[1];
3114 #endif
3115 UNLOCK(st->streamlock);
3116 t2 = MkStream (sno);
3117 return
3118 Yap_unify (ARG1, t1) &&
3119 Yap_unify (ARG2, t2);
3120 }
3121
3122 static int
3123 open_buf_read_stream(char *nbuf, Int nchars)
3124 {
3125 int sno;
3126 StreamDesc *st;
3127
3128
3129 sno = GetFreeStreamD();
3130 if (sno < 0)
3131 return (PlIOError (RESOURCE_ERROR_MAX_STREAMS,TermNil, "new stream not available for open_mem_read_stream/1"));
3132 st = &Stream[sno];
3133 /* currently these streams are not seekable */
3134 st->status = Input_Stream_f | InMemory_Stream_f;
3135 st->linepos = 0;
3136 st->charcount = 0;
3137 st->linecount = 1;
3138 st->stream_putc = MemPutc;
3139 st->stream_wputc = put_wchar;
3140 st->stream_getc = MemGetc;
3141 st->stream_gets = DefaultGets;
3142 st->stream_wgetc = get_wchar;
3143 if (CharConversionTable != NULL)
3144 st->stream_wgetc_for_read = ISOWGetc;
3145 else
3146 st->stream_wgetc_for_read = st->stream_wgetc;
3147 st->u.mem_string.pos = 0;
3148 st->u.mem_string.buf = nbuf;
3149 st->u.mem_string.max_size = nchars;
3150 st->u.mem_string.error_handler = NULL;
3151 st->u.mem_string.src = MEM_BUF_CODE;
3152 UNLOCK(st->streamlock);
3153 return sno;
3154 }
3155
3156 static Int
3157 p_open_mem_read_stream (void) /* $open_mem_read_stream(+List,-Stream) */
3158 {
3159 Term t, ti;
3160 int sno;
3161 Int sl = 0, nchars = 0;
3162 char *nbuf;
3163
3164 ti = Deref(ARG1);
3165 while (ti != TermNil) {
3166 if (IsVarTerm(ti)) {
3167 Yap_Error(INSTANTIATION_ERROR, ti, "open_mem_read_stream");
3168 return (FALSE);
3169 } else if (!IsPairTerm(ti)) {
3170 Yap_Error(TYPE_ERROR_LIST, ti, "open_mem_read_stream");
3171 return (FALSE);
3172 } else {
3173 sl++;
3174 ti = TailOfTerm(ti);
3175 }
3176 }
3177 while ((nbuf = (char *)Yap_AllocAtomSpace((sl+1)*sizeof(char))) == NULL) {
3178 if (!Yap_growheap(FALSE, (sl+1)*sizeof(char), NULL)) {
3179 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
3180 return(FALSE);
3181 }
3182 }
3183 ti = Deref(ARG1);
3184 while (ti != TermNil) {
3185 Term ts = HeadOfTerm(ti);
3186
3187 if (IsVarTerm(ts)) {
3188 Yap_Error(INSTANTIATION_ERROR, ARG1, "open_mem_read_stream");
3189 return (FALSE);
3190 } else if (!IsIntTerm(ts)) {
3191 Yap_Error(TYPE_ERROR_INTEGER, ARG1, "open_mem_read_stream");
3192 return (FALSE);
3193 }
3194 nbuf[nchars++] = IntOfTerm(ts);
3195 ti = TailOfTerm(ti);
3196 }
3197 nbuf[nchars] = '\0';
3198 sno = open_buf_read_stream(nbuf, nchars);
3199 t = MkStream (sno);
3200 return (Yap_unify (ARG2, t));
3201 }
3202
3203 static int
3204 open_buf_write_stream(char *nbuf, UInt sz)
3205 {
3206 int sno;
3207 StreamDesc *st;
3208
3209 sno = GetFreeStreamD();
3210 if (sno < 0)
3211 return -1;
3212 st = &Stream[sno];
3213 /* currently these streams are not seekable */
3214 st->status = Output_Stream_f | InMemory_Stream_f;
3215 st->linepos = 0;
3216 st->charcount = 0;
3217 st->linecount = 1;
3218 st->stream_putc = MemPutc;
3219 st->stream_wputc = put_wchar;
3220 st->stream_getc = MemGetc;
3221 st->stream_gets = DefaultGets;
3222 st->stream_wgetc = get_wchar;
3223 if (CharConversionTable != NULL)
3224 st->stream_wgetc_for_read = ISOWGetc;
3225 else
3226 st->stream_wgetc_for_read = st->stream_wgetc;
3227 st->u.mem_string.pos = 0;
3228 st->u.mem_string.buf = nbuf;
3229 st->u.mem_string.max_size = sz;
3230 st->u.mem_string.src = MEM_BUF_CODE;
3231 UNLOCK(st->streamlock);
3232 return sno;
3233 }
3234
3235 static int
3236 OpenBufWriteStream(void)
3237 {
3238 char *nbuf;
3239 extern int Yap_page_size;
3240
3241
3242 while ((nbuf = (char *)Yap_AllocAtomSpace(Yap_page_size*sizeof(char))) == NULL) {
3243 if (!Yap_growheap(FALSE, Yap_page_size*sizeof(char), NULL)) {
3244 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
3245 return -1;
3246 }
3247 }
3248 return open_buf_write_stream(nbuf, Yap_page_size);
3249 }
3250
3251 static Int
3252 p_open_mem_write_stream (void) /* $open_mem_write_stream(-Stream) */
3253 {
3254 Term t;
3255 int sno;
3256
3257 sno = OpenBufWriteStream();
3258 if (sno == -1)
3259 return (PlIOError (SYSTEM_ERROR,TermNil, "new stream not available for open_mem_read_stream/1"));
3260 t = MkStream (sno);
3261 return (Yap_unify (ARG1, t));
3262 }
3263
3264 static void
3265 ExtendAliasArray(void)
3266 {
3267 AliasDesc new;
3268 UInt new_size = SzOfFileAliases+ALIASES_BLOCK_SIZE;
3269
3270 new = (AliasDesc)Yap_AllocCodeSpace(sizeof(AliasDesc *)*new_size);
3271 memcpy((void *)new, (void *)FileAliases, sizeof(AliasDesc *)*SzOfFileAliases);
3272 Yap_FreeCodeSpace((ADDR)FileAliases);
3273 FileAliases = new;
3274 SzOfFileAliases = new_size;
3275 }
3276
3277 /* create a new alias arg for stream sno */
3278 static int
3279 AddAlias (Atom arg, int sno)
3280 {
3281
3282 AliasDesc aliasp = FileAliases, aliasp_max = FileAliases+NOfFileAliases;
3283
3284 while (aliasp < aliasp_max) {
3285 if (aliasp->name == arg) {
3286 if (aliasp->alias_stream != sno) {
3287 return(FALSE);
3288 }
3289 return(TRUE);
3290 }
3291 aliasp++;
3292 }
3293 /* we have not found an alias neither a hole */
3294 if (aliasp == FileAliases+SzOfFileAliases)
3295 ExtendAliasArray();
3296 NOfFileAliases++;
3297 aliasp->name = arg;
3298 aliasp->alias_stream = sno;
3299 return(TRUE);
3300 }
3301
3302 /* create a new alias arg for stream sno */
3303 static void
3304 SetAlias (Atom arg, int sno)
3305 {
3306
3307 AliasDesc aliasp = FileAliases, aliasp_max = FileAliases+NOfFileAliases;
3308
3309 while (aliasp < aliasp_max) {
3310 if (aliasp->name == arg) {
3311 Int alno = aliasp-FileAliases;
3312 aliasp->alias_stream = sno;
3313 if (!(Stream[sno].status &
3314 (Null_Stream_f|InMemory_Stream_f|Socket_Stream_f))) {
3315 switch(alno) {
3316 case 0:
3317 Yap_stdin = Stream[sno].u.file.file;
3318 break;
3319 case 1:
3320 Yap_stdout = Stream[sno].u.file.file;
3321 break;
3322 case 2:
3323 Yap_stderr = Stream[sno].u.file.file;
3324 break;
3325 default:
3326 break;
3327 }
3328 #if HAVE_SETBUF_COMMENTED_OUT
3329 YP_setbuf (Stream[sno].u.file.file, NULL);
3330 #endif /* HAVE_SETBUF */
3331 }
3332 return;
3333 }
3334 aliasp++;
3335 }
3336 /* we have not found an alias, create one */
3337 if (aliasp == FileAliases+SzOfFileAliases)
3338 ExtendAliasArray();
3339 NOfFileAliases++;
3340 aliasp->name = arg;
3341 aliasp->alias_stream = sno;
3342 }
3343
3344 /* purge all aliases for stream sno */
3345 static void
3346 PurgeAlias (int sno)
3347 {
3348 AliasDesc aliasp = FileAliases, aliasp_max = FileAliases+NOfFileAliases, new_aliasp = aliasp;
3349
3350 while (aliasp < aliasp_max) {
3351 if (aliasp->alias_stream == sno) {
3352 if (aliasp - FileAliases < 3) {
3353 /* get back to std streams, but keep alias around */
3354 Int alno = aliasp-FileAliases;
3355 new_aliasp->alias_stream = alno;
3356 switch(alno) {
3357 case 0:
3358 Yap_stdin = stdin;
3359 break;
3360 case 1:
3361 Yap_stdout = stdout;
3362 break;
3363 case 2:
3364 Yap_stderr = stderr;
3365 break;
3366 default:
3367 break; /* just put something here */
3368 }
3369 new_aliasp++;
3370 } else {
3371 NOfFileAliases--;
3372 }
3373 } else {
3374 /* avoid holes in alias array */
3375 if (new_aliasp != aliasp) {
3376 new_aliasp->alias_stream = aliasp->alias_stream;
3377 new_aliasp->name = aliasp->name;
3378 }
3379 new_aliasp++;
3380 }
3381 aliasp++;
3382 }
3383 }
3384
3385 /* check if name is an alias */
3386 static int
3387 CheckAlias (Atom arg)
3388 {
3389 AliasDesc aliasp = FileAliases, aliasp_max = FileAliases+NOfFileAliases;
3390
3391
3392 while (aliasp < aliasp_max) {
3393 if (aliasp->name == arg) {
3394 return(aliasp->alias_stream);
3395 }
3396 aliasp++;
3397 }
3398 return(-1);
3399 }
3400
3401 /* check if stream has an alias */
3402 static Atom
3403 FetchAlias (int sno)
3404 {
3405 AliasDesc aliasp = FileAliases, aliasp_max = FileAliases+NOfFileAliases;
3406
3407 while (aliasp < aliasp_max) {
3408 if (aliasp->alias_stream == sno) {
3409 return(aliasp->name);
3410 }
3411 aliasp++;
3412 }
3413 return(AtomFoundVar);
3414 }
3415
3416 /* check if arg is an alias */
3417 static int
3418 FindAliasForStream (int sno, Atom al)
3419 {
3420 AliasDesc aliasp = FileAliases, aliasp_max = FileAliases+NOfFileAliases;
3421
3422 while (aliasp < aliasp_max) {
3423 if (aliasp->alias_stream == sno && aliasp->name == al) {
3424 return(TRUE);
3425 }
3426 aliasp++;
3427 }
3428 return(FALSE);
3429 }
3430
3431 /* check if arg is an alias */
3432 static int
3433 FindStreamForAlias (Atom al)
3434 {
3435 AliasDesc aliasp = FileAliases, aliasp_max = FileAliases+NOfFileAliases;
3436
3437 while (aliasp < aliasp_max) {
3438 if (aliasp->name == al) {
3439 return(aliasp->alias_stream);
3440 }
3441 aliasp++;
3442 }
3443 return(FALSE);
3444 }
3445
3446 static int
3447 LookupSWIStream (struct io_stream *swi_s)
3448 {
3449 int i = 0;
3450
3451 while (i < MaxStreams) {
3452 LOCK(Stream[i].streamlock);
3453 if (Stream[i].status & SWI_Stream_f &&
3454 Stream[i].u.swi_stream.swi_ptr == swi_s
3455 ) {
3456 UNLOCK(Stream[i].streamlock);
3457 return i;
3458 }
3459 UNLOCK(Stream[i].streamlock);
3460 i++;
3461 }
3462 i = GetFreeStreamD();
3463 if (i < 0)
3464 return i;
3465 Stream[i].u.swi_stream.swi_ptr = swi_s;
3466 Stream[i].status = SWI_Stream_f|Output_Stream_f|Input_Stream_f|Append_Stream_f|Tty_Stream_f|Promptable_Stream_f;
3467 Stream[i].linepos = 0;
3468 Stream[i].linecount = 1;
3469 Stream[i].charcount = 0;
3470 Stream[i].encoding = DefaultEncoding();
3471 Stream[i].stream_getc = IOSWIGetc;
3472 Stream[i].stream_putc = IOSWIPutc;
3473 Stream[i].stream_wputc = IOSWIWidePutc;
3474 Stream[i].stream_wgetc = IOSWIWideGetc;
3475 Stream[i].stream_gets = DefaultGets;
3476 if (CharConversionTable != NULL)
3477 Stream[i].stream_wgetc_for_read = ISOWGetc;
3478 else
3479 Stream[i].stream_wgetc_for_read = IOSWIWideGetc;
3480 UNLOCK(Stream[i].streamlock);
3481 return i;
3482 }
3483
3484 static int
3485 CheckStream (Term arg, int kind, char *msg)
3486 {
3487 int sno = -1;
3488 arg = Deref (arg);
3489 if (IsVarTerm (arg)) {
3490 Yap_Error(INSTANTIATION_ERROR, arg, msg);
3491 return -1;
3492 } else if (IsAtomTerm (arg)) {
3493 Atom sname = AtomOfTerm (arg);
3494
3495 if (sname == AtomUser) {
3496 if (kind & Input_Stream_f) {
3497 if (kind & (Output_Stream_f|Append_Stream_f)) {
3498 Yap_Error(PERMISSION_ERROR_INPUT_STREAM, arg,
3499 "ambiguous use of 'user' as a stream");
3500 return (-1);
3501 }
3502 sname = AtomUserIn;
3503 } else {
3504 sname = AtomUserOut;
3505 }
3506 }
3507 if (kind & SWI_Stream_f) {
3508 struct io_stream *swi_stream;
3509
3510 if (Yap_get_stream_handle(arg, kind & Input_Stream_f, kind & Output_Stream_f, &swi_stream)) {
3511 sno = LookupSWIStream(swi_stream);
3512 return sno;
3513 }
3514 }
3515 if ((sno = CheckAlias(sname)) == -1) {
3516 Yap_Error(EXISTENCE_ERROR_STREAM, arg, msg);
3517 return -1;
3518 }
3519 } else if (IsApplTerm (arg) && FunctorOfTerm (arg) == FunctorStream) {
3520 arg = ArgOfTerm (1, arg);
3521 if (!IsVarTerm (arg) && IsIntegerTerm (arg)) {
3522 Int xsno = IntegerOfTerm(arg);
3523 if (xsno > MaxStreams) {
3524 sno = LookupSWIStream((struct io_stream *)xsno);
3525 } else {
3526 sno = xsno;
3527 }
3528 }
3529 } else if (IsApplTerm (arg) && FunctorOfTerm (arg) == FSWIStream) {
3530 arg = ArgOfTerm (1, arg);
3531 if (!IsVarTerm (arg) && IsIntegerTerm (arg))
3532 sno = LookupSWIStream((struct io_stream *)IntegerOfTerm (arg));
3533 }
3534 if (sno < 0)
3535 {
3536 Yap_Error(DOMAIN_ERROR_STREAM_OR_ALIAS, arg, msg);
3537 return (-1);
3538 }
3539 LOCK(Stream[sno].streamlock);
3540 if (Stream[sno].status & Free_Stream_f)
3541 {
3542 UNLOCK(Stream[sno].streamlock);
3543 Yap_Error(EXISTENCE_ERROR_STREAM, arg, msg);
3544 return (-1);
3545 }
3546 if ((Stream[sno].status & kind) == 0)
3547 {
3548 UNLOCK(Stream[sno].streamlock);
3549 if (kind & Input_Stream_f)
3550 Yap_Error(PERMISSION_ERROR_INPUT_STREAM, arg, msg);
3551 else
3552 Yap_Error(PERMISSION_ERROR_OUTPUT_STREAM, arg, msg);
3553 return (-1);
3554 }
3555 return (sno);
3556 }
3557
3558 int
3559 Yap_CheckStream (Term arg, int kind, char *msg)
3560 {
3561 return CheckStream(arg, kind, msg);
3562 }
3563
3564
3565 #if defined(YAPOR) || defined(THREADS)
3566 void
3567 Yap_LockStream (int sno)
3568 {
3569 LOCK(Stream[sno].streamlock);
3570 }
3571
3572 void
3573 Yap_UnLockStream (int sno)
3574 {
3575 UNLOCK(Stream[sno].streamlock);
3576 }
3577 #endif
3578
3579 static Int
3580 p_check_stream (void)
3581 { /* '$check_stream'(Stream,Mode) */
3582 Term mode = Deref (ARG2);
3583 int sno = CheckStream (ARG1,
3584 AtomOfTerm (mode) == AtomRead ? Input_Stream_f : Output_Stream_f,
3585 "check_stream/2");
3586 if (sno != -1)
3587 UNLOCK(Stream[sno].streamlock);
3588 return sno != -1;
3589 }
3590
3591 static Int
3592 p_check_if_stream (void)
3593 { /* '$check_stream'(Stream) */
3594 int sno = CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f | Socket_Stream_f, "check_stream/1");
3595 if (sno != -1)
3596 UNLOCK(Stream[sno].streamlock);
3597 return sno != -1;
3598 }
3599
3600 static Term
3601 StreamName(int i)
3602 {
3603 if (i < 3) return(MkAtomTerm(AtomUser));
3604 #if USE_SOCKET
3605 if (Stream[i].status & Socket_Stream_f)
3606 return(MkAtomTerm(AtomSocket));
3607 else
3608 #endif
3609 if (Stream[i].status & Pipe_Stream_f)
3610 return(MkAtomTerm(AtomPipe));
3611 if (Stream[i].status & InMemory_Stream_f)
3612 return(MkAtomTerm(AtomCharsio));
3613 else {
3614 return(Stream[i].u.file.user_name);
3615 }
3616 }
3617
3618 static Int
3619 init_cur_s (void)
3620 { /* Init current_stream */
3621 Term t3 = Deref(ARG3);
3622 /* make valgrind happy by always filling in memory */
3623 EXTRA_CBACK_ARG (3, 1) = MkIntTerm (0);
3624 if (!IsVarTerm(t3)) {
3625
3626 Int i;
3627 Term t1, t2;
3628
3629 i = CheckStream (t3, Input_Stream_f|Output_Stream_f, "current_stream/3");
3630 if (i < 0) {
3631 return FALSE;
3632 }
3633 t1 = StreamName(i);
3634 t2 = (Stream[i].status & Input_Stream_f ?
3635 MkAtomTerm (AtomRead) :
3636 MkAtomTerm (AtomWrite));
3637 UNLOCK(Stream[i].streamlock);
3638 if (Yap_unify(ARG1,t1) && Yap_unify(ARG2,t2)) {
3639 cut_succeed();
3640 } else {
3641 cut_fail();
3642 }
3643 } else {
3644 return (cont_cur_s ());
3645 }
3646 }
3647
3648 static Int
3649 cont_cur_s (void)
3650 { /* current_stream */
3651 Term t1, t2, t3;
3652 int i = IntOfTerm (EXTRA_CBACK_ARG (3, 1));
3653 while (i < MaxStreams) {
3654 LOCK(Stream[i].streamlock);
3655 if (Stream[i].status & Free_Stream_f) {
3656 ++i;
3657 UNLOCK(Stream[i-1].streamlock);
3658 continue;
3659 }
3660 t1 = StreamName(i);
3661 t2 = (Stream[i].status & Input_Stream_f ?
3662 MkAtomTerm (AtomRead) :
3663 MkAtomTerm (AtomWrite));
3664 t3 = MkStream (i++);
3665 UNLOCK(Stream[i-1].streamlock);
3666 EXTRA_CBACK_ARG (3, 1) = Unsigned (MkIntTerm (i));
3667 if (Yap_unify (ARG3, t3) && Yap_unify_constant (ARG1, t1) && Yap_unify_constant (ARG2, t2)) {
3668 return TRUE;
3669 } else {
3670 return FALSE;
3671 }
3672 }
3673 cut_fail();
3674 }
3675
3676
3677 /*
3678 * Called when you want to close all open streams, except for stdin, stdout
3679 * and stderr
3680 */
3681 void
3682 Yap_CloseStreams (int loud)
3683 {
3684 int sno;
3685 for (sno = 3; sno < MaxStreams; ++sno) {
3686 if (Stream[sno].status & Free_Stream_f)
3687 continue;
3688 if ((Stream[sno].status & Popen_Stream_f))
3689 pclose (Stream[sno].u.file.file);
3690 #if _MSC_VER || defined(__MINGW32__)
3691 if (Stream[sno].status & Pipe_Stream_f)
3692 CloseHandle (Stream[sno].u.pipe.hdl);
3693 #else
3694 if (Stream[sno].status & (Pipe_Stream_f|Socket_Stream_f))
3695 close (Stream[sno].u.pipe.fd);
3696 #endif
3697 #if USE_SOCKET
3698 else if (Stream[sno].status & (Socket_Stream_f)) {
3699 Yap_CloseSocket(Stream[sno].u.socket.fd,
3700 Stream[sno].u.socket.flags,
3701 Stream[sno].u.socket.domain);
3702 }
3703 #endif
3704 else if (Stream[sno].status & InMemory_Stream_f) {
3705 if (Stream[sno].u.mem_string.src == MEM_BUF_CODE) {
3706 Yap_FreeAtomSpace(Stream[sno].u.mem_string.buf);
3707 } else {
3708 free(Stream[sno].u.mem_string.buf);
3709 }
3710 } else if (Stream[sno].status & (SWI_Stream_f)) {
3711 SWIClose(Stream[sno].u.swi_stream.swi_ptr);
3712 } else if (!(Stream[sno].status & Null_Stream_f)) {
3713 YP_fclose (Stream[sno].u.file.file);
3714 } else {
3715 if (loud)
3716 fprintf (Yap_stderr, "%% YAP Error: while closing stream: %s\n", RepAtom (Stream[sno].u.file.name)->StrOfAE);
3717 }
3718 if (Yap_c_input_stream == sno) {
3719 Yap_c_input_stream = StdInStream;
3720 } else if (Yap_c_output_stream == sno) {
3721 Yap_c_output_stream = StdOutStream;
3722 }
3723 Stream[sno].status = Free_Stream_f;
3724 }
3725 }
3726
3727
3728 static void
3729 CloseStream(int sno)
3730 {
3731 if (!(Stream[sno].status & (Null_Stream_f|Socket_Stream_f|InMemory_Stream_f|Pipe_Stream_f|SWI_Stream_f)))
3732 YP_fclose (Stream[sno].u.file.file);
3733 #if USE_SOCKET
3734 else if (Stream[sno].status & (Socket_Stream_f)) {
3735 Yap_CloseSocket(Stream[sno].u.socket.fd,
3736 Stream[sno].u.socket.flags,
3737 Stream[sno].u.socket.domain);
3738 }
3739 #endif
3740 else if (Stream[sno].status & Pipe_Stream_f) {
3741 #if _MSC_VER || defined(__MINGW32__)
3742 CloseHandle (Stream[sno].u.pipe.hdl);
3743 #else
3744 close(Stream[sno].u.pipe.fd);
3745 #endif
3746 }
3747 else if (Stream[sno].status & (InMemory_Stream_f)) {
3748 if (Stream[sno].u.mem_string.src == MEM_BUF_CODE)
3749 Yap_FreeAtomSpace(Stream[sno].u.mem_string.buf);
3750 else
3751 free(Stream[sno].u.mem_string.buf);
3752 }
3753 else if (Stream[sno].status & (SWI_Stream_f)) {
3754 SWIClose(Stream[sno].u.swi_stream.swi_ptr);
3755 }
3756 Stream[sno].status = Free_Stream_f;
3757 PurgeAlias(sno);
3758 if (Yap_c_input_stream == sno)
3759 {
3760 Yap_c_input_stream = StdInStream;
3761 }
3762 else if (Yap_c_output_stream == sno)
3763 {
3764 Yap_c_output_stream = StdOutStream;
3765 }
3766 /* if (st->status == Socket_Stream_f|Input_Stream_f|Output_Stream_f) {
3767 Yap_CloseSocket();
3768 }
3769 */
3770 }
3771
3772 void
3773 Yap_CloseStream(int sno)
3774 {
3775 CloseStream(sno);
3776 }
3777
3778 static Int
3779 p_close (void)
3780 { /* '$close'(+Stream) */
3781 Int sno = CheckStream (ARG1, (Input_Stream_f | Output_Stream_f | Socket_Stream_f), "close/2");
3782 if (sno < 0)
3783 return (FALSE);
3784 if (sno <= StdErrStream) {
3785 UNLOCK(Stream[sno].streamlock);
3786 return TRUE;
3787 }
3788 CloseStream(sno);
3789 UNLOCK(Stream[sno].streamlock);
3790 return (TRUE);
3791 }
3792
3793 static Int
3794 p_peek_mem_write_stream (void)
3795 { /* '$peek_mem_write_stream'(+Stream,?S0,?S) */
3796 Int sno = CheckStream (ARG1, (Output_Stream_f | InMemory_Stream_f), "close/2");
3797 Int i = Stream[sno].u.mem_string.pos;
3798 Term tf = ARG2;
3799 CELL *HI;
3800
3801 if (sno < 0)
3802 return (FALSE);
3803 restart:
3804 HI = H;
3805 while (i > 0) {
3806 --i;
3807 tf = MkPairTerm(MkIntTerm(Stream[sno].u.mem_string.buf[i]),tf);
3808 if (H + 1024 >= ASP) {
3809 UNLOCK(Stream[sno].streamlock);
3810 H = HI;
3811 if (!Yap_gcl((ASP-HI)*sizeof(CELL), 3, ENV, gc_P(P,CP))) {
3812 UNLOCK(Stream[sno].streamlock);
3813 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
3814 return(FALSE);
3815 }
3816 i = Stream[sno].u.mem_string.pos;
3817 tf = ARG2;
3818 LOCK(Stream[sno].streamlock);
3819 goto restart;
3820 }
3821 }
3822 UNLOCK(Stream[sno].streamlock);
3823 return (Yap_unify(ARG3,tf));
3824 }
3825
3826 static Int
3827 p_past_eof (void)
3828 { /* at_end_of_stream */
3829 /* the next character is a EOF */
3830 int sno = CheckStream (ARG1, Input_Stream_f, "past_eof/1");
3831 Int out;
3832
3833 if (sno < 0)
3834 return (FALSE);
3835 if (Stream[sno].stream_getc == PlUnGetc) {
3836 UNLOCK(Stream[sno].streamlock);
3837 return FALSE;
3838 }
3839 out = Stream[sno].status & Eof_Stream_f;
3840 UNLOCK(Stream[sno].streamlock);
3841 return out;
3842 }
3843
3844 static Int
3845 p_peek_byte (void)
3846 { /* at_end_of_stream */
3847 /* the next character is a EOF */
3848 int sno = CheckStream (ARG1, Input_Stream_f, "peek/2");
3849 StreamDesc *s;
3850 Int ocharcount, olinecount, olinepos;
3851 Int status;
3852 Int ch;
3853
3854 if (sno < 0)
3855 return(FALSE);
3856 status = Stream[sno].status;
3857 if (!(status & Binary_Stream_f)) {
3858 UNLOCK(Stream[sno].streamlock);
3859 Yap_Error(PERMISSION_ERROR_INPUT_TEXT_STREAM, ARG1, "peek/2");
3860 return(FALSE);
3861 }
3862 UNLOCK(Stream[sno].streamlock);
3863 if (Stream[sno].stream_getc == PlUnGetc) {
3864 ch = MkIntTerm(Stream[sno].och);
3865 /* sequence of peeks */
3866 return Yap_unify_constant(ARG2,ch);
3867 }
3868 if (status & Eof_Stream_f) {
3869 Yap_Error(PERMISSION_ERROR_INPUT_PAST_END_OF_STREAM, ARG1, "peek/2");
3870 return(FALSE);
3871 }
3872 s = Stream+sno;
3873 ocharcount = s->charcount;
3874 olinecount = s->linecount;
3875 olinepos = s->linepos;
3876 ch = Stream[sno].stream_getc(sno);
3877 s->charcount = ocharcount;
3878 s->linecount = olinecount;
3879 s->linepos = olinepos;
3880 /* buffer the character */
3881 s->och = ch;
3882 /* mark a special function to recover this character */
3883 s->stream_getc = PlUnGetc;
3884 s->stream_wgetc = get_wchar;
3885 s->stream_gets = DefaultGets;
3886 if (CharConversionTable != NULL)
3887 s->stream_wgetc_for_read = ISOWGetc;
3888 else
3889 s->stream_wgetc_for_read = s->stream_wgetc;
3890 UNLOCK(s->streamlock);
3891 return(Yap_unify_constant(ARG2,MkIntTerm(ch)));
3892 }
3893
3894 static Int
3895 p_peek (void)
3896 { /* at_end_of_stream */
3897 /* the next character is a EOF */
3898 int sno = CheckStream (ARG1, Input_Stream_f, "peek/2");
3899 StreamDesc *s;
3900 Int ocharcount, olinecount, olinepos;
3901 Int status;
3902 Int ch;
3903
3904 if (sno < 0)
3905 return(FALSE);
3906 status = Stream[sno].status;
3907 if (status & Binary_Stream_f) {
3908 UNLOCK(Stream[sno].streamlock);
3909 Yap_Error(PERMISSION_ERROR_INPUT_BINARY_STREAM, ARG1, "peek/2");
3910 return FALSE;
3911 }
3912 UNLOCK(Stream[sno].streamlock);
3913 if (Stream[sno].stream_getc == PlUnGetc) {
3914 ch = MkIntTerm(Stream[sno].och);
3915 /* sequence of peeks */
3916 return Yap_unify_constant(ARG2,ch);
3917 }
3918 LOCK(Stream[sno].streamlock);
3919 s = Stream+sno;
3920 ocharcount = s->charcount;
3921 olinecount = s->linecount;
3922 olinepos = s->linepos;
3923 UNLOCK(Stream[sno].streamlock);
3924 ch = get_wchar(sno);
3925 LOCK(Stream[sno].streamlock);
3926 s->charcount = ocharcount;
3927 s->linecount = olinecount;
3928 s->linepos = olinepos;
3929 /* buffer the character */
3930 s->och = ch;
3931 /* mark a special function to recover this character */
3932 s->stream_getc = PlUnGetc;
3933 s->stream_wgetc = get_wchar;
3934 s->stream_gets = DefaultGets;
3935 if (CharConversionTable != NULL)
3936 s->stream_wgetc_for_read = ISOWGetc;
3937 else
3938 s->stream_wgetc_for_read = s->stream_wgetc;
3939 UNLOCK(Stream[sno].streamlock);
3940 return(Yap_unify_constant(ARG2,MkIntTerm(ch)));
3941 }
3942
3943 static Int
3944 p_set_input (void)
3945 { /* '$set_input'(+Stream,-ErrorMessage) */
3946 Int sno = CheckStream (ARG1, Input_Stream_f, "set_input/1");
3947 if (sno < 0)
3948 return (FALSE);
3949 Yap_c_input_stream = sno;
3950 UNLOCK(Stream[sno].streamlock);
3951 return TRUE;
3952 }
3953
3954 static Int
3955 p_set_output (void)
3956 { /* '$set_output'(+Stream,-ErrorMessage) */
3957 Int sno = CheckStream (ARG1, Output_Stream_f, "set_output/1");
3958 if (sno < 0)
3959 return FALSE;
3960 Yap_c_output_stream = sno;
3961 UNLOCK(Stream[sno].streamlock);
3962 return (TRUE);
3963 }
3964
3965 static Int
3966 p_has_bom (void)
3967 { /* '$set_output'(+Stream,-ErrorMessage) */
3968 Int sno = CheckStream (ARG1, Input_Stream_f|Output_Stream_f, "has_bom/1");
3969 if (sno < 0)
3970 return (FALSE);
3971 UNLOCK(Stream[sno].streamlock);
3972 return ((Stream[sno].status & HAS_BOM_f));
3973 }
3974
3975 static Int
3976 p_representation_error (void)
3977 {
3978 /* '$representation_error'(+Stream,-ErrorMessage) */
3979 Term t;
3980 Int sno = CheckStream (ARG1, Input_Stream_f|Output_Stream_f, "representation_errors/1");
3981 if (sno < 0)
3982 return (FALSE);
3983 t = Deref(ARG2);
3984
3985 if (IsVarTerm(t)) {
3986 UNLOCK(Stream[sno].streamlock);
3987 if (Stream[sno].status & RepError_Prolog_f) {
3988 return Yap_unify(ARG2, MkIntegerTerm(512));
3989 }
3990 if (Stream[sno].status & RepError_Xml_f) {
3991 return Yap_unify(ARG2, MkIntegerTerm(1024));
3992 }
3993 return Yap_unify(ARG2, MkIntegerTerm(0));
3994 } else {
3995 Int i = IntegerOfTerm(t);
3996 switch (i) {
3997 case 512:
3998 Stream[sno].status &= ~RepError_Xml_f;
3999 Stream[sno].status |= RepError_Prolog_f;
4000 break;
4001 case 1024:
4002 Stream[sno].status &= ~RepError_Prolog_f;
4003 Stream[sno].status |= RepError_Xml_f;
4004 default:
4005 Stream[sno].status &= ~(RepError_Prolog_f|RepError_Xml_f);
4006 }
4007 }
4008 UNLOCK(Stream[sno].streamlock);
4009 return TRUE;
4010 }
4011
4012 static Int
4013 p_current_input (void)
4014 { /* current_input(?Stream) */
4015 Term t1 = Deref(ARG1);
4016 if (IsVarTerm(t1)) {
4017 Term t = MkStream (Yap_c_input_stream);
4018 BIND(VarOfTerm(t1), t, bind_in_current_input);
4019 #ifdef COROUTINING
4020 DO_TRAIL(CellPtr(t1), t);
4021 if (CellPtr(t1) < H0) Yap_WakeUp(VarOfTerm(t1));
4022 bind_in_current_input:
4023 #endif
4024 return TRUE;
4025 } else if (!IsApplTerm(t1) ||
4026 FunctorOfTerm(t1) != FunctorStream ||
4027 !IsIntTerm((t1=ArgOfTerm(1,t1)))) {
4028 Yap_Error(DOMAIN_ERROR_STREAM,t1,"current_input/1");
4029 return FALSE;
4030 } else {
4031 return Yap_c_input_stream == IntOfTerm(t1);
4032 }
4033 }
4034
4035 static Int
4036 p_current_output (void)
4037 { /* current_output(?Stream) */
4038 Term t1 = Deref(ARG1);
4039 if (IsVarTerm(t1)) {
4040 Term t = MkStream (Yap_c_output_stream);
4041 BIND((CELL *)t1, t, bind_in_current_output);
4042 #ifdef COROUTINING
4043 DO_TRAIL(CellPtr(t1), t);
4044 if (CellPtr(t1) < H0) Yap_WakeUp(VarOfTerm(t1));
4045 bind_in_current_output:
4046 #endif
4047 return TRUE;
4048 } else if (!IsApplTerm(t1) ||
4049 FunctorOfTerm(t1) != FunctorStream ||
4050 !IsIntTerm((t1=ArgOfTerm(1,t1)))) {
4051 Yap_Error(DOMAIN_ERROR_STREAM,t1,"current_output/1");
4052 return FALSE;
4053 } else {
4054 return(Yap_c_output_stream == IntOfTerm(t1));
4055 }
4056 }
4057
4058
4059 #ifdef BEAM
4060 int beam_write (void)
4061 {
4062 Yap_StartSlots();
4063 Yap_plwrite (ARG1, Stream[Yap_c_output_stream].stream_wputc, 0, 1200);
4064 Yap_CloseSlots();
4065 if (EX != 0L) {
4066 Term ball = Yap_PopTermFromDB(EX);
4067 EX = 0L;
4068 Yap_JumpToEnv(ball);
4069 return(FALSE);
4070 }
4071 return (TRUE);
4072 }
4073 #endif
4074
4075 static Int
4076 p_write (void)
4077 {
4078 /* '$write'(+Flags,?Term) */
4079 int flags = (int) IntOfTerm (Deref (ARG1));
4080 /* notice: we must have ASP well set when using portray, otherwise
4081 we cannot make recursive Prolog calls */
4082 Yap_StartSlots();
4083 Yap_plwrite (ARG2, Stream[Yap_c_output_stream].stream_wputc, flags, 1200);
4084 Yap_CloseSlots();
4085 if (EX != 0L) {
4086 Term ball = Yap_PopTermFromDB(EX);
4087 EX = NULL;
4088 Yap_JumpToEnv(ball);
4089 return(FALSE);
4090 }
4091 return (TRUE);
4092 }
4093
4094 static Int
4095 p_write_prio (void)
4096 {
4097 /* '$write'(+Flags,?Term) */
4098 int flags = (int) IntOfTerm (Deref (ARG1));
4099 /* notice: we must have ASP well set when using portray, otherwise
4100 we cannot make recursive Prolog calls */
4101 Yap_StartSlots();
4102 Yap_plwrite (ARG3, Stream[Yap_c_output_stream].stream_wputc, flags, (int)IntOfTerm(Deref(ARG2)));
4103 Yap_CloseSlots();
4104 if (EX != 0L) {
4105 Term ball = Yap_PopTermFromDB(EX);
4106 EX = NULL;
4107 Yap_JumpToEnv(ball);
4108 return(FALSE);
4109 }
4110 return (TRUE);
4111 }
4112
4113 static Int
4114 p_write2_prio (void)
4115 { /* '$write'(+Stream,+Flags,?Term) */
4116 int old_output_stream = Yap_c_output_stream;
4117 Int flags = IntegerOfTerm(Deref(ARG2));
4118 int stream_f;
4119
4120 if (flags & Use_SWI_Stream_f) {
4121 stream_f = Output_Stream_f|SWI_Stream_f;
4122 } else {
4123 stream_f = Output_Stream_f;
4124 }
4125 Yap_c_output_stream = CheckStream (ARG1, stream_f, "write/2");
4126 if (Yap_c_output_stream == -1) {
4127 Yap_c_output_stream = old_output_stream;
4128 return(FALSE);
4129 }
4130 UNLOCK(Stream[Yap_c_output_stream].streamlock);
4131 /* notice: we must have ASP well set when using portray, otherwise
4132 we cannot make recursive Prolog calls */
4133 Yap_StartSlots();
4134 Yap_plwrite (ARG4, Stream[Yap_c_output_stream].stream_wputc, (int) flags, (int) IntOfTerm (Deref (ARG3)));
4135 Yap_CloseSlots();
4136 Yap_c_output_stream = old_output_stream;
4137 if (EX != 0L) {
4138 Term ball = Yap_PopTermFromDB(EX);
4139 EX = NULL;
4140 Yap_JumpToEnv(ball);
4141 return(FALSE);
4142 }
4143 return (TRUE);
4144 }
4145
4146 static Int
4147 p_write2 (void)
4148 { /* '$write'(+Stream,+Flags,?Term) */
4149 int old_output_stream = Yap_c_output_stream;
4150 Yap_c_output_stream = CheckStream (ARG1, Output_Stream_f, "write/2");
4151 if (Yap_c_output_stream == -1) {
4152 Yap_c_output_stream = old_output_stream;
4153 return(FALSE);
4154 }
4155 UNLOCK(Stream[Yap_c_output_stream].streamlock);
4156 /* notice: we must have ASP well set when using portray, otherwise
4157 we cannot make recursive Prolog calls */
4158 Yap_StartSlots();
4159 Yap_plwrite (ARG3, Stream[Yap_c_output_stream].stream_wputc, (int) IntOfTerm (Deref (ARG2)), 1200);
4160 Yap_CloseSlots();
4161 Yap_c_output_stream = old_output_stream;
4162 if (EX != 0L) {
4163 Term ball = Yap_PopTermFromDB(EX);
4164 EX = NULL;
4165 Yap_JumpToEnv(ball);
4166 return(FALSE);
4167 }
4168 return (TRUE);
4169 }
4170
4171 static void
4172 clean_vars(VarEntry *p)
4173 {
4174 if (p == NULL) return;
4175 p->VarAdr = TermNil;
4176 clean_vars(p->VarLeft);
4177 clean_vars(p->VarRight);
4178 }
4179
4180 static Term
4181 syntax_error (TokEntry * tokptr, int sno, Term *outp)
4182 {
4183 Term info;
4184 int count = 0, out = 0;
4185 Int start, err = 0, end;
4186 Term tf[7];
4187 Term *error = tf+3;
4188 CELL *Hi = H;
4189
4190 /* make sure to globalise variable */
4191 Yap_unify(*outp, MkVarTerm());
4192 start = tokptr->TokPos;
4193 clean_vars(Yap_VarTable);
4194 clean_vars(Yap_AnonVarTable);
4195 while (1) {
4196 Term ts[2];
4197
4198 if (H > ASP-1024) {
4199 tf[3] = TermNil;
4200 err = 0;
4201 end = 0;
4202 /* for some reason moving this earlier confuses gcc on solaris */
4203 H = Hi;
4204 break;
4205 }
4206 if (tokptr == Yap_toktide) {
4207 err = tokptr->TokPos;
4208 out = count;
4209 }
4210 info = tokptr->TokInfo;
4211 switch (tokptr->Tok) {
4212 case Name_tok:
4213 {
4214 Term t0[1];
4215 t0[0] = MkAtomTerm((Atom)info);
4216 ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomAtom,1),1,t0);
4217 }
4218 break;
4219 case Number_tok:
4220 ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomNumber,1),1,&(tokptr->TokInfo));
4221 break;
4222 case Var_tok:
4223 {
4224 Term t[3];
4225 VarEntry *varinfo = (VarEntry *)info;
4226
4227 t[0] = MkIntTerm(0);
4228 t[1] = Yap_StringToList(varinfo->VarRep);
4229 if (varinfo->VarAdr == TermNil) {
4230 t[2] = varinfo->VarAdr = MkVarTerm();
4231 } else {
4232 t[2] = varinfo->VarAdr;
4233 }
4234 ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomGVar,3),3,t);
4235 }
4236 break;
4237 case String_tok:
4238 {
4239 Term t0 = Yap_StringToList((char *)info);
4240 ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomString,1),1,&t0);
4241 }
4242 break;
4243 case WString_tok:
4244 {
4245 Term t0 = Yap_WideStringToList((wchar_t *)info);
4246 ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomString,1),1,&t0);
4247 }
4248 break;
4249 case Error_tok:
4250 case eot_tok:
4251 break;
4252 case Ponctuation_tok:
4253 {
4254 char s[2];
4255 s[1] = '\0';
4256 if (Ord (info) == 'l') {
4257 s[0] = '(';
4258 } else {
4259 s[0] = (char)info;
4260 }
4261 ts[0] = MkAtomTerm(Yap_LookupAtom(s));
4262 }
4263 }
4264 if (tokptr->Tok == Ord (eot_tok)) {
4265 *error = TermNil;
4266 end = tokptr->TokPos;
4267 break;
4268 } else if (tokptr->Tok != Ord (Error_tok)) {
4269 ts[1] = MkIntegerTerm(tokptr->TokPos);
4270 *error =
4271 MkPairTerm(Yap_MkApplTerm(FunctorMinus,2,ts),TermNil);
4272 error = RepPair(*error)+1;
4273 count++;
4274 }
4275 tokptr = tokptr->TokNext;
4276 }
4277 if (IsVarTerm(*outp) && (VarOfTerm(*outp) > H || VarOfTerm(*outp) < H0)) {
4278 tf[0] = Yap_MkNewApplTerm(Yap_MkFunctor(AtomRead,1),1);
4279 } else {
4280 tf[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomRead,1),1,outp);
4281 }
4282 {
4283 Term t[3];
4284
4285 t[0] = MkIntegerTerm(start);
4286 t[1] = MkIntegerTerm(err);
4287 t[2] = MkIntegerTerm(end);
4288 tf[1] = Yap_MkApplTerm(Yap_MkFunctor(AtomBetween,3),3,t);
4289 }
4290 tf[2] = MkAtomTerm(AtomHERE);
4291 tf[4] = MkIntegerTerm(out);
4292 tf[5] = MkIntegerTerm(err);
4293 tf[6] = StreamName(sno);
4294 return(Yap_MkApplTerm(FunctorSyntaxError,7,tf));
4295 }
4296
4297 Int
4298 Yap_FirstLineInParse (void)
4299 {
4300 return StartLine;
4301 }
4302
4303 static Int
4304 p_startline (void)
4305 {
4306 return (Yap_unify_constant (ARG1, MkIntegerTerm (StartLine)));
4307 }
4308
4309 /* control the parser error handler */
4310 static Int
4311 p_set_read_error_handler(void)
4312 {
4313 Term t = Deref(ARG1);
4314 char *s;
4315 if (IsVarTerm(t)) {
4316 Yap_Error(INSTANTIATION_ERROR,t,"set_read_error_handler");
4317 return(FALSE);
4318 }
4319 if (!IsAtomTerm(t)) {
4320 Yap_Error(TYPE_ERROR_ATOM,t,"bad syntax_error handler");
4321 return(FALSE);
4322 }
4323 s = RepAtom(AtomOfTerm(t))->StrOfAE;
4324 if (!strcmp(s, "fail")) {
4325 ParserErrorStyle = FAIL_ON_PARSER_ERROR;
4326 } else if (!strcmp(s, "error")) {
4327 ParserErrorStyle = EXCEPTION_ON_PARSER_ERROR;
4328 } else if (!strcmp(s, "quiet")) {
4329 ParserErrorStyle = QUIET_ON_PARSER_ERROR;
4330 } else if (!strcmp(s, "dec10")) {
4331 ParserErrorStyle = CONTINUE_ON_PARSER_ERROR;
4332 } else {
4333 Yap_Error(DOMAIN_ERROR_SYNTAX_ERROR_HANDLER,t,"bad syntax_error handler");
4334 return(FALSE);
4335 }
4336 return(TRUE);
4337 }
4338
4339 /* return the status for the parser error handler */
4340 static Int
4341 p_get_read_error_handler(void)
4342 {
4343 Term t;
4344
4345 switch (ParserErrorStyle) {
4346 case FAIL_ON_PARSER_ERROR:
4347 t = MkAtomTerm(AtomFail);
4348 break;
4349 case EXCEPTION_ON_PARSER_ERROR:
4350 t = MkAtomTerm(AtomError);
4351 break;
4352 case QUIET_ON_PARSER_ERROR:
4353 t = MkAtomTerm(AtomQuiet);
4354 break;
4355 case CONTINUE_ON_PARSER_ERROR:
4356 t = MkAtomTerm(AtomDec10);
4357 break;
4358 default:
4359 Yap_Error(SYSTEM_ERROR,TermNil,"corrupted syntax_error handler");
4360 return(FALSE);
4361 }
4362 return (Yap_unify_constant (ARG1, t));
4363 }
4364
4365 /*
4366 Assumes
4367 Flag: ARG1
4368 Term: ARG2
4369 Module: ARG3
4370 Vars: ARG4
4371 Pos: ARG5
4372 Err: ARG6
4373 */
4374 static Int
4375 do_read(int inp_stream, int nargs)
4376 {
4377 Term t, v;
4378 TokEntry *tokstart;
4379 #if EMACS
4380 int emacs_cares = FALSE;
4381 #endif
4382 Term tmod = Deref(ARG3), OCurrentModule = CurrentModule, tpos;
4383
4384 if (IsVarTerm(tmod)) {
4385 tmod = CurrentModule;
4386 } else if (!IsAtomTerm(tmod)) {
4387 Yap_Error(TYPE_ERROR_ATOM, tmod, "read_term/2");
4388 return FALSE;
4389 }
4390 if (Stream[inp_stream].status & Binary_Stream_f) {
4391 Yap_Error(PERMISSION_ERROR_INPUT_BINARY_STREAM, MkAtomTerm(Stream[inp_stream].u.file.name), "read_term/2");
4392 return FALSE;
4393 }
4394 Yap_Error_TYPE = YAP_NO_ERROR;
4395 tpos = StreamPosition(inp_stream);
4396 if (!Yap_unify(tpos,ARG5)) {
4397 /* do this early so that we do not have to protect it in case of stack expansion */
4398 return FALSE;
4399 }
4400 while (TRUE) {
4401 CELL *old_H;
4402 UInt cpos = 0;
4403 int seekable = Stream[inp_stream].status & Seekable_Stream_f;
4404 #if HAVE_FGETPOS
4405 fpos_t rpos;
4406 #endif
4407 int ungetc_oldc = 0;
4408 int had_ungetc = FALSE;
4409
4410 /* two cases where we can seek: memory and console */
4411 if (seekable) {
4412 if (Stream[inp_stream].stream_getc == PlUnGetc) {
4413 had_ungetc = TRUE;
4414 ungetc_oldc = Stream[inp_stream].och;
4415 }
4416 if (Stream[inp_stream].status & InMemory_Stream_f) {
4417 cpos = Stream[inp_stream].u.mem_string.pos;
4418 } else {
4419 #if HAVE_FGETPOS
4420 fgetpos(Stream[inp_stream].u.file.file, &rpos);
4421 #else
4422 cpos = Stream[inp_stream].charcount;
4423 #endif
4424 }
4425 }
4426 /* Scans the term using stack space */
4427 while (TRUE) {
4428 old_H = H;
4429 Yap_eot_before_eof = FALSE;
4430 tpos = StreamPosition(inp_stream);
4431 tokstart = Yap_tokptr = Yap_toktide = Yap_tokenizer(inp_stream, &tpos);
4432 if (Yap_Error_TYPE != YAP_NO_ERROR && seekable) {
4433 H = old_H;
4434 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
4435 if (had_ungetc) {
4436 Stream[inp_stream].stream_getc = PlUnGetc;
4437 Stream[inp_stream].och = ungetc_oldc;
4438 }
4439 if (seekable) {
4440 if (Stream[inp_stream].status & InMemory_Stream_f) {
4441 Stream[inp_stream].u.mem_string.pos = cpos;
4442 } else if (Stream[inp_stream].status) {
4443 #if HAVE_FGETPOS
4444 fsetpos(Stream[inp_stream].u.file.file, &rpos);
4445 #else
4446 fseek(Stream[inp_stream].u.file.file, cpos, 0L);
4447 #endif
4448 }
4449 if ((Stream[inp_stream].status & Eof_Stream_f)) {
4450 Stream[inp_stream].status &= ~Eof_Stream_f;
4451 Stream[inp_stream].status |= Push_Eof_Stream_f;
4452 ResetEOF(Stream+inp_stream);
4453 }
4454 }
4455 if (Yap_Error_TYPE == OUT_OF_TRAIL_ERROR) {
4456 Yap_Error_TYPE = YAP_NO_ERROR;
4457 if (!Yap_growtrail (sizeof(CELL) * K16, FALSE)) {
4458 return FALSE;
4459 }
4460 } else if (Yap_Error_TYPE == OUT_OF_AUXSPACE_ERROR) {
4461 Yap_Error_TYPE = YAP_NO_ERROR;
4462 if (!Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE)) {
4463 return FALSE;
4464 }
4465 } else if (Yap_Error_TYPE == OUT_OF_HEAP_ERROR) {
4466 Yap_Error_TYPE = YAP_NO_ERROR;
4467 if (!Yap_growheap(FALSE, 0, NULL)) {
4468 return FALSE;
4469 }
4470 } else if (Yap_Error_TYPE == OUT_OF_STACK_ERROR) {
4471 Yap_Error_TYPE = YAP_NO_ERROR;
4472 if (!Yap_gcl(Yap_Error_Size, nargs, ENV, CP)) {
4473 return FALSE;
4474 }
4475 }
4476 } else {
4477 /* done with this */
4478 break;
4479 }
4480 }
4481 Yap_Error_TYPE = YAP_NO_ERROR;
4482 /* preserve value of H after scanning: otherwise we may lose strings
4483 and floats */
4484 old_H = H;
4485 if (Stream[inp_stream].status & Eof_Stream_f) {
4486 if (Yap_eot_before_eof || (Stream[inp_stream].status & InMemory_Stream_f)) {
4487 /* next read should give out an end of file */
4488 Stream[inp_stream].status |= Push_Eof_Stream_f;
4489 } else {
4490 if (tokstart != NULL && tokstart->Tok != Ord (eot_tok)) {
4491 /* we got the end of file from an abort */
4492 if (Yap_ErrorMessage &&
4493 !strcmp(Yap_ErrorMessage,"Abort")) {
4494 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
4495 return FALSE;
4496 }
4497 /* we need to force the next reading to also give end of file.*/
4498 Stream[inp_stream].status |= Push_Eof_Stream_f;
4499 Yap_ErrorMessage = "end of file found before end of term";
4500 } else {
4501 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
4502
4503 return Yap_unify_constant(ARG2, MkAtomTerm (AtomEof))
4504 && Yap_unify_constant(ARG4, TermNil);
4505 }
4506 }
4507 }
4508 repeat_cycle:
4509 CurrentModule = tmod;
4510 if (Yap_ErrorMessage || (t = Yap_Parse()) == 0) {
4511 CurrentModule = OCurrentModule;
4512 if (Yap_ErrorMessage) {
4513 int res;
4514
4515 if (!strcmp(Yap_ErrorMessage,"Stack Overflow") ||
4516 !strcmp(Yap_ErrorMessage,"Trail Overflow") ||
4517 !strcmp(Yap_ErrorMessage,"Heap Overflow")) {
4518 /* ignore term we just built */
4519 tr_fr_ptr old_TR = TR;
4520
4521
4522 H = old_H;
4523 TR = (tr_fr_ptr)ScannerStack;
4524
4525 if (!strcmp(Yap_ErrorMessage,"Stack Overflow"))
4526 res = Yap_growstack_in_parser(&old_TR, &tokstart, &Yap_VarTable);
4527 else if (!strcmp(Yap_ErrorMessage,"Heap Overflow"))
4528 res = Yap_growheap_in_parser(&old_TR, &tokstart, &Yap_VarTable);
4529 else
4530 res = Yap_growtrail_in_parser(&old_TR, &tokstart, &Yap_VarTable);
4531 if (res) {
4532 ScannerStack = (char *)TR;
4533 TR = old_TR;
4534 old_H = H;
4535 Yap_tokptr = Yap_toktide = tokstart;
4536 Yap_ErrorMessage = NULL;
4537 goto repeat_cycle;
4538 }
4539 ScannerStack = (char *)TR;
4540 TR = old_TR;
4541 }
4542 }
4543 if (ParserErrorStyle == QUIET_ON_PARSER_ERROR) {
4544 /* just fail */
4545 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
4546 return FALSE;
4547 } else if (ParserErrorStyle == CONTINUE_ON_PARSER_ERROR) {
4548 Yap_ErrorMessage = NULL;
4549 /* try again */
4550 goto repeat_cycle;
4551 } else {
4552 Term terr = syntax_error(tokstart, inp_stream, &ARG2);
4553 if (Yap_ErrorMessage == NULL)
4554 Yap_ErrorMessage = "SYNTAX ERROR";
4555
4556 if (ParserErrorStyle == EXCEPTION_ON_PARSER_ERROR) {
4557 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
4558 Yap_Error(SYNTAX_ERROR,terr,Yap_ErrorMessage);
4559 return FALSE;
4560 } else /* FAIL ON PARSER ERROR */ {
4561 Term t[2];
4562 t[0] = terr;
4563 t[1] = MkAtomTerm(Yap_LookupAtom(Yap_ErrorMessage));
4564 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
4565 return Yap_unify(ARG6,Yap_MkApplTerm(Yap_MkFunctor(AtomError,2),2,t));
4566 }
4567 }
4568 } else {
4569 CurrentModule = OCurrentModule;
4570 /* parsing succeeded */
4571 break;
4572 }
4573 }
4574 #if EMACS
4575 first_char = tokstart->TokPos;
4576 #endif /* EMACS */
4577 if (!Yap_unify(t, ARG2))
4578 return FALSE;
4579 if (AtomOfTerm (Deref (ARG1)) == AtomTrue) {
4580 while (TRUE) {
4581 CELL *old_H = H;
4582
4583 if (setjmp(Yap_IOBotch) == 0) {
4584 v = Yap_VarNames(Yap_VarTable, TermNil);
4585 break;
4586 } else {
4587 tr_fr_ptr old_TR;
4588 restore_machine_regs();
4589
4590 old_TR = TR;
4591 /* restart global */
4592 H = old_H;
4593 TR = (tr_fr_ptr)ScannerStack;
4594 Yap_growstack_in_parser(&old_TR, &tokstart, &Yap_VarTable);
4595 ScannerStack = (char *)TR;
4596 TR = old_TR;
4597 }
4598 }
4599 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
4600 return Yap_unify (v, ARG4);
4601 } else {
4602 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
4603 return TRUE;
4604 }
4605 }
4606
4607 static Int
4608 p_read (void)
4609 { /* '$read'(+Flag,?Term,?Module,?Vars,-Pos,-Err) */
4610 return do_read(Yap_c_input_stream, 6);
4611 }
4612
4613 static Int
4614 p_read2 (void)
4615 { /* '$read2'(+Flag,?Term,?Module,?Vars,-Pos,-Err,+Stream) */
4616 int inp_stream;
4617 Int out;
4618
4619 /* needs to change Yap_c_output_stream for write */
4620 inp_stream = CheckStream (ARG7, Input_Stream_f, "read/3");
4621 if (inp_stream == -1) {
4622 return(FALSE);
4623 }
4624 UNLOCK(Stream[inp_stream].streamlock);
4625 out = do_read(inp_stream, 7);
4626 return out;
4627 }
4628
4629 static Int
4630 p_user_file_name (void)
4631 {
4632 Term tout;
4633 int sno = CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f,"user_file_name/2");
4634 if (sno < 0)
4635 return (FALSE);
4636 #if USE_SOCKET
4637 if (Stream[sno].status & Socket_Stream_f)
4638 tout = MkAtomTerm(AtomSocket);
4639 else
4640 #endif
4641 if (Stream[sno].status & Pipe_Stream_f)
4642 tout = MkAtomTerm(AtomPipe);
4643 else if (Stream[sno].status & InMemory_Stream_f)
4644 tout = MkAtomTerm(AtomCharsio);
4645 else
4646 tout = Stream[sno].u.file.user_name;
4647 UNLOCK(Stream[sno].streamlock);
4648 return (Yap_unify_constant (ARG2, tout));
4649 }
4650
4651 static Int
4652 p_file_name (void)
4653 {
4654 Term tout;
4655 int sno = CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f,"file_name/2");
4656 if (sno < 0)
4657 return (FALSE);
4658 #if USE_SOCKET
4659 if (Stream[sno].status & Socket_Stream_f)
4660 tout = MkAtomTerm(AtomSocket);
4661 else
4662 #endif
4663 if (Stream[sno].status & Pipe_Stream_f)
4664 tout = MkAtomTerm(AtomPipe);
4665 else if (Stream[sno].status & InMemory_Stream_f)
4666 tout = MkAtomTerm(AtomCharsio);
4667 else
4668 tout = MkAtomTerm(Stream[sno].u.file.name);
4669 UNLOCK(Stream[sno].streamlock);
4670 return Yap_unify_constant (ARG2, tout);
4671 }
4672
4673 static Int
4674 p_cur_line_no (void)
4675 { /* '$current_line_number'(+Stream,-N) */
4676 Term tout;
4677 int sno =
4678 CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f,"current_line_number/2");
4679 if (sno < 0)
4680 return (FALSE);
4681 /* one has to be somewhat more careful because of terminals */
4682 if (Stream[sno].status & Tty_Stream_f)
4683 {
4684 Int no = 1;
4685 int i;
4686 Atom my_stream;
4687 #if USE_SOCKET
4688 if (Stream[sno].status & Socket_Stream_f)
4689 my_stream = AtomSocket;
4690 else
4691 #endif
4692 if (Stream[sno].status & Pipe_Stream_f)
4693 my_stream = AtomPipe;
4694 else
4695 if (Stream[sno].status & InMemory_Stream_f)
4696 my_stream = AtomCharsio;
4697 else
4698 my_stream = Stream[sno].u.file.name;
4699 for (i = 0; i < MaxStreams; i++)
4700 {
4701 if (!(Stream[i].status & (Free_Stream_f|Socket_Stream_f|Pipe_Stream_f|InMemory_Stream_f)) &&
4702 Stream[i].u.file.name == my_stream)
4703 no += Stream[i].linecount - 1;
4704 }
4705 tout = MkIntTerm (no);
4706 }
4707 else
4708 tout = MkIntTerm (Stream[sno].linecount);
4709 UNLOCK(Stream[sno].streamlock);
4710 return (Yap_unify_constant (ARG2, tout));
4711 }
4712
4713 static Int
4714 p_line_position (void)
4715 { /* '$line_position'(+Stream,-N) */
4716 Term tout;
4717 int sno = CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f, "line_position/2");
4718 if (sno < 0)
4719 return (FALSE);
4720 if (Stream[sno].status & Tty_Stream_f)
4721 {
4722 Int no = 0;
4723 int i;
4724 Atom my_stream = Stream[sno].u.file.name;
4725 for (i = 0; i < MaxStreams; i++)
4726 {
4727 if (!(Stream[i].status & Free_Stream_f) &&
4728 Stream[i].u.file.name == my_stream)
4729 no += Stream[i].linepos;
4730 }
4731 tout = MkIntTerm (no);
4732 }
4733 else
4734 tout = MkIntTerm (Stream[sno].linepos);
4735 UNLOCK(Stream[sno].streamlock);
4736 return (Yap_unify_constant (ARG2, tout));
4737 }
4738
4739 static Int
4740 p_character_count (void)
4741 { /* '$character_count'(+Stream,-N) */
4742 Term tout;
4743 int sno = CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f, "character_count/2");
4744 if (sno < 0)
4745 return (FALSE);
4746 if (Stream[sno].status & Tty_Stream_f)
4747 {
4748 Int no = 0;
4749 int i;
4750 Atom my_stream = Stream[sno].u.file.name;
4751 for (i = 0; i < MaxStreams; i++)
4752 {
4753 if (!(Stream[i].status & Free_Stream_f) &&
4754 Stream[i].u.file.name == my_stream)
4755 no += Stream[i].charcount;
4756 }
4757 tout = MkIntTerm (no);
4758 }
4759 else if (Stream[sno].status & Null_Stream_f)
4760 tout = MkIntTerm (Stream[sno].charcount);
4761 else
4762 tout = MkIntTerm (YP_ftell (Stream[sno].u.file.file));
4763 UNLOCK(Stream[sno].streamlock);
4764 return (Yap_unify_constant (ARG2, tout));
4765 }
4766
4767 static Int
4768 p_show_stream_flags(void)
4769 { /* '$show_stream_flags'(+Stream,Pos) */
4770 Term tout;
4771 int sno =
4772 CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f, "stream_property/2");
4773 if (sno < 0)
4774 return (FALSE);
4775 tout = MkIntTerm(Stream[sno].status);
4776 UNLOCK(Stream[sno].streamlock);
4777 return (Yap_unify (ARG2, tout));
4778 }
4779
4780 static Term
4781 StreamPosition(int sno)
4782 {
4783 Term sargs[5];
4784 Int cpos;
4785 cpos = Stream[sno].charcount;
4786 if (Stream[sno].status & SWI_Stream_f) {
4787 return Yap_get_stream_position(Stream[sno].u.swi_stream.swi_ptr);
4788 }
4789 if (Stream[sno].stream_getc == PlUnGetc) {
4790 cpos--;
4791 }
4792 sargs[0] = MkIntegerTerm (cpos);
4793 sargs[1] = MkIntegerTerm (StartLine = Stream[sno].linecount);
4794 sargs[2] = MkIntegerTerm (Stream[sno].linepos);
4795 sargs[3] = sargs[4] = MkIntTerm (0);
4796 return Yap_MkApplTerm (FunctorStreamPos, 5, sargs);
4797 }
4798
4799
4800 Term
4801 Yap_StreamPosition(int sno)
4802 {
4803 return StreamPosition(sno);
4804 }
4805
4806 static Int
4807 p_show_stream_position (void)
4808 { /* '$show_stream_position'(+Stream,Pos) */
4809 Term tout;
4810 int sno =
4811 CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f, "stream_position/2");
4812 if (sno < 0)
4813 return (FALSE);
4814 tout = StreamPosition(sno);
4815 UNLOCK(Stream[sno].streamlock);
4816 return Yap_unify (ARG2, tout);
4817 }
4818
4819 static Int
4820 p_set_stream_position (void)
4821 { /* '$set_stream_position'(+Stream,Pos) */
4822 Term tin, tp;
4823 Int char_pos;
4824 int sno = CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f, "set_stream_position/2");
4825 if (sno < 0) {
4826 return (FALSE);
4827 }
4828 tin = Deref (ARG2);
4829 if (IsVarTerm (tin)) {
4830 UNLOCK(Stream[sno].streamlock);
4831 Yap_Error(INSTANTIATION_ERROR, tin, "set_stream_position/2");
4832 return (FALSE);
4833 } else if (!(IsApplTerm (tin))) {
4834 UNLOCK(Stream[sno].streamlock);
4835 Yap_Error(DOMAIN_ERROR_STREAM_POSITION, tin, "set_stream_position/2");
4836 return (FALSE);
4837 }
4838 if (FunctorOfTerm (tin) == FunctorStreamPos) {
4839 if (IsVarTerm (tp = ArgOfTerm (1, tin))) {
4840 UNLOCK(Stream[sno].streamlock);
4841 Yap_Error(INSTANTIATION_ERROR, tp, "set_stream_position/2");
4842 return (FALSE);
4843 } else if (!IsIntTerm (tp)) {
4844 UNLOCK(Stream[sno].streamlock);
4845 Yap_Error(DOMAIN_ERROR_STREAM_POSITION, tin, "set_stream_position/2");
4846 return (FALSE);
4847 }
4848 if (!(Stream[sno].status & Seekable_Stream_f) ) {
4849 UNLOCK(Stream[sno].streamlock);
4850 Yap_Error(PERMISSION_ERROR_REPOSITION_STREAM, ARG1,"set_stream_position/2");
4851 return(FALSE);
4852 }
4853 char_pos = IntOfTerm (tp);
4854 if (IsVarTerm (tp = ArgOfTerm (2, tin))) {
4855 UNLOCK(Stream[sno].streamlock);
4856 Yap_Error(INSTANTIATION_ERROR, tp, "set_stream_position/2");
4857 return (FALSE);
4858 } else if (!IsIntTerm (tp)) {
4859 UNLOCK(Stream[sno].streamlock);
4860 Yap_Error(DOMAIN_ERROR_STREAM_POSITION, tin, "set_stream_position/2");
4861 return (FALSE);
4862 }
4863 Stream[sno].charcount = char_pos;
4864 Stream[sno].linecount = IntOfTerm (tp);
4865 if (IsVarTerm (tp = ArgOfTerm (3, tin))) {
4866 UNLOCK(Stream[sno].streamlock);
4867 Yap_Error(INSTANTIATION_ERROR, tp, "set_stream_position/2");
4868 return (FALSE);
4869 } else if (!IsIntTerm (tp)) {
4870 UNLOCK(Stream[sno].streamlock);
4871 Yap_Error(DOMAIN_ERROR_STREAM_POSITION, tin, "set_stream_position/2");
4872 return (FALSE);
4873 }
4874 Stream[sno].linepos = IntOfTerm (tp);
4875 if (YP_fseek (Stream[sno].u.file.file, (long) (char_pos), 0) == -1) {
4876 UNLOCK(Stream[sno].streamlock);
4877 Yap_Error(SYSTEM_ERROR, tp,
4878 "fseek failed for set_stream_position/2");
4879 return(FALSE);
4880 }
4881 Stream[sno].stream_getc = PlGetc;
4882 Stream[sno].stream_gets = PlGetsFunc();
4883 } else if (FunctorOfTerm (tin) == FunctorStreamEOS) {
4884 if (IsVarTerm (tp = ArgOfTerm (1, tin))) {
4885 UNLOCK(Stream[sno].streamlock);
4886 Yap_Error(INSTANTIATION_ERROR, tp, "set_stream_position/2");
4887 return (FALSE);
4888 } else if (tp != MkAtomTerm(AtomAt)) {
4889 UNLOCK(Stream[sno].streamlock);
4890 Yap_Error(DOMAIN_ERROR_STREAM_POSITION, tin, "set_stream_position/2");
4891 return (FALSE);
4892 }
4893 if (!(Stream[sno].status & Seekable_Stream_f) ) {
4894 UNLOCK(Stream[sno].streamlock);
4895 Yap_Error(PERMISSION_ERROR_REPOSITION_STREAM, ARG1,"set_stream_position/2");
4896 return(FALSE);
4897 }
4898 if (YP_fseek (Stream[sno].u.file.file, 0L, SEEK_END) == -1) {
4899 UNLOCK(Stream[sno].streamlock);
4900 Yap_Error(SYSTEM_ERROR, tp,
4901 "fseek failed for set_stream_position/2");
4902 return(FALSE);
4903 }
4904 Stream[sno].stream_getc = PlGetc;
4905 Stream[sno].stream_gets = PlGetsFunc();
4906 /* reset the counters */
4907 Stream[sno].linepos = 0;
4908 Stream[sno].linecount = 1;
4909 Stream[sno].charcount = 0;
4910 }
4911 UNLOCK(Stream[sno].streamlock);
4912 return (TRUE);
4913 }
4914
4915 static Int
4916 p_get (void)
4917 { /* '$get'(Stream,-N) */
4918 int sno = CheckStream (ARG1, Input_Stream_f, "get/2");
4919 int ch;
4920 Int status;
4921
4922 if (sno < 0)
4923 return FALSE;
4924 status = Stream[sno].status;
4925 if (status & Binary_Stream_f) {
4926 UNLOCK(Stream[sno].streamlock);
4927 Yap_Error(PERMISSION_ERROR_INPUT_BINARY_STREAM, ARG1, "get/2");
4928 return FALSE;
4929 }
4930 UNLOCK(Stream[sno].streamlock);
4931 while ((ch = Stream[sno].stream_wgetc(sno)) <= 32 && ch >= 0);
4932 return (Yap_unify_constant (ARG2, MkIntegerTerm (ch)));
4933 }
4934
4935 static Int
4936 p_get0 (void)
4937 { /* get0(Stream,-N) */
4938 int sno = CheckStream (ARG1, Input_Stream_f, "get0/2");
4939 Int status;
4940 Int out;
4941
4942 if (sno < 0)
4943 return(FALSE);
4944 status = Stream[sno].status;
4945 if (status & Binary_Stream_f) {
4946 UNLOCK(Stream[sno].streamlock);
4947 Yap_Error(PERMISSION_ERROR_INPUT_BINARY_STREAM, ARG1, "get0/2");
4948 return FALSE;
4949 }
4950 UNLOCK(Stream[sno].streamlock);
4951 out = Stream[sno].stream_wgetc(sno);
4952 return (Yap_unify_constant (ARG2, MkIntegerTerm (out)) );
4953 }
4954
4955 static Term
4956 read_line(int sno)
4957 {
4958 Term tail;
4959 Int ch;
4960
4961 if ((ch = Stream[sno].stream_wgetc(sno)) == 10) {
4962 return(TermNil);
4963 }
4964 tail = read_line(sno);
4965 return(MkPairTerm(MkIntTerm(ch),tail));
4966 }
4967
4968 static Int
4969 p_get0_line_codes (void)
4970 { /* '$get0'(Stream,-N) */
4971 int sno = CheckStream (ARG1, Input_Stream_f, "get0/2");
4972 Int status;
4973 Term out;
4974 Int ch = '\0';
4975 int rewind;
4976
4977 if (sno < 0)
4978 return(FALSE);
4979 if (Stream[sno].stream_getc == PlUnGetc) {
4980 ch = PlUnGetc(sno);
4981 rewind = TRUE;
4982 } else {
4983 rewind = FALSE;
4984 }
4985 status = Stream[sno].status;
4986 if (status & Binary_Stream_f) {
4987 UNLOCK(Stream[sno].streamlock);
4988 Yap_Error(PERMISSION_ERROR_INPUT_BINARY_STREAM, ARG1, "get0/2");
4989 return FALSE;
4990 }
4991 UNLOCK(Stream[sno].streamlock);
4992 out = read_line(sno);
4993 if (rewind)
4994 return Yap_unify(MkPairTerm(MkIntegerTerm(ch),out), ARG2);
4995 else
4996 return Yap_unify(out,ARG2);
4997 }
4998
4999 static Int
5000 p_get_byte (void)
5001 { /* '$get_byte'(Stream,-N) */
5002 int sno = CheckStream (ARG1, Input_Stream_f, "get_byte/2");
5003 Int status;
5004 Term out;
5005
5006 if (sno < 0)
5007 return(FALSE);
5008 status = Stream[sno].status;
5009 if (!(status & Binary_Stream_f) &&
5010 yap_flags[STRICT_ISO_FLAG]) {
5011 UNLOCK(Stream[sno].streamlock);
5012 Yap_Error(PERMISSION_ERROR_INPUT_TEXT_STREAM, ARG1, "get_byte/2");
5013 return(FALSE);
5014 }
5015 out = MkIntTerm(Stream[sno].stream_getc(sno));
5016 UNLOCK(Stream[sno].streamlock);
5017 return Yap_unify_constant (ARG2, out);
5018 }
5019
5020 static Int
5021 p_put (void)
5022 { /* '$put'(Stream,N) */
5023 int sno = CheckStream (ARG1, Output_Stream_f, "put/2");
5024 if (sno < 0)
5025 return (FALSE);
5026 if (Stream[sno].status & Binary_Stream_f) {
5027 UNLOCK(Stream[sno].streamlock);
5028 Yap_Error(PERMISSION_ERROR_OUTPUT_BINARY_STREAM, ARG1, "put/2");
5029 return(FALSE);
5030 }
5031 Stream[sno].stream_wputc (sno, (int) IntegerOfTerm (Deref (ARG2)));
5032 /*
5033 * if (!(Stream[sno].status & Null_Stream_f))
5034 * yap_fflush(Stream[sno].u.file.file);
5035 */
5036 UNLOCK(Stream[sno].streamlock);
5037 return (TRUE);
5038 }
5039
5040 static Int
5041 p_put_byte (void)
5042 { /* '$put_byte'(Stream,N) */
5043 int sno = CheckStream (ARG1, Output_Stream_f, "put/2");
5044 if (sno < 0)
5045 return (FALSE);
5046 if (!(Stream[sno].status & Binary_Stream_f) &&
5047 yap_flags[STRICT_ISO_FLAG]) {
5048 UNLOCK(Stream[sno].streamlock);
5049 Yap_Error(PERMISSION_ERROR_OUTPUT_TEXT_STREAM, ARG1, "get0/2");
5050 return(FALSE);
5051 }
5052 Stream[sno].stream_putc(sno, (int) IntegerOfTerm (Deref (ARG2)));
5053 /*
5054 * if (!(Stream[sno].status & Null_Stream_f))
5055 * yap_fflush(Stream[sno].u.file.file);
5056 */
5057 UNLOCK(Stream[sno].streamlock);
5058 return (TRUE);
5059 }
5060
5061 #define FORMAT_MAX_SIZE 256
5062
5063 typedef struct {
5064 Int pos; /* tab point */
5065 char pad; /* ok, it's not standard english */
5066 } pads;
5067
5068 typedef struct format_status {
5069 int format_error;
5070 char *format_ptr, *format_base, *format_max;
5071 int format_buf_size;
5072 pads pad_entries[16], *pad_max;
5073 } format_info;
5074
5075 static int
5076 format_putc(int sno, wchar_t ch) {
5077 if (FormatInfo->format_buf_size == -1)
5078 return EOF;
5079 if (ch == 10) {
5080 char *ptr = FormatInfo->format_base;
5081 #if MAC || _MSC_VER
5082 ch = '\n';
5083 #endif
5084 for (ptr = FormatInfo->format_base; ptr < FormatInfo->format_ptr; ptr++) {
5085 Stream[sno].stream_putc(sno, *ptr);
5086 }
5087 /* reset line */
5088 FormatInfo->format_ptr = FormatInfo->format_base;
5089 FormatInfo->pad_max = FormatInfo->pad_entries;
5090 Stream[sno].stream_putc(sno, '\n');
5091 return((int)10);
5092 } else {
5093 *FormatInfo->format_ptr++ = (char)ch;
5094 if (FormatInfo->format_ptr == FormatInfo->format_max) {
5095 /* oops, we have reached an overflow */
5096 Int new_max_size = FormatInfo->format_buf_size + FORMAT_MAX_SIZE;
5097 char *newbuf;
5098
5099 if ((newbuf = Yap_AllocAtomSpace(new_max_size*sizeof(char))) == NULL) {
5100 FormatInfo->format_buf_size = -1;
5101 Yap_Error(SYSTEM_ERROR, TermNil, "YAP could not grow heap for format/2");
5102 return(EOF);
5103 }
5104 #if HAVE_MEMMOVE
5105 memmove((void *)newbuf, (void *)FormatInfo->format_base, (size_t)((FormatInfo->format_ptr-FormatInfo->format_base)*sizeof(char)));
5106 #else
5107 {
5108 Int n = FormatInfo->format_ptr-FormatInfo->format_base;
5109 char *to = newbuf;
5110 char *from = FormatInfo->format_base;
5111 while (n-- >= 0) {
5112 *to++ = *from++;
5113 }
5114 }
5115 #endif
5116 Yap_FreeAtomSpace(FormatInfo->format_base);
5117 FormatInfo->format_ptr = newbuf+(FormatInfo->format_ptr-FormatInfo->format_base);
5118 FormatInfo->format_base = newbuf;
5119 FormatInfo->format_max = newbuf+new_max_size;
5120 FormatInfo->format_buf_size = new_max_size;
5121 if (ActiveSignals & YAP_CDOVF_SIGNAL) {
5122 if (!Yap_growheap(FALSE, 0, NULL)) {
5123 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "YAP failed to grow heap at format");
5124 }
5125 }
5126 }
5127 }
5128 return ((int) ch);
5129 }
5130
5131 static void fill_pads(int nchars)
5132 {
5133 int nfillers, fill_space, lfill_space;
5134
5135 if (nchars <= 0) return; /* ignore */
5136 nfillers = FormatInfo->pad_max-FormatInfo->pad_entries;
5137 if (nfillers == 0) {
5138 /* OK, just pad with spaces */
5139 while (nchars--) {
5140 *FormatInfo->format_ptr++ = ' ';
5141 }
5142 return;
5143 }
5144 fill_space = nchars/nfillers;
5145 lfill_space = nchars%nfillers;
5146
5147 if (fill_space) {
5148 pads *padi = FormatInfo->pad_max;
5149
5150 while (padi > FormatInfo->pad_entries) {
5151 char *start_pos;
5152 int n, i;
5153 padi--;
5154 start_pos = FormatInfo->format_base+padi->pos;
5155 n = FormatInfo->format_ptr-start_pos;
5156
5157 #if HAVE_MEMMOVE
5158 memmove((void *)(start_pos+fill_space), (void *)start_pos, (size_t)(n*sizeof(char)));
5159 #else
5160 {
5161 char *to = start_pos+(fill_space+n);
5162 char *from = FormatInfo->format_ptr;
5163
5164 while (n-- > 0) {
5165 *--to = *--from;
5166 }
5167 }
5168 #endif
5169 FormatInfo->format_ptr += fill_space;
5170 for (i = 0; i < fill_space; i++) {
5171 *start_pos++ = padi->pad;
5172 }
5173 }
5174 }
5175 while (lfill_space--) {
5176 *FormatInfo->format_ptr++ = FormatInfo->pad_max[-1].pad;
5177 }
5178 }
5179
5180 static int
5181 format_print_str (Int sno, Int size, Int has_size, Term args, int (* f_putc)(int, wchar_t))
5182 {
5183 Term arghd;
5184 while (!has_size || size > 0) {
5185 if (IsVarTerm(args)) {
5186 Yap_Error(INSTANTIATION_ERROR, args, "format/2");
5187 return FALSE;
5188 } else if (args == TermNil) {
5189 return TRUE;
5190 }
5191 else if (!IsPairTerm (args)) {
5192 Yap_Error(TYPE_ERROR_LIST, args, "format/2");
5193 return FALSE;
5194 }
5195 arghd = HeadOfTerm (args);
5196 args = TailOfTerm (args);
5197 if (IsVarTerm(arghd)) {
5198 Yap_Error(INSTANTIATION_ERROR, arghd, "format/2");
5199 return FALSE;
5200 } else if (!IsIntTerm (arghd)) {
5201 Yap_Error(TYPE_ERROR_LIST, arghd, "format/2");
5202 return FALSE;
5203 }
5204 f_putc(sno, (int) IntOfTerm (arghd));
5205 size--;
5206 }
5207 return TRUE;
5208 }
5209
5210 typedef enum {
5211 fst_ok,
5212 fst_error,
5213 fst_too_long
5214 } format_cp_res;
5215
5216 static format_cp_res
5217 copy_format_string(Term inp, char *out, int max)
5218 {
5219 int i = 0;
5220 while (inp != TermNil) {
5221 Term hd;
5222 int ch;
5223
5224 if (IsVarTerm(inp)) {
5225 Yap_Error(INSTANTIATION_ERROR,inp,"format/2");
5226 return fst_error;
5227 }
5228 if (!IsPairTerm(inp)) {
5229 Yap_Error(TYPE_ERROR_LIST,inp,"format/2");
5230 return fst_error;
5231 }
5232 hd = HeadOfTerm(inp);
5233 if (IsVarTerm(hd)) {
5234 Yap_Error(INSTANTIATION_ERROR,hd,"format/2");
5235 return fst_error;
5236 }
5237 if (!IsIntTerm(hd)) {
5238 Yap_Error(TYPE_ERROR_INTEGER,hd,"format/2");
5239 return fst_error;
5240 }
5241 ch = IntOfTerm(hd);
5242 if (ch < 0) {
5243 Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,hd,"format/2");
5244 return fst_error;
5245 }
5246 if (i+1 == max) {
5247 return fst_too_long;
5248 }
5249 /* we've got a character */
5250 out[i++] = ch;
5251 /* done */
5252 inp = TailOfTerm(inp);
5253 }
5254 out[i] = '\0';
5255 return fst_ok;
5256 }
5257
5258 #define FORMAT_COPY_ARGS_ERROR -1
5259 #define FORMAT_COPY_ARGS_OVERFLOW -2
5260
5261 static Int
5262 format_copy_args(Term args, Term *targs, Int tsz)
5263 {
5264 Int n = 0;
5265 while (args != TermNil) {
5266 if (IsVarTerm(args)) {
5267 Yap_Error(INSTANTIATION_ERROR,args,"format/2");
5268 return FORMAT_COPY_ARGS_ERROR;
5269 }
5270 if (!IsPairTerm(args)) {
5271 Yap_Error(TYPE_ERROR_LIST,args,"format/2");
5272 return FORMAT_COPY_ARGS_ERROR;
5273 }
5274 if (n == tsz)
5275 return FORMAT_COPY_ARGS_OVERFLOW;
5276 targs[n] = HeadOfTerm(args);
5277 args = TailOfTerm(args);
5278 n++;
5279 }
5280 return n;
5281
5282 }
5283
5284 static void
5285 format_clean_up(char *format_base, char *fstr, Term *targs)
5286 {
5287 if (format_base)
5288 Yap_FreeAtomSpace(format_base);
5289 if (fstr)
5290 Yap_FreeAtomSpace(fstr);
5291 if (targs)
5292 Yap_FreeAtomSpace((char *)targs);
5293 }
5294
5295 static Int
5296 fetch_index_from_args(Term t)
5297 {
5298 Int i;
5299
5300 if (IsVarTerm(t))
5301 return -1;
5302 if (!IsIntegerTerm(t))
5303 return -1;
5304 i = IntegerOfTerm(t);
5305 if (i < 0)
5306 return -1;
5307 return i;
5308 }
5309
5310 static int
5311 format_has_tabs(const char *seq)
5312 {
5313 int ch;
5314
5315 while ((ch = *seq++)) {
5316 if (ch == '~') {
5317 ch = *seq++;
5318 if (ch == 'p' || ch == '@') {
5319 return TRUE;
5320 }
5321 if (ch == '*') {
5322 ch = *seq++;
5323 } else {
5324 while (ch >= '0' && ch <= '9') ch = *seq++;
5325 }
5326 if (ch == 't' || ch == '|' || ch == '+') {
5327 return TRUE;
5328 }
5329 if (!ch)
5330 return FALSE;
5331 }
5332 }
5333 return FALSE;
5334 }
5335
5336 static wchar_t
5337 base_dig(Int dig, Int ch)
5338 {
5339 if (dig < 10)
5340 return dig+'0';
5341 else if (ch == 'r')
5342 return (dig-10)+'a';
5343 else /* ch == 'R' */
5344 return (dig-10)+'A';
5345 }
5346
5347 #define TMP_STRING_SIZE 1024
5348
5349 static Int
5350 format(volatile Term otail, volatile Term oargs, int sno)
5351 {
5352 char tmp1[TMP_STRING_SIZE], *tmpbase;
5353 int ch;
5354 int column_boundary;
5355 Term mytargs[8], *targs;
5356 Int tnum, targ;
5357 char *fstr = NULL, *fptr;
5358 Term args;
5359 Term tail;
5360 int (* f_putc)(int, wchar_t);
5361 int has_tabs;
5362 jmp_buf format_botch;
5363 volatile void *old_handler;
5364 volatile int old_pos;
5365 format_info finfo;
5366 Term fmod = CurrentModule;
5367
5368
5369 FormatInfo = &finfo;
5370 finfo.pad_max = finfo.pad_entries;
5371 finfo.format_error = FALSE;
5372 if (Stream[sno].status & InMemory_Stream_f) {
5373 old_handler = Stream[sno].u.mem_string.error_handler;
5374 Stream[sno].u.mem_string.error_handler = (void *)&format_botch;
5375 old_pos = Stream[sno].u.mem_string.pos;
5376 /* set up an error handler */
5377 if (setjmp(format_botch)) {
5378 restore_machine_regs();
5379 *H++ = oargs;
5380 *H++ = otail;
5381 if (!Yap_growheap(FALSE, Yap_Error_Size, NULL)) {
5382 Yap_Error(OUT_OF_HEAP_ERROR,otail,"format/2");
5383 return FALSE;
5384 }
5385 oargs = H[-2];
5386 otail = H[-1];
5387 Stream[sno].u.mem_string.pos = old_pos;
5388 H -= 2;
5389 }
5390 } else {
5391 old_handler = NULL;
5392 }
5393 args = oargs;
5394 tail = otail;
5395 targ = 0;
5396 column_boundary = 0;
5397 if (IsVarTerm(tail)) {
5398 Yap_Error(INSTANTIATION_ERROR,tail,"format/2");
5399 return(FALSE);
5400 } else if (IsPairTerm (tail)) {
5401 int sz = 256;
5402 do {
5403 format_cp_res fr;
5404
5405 fstr = fptr = Yap_AllocAtomSpace(sz*sizeof(char));
5406 if ((fr = copy_format_string(tail, fstr, sz)) == fst_ok)
5407 break;
5408 if (fr == fst_error) return FALSE;
5409 sz += 256;
5410 Yap_FreeCodeSpace(fstr);
5411 } while (TRUE);
5412 } else if (IsAtomTerm(tail)) {
5413 fstr = fptr = RepAtom(AtomOfTerm(tail))->StrOfAE;
5414 } else {
5415 Yap_Error(CONSISTENCY_ERROR, tail, "format/2");
5416 return FALSE;
5417 }
5418 if (IsVarTerm(args)) {
5419 Yap_Error(INSTANTIATION_ERROR, args, "format/2");
5420 return FALSE;
5421 }
5422 while (IsApplTerm(args) && FunctorOfTerm(args) == FunctorModule) {
5423 fmod = ArgOfTerm(1,args);
5424 args = ArgOfTerm(2,args);
5425 if (IsVarTerm(fmod)) {
5426 Yap_Error(INSTANTIATION_ERROR, fmod, "format/2");
5427 return FALSE;
5428 }
5429 if (!IsAtomTerm(fmod)) {
5430 Yap_Error(TYPE_ERROR_ATOM, fmod, "format/2");
5431 return FALSE;
5432 }
5433 if (IsVarTerm(args)) {
5434 Yap_Error(INSTANTIATION_ERROR, args, "format/2");
5435 return FALSE;
5436 }
5437 }
5438 if (IsPairTerm(args)) {
5439 Int tsz = 8;
5440
5441 targs = mytargs;
5442 do {
5443 tnum = format_copy_args(args, targs, tsz);
5444 if (tnum == FORMAT_COPY_ARGS_ERROR)
5445 return FALSE;
5446 else if (tnum == FORMAT_COPY_ARGS_OVERFLOW) {
5447 if (mytargs != targs) {
5448 Yap_FreeCodeSpace((char *)targs);
5449 }
5450 tsz += 16;
5451 targs = (Term *)Yap_AllocAtomSpace(tsz*sizeof(Term));
5452 } else {
5453 break;
5454 }
5455 } while (TRUE);
5456 } else if (args != TermNil) {
5457 tnum = 1;
5458 mytargs[0] = args;
5459 targs = mytargs;
5460 } else {
5461 tnum = 0;
5462 targs = mytargs;
5463 }
5464 finfo.format_error = FALSE;
5465
5466 if ((has_tabs = format_has_tabs(fptr))) {
5467 finfo.format_base = finfo.format_ptr = Yap_AllocAtomSpace(FORMAT_MAX_SIZE*sizeof(char));
5468 finfo.format_max = finfo.format_base+FORMAT_MAX_SIZE;
5469 if (finfo.format_ptr == NULL) {
5470 Yap_Error(INSTANTIATION_ERROR,tail,"format/2");
5471 return(FALSE);
5472 }
5473 finfo.format_buf_size = FORMAT_MAX_SIZE;
5474 f_putc = format_putc;
5475 } else {
5476 f_putc = Stream[sno].stream_wputc;
5477 finfo.format_base = NULL;
5478 }
5479 while ((ch = *fptr++)) {
5480 Term t = TermNil;
5481 int has_repeats = FALSE;
5482 int repeats = 0;
5483
5484 if (ch == '~') {
5485 /* start command */
5486 ch = *fptr++;
5487 if (ch == '*') {
5488 ch = *fptr++;
5489 has_repeats = TRUE;
5490 if (targ > tnum-1) {
5491 goto do_consistency_error;
5492 }
5493 repeats = fetch_index_from_args(targs[targ++]);
5494 if (repeats == -1)
5495 goto do_consistency_error;
5496 } else if (ch == '`') {
5497 /* next character is kept as code */
5498 has_repeats = TRUE;
5499 repeats = *fptr++;
5500 ch = *fptr++;
5501 } else if (ch >= '0' && ch <= '9') {
5502 has_repeats = TRUE;
5503 repeats = 0;
5504 while (ch >= '0' && ch <= '9') {
5505 repeats = repeats*10+(ch-'0');
5506 ch = *fptr++;
5507 }
5508 }
5509 switch (ch) {
5510 case 'a':
5511 /* print an atom */
5512 if (has_repeats || targ > tnum-1)
5513 goto do_consistency_error;
5514 t = targs[targ++];
5515 if (IsVarTerm(t))
5516 goto do_instantiation_error;
5517 if (!IsAtomTerm(t))
5518 goto do_type_atom_error;
5519 Yap_StartSlots();
5520 Yap_plwrite (t, f_putc, Handle_vars_f|To_heap_f, 1200);
5521 Yap_CloseSlots();
5522 FormatInfo = &finfo;
5523 break;
5524 case 'c':
5525 {
5526 Int nch, i;
5527
5528 if (targ > tnum-1)
5529 goto do_consistency_error;
5530 t = targs[targ++];
5531 if (IsVarTerm(t))
5532 goto do_instantiation_error;
5533 if (!IsIntegerTerm(t))
5534 goto do_type_int_error;
5535 nch = IntegerOfTerm(t);
5536 if (nch < 0)
5537 goto do_domain_not_less_zero_error;
5538 if (!has_repeats)
5539 repeats = 1;
5540 for (i = 0; i < repeats; i++)
5541 f_putc(sno, nch);
5542 break;
5543 }
5544 case 'e':
5545 case 'E':
5546 case 'f':
5547 case 'g':
5548 case 'G':
5549 {
5550 Float fl;
5551 char *ptr;
5552
5553 if (targ > tnum-1)
5554 goto do_consistency_error;
5555 t = targs[targ++];
5556 if (IsVarTerm(t))
5557 goto do_instantiation_error;
5558 if (!IsNumTerm(t))
5559 goto do_type_number_error;
5560 if (IsIntegerTerm(t)) {
5561 fl = (Float)IntegerOfTerm(t);
5562 #ifdef USE_GMP
5563 } else if (IsBigIntTerm(t)) {
5564 fl = Yap_gmp_to_float(t);
5565 #endif
5566 } else {
5567 fl = FloatOfTerm(t);
5568 }
5569 if (!has_repeats)
5570 repeats = 6;
5571 tmp1[0] = '%';
5572 tmp1[1] = '.';
5573 ptr = tmp1+2;
5574 #if HAVE_SNPRINTF
5575 snprintf(ptr,256-5,"%d",repeats);
5576 #else
5577 sprintf(ptr,"%d",repeats);
5578 #endif
5579 while (*ptr) ptr++;
5580 ptr[0] = ch;
5581 ptr[1] = '\0';
5582 {
5583 char *tmp2;
5584 if (!(tmp2 = Yap_AllocCodeSpace(repeats+10)))
5585 goto do_type_int_error;
5586 #if HAVE_SNPRINTF
5587 snprintf (tmp2, repeats+10, tmp1, fl);
5588 #else
5589 sprintf (tmp2, tmp1, fl);
5590 #endif
5591 ptr = tmp2;
5592 while ((ch = *ptr++) != 0)
5593 f_putc(sno, ch);
5594 Yap_FreeCodeSpace(tmp2);
5595 }
5596 break;
5597 case 'd':
5598 case 'D':
5599 /* print a decimal, using weird . stuff */
5600 if (targ > tnum-1)
5601 goto do_consistency_error;
5602 t = targs[targ++];
5603 if (IsVarTerm(t))
5604 goto do_instantiation_error;
5605 if (!IsIntegerTerm(t)
5606 #ifdef USE_GMP
5607 && !IsBigIntTerm(t)
5608 #endif
5609
5610 )
5611 goto do_type_int_error;
5612
5613 {
5614 Int siz = 0;
5615 char *ptr = tmp1;
5616 tmpbase = tmp1;
5617
5618 if (IsIntegerTerm(t)) {
5619 Int il = IntegerOfTerm(t);
5620 #if HAVE_SNPRINTF
5621 snprintf(tmp1, 256, "%ld", (long int)il);
5622 #else
5623 sprintf(tmp1, "%ld", (long int)il);
5624 #endif
5625 siz = strlen(tmp1);
5626 if (il < 0) siz--;
5627 #ifdef USE_GMP
5628 } else if (IsBigIntTerm(t) && RepAppl(t)[1] == BIG_INT) {
5629 char *res;
5630
5631 tmpbase = tmp1;
5632
5633 while (!(res = Yap_gmp_to_string(t, tmpbase, TMP_STRING_SIZE, 10))) {
5634 if (tmpbase == tmp1) {
5635 tmpbase = NULL;
5636 } else {
5637 tmpbase = res;
5638 goto do_type_int_error;
5639 }
5640 }
5641 tmpbase = res;
5642 ptr = tmpbase;
5643 #endif
5644 siz = strlen(tmpbase);
5645 } else {
5646 goto do_type_int_error;
5647 }
5648
5649 if (tmpbase[0] == '-') {
5650 f_putc(sno, (int) '-');
5651 ptr++;
5652 }
5653 if (ch == 'D') {
5654 int first = TRUE;
5655
5656 while (siz > repeats) {
5657 if ((siz-repeats) % 3 == 0 &&
5658 !first) {
5659 f_putc(sno, (int) ',');
5660 }
5661 f_putc(sno, (int) (*ptr++));
5662 first = FALSE;
5663 siz--;
5664 }
5665 } else {
5666 while (siz > repeats) {
5667 f_putc(sno, (int) (*ptr++));
5668 siz--;
5669 }
5670 }
5671 if (repeats) {
5672 if (ptr == tmpbase ||
5673 ptr[-1] == '-') {
5674 f_putc(sno, (int) '0');
5675 }
5676 f_putc(sno, (int) '.');
5677 while (repeats > siz) {
5678 f_putc(sno, (int) '0');
5679 repeats--;
5680 }
5681 while (repeats) {
5682 f_putc(sno, (int) (*ptr++));
5683 repeats--;
5684 }
5685 }
5686 if (tmpbase != tmp1)
5687 free(tmpbase);
5688 break;
5689 case 'r':
5690 case 'R':
5691 {
5692 Int numb, radix;
5693 UInt divfactor = 1, size = 1, i;
5694 wchar_t och;
5695
5696 /* print a decimal, using weird . stuff */
5697 if (targ > tnum-1)
5698 goto do_consistency_error;
5699 t = targs[targ++];
5700 if (IsVarTerm(t))
5701 goto do_instantiation_error;
5702 if (!has_repeats)
5703 radix = 8;
5704 else
5705 radix = repeats;
5706 if (radix > 36 || radix < 2)
5707 goto do_domain_error_radix;
5708 #ifdef USE_GMP
5709 if (IsBigIntTerm(t) && RepAppl(t)[1] == BIG_INT) {
5710 char *pt, *res;
5711
5712 tmpbase = tmp1;
5713 while (!(res = Yap_gmp_to_string(t, tmpbase, TMP_STRING_SIZE, radix))) {
5714 if (tmpbase == tmp1) {
5715 tmpbase = NULL;
5716 } else {
5717 tmpbase = res;
5718 goto do_type_int_error;
5719 }
5720 }
5721 tmpbase = res;
5722 pt = tmpbase;
5723 while ((ch = *pt++))
5724 f_putc(sno, ch);
5725 if (tmpbase != tmp1)
5726 free(tmpbase);
5727 break;
5728 }
5729 #endif
5730 if (!IsIntegerTerm(t))
5731 goto do_type_int_error;
5732 numb = IntegerOfTerm(t);
5733 if (numb < 0) {
5734 numb = -numb;
5735 f_putc(sno, (int) '-');
5736 }
5737 while (numb/divfactor >= radix) {
5738 divfactor *= radix;
5739 size++;
5740 }
5741 for (i = 1; i < size; i++) {
5742 Int dig = numb/divfactor;
5743 och = base_dig(dig, ch);
5744 f_putc(sno, och);
5745 numb %= divfactor;
5746 divfactor /= radix;
5747 }
5748 och = base_dig(numb, ch);
5749 f_putc(sno, och);
5750 break;
5751 }
5752 case 's':
5753 if (targ > tnum-1)
5754 goto do_consistency_error;
5755 t = targs[targ++];
5756 if (!format_print_str (sno, repeats, has_repeats, t, f_putc)) {
5757 goto do_default_error;
5758 }
5759 break;
5760 case 'i':
5761 if (targ > tnum-1 || has_repeats)
5762 goto do_consistency_error;
5763 targ++;
5764 break;
5765 case 'k':
5766 if (targ > tnum-1 || has_repeats)
5767 goto do_consistency_error;
5768 t = targs[targ++];
5769 Yap_StartSlots();
5770 Yap_plwrite (t, f_putc, Quote_illegal_f|Ignore_ops_f|To_heap_f , 1200);
5771 Yap_CloseSlots();
5772 FormatInfo = &finfo;
5773 break;
5774 case '@':
5775 t = targs[targ++];
5776 Yap_StartSlots();
5777 {
5778 Int sl = Yap_InitSlot(args);
5779 Int sl2;
5780 Int res;
5781 Term ta[2];
5782 Term ts;
5783
5784 ta[0] = fmod;
5785 ta[1] = t;
5786 ta[0] = Yap_MkApplTerm(FunctorModule, 2, ta);
5787 ta[1] = MkVarTerm();
5788 sl2 = Yap_InitSlot(ta[1]);
5789 ts = Yap_MkApplTerm(FunctorGFormatAt, 2, ta);
5790 res = Yap_execute_goal(ts, 0, CurrentModule);
5791 FormatInfo = &finfo;
5792 args = Yap_GetFromSlot(sl);
5793 if (EX) goto ex_handler;
5794 if (!res) return FALSE;
5795 ts = Yap_GetFromSlot(sl2);
5796 Yap_RecoverSlots(2);
5797 if (!format_print_str (sno, repeats, has_repeats, ts, f_putc)) {
5798 goto do_default_error;
5799 }
5800 }
5801 Yap_CloseSlots();
5802 break;
5803 case 'p':
5804 if (targ > tnum-1 || has_repeats)
5805 goto do_consistency_error;
5806 t = targs[targ++];
5807 Yap_StartSlots();
5808 {
5809 Int sl = Yap_InitSlot(args);
5810 Yap_plwrite(t, f_putc, Handle_vars_f|Use_portray_f|To_heap_f, 1200);
5811 FormatInfo = &finfo;
5812 args = Yap_GetFromSlot(sl);
5813 Yap_RecoverSlots(1);
5814 }
5815 Yap_CloseSlots();
5816 if (EX != 0L) {
5817 Term ball;
5818
5819 ex_handler:
5820 ball = Yap_PopTermFromDB(EX);
5821 EX = NULL;
5822 if (tnum <= 8)
5823 targs = NULL;
5824 if (IsAtomTerm(tail)) {
5825 fstr = NULL;
5826 }
5827 if (Stream[sno].status & InMemory_Stream_f) {
5828 Stream[sno].u.mem_string.error_handler = old_handler;
5829 }
5830 format_clean_up(finfo.format_base, fstr, targs);
5831 Yap_JumpToEnv(ball);
5832 return FALSE;
5833 }
5834 break;
5835 case 'q':
5836 if (targ > tnum-1 || has_repeats)
5837 goto do_consistency_error;
5838 t = targs[targ++];
5839 Yap_StartSlots();
5840 Yap_plwrite (t, f_putc, Handle_vars_f|Quote_illegal_f|To_heap_f, 1200);
5841 Yap_CloseSlots();
5842 FormatInfo = &finfo;
5843 break;
5844 case 'w':
5845 if (targ > tnum-1 || has_repeats)
5846 goto do_consistency_error;
5847 t = targs[targ++];
5848 Yap_StartSlots();
5849 Yap_plwrite (t, f_putc, Handle_vars_f|To_heap_f, 1200);
5850 Yap_CloseSlots();
5851 FormatInfo = &finfo;
5852 break;
5853 case '~':
5854 if (has_repeats)
5855 goto do_consistency_error;
5856 f_putc(sno, (int) '~');
5857 break;
5858 case 'n':
5859 if (!has_repeats)
5860 repeats = 1;
5861 while (repeats--) {
5862 f_putc(sno, (int) '\n');
5863 }
5864 column_boundary = 0;
5865 finfo.pad_max = finfo.pad_entries;
5866 break;
5867 case 'N':
5868 if (!has_repeats)
5869 has_repeats = 1;
5870 if (Stream[sno].linepos != 0) {
5871 f_putc(sno, (int) '\n');
5872 column_boundary = 0;
5873 finfo.pad_max = finfo.pad_entries;
5874 }
5875 if (repeats > 1) {
5876 Int i;
5877 for (i = 1; i < repeats; i++)
5878 f_putc(sno, (int) '\n');
5879 column_boundary = 0;
5880 finfo.pad_max = finfo.pad_entries;
5881 }
5882 break;
5883 /* padding */
5884 case '|':
5885 if (has_repeats) {
5886 fill_pads(repeats-(finfo.format_ptr-finfo.format_base));
5887 }
5888 finfo.pad_max = finfo.pad_entries;
5889 if (repeats)
5890 column_boundary = repeats;
5891 else
5892 column_boundary = finfo.format_ptr-finfo.format_base;
5893 break;
5894 case '+':
5895 if (has_repeats) {
5896 fill_pads((repeats+column_boundary)-(finfo.format_ptr-finfo.format_base));
5897 } else {
5898 repeats = 8;
5899 fill_pads(8);
5900 }
5901 finfo.pad_max = finfo.pad_entries;
5902 column_boundary = repeats+column_boundary;
5903 break;
5904 case 't':
5905 if (!has_repeats)
5906 finfo.pad_max->pad = ' ';
5907 else
5908 finfo.pad_max->pad = fptr[-2];
5909 finfo.pad_max->pos = finfo.format_ptr-finfo.format_base;
5910 finfo.pad_max++;
5911 f_putc = format_putc;
5912 break;
5913 do_instantiation_error:
5914 Yap_Error_TYPE = INSTANTIATION_ERROR;
5915 goto do_default_error;
5916 do_type_int_error:
5917 Yap_Error_TYPE = TYPE_ERROR_INTEGER;
5918 goto do_default_error;
5919 do_type_number_error:
5920 Yap_Error_TYPE = TYPE_ERROR_NUMBER;
5921 goto do_default_error;
5922 do_type_atom_error:
5923 Yap_Error_TYPE = TYPE_ERROR_ATOM;
5924 goto do_default_error;
5925 do_domain_not_less_zero_error:
5926 Yap_Error_TYPE = DOMAIN_ERROR_NOT_LESS_THAN_ZERO;
5927 goto do_default_error;
5928 do_domain_error_radix:
5929 Yap_Error_TYPE = DOMAIN_ERROR_RADIX;
5930 goto do_default_error;
5931 do_consistency_error:
5932 default:
5933 Yap_Error_TYPE = CONSISTENCY_ERROR;
5934 do_default_error:
5935 if (tnum <= 8)
5936 targs = NULL;
5937 if (IsAtomTerm(tail)) {
5938 fstr = NULL;
5939 }
5940 {
5941 Term ta[2];
5942 ta[0] = otail;
5943 ta[1] = oargs;
5944 Yap_Error(Yap_Error_TYPE, Yap_MkApplTerm(Yap_MkFunctor(AtomFormat,2),2,ta), "format/2");
5945 }
5946 if (Stream[sno].status & InMemory_Stream_f) {
5947 Stream[sno].u.mem_string.error_handler = old_handler;
5948 }
5949 format_clean_up(finfo.format_base, fstr, targs);
5950 Yap_Error_TYPE = YAP_NO_ERROR;
5951 return FALSE;
5952 }
5953 }
5954 /* ok, now we should have a command */
5955 }
5956 } else {
5957 f_putc(sno, ch);
5958 }
5959 }
5960 if (has_tabs) {
5961 for (fptr = finfo.format_base; fptr < finfo.format_ptr; fptr++) {
5962 Stream[sno].stream_putc(sno, *fptr);
5963 }
5964 }
5965 if (IsAtomTerm(tail)) {
5966 fstr = NULL;
5967 }
5968 if (tnum <= 8)
5969 targs = NULL;
5970 if (Stream[sno].status & InMemory_Stream_f) {
5971 Stream[sno].u.mem_string.error_handler = old_handler;
5972 }
5973 format_clean_up(finfo.format_base, fstr, targs);
5974 return (TRUE);
5975 }
5976
5977 static Int
5978 p_format(void)
5979 { /* 'format'(Control,Args) */
5980 Int res;
5981 res = format(Deref(ARG1),Deref(ARG2), Yap_c_output_stream);
5982 return res;
5983 }
5984
5985 static Int
5986 format2(UInt stream_flag)
5987 {
5988 int old_c_stream = Yap_c_output_stream;
5989 int mem_stream = FALSE, codes_stream = FALSE;
5990 Int out;
5991 Term tin = Deref(ARG1);
5992
5993 if (IsVarTerm(tin)) {
5994 Yap_Error(INSTANTIATION_ERROR,tin,"format/3");
5995 return FALSE;
5996 }
5997 if (IsApplTerm(tin) && FunctorOfTerm(tin) == FunctorAtom) {
5998 Yap_c_output_stream = OpenBufWriteStream();
5999 mem_stream = TRUE;
6000 } else if (IsApplTerm(tin) && FunctorOfTerm(tin) == FunctorCodes) {
6001 Yap_c_output_stream = OpenBufWriteStream();
6002 codes_stream = TRUE;
6003 mem_stream = TRUE;
6004 } else {
6005 /* needs to change Yap_c_output_stream for write */
6006 Yap_c_output_stream = CheckStream (ARG1, Output_Stream_f|stream_flag, "format/3");
6007 }
6008 UNLOCK(Stream[Yap_c_output_stream].streamlock);
6009 if (Yap_c_output_stream == -1) {
6010 Yap_c_output_stream = old_c_stream;
6011 return FALSE;
6012 }
6013 out = format(Deref(ARG2),Deref(ARG3),Yap_c_output_stream);
6014 if (mem_stream) {
6015 Term tat;
6016 Term inp = Deref(ARG1);
6017 int stream = Yap_c_output_stream;
6018 Yap_c_output_stream = old_c_stream;
6019 if (out) {
6020 Stream[stream].u.mem_string.buf[Stream[stream].u.mem_string.pos] = '\0';
6021 if (codes_stream) {
6022 tat = Yap_StringToDiffList(Stream[stream].u.mem_string.buf, ArgOfTerm(2,inp));
6023 } else {
6024 tat = MkAtomTerm(Yap_LookupAtom(Stream[stream].u.mem_string.buf));
6025 }
6026 CloseStream(stream);
6027 if (!Yap_unify(tat,ArgOfTerm(1,inp)))
6028 return FALSE;
6029 } else {
6030 CloseStream(stream);
6031 }
6032 } else {
6033 Yap_c_output_stream = old_c_stream;
6034 }
6035 return out;
6036 }
6037
6038 static Int
6039 p_format2(void)
6040 { /* 'format'(Stream,Control,Args) */
6041 return format2(0);
6042 }
6043
6044 static Int
6045 p_swi_format(void)
6046 { /* 'format'(Stream,Control,Args) */
6047 return format2(SWI_Stream_f);
6048 }
6049
6050
6051 static Int
6052 p_skip (void)
6053 { /* '$skip'(Stream,N) */
6054 int sno = CheckStream (ARG1, Input_Stream_f, "skip/2");
6055 Int n = IntOfTerm (Deref (ARG2));
6056 int ch;
6057
6058 if (sno < 0)
6059 return (FALSE);
6060 if (n < 0 || n > 127) {
6061 UNLOCK(Stream[sno].streamlock);
6062 return (FALSE);
6063 }
6064 UNLOCK(Stream[sno].streamlock);
6065 while ((ch = Stream[sno].stream_wgetc(sno)) != n && ch != -1);
6066 return (TRUE);
6067 }
6068
6069 static Int
6070 p_flush (void)
6071 { /* flush_output(Stream) */
6072 int sno = CheckStream (ARG1, Output_Stream_f, "flush_output/1");
6073 if (sno < 0)
6074 return (FALSE);
6075 yap_fflush (sno);
6076 UNLOCK(Stream[sno].streamlock);
6077 return (TRUE);
6078 }
6079
6080 static Int
6081 p_flush_all_streams (void)
6082 { /* $flush_all_streams */
6083 #if BROKEN_FFLUSH_NULL
6084 int i;
6085 for (i = 0; i < MaxStreams; ++i) {
6086 LOCK(Stream[i].streamlock);
6087 yap_fflush (i);
6088 UNLOCK(Stream[i].streamlock);
6089 }
6090 #else
6091 fflush (NULL);
6092 #endif
6093
6094 return TRUE;
6095 }
6096
6097 void Yap_FlushStreams(void)
6098 {
6099 (void)p_flush_all_streams();
6100 }
6101
6102 #if HAVE_SELECT
6103 /* stream_select(+Streams,+TimeOut,-Result) */
6104 static Int
6105 p_stream_select(void)
6106 {
6107 Term t1 = Deref(ARG1), t2;
6108 fd_set readfds, writefds, exceptfds;
6109 struct timeval timeout, *ptime;
6110
6111 #if _MSC_VER
6112 u_int fdmax=0;
6113 #else
6114 int fdmax=0;
6115 #endif
6116 Term tout = TermNil, ti, Head;
6117
6118 if (IsVarTerm(t1)) {
6119 Yap_Error(INSTANTIATION_ERROR,t1,"stream_select/3");
6120 return FALSE;
6121 }
6122 if (!IsPairTerm(t1)) {
6123 Yap_Error(TYPE_ERROR_LIST,t1,"stream_select/3");
6124 return(FALSE);
6125 }
6126 FD_ZERO(&readfds);
6127 FD_ZERO(&writefds);
6128 FD_ZERO(&exceptfds);
6129 ti = t1;
6130 while (ti != TermNil) {
6131 #if _MSC_VER
6132 u_int fd;
6133 #else
6134 int fd;
6135 #endif
6136 int sno;
6137
6138 Head = HeadOfTerm(ti);
6139 sno = CheckStream(Head, Input_Stream_f, "stream_select/3");
6140 if (sno < 0)
6141 return(FALSE);
6142 fd = GetStreamFd(sno);
6143 FD_SET(fd, &readfds);
6144 UNLOCK(Stream[sno].streamlock);
6145 if (fd > fdmax)
6146 fdmax = fd;
6147 ti = TailOfTerm(ti);
6148 }
6149 t2 = Deref(ARG2);
6150 if (IsVarTerm(t2)) {
6151 Yap_Error(INSTANTIATION_ERROR,t2,"stream_select/3");
6152 return(FALSE);
6153 }
6154 if (IsAtomTerm(t2)) {
6155 if (t2 == MkAtomTerm(AtomOff)) {
6156 /* wait indefinitely */
6157 ptime = NULL;
6158 } else {
6159 Yap_Error(DOMAIN_ERROR_TIMEOUT_SPEC,t1,"stream_select/3");
6160 return(FALSE);
6161 }
6162 } else {
6163 Term t21, t22;
6164
6165 if (!IsApplTerm(t2) || FunctorOfTerm(t2) != FunctorModule) {
6166 Yap_Error(DOMAIN_ERROR_TIMEOUT_SPEC,t2,"stream_select/3");
6167 return(FALSE);
6168 }
6169 t21 = ArgOfTerm(1, t2);
6170 if (IsVarTerm(t21)) {
6171 Yap_Error(INSTANTIATION_ERROR,t2,"stream_select/3");
6172 return(FALSE);
6173 }
6174 if (!IsIntegerTerm(t21)) {
6175 Yap_Error(DOMAIN_ERROR_TIMEOUT_SPEC,t2,"stream_select/3");
6176 return(FALSE);
6177 }
6178 timeout.tv_sec = IntegerOfTerm(t21);
6179 if (timeout.tv_sec < 0) {
6180 Yap_Error(DOMAIN_ERROR_TIMEOUT_SPEC,t2,"stream_select/3");
6181 return(FALSE);
6182 }
6183 t22 = ArgOfTerm(2, t2);
6184 if (IsVarTerm(t22)) {
6185 Yap_Error(INSTANTIATION_ERROR,t2,"stream_select/3");
6186 return(FALSE);
6187 }
6188 if (!IsIntegerTerm(t22)) {
6189 Yap_Error(DOMAIN_ERROR_TIMEOUT_SPEC,t2,"stream_select/3");
6190 return(FALSE);
6191 }
6192 timeout.tv_usec = IntegerOfTerm(t22);
6193 if (timeout.tv_usec < 0) {
6194 Yap_Error(DOMAIN_ERROR_TIMEOUT_SPEC,t2,"stream_select/3");
6195 return(FALSE);
6196 }
6197 ptime = &timeout;
6198 }
6199 /* do the real work */
6200 if (select(fdmax+1, &readfds, &writefds, &exceptfds, ptime) < 0) {
6201 #if HAVE_STRERROR
6202 Yap_Error(SYSTEM_ERROR, TermNil,
6203 "stream_select/3 (select: %s)", strerror(errno));
6204 #else
6205 Yap_Error(SYSTEM_ERROR, TermNil,
6206 "stream_select/3 (select)");
6207 #endif
6208 }
6209 while (t1 != TermNil) {
6210 int fd;
6211 int sno;
6212
6213 Head = HeadOfTerm(t1);
6214 sno = CheckStream(Head, Input_Stream_f, "stream_select/3");
6215 fd = GetStreamFd(sno);
6216 if (FD_ISSET(fd, &readfds))
6217 tout = MkPairTerm(Head,tout);
6218 else
6219 tout = MkPairTerm(TermNil,tout);
6220 UNLOCK(Stream[sno].streamlock);
6221 t1 = TailOfTerm(t1);
6222 }
6223 /* we're done, just pass the info back */
6224 return(Yap_unify(ARG3,tout));
6225
6226 }
6227 #endif
6228
6229 static Int
6230 p_write_depth (void)
6231 { /* write_depth(Old,New) */
6232 Term t1 = Deref (ARG1);
6233 Term t2 = Deref (ARG2);
6234 Term t3 = Deref (ARG3);
6235
6236 if (!IsVarTerm (t1) && !IsIntegerTerm (t1)) {
6237 Yap_Error(TYPE_ERROR_INTEGER,t1,"write_depth/3");
6238 return FALSE;
6239 }
6240 if (!IsVarTerm (t2) && !IsIntegerTerm (t2)) {
6241 Yap_Error(TYPE_ERROR_INTEGER,t2,"write_depth/3");
6242 return FALSE;
6243 }
6244 if (!IsVarTerm (t3) && !IsIntegerTerm (t3)) {
6245 Yap_Error(TYPE_ERROR_INTEGER,t3,"write_depth/3");
6246 return FALSE;
6247 }
6248 if (IsVarTerm (t1))
6249 {
6250 Term t = MkIntegerTerm (max_depth);
6251 if (!Yap_unify_constant(t1, t))
6252 return FALSE;
6253 }
6254 else
6255 max_depth = IntegerOfTerm (t1);
6256 if (IsVarTerm (t2))
6257 {
6258 Term t = MkIntegerTerm (max_list);
6259 if (!Yap_unify_constant (t2, t))
6260 return FALSE;
6261 }
6262 else
6263 max_list = IntegerOfTerm (t2);
6264 if (IsVarTerm (t3))
6265 {
6266 Term t = MkIntegerTerm (max_write_args);
6267 if (!Yap_unify_constant (t3, t))
6268 return FALSE;
6269 }
6270 else
6271 max_write_args = IntegerOfTerm (t3);
6272 return TRUE;
6273 }
6274
6275 static Int
6276 p_change_type_of_char (void)
6277 { /* change_type_of_char(+char,+type) */
6278 Term t1 = Deref (ARG1);
6279 Term t2 = Deref (ARG2);
6280 if (!IsVarTerm (t1) && !IsIntegerTerm (t1))
6281 return FALSE;
6282 if (!IsVarTerm(t2) && !IsIntegerTerm(t2))
6283 return FALSE;
6284 Yap_chtype[IntegerOfTerm(t1)] = IntegerOfTerm(t2);
6285 return TRUE;
6286 }
6287
6288 static Int
6289 p_type_of_char (void)
6290 { /* type_of_char(+char,-type) */
6291 Term t;
6292
6293 Term t1 = Deref (ARG1);
6294 if (!IsVarTerm (t1) && !IsIntegerTerm (t1))
6295 return FALSE;
6296 t = MkIntTerm(Yap_chtype[IntegerOfTerm (t1)]);
6297 return Yap_unify(t,ARG2);
6298 }
6299
6300
6301 static Int
6302 p_force_char_conversion(void)
6303 {
6304 int i;
6305
6306 /* don't actually enable it until someone tries to add a conversion */
6307 if (CharConversionTable2 == NULL)
6308 return(TRUE);
6309 for (i = 0; i < MaxStreams; i++) {
6310 if (!(Stream[i].status & Free_Stream_f))
6311 Stream[i].stream_wgetc_for_read = ISOWGetc;
6312 }
6313 CharConversionTable = CharConversionTable2;
6314 return(TRUE);
6315 }
6316
6317 static Int
6318 p_disable_char_conversion(void)
6319 {
6320 int i;
6321
6322 for (i = 0; i < MaxStreams; i++) {
6323 if (!(Stream[i].status & Free_Stream_f))
6324 Stream[i].stream_wgetc_for_read = Stream[i].stream_wgetc;
6325 }
6326 CharConversionTable = NULL;
6327 return(TRUE);
6328 }
6329
6330 static Int
6331 p_char_conversion(void)
6332 {
6333 Term t0 = Deref(ARG1), t1 = Deref(ARG2);
6334 char *s0, *s1;
6335
6336 if (IsVarTerm(t0)) {
6337 Yap_Error(INSTANTIATION_ERROR, t0, "char_conversion/2");
6338 return (FALSE);
6339 }
6340 if (!IsAtomTerm(t0)) {
6341 Yap_Error(REPRESENTATION_ERROR_CHARACTER, t0, "char_conversion/2");
6342 return (FALSE);
6343 }
6344 s0 = RepAtom(AtomOfTerm(t0))->StrOfAE;
6345 if (s0[1] != '\0') {
6346 Yap_Error(REPRESENTATION_ERROR_CHARACTER, t0, "char_conversion/2");
6347 return (FALSE);
6348 }
6349 if (IsVarTerm(t1)) {
6350 Yap_Error(INSTANTIATION_ERROR, t1, "char_conversion/2");
6351 return (FALSE);
6352 }
6353 if (!IsAtomTerm(t1)) {
6354 Yap_Error(REPRESENTATION_ERROR_CHARACTER, t1, "char_conversion/2");
6355 return (FALSE);
6356 }
6357 s1 = RepAtom(AtomOfTerm(t1))->StrOfAE;
6358 if (s1[1] != '\0') {
6359 Yap_Error(REPRESENTATION_ERROR_CHARACTER, t1, "char_conversion/2");
6360 return (FALSE);
6361 }
6362 /* check if we do have a table for converting characters */
6363 if (CharConversionTable2 == NULL) {
6364 int i;
6365
6366 /* don't create a table if we don't need to */
6367 if (s0[0] == s1[0])
6368 return(TRUE);
6369 CharConversionTable2 = Yap_AllocCodeSpace(NUMBER_OF_CHARS*sizeof(char));
6370 while (CharConversionTable2 == NULL) {
6371 if (!Yap_growheap(FALSE, NUMBER_OF_CHARS*sizeof(char), NULL)) {
6372 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
6373 return(FALSE);
6374 }
6375 }
6376 if (yap_flags[CHAR_CONVERSION_FLAG] != 0) {
6377 if (p_force_char_conversion() == FALSE)
6378 return(FALSE);
6379 }
6380 for (i = 0; i < NUMBER_OF_CHARS; i++)
6381 CharConversionTable2[i] = i;
6382 }
6383 /* just add the new entry */
6384 CharConversionTable2[(int)s0[0]] = s1[0];
6385 /* done */
6386 return(TRUE);
6387 }
6388
6389 static Int
6390 p_current_char_conversion(void)
6391 {
6392 Term t0, t1;
6393 char *s0, *s1;
6394
6395 if (CharConversionTable == NULL) {
6396 return(FALSE);
6397 }
6398 t0 = Deref(ARG1);
6399 if (IsVarTerm(t0)) {
6400 Yap_Error(INSTANTIATION_ERROR, t0, "current_char_conversion/2");
6401 return (FALSE);
6402 }
6403 if (!IsAtomTerm(t0)) {
6404 Yap_Error(REPRESENTATION_ERROR_CHARACTER, t0, "current_char_conversion/2");
6405 return (FALSE);
6406 }
6407 s0 = RepAtom(AtomOfTerm(t0))->StrOfAE;
6408 if (s0[1] != '\0') {
6409 Yap_Error(REPRESENTATION_ERROR_CHARACTER, t0, "current_char_conversion/2");
6410 return (FALSE);
6411 }
6412 t1 = Deref(ARG2);
6413 if (IsVarTerm(t1)) {
6414 char out[2];
6415 if (CharConversionTable[(int)s0[0]] == '\0') return(FALSE);
6416 out[0] = CharConversionTable[(int)s0[0]];
6417 out[1] = '\0';
6418 return(Yap_unify(ARG2,MkAtomTerm(Yap_LookupAtom(out))));
6419 }
6420 if (!IsAtomTerm(t1)) {
6421 Yap_Error(REPRESENTATION_ERROR_CHARACTER, t1, "current_char_conversion/2");
6422 return (FALSE);
6423 }
6424 s1 = RepAtom(AtomOfTerm(t1))->StrOfAE;
6425 if (s1[1] != '\0') {
6426 Yap_Error(REPRESENTATION_ERROR_CHARACTER, t1, "current_char_conversion/2");
6427 return (FALSE);
6428 } else {
6429 return (CharConversionTable[(int)s0[0]] == '\0' &&
6430 CharConversionTable[(int)s0[0]] == s1[0] );
6431 }
6432 }
6433
6434 static Int
6435 p_all_char_conversions(void)
6436 {
6437 Term out = TermNil;
6438 int i;
6439
6440 if (CharConversionTable == NULL) {
6441 return(FALSE);
6442 }
6443 for (i = NUMBER_OF_CHARS; i > 0; ) {
6444 i--;
6445 if (CharConversionTable[i] != '\0') {
6446 Term t1, t2;
6447 char s[2];
6448 s[1] = '\0';
6449 s[0] = CharConversionTable[i];
6450 t1 = MkAtomTerm(Yap_LookupAtom(s));
6451 out = MkPairTerm(t1,out);
6452 s[0] = i;
6453 t2 = MkAtomTerm(Yap_LookupAtom(s));
6454 out = MkPairTerm(t2,out);
6455 }
6456 }
6457 return(Yap_unify(ARG1,out));
6458 }
6459
6460 Int
6461 Yap_StreamToFileNo(Term t)
6462 {
6463 int sno =
6464 CheckStream(t, (Input_Stream_f|Output_Stream_f), "StreamToFileNo");
6465 if (Stream[sno].status & Pipe_Stream_f) {
6466 UNLOCK(Stream[sno].streamlock);
6467 #if _MSC_VER || defined(__MINGW32__)
6468 return((Int)(Stream[sno].u.pipe.hdl));
6469 #else
6470 return(Stream[sno].u.pipe.fd);
6471 #endif
6472 #if USE_SOCKET
6473 } else if (Stream[sno].status & Socket_Stream_f) {
6474 UNLOCK(Stream[sno].streamlock);
6475 return(Stream[sno].u.socket.fd);
6476 #endif
6477 } else if (Stream[sno].status & (Null_Stream_f|InMemory_Stream_f)) {
6478 UNLOCK(Stream[sno].streamlock);
6479 return(-1);
6480 } else {
6481 UNLOCK(Stream[sno].streamlock);
6482 return(YP_fileno(Stream[sno].u.file.file));
6483 }
6484 }
6485
6486 static Int
6487 p_stream(void)
6488 {
6489 Term in = Deref(ARG1);
6490 if (IsVarTerm(in))
6491 return(FALSE);
6492 if (IsAtomTerm(in))
6493 return(CheckAlias(AtomOfTerm(in)) >= 0);
6494 if (IsApplTerm(in))
6495 return(FunctorOfTerm(in) == FunctorStream);
6496 return(FALSE);
6497 }
6498
6499 static Int
6500 p_same_file(void) {
6501 char *f1 = RepAtom(AtomOfTerm(Deref(ARG1)))->StrOfAE;
6502 char *f2 = RepAtom(AtomOfTerm(Deref(ARG2)))->StrOfAE;
6503
6504 if (strcmp(f1,f2) == 0)
6505 return TRUE;
6506 #if HAVE_LSTAT
6507 {
6508 int out;
6509 struct stat *b1, *b2;
6510 while ((char *)H+sizeof(struct stat)*2 > (char *)(ASP-1024)) {
6511 if (!Yap_gcl(2*sizeof(struct stat), 2, ENV, gc_P(P,CP))) {
6512 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
6513 return FALSE;
6514 }
6515 }
6516 b1 = (struct stat *)H;
6517 b2 = b1+1;
6518 if (strcmp(f1,"user_input") == 0) {
6519 if (fstat(fileno(Stream[0].u.file.file), b1) == -1) {
6520 /* file does not exist, but was opened? Return -1 */
6521 return FALSE;
6522 }
6523 } else if (strcmp(f1,"user_output") == 0) {
6524 if (fstat(fileno(Stream[1].u.file.file), b1) == -1) {
6525 /* file does not exist, but was opened? Return -1 */
6526 return FALSE;
6527 }
6528 } else if (strcmp(f1,"user_error") == 0) {
6529 if (fstat(fileno(Stream[2].u.file.file), b1) == -1) {
6530 /* file does not exist, but was opened? Return -1 */
6531 return FALSE;
6532 }
6533 } else if (stat(f1, b1) == -1) {
6534 /* file does not exist, but was opened? Return -1 */
6535 return FALSE;
6536 }
6537 if (strcmp(f2,"user_input") == 0) {
6538 if (fstat(fileno(Stream[0].u.file.file), b2) == -1) {
6539 /* file does not exist, but was opened? Return -1 */
6540 return FALSE;
6541 }
6542 } else if (strcmp(f2,"user_output") == 0) {
6543 if (fstat(fileno(Stream[1].u.file.file), b2) == -1) {
6544 /* file does not exist, but was opened? Return -1 */
6545 return FALSE;
6546 }
6547 } else if (strcmp(f2,"user_error") == 0) {
6548 if (fstat(fileno(Stream[2].u.file.file), b2) == -1) {
6549 /* file does not exist, but was opened? Return -1 */
6550 return FALSE;
6551 }
6552 } else if (stat(f2, b2) == -1) {
6553 /* file does not exist, but was opened? Return -1 */
6554 return FALSE;
6555 }
6556 out = (b1->st_ino == b2->st_ino
6557 #ifdef __LCC__
6558 && memcmp((const void *)&(b1->st_dev),(const void *)&(b2->st_dev),sizeof(buf1.st_dev)) == 0
6559 #else
6560 && b1->st_dev == b2->st_dev
6561 #endif
6562 );
6563 return out;
6564 }
6565 #else
6566 return(FALSE);
6567 #endif
6568 }
6569
6570 static Int
6571 p_float_format(void)
6572 {
6573 Term in = Deref(ARG1);
6574 if (IsVarTerm(in))
6575 return Yap_unify(ARG1, MkAtomTerm(AtomFloatFormat));
6576 AtomFloatFormat = AtomOfTerm(in);
6577 return TRUE;
6578 }
6579
6580 static Int
6581 p_get_default_encoding(void)
6582 {
6583 Term out = MkIntegerTerm(DefaultEncoding());
6584 return Yap_unify(ARG1, out);
6585 }
6586
6587 static Int
6588 p_toupper(void)
6589 {
6590 Int out = IntegerOfTerm(Deref(ARG1)), uout;
6591 if (out < 0) {
6592 Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE, ARG1, "toupper");
6593 return FALSE;
6594 }
6595 if (out < 128)
6596 uout = toupper(out);
6597 else
6598 uout = towupper(out);
6599 return Yap_unify(ARG2, MkIntegerTerm(uout));
6600 }
6601
6602 static Int
6603 p_tolower(void)
6604 {
6605 Int out = IntegerOfTerm(Deref(ARG1)), uout;
6606 if (out < 0) {
6607 Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE, ARG1, "tolower");
6608 return FALSE;
6609 }
6610 if (out < 128)
6611 uout = tolower(out);
6612 else
6613 uout = towlower(out);
6614 return Yap_unify(ARG2, MkIntegerTerm(uout));
6615 }
6616
6617 static Int
6618 p_encoding (void)
6619 { /* '$encoding'(Stream,N) */
6620 int sno = CheckStream (ARG1, Input_Stream_f|Output_Stream_f, "encoding/2");
6621 Term t = Deref(ARG2);
6622 if (sno < 0)
6623 return FALSE;
6624 if (IsVarTerm(t)) {
6625 UNLOCK(Stream[sno].streamlock);
6626 return Yap_unify(ARG2, MkIntegerTerm(Stream[sno].encoding));
6627 }
6628 Stream[sno].encoding = IntegerOfTerm(Deref(ARG2));
6629 UNLOCK(Stream[sno].streamlock);
6630 return TRUE;
6631 }
6632
6633 Term
6634 Yap_StringToTerm(char *s,Term *tp)
6635 {
6636 int sno = open_buf_read_stream(s, strlen(s)+1);
6637 Term t;
6638 TokEntry *tokstart;
6639 tr_fr_ptr TR_before_parse;
6640 Term tpos = TermNil;
6641
6642 if (sno < 0)
6643 return FALSE;
6644 UNLOCK(Stream[sno].streamlock);
6645 TR_before_parse = TR;
6646 tokstart = Yap_tokptr = Yap_toktide = Yap_tokenizer(sno, &tpos);
6647 if (tokstart == NIL && tokstart->Tok == Ord (eot_tok)) {
6648 if (tp) {
6649 *tp = MkAtomTerm(AtomEOFBeforeEOT);
6650 }
6651 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
6652 /* cannot actually use CloseStream, because we didn't allocate the buffer */
6653 Stream[sno].status = Free_Stream_f;
6654 return FALSE;
6655 } else if (Yap_ErrorMessage) {
6656 if (tp) {
6657 *tp = MkAtomTerm(Yap_LookupAtom(Yap_ErrorMessage));
6658 }
6659 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
6660 /* cannot actually use CloseStream, because we didn't allocate the buffer */
6661 Stream[sno].status = Free_Stream_f;
6662 return FALSE;
6663 }
6664 t = Yap_Parse();
6665 TR = TR_before_parse;
6666 if (!t && !Yap_ErrorMessage) {
6667 if (tp) {
6668 t = MkVarTerm();
6669 *tp = syntax_error(tokstart, sno, &t);
6670 }
6671 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
6672 /* cannot actually use CloseStream, because we didn't allocate the buffer */
6673 Stream[sno].status = Free_Stream_f;
6674 return FALSE;
6675 }
6676 Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
6677 /* cannot actually use CloseStream, because we didn't allocate the buffer */
6678 Stream[sno].status = Free_Stream_f;
6679 return t;
6680 }
6681
6682 static Int
6683 p_file_base_name (void)
6684 { /* file_base_name(Stream,N) */
6685 Term t = Deref(ARG1);
6686 Atom at;
6687 if (IsVarTerm(t)) {
6688 Yap_Error(INSTANTIATION_ERROR, t, "file_base_name/2");
6689 return FALSE;
6690 }
6691 if (!IsAtomTerm(t)) {
6692 Yap_Error(TYPE_ERROR_ATOM, t, "file_base_name/2");
6693 return FALSE;
6694 }
6695 at = AtomOfTerm(t);
6696 if (IsWideAtom(at)) {
6697 wchar_t *c = RepAtom(at)->WStrOfAE;
6698 Int i = wcslen(c);
6699 while (i && !Yap_dir_separator((int)c[--i]));
6700 return Yap_unify(ARG2, MkAtomTerm(Yap_LookupWideAtom(c+i)));
6701 } else {
6702 char *c = RepAtom(at)->StrOfAE;
6703 Int i = strlen(c);
6704 while (i && !Yap_dir_separator((int)c[--i]));
6705 if (Yap_dir_separator((int)c[i])) {
6706 i++;
6707 }
6708 return Yap_unify(ARG2, MkAtomTerm(Yap_LookupAtom(c+i)));
6709 }
6710 }
6711
6712 Term
6713 Yap_TermToString(Term t, char *s, unsigned int sz, int flags)
6714 {
6715 int sno = open_buf_write_stream(s, sz);
6716 int old_output_stream = Yap_c_output_stream;
6717
6718 if (sno < 0)
6719 return FALSE;
6720 Yap_c_output_stream = sno;
6721 Yap_StartSlots();
6722 Yap_plwrite (t, Stream[sno].stream_wputc, flags, 1200);
6723 Yap_CloseSlots();
6724 s[Stream[sno].u.mem_string.pos] = '\0';
6725 LOCK(Stream[sno].streamlock);
6726 Stream[sno].status = Free_Stream_f;
6727 UNLOCK(Stream[sno].streamlock);
6728 Yap_c_output_stream = old_output_stream;
6729 return EX != NULL;
6730 }
6731
6732 FILE *
6733 Yap_FileDescriptorFromStream(Term t)
6734 {
6735 int sno = CheckStream (t, Input_Stream_f|Output_Stream_f, "FileDescriptorFromStream");
6736 if (sno < 0)
6737 return NULL;
6738 if (Stream[sno].status & (Null_Stream_f|
6739 InMemory_Stream_f|
6740 Socket_Stream_f|
6741 Pipe_Stream_f|
6742 Free_Stream_f))
6743 return NULL;
6744 return Stream[sno].u.file.file;
6745 }
6746
6747 void
6748 Yap_InitBackIO (void)
6749 {
6750 Yap_InitCPredBack ("$current_stream", 3, 1, init_cur_s, cont_cur_s, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6751 }
6752
6753
6754 void
6755 Yap_InitIOPreds(void)
6756 {
6757 Term cm = CurrentModule;
6758
6759 Yap_stdin = stdin;
6760 Yap_stdout = stdout;
6761 Yap_stderr = stderr;
6762 if (!Stream)
6763 Stream = (StreamDesc *)Yap_AllocCodeSpace(sizeof(StreamDesc)*MaxStreams);
6764 /* here the Input/Output predicates */
6765 Yap_InitCPred ("$check_stream", 2, p_check_stream, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6766 Yap_InitCPred ("$check_stream", 1, p_check_if_stream, SafePredFlag|SyncPredFlag|HiddenPredFlag|HiddenPredFlag);
6767 Yap_InitCPred ("$stream_flags", 2, p_stream_flags, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6768 Yap_InitCPred ("$close", 1, p_close, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6769 Yap_InitCPred ("flush_output", 1, p_flush, SafePredFlag|SyncPredFlag);
6770 Yap_InitCPred ("$flush_all_streams", 0, p_flush_all_streams, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6771 Yap_InitCPred ("get", 2, p_get, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6772 Yap_InitCPred ("get0", 2, p_get0, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6773 Yap_InitCPred ("$get0_line_codes", 2, p_get0_line_codes, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6774 Yap_InitCPred ("$get_byte", 2, p_get_byte, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6775 Yap_InitCPred ("access_file", 2, p_access2, SafePredFlag|HiddenPredFlag);
6776 Yap_InitCPred ("$access", 1, p_access, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6777 Yap_InitCPred ("exists_directory", 1, p_exists_directory, SafePredFlag|SyncPredFlag);
6778 Yap_InitCPred ("$open", 6, p_open, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6779 Yap_InitCPred ("$file_expansion", 2, p_file_expansion, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6780 Yap_InitCPred ("$open_null_stream", 1, p_open_null_stream, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6781 Yap_InitCPred ("$open_pipe_stream", 2, p_open_pipe_stream, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6782 CurrentModule = CHARSIO_MODULE;
6783 Yap_InitCPred ("open_mem_read_stream", 2, p_open_mem_read_stream, SyncPredFlag);
6784 Yap_InitCPred ("open_mem_write_stream", 1, p_open_mem_write_stream, SyncPredFlag);
6785 Yap_InitCPred ("peek_mem_write_stream", 3, p_peek_mem_write_stream, SyncPredFlag);
6786 CurrentModule = cm;
6787 Yap_InitCPred ("$put", 2, p_put, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6788 Yap_InitCPred ("$put_byte", 2, p_put_byte, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6789 Yap_InitCPred ("$set_read_error_handler", 1, p_set_read_error_handler, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6790 Yap_InitCPred ("$get_read_error_handler", 1, p_get_read_error_handler, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6791 Yap_InitCPred ("$read", 6, p_read, SyncPredFlag|HiddenPredFlag);
6792 Yap_InitCPred ("$read", 7, p_read2, SyncPredFlag|HiddenPredFlag);
6793 Yap_InitCPred ("$set_input", 1, p_set_input, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6794 Yap_InitCPred ("$set_output", 1, p_set_output, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6795 Yap_InitCPred ("$skip", 2, p_skip, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6796 Yap_InitCPred ("$write", 2, p_write, SyncPredFlag|HiddenPredFlag);
6797 Yap_InitCPred ("$write", 3, p_write2, SyncPredFlag|HiddenPredFlag);
6798 Yap_InitCPred ("$write_with_prio", 3, p_write_prio, SyncPredFlag|HiddenPredFlag);
6799 Yap_InitCPred ("$write_with_prio", 4, p_write2_prio, SyncPredFlag|HiddenPredFlag);
6800 Yap_InitCPred ("format", 2, p_format, SyncPredFlag);
6801 Yap_InitCPred ("format", 3, p_format2, SyncPredFlag);
6802 Yap_InitCPred ("$current_line_number", 2, p_cur_line_no, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6803 Yap_InitCPred ("$line_position", 2, p_line_position, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6804 Yap_InitCPred ("$character_count", 2, p_character_count, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6805 Yap_InitCPred ("$start_line", 1, p_startline, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6806 Yap_InitCPred ("$show_stream_flags", 2, p_show_stream_flags, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6807 Yap_InitCPred ("$show_stream_position", 2, p_show_stream_position, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6808 Yap_InitCPred ("$set_stream_position", 2, p_set_stream_position, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6809 Yap_InitCPred ("$user_file_name", 2, p_user_file_name, SafePredFlag|SyncPredFlag),
6810 Yap_InitCPred ("$file_name", 2, p_file_name, SafePredFlag|SyncPredFlag),
6811 Yap_InitCPred ("$past_eof", 1, p_past_eof, SafePredFlag|SyncPredFlag),
6812 Yap_InitCPred ("$peek", 2, p_peek, SafePredFlag|SyncPredFlag),
6813 Yap_InitCPred ("$peek_byte", 2, p_peek_byte, SafePredFlag|SyncPredFlag),
6814 Yap_InitCPred ("$has_bom", 1, p_has_bom, SafePredFlag);
6815 Yap_InitCPred ("$stream_representation_error", 2, p_representation_error, SafePredFlag|SyncPredFlag);
6816 Yap_InitCPred ("current_input", 1, p_current_input, SafePredFlag|SyncPredFlag);
6817 Yap_InitCPred ("current_output", 1, p_current_output, SafePredFlag|SyncPredFlag);
6818 Yap_InitCPred ("prompt", 1, p_setprompt, SafePredFlag|SyncPredFlag);
6819 Yap_InitCPred ("$is_same_tty", 2, p_is_same_tty, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6820 Yap_InitCPred ("prompt", 2, p_prompt, SafePredFlag|SyncPredFlag);
6821 Yap_InitCPred ("always_prompt_user", 0, p_always_prompt_user, SafePredFlag|SyncPredFlag);
6822 Yap_InitCPred ("write_depth", 3, p_write_depth, SafePredFlag|SyncPredFlag);
6823 Yap_InitCPred ("$change_type_of_char", 2, p_change_type_of_char, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6824 Yap_InitCPred ("$type_of_char", 2, p_type_of_char, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6825 Yap_InitCPred ("char_conversion", 2, p_char_conversion, SyncPredFlag);
6826 Yap_InitCPred ("$current_char_conversion", 2, p_current_char_conversion, SyncPredFlag|HiddenPredFlag);
6827 Yap_InitCPred ("$all_char_conversions", 1, p_all_char_conversions, SyncPredFlag|HiddenPredFlag);
6828 Yap_InitCPred ("$force_char_conversion", 0, p_force_char_conversion, SyncPredFlag|HiddenPredFlag);
6829 Yap_InitCPred ("$disable_char_conversion", 0, p_disable_char_conversion, SyncPredFlag|HiddenPredFlag);
6830 Yap_InitCPred ("$add_alias_to_stream", 2, p_add_alias_to_stream, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6831 Yap_InitCPred ("$change_alias_to_stream", 2, p_change_alias_to_stream, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6832 Yap_InitCPred ("$check_if_valid_new_alias", 1, p_check_if_valid_new_alias, TestPredFlag|SafePredFlag|SyncPredFlag|HiddenPredFlag);
6833 Yap_InitCPred ("$fetch_stream_alias", 2, p_fetch_stream_alias, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6834 Yap_InitCPred ("$stream", 1, p_stream, SafePredFlag|TestPredFlag);
6835 Yap_InitCPred ("$get_default_encoding", 1, p_get_default_encoding, SafePredFlag|TestPredFlag);
6836 Yap_InitCPred ("$encoding", 2, p_encoding, SafePredFlag|SyncPredFlag),
6837 #if HAVE_SELECT
6838 Yap_InitCPred ("stream_select", 3, p_stream_select, SafePredFlag|SyncPredFlag);
6839 #endif
6840 Yap_InitCPred ("$same_file", 2, p_same_file, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6841 Yap_InitCPred ("$float_format", 1, p_float_format, SafePredFlag|SyncPredFlag|HiddenPredFlag);
6842 Yap_InitCPred ("$has_readline", 0, p_has_readline, SafePredFlag|HiddenPredFlag);
6843 Yap_InitCPred ("$toupper", 2, p_toupper, SafePredFlag|HiddenPredFlag);
6844 Yap_InitCPred ("$tolower", 2, p_tolower, SafePredFlag|HiddenPredFlag);
6845 Yap_InitCPred ("file_base_name", 2, p_file_base_name, SafePredFlag|HiddenPredFlag);
6846
6847 CurrentModule = SYSTEM_MODULE;
6848 Yap_InitCPred ("swi_format", 3, p_swi_format, SyncPredFlag);
6849 CurrentModule = cm;
6850
6851 Yap_InitReadUtil ();
6852 #if USE_SOCKET
6853 Yap_InitSockets ();
6854 #endif
6855 InitPlIO ();
6856 #if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H
6857 InitReadline();
6858 #endif
6859 }
6860