i can compile slang and newt with dietlibc now

1 files changed, 1050 insertions, 0 deletions

diff --git a/mdk-stage1/slang/slstdio.c b/mdk-stage1/slang/slstdio.c
new file mode 100644
index 000000000..05db1af77
--- /dev/null
+++ b/mdk-stage1/slang/slstdio.c
@@ -0,0 +1,1050 @@
+/* file stdio intrinsics for S-Lang */
+/* Copyright (c) 1992, 1999, 2001 John E. Davis
+ * This file is part of the S-Lang library.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Perl Artistic License.
+ */
+
+#include "slinclud.h"
+
+#if defined(__unix__) || (defined (__os2__) && defined (__EMX__))
+# include <sys/types.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+# include <fcntl.h>
+#endif
+#ifdef HAVE_SYS_FCNTL_H
+# include <sys/fcntl.h>
+#endif
+
+#ifdef __unix__
+# include <sys/file.h>
+#endif
+
+#if defined(__BORLANDC__)
+# include <io.h>
+# include <dir.h>
+#endif
+
+#if defined(__DECC) && defined(VMS)
+# include <unixio.h>
+# include <unixlib.h>
+#endif
+
+#ifdef VMS
+# include <stat.h>
+#else
+# include <sys/stat.h>
+#endif
+
+#include <errno.h>
+
+#define SL_APP_WANTS_FOREACH
+#include "slang.h"
+#include "_slang.h"
+
+typedef struct
+{
+   FILE *fp;			       /* kind of obvious */
+   char *file;			       /* file name associated with pointer */
+
+   unsigned int flags;		       /* modes, etc... */
+#define SL_READ		0x0001
+#define SL_WRITE	0x0002
+#define SL_BINARY	0x0004
+#define SL_FDOPEN	0x2000
+#define SL_PIPE		0x4000
+#define SL_INUSE	0x8000
+}
+SL_File_Table_Type;
+
+static SL_File_Table_Type *SL_File_Table;
+
+static SL_File_Table_Type *get_free_file_table_entry (void)
+{
+   SL_File_Table_Type *t = SL_File_Table, *tmax;
+
+   tmax = t + SL_MAX_FILES;
+   while (t < tmax)
+     {
+	if (t->flags == 0)
+	  {
+	     memset ((char *) t, 0, sizeof (SL_File_Table_Type));
+	     return t;
+	  }
+	t++;
+     }
+
+   return NULL;
+}
+
+static unsigned int file_process_flags (char *mode)
+{
+   char ch;
+   unsigned int flags = 0;
+
+   while (1)
+     {
+	ch = *mode++;
+	switch (ch)
+	  {
+	   case 'r': flags |= SL_READ;
+	     break;
+	   case 'w':
+	   case 'a':
+	   case 'A':
+	     flags |= SL_WRITE;
+	     break;
+	   case '+': flags |= SL_WRITE | SL_READ;
+	     break;
+	   case 'b': flags |= SL_BINARY;
+	     break;
+	   case 0:
+	     return flags;
+
+	   default:
+	     SLang_verror (SL_INVALID_PARM, "File flag %c is not supported", ch);
+	     return 0;
+	  }
+     }
+}
+
+static int open_file_type (char *file, int fd, char *mode,
+			   FILE *(*open_fun)(char *, char *),
+			   int (*close_fun)(FILE *),
+			   unsigned int xflags)
+{
+   FILE *fp;
+   SL_File_Table_Type *t;
+   unsigned int flags;
+   SLang_MMT_Type *mmt;
+
+   fp = NULL;
+   t = NULL;
+   mmt = NULL;
+
+   if ((NULL == (t = get_free_file_table_entry ()))
+       || (0 == (flags = file_process_flags(mode))))
+     goto return_error;
+   
+   if (fd != -1)
+     fp = fdopen (fd, mode);
+   else
+     fp = open_fun (file, mode);
+
+   if (fp == NULL)
+     {
+	_SLerrno_errno = errno;
+	goto return_error;
+     }
+
+   if (NULL == (mmt = SLang_create_mmt (SLANG_FILE_PTR_TYPE, (VOID_STAR) t)))
+     goto return_error;
+
+   t->fp = fp;
+   t->flags = flags | xflags;
+   fp = NULL;			       /* allow free_mmt to close fp */
+
+   if ((NULL != (t->file = SLang_create_slstring (file)))
+       && (0 == SLang_push_mmt (mmt)))
+     return 0;
+
+   /* drop */
+
+   return_error:
+   if (fp != NULL) (*close_fun) (fp);
+   if (mmt != NULL) SLang_free_mmt (mmt);
+   (void) SLang_push_null ();
+   return -1;
+}
+
+/* Since some compilers do not have popen/pclose prototyped and in scope,
+ * and pc compilers sometimes have silly prototypes involving PASCAL, etc.
+ * use wrappers around the function to avoid compilation errors.
+ */
+
+static FILE *fopen_fun (char *f, char *m)
+{
+   return fopen (f, m);
+}
+static int fclose_fun (FILE *fp)
+{
+   return fclose (fp);
+}
+
+static void stdio_fopen (char *file, char *mode)
+{
+   (void) open_file_type (file, -1, mode, fopen_fun, fclose_fun, 0);
+}
+
+int _SLstdio_fdopen (char *file, int fd, char *mode)
+{
+   if (fd == -1)
+     {
+	_SLerrno_errno = EBADF;
+	(void) SLang_push_null ();
+	return -1;
+     }
+
+   return open_file_type (file, fd, mode, NULL, fclose_fun, SL_FDOPEN);
+}
+
+#ifdef HAVE_POPEN
+static int pclose_fun (FILE *fp)
+{
+   return pclose (fp);
+}
+
+static FILE *popen_fun (char *file, char *mode)
+{
+   return popen (file, mode);
+}
+
+static void stdio_popen (char *file, char *mode)
+{
+   (void) open_file_type (file, -1, mode, popen_fun, pclose_fun, SL_PIPE);
+}
+#endif
+
+/* returns pointer to file entry if it is open and consistent with
+   flags.  Returns NULL otherwise */
+static SLang_MMT_Type *pop_fp (unsigned int flags, FILE **fp_ptr)
+{
+   SL_File_Table_Type *t;
+   SLang_MMT_Type *mmt;
+
+   *fp_ptr = NULL;
+
+   if (NULL == (mmt = SLang_pop_mmt (SLANG_FILE_PTR_TYPE)))
+     return NULL;
+
+   t = (SL_File_Table_Type *) SLang_object_from_mmt (mmt);
+   if ((t->flags & flags)
+       && (NULL != (*fp_ptr = t->fp)))
+     return mmt;
+
+   SLang_free_mmt (mmt);
+   return NULL;
+}
+
+static FILE *check_fp (SL_File_Table_Type *t, unsigned flags)
+{
+   if ((t != NULL) && (t->flags & flags))
+     return t->fp;
+
+   return NULL;
+}
+
+char *SLang_get_name_from_fileptr (SLang_MMT_Type *mmt)
+{
+   SL_File_Table_Type *ft;
+
+   ft = (SL_File_Table_Type *) SLang_object_from_mmt (mmt);
+   if (ft == NULL)
+     return NULL;
+   return ft->file;
+}
+
+int SLang_pop_fileptr (SLang_MMT_Type **mmt, FILE **fp)
+{
+   if (NULL == (*mmt = pop_fp (0xFFFF, fp)))
+     {
+#ifdef EBADF
+	_SLerrno_errno = EBADF;
+#endif
+	return -1;
+     }
+
+   return 0;
+}
+
+static int close_file_type (SL_File_Table_Type *t)
+{
+   int ret = 0;
+   FILE *fp;
+
+   if (t == NULL)
+     return -1;
+
+   fp = t->fp;
+
+   if (NULL == fp) ret = -1;
+   else
+     {
+	if (0 == (t->flags & SL_PIPE))
+	  {
+	     if (EOF == (ret = fclose (fp)))
+	       _SLerrno_errno = errno;
+	  }
+#ifdef HAVE_POPEN
+	else
+	  {
+	     if (-1 == (ret = pclose (fp)))
+	       _SLerrno_errno = errno;
+	  }
+#endif
+     }
+
+   if (t->file != NULL) SLang_free_slstring (t->file);
+   memset ((char *) t, 0, sizeof (SL_File_Table_Type));
+   return ret;
+}
+
+static int stdio_fclose (SL_File_Table_Type *t)
+{
+   int ret;
+
+   if (NULL == check_fp (t, 0xFFFF))
+     return -1;
+
+   ret = close_file_type (t);
+
+   t->flags = SL_INUSE;
+   return ret;
+}
+
+static int read_one_line (FILE *fp, char **strp, unsigned int *lenp)
+{
+   char buf[512];
+   char *str;
+   unsigned int len;
+
+   *strp = NULL;
+   len = 0;
+   str = NULL;
+
+   while (NULL != fgets (buf, sizeof (buf), fp))
+     {
+	unsigned int dlen;
+	char *new_str;
+	int done_flag;
+
+	dlen = strlen (buf);
+	/* Note: If the file contains embedded \0 characters, then this
+	 * fails to work properly since dlen will not be correct.
+	 */
+	done_flag = ((dlen + 1 < sizeof (buf))
+		     || (buf[dlen - 1] == '\n'));
+
+	if (done_flag && (str == NULL))
+	  {
+	     /* Avoid the malloc */
+	     str = buf;
+	     len = dlen;
+	     break;
+	  }
+
+	if (NULL == (new_str = SLrealloc (str, len + dlen + 1)))
+	  {
+	     SLfree (str);
+	     return -1;
+	  }
+
+	str = new_str;
+	strcpy (str + len, buf);
+	len += dlen;
+
+	if (done_flag) break;
+     }
+
+   if (str == NULL)
+     return 0;
+
+   *strp = SLang_create_nslstring (str, len);
+   if (str != buf) SLfree (str);
+
+   if (*strp == NULL) return -1;
+
+   *lenp = len;
+   return 1;
+}
+
+/* returns number of characters read and pushes the string to the stack.
+   If it fails, it returns -1 */
+static int stdio_fgets (SLang_Ref_Type *ref, SL_File_Table_Type *t)
+{
+   char *s;
+   unsigned int len;
+   FILE *fp;
+   int status;
+
+   if (NULL == (fp = check_fp (t, SL_READ)))
+     return -1;
+
+   status = read_one_line (fp, &s, &len);
+   if (status <= 0)
+     return -1;
+
+   status = SLang_assign_to_ref (ref, SLANG_STRING_TYPE, (VOID_STAR)&s);
+   SLang_free_slstring (s);
+
+   if (status == -1)
+     return -1;
+
+   return (int) len;
+}
+
+static void stdio_fgetslines_internal (FILE *fp, unsigned int n)
+{
+   unsigned int num_lines, max_num_lines;
+   char **list;
+   SLang_Array_Type *at;
+   int inum_lines;
+
+   if (n > 1024)
+     max_num_lines = 1024;
+   else 
+     {
+	max_num_lines = n;
+	if (max_num_lines == 0)
+	  max_num_lines++;
+     }
+
+   list = (char **) SLmalloc (sizeof (char *) * max_num_lines);
+   if (list == NULL)
+     return;
+
+   num_lines = 0;
+   while (num_lines < n)
+     {
+	int status;
+	char *line;
+	unsigned int len;
+
+	status = read_one_line (fp, &line, &len);
+	if (status == -1)
+	  goto return_error;
+
+	if (status == 0)
+	  break;
+
+	if (max_num_lines == num_lines)
+	  {
+	     char **new_list;
+
+	     if (max_num_lines + 4096 > n)
+	       max_num_lines = n;
+	     else
+	       max_num_lines += 4096;
+
+	     new_list = (char **) SLrealloc ((char *)list, sizeof (char *) * max_num_lines);
+	     if (new_list == NULL)
+	       {
+		  SLang_free_slstring (line);
+		  goto return_error;
+	       }
+	     list = new_list;
+	  }
+
+	list[num_lines] = line;
+	num_lines++;
+     }
+
+   if (num_lines != max_num_lines)
+     {
+	char **new_list;
+
+	new_list = (char **)SLrealloc ((char *)list, sizeof (char *) * (num_lines + 1));
+	if (new_list == NULL)
+	  goto return_error;
+
+	list = new_list;
+     }
+
+   inum_lines = (int) num_lines;
+   if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) list, &inum_lines, 1)))
+     goto return_error;
+
+   if (-1 == SLang_push_array (at, 1))
+     SLang_push_null ();
+   return;
+
+   return_error:
+   while (num_lines > 0)
+     {
+	num_lines--;
+	SLfree (list[num_lines]);
+     }
+   SLfree ((char *)list);
+   SLang_push_null ();
+}
+
+static void stdio_fgetslines (void)
+{
+   unsigned int n;
+   FILE *fp;
+   SLang_MMT_Type *mmt;
+
+   n = (unsigned int)-1;
+
+   if (SLang_Num_Function_Args == 2)
+     {
+	if (-1 == SLang_pop_uinteger (&n))
+	  return;
+     }
+   
+   if (NULL == (mmt = pop_fp (SL_READ, &fp)))
+     {
+	SLang_push_null ();
+	return;
+     }
+
+   stdio_fgetslines_internal (fp, n);
+   SLang_free_mmt (mmt);
+}
+
+
+static int stdio_fputs (char *s, SL_File_Table_Type *t)
+{
+   FILE *fp;
+
+   if (NULL == (fp = check_fp (t, SL_WRITE)))
+     return -1;
+
+   if (EOF == fputs(s, fp)) return -1;
+   return (int) strlen (s);
+}
+
+static int stdio_fflush (SL_File_Table_Type *t)
+{
+   FILE *fp;
+
+   if (NULL == (fp = check_fp (t, SL_WRITE)))
+     return -1;
+
+   if (EOF == fflush (fp))
+     {
+	_SLerrno_errno = errno;
+	return -1;
+     }
+
+   return 0;
+}
+
+/* Usage: n = fread (&str, data-type, nelems, fp); */
+static void stdio_fread (SLang_Ref_Type *ref, int *data_typep, unsigned int *num_elemns, SL_File_Table_Type *t)
+{
+   char *s;
+   FILE *fp;
+   int ret;
+   unsigned int num_read, num_to_read;
+   unsigned int nbytes;
+   SLang_Class_Type *cl;
+   unsigned int sizeof_type;
+   int data_type;
+
+   ret = -1;
+   s = NULL;
+   cl = NULL;
+
+   if (NULL == (fp = check_fp (t, SL_READ)))
+     goto the_return;
+
+   /* FIXME: priority = low : I should add some mechanism to support
+    * other types.
+    */
+   data_type = *data_typep;
+
+   cl = _SLclass_get_class ((unsigned char) data_type);
+
+   if (cl->cl_fread == NULL)
+     {
+	SLang_verror (SL_NOT_IMPLEMENTED,
+		      "fread does not support %s objects",
+		      cl->cl_name);
+	goto the_return;
+     }
+
+   sizeof_type = cl->cl_sizeof_type;
+
+   num_to_read = *num_elemns;
+   nbytes = (unsigned int) num_to_read * sizeof_type;
+
+   s = SLmalloc (nbytes + 1);
+   if (s == NULL)
+     goto the_return;
+
+   ret = cl->cl_fread (data_type, fp, (VOID_STAR)s, num_to_read, &num_read);
+
+   if ((num_read == 0)
+       && (num_read != num_to_read))
+     ret = -1;
+
+   if ((ret == -1) && ferror (fp))
+     _SLerrno_errno = errno;
+
+   if ((ret == 0)
+       && (num_read != num_to_read))
+     {
+	char *new_s;
+
+	nbytes = num_read * sizeof_type;
+	new_s = SLrealloc (s, nbytes + 1);
+	if (new_s == NULL)
+	  ret = -1;
+	else
+	  s = new_s;
+     }
+
+   if (ret == 0)
+     {
+	if (num_read == 1)
+	  {
+	     ret = SLang_assign_to_ref (ref, data_type, (VOID_STAR)s);
+	     SLfree (s);
+	  }
+	else if ((data_type == SLANG_CHAR_TYPE)
+		 || (data_type == SLANG_UCHAR_TYPE))
+	  {
+	     SLang_BString_Type *bs;
+
+	     bs = SLbstring_create_malloced ((unsigned char *)s, num_read, 1);
+	     ret = SLang_assign_to_ref (ref, SLANG_BSTRING_TYPE, (VOID_STAR)&bs);
+	     SLbstring_free (bs);
+	  }
+	else
+	  {
+	     SLang_Array_Type *at;
+	     int inum_read = (int) num_read;
+	     at = SLang_create_array (data_type, 0, (VOID_STAR)s, &inum_read, 1);
+	     ret = SLang_assign_to_ref (ref, SLANG_ARRAY_TYPE, (VOID_STAR)&at);
+	     SLang_free_array (at);
+	  }
+	s = NULL;
+     }
+
+   the_return:
+
+   if (s != NULL)
+     SLfree (s);
+   
+   if (ret == -1)
+     SLang_push_integer (ret);
+   else
+     SLang_push_uinteger (num_read);
+}
+
+/* Usage: n = fwrite (str, fp); */
+static void stdio_fwrite (SL_File_Table_Type *t)
+{
+   FILE *fp;
+   unsigned char *s;
+   unsigned int num_to_write, num_write;
+   int ret;
+   SLang_BString_Type *b;
+   SLang_Array_Type *at;
+   SLang_Class_Type *cl;
+
+   ret = -1;
+   b = NULL;
+   at = NULL;
+
+   switch (SLang_peek_at_stack ())
+     {
+      case SLANG_BSTRING_TYPE:
+      case SLANG_STRING_TYPE:
+	if (-1 == SLang_pop_bstring (&b))
+	  goto the_return;
+
+	if (NULL == (s = SLbstring_get_pointer (b, &num_to_write)))
+	  goto the_return;
+
+	cl = _SLclass_get_class (SLANG_UCHAR_TYPE);
+	break;
+
+      default:
+	if (-1 == SLang_pop_array (&at, 1))
+	  goto the_return;
+
+	cl = at->cl;
+	num_to_write = at->num_elements;
+	s = (unsigned char *) at->data;
+     }
+
+   if (NULL == (fp = check_fp (t, SL_WRITE)))
+     goto the_return;
+
+   if (cl->cl_fwrite == NULL)
+     {
+	SLang_verror (SL_NOT_IMPLEMENTED,
+		      "fwrite does not support %s objects", cl->cl_name);
+	goto the_return;
+     }
+
+   ret = cl->cl_fwrite (cl->cl_data_type, fp, s, num_to_write, &num_write);
+
+   if ((ret == -1) && ferror (fp))
+     _SLerrno_errno = errno;
+
+   /* drop */
+   the_return:
+   if (b != NULL)
+     SLbstring_free (b);
+   if (at != NULL)
+     SLang_free_array (at);
+
+   if (ret == -1)
+     SLang_push_integer (ret);
+   else
+     SLang_push_uinteger (num_write);
+}
+
+static int stdio_fseek (SL_File_Table_Type *t, int *ofs, int *whence)
+{
+   FILE *fp;
+
+   if (NULL == (fp = check_fp (t, 0xFFFF)))
+     return -1;
+
+   if (-1  == fseek (fp, (long) *ofs, *whence))
+     {
+	_SLerrno_errno = errno;
+	return -1;
+     }
+
+   return 0;
+}
+
+static int stdio_ftell (SL_File_Table_Type *t)
+{
+   FILE *fp;
+   long ofs;
+
+   if (NULL == (fp = check_fp (t, 0xFFFF)))
+     return -1;
+
+   if (-1L == (ofs = ftell (fp)))
+     {
+	_SLerrno_errno = errno;
+	return -1;
+     }
+
+   return (int) ofs;
+}
+
+static int stdio_feof (SL_File_Table_Type *t)
+{
+   FILE *fp;
+
+   if (NULL == (fp = check_fp (t, 0xFFFF)))
+     return -1;
+
+   return feof (fp);
+}
+
+static int stdio_ferror (SL_File_Table_Type *t)
+{
+   FILE *fp;
+
+   if (NULL == (fp = check_fp (t, 0xFFFF)))
+     return -1;
+
+   return ferror (fp);
+}
+
+static void stdio_clearerr (SL_File_Table_Type *t)
+{
+   FILE *fp;
+
+   if (NULL != (fp = check_fp (t, 0xFFFF)))
+     clearerr (fp);
+}
+
+/* () = fprintf (fp, "FORMAT", arg...); */
+static int stdio_fprintf (void)
+{
+   char *s;
+   FILE *fp;
+   SLang_MMT_Type *mmt;
+   int status;
+
+   if (-1 == _SLstrops_do_sprintf_n (SLang_Num_Function_Args - 2))
+     return -1;
+   
+   if (-1 == SLang_pop_slstring (&s))
+     return -1;
+   
+   if (NULL == (mmt = pop_fp (SL_WRITE, &fp)))
+     {
+	SLang_free_slstring (s);
+	return -1;
+     }
+   
+   if (EOF == fputs(s, fp))
+     status = -1;
+   else
+     status = (int) strlen (s);
+
+   SLang_free_mmt (mmt);
+   SLang_free_slstring (s);
+   return status;
+}
+
+static int stdio_printf (void)
+{
+   char *s;
+   int status;
+
+   if (-1 == _SLstrops_do_sprintf_n (SLang_Num_Function_Args - 1))
+     return -1;
+
+   if (-1 == SLang_pop_slstring (&s))
+     return -1;
+   
+   if (EOF == fputs(s, stdout))
+     status = -1;
+   else
+     status = (int) strlen (s);
+
+   SLang_free_slstring (s);
+   return status;
+}
+
+   
+#define F SLANG_FILE_PTR_TYPE
+#define R SLANG_REF_TYPE
+#define I SLANG_INT_TYPE
+#define V SLANG_VOID_TYPE
+#define S SLANG_STRING_TYPE
+#define B SLANG_BSTRING_TYPE
+#define U SLANG_UINT_TYPE
+#define D SLANG_DATATYPE_TYPE
+static SLang_Intrin_Fun_Type Stdio_Name_Table[] =
+{
+   MAKE_INTRINSIC_0("fgetslines", stdio_fgetslines, V),
+   MAKE_INTRINSIC_SS("fopen", stdio_fopen, V),
+   MAKE_INTRINSIC_1("feof", stdio_feof, I, F),
+   MAKE_INTRINSIC_1("ferror", stdio_ferror, I, F),
+   MAKE_INTRINSIC_1("fclose", stdio_fclose, I, F),
+   MAKE_INTRINSIC_2("fgets", stdio_fgets, I, R, F),
+   MAKE_INTRINSIC_1("fflush", stdio_fflush, I, F),
+   MAKE_INTRINSIC_2("fputs", stdio_fputs, I, S, F),
+   MAKE_INTRINSIC_0("fprintf", stdio_fprintf, I),
+   MAKE_INTRINSIC_0("printf", stdio_printf, I),
+   MAKE_INTRINSIC_3("fseek", stdio_fseek, I, F, I, I),
+   MAKE_INTRINSIC_1("ftell", stdio_ftell, I, F),
+   MAKE_INTRINSIC_1("clearerr", stdio_clearerr, V, F),
+   MAKE_INTRINSIC_4("fread", stdio_fread, V, R, D, U, F),
+   MAKE_INTRINSIC_1("fwrite", stdio_fwrite, V, F),
+#ifdef HAVE_POPEN
+   MAKE_INTRINSIC_SS("popen", stdio_popen, V),
+   MAKE_INTRINSIC_1("pclose", stdio_fclose, I, F),
+#endif
+   SLANG_END_INTRIN_FUN_TABLE
+};
+#undef F
+#undef I
+#undef R
+#undef V
+#undef S
+#undef B
+#undef U
+#undef D
+
+#ifndef SEEK_SET
+# define SEEK_SET 0
+#endif
+#ifndef SEEK_CUR
+# define SEEK_CUR 1
+#endif
+#ifndef SEEK_END
+# define SEEK_END 2
+#endif
+
+static SLang_IConstant_Type Stdio_Consts [] =
+{
+   MAKE_ICONSTANT("SEEK_SET", SEEK_SET),
+   MAKE_ICONSTANT("SEEK_END", SEEK_END),
+   MAKE_ICONSTANT("SEEK_CUR", SEEK_CUR),
+   SLANG_END_ICONST_TABLE
+};
+
+static void destroy_file_type (unsigned char type, VOID_STAR ptr)
+{
+   (void) type;
+   (void) close_file_type ((SL_File_Table_Type *) ptr);
+}
+
+
+struct _SLang_Foreach_Context_Type
+{
+   SLang_MMT_Type *mmt;
+   FILE *fp;
+#define CTX_USE_LINE 1
+#define CTX_USE_CHAR 2
+   unsigned char type;
+};
+
+
+static SLang_Foreach_Context_Type *
+cl_foreach_open (unsigned char type, unsigned int num)
+{
+   SLang_Foreach_Context_Type *c;
+   SLang_MMT_Type *mmt;
+   FILE *fp;
+
+   if (NULL == (mmt = pop_fp (SL_READ, &fp)))
+     return NULL;
+
+   type = CTX_USE_LINE;
+
+   switch (num)
+     {
+	char *s;
+
+      case 0:
+	type = CTX_USE_LINE;
+	break;
+	
+      case 1:
+	if (-1 == SLang_pop_slstring (&s))
+	  {
+	     SLang_free_mmt (mmt);
+	     return NULL;
+	  }
+	if (0 == strcmp (s, "char"))
+	  type = CTX_USE_CHAR;
+	else if (0 == strcmp (s, "line"))
+	  type = CTX_USE_LINE;
+	else
+	  {
+	     SLang_verror (SL_NOT_IMPLEMENTED,
+			   "using '%s' not supported by File_Type",
+			   s);
+	     SLang_free_slstring (s);
+	     SLang_free_mmt (mmt);
+	     return NULL;
+	  }
+	SLang_free_slstring (s);
+	break;
+
+      default:
+	SLdo_pop_n (num);
+	SLang_verror (SL_NOT_IMPLEMENTED, 
+		      "Usage: foreach (File_Type) using ([line|char])");
+	SLang_free_mmt (mmt);
+	return NULL;
+     }
+
+   if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type))))
+     {
+	SLang_free_mmt (mmt);
+	return NULL;
+     }
+   memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type));
+
+   c->type = type;
+   c->mmt = mmt;
+   c->fp = fp;
+
+   return c;
+}
+
+static void cl_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c)
+{
+   (void) type;
+   if (c == NULL) return;
+   SLang_free_mmt (c->mmt);
+   SLfree ((char *) c);
+}
+
+static int cl_foreach (unsigned char type, SLang_Foreach_Context_Type *c)
+{
+   int status;
+   int ch;
+   unsigned int len;
+   char *s;
+
+   (void) type;
+
+   if (c == NULL)
+     return -1;
+   
+   switch (c->type)
+     {
+      case CTX_USE_CHAR:
+	if (EOF == (ch = getc (c->fp)))
+	  return 0;
+	if (-1 == SLang_push_uchar ((unsigned char) ch))
+	  return -1;
+	return 1;
+
+      case CTX_USE_LINE:
+	status = read_one_line (c->fp, &s, &len);
+	if (status <= 0)
+	  return status;
+	if (0 == _SLang_push_slstring (s))
+	  return 1;
+	return -1;
+     }
+   
+   return -1;
+}
+
+static int Stdio_Initialized;
+static SLang_MMT_Type *Stdio_Mmts[3];
+
+int SLang_init_stdio (void)
+{
+   unsigned int i;
+   SL_File_Table_Type *s;
+   SLang_Class_Type *cl;
+   char *names[3];
+
+   if (Stdio_Initialized)
+     return 0;
+
+   SL_File_Table = (SL_File_Table_Type *)SLcalloc(sizeof (SL_File_Table_Type), SL_MAX_FILES);
+   if (SL_File_Table == NULL)
+     return -1;
+
+   if (NULL == (cl = SLclass_allocate_class ("File_Type")))
+     return -1;
+   cl->cl_destroy = destroy_file_type;
+   cl->cl_foreach_open = cl_foreach_open;
+   cl->cl_foreach_close = cl_foreach_close;
+   cl->cl_foreach = cl_foreach;
+
+
+   if (-1 == SLclass_register_class (cl, SLANG_FILE_PTR_TYPE, sizeof (SL_File_Table_Type), SLANG_CLASS_TYPE_MMT))
+     return -1;
+
+   if ((-1 == SLadd_intrin_fun_table(Stdio_Name_Table, "__STDIO__"))
+       || (-1 == SLadd_iconstant_table (Stdio_Consts, NULL))
+       || (-1 == _SLerrno_init ()))
+     return -1;
+
+   names[0] = "stdin";
+   names[1] = "stdout";
+   names[2] = "stderr";
+
+   s = SL_File_Table;
+   s->fp = stdin;  s->flags = SL_READ;
+
+   s++;
+   s->fp = stdout;  s->flags = SL_WRITE;
+
+   s++;
+   s->fp = stderr;  s->flags = SL_WRITE|SL_READ;
+
+   s = SL_File_Table;
+   for (i = 0; i < 3; i++)
+     {
+	if (NULL == (s->file = SLang_create_slstring (names[i])))
+	  return -1;
+
+	if (NULL == (Stdio_Mmts[i] = SLang_create_mmt (SLANG_FILE_PTR_TYPE, (VOID_STAR) s)))
+	  return -1;
+	SLang_inc_mmt (Stdio_Mmts[i]);
+
+	if (-1 == SLadd_intrinsic_variable (s->file, (VOID_STAR)&Stdio_Mmts[i], SLANG_FILE_PTR_TYPE, 1))
+	  return -1;
+	s++;
+     }
+
+   Stdio_Initialized = 1;
+   return 0;
+}
+