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