libguile/ports.c

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