libguile/ports.c

   1 /*      Copyright (C) 1995,1996 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42 #include <stdio.h>
  43 #include "_scm.h"
  44 #include "genio.h"
  45 #include "chars.h"
  46
  47 #include "markers.h"
  48 #include "filesys.h"
  49 #include "fports.h"
  50 #include "strports.h"
  51 #include "vports.h"
  52
  53 #include "ports.h"
  54
  55 #ifdef HAVE_MALLOC_H
  56 #include <malloc.h>
  57 #endif
  58
  59 #ifdef HAVE_UNISTD_H
  60 #include <unistd.h>
  61 #endif
  62
  63 #ifdef HAVE_SYS_IOCTL_H
  64 #include <sys/ioctl.h>
  65 #endif
  66 \f
  67
  68
  69 /* scm_ptobs scm_numptob
  70  * implement a dynamicly resized array of ptob records.
  71  * Indexes into this table are used when generating type
  72  * tags for smobjects (if you know a tag you can get an index and conversely).
  73  */
  74 scm_ptobfuns *scm_ptobs;
  75 scm_sizet scm_numptob;
  76
  77
  78 SCM
  79 scm_markstream (ptr)
  80      SCM ptr;
  81 {
  82   int openp;
  83   if (SCM_GC8MARKP (ptr))
  84     return SCM_BOOL_F;
  85   openp = SCM_CAR (ptr) & SCM_OPN;
  86   SCM_SETGC8MARK (ptr);
  87   if (openp)
  88     return SCM_STREAM  (ptr);
  89   else
  90     return SCM_BOOL_F;
  91 }
  92
  93
  94
  95 long
  96 scm_newptob (ptob)
  97      scm_ptobfuns *ptob;
  98 {
  99   char *tmp;
 100   if (255 <= scm_numptob)
 101     goto ptoberr;
 102   SCM_DEFER_INTS;
 103   SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns)));
 104   if (tmp)
 105     {
 106       scm_ptobs = (scm_ptobfuns *) tmp;
 107       scm_ptobs[scm_numptob].mark = ptob->mark;
 108       scm_ptobs[scm_numptob].free = ptob->free;
 109       scm_ptobs[scm_numptob].print = ptob->print;
 110       scm_ptobs[scm_numptob].equalp = ptob->equalp;
 111       scm_ptobs[scm_numptob].fputc = ptob->fputc;
 112       scm_ptobs[scm_numptob].fputs = ptob->fputs;
 113       scm_ptobs[scm_numptob].fwrite = ptob->fwrite;
 114       scm_ptobs[scm_numptob].fflush = ptob->fflush;
 115       scm_ptobs[scm_numptob].fgetc = ptob->fgetc;
 116       scm_ptobs[scm_numptob].fclose = ptob->fclose;
 117       scm_numptob++;
 118     }
 119   SCM_ALLOW_INTS;
 120   if (!tmp)
 121   ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), (char *) SCM_NALLOC, "newptob");
 122   return scm_tc7_port + (scm_numptob - 1) * 256;
 123 }
 124
 125 \f
 126 /* internal SCM call */
 127
 128 void
 129 scm_fflush (port)
 130      SCM port;
 131 {
 132   scm_sizet i = SCM_PTOBNUM (port);
 133   (scm_ptobs[i].fflush) (SCM_STREAM (port));
 134 }
 135
 136 \f
 137
 138 SCM_PROC(s_char_ready_p, "char-ready?", 1, 0, 0, scm_char_ready_p);
 139
 140 SCM
 141 scm_char_ready_p (port)
 142      SCM port;
 143 {
 144   if (SCM_UNBNDP (port))
 145     port = scm_cur_inp;
 146   else
 147     SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_char_ready_p);
 148   if (SCM_CRDYP (port) || !SCM_FPORTP (port))
 149     return SCM_BOOL_T;
 150   return (scm_input_waiting_p ((FILE *) SCM_STREAM (port), s_char_ready_p)
 151           ? SCM_BOOL_T
 152           : SCM_BOOL_F);
 153 }
 154
 155
 156 \f
 157
 158 SCM_PROC (s_ungetc_char_ready_p, "ungetc-char-ready?", 1, 0, 0, scm_ungetc_char_ready_p);
 159
 160 SCM
 161 scm_ungetc_char_ready_p (port)
 162      SCM port;
 163 {
 164   if (SCM_UNBNDP (port))
 165     port = scm_cur_inp;
 166   else
 167     SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_ungetc_char_ready_p);
 168   return (SCM_CRDYP (port)
 169           ? SCM_BOOL_T
 170           : SCM_BOOL_F);
 171 }
 172
 173
 174 \f
 175
 176
 177 /* {Standard Ports}
 178  */
 179 SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port);
 180
 181 SCM
 182 scm_current_input_port ()
 183 {
 184   return scm_cur_inp;
 185 }
 186
 187 SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port);
 188
 189 SCM
 190 scm_current_output_port ()
 191 {
 192   return scm_cur_outp;
 193 }
 194
 195 SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port);
 196
 197 SCM
 198 scm_current_error_port ()
 199 {
 200   return scm_cur_errp;
 201 }
 202
 203 SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port);
 204
 205 SCM
 206 scm_set_current_input_port (port)
 207      SCM port;
 208 {
 209   SCM oinp = scm_cur_inp;
 210   SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port);
 211   scm_cur_inp = port;
 212   return oinp;
 213 }
 214
 215
 216 SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port);
 217
 218 SCM
 219 scm_set_current_output_port (port)
 220      SCM port;
 221 {
 222   SCM ooutp = scm_cur_outp;
 223   SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port);
 224   scm_cur_outp = port;
 225   return ooutp;
 226 }
 227
 228
 229 SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port);
 230
 231 SCM
 232 scm_set_current_error_port (port)
 233      SCM port;
 234 {
 235   SCM oerrp = scm_cur_errp;
 236   SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port);
 237   scm_cur_errp = port;
 238   return oerrp;
 239 }
 240
 241 \f
 242
 243 /* {Ports - in general}
 244  *
 245  */
 246
 247 /* Array of open ports, required for reliable MOVE->FDES etc.  */
 248 struct scm_port_table **scm_port_table;
 249
 250 int scm_port_table_size = 0;    /* Number of ports in scm_port_table.  */
 251 int scm_port_table_room = 20;   /* Size of the array.  */
 252
 253 /* Add a port to the table.  Call with SCM_DEFER_INTS active.  */
 254
 255 struct scm_port_table *
 256 scm_add_to_port_table (port)
 257      SCM port;
 258 {
 259   if (scm_port_table_size == scm_port_table_room)
 260     {
 261       scm_port_table = ((struct scm_port_table **)
 262                         realloc ((char *) scm_port_table,
 263                                  (long) (sizeof (struct scm_port_table)
 264                                          * scm_port_table_room * 2)));
 265       /* !!! error checking */
 266       scm_port_table_room *= 2;
 267     }
 268   scm_port_table[scm_port_table_size] = ((struct scm_port_table *)
 269                                          scm_must_malloc (sizeof (struct scm_port_table),
 270                                                           "system port table"));
 271   scm_port_table[scm_port_table_size]->port = port;
 272   scm_port_table[scm_port_table_size]->revealed = 0;
 273   scm_port_table[scm_port_table_size]->stream = 0;
 274   scm_port_table[scm_port_table_size]->file_name = SCM_BOOL_F;
 275   scm_port_table[scm_port_table_size]->line_number = 1;
 276   scm_port_table[scm_port_table_size]->column_number = 0;
 277   scm_port_table[scm_port_table_size]->representation = scm_regular_port;
 278   return scm_port_table[scm_port_table_size++];
 279 }
 280
 281 /* Remove a port from the table.  Call with SCM_DEFER_INTS active.  */
 282
 283 void
 284 scm_remove_from_port_table (port)
 285      SCM port;
 286 {
 287   int i = 0;
 288   while (scm_port_table[i]->port != port)
 289     {
 290       i++;
 291       /* Error if not found: too violent?  May occur in GC.  */
 292       if (i >= scm_port_table_size)
 293         scm_wta (port, "Port not in table", "scm_remove_from_port_table");
 294     }
 295   scm_must_free ((char *)scm_port_table[i]);
 296   scm_mallocated -= sizeof (*scm_port_table[i]);
 297   scm_port_table[i] = scm_port_table[scm_port_table_size - 1];
 298   SCM_SETPTAB_ENTRY (port, 0);
 299   scm_port_table_size--;
 300 }
 301
 302 #ifdef DEBUG
 303 /* Undocumented functions for debugging.  */
 304 /* Return the number of ports in the table.  */
 305
 306 SCM_PROC(s_pt_size, "pt-size", 0, 0, 0, scm_pt_size);
 307 SCM
 308 scm_pt_size ()
 309 {
 310   return SCM_MAKINUM (scm_port_table_size);
 311 }
 312
 313 /* Return the ith member of the port table.  */
 314 SCM_PROC(s_pt_member, "pt-member", 1, 0, 0, scm_pt_member);
 315 SCM
 316 scm_pt_member (member)
 317      SCM member;
 318 {
 319   int i;
 320   SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member);
 321   i = SCM_INUM (member);
 322   if (i < 0 || i >= scm_port_table_size)
 323     return SCM_BOOL_F;
 324   else
 325     return scm_port_table[i]->port;
 326 }
 327 #endif
 328
 329
 330 /* Find a port in the table and return its revealed count.
 331    Also used by the garbage collector.
 332  */
 333
 334 int
 335 scm_revealed_count (port)
 336      SCM port;
 337 {
 338   return SCM_REVEALED(port);
 339 }
 340
 341
 342
 343 /* Return the revealed count for a port.  */
 344
 345 SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed);
 346
 347 SCM
 348 scm_port_revealed (port)
 349      SCM port;
 350 {
 351   SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed);
 352   return SCM_MAKINUM (scm_revealed_count (port));
 353 }
 354
 355 /* Set the revealed count for a port.  */
 356 SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x);
 357
 358 SCM
 359 scm_set_port_revealed_x (port, rcount)
 360      SCM port;
 361      SCM rcount;
 362 {
 363   SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x);
 364   SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x);
 365   SCM_DEFER_INTS;
 366   SCM_REVEALED (port) = SCM_INUM (rcount);
 367   SCM_ALLOW_INTS;
 368   return SCM_UNSPECIFIED;
 369 }
 370
 371 /* scm_close_port
 372  * Call the close operation on a port object.
 373  */
 374 SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port);
 375
 376 SCM
 377 scm_close_port (port)
 378      SCM port;
 379 {
 380   scm_sizet i;
 381   SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_close_port);
 382   if (SCM_CLOSEDP (port))
 383     return SCM_UNSPECIFIED;
 384   i = SCM_PTOBNUM (port);
 385   SCM_DEFER_INTS;
 386   if (scm_ptobs[i].fclose)
 387     SCM_SYSCALL ((scm_ptobs[i].fclose) (SCM_STREAM (port)));
 388   scm_remove_from_port_table (port);
 389   SCM_SETAND_CAR (port, ~SCM_OPN);
 390   SCM_ALLOW_INTS;
 391   return SCM_UNSPECIFIED;
 392 }
 393
 394 SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except);
 395
 396 SCM
 397 scm_close_all_ports_except (ports)
 398      SCM ports;
 399 {
 400   int i = 0;
 401   SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except);
 402   SCM_DEFER_INTS;
 403   while (i < scm_port_table_size)
 404     {
 405       SCM thisport = scm_port_table[i]->port;
 406       int found = 0;
 407       SCM ports_ptr = ports;
 408
 409       while (SCM_NNULLP (ports_ptr))
 410         {
 411           SCM port = SCM_CAR (ports_ptr);
 412           if (i == 0)
 413             SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except);
 414           if (port == thisport)
 415             found = 1;
 416           ports_ptr = SCM_CDR (ports_ptr);
 417         }
 418       if (found)
 419         i++;
 420       else
 421         /* i is not to be incremented here.  */
 422         scm_close_port (thisport);
 423     }
 424   SCM_ALLOW_INTS;
 425   return SCM_UNSPECIFIED;
 426 }
 427
 428 SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p);
 429
 430 SCM
 431 scm_input_port_p (x)
 432      SCM x;
 433 {
 434   if (SCM_IMP (x))
 435  return SCM_BOOL_F;
 436   return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F;
 437 }
 438
 439 SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p);
 440
 441 SCM
 442 scm_output_port_p (x)
 443      SCM x;
 444 {
 445   if (SCM_IMP (x))
 446  return SCM_BOOL_F;
 447   return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F;
 448 }
 449
 450
 451 SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p);
 452
 453 SCM
 454 scm_eof_object_p (x)
 455      SCM x;
 456 {
 457   return (SCM_EOF_VAL == x) ? SCM_BOOL_T : SCM_BOOL_F;
 458 }
 459
 460 SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output);
 461
 462 SCM
 463 scm_force_output (port)
 464      SCM port;
 465 {
 466   if (SCM_UNBNDP (port))
 467  port = scm_cur_outp;
 468   else
 469     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_force_output);
 470   {
 471     scm_sizet i = SCM_PTOBNUM (port);
 472     SCM_SYSCALL ((scm_ptobs[i].fflush) (SCM_STREAM (port)));
 473     return SCM_UNSPECIFIED;
 474   }
 475 }
 476
 477
 478 SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char);
 479
 480 SCM
 481 scm_read_char (port)
 482      SCM port;
 483 {
 484   int c;
 485   if (SCM_UNBNDP (port))
 486     port = scm_cur_inp;
 487   else
 488     SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char);
 489   c = scm_gen_getc (port);
 490   if (EOF == c)
 491     return SCM_EOF_VAL;
 492   return SCM_MAKICHR (c);
 493 }
 494
 495
 496 SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char);
 497
 498 SCM
 499 scm_peek_char (port)
 500      SCM port;
 501 {
 502   int c;
 503   if (SCM_UNBNDP (port))
 504     port = scm_cur_inp;
 505   else
 506     SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char);
 507   c = scm_gen_getc (port);
 508   if (EOF == c)
 509     return SCM_EOF_VAL;
 510   scm_gen_ungetc (c, port);
 511   return SCM_MAKICHR (c);
 512 }
 513
 514 SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char);
 515
 516 SCM
 517 scm_unread_char (cobj, port)
 518      SCM cobj;
 519      SCM port;
 520 {
 521   int c;
 522
 523   SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char);
 524
 525   if (SCM_UNBNDP (port))
 526     port = scm_cur_inp;
 527   else
 528     SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char);
 529
 530
 531   c = SCM_ICHR (cobj);
 532
 533   scm_gen_ungetc (c, port);
 534   return cobj;
 535 }
 536
 537
 538
 539 SCM_PROC (s_port_line, "port-line", 0, 1, 0, scm_port_line);
 540
 541 SCM
 542 scm_port_line (port)
 543      SCM port;
 544 {
 545   SCM p;
 546   p = ((port == SCM_UNDEFINED)
 547        ? scm_cur_inp
 548        : port);
 549   if (!(SCM_NIMP (p) && SCM_PORTP (p)))
 550     return SCM_BOOL_F;
 551   else
 552     return SCM_MAKINUM (SCM_LINUM (p));
 553 }
 554
 555 SCM_PROC (s_set_port_line_x, "set-port-line!", 1, 1, 0, scm_set_port_line_x);
 556
 557 SCM
 558 scm_set_port_line_x (port, line)
 559      SCM port;
 560      SCM line;
 561 {
 562   if (line == SCM_UNDEFINED)
 563     {
 564       line = port;
 565       port = scm_cur_inp;
 566     }
 567   else
 568     SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
 569                 port,
 570                 SCM_ARG1,
 571                 s_set_port_line_x);
 572   return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line);
 573 }
 574
 575 SCM_PROC (s_port_column, "port-column", 0, 1, 0, scm_port_column);
 576
 577 SCM
 578 scm_port_column  (port)
 579      SCM port;
 580 {
 581   SCM p;
 582   p = ((port == SCM_UNDEFINED)
 583        ? scm_cur_inp
 584        : port);
 585   if (!(SCM_NIMP (p) && SCM_PORTP (p)))
 586     return SCM_BOOL_F;
 587   else
 588     return SCM_MAKINUM (SCM_COL (p));
 589 }
 590
 591 SCM_PROC (s_set_port_column_x, "set-port-column!", 1, 1, 0, scm_set_port_column_x);
 592
 593 SCM
 594 scm_set_port_column_x (port, column)
 595      SCM port;
 596      SCM column;
 597 {
 598   if (column == SCM_UNDEFINED)
 599     {
 600       column = port;
 601       port = scm_cur_inp;
 602     }
 603   else
 604     SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
 605                 port,
 606                 SCM_ARG1,
 607                 s_set_port_column_x);
 608   return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column);
 609 }
 610
 611 SCM_PROC (s_port_filename, "port-filename", 0, 1, 0, scm_port_filename);
 612
 613 SCM
 614 scm_port_filename (port)
 615      SCM port;
 616 {
 617   SCM p;
 618   p = ((port == SCM_UNDEFINED)
 619        ? scm_cur_inp
 620        : port);
 621   if (!(SCM_NIMP (p) && SCM_PORTP (p)))
 622     return SCM_BOOL_F;
 623   else
 624     return SCM_PTAB_ENTRY (p)->file_name;
 625 }
 626
 627 SCM_PROC (s_set_port_filename_x, "set-port-filename!", 1, 1, 0, scm_set_port_filename_x);
 628
 629 SCM
 630 scm_set_port_filename_x (port, filename)
 631      SCM port;
 632      SCM filename;
 633 {
 634   if (filename == SCM_UNDEFINED)
 635     {
 636       filename = port;
 637       port = scm_cur_inp;
 638     }
 639   else
 640     SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
 641                 port,
 642                 SCM_ARG1,
 643                 s_set_port_filename_x);
 644   return SCM_PTAB_ENTRY (port)->file_name = filename;
 645 }
 646
 647 #ifndef ttyname
 648 extern char * ttyname();
 649 #endif
 650
 651
 652 void
 653 scm_prinport (exp, port, type)
 654      SCM exp;
 655      SCM port;
 656      char *type;
 657 {
 658   scm_gen_puts (scm_regular_string, "#<", port);
 659   if (SCM_CLOSEDP (exp))
 660     scm_gen_puts (scm_regular_string, "closed: ", port);
 661   else
 662     {
 663       if (SCM_RDNG & SCM_CAR (exp))
 664         scm_gen_puts (scm_regular_string, "input: ", port);
 665       if (SCM_WRTNG & SCM_CAR (exp))
 666         scm_gen_puts (scm_regular_string, "output: ", port);
 667     }
 668   scm_gen_puts (scm_regular_string, type, port);
 669   scm_gen_putc (' ', port);
 670 #ifndef MSDOS
 671 #ifndef __EMX__
 672 #ifndef _DCC
 673 #ifndef AMIGA
 674 #ifndef THINK_C
 675   if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp))))
 676     scm_gen_puts (scm_regular_string, ttyname (fileno ((FILE *)SCM_STREAM (exp))), port);
 677   else
 678 #endif
 679 #endif
 680 #endif
 681 #endif
 682 #endif
 683   if (SCM_OPFPORTP (exp))
 684     scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port);
 685   else
 686     scm_intprint (SCM_CDR (exp), 16, port);
 687   scm_gen_putc ('>', port);
 688 }
 689
 690
 691 void
 692 scm_ports_prehistory ()
 693 {
 694   scm_numptob = 0;
 695   scm_ptobs = (scm_ptobfuns *) malloc (sizeof (scm_ptobfuns));
 696
 697   /* WARNING: These scm_newptob calls must be done in this order.
 698    * They must agree with the port declarations in tags.h.
 699    */
 700   /* scm_tc16_fport = */ scm_newptob (&scm_fptob);
 701   /* scm_tc16_pipe = */ scm_newptob (&scm_pipob);
 702   /* scm_tc16_strport = */ scm_newptob (&scm_stptob);
 703   /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob);
 704 }
 705 \f
 706
 707 \f
 708 /* {Void Ports}
 709  */
 710
 711 int scm_tc16_void_port = 0;
 712
 713 static int
 714 print_void_port (exp, port, writing)
 715      SCM exp;
 716      SCM port;
 717      int writing;
 718 {
 719   scm_prinport (exp, port, "void");
 720   return 1;
 721 }
 722
 723 static int
 724 putc_void_port (c, strm)
 725      int c;
 726      SCM strm;
 727 {
 728   return 0;                     /* vestigial return value */
 729 }
 730
 731 static int
 732 puts_void_port (s, strm)
 733      char * s;
 734      SCM strm;
 735 {
 736   return 0;                     /* vestigial return value */
 737 }
 738
 739 static scm_sizet
 740 write_void_port (ptr, size, nitems, strm)
 741      void * ptr;
 742      int size;
 743      int nitems;
 744      SCM strm;
 745 {
 746   int len;
 747   len = size * nitems;
 748   return len;
 749 }
 750
 751
 752 static int flush_void_port SCM_P ((SCM strm));
 753
 754 static int
 755 flush_void_port (strm)
 756      SCM strm;
 757 {
 758   return 0;
 759 }
 760
 761
 762 static int getc_void_port SCM_P ((SCM strm));
 763
 764 static int
 765 getc_void_port (strm)
 766      SCM strm;
 767 {
 768   return EOF;
 769 }
 770
 771
 772 static int close_void_port SCM_P ((SCM strm));
 773
 774 static int
 775 close_void_port (strm)
 776      SCM strm;
 777 {
 778   return 0;                     /* this is ignored by scm_close_port. */
 779 }
 780
 781
 782
 783 static int noop0 SCM_P ((SCM stream));
 784
 785 static int
 786 noop0 (stream)
 787      SCM stream;
 788 {
 789   return 0;
 790 }
 791
 792
 793 static struct scm_ptobfuns  void_port_ptob =
 794 {
 795   scm_mark0,
 796   noop0,
 797   print_void_port,
 798   0,                            /* equal? */
 799   putc_void_port,
 800   puts_void_port,
 801   write_void_port,
 802   flush_void_port,
 803   getc_void_port,
 804   close_void_port,
 805 };
 806
 807 \f
 808
 809
 810 SCM
 811 scm_void_port (mode_str)
 812      char * mode_str;
 813 {
 814   int mode_bits;
 815   SCM answer;
 816   struct scm_port_table * pt;
 817
 818   SCM_NEWCELL (answer);
 819   SCM_DEFER_INTS;
 820   mode_bits = scm_mode_bits (mode_str);
 821   pt = scm_add_to_port_table (answer);
 822   SCM_SETCAR (answer, scm_tc16_void_port | mode_bits);
 823   SCM_SETPTAB_ENTRY (answer, pt);
 824   SCM_SETSTREAM (answer, SCM_BOOL_F);
 825   SCM_ALLOW_INTS;
 826   return answer;
 827 }
 828
 829
 830 SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port);
 831
 832 SCM
 833 scm_sys_make_void_port (mode)
 834      SCM mode;
 835 {
 836   SCM_ASSERT (SCM_NIMP (mode) && SCM_STRINGP (mode), mode,
 837               SCM_ARG1, s_sys_make_void_port);
 838
 839   return scm_void_port (SCM_ROCHARS (mode));
 840 }
 841
 842
 843
 844 \f
 845
 846
 847 void
 848 scm_init_ports ()
 849 {
 850   scm_tc16_void_port = scm_newptob (&void_port_ptob);
 851 #include "ports.x"
 852 }
 853