diff options
Diffstat (limited to 'libguile/fports.c')
-rw-r--r-- | libguile/fports.c | 400 |
1 files changed, 0 insertions, 400 deletions
diff --git a/libguile/fports.c b/libguile/fports.c deleted file mode 100644 index 928aeeff5..000000000 --- a/libguile/fports.c +++ /dev/null @@ -1,400 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "markers.h" - -#include "fports.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#else -scm_sizet fwrite (); -#endif - - -#ifdef __IBMC__ -#include <io.h> -#include <direct.h> -#else -#ifndef MSDOS -#ifndef ultrix -#ifndef vms -#ifdef _DCC -#include <ioctl.h> -#define setbuf(stream, buf) setvbuf(stream, buf, _IONBF, 0) -#else -#ifdef MWC -#include <sys/io.h> -#else -#ifndef THINK_C -#ifndef ARM_ULIB -#include <sys/ioctl.h> -#endif -#endif -#endif -#endif -#endif -#endif -#endif -#endif - - -/* {Ports - file ports} - * - */ - -/* should be called with SCM_DEFER_INTS active */ - -SCM -scm_setbuf0 (port) - SCM port; -{ -#ifndef NOSETBUF -#ifndef MSDOS -#ifdef FIONREAD -#ifndef ultrix - SCM_SYSCALL (setbuf ((FILE *)SCM_STREAM (port), 0);); -#endif -#endif -#endif -#endif - return SCM_UNSPECIFIED; -} - -/* Return the flags that characterize a port based on the mode - * string used to open a file for that port. - * - * See PORT FLAGS in scm.h - */ - -long -scm_mode_bits (modes) - char *modes; -{ - return (SCM_OPN - | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0) - | ( strchr (modes, 'w') - || strchr (modes, 'a') - || strchr (modes, '+') ? SCM_WRTNG : 0) - | (strchr (modes, '0') ? SCM_BUF0 : 0)); -} - - -/* scm_open_file - * Return a new port open on a given file. - * - * The mode string must match the pattern: [rwa+]** which - * is interpreted in the usual unix way. - * - * Return the new port. - */ -SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file); - -SCM -scm_open_file (filename, modes) - SCM filename; - SCM modes; -{ - SCM port; - FILE *f; - char *file; - char *mode; - - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); - if (SCM_SUBSTRP (modes)) - modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0); - - file = SCM_ROCHARS (filename); - mode = SCM_ROCHARS (modes); - - SCM_NEWCELL (port); - SCM_DEFER_INTS; - SCM_SYSCALL (f = fopen (file, mode)); - if (!f) - { - scm_syserror_msg (s_open_file, "%s: %S", - scm_listify (scm_makfrom0str (strerror (errno)), - filename, - SCM_UNDEFINED)); - } - else - { - struct scm_port_table * pt; - - pt = scm_add_to_port_table (port); - SCM_SETPTAB_ENTRY (port, pt); - SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (mode)); - SCM_SETSTREAM (port, (SCM) f); - if (SCM_BUF0 & SCM_CAR (port)) - scm_setbuf0 (port); - SCM_PTAB_ENTRY (port)->file_name = filename; - } - SCM_ALLOW_INTS; - return port; -} - - -/* Build a Scheme port from an open stdio port, FILE. - MODE indicates whether FILE is open for reading or writing; it uses - the same notation as open-file's second argument. - If NAME is non-zero, use it as the port's filename. - - scm_stdio_to_port sets the revealed count for FILE's file - descriptor to 1, so that FILE won't be closed when the port object - is GC'd. */ -SCM -scm_stdio_to_port (file, mode, name) - FILE *file; - char *mode; - char *name; -{ - long mode_bits = scm_mode_bits (mode); - SCM port; - struct scm_port_table * pt; - - SCM_NEWCELL (port); - SCM_DEFER_INTS; - { - pt = scm_add_to_port_table (port); - SCM_SETPTAB_ENTRY (port, pt); - SCM_SETCAR (port, (scm_tc16_fport | mode_bits)); - SCM_SETSTREAM (port, (SCM) file); - if (SCM_BUF0 & SCM_CAR (port)) - scm_setbuf0 (port); - SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name); - } - SCM_ALLOW_INTS; - scm_set_port_revealed_x (port, SCM_MAKINUM (1)); - return port; -} - - -/* Return the mode flags from an open port. - * Some modes such as "append" are only used when opening - * a file and are not returned here. */ - -SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode); - -SCM -scm_port_mode (port) - SCM port; -{ - char modes[3]; - modes[0] = '\0'; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode); - if (SCM_CAR (port) & SCM_RDNG) { - if (SCM_CAR (port) & SCM_WRTNG) - strcpy (modes, "r+"); - else - strcpy (modes, "r"); - } - else if (SCM_CAR (port) & SCM_WRTNG) - strcpy (modes, "w"); - if (SCM_CAR (port) & SCM_BUF0) - strcat (modes, "0"); - return scm_makfromstr (modes, strlen (modes), 0); -} - - - -static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinfport (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - SCM name; - char * c; - if (SCM_CLOSEDP (exp)) - { - c = "file"; - } - else - { - name = SCM_PTAB_ENTRY (exp)->file_name; - if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) - c = SCM_ROCHARS (name); - else - c = "file"; - } - - scm_prinport (exp, port, c); - return !0; -} - - - -static int scm_fgetc SCM_P ((FILE * s)); - -static int -scm_fgetc (s) - FILE * s; -{ - if (feof (s)) - return EOF; - else - return fgetc (s); -} - -#ifdef vms - -static scm_sizet pwrite SCM_P ((char *ptr, scm_sizet size, nitems, FILE *port)); - -static scm_sizet -pwrite (ptr, size, nitems, port) - char *ptr; - scm_sizet size, nitems; - FILE *port; -{ - scm_sizet len = size * nitems; - scm_sizet i = 0; - for (; i < len; i++) - putc (ptr[i], port); - return len; -} - -#define ffwrite pwrite -#else -#define ffwrite fwrite -#endif - - -/* This otherwise pointless code helps some poor - * crippled C compilers cope with life. - */ - -static int local_fclose SCM_P ((FILE *fp)); - -static int -local_fclose (fp) - FILE * fp; -{ - return fclose (fp); -} - -static int local_fflush SCM_P ((FILE *fp)); - -static int -local_fflush (fp) - FILE * fp; -{ - return fflush (fp); -} - -static int local_fputc SCM_P ((int c, FILE *fp)); - -static int -local_fputc (c, fp) - int c; - FILE * fp; -{ - return fputc (c, fp); -} - -static int local_fputs SCM_P ((char *s, FILE *fp)); - -static int -local_fputs (s, fp) - char * s; - FILE * fp; -{ - return fputs (s, fp); -} - -static scm_sizet local_ffwrite SCM_P ((void *ptr, int size, int nitems, FILE *fp)); - -static scm_sizet -local_ffwrite (ptr, size, nitems, fp) - void * ptr; - int size; - int nitems; - FILE * fp; -{ - return ffwrite (ptr, size, nitems, fp); -} - - -scm_ptobfuns scm_fptob = -{ - scm_mark0, - (int (*) SCM_P ((SCM))) local_fclose, - prinfport, - 0, - (int (*) SCM_P ((int, SCM))) local_fputc, - (int (*) SCM_P ((char *, SCM))) local_fputs, - (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite, - (int (*) SCM_P ((SCM))) local_fflush, - (int (*) SCM_P ((SCM))) scm_fgetc, - (int (*) SCM_P ((SCM))) local_fclose -}; - -/* {Pipe ports} - */ -scm_ptobfuns scm_pipob = -{ - scm_mark0, - 0, /* replaced by pclose in scm_init_ioext() */ - 0, /* replaced by prinpipe in scm_init_ioext() */ - 0, - (int (*) SCM_P ((int, SCM))) local_fputc, - (int (*) SCM_P ((char *, SCM))) local_fputs, - (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite, - (int (*) SCM_P ((SCM))) local_fflush, - (int (*) SCM_P ((SCM))) scm_fgetc, - 0 -}; /* replaced by pclose in scm_init_ioext() */ - -void -scm_init_fports () -{ -#include "fports.x" -} |