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