⟦b6f2f687e⟧

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.          *
*                                                               *
****************************************************************/
\f


/* File: VMS.C

   Contains operating system (VMS) dependent primitives and routines.

*/

#include <types.h>
#include <timeb.h>
#include <signal.h>
#include <time.h>
#include <descrip.h>
#include "vmsio.h"
#include ssdef
#include jpidef

/* Forward references */

forward int Sift_Out_Interrupt();
forward Suspend_Me(), OS_Quit(), OS_Re_Init();

/* The following is hackery for checking multiply overflow */

#if false
/* Macro_EMUL is currently broken, it should be fixed.  
 * The extra procedure call should be eliminated also.
 */

Mul(A, B)
fast long A, B;
{ fast long C;
  return Macro_EMUL(A,B);
}
#else

#include "mul.c"

#endif
\f


/* Operating system dependent IO operations */

#define dump_output_buffer()	fflush(stdout)

NIY(Prim_Remove_File, 1, "REMOVE-FILE")
NIY(Prim_Delete_File, 1, "DELETE-FILE")
NIY(Prim_Link_File, 3, "LINK-FILE")
NIY(Prim_Rename_File, 3, "RENAME-FILE")
NIY(Prim_Make_Directory, 1, "MAKE-DIRECTORY")
NIY(Prim_Prefix_Volume, 1, "PREFIX-VOLUME")
NIY(Prim_Move_Cursor, 2, "MOVE-CURSOR")
NIY(Prim_Clear_To_End_Of_Line, 0, "CLEAR-TO-END-OF-LINE")

void OS_Flush_Output_Buffer()
{ dump_output_buffer();
}

void OS_Clear_Screen()
{ putchar('\f');
}

/* These are faked since I have no idea how to do them right. */

long NColumns()
{ return 79;
}

long NLines()
{ return 24;
}

void Restartable_Exit()
{ Suspend_Me(false);
  return;
}
\f


/* Time and dates. */

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;
}

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_Day, "DAY", tm_mday);
Date_Part(Prim_Current_Hour, "HOUR", tm_hour);
Date_Part(Prim_Current_Minute, "MINUTE", tm_min);
Date_Part(Prim_Current_Month, "MONTH", tm_mon + 1);
Date_Part(Prim_Current_Second, "SECOND", tm_sec);
Date_Part(Prim_Current_Year, "YEAR", tm_year);
\f


/* Scheme keyboard interrupts */

#define CONTROL_A	'A'
#define CONTROL_B       'B'
#define CONTROL_F	'F'
#define CONTROL_G       'G'
#define CONTROL_M	'M'
#define CONTROL_P       'P'
#define CONTROL_U	'U'
#define CONTROL_X       'X'
#define CONTROL_Z	'Z'

#define CONTROL_BIT	0100	/* Octal, control bit in ASCII */

#define C_A (CONTROL_A - CONTROL_BIT)
#define C_B (CONTROL_B - CONTROL_BIT)
#define C_F (CONTROL_F - CONTROL_BIT)
#define C_G (CONTROL_G - CONTROL_BIT)
#define C_M (CONTROL_M - CONTROL_BIT)
#define C_P (CONTROL_P - CONTROL_BIT)
#define C_X (CONTROL_X - CONTROL_BIT)
#define C_Z (CONTROL_Z - CONTROL_BIT)

#define Control_A_Bit (1 << C_A)
#define Control_B_Bit (1 << C_B)
#define Control_F_Bit (1 << C_F)
#define Control_G_Bit (1 << C_G)
#define Control_P_Bit (1 << C_P)
#define Control_X_Bit (1 << C_X)
#define Control_Z_Bit (1 << C_Z)
#define CR_Bit	      (1 << C_M)

#define MASK_SIZE 32	/* In bits */

#define Scheme_Interrupt_Mask (Control_G_Bit | Control_P_Bit | 		\
			       Control_F_Bit | Control_B_Bit |		\
			       Control_A_Bit | Control_Z_Bit )

#define Normal_Terminator_Mask CR_Bit

#define INTERRUPT	1
#define REDO		2
\f


/* Interrupts & IO synchronization */

static long TT_Channel;

struct Block { short Status;
	       short Count;
	       long Ptr;
	     };
static struct Block
	Scheme_Interrupt_Descriptor = {0, 0, Scheme_Interrupt_Mask};
static struct Block 
	Scheme_Read_Terminator =
		{0, 0, (Scheme_Interrupt_Mask | Normal_Terminator_Mask)};

#define Is_Terminator(c)	\
 ((c >= MASK_SIZE) ? 		\
  false : (((1 << c) & Normal_Terminator_Mask) != 0))

Set_Interrupt_Mask(Mask, AST)
struct Block *Mask;
long *AST;
{ long Return_Status;
  struct Block IO_Status_Block = {0, 0, 0};
  Return_Status = SYS$QIO(0, TT_Channel, IO$_SETMODE|IO$M_OUTBAND,
                          &IO_Status_Block, 0, 0,
                          AST, Mask, 0xFFFFFFFF,
                          0, 0, 0);
      
  if (Return_Status != SS$_NORMAL)
    printf("\nStatus = %x Unable to Setmode", Return_Status);
  return;
}

#define Setup_Scheme_Interrupts()				\
  Set_Interrupt_Mask(&Scheme_Interrupt_Descriptor,		\
		     ((long *) Sift_Out_Interrupt))

#define Clear_Scheme_Interrupts()				\
  Set_Interrupt_Mask(((struct Block *) 0), ((long *) 0))

#define interrupt_start(signal_name, routine, restore_handler)
#define interrupt_end(action) return action
\f


/* Keyboard input low level */

#define INPUT_BUF_SIZE 512	/* Over 6 full lines of text */
#define NO_INTERRUPTS   -1	/* Not a valid character */

static char Input_Buffer[INPUT_BUF_SIZE];
static char *Input_Pointer;
static char *Input_End;

#define Initialize_Input() 					\
  Input_Pointer = Input_End = &Input_Buffer[0]

int fill_input_buffer(size, keep_type_ahead)
int size;
Boolean keep_type_ahead;
{ struct Block IO_Status_Block = {0, 0, 0};
  long Return_Status;
  int terminator;

  Clear_Scheme_Interrupts();

  do
  { Return_Status =
      SYS$QIOW(0,TT_Channel,
	       (IO$_READVBLK | (keep_type_ahead ? 0 : IO$M_PURGE)),
	       &IO_Status_Block,0,0,
	       &Input_Buffer[0],size,0,
	       &Scheme_Read_Terminator,0,0);
  } while (Return_Status != SS$_NORMAL);

  Setup_Scheme_Interrupts();

  Input_Pointer = &Input_Buffer[0];
  Input_End  = &Input_Buffer[IO_Status_Block.Count];

  /* Interrupt? */

  terminator = (IO_Status_Block.Ptr & 0377);
  if (terminator == 0) return NO_INTERRUPTS;
  if (Is_Terminator(terminator))
  { *Input_End++ = ((terminator == C_M) ? '\n' : terminator);
    return NO_INTERRUPTS;
  }
  return terminator;
}
\f


/* Keyboard input */

extern char OS_tty_tyi();

char OS_tty_tyi(Immediate, Interrupted)
Boolean Immediate, *Interrupted;
{ *Interrupted = false;
  while (Input_Pointer >= Input_End) /* Should be == ... */
  { int result = fill_input_buffer((Immediate ? 1 : INPUT_BUF_SIZE), true);
    if ((result != NO_INTERRUPTS) &&
        (Sift_Out_Interrupt(result) == INTERRUPT))
    { *Interrupted = true;
      return EOF;
    }
  }
  return (*Input_Pointer++ & 0377);
}

/* Flushes type ahead and ignores other interrupts */

char Interrupt_Getchar()
{ int result;
  do
  { Initialize_Input();
    result = fill_input_buffer(1, false);
  } while (result != NO_INTERRUPTS);
  return *Input_Pointer++;
}  

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

char Int_Char;

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


/* Interrupt handlers */

long Ask_Me()
{ char command;
  putchar('\007');
  putchar('\n');
Loop:
  printf("Interrupt character (? for help): ");
  command =  Interrupt_Getchar();
  switch (command)
  { case 'B':
    case 'b': Int_Char = CONTROL_B; break;

    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;
\f


    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 'H':
    case 'h': printf("\nThe following control characters are available at\n");
              printf("any time in Scheme:\n\n");
              printf("^A: interactive choice of interrupt\n");
              printf("^B: create and enter a breakpoint REP loop\n");
              printf("^F: abort to current REP loop\n");
              printf("^G: abort to top level REP loop\n");
              printf("^P: abort to previous (lower number) REP loop\n");
	      printf("^Z: exit Scheme temporarily\n");
              printf("<returning to Scheme>\n\n");
              goto exit_gracefully;

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

    case 'Z':
    case 'z':
    	      putchar('\n');
	      Suspend_Me(true);
	      goto exit_gracefully;

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

    case 'I':
    case 'i': 	 printf("gnored.\n");
exit_gracefully: return REDO;

    default: putchar('\n');
             printf("B: Enter a breakpoint loop\n");
             printf("D: Debugging: change interpreter flags\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 information about interrupt characters\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: Exit Scheme temporarily\n");
             printf("^L: Clear the screen\n");
             goto Loop;
  }
  IntCode |= INT_Character;
  New_Compiler_MemTop();
  return INTERRUPT;
}
\f


/* Interrupt handlers, continued */

int Sift_Out_Interrupt(Interrupt_Char)
char Interrupt_Char;
{ interrupt_start(0, 0, false);
  switch(Interrupt_Char)
  { 
    case C_A:
      { long Result = Ask_Me();
        interrupt_end(Result);
      }
    case C_B:
      Int_Char = CONTROL_B; break;
    case C_G:
      Int_Char = CONTROL_G; break;
    case C_F:	/* You type ^F to get an ^X interrupt! */
      Int_Char = CONTROL_X; break;
    case C_P:	/* You type ^P to get an ^U interrupt! */
      Int_Char = CONTROL_U; break;
    case C_Z:
      { Suspend_Me(true);
	interrupt_end(REDO);
      }
    default:
      printf("\nAST error! Sift_Out_Interrupt %x",Interrupt_Char);
      Int_Char = 0;
      interrupt_end(REDO);
  }
  printf("^%c", Int_Char);
  IntCode |= INT_Character;
  New_Compiler_MemTop();
  interrupt_end(INTERRUPT);
}
\f


/* Temporary exit to parent process */

#define LAST_ITEM 0

Suspend_Me(from_interrupt)
Boolean from_interrupt;
{ int result;
  short nbytes = 0;       
  long pid = -1;

  struct Block ignore_me;
  struct item_desc {
		     short length;
		     short code;
		     long *buffer;
                     short *ret_length;
		    } item_block[2];

  item_block[0].code = JPI$_OWNER;
  item_block[0].length = sizeof(long);
  item_block[0].buffer = &pid;
  item_block[0].ret_length = &nbytes;
  item_block[1].code = LAST_ITEM;
  item_block[1].length = 0;
  item_block[1].buffer = NULL;
  item_block[1].ret_length = NULL;
  result = SYS$GETJPI( 0, NULL, NULL, &item_block[0], &ignore_me, NULL, 0);
  if (result != SS$_NORMAL)
  { printf("SYS$GETJPI returned %d != SS$_NORMAL; Continuing\n", result);
    return;
  }
  if (result == 0)
  { printf("Scheme is running at top level, it cannot detach\n");
    return;
  }
  OS_Quit();
  result = LIB$ATTACH(&pid);
  if (result != SS$_NORMAL)
    printf("LIB$ATTACH returned %d; Continuing\n", result);
  OS_Re_Init();
  return;
}
\f


/* Initializes OS dependent information for Scheme */

OS_Init()
{ OS_Name = "vms";
  OS_Variant = NULL;
  printf("MIT Scheme, VMS version\n");
  printf("^AH (CTRL-A, then H) shows help on interrupt keys.\n");
  Int_Char = 0;
  TT_Channel = 0;
  Init_System_Clock();
  OS_Re_Init();
  return;
}

OS_Re_Init()
{ static $DESCRIPTOR(Device_Name,"SYS$INPUT");
  if (TT_Channel == 0)
  { long Return_Status = SYS$ASSIGN(&Device_Name,&TT_Channel,3,0);
    if (Return_Status != SS$_NORMAL)
    { fprintf(stderr, "\nUnable to find Terminal: SYS$ASSIGN\n");
      Microcode_Termination(TERM_EOF);
    }
    else Setup_Scheme_Interrupts();
  }
  else Setup_Scheme_Interrupts();
  Initialize_Input();
  return;
}

OS_Quit()
{ if (TT_Channel != 0) Clear_Scheme_Interrupts();
  return;
}
\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;
}

#ifdef COMPILE_FUTURES
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

⟦b6f2f687e⟧ TextFile

Derivation

TextFile
