⟦0dcc7c9b3⟧

TextFile

/*          Hey EMACS, this is -*- C -*- code!                 */

/****************************************************************
*                                                               *
*                         Copyright (c) 1985                    *
*               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.          *
*                                                               *
****************************************************************/

/* File: UNIX.C

   Contains operating system (Unix) dependent primitives and routines.

*/

#include <sys/types.h>
#include <signal.h>
#include <errno.h>

\f


#define SYSTEM_NAME "unix"

/* Sun systems are bsd but have some of the files elsewhere ? */

#if defined(bsd) && !defined(sun)
#include <sys/timeb.h>
#include <sys/time.h>
#include <sgtty.h>
#ifdef vax
#define SYSTEM_VARIANT "bsd (vax)"
#endif
#ifdef celerity
#define SYSTEM_VARIANT "bsd (Celerity)"
#endif
#ifndef SYSTEM_VARIANT
#define SYSTEM_VARIANT "bsd (unknown)"
#endif

#else
#if defined(nu) || defined(sun)
#include <sys/timeb.h>
#include <time.h>
#include <sgtty.h>
#ifdef nu
#define SYSTEM_VARIANT "nu (lose)"
#else
#define SYSTEM_VARIANT "bsd (sun)"
#endif

#else /* hpux, ATT */
#include <time.h>
#include <sys/times.h>
#include <termio.h>
#ifdef system3
#include <mknod.h>
#ifdef hpux
#define SYSTEM_VARIANT "hpux (III)"
#else
#define SYSTEM_VARIANT "AT&T (III)"
#endif
#else
#include <sys/mknod.h>
#ifdef hpux
#define SYSTEM_VARIANT "hpux (V)"
#else
#define SYSTEM_VARIANT "ATT (V)"
#endif
#endif
#endif
#endif
\f


/* Fixnum multiplication */

#ifdef vax

#define Mul_handled

/* Note that "register" is used here (not "fast") since the
   assembly code requires knowledge of the location of
   the variables and they therefore must be in registers.
   This is a kludge.  It depends on what register variables 
   get assigned to what registers.  It should be entirely 
   coded in assembly language.  -- JINX
*/

Pointer Mul(Arg1, Arg2)
long Arg1, Arg2;
{ register long A, B, C;
  Sign_Extend(Arg1, A); Sign_Extend(Arg2, B);
  asm("	emul	r11,r10,$0,r10");  /* A is in 11, B in 10 */
  C = A;
  A = B;	/* What is all this shuffling? -- JINX */
  B = C;
  /* B should have high order result, A low order */
  if ((B==0  && (A&(-1<<23)) == 0) ||
      (B==-1 && (A&(-1<<23)) == (-1<<23)))
    return Make_Non_Pointer(TC_FIXNUM, A);
  else return NIL;
}

#endif
\f


/* 68k family code.  Uses hp9000s200 conventions for the new compiler. */

#if defined(hp9000s200) && defined(new_cc)
#define Mul_handled

/* The following constants are hard coded in the assembly language
 * code below.  The code assumes that d0 and d1 are scratch registers 
 * for the compiler. 
 */

#if (NIL != 0) || (TC_FIXNUM != 0x1A)
#include "Error: types changed.  Change assembly language appropriately"
#endif

#ifdef MC68020

static long Fixnum_Range[2] = {SMALLEST_FIXNUM , BIGGEST_FIXNUM};

	asm("	text");
	asm("	global _Mul");
	asm("_Mul:");
	asm("	bfexts	4(%sp){&8:&24},%d0");
	asm("	bfexts	8(%sp){&8:&24},%d1");
	asm("	muls.l	%d1,%d0");
	asm("	bvs.b	result_is_nil");
	asm("	cmp2.l	%d0,_Fixnum_Range");
	asm("	bcs.b	result_is_nil");
	asm("	moveq	&0x1A,%d1");
	asm("	bfins	%d1,%d0{&0:&8}");
	asm("	rts");
	asm("result_is_nil:");
	asm("	clr.l	%d0");
	asm("	rts");

#else	/* not MC68020, but 68k family */
\f


	/* 20(sp) = arg0; 24(sp) = arg1 because of movem */

	asm("	text");
	asm("	global _Mul");
	asm("_Mul:");
	asm("	movem.l	%d2-%d5,-(%sp)");
	asm("	clr.b	%d5");
	asm("	tst.b	21(%sp)");
	asm("	slt	20(%sp)");
	asm("	bge.b	coerce_1");
	asm("	moveq	&1,%d5");
	asm("	neg.l	20(%sp)");
	asm("coerce_1:");
	asm("	tst.b	25(%sp)");
	asm("	slt	24(%sp)");
	asm("	bge.b	after_coerce");
	asm("	eori.b	&1,%d5");
	asm("	neg.l	24(%sp)");
	asm("after_coerce:");
	asm("	move.l	20(%sp),%d0");
	asm("	move.l	24(%sp),%d1");
	asm("	move.w	%d0,%d2");
	asm("	mulu	%d1,%d2");
	asm("	move.w	%d1,%d4");
	asm("	swap	%d1");
	asm("	move.w	%d1,%d3");
	asm("	mulu	%d0,%d3");
	asm("	swap	%d0");
	asm("	mulu	%d0,%d4");
	asm("	add.l	%d4,%d3");
	asm("	bcs.b	result_is_nil");
	asm("	mulu	%d0,%d1");
	asm("	bne.b	result_is_nil");
	asm("	swap	%d2");
	asm("	add.w	%d3,%d2");
	asm("	bcs.b	result_is_nil");
	asm("	swap	%d3");
	asm("	tst.w	%d3");
	asm("	bne.b	result_is_nil");
	asm("	cmpi.w	%d2,&0x7F");
	asm("	bgt.b	result_is_nil");
	asm("	swap	%d2");
	asm("	tst.b	%d5");
	asm("	beq.b	sign_is_right");
	asm("	neg.l	%d2");
	asm("sign_is_right:");
	asm("	move.l	%d2,-(%sp)");
	asm("	move.b	&0x1A,(%sp)");
	asm("	move.l	(%sp)+,%d0");
	asm("	movem.l	(%sp)+,%d2-%d5");
	asm("	rts");
	asm("result_is_nil:");
	asm("	clr.l	%d0");
	asm("	movem.l	(%sp)+,%d2-%d5");
	asm("	rts");
\f

	
#endif	/* not MC68020 */
#endif  /* hp9000s200 */

#ifndef Mul_handled
/* Portable case */
#include "mul.c"
#endif

/* OpSys dependent I/O operations. */

#define dump_output_buffer() fflush(stdout)
#define flush_input_buffer() ioctl(fileno(stdin), TIOCFLUSH, NULL);

void OS_Flush_Output_Buffer()
{ dump_output_buffer();
}

static Boolean stdin_is_a_kbd, stdout_is_a_crt, Under_Emacs;
forward char TYI_Immediate(), TYI_Buffered();
forward void OS_Re_Init();

char OS_tty_tyi(Immediate, Interrupted)
Boolean Immediate, *Interrupted;
{ char C;
  if (stdin_is_a_kbd)
    C = (Immediate ?
	 TYI_Immediate(Interrupted) :
	 TYI_Buffered(Interrupted));
  else if (!Under_Emacs)
  { *Interrupted = false;
    if ((C = getchar()) == EOF)
      Microcode_Termination(TERM_EOF);
  }   
  else if (Immediate)
  { char Spurious;
    C = TYI_Buffered(Interrupted);
    /* Read Spurious New Line */
    if (!(*Interrupted))
    { Spurious = TYI_Buffered(Interrupted);
      if ((Spurious != '\n') && (!(*Interrupted)))
	ungetc(Spurious, stdin);
      /* We got a real character before. */
      *Interrupted = false;
    }
  }
  else C = TYI_Buffered(Interrupted);
  return C;
}
 
#ifdef bsd
#define make_a_directory(path) mkdir((path), 511) 
#else
#define make_a_directory(path) mknod((path), 0040666, ((dev_t) 0))
#endif

Built_In_Primitive(Prim_Make_Directory, 1, "MAKE-DIRECTORY")
{ int Mask;
  Primitive_1_Arg();

  Arg_1_Type(TC_CHARACTER_STRING);
  Mask = umask(0);
  if (make_a_directory(Scheme_String_To_C_String(Arg1)) != 0)
  { umask(Mask);
    Primitive_Error(ERR_ARG_1_BAD_RANGE);
  }
  umask(Mask);
  return NIL;
}
\f


#if defined(system3)
getcwd(buffer, length)
char *buffer;
long length;
{ FILE *the_pipe = popen("pwd", "r");
  char *finder = buffer;
  if (the_pipe == NULL)
  { fprintf(stderr, "popen failed.\n");
    _exit(1);
  }
  fgets(buffer, length, the_pipe);
  /* Remove extraneous newline */
  while((*finder != '\0') && (*finder != '\n')) finder++;
  if (*finder == '\n') *finder = '\0';
  pclose(the_pipe);
  return;
}
#endif

Built_In_Primitive(Prim_Prefix_Volume, 1, "PREFIX-VOLUME")
{ char Old_Path[FILE_NAME_LENGTH];
  Primitive_1_Arg();

  Arg_1_Type(TC_CHARACTER_STRING);
  getcwd(Old_Path, FILE_NAME_LENGTH);
  if (chdir(Scheme_String_To_C_String(Arg1)) != 0)
    Primitive_Error(ERR_ARG_1_BAD_RANGE);
  return C_String_To_Scheme_String(Old_Path);
}

Built_In_Primitive(Prim_Remove_File, 1, "REMOVE-FILE")
{ Primitive_1_Arg();

  Arg_1_Type(TC_CHARACTER_STRING);
  if (unlink(Scheme_String_To_C_String(Arg1)) != 0)
    Primitive_Error(ERR_ARG_1_BAD_RANGE);
  return NIL;
}

Built_In_Primitive(Prim_Delete_File, 1, "DELETE-FILE")
{ return Prim_Remove_File();
}
\f


/* File operations continued */

/* Prim_Link_File takes a third argument which specifies whether the
 * link is to be physical (#!TRUE) or symbolic (#!FALSE).  Of course,
 * this is only meaningful if both kinds exist.
 * Note that symbolic links are made regardless of the existence of the
 * source file.
 * It returns #!TRUE if it managed to link in the specified way, #!FALSE
 * if it had to link in a different way (symbolic was specified but not
 * available).
 */

Built_In_Primitive(Prim_Link_File, 3, "LINK-FILE")
{ char *Real_File, *Symbolic_File;
  long Result;
  Pointer Answer;
  Primitive_3_Args();

  Arg_1_Type(TC_CHARACTER_STRING);
  Arg_2_Type(TC_CHARACTER_STRING);
  Real_File = Scheme_String_To_C_String(Arg1);
  Symbolic_File = Scheme_String_To_C_String(Arg2);
#ifdef bsd
  Result = ((Arg3 == TRUTH) ?
	    link(Real_File, Symbolic_File) :
	    symlink(Real_File, Symbolic_File));
  Answer = TRUTH;
#else
  Result = link(Real_File, Symbolic_File);
  Answer = ((Arg3 == TRUTH) ? TRUTH : NIL);
#endif
  if (Result != 0) Primitive_Error(ERR_EXTERNAL_RETURN);
  return Answer;
}

/* Somewhat kludged.  Simply reduces to a hard-link then
   a delete file.  It should be fixed for cross-structure rename.
*/
Built_In_Primitive(Prim_Rename_File, 2, "RENAME-FILE")
{ char *Source_File, *Destination_File;
  Primitive_2_Args();

  Arg_1_Type(TC_CHARACTER_STRING);
  Arg_2_Type(TC_CHARACTER_STRING);
  Source_File = Scheme_String_To_C_String(Arg1);
  Destination_File = Scheme_String_To_C_String(Arg2);
  if (link(Source_File, Destination_File) != 0)
    Primitive_Error(ERR_EXTERNAL_RETURN);
  unlink(Source_File);
  return TRUTH;
}
\f


/* Terminal hacking. */

extern char *getenv(), *tgetstr(), *tgoto();
char *CM, *BC, *UP, *CL, *CE, *term;
int LI, CO;

outc(C)
char C;
{ putchar(C);
}

void OS_Clear_Screen()
{ if (Can_Do_Cursor) tputs(CL, LI, outc);
  else putchar('\f');
  dump_output_buffer();
}

long NColumns()
{ return (Can_Do_Cursor? CO : 79);
}

long NLines()
{ return (Can_Do_Cursor? LI : 24);
}

Built_In_Primitive(Prim_Clear_To_End_Of_Line, 0, "CLEAR-TO-END-OF-LINE")
{ if (Can_Do_Cursor) tputs(CE, 1, outc);
   return NIL;
}

Built_In_Primitive(Prim_Move_Cursor, 2, "MOVE-CURSOR")
{ Primitive_2_Args();

  Arg_1_Type(TC_FIXNUM);
  Arg_2_Type(TC_FIXNUM);
  if (Can_Do_Cursor)
    tputs(tgoto(CM, Get_Integer(Arg1), Get_Integer(Arg2)), 1, outc);
  return NIL;
}	  
\f


/* Time and dates. */

#if defined(bsd) || defined(nu)

long Start_Time, Start_Milli_Time;

long System_Clock()
{ struct timeb TimeBlock;
  long DeltaT, DeltaMilliT, NowT, NowMilliT;

  ftime(&TimeBlock);
  NowT = TimeBlock.time;
  NowMilliT = TimeBlock.millitm;
  DeltaT = NowT - Start_Time;
  DeltaMilliT = NowMilliT - Start_Milli_Time;
  return (DeltaT*100) + (DeltaMilliT/10);
}

void Init_System_Clock()
{ struct timeb Time;
  ftime(&Time);
  Start_Time = Time.time;
  Start_Milli_Time = Time.millitm;
  return;
}

#else
#if defined(hpux) || defined(ATT)

long Start_Time;

long System_Clock()
{ struct tms buff;
  long Temp;

  times(&buff);
  Temp = (buff.tms_utime+buff.tms_stime);
  Temp -= Start_Time;
  return (100*Temp)/60;
}

void Init_System_Clock()
{ struct tms buff;
  times(&buff);
  Start_Time = buff.tms_utime + buff.tms_stime;
  return;
}

#else

/* Should be fixed some day. */
long System_Clock()
{ fprintf(stderr, "\nUnimplemented utility: System Clock.");
  return 0;
}

void Init_System_Clock()
{ return;
}

#endif
#endif
\f


#if defined(bsd) || defined(hpux) || defined(nu)

extern struct tm *(localtime());

#define Date_Part(C_Name, S_Name, Which)\
Built_In_Primitive(C_Name, 0, S_Name)	\
{ struct tm *Time;			\
  long Ans, The_Time;			\
					\
  time(&The_Time);			\
  Time = localtime(&The_Time);		\
  return FIXNUM_0 + (Time->Which);	\
}

Date_Part(Prim_Current_Year, "YEAR", tm_year);
Date_Part(Prim_Current_Month, "MONTH", tm_mon + 1);
Date_Part(Prim_Current_Day, "DAY", tm_mday);
Date_Part(Prim_Current_Hour, "HOUR", tm_hour);
Date_Part(Prim_Current_Minute, "MINUTE", tm_min);
Date_Part(Prim_Current_Second, "SECOND", tm_sec);

#else

NIY(Prim_Current_Year, 0, "YEAR")
NIY(Prim_Current_Month, 0, "MONTH")
NIY(Prim_Current_Day, 0, "DAY")
NIY(Prim_Current_Hour, 0, "HOUR")
NIY(Prim_Current_Minute, 0, "MINUTE")
NIY(Prim_Current_Second, 0, "SECOND")

#endif
\f


/* actual keyboard I/O */

#if defined(CBREAK)	/* bsd */

#define Immediate_Declarations()				\
struct sgttyb TTY_Block

#define Immediate_Prolog()					\
flush_input_buffer();						\
gtty(fileno(stdin), &TTY_Block);				\
TTY_Block.sg_flags |= CBREAK;					\
stty(fileno(stdin), &TTY_Block)

#define Immediate_Epilog()					\
TTY_Block.sg_flags &= ~CBREAK;					\
stty(fileno(stdin), &TTY_Block)

#else
#if defined(TCFLSH)	/* hpux, ATT */

#define TIOCFLUSH	TCFLSH

#ifndef VINTR
#define VINTR	  	0
#define VQUIT	  	1
#define VEOF		4
#define VMIN		4
#define VTIME		5
#endif

#define Immediate_Declarations()				\
struct termio The_Chars;					\
char Old_VMIN, Old_VTIME;					\
unsigned short lflag

#define Immediate_Prolog()					\
flush_input_buffer();						\
ioctl(fileno(stdin), TCGETA, &The_Chars);			\
lflag = The_Chars.c_lflag;					\
The_Chars.c_lflag &= ~ICANON;					\
Old_VMIN = The_Chars.c_cc[VMIN];				\
Old_VTIME = The_Chars.c_cc[VTIME];				\
The_Chars.c_cc[VMIN] = (char) 1;  /* Min # of chars. */		\
The_Chars.c_cc[VTIME] = (char) 1;	 /* Time-out */		\
ioctl(fileno(stdin), TCSETA, &The_Chars)
  
#define Immediate_Epilog()					\
The_Chars.c_cc[VMIN] = Old_VMIN;				\
The_Chars.c_cc[VTIME] = Old_VTIME;				\
The_Chars.c_lflag = lflag;					\
ioctl(fileno(stdin), TCSETA, &The_Chars)

#else	/* ??? */
/* No immediate IO */

#define Immediate_Declarations()
#define Immediate_Prolog()
#define Immediate_Epilog()

#endif
#endif

/* These are pretty trivial */

#define Buffered_Declarations()
#define Buffered_Prolog()
#define Buffered_Epilog()
\f


/* Keyboard Interrupts */

#define CONTROL_A	'A'
#define CONTROL_B	'B'
#define CONTROL_G	'G'
#define CONTROL_U	'U'
#define CONTROL_X	'X'

#define CONTROL_BIT	0100
#define C_A		(CONTROL_A - CONTROL_BIT)
#define C_G		(CONTROL_G - CONTROL_BIT)
#define DISABLE_EOF	-1

char Int_Char;
    
int Scheme_Process_Id;

Built_In_Primitive(Prim_Chk_And_Cln_Input_Channel, 2,
		 "CHECK-AND-CLEAN-UP-INPUT-CHANNEL")
{ return TRUTH;
}

Built_In_Primitive(Prim_Get_Next_Interrupt_Char, 0,
		 "GET-NEXT-INTERRUPT-CHARACTER")
{ Pointer Result = FIXNUM_0 + Int_Char;
  Int_Char = 0;
  IntCode &= ~INT_Character;
  return Result;
}
\f


/* Keyboard Interrupts and I/O synchronization */

#define FIRST_TIME	0
#define INTERRUPT	1
#define REDO		2

#define Interrupt_available (((IntCode & IntEnb) & INT_Character) != 0)

typedef struct { Boolean in_input_wait; jmp_buf storage; } reader_context;
static reader_context real_read_env, *saved_read_env;
  
#define Keyboard_Input_Procedure(Name, decl, prolog, epilog)		\
char Name(Interrupted)							\
Boolean *Interrupted;							\
{ int Which_Way;							\
  char C;								\
  decl;									\
  Which_Way = setjmp(saved_read_env->storage);				\
  while(true)								\
  { switch (Which_Way)							\
    { case FIRST_TIME:							\
      		 prolog;						\
      case REDO:							\
		 saved_read_env->in_input_wait = true;			\
		 if (Interrupt_available) 				\
		 { saved_read_env->in_input_wait = false;		\
		   epilog;						\
		   longjmp(saved_read_env->storage, INTERRUPT);		\
		 }							\
		 C = getchar();						\
		 saved_read_env->in_input_wait = false;			\
		 epilog;						\
		 if (C == EOF) Microcode_Termination(TERM_EOF);		\
                 if (Photo_Open) putc(C, Photo_File_Handle);		\
		 *Interrupted = false;					\
      		 return C;						\
      case INTERRUPT:							\
		 epilog;						\
		 *Interrupted = true;					\
      		 return EOF;						\
      default:	 continue;						\
    }									\
  }									\
}

Keyboard_Input_Procedure(TYI_Immediate,
			 Immediate_Declarations(),
			 Immediate_Prolog(),
			 Immediate_Epilog())

Keyboard_Input_Procedure(TYI_Buffered,
			 Buffered_Declarations(),
			 Buffered_Prolog(),
			 Buffered_Epilog())

\f


/* Interrupt Handlers */

#define save_read_context(extra)				\
reader_context next_buffer, *old_env;				\
extra;								\
next_buffer.in_input_wait = false;				\
old_env = saved_read_env;					\
saved_read_env = &next_buffer

#define restore_read_context(extra, action)			\
if (old_env->in_input_wait)					\
{ old_env->in_input_wait = false;				\
  saved_read_env = old_env;					\
  extra;							\
  longjmp(saved_read_env->storage, action);			\
}								\
extra;								\
saved_read_env = old_env;					\
return

#define disable_interrupt(signal_name)				\
signal(signal_name, SIG_IGN)

#define enable_interrupt(signal_name, routine)			\
signal(signal_name, routine)

#define interrupt_start(signal_name)				\
save_read_context(disable_interrupt(signal_name))

#define interrupt_end(signal_name, routine, action)		\
restore_read_context(enable_interrupt(signal_name, routine), action)
\f


static int (*old_Real_Timer_handler)();
static int (*old_Virtual_Timer_handler)();
static int (*old_INT_handler)();
static int (*old_QUIT_handler)();
static int (*old_TERM_handler)();

#ifdef SIGTSTP

/* Assumes there is sigsetmask */

static int (*old_TSTP_handler)();

#define NO_SIGNALS_ALLOWED -1
#define TSTP_MASK ~(1 << (SIGTSTP - 1))
#define BOGUS_SIGNAL 0

/* sig should only be SIGTSTP or BOGUS_SIGNAL in the following */

Suspend_Me(sig)
int sig;
{ int saved_mask = sigsetmask(NO_SIGNALS_ALLOWED);
  interrupt_start(SIGTSTP);
  OS_Quit();
  sigsetmask(saved_mask & TSTP_MASK);
  kill(Scheme_Process_Id, SIGTSTP);
  sigsetmask(NO_SIGNALS_ALLOWED);
  OS_Re_Init();
  sigsetmask(saved_mask);
  interrupt_end(SIGTSTP, Suspend_Me, REDO);
}

void Restartable_Exit()
{ Suspend_Me(BOGUS_SIGNAL);
  return;
}

#else

void Restartable_Exit()
{ fprintf(stderr, "\nUnimplemented utility: Restartable_Exit.");
  return;
}

#endif
\f


/* Interrupt handlers (continued) */

Control_G(sig)
int sig;
{ interrupt_start(sig);
  putchar('\007');
  dump_output_buffer();
  IntCode |= INT_Character;
  Int_Char = CONTROL_G;
  New_Compiler_MemTop();
  interrupt_end(sig, Control_G, INTERRUPT);
}

/* Kill Scheme after undoing terminal garbage */

Kill_Me(sig)
int sig;
{ OS_Quit();
  exit(1);
}

#if defined(COMPILE_FUTURES) && defined(ITIMER_VIRTUAL)
Timer_Interrupt(sig)
int sig;
{ interrupt_start(sig);
  IntCode |= INT_Timer;
  New_Compiler_MemTop();
  interrupt_end(sig, Timer_Interrupt, INTERRUPT);
}
#endif
\f


/* Procedure needed in Ask_Me */

#define C_STRING_LENGTH 256

Examine_Memory()
{ Pointer *Where;
  char input_string[10];
  int free;
  Boolean interrupted;
  printf("Enter location to examine (0x prefix for hex) : ");
  dump_output_buffer();

  /* Considerably haired up to go through standard (safe) interface.
     Taken from debug.c */
  
  if (interrupted) return;
  for (free = 0; free < C_STRING_LENGTH; free++)
  { input_string[free] = OS_tty_tyi(false, &interrupted);
    if (interrupted) return;
    if (input_string[free] == '\n')
    { input_string[free] = '\0';
      break;
    }
  }

  /* Check to see if address is in Hex (0x prefix). */
  if ((input_string[0] == '0') && (input_string[1] == 'x')) 
    sscanf(input_string + 2, "%x", &Where);
  else
    sscanf(input_string, "%d", &Where);
  Print_Expression(*Where, "Contents");
  CRLF();
}
\f


/* Interactive interrupt handler. */

Ask_Me(sig)
int sig;
{ char command;
  Boolean Interrupted;
  interrupt_start(sig);
  putchar('\007');
  putchar('\n');
Loop:
  printf("Interrupt character (? for help): ");
  dump_output_buffer();
  command = OS_tty_tyi(true, &Interrupted);
  if (Interrupted) goto exit_gracefully;
  switch (command)
  { case 'B':
    case 'b': Int_Char = CONTROL_B; break;
    case 'E':
    case 'e': putchar('\n'); 
	      Examine_Memory(); 
	      goto exit_gracefully;

    case 'D':
    case 'd': putchar('\n');
	      Handle_Debug_Flags();
	      goto exit_gracefully;
    case 'T':
    case 't': putchar('\n'); 
	      Back_Trace();
	      goto exit_gracefully;

    case 'G':
    case 'g': Int_Char = CONTROL_G; break;

    case 'P':
    case 'p':
    case 'U':
    case 'u': Int_Char = CONTROL_U; break;

    case 'F':
    case 'f':
    case 'X':
    case 'x': Int_Char = CONTROL_X; break;

    case 'Z':
    case 'z': putchar('\n');
	      Restartable_Exit();
	      goto exit_gracefully;
\f


    case 'Q':
    case 'q': putchar('\n'); Microcode_Termination(TERM_HALT);

    case '\f': OS_Clear_Screen(); goto exit_gracefully;

    case 'H':
    case 'h':
	      putchar('\n');
	      printf(
"The interrupt character is ^G (cntrl-G).  Unless redefined, when\n");
	      printf(
"typed, the running (Scheme) program will be aborted and the top level\n");
	      printf("read-eval-print loop will resume control.\n");
	      printf(
"The quit character is ^A.  When typed, it offers various options.\n");
	      printf("Type ^A? for a list of the options.\n");
	      goto exit_gracefully;


    case 'I':
    case 'i': if (!stdin_is_a_kbd || Under_Emacs) putchar('I');
	      printf("gnored.\n");
exit_gracefully:
	      interrupt_end(sig, Ask_Me,
			    (Interrupted ? INTERRUPT : REDO));

    default: putchar('\n');
             printf("B: Enter a breakpoint loop.\n");
             printf("D: Debugging: change interpreter flags.\n");
	     printf("E: Examine memory location.\n");
             printf("F or X: Abort to current REP loop.\n");
             printf("G: Goto to top level read-eval-print (REP) loop.\n");
	     printf("H: Print simple information on interrupts.\n");
             printf("I: Ignore interrupt request.\n");
             printf("P or U: Up to previous (lower numbered) REP loop.\n");
             printf("Q: Quit instantly, killing Scheme.\n");
             printf("T: Stack trace.\n");
             printf("Z: Quit instantly, suspending Scheme.\n");
             printf("^L: Clear the screen.\n");
             goto Loop;
  }
  IntCode |= INT_Character;
  New_Compiler_MemTop();
  interrupt_end(sig, Ask_Me, INTERRUPT);
}
\f


#define TERMCAP_BUFFER_SIZE 1024

#ifndef bsd
#define Break_Terminal_Connection()	setpgrp()
#else
#define Break_Terminal_Connection()
#endif

OS_Init()
{ char termcaps[TERMCAP_BUFFER_SIZE];
  static char tcb[TERMCAP_BUFFER_SIZE];
  char *tcp = &tcb[0];
  OS_Name = SYSTEM_NAME;
  OS_Variant = SYSTEM_VARIANT;

  Init_System_Clock();

  real_read_env.in_input_wait = false;
  saved_read_env = &real_read_env;

  /* Find process information */

  Under_Emacs =
    Parse_Option("-emacs", Saved_argc, Saved_argv, true) != NOT_THERE;

  Scheme_Process_Id = getpid();
\f


  stdin_is_a_kbd = isatty(fileno(stdin));

  /* The ultimate in C style -- by Jinx */

  if ((!(stdout_is_a_crt = isatty(fileno(stdout))))	||
      ((term = getenv("TERM")) == NULL) 		||
      (tgetent(termcaps, term) <= 0)			||
      ((CM = tgetstr("cm", &tcp)) == NULL))

  Can_Do_Cursor = false;

  else /* Find terminal information */
  { LI = tgetnum("li");
    CO = tgetnum("co");
    UP = tgetstr("up", &tcp);
    CL = tgetstr("cl", &tcp);
    CE = tgetstr("ce", &tcp);
    BC = tgetflag("bs") ? "\b" : tgetstr("bc", &tcp);
    Can_Do_Cursor = true;
  }
  Int_Char = 0;

  printf("MIT Scheme, UNIX version\n");

  if (stdout_is_a_crt && stdin_is_a_kbd)
    printf("^AH (CTRL-A, then H) shows help on interrupt keys.\n");

  if (!stdin_is_a_kbd && !stdout_is_a_crt && !Under_Emacs)
    Break_Terminal_Connection();
  
  dump_output_buffer();

  /* Swap in Scheme IO */
  OS_Re_Init();
}
\f


static char Orig_Interrupt, Orig_Quit, Orig_EOF;

#if defined(bsd) || defined(nu)

static long Orig_flags;

#define hack_crt(old, new)						\
{ int crt_pgrp;								\
  ioctl(fileno(stdout), TIOCGPGRP, &crt_pgrp);				\
  if (getpgrp(Scheme_Process_Id) == crt_pgrp)				\
  { struct sgttyb sg;							\
    gtty(fileno(stdout), &sg);						\
    Orig_flags = old;							\
    sg.sg_flags = new;							\
    ioctl(fileno(stdout), TIOCSETN, &sg);				\
  }									\
}

#define hack_kbd(Ni, Oi, Nq, Oq, Ne, Oe)				\
{ int crt_pgrp;								\
  ioctl(fileno(stdin), TIOCGPGRP, &crt_pgrp);				\
  if (getpgrp(Scheme_Process_Id) == crt_pgrp)				\
    basic_hack_kbd(Ni, Oi, Nq, Oq, Ne, Oe);				\
}

#else
#if defined(TCSETA) /* hpux, ATT */

/* Make hpux/system V look like bsd so hack_kbd works */

#define tchars termio
#define TIOCGETC TCGETA
#define TIOCSETC TCSETA
#define t_intrc c_cc[VINTR]
#define t_quitc c_cc[VQUIT]
#define t_eofc  c_cc[VEOF]
#define hack_crt(old, new)

#define hack_kbd(Ni, Oi, Nq, Oq, Ne, Oe)				\
  basic_hack_kbd(Ni, Oi, Nq, Oq, Ne, Oe)

#else /* ??? */

#define hack_crt(old, new)
#define hack_kbd(Ni, Oi, Nq, Oq, Ne, Oe)

#endif
#endif

/* This swaps interrupt characters */

#define basic_hack_kbd(Nintr, Ointr, Nquit, Oquit, NEOF, OEOF)		\
{ struct tchars Terminal_Chars;						\
  ioctl(fileno(stdin), TIOCGETC, &Terminal_Chars);			\
  Orig_Interrupt = Ointr;						\
  Orig_Quit = Oquit;							\
  Orig_EOF = OEOF;							\
  Terminal_Chars.t_intrc = Nintr;					\
  Terminal_Chars.t_quitc = Nquit;					\
  Terminal_Chars.t_eofc  = NEOF;					\
  ioctl(fileno(stdin), TIOCSETC, &Terminal_Chars);			\
}
\f


void OS_Re_Init()
{ if (stdin_is_a_kbd)
    hack_kbd(C_G, Terminal_Chars.t_intrc,
	     C_A, Terminal_Chars.t_quitc,
	     DISABLE_EOF, Terminal_Chars.t_eofc);
  if (stdin_is_a_kbd || Under_Emacs)
  { old_QUIT_handler = signal(SIGQUIT, Ask_Me);
#ifdef SIGTSTP
    old_TSTP_handler = signal(SIGTSTP, Suspend_Me);
#endif
  }
#if defined(COMPILE_FUTURES) && defined(ITIMER_VIRTUAL)
  old_Virtual_Timer_handler = signal(SIGVTALRM, Timer_Interrupt);
  old_Real_Timer_handler = signal(SIGALRM, Timer_Interrupt);
#endif
  old_INT_handler  = signal(SIGINT, Control_G);
  old_TERM_handler = signal(SIGTERM, Kill_Me);
  if (stdout_is_a_crt)
    hack_crt(sg.sg_flags, (sg.sg_flags & (~XTABS)));
}
\f


OS_Quit()
{ dump_output_buffer();
  if (stdout_is_a_crt)
    hack_crt(Orig_flags, Orig_flags);
  signal(SIGTERM, old_TERM_handler);
  signal(SIGINT, old_INT_handler);
#if defined(COMPILE_FUTURES) && defined(ITIMER_VIRTUAL)
  signal(SIGVTALRM, old_Virtual_Timer_handler);
  signal(SIGALRM, old_Real_Timer_handler);
#endif
  if (stdin_is_a_kbd || Under_Emacs)
  { signal(SIGQUIT, old_QUIT_handler);
#ifdef SIGTSTP
    signal(SIGTSTP, old_TSTP_handler);
#endif
  }
  if (stdin_is_a_kbd)
    hack_kbd(Orig_Interrupt, Orig_Interrupt,
	     Orig_Quit, Orig_Quit,
	     Orig_EOF, Orig_EOF);
}
\f


/* Fasload and Fasdump use the following routines */

void Load_Data(Count, To_Where)
long Count;
char *To_Where;
{ fread(To_Where, sizeof(Pointer), Count, File_Handle);
  return;
}

Boolean Open_Dump_File(Name, flag)
char *Name, *flag;
{ return Open_File(Name, flag, &File_Handle);
}

void Write_Data(Count, From_Where)
long Count;
char *From_Where;
{ fwrite(From_Where, sizeof(Pointer), Count, File_Handle);
  return;
}
\f


#if defined(COMPILE_FUTURES) && defined(ITIMER_VIRTUAL)
void Clear_Timer()
{ struct itimerval New_Value, Old_Value;
  New_Value.it_value.tv_sec = 0;
  New_Value.it_value.tv_usec = 0;
  setitimer(ITIMER_REAL, &New_Value, &Old_Value);
  setitimer(ITIMER_VIRTUAL, &New_Value, &Old_Value);
  return;
}

void Set_Timer(Days, Centi_Seconds)
long Days, Centi_Seconds;
{ struct itimerval New_Value, Old_Value;
  long Which_Timer = ITIMER_VIRTUAL;

  Clear_Timer();
  if (Centi_Seconds < 0)
  { Centi_Seconds = -Centi_Seconds;
    Which_Timer = ITIMER_REAL;
  }
  New_Value.it_value.tv_sec =
    (Days*24*60*60*60) + (Centi_Seconds/100);
  New_Value.it_value.tv_usec = (Centi_Seconds % 100) *10000;
  New_Value.it_interval.tv_sec = 0;	/* Turn off after it rings */
  New_Value.it_interval.tv_usec = 0;
  setitimer(Which_Timer, &New_Value, &Old_Value);
  return;
}
#else
void Clear_Timer()
{ fprintf(stderr, "\nCan't clear a timer under this OS.");
  return;
}

void Set_Timer()
{ fprintf(stderr, "\nCan't set a timer under this OS.");
  return;
}
#endif
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦0dcc7c9b3⟧ TextFile

Derivation

TextFile
