libguile/ports.c

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