--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/critsec.h,v 1.1 1990/06/20 19:35:41 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Critical sections.
+ There should be a stack of critical sections, each with a
+ queue of hooks. */
+
+extern char * critical_section_name;
+extern int critical_section_hook_p;
+extern void (*critical_section_hook) ();
+
+#define DECLARE_CRITICAL_SECTION() \
+ char * critical_section_name = 0; \
+ int critical_section_hook_p; \
+ void (*critical_section_hook) ()
+
+#define ENTER_CRITICAL_SECTION(name) critical_section_name = (name)
+#define RENAME_CRITICAL_SECTION(name) critical_section_name = (name)
+
+#define EXIT_CRITICAL_SECTION(code_if_hook) \
+{ \
+ if (critical_section_hook_p) \
+ { \
+ code_if_hook; \
+ { \
+ char * name = critical_section_name; \
+ critical_section_hook_p = 0; \
+ critical_section_name = 0; \
+ (*critical_section_hook) (name); \
+ } \
+ } \
+ else \
+ critical_section_name = 0; \
+}
+
+#define SET_CRITICAL_SECTION_HOOK(hook) \
+{ \
+ critical_section_hook = (hook); \
+ critical_section_hook_p = 1; \
+}
+
+#define CLEAR_CRITICAL_SECTION_HOOK() critical_section_hook_p = 0
+#define WITHIN_CRITICAL_SECTION_P() (critical_section_name != 0)
+#define CRITICAL_SECTION_NAME() (critical_section_name)
--- /dev/null
+/* Copyright (C) 1990 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 1, 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 program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/dstack.h,v 1.1 1990/06/20 19:35:44 cph Rel $ */
+
+#ifndef __DSTACK_H__
+#define __DSTACK_H__
+
+#include "ansidecl.h"
+#include <setjmp.h>
+
+extern void EXFUN (dstack_initialize, (void));
+/* Call this once to initialize the stack. */
+
+extern void EXFUN (dstack_reset, (void));
+/* Call this once to reset the stack. */
+
+extern PTR EXFUN (dstack_alloc, (unsigned int length));
+/* Allocate a chunk of `length' bytes of space on the stack and return
+ a pointer to it. */
+
+extern void EXFUN
+ (dstack_protect,
+ (void EXFUN ((*protector), (PTR environment)), PTR environment));
+/* Create an unwind protection frame which invokes `protector' when
+ the stack is unwound. `environment' is passed to `protector' as
+ its sole argument when it is invoked. */
+
+extern PTR dstack_position;
+/* The current stack pointer. */
+
+extern void EXFUN (dstack_set_position, (PTR position));
+/* Unwind the stack to `position', which must be a previous value of
+ `dstack_position'. */
+
+typedef struct
+{
+ PTR stack_pointer;
+ jmp_buf env;
+} Tcatch_tag;
+
+#define CATCH(tag) \
+ ((((tag) . stack_pointer) = dstack_position), \
+ (setjmp ((tag) . env)))
+
+#define THROW(tag, value) \
+{ \
+ /* Copy `tag' in case it is dstack-allocated. */ \
+ /* Must split declaration and assignment because some compilers \
+ do not permit aggregate initializers. */ \
+ Tcatch_tag THROW_tag; \
+ THROW_tag = (tag); \
+ dstack_set_position (THROW_tag . stack_pointer); \
+ longjmp ((THROW_tag . env), (value)); \
+}
+
+extern void EXFUN (dstack_bind, (PTR location, PTR value));
+/* Dynamically bind `location' to `value'. `location' is treated as
+ `PTR*' -- it is declared `PTR' for programming convenience. */
+
+enum transaction_action_type { tat_abort, tat_commit, tat_always };
+
+extern void EXFUN (transaction_initialize, (void));
+extern void EXFUN (transaction_begin, (void));
+extern void EXFUN (transaction_abort, (void));
+extern void EXFUN (transaction_commit, (void));
+extern void EXFUN
+ (transaction_record_action,
+ (enum transaction_action_type type,
+ void EXFUN ((*procedure), (PTR environment)),
+ PTR environment));
+\f
+typedef unsigned long Tptrvec_index;
+typedef unsigned long Tptrvec_length;
+
+struct struct_ptrvec
+{
+ Tptrvec_length length;
+ PTR * elements;
+};
+typedef struct struct_ptrvec * Tptrvec;
+
+#define PTRVEC_LENGTH(ptrvec) ((ptrvec) -> length)
+#define PTRVEC_REF(ptrvec, index) (((ptrvec) -> elements) [(index)])
+#define PTRVEC_LOC(ptrvec, index) (& (PTRVEC_REF ((ptrvec), (index))))
+#define PTRVEC_START(ptrvec) (PTRVEC_LOC ((ptrvec), 0))
+#define PTRVEC_END(ptrvec) (PTRVEC_LOC ((ptrvec), (PTRVEC_LENGTH (ptrvec))))
+
+extern Tptrvec EXFUN (ptrvec_allocate, (Tptrvec_length length));
+extern void EXFUN (ptrvec_deallocate, (Tptrvec ptrvec));
+extern void EXFUN (ptrvec_set_length, (Tptrvec ptrvec, Tptrvec_length length));
+extern Tptrvec EXFUN (ptrvec_copy, (Tptrvec ptrvec));
+extern void EXFUN (ptrvec_adjoin, (Tptrvec ptrvec, PTR element));
+extern int EXFUN (ptrvec_memq, (Tptrvec ptrvec, PTR element));
+extern void EXFUN
+ (ptrvec_move_left,
+ (Tptrvec source, Tptrvec_index source_start, Tptrvec_index source_end,
+ Tptrvec target, Tptrvec_index target_start));
+extern void EXFUN
+ (ptrvec_move_right,
+ (Tptrvec source, Tptrvec_index source_start, Tptrvec_index source_end,
+ Tptrvec target, Tptrvec_index target_start));
+\f
+typedef struct condition_type * Tcondition_type;
+typedef struct condition * Tcondition;
+typedef struct condition_restart * Tcondition_restart;
+
+struct condition_type
+{
+ unsigned long index;
+ PTR name;
+ Tptrvec generalizations;
+ void EXFUN ((*reporter), (Tcondition condition));
+};
+#define CONDITION_TYPE_INDEX(type) ((type) -> index)
+#define CONDITION_TYPE_NAME(type) ((type) -> name)
+#define CONDITION_TYPE_GENERALIZATIONS(type) ((type) -> generalizations)
+#define CONDITION_TYPE_REPORTER(type) ((type) -> reporter)
+
+struct condition
+{
+ Tcondition_type type;
+ Tptrvec irritants;
+};
+#define CONDITION_TYPE(condition) ((condition) -> type)
+#define CONDITION_IRRITANTS(condition) ((condition) -> irritants)
+
+struct condition_restart
+{
+ PTR name;
+ Tcondition_type type;
+ void EXFUN ((*procedure), (PTR argument));
+};
+#define CONDITION_RESTART_NAME(restart) ((restart) -> name)
+#define CONDITION_RESTART_TYPE(restart) ((restart) -> type)
+#define CONDITION_RESTART_PROCEDURE(restart) ((restart) -> procedure)
+
+/* Allocate and return a new condition type object. */
+extern Tcondition_type EXFUN
+ (condition_type_allocate,
+ (PTR name,
+ Tptrvec generalizations,
+ void EXFUN ((*reporter), (Tcondition condition))));
+
+/* Deallocate the condition type object `type'. */
+extern void EXFUN (condition_type_deallocate, (Tcondition_type type));
+
+/* Allocate and return a new condition object. */
+extern Tcondition EXFUN
+ (condition_allocate, (Tcondition_type type, Tptrvec irritants));
+
+/* Deallocate the condition object `condition'. */
+extern void EXFUN (condition_deallocate, (Tcondition condition));
+
+/* Bind a handler for the condition type object `type'. */
+extern void EXFUN
+ (condition_handler_bind,
+ (Tcondition_type type, void EXFUN ((*handler), (Tcondition condition))));
+
+/* Signal `condition'. */
+extern void EXFUN (condition_signal, (Tcondition condition));
+
+/* Bind a restart called `name' for the condition type object `type'.
+ Invoking the restart causes `restart_procedure' to be executed. */
+extern void EXFUN
+ (condition_restart_bind,
+ (PTR name,
+ Tcondition_type type,
+ void EXFUN ((*procedure), (PTR argument))));
+
+/* Find a restart called `name' that matches `condition'.
+ If `condition' is 0, any restart called `name' will do.
+ If no such restart exists, 0 is returned. */
+extern Tcondition_restart EXFUN
+ (condition_restart_find, (PTR name, Tcondition condition));
+
+/* Return a ptrvec of the restarts that match `condition'.
+ If `condition' is 0, all restarts are returned. */
+extern Tptrvec EXFUN (condition_restarts, (Tcondition condition));
+
+#endif /* __DSTACK_H__ */
--- /dev/null
+/* Copyright (C) 1990 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 1, 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 program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/error.c,v 1.1 1990/06/20 19:35:47 cph Rel $ */
+
+#include <stdio.h>
+#include "dstack.h"
+
+static PTR
+DEFUN (xmalloc, (length), unsigned int length)
+{
+ extern PTR EXFUN (malloc, (unsigned int length));
+ PTR result = (malloc (length));
+ if (result == 0)
+ {
+ fputs ("malloc: memory allocation failed\n", stderr);
+ fflush (stderr);
+ abort ();
+ }
+ return (result);
+}
+\f
+struct handler_record
+{
+ struct handler_record * next;
+ Tcondition_type type;
+ void EXFUN ((*handler), (Tcondition condition));
+};
+
+struct restart_record
+{
+ struct restart_record * next;
+ struct condition_restart contents;
+};
+
+static unsigned long next_condition_type_index;
+static struct handler_record * current_handler_record;
+static struct restart_record * current_restart_record;
+
+void
+DEFUN_VOID (initialize_condition_system)
+{
+ next_condition_type_index = 0;
+ current_handler_record = 0;
+ current_restart_record = 0;
+}
+
+Tcondition_type
+DEFUN (condition_type_allocate, (name, generalizations, reporter),
+ PTR name AND
+ Tptrvec generalizations AND
+ void EXFUN ((*reporter), (Tcondition condition)))
+{
+ static Tptrvec EXFUN (generalizations_union, (Tptrvec generalizations));
+ Tcondition_type type = (xmalloc (sizeof (struct condition_type)));
+ Tptrvec g = (generalizations_union (generalizations));
+ ptrvec_adjoin (g, type);
+ (CONDITION_TYPE_INDEX (type)) = (next_condition_type_index++);
+ (CONDITION_TYPE_NAME (type)) = name;
+ (CONDITION_TYPE_GENERALIZATIONS (type)) = g;
+ (CONDITION_TYPE_REPORTER (type)) = reporter;
+ return (type);
+}
+
+void
+DEFUN (condition_type_deallocate, (type), Tcondition_type type)
+{
+ ptrvec_deallocate (CONDITION_TYPE_GENERALIZATIONS (type));
+ free (type);
+}
+
+Tcondition
+DEFUN (condition_allocate, (type, irritants),
+ Tcondition_type type AND
+ Tptrvec irritants)
+{
+ Tcondition condition = (xmalloc (sizeof (struct condition)));
+ (CONDITION_TYPE (condition)) = type;
+ (CONDITION_IRRITANTS (condition)) = irritants;
+ return (condition);
+}
+
+void
+DEFUN (condition_deallocate, (condition), Tcondition condition)
+{
+ ptrvec_deallocate (CONDITION_IRRITANTS (condition));
+ free (condition);
+}
+\f
+static Tptrvec
+DEFUN (generalizations_union_2, (x, y), Tptrvec x AND Tptrvec y)
+{
+ PTR * scan_x = (PTRVEC_START (x));
+ PTR * end_x = (scan_x + (PTRVEC_LENGTH (x)));
+ PTR * scan_y = (PTRVEC_START (y));
+ PTR * end_y = (scan_y + (PTRVEC_LENGTH (y)));
+ Tptrvec_length length = 0;
+ unsigned long ix;
+ unsigned long iy;
+ Tptrvec result;
+ PTR * scan_result;
+ while (1)
+ {
+ if (scan_x == end_x)
+ {
+ length += (end_y - scan_y);
+ break;
+ }
+ if (scan_y == end_y)
+ {
+ length += (end_x - scan_x);
+ break;
+ }
+ length += 1;
+ ix = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_x)));
+ iy = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_y)));
+ if (ix <= iy) scan_x += 1;
+ if (iy <= ix) scan_y += 1;
+ }
+ result = (ptrvec_allocate (length));
+ scan_result = (PTRVEC_START (result));
+ while (1)
+ {
+ if (scan_x == end_x)
+ {
+ while (scan_y < end_y) (*scan_result++) = (*scan_y++);
+ break;
+ }
+ if (scan_y == end_y)
+ {
+ while (scan_x < end_x) (*scan_result++) = (*scan_x++);
+ break;
+ }
+ ix = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_x)));
+ iy = (CONDITION_TYPE_INDEX ((Tcondition_type) (*scan_y)));
+ if (ix == iy)
+ {
+ (*scan_result++) = (*scan_x++);
+ scan_y += 1;
+ }
+ else
+ (*scan_result++) = ((ix < iy) ? (*scan_x++) : (*scan_y++));
+ }
+ return (result);
+}
+
+static Tptrvec
+DEFUN (generalizations_union, (generalizations), Tptrvec generalizations)
+{
+ Tptrvec_length length = (PTRVEC_LENGTH (generalizations));
+ if (length == 0)
+ return (ptrvec_allocate (0));
+ if (length == 1)
+ return (ptrvec_copy (PTRVEC_REF (generalizations, 0)));
+ {
+ PTR * scan = (PTRVEC_START (generalizations));
+ PTR * end = (scan + length);
+ Tptrvec result = ((Tptrvec) (*scan++));
+ result = (generalizations_union_2 (result, ((Tptrvec) (*scan++))));
+ while (scan < end)
+ {
+ Tptrvec v = (generalizations_union_2 (result, ((Tptrvec) (*scan++))));
+ ptrvec_deallocate (result);
+ result = v;
+ }
+ return (result);
+ }
+}
+\f
+void
+DEFUN (condition_handler_bind, (type, handler),
+ Tcondition_type type AND
+ void EXFUN ((*handler), (Tcondition condition)))
+{
+ struct handler_record * record =
+ (dstack_alloc (sizeof (struct handler_record)));
+ (record -> next) = current_handler_record;
+ (record -> type) = type;
+ (record -> handler) = handler;
+ dstack_bind ((¤t_handler_record), record);
+}
+
+#define GENERALIZATIONS(condition) \
+ (CONDITION_TYPE_GENERALIZATIONS (CONDITION_TYPE (condition)))
+
+void
+DEFUN (condition_signal, (condition), Tcondition condition)
+{
+ Tptrvec generalizations = (GENERALIZATIONS (condition));
+ struct handler_record * record = current_handler_record;
+ while (record != 0)
+ {
+ Tcondition_type type = (record -> type);
+ if ((type == 0) || (ptrvec_memq (generalizations, type)))
+ {
+ PTR position = dstack_position;
+ dstack_bind ((¤t_handler_record), (record -> next));
+ (* (record -> handler)) (condition);
+ dstack_set_position (position);
+ }
+ record = (record -> next);
+ }
+}
+\f
+void
+DEFUN (condition_restart_bind, (name, type, procedure),
+ PTR name AND
+ Tcondition_type type AND
+ void EXFUN ((*procedure), (PTR argument)))
+{
+ struct restart_record * record =
+ (dstack_alloc (sizeof (struct restart_record)));
+ (record -> next) = current_restart_record;
+ (record -> contents . name) = name;
+ (record -> contents . type) = type;
+ (record -> contents . procedure) = procedure;
+ dstack_bind ((¤t_restart_record), record);
+}
+
+Tcondition_restart
+DEFUN (condition_restart_find, (name, condition),
+ PTR name AND
+ Tcondition condition)
+{
+ struct restart_record * record = current_restart_record;
+ if (condition == 0)
+ while (record != 0)
+ {
+ if ((record -> contents . name) == name)
+ return (& (record -> contents));
+ record = (record -> next);
+ }
+ else
+ {
+ Tptrvec generalizations = (GENERALIZATIONS (condition));
+ while (record != 0)
+ {
+ if (((record -> contents . name) == name) &&
+ (ptrvec_memq (generalizations, (record -> contents . type))))
+ return (& (record -> contents));
+ record = (record -> next);
+ }
+ }
+ return (0);
+}
+
+Tptrvec
+DEFUN (condition_restarts, (condition), Tcondition condition)
+{
+ struct restart_record * record = current_restart_record;
+ Tptrvec_length length = 0;
+ Tptrvec generalizations;
+ Tptrvec result;
+ PTR * scan_result;
+ if (condition == 0)
+ while (record != 0)
+ {
+ length += 1;
+ record = (record -> next);
+ }
+ else
+ {
+ generalizations = (GENERALIZATIONS (condition));
+ while (record != 0)
+ {
+ if (ptrvec_memq (generalizations, (record -> contents . type)))
+ length += 1;
+ record = (record -> next);
+ }
+ }
+ result = (ptrvec_allocate (length));
+ scan_result = (PTRVEC_START (result));
+ record = current_restart_record;
+ if (condition == 0)
+ while (record != 0)
+ {
+ (*scan_result++) = (& (record -> contents));
+ record = (record -> next);
+ }
+ else
+ while (record != 0)
+ {
+ if (ptrvec_memq (generalizations, (record -> contents . type)))
+ (*scan_result++) = (& (record -> contents));
+ record = (record -> next);
+ }
+ return (result);
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intext.c,v 1.1 1990/06/20 19:35:50 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ansidecl.h"
+#include "dstack.h"
+#include "intext.h"
+
+struct interruptable_extent * current_interruptable_extent;
+
+void
+DEFUN_VOID (initialize_interruptable_extent)
+{
+ current_interruptable_extent = 0;
+}
+
+void
+DEFUN_VOID (reset_interruptable_extent)
+{
+ current_interruptable_extent = 0;
+}
+
+struct interruptable_extent *
+DEFUN_VOID (enter_interruptable_extent)
+{
+ PTR position = dstack_position;
+ struct interruptable_extent * frame =
+ (dstack_alloc (sizeof (struct interruptable_extent)));
+ (frame -> position) = position;
+ (frame -> interrupted) = 0;
+ /* Create a dynamic binding frame but don't assign the new frame to
+ it until the CATCH has been done. */
+ dstack_bind ((¤t_interruptable_extent), current_interruptable_extent);
+ return (frame);
+}
+
+/* It is possible that two signals arriving close together could both
+ set `interrupted'. This does not matter, because the signal
+ handlers haven't done anything at this point, and the net effect is
+ to cause the second signal handler to do the longjmp, rather than
+ the first. However, the first signal handler never runs, which may
+ be a problem for some applications. */
+
+int
+DEFUN_VOID (enter_interruption_extent)
+{
+ if ((current_interruptable_extent == 0)
+ || (current_interruptable_extent -> interrupted))
+ return (0);
+ (current_interruptable_extent -> interrupted) = 1;
+ return (1);
+}
+
+void
+DEFUN_VOID (exit_interruption_extent)
+{
+ THROW ((current_interruptable_extent -> control_point), 1);
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intext.h,v 1.1 1990/06/20 19:35:53 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_INTEXT_H
+#define SCM_INTEXT_H
+
+#include "ansidecl.h"
+#include "dstack.h"
+
+struct interruptable_extent
+{
+ PTR position;
+ Tcatch_tag control_point;
+ int interrupted;
+};
+
+extern struct interruptable_extent * current_interruptable_extent;
+extern void EXFUN (initialize_interruptable_extent, (void));
+extern void EXFUN (reset_interruptable_extent, (void));
+extern struct interruptable_extent * EXFUN
+ (enter_interruptable_extent, (void));
+extern int EXFUN (enter_interruption_extent, (void));
+extern void EXFUN (exit_interruption_extent, (void));
+
+#define INTERRUPTABLE_EXTENT(result, expression) \
+{ \
+ struct interruptable_extent * INTERRUPTABLE_EXTENT_frame = \
+ (enter_interruptable_extent ()); \
+ if ((CATCH (INTERRUPTABLE_EXTENT_frame -> control_point)) == 0) \
+ { \
+ current_interruptable_extent = INTERRUPTABLE_EXTENT_frame; \
+ (result) = (expression); \
+ } \
+ else \
+ { \
+ errno = EINTR; \
+ (result) = (-1); \
+ } \
+ dstack_set_position (current_interruptable_extent -> position); \
+}
+
+#endif /* SCM_INTEXT_H */
--- /dev/null
+/* obstack.c - subroutines used implicitly by object stack macros
+ Copyright (C) 1988 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 1, 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 program; if not, write to the Free Software
+Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "obstack.h"
+
+#ifdef __STDC__
+#define POINTER void *
+#else
+#define POINTER char *
+#endif
+
+/* Determine default alignment. */
+struct fooalign {char x; double d;};
+#define DEFAULT_ALIGNMENT ((char *)&((struct fooalign *) 0)->d - (char *)0)
+/* If malloc were really smart, it would round addresses to DEFAULT_ALIGNMENT.
+ But in fact it might be less smart and round addresses to as much as
+ DEFAULT_ROUNDING. So we prepare for it to do that. */
+union fooround {long x; double d;};
+#define DEFAULT_ROUNDING (sizeof (union fooround))
+
+/* When we copy a long block of data, this is the unit to do it with.
+ On some machines, copying successive ints does not work;
+ in such a case, redefine COPYING_UNIT to `long' (if that works)
+ or `char' as a last resort. */
+#ifndef COPYING_UNIT
+#define COPYING_UNIT int
+#endif
+
+/* The non-GNU-C macros copy the obstack into this global variable
+ to avoid multiple evaluation. */
+
+struct obstack *_obstack;
+\f
+/* Initialize an obstack H for use. Specify chunk size SIZE (0 means default).
+ Objects start on multiples of ALIGNMENT (0 means use default).
+ CHUNKFUN is the function to use to allocate chunks,
+ and FREEFUN the function to free them. */
+
+void
+_obstack_begin (h, size, alignment, chunkfun, freefun)
+ struct obstack *h;
+ int size;
+ int alignment;
+ POINTER (*chunkfun) ();
+ void (*freefun) ();
+{
+ register struct _obstack_chunk* chunk; /* points to new chunk */
+
+ if (alignment == 0)
+ alignment = DEFAULT_ALIGNMENT;
+ if (size == 0)
+ /* Default size is what GNU malloc can fit in a 4096-byte block. */
+ {
+ /* 12 is sizeof (mhead) and 4 is EXTRA from GNU malloc.
+ Use the values for range checking, because if range checking is off,
+ the extra bytes won't be missed terribly, but if range checking is on
+ and we used a larger request, a whole extra 4096 bytes would be
+ allocated.
+
+ These number are irrelevant to the new GNU malloc. I suspect it is
+ less sensitive to the size of the request. */
+ int extra = ((((12 + DEFAULT_ROUNDING - 1) & ~(DEFAULT_ROUNDING - 1))
+ + 4 + DEFAULT_ROUNDING - 1)
+ & ~(DEFAULT_ROUNDING - 1));
+ size = 4096 - extra;
+ }
+
+ h->chunkfun = (struct _obstack_chunk * (*)()) chunkfun;
+ h->freefun = freefun;
+ h->chunk_size = size;
+ h->alignment_mask = alignment - 1;
+
+ chunk = h->chunk = (*h->chunkfun) (h->chunk_size);
+ h->next_free = h->object_base = chunk->contents;
+ h->chunk_limit = chunk->limit
+ = (char *) chunk + h->chunk_size;
+ chunk->prev = 0;
+}
+
+/* Allocate a new current chunk for the obstack *H
+ on the assumption that LENGTH bytes need to be added
+ to the current object, or a new object of length LENGTH allocated.
+ Copies any partial object from the end of the old chunk
+ to the beginning of the new one. */
+
+void
+_obstack_newchunk (h, length)
+ struct obstack *h;
+ int length;
+{
+ register struct _obstack_chunk* old_chunk = h->chunk;
+ register struct _obstack_chunk* new_chunk;
+ register long new_size;
+ register int obj_size = h->next_free - h->object_base;
+ register int i;
+ int already;
+
+ /* Compute size for new chunk. */
+ new_size = (obj_size + length) + (obj_size >> 3) + 100;
+ if (new_size < h->chunk_size)
+ new_size = h->chunk_size;
+
+ /* Allocate and initialize the new chunk. */
+ new_chunk = h->chunk = (*h->chunkfun) (new_size);
+ new_chunk->prev = old_chunk;
+ new_chunk->limit = h->chunk_limit = (char *) new_chunk + new_size;
+
+ /* Move the existing object to the new chunk.
+ Word at a time is fast and is safe if the object
+ is sufficiently aligned. */
+ if (h->alignment_mask + 1 >= DEFAULT_ALIGNMENT)
+ {
+ for (i = obj_size / sizeof (COPYING_UNIT) - 1;
+ i >= 0; i--)
+ ((COPYING_UNIT *)new_chunk->contents)[i]
+ = ((COPYING_UNIT *)h->object_base)[i];
+ /* We used to copy the odd few remaining bytes as one extra COPYING_UNIT,
+ but that can cross a page boundary on a machine
+ which does not do strict alignment for COPYING_UNITS. */
+ already = obj_size / sizeof (COPYING_UNIT) * sizeof (COPYING_UNIT);
+ }
+ else
+ already = 0;
+ /* Copy remaining bytes one by one. */
+ for (i = already; i < obj_size; i++)
+ new_chunk->contents[i] = h->object_base[i];
+
+ h->object_base = new_chunk->contents;
+ h->next_free = h->object_base + obj_size;
+}
+
+/* Return nonzero if object OBJ has been allocated from obstack H.
+ This is here for debugging.
+ If you use it in a program, you are probably losing. */
+
+int
+_obstack_allocated_p (h, obj)
+ struct obstack *h;
+ POINTER obj;
+{
+ register struct _obstack_chunk* lp; /* below addr of any objects in this chunk */
+ register struct _obstack_chunk* plp; /* point to previous chunk if any */
+
+ lp = (h)->chunk;
+ while (lp != 0 && ((POINTER)lp > obj || (POINTER)(lp)->limit < obj))
+ {
+ plp = lp -> prev;
+ lp = plp;
+ }
+ return lp != 0;
+}
+
+/* Free objects in obstack H, including OBJ and everything allocate
+ more recently than OBJ. If OBJ is zero, free everything in H. */
+
+void
+#ifdef __STDC__
+#undef obstack_free
+obstack_free (struct obstack *h, POINTER obj)
+#else
+_obstack_free (h, obj)
+ struct obstack *h;
+ POINTER obj;
+#endif
+{
+ register struct _obstack_chunk* lp; /* below addr of any objects in this chunk */
+ register struct _obstack_chunk* plp; /* point to previous chunk if any */
+
+ lp = (h)->chunk;
+ /* We use >= because there cannot be an object at the beginning of a chunk.
+ But there can be an empty object at that address
+ at the end of another chunk. */
+ while (lp != 0 && ((POINTER)lp >= obj || (POINTER)(lp)->limit < obj))
+ {
+ plp = lp -> prev;
+ (*h->freefun) (lp);
+ lp = plp;
+ }
+ if (lp)
+ {
+ (h)->object_base = (h)->next_free = (char *)(obj);
+ (h)->chunk_limit = lp->limit;
+ (h)->chunk = lp;
+ }
+ else if (obj != 0)
+ /* obj is not in any of the chunks! */
+ abort ();
+}
+
+/* Let same .o link with output of gcc and other compilers. */
+
+#ifdef __STDC__
+void
+_obstack_free (h, obj)
+ struct obstack *h;
+ POINTER obj;
+{
+ obstack_free (h, obj);
+}
+#endif
+\f
+#if 0
+/* These are now turned off because the applications do not use it
+ and it uses bcopy via obstack_grow, which causes trouble on sysV. */
+
+/* Now define the functional versions of the obstack macros.
+ Define them to simply use the corresponding macros to do the job. */
+
+#ifdef __STDC__
+/* These function definitions do not work with non-ANSI preprocessors;
+ they won't pass through the macro names in parentheses. */
+
+/* The function names appear in parentheses in order to prevent
+ the macro-definitions of the names from being expanded there. */
+
+POINTER (obstack_base) (obstack)
+ struct obstack *obstack;
+{
+ return obstack_base (obstack);
+}
+
+POINTER (obstack_next_free) (obstack)
+ struct obstack *obstack;
+{
+ return obstack_next_free (obstack);
+}
+
+int (obstack_object_size) (obstack)
+ struct obstack *obstack;
+{
+ return obstack_object_size (obstack);
+}
+
+int (obstack_room) (obstack)
+ struct obstack *obstack;
+{
+ return obstack_room (obstack);
+}
+
+void (obstack_grow) (obstack, pointer, length)
+ struct obstack *obstack;
+ POINTER pointer;
+ int length;
+{
+ obstack_grow (obstack, pointer, length);
+}
+
+void (obstack_grow0) (obstack, pointer, length)
+ struct obstack *obstack;
+ POINTER pointer;
+ int length;
+{
+ obstack_grow0 (obstack, pointer, length);
+}
+
+void (obstack_1grow) (obstack, character)
+ struct obstack *obstack;
+ int character;
+{
+ obstack_1grow (obstack, character);
+}
+
+void (obstack_blank) (obstack, length)
+ struct obstack *obstack;
+ int length;
+{
+ obstack_blank (obstack, length);
+}
+
+void (obstack_1grow_fast) (obstack, character)
+ struct obstack *obstack;
+ int character;
+{
+ obstack_1grow_fast (obstack, character);
+}
+
+void (obstack_blank_fast) (obstack, length)
+ struct obstack *obstack;
+ int length;
+{
+ obstack_blank_fast (obstack, length);
+}
+
+POINTER (obstack_finish) (obstack)
+ struct obstack *obstack;
+{
+ return obstack_finish (obstack);
+}
+
+POINTER (obstack_alloc) (obstack, length)
+ struct obstack *obstack;
+ int length;
+{
+ return obstack_alloc (obstack, length);
+}
+
+POINTER (obstack_copy) (obstack, pointer, length)
+ struct obstack *obstack;
+ POINTER pointer;
+ int length;
+{
+ return obstack_copy (obstack, pointer, length);
+}
+
+POINTER (obstack_copy0) (obstack, pointer, length)
+ struct obstack *obstack;
+ POINTER pointer;
+ int length;
+{
+ return obstack_copy0 (obstack, pointer, length);
+}
+
+#endif /* __STDC__ */
+
+#endif /* 0 */
--- /dev/null
+/* obstack.h - object stack macros
+ Copyright (C) 1988 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 1, 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 program; if not, write to the Free Software
+Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+/* Summary:
+
+All the apparent functions defined here are macros. The idea
+is that you would use these pre-tested macros to solve a
+very specific set of problems, and they would run fast.
+Caution: no side-effects in arguments please!! They may be
+evaluated MANY times!!
+
+These macros operate a stack of objects. Each object starts life
+small, and may grow to maturity. (Consider building a word syllable
+by syllable.) An object can move while it is growing. Once it has
+been "finished" it never changes address again. So the "top of the
+stack" is typically an immature growing object, while the rest of the
+stack is of mature, fixed size and fixed address objects.
+
+These routines grab large chunks of memory, using a function you
+supply, called `obstack_chunk_alloc'. On occasion, they free chunks,
+by calling `obstack_chunk_free'. You must define them and declare
+them before using any obstack macros.
+
+Each independent stack is represented by a `struct obstack'.
+Each of the obstack macros expects a pointer to such a structure
+as the first argument.
+
+One motivation for this package is the problem of growing char strings
+in symbol tables. Unless you are "fascist pig with a read-only mind"
+[Gosper's immortal quote from HAKMEM item 154, out of context] you
+would not like to put any arbitrary upper limit on the length of your
+symbols.
+
+In practice this often means you will build many short symbols and a
+few long symbols. At the time you are reading a symbol you don't know
+how long it is. One traditional method is to read a symbol into a
+buffer, realloc()ating the buffer every time you try to read a symbol
+that is longer than the buffer. This is beaut, but you still will
+want to copy the symbol from the buffer to a more permanent
+symbol-table entry say about half the time.
+
+With obstacks, you can work differently. Use one obstack for all symbol
+names. As you read a symbol, grow the name in the obstack gradually.
+When the name is complete, finalize it. Then, if the symbol exists already,
+free the newly read name.
+
+The way we do this is to take a large chunk, allocating memory from
+low addresses. When you want to build a symbol in the chunk you just
+add chars above the current "high water mark" in the chunk. When you
+have finished adding chars, because you got to the end of the symbol,
+you know how long the chars are, and you can create a new object.
+Mostly the chars will not burst over the highest address of the chunk,
+because you would typically expect a chunk to be (say) 100 times as
+long as an average object.
+
+In case that isn't clear, when we have enough chars to make up
+the object, THEY ARE ALREADY CONTIGUOUS IN THE CHUNK (guaranteed)
+so we just point to it where it lies. No moving of chars is
+needed and this is the second win: potentially long strings need
+never be explicitly shuffled. Once an object is formed, it does not
+change its address during its lifetime.
+
+When the chars burst over a chunk boundary, we allocate a larger
+chunk, and then copy the partly formed object from the end of the old
+chunk to the beginning of the new larger chunk. We then carry on
+accreting characters to the end of the object as we normally would.
+
+A special macro is provided to add a single char at a time to a
+growing object. This allows the use of register variables, which
+break the ordinary 'growth' macro.
+
+Summary:
+ We allocate large chunks.
+ We carve out one object at a time from the current chunk.
+ Once carved, an object never moves.
+ We are free to append data of any size to the currently
+ growing object.
+ Exactly one object is growing in an obstack at any one time.
+ You can run one obstack per control block.
+ You may have as many control blocks as you dare.
+ Because of the way we do it, you can `unwind' a obstack
+ back to a previous state. (You may remove objects much
+ as you would with a stack.)
+*/
+
+
+/* Don't do the contents of this file more than once. */
+
+#ifndef __OBSTACKS__
+#define __OBSTACKS__
+\f
+/* We use subtraction of (char *)0 instead of casting to int
+ because on word-addressable machines a simple cast to int
+ may ignore the byte-within-word field of the pointer. */
+
+#ifndef __PTR_TO_INT
+#define __PTR_TO_INT(P) ((P) - (char *)0)
+#endif
+
+#ifndef __INT_TO_PTR
+#define __INT_TO_PTR(P) ((P) + (char *)0)
+#endif
+
+struct _obstack_chunk /* Lives at front of each chunk. */
+{
+ char *limit; /* 1 past end of this chunk */
+ struct _obstack_chunk *prev; /* address of prior chunk or NULL */
+ char contents[4]; /* objects begin here */
+};
+
+struct obstack /* control current object in current chunk */
+{
+ long chunk_size; /* preferred size to allocate chunks in */
+ struct _obstack_chunk* chunk; /* address of current struct obstack_chunk */
+ char *object_base; /* address of object we are building */
+ char *next_free; /* where to add next char to current object */
+ char *chunk_limit; /* address of char after current chunk */
+ int temp; /* Temporary for some macros. */
+ int alignment_mask; /* Mask of alignment for each object. */
+ struct _obstack_chunk *(*chunkfun) (); /* User's fcn to allocate a chunk. */
+ void (*freefun) (); /* User's function to free a chunk. */
+};
+\f
+#ifdef __STDC__
+
+/* Do the function-declarations after the structs
+ but before defining the macros. */
+
+void obstack_init (struct obstack *obstack);
+
+void * obstack_alloc (struct obstack *obstack, int size);
+
+void * obstack_copy (struct obstack *obstack, void *address, int size);
+void * obstack_copy0 (struct obstack *obstack, void *address, int size);
+
+void obstack_free (struct obstack *obstack, void *block);
+
+void obstack_blank (struct obstack *obstack, int size);
+
+void obstack_grow (struct obstack *obstack, void *data, int size);
+void obstack_grow0 (struct obstack *obstack, void *data, int size);
+
+void obstack_1grow (struct obstack *obstack, int data_char);
+void obstack_ptr_grow (struct obstack *obstack, void *data);
+void obstack_int_grow (struct obstack *obstack, int data);
+
+void * obstack_finish (struct obstack *obstack);
+
+int obstack_object_size (struct obstack *obstack);
+
+int obstack_room (struct obstack *obstack);
+void obstack_1grow_fast (struct obstack *obstack, int data_char);
+void obstack_ptr_grow_fast (struct obstack *obstack, void *data);
+void obstack_int_grow_fast (struct obstack *obstack, int data);
+void obstack_blank_fast (struct obstack *obstack, int size);
+
+void * obstack_base (struct obstack *obstack);
+void * obstack_next_free (struct obstack *obstack);
+int obstack_alignment_mask (struct obstack *obstack);
+int obstack_chunk_size (struct obstack *obstack);
+
+#endif /* __STDC__ */
+
+/* Non-ANSI C cannot really support alternative functions for these macros,
+ so we do not declare them. */
+\f
+/* Pointer to beginning of object being allocated or to be allocated next.
+ Note that this might not be the final address of the object
+ because a new chunk might be needed to hold the final size. */
+
+#define obstack_base(h) ((h)->object_base)
+
+/* Size for allocating ordinary chunks. */
+
+#define obstack_chunk_size(h) ((h)->chunk_size)
+
+/* Pointer to next byte not yet allocated in current chunk. */
+
+#define obstack_next_free(h) ((h)->next_free)
+
+/* Mask specifying low bits that should be clear in address of an object. */
+
+#define obstack_alignment_mask(h) ((h)->alignment_mask)
+
+#define obstack_init(h) \
+ _obstack_begin ((h), 0, 0, obstack_chunk_alloc, obstack_chunk_free)
+
+#define obstack_begin(h, size) \
+ _obstack_begin ((h), (size), 0, obstack_chunk_alloc, obstack_chunk_free)
+
+#define obstack_1grow_fast(h,achar) (*((h)->next_free)++ = achar)
+
+#define obstack_blank_fast(h,n) ((h)->next_free += (n))
+\f
+#if defined (__GNUC__) && defined (__STDC__)
+
+/* For GNU C, if not -traditional,
+ we can define these macros to compute all args only once
+ without using a global variable.
+ Also, we can avoid using the `temp' slot, to make faster code. */
+
+#define obstack_object_size(OBSTACK) \
+ ({ struct obstack *__o = (OBSTACK); \
+ (unsigned) (__o->next_free - __o->object_base); })
+
+#define obstack_room(OBSTACK) \
+ ({ struct obstack *__o = (OBSTACK); \
+ (unsigned) (__o->chunk_limit - __o->next_free); })
+
+#define obstack_grow(OBSTACK,where,length) \
+({ struct obstack *__o = (OBSTACK); \
+ int __len = (length); \
+ ((__o->next_free + __len > __o->chunk_limit) \
+ ? _obstack_newchunk (__o, __len) : 0); \
+ bcopy (where, __o->next_free, __len); \
+ __o->next_free += __len; \
+ (void) 0; })
+
+#define obstack_grow0(OBSTACK,where,length) \
+({ struct obstack *__o = (OBSTACK); \
+ int __len = (length); \
+ ((__o->next_free + __len + 1 > __o->chunk_limit) \
+ ? _obstack_newchunk (__o, __len + 1) : 0), \
+ bcopy (where, __o->next_free, __len), \
+ __o->next_free += __len, \
+ *(__o->next_free)++ = 0; \
+ (void) 0; })
+
+#define obstack_1grow(OBSTACK,datum) \
+({ struct obstack *__o = (OBSTACK); \
+ ((__o->next_free + 1 > __o->chunk_limit) \
+ ? _obstack_newchunk (__o, 1) : 0), \
+ *(__o->next_free)++ = (datum); \
+ (void) 0; })
+
+/* These assume that the obstack alignment is good enough for pointers or ints,
+ and that the data added so far to the current object
+ shares that much alignment. */
+
+#define obstack_ptr_grow(OBSTACK,datum) \
+({ struct obstack *__o = (OBSTACK); \
+ ((__o->next_free + sizeof (void *) > __o->chunk_limit) \
+ ? _obstack_newchunk (__o, sizeof (void *)) : 0), \
+ *((void **)__o->next_free)++ = ((void *)datum); \
+ (void) 0; })
+
+#define obstack_int_grow(OBSTACK,datum) \
+({ struct obstack *__o = (OBSTACK); \
+ ((__o->next_free + sizeof (int) > __o->chunk_limit) \
+ ? _obstack_newchunk (__o, sizeof (int)) : 0), \
+ *((int *)__o->next_free)++ = ((int)datum); \
+ (void) 0; })
+
+#define obstack_ptr_grow_fast(h,aptr) (*((void **)(h)->next_free)++ = (void *)aptr)
+#define obstack_int_grow_fast(h,aint) (*((int *)(h)->next_free)++ = (int)aint)
+
+#define obstack_blank(OBSTACK,length) \
+({ struct obstack *__o = (OBSTACK); \
+ int __len = (length); \
+ ((__o->next_free + __len > __o->chunk_limit) \
+ ? _obstack_newchunk (__o, __len) : 0); \
+ __o->next_free += __len; \
+ (void) 0; })
+
+#define obstack_alloc(OBSTACK,length) \
+({ struct obstack *__h = (OBSTACK); \
+ obstack_blank (__h, (length)); \
+ obstack_finish (__h); })
+
+#define obstack_copy(OBSTACK,where,length) \
+({ struct obstack *__h = (OBSTACK); \
+ obstack_grow (__h, (where), (length)); \
+ obstack_finish (__h); })
+
+#define obstack_copy0(OBSTACK,where,length) \
+({ struct obstack *__h = (OBSTACK); \
+ obstack_grow0 (__h, (where), (length)); \
+ obstack_finish (__h); })
+
+#define obstack_finish(OBSTACK) \
+({ struct obstack *__o = (OBSTACK); \
+ void *value = (void *) __o->object_base; \
+ __o->next_free \
+ = __INT_TO_PTR ((__PTR_TO_INT (__o->next_free)+__o->alignment_mask)\
+ & ~ (__o->alignment_mask)); \
+ ((__o->next_free - (char *)__o->chunk \
+ > __o->chunk_limit - (char *)__o->chunk) \
+ ? (__o->next_free = __o->chunk_limit) : 0); \
+ __o->object_base = __o->next_free; \
+ value; })
+
+#define obstack_free(OBSTACK, OBJ) \
+({ struct obstack *__o = (OBSTACK); \
+ void *__obj = (OBJ); \
+ if (__obj > (void *)__o->chunk && __obj < (void *)__o->chunk_limit) \
+ __o->next_free = __o->object_base = __obj; \
+ else (obstack_free) (__o, __obj); })
+\f
+#else /* not __GNUC__ or not __STDC__ */
+
+#define obstack_object_size(h) \
+ (unsigned) ((h)->next_free - (h)->object_base)
+
+#define obstack_room(h) \
+ (unsigned) ((h)->chunk_limit - (h)->next_free)
+
+#define obstack_grow(h,where,length) \
+( (h)->temp = (length), \
+ (((h)->next_free + (h)->temp > (h)->chunk_limit) \
+ ? _obstack_newchunk ((h), (h)->temp) : 0), \
+ bcopy (where, (h)->next_free, (h)->temp), \
+ (h)->next_free += (h)->temp)
+
+#define obstack_grow0(h,where,length) \
+( (h)->temp = (length), \
+ (((h)->next_free + (h)->temp + 1 > (h)->chunk_limit) \
+ ? _obstack_newchunk ((h), (h)->temp + 1) : 0), \
+ bcopy (where, (h)->next_free, (h)->temp), \
+ (h)->next_free += (h)->temp, \
+ *((h)->next_free)++ = 0)
+
+#define obstack_1grow(h,datum) \
+( (((h)->next_free + 1 > (h)->chunk_limit) \
+ ? _obstack_newchunk ((h), 1) : 0), \
+ *((h)->next_free)++ = (datum))
+
+#define obstack_ptr_grow(h,datum) \
+( (((h)->next_free + sizeof (char *) > (h)->chunk_limit) \
+ ? _obstack_newchunk ((h), sizeof (char *)) : 0), \
+ *((char **)(h)->next_free)++ = ((char *)datum))
+
+#define obstack_int_grow(h,datum) \
+( (((h)->next_free + sizeof (int) > (h)->chunk_limit) \
+ ? _obstack_newchunk ((h), sizeof (int)) : 0), \
+ *((int *)(h)->next_free)++ = ((int)datum))
+
+#define obstack_ptr_grow_fast(h,aptr) (*((char **)(h)->next_free)++ = (char *)aptr)
+#define obstack_int_grow_fast(h,aint) (*((int *)(h)->next_free)++ = (int)aint)
+
+#define obstack_blank(h,length) \
+( (h)->temp = (length), \
+ (((h)->next_free + (h)->temp > (h)->chunk_limit) \
+ ? _obstack_newchunk ((h), (h)->temp) : 0), \
+ (h)->next_free += (h)->temp)
+
+#define obstack_alloc(h,length) \
+ (obstack_blank ((h), (length)), obstack_finish ((h)))
+
+#define obstack_copy(h,where,length) \
+ (obstack_grow ((h), (where), (length)), obstack_finish ((h)))
+
+#define obstack_copy0(h,where,length) \
+ (obstack_grow0 ((h), (where), (length)), obstack_finish ((h)))
+
+#define obstack_finish(h) \
+( (h)->temp = __PTR_TO_INT ((h)->object_base), \
+ (h)->next_free \
+ = __INT_TO_PTR ((__PTR_TO_INT ((h)->next_free)+(h)->alignment_mask) \
+ & ~ ((h)->alignment_mask)), \
+ (((h)->next_free - (char *)(h)->chunk \
+ > (h)->chunk_limit - (char *)(h)->chunk) \
+ ? ((h)->next_free = (h)->chunk_limit) : 0), \
+ (h)->object_base = (h)->next_free, \
+ __INT_TO_PTR ((h)->temp))
+
+#ifdef __STDC__
+#define obstack_free(h,obj) \
+( (h)->temp = (char *)(obj) - (char *) (h)->chunk, \
+ (((h)->temp >= 0 && (h)->temp < (h)->chunk_limit - (char *) (h)->chunk)\
+ ? (int) ((h)->next_free = (h)->object_base \
+ = (h)->temp + (char *) (h)->chunk) \
+ : ((obstack_free) ((h), (h)->temp + (char *) (h)->chunk), 0)))
+#else
+#define obstack_free(h,obj) \
+( (h)->temp = (char *)(obj) - (char *) (h)->chunk, \
+ (((h)->temp >= 0 && (h)->temp < (h)->chunk_limit - (char *) (h)->chunk)\
+ ? (int) ((h)->next_free = (h)->object_base \
+ = (h)->temp + (char *) (h)->chunk) \
+ : (int) _obstack_free ((h), (h)->temp + (char *) (h)->chunk)))
+#endif
+
+#endif /* not __GNUC__ or not __STDC__ */
+
+#endif /* not __OBSTACKS__ */
+
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/os.h,v 1.1 1990/06/20 19:36:04 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OS_H
+#define SCM_OS_H
+
+#include "ansidecl.h"
+#include "posixtype.h"
+
+typedef unsigned int Tchannel;
+
+#endif /* SCM_OS_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/oscond.h,v 1.1 1990/06/20 19:36:08 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Operating System Conditionalizations.
+ Identify the operating system, its version, and generalizations. */
+
+#ifndef SCM_OSCOND_H
+#define SCM_OSCOND_H
+\f
+/* _POSIX is assumed to be independent of all operating-system and
+ machine specification macros. */
+
+#if defined(hpux) && !defined(_HPUX)
+#define _HPUX
+#endif
+
+#ifdef _HPUX
+#ifdef __hpux
+
+#define _HPUX_VERSION 70
+#define _POSIX
+#define _SYSV3
+
+#else /* not __hpux */
+
+#define _SYSV
+
+/* Definitions in this file identify the operating system version. */
+#include <signal.h>
+
+#ifdef hp9000s300
+#ifdef SV_BSDSIG
+#define _HPUX_VERSION 65
+#else
+/* Versions prior to 6.2 aren't worth dealing with anymore. */
+#define _HPUX_VERSION 62
+#endif
+#endif
+
+#ifdef hp9000s800
+#ifdef SV_RESETHAND
+#define _HPUX_VERSION 65 /* actually, 3.0 */
+#else
+/* Versions prior to 2.0 aren't worth dealing with anymore. */
+#define _HPUX_VERSION 62 /* actually, 2.0 */
+#endif
+#endif
+
+#endif /* __hpux */
+#endif /* _HPUX */
+
+#ifdef _SYSV3
+#define _SYSV
+#endif
+
+#if defined(_SUNOS3) || defined(_SUNOS4)
+#define _SUNOS
+#define _BSD4_2
+#endif
+
+#if defined(_BSD4_2) || defined(_BSD4_3)
+#define _BSD
+#endif
+
+#if defined(_BSD) && defined(_SYSV)
+#include "error: can't define both _BSD and _SYSV"
+#endif
+
+#if defined(_BSD) || defined(_SYSV) || defined(_PIXEL)
+#define _UNIX
+#else
+#include "error: unknown unix system -- you must add customizations"
+#endif
+
+#endif /* SCM_OSCOND_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osctty.h,v 1.1 1990/06/20 19:36:13 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OSCTTY_H
+#define SCM_OSCTTY_H
+
+#include "os.h"
+
+extern cc_t EXFUN (OS_ctty_quit_char, (void));
+extern cc_t EXFUN (OS_ctty_int_char, (void));
+extern cc_t EXFUN (OS_ctty_tstp_char, (void));
+extern void EXFUN
+ (OS_ctty_set_interrupt_chars,
+ (cc_t quit_char, cc_t int_char, cc_t tstp_char));
+
+/* If this procedure returns 0, the interrupt control procedures will
+ not work correctly. */
+extern int EXFUN (OS_ctty_interrupt_control, (void));
+
+typedef unsigned int Tinterrupt_enables;
+extern void EXFUN (OS_ctty_get_interrupt_enables, (Tinterrupt_enables * mask));
+extern void EXFUN (OS_ctty_set_interrupt_enables, (Tinterrupt_enables * mask));
+
+#endif /* SCM_OSCTTY_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osenv.h,v 1.1 1990/06/20 19:36:16 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OSENV_H
+#define SCM_OSENV_H
+
+#include "os.h"
+
+struct time_structure
+{
+ unsigned int year;
+ unsigned int month;
+ unsigned int day;
+ unsigned int hour;
+ unsigned int minute;
+ unsigned int second;
+ unsigned int day_of_week;
+};
+
+extern void EXFUN (OS_current_time, (struct time_structure * ts));
+extern clock_t EXFUN (OS_process_clock, (void));
+extern clock_t EXFUN (OS_real_time_clock, (void));
+extern void EXFUN (OS_process_timer_set, (clock_t first, clock_t interval));
+extern void EXFUN (OS_process_timer_clear, (void));
+extern void EXFUN (OS_real_timer_set, (clock_t first, clock_t interval));
+extern void EXFUN (OS_real_timer_clear, (void));
+extern CONST char * EXFUN (OS_working_dir_pathname, (void));
+extern void EXFUN (OS_set_working_dir_pathname, (CONST char * name));
+extern CONST char * EXFUN (OS_get_environment_variable, (CONST char * name));
+extern CONST char * EXFUN (OS_current_user_name, (void));
+extern CONST char * EXFUN (OS_current_user_home_directory, (void));
+
+#endif /* SCM_OSENV_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osfile.h,v 1.1 1990/06/20 19:36:20 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OSFILE_H
+#define SCM_OSFILE_H
+
+#include "os.h"
+
+extern Tchannel EXFUN (OS_open_input_file, (CONST char * filename));
+extern Tchannel EXFUN (OS_open_output_file, (CONST char * filename));
+extern Tchannel EXFUN (OS_open_io_file, (CONST char * filename));
+extern Tchannel EXFUN (OS_open_append_file, (CONST char * filename));
+extern Tchannel EXFUN (OS_open_load_file, (CONST char * filename));
+extern Tchannel EXFUN (OS_open_dump_file, (CONST char * filename));
+extern off_t EXFUN (OS_file_length, (Tchannel channel));
+extern off_t EXFUN (OS_file_position, (Tchannel channel));
+extern void EXFUN (OS_file_set_position, (Tchannel channel, off_t position));
+
+#endif /* SCM_OSFILE_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osfs.h,v 1.1 1990/06/20 19:36:23 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OSFS_H
+#define SCM_OSFS_H
+
+#include "os.h"
+
+enum file_existence { file_does_exist, file_doesnt_exist, file_may_exist };
+
+extern enum file_existence EXFUN (OS_file_existence_test, (CONST char * name));
+extern int EXFUN (OS_file_access, (CONST char * name, unsigned int mode));
+extern int EXFUN (OS_file_directory_p, (CONST char * name));
+extern CONST char * EXFUN (OS_file_soft_link_p, (CONST char * name));
+extern void EXFUN (OS_file_remove, (CONST char * name));
+extern void EXFUN (OS_file_remove_link, (CONST char * name));
+extern void EXFUN
+ (OS_file_rename, (CONST char * from_name, CONST char * to_name));
+extern void EXFUN
+ (OS_file_link_hard, (CONST char * from_name, CONST char * to_name));
+extern void EXFUN
+ (OS_file_link_soft, (CONST char * from_name, CONST char * to_name));
+extern void EXFUN (OS_directory_make, (CONST char * name));
+extern CONST char * EXFUN (OS_directory_open, (CONST char * name));
+extern CONST char * EXFUN (OS_directory_read, (void));
+extern void EXFUN (OS_directory_close, (void));
+
+#endif /* SCM_OSFS_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osio.h,v 1.1 1990/06/20 19:36:26 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OSIO_H
+#define SCM_OSIO_H
+
+#include "os.h"
+
+enum channel_type
+{
+ channel_type_unknown,
+ channel_type_file,
+ channel_type_pipe,
+ channel_type_fifo,
+ channel_type_terminal,
+ channel_type_pty_master,
+ channel_type_unix_stream_socket,
+ channel_type_tcp_stream_socket
+};
+
+extern size_t OS_channel_table_size;
+#define NO_CHANNEL OS_channel_table_size
+extern int EXFUN (OS_channel_open_p, (Tchannel channel));
+extern void EXFUN (OS_channel_close, (Tchannel channel));
+extern void EXFUN (OS_channel_close_noerror, (Tchannel channel));
+extern void EXFUN (OS_channel_close_all, (void));
+extern enum channel_type EXFUN (OS_channel_type, (Tchannel channel));
+extern size_t EXFUN
+ (OS_channel_read_load_file, (Tchannel channel, PTR buffer, size_t nbytes));
+extern size_t EXFUN
+ (OS_channel_write_dump_file,
+ (Tchannel channel, CONST PTR buffer, size_t nbytes));
+extern long EXFUN
+ (OS_channel_read, (Tchannel channel, PTR buffer, size_t nbytes));
+extern long EXFUN
+ (OS_channel_write, (Tchannel channel, CONST PTR buffer, size_t nbytes));
+extern int EXFUN (OS_channel_read_char_interruptably, (Tchannel channel));
+extern void EXFUN
+ (OS_channel_write_string, (Tchannel channel, CONST char * string));
+extern int EXFUN (OS_channel_nonblocking_p, (Tchannel channel));
+extern void EXFUN (OS_channel_nonblocking, (Tchannel channel));
+extern void EXFUN (OS_channel_blocking, (Tchannel channel));
+
+#endif /* SCM_OSIO_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osproc.h,v 1.1 1990/06/20 19:36:30 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OSPROC_H
+#define SCM_OSPROC_H
+
+#include "os.h"
+
+typedef unsigned int Tprocess;
+
+enum process_status
+{
+ process_status_free, /* unused process table entry */
+ process_status_allocated, /* being started */
+ process_status_running, /* running */
+ process_status_stopped, /* stopped but continuable */
+ process_status_exited, /* terminated by calling _exit() */
+ process_status_signalled /* terminated by being signalled */
+};
+
+enum process_ctty_type
+{
+ ctty_type_none, /* no controlling terminal */
+ ctty_type_inherited, /* ctty is Scheme's ctty */
+ ctty_type_pipe, /* ctty is a pipe */
+ ctty_type_pty /* ctty is a PTY */
+};
+
+extern size_t OS_process_table_size;
+#define NO_PROCESS OS_process_table_size
+extern Tprocess EXFUN
+ (OS_make_subprocess,
+ (CONST char * filename,
+ CONST char ** argv,
+ char ** env,
+ enum process_ctty_type ctty_type));
+extern void EXFUN (OS_process_deallocate, (Tprocess process));
+extern pid_t EXFUN (OS_process_id, (Tprocess process));
+extern Tchannel EXFUN (OS_process_input, (Tprocess process));
+extern Tchannel EXFUN (OS_process_output, (Tprocess process));
+extern enum process_ctty_type EXFUN (OS_process_ctty_type, (Tprocess process));
+extern enum process_status EXFUN (OS_process_status, (Tprocess process));
+extern unsigned short EXFUN (OS_process_reason, (Tprocess process));
+extern int EXFUN (OS_process_synchronous, (Tprocess process));
+extern void EXFUN (OS_process_send_signal, (Tprocess process, int sig));
+extern void EXFUN (OS_process_kill, (Tprocess process));
+extern void EXFUN (OS_process_stop, (Tprocess process));
+extern void EXFUN (OS_process_continue, (Tprocess process));
+extern void EXFUN (OS_process_interrupt, (Tprocess process));
+extern void EXFUN (OS_process_quit, (Tprocess process));
+
+#endif /* SCM_OSPROC_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osscheme.c,v 1.1 1990/06/20 19:36:32 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "scheme.h"
+#include "osscheme.h"
+\f
+void
+DEFUN_VOID (error_out_of_channels)
+{
+ signal_error_from_primitive (ERR_OUT_OF_FILE_HANDLES);
+}
+
+void
+DEFUN_VOID (error_out_of_processes)
+{
+ signal_error_from_primitive (ERR_OUT_OF_FILE_HANDLES);
+}
+
+void
+DEFUN_VOID (error_unimplemented_primitive)
+{
+ signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE);
+}
+
+void
+DEFUN_VOID (error_floating_point_exception)
+{
+ signal_error_from_primitive (ERR_FLOATING_OVERFLOW);
+}
+
+int
+DEFUN_VOID (executing_scheme_primitive_p)
+{
+ return (PRIMITIVE_P (Regs [REGBLOCK_PRIMITIVE]));
+}
+
+void
+DEFUN_VOID (request_character_interrupt)
+{
+ REQUEST_INTERRUPT (INT_Character);
+}
+
+void
+DEFUN_VOID (request_timer_interrupt)
+{
+ REQUEST_INTERRUPT (INT_Timer);
+}
+
+void
+DEFUN_VOID (request_suspend_interrupt)
+{
+ REQUEST_INTERRUPT (INT_Suspend);
+}
+
+void
+DEFUN_VOID (deliver_pending_interrupts)
+{
+ if (INTERRUPT_PENDING_P (INT_Mask))
+ signal_interrupt_from_primitive ();
+}
+
+void
+DEFUN_VOID (debug_back_trace)
+{
+ Back_Trace (stdout);
+}
+
+void
+DEFUN (debug_examine_memory, (address, label),
+ long address AND
+ CONST char * label)
+{
+ Print_Expression ((* ((SCHEME_OBJECT *) address)), label);
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osscheme.h,v 1.1 1990/06/20 19:36:35 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OSSCHEME_H
+#define SCM_OSSCHEME_H
+
+#include "os.h"
+
+extern Tchannel EXFUN (arg_channel, (int arg_number));
+extern Tchannel EXFUN (arg_channel_old, (int arg_number));
+
+extern int EXFUN (boolean_option_argument, (CONST char * name));
+
+extern int EXFUN (executing_scheme_primitive_p, (void));
+
+extern void EXFUN (debug_edit_flags, (void));
+extern void EXFUN (debug_back_trace, (void));
+extern void EXFUN (debug_examine_memory, (long address, CONST char * label));
+
+extern void EXFUN (error_out_of_channels, (void));
+extern void EXFUN (error_unimplemented_primitive, (void));
+extern void EXFUN (error_external_return, (void));
+extern void EXFUN (error_out_of_processes, (void));
+extern void EXFUN (error_floating_point_exception, (void));
+
+extern void EXFUN (termination_eof, (void));
+extern void EXFUN (termination_normal, (void));
+extern void EXFUN (termination_signal, (CONST char * signal_name));
+extern void EXFUN (termination_trap, (void));
+/* Perhaps this should be different. */
+#define termination_init_error termination_normal
+
+extern void EXFUN (request_character_interrupt, (void));
+extern void EXFUN (request_timer_interrupt, (void));
+extern void EXFUN (request_suspend_interrupt, (void));
+extern void EXFUN (deliver_pending_interrupts, (void));
+
+#endif /* SCM_OSSCHEME_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/ossig.h,v 1.1 1990/06/20 19:36:40 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OSSIG_H
+#define SCM_OSSIG_H
+
+#include "os.h"
+
+enum interrupt_handler
+{
+ interrupt_handler_default,
+ interrupt_handler_ignore,
+ interrupt_handler_terminate,
+ interrupt_handler_stop,
+ interrupt_handler_control_g,
+ interrupt_handler_interactive,
+ interrupt_handler_unknown
+};
+
+extern enum interrupt_handler EXFUN (OS_signal_quit_handler, (void));
+extern enum interrupt_handler EXFUN (OS_signal_int_handler, (void));
+extern enum interrupt_handler EXFUN (OS_signal_tstp_handler, (void));
+extern void EXFUN
+ (OS_signal_set_interrupt_handlers,
+ (enum interrupt_handler quit_handler,
+ enum interrupt_handler int_handler,
+ enum interrupt_handler tstp_handler));
+
+#endif /* SCM_OSSIG_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/osterm.h,v 1.1 1990/06/20 19:36:43 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OSTERM_H
+#define SCM_OSTERM_H
+
+#include "os.h"
+
+extern int EXFUN (OS_terminal_read_char, (Tchannel channel));
+extern int EXFUN (OS_terminal_char_ready_p, (Tchannel channel, clock_t delay));
+extern int EXFUN (OS_terminal_buffered_p, (Tchannel channel));
+extern void EXFUN (OS_terminal_buffered, (Tchannel channel));
+extern void EXFUN (OS_terminal_nonbuffered, (Tchannel channel));
+extern void EXFUN (OS_terminal_flush_input, (Tchannel channel));
+extern void EXFUN (OS_terminal_flush_output, (Tchannel channel));
+extern void EXFUN (OS_terminal_drain_output, (Tchannel channel));
+extern CONST char * EXFUN
+ (OS_open_pty_master, (Tchannel * master_fd, CONST char ** master_fname));
+extern void EXFUN (OS_pty_master_send_signal, (Tchannel channel, int sig));
+
+#endif /* SCM_OSTERM_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/ostop.h,v 1.1 1990/06/20 19:36:48 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OSTOP_H
+#define SCM_OSTOP_H
+
+#include "os.h"
+
+extern int EXFUN (OS_under_emacs_p, (void));
+extern void EXFUN (OS_initialize, (void));
+extern void EXFUN (OS_quit, (int code, int abnormal_p));
+extern void EXFUN (OS_restartable_exit, (void));
+extern void EXFUN (OS_save_external_state, (void));
+extern void EXFUN (OS_save_internal_state, (void));
+extern void EXFUN (OS_restore_internal_state, (void));
+extern void EXFUN (OS_restore_external_state, (void));
+
+#endif /* SCM_OSTOP_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/ostty.c,v 1.1 1990/06/20 19:36:51 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ostty.h"
+#include "osscheme.h"
+
+static cc_t next_interrupt_char;
+
+void
+DEFUN (tty_set_next_interrupt_char, (c), cc_t c)
+{
+ if (next_interrupt_char == '\0')
+ {
+ next_interrupt_char = c;
+ request_character_interrupt ();
+ }
+}
+
+cc_t
+DEFUN_VOID (OS_tty_next_interrupt_char)
+{
+ if (next_interrupt_char == '\0')
+ error_external_return ();
+ {
+ cc_t result = next_interrupt_char;
+ next_interrupt_char = '\0';
+ return (result);
+ }
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/ostty.h,v 1.1 1990/06/20 19:36:54 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OSTTY_H
+#define SCM_OSTTY_H
+
+#include "os.h"
+
+/* New interface uses standard terminal and channel I/O. */
+extern Tchannel EXFUN (OS_tty_input_channel, (void));
+extern Tchannel EXFUN (OS_tty_output_channel, (void));
+extern unsigned int EXFUN (OS_tty_x_size, (void));
+extern unsigned int EXFUN (OS_tty_y_size, (void));
+extern CONST char * EXFUN (OS_tty_command_beep, (void));
+extern CONST char * EXFUN (OS_tty_command_clear, (void));
+
+/* These are for the convenience of the microcode. */
+extern void EXFUN (OS_tty_write_char, (unsigned char c));
+extern void EXFUN (OS_tty_write_string, (CONST char * string));
+extern void EXFUN (OS_tty_beep, (void));
+
+/* Old interface requires special entry points and buffered output. */
+extern int EXFUN (OS_tty_char_ready_p, (clock_t delay));
+extern unsigned char EXFUN (OS_tty_read_char, (void));
+extern unsigned char EXFUN (OS_tty_read_char_immediate, (void));
+
+/* `OS_tty_clean_interrupts' is used to clear the input buffer when a
+ character interrupt is received. On most systems this is not
+ currently used, but the Emacs interface needs some assistance.
+ Normally this is used in conjunction with some kind of
+ distinguished marker in the input stream that indicates where each
+ interrupt occurred.
+
+ The `mode' argument allows the following values:
+
+ `tty_clean_most_recent' indicates that the input buffer should be
+ flushed up to and including the most recent interrupt marker.
+
+ `tty_clean_multiple_copies' indicates that all interrupts which
+ match `interrupt_char' should be removed from the input buffer.
+ Any other interrupts should be left alone. */
+
+enum tty_clean_mode { tty_clean_most_recent, tty_clean_multiple_copies };
+extern cc_t EXFUN (OS_tty_next_interrupt_char, (void));
+extern int EXFUN
+ (OS_tty_clean_interrupts, (enum tty_clean_mode mode, cc_t interrupt_char));
+
+#endif /* SCM_OSTTY_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/posixtyp.h,v 1.1 1990/06/20 19:38:14 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+\f
+#ifndef SCM_POSIXTYPE_H
+#define SCM_POSIXTYPE_H
+
+#ifdef _POSIX
+
+#include <sys/types.h>
+#include <sys/times.h>
+#include <termios.h>
+
+#else /* not _POSIX */
+
+#ifdef _UNIX
+#include <sys/types.h>
+
+#if defined(_HPUX) && (_HPUX_VERSION == 65)
+#define _MODE_T
+#define _NLINK_T
+#define _SIZE_T
+#endif
+
+#ifdef _BSD
+#define _UID_T
+#define _SIZE_T
+#endif
+
+#endif
+
+#ifndef _MODE_T
+#define _MODE_T
+typedef unsigned short mode_t;
+#endif
+
+#ifndef _NLINK_T
+#define _NLINK_T
+typedef short nlink_t;
+#endif
+
+#ifndef _PID_T
+#define _PID_T
+typedef long pid_t;
+#endif
+
+#ifndef _UID_T
+#define _UID_T
+#ifdef _SYSV
+typedef unsigned short uid_t;
+typedef unsigned short gid_t;
+#else
+typedef short uid_t;
+typedef short gid_t;
+#endif
+#endif
+
+#ifndef _CLOCK_T
+#define _CLOCK_T
+typedef unsigned long clock_t;
+#endif
+
+#ifndef _SIZE_T
+#define _SIZE_T
+typedef unsigned int size_t;
+#endif
+
+#ifndef _CC_T
+#define _CC_T
+typedef unsigned char cc_t;
+#endif
+
+#endif /* not _POSIX */
+
+#endif /* SCM_POSIXTYPE_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prosenv.c,v 1.1 1990/06/20 19:38:17 cph Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Process-environment primitives. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "osenv.h"
+\f
+DEFINE_PRIMITIVE ("GET-DECODED-TIME", Prim_get_decoded_time, 1, 1,
+ "Return a vector with the current decoded time;\n\
+arg TAG is used to tag the vector.\n\
+The vector's elements are:\n\
+ #(TAG second minute hour day month year day-of-week)")
+{
+ struct time_structure ts;
+ PRIMITIVE_HEADER (1);
+ OS_current_time (&ts);
+ {
+ SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 8, 1));
+ FAST_VECTOR_SET (result, 0, (ARG_REF (1)));
+ FAST_VECTOR_SET (result, 1, (ts . second));
+ FAST_VECTOR_SET (result, 2, (ts . minute));
+ FAST_VECTOR_SET (result, 3, (ts . hour));
+ FAST_VECTOR_SET (result, 4, (ts . day));
+ FAST_VECTOR_SET (result, 5, (ts . month));
+ FAST_VECTOR_SET (result, 6, (ts . year));
+ FAST_VECTOR_SET (result, 6, (ts . day_of_week));
+ PRIMITIVE_RETURN (result);
+ }
+}
+
+DEFINE_PRIMITIVE ("CURRENT-YEAR", Prim_current_year, 0, 0,
+ "This is an obsolete primitive; use `get-decoded-time' instead.")
+{
+ struct time_structure ts;
+ PRIMITIVE_HEADER (0);
+ OS_current_time (&ts);
+ PRIMITIVE_RETURN (long_to_integer ((ts . year) - 1900));
+}
+
+#define DATE_PRIMITIVE(element) \
+{ \
+ struct time_structure ts; \
+ PRIMITIVE_HEADER (0); \
+ OS_current_time (&ts); \
+ PRIMITIVE_RETURN (long_to_integer (ts . element)); \
+}
+
+DEFINE_PRIMITIVE ("CURRENT-MONTH", Prim_current_month, 0, 0,
+ "This is an obsolete primitive; use `get-decoded-time' instead.")
+ DATE_PRIMITIVE (month)
+
+DEFINE_PRIMITIVE ("CURRENT-DAY", Prim_current_day, 0, 0,
+ "This is an obsolete primitive; use `get-decoded-time' instead.")
+ DATE_PRIMITIVE (day)
+
+DEFINE_PRIMITIVE ("CURRENT-HOUR", Prim_current_hour, 0, 0,
+ "This is an obsolete primitive; use `get-decoded-time' instead.")
+ DATE_PRIMITIVE (hour)
+
+DEFINE_PRIMITIVE ("CURRENT-MINUTE", Prim_current_minute, 0, 0,
+ "This is an obsolete primitive; use `get-decoded-time' instead.")
+ DATE_PRIMITIVE (minute)
+
+DEFINE_PRIMITIVE ("CURRENT-SECOND", Prim_current_second, 0, 0,
+ "This is an obsolete primitive; use `get-decoded-time' instead.")
+ DATE_PRIMITIVE (second)
+\f
+DEFINE_PRIMITIVE ("SYSTEM-CLOCK", Prim_system_clock, 0, 0,
+ "Return the current process time in units of milliseconds.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (long_to_integer (OS_process_clock ()));
+}
+
+DEFINE_PRIMITIVE ("REAL-TIME-CLOCK", Prim_real_time_clock, 0, 0,
+ "Return the current real time in units of milliseconds.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (long_to_integer (OS_real_time_clock ()));
+}
+
+DEFINE_PRIMITIVE ("PROCESS-TIMER-CLEAR", Prim_process_timer_clear, 0, 0,
+ "Turn off the process timer.")
+{
+ PRIMITIVE_HEADER (0);
+ OS_process_timer_clear ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("PROCESS-TIMER-SET", Prim_process_timer_set, 2, 2,
+ "Set the process timer.\n\
+First arg FIRST says how long to wait until the first interrupt;\n\
+second arg INTERVAL says how long to wait between interrupts after that.\n\
+Both arguments are in units of milliseconds.")
+{
+ PRIMITIVE_HEADER (2);
+ OS_process_timer_set ((arg_nonnegative_integer (1)),
+ (arg_nonnegative_integer (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("REAL-TIMER-CLEAR", Prim_real_timer_clear, 0, 0,
+ "Turn off the real timer.")
+{
+ PRIMITIVE_HEADER (0);
+ OS_real_timer_clear ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("REAL-TIMER-SET", Prim_real_timer_set, 2, 2,
+ "Set the real timer.\n\
+First arg FIRST says how long to wait until the first interrupt;\n\
+second arg INTERVAL says how long to wait between interrupts after that.\n\
+Both arguments are in units of milliseconds.")
+{
+ PRIMITIVE_HEADER (2);
+ OS_real_timer_set ((arg_nonnegative_integer (1)),
+ (arg_nonnegative_integer (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("SETUP-TIMER-INTERRUPT", Prim_setup_timer_interrupt, 2, 2,
+ "This is an obsolete primitive; use `process-timer-set' instead.")
+{
+ PRIMITIVE_HEADER (2);
+ if (((ARG_REF (1)) == SHARP_F) && ((ARG_REF (2)) == SHARP_F))
+ OS_process_timer_clear ();
+ else
+ {
+ unsigned long days = (arg_nonnegative_integer (1));
+ unsigned long centisec = (arg_nonnegative_integer (2));
+ OS_process_timer_set
+ ((((days * 24 * 60 * 60 * 100) + centisec) * 10), 0);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("WORKING-DIRECTORY-PATHNAME", Prim_working_dir_pathname, 0, 0,
+ "Return the current working directory as a string.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (char_pointer_to_string (OS_working_dir_pathname ()));
+}
+
+DEFINE_PRIMITIVE ("SET-WORKING-DIRECTORY-PATHNAME!", Prim_set_working_dir_pathname, 1, 1,
+ "Change the current working directory to NAME.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_set_working_dir_pathname (STRING_ARG (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("GET-ENVIRONMENT-VARIABLE", Prim_get_environment_variable, 1, 1,
+ "Look up the value of a variable in the user's shell environment.\n\
+The argument, a variable name, must be a string.\n\
+The result is either a string (the variable's value),\n\
+ or #F indicating that the variable does not exist.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ CONST char * variable_value =
+ (OS_get_environment_variable (STRING_ARG (1)));
+ PRIMITIVE_RETURN
+ ((variable_value == 0)
+ ? SHARP_F
+ : (char_pointer_to_string (variable_value)));
+ }
+}
+
+DEFINE_PRIMITIVE ("CURRENT-USER-NAME", Prim_current_user_name, 0, 0,
+ "Return (as a string) the user name of the user running Scheme.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (char_pointer_to_string (OS_current_user_name ()));
+}
+
+DEFINE_PRIMITIVE ("CURRENT-USER-HOME-DIRECTORY", Prim_current_user_home_directory, 0, 0,
+ "Return the name of the current user's home directory.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN
+ (char_pointer_to_string (OS_current_user_home_directory ()));
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prosfile.c,v 1.1 1990/06/20 19:38:21 cph Rel $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Primitives to perform I/O to and from files. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "osfile.h"
+
+#ifndef OPEN_FILE_HOOK
+#define OPEN_FILE_HOOK(channel)
+#endif
+\f
+#define OPEN_FILE_PRIMITIVE(OS_open_file) \
+{ \
+ PRIMITIVE_HEADER (1); \
+ { \
+ Tchannel channel = (OS_open_file (STRING_ARG (1))); \
+ OPEN_FILE_HOOK (channel); \
+ PRIMITIVE_RETURN (long_to_integer (channel)); \
+ } \
+}
+
+DEFINE_PRIMITIVE ("FILE-OPEN-INPUT-CHANNEL", Prim_file_open_input_channel, 1, 1,
+ "Open an input file called FILENAME, returning a channel number.")
+ OPEN_FILE_PRIMITIVE (OS_open_input_file)
+
+DEFINE_PRIMITIVE ("FILE-OPEN-OUTPUT-CHANNEL", Prim_file_open_output_channel, 1, 1,
+ "Open an output file called FILENAME, returning a channel number.\n\
+If the file exists, it is rewritten.")
+ OPEN_FILE_PRIMITIVE (OS_open_output_file)
+
+DEFINE_PRIMITIVE ("FILE-OPEN-IO-CHANNEL", Prim_file_open_io_channel, 1, 1,
+ "Open a file called FILENAME, returning a channel number.\n\
+The file is opened for both input and output.\n\
+If the file exists, its contents are not disturbed.")
+ OPEN_FILE_PRIMITIVE (OS_open_io_file)
+
+DEFINE_PRIMITIVE ("FILE-OPEN-APPEND-CHANNEL", Prim_file_open_append_channel, 1, 1,
+ "Open an output file called FILENAME, returning a channel number.\n\
+If the file exists, output is appended to its contents.")
+ OPEN_FILE_PRIMITIVE (OS_open_append_file)
+
+DEFINE_PRIMITIVE ("FILE-OPEN-CHANNEL", Prim_file_open_channel, 2, 2,
+ "This is an obsolete primitive.\n\
+Open a file called FILENAME, returning a channel number.\n\
+Second argument MODE says how to open the file:\n\
+ #F ==> open for input;\n\
+ #T ==> open for output, rewriting file if it exists;\n\
+ otherwise ==> open for output, appending to existing file.")
+{
+ PRIMITIVE_HEADER (2);
+ {
+ CONST char * filename = (STRING_ARG (1));
+ fast SCHEME_OBJECT mode = (ARG_REF (2));
+ fast Tchannel channel =
+ ((mode == SHARP_F)
+ ? (OS_open_input_file (filename))
+ : (mode == SHARP_T)
+ ? (OS_open_output_file (filename))
+ : (OS_open_append_file (filename)));
+ OPEN_FILE_HOOK (channel);
+ PRIMITIVE_RETURN (long_to_integer (channel));
+ }
+}
+
+DEFINE_PRIMITIVE ("FILE-LENGTH", Prim_file_length, 1, 1,
+ "Return the length of CHANNEL in characters.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (long_to_integer (OS_file_length (arg_channel_old (1))));
+}
+
+DEFINE_PRIMITIVE ("FILE-LENGTH-NEW", Prim_file_length_new, 1, 1,
+ "Return the length of CHANNEL in characters.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (long_to_integer (OS_file_length (arg_channel (1))));
+}
+
+DEFINE_PRIMITIVE ("FILE-POSITION", Prim_file_position, 1, 1,
+ "Return the position of CHANNEL's file-pointer.\n\
+This is a non-negative number strictly less than the file's length.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (long_to_integer (OS_file_position (arg_channel (1))));
+}
+
+DEFINE_PRIMITIVE ("FILE-SET-POSITION", Prim_file_set_position, 2, 2,
+ "Set the file-pointer of CHANNEL to POSITION.\n\
+POSITION must be a non-negative number strictly less than the file's length.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_file_set_position ((arg_channel (1)), (arg_nonnegative_integer (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prosfs.c,v 1.1 1990/06/20 19:38:24 cph Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Primitives to perform file-system operations. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "osfs.h"
+
+#define STRING_RESULT(expression) \
+{ \
+ CONST char * result = (expression); \
+ PRIMITIVE_RETURN \
+ ((result == 0) \
+ ? SHARP_F \
+ : (char_pointer_to_string (result))); \
+}
+\f
+DEFINE_PRIMITIVE ("FILE-EXISTS?", Prim_file_exists_p, 1, 1,
+ "Return #T iff FILENAME refers to an existing file.\n\
+Otherwise #F is returned, in which case either:\n\
+ (1) the file doesn't exist, or\n\
+ (2) it's not possible to determine whether the file exists.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN
+ (BOOLEAN_TO_OBJECT
+ ((OS_file_existence_test (STRING_ARG (1))) == file_does_exist));
+}
+
+DEFINE_PRIMITIVE ("FILE-ACCESS", Prim_file_access, 2, 2,
+ "Return #T iff FILENAME exists and is accessible according to MODE.\n\
+MODE is an integer between 0 and 7 inclusive, bitwise encoded:\n\
+ 4 ==> file is readable;\n\
+ 2 ==> file is writable;\n\
+ 1 ==> file is executable.")
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (BOOLEAN_TO_OBJECT
+ (OS_file_access ((STRING_ARG (1)), (arg_index_integer (2, 8)))));
+}
+
+DEFINE_PRIMITIVE ("FILE-DIRECTORY?", Prim_file_directory_p, 1, 1,
+ "Return #T iff FILENAME refers to an existing directory.\n\
+Otherwise #F is returned, meaning either that FILENAME doesn't exist\n\
+ or that it isn't a directory.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS_file_directory_p (STRING_ARG (1))));
+}
+
+DEFINE_PRIMITIVE ("FILE-SOFT-LINK?", Prim_file_soft_link_p, 1, 1,
+ "Iff FILENAME refers to an existing soft link, return the link contents.\n\
+Otherwise #F is returned, meaning either that FILENAME doesn't exist\n\
+ or that it isn't a soft link.")
+{
+ PRIMITIVE_HEADER (1);
+ STRING_RESULT (OS_file_soft_link_p (STRING_ARG (1)));
+}
+\f
+DEFINE_PRIMITIVE ("FILE-REMOVE", Prim_file_remove, 1, 1,
+ "Delete file FILENAME.\n\
+If FILENAME is a soft link, the link is deleted.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_file_remove (STRING_ARG (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("FILE-REMOVE-LINK", Prim_file_remove_link, 1, 1,
+ "If file FILENAME is a link to another file (hard or soft), remove it.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_file_remove_link (STRING_ARG (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("FILE-RENAME", Prim_file_rename, 2, 2,
+ "Rename file FROM-NAME to TO-NAME.")
+{
+ PRIMITIVE_HEADER (2);
+ OS_file_rename ((STRING_ARG (1)), (STRING_ARG (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("FILE-LINK-HARD", Prim_file_link_hard, 2, 2,
+ "Create a hard link from file FROM-NAME to file TO-NAME.\n\
+TO-NAME becomes another name for the file FROM-NAME.")
+{
+ PRIMITIVE_HEADER (2);
+ OS_file_link_hard ((STRING_ARG (1)), (STRING_ARG (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("FILE-LINK-SOFT", Prim_file_link_soft, 2, 2,
+ "Create a soft link from file FROM-NAME to file TO-NAME.\n\
+TO-NAME becomes a soft link containing the string FROM-NAME.")
+{
+ PRIMITIVE_HEADER (2);
+ OS_file_link_soft ((STRING_ARG (1)), (STRING_ARG (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("LINK-FILE", Prim_link_file, 3, 3,
+ "This is an obsolete primitive. Use `file-link-hard' or `file-link-soft'.\n\
+Create a new name for file FROM-NAME, called TO-NAME.\n\
+If third arg HARD? is #F, a soft link is created;\n\
+ otherwise a hard link is created.")
+{
+ PRIMITIVE_HEADER (3);
+ {
+ CONST char * from_name = (STRING_ARG (1));
+ CONST char * to_name = (STRING_ARG (2));
+ if ((ARG_REF (3)) != SHARP_F)
+ OS_file_link_hard (from_name, to_name);
+ else
+ OS_file_link_soft (from_name, to_name);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+#ifndef FILE_COPY_BUFFER_LENGTH
+#define FILE_COPY_BUFFER_LENGTH 8192
+#endif
+
+static void
+DEFUN (OS_file_copy, (from_name, to_name),
+ CONST char * from_name AND
+ CONST char * to_name)
+{
+ char buffer [FILE_COPY_BUFFER_LENGTH];
+ Tchannel source_channel = (OS_open_input_file (from_name));
+ Tchannel destination_channel = (OS_open_output_file (to_name));
+ off_t source_length = (OS_file_length (source_channel));
+ off_t transfer_length =
+ ((source_length > (sizeof (buffer))) ? (sizeof (buffer)) : source_length);
+ if (source_length > 0)
+ while (1)
+ {
+ long nread =
+ (OS_channel_read (source_channel, buffer, transfer_length));
+ if (nread == 0)
+ break;
+ OS_channel_write (destination_channel, buffer, nread);
+ source_length -= nread;
+ if (source_length == 0)
+ break;
+ if (source_length < (sizeof (buffer)))
+ transfer_length = source_length;
+ }
+ OS_channel_close (source_channel);
+ OS_channel_close (destination_channel);
+}
+
+DEFINE_PRIMITIVE ("FILE-COPY", Prim_file_copy, 2, 2,
+ "Make a new copy of the file FROM-NAME, called TO-NAME.")
+{
+ PRIMITIVE_HEADER (2);
+ OS_file_copy ((STRING_ARG (1)), (STRING_ARG (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("DIRECTORY-MAKE", Prim_directory_make, 1, 1,
+ "Create a new directory, called NAME.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_directory_make (STRING_ARG (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("DIRECTORY-OPEN", Prim_directory_open, 1, 1,
+ "Open the directory NAME for reading.\n\
+If successful, return the first filename in the directory as a string.\n\
+If there is no such file, or the directory cannot be opened, #F is returned.")
+{
+ PRIMITIVE_HEADER (1);
+ STRING_RESULT (OS_directory_open (STRING_ARG (1)));
+}
+
+DEFINE_PRIMITIVE ("DIRECTORY-READ", Prim_directory_read, 0, 0,
+ "Read and return a filename from the directory opened by `directory-open'.\n\
+Return #F if there are no more files in the directory.")
+{
+ PRIMITIVE_HEADER (0);
+ STRING_RESULT (OS_directory_read ());
+}
+
+DEFINE_PRIMITIVE ("DIRECTORY-CLOSE", Prim_directory_close, 0, 0,
+ "Close the directory opened by `directory-open'.")
+{
+ PRIMITIVE_HEADER (0);
+ OS_directory_close ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prosio.c,v 1.1 1990/06/20 19:38:27 cph Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Primitives to perform I/O to and from files. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "osio.h"
+
+#ifndef CLOSE_CHANNEL_HOOK
+#define CLOSE_CHANNEL_HOOK(channel)
+#endif
+\f
+static Tchannel
+DEFUN (arg_to_channel, (argument, arg_number),
+ SCHEME_OBJECT argument AND
+ int arg_number)
+{
+ if (! ((INTEGER_P (argument)) && (integer_to_long_p (argument))))
+ error_wrong_type_arg (arg_number);
+ {
+ fast long channel = (integer_to_long (argument));
+ if (! ((channel >= 0) || (channel < OS_channel_table_size)))
+ error_wrong_type_arg (arg_number);
+ return (channel);
+ }
+}
+
+Tchannel
+DEFUN (arg_channel, (arg_number), int arg_number)
+{
+ fast Tchannel channel =
+ (arg_to_channel ((ARG_REF (arg_number)), arg_number));
+ if (! (OS_channel_open_p (channel)))
+ error_bad_range_arg (arg_number);
+ return (channel);
+}
+
+Tchannel
+DEFUN (arg_channel_old, (arg_number), int arg_number)
+{
+ fast SCHEME_OBJECT argument = (ARG_REF (arg_number));
+ if ((OBJECT_TYPE (argument)) != TC_HUNK3)
+ error_wrong_type_arg (arg_number);
+ {
+ fast Tchannel channel =
+ (arg_to_channel ((MEMORY_REF (argument, 0)), arg_number));
+ if (! (OS_channel_open_p (channel)))
+ error_bad_range_arg (arg_number);
+ return (channel);
+ }
+}
+
+DEFINE_PRIMITIVE ("CHANNEL-CLOSE", Prim_channel_close, 1, 1,
+ "Close file CHANNEL-NUMBER.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ fast Tchannel channel = (arg_to_channel ((ARG_REF (1)), 1));
+ if (OS_channel_open_p (channel))
+ {
+ CLOSE_CHANNEL_HOOK (channel);
+ OS_channel_close (channel);
+ }
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("CHANNEL-TABLE", Prim_channel_table, 0, 0,
+ "Return a vector of all channels in the channel table.")
+{
+ PRIMITIVE_HEADER (0);
+ {
+ Tchannel channel;
+ for (channel = 0; (channel < OS_channel_table_size); channel += 1)
+ if (OS_channel_open_p (channel))
+ obstack_grow ((&scratch_obstack), (&channel), (sizeof (Tchannel)));
+ }
+ {
+ unsigned int n_channels =
+ ((obstack_object_size ((&scratch_obstack))) / (sizeof (Tchannel)));
+ if (n_channels == 0)
+ PRIMITIVE_RETURN (SHARP_F);
+ {
+ Tchannel * channels = (obstack_finish (&scratch_obstack));
+ Tchannel * scan_channels = channels;
+ SCHEME_OBJECT vector =
+ (allocate_marked_vector (TC_VECTOR, n_channels, 1));
+ SCHEME_OBJECT * scan_vector = (VECTOR_LOC (vector, 0));
+ SCHEME_OBJECT * end_vector = (scan_vector + n_channels);
+ while (scan_vector < end_vector)
+ (*scan_vector++) = (long_to_integer (*scan_channels++));
+ obstack_free ((&scratch_obstack), channels);
+ PRIMITIVE_RETURN (vector);
+ }
+ }
+}
+
+DEFINE_PRIMITIVE ("CHANNEL-TYPE", Prim_channel_type, 1, 1,
+ "Return (as a nonnegative integer) the type of CHANNEL.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN
+ (long_to_integer ((long) (OS_channel_type (arg_channel (1)))));
+}
+\f
+DEFINE_PRIMITIVE ("CHANNEL-READ", Prim_channel_read, 4, 4,
+ "Read characters from CHANNEL, storing them in STRING.\n\
+Third and fourth args START and END specify the substring to use.\n\
+Attempt to fill that substring unless end-of-file is reached.\n\
+Return the number of characters actually read from CHANNEL.")
+{
+ PRIMITIVE_HEADER (4);
+ CHECK_ARG (2, STRING_P);
+ {
+ SCHEME_OBJECT buffer = (ARG_REF (2));
+ long length = (STRING_LENGTH (buffer));
+ long end = (arg_index_integer (4, (length + 1)));
+ long start = (arg_index_integer (3, (end + 1)));
+ long nread =
+ (OS_channel_read ((arg_channel (1)),
+ (STRING_LOC (buffer, start)),
+ (end - start)));
+ PRIMITIVE_RETURN ((nread < 0) ? SHARP_F : (long_to_integer (nread)));
+ }
+}
+
+DEFINE_PRIMITIVE ("CHANNEL-WRITE", Prim_channel_write, 4, 4,
+ "Write characters to CHANNEL, reading them from STRING.\n\
+Third and fourth args START and END specify the substring to use.")
+{
+ PRIMITIVE_HEADER (4);
+ CHECK_ARG (2, STRING_P);
+ {
+ SCHEME_OBJECT buffer = (ARG_REF (2));
+ long length = (STRING_LENGTH (buffer));
+ long end = (arg_index_integer (4, (length + 1)));
+ long start = (arg_index_integer (3, (end + 1)));
+ long nwritten =
+ (OS_channel_write ((arg_channel (1)),
+ (STRING_LOC (buffer, start)),
+ (end - start)));
+ PRIMITIVE_RETURN ((nwritten < 0) ? SHARP_F : (long_to_integer (nwritten)));
+ }
+}
+
+DEFINE_PRIMITIVE ("CHANNEL-BLOCKING?", Prim_channel_blocking_p, 1, 1,
+ "Return #F iff CHANNEL is in non-blocking mode.\n\
+Otherwise, CHANNEL is in blocking mode.\n\
+If CHANNEL can be put in non-blocking mode, #T is returned.\n\
+If it cannot, 0 is returned.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ int result = (OS_channel_nonblocking_p (arg_channel (1)));
+ PRIMITIVE_RETURN
+ ((result < 0)
+ ? (LONG_TO_UNSIGNED_FIXNUM (0))
+ : (BOOLEAN_TO_OBJECT (result == 0)));
+ }
+}
+
+DEFINE_PRIMITIVE ("CHANNEL-NONBLOCKING", Prim_channel_nonblocking, 1, 1,
+ "Put CHANNEL in non-blocking mode.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_channel_nonblocking (arg_channel (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("CHANNEL-BLOCKING", Prim_channel_blocking, 1, 1,
+ "Put CHANNEL in blocking mode.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_channel_blocking (arg_channel (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("FILE-FILL-INPUT-BUFFER", Prim_file_fill_input_buffer, 2, 2,
+ "Read characters from CHANNEL, storing them in STRING.\n\
+Attempt to fill STRING unless end-of-file is reached.
+Return the number of characters actually read from CHANNEL.")
+{
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (2, STRING_P);
+ {
+ SCHEME_OBJECT buffer = (ARG_REF (2));
+ long nread =
+ (OS_channel_read ((arg_channel_old (1)),
+ (STRING_LOC (buffer, 0)),
+ (STRING_LENGTH (buffer))));
+ PRIMITIVE_RETURN ((nread < 0) ? SHARP_F : (long_to_integer (nread)));
+ }
+}
+
+DEFINE_PRIMITIVE ("FILE-WRITE-CHAR", Prim_file_write_char, 2, 2,
+ "This is an obsolete primitive.\n\
+Write CHAR to CHANNEL.")
+{
+ PRIMITIVE_HEADER (2);
+ {
+ char c = (arg_ascii_char (1));
+ long nwritten = (OS_channel_write ((arg_channel_old (2)), (&c), 1));
+ PRIMITIVE_RETURN ((nwritten < 0) ? SHARP_F : (long_to_integer (nwritten)));
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("FILE-FLUSH-OUTPUT", Prim_file_flush_output, 1, 1,
+ "This is an obsolete primitive.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("FILE-WRITE-STRING", Prim_file_write_string, 2, 2,
+ "This is an obsolete primitive.")
+{
+ PRIMITIVE_HEADER (2);
+ {
+ fast SCHEME_OBJECT buffer = (ARG_REF (1));
+ if (! (STRING_P (buffer)))
+ error_wrong_type_arg (1);
+ {
+ long nwritten =
+ (OS_channel_write ((arg_channel_old (2)),
+ (STRING_LOC (buffer, 0)),
+ (STRING_LENGTH (buffer))));
+ PRIMITIVE_RETURN
+ ((nwritten < 0) ? SHARP_F : (long_to_integer (nwritten)));
+ }
+ }
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prosproc.c,v 1.1 1990/06/20 19:38:30 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Primitives for subprocess control. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "osproc.h"
+
+static int EXFUN (string_vector_p, (SCHEME_OBJECT vector));
+static char ** EXFUN (convert_string_vector, (SCHEME_OBJECT vector));
+\f
+static Tprocess
+DEFUN (arg_process, (argument_number), int argument_number)
+{
+ Tprocess process =
+ (arg_index_integer (argument_number, OS_process_table_size));
+ switch (OS_process_status (process))
+ {
+ case process_status_exited:
+ case process_status_signalled:
+ case process_status_running:
+ case process_status_stopped:
+ break;
+ default:
+ error_bad_range_arg (1);
+ break;
+ }
+ return (process);
+}
+
+DEFINE_PRIMITIVE ("MAKE-SUBPROCESS", Prim_make_subprocess, 4, 4,
+ "Create a subprocess.\n\
+First arg FILENAME is the program to run.\n\
+Second arg ARGV is a vector of strings to pass to the program as arguments.\n\
+Third arg ENV is a vector of strings to pass as the program's environment.\n\
+Fourth arg CTTY-TYPE specifies the program's controlling terminal type:\n\
+ 0 => none; 1 => inherited; 2 => pipe; 3 => PTY.")
+{
+ PRIMITIVE_HEADER (4);
+ CHECK_ARG (2, string_vector_p);
+ CHECK_ARG (3, string_vector_p);
+ {
+ PTR position = dstack_position;
+ CONST char * filename = (STRING_ARG (1));
+ CONST char ** argv =
+ ((CONST char **) (convert_string_vector (ARG_REF (2))));
+ char ** env = (convert_string_vector (ARG_REF (3)));
+ enum process_ctty_type ctty_type;
+ Tprocess process;
+ switch (arg_index_integer (4, 4))
+ {
+ case 0: ctty_type = ctty_type_none; break;
+ case 1: ctty_type = ctty_type_inherited; break;
+ case 2: ctty_type = ctty_type_pipe; break;
+ case 3: ctty_type = ctty_type_pty; break;
+ }
+ process = (OS_make_subprocess (filename, argv, env, ctty_type));
+ dstack_set_position (position);
+ PRIMITIVE_RETURN (long_to_integer (process));
+ }
+}
+
+static int
+DEFUN (string_vector_p, (vector), SCHEME_OBJECT vector)
+{
+ if (! (VECTOR_P (vector)))
+ return (0);
+ {
+ unsigned long length = (VECTOR_LENGTH (vector));
+ SCHEME_OBJECT * scan = (VECTOR_LOC (vector, 0));
+ SCHEME_OBJECT * end = (scan + length);
+ while (scan < end)
+ if (! (STRING_P (*scan++)))
+ return (0);
+ }
+ return (1);
+}
+
+static char **
+DEFUN (convert_string_vector, (vector), SCHEME_OBJECT vector)
+{
+ unsigned long length = (VECTOR_LENGTH (vector));
+ char ** result = (dstack_alloc (length * (sizeof (char *))));
+ SCHEME_OBJECT * scan = (VECTOR_LOC (vector, 0));
+ SCHEME_OBJECT * end = (scan + length);
+ char ** scan_result = result;
+ while (scan < end)
+ (*scan_result++) = ((char *) (STRING_LOC ((*scan++), 0)));
+ return (result);
+}
+\f
+DEFINE_PRIMITIVE ("PROCESS-DELETE", Prim_process_delete, 1, 1,
+ "Delete process PROCESS-NUMBER from the process table.\n\
+The process may be deleted only if it is exited or stopped.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ Tprocess process = (arg_index_integer (1, OS_process_table_size));
+ switch (OS_process_status (process))
+ {
+ case process_status_free:
+ break;
+ case process_status_allocated:
+ case process_status_exited:
+ case process_status_signalled:
+ OS_process_deallocate (process);
+ break;
+ case process_status_running:
+ case process_status_stopped:
+ error_bad_range_arg (1);
+ break;
+ }
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("PROCESS-TABLE", Prim_process_table, 0, 0,
+ "Return a vector of all processes in the process table.")
+{
+ PRIMITIVE_HEADER (0);
+ {
+ Tprocess process;
+ for (process = 0; (process < OS_process_table_size); process += 1)
+ if ((OS_process_status (process)) != process_status_free)
+ obstack_grow ((&scratch_obstack), (&process), (sizeof (Tprocess)));
+ }
+ {
+ unsigned int n_processes =
+ ((obstack_object_size ((&scratch_obstack))) / (sizeof (Tprocess)));
+ if (n_processes == 0)
+ PRIMITIVE_RETURN (SHARP_F);
+ {
+ Tprocess * processes = (obstack_finish (&scratch_obstack));
+ Tprocess * scan_processes = processes;
+ SCHEME_OBJECT vector =
+ (allocate_marked_vector (TC_VECTOR, n_processes, 1));
+ SCHEME_OBJECT * scan_vector = (VECTOR_LOC (vector, 0));
+ SCHEME_OBJECT * end_vector = (scan_vector + n_processes);
+ while (scan_vector < end_vector)
+ (*scan_vector++) = (long_to_integer (*scan_processes++));
+ obstack_free ((&scratch_obstack), processes);
+ PRIMITIVE_RETURN (vector);
+ }
+ }
+}
+\f
+DEFINE_PRIMITIVE ("PROCESS-ID", Prim_process_id, 1, 1,
+ "Return the process ID of process PROCESS-NUMBER.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (long_to_integer (OS_process_id (arg_process (1))));
+}
+
+DEFINE_PRIMITIVE ("PROCESS-INPUT", Prim_process_input, 1, 1,
+ "Return the input channel number of process PROCESS-NUMBER.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (long_to_integer (OS_process_input (arg_process (1))));
+}
+
+DEFINE_PRIMITIVE ("PROCESS-OUTPUT", Prim_process_output, 1, 1,
+ "Return the output channel number of process PROCESS-NUMBER.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (long_to_integer (OS_process_output (arg_process (1))));
+}
+
+DEFINE_PRIMITIVE ("PROCESS-SYNCHRONOUS?", Prim_process_synchronous_p, 1, 1,
+ "Return #F iff process PROCESS-NUMBER is not synchronous.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN
+ (BOOLEAN_TO_OBJECT (OS_process_synchronous (arg_process (1))));
+}
+
+DEFINE_PRIMITIVE ("PROCESS-CTTY-TYPE", Prim_process_ctty_type, 1, 1,
+ "Return the controlling terminal type of process PROCESS-NUMBER.\n\
+This is a nonnegative integer:\n\
+ 0 = none; 1 = inherited; 2 = pipe; 3 = PTY.")
+{
+ PRIMITIVE_HEADER (1);
+ switch (OS_process_ctty_type (arg_process (1)))
+ {
+ case ctty_type_none:
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
+ case ctty_type_inherited:
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
+ case ctty_type_pipe:
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (2));
+ case ctty_type_pty:
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (3));
+ default:
+ error_bad_range_arg (1);
+ }
+}
+\f
+DEFINE_PRIMITIVE ("PROCESS-STATUS", Prim_process_status, 1, 1,
+ "Return the status of process PROCESS-NUMBER.\n\
+This is a nonnegative integer:\n\
+ 0 = running; 1 = stopped; 2 = exited; 3 = signalled; 4 = unstarted.")
+{
+ PRIMITIVE_HEADER (1);
+ switch (OS_process_status (arg_index_integer (1, OS_process_table_size)))
+ {
+ case process_status_running:
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
+ case process_status_stopped:
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
+ case process_status_exited:
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (2));
+ case process_status_signalled:
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (3));
+ case process_status_allocated:
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (4));
+ default:
+ error_bad_range_arg (1);
+ }
+}
+
+DEFINE_PRIMITIVE ("PROCESS-REASON", Prim_process_reason, 1, 1,
+ "Return the termination reason of process PROCESS-NUMBER.\n\
+It is an error if the process is running.\n\
+This is a nonnegative integer, which depends on the process's status:\n\
+ stopped => the signal that stopped the process;\n\
+ exited => the exit code returned by the process;\n\
+ signalled => the signal that killed the process.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ Tprocess process = (arg_process (1));
+ if ((OS_process_status (process)) == process_status_running)
+ error_bad_range_arg (1);
+ PRIMITIVE_RETURN (long_to_integer (OS_process_reason (process)));
+ }
+}
+
+DEFINE_PRIMITIVE ("PROCESS-SIGNAL", Prim_process_signal, 2, 2,
+ "Send a signal to process PROCESS-NUMBER; second arg SIGNAL says which one.")
+{
+ PRIMITIVE_HEADER (2);
+ OS_process_send_signal ((arg_process (1)), (arg_nonnegative_integer (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+#define PROCESS_SIGNALLING_PRIMITIVE(signaller) \
+{ \
+ PRIMITIVE_HEADER (1); \
+ signaller (arg_process (1)); \
+ PRIMITIVE_RETURN (UNSPECIFIC); \
+}
+
+DEFINE_PRIMITIVE ("PROCESS-KILL", Prim_process_kill, 1, 1,
+ "Kill process PROCESS-NUMBER (in unix: signal SIGKILL).")
+ PROCESS_SIGNALLING_PRIMITIVE (OS_process_kill)
+
+DEFINE_PRIMITIVE ("PROCESS-INTERRUPT", Prim_process_interrupt, 1, 1,
+ "Interrupt process PROCESS-NUMBER (in unix: signal SIGINT).")
+ PROCESS_SIGNALLING_PRIMITIVE (OS_process_interrupt)
+
+DEFINE_PRIMITIVE ("PROCESS-QUIT", Prim_process_quit, 1, 1,
+ "Quit process PROCESS-NUMBER (in unix: signal SIGQUIT).")
+ PROCESS_SIGNALLING_PRIMITIVE (OS_process_quit)
+
+DEFINE_PRIMITIVE ("PROCESS-STOP", Prim_process_stop, 1, 1,
+ "Stop process PROCESS-NUMBER (in unix: signal SIGTSTP).")
+ PROCESS_SIGNALLING_PRIMITIVE (OS_process_stop)
+
+DEFINE_PRIMITIVE ("PROCESS-CONTINUE", Prim_process_continue, 1, 1,
+ "Continue process PROCESS-NUMBER (in unix: signal SIGCONT).")
+ PROCESS_SIGNALLING_PRIMITIVE (OS_process_continue)
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prosterm.c,v 1.1 1990/06/20 19:38:35 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Primitives to control terminal devices. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "osterm.h"
+#include "osio.h"
+\f
+static Tchannel
+DEFUN (arg_terminal, (argument_number), int argument_number)
+{
+ Tchannel channel = (arg_channel (argument_number));
+ enum channel_type type = (OS_channel_type (channel));
+ if (! ((type == channel_type_terminal) || (type == channel_type_pty_master)))
+ error_bad_range_arg (argument_number);
+ return (channel);
+}
+
+DEFINE_PRIMITIVE ("TERMINAL-READ-CHAR", Prim_terminal_read_char, 1, 1,
+ "Read and return a single character from TERMINAL.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ int c = (OS_terminal_read_char (arg_terminal (1)));
+ PRIMITIVE_RETURN ((c < 0) ? SHARP_F : (ASCII_TO_CHAR (c)));
+ }
+}
+
+DEFINE_PRIMITIVE ("TERMINAL-CHAR-READY?", Prim_terminal_char_ready_p, 2, 2,
+ "Return #T if a character from TERMINAL.\n\
+Second arg DELAY says how long to wait for one to arrive, in milliseconds.")
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (BOOLEAN_TO_OBJECT
+ (OS_terminal_char_ready_p ((arg_terminal (1)),
+ (arg_nonnegative_integer (2)))));
+}
+
+DEFINE_PRIMITIVE ("TERMINAL-BUFFERED?", Prim_terminal_buffered_p, 1, 1,
+ "Return #F iff TERMINAL is not in buffered mode.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN
+ (BOOLEAN_TO_OBJECT (OS_terminal_buffered_p (arg_terminal (1))));
+}
+
+DEFINE_PRIMITIVE ("TERMINAL-BUFFERED", Prim_terminal_buffered, 1, 1,
+ "Put TERMINAL into buffered mode.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_terminal_buffered (arg_terminal (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("TERMINAL-NONBUFFERED", Prim_terminal_nonbuffered, 1, 1,
+ "Put TERMINAL into nonbuffered mode.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_terminal_nonbuffered (arg_terminal (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("TERMINAL-FLUSH-INPUT", Prim_terminal_flush_input, 1, 1,
+ "Discard any characters in TERMINAL's input buffer.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_terminal_flush_input (arg_terminal (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("TERMINAL-FLUSH-OUTPUT", Prim_terminal_flush_output, 1, 1,
+ "Discard any characters in TERMINAL's output buffer.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_terminal_flush_output (arg_terminal (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("TERMINAL-DRAIN-OUTPUT", Prim_terminal_drain_output, 1, 1,
+ "Wait until all characters in TERMINAL's output buffer have been sent.")
+{
+ PRIMITIVE_HEADER (1);
+ OS_terminal_drain_output (arg_terminal (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("OPEN-PTY-MASTER", Prim_open_pty_master, 0, 0,
+ "Open a PTY master, returning the master's channel and the slave's name.\n\
+The result is a pair whose car is a channel and whose cdr is a filename.\n\
+If no PTY can be opened, #F is returned.")
+{
+ PRIMITIVE_HEADER (0);
+ {
+ Tchannel channel;
+ CONST char * master_name;
+ CONST char * slave_name =
+ (OS_open_pty_master ((&channel), (&master_name)));
+ if (slave_name == 0)
+ PRIMITIVE_RETURN (SHARP_F);
+ {
+ SCHEME_OBJECT vector = (allocate_marked_vector (TC_VECTOR, 3, 1));
+ VECTOR_SET (vector, 0, (long_to_integer (channel)));
+ VECTOR_SET (vector, 1, (char_pointer_to_string (master_name)));
+ VECTOR_SET (vector, 2, (char_pointer_to_string (slave_name)));
+ PRIMITIVE_RETURN (vector);
+ }
+ }
+}
+
+DEFINE_PRIMITIVE ("PTY-MASTER-SEND-SIGNAL", Prim_pty_master_send_signal, 2, 2,
+ "Send a signal to PTY-MASTER; second arg says which one.")
+{
+ PRIMITIVE_HEADER (2);
+ {
+ Tchannel channel = (arg_channel (1));
+ if ((OS_channel_type (channel)) != channel_type_pty_master)
+ error_bad_range_arg (1);
+ OS_pty_master_send_signal (channel, (arg_nonnegative_integer (2)));
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prostty.c,v 1.1 1990/06/20 19:38:38 cph Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Primitives to perform I/O to and from the console. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "ostty.h"
+#include "osctty.h"
+#include "ossig.h"
+#include "osfile.h"
+#include "osio.h"
+\f
+static int transcript_file_open;
+static Tchannel transcript_channel;
+
+void
+DEFUN_VOID (OS_initialize_transcript_file)
+{
+ transcript_file_open = 0;
+ return;
+}
+
+DEFINE_PRIMITIVE ("TRANSCRIPT-ON", Prim_transcript_on, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ if (transcript_file_open)
+ error_external_return ();
+ transcript_channel = (OS_open_output_file (STRING_ARG (1)));
+ transcript_file_open = 1;
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("TRANSCRIPT-OFF", Prim_transcript_off, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+ if (transcript_file_open)
+ {
+ OS_channel_close (transcript_channel);
+ transcript_file_open = 0;
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("TTY-INPUT-CHANNEL", Prim_tty_input_channel, 0, 0,
+ "Return the standard input channel.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (long_to_integer (OS_tty_input_channel ()));
+}
+
+DEFINE_PRIMITIVE ("TTY-OUTPUT-CHANNEL", Prim_tty_output_channel, 0, 0,
+ "Return the standard output channel.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (long_to_integer (OS_tty_output_channel ()));
+}
+
+DEFINE_PRIMITIVE ("TTY-X-SIZE", Prim_tty_x_size, 0, 0,
+ "Return the display width in character columns.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (long_to_integer (OS_tty_x_size ()));
+}
+
+DEFINE_PRIMITIVE ("TTY-Y-SIZE", Prim_tty_y_size, 0, 0,
+ "Return the display height in character lines.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (long_to_integer (OS_tty_y_size ()));
+}
+
+DEFINE_PRIMITIVE ("TTY-COMMAND-BEEP", Prim_tty_command_beep, 0, 0,
+ "Return a string that, when written to the display, will make it beep.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (char_pointer_to_string (OS_tty_command_beep ()));
+}
+
+DEFINE_PRIMITIVE ("TTY-COMMAND-CLEAR", Prim_tty_command_clear, 0, 0,
+ "Return a string that, when written to the display, will clear it.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (char_pointer_to_string (OS_tty_command_clear ()));
+}
+\f
+DEFINE_PRIMITIVE ("TTY-READ-CHAR-READY?", Prim_tty_read_char_ready_p, 1, 1,
+ "This is an obsolete primitive.\n\
+Return #T iff a character is ready to be read from the console.\n\
+Argument DELAY says how many milliseconds to wait for a character.\n\
+If a character is typed, #T is returned immediately,\n\
+ otherwise #F is returned after DELAY has expired.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN
+ (BOOLEAN_TO_OBJECT (OS_tty_char_ready_p (arg_nonnegative_integer (1))));
+}
+
+DEFINE_PRIMITIVE ("TTY-READ-CHAR", Prim_tty_read_char, 0, 0,
+ "This is an obsolete primitive.\n\
+Read a character from the console.\n\
+The operating system's input editor is used to provide the character.")
+{
+ PRIMITIVE_HEADER (0);
+ {
+ char c = (OS_tty_read_char ());
+ if (transcript_file_open)
+ {
+ if ((OS_channel_write (transcript_channel, (&c), 1)) != 1)
+ error_external_return ();
+ }
+ PRIMITIVE_RETURN (ASCII_TO_CHAR (c));
+ }
+}
+
+DEFINE_PRIMITIVE ("TTY-READ-CHAR-IMMEDIATE", Prim_tty_read_char_immediate, 0, 0,
+ "This is an obsolete primitive.\n\
+Read a character from the console, without input editing.\n\
+First, any pending input is discarded,\n\
+ then the next character typed is returned immediately.")
+{
+ PRIMITIVE_HEADER (0);
+ {
+ char c = (OS_tty_read_char_immediate ());
+ if (transcript_file_open)
+ {
+ if ((OS_channel_write (transcript_channel, (&c), 1)) != 1)
+ error_external_return ();
+ }
+ PRIMITIVE_RETURN (ASCII_TO_CHAR (c));
+ }
+}
+\f
+DEFINE_PRIMITIVE ("TTY-WRITE-CHAR", Prim_tty_write_char, 1, 1,
+ "This is an obsolete primitive.\n\
+Write a character to the console.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ char c = (arg_ascii_char (1));
+ OS_tty_write_char (c);
+ if (transcript_file_open)
+ {
+ if ((OS_channel_write (transcript_channel, (&c), 1)) != 1)
+ error_external_return ();
+ }
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("TTY-WRITE-STRING", Prim_tty_write_string, 1, 1,
+ "This is an obsolete primitive.\n\
+Write a string to the console.")
+{
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, STRING_P);
+ {
+ fast SCHEME_OBJECT argument = (ARG_REF (1));
+ fast CONST PTR string = (STRING_LOC (argument, 0));
+ OS_tty_write_string (string);
+ if (transcript_file_open)
+ {
+ long length = (STRING_LENGTH (argument));
+ if ((OS_channel_write (transcript_channel, string, length)) != length)
+ error_external_return ();
+ }
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("TTY-FLUSH-OUTPUT", Prim_tty_flush_output, 0, 0,
+ "This is an obsolete primitive.\n\
+Write the contents of the console output buffer to the console.\n\
+Return after all of the contents has been written.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("TTY-BEEP", Prim_tty_beep, 0, 0,
+ "This is an obsolete primitive.\n\
+Ring the console bell.")
+{
+ PRIMITIVE_HEADER (0);
+ OS_tty_beep ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("TTY-CLEAR", Prim_tty_clear, 0, 0,
+ "This is an obsolete primitive.\n\
+Clear the console screen.")
+{
+ PRIMITIVE_HEADER (0);
+ OS_tty_write_string (OS_tty_command_clear ());
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("TTY-NEXT-INTERRUPT-CHAR", Prim_tty_next_interrupt_char, 0, 0,
+ "Return the next interrupt character in the console input buffer.\n\
+The character is returned as an unsigned integer.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (long_to_integer (OS_tty_next_interrupt_char ()));
+}
+
+DEFINE_PRIMITIVE ("TTY-CLEAN-INTERRUPTS", Prim_tty_clean_interrupts, 2, 2,
+ "Clear the input buffer for a character interrupt.\n\
+First arg MODE says how:\n\
+ 0 ==> discard input up to the most recent interrupt marker\n\
+ that matches second arg CHAR.\n\
+ 1 ==> remove all interrupt markers that match second arg CHAR.\n\
+CHAR should be the result of a call to `tty-next-interrupt-char'.")
+{
+ PRIMITIVE_HEADER (2);
+ OS_tty_clean_interrupts ((arg_index_integer (1, 2)),
+ ((enum tty_clean_mode) (arg_ascii_integer (2))));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("TTY-GET-INTERRUPT-ENABLES", Prim_tty_get_interrupt_enables, 0, 0,
+ "Return the current keyboard interrupt enables.")
+{
+ PRIMITIVE_HEADER (0);
+ {
+ Tinterrupt_enables mask;
+ OS_ctty_get_interrupt_enables (&mask);
+ PRIMITIVE_RETURN (long_to_integer (mask));
+ }
+}
+
+DEFINE_PRIMITIVE ("TTY-SET-INTERRUPT-ENABLES", Prim_tty_set_interrupt_enables, 1, 1,
+ "Change the keyboard interrupt enables to MASK.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ Tinterrupt_enables mask = (arg_integer (1));
+ OS_ctty_set_interrupt_enables (&mask);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("TTY-GET-INTERRUPT-CHARS", Prim_tty_get_interrupt_chars, 0, 0,
+ "Return the current interrupt characters as a string.")
+{
+ PRIMITIVE_HEADER (0);
+ {
+ SCHEME_OBJECT result = (allocate_string (6));
+ unsigned char * scan = (STRING_LOC (result, 0));
+ (*scan++) = ((unsigned char) (OS_ctty_quit_char ()));
+ (*scan++) = ((unsigned char) (OS_signal_quit_handler ()));
+ (*scan++) = ((unsigned char) (OS_ctty_int_char ()));
+ (*scan++) = ((unsigned char) (OS_signal_int_handler ()));
+ (*scan++) = ((unsigned char) (OS_ctty_tstp_char ()));
+ (*scan) = ((unsigned char) (OS_signal_tstp_handler ()));
+ PRIMITIVE_RETURN (result);
+ }
+}
+
+DEFINE_PRIMITIVE ("TTY-SET-INTERRUPT-CHARS", Prim_tty_set_interrupt_chars, 1, 1,
+ "Change the current interrupt characters to STRING.\n\
+STRING must be in the correct form for this operating system.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ SCHEME_OBJECT argument = (ARG_REF (1));
+ if (! ((STRING_P (argument)) && ((STRING_LENGTH (argument)) == 6)))
+ error_wrong_type_arg (1);
+ OS_signal_set_interrupt_handlers
+ (((enum interrupt_handler) (STRING_REF (argument, 1))),
+ ((enum interrupt_handler) (STRING_REF (argument, 3))),
+ ((enum interrupt_handler) (STRING_REF (argument, 5))));
+ OS_ctty_set_interrupt_chars
+ ((STRING_REF (argument, 0)),
+ (STRING_REF (argument, 2)),
+ (STRING_REF (argument, 4)));
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("SET-TTY-INTERRUPT-ENABLES!", Prim_set_tty_interrupt_enables, 1, 1,
+ "This primitive is obsolete.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ Tinterrupt_enables old;
+ Tinterrupt_enables new = (arg_integer (1));
+ OS_ctty_get_interrupt_enables (&old);
+ OS_ctty_set_interrupt_enables (&new);
+ PRIMITIVE_RETURN (long_to_integer (old));
+ }
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/pruxenv.c,v 1.1 1990/06/20 19:38:41 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Unix-specific process-environment primitives. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "ux.h"
+
+extern char ** environ;
+\f
+DEFINE_PRIMITIVE ("CURRENT-FILE-TIME", Prim_current_file_time, 0, 0,
+ "Return the current file system time stamp.\n\
+This is an integer whose units are in seconds.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (long_to_integer (UX_time (0)));
+}
+
+DEFINE_PRIMITIVE ("FILE-TIME->STRING", Prim_file_time_to_string, 1, 1,
+ "Convert a file system time stamp into a date/time string.")
+{
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, INTEGER_P);
+ {
+ long clock = (arg_integer (1));
+ char * time_string = (UX_ctime (&clock));
+ (time_string[24]) = '\0';
+ PRIMITIVE_RETURN (char_pointer_to_string (time_string));
+ }
+}
+
+DEFINE_PRIMITIVE ("GET-USER-HOME-DIRECTORY", Prim_get_user_home_directory, 1, 1,
+ "Return the file name of a given user's home directory.\n\
+The user name argument must be a string.\n\
+If no such user is known, #F is returned.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ struct passwd * entry = (UX_getpwnam (STRING_ARG (1)));
+ PRIMITIVE_RETURN
+ ((entry == 0) ? SHARP_F : (char_pointer_to_string (entry -> pw_dir)));
+ }
+}
+
+DEFINE_PRIMITIVE ("UID->STRING", Prim_uid_to_string, 1, 1,
+ "Return the user name corresponding to UID.\n\
+If the argument is not a known user ID, #F is returned.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ struct passwd * entry = (UX_getpwuid (arg_nonnegative_integer (1)));
+ PRIMITIVE_RETURN
+ ((entry == 0) ? SHARP_F : (char_pointer_to_string (entry -> pw_name)));
+ }
+}
+
+DEFINE_PRIMITIVE ("GID->STRING", Prim_gid_to_string, 1, 1,
+ "Return the group name corresponding to GID.\n\
+If the argument is not a known group ID, #F is returned.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ struct group * entry = (UX_getgrgid (arg_nonnegative_integer (1)));
+ PRIMITIVE_RETURN
+ ((entry == 0) ? SHARP_F : (char_pointer_to_string (entry -> gr_name)));
+ }
+}
+
+DEFINE_PRIMITIVE ("CURRENT-UID", Prim_current_uid, 0, 0,
+ "Return Scheme's effective UID.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (long_to_integer (UX_geteuid ()));
+}
+
+DEFINE_PRIMITIVE ("CURRENT-GID", Prim_current_gid, 0, 0,
+ "Return Scheme's effective GID.")
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (long_to_integer (UX_getegid ()));
+}
+\f
+DEFINE_PRIMITIVE ("SYSTEM", Prim_system, 1, 1,
+ "Invoke sh (the Bourne shell) on the string argument.\n\
+Wait until the shell terminates, returning its exit status as an integer.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (long_to_integer (UX_system (STRING_ARG (1))));
+}
+
+DEFINE_PRIMITIVE ("UNIX-ENVIRONMENT", Prim_unix_environment_alist, 0, 0,
+ "Copy the unix environment and return it as a vector of strings.")
+{
+ PRIMITIVE_HEADER (0);
+ {
+ char ** scan = environ;
+ char ** end = scan;
+ while ((*end++) != 0);
+ end -= 1;
+ {
+ SCHEME_OBJECT result =
+ (allocate_marked_vector (TC_VECTOR, (end - scan), 1));
+ SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
+ while (scan < end)
+ (*scan_result++) = (char_pointer_to_string (*scan++));
+ PRIMITIVE_RETURN (result);
+ }
+ }
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/pruxsock.c,v 1.1 1990/06/20 19:38:47 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Primitives for socket control. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "ux.h"
+
+#ifdef HAVE_SOCKETS
+
+#include "uxsock.h"
+\f
+DEFINE_PRIMITIVE ("GET-SERVICE-BY-NAME", Prim_get_service_by_name, 2, 2,
+ "Given SERVICE-NAME and PROTOCOL-NAME, return a port number.\n\
+The result is a nonnegative integer, or #F if no such service exists.")
+{
+ PRIMITIVE_HEADER (2);
+ {
+ int result = (OS_get_service_by_name ((STRING_ARG (1)), (STRING_ARG (2))));
+ return ((result < 0) ? SHARP_F : (long_to_integer (result)));
+ }
+}
+
+DEFINE_PRIMITIVE ("GET-HOST-BY-NAME", Prim_get_host_by_name, 1, 1,
+ "Given HOST-NAME, return its internet host numbers.\n\
+The result is a vector of nonnegative integers, or #F if no such host exists.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ struct host_addresses * result = (OS_get_host_by_name (STRING_ARG (1)));
+ if (result == 0)
+ PRIMITIVE_RETURN (SHARP_F);
+ {
+ int length = (result -> address_length);
+ char ** scan = (result -> addresses);
+ char ** end = scan;
+ while ((*end++) != 0) ;
+ end -= 1;
+ {
+ SCHEME_OBJECT result =
+ (allocate_marked_vector (TC_VECTOR, (end - scan), 1));
+ SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
+ while (scan < end)
+ (*scan_result++) = (memory_to_string (length, (*scan++)));
+ PRIMITIVE_RETURN (result);
+ }
+ }
+ }
+}
+
+DEFINE_PRIMITIVE ("OPEN-TCP-STREAM-SOCKET", Prim_open_tcp_stream_socket, 2, 2,
+ "Given HOST-ADDRESS and PORT-NUMBER, open and return a TCP stream socket.")
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ (OS_open_tcp_stream_socket ((STRING_ARG (1)),
+ (arg_nonnegative_integer (2)))));
+}
+
+#ifdef HAVE_UNIX_SOCKETS
+
+DEFINE_PRIMITIVE ("OPEN-UNIX-STREAM-SOCKET", Prim_open_unix_stream_socket, 1, 1,
+ "Open the unix stream socket FILENAME.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN
+ (long_to_integer (OS_open_unix_stream_socket (STRING_ARG (1))));
+}
+
+#endif /* HAVE_UNIX_SOCKETS */
+
+#endif /* HAVE_SOCKETS */
--- /dev/null
+/* Copyright (C) 1990 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 1, 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 program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/ptrvec.c,v 1.1 1990/06/20 19:38:50 cph Rel $ */
+
+#include <stdio.h>
+#include "dstack.h"
+
+static PTR
+DEFUN (xmalloc, (length), unsigned int length)
+{
+ extern PTR EXFUN (malloc, (unsigned int length));
+ PTR result = (malloc (length));
+ if (result == 0)
+ {
+ fputs ("malloc: memory allocation failed\n", stderr);
+ fflush (stderr);
+ abort ();
+ }
+ return (result);
+}
+
+static PTR
+DEFUN (xrealloc, (ptr, length), PTR ptr AND unsigned int length)
+{
+ extern PTR EXFUN (realloc, (PTR ptr, unsigned int length));
+ PTR result = (realloc (ptr, length));
+ if (result == 0)
+ {
+ fputs ("realloc: memory allocation failed\n", stderr);
+ fflush (stderr);
+ abort ();
+ }
+ return (result);
+}
+
+Tptrvec
+DEFUN (ptrvec_allocate, (length), Tptrvec_length length)
+{
+ Tptrvec ptrvec = (xmalloc (sizeof (struct struct_ptrvec)));
+ (ptrvec -> length) = length;
+ (ptrvec -> elements) =
+ ((length > 0) ? (xmalloc (length * (sizeof (PTR)))) : 0);
+ return (ptrvec);
+}
+
+void
+DEFUN (ptrvec_deallocate, (ptrvec), Tptrvec ptrvec)
+{
+ if ((ptrvec -> length) > 0)
+ free (ptrvec -> elements);
+ free (ptrvec);
+}
+
+void
+DEFUN (ptrvec_set_length, (ptrvec, length),
+ Tptrvec ptrvec AND
+ Tptrvec_length length)
+{
+ (ptrvec -> length) = length;
+ (ptrvec -> elements) =
+ ((length > 0)
+ ? (xrealloc ((ptrvec -> elements), (length * (sizeof (PTR)))))
+ : 0);
+}
+
+Tptrvec
+DEFUN (ptrvec_copy, (ptrvec), Tptrvec ptrvec)
+{
+ Tptrvec_length length = (PTRVEC_LENGTH (ptrvec));
+ Tptrvec result = (ptrvec_allocate (length));
+ PTR * scan_source = (PTRVEC_START (ptrvec));
+ PTR * end_source = (scan_source + length);
+ PTR * scan_result = (PTRVEC_START (result));
+ while (scan_source < end_source)
+ (*scan_result++) = (*scan_source++);
+ return (result);
+}
+
+void
+DEFUN (ptrvec_adjoin, (ptrvec, element), Tptrvec ptrvec AND PTR element)
+{
+ Tptrvec_length length = (PTRVEC_LENGTH (ptrvec));
+ ptrvec_set_length (ptrvec, (length + 1));
+ (PTRVEC_REF (ptrvec, length)) = element;
+}
+
+int
+DEFUN (ptrvec_memq, (ptrvec, element), Tptrvec ptrvec AND PTR element)
+{
+ PTR * scan = (PTRVEC_START (ptrvec));
+ PTR * end = (scan + (PTRVEC_LENGTH (ptrvec)));
+ while (scan < end)
+ if (element == (*scan++))
+ return (1);
+ return (0);
+}
+
+void
+DEFUN (ptrvec_move_left,
+ (source, source_start, source_end, target, target_start),
+ Tptrvec source AND
+ Tptrvec_index source_start AND
+ Tptrvec_index source_end AND
+ Tptrvec target AND
+ Tptrvec_index target_start)
+{
+ PTR * scan_source = (PTRVEC_LOC (source, source_start));
+ PTR * end_source = (PTRVEC_LOC (source, source_end));
+ PTR * scan_target = (PTRVEC_LOC (target, target_start));
+ while (scan_source < end_source)
+ (*scan_target++) = (*scan_source++);
+}
+
+void
+DEFUN (ptrvec_move_right,
+ (source, source_start, source_end, target, target_start),
+ Tptrvec source AND
+ Tptrvec_index source_start AND
+ Tptrvec_index source_end AND
+ Tptrvec target AND
+ Tptrvec_index target_start)
+{
+ PTR * end_source = (PTRVEC_LOC (source, source_start));
+ PTR * scan_source = (PTRVEC_LOC (source, source_end));
+ PTR * scan_target =
+ (PTRVEC_LOC (target, (target_start + (source_end - source_start))));
+ while (scan_source > end_source)
+ (*--scan_target) = (*--scan_source);
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/term.c,v 1.1 1990/06/20 19:38:53 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "scheme.h"
+
+extern long death_blow;
+extern char * Term_Messages [];
+extern void EXFUN (get_band_parameters, (long * heap_size, long * const_size));
+extern void EXFUN (Reset_Memory, (void));
+
+#ifndef EXIT_HOOK
+#define EXIT_HOOK()
+#endif
+
+#define BYTES_TO_BLOCKS(n) (((n) + 1023) / 1024)
+#define MIN_HEAP_DELTA 50
+\f
+static void
+DEFUN (attempt_termination_backout, (code), int code)
+{
+ if ((WITHIN_CRITICAL_SECTION_P ())
+ || (code == TERM_HALT)
+ || (! (Valid_Fixed_Obj_Vector ())))
+ return;
+ {
+ SCHEME_OBJECT Term_Vector = (Get_Fixed_Obj_Slot (Termination_Proc_Vector));
+ if ((! (VECTOR_P (Term_Vector)))
+ || ((VECTOR_LENGTH (Term_Vector)) <= code))
+ return;
+ {
+ SCHEME_OBJECT Handler = (VECTOR_REF (Term_Vector, code));
+ if (Handler == SHARP_F)
+ return;
+ Will_Push (CONTINUATION_SIZE
+ + STACK_ENV_EXTRA_SLOTS
+ + ((code == TERM_NO_ERROR_HANDLER) ? 5 : 4));
+ Store_Return (RC_HALT);
+ Store_Expression (LONG_TO_UNSIGNED_FIXNUM (code));
+ Save_Cont ();
+ if (code == TERM_NO_ERROR_HANDLER)
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (death_blow));
+ STACK_PUSH (Val); /* Arg 3 */
+ STACK_PUSH (Fetch_Env ()); /* Arg 2 */
+ STACK_PUSH (Fetch_Expression ()); /* Arg 1 */
+ STACK_PUSH (Handler); /* The handler function */
+ STACK_PUSH (STACK_FRAME_HEADER
+ + ((code == TERM_NO_ERROR_HANDLER) ? 4 : 3));
+ Pushed ();
+ abort_to_interpreter (PRIM_NO_TRAP_APPLY);
+ }
+ }
+}
+
+static void
+DEFUN (termination_prefix, (code), int code)
+{
+ attempt_termination_backout (code);
+ putc ('\n', stdout);
+ if ((code < 0) || (code > MAX_TERMINATION))
+ fprintf (stdout, "Unknown termination code 0x%x", code);
+ else
+ fputs ((Term_Messages [code]), stdout);
+ if ((WITHIN_CRITICAL_SECTION_P ()) && (code != TERM_HALT))
+ fprintf (stdout, " within critical section \"%s\"",
+ (CRITICAL_SECTION_NAME ()));
+ fputs (".\n", stdout);
+}
+
+static void
+DEFUN (termination_suffix, (code, value, abnormal_p),
+ int code AND int value AND int abnormal_p)
+{
+ fflush (stdout);
+ Reset_Memory ();
+ EXIT_HOOK ();
+ Exit_Scheme (value);
+}
+
+static void
+DEFUN (termination_suffix_trace, (code), int code)
+{
+ if (Trace_On_Error)
+ {
+ fprintf (stdout, "\n\n**** Stack trace ****\n\n");
+ Back_Trace (stdout);
+ }
+ termination_suffix (code, 1, 1);
+}
+
+void
+DEFUN (Microcode_Termination, (code), int code)
+{
+ termination_prefix (code);
+ termination_suffix_trace (code);
+}
+\f
+void
+DEFUN_VOID (termination_normal)
+{
+ termination_prefix (TERM_HALT);
+ termination_suffix (TERM_HALT, 0, 0);
+}
+
+void
+DEFUN_VOID (termination_end_of_computation)
+{
+ termination_prefix (TERM_END_OF_COMPUTATION);
+ Print_Expression (Val, "Final result");
+ putc ('\n', stdout);
+ termination_suffix (TERM_END_OF_COMPUTATION, 0, 0);
+}
+
+void
+DEFUN_VOID (termination_trap)
+{
+ /* This claims not to be abnormal so that the user will
+ not be asked a second time about dumping core. */
+ termination_prefix (TERM_TRAP);
+ termination_suffix (TERM_TRAP, 1, 0);
+}
+
+void
+DEFUN_VOID (termination_no_error_handler)
+{
+ /* This does not print a back trace because the caller printed one. */
+ termination_prefix (TERM_NO_ERROR_HANDLER);
+ if (death_blow == ERR_FASL_FILE_TOO_BIG)
+ {
+ long heap_size;
+ long const_size;
+ get_band_parameters (&heap_size, &const_size);
+ fputs ("Try again with values at least as large as\n", stdout);
+ fprintf (stdout, " -heap %d (%d + %d)\n",
+ (MIN_HEAP_DELTA + (BYTES_TO_BLOCKS (heap_size))),
+ (BYTES_TO_BLOCKS (heap_size)),
+ MIN_HEAP_DELTA);
+ fprintf (stdout, " -constant %d\n", (BYTES_TO_BLOCKS (const_size)));
+ }
+ termination_suffix (TERM_NO_ERROR_HANDLER, 1, 1);
+}
+
+void
+DEFUN_VOID (termination_gc_out_of_space)
+{
+ termination_prefix (TERM_GC_OUT_OF_SPACE);
+ fputs ("You are out of space at the end of a Garbage Collection!\n",
+ stdout);
+ fprintf (stdout, "Free = 0x%lx; MemTop = 0x%lx; Heap_Top = 0x%lx\n",
+ Free, MemTop, Heap_Top);
+ fprintf (stdout, "Words required = %ld; Words available = %ld\n",
+ (MemTop - Free), GC_Space_Needed);
+ termination_suffix_trace (TERM_GC_OUT_OF_SPACE);
+}
+
+void
+DEFUN_VOID (termination_eof)
+{
+ Microcode_Termination (TERM_EOF);
+}
+
+void
+DEFUN (termination_signal, (signal_name), CONST char * signal_name)
+{
+ if (signal_name != 0)
+ {
+ termination_prefix (TERM_SIGNAL);
+ fprintf (stdout, "Killed by %s.\n", signal_name);
+ }
+ else
+ attempt_termination_backout (TERM_SIGNAL);
+ termination_suffix_trace (TERM_SIGNAL);
+}
--- /dev/null
+/* Copyright (C) 1990 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 1, 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 program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/transact.c,v 1.1 1990/06/20 19:38:56 cph Rel $ */
+
+#include <stdio.h>
+#include "dstack.h"
+
+static void
+DEFUN (error, (procedure_name, message),
+ CONST char * procedure_name AND
+ CONST char * message)
+{
+ fprintf (stderr, "%s: %s\n", procedure_name, message);
+ fflush (stderr);
+ abort ();
+}
+
+enum transaction_state { active, aborting, committing };
+
+struct transaction
+{
+ PTR checkpoint;
+ enum transaction_state state;
+};
+
+static struct transaction * current_transaction;
+
+static void
+DEFUN (guarantee_current_transaction, (proc), CONST char * proc)
+{
+ if (current_transaction == 0)
+ error (proc, "no transaction");
+ switch (current_transaction -> state)
+ {
+ case committing: error (proc, "commit in progress");
+ case aborting: error (proc, "abort in progress");
+ }
+}
+
+void
+DEFUN_VOID (transaction_initialize)
+{
+ current_transaction = 0;
+}
+
+void
+DEFUN_VOID (transaction_begin)
+{
+ PTR checkpoint = dstack_position;
+ struct transaction * transaction =
+ (dstack_alloc (sizeof (struct transaction)));
+ (transaction -> checkpoint) = checkpoint;
+ (transaction -> state) = active;
+ dstack_bind ((¤t_transaction), transaction);
+}
+
+void
+DEFUN_VOID (transaction_abort)
+{
+ guarantee_current_transaction ("transaction_abort");
+ (current_transaction -> state) = aborting;
+ dstack_set_position (current_transaction -> checkpoint);
+}
+
+void
+DEFUN_VOID (transaction_commit)
+{
+ guarantee_current_transaction ("transaction_commit");
+ (current_transaction -> state) = committing;
+ dstack_set_position (current_transaction -> checkpoint);
+}
+
+struct action
+{
+ enum transaction_action_type type;
+ void EXFUN ((*procedure), (PTR environment));
+ PTR environment;
+};
+
+static void
+DEFUN (execute_action, (action), PTR action)
+{
+ if ((((struct action *) action) -> type) !=
+ (((current_transaction -> state) == committing)
+ ? tat_abort : tat_commit))
+ (* (((struct action *) action) -> procedure))
+ (((struct action *) action) -> environment);
+}
+
+void
+DEFUN (transaction_record_action, (type, procedure, environment),
+ enum transaction_action_type type AND
+ void EXFUN ((*procedure), (PTR environment)) AND
+ PTR environment)
+{
+ guarantee_current_transaction ("transaction_record_action");
+ {
+ struct action * action = (dstack_alloc (sizeof (struct action)));
+ (action -> type) = type;
+ (action -> procedure) = procedure;
+ (action -> environment) = environment;
+ dstack_protect (execute_action, action);
+ }
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/ux.c,v 1.1 1990/06/20 19:36:57 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+\f
+void
+DEFUN (UX_prim_check_errno, (name), CONST char * name)
+{
+ if (errno != EINTR)
+ error_system_call (errno, name);
+ deliver_pending_interrupts ();
+}
+
+#ifndef HAVE_TERMIOS
+#ifdef HAVE_TERMIO
+
+int
+DEFUN (UX_tcdrain, (fd), int fd)
+{
+ return (UX_ioctl (fd, TCSBRK, 1));
+}
+
+int
+DEFUN (UX_tcflush, (fd, queue_selector), int fd AND int queue_selector)
+{
+ return (UX_ioctl (fd, TCFLSH, queue_selector));
+}
+
+#else /* not HAVE_TERMIO */
+#ifdef HAVE_BSD_TTY_DRIVER
+
+int
+DEFUN (UX_tcdrain, (fd), int fd)
+{
+ /* BSD provides no such feature -- pretend it worked. */
+ return (0);
+}
+
+int
+DEFUN (UX_tcflush, (fd, queue_selector), int fd AND int queue_selector)
+{
+ /* Losing BSD always flushes input and output together. */
+ int zero = 0;
+ return (UX_ioctl (fd, TIOCFLUSH, (&zero)));
+}
+
+#endif /* HAVE_BSD_TTY_DRIVER */
+#endif /* HAVE_TERMIO */
+#endif /* HAVE_TERMIOS */
+\f
+#ifdef HAVE_TERMIOS
+
+int
+DEFUN (UX_terminal_get_state, (fd, s), int fd AND Ttty_state * s)
+{
+ return (tcgetattr (fd, s));
+}
+
+int
+DEFUN (UX_terminal_set_state, (fd, s), int fd AND Ttty_state * s)
+{
+ return (tcsetattr (fd, TCSANOW, s));
+}
+
+#else /* not HAVE_TERMIOS */
+#ifdef HAVE_TERMIO
+
+int
+DEFUN (UX_terminal_get_state, (fd, s), int fd AND Ttty_state * s)
+{
+ return
+ ((((UX_ioctl (fd, TCGETA, (& (s -> tio)))) < 0)
+#ifdef HAVE_BSD_JOB_CONTROL
+ || ((UX_ioctl (fd, TIOCGLTC, (& (s -> ltc)))) < 0)
+#endif
+ ) ? (-1) : 0);
+}
+
+int
+DEFUN (UX_terminal_set_state, (fd, s), int fd AND Ttty_state * s)
+{
+ return
+ ((((UX_ioctl (fd, TCSETA, (& (s -> tio)))) < 0)
+#ifdef HAVE_BSD_JOB_CONTROL
+ || ((UX_ioctl (fd, TIOCSLTC, (& (s -> ltc)))) < 0)
+#endif
+ ) ? (-1) : 0);
+}
+
+#else /* not HAVE_TERMIO */
+#ifdef HAVE_BSD_TTY_DRIVER
+
+int
+DEFUN (UX_terminal_get_state, (fd, s), int fd AND Ttty_state * s)
+{
+ return
+ ((((UX_ioctl (fd, TIOCGETP, (& (s -> sg)))) < 0)
+ || ((UX_ioctl (fd, TIOCGETC, (& (s -> tc)))) < 0)
+#ifdef HAVE_BSD_JOB_CONTROL
+ || ((UX_ioctl (fd, TIOCGLTC, (& (s -> ltc)))) < 0)
+#endif
+ ) ? (-1) : 0);
+}
+
+int
+DEFUN (UX_terminal_set_state, (fd, s), int fd AND Ttty_state * s)
+{
+ return
+ ((((UX_ioctl (fd, TIOCSETN, (& (s -> sg)))) < 0)
+ || ((UX_ioctl (fd, TIOCSETC, (& (s -> tc)))) < 0)
+#ifdef HAVE_BSD_JOB_CONTROL
+ || ((UX_ioctl (fd, TIOCSLTC, (& (s -> ltc)))) < 0)
+#endif
+ ) ? (-1) : 0);
+}
+
+#endif /* HAVE_BSD_TTY_DRIVER */
+#endif /* HAVE_TERMIO */
+#endif /* HAVE_TERMIOS */
+\f
+#if !defined(_POSIX) && defined(_BSD)
+
+pid_t
+DEFUN_VOID (UX_getpgrp)
+{
+ return (getpgrp (getpid ()));
+}
+
+pid_t
+DEFUN_VOID (UX_setsid)
+{
+#ifdef TIOCNOTTY
+ int fd = (UX_open (BSD_DEV_TTY, O_RDWR, 0));
+ if (fd >= 0)
+ {
+ UX_ioctl (fd, TIOCNOTTY, 0);
+ UX_close (fd);
+ }
+#endif
+ {
+ pid_t pid = (getpid ());
+ return (setpgrp (pid, pid));
+ }
+}
+
+#ifndef _SUNOS
+
+char *
+DEFUN (UX_ctermid, (s), char * s)
+{
+ static char result [] = BSD_DEV_TTY;
+ if (s == 0)
+ return (result);
+ strcpy (s, BSD_DEV_TTY);
+ return (s);
+}
+
+int
+DEFUN (UX_kill, (pid, sig), pid_t pid AND int sig)
+{
+ return ((pid >= 0) ? (kill (pid, sig)) : (killpg ((-pid), sig)));
+}
+
+#endif /* not _SUNOS */
+#endif /* not _POSIX and _BSD */
+
+#ifndef _POSIX
+#ifdef HAVE_BSD_JOB_CONTROL
+
+pid_t
+DEFUN (UX_tcgetpgrp, (fd), int fd)
+{
+ pid_t pgrp_id;
+ int result = (UX_ioctl (fd, TIOCGPGRP, (&pgrp_id)));
+ return ((result < 0) ? result : pgrp_id);
+}
+
+int
+DEFUN (UX_tcsetpgrp, (fd, pgrp_id),
+ int fd AND
+ pid_t pgrp_id)
+{
+ return (UX_ioctl (fd, TIOCSPGRP, (&pgrp_id)));
+}
+
+#else /* not HAVE_BSD_JOB_CONTROL */
+
+pid_t
+DEFUN (UX_tcgetpgrp, (fd), int fd)
+{
+ errno = ENOSYS;
+ return (-1);
+}
+
+int
+DEFUN (UX_tcsetpgrp, (fd, pgrp_id),
+ int fd AND
+ pid_t pgrp_id)
+{
+ errno = ENOSYS;
+ return (-1);
+}
+
+#endif /* HAVE_BSD_JOB_CONTROL */
+#endif /* not _POSIX */
+\f
+#ifdef EMULATE_GETCWD
+char *
+DEFUN (UX_getcwd, (buffer, length),
+ char * buffer AND
+ size_t length)
+{
+ char internal_buffer [MAXPATHLEN + 2];
+ char * collection_buffer;
+ size_t collection_length;
+ if (length <= 0)
+ {
+ errno = EINVAL;
+ return (0);
+ }
+ /* Allocate the buffer if needed. */
+ if (buffer == 0)
+ {
+ buffer = (UX_malloc (length));
+ if (buffer == 0)
+ {
+ errno = ENOMEM;
+ return (0);
+ }
+ }
+ if (length >= (sizeof (internal_buffer)))
+ {
+ collection_buffer = buffer;
+ collection_length = length;
+ }
+ else
+ {
+ collection_buffer = internal_buffer;
+ collection_length = (sizeof (internal_buffer));
+ }
+#ifdef HAVE_GETWD
+ if ((getwd (collection_buffer)) == 0)
+ {
+ errno = EACCES;
+ return (0);
+ }
+#else /* not HAVE_GETWD */
+ {
+ /* Invoke `pwd' and fill the buffer with its output. */
+ FILE * stream = (popen ("pwd", "r"));
+ char * scan_buffer = collection_buffer;
+ if (stream == 0)
+ {
+ errno = EACCES;
+ return (0);
+ }
+ fgets (collection_buffer, collection_length, stream);
+ pclose (stream);
+ while (1)
+ {
+ int c = (*scan_buffer++);
+ if (c == '\0')
+ break;
+ else if (c == '\n')
+ {
+ (*--scan_buffer) = '\0'; /* remove extraneous newline */
+ break;
+ }
+ }
+ }
+#endif /* HAVE_GETWD */
+ if (collection_buffer == internal_buffer)
+ {
+ if (length <= (strlen (internal_buffer)))
+ {
+ errno = ERANGE;
+ return (0);
+ }
+ strcpy (buffer, internal_buffer);
+ }
+ return (buffer);
+}
+#endif /* not EMULATE_GETCWD */
+\f
+#ifdef EMULATE_WAITPID
+int
+DEFUN (UX_waitpid, (pid, stat_loc, options),
+ pid_t pid AND
+ wait_status_t * stat_loc AND
+ int options)
+{
+ if (pid == (-1))
+ return (wait3 (stat_loc, options, 0));
+#ifdef HAVE_WAIT4
+ else if (pid > 0)
+ return (wait4 (pid, stat_loc, options, 0));
+#endif
+ errno = EINVAL;
+ return (-1);
+}
+#endif /* EMULATE_WAITPID */
+
+#ifdef EMULATE_DUP2
+int
+DEFUN (UX_dup2, (fd, fd2), int fd AND int fd2)
+{
+ if (fd != fd2)
+ UX_close (fd2);
+ {
+ int result = (UX_fcntl (fd, F_DUPFD, fd2));
+ if ((result < 0) && (errno == EINVAL))
+ errno = EBADF;
+ return (result);
+ }
+}
+#endif /* EMULATE_DUP2 */
+
+#ifdef EMULATE_RENAME
+int
+DEFUN (UX_rename, (from_name, to_name),
+ CONST char * from_name AND
+ CONST char * to_name)
+{
+ int result;
+ if ((result = (UX_access (from_name, 0))) < 0)
+ return (result);
+ {
+ struct stat fs;
+ struct stat ts;
+ if (((UX_stat (from_name, (&fs))) == 0) &&
+ ((UX_lstat (to_name, (&ts))) == 0))
+ {
+ if (((fs . st_dev) == (ts . st_dev)) &&
+ ((fs . st_ino) == (ts . st_ino)))
+ return (0);
+ UX_unlink (to_name);
+ }
+ }
+ return
+ (((result = (UX_link (from_name, to_name))) < 0)
+ ? result
+ : (UX_unlink (from_name)));
+}
+#endif /* EMULATE_RENAME */
+
+#ifdef EMULATE_MKDIR
+int
+DEFUN (UX_mkdir, (name, mode),
+ CONST char * name AND
+ mode_t mode)
+{
+ return (UX_mknod (name, ((mode & MODE_DIR) | S_IFDIR), ((dev_t) 0)));
+}
+#endif /* EMULATE_MKDIR */
+\f
+#ifdef _POSIX
+
+cc_t
+DEFUN (UX_PC_VDISABLE, (fildes), int fildes)
+{
+ long result = (fpathconf (fildes, _PC_VDISABLE));
+ return
+ ((result < 0) ?
+#ifdef _POSIX_VDISABLE
+ _POSIX_VDISABLE
+#else
+ '\377'
+#endif
+ : result);
+}
+
+#endif /* _POSIX */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/ux.h,v 1.1 1990/06/20 19:37:00 cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Unix system include file */
+
+#ifndef SCM_UX_H
+#define SCM_UX_H
+
+#define SYSTEM_NAME "unix"
+
+#include <sys/types.h>
+#include <sys/times.h>
+#include <sys/file.h>
+#include <sys/stat.h>
+#include <sys/param.h>
+#include <stdio.h>
+#include <signal.h>
+#include <errno.h>
+#include <pwd.h>
+#include <grp.h>
+
+#include "oscond.h"
+#include "ansidecl.h"
+#include "posixtype.h"
+
+extern int errno;
+
+#include "intext.h"
+#include "dstack.h"
+#include "osscheme.h"
+
+extern int parent_process_is_emacs;
+
+extern void EXFUN (error_system_call, (int code, CONST char * name));
+\f
+/* Conditionalizations that are overridden by _POSIX. */
+
+#ifdef _POSIX
+
+#include <limits.h>
+#include <unistd.h>
+#include <time.h>
+#include <termios.h>
+#include <fcntl.h>
+#include <sys/wait.h>
+#include <dirent.h>
+
+#define DECL_GETLOGIN
+#define HAVE_APPEND
+#define HAVE_DIRENT
+#define HAVE_DUP2
+#define HAVE_FCNTL
+#define HAVE_GETCWD
+#define HAVE_MKDIR
+#define HAVE_POSIX_SIGNALS
+#define HAVE_RENAME
+#define HAVE_RMDIR
+#define HAVE_TERMIOS
+#define HAVE_TIMES
+#define HAVE_WAITPID
+#define VOID_SIGNAL_HANDLERS
+
+#else /* not _POSIX */
+#ifdef _BSD
+
+#include <sys/dir.h>
+#include <sgtty.h>
+#include <sys/time.h>
+#include <sys/wait.h>
+
+#define HAVE_APPEND
+#define HAVE_BSD_JOB_CONTROL
+#define HAVE_BSD_SIGNALS
+#define HAVE_BSD_TTY_DRIVER
+#define HAVE_DIR
+#define HAVE_DUP2
+#define HAVE_FCNTL
+#define HAVE_FNDELAY
+#define HAVE_GETWD
+#define HAVE_MKDIR
+#define HAVE_RENAME
+#define HAVE_RMDIR
+#define HAVE_TIMES
+#define HAVE_WAIT3
+/* MORE/BSD has this -- do all 4.3 implementations? */
+/* #define HAVE_WAIT4 */
+#define UNION_WAIT_STATUS
+
+#if defined(_ULTRIX) || defined(_SUNOS4) || defined(sun4)
+#define VOID_SIGNAL_HANDLERS
+#endif
+
+#else /* not _BSD */
+#ifdef _SYSV
+
+#include <time.h>
+#include <termio.h>
+#include <fcntl.h>
+
+#define HAVE_APPEND
+#define HAVE_FCNTL
+#define HAVE_ONDELAY
+#define HAVE_GETCWD
+#define HAVE_TERMIO
+#define HAVE_TIMES
+
+#ifdef _SYSV3
+
+#include <dirent.h>
+
+#define HAVE_DIRENT
+#define HAVE_DUP2
+#define HAVE_MKDIR
+#define HAVE_RMDIR
+#define HAVE_SYSV3_SIGNALS
+#define VOID_SIGNAL_HANDLERS
+
+#else /* not _SYSV3 */
+#ifdef _HPUX
+
+#include <sys/wait.h>
+
+#define HAVE_BSD_SIGNALS
+#define HAVE_DUP2
+#define HAVE_MKDIR
+#define HAVE_RENAME
+#define HAVE_RMDIR
+#define HAVE_WAIT3
+
+#if (_HPUX_VERSION < 65)
+
+#include <ndir.h>
+#define HAVE_DIR
+
+#else /* (_HPUX_VERSION >= 65) */
+
+#include <dirent.h>
+#define HAVE_DIRENT
+#define HAVE_POSIX_SIGNALS
+#define HAVE_WAITPID
+#define VOID_SIGNAL_HANDLERS
+
+#endif /* _HPUX_VERSION */
+
+#if (_HPUX_VERSION >= 65) || defined(hp9000s800)
+#include <bsdtty.h>
+#define HAVE_BSD_JOB_CONTROL
+#endif
+
+#endif /* _HPUX */
+#endif /* _SYSV3 */
+#else /* not _SYSV */
+#ifdef _PIXEL
+
+#include <time.h>
+#include <sgtty.h>
+
+#define HAVE_BSD_TTY_DRIVER
+#define HAVE_DUMB_OPEN
+#define HAVE_DUP2
+#define HAVE_TIMES
+
+#endif /* _PIXEL */
+#endif /* _SYSV */
+#endif /* _BSD */
+#endif /* _POSIX */
+\f
+/* Conditionalizations that are independent of _POSIX. */
+
+#ifdef _BSD
+
+#define SYSTEM_VARIANT "BSD"
+#define HAVE_FIONREAD
+#define HAVE_GETTIMEOFDAY
+#define HAVE_ITIMER
+#define HAVE_PTYS
+#define FIRST_PTY_LETTER 'p'
+#define HAVE_SIGCONTEXT
+#define HAVE_SOCKETS
+#define HAVE_SYMBOLIC_LINKS
+#define HAVE_TRUNCATE
+#define HAVE_UNIX_SOCKETS
+#define HAVE_VFORK
+
+#ifdef _SUNOS
+
+#include <sys/vadvise.h>
+#ifdef _SUNOS3
+#define USE_HOSTENT_ADDR
+#endif
+
+#else /* not _SUNOS */
+
+#ifdef _BSD4_2
+#define USE_HOSTENT_ADDR
+#endif
+
+#endif /* _SUNOS */
+
+#else /* not _BSD */
+#ifdef _HPUX
+
+#include <sys/ptyio.h>
+
+#define SYSTEM_VARIANT "HP-UX"
+#define HAVE_GETTIMEOFDAY
+#define HAVE_ITIMER
+#define HAVE_NICE
+#define HAVE_PTYS
+#define FIRST_PTY_LETTER 'p'
+#define HAVE_SIGCONTEXT
+#define HAVE_SOCKETS
+#define HAVE_SYMBOLIC_LINKS
+#define HAVE_TRUNCATE
+#define HAVE_VFORK
+
+#if (_HPUX_VERSION >= 65)
+/* Is this right for 800-series machines? */
+#define HAVE_UNIX_SOCKETS
+#endif
+
+#if (_HPUX_VERSION >= 70) || defined(hp9000s800)
+#define HAVE_FIONREAD
+#endif
+
+#if (_HPUX_VERSION <= 65)
+#define USE_HOSTENT_ADDR
+#endif
+
+#else /* not _HPUX */
+#ifdef _AIX
+
+#define SYSTEM_VARIANT "AIX"
+#define HAVE_SOCKETS
+#define HAVE_VFORK
+
+#else /* not _AIX */
+#ifdef _SYSV
+
+#define SYSTEM_VARIANT "ATT (V)"
+
+#else /* not _SYSV */
+#ifdef _PIXEL
+
+#define SYSTEM_VARIANT "Pixel"
+
+#define HAVE_FIONREAD
+#define HAVE_NICE
+
+#else /* not _PIXEL */
+
+#define SYSTEM_VARIANT "unknown"
+
+#endif /* _PIXEL */
+#endif /* _SYSV */
+#endif /* _AIX */
+#endif /* _HPUX */
+#endif /* _BSD */
+\f
+#ifdef VOID_SIGNAL_HANDLERS
+typedef void Tsignal_handler_result;
+#define SIGNAL_HANDLER_RETURN() return
+#else
+typedef int Tsignal_handler_result;
+#define SIGNAL_HANDLER_RETURN() return (0)
+#endif
+
+typedef Tsignal_handler_result (*Tsignal_handler) ();
+
+#ifndef SIG_ERR
+#define SIG_ERR ((Tsignal_handler) (-1))
+#endif
+
+#if !defined(SIGCHLD) && defined(SIGCLD)
+#define SIGCHLD SIGCLD
+#endif
+#if !defined(SIGABRT) && defined(SIGIOT)
+#define SIGABRT SIGIOT
+#endif
+
+#ifndef HAVE_SIGCONTEXT
+struct sigcontext { long sc_sp, sc_pc; };
+#define HAVE_SIGCONTEXT
+#endif
+
+/* Crufty, but it will work here. */
+#ifndef ENOSYS
+#define ENOSYS 0
+#endif
+
+#ifdef UNION_WAIT_STATUS
+
+typedef union wait wait_status_t;
+
+#ifndef WEXITSTATUS
+#define WEXITSTATUS(_X) ((_X) . w_retcode)
+#endif
+
+#ifndef WTERMSIG
+#define WTERMSIG(_X) ((_X) . w_termsig)
+#endif
+
+#ifndef WSTOPSIG
+#define WSTOPSIG(_X) ((_X) . w_stopsig)
+#endif
+
+#else /* not UNION_WAIT_STATUS */
+
+typedef int wait_status_t;
+
+#ifndef WIFEXITED
+#define WIFEXITED(_X) (((_X) & 0377) == 0)
+#endif
+
+#ifndef WIFSTOPPED
+#define WIFSTOPPED(_X) (((_X) & 0377) == 0177)
+#endif
+
+#ifndef WIFSIGNALED
+#define WIFSIGNALED(_X) ((((_X) & 0377) != 0) && (((_X) & 0377) != 0177))
+#endif
+
+#ifndef WEXITSTATUS
+#define WEXITSTATUS(_X) (((_X) >> 8) & 0377)
+#endif
+
+#ifndef WTERMSIG
+#define WTERMSIG(_X) ((_X) & 0177)
+#endif
+
+#ifndef WSTOPSIG
+#define WSTOPSIG(_X) (((_X) >> 8) & 0377)
+#endif
+
+#endif /* UNION_WAIT_STATUS */
+\f
+/* constants for access() */
+#ifndef R_OK
+#define R_OK 4
+#define W_OK 2
+#define X_OK 1
+#define F_OK 0
+#endif
+
+#ifndef MAXPATHLEN
+#define MAXPATHLEN 1024
+#endif
+
+#ifdef __STDC__
+#define ALERT_CHAR '\a'
+#define ALERT_STRING "\a"
+#else
+#define ALERT_CHAR '\007'
+#define ALERT_STRING "\007"
+#endif
+
+#ifndef STDIN_FILENO
+#define STDIN_FILENO 0
+#define STDOUT_FILENO 1
+#define STDERR_FILENO 2
+#endif
+
+/* constants for open() and fcntl() */
+#ifndef O_RDONLY
+#define O_RDONLY 0
+#define O_WRONLY 1
+#define O_RDWR 2
+#endif
+
+/* mode bit definitions for open(), creat(), and chmod() */
+#ifndef S_IRWXU
+#define S_IRWXU 0700
+#define S_IRWXG 0070
+#define S_IRWXO 0007
+#endif
+
+#ifndef S_IRUSR
+#define S_IRUSR 0400
+#define S_IWUSR 0200
+#define S_IXUSR 0100
+#define S_IRGRP 0040
+#define S_IWGRP 0020
+#define S_IXGRP 0010
+#define S_IROTH 0004
+#define S_IWOTH 0002
+#define S_IXOTH 0001
+#endif
+
+#define MODE_REG (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
+#define MODE_DIR (MODE_REG | S_IXUSR | S_IXGRP | S_IXOTH)
+
+/* constants for lseek() */
+#ifndef SEEK_SET
+#define SEEK_SET 0
+#define SEEK_CUR 1
+#define SEEK_END 2
+#endif
+\f
+#ifndef DECL_GETLOGIN
+extern char * EXFUN (getlogin, (void));
+#endif
+
+#define UX_abort abort
+#define UX_access access
+#define UX_alarm alarm
+#define UX_chdir chdir
+#define UX_chmod chmod
+#define UX_close close
+#define UX_ctime ctime
+#define UX_fstat fstat
+#define UX_getenv getenv
+#define UX_getegid getegid
+#define UX_geteuid geteuid
+#define UX_getgrgid getgrgid
+#define UX_getlogin getlogin
+#define UX_getpid getpid
+#define UX_getpwnam getpwnam
+#define UX_getpwuid getpwuid
+#define UX_ioctl ioctl
+#define UX_link link
+#define UX_localtime localtime
+#define UX_lseek lseek
+#define UX_malloc malloc
+#define UX_mknod mknod
+#define UX_pipe pipe
+#define UX_read read
+#define UX_realloc realloc
+#define UX_signal signal
+#define UX_stat stat
+#define UX_system system
+#define UX_time time
+#define UX_unlink unlink
+#define UX_write write
+#define UX_wait wait
+
+extern PTR EXFUN (malloc, (unsigned int size));
+extern PTR EXFUN (realloc, (PTR ptr, unsigned int size));
+extern CONST char * EXFUN (getenv, (CONST char * name));
+
+#ifdef HAVE_FCNTL
+#define UX_fcntl fcntl
+#endif
+
+#ifdef HAVE_TRUNCATE
+#define UX_ftruncate ftruncate
+#define UX_truncate truncate
+#endif
+
+#ifdef HAVE_VFORK
+#define UX_vfork vfork
+#else
+#define UX_vfork fork
+#endif
+
+#ifdef HAVE_SYMBOLIC_LINKS
+#define UX_lstat lstat
+#define UX_readlink readlink
+#define UX_symlink symlink
+#else
+#define UX_lstat stat
+#endif
+
+extern void EXFUN (UX_prim_check_errno, (CONST char * name));
+
+#define STD_VOID_SYSTEM_CALL(name, expression) \
+{ \
+ while ((expression) < 0) \
+ if (errno != EINTR) \
+ error_system_call (errno, (name)); \
+}
+
+#define STD_UINT_SYSTEM_CALL(name, result, expression) \
+{ \
+ while (((result) = (expression)) < 0) \
+ if (errno != EINTR) \
+ error_system_call (errno, name); \
+}
+
+#define STD_PTR_SYSTEM_CALL(name, result, expression) \
+{ \
+ while (((result) = (expression)) == 0) \
+ if (errno != EINTR) \
+ error_system_call (errno, name); \
+}
+\f
+#ifdef HAVE_TERMIOS
+
+typedef struct termios Ttty_state;
+#define UX_tcflush tcflush
+#define UX_tcdrain tcdrain
+#define UX_tcgetattr tcgetattr
+#define UX_tcsetattr tcsetattr
+
+#else /* not HAVE_TERMIOS */
+
+extern int EXFUN (UX_tcdrain, (int fd));
+extern int EXFUN (UX_tcflush, (int fd, int queue_selector));
+/* These values chosen to match the ioctl TCFLSH argument for termio. */
+#define TCIFLUSH 0
+#define TCOFLUSH 1
+#define TCIOFLUSH 2
+
+#ifdef HAVE_TERMIO
+
+typedef struct
+{
+ struct termio tio;
+#ifdef HAVE_BSD_JOB_CONTROL
+ struct ltchars ltc;
+#endif
+} Ttty_state;
+
+#else /* not HAVE_TERMIO */
+#ifdef HAVE_BSD_TTY_DRIVER
+
+typedef struct
+{
+ struct sgttyb sg;
+ struct tchars tc;
+#ifdef HAVE_BSD_JOB_CONTROL
+ struct ltchars ltc;
+#endif
+} Ttty_state;
+
+#endif /* HAVE_BSD_TTY_DRIVER */
+#endif /* HAVE_TERMIO */
+#endif /* HAVE_TERMIOS */
+
+extern int EXFUN (UX_terminal_get_state, (int fd, Ttty_state * s));
+extern int EXFUN (UX_terminal_set_state, (int fd, Ttty_state * s));
+\f
+#ifdef _POSIX
+#define UX_getpgrp getpgrp
+#define UX_setsid setsid
+#else
+#ifdef _SYSV
+#define UX_getpgrp getpgrp
+#define UX_setsid setpgrp
+#else /* not _SYSV */
+extern pid_t EXFUN (UX_getpgrp, (void));
+extern pid_t EXFUN (UX_setsid, (void));
+#endif /* _SYSV */
+#endif /* _POSIX */
+
+#ifdef _POSIX
+
+#define UX_setpgid setpgid
+#define UX_tcgetpgrp tcgetpgrp
+#define UX_tcsetpgrp tcsetpgrp
+
+#else /* not _POSIX */
+
+extern pid_t EXFUN (UX_tcgetpgrp, (int fd));
+extern int EXFUN (UX_tcsetpgrp, (int fd, pid_t pgrp_id));
+
+#ifdef HAVE_BSD_JOB_CONTROL
+
+#ifdef _SYSV
+#define UX_setpgid setpgrp2
+#else
+#define UX_setpgid setpgrp
+#endif
+
+#endif /* HAVE_BSD_JOB_CONTROL */
+#endif /* _POSIX */
+\f
+#ifdef HAVE_GETTIMEOFDAY
+#define UX_gettimeofday gettimeofday
+#endif
+#ifdef HAVE_ITIMER
+#define UX_setitimer setitimer
+#endif
+#ifdef HAVE_RMDIR
+#define UX_rmdir rmdir
+#endif
+#ifdef HAVE_TIMES
+#define UX_times times
+#endif
+#ifdef HAVE_SOCKETS
+#define UX_connect connect
+#define UX_gethostbyname gethostbyname
+#define UX_getservbyname getservbyname
+#define UX_socket socket
+#endif
+
+#ifdef HAVE_DUMB_OPEN
+extern int EXFUN (UX_open, (CONST char * name, int oflag, mode_t mode));
+#else
+#define UX_open open
+#endif
+
+#ifdef HAVE_DUP2
+#define UX_dup2 dup2
+#else
+#ifdef HAVE_FCNTL
+#define EMULATE_DUP2
+#define HAVE_DUP2
+extern int EXFUN (UX_dup2, (int fd, int fd2));
+#endif
+#endif
+
+#ifdef HAVE_GETCWD
+#define UX_getcwd getcwd
+#else
+#define EMULATE_GETCWD
+#define HAVE_GETCWD
+extern char * EXFUN (UX_getcwd, (char * buffer, size_t length));
+#endif
+
+#ifdef HAVE_MKDIR
+#define UX_mkdir mkdir
+#else
+#define EMULATE_MKDIR
+#define HAVE_MKDIR
+extern int EXFUN (UX_mkdir, (CONST char * name, mode_t mode));
+#endif
+
+#ifdef HAVE_RENAME
+#define UX_rename rename
+#else
+#define EMULATE_RENAME
+#define HAVE_RENAME
+extern int EXFUN (UX_rename, (CONST char * from_name, CONST char * to_name));
+#endif
+
+#ifdef HAVE_WAITPID
+#define UX_waitpid waitpid
+#else /* not HAVE_WAITPID */
+#ifdef HAVE_WAIT3
+#define EMULATE_WAITPID
+#define HAVE_WAITPID
+extern int EXFUN
+ (UX_waitpid, (pid_t pid, wait_status_t * stat_loc, int options));
+#endif /* HAVE_WAIT3 */
+#endif /* HAVE_WAITPID */
+
+#ifndef WUNTRACED
+#define WUNTRACED 0
+#endif
+\f
+#ifdef _BSD
+#define BSD_DEV_TTY "/dev/tty"
+#endif
+
+#if !defined(_POSIX) && defined(_BSD) && !defined(_SUNOS)
+
+#define L_ctermid ((strlen (BSD_DEV_TTY)) + 1);
+extern char * EXFUN (UX_ctermid, (char * s));
+extern int EXFUN (UX_kill, (pid_t pid, int sig));
+
+#else
+
+#define UX_ctermid ctermid
+#define UX_kill kill
+
+#endif
+
+#ifdef HAVE_POSIX_SIGNALS
+
+#define UX_sigemptyset sigemptyset
+#define UX_sigfillset sigfillset
+#define UX_sigaddset sigaddset
+#define UX_sigdelset sigdelset
+#define UX_sigismember sigismember
+#define UX_sigaction sigaction
+#define UX_sigsuspend sigsuspend
+#define UX_sigprocmask sigprocmask
+
+#else /* not HAVE_POSIX_SIGNALS */
+#ifdef HAVE_BSD_SIGNALS
+
+#ifdef _HPUX
+#define UX_sigvec sigvector
+#else
+#define UX_sigvec sigvec
+#endif
+#define UX_sigblock sigblock
+#define UX_sigsetmask sigsetmask
+#define UX_sigpause sigpause
+
+#else /* not HAVE_BSD_SIGNALS */
+#ifdef HAVE_SYSV3_SIGNALS
+
+#define UX_sigset sigset
+#define UX_sighold sighold
+#define UX_sigrelse sigrelse
+
+#endif /* HAVE_SYSV3_SIGNALS */
+#endif /* HAVE_BSD_SIGNALS */
+#endif /* HAVE_POSIX_SIGNALS */
+\f
+#ifdef _POSIX
+
+extern cc_t EXFUN (UX_PC_VDISABLE, (int fildes));
+#define UX_SC_OPEN_MAX() ((size_t) (sysconf (_SC_OPEN_MAX)))
+#define UX_SC_CHILD_MAX() ((size_t) (sysconf (_SC_CHILD_MAX)))
+#define UX_SC_CLK_TCK() ((clock_t) (sysconf (_SC_CLK_TCK)))
+
+#ifdef _POSIX_JOB_CONTROL
+#define UX_SC_JOB_CONTROL() 1
+#else
+#define UX_SC_JOB_CONTROL() ((sysconf (_SC_JOB_CONTROL)) >= 0)
+#endif
+
+#else /* not _POSIX */
+
+#define UX_PC_VDISABLE(fildes) '\377'
+
+#ifdef OPEN_MAX
+#define UX_SC_OPEN_MAX() OPEN_MAX
+#else
+#ifdef _NFILE
+#define UX_SC_OPEN_MAX() _NFILE
+#else
+#define UX_SC_OPEN_MAX() 16
+#endif
+#endif
+
+#ifdef CHILD_MAX
+#define UX_SC_CHILD_MAX() CHILD_MAX
+#else
+#define UX_SC_CHILD_MAX() 6
+#endif
+
+#ifdef CLK_TCK
+#define UX_SC_CLK_TCK() CLK_TCK
+#else
+#ifdef HZ
+#define UX_SC_CLK_TCK() HZ
+#else
+#define UX_SC_CLK_TCK() 60
+#endif
+#endif
+
+#ifdef HAVE_BSD_JOB_CONTROL
+#define UX_SC_JOB_CONTROL() 1
+#else
+#define UX_SC_JOB_CONTROL() 0
+#endif
+
+#endif /* _POSIX */
+
+#endif /* SCM_UX_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxctty.c,v 1.1 1990/06/20 19:37:03 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+#include "osctty.h"
+
+/* If `ctty_fildes' is nonnegative, it is an open file descriptor for
+ the controlling terminal of the process.
+
+ If `ctty_fildes' is negative, Scheme should not alter the control
+ terminal's settings. */
+static int ctty_fildes;
+
+/* If `ctty_fildes' is nonnegative, this flag says whether Scheme was
+ in the foreground when it was last entered. Provided that no other
+ process forces Scheme out of the foreground, it will remain in the
+ foreground until it exits or is stopped.
+
+ If `ctty_foreground' is zero, Scheme should not alter the control
+ terminal's settings. */
+static int ctty_foreground;
+
+/* This flag, set during initialization, says whether we are
+ permitted to change the settings of the control terminal. */
+static int permit_ctty_control;
+
+/* Original states of the control terminal when Scheme was last
+ continued or stopped, respectively. If the corresponding
+ `_recorded' flag is zero, then no information is saved. */
+static int outside_ctty_state_recorded;
+static Ttty_state outside_ctty_state;
+static int inside_ctty_state_recorded;
+static Ttty_state inside_ctty_state;
+
+static void EXFUN (ctty_update_interrupt_chars, (void));
+\f
+void
+DEFUN_VOID (UX_ctty_save_external_state)
+{
+ if (permit_ctty_control && (ctty_fildes >= 0))
+ {
+ pid_t pgrp_id = (UX_tcgetpgrp (ctty_fildes));
+ ctty_foreground =
+ ((pgrp_id < 0)
+ /* If no job control, assume we're in foreground. */
+ ? (errno == ENOSYS)
+ : ((UX_getpgrp ()) == pgrp_id));
+ }
+ else
+ ctty_foreground = 0;
+ outside_ctty_state_recorded =
+ (ctty_foreground &&
+ ((UX_terminal_get_state (ctty_fildes, (&outside_ctty_state))) >= 0));
+}
+
+void
+DEFUN_VOID (UX_ctty_restore_internal_state)
+{
+ if (inside_ctty_state_recorded)
+ {
+ if (outside_ctty_state_recorded)
+ {
+ UX_terminal_set_state (ctty_fildes, (&inside_ctty_state));
+ ctty_update_interrupt_chars ();
+ }
+ inside_ctty_state_recorded = 0;
+ }
+}
+
+void
+DEFUN_VOID (UX_ctty_save_internal_state)
+{
+ inside_ctty_state_recorded =
+ (outside_ctty_state_recorded
+ ? ((UX_terminal_get_state (ctty_fildes, (&inside_ctty_state))) >= 0)
+ /* If outside state not recorded, we haven't changed anything, so
+ there's no need to save the inside state. */
+ : 0);
+}
+
+void
+DEFUN_VOID (UX_ctty_restore_external_state)
+{
+ if (outside_ctty_state_recorded)
+ {
+ UX_terminal_set_state (ctty_fildes, (&outside_ctty_state));
+ outside_ctty_state_recorded = 0;
+ }
+}
+
+int
+DEFUN_VOID (OS_ctty_interrupt_control)
+{
+ return (outside_ctty_state_recorded);
+}
+\f
+/* Keyboard Interrupt Characters */
+
+typedef struct
+{
+ cc_t quit;
+ cc_t intrpt;
+ cc_t tstp;
+} Tinterrupt_chars;
+
+static Tinterrupt_enables current_interrupt_enables;
+static Tinterrupt_chars current_interrupt_chars;
+
+#define DEFAULT_SIGQUIT_CHAR ((cc_t) '\003') /* ^C */
+#define DEFAULT_SIGINT_CHAR ((cc_t) '\007') /* ^G */
+#define DEFAULT_SIGTSTP_CHAR ((cc_t) '\032') /* ^Z */
+
+#define KEYBOARD_QUIT_INTERRUPT 0x1
+#define KEYBOARD_INTRPT_INTERRUPT 0x2
+#define KEYBOARD_TSTP_INTERRUPT 0x4
+#define KEYBOARD_ALL_INTERRUPTS 0x7
+
+cc_t
+DEFUN_VOID (OS_ctty_quit_char)
+{
+ return (current_interrupt_chars . quit);
+}
+
+cc_t
+DEFUN_VOID (OS_ctty_int_char)
+{
+ return (current_interrupt_chars . intrpt);
+}
+
+cc_t
+DEFUN_VOID (OS_ctty_tstp_char)
+{
+ return (current_interrupt_chars . tstp);
+}
+
+cc_t
+DEFUN_VOID (OS_ctty_disabled_char)
+{
+ return ((ctty_fildes >= 0) ? (UX_PC_VDISABLE (ctty_fildes)) : '\377');
+}
+\f
+#if 0
+/* not currently used */
+static void
+DEFUN (ctty_get_interrupt_chars, (ic), Tinterrupt_chars * ic)
+{
+ Ttty_state s;
+ if ((UX_terminal_get_state (ctty_fildes, (&s))) == 0)
+ {
+#ifdef HAVE_TERMIOS
+ (ic -> quit) = ((s . c_cc) [VQUIT]);
+ (ic -> intrpt) = ((s . c_cc) [VINTR]);
+ (ic -> tstp) = ((s . c_cc) [VSUSP]);
+#else /* not HAVE_TERMIOS */
+#ifdef HAVE_TERMIO
+ (ic -> quit) = ((s . tio . c_cc) [VQUIT]);
+ (ic -> intrpt) = ((s . tio . c_cc) [VINTR]);
+#ifdef HAVE_BSD_JOB_CONTROL
+ (ic -> tstp) = ((s . ltc . c_cc) [VSUSP]);
+#else
+ (ic -> tstp) = (UX_PC_VDISABLE (ctty_fildes));
+#endif
+#else /* not HAVE_TERMIO */
+#ifdef HAVE_BSD_TTY_DRIVER
+ (ic -> quit) = (s . tc . t_quitc);
+ (ic -> intrpt) = (s . tc . t_intrc);
+#ifdef HAVE_BSD_JOB_CONTROL
+ (ic -> tstp) = (s . ltc . t_suspc);
+#else
+ (ic -> tstp) = (UX_PC_VDISABLE (ctty_fildes));
+#endif
+#endif /* HAVE_BSD_TTY_DRIVER */
+#endif /* HAVE_TERMIO */
+#endif /* HAVE_TERMIOS */
+ }
+ else
+ {
+ cc_t disabled_char = (UX_PC_VDISABLE (ctty_fildes));
+ (ic -> quit) = disabled_char;
+ (ic -> intrpt) = disabled_char;
+ (ic -> tstp) = disabled_char;
+ }
+}
+#endif /* 0 */
+
+static void
+DEFUN (ctty_set_interrupt_chars, (ic), Tinterrupt_chars * ic)
+{
+ Ttty_state s;
+ if ((UX_terminal_get_state (ctty_fildes, (&s))) == 0)
+ {
+#ifdef HAVE_TERMIOS
+ ((s . c_cc) [VQUIT]) = (ic -> quit);
+ ((s . c_cc) [VINTR]) = (ic -> intrpt);
+ ((s . c_cc) [VSUSP]) = (ic -> tstp);
+#else /* not HAVE_TERMIOS */
+#ifdef HAVE_TERMIO
+ ((s . tio . c_cc) [VQUIT]) = (ic -> quit);
+ ((s . tio . c_cc) [VINTR]) = (ic -> intrpt);
+#ifdef HAVE_BSD_JOB_CONTROL
+ (s . ltc . t_suspc) = (ic -> tstp);
+#endif
+#else /* not HAVE_TERMIO */
+#ifdef HAVE_BSD_TTY_DRIVER
+ (s . tc . t_quitc) = (ic -> quit);
+ (s . tc . t_intrc) = (ic -> intrpt);
+#ifdef HAVE_BSD_JOB_CONTROL
+ (s . ltc . t_suspc) = (ic -> tstp);
+#endif
+#endif /* HAVE_BSD_TTY_DRIVER */
+#endif /* HAVE_TERMIO */
+#endif /* HAVE_TERMIOS */
+ UX_terminal_set_state (ctty_fildes, (&s));
+ }
+}
+\f
+static void
+DEFUN_VOID (ctty_update_interrupt_chars)
+{
+ if (outside_ctty_state_recorded)
+ {
+ cc_t disabled_char = (UX_PC_VDISABLE (ctty_fildes));
+ /* Must split declaration and assignment because some compilers
+ do not permit aggregate initializers. */
+ Tinterrupt_chars active_interrupt_chars;
+ active_interrupt_chars = current_interrupt_chars;
+ if ((current_interrupt_enables & KEYBOARD_QUIT_INTERRUPT) == 0)
+ (active_interrupt_chars . quit) = disabled_char;
+ if ((current_interrupt_enables & KEYBOARD_INTRPT_INTERRUPT) == 0)
+ (active_interrupt_chars . intrpt) = disabled_char;
+ if ((current_interrupt_enables & KEYBOARD_TSTP_INTERRUPT) == 0)
+ (active_interrupt_chars . tstp) = disabled_char;
+ ctty_set_interrupt_chars (&active_interrupt_chars);
+ }
+}
+
+void
+DEFUN (OS_ctty_get_interrupt_enables, (mask), Tinterrupt_enables * mask)
+{
+ (*mask) = current_interrupt_enables;
+}
+
+void
+DEFUN (OS_ctty_set_interrupt_enables, (mask), Tinterrupt_enables * mask)
+{
+ current_interrupt_enables = (*mask);
+ ctty_update_interrupt_chars ();
+}
+
+void
+DEFUN (OS_ctty_set_interrupt_chars, (quit_char, int_char, tstp_char),
+ cc_t quit_char AND
+ cc_t int_char AND
+ cc_t tstp_char)
+{
+ (current_interrupt_chars . quit) = quit_char;
+ (current_interrupt_chars . intrpt) = int_char;
+ (current_interrupt_chars . tstp) = tstp_char;
+ ctty_update_interrupt_chars ();
+}
+\f
+void
+DEFUN (UX_initialize_ctty, (interactive), int interactive)
+{
+ {
+ char * tty = (UX_ctermid (0));
+ ctty_fildes =
+ (((tty == 0) || ((tty[0]) == 0))
+ ? (-1)
+ : (UX_open (tty, O_RDWR, 0)));
+ }
+ permit_ctty_control = interactive;
+ UX_ctty_save_external_state ();
+ (current_interrupt_chars . quit) = DEFAULT_SIGQUIT_CHAR;
+ (current_interrupt_chars . intrpt) = DEFAULT_SIGINT_CHAR;
+ (current_interrupt_chars . tstp) = DEFAULT_SIGTSTP_CHAR;
+ current_interrupt_enables = KEYBOARD_ALL_INTERRUPTS;
+ if (outside_ctty_state_recorded)
+ ctty_set_interrupt_chars (¤t_interrupt_chars);
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxenv.c,v 1.1 1990/06/20 19:37:06 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+#include "osenv.h"
+\f
+void
+DEFUN (OS_current_time, (buffer), struct time_structure * buffer)
+{
+ time_t t;
+ struct tm * ts;
+ STD_UINT_SYSTEM_CALL ("time", t, (UX_time (0)));
+ STD_PTR_SYSTEM_CALL ("localtime", ts, (UX_localtime (&t)));
+ (buffer -> year) = ((ts -> tm_year) + 1900);
+ (buffer -> month) = ((ts -> tm_mon) + 1);
+ (buffer -> day) = (ts -> tm_mday);
+ (buffer -> hour) = (ts -> tm_hour);
+ (buffer -> minute) = (ts -> tm_min);
+ (buffer -> second) = (ts -> tm_sec);
+ {
+ /* In localtime() encoding, 0 is Sunday; in ours, it's Monday. */
+ int wday = (ts -> tm_wday);
+ (buffer -> day_of_week) = ((wday == 0) ? 6 : (wday - 1));
+ }
+}
+
+#ifdef HAVE_TIMES
+
+static clock_t initial_process_clock;
+
+static void
+DEFUN_VOID (initialize_process_clock)
+{
+ struct tms buffer;
+ UX_times (&buffer);
+ initial_process_clock = (buffer . tms_utime);
+}
+
+clock_t
+DEFUN_VOID (OS_process_clock)
+{
+ clock_t ct = (UX_SC_CLK_TCK ());
+ struct tms buffer;
+ STD_VOID_SYSTEM_CALL ("times", (UX_times (&buffer)));
+ return
+ (((((buffer . tms_utime) - initial_process_clock) * 2000) + ct) /
+ (2 * ct));
+}
+
+#else /* not HAVE_TIMES */
+
+static void
+DEFUN_VOID (initialize_process_clock)
+{
+}
+
+clock_t
+DEFUN_VOID (OS_process_clock)
+{
+ /* This must not signal an error in normal use. */
+ return (0);
+}
+
+#endif /* HAVE_TIMES */
+\f
+#ifdef HAVE_GETTIMEOFDAY
+
+static struct timeval initial_rtc;
+
+static void
+DEFUN_VOID (initialize_real_time_clock)
+{
+ struct timezone tz;
+ UX_gettimeofday ((&initial_rtc), (&tz));
+}
+
+clock_t
+DEFUN_VOID (OS_real_time_clock)
+{
+ struct timeval rtc;
+ struct timezone tz;
+ STD_VOID_SYSTEM_CALL ("gettimeofday", (UX_gettimeofday ((&rtc), (&tz))));
+ return
+ ((((rtc . tv_sec) - (initial_rtc . tv_sec)) * 1000) +
+ ((((rtc . tv_usec) - (initial_rtc . tv_usec)) + 500) / 1000));
+}
+
+#else /* not HAVE_GETTIMEOFDAY */
+#ifdef HAVE_TIMES
+
+static clock_t initial_rtc;
+
+static void
+DEFUN_VOID (initialize_real_time_clock)
+{
+ struct tms buffer;
+ initial_rtc = (UX_times (&buffer));
+}
+
+clock_t
+DEFUN_VOID (OS_real_time_clock)
+{
+ clock_t ct = (UX_SC_CLK_TCK ());
+ struct tms buffer;
+ clock_t t;
+ STD_UINT_SYSTEM_CALL ("times", t, (UX_times (&buffer)));
+ return ((((t - initial_rtc) * 2000) + ct) / (2 * ct));
+}
+
+#else /* not HAVE_TIMES */
+
+static time_t initial_rtc;
+
+static void
+DEFUN_VOID (initialize_real_time_clock)
+{
+ initial_rtc = (time (0));
+}
+
+clock_t
+DEFUN_VOID (OS_real_time_clock)
+{
+ time_t t;
+ STD_UINT_SYSTEM_CALL ("time", t, (UX_time (0)));
+ return ((t - initial_rtc) * 1000);
+}
+
+#endif /* HAVE_TIMES */
+#endif /* HAVE_GETTIMEOFDAY */
+\f
+#ifdef HAVE_ITIMER
+
+static void
+DEFUN (set_timer, (which, first, interval),
+ int which AND
+ clock_t first AND
+ clock_t interval)
+{
+ struct itimerval value;
+ struct itimerval ovalue;
+ (value . it_value . tv_sec) = (first / 1000);
+ (value . it_value . tv_usec) = ((first % 1000) * 1000);
+ (value . it_interval . tv_sec) = (interval / 1000);
+ (value . it_interval . tv_usec) = ((interval % 1000) * 1000);
+ STD_VOID_SYSTEM_CALL
+ ("setitimer", (UX_setitimer (which, (&value), (&ovalue))));
+}
+
+void
+DEFUN (OS_process_timer_set, (first, interval),
+ clock_t first AND
+ clock_t interval)
+{
+ set_timer (ITIMER_VIRTUAL, first, interval);
+}
+
+void
+DEFUN_VOID (OS_process_timer_clear)
+{
+ set_timer (ITIMER_VIRTUAL, 0, 0);
+}
+
+void
+DEFUN (OS_real_timer_set, (first, interval),
+ clock_t first AND
+ clock_t interval)
+{
+ set_timer (ITIMER_REAL, first, interval);
+}
+
+void
+DEFUN_VOID (OS_real_timer_clear)
+{
+ set_timer (ITIMER_REAL, 0, 0);
+}
+
+#else /* not HAVE_ITIMER */
+\f
+static unsigned int alarm_interval;
+
+void
+DEFUN_VOID (reschedule_alarm)
+{
+ UX_alarm (alarm_interval);
+}
+
+void
+DEFUN (OS_process_timer_set, (first, interval),
+ clock_t first AND
+ clock_t interval)
+{
+ error_unimplemented_primitive ();
+}
+
+void
+DEFUN_VOID (OS_process_timer_clear)
+{
+ error_unimplemented_primitive ();
+}
+
+void
+DEFUN (OS_real_timer_set, (first, interval),
+ clock_t first AND
+ clock_t interval)
+{
+ alarm_interval = ((interval + 999) / 1000);
+ UX_alarm ((first + 999) / 1000);
+}
+
+void
+DEFUN_VOID (OS_real_timer_clear)
+{
+ alarm_interval = 0;
+ UX_alarm (0);
+}
+
+#endif /* HAVE_ITIMER */
+
+void
+DEFUN_VOID (UX_initialize_environment)
+{
+ initialize_process_clock ();
+ initialize_real_time_clock ();
+#ifndef HAVE_ITIMER
+ alarm_interval = 0;
+#endif
+}
+\f
+CONST char *
+DEFUN_VOID (OS_working_dir_pathname)
+{
+ static size_t path_size = 0;
+ static char * path;
+ if (path_size == 0)
+ {
+ path = (UX_malloc (1024));
+ if (path == 0)
+ error_system_call (ENOMEM, "malloc");
+ path_size = 1024;
+ }
+ while (1)
+ {
+ if ((UX_getcwd (path, path_size)) != 0)
+ return (path);
+ if (errno != ERANGE)
+ error_system_call (errno, "getcwd");
+ path_size *= 2;
+ {
+ char * new_path = (UX_realloc (path, path_size));
+ if (new_path == 0)
+ /* ANSI C requires `path' to be unchanged -- we may have to
+ discard it for systems that don't behave thus. */
+ error_system_call (ENOMEM, "realloc");
+ path = new_path;
+ }
+ }
+}
+
+void
+DEFUN (OS_set_working_dir_pathname, (name), CONST char * name)
+{
+ STD_VOID_SYSTEM_CALL ("chdir", (UX_chdir (name)));
+}
+
+CONST char *
+DEFUN (OS_get_environment_variable, (name), CONST char * name)
+{
+ return (UX_getenv (name));
+}
+
+CONST char *
+DEFUN_VOID (OS_current_user_name)
+{
+ {
+ CONST char * result = (UX_getlogin ());
+ if (result != 0)
+ return (result);
+ }
+ {
+ struct passwd * entry = (UX_getpwuid (UX_geteuid ()));
+ if (entry != 0)
+ return (entry -> pw_name);
+ }
+ error_external_return ();
+ return (0);
+}
+
+CONST char *
+DEFUN_VOID (OS_current_user_home_directory)
+{
+ {
+ char * user_name = (UX_getlogin ());
+ if (user_name != 0)
+ {
+ struct passwd * entry = (UX_getpwnam (user_name));
+ if (entry != 0)
+ return (entry -> pw_dir);
+ }
+ }
+ {
+ struct passwd * entry = (UX_getpwuid (UX_geteuid ()));
+ if (entry != 0)
+ return (entry -> pw_dir);
+ }
+ error_external_return ();
+ return (0);
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxfile.c,v 1.1 1990/06/20 19:37:09 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+#include "osfile.h"
+#include "uxio.h"
+
+extern void EXFUN (terminal_open, (Tchannel channel));
+\f
+static enum channel_type
+DEFUN (fd_channel_type, (fd), int fd)
+{
+ struct stat stat_buf;
+ STD_VOID_SYSTEM_CALL ("fstat", (UX_fstat (fd, (&stat_buf))));
+ {
+ mode_t type = ((stat_buf . st_mode) & S_IFMT);
+ return
+ ((type == S_IFREG) ? channel_type_file
+ : ((type == S_IFCHR) && (isatty (fd))) ? channel_type_terminal
+#ifdef S_IFIFO
+ : (type == S_IFIFO) ? channel_type_fifo
+#endif
+ : channel_type_unknown);
+ }
+}
+
+Tchannel
+DEFUN (OS_open_fd, (fd), int fd)
+{
+ enum channel_type type = (fd_channel_type (fd));
+ Tchannel channel;
+ MAKE_CHANNEL (fd, type, channel =);
+ if (type == channel_type_terminal)
+ terminal_open (channel);
+ return (channel);
+}
+
+static Tchannel
+DEFUN (open_file, (filename, oflag), CONST char * filename AND int oflag)
+{
+ int fd;
+ STD_UINT_SYSTEM_CALL ("open", fd, (UX_open (filename, oflag, MODE_REG)));
+ return (OS_open_fd (fd));
+}
+
+#define DEFUN_OPEN_FILE(name, oflag) \
+Tchannel \
+DEFUN (name, (filename), CONST char * filename) \
+{ \
+ return (open_file (filename, oflag)); \
+}
+
+DEFUN_OPEN_FILE (OS_open_input_file, O_RDONLY)
+DEFUN_OPEN_FILE (OS_open_output_file, (O_WRONLY | O_CREAT | O_TRUNC))
+DEFUN_OPEN_FILE (OS_open_io_file, (O_RDWR | O_CREAT))
+
+#ifdef HAVE_APPEND
+
+DEFUN_OPEN_FILE (OS_open_append_file, (O_WRONLY | O_CREAT | O_APPEND))
+
+#else
+
+Tchannel
+DEFUN (OS_open_append_file, (filename), CONST char * filename)
+{
+ error_unimplemented_primitive ();
+ return (0);
+}
+
+#endif
+\f
+Tchannel
+DEFUN (OS_open_load_file, (filename), CONST char * filename)
+{
+ while (1)
+ {
+ int fd = (UX_open (filename, O_RDONLY, MODE_REG));
+ if (fd >= 0)
+ MAKE_CHANNEL (fd, channel_type_file, return);
+ if (errno != EINTR)
+ return (NO_CHANNEL);
+ }
+}
+
+Tchannel
+DEFUN (OS_open_dump_file, (filename), CONST char * filename)
+{
+ OS_file_remove_link (filename);
+ while (1)
+ {
+ int fd = (UX_open (filename, (O_WRONLY | O_CREAT | O_TRUNC), MODE_REG));
+ if (fd >= 0)
+ MAKE_CHANNEL (fd, channel_type_file, return);
+ if (errno != EINTR)
+ return (NO_CHANNEL);
+ }
+}
+
+off_t
+DEFUN (OS_file_length, (channel), Tchannel channel)
+{
+ struct stat stat_buf;
+ STD_VOID_SYSTEM_CALL
+ ("fstat", (UX_fstat ((CHANNEL_DESCRIPTOR (channel)), (&stat_buf))));
+ return (stat_buf . st_size);
+}
+
+off_t
+DEFUN (OS_file_position, (channel), Tchannel channel)
+{
+ off_t result;
+ STD_UINT_SYSTEM_CALL
+ ("lseek",
+ result,
+ (UX_lseek ((CHANNEL_DESCRIPTOR (channel)), 0L, SEEK_CUR)));
+ return (result);
+}
+
+void
+DEFUN (OS_file_set_position, (channel, position),
+ Tchannel channel AND
+ off_t position)
+{
+ off_t result;
+ STD_UINT_SYSTEM_CALL
+ ("lseek",
+ result,
+ (UX_lseek ((CHANNEL_DESCRIPTOR (channel)), position, SEEK_SET)));
+ if (result != position)
+ error_external_return ();
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxfs.c,v 1.1 1990/06/20 19:37:11 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+#include "osfs.h"
+\f
+enum file_existence
+DEFUN (OS_file_existence_test, (name), CONST char * name)
+{
+ struct stat s;
+ return
+ (((UX_stat (name, (&s))) < 0)
+ ? (((errno == ENOENT) || (errno == ENOTDIR))
+ ? file_doesnt_exist
+ : file_may_exist)
+ : file_does_exist);
+}
+
+int
+DEFUN (OS_file_access, (name, mode), CONST char * name AND unsigned int mode)
+{
+ return ((UX_access (name, mode)) == 0);
+}
+
+int
+DEFUN (OS_file_directory_p, (name), CONST char * name)
+{
+ struct stat s;
+ return (((UX_stat (name, (&s))) == 0) &&
+ (((s . st_mode) & S_IFMT) == S_IFDIR));
+}
+
+CONST char *
+DEFUN (OS_file_soft_link_p, (name), CONST char * name)
+{
+#ifdef HAVE_SYMBOLIC_LINKS
+ struct stat s;
+ if (((UX_lstat (name, (&s))) < 0)
+ || (((s . st_mode) & S_IFMT) != S_IFLNK))
+ return (0);
+ {
+ int scr;
+ int buffer_length = 100;
+ char * buffer = (UX_malloc (buffer_length));
+ if (buffer == 0)
+ error_system_call (ENOMEM, "malloc");
+ while (1)
+ {
+ STD_UINT_SYSTEM_CALL
+ ("readlink", scr, (UX_readlink (name, buffer, buffer_length)));
+ if (scr < buffer_length)
+ break;
+ buffer_length *= 2;
+ buffer = (UX_realloc (buffer, buffer_length));
+ if (buffer == 0)
+ error_system_call (ENOMEM, "realloc");
+ }
+ (buffer[scr]) = '\0';
+ return ((CONST char *) buffer);
+ }
+#else
+ return (0);
+#endif
+}
+
+void
+DEFUN (OS_file_remove, (name), CONST char * name)
+{
+ STD_VOID_SYSTEM_CALL ("unlink", (UX_unlink (name)));
+}
+
+void
+DEFUN (OS_file_remove_link, (name), CONST char * name)
+{
+ struct stat s;
+ if (((UX_lstat (name, (&s))) == 0) &&
+ (((((s . st_mode) & S_IFMT) == S_IFREG) && ((s . st_nlink) > 1))
+#ifdef HAVE_SYMBOLIC_LINKS
+ || (((s . st_mode) & S_IFMT) == S_IFLNK)
+#endif
+ ))
+ UX_unlink (name);
+}
+
+void
+DEFUN (OS_file_link_hard, (from_name, to_name),
+ CONST char * from_name AND
+ CONST char * to_name)
+{
+ STD_VOID_SYSTEM_CALL ("link", (UX_link (from_name, to_name)));
+}
+
+void
+DEFUN (OS_file_link_soft, (from_name, to_name),
+ CONST char * from_name AND
+ CONST char * to_name)
+{
+#ifdef HAVE_SYMBOLIC_LINKS
+ STD_VOID_SYSTEM_CALL ("symlink", (UX_symlink (from_name, to_name)));
+#else
+ error_unimplemented_primitive ();
+#endif
+}
+
+void
+DEFUN (OS_file_rename, (from_name, to_name),
+ CONST char * from_name AND
+ CONST char * to_name)
+{
+ STD_VOID_SYSTEM_CALL ("rename", (UX_rename (from_name, to_name)));
+}
+
+void
+DEFUN (OS_directory_make, (name), CONST char * name)
+{
+ STD_VOID_SYSTEM_CALL ("mkdir", (UX_mkdir (name, MODE_DIR)));
+}
+\f
+#if defined(HAVE_DIRENT) || defined(HAVE_DIR)
+
+static DIR * directory_pointer = 0;
+#ifdef HAVE_DIRENT
+static struct dirent * directory_entry;
+#else
+static struct direct * directory_entry;
+#endif
+
+#define READ_DIRECTORY_ENTRY() \
+{ \
+ directory_entry = (readdir (directory_pointer)); \
+ if (directory_entry == 0) \
+ { \
+ closedir (directory_pointer); \
+ directory_pointer = 0; \
+ return (0); \
+ } \
+ return (directory_entry -> d_name); \
+}
+
+CONST char *
+DEFUN (OS_directory_open, (name), CONST char * name)
+{
+ if (directory_pointer != 0)
+ error_external_return ();
+ /* Cast `name' to non-const because hp-ux 7.0 declaration incorrect. */
+ directory_pointer = (opendir ((char *) name));
+ if (directory_pointer == 0)
+#ifdef HAVE_DIRENT
+ error_system_call (errno, "opendir");
+#else
+ error_external_return ();
+#endif
+ READ_DIRECTORY_ENTRY ();
+}
+
+CONST char *
+DEFUN_VOID (OS_directory_read)
+{
+ if (directory_pointer == 0)
+ error_external_return ();
+ READ_DIRECTORY_ENTRY ();
+}
+
+void
+DEFUN_VOID (OS_directory_close)
+{
+ if (directory_pointer != 0)
+ {
+ closedir (directory_pointer);
+ directory_pointer = 0;
+ }
+}
+
+void
+DEFUN_VOID (UX_initialize_directory_reader)
+{
+ directory_pointer = 0;
+}
+
+#else /* not HAVE_DIRENT nor HAVE_DIR */
+
+CONST char *
+DEFUN (OS_directory_open, (name), CONST char * name)
+{
+ error_unimplemented_primitive ();
+ return (0);
+}
+
+CONST char *
+DEFUN_VOID (OS_directory_read)
+{
+ error_unimplemented_primitive ();
+ return (0);
+}
+
+void
+DEFUN_VOID (OS_directory_close)
+{
+ error_unimplemented_primitive ();
+}
+
+void
+DEFUN_VOID (UX_initialize_directory_reader)
+{
+}
+
+#endif /* HAVE_DIRENT */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxio.c,v 1.1 1990/06/20 19:37:14 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+#include "uxio.h"
+\f
+size_t OS_channel_table_size;
+struct channel * channel_table;
+
+void
+DEFUN_VOID (UX_initialize_channels)
+{
+ OS_channel_table_size = (UX_SC_OPEN_MAX ());
+ channel_table =
+ (UX_malloc (OS_channel_table_size * (sizeof (struct channel))));
+ if (channel_table == 0)
+ {
+ fprintf (stderr, "\nUnable to allocate channel table.\n");
+ fflush (stderr);
+ termination_init_error ();
+ }
+ {
+ Tchannel channel;
+ for (channel = 0; (channel < OS_channel_table_size); channel += 1)
+ MARK_CHANNEL_CLOSED (channel);
+ }
+}
+
+void
+DEFUN_VOID (OS_channel_close_all)
+{
+ Tchannel channel;
+ for (channel = 0; (channel < OS_channel_table_size); channel += 1)
+ if ((CHANNEL_OPEN_P (channel)) && (! (CHANNEL_INTERNAL (channel))))
+ OS_channel_close (channel);
+}
+
+Tchannel
+DEFUN_VOID (channel_allocate)
+{
+ Tchannel channel = 0;
+ while (1)
+ {
+ if (channel == OS_channel_table_size)
+ error_out_of_channels ();
+ if (CHANNEL_CLOSED_P (channel))
+ return (channel);
+ channel += 1;
+ }
+}
+
+int
+DEFUN (OS_channel_open_p, (channel), Tchannel channel)
+{
+ return (CHANNEL_OPEN_P (channel));
+}
+
+void
+DEFUN (OS_channel_close, (channel), Tchannel channel)
+{
+ if (! (CHANNEL_INTERNAL (channel)))
+ STD_VOID_SYSTEM_CALL ("close", (UX_close (CHANNEL_DESCRIPTOR (channel))));
+ MARK_CHANNEL_CLOSED (channel);
+}
+
+void
+DEFUN (OS_channel_close_noerror, (channel), Tchannel channel)
+{
+ UX_close (CHANNEL_DESCRIPTOR (channel));
+ MARK_CHANNEL_CLOSED (channel);
+}
+
+enum channel_type
+DEFUN (OS_channel_type, (channel), Tchannel channel)
+{
+ return (CHANNEL_TYPE (channel));
+}
+\f
+#ifdef _POSIX
+
+#define ERRNO_NONBLOCK EAGAIN
+#define FCNTL_NONBLOCK O_NONBLOCK
+
+#else /* not _POSIX */
+#ifdef HAVE_ONDELAY
+
+#define AMBIGUOUS_NONBLOCK
+#define ERRNO_NONBLOCK EAGAIN
+#define FCNTL_NONBLOCK O_NDELAY
+
+#else /* not HAVE_ONDELAY */
+#ifdef HAVE_FNDELAY
+
+#define ERRNO_NONBLOCK EWOULDBLOCK
+#define FCNTL_NONBLOCK FNDELAY
+
+#endif /* HAVE_FNDELAY */
+#endif /* HAVE_ONDELAY */
+#endif /* not _POSIX */
+
+long
+DEFUN (OS_channel_read, (channel, buffer, nbytes),
+ Tchannel channel AND
+ PTR buffer AND
+ size_t nbytes)
+{
+ if (nbytes == 0)
+ return (0);
+ while (1)
+ {
+ long scr = (UX_read ((CHANNEL_DESCRIPTOR (channel)), buffer, nbytes));
+ if (scr < 0)
+ {
+#ifdef ERRNO_NONBLOCK
+ if (errno == ERRNO_NONBLOCK)
+ return (-1);
+#endif
+ if (errno == EINTR)
+ continue;
+ error_system_call (errno, "read");
+ }
+ if (scr > nbytes)
+ error_external_return ();
+#ifdef AMBIGUOUS_NONBLOCK
+ return ((scr > 0) ? scr : (CHANNEL_NONBLOCKING (channel)) ? (-1) : 0);
+#else
+ return (scr);
+#endif
+ }
+}
+
+long
+DEFUN (OS_channel_write, (channel, buffer, nbytes),
+ Tchannel channel AND
+ CONST PTR buffer AND
+ size_t nbytes)
+{
+ if (nbytes == 0)
+ return (0);
+ while (1)
+ {
+ long scr = (UX_write ((CHANNEL_DESCRIPTOR (channel)), buffer, nbytes));
+ if (scr < 0)
+ {
+#ifdef ERRNO_NONBLOCK
+ if (errno == ERRNO_NONBLOCK)
+ return (-1);
+#endif
+ if (errno == EINTR)
+ continue;
+ error_system_call (errno, "write");
+ }
+ if (scr > nbytes)
+ error_external_return ();
+ return ((scr > 0) ? scr : (-1));
+ }
+}
+\f
+size_t
+DEFUN (OS_channel_read_load_file, (channel, buffer, nbytes),
+ Tchannel channel AND PTR buffer AND size_t nbytes)
+{
+ int scr = (UX_read ((CHANNEL_DESCRIPTOR (channel)), buffer, nbytes));
+ return ((scr < 0) ? 0 : scr);
+}
+
+size_t
+DEFUN (OS_channel_write_dump_file, (channel, buffer, nbytes),
+ Tchannel channel AND CONST PTR buffer AND size_t nbytes)
+{
+ int scr = (UX_write ((CHANNEL_DESCRIPTOR (channel)), buffer, nbytes));
+ return ((scr < 0) ? 0 : scr);
+}
+
+int
+DEFUN (OS_channel_read_char_interruptably, (channel), Tchannel channel)
+{
+ unsigned char c;
+ int nread;
+ while (1)
+ {
+ INTERRUPTABLE_EXTENT
+ (nread, (UX_read ((CHANNEL_DESCRIPTOR (channel)), ((PTR) (&c)), 1)));
+ if (nread >= 0)
+ break;
+#ifdef ERRNO_NONBLOCK
+ if (errno == ERRNO_NONBLOCK)
+ {
+ nread = 0;
+ break;
+ }
+#endif
+ UX_prim_check_errno ("read");
+ }
+ return ((nread == 1) ? c : (-1));
+}
+
+void
+DEFUN (OS_channel_write_string, (channel, string),
+ Tchannel channel AND
+ CONST char * string)
+{
+ unsigned long length = (strlen (string));
+ if ((OS_channel_write (channel, string, length)) != length)
+ error_external_return ();
+}
+\f
+#ifdef FCNTL_NONBLOCK
+
+static int
+DEFUN (get_flags, (fd), int fd)
+{
+ int scr;
+ STD_UINT_SYSTEM_CALL ("fcntl_GETFL", scr, (UX_fcntl (fd, F_GETFL, 0)));
+ return (scr);
+}
+
+static void
+DEFUN (set_flags, (fd, flags), int fd AND int flags)
+{
+ STD_VOID_SYSTEM_CALL ("fcntl_SETFL", (UX_fcntl (fd, F_SETFL, flags)));
+}
+
+int
+DEFUN (OS_channel_nonblocking_p, (channel), Tchannel channel)
+{
+ return (CHANNEL_NONBLOCKING (channel));
+}
+
+void
+DEFUN (OS_channel_nonblocking, (channel), Tchannel channel)
+{
+ int fd = (CHANNEL_DESCRIPTOR (channel));
+ int flags = (get_flags (fd));
+ if ((flags & FCNTL_NONBLOCK) == 0)
+ set_flags (fd, (flags | FCNTL_NONBLOCK));
+ (CHANNEL_NONBLOCKING (channel)) = 1;
+}
+
+void
+DEFUN (OS_channel_blocking, (channel), Tchannel channel)
+{
+ int fd = (CHANNEL_DESCRIPTOR (channel));
+ int flags = (get_flags (fd));
+ if ((flags & FCNTL_NONBLOCK) != 0)
+ set_flags (fd, (flags &~ FCNTL_NONBLOCK));
+ (CHANNEL_NONBLOCKING (channel)) = 0;
+}
+
+#else /* not FCNTL_NONBLOCK */
+
+int
+DEFUN (OS_channel_nonblocking_p, (channel), Tchannel channel)
+{
+ return (-1);
+}
+
+void
+DEFUN (OS_channel_nonblocking, (channel), Tchannel channel)
+{
+ error_unimplemented_primitive ();
+}
+
+void
+DEFUN (OS_channel_blocking, (channel), Tchannel channel)
+{
+}
+
+#endif /* FCNTL_NONBLOCK */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxio.h,v 1.1 1990/06/20 19:37:20 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_UXIO_H
+#define SCM_UXIO_H
+
+#include "osio.h"
+
+struct channel
+{
+ int descriptor;
+ enum channel_type type;
+ unsigned int internal : 1;
+ unsigned int nonblocking : 1;
+};
+
+#define MARK_CHANNEL_CLOSED(channel) ((CHANNEL_DESCRIPTOR (channel)) = (-1))
+#define CHANNEL_CLOSED_P(channel) ((CHANNEL_DESCRIPTOR (channel)) < 0)
+#define CHANNEL_OPEN_P(channel) ((CHANNEL_DESCRIPTOR (channel)) >= 0)
+#define CHANNEL_DESCRIPTOR(channel) ((channel_table [(channel)]) . descriptor)
+#define CHANNEL_TYPE(channel) ((channel_table [(channel)]) . type)
+#define CHANNEL_INTERNAL(channel) ((channel_table [(channel)]) . internal)
+#define CHANNEL_NONBLOCKING(channel) \
+ ((channel_table [(channel)]) . nonblocking)
+
+#define MAKE_CHANNEL(descriptor, type, receiver) \
+{ \
+ Tchannel MAKE_CHANNEL_temp = (channel_allocate ()); \
+ (CHANNEL_DESCRIPTOR (MAKE_CHANNEL_temp)) = (descriptor); \
+ (CHANNEL_TYPE (MAKE_CHANNEL_temp)) = (type); \
+ (CHANNEL_INTERNAL (MAKE_CHANNEL_temp)) = 0; \
+ (CHANNEL_NONBLOCKING (MAKE_CHANNEL_temp)) = 0; \
+ receiver (MAKE_CHANNEL_temp); \
+}
+
+extern struct channel * channel_table;
+extern Tchannel EXFUN (channel_allocate, (void));
+
+#endif /* SCM_UXIO_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxproc.c,v 1.1 1990/06/20 19:37:22 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+#include "uxproc.h"
+#include "uxio.h"
+#include "osterm.h"
+
+static void EXFUN (deallocate_uncommitted_processes, (PTR ignore));
+static void EXFUN (subprocess_death, (pid_t pid, wait_status_t * status));
+static Tprocess EXFUN (find_process, (pid_t pid));
+static int EXFUN (child_setup_tty, (Tchannel channel));
+\f
+size_t OS_process_table_size;
+struct process * process_table;
+
+void
+DEFUN_VOID (UX_initialize_processes)
+{
+ OS_process_table_size = (UX_SC_CHILD_MAX ());
+ process_table =
+ (UX_malloc (OS_process_table_size * (sizeof (struct process))));
+ if (process_table == 0)
+ {
+ fprintf (stderr, "\nUnable to allocate process table.\n");
+ fflush (stderr);
+ termination_init_error ();
+ }
+ {
+ Tprocess process;
+ for (process = 0; (process < OS_process_table_size); process += 1)
+ (PROCESS_STATUS (process)) = process_status_free;
+ }
+ {
+ extern void EXFUN
+ ((*subprocess_death_hook), (pid_t pid, wait_status_t * status));
+ subprocess_death_hook = subprocess_death;
+ }
+}
+
+static Tprocess
+DEFUN_VOID (process_allocate)
+{
+ Tprocess process;
+ for (process = 0; (process < OS_process_table_size); process += 1)
+ if ((PROCESS_STATUS (process)) == process_status_free)
+ {
+ transaction_record_action
+ (tat_abort, deallocate_uncommitted_processes, 0);
+ (PROCESS_STATUS (process)) = process_status_allocated;
+ return (process);
+ }
+ error_out_of_processes ();
+ return (NO_PROCESS);
+}
+
+static void
+DEFUN (deallocate_uncommitted_processes, (ignore), PTR ignore)
+{
+ Tprocess process;
+ for (process = 0; (process < OS_process_table_size); process += 1)
+ if ((PROCESS_STATUS (process)) == process_status_allocated)
+ (PROCESS_STATUS (process)) = process_status_free;
+}
+
+void
+DEFUN (OS_process_deallocate, (process), Tprocess process)
+{
+ (PROCESS_STATUS (process)) = process_status_free;
+}
+
+#define PROTECT_CHANNEL(channel) \
+{ \
+ Tchannel * PROTECT_CHANNEL_cp = (dstack_alloc (sizeof (Tchannel))); \
+ (*PROTECT_CHANNEL_cp) = (channel); \
+ transaction_record_action \
+ (tat_abort, channel_close, PROTECT_CHANNEL_cp); \
+}
+
+static void
+DEFUN (channel_close, (cp), PTR cp)
+{
+ OS_channel_close (* ((Tchannel *) cp));
+}
+\f
+Tprocess
+DEFUN (OS_make_subprocess, (filename, argv, envp, ctty_type),
+ CONST char * filename AND
+ CONST char ** argv AND
+ char ** envp AND
+ enum process_ctty_type ctty_type)
+{
+ Tchannel child_read;
+ Tchannel child_write;
+ Tchannel parent_read;
+ Tchannel parent_write;
+ pid_t child_pid;
+#ifdef HAVE_PTYS
+ CONST char * pty_name;
+#endif
+ Tprocess child;
+
+ if ((ctty_type == ctty_type_none) || (ctty_type == ctty_type_inherited))
+ /* Implement shell-like subprocess control later. */
+ error_unimplemented_primitive ();
+
+ transaction_begin ();
+ child = (process_allocate ());
+
+ if (ctty_type == ctty_type_pty)
+ {
+#ifdef HAVE_PTYS
+ {
+ CONST char * master_name;
+ pty_name = (OS_open_pty_master ((&parent_read), (&master_name)));
+ }
+ if (pty_name != 0)
+ {
+ PROTECT_CHANNEL (parent_read);
+ parent_write = parent_read;
+ }
+ else
+#endif /* HAVE_PTYS */
+ ctty_type = ctty_type_pipe;
+ }
+ if (ctty_type == ctty_type_pipe)
+ {
+ int pv [2];
+ STD_VOID_SYSTEM_CALL ("pipe", (UX_pipe (pv)));
+ MAKE_CHANNEL ((pv[0]), channel_type_pipe, child_read =);
+ PROTECT_CHANNEL (child_read);
+ MAKE_CHANNEL ((pv[1]), channel_type_pipe, parent_write =);
+ PROTECT_CHANNEL (parent_write);
+ STD_VOID_SYSTEM_CALL ("pipe", (UX_pipe (pv)));
+ MAKE_CHANNEL ((pv[0]), channel_type_pipe, parent_read =);
+ PROTECT_CHANNEL (parent_read);
+ MAKE_CHANNEL ((pv[1]), channel_type_pipe, child_write =);
+ PROTECT_CHANNEL (child_write);
+ }
+
+ /* Flush streams so that i/o won't be duplicated after the fork */
+ fflush (stdin);
+ fflush (stdout);
+ fflush (stderr);
+
+ STD_UINT_SYSTEM_CALL ("vfork", child_pid, (UX_vfork ()));
+ if (child_pid > 0)
+ {
+ /* In the parent process. */
+ (PROCESS_ID (child)) = child_pid;
+ (PROCESS_INPUT (child)) = parent_write;
+ (PROCESS_OUTPUT (child)) = parent_read;
+ (PROCESS_STATUS (child)) = process_status_running;
+ (PROCESS_CTTY_TYPE (child)) = ctty_type;
+ (PROCESS_CHANGED (child)) = 0;
+ (PROCESS_SYNCHRONOUS (child)) = 0;
+ if (ctty_type == ctty_type_pipe)
+ {
+ /* If either of these closes signals an error, ignore it. */
+ UX_close (CHANNEL_DESCRIPTOR (child_read));
+ MARK_CHANNEL_CLOSED (child_read);
+ UX_close (CHANNEL_DESCRIPTOR (child_write));
+ MARK_CHANNEL_CLOSED (child_write);
+ }
+ transaction_commit ();
+ return (child);
+ }
+ else
+ {
+ /* In the child process -- if any errors occur, just exit. */
+
+ /* Force child into different session. */
+ if ((UX_setsid ()) < 0)
+ goto kill_child;
+
+#ifdef HAVE_PTYS
+ /* If connection is a PTY, open the slave side (which becomes
+ the controlling terminal). */
+ if (ctty_type == ctty_type_pty)
+ {
+ int fd = (UX_open (pty_name, O_RDWR, 0));
+ if (fd < 0)
+ goto kill_child;
+ MAKE_CHANNEL (fd, channel_type_terminal, child_read =);
+ child_write = child_read;
+ if ((child_setup_tty (child_read)) < 0)
+ goto kill_child;
+ }
+#endif /* HAVE_PTYS */
+
+#ifdef HAVE_DUP2
+ /* Setup the standard I/O for the child. */
+ if (((UX_dup2 (child_read, STDIN_FILENO)) < 0) ||
+ ((UX_dup2 (child_write, STDOUT_FILENO)) < 0) ||
+ ((UX_dup2 (child_write, STDERR_FILENO)) < 0))
+ goto kill_child;
+#else
+#include "error: can't hack subprocess I/O without dup2() or equivalent"
+#endif
+
+ /* Close all other file descriptors. */
+ {
+ int fd = 0;
+ int open_max = (UX_SC_OPEN_MAX ());
+ while (fd < open_max)
+ if (! ((fd == STDIN_FILENO) ||
+ (fd == STDOUT_FILENO) ||
+ (fd == STDERR_FILENO)))
+ UX_close (fd++);
+ }
+
+ /* Force the signal mask to be empty.
+ (This should be done for HAVE_SYSV3_SIGNALS too, but
+ it's more difficult in that case.) */
+#ifdef HAVE_POSIX_SIGNALS
+ {
+ sigset_t empty_mask;
+ UX_sigemptyset (&empty_mask);
+ UX_sigprocmask (SIG_SETMASK, (&empty_mask), 0);
+ }
+#else /* not HAVE_POSIX_SIGNALS */
+#ifdef HAVE_BSD_SIGNALS
+ UX_sigsetmask (0);
+#endif /* HAVE_BSD_SIGNALS */
+#endif /* HAVE_POSIX_SIGNALS */
+
+ /* Start the process. */
+ execve (filename, argv, envp);
+ kill_child:
+ _exit (1);
+ }
+}
+\f
+static void
+DEFUN (subprocess_death, (pid, status), pid_t pid AND wait_status_t * status)
+{
+ Tprocess process = (find_process (pid));
+ if (process != NO_PROCESS)
+ {
+ if (WIFEXITED (*status))
+ {
+ (PROCESS_CHANGED (process)) = 1;
+ (PROCESS_STATUS (process)) = process_status_exited;
+ (PROCESS_REASON (process)) = (WEXITSTATUS (*status));
+ }
+ else if (WIFSTOPPED (*status))
+ {
+ (PROCESS_CHANGED (process)) = 1;
+ (PROCESS_STATUS (process)) = process_status_stopped;
+ (PROCESS_REASON (process)) = (WSTOPSIG (*status));
+ if (PROCESS_SYNCHRONOUS (process))
+ UX_kill (pid, SIGKILL);
+ }
+ else if (WIFSIGNALED (*status))
+ {
+ (PROCESS_CHANGED (process)) = 1;
+ (PROCESS_STATUS (process)) = process_status_signalled;
+ (PROCESS_REASON (process)) = (WTERMSIG (*status));
+ }
+ }
+}
+
+static Tprocess
+DEFUN (find_process, (pid), pid_t pid)
+{
+ Tprocess process;
+ for (process = 0; (process < OS_process_table_size); process += 1)
+ if ((PROCESS_ID (process)) == pid)
+ {
+ if (((PROCESS_STATUS (process)) == process_status_free)
+ || ((PROCESS_STATUS (process)) == process_status_allocated))
+ break;
+ return (process);
+ }
+ return (NO_PROCESS);
+}
+
+#define DEFUN_PROCESS_ACCESSOR(name, result_type, accessor) \
+result_type \
+DEFUN (name, (process), Tprocess process) \
+{ \
+ return (accessor (process)); \
+}
+
+DEFUN_PROCESS_ACCESSOR (OS_process_id, pid_t, PROCESS_ID)
+DEFUN_PROCESS_ACCESSOR (OS_process_status, enum process_status, PROCESS_STATUS)
+DEFUN_PROCESS_ACCESSOR
+ (OS_process_ctty_type, enum process_ctty_type, PROCESS_CTTY_TYPE)
+DEFUN_PROCESS_ACCESSOR (OS_process_reason, unsigned short, PROCESS_REASON)
+DEFUN_PROCESS_ACCESSOR (OS_process_synchronous, int, PROCESS_SYNCHRONOUS)
+
+Tchannel
+DEFUN (OS_process_input, (process), Tprocess process)
+{
+ Tchannel channel = (PROCESS_INPUT (process));
+ if (channel == NO_CHANNEL)
+ error_external_return ();
+ return (channel);
+}
+
+Tchannel
+DEFUN (OS_process_output, (process), Tprocess process)
+{
+ Tchannel channel = (PROCESS_OUTPUT (process));
+ if (channel == NO_CHANNEL)
+ error_external_return ();
+ return (channel);
+}
+\f
+void
+DEFUN (OS_process_send_signal, (process, sig), Tprocess process AND int sig)
+{
+ STD_VOID_SYSTEM_CALL ("kill", (UX_kill ((PROCESS_ID (process)), sig)));
+}
+
+void
+DEFUN (OS_process_kill, (process), Tprocess process)
+{
+ OS_process_send_signal (process, SIGKILL);
+}
+
+void
+DEFUN (OS_process_stop, (process), Tprocess process)
+{
+ if (UX_SC_JOB_CONTROL ())
+ OS_process_send_signal (process, SIGTSTP);
+ else
+ error_unimplemented_primitive ();
+}
+
+void
+DEFUN (OS_process_continue, (process), Tprocess process)
+{
+ if (UX_SC_JOB_CONTROL ())
+ OS_process_send_signal (process, SIGCONT);
+ else
+ error_unimplemented_primitive ();
+}
+
+void
+DEFUN (OS_process_interrupt, (process), Tprocess process)
+{
+ OS_process_send_signal (process, SIGINT);
+}
+
+void
+DEFUN (OS_process_quit, (process), Tprocess process)
+{
+ OS_process_send_signal (process, SIGQUIT);
+}
+\f
+#ifdef HAVE_PTYS
+
+/* Set up the terminal at the other end of a pseudo-terminal that we
+ will be controlling an inferior through. */
+
+#ifdef HAVE_TERMIOS
+
+#ifndef IUCLC
+/* POSIX.1 doesn't require (or even mention) these symbols, but we
+ must disable them if they are present. */
+#define IUCLC 0
+#define OLCUC 0
+#define ONLCR 0
+#define NLDLY 0
+#define CRDLY 0
+#define TABDLY 0
+#define BSDLY 0
+#define VTDLY 0
+#define FFDLY 0
+#endif
+
+static int
+DEFUN (child_setup_tty, (channel), Tchannel channel)
+{
+ int fd = (CHANNEL_DESCRIPTOR (channel));
+ cc_t disabled_char = (UX_PC_VDISABLE (fd));
+ struct termios s;
+ if ((UX_tcgetattr (fd, (&s))) < 0)
+ return (-1);
+ (s . c_iflag) &=~ IUCLC;
+ (s . c_oflag) |= OPOST;
+ (s . c_oflag) &=~
+ (OLCUC | ONLCR | NLDLY | CRDLY | TABDLY | BSDLY | VTDLY | FFDLY);
+ (s . c_lflag) &=~ (ECHO | ECHOE | ECHOK | ECHONL);
+ (s . c_lflag) |= (ICANON | ISIG);
+ ((s . c_cc) [VEOF]) = '\004';
+ ((s . c_cc) [VERASE]) = disabled_char;
+ ((s . c_cc) [VKILL]) = disabled_char;
+ cfsetispeed ((&s), B9600);
+ cfsetospeed ((&s), B9600);
+ return (UX_tcsetattr (fd, TCSADRAIN, (&s)));
+}
+
+#else /* not HAVE_TERMIOS */
+\f
+#ifdef HAVE_TERMIO
+
+static int
+DEFUN (child_setup_tty, (channel), Tchannel channel)
+{
+ int fd = (CHANNEL_DESCRIPTOR (channel));
+ cc_t disabled_char = (UX_PC_VDISABLE (fd));
+ struct termio s;
+ if ((ioctl (fd, TCGETA, (&s))) < 0)
+ return (-1);
+ (s . c_iflag) &=~ IUCLC;
+ (s . c_oflag) |= OPOST;
+ (s . c_oflag) &=~
+ (OLCUC | ONLCR | NLDLY | CRDLY | TABDLY | BSDLY | VTDLY | FFDLY);
+ (s . c_lflag) &=~ (ECHO | ECHOE | ECHOK | ECHONL);
+ (s . c_lflag) |= (ICANON | ISIG);
+ ((s . c_cc) [VEOF]) = '\004';
+ ((s . c_cc) [VERASE]) = disabled_char;
+ ((s . c_cc) [VKILL]) = disabled_char;
+ (s . c_cflag) = (((s . c_cflag) &~ CBAUD) | B9600);
+#ifdef _AIX
+ /* AIX enhanced edit loses NULs, so disable it.
+ Also, PTY overloads NUL and BREAK.
+ don't ignore break, but don't signal either, so it looks like NUL.
+ This really serves a purpose only if running in an XTERM window
+ or via TELNET or the like, but does no harm elsewhere. */
+ (s . c_line) = 0;
+ (s . c_iflag) &=~ (ASCEDIT | IGNBRK | BRKINT);
+ /* QUIT and INTR work better as signals, so disable character forms */
+ (s . c_lflag) &=~ ISIG;
+ ((s . c_cc) [VQUIT]) = disabled_char;
+ ((s . c_cc) [VINTR]) = disabled_char;
+ ((s . c_cc) [VEOL]) = disabled_char;
+#endif /* _AIX */
+ return (ioctl (fd, TCSETAW, (&s)));
+}
+
+#else /* not HAVE_TERMIO */
+#ifdef HAVE_BSD_TTY_DRIVER
+
+static int
+DEFUN (child_setup_tty, (channel), Tchannel channel)
+{
+ int fd = (CHANNEL_DESCRIPTOR (channel));
+ struct sgttyb s;
+ if ((ioctl (fd, TIOCGETP, (&s))) < 0)
+ return (-1);
+ (s . sg_flags) &=~
+ (ECHO | CRMOD | ANYP | ALLDELAY | RAW | LCASE | CBREAK | TANDEM);
+ return (ioctl (fd, TIOCSETN, (&s)));
+}
+
+#endif /* HAVE_BSD_TTY_DRIVER */
+#endif /* HAVE_TERMIO */
+#endif /* HAVE_TERMIOS */
+#endif /* HAVE_PTYS */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxproc.h,v 1.1 1990/06/20 19:37:25 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_UXPROC_H
+#define SCM_UXPROC_H
+
+#include "osproc.h"
+
+struct process
+{
+ pid_t id; /* process id */
+ Tchannel input; /* standard input */
+ Tchannel output; /* standard output and error */
+ unsigned short reason;
+ enum process_status status;
+ enum process_ctty_type ctty_type;
+ unsigned int changed : 1;
+ unsigned int synchronous : 1;
+};
+
+#define PROCESS_ID(process) ((process_table [(process)]) . id)
+#define PROCESS_INPUT(process) ((process_table [(process)]) . input)
+#define PROCESS_OUTPUT(process) ((process_table [(process)]) . output)
+#define PROCESS_STATUS(process) ((process_table [(process)]) . status)
+#define PROCESS_CTTY_TYPE(process) ((process_table [(process)]) . ctty_type)
+#define PROCESS_REASON(process) ((process_table [(process)]) . reason)
+#define PROCESS_CHANGED(process) ((process_table [(process)]) . changed)
+#define PROCESS_SYNCHRONOUS(process) \
+ ((process_table [(process)]) . synchronous)
+
+extern struct process * process_table;
+
+#endif /* SCM_UXPROC_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxsig.c,v 1.1 1990/06/20 19:37:28 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+#include "ossig.h"
+#include "osctty.h"
+#include "ostty.h"
+#include "uxtrap.h"
+#include "uxutil.h"
+#include "critsec.h"
+\f
+/* Signal Manipulation */
+
+#ifdef HAVE_POSIX_SIGNALS
+
+static Tsignal_handler
+DEFUN (current_handler, (signo), int signo)
+{
+ struct sigaction act;
+ UX_sigaction (signo, 0, (&act));
+ return (act . sa_handler);
+}
+
+static void
+DEFUN (INSTALL_HANDLER, (signo, handler),
+ int signo AND
+ Tsignal_handler handler)
+{
+ struct sigaction act;
+ (act . sa_handler) = handler;
+ UX_sigemptyset (& (act . sa_mask));
+ UX_sigaddset ((& (act . sa_mask)), signo);
+ (act . sa_flags) = 0;
+ UX_sigaction (signo, (&act), 0);
+}
+
+#define BLOCK_SIGNALS_DECLARE() sigset_t BLOCK_SIGNALS_mask
+
+#define BLOCK_SIGNALS(signo) \
+{ \
+ sigset_t BLOCK_SIGNALS_set; \
+ UX_sigfillset (&BLOCK_SIGNALS_set); \
+ UX_sigdelset ((&BLOCK_SIGNALS_set), (signo)); \
+ UX_sigprocmask \
+ (SIG_SETMASK, (&BLOCK_SIGNALS_set), (&BLOCK_SIGNALS_mask)); \
+}
+
+#define UNBLOCK_SIGNALS() \
+ UX_sigprocmask (SIG_SETMASK, (&BLOCK_SIGNALS_mask), 0)
+
+#else /* not HAVE_POSIX_SIGNALS */
+#ifdef HAVE_BSD_SIGNALS
+
+static Tsignal_handler
+DEFUN (current_handler, (signo), int signo)
+{
+ struct sigvec act;
+ UX_sigvec (signo, 0, (&act));
+ return (act . sv_handler);
+}
+
+static void
+DEFUN (INSTALL_HANDLER, (signo, handler),
+ int signo AND
+ Tsignal_handler handler)
+{
+ struct sigvec act;
+ (act . sv_handler) = handler;
+ (act . sv_mask) = (1 << (signo - 1));
+ (act . sv_flags) = 0;
+ UX_sigvec (signo, (&act), 0);
+}
+
+#define BLOCK_SIGNALS_DECLARE() int BLOCK_SIGNALS_mask
+
+#define BLOCK_SIGNALS(signo) \
+{ \
+ BLOCK_SIGNALS_mask = (UX_sigblock (0)); \
+ UX_sigsetmask (~ (1 << ((signo) - 1))); \
+}
+
+#define UNBLOCK_SIGNALS() UX_sigsetmask (BLOCK_SIGNALS_mask)
+\f
+#else /* not HAVE_BSD_SIGNALS */
+#ifdef HAVE_SYSV3_SIGNALS
+
+static Tsignal_handler
+DEFUN (current_handler, (signo), int signo)
+{
+ Tsignal_handler result = (UX_sigset (signo, SIG_HOLD));
+ if (result != SIG_HOLD)
+ UX_signal (signo, result);
+ return (result);
+}
+
+#define INSTALL_HANDLER UX_sigset
+#define BLOCK_SIGNALS_DECLARE() int BLOCK_SIGNALS_mask
+#define BLOCK_SIGNALS(signo) UX_sigrelse (signo)
+#define UNBLOCK_SIGNALS()
+
+#define NEED_HANDLER_TRANSACTION
+#define ENTER_HANDLER(signo)
+#define ABORT_HANDLER(signo, handler) UX_sigrelse (signo)
+#define EXIT_HANDLER(signo, handler)
+
+#else /* not HAVE_SYSV3_SIGNALS */
+
+static Tsignal_handler
+DEFUN (current_handler, (signo), int signo)
+{
+ Tsignal_handler result = (UX_signal (signo, SIG_IGN));
+ if (result != SIG_IGN)
+ UX_signal (signo, result);
+ return (result);
+}
+
+#define INSTALL_HANDLER UX_signal
+#define BLOCK_SIGNALS_DECLARE() int BLOCK_SIGNALS_mask
+#define BLOCK_SIGNALS(signo)
+#define UNBLOCK_SIGNALS()
+
+#define NEED_HANDLER_TRANSACTION
+#define ENTER_HANDLER(signo) UX_signal ((signo), SIG_IGN)
+#define ABORT_HANDLER UX_signal
+#define EXIT_HANDLER UX_signal
+
+#endif /* HAVE_SYSV3_SIGNALS */
+#endif /* HAVE_BSD_SIGNALS */
+#endif /* HAVE_POSIX_SIGNALS */
+\f
+/* Signal Descriptors */
+
+enum dfl_action { dfl_terminate, dfl_ignore, dfl_stop };
+
+struct signal_descriptor
+{
+ int signo;
+ CONST char * name;
+ enum dfl_action action;
+ int flags;
+};
+
+/* `flags' bits */
+#define NOIGNORE 1
+#define NOBLOCK 2
+#define NOCATCH 4
+#define CORE_DUMP 8
+
+static struct signal_descriptor * signal_descriptors;
+static unsigned int signal_descriptors_length;
+static unsigned int signal_descriptors_limit;
+
+static void
+DEFUN (defsignal, (signo, name, action, flags),
+ int signo AND
+ CONST char * name AND
+ enum dfl_action action AND
+ int flags)
+{
+ if (signo == 0)
+ return;
+ if (signal_descriptors_length == signal_descriptors_limit)
+ {
+ signal_descriptors_limit += 8;
+ signal_descriptors =
+ (UX_realloc (signal_descriptors,
+ (signal_descriptors_limit *
+ (sizeof (struct signal_descriptor)))));
+ if (signal_descriptors == 0)
+ {
+ fprintf (stderr, "\nUnable to grow signal definitions table.\n");
+ fflush (stderr);
+ termination_init_error ();
+ }
+ }
+ {
+ struct signal_descriptor * sd =
+ (signal_descriptors + (signal_descriptors_length++));
+ (sd -> signo) = signo;
+ (sd -> name) = name;
+ (sd -> action) = action;
+ (sd -> flags) = flags;
+ }
+}
+
+static struct signal_descriptor *
+DEFUN (find_signal_descriptor, (signo), int signo)
+{
+ struct signal_descriptor * scan = signal_descriptors;
+ struct signal_descriptor * end = (scan + signal_descriptors_length);
+ for (; (scan < end); scan += 1)
+ if ((scan -> signo) == signo)
+ return (scan);
+ return (0);
+}
+
+CONST char *
+DEFUN (find_signal_name, (signo), int signo)
+{
+ static char buffer [32];
+ struct signal_descriptor * descriptor = (find_signal_descriptor (signo));
+ if (descriptor != 0)
+ return (descriptor -> name);
+ sprintf (buffer, "unknown signal %d", signo);
+ return ((CONST char *) buffer);
+}
+\f
+#ifdef _HPUX
+
+#define OS_SPECIFIC_SIGNALS() \
+{ \
+ defsignal (SIGPWR, "SIGPWR", dfl_ignore, 0); \
+ defsignal (SIGWINDOW, "SIGWINDOW", dfl_ignore, 0); \
+ defsignal (SIGLOST, "SIGLOST", dfl_terminate, 0); \
+}
+
+#else /* not _HPUX */
+#ifdef _BSD
+
+#define OS_SPECIFIC_SIGNALS() \
+{ \
+ defsignal (SIGXCPU, "SIGXCPU", dfl_terminate, 0); \
+ defsignal (SIGXFSZ, "SIGXFSZ", dfl_terminate, 0); \
+ defsignal (SIGWINCH, "SIGWINCH", dfl_ignore, 0); \
+}
+
+#endif /* _BSD */
+#endif /* _HPUX */
+
+/* Provide null defaults for all the signals we're likely to use so we
+ aren't continually testing to see if they're defined. */
+
+#if (SIGABRT == SIGIOT)
+#undef SIGABRT
+#endif
+
+#ifndef SIGLOST
+#define SIGLOST 0
+#endif
+#ifndef SIGWINCH
+#define SIGWINCH 0
+#endif
+#ifndef SIGURG
+#define SIGURG 0
+#endif
+#ifndef SIGIO
+#define SIGIO 0
+#endif
+#ifndef SIGUSR1
+#define SIGUSR1 0
+#endif
+#ifndef SIGUSR2
+#define SIGUSR2 0
+#endif
+#ifndef SIGVTALRM
+#define SIGVTALRM 0
+#endif
+#ifndef SIGABRT
+#define SIGABRT 0
+#endif
+#ifndef SIGPWR
+#define SIGPWR 0
+#endif
+#ifndef SIGPROF
+#define SIGPROF 0
+#endif
+#ifndef SIGSTOP
+#define SIGSTOP 0
+#endif
+#ifndef SIGTSTP
+#define SIGTSTP 0
+#endif
+#ifndef SIGCONT
+#define SIGCONT 0
+#endif
+#ifndef SIGCHLD
+#define SIGCHLD 0
+#endif
+#ifndef SIGTTIN
+#define SIGTTIN 0
+#endif
+#ifndef SIGTTOU
+#define SIGTTOU 0
+#endif
+\f
+static void
+DEFUN_VOID (initialize_signal_descriptors)
+{
+ signal_descriptors_length = 0;
+ signal_descriptors_limit = 32;
+ signal_descriptors =
+ (UX_malloc (signal_descriptors_limit *
+ (sizeof (struct signal_descriptor))));
+ if (signal_descriptors == 0)
+ {
+ fprintf (stderr, "\nUnable to allocate signal definitions table.\n");
+ fflush (stderr);
+ termination_init_error ();
+ }
+ defsignal (SIGHUP, "SIGHUP", dfl_terminate, 0);
+ defsignal (SIGINT, "SIGINT", dfl_terminate, 0);
+ defsignal (SIGQUIT, "SIGQUIT", dfl_terminate, CORE_DUMP);
+ defsignal (SIGILL, "SIGILL", dfl_terminate, CORE_DUMP);
+ defsignal (SIGTRAP, "SIGTRAP", dfl_terminate, CORE_DUMP);
+ defsignal (SIGIOT, "SIGIOT", dfl_terminate, CORE_DUMP);
+ defsignal (SIGEMT, "SIGEMT", dfl_terminate, CORE_DUMP);
+ defsignal (SIGFPE, "SIGFPE", dfl_terminate, CORE_DUMP);
+ defsignal (SIGKILL, "SIGKILL", dfl_terminate, (NOIGNORE | NOBLOCK | NOCATCH));
+ defsignal (SIGBUS, "SIGBUS", dfl_terminate, CORE_DUMP);
+ defsignal (SIGSEGV, "SIGSEGV", dfl_terminate, CORE_DUMP);
+ defsignal (SIGSYS, "SIGSYS", dfl_terminate, CORE_DUMP);
+ defsignal (SIGPIPE, "SIGPIPE", dfl_terminate, 0);
+ defsignal (SIGALRM, "SIGALRM", dfl_terminate, 0);
+ defsignal (SIGTERM, "SIGTERM", dfl_terminate, 0);
+ defsignal (SIGUSR1, "SIGUSR1", dfl_terminate, 0);
+ defsignal (SIGUSR2, "SIGUSR2", dfl_terminate, 0);
+ defsignal (SIGABRT, "SIGABRT", dfl_terminate, CORE_DUMP);
+ defsignal (SIGIO, "SIGIO", dfl_ignore, 0);
+ defsignal (SIGURG, "SIGURG", dfl_ignore, 0);
+ defsignal (SIGVTALRM, "SIGVTALRM", dfl_terminate, 0);
+ defsignal (SIGPROF, "SIGPROF", dfl_terminate, 0);
+ defsignal (SIGSTOP, "SIGSTOP", dfl_stop, (NOIGNORE | NOBLOCK | NOCATCH));
+ defsignal (SIGTSTP, "SIGTSTP", dfl_stop, 0);
+ defsignal (SIGCONT, "SIGCONT", dfl_ignore, (NOIGNORE | NOBLOCK));
+ defsignal (SIGCHLD, "SIGCHLD", dfl_ignore, 0);
+ defsignal (SIGTTIN, "SIGTTIN", dfl_stop, 0);
+ defsignal (SIGTTOU, "SIGTTOU", dfl_stop, 0);
+#ifdef OS_SPECIFIC_SIGNALS
+ OS_SPECIFIC_SIGNALS ();
+#endif
+}
+\f
+/* Signal Handlers */
+
+#ifndef NEED_HANDLER_TRANSACTION
+
+#define DEFUN_STD_HANDLER(name, statement) \
+static Tsignal_handler_result \
+DEFUN (name, (signo, code, pscp), \
+ int signo AND \
+ int code AND \
+ struct SIGCONTEXT * pscp) \
+{ \
+ int STD_HANDLER_abortp; \
+ DECLARE_FULL_SIGCONTEXT (scp); \
+ INITIALIZE_FULL_SIGCONTEXT (pscp, scp); \
+ STD_HANDLER_abortp = (enter_interruption_extent ()); \
+ statement; \
+ if (STD_HANDLER_abortp) \
+ exit_interruption_extent (); \
+ SIGNAL_HANDLER_RETURN (); \
+}
+
+#else /* NEED_HANDLER_TRANSACTION */
+
+struct handler_record
+{
+ int signo;
+ Tsignal_handler handler;
+}
+
+#define DEFUN_STD_HANDLER(name, statement) \
+static Tsignal_handler_result \
+DEFUN (name, (signo, code, pscp), \
+ int signo AND \
+ int code AND \
+ struct SIGCONTEXT * pscp) \
+{ \
+ int STD_HANDLER_abortp; \
+ DECLARE_FULL_SIGCONTEXT (scp); \
+ INITIALIZE_FULL_SIGCONTEXT (pscp, scp); \
+ ENTER_HANDLER (signo); \
+ STD_HANDLER_abortp = (enter_interruption_extent ()); \
+ transaction_begin (); \
+ { \
+ struct handler_record * record = \
+ (dstack_alloc (sizeof (struct handler_record))); \
+ (record -> signo) = signo; \
+ (record -> handler) = handler; \
+ transaction_record_action (tat_abort, ta_abort_handler, record); \
+ } \
+ statement; \
+ if (STD_HANDLER_abortp) \
+ { \
+ transaction_abort (); \
+ exit_interruption_extent (); \
+ } \
+ transaction_commit (); \
+ EXIT_HANDLER (signo, name); \
+ SIGNAL_HANDLER_RETURN (); \
+}
+
+static void
+DEFUN (ta_abort_handler, (ap), PTR ap)
+{
+ ABORT_HANDLER ((((struct handler_record *) ap) -> signo),
+ (((struct handler_record *) ap) -> handler));
+}
+
+#endif /* NEED_HANDLER_TRANSACTION */
+\f
+#define CONTROL_B_INTERRUPT_CHAR 'B'
+#define CONTROL_G_INTERRUPT_CHAR 'G'
+#define CONTROL_U_INTERRUPT_CHAR 'U'
+#define CONTROL_X_INTERRUPT_CHAR 'X'
+
+static void
+DEFUN (echo_keyboard_interrupt, (c, dc), cc_t c AND cc_t dc)
+{
+ if (c == (OS_ctty_disabled_char ()))
+ c = dc;
+ c &= 0177;
+ if (c == ALERT_CHAR)
+ putc (c, stdout);
+ else if (c < '\040')
+ {
+ putc ('^', stdout);
+ putc ((c + '@'), stdout);
+ }
+ else if (c == '\177')
+ fputs ("^?", stdout);
+ else
+ putc (c, stdout);
+ fflush (stdout);
+}
+
+DEFUN_STD_HANDLER (sighnd_control_g,
+ {
+ echo_keyboard_interrupt ((OS_ctty_int_char ()), ALERT_CHAR);
+ tty_set_next_interrupt_char (CONTROL_G_INTERRUPT_CHAR);
+ })
+
+static void EXFUN
+ (interactive_interrupt_handler, (struct FULL_SIGCONTEXT * scp));
+
+DEFUN_STD_HANDLER (sighnd_interactive,
+ (interactive_interrupt_handler (scp)))
+
+void
+DEFUN_VOID (OS_restartable_exit)
+{
+ if (UX_SC_JOB_CONTROL ())
+ {
+ BLOCK_SIGNALS_DECLARE ();
+ BLOCK_SIGNALS (SIGTSTP);
+ OS_save_internal_state ();
+ OS_restore_external_state ();
+ {
+ Tsignal_handler handler = (current_handler (SIGTSTP));
+ INSTALL_HANDLER (SIGTSTP, SIG_DFL);
+ UX_kill ((UX_getpid ()), SIGTSTP);
+ INSTALL_HANDLER (SIGTSTP, handler);
+ }
+ OS_save_external_state ();
+ OS_restore_internal_state ();
+ UNBLOCK_SIGNALS ();
+ }
+}
+
+DEFUN_STD_HANDLER (sighnd_stop,
+ (OS_restartable_exit ()))
+
+#ifdef HAVE_ITIMER
+
+DEFUN_STD_HANDLER (sighnd_timer,
+ {
+ request_timer_interrupt ();
+ })
+
+#else /* not HAVE_ITIMER */
+
+extern void EXFUN (reschedule_alarm, (void));
+
+DEFUN_STD_HANDLER (sighnd_timer,
+ {
+ reschedule_alarm ();
+ request_timer_interrupt ();
+ })
+
+#endif /* HAVE_ITIMER */
+
+DEFUN_STD_HANDLER (sighnd_save_then_terminate,
+ (request_suspend_interrupt ()))
+
+DEFUN_STD_HANDLER (sighnd_terminate,
+ (termination_signal
+ ((! (parent_process_is_emacs && (signo == SIGHUP)))
+ ? (find_signal_name (signo))
+ : 0)))
+\f
+DEFUN_STD_HANDLER (sighnd_fpe,
+ {
+ if (executing_scheme_primitive_p ())
+ error_floating_point_exception ();
+ trap_handler ("floating-point exception", signo, code, scp);
+ })
+
+DEFUN_STD_HANDLER (sighnd_hardware_trap,
+ (trap_handler ("hardware fault", signo, code, scp)))
+
+DEFUN_STD_HANDLER (sighnd_software_trap,
+ (trap_handler ("system software fault", signo, code, scp)))
+
+#ifdef HAVE_NICE
+
+#ifndef NICE_DELTA
+#define NICE_DELTA 5
+#endif
+
+DEFUN_STD_HANDLER (sighnd_renice,
+ {
+ fprintf (stderr, "\n;;; Renicing! New nice value = %d\n",
+ ((nice (NICE_DELTA)) + 20));
+ fflush (stderr);
+ })
+
+#endif /* HAVE_NICE */
+
+/* When a child process terminates, it becomes a zombie until its
+ parent process calls one of the wait() routines to obtain the
+ child's termination status. The SIGCHLD handler must always call
+ wait() or waitpid() to permit the child process's resources to be
+ freed. */
+
+/* On systems with waitpid() (i.e. those that support WNOHANG) we must
+ loop until there are no more processes, because some of those
+ systems may deliver only one SIGCHLD when more than one child
+ terminates. Systems without waitpid() (e.g. _SYSV) typically
+ provide queuing of SIGCHLD such that one SIGCHLD is delivered for
+ every child that terminates. Systems that provide neither
+ waitpid() nor queuing are so losing that we can't win, in which
+ case we just hope that child terminations don't happen too close to
+ one another to cause problems. */
+
+void EXFUN ((*subprocess_death_hook), (pid_t pid, wait_status_t * status));
+
+#ifdef HAVE_WAITPID
+#define WAITPID(status) (UX_waitpid ((-1), (status), (WNOHANG | WUNTRACED)))
+#define BREAK
+#else
+#define WAITPID(status) (UX_wait (status))
+#define BREAK break
+#endif
+
+DEFUN_STD_HANDLER (sighnd_dead_subprocess,
+ {
+ while (1)
+ {
+ wait_status_t status;
+ pid_t pid = (WAITPID (&status));
+ if (pid <= 0)
+ break;
+ if (subprocess_death_hook != 0)
+ (*subprocess_death_hook) (pid, (&status));
+ BREAK;
+ }
+ })
+\f
+/* Signal Bindings */
+
+static void
+DEFUN (bind_handler, (signo, handler),
+ int signo AND
+ Tsignal_handler handler)
+{
+ if ((signo != 0) &&
+ ((handler != sighnd_stop) || (UX_SC_JOB_CONTROL ())) &&
+ ((current_handler (signo)) == SIG_DFL))
+ INSTALL_HANDLER (signo, handler);
+}
+
+void
+DEFUN_VOID (UX_initialize_signals)
+{
+ subprocess_death_hook = 0;
+ initialize_signal_descriptors ();
+ bind_handler (SIGINT, sighnd_control_g);
+ bind_handler (SIGFPE, sighnd_fpe);
+ bind_handler (SIGALRM, sighnd_timer);
+ bind_handler (SIGVTALRM, sighnd_timer);
+ bind_handler (SIGUSR1, sighnd_save_then_terminate);
+#ifdef HAVE_NICE
+ bind_handler (SIGUSR2, sighnd_renice);
+#endif
+ bind_handler (SIGCHLD, sighnd_dead_subprocess);
+ if ((isatty (STDIN_FILENO)) || parent_process_is_emacs)
+ {
+ if (!parent_process_is_emacs)
+ bind_handler (SIGHUP, sighnd_save_then_terminate);
+ bind_handler (SIGQUIT, sighnd_interactive);
+ bind_handler (SIGPWR, sighnd_save_then_terminate);
+ bind_handler (SIGTSTP, sighnd_stop);
+ bind_handler (SIGILL, sighnd_hardware_trap);
+ bind_handler (SIGTRAP, sighnd_hardware_trap);
+ bind_handler (SIGBUS, sighnd_hardware_trap);
+ bind_handler (SIGSEGV, sighnd_hardware_trap);
+ bind_handler (SIGIOT, sighnd_software_trap);
+ bind_handler (SIGEMT, sighnd_software_trap);
+ bind_handler (SIGSYS, sighnd_software_trap);
+ bind_handler (SIGABRT, sighnd_software_trap);
+ bind_handler (SIGPROF, sighnd_software_trap);
+ }
+ {
+ struct signal_descriptor * scan = signal_descriptors;
+ struct signal_descriptor * end = (scan + signal_descriptors_length);
+ while (scan < end)
+ {
+ if (((scan -> flags) & NOCATCH) == 0)
+ switch (scan -> action)
+ {
+ case dfl_terminate:
+ bind_handler ((scan -> signo), sighnd_terminate);
+ break;
+ case dfl_stop:
+ bind_handler ((scan -> signo), sighnd_stop);
+ break;
+ }
+ scan += 1;
+ }
+ }
+}
+\f
+/* Interactive Interrupt Handler */
+
+static void EXFUN (print_interactive_help, (void));
+static void EXFUN (print_interrupt_chars, (void));
+static void EXFUN (examine_memory, (void));
+static void EXFUN (reset_query, (struct FULL_SIGCONTEXT * scp));
+
+#define INTERACTIVE_NEWLINE() \
+{ \
+ if (!parent_process_is_emacs) \
+ { \
+ putc ('\n', stdout); \
+ fflush (stdout); \
+ } \
+}
+
+static void
+DEFUN (interactive_interrupt_handler, (scp), struct FULL_SIGCONTEXT * scp)
+{
+ if (!parent_process_is_emacs)
+ {
+ fputs ((OS_tty_command_beep ()), stdout);
+ putc ('\n', stdout);
+ fflush (stdout);
+ }
+ while (1)
+ {
+ if (!parent_process_is_emacs)
+ {
+ fprintf (stdout, "Interrupt option (? for help): ");
+ fflush (stdout);
+ }
+ switch (userio_read_char_raw ())
+ {
+ case '\002': /* C-B */
+ case 'B':
+ case 'b':
+ tty_set_next_interrupt_char (CONTROL_B_INTERRUPT_CHAR);
+ return;
+ case '\003': /* C-C */
+ case '\007': /* C-G */
+ case 'G':
+ case 'g':
+ tty_set_next_interrupt_char (CONTROL_G_INTERRUPT_CHAR);
+ return;
+ case '\025': /* C-U */
+ case 'U':
+ case 'u':
+ tty_set_next_interrupt_char (CONTROL_U_INTERRUPT_CHAR);
+ return;
+ case '\030': /* C-X */
+ case 'X':
+ case 'x':
+ tty_set_next_interrupt_char (CONTROL_X_INTERRUPT_CHAR);
+ return;
+ case 'E':
+ case 'e':
+ INTERACTIVE_NEWLINE ();
+ examine_memory ();
+ return;
+ case 'D':
+ case 'd':
+ INTERACTIVE_NEWLINE ();
+ debug_edit_flags ();
+ return;
+ case 'T':
+ case 't':
+ INTERACTIVE_NEWLINE ();
+ debug_back_trace ();
+ return;
+ case 'Z':
+ case 'z':
+ INTERACTIVE_NEWLINE ();
+ OS_restartable_exit ();
+ return;
+ case 'Q':
+ case 'q':
+ INTERACTIVE_NEWLINE ();
+ termination_normal ();
+ return;
+ case '\f':
+ if (!parent_process_is_emacs)
+ {
+ fputs ((OS_tty_command_clear ()), stdout);
+ fflush (stdout);
+ }
+ return;
+ case 'R':
+ case 'r':
+ reset_query (scp);
+ return;
+ case 'H':
+ case 'h':
+ if (!parent_process_is_emacs)
+ print_interrupt_chars ();
+ break;
+ case 'I':
+ case 'i':
+ if (!parent_process_is_emacs)
+ {
+ fputs ("Ignored. Resuming Scheme.\n", stdout);
+ fflush (stdout);
+ }
+ return;
+ default:
+ if (!parent_process_is_emacs)
+ print_interactive_help ();
+ break;
+ }
+ }
+}
+\f
+static enum interrupt_handler
+DEFUN (encode_interrupt_handler, (handler), Tsignal_handler handler)
+{
+ return
+ ((handler == sighnd_control_g) ? interrupt_handler_control_g
+ : (handler == sighnd_interactive) ? interrupt_handler_interactive
+ : (handler == sighnd_stop) ? interrupt_handler_stop
+ : (handler == sighnd_terminate) ? interrupt_handler_terminate
+ : (handler == SIG_IGN) ? interrupt_handler_ignore
+ : (handler == SIG_DFL) ? interrupt_handler_default
+ : interrupt_handler_unknown);
+}
+
+static Tsignal_handler
+DEFUN (decode_interrupt_handler, (encoding), enum interrupt_handler encoding)
+{
+ return
+ ((encoding == interrupt_handler_control_g) ? sighnd_control_g
+ : (encoding == interrupt_handler_interactive) ? sighnd_interactive
+ : (encoding == interrupt_handler_stop) ? sighnd_stop
+ : (encoding == interrupt_handler_terminate) ? sighnd_terminate
+ : (encoding == interrupt_handler_ignore) ? SIG_IGN
+ : (encoding == interrupt_handler_default) ? SIG_DFL
+ : 0);
+}
+
+enum interrupt_handler
+DEFUN_VOID (OS_signal_quit_handler)
+{
+ return (encode_interrupt_handler (current_handler (SIGQUIT)));
+}
+
+enum interrupt_handler
+DEFUN_VOID (OS_signal_int_handler)
+{
+ return (encode_interrupt_handler (current_handler (SIGINT)));
+}
+
+enum interrupt_handler
+DEFUN_VOID (OS_signal_tstp_handler)
+{
+ return
+ ((UX_SC_JOB_CONTROL ())
+ ? (encode_interrupt_handler (current_handler (SIGTSTP)))
+ : interrupt_handler_ignore);
+}
+
+void
+DEFUN (OS_signal_set_interrupt_handlers,
+ (quit_handler, int_handler, tstp_handler),
+ enum interrupt_handler quit_handler AND
+ enum interrupt_handler int_handler AND
+ enum interrupt_handler tstp_handler)
+{
+ {
+ Tsignal_handler handler = (decode_interrupt_handler (quit_handler));
+ if (handler != 0)
+ INSTALL_HANDLER (SIGQUIT, handler);
+ }
+ {
+ Tsignal_handler handler = (decode_interrupt_handler (int_handler));
+ if (handler != 0)
+ INSTALL_HANDLER (SIGINT, handler);
+ }
+ if (UX_SC_JOB_CONTROL ())
+ {
+ Tsignal_handler handler = (decode_interrupt_handler (tstp_handler));
+ if (handler != 0)
+ INSTALL_HANDLER (SIGTSTP, handler);
+ }
+}
+\f
+static void
+DEFUN (describe_sighnd, (signo, c), int signo AND unsigned char c)
+{
+ switch (encode_interrupt_handler (current_handler (signo)))
+ {
+ case interrupt_handler_control_g:
+ fputs ("When typed, scheme will get the ^G character interrupt.\n",
+ stdout);
+ fputs ("The default action is to abort the running program,\n", stdout);
+ fputs ("and to resume the top level read-eval-print loop.\n", stdout);
+ break;
+ case interrupt_handler_interactive:
+ fputs ("When typed, various interrupt options are offered.\n", stdout);
+ fprintf (stdout, "Type %s followed by `?' for a list of options.\n",
+ (char_description (c, 0)));
+ break;
+ case interrupt_handler_terminate:
+ describe_terminate:
+ fputs ("When typed, scheme will terminate.\n", stdout);
+ break;
+ case interrupt_handler_stop:
+ describe_stop:
+ fputs ("When typed, scheme will suspend execution.\n", stdout);
+ break;
+ case interrupt_handler_ignore:
+ describe_ignore:
+ fputs ("When typed, this character will be ignored.\n", stdout);
+ break;
+ case interrupt_handler_default:
+ {
+ struct signal_descriptor * descriptor =
+ (find_signal_descriptor (signo));
+ if (descriptor != 0)
+ switch (descriptor -> action)
+ {
+ case dfl_ignore: goto describe_ignore;
+ case dfl_stop: goto describe_stop;
+ case dfl_terminate: goto describe_terminate;
+ }
+ }
+ default:
+ fputs ("When typed, this character will have an unknown effect.\n",
+ stdout);
+ break;
+ }
+}
+\f
+static void
+DEFUN_VOID (print_interrupt_chars)
+{
+ {
+ unsigned char quit_char = (OS_ctty_quit_char ());
+ fprintf (stdout, "\n\nThe quit character is %s.\n",
+ (char_description (quit_char, 1)));
+ describe_sighnd (SIGQUIT, quit_char);
+ }
+ {
+ unsigned char int_char = (OS_ctty_int_char ());
+ fprintf (stdout, "\nThe interrupt character is %s.\n",
+ (char_description (int_char, 1)));
+ describe_sighnd (SIGINT, int_char);
+ }
+ if (UX_SC_JOB_CONTROL ())
+ {
+ unsigned char tstp_char = (OS_ctty_tstp_char ());
+ fprintf (stdout, "\nThe terminal stop character is %s.\n",
+ (char_description (tstp_char, 1)));
+ describe_sighnd (SIGTSTP, tstp_char);
+ }
+ putc ('\n', stdout);
+ fflush (stdout);
+}
+
+static void
+DEFUN_VOID (print_interactive_help)
+{
+ fputs ("\n\n", stdout);
+ fputs ("B: Enter a breakpoint loop.\n", stdout);
+ fputs ("D: Debugging: change interpreter flags.\n", stdout);
+ fputs ("E: Examine memory location.\n", stdout);
+ fputs ("G: Goto to top level read-eval-print (REP) loop.\n", stdout);
+ fputs ("H: Print simple information on interrupts.\n", stdout);
+ fputs ("I: Ignore interrupt request.\n", stdout);
+ fputs ("Q: Quit instantly, killing Scheme.\n", stdout);
+ fputs ("R: Hard reset, possibly killing Scheme in the process.\n", stdout);
+ fputs ("T: Stack trace.\n", stdout);
+ fputs ("U: Up to previous (lower numbered) REP loop.\n", stdout);
+ fputs ("X: Abort to current REP loop.\n", stdout);
+ if (UX_SC_JOB_CONTROL ())
+ fputs ("Z: Quit instantly, suspending Scheme.\n", stdout);
+ fputs ("^L: Clear the screen.\n", stdout);
+ fputs ("\n", stdout);
+}
+\f
+static void
+DEFUN (reset_query, (scp), struct FULL_SIGCONTEXT * scp)
+{
+ putc ('\n', stdout);
+ fflush (stdout);
+ if (WITHIN_CRITICAL_SECTION_P ())
+ {
+ static CONST char * reset_choices [] =
+ {
+ "D = delay reset until the end of the critical section",
+ "N = attempt reset now",
+ "P = punt reset",
+ 0
+ };
+ fprintf (stdout,
+ "Scheme is executing within critical section \"%s\".\n",
+ (CRITICAL_SECTION_NAME ()));
+ fputs ("Resetting now is likely to kill Scheme.\n", stdout);
+ fflush (stdout);
+ switch (userio_choose_option
+ ("Choose one of the following actions:",
+ "Action -> ",
+ reset_choices))
+ {
+ case 'D':
+ SET_CRITICAL_SECTION_HOOK (soft_reset);
+ return;
+ case 'N':
+ CLEAR_CRITICAL_SECTION_HOOK ();
+ EXIT_CRITICAL_SECTION ({});
+ hard_reset (scp);
+ case 'P':
+ default:
+ return;
+ }
+ }
+ if (userio_confirm ("Do you really want to reset? [Y or N] "))
+ hard_reset (scp);
+}
+
+static void
+DEFUN_VOID (examine_memory)
+{
+ char input_string [256];
+ fputs ("Enter location to examine (0x prefix for hex): ", stdout);
+ fflush (stdout);
+ {
+ transaction_begin ();
+ userio_buffered_input ();
+ {
+ char * scan = input_string;
+ char * end = (input_string + (sizeof (input_string)));
+ while (scan < end)
+ {
+ char c = (userio_read_char ());
+ (*scan) = c;
+ if (c == '\n')
+ c = '\0';
+ if (c == '\0')
+ break;
+ scan += 1;
+ }
+ }
+ transaction_commit ();
+ }
+ {
+ long input;
+ if (((((input_string[0]) == '0') && ((input_string[1]) == 'x'))
+ ? (sscanf ((&input_string[2]), "%lx", (&input)))
+ : (sscanf (input_string, "%ld", (&input))))
+ == 1)
+ debug_examine_memory (input, "contents");
+ }
+ putc ('\n', stdout);
+ fflush (stdout);
+}
+\f
+#ifdef sun3
+
+/* This code assumes that it is called very soon, before
+ any registers except fp have been clobbered.
+
+ It also assumes that it is called directly by the
+ handler, so that the original fp can be found
+ by indirecting through fp twice.
+
+ The trampoline routine saves d0, d1, a0, and a1
+ before invoking the handler.
+
+ The magic constant of 276 was found by poking with adb. */
+
+static void
+DEFUN (sun3_save_regs, (regs), int * regs)
+{
+ asm ("\n\
+ movel a6@(8),a0\n\
+ movel a6@,a1\n\
+\n\
+ movel a1@(276),a0@\n\
+ movel a1@(280),a0@(4)\n\
+ movel d2,a0@(8)\n\
+ movel d3,a0@(12)\n\
+ movel d4,a0@(16)\n\
+ movel d5,a0@(20)\n\
+ movel d6,a0@(24)\n\
+ movel d7,a0@(28)\n\
+\n\
+ movel a1@(284),a0@(32)\n\
+ movel a1@(288),a0@(36)\n\
+ movel a2,a0@(40)\n\
+ movel a3,a0@(44)\n\
+ movel a4,a0@(48)\n\
+ movel a5,a0@(52)\n\
+ movel a1@,a0@(56)\n\
+ ");
+}
+
+#endif /* sun3 */
+\f
+#ifdef vax
+
+static int
+DEFUN_VOID (vax_get_r0)
+{
+ /* This is a kludge. It relies on r0 being the return value register. */
+ asm ("ret");
+}
+
+static int *
+DEFUN (vax_save_start, (regs, r0), int * regs AND int r0)
+{
+ asm ("movl fp,-(sp)");
+ asm ("movl 4(ap),fp");
+ asm ("movl 8(ap),(fp)");
+ asm ("movl r1,4(fp)");
+ asm ("movl r2,8(fp)");
+ asm ("movl r3,12(fp)");
+ asm ("movl r4,16(fp)");
+ asm ("movl r5,20(fp)");
+ asm ("movl r6,24(fp)");
+ asm ("movl r7,28(fp)");
+ asm ("movl r8,32(fp)");
+ asm ("movl r9,36(fp)");
+ asm ("movl r10,40(fp)");
+ asm ("movl r11,44(fp)");
+ asm ("movl (sp)+,fp");
+ asm ("movl 12(fp),r0");
+ asm ("ret");
+}
+
+static void
+DEFUN (vax_save_finish, (fp, pscp, scp),
+ int * fp AND
+ struct sigcontext * pscp AND
+ struct full_sigcontext * scp)
+{
+ (scp -> fs_original) = pscp;
+#ifndef _ULTRIX
+ /* For now, ap and fp undefined. */
+ ((scp -> fs_regs) [12]) = (pscp -> sc_ap);
+ ((scp -> fs_regs) [13]) = (pscp -> sc_fp);
+#endif
+ ((scp -> fs_regs) [14]) = (pscp -> sc_sp);
+ ((scp -> fs_regs) [15]) = (pscp -> sc_pc);
+ {
+ int reg_number = 0;
+ unsigned long reg_mask = (((fp[1]) >> 16) & 0x0fff);
+ int stack_index = 5;
+ while (reg_mask != 0)
+ {
+ if ((reg_mask & 1) != 0)
+ ((scp -> fs_regs) [reg_number]) = (fp[stack_index++]);
+ reg_number += 1;
+ reg_mask = ((reg_mask >> 1) & 0x0fff);
+ }
+ }
+}
+
+#endif /* vax */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxsock.c,v 1.1 1990/06/20 19:37:32 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+
+#ifdef HAVE_SOCKETS
+
+#include <sys/socket.h>
+#include <netinet/in.h>
+#include <netdb.h>
+#ifdef HAVE_UNIX_SOCKETS
+#include <sys/un.h>
+#endif
+#include "uxsock.h"
+#include "uxio.h"
+\f
+Tchannel
+DEFUN (OS_open_tcp_stream_socket, (host, port), PTR host AND int port)
+{
+ int s;
+ STD_UINT_SYSTEM_CALL ("socket", s, (UX_socket (AF_INET, SOCK_STREAM, 0)));
+ {
+ struct sockaddr_in address;
+ (address . sin_family) = AF_INET;
+ (address . sin_port) = port;
+ (address . sin_addr . s_addr) = (* ((unsigned long *) host));
+ STD_VOID_SYSTEM_CALL
+ ("connect", (UX_connect (s, (&address), (sizeof (address)))));
+ }
+ MAKE_CHANNEL (s, channel_type_tcp_stream_socket, return);
+}
+
+int
+DEFUN (OS_get_service_by_name, (service_name, protocol_name),
+ CONST char * service_name AND
+ CONST char * protocol_name)
+{
+ struct servent * entry = (UX_getservbyname (service_name, protocol_name));
+ return ((entry == 0) ? (-1) : (entry -> s_port));
+}
+
+struct host_addresses *
+DEFUN (OS_get_host_by_name, (host_name), CONST char * host_name)
+{
+ static struct host_addresses result;
+ struct hostent * entry = (UX_gethostbyname (host_name));
+ if (entry == 0)
+ return (0);
+ (result . address_length) = (entry -> h_length);
+#ifndef USE_HOSTENT_ADDR
+ (result . addresses) = (entry -> h_addr_list);
+#else
+ {
+ static char * addresses [2];
+ (addresses[0]) = (entry -> h_addr);
+ (addresses[1]) = 0;
+ (result . addresses) = addresses;
+ }
+#endif
+ return (&result);
+}
+
+#ifdef HAVE_UNIX_SOCKETS
+
+Tchannel
+DEFUN (OS_open_unix_stream_socket, (filename), CONST char * filename)
+{
+ int s;
+ STD_UINT_SYSTEM_CALL ("socket", s, (UX_socket (AF_UNIX, SOCK_STREAM, 0)));
+ {
+ struct sockaddr_un address;
+ (address . sun_family) = AF_UNIX;
+ strncpy ((address . sun_path), filename, (sizeof (address . sun_path)));
+ STD_VOID_SYSTEM_CALL
+ ("connect", (UX_connect (s, (&address), (sizeof (address)))));
+ }
+ MAKE_CHANNEL (s, channel_type_unix_stream_socket, return);
+}
+
+#endif /* HAVE_UNIX_SOCKETS */
+
+#endif /* HAVE_SOCKETS */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxsock.h,v 1.1 1990/06/20 19:37:35 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_UXSOCK_H
+#define SCM_UXSOCK_H
+
+#include "os.h"
+
+struct host_addresses
+{
+ int address_length;
+ char ** addresses;
+};
+
+extern Tchannel EXFUN (OS_open_tcp_stream_socket, (PTR host, int port));
+extern int EXFUN
+ (OS_get_service_by_name,
+ (CONST char * service_name, CONST char * protocol_name));
+extern struct host_addresses * EXFUN
+ (OS_get_host_by_name, (CONST char * host_name));
+
+#ifdef HAVE_UNIX_SOCKETS
+extern Tchannel EXFUN (OS_open_unix_stream_socket, (CONST char * filename));
+#endif
+
+#endif /* SCM_UXSOCK_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxterm.c,v 1.1 1990/06/20 19:37:38 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+#include "uxterm.h"
+#include "uxio.h"
+\f
+struct terminal_state
+{
+ int buffer;
+#if defined(HAVE_TERMIOS) || defined(HAVE_TERMIO)
+ char saved_echo;
+ cc_t saved_vmin;
+ cc_t saved_vtime;
+#endif
+};
+
+static struct terminal_state * terminal_table;
+#define TERMINAL_BUFFER(channel) ((terminal_table[(channel)]) . buffer)
+#if defined(HAVE_TERMIOS) || defined(HAVE_TERMIO)
+#define TERMINAL_ECHO(channel) ((terminal_table[(channel)]) . saved_echo)
+#define TERMINAL_VMIN(channel) ((terminal_table[(channel)]) . saved_vmin)
+#define TERMINAL_VTIME(channel) ((terminal_table[(channel)]) . saved_vtime)
+#endif
+
+void
+DEFUN_VOID (UX_initialize_terminals)
+{
+ terminal_table =
+ (UX_malloc (OS_channel_table_size * (sizeof (struct terminal_state))));
+ if (terminal_table == 0)
+ {
+ fprintf (stderr, "\nUnable to allocate terminal table.\n");
+ fflush (stderr);
+ termination_init_error ();
+ }
+}
+
+/* This is called from the file-opening code. */
+void
+DEFUN (terminal_open, (channel), Tchannel channel)
+{
+ (TERMINAL_BUFFER (channel)) = (-1);
+#if defined(HAVE_TERMIOS) || defined(HAVE_TERMIO)
+ {
+ Ttty_state s;
+#ifdef HAVE_TERMIOS
+ struct termios * tio = (&s);
+#else
+ struct termio * tio = (& (s . tio));
+#endif
+ get_terminal_state (channel, (&s));
+ (TERMINAL_ECHO (channel)) = (((tio -> c_lflag) & ECHO) != 0);
+ (TERMINAL_VMIN (channel)) = ((tio -> c_cc) [VMIN]);
+ (TERMINAL_VTIME (channel)) = ((tio -> c_cc) [VTIME]);
+ }
+#endif
+}
+
+int
+DEFUN (OS_terminal_read_char, (channel), Tchannel channel)
+{
+ {
+ int c = (TERMINAL_BUFFER (channel));
+ if (c >= 0)
+ {
+ (TERMINAL_BUFFER (channel)) = (-1);
+ return (c);
+ }
+ }
+ return (OS_channel_read_char_interruptably (channel));
+}
+\f
+int
+DEFUN (terminal_state_buffered_p, (s), Ttty_state * s)
+{
+#if defined(HAVE_TERMIOS) || defined(HAVE_TERMIO)
+#ifdef HAVE_TERMIOS
+ struct termios * tio = s;
+#else
+ struct termio * tio = (& (s -> tio));
+#endif
+ return (((tio -> c_lflag) & ICANON) != 0);
+#else /* not HAVE_TERMIOS nor HAVE_TERMIO */
+#ifdef HAVE_BSD_TTY_DRIVER
+ return (((s -> sg . sg_flags) & CBREAK) == 0);
+#endif /* HAVE_BSD_TTY_DRIVER */
+#endif /* HAVE_TERMIOS or HAVE_TERMIO */
+}
+
+void
+DEFUN (terminal_state_buffered, (s, channel),
+ Ttty_state * s AND
+ Tchannel channel)
+{
+#if defined(HAVE_TERMIOS) || defined(HAVE_TERMIO)
+#ifdef HAVE_TERMIOS
+ struct termios * tio = s;
+#else
+ struct termio * tio = (& (s -> tio));
+#endif
+ (tio -> c_lflag) |= ICANON;
+ if (TERMINAL_ECHO (channel))
+ (tio -> c_lflag) |= ECHO;
+ ((tio -> c_cc) [VMIN]) = (TERMINAL_VMIN (channel));
+ ((tio -> c_cc) [VTIME]) = (TERMINAL_VTIME (channel));
+#else /* not HAVE_TERMIOS nor HAVE_TERMIO */
+#ifdef HAVE_BSD_TTY_DRIVER
+ (s -> sg . sg_flags) &=~ CBREAK;
+#endif /* HAVE_BSD_TTY_DRIVER */
+#endif /* HAVE_TERMIOS or HAVE_TERMIO */
+}
+
+void
+DEFUN (terminal_state_nonbuffered, (s, polling),
+ Ttty_state * s AND int polling)
+{
+#if defined(HAVE_TERMIOS) || defined(HAVE_TERMIO)
+#ifdef HAVE_TERMIOS
+ struct termios * tio = s;
+#else
+ struct termio * tio = (& (s -> tio));
+#endif
+ (tio -> c_lflag) &=~ (ICANON | ECHO);
+ ((tio -> c_cc) [VMIN]) = (polling ? 0 : 1);
+ ((tio -> c_cc) [VTIME]) = 0;
+#else /* not HAVE_TERMIOS nor HAVE_TERMIO */
+#ifdef HAVE_BSD_TTY_DRIVER
+ (s -> sg . sg_flags) |= CBREAK;
+#endif /* HAVE_BSD_TTY_DRIVER */
+#endif /* HAVE_TERMIOS or HAVE_TERMIO */
+}
+
+void
+DEFUN (terminal_state_raw, (s), Ttty_state * s)
+{
+#if defined(HAVE_TERMIOS) || defined(HAVE_TERMIO)
+#ifdef HAVE_TERMIOS
+ struct termios * tio = s;
+#else
+ struct termio * tio = (& (s -> tio));
+#endif
+ (tio -> c_lflag) &=~ (ICANON | ECHO | ISIG);
+ ((tio -> c_cc) [VMIN]) = 1;
+ ((tio -> c_cc) [VTIME]) = 0;
+#else /* not HAVE_TERMIOS nor HAVE_TERMIO */
+#ifdef HAVE_BSD_TTY_DRIVER
+ (s -> sg . sg_flags) |= RAW;
+#endif /* HAVE_BSD_TTY_DRIVER */
+#endif /* HAVE_TERMIOS or HAVE_TERMIO */
+}
+\f
+void
+DEFUN (get_terminal_state, (channel, s), Tchannel channel AND Ttty_state * s)
+{
+ STD_VOID_SYSTEM_CALL
+ ("tty_get_state",
+ (UX_terminal_get_state ((CHANNEL_DESCRIPTOR (channel)), s)));
+}
+
+void
+DEFUN (set_terminal_state, (channel, s), Tchannel channel AND Ttty_state * s)
+{
+ STD_VOID_SYSTEM_CALL
+ ("tty_set_state",
+ (UX_terminal_set_state ((CHANNEL_DESCRIPTOR (channel)), s)));
+}
+
+struct terminal_state_record
+{
+ Tchannel channel;
+ Ttty_state state;
+};
+
+static void
+DEFUN (restore_terminal_state, (ap), PTR ap)
+{
+ set_terminal_state ((((struct terminal_state_record *) ap) -> channel),
+ (& (((struct terminal_state_record *) ap) -> state)));
+}
+
+Ttty_state *
+DEFUN (preserve_terminal_state, (channel), Tchannel channel)
+{
+ struct terminal_state_record * record =
+ (dstack_alloc (sizeof (struct terminal_state_record)));
+ (record -> channel) = channel;
+ get_terminal_state (channel, (& (record -> state)));
+ transaction_record_action (tat_always, restore_terminal_state, record);
+ return (& (record -> state));
+}
+\f
+#ifdef HAVE_FIONREAD
+/* This covers HAVE_BSD_TTY_DRIVER and some others. */
+
+int
+DEFUN (OS_terminal_char_ready_p, (channel, delay),
+ Tchannel channel AND clock_t delay)
+{
+ clock_t limit;
+ if (delay > 0)
+ limit = ((OS_real_time_clock ()) + delay);
+ while (1)
+ {
+ long n;
+ int scr;
+ INTERRUPTABLE_EXTENT
+ (scr, (UX_ioctl ((CHANNEL_DESCRIPTOR (channel)), FIONREAD, (&n))));
+ if (scr < 0)
+ UX_prim_check_errno ("ioctl_FIONREAD");
+ else if (n > 0)
+ return (1);
+ else if ((delay <= 0) || ((OS_real_time_clock ()) >= limit))
+ return (0);
+ }
+}
+
+#else /* not HAVE_FIONREAD */
+#if defined(HAVE_TERMIO) || defined(HAVE_TERMIOS)
+
+int
+DEFUN (OS_terminal_char_ready_p, (channel, delay),
+ Tchannel channel AND clock_t delay)
+{
+ clock_t limit;
+ if (delay > 0)
+ limit = ((OS_real_time_clock ()) + delay);
+ transaction_begin ();
+ {
+ /* Must split declaration and assignment because some compilers
+ do not permit aggregate initializers. */
+ Ttty_state s;
+ s = (* (preserve_terminal_state (channel)));
+ terminal_state_nonbuffered ((&s), 1);
+ set_terminal_state (channel, (&s));
+ }
+ while (1)
+ {
+ unsigned char c;
+ int nread;
+ INTERRUPTABLE_EXTENT
+ (nread, (UX_read ((CHANNEL_DESCRIPTOR (channel)), (&c), 1)));
+ if (nread < 0)
+ UX_prim_check_errno ("read");
+ else if (nread == 1)
+ {
+ (TERMINAL_BUFFER (channel)) = c;
+ transaction_commit ();
+ return (1);
+ }
+ if ((delay <= 0) || ((OS_real_time_clock ()) >= limit))
+ {
+ transaction_commit ();
+ return (0);
+ }
+ }
+}
+
+#endif /* HAVE_TERMIO or HAVE_TERMIOS */
+#endif /* HAVE_FIONREAD */
+\f
+int
+DEFUN (OS_terminal_buffered_p, (channel), Tchannel channel)
+{
+ Ttty_state s;
+ get_terminal_state (channel, (&s));
+ return (terminal_state_buffered_p (&s));
+}
+
+void
+DEFUN (OS_terminal_buffered, (channel), Tchannel channel)
+{
+ Ttty_state s;
+ get_terminal_state (channel, (&s));
+ terminal_state_buffered ((&s), channel);
+ set_terminal_state (channel, (&s));
+}
+
+void
+DEFUN (OS_terminal_nonbuffered, (channel), Tchannel channel)
+{
+ Ttty_state s;
+ get_terminal_state (channel, (&s));
+ terminal_state_nonbuffered ((&s), 0);
+ set_terminal_state (channel, (&s));
+}
+
+void
+DEFUN (OS_terminal_flush_input, (channel), Tchannel channel)
+{
+ STD_VOID_SYSTEM_CALL
+ ("tcflush", (UX_tcflush ((CHANNEL_DESCRIPTOR (channel)), TCIFLUSH)));
+}
+
+void
+DEFUN (OS_terminal_flush_output, (channel), Tchannel channel)
+{
+ STD_VOID_SYSTEM_CALL
+ ("tcflush", (UX_tcflush ((CHANNEL_DESCRIPTOR (channel)), TCOFLUSH)));
+}
+
+void
+DEFUN (OS_terminal_drain_output, (channel), Tchannel channel)
+{
+ STD_VOID_SYSTEM_CALL
+ ("tcdrain", (UX_tcdrain (CHANNEL_DESCRIPTOR (channel))));
+}
+\f
+#ifdef HAVE_PTYS
+
+/* Open an available pty, putting channel in (*ptyv),
+ and return the file name of the pty. Return 0 if none available. */
+
+CONST char *
+DEFUN (OS_open_pty_master, (master_fd, master_fname),
+ Tchannel * master_fd AND
+ CONST char ** master_fname)
+{
+ struct stat stb;
+ register int c;
+ register int i;
+ char master_name [24];
+ char slave_name [24];
+ int fd;
+#ifdef PTY_ITERATION
+ PTY_ITERATION
+#else
+ for (c = FIRST_PTY_LETTER; (c <= 'z'); c += 1)
+ for (i = 0; (i < 16); i += 1)
+#endif
+ {
+#ifdef PTY_NAME_SPRINTF
+ PTY_NAME_SPRINTF
+#else
+ sprintf (master_name, "/dev/pty%c%x", c, i);
+#endif
+ retry_open:
+ fd = (UX_open (master_name, O_RDWR, 0));
+ if (fd < 0)
+ {
+ if (errno == EACCES)
+ return (0);
+ if (errno != EINTR)
+ continue;
+ deliver_pending_interrupts ();
+ goto retry_open;
+ }
+ /* check to make certain that both sides are available
+ this avoids a nasty yet stupid bug in rlogins */
+#ifdef PTY_TTY_NAME_SPRINTF
+ PTY_TTY_NAME_SPRINTF
+#else
+ sprintf (slave_name, "/dev/tty%c%x", c, i);
+#endif
+ if ((UX_access (slave_name, (R_OK | W_OK))) < 0)
+ {
+ UX_close (fd);
+ continue;
+ }
+ MAKE_CHANNEL (fd, channel_type_pty_master, (*master_fd) =);
+ (*master_fname) = master_name;
+ return (slave_name);
+ }
+ return (0);
+}
+
+void
+DEFUN (OS_pty_master_send_signal, (channel, sig), Tchannel channel AND int sig)
+{
+#ifdef _HPUX
+ STD_VOID_SYSTEM_CALL
+ ("ioctl_TIOCSIGSEND",
+ (UX_ioctl ((CHANNEL_DESCRIPTOR (channel)), TIOCSIGSEND, sig)));
+#else /* not _HPUX */
+#ifdef HAVE_BSD_JOB_CONTROL
+ int fd = (CHANNEL_DESCRIPTOR (channel));
+ int gid;
+ STD_VOID_SYSTEM_CALL ("ioctl_TIOCGPGRP", (UX_ioctl (fd, TIOCGPGRP, (&gid))));
+ STD_VOID_SYSTEM_CALL ("kill", (UX_kill ((-gid), sig)));
+#else /* not HAVE_BSD_JOB_CONTROL */
+ error_unimplemented_primitive ();
+#endif /* HAVE_BSD_JOB_CONTROL */
+#endif /* _HPUX */
+}
+
+#else /* not HAVE_PTYS */
+
+CONST char *
+DEFUN (OS_open_pty_master, (master_fd, master_fname),
+ Tchannel * master_fd AND
+ CONST char ** master_fname)
+{
+ return (0);
+}
+
+void
+DEFUN (OS_pty_master_send_signal, (channel, sig), Tchannel channel AND int sig)
+{
+ error_unimplemented_primitive ();
+}
+
+#endif /* HAVE_PTYS */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxterm.h,v 1.1 1990/06/20 19:37:42 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_UXTERM_H
+#define SCM_UXTERM_H
+
+#include "osterm.h"
+
+extern int EXFUN (terminal_state_buffered_p, (Ttty_state * s));
+extern void EXFUN
+ (terminal_state_buffered, (Ttty_state * s, Tchannel channel));
+extern void EXFUN (terminal_state_nonbuffered, (Ttty_state * s, int polling));
+extern void EXFUN (terminal_state_raw, (Ttty_state * s));
+extern void EXFUN (get_terminal_state, (Tchannel channel, Ttty_state * s));
+extern void EXFUN (set_terminal_state, (Tchannel channel, Ttty_state * s));
+extern Ttty_state * EXFUN (preserve_terminal_state, (Tchannel channel));
+
+#endif /* SCM_UXTERM_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtop.c,v 1.1 1990/06/20 19:37:45 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+#include "uxtop.h"
+#include "osctty.h"
+#include "uxutil.h"
+#include "errors.h"
+
+extern void EXFUN (UX_initialize_channels, (void));
+extern void EXFUN (UX_initialize_ctty, (int interactive));
+extern void EXFUN (UX_initialize_directory_reader, (void));
+extern void EXFUN (UX_initialize_environment, (void));
+extern void EXFUN (UX_initialize_processes, (void));
+extern void EXFUN (UX_initialize_signals, (void));
+extern void EXFUN (UX_initialize_terminals, (void));
+extern void EXFUN (UX_initialize_trap_recovery, (void));
+extern void EXFUN (UX_initialize_tty, (void));
+extern void EXFUN (UX_initialize_userio, (void));
+
+extern void EXFUN (OS_initialize_transcript_file, (void));
+
+extern void EXFUN (UX_ctty_save_external_state, (void));
+extern void EXFUN (UX_ctty_save_internal_state, (void));
+extern void EXFUN (UX_ctty_restore_internal_state, (void));
+extern void EXFUN (UX_ctty_restore_external_state, (void));
+
+/* reset_interruptable_extent */
+
+extern CONST char * OS_Name;
+extern CONST char * OS_Variant;
+\f
+int parent_process_is_emacs;
+static int interactive;
+
+int
+DEFUN_VOID (OS_under_emacs_p)
+{
+ return (parent_process_is_emacs);
+}
+
+void
+DEFUN_VOID (OS_initialize)
+{
+ dstack_initialize ();
+ transaction_initialize ();
+ initialize_interruptable_extent ();
+ parent_process_is_emacs = (boolean_option_argument ("-emacs"));
+ {
+ interactive =
+ ((isatty (STDIN_FILENO)) ||
+ (isatty (STDOUT_FILENO)) ||
+ (isatty (STDERR_FILENO)) ||
+ (boolean_option_argument ("-interactive")));
+ /* If none of the stdio streams is a terminal, disassociate us
+ from the controlling terminal so that we're not affected by
+ keyboard interrupts or hangup signals. However, if we're
+ running under Emacs we don't want to do this, because we want
+ to receive a hangup signal if Emacs dies. */
+ if ((!interactive) && (!parent_process_is_emacs))
+ UX_setsid ();
+ /* The argument passed to `UX_ctty_initialize' says whether to
+ permit interrupt control, i.e. whether to attempt to setup the
+ keyboard interrupt characters. */
+ UX_initialize_ctty (interactive);
+ }
+ UX_initialize_channels ();
+ UX_initialize_terminals ();
+ UX_initialize_processes ();
+ UX_initialize_environment ();
+ UX_initialize_tty ();
+ UX_initialize_userio ();
+ UX_initialize_signals ();
+ UX_initialize_trap_recovery ();
+ UX_initialize_directory_reader ();
+ OS_initialize_transcript_file ();
+ OS_Name = SYSTEM_NAME;
+ OS_Variant = SYSTEM_VARIANT;
+ fprintf (stdout, "MIT Scheme running under %s\n", OS_Variant);
+ if ((!parent_process_is_emacs) && (OS_ctty_interrupt_control ()))
+ {
+ fputs ("", stdout);
+ fprintf (stdout, "Type %s followed by `H' to obtain information about interrupts.\n",
+ (char_description ((OS_ctty_quit_char ()), 1)));
+ }
+ fflush (stdout);
+#ifdef _SUNOS
+ vadvise (VA_ANOM); /* Anomolous paging, don't try to guess. */
+#endif
+}
+
+void
+DEFUN (OS_quit, (code, abnormal_p), int code AND int abnormal_p)
+{
+ fflush (stdout);
+ if (abnormal_p
+ && interactive
+ && (! ((code == TERM_SIGNAL) || (code == TERM_EOF))))
+ {
+ fputs ("\nScheme has terminated abnormally!\n", stdout);
+ {
+ int dump_core =
+ ((! (boolean_option_argument ("-nocore")))
+ && (userio_confirm ("Would you like a core dump? [Y or N] "))
+ && (userio_confirm ("Do you really want a core dump? [Y or N] ")));
+ putc ('\n', stdout);
+ fflush (stdout);
+ if (dump_core)
+ UX_dump_core ();
+ }
+ }
+ OS_restore_external_state ();
+}
+
+void
+DEFUN_VOID (UX_dump_core)
+{
+ OS_restore_external_state ();
+ /* Unmask this too? */
+ UX_signal (SIGABRT, SIG_DFL);
+ UX_abort ();
+}
+
+void
+DEFUN_VOID (OS_save_external_state)
+{
+ UX_ctty_save_external_state ();
+}
+
+void
+DEFUN_VOID (OS_save_internal_state)
+{
+ UX_ctty_save_internal_state ();
+}
+
+void
+DEFUN_VOID (OS_restore_internal_state)
+{
+ UX_ctty_restore_internal_state ();
+}
+
+void
+DEFUN_VOID (OS_restore_external_state)
+{
+ UX_ctty_restore_external_state ();
+}
+
+void
+DEFUN (error_system_call, (code, name), int code AND CONST char * name)
+{
+ /* Improve this so that the code and name information is available
+ to the Scheme error handler. */
+ extern char * sys_errlist [];
+ extern int sys_nerr;
+ if ((code >= 0) && (code <= sys_nerr))
+ fprintf (stderr, "\nerror in system call: %s: %s\n", (sys_errlist [code]));
+ else
+ fprintf (stderr, "\nunknown error %d in system call: %s\n", code);
+ fflush (stderr);
+ error_external_return ();
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtop.h,v 1.1 1990/06/20 19:37:51 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_UXTOP_H
+#define SCM_UXTOP_H
+
+#include "ostop.h"
+
+extern void EXFUN (UX_dump_core, (void));
+
+#endif /* SCM_UXTOP_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtrap.c,v 1.1 1990/06/20 19:37:56 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "scheme.h"
+#include "ux.h"
+#include "uxtrap.h"
+#include "uxutil.h"
+
+extern CONST char * EXFUN (find_signal_name, (int signo));
+extern void EXFUN (UX_dump_core, (void));
+extern PTR initial_C_stack_pointer;
+\f
+static enum trap_state trap_state;
+static enum trap_state user_trap_state;
+
+static enum trap_state saved_trap_state;
+static int saved_signo;
+static int saved_code;
+static struct FULL_SIGCONTEXT * saved_scp;
+
+static void EXFUN
+ (continue_from_trap, (int signo, int code, struct FULL_SIGCONTEXT * scp));
+
+void
+DEFUN_VOID (UX_initialize_trap_recovery)
+{
+ trap_state = trap_state_recover;
+ user_trap_state = trap_state_recover;
+}
+
+enum trap_state
+DEFUN (OS_set_trap_state, (state), enum trap_state state)
+{
+ enum trap_state old_trap_state = user_trap_state;
+ user_trap_state = state;
+ trap_state = state;
+ return (old_trap_state);
+}
+
+static void
+DEFUN_VOID (trap_immediate_termination)
+{
+ OS_restore_external_state ();
+ exit (1);
+}
+
+static void
+DEFUN_VOID (trap_dump_core)
+{
+ if (boolean_option_argument ("-nocore"))
+ {
+ fputs (">> Core dumps are disabled - Terminating normally.\n", stdout);
+ fflush (stdout);
+ termination_trap ();
+ }
+ else
+ UX_dump_core ();
+}
+
+static void
+DEFUN_VOID (trap_recover)
+{
+ if (WITHIN_CRITICAL_SECTION_P ())
+ {
+ CLEAR_CRITICAL_SECTION_HOOK ();
+ EXIT_CRITICAL_SECTION ({});
+ }
+ reset_interruptable_extent ();
+ continue_from_trap (saved_signo, saved_code, saved_scp);
+}
+\f
+void
+DEFUN (trap_handler, (message, signo, code, scp),
+ CONST char * message AND
+ int signo AND
+ int code AND
+ struct FULL_SIGCONTEXT * scp)
+{
+ enum trap_state old_trap_state = trap_state;
+ trap_state = trap_state_trapped;
+ if (WITHIN_CRITICAL_SECTION_P ())
+ {
+ fprintf (stdout,
+ "\n>> A %s has occurred within critical section \"%s\".\n",
+ message, (CRITICAL_SECTION_NAME ()));
+ fprintf (stdout, ">> [signal %d (%s), code %d]\n",
+ signo, (find_signal_name (signo)), code);
+ }
+ else if (old_trap_state != trap_state_recover)
+ {
+ fprintf (stdout, "\n>> A %s has occurred.\n", message);
+ fprintf (stdout, ">> [signal %d (%s), code %d]\n",
+ signo, (find_signal_name (signo)), code);
+ }
+ fflush (stdout);
+ switch (old_trap_state)
+ {
+ case trap_state_trapped:
+ if ((saved_trap_state == trap_state_recover) ||
+ (saved_trap_state == trap_state_query))
+ {
+ fputs (">> The trap occurred while processing an earlier trap.\n",
+ stdout);
+ fprintf (stdout,
+ ">> [The earlier trap raised signal %d (%s), code %d.]\n",
+ saved_signo,
+ (find_signal_name (saved_signo)),
+ saved_code);
+ fputs (((WITHIN_CRITICAL_SECTION_P ())
+ ? ">> Successful recovery is extremely unlikely.\n"
+ : ">> Successful recovery is unlikely.\n"),
+ stdout);
+ break;
+ }
+ else
+ trap_immediate_termination ();
+ case trap_state_recover:
+ if (WITHIN_CRITICAL_SECTION_P ())
+ {
+ fputs (">> Successful recovery is unlikely.\n", stdout);
+ break;
+ }
+ else
+ trap_recover ();
+ case trap_state_exit:
+ termination_trap ();
+ }
+ fflush (stdout);
+ saved_trap_state = old_trap_state;
+ saved_signo = signo;
+ saved_code = code;
+ saved_scp = scp;
+ while (1)
+ {
+ static CONST char * trap_query_choices[] =
+ {
+ "D = dump core",
+ "I = terminate immediately",
+ "N = terminate normally",
+ "R = attempt recovery",
+ "Q = terminate normally",
+ 0
+ };
+ switch (userio_choose_option
+ ("Choose one of the following actions:",
+ "Action -> ",
+ trap_query_choices))
+ {
+ case 'I':
+ trap_immediate_termination ();
+ case 'D':
+ trap_dump_core ();
+ case 'N':
+ case 'Q':
+ termination_trap ();
+ case 'R':
+ trap_recover ();
+ }
+ }
+}
+\f
+#define STATE_UNKNOWN (LONG_TO_UNSIGNED_FIXNUM (0))
+#define STATE_PRIMITIVE (LONG_TO_UNSIGNED_FIXNUM (1))
+#define STATE_COMPILED_CODE (LONG_TO_UNSIGNED_FIXNUM (2))
+#define STATE_PROBABLY_COMPILED (LONG_TO_UNSIGNED_FIXNUM (3))
+
+struct trap_recovery_info
+{
+ SCHEME_OBJECT state;
+ SCHEME_OBJECT pc_info_1;
+ SCHEME_OBJECT pc_info_2;
+ SCHEME_OBJECT extra_trap_info;
+};
+
+static struct trap_recovery_info dummy_recovery_info =
+{
+ STATE_UNKNOWN,
+ SHARP_F,
+ SHARP_F,
+ SHARP_F
+};
+
+static void
+DEFUN (setup_trap_frame, (signo, code, info, new_stack_pointer),
+ int signo AND
+ int code AND
+ struct trap_recovery_info * info AND
+ SCHEME_OBJECT * new_stack_pointer)
+{
+ SCHEME_OBJECT handler;
+ SCHEME_OBJECT signal_name;
+ int stack_recovered_p = (new_stack_pointer != 0);
+ long saved_mask = (FETCH_INTERRUPT_MASK ());
+ SET_INTERRUPT_MASK (0); /* To prevent GC for now. */
+ if ((! (Valid_Fixed_Obj_Vector ())) ||
+ ((handler = (Get_Fixed_Obj_Slot (Trap_Handler))) == SHARP_F))
+ {
+ fprintf (stderr, "There is no trap handler for recovery!\n");
+ fflush (stderr);
+ termination_trap ();
+ }
+ signal_name =
+ ((signo == 0)
+ ? SHARP_F
+ : (char_pointer_to_string (find_signal_name (signo))));
+ if (Free > MemTop)
+ {
+ Request_GC (0);
+ }
+ History = (Make_Dummy_History ());
+ if (!stack_recovered_p)
+ {
+ Initialize_Stack ();
+ Will_Push (CONTINUATION_SIZE);
+ Store_Return (RC_END_OF_COMPUTATION);
+ Store_Expression (SHARP_F);
+ Save_Cont ();
+ Pushed ();
+ }
+ else
+ Stack_Pointer = new_stack_pointer;
+ Will_Push ((6 + CONTINUATION_SIZE) + (STACK_ENV_EXTRA_SLOTS + 2));
+ STACK_PUSH (info -> extra_trap_info);
+ STACK_PUSH (info -> pc_info_2);
+ STACK_PUSH (info -> pc_info_1);
+ STACK_PUSH (info -> state);
+ STACK_PUSH (BOOLEAN_TO_OBJECT (stack_recovered_p));
+ STACK_PUSH (long_to_integer (code));
+ STACK_PUSH (signal_name);
+ Store_Return (RC_HARDWARE_TRAP);
+ Store_Expression (long_to_integer (signo));
+ Save_Cont ();
+ STACK_PUSH (signal_name);
+ STACK_PUSH (handler);
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
+ Pushed ();
+ SET_INTERRUPT_MASK (saved_mask);
+ abort_to_interpreter (PRIM_APPLY);
+}
+\f
+/* 0 is an invalid signal, it means a user requested reset. */
+
+void
+DEFUN (hard_reset, (scp), struct FULL_SIGCONTEXT * scp)
+{
+ continue_from_trap (0, 0, scp);
+}
+
+/* Called synchronously. */
+
+void
+DEFUN_VOID (soft_reset)
+{
+ struct trap_recovery_info info;
+ SCHEME_OBJECT * new_stack_pointer =
+ (((Stack_Pointer <= Stack_Top) && (Stack_Pointer > Stack_Guard))
+ ? Stack_Pointer
+ : 0);
+ if ((Regs[REGBLOCK_PRIMITIVE]) != SHARP_F)
+ {
+ (info . state) = STATE_PRIMITIVE;
+ (info . pc_info_1) = (Regs[REGBLOCK_PRIMITIVE]);
+ (info . pc_info_2) =
+ (LONG_TO_UNSIGNED_FIXNUM (Regs[REGBLOCK_LEXPR_ACTUALS]));
+ (info . extra_trap_info) = SHARP_F;
+ }
+ else
+ {
+ (info . state) = STATE_UNKNOWN;
+ (info . pc_info_1) = SHARP_F;
+ (info . pc_info_2) = SHARP_F;
+ (info . extra_trap_info) = SHARP_F;
+ }
+ if ((Free >= Heap_Top) || (Free < Heap_Bottom))
+ /* Let's hope this works. */
+ Free = MemTop;
+ setup_trap_frame (0, 0, (&info), new_stack_pointer);
+}
+
+#if !defined(HAVE_SIGCONTEXT) || !defined(HAS_COMPILER_SUPPORT) || defined(USE_STACKLETS)
+
+static void
+DEFUN (continue_from_trap, (signo, code, scp),
+ int signo AND
+ int code AND
+ struct FULL_SIGCONTEXT * scp)
+{
+ if (Free < MemTop)
+ Free = MemTop;
+ setup_trap_frame (signo, code, (&dummy_recovery_info), 0);
+}
+
+#else /* HAVE_SIGCONTEXT and HAS_COMPILER_SUPPORT and not USE_STACKLETS*/
+\f
+/* Heuristic recovery from Unix signals (traps).
+
+ continue_from_trap attempts to:
+
+ 1) validate the trap information (pc and sp);
+ 2) determine whether compiled code was executing, a primitive was
+ executing, or execution was in the interpreter;
+ 3) guess what C global state is still valid; and
+ 4) set up a recovery frame for the interpreter so that debuggers can
+ display more information. */
+
+#include "gccode.h"
+
+#define SCHEME_ALIGNMENT_MASK ((sizeof (long)) - 1)
+#define STACK_ALIGNMENT_MASK SCHEME_ALIGNMENT_MASK
+#define PC_ALIGNMENT_MASK ((1 << PC_ZERO_BITS) - 1)
+#define FREE_PARANOIA_MARGIN 0x100
+
+#define C_STACK_SIZE 0x01000000
+
+#ifdef HAS_COMPILER_SUPPORT
+#define ALLOW_ONLY_C 0
+#else
+#define ALLOW_ONLY_C 1
+#define PLAUSIBLE_CC_BLOCK_P(block) 0
+#endif
+
+static SCHEME_OBJECT * EXFUN
+ (find_block_address, (char * pc_value, SCHEME_OBJECT * area_start));
+
+static void
+DEFUN (continue_from_trap, (signo, code, scp),
+ int signo AND
+ int code AND
+ struct FULL_SIGCONTEXT * scp)
+{
+ int pc_in_C;
+ int pc_in_heap;
+ int pc_in_constant_space;
+ int pc_in_scheme;
+ int pc_in_hyper_space;
+ int sp_in_C;
+ int sp_in_scheme;
+ int sp_in_hyper_space;
+ long the_pc = (FULL_SIGCONTEXT_PC (scp));
+ long the_sp = (FULL_SIGCONTEXT_SP (scp));
+ SCHEME_OBJECT * new_stack_pointer;
+ SCHEME_OBJECT * xtra_info;
+ struct trap_recovery_info info;
+ extern long etext;
+ if ((the_pc & PC_ALIGNMENT_MASK) != 0)
+ {
+ pc_in_C = 0;
+ pc_in_heap = 0;
+ pc_in_constant_space = 0;
+ pc_in_scheme = 0;
+ pc_in_hyper_space = 1;
+ }
+ else
+ {
+ pc_in_C = (the_pc <= ((long) (&etext)));
+ pc_in_heap =
+ ((the_pc < ((long) Heap_Top)) && (the_pc >= ((long) Heap_Bottom)));
+ pc_in_constant_space =
+ ((the_pc < ((long) Constant_Top)) &&
+ (the_pc >= ((long) Constant_Space)));
+ pc_in_scheme = (pc_in_heap || pc_in_constant_space);
+ pc_in_hyper_space = ((!pc_in_C) && (!pc_in_scheme));
+ }
+ sp_in_scheme =
+ ((the_sp < ((long) Stack_Top)) &&
+ (the_sp >= ((long) Absolute_Stack_Base)) &&
+ ((the_sp & STACK_ALIGNMENT_MASK) == 0));
+ {
+ long delta = (((char *) the_sp) - ((char *) initial_C_stack_pointer));
+ if (delta < 0)
+ delta = (-delta);
+ sp_in_C = ((!sp_in_scheme) && (delta < C_STACK_SIZE));
+ }
+ sp_in_hyper_space = ((!sp_in_scheme) && (!sp_in_C));
+ new_stack_pointer =
+ (sp_in_C
+ ? (((Stack_Pointer < Stack_Top) && (Stack_Pointer > Absolute_Stack_Base))
+ ? Stack_Pointer
+ : 0)
+ : sp_in_hyper_space
+ ? 0
+ : ((SCHEME_OBJECT *) the_sp));
+ if ((sp_in_hyper_space && pc_in_hyper_space) ||
+ (ALLOW_ONLY_C && pc_in_scheme))
+ {
+ /* In hyper space. */
+ (info . state) = STATE_UNKNOWN;
+ (info . pc_info_1) = SHARP_F;
+ (info . pc_info_2) = SHARP_F;
+ new_stack_pointer = 0;
+ if ((Free < MemTop) ||
+ (Free >= Heap_Top) ||
+ ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
+ Free = MemTop;
+ }
+ else if (pc_in_scheme)
+ {
+ /* In compiled code. */
+ SCHEME_OBJECT * block_addr;
+ SCHEME_OBJECT * maybe_free;
+ block_addr =
+ (find_block_address (((PTR) the_pc),
+ (pc_in_heap ? Heap_Bottom : Constant_Space)));
+ if (block_addr == 0)
+ {
+ (info . state) = STATE_PROBABLY_COMPILED;
+ (info . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (the_pc));
+ (info . pc_info_2) = SHARP_F;
+ if ((Free < MemTop) ||
+ (Free >= Heap_Top) ||
+ ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
+ Free = MemTop;
+ }
+ else
+ {
+ (info . state) = STATE_COMPILED_CODE;
+ (info . pc_info_1) =
+ (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr));
+ (info . pc_info_2) =
+ (LONG_TO_UNSIGNED_FIXNUM (the_pc - ((long) block_addr)));
+#ifdef HAVE_FULL_SIGCONTEXT
+ maybe_free = ((SCHEME_OBJECT *) (FULL_SIGCONTEXT_RFREE (scp)));
+ if (((((unsigned long) maybe_free) & SCHEME_ALIGNMENT_MASK) == 0) &&
+ (maybe_free >= Heap_Bottom) &&
+ (maybe_free < Heap_Top))
+ Free = (maybe_free + FREE_PARANOIA_MARGIN);
+ else
+#endif
+ if ((Free < MemTop) ||
+ (Free >= Heap_Top) ||
+ ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0))
+ Free = MemTop;
+ }
+ }
+ else
+ {
+ /* In the interpreter, a primitive, or a compiled code utility. */
+ SCHEME_OBJECT primitive = (Regs[REGBLOCK_PRIMITIVE]);
+ if ((OBJECT_TYPE (primitive)) != TC_PRIMITIVE)
+ {
+ (info . state) = STATE_UNKNOWN;
+ (info . pc_info_1) = SHARP_F;
+ (info . pc_info_2) = SHARP_F;
+ if (sp_in_scheme)
+ new_stack_pointer = 0;
+ }
+ else
+ {
+ long primitive_address =
+ ((long) (Primitive_Procedure_Table[OBJECT_DATUM (primitive)]));
+ (info . state) = STATE_PRIMITIVE;
+ (info . pc_info_1) = primitive;
+ (info . pc_info_2) =
+ (LONG_TO_UNSIGNED_FIXNUM (Regs[REGBLOCK_LEXPR_ACTUALS]));
+ if (sp_in_scheme)
+ {
+ /* Called from compiled code */
+ if (new_stack_pointer > Stack_Pointer)
+ new_stack_pointer = 0;
+ else if (new_stack_pointer != 0)
+ new_stack_pointer = Stack_Pointer;
+ }
+ }
+ if ((!sp_in_C) ||
+ ((((unsigned long) Free) & SCHEME_ALIGNMENT_MASK) != 0) ||
+ ((Free < Heap_Bottom) || (Free >= Heap_Top)))
+ Free = MemTop;
+ }
+ xtra_info = Free;
+ Free += (1 + 2 + PROCESSOR_NREGS);
+ (info . extra_trap_info) =
+ (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, xtra_info));
+ (*xtra_info++) =
+ (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (2 + PROCESSOR_NREGS)));
+ (*xtra_info++) = ((SCHEME_OBJECT) the_pc);
+ (*xtra_info++) = ((SCHEME_OBJECT) the_sp);
+ {
+ int counter = FULL_SIGCONTEXT_NREGS;
+ int * regs = (FULL_SIGCONTEXT_FIRST_REG (scp));
+ while ((counter--) > 0)
+ (*xtra_info++) = ((SCHEME_OBJECT) (*regs++));
+ }
+ /* We assume that regs,sp,pc is the order in the processor.
+ Scheme can always fix this. */
+ if ((PROCESSOR_NREGS - FULL_SIGCONTEXT_NREGS) > 0)
+ (*xtra_info++) = ((SCHEME_OBJECT) the_sp);
+ if ((PROCESSOR_NREGS - FULL_SIGCONTEXT_NREGS) > 1)
+ (*xtra_info++) = ((SCHEME_OBJECT) the_pc);
+ setup_trap_frame (signo, code, (&info), new_stack_pointer);
+}
+\f
+/* Find the compiled code block in area which contains `pc_value'.
+ This attempts to be more efficient than `find_block_address_in_area'.
+ If the pointer is in the heap, it can actually do twice as
+ much work, but it is expected to pay off on the average. */
+
+static SCHEME_OBJECT * EXFUN
+ (find_block_address_in_area, (char * pc_value, SCHEME_OBJECT * area_start));
+
+#define MINIMUM_SCAN_RANGE 2048
+
+static SCHEME_OBJECT *
+DEFUN (find_block_address, (pc_value, area_start),
+ char * pc_value AND
+ SCHEME_OBJECT * area_start)
+{
+ if (area_start == Constant_Space)
+ {
+ extern SCHEME_OBJECT * EXFUN
+ (find_constant_space_block, (SCHEME_OBJECT *));
+ SCHEME_OBJECT * constant_block =
+ (find_constant_space_block
+ ((SCHEME_OBJECT *)
+ (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK)));
+ return
+ ((constant_block == 0)
+ ? 0
+ : (find_block_address_in_area (pc_value, constant_block)));
+ }
+ {
+ SCHEME_OBJECT * nearest_word =
+ ((SCHEME_OBJECT *)
+ (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK));
+ long maximum_distance = (nearest_word - area_start);
+ long distance = maximum_distance;
+ while ((distance / 2) > MINIMUM_SCAN_RANGE)
+ distance = (distance / 2);
+ while ((distance * 2) < maximum_distance)
+ {
+ SCHEME_OBJECT * block =
+ (find_block_address_in_area (pc_value, (nearest_word - distance)));
+ if (block != 0)
+ return (block);
+ distance *= 2;
+ }
+ }
+ return (find_block_address_in_area (pc_value, area_start));
+}
+\f
+/*
+ Find the compiled code block in area which contains `pc_value',
+ by scanning sequentially the complete area.
+ For the time being, skip over manifest closures and linkage sections. */
+
+static SCHEME_OBJECT *
+DEFUN (find_block_address_in_area, (pc_value, area_start),
+ char * pc_value AND
+ SCHEME_OBJECT * area_start)
+{
+ SCHEME_OBJECT * first_valid = area_start;
+ SCHEME_OBJECT * area = area_start;
+ while (((char *) area) < pc_value)
+ {
+ SCHEME_OBJECT object = (*area);
+ switch (OBJECT_TYPE (object))
+ {
+ case TC_LINKAGE_SECTION:
+ {
+ if ((READ_LINKAGE_KIND (object)) != OPERATOR_LINKAGE_KIND)
+ area += ((READ_CACHE_LINKAGE_COUNT (object)) + 1);
+ else
+ {
+ long count = (READ_OPERATOR_LINKAGE_COUNT (object));
+ area = ((END_OPERATOR_LINKAGE_AREA (area, count)) + 1);
+ }
+ break;
+ }
+ case TC_MANIFEST_CLOSURE:
+ {
+ area += 1;
+ {
+ long count = (MANIFEST_CLOSURE_COUNT (area));
+ area = ((MANIFEST_CLOSURE_END (area, count)) + 1);
+ }
+ break;
+ }
+ case TC_MANIFEST_NM_VECTOR:
+ {
+ long count = (OBJECT_DATUM (object));
+ if (((char *) (area + (count + 1))) < pc_value)
+ {
+ area += (count + 1);
+ first_valid = area;
+ break;
+ }
+ {
+ SCHEME_OBJECT * block = (area - 1);
+ return
+ (((area == first_valid) ||
+ ((OBJECT_TYPE (*block)) != TC_MANIFEST_VECTOR) ||
+ ((OBJECT_DATUM (*block)) < (count + 1)) ||
+ (! (PLAUSIBLE_CC_BLOCK_P (block))))
+ ? 0
+ : block);
+ }
+ }
+ }
+ }
+ return (0);
+}
+
+#endif /* HAVE_SIGCONTEXT and HAS_COMPILER_SUPPORT */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtrap.h,v 1.1 1990/06/20 19:38:01 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_UXTRAP_H
+#define SCM_UXTRAP_H
+
+#include "os.h"
+\f
+#ifdef hp9000s300
+
+#include <sys/sysmacros.h>
+#include <machine/sendsig.h>
+#include <machine/reg.h>
+
+#define HAVE_FULL_SIGCONTEXT
+#define PROCESSOR_NREGS 16
+#define FULL_SIGCONTEXT_NREGS GPR_REGS /* Missing sp */
+
+#define RFREE AR5
+#define SIGCONTEXT full_sigcontext
+#define SIGCONTEXT_SP(scp) ((scp)->fs_context.sc_sp)
+#define SIGCONTEXT_PC(scp) ((scp)->fs_context.sc_pc)
+#define FULL_SIGCONTEXT_RFREE(scp) ((scp)->fs_regs[RFREE])
+#define FULL_SIGCONTEXT_FIRST_REG(scp) (&((scp)->fs_regs[GPR_START]))
+
+#endif /* hp9000s300 */
+
+#ifdef hp9000s800
+
+#include <sys/sysmacros.h>
+
+/* See <machine/save_state.h> included by <signal.h> */
+
+#ifndef sc_pc
+/* pcoq is the offset (32 bit in 64 bit virtual address space)
+ in the space included in the corresponding sc_pcsq.
+ head is the current instruction, tail is the next instruction
+ which is not necessarily the following instruction because
+ of delayed branching, etc.
+ Both queues need to be collected for some screw cases of
+ debugging and if there is ever a hope to restart the code.
+ */
+#define sc_pc sc_pcoq_head
+#endif
+
+#define ss_gr0 ss_flags /* not really true */
+#define ss_rfree ss_gr25 /* or some such */
+#define HAVE_FULL_SIGCONTEXT
+#define FULL_SIGCONTEXT_RFREE(scp) ((scp)->sc_sl.sl_ss.ss_rfree)
+#define FULL_SIGCONTEXT_FIRST_REG(scp) (&((scp)->sc_sl.sl_ss.ss_gr0))
+#define FULL_SIGCONTEXT_NREGS 32
+#define PROCESSOR_NREGS 32
+
+#endif /* hp9000s800 */
+
+#ifdef sun3
+
+#define HAVE_FULL_SIGCONTEXT
+#define PROCESSOR_NREGS 16
+#define FULL_SIGCONTEXT_NREGS 15 /* missing sp */
+
+struct full_sigcontext
+{
+ struct sigcontext * fs_original;
+ int fs_regs[FULL_SIGCONTEXT_NREGS];
+};
+
+#define RFREE (8 + 5) /* A5 */
+#define FULL_SIGCONTEXT full_sigcontext
+#define FULL_SIGCONTEXT_SP(scp) (scp->fs_original->sc_sp)
+#define FULL_SIGCONTEXT_PC(scp) (scp->fs_original->sc_pc)
+#define FULL_SIGCONTEXT_RFREE(scp) (scp->fs_regs[RFREE])
+#define FULL_SIGCONTEXT_FIRST_REG(scp) (&((scp)->fs_regs[0]))
+
+#define DECLARE_FULL_SIGCONTEXT(name) \
+ struct FULL_SIGCONTEXT name [1]
+
+#define INITIALIZE_FULL_SIGCONTEXT(partial, full) \
+{ \
+ static void EXFUN (sun3_save_regs, (int * regs)); \
+ sun3_save_regs (& ((((full) [0]) . fs_regs) [0])); \
+ (((full) [0]) . fs_original) = (partial); \
+}
+
+#endif /* sun3 */
+\f
+#ifdef vax
+
+#define HAVE_FULL_SIGCONTEXT
+#define PROCESSOR_NREGS 16
+#define FULL_SIGCONTEXT_NREGS 16
+
+struct full_sigcontext
+{
+ struct sigcontext * fs_original;
+ int fs_regs [FULL_SIGCONTEXT_NREGS];
+};
+
+#define RFREE 12 /* fp */
+#define FULL_SIGCONTEXT full_sigcontext
+#define FULL_SIGCONTEXT_SP(scp) ((scp)->fs_original->sc_sp)
+#define FULL_SIGCONTEXT_PC(scp) ((scp)->fs_original->sc_pc)
+#define FULL_SIGCONTEXT_RFREE(scp) ((scp)->fs_regs[RFREE])
+#define FULL_SIGCONTEXT_FIRST_REG(scp) (&((scp)->fs_regs[0]))
+
+#define DECLARE_FULL_SIGCONTEXT(name) \
+ struct FULL_SIGCONTEXT name [1]
+
+/* r0 has to be kludged. */
+
+#define INITIALIZE_FULL_SIGCONTEXT(partial, full) \
+{ \
+ static int EXFUN (vax_get_r0, (void)); \
+ static int * EXFUN (vax_save_start, (int * regs, int r0)); \
+ static void EXFUN \
+ (vax_save_finish, (int * fp, \
+ struct sigcontext * pscp, \
+ struct full_sigcontext * scp)); \
+ vax_save_finish ((vax_save_start ((& ((((full) [0]) . fs_regs) [0])), \
+ (vax_get_r0 ()))), \
+ (partial), \
+ (&(full)[0])); \
+}
+
+#endif /* vax */
+
+#ifdef mips
+
+/* For now, no compiler */
+/* If the compiler is ever ported, look at <signal.h> */
+
+#define sc_sp (sc_regs[29])
+
+#endif /* mips */
+
+#ifndef SIGCONTEXT
+#define SIGCONTEXT sigcontext
+#define SIGCONTEXT_SP(scp) ((scp)->sc_sp)
+#define SIGCONTEXT_PC(scp) ((scp)->sc_pc)
+#endif /* SIGCONTEXT */
+
+#ifndef FULL_SIGCONTEXT
+
+#define FULL_SIGCONTEXT SIGCONTEXT
+#define FULL_SIGCONTEXT_SP SIGCONTEXT_SP
+#define FULL_SIGCONTEXT_PC SIGCONTEXT_PC
+
+#define DECLARE_FULL_SIGCONTEXT(name) \
+ struct FULL_SIGCONTEXT * name
+
+#define INITIALIZE_FULL_SIGCONTEXT(partial, full) \
+ ((full) = ((struct FULL_SIGCONTEXT *) (partial)))
+
+#endif /* not FULL_SIGCONTEXT */
+
+#ifndef FULL_SIGCONTEXT_NREGS
+#define FULL_SIGCONTEXT_NREGS 0
+#define FULL_SIGCONTEXT_FIRST_REG(scp) ((int *) 0)
+#endif
+
+#ifndef PROCESSOR_NREGS
+#define PROCESSOR_NREGS 0
+#endif
+\f
+enum trap_state
+{
+ trap_state_trapped,
+ trap_state_exit,
+ trap_state_suspend,
+ trap_state_query,
+ trap_state_recover
+};
+
+extern void EXFUN (initialize_trap_recovery, (char * C_sp));
+extern enum trap_state EXFUN (OS_set_trap_state, (enum trap_state state));
+extern void EXFUN
+ (trap_handler,
+ (CONST char * message, int signo, int code, struct FULL_SIGCONTEXT * scp));
+extern void EXFUN (hard_reset, (struct FULL_SIGCONTEXT * scp));
+extern void EXFUN (soft_reset, (void));
+
+#endif /* SCM_UXTRAP_H */
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtty.c,v 1.1 1990/06/20 19:38:04 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+#include "ostty.h"
+#include "osenv.h"
+#include "uxio.h"
+#include "uxterm.h"
+\f
+/* Standard Input */
+
+static Tchannel input_channel;
+
+Tchannel
+DEFUN_VOID (OS_tty_input_channel)
+{
+ return (input_channel);
+}
+
+/* New input interface doesn't require the following, because they
+ can be provided by standard terminal and channel operations. */
+
+static unsigned char
+DEFUN (tty_read_char, (immediate), int immediate)
+{
+ int c;
+ if ((OS_channel_type (input_channel)) == channel_type_terminal)
+ {
+ transaction_begin ();
+ preserve_terminal_state (input_channel);
+ if (immediate)
+ OS_terminal_nonbuffered (input_channel);
+ else
+ OS_terminal_buffered (input_channel);
+ c = (OS_terminal_read_char (input_channel));
+ if (c == (-1))
+ termination_eof ();
+ transaction_commit ();
+ }
+ else
+ {
+ c = (OS_channel_read_char_interruptably (input_channel));
+ if (c == (-1))
+ termination_eof ();
+ if ((OS_channel_type (input_channel)) == channel_type_file)
+ OS_tty_write_char (c);
+ }
+ return ((unsigned char) c);
+}
+
+unsigned char
+DEFUN_VOID (OS_tty_read_char)
+{
+ return (tty_read_char (0));
+}
+
+unsigned char
+DEFUN_VOID (OS_tty_read_char_immediate)
+{
+ return (tty_read_char (1));
+}
+
+int
+DEFUN (OS_tty_char_ready_p, (delay), clock_t delay)
+{
+ if ((OS_channel_type (input_channel)) == channel_type_terminal)
+ return (OS_terminal_char_ready_p (input_channel, delay));
+ if (delay > 0)
+ {
+ clock_t limit = ((OS_real_time_clock ()) + delay);
+ while ((OS_real_time_clock ()) < limit)
+ ;
+ }
+ return (0);
+}
+
+int
+DEFUN (OS_tty_clean_interrupts, (mode, interrupt_char),
+ enum tty_clean_mode mode AND
+ cc_t interrupt_char)
+{
+ if (parent_process_is_emacs && (mode == tty_clean_most_recent))
+ while ((OS_tty_read_char_immediate ()) != '\0')
+ ;
+ return (1);
+}
+\f
+/* Standard Output */
+
+static Tchannel output_channel;
+static int tty_x_size;
+static int tty_y_size;
+static CONST char * tty_command_beep;
+static CONST char * tty_command_clear;
+
+Tchannel
+DEFUN_VOID (OS_tty_output_channel)
+{
+ return (output_channel);
+}
+
+unsigned int
+DEFUN_VOID (OS_tty_x_size)
+{
+ CONST char * columns = (UX_getenv ("COLUMNS"));
+ if (columns != 0)
+ {
+ int x = (atoi (columns));
+ if (x > 0)
+ tty_x_size = x;
+ }
+ return (tty_x_size);
+}
+
+unsigned int
+DEFUN_VOID (OS_tty_y_size)
+{
+ CONST char * lines = (UX_getenv ("LINES"));
+ if (lines != 0)
+ {
+ int y = (atoi (lines));
+ if (y > 0)
+ tty_y_size = y;
+ }
+ return (tty_y_size);
+}
+
+CONST char *
+DEFUN_VOID (OS_tty_command_beep)
+{
+ return (tty_command_beep);
+}
+
+CONST char *
+DEFUN_VOID (OS_tty_command_clear)
+{
+ return (tty_command_clear);
+}
+
+/* Old output interface requires output buffering at the microcode
+ level. The new runtime system will provide the buffering so that
+ the microcode doesn't have to. */
+
+void
+DEFUN (OS_tty_write_char, (c), unsigned char c)
+{
+ if ((OS_channel_write (output_channel, (&c), 1)) != 1)
+ error_external_return ();
+}
+
+void
+DEFUN (OS_tty_write_string, (s), CONST char * s)
+{
+ OS_channel_write_string (output_channel, s);
+}
+
+void
+DEFUN_VOID (OS_tty_beep)
+{
+ OS_channel_write_string (output_channel, tty_command_beep);
+}
+\f
+#ifndef TERMCAP_BUFFER_SIZE
+#define TERMCAP_BUFFER_SIZE 2048
+#endif
+
+#ifndef DEFAULT_TTY_X_SIZE
+#define DEFAULT_TTY_X_SIZE 80
+#endif
+
+#ifndef DEFAULT_TTY_Y_SIZE
+#define DEFAULT_TTY_Y_SIZE 24
+#endif
+
+static char tputs_output [TERMCAP_BUFFER_SIZE];
+static char * tputs_output_scan;
+
+static void
+DEFUN (tputs_write_char, (c), char c)
+{
+ (*tputs_output_scan++) = c;
+}
+
+void
+DEFUN_VOID (UX_initialize_tty)
+{
+ extern Tchannel EXFUN (OS_open_fd, (int fd));
+ input_channel = (OS_open_fd (STDIN_FILENO));
+ (CHANNEL_INTERNAL (input_channel)) = 1;
+ output_channel = (OS_open_fd (STDOUT_FILENO));
+ (CHANNEL_INTERNAL (output_channel)) = 1;
+ tty_x_size = (-1);
+ tty_y_size = (-1);
+ tty_command_beep = ALERT_STRING;
+ tty_command_clear = 0;
+ tputs_output_scan = tputs_output;
+ {
+ extern int EXFUN (tgetent, (PTR, CONST char *));
+ extern int EXFUN (tgetnum, (CONST char *));
+ extern CONST char * EXFUN (tgetstr, (CONST char *, char **));
+ static char tgetstr_buffer [TERMCAP_BUFFER_SIZE];
+ char termcap_buffer [TERMCAP_BUFFER_SIZE];
+ char * tbp = tgetstr_buffer;
+ CONST char * term;
+ if ((isatty (STDOUT_FILENO)) &&
+ (!parent_process_is_emacs) &&
+ ((term = (getenv ("TERM"))) != 0) &&
+ ((tgetent (termcap_buffer, term)) > 0))
+ {
+ tty_x_size = (tgetnum ("co"));
+ tty_y_size = (tgetnum ("li"));
+ tty_command_clear = (tgetstr ("cl", (&tbp)));
+ }
+ }
+ if (tty_x_size == (-1))
+ tty_x_size = DEFAULT_TTY_X_SIZE;
+ if (tty_y_size == (-1))
+ tty_y_size = DEFAULT_TTY_Y_SIZE;
+ if (tty_command_clear == 0)
+ tty_command_clear = "\f";
+ else
+ {
+ char * command = tputs_output_scan;
+ tputs (tty_command_clear, tty_y_size, tputs_write_char);
+ (*tputs_output_scan++) = '\0';
+ tty_command_clear = command;
+ }
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxutil.c,v 1.1 1990/06/20 19:38:07 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include "ux.h"
+#include "uxutil.h"
+#include <ctype.h>
+\f
+static CONST char *
+DEFUN (char_description_brief, (c), unsigned char c)
+{
+ static char buffer [5];
+ switch (c)
+ {
+ case ' ': return ("SPC");
+ case '\t': return ("TAB");
+ case '\r': return ("RET");
+ case '\n': return ("LFD");
+ case '\033': return ("ESC");
+ case '\177': return ("DEL");
+ default:
+ if (c < ' ')
+ {
+ (buffer[0]) = '^';
+ (buffer[1]) = (c + '@');
+ (buffer[2]) = '\0';
+ }
+ else if (c < '\177')
+ {
+ (buffer[0]) = c;
+ (buffer[1]) = '\0';
+ }
+ else
+ {
+ (buffer[0]) = '\\';
+ (buffer[1]) = (c >> 6);
+ (buffer[2]) = ((c >> 3) & 7);
+ (buffer[3]) = (c & 7);
+ (buffer[4]) = '\0';
+ }
+ return (buffer);
+ }
+}
+
+CONST char *
+DEFUN (char_description, (c, long_p), unsigned char c AND int long_p)
+{
+ static char buffer [64];
+ CONST char * description = (char_description_brief (c));
+ if (long_p)
+ {
+ int meta = (c >= 0200);
+ int cc = (c & 0177);
+ int control = (cc < 0040);
+ if (meta || control)
+ {
+ sprintf (buffer, "`%s' (%s%s%c)",
+ description,
+ (meta ? "meta-" : ""),
+ (control ? "control-" : ""),
+ (control ? (cc + 0100) : cc));
+ return (buffer);
+ }
+ }
+ sprintf (buffer, "`%s'", description);
+ return (buffer);
+}
+\f
+static Ttty_state original_tty_state;
+
+void
+DEFUN_VOID (UX_initialize_userio)
+{
+ UX_terminal_get_state (STDIN_FILENO, (&original_tty_state));
+}
+
+static void
+DEFUN (restore_input_state, (ap), PTR ap)
+{
+ UX_terminal_set_state (STDIN_FILENO, ap);
+}
+
+static Ttty_state *
+DEFUN_VOID (save_input_state)
+{
+ Ttty_state * s = (dstack_alloc (sizeof (Ttty_state)));
+ UX_terminal_get_state (STDIN_FILENO, s);
+ transaction_record_action (tat_always, restore_input_state, s);
+ return (s);
+}
+
+void
+DEFUN_VOID (userio_buffered_input)
+{
+ save_input_state ();
+ UX_terminal_set_state (STDIN_FILENO, (&original_tty_state));
+}
+
+char
+DEFUN_VOID (userio_read_char)
+{
+ char c;
+ while (1)
+ {
+ int nread = (UX_read (STDIN_FILENO, (&c), 1));
+ if (nread == 1)
+ break;
+ if ((nread < 0) && (errno != EINTR))
+ {
+ c = '\0';
+ break;
+ }
+ }
+ return (c);
+}
+
+char
+DEFUN_VOID (userio_read_char_raw)
+{
+ transaction_begin ();
+ {
+ /* Must split declaration and assignment because some compilers
+ do not permit aggregate initializers. */
+ Ttty_state state;
+ state = (* (save_input_state ()));
+ terminal_state_raw (&state);
+ UX_terminal_set_state (STDIN_FILENO, (&state));
+ }
+ {
+ char c = (userio_read_char ());
+ transaction_commit ();
+ return (c);
+ }
+}
+\f
+char
+DEFUN (userio_choose_option, (herald, prompt, choices),
+ CONST char * herald AND
+ CONST char * prompt AND
+ CONST char ** choices)
+{
+ while (1)
+ {
+ fputs (herald, stdout);
+ putc ('\n', stdout);
+ {
+ CONST char ** scan = choices;
+ while (1)
+ {
+ CONST char * choice = (*scan++);
+ if (choice == 0)
+ break;
+ fprintf (stdout, " %s\n", choice);
+ }
+ }
+ fputs (prompt, stdout);
+ fflush (stdout);
+ {
+ char command = (userio_read_char_raw ());
+ putc ('\n', stdout);
+ fflush (stdout);
+ if (islower (command))
+ command = (toupper (command));
+ {
+ CONST char ** scan = choices;
+ while (1)
+ {
+ CONST char * choice = (*scan++);
+ if (choice == 0)
+ break;
+ {
+ char option = (*choice);
+ if (islower (option))
+ option = (toupper (option));
+ if (command == option)
+ return (option);
+ }
+ }
+ }
+ }
+ }
+}
+
+int
+DEFUN (userio_confirm, (prompt), CONST char * prompt)
+{
+ while (1)
+ {
+ fputs (prompt, stdout);
+ switch (userio_read_char_raw ())
+ {
+ case 'y':
+ case 'Y':
+ return (1);
+ case 'n':
+ case 'N':
+ return (0);
+ }
+ }
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxutil.h,v 1.1 1990/06/20 19:38:10 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_UXUTIL_H
+#define SCM_UXUTIL_H
+
+#include "os.h"
+
+extern CONST char * EXFUN (char_description, (unsigned char c, int long_p));
+extern void EXFUN (userio_buffered_input, (void));
+extern char EXFUN (userio_read_char, (void));
+extern char EXFUN (userio_read_char_raw, (void));
+extern char EXFUN
+ (userio_choose_option,
+ (CONST char * herald, CONST char * prompt, CONST char ** choices));
+extern int EXFUN (userio_confirm, (CONST char * prompt));
+
+#endif /* SCM_UXUTIL_H */
--- /dev/null
+/* Copyright (C) 1990 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 1, 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 program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/wind.c,v 1.1 1990/06/20 19:38:59 cph Rel $ */
+
+#include <stdio.h>
+#include "obstack.h"
+#include "dstack.h"
+extern void EXFUN (free, (PTR ptr));
+#define obstack_chunk_alloc xmalloc
+#define obstack_chunk_free free
+
+static void
+DEFUN (error, (procedure_name, message),
+ CONST char * procedure_name AND
+ CONST char * message)
+{
+ fprintf (stderr, "%s: %s\n", procedure_name, message);
+ fflush (stderr);
+ abort ();
+}
+
+static PTR
+DEFUN (xmalloc, (length), unsigned int length)
+{
+ extern PTR EXFUN (malloc, (unsigned int length));
+ PTR result = (malloc (length));
+ if (result == 0)
+ error ("malloc", "memory allocation failed");
+ return (result);
+}
+
+struct winding_record
+{
+ struct winding_record * next;
+ void EXFUN ((*protector), (PTR environment));
+ PTR environment;
+};
+
+static struct obstack dstack;
+static struct winding_record * current_winding_record;
+PTR dstack_position;
+
+void
+DEFUN_VOID (dstack_initialize)
+{
+ obstack_init (&dstack);
+ dstack_position = 0;
+ current_winding_record = 0;
+}
+
+void
+DEFUN_VOID (dstack_reset)
+{
+ obstack_free ((&dstack), 0);
+ dstack_initialize ();
+}
+
+#define EXPORT(sp) ((PTR) (((char *) (sp)) + (sizeof (PTR))))
+
+PTR
+DEFUN (dstack_alloc, (length), unsigned int length)
+{
+ PTR chunk = (obstack_alloc ((&dstack), ((sizeof (PTR)) + length)));
+ (* ((PTR *) chunk)) = dstack_position;
+ dstack_position = chunk;
+ return (EXPORT (chunk));
+}
+
+void
+DEFUN (dstack_protect, (protector, environment),
+ void EXFUN ((*protector), (PTR environment)) AND
+ PTR environment)
+{
+ struct winding_record * record =
+ (dstack_alloc (sizeof (struct winding_record)));
+ (record -> next) = current_winding_record;
+ (record -> protector) = protector;
+ (record -> environment) = environment;
+ current_winding_record = record;
+}
+
+void
+DEFUN (dstack_set_position, (position), PTR position)
+{
+ while (dstack_position != position)
+ {
+ if (dstack_position == 0)
+ error ("dstack_set_position", "no more stack");
+ if ((EXPORT (dstack_position)) == current_winding_record)
+ {
+ PTR sp = dstack_position;
+ struct winding_record * record = current_winding_record;
+ (* (record -> protector)) (record -> environment);
+ if (sp != dstack_position)
+ error ("dstack_set_position", "stack slipped during unwind");
+ current_winding_record = (record -> next);
+ }
+ {
+ PTR * sp = dstack_position;
+ dstack_position = (*sp);
+ obstack_free ((&dstack), sp);
+ }
+ }
+}
+
+struct binding_record
+{
+ PTR * location;
+ PTR value;
+};
+
+static void
+DEFUN (undo_binding, (record), PTR record)
+{
+ (* (((struct binding_record *) record) -> location)) =
+ (((struct binding_record *) record) -> value);
+}
+
+void
+DEFUN (dstack_bind, (location, value), PTR location AND PTR value)
+{
+ struct binding_record * record =
+ (dstack_alloc (sizeof (struct binding_record)));
+ (record -> location) = ((PTR *) location);
+ (record -> value) = (* ((PTR *) location));
+ dstack_protect (undo_binding, record);
+ (* ((PTR *) location)) = value;
+}
projects / mit-scheme.git / commitdiff