From: Chris Hanson Date: Wed, 20 Jun 1990 19:38:59 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~11380 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8694aecef997b8ea4c277455e7b2fa8c60324524;p=mit-scheme.git Initial revision --- diff --git a/v7/src/microcode/critsec.h b/v7/src/microcode/critsec.h new file mode 100644 index 000000000..a68565b6e --- /dev/null +++ b/v7/src/microcode/critsec.h @@ -0,0 +1,75 @@ +/* -*-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) diff --git a/v7/src/microcode/dstack.h b/v7/src/microcode/dstack.h new file mode 100644 index 000000000..e29d13649 --- /dev/null +++ b/v7/src/microcode/dstack.h @@ -0,0 +1,194 @@ +/* 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 + +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)); + +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)); + +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__ */ diff --git a/v7/src/microcode/error.c b/v7/src/microcode/error.c new file mode 100644 index 000000000..e62364dbf --- /dev/null +++ b/v7/src/microcode/error.c @@ -0,0 +1,301 @@ +/* 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 +#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); +} + +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); +} + +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); + } +} + +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); + } +} + +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); +} diff --git a/v7/src/microcode/intext.c b/v7/src/microcode/intext.c new file mode 100644 index 000000000..38b7c578b --- /dev/null +++ b/v7/src/microcode/intext.c @@ -0,0 +1,88 @@ +/* -*-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); +} diff --git a/v7/src/microcode/intext.h b/v7/src/microcode/intext.h new file mode 100644 index 000000000..cb1284bed --- /dev/null +++ b/v7/src/microcode/intext.h @@ -0,0 +1,73 @@ +/* -*-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 */ diff --git a/v7/src/microcode/obstack.c b/v7/src/microcode/obstack.c new file mode 100644 index 000000000..f32932772 --- /dev/null +++ b/v7/src/microcode/obstack.c @@ -0,0 +1,329 @@ +/* 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; + +/* 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 + +#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 */ diff --git a/v7/src/microcode/obstack.h b/v7/src/microcode/obstack.h new file mode 100644 index 000000000..81a6666bf --- /dev/null +++ b/v7/src/microcode/obstack.h @@ -0,0 +1,399 @@ +/* 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__ + +/* 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. */ +}; + +#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. */ + +/* 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)) + +#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); }) + +#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__ */ + diff --git a/v7/src/microcode/os.h b/v7/src/microcode/os.h new file mode 100644 index 000000000..581e4ef7c --- /dev/null +++ b/v7/src/microcode/os.h @@ -0,0 +1,43 @@ +/* -*-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 */ diff --git a/v7/src/microcode/oscond.h b/v7/src/microcode/oscond.h new file mode 100644 index 000000000..c114a0b65 --- /dev/null +++ b/v7/src/microcode/oscond.h @@ -0,0 +1,106 @@ +/* -*-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 + +/* _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 + +#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 */ diff --git a/v7/src/microcode/osctty.h b/v7/src/microcode/osctty.h new file mode 100644 index 000000000..3bacb318a --- /dev/null +++ b/v7/src/microcode/osctty.h @@ -0,0 +1,55 @@ +/* -*-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 */ diff --git a/v7/src/microcode/osenv.h b/v7/src/microcode/osenv.h new file mode 100644 index 000000000..6f70ebbd1 --- /dev/null +++ b/v7/src/microcode/osenv.h @@ -0,0 +1,64 @@ +/* -*-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 */ diff --git a/v7/src/microcode/osfile.h b/v7/src/microcode/osfile.h new file mode 100644 index 000000000..0b9dcfae3 --- /dev/null +++ b/v7/src/microcode/osfile.h @@ -0,0 +1,50 @@ +/* -*-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 */ diff --git a/v7/src/microcode/osfs.h b/v7/src/microcode/osfs.h new file mode 100644 index 000000000..86dab6705 --- /dev/null +++ b/v7/src/microcode/osfs.h @@ -0,0 +1,59 @@ +/* -*-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 */ diff --git a/v7/src/microcode/osio.h b/v7/src/microcode/osio.h new file mode 100644 index 000000000..69fc60379 --- /dev/null +++ b/v7/src/microcode/osio.h @@ -0,0 +1,75 @@ +/* -*-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 */ diff --git a/v7/src/microcode/osproc.h b/v7/src/microcode/osproc.h new file mode 100644 index 000000000..525041f51 --- /dev/null +++ b/v7/src/microcode/osproc.h @@ -0,0 +1,83 @@ +/* -*-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 */ diff --git a/v7/src/microcode/osscheme.c b/v7/src/microcode/osscheme.c new file mode 100644 index 000000000..4e1fe75f6 --- /dev/null +++ b/v7/src/microcode/osscheme.c @@ -0,0 +1,105 @@ +/* -*-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" + +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); +} diff --git a/v7/src/microcode/osscheme.h b/v7/src/microcode/osscheme.h new file mode 100644 index 000000000..12b9f915e --- /dev/null +++ b/v7/src/microcode/osscheme.h @@ -0,0 +1,69 @@ +/* -*-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 */ diff --git a/v7/src/microcode/ossig.h b/v7/src/microcode/ossig.h new file mode 100644 index 000000000..27deae556 --- /dev/null +++ b/v7/src/microcode/ossig.h @@ -0,0 +1,60 @@ +/* -*-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 */ diff --git a/v7/src/microcode/osterm.h b/v7/src/microcode/osterm.h new file mode 100644 index 000000000..0d685d155 --- /dev/null +++ b/v7/src/microcode/osterm.h @@ -0,0 +1,52 @@ +/* -*-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 */ diff --git a/v7/src/microcode/ostop.h b/v7/src/microcode/ostop.h new file mode 100644 index 000000000..903ac2eba --- /dev/null +++ b/v7/src/microcode/ostop.h @@ -0,0 +1,49 @@ +/* -*-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 */ diff --git a/v7/src/microcode/ostty.c b/v7/src/microcode/ostty.c new file mode 100644 index 000000000..47b55516e --- /dev/null +++ b/v7/src/microcode/ostty.c @@ -0,0 +1,60 @@ +/* -*-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); + } +} diff --git a/v7/src/microcode/ostty.h b/v7/src/microcode/ostty.h new file mode 100644 index 000000000..93f8e80e8 --- /dev/null +++ b/v7/src/microcode/ostty.h @@ -0,0 +1,79 @@ +/* -*-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 */ diff --git a/v7/src/microcode/posixtyp.h b/v7/src/microcode/posixtyp.h new file mode 100644 index 000000000..0e3e70e32 --- /dev/null +++ b/v7/src/microcode/posixtyp.h @@ -0,0 +1,105 @@ +/* -*-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. */ + +#ifndef SCM_POSIXTYPE_H +#define SCM_POSIXTYPE_H + +#ifdef _POSIX + +#include +#include +#include + +#else /* not _POSIX */ + +#ifdef _UNIX +#include + +#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 */ diff --git a/v7/src/microcode/prosenv.c b/v7/src/microcode/prosenv.c new file mode 100644 index 000000000..051ed2daf --- /dev/null +++ b/v7/src/microcode/prosenv.c @@ -0,0 +1,216 @@ +/* -*-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" + +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) + +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); +} + +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 ())); +} diff --git a/v7/src/microcode/prosfile.c b/v7/src/microcode/prosfile.c new file mode 100644 index 000000000..0f58e0a33 --- /dev/null +++ b/v7/src/microcode/prosfile.c @@ -0,0 +1,127 @@ +/* -*-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 + +#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); +} diff --git a/v7/src/microcode/prosfs.c b/v7/src/microcode/prosfs.c new file mode 100644 index 000000000..82db3a7c5 --- /dev/null +++ b/v7/src/microcode/prosfs.c @@ -0,0 +1,226 @@ +/* -*-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))); \ +} + +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))); +} + +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); +} + +#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); +} diff --git a/v7/src/microcode/prosio.c b/v7/src/microcode/prosio.c new file mode 100644 index 000000000..86a710750 --- /dev/null +++ b/v7/src/microcode/prosio.c @@ -0,0 +1,264 @@ +/* -*-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 + +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))))); +} + +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); +} + +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))); + } + } +} diff --git a/v7/src/microcode/prosproc.c b/v7/src/microcode/prosproc.c new file mode 100644 index 000000000..dfeb537a7 --- /dev/null +++ b/v7/src/microcode/prosproc.c @@ -0,0 +1,302 @@ +/* -*-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)); + +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); +} + +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); + } + } +} + +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); + } +} + +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) diff --git a/v7/src/microcode/prosterm.c b/v7/src/microcode/prosterm.c new file mode 100644 index 000000000..a0e398ab9 --- /dev/null +++ b/v7/src/microcode/prosterm.c @@ -0,0 +1,155 @@ +/* -*-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" + +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); +} diff --git a/v7/src/microcode/prostty.c b/v7/src/microcode/prostty.c new file mode 100644 index 000000000..577bd7b02 --- /dev/null +++ b/v7/src/microcode/prostty.c @@ -0,0 +1,322 @@ +/* -*-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" + +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 ())); +} + +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)); + } +} + +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); +} + +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); +} + +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)); + } +} diff --git a/v7/src/microcode/pruxenv.c b/v7/src/microcode/pruxenv.c new file mode 100644 index 000000000..12088e370 --- /dev/null +++ b/v7/src/microcode/pruxenv.c @@ -0,0 +1,141 @@ +/* -*-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; + +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 ())); +} + +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); + } + } +} diff --git a/v7/src/microcode/pruxsock.c b/v7/src/microcode/pruxsock.c new file mode 100644 index 000000000..444bd4db4 --- /dev/null +++ b/v7/src/microcode/pruxsock.c @@ -0,0 +1,105 @@ +/* -*-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" + +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 */ diff --git a/v7/src/microcode/ptrvec.c b/v7/src/microcode/ptrvec.c new file mode 100644 index 000000000..2b4da5a81 --- /dev/null +++ b/v7/src/microcode/ptrvec.c @@ -0,0 +1,143 @@ +/* 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 +#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); +} diff --git a/v7/src/microcode/term.c b/v7/src/microcode/term.c new file mode 100644 index 000000000..6744e77d0 --- /dev/null +++ b/v7/src/microcode/term.c @@ -0,0 +1,203 @@ +/* -*-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 + +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); +} + +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); +} diff --git a/v7/src/microcode/transact.c b/v7/src/microcode/transact.c new file mode 100644 index 000000000..f162a83f5 --- /dev/null +++ b/v7/src/microcode/transact.c @@ -0,0 +1,118 @@ +/* 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 +#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); + } +} diff --git a/v7/src/microcode/ux.c b/v7/src/microcode/ux.c new file mode 100644 index 000000000..cafcdd2a6 --- /dev/null +++ b/v7/src/microcode/ux.c @@ -0,0 +1,403 @@ +/* -*-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" + +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 */ + +#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 */ + +#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 */ + +#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 */ + +#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 */ + +#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 */ diff --git a/v7/src/microcode/ux.h b/v7/src/microcode/ux.h new file mode 100644 index 000000000..8a1604335 --- /dev/null +++ b/v7/src/microcode/ux.h @@ -0,0 +1,774 @@ +/* -*-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 +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#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)); + +/* Conditionalizations that are overridden by _POSIX. */ + +#ifdef _POSIX + +#include +#include +#include +#include +#include +#include +#include + +#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 +#include +#include +#include + +#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 +#include +#include + +#define HAVE_APPEND +#define HAVE_FCNTL +#define HAVE_ONDELAY +#define HAVE_GETCWD +#define HAVE_TERMIO +#define HAVE_TIMES + +#ifdef _SYSV3 + +#include + +#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 + +#define HAVE_BSD_SIGNALS +#define HAVE_DUP2 +#define HAVE_MKDIR +#define HAVE_RENAME +#define HAVE_RMDIR +#define HAVE_WAIT3 + +#if (_HPUX_VERSION < 65) + +#include +#define HAVE_DIR + +#else /* (_HPUX_VERSION >= 65) */ + +#include +#define HAVE_DIRENT +#define HAVE_POSIX_SIGNALS +#define HAVE_WAITPID +#define VOID_SIGNAL_HANDLERS + +#endif /* _HPUX_VERSION */ + +#if (_HPUX_VERSION >= 65) || defined(hp9000s800) +#include +#define HAVE_BSD_JOB_CONTROL +#endif + +#endif /* _HPUX */ +#endif /* _SYSV3 */ +#else /* not _SYSV */ +#ifdef _PIXEL + +#include +#include + +#define HAVE_BSD_TTY_DRIVER +#define HAVE_DUMB_OPEN +#define HAVE_DUP2 +#define HAVE_TIMES + +#endif /* _PIXEL */ +#endif /* _SYSV */ +#endif /* _BSD */ +#endif /* _POSIX */ + +/* 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 +#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 + +#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 */ + +#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 */ + +/* 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 + +#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); \ +} + +#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)); + +#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 */ + +#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 + +#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 */ + +#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 */ diff --git a/v7/src/microcode/uxctty.c b/v7/src/microcode/uxctty.c new file mode 100644 index 000000000..3897e8831 --- /dev/null +++ b/v7/src/microcode/uxctty.c @@ -0,0 +1,311 @@ +/* -*-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)); + +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); +} + +/* 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'); +} + +#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)); + } +} + +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 (); +} + +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); +} diff --git a/v7/src/microcode/uxenv.c b/v7/src/microcode/uxenv.c new file mode 100644 index 000000000..2f7e5ead8 --- /dev/null +++ b/v7/src/microcode/uxenv.c @@ -0,0 +1,338 @@ +/* -*-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" + +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 */ + +#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 */ + +#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 */ + +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 +} + +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); +} diff --git a/v7/src/microcode/uxfile.c b/v7/src/microcode/uxfile.c new file mode 100644 index 000000000..5a55513cc --- /dev/null +++ b/v7/src/microcode/uxfile.c @@ -0,0 +1,162 @@ +/* -*-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)); + +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 + +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 (); +} diff --git a/v7/src/microcode/uxfs.c b/v7/src/microcode/uxfs.c new file mode 100644 index 000000000..0f468ad65 --- /dev/null +++ b/v7/src/microcode/uxfs.c @@ -0,0 +1,238 @@ +/* -*-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" + +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))); +} + +#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 */ diff --git a/v7/src/microcode/uxio.c b/v7/src/microcode/uxio.c new file mode 100644 index 000000000..75f107d9b --- /dev/null +++ b/v7/src/microcode/uxio.c @@ -0,0 +1,300 @@ +/* -*-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" + +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)); +} + +#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)); + } +} + +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 (); +} + +#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 */ diff --git a/v7/src/microcode/uxio.h b/v7/src/microcode/uxio.h new file mode 100644 index 000000000..30ced2bae --- /dev/null +++ b/v7/src/microcode/uxio.h @@ -0,0 +1,70 @@ +/* -*-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 */ diff --git a/v7/src/microcode/uxproc.c b/v7/src/microcode/uxproc.c new file mode 100644 index 000000000..d671d4ae6 --- /dev/null +++ b/v7/src/microcode/uxproc.c @@ -0,0 +1,483 @@ +/* -*-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)); + +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)); +} + +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); + } +} + +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); +} + +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); +} + +#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 */ + +#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 */ diff --git a/v7/src/microcode/uxproc.h b/v7/src/microcode/uxproc.h new file mode 100644 index 000000000..53faf7b50 --- /dev/null +++ b/v7/src/microcode/uxproc.h @@ -0,0 +1,64 @@ +/* -*-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 */ diff --git a/v7/src/microcode/uxsig.c b/v7/src/microcode/uxsig.c new file mode 100644 index 000000000..81b8aeae0 --- /dev/null +++ b/v7/src/microcode/uxsig.c @@ -0,0 +1,1110 @@ +/* -*-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" + +/* 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) + +#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 */ + +/* 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); +} + +#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 + +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 +} + +/* 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 */ + +#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))) + +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; + } + }) + +/* 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; + } + } +} + +/* 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; + } + } +} + +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); + } +} + +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; + } +} + +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); +} + +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); +} + +#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 */ + +#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 */ diff --git a/v7/src/microcode/uxsock.c b/v7/src/microcode/uxsock.c new file mode 100644 index 000000000..16351549a --- /dev/null +++ b/v7/src/microcode/uxsock.c @@ -0,0 +1,113 @@ +/* -*-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 +#include +#include +#ifdef HAVE_UNIX_SOCKETS +#include +#endif +#include "uxsock.h" +#include "uxio.h" + +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 */ diff --git a/v7/src/microcode/uxsock.h b/v7/src/microcode/uxsock.h new file mode 100644 index 000000000..0b44c947a --- /dev/null +++ b/v7/src/microcode/uxsock.h @@ -0,0 +1,57 @@ +/* -*-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 */ diff --git a/v7/src/microcode/uxterm.c b/v7/src/microcode/uxterm.c new file mode 100644 index 000000000..ffe7637ae --- /dev/null +++ b/v7/src/microcode/uxterm.c @@ -0,0 +1,433 @@ +/* -*-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" + +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)); +} + +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 */ +} + +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)); +} + +#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 */ + +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)))); +} + +#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 */ diff --git a/v7/src/microcode/uxterm.h b/v7/src/microcode/uxterm.h new file mode 100644 index 000000000..fa8783e4b --- /dev/null +++ b/v7/src/microcode/uxterm.h @@ -0,0 +1,49 @@ +/* -*-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 */ diff --git a/v7/src/microcode/uxtop.c b/v7/src/microcode/uxtop.c new file mode 100644 index 000000000..f70ff3a30 --- /dev/null +++ b/v7/src/microcode/uxtop.c @@ -0,0 +1,192 @@ +/* -*-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; + +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 (); +} diff --git a/v7/src/microcode/uxtop.h b/v7/src/microcode/uxtop.h new file mode 100644 index 000000000..79eac606c --- /dev/null +++ b/v7/src/microcode/uxtop.h @@ -0,0 +1,42 @@ +/* -*-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 */ diff --git a/v7/src/microcode/uxtrap.c b/v7/src/microcode/uxtrap.c new file mode 100644 index 000000000..9615f2b62 --- /dev/null +++ b/v7/src/microcode/uxtrap.c @@ -0,0 +1,633 @@ +/* -*-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; + +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); +} + +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 (); + } + } +} + +#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); +} + +/* 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*/ + +/* 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); +} + +/* 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)); +} + +/* + 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 */ diff --git a/v7/src/microcode/uxtrap.h b/v7/src/microcode/uxtrap.h new file mode 100644 index 000000000..fd182bf16 --- /dev/null +++ b/v7/src/microcode/uxtrap.h @@ -0,0 +1,213 @@ +/* -*-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" + +#ifdef hp9000s300 + +#include +#include +#include + +#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 + +/* See included by */ + +#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 */ + +#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 */ + +#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 + +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 */ diff --git a/v7/src/microcode/uxtty.c b/v7/src/microcode/uxtty.c new file mode 100644 index 000000000..98563b554 --- /dev/null +++ b/v7/src/microcode/uxtty.c @@ -0,0 +1,259 @@ +/* -*-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" + +/* 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); +} + +/* 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); +} + +#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; + } +} diff --git a/v7/src/microcode/uxutil.c b/v7/src/microcode/uxutil.c new file mode 100644 index 000000000..53f718ec6 --- /dev/null +++ b/v7/src/microcode/uxutil.c @@ -0,0 +1,230 @@ +/* -*-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 + +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); +} + +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); + } +} + +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); + } + } +} diff --git a/v7/src/microcode/uxutil.h b/v7/src/microcode/uxutil.h new file mode 100644 index 000000000..4d4295f6d --- /dev/null +++ b/v7/src/microcode/uxutil.h @@ -0,0 +1,49 @@ +/* -*-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 */ diff --git a/v7/src/microcode/wind.c b/v7/src/microcode/wind.c new file mode 100644 index 000000000..0cf72b913 --- /dev/null +++ b/v7/src/microcode/wind.c @@ -0,0 +1,142 @@ +/* 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 +#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; +}