385 lines
13 KiB
C
385 lines
13 KiB
C
/* =====> SMAIN.C */
|
||
/* TIPC Scheme '84 Runtime Support - Driver
|
||
(C) Copyright 1984,1985,1986,1987,1988 by Texas Instruments Incorporated.
|
||
All rights reserved.
|
||
|
||
Author: John C. Jensen
|
||
Installation: Texas Instruments Incorporated, Dallas, Texas
|
||
Division: Central Research Laboratories
|
||
Cost Center: Computer Science Laboratory
|
||
Project: Computer Architecture Branch
|
||
Date Written: 12 April 1984
|
||
Last Modification: 23 October 1985
|
||
rb 5/21/86 - added PCS 2.0 command line parameters
|
||
tc 6/03/86 - added call to initmem, include version.h
|
||
dbs 10/21/86 - added EGA support
|
||
rb 2/20/87 - PCS 3.0 command line parsing; XLI initialization
|
||
rb 5/11/87 - pcs-sysdir is determined earlier so XLI can use it
|
||
*/
|
||
|
||
#include "version.h"
|
||
#include "scheme.h"
|
||
#include "sport.h"
|
||
#include "pcmake.h"
|
||
|
||
#define COPYRIGHT "\n(C) Copyright 1988 by Texas Instruments"
|
||
#define AIACOPY "\n(C) Copyright A.I. Architects, Inc. 1987,1988."
|
||
#define RIGHTS "\n All Rights Reserved.\n"
|
||
|
||
#define N_SYMBS 14 /* number of special symbols to be interned */
|
||
static char *spec_symbs[N_SYMBS] = {"SCHEME-TOP-LEVEL", "READ", "EOF",
|
||
"INPUT-PORT", "OUTPUT-PORT", "CONSOLE",
|
||
"*THE-NON-PRINTING-OBJECT*", "USER-GLOBAL-ENVIRONMENT",
|
||
"USER-INITIAL-ENVIRONMENT", "*ERROR-HANDLER*",
|
||
"PCS-STATUS-WINDOW", "T", "NIL", "PCS-KILL-ENGINE"};
|
||
|
||
static char *app_default = "compiler.app";
|
||
static char *ini_default = "scheme.ini";
|
||
static char *ctl_default = "scheme.xli";
|
||
char *app_file; /* VM bootstrap file */
|
||
char *ini_file; /* Scheme startup file */
|
||
char *ctl_file; /* XLI control file */
|
||
char *pcs_sysdir; /* PCS system directory name */
|
||
|
||
/* Definition of Lattice C's memory management variables */
|
||
/*%%unsigned _top; /* "top" of the runtime stack */*/
|
||
/*%%unsigned _base; /* "bottom" of the runtime stack */*/
|
||
/*%%unsigned _paras; /* number of paragraphs of memory available */*/
|
||
/*%%unsigned _psp; /* program segment prefix paragraph address */*/
|
||
/*%%unsigned first_page; /* paragraph address for first physical page */*/
|
||
|
||
/* Up Lattice C's runtime stack space to 12K bytes */
|
||
int _stack = 12288;
|
||
|
||
main(argc,argv)
|
||
int argc;
|
||
char *argv[];
|
||
{
|
||
int i,j; /* the usual index variable(s) */
|
||
int page_count; /* count of pages allocated during memory initialization */
|
||
/*%%int paragraphs_per_page; /* the number of paragraphs in a standard page */*/
|
||
int *ptr; /* pointer to current register */
|
||
int *ptr_r1; /* pointer to VM register 1 */
|
||
int sym_reg[2]; /* temporary register for symbol pointer */
|
||
/*%%int page, disp; /* temporary pointers for register contents */*/
|
||
int stat; /* status variable */
|
||
|
||
static int fix4[2] = {4, SPECFIX*2};
|
||
static int fix7[2] = {7, SPECFIX*2};
|
||
static int fix24[2] = {24, SPECFIX*2};
|
||
static int fix112[2] = {112, SPECFIX*2}; /* 70 hex */
|
||
static int fix135[2] = {135, SPECFIX*2}; /* 87 hex */
|
||
static int make[2] = {0, SPECFIX*2};
|
||
static int in_ptr[2] = {IN_DISP, IN_PAGE*2};
|
||
static int who_ptr[2] = {WHO_DISP, WHO_PAGE*2};
|
||
|
||
extern unsigned _SS(); /* function to return the stack segment (SS) reg */
|
||
extern unsigned _DS(); /* function to return the data segment (DS) reg */
|
||
extern VID_MODE; /* current video mode */
|
||
|
||
char *set_path();
|
||
char *get_path();
|
||
void parse_files();
|
||
|
||
ENTER(main);
|
||
|
||
#ifdef PROMEM
|
||
parse_files(&argc, &argv, &app_file, &ctl_file, &ini_file);
|
||
/* Gets the file mix and sets debug mode */
|
||
|
||
pcs_sysdir = get_path(app_file);
|
||
/* get Scheme directory name; if can't load an .EXE */
|
||
/* file, try it again with this prefix */
|
||
|
||
pcinit(); /* Initialize PC specific things - see pro2real.asm */
|
||
|
||
#else
|
||
|
||
pc_type(); /* Check the system ROM's copyright notice to see */
|
||
/* if this PC is made by TI or a competitor. */
|
||
|
||
fix_intr(); /* "Fixes" keyboard DSR to have SHIFT-BRK cause the */
|
||
/* debugger to "kick-in" on the next VM instruction */
|
||
/* "Fixes" 24H int DOS Fatal error too */
|
||
/* The keyboard is restored in SC.ASM */
|
||
|
||
pcinit(); /* This calls a routine in XGROUP that will do most */
|
||
/* any "special" pc-dependent initialization. */
|
||
/* For now it only does TIPC & IBM. (thank God) */
|
||
|
||
parse_files(&argc, &argv, &app_file, &ctl_file, &ini_file);
|
||
/* Gets the file mix and sets debug mode */
|
||
|
||
pcs_sysdir = get_path(app_file);
|
||
/* get Scheme directory name; if can't load an .EXE */
|
||
/* file, try it again with this prefix */
|
||
if (pcs_sysdir) {
|
||
xli_init(); /* Load in external language files. */
|
||
} /* The error of no system directory name is detected */
|
||
/* further below. */
|
||
#endif
|
||
|
||
page_count = initmem();
|
||
|
||
/* Initialize the console window */
|
||
|
||
zcuroff();
|
||
clear_window(in_ptr);
|
||
set_window_attribute(in_ptr, fix4, fix24);
|
||
|
||
/* Print Welcome to Scheme */
|
||
|
||
ssetadr(ADJPAGE(OUT_PAGE), OUT_DISP);
|
||
outtext(VERSION, strlen(VERSION));
|
||
outtext(COPYRIGHT, strlen(COPYRIGHT));
|
||
#ifdef PROMEM
|
||
outtext(AIACOPY, strlen(AIACOPY));
|
||
#endif
|
||
outtext(RIGHTS, strlen(RIGHTS));
|
||
|
||
/* Display the "who-line" */
|
||
|
||
if (PC_MAKE != TIPC && VID_MODE < 14)
|
||
set_window_attribute(who_ptr, fix7, fix112);
|
||
if (PC_MAKE != TIPC && VID_MODE > 13)
|
||
set_window_attribute(who_ptr, fix7, fix135);
|
||
clear_window(who_ptr);
|
||
who_clear();
|
||
|
||
/* Print Out Data Concerning Memory Management */
|
||
/*****
|
||
printf("Total number of paragraphs: >%x\n_top: >%x\n_base: >%x\n\n",
|
||
_paras,_top,_base);
|
||
*****/
|
||
if (page_count <= 0) {
|
||
print_and_exit("[VM FATAL ERROR] Unable to allocate memory for PC Scheme\n");
|
||
}
|
||
else {
|
||
pagelink[nextpage-1] = END_LIST;
|
||
/*****
|
||
printf("%d memory pages allocated for Scheme\n", page_count);
|
||
*****/
|
||
}
|
||
|
||
/* define PCS-INITIAL-ARGUMENTS: ("file(s)" "arg1" "arg2" ...) */
|
||
|
||
ptr_r1 = (int *) ®s[1]; /* VM reg 1 will get compiler filename */
|
||
intern (sym_reg, "PCS-INITIAL-ARGUMENTS", 21);
|
||
if (argc <= 1) { /* there are no command line arguments */
|
||
regs[1] = 0;
|
||
}
|
||
else {
|
||
ptr = (int *) ®s[3]; /* stuff VM registers with parameters */
|
||
for (i = 1; i < argc; i++) {
|
||
alloc_string(ptr, argv[i]);
|
||
ptr += 2;
|
||
}
|
||
ptr -= 2;
|
||
cons(ptr_r1, ptr, nil_reg); /* cons onto empty list */
|
||
for (i = argc-2; i >= 1; i--) { /* continue consing */
|
||
ptr -= 2;
|
||
cons(ptr_r1, ptr, ptr_r1);
|
||
}
|
||
}
|
||
sym_bind(sym_reg, ptr_r1, GNV_reg);
|
||
|
||
/* establish the Scheme system directory pathname */
|
||
|
||
app_file = set_path(pcs_sysdir,app_file);
|
||
alloc_string(ptr_r1,app_file); /* put compiler name into VM register 1 */
|
||
if (VM_debug) { /* put VM debug flag into VM register 2 */
|
||
/* if flag on, then R2 = Scheme 0, i.e. tagged fixnum zero */
|
||
*(ptr_r1+2) = 0;
|
||
*(ptr_r1+3) = SPECFIX * 2;
|
||
}
|
||
else {
|
||
/* if flag off, then R2 = binary 0, i.e. nil */
|
||
regs[2] = 0;
|
||
}
|
||
|
||
/* Define the symbol 'quote */
|
||
|
||
intern (tmp_reg, "QUOTE", 5);
|
||
QUOTE_PAGE = CORRPAGE(tmp_page);
|
||
QUOTE_DISP = tmp_disp;
|
||
|
||
/* Create the special interned symbols */
|
||
|
||
for (i = 0, j = 6; i < N_SYMBS; i++, j += PTRSIZE) {
|
||
intern (tmp_reg, spec_symbs[i], strlen(spec_symbs[i]));
|
||
put_ptr(SPECCODE, j, tmp_page, tmp_disp);
|
||
}
|
||
intern (CONSOLE_, "CONSOLE", 7);
|
||
|
||
/* Define the global symbol *pc-make* */
|
||
|
||
intern (fix4, "PCS-MACHINE-TYPE", 16);
|
||
make[C_DISP] = PC_MAKE;
|
||
sym_bind(fix4, make, GNV_reg);
|
||
|
||
/* Execute loader-- run time "halt" or "debug" condition detected */
|
||
|
||
while (!(stat = interp(&S_pc, 0x7FFF))) /* do nothing */ ;
|
||
|
||
if (stat == 2) /* enter interactive debugger */
|
||
sdebug();
|
||
|
||
} /* end of function: main(argc,argv) */
|
||
|
||
/************************************************************************/
|
||
/* "Clear" the Who-Line */
|
||
/************************************************************************/
|
||
who_clear()
|
||
{
|
||
int lcl_reg[2]; /* local register */
|
||
char *text; /* "garbage collection" message text */
|
||
char *string_asciz(); /* returns C equivalent of a Scheme string */
|
||
|
||
intern(lcl_reg, "PCS-GC-RESET", 12);
|
||
if (sym_lookup (lcl_reg, GNV_reg) &&
|
||
(text = string_asciz(lcl_reg))) {
|
||
who_write("\n");
|
||
who_write(text);
|
||
rlsstr(text);
|
||
}
|
||
else {
|
||
who_write(VERSION);
|
||
}
|
||
}
|
||
|
||
/************************************************************************/
|
||
/* Determine PC Scheme's System Directory Pathname */
|
||
/************************************************************************/
|
||
char *set_path(directory,filespec)
|
||
char *directory; /* PCS system directory pathname character string */
|
||
char *filespec; /* compiler filename */
|
||
{
|
||
int fudge; /* fudge factor-- 1=no extra '\' needed, 2='\' needed */
|
||
int len; /* length of the return string */
|
||
int len_dir; /* length of the directory pathname */
|
||
char *ret_string; /* complete filename to be returned */
|
||
int sym_reg[2]; /* temporary register for symbol pointer */
|
||
|
||
char *get_path(); /* Search PATH= routine */
|
||
char *getmem(); /* Lattice C's memory allocation routine */
|
||
|
||
/*directory = get_path(filespec);*/ /* put earlier in smain so XLI can */
|
||
/* refer to the pcs-sysdir name */
|
||
if (directory) {
|
||
/* bind PCS-SYSDIR to the Scheme directory pathname */
|
||
intern(sym_reg, "PCS-SYSDIR", 10);
|
||
alloc_string(tm2_reg, directory);
|
||
sym_bind(sym_reg, tm2_reg, GNV_reg);
|
||
|
||
/* compute length of return string and allocate it */
|
||
len_dir = strlen(directory);
|
||
fudge = (len_dir ? (directory[len_dir-1] == '\\' ? 1 : 2) : 1);
|
||
len = strlen(filespec) + len_dir + fudge;
|
||
if (!(ret_string = getmem(len))) getmem_error("set_path");
|
||
|
||
/* concatenate directory path, "\" if needed, and filespec */
|
||
strcpy(ret_string, directory);
|
||
if (fudge == 2) strcat(ret_string, "\\");
|
||
strcat(ret_string, filespec);
|
||
rlsstr(directory);
|
||
}
|
||
else {
|
||
printf("[VM FATAL ERROR] File Not Found: %s\n", filespec);
|
||
getch();
|
||
exit();
|
||
}
|
||
return(ret_string);
|
||
} /* end set_path */
|
||
|
||
/************************************************************************/
|
||
/* Determine the .APP, .CTL, .INI files */
|
||
/************************************************************************/
|
||
|
||
/* Actually, we don't care anything about INI-type files at the VM level.
|
||
File PSTL.S does its own processing for INI files by examining
|
||
PCS-INITIAL-ARGUMENTS, so our limit of 1 INI file here has no
|
||
bearing on what PSTL.S sees or does. */
|
||
|
||
#define NFILES 3
|
||
void parse_files(argc,argv,app_file,ctl_file,ini_file)
|
||
int *argc;
|
||
char ***argv; /* this is same as char *(*argv)[] */
|
||
/* i.e. pointer to standard argv */
|
||
char **app_file, **ctl_file, **ini_file;
|
||
{
|
||
int i; /* index variable */
|
||
int intoken; /* in-token flag */
|
||
char *pfiles[NFILES]; /* ptrs to filenames inside argv[1] */
|
||
char *p,*r; /* scratch */
|
||
char **q = &r; /* scratch */
|
||
char debug_char = '\xEB'; /* 253, "delta" */
|
||
|
||
char *strchr(), *getmem();
|
||
|
||
/* command line is: PCS */
|
||
|
||
if (*argc <= 1) {
|
||
*app_file = app_default;
|
||
*ini_file = ini_default;
|
||
*ctl_file = ctl_default;
|
||
return;
|
||
}
|
||
|
||
/* command line is: PCS file(s) arg1 ... */
|
||
|
||
/* look for debug char */
|
||
|
||
p = strchr((*argv)[1],debug_char);
|
||
if (p) (*p = ' ', VM_debug = TRUE);
|
||
|
||
/* make a lowercase copy */
|
||
|
||
p = getmem(strlen((*argv)[1])+1);
|
||
(void) strcpy(p,(*argv)[1]);
|
||
for (i = 0; i < strlen(p); i++) p[i] = tolower(p[i]);
|
||
|
||
/* split out the filenames */
|
||
|
||
for (i = 0; i < NFILES; i++) pfiles[i] = NULL;
|
||
intoken = FALSE;
|
||
i = 0;
|
||
while (i < NFILES && *p) {
|
||
switch (*p) {
|
||
case ' ' : if (intoken) (i++, intoken = FALSE);
|
||
*p = '\0';
|
||
break;
|
||
case '(' :
|
||
case ')' : *p = '\0';
|
||
break;
|
||
default : if (!intoken) (pfiles[i] = p, intoken = TRUE);
|
||
} /* end switch */
|
||
p++;
|
||
} /* end while */
|
||
|
||
/* now determine who's who */
|
||
|
||
*app_file = *ctl_file = *ini_file = NULL;
|
||
for (i = 0; i < NFILES; i++) {
|
||
if (stcpm(pfiles[i],".app",q)) *app_file = pfiles[i];
|
||
else if (stcpm(pfiles[i],".xli",q)) *ctl_file = pfiles[i];
|
||
else if (pfiles[i]) *ini_file = pfiles[i];
|
||
} /* end for i */
|
||
if (*app_file == NULL) *app_file = app_default;
|
||
if (*ctl_file == NULL) *ctl_file = ctl_default;
|
||
} /* end parse_files */
|
||
#undef NFILES
|
||
|
||
/************************************************************************/
|
||
/* Assertion Processing Routine */
|
||
/************************************************************************/
|
||
#undef ASSERT
|
||
asrt$(rtn,str)
|
||
char *rtn, *str;
|
||
{
|
||
char ch;
|
||
printf("\n[VM INTERNAL ERROR] Assertion failure in %s\n'%s'\n%s",
|
||
rtn, str, "\nPress 'Q' to quit, any other key to continue\n");
|
||
ch = getch();
|
||
if (tolower(ch) == 'q') exit();
|
||
}
|
||
|