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