Unpack disk4.tgz
This commit is contained in:
parent
777c904054
commit
3855274aa5
|
|
@ -0,0 +1,136 @@
|
|||
/* =====> ASM_LINK.C */
|
||||
/* TIPC Scheme '84 Runtime Support - Linkage to non-Scheme Routines
|
||||
(C) Copyright 1984,1985 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: 20 June 1985
|
||||
Last Modification: 18 October 1985
|
||||
*/
|
||||
|
||||
#include "scheme.h"
|
||||
|
||||
asm_link(n_args, arg1, arg2, arg3, arg4, arg5, arg6, arg7)
|
||||
int n_args; /* the number of actual arguments */
|
||||
int arg1[2],arg2[2],arg3[2],arg4[2],arg5[2],arg6[2],arg7[2];
|
||||
{
|
||||
int i; /* the usual index variable */
|
||||
int page,disp; /* page and displacement components of a pointer */
|
||||
long *p[7]; /* pointers to arguments */
|
||||
int **ptr; /* pointer to current argument register address */
|
||||
double result_value; /* return area for result */
|
||||
double *result; /* pointer to result returned */
|
||||
int return_code = 0; /* return_code to send back to Scheme support */
|
||||
int stat; /* status returned from called procedure */
|
||||
int str_len[7]; /* length of dynamically allocated strings */
|
||||
|
||||
long integers[7];
|
||||
int chars[7];
|
||||
double flonums[7];
|
||||
char *strings[7];
|
||||
|
||||
char *string_asciz();
|
||||
double get_flo();
|
||||
|
||||
ENTER(asm_link);
|
||||
|
||||
/* null out string pointers */
|
||||
for (i = 0; i < 7; i++)
|
||||
{
|
||||
p[i] = NULL;
|
||||
strings[i] = NULL;
|
||||
str_len[i] = 0;
|
||||
}
|
||||
|
||||
/* create a C version of each argument */
|
||||
result = &result_value;
|
||||
ptr = &arg1;
|
||||
for (i = n_args-1; i >= 0; i--, ptr++)
|
||||
{
|
||||
page = CORRPAGE((*ptr)[C_PAGE]);
|
||||
disp = (*ptr)[C_DISP];
|
||||
switch (ptype[page])
|
||||
{
|
||||
case STRTYPE*2: strings[i] = string_asciz(*ptr);
|
||||
str_len[i] = get_word(page,disp+1);
|
||||
if (str_len[i] < 0) /* Adjust for small strings */
|
||||
str_len[i] = str_len[i] + BLK_OVHD + 1;
|
||||
else
|
||||
str_len[i] = str_len[i] - BLK_OVHD + 1;
|
||||
p[i] = (long *) strings[i];
|
||||
break;
|
||||
|
||||
case BIGTYPE*2:
|
||||
case FIXTYPE*2: if (int2long(integers+i, *ptr))
|
||||
goto bad_arg;
|
||||
p[i] = (long *) (integers+i);
|
||||
break;
|
||||
|
||||
case FLOTYPE*2: flonums[i] = get_flo(page, disp);
|
||||
p[i] = (long *) (flonums+i);
|
||||
break;
|
||||
|
||||
case CHARTYPE*2: chars[i] = get_char(page,disp);
|
||||
p[i] = (long *) (chars+i);
|
||||
break;
|
||||
bad_arg:
|
||||
default: return(1);
|
||||
} /* end: switch (ptype[page]) */
|
||||
} /* end: for (i = 0; i < n_args; i++, ptr++) */
|
||||
|
||||
/* all arguments ready-- call the interface routine */
|
||||
stat = link(&result,p[0],p[1],p[2],p[3],p[4],p[5],p[6]);
|
||||
|
||||
/* fetch result returned from low level return and make it a Scheme object */
|
||||
ptr = ((int **) &arg1) + (n_args - 1);
|
||||
switch (stat)
|
||||
{
|
||||
case 1: /* 't or 'nil */
|
||||
if (*((int *) result))
|
||||
{
|
||||
(*ptr)[C_PAGE] = T_PAGE*2;
|
||||
(*ptr)[C_DISP] = T_DISP;
|
||||
}
|
||||
else
|
||||
{
|
||||
(*ptr)[C_PAGE] = (*ptr)[C_DISP] = 0;
|
||||
}
|
||||
case 0: /* no value returned */
|
||||
break;
|
||||
|
||||
case 2: /* integer */
|
||||
long2int(*ptr, *((long *) result));
|
||||
break;
|
||||
|
||||
case 3: /* flonum */
|
||||
alloc_flonum(*ptr, *result);
|
||||
break;
|
||||
|
||||
case 4: /* character */
|
||||
(*ptr)[C_PAGE] = SPECCHAR*2;
|
||||
(*ptr)[C_DISP] = *((char *) result);
|
||||
break;
|
||||
|
||||
case 5: /* string */
|
||||
alloc_string(*ptr, result);
|
||||
break;
|
||||
|
||||
default: /* error */
|
||||
return_code = 1;
|
||||
} /* end: switch (stat) */
|
||||
|
||||
/* release memory allocated to character strings */
|
||||
for (i = 0; i < 7; i++)
|
||||
{
|
||||
if (strings[i])
|
||||
if (rlsmem(strings[i], str_len[i]))
|
||||
rlsmem_error(rtn_name);
|
||||
}
|
||||
|
||||
return(return_code);
|
||||
} /* end of function: asm_link(n_args, arg1, arg2, ... , arg7) */
|
||||
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
/* =====> FREESP.C */
|
||||
/* TIPC Scheme '84 -- Freespace Utility
|
||||
(C) Copyright 1984,1985 by Texas Instruments Incorporated.
|
||||
All rights reserved.
|
||||
|
||||
Author: Terry Caudill
|
||||
Date Written: 07 August 1985
|
||||
Last Modification:
|
||||
*/
|
||||
|
||||
#include "ctype.h"
|
||||
#include "scheme.h"
|
||||
|
||||
/**********************************************************************/
|
||||
/* TIPC Scheme '84 Free Space */
|
||||
/* */
|
||||
/* Purpose: This Routine will return the number of bytes of free */
|
||||
/* user memory. */
|
||||
/**********************************************************************/
|
||||
long int freesp()
|
||||
{
|
||||
int space[NUMPAGES]; /* Free memory per page array */
|
||||
int i; /* index var */
|
||||
long int bytes_free; /* word to sum bytes available */
|
||||
|
||||
ENTER(freesp);
|
||||
|
||||
sum_space(space);
|
||||
bytes_free = 0;
|
||||
|
||||
for (i = DEDPAGES; i < lastpage; i++)
|
||||
if (ptype[i] == FREETYPE*2)
|
||||
bytes_free = bytes_free + psize[i];
|
||||
else
|
||||
bytes_free = bytes_free + space[i];
|
||||
|
||||
return (bytes_free);
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,133 @@
|
|||
/* =====> GET_PORT */
|
||||
/* Copyright 1985 by Texas Instruments Incorporated.
|
||||
All Rights Reserved.
|
||||
|
||||
Author: John C. Jensen
|
||||
Installation: Texas Instruments Incorporated, Dallas, Texas
|
||||
Project: Computer Architecture Branch
|
||||
Date Written: January 1985
|
||||
Last Modification: 18 October 1985
|
||||
*/
|
||||
|
||||
#include "ctype.h"
|
||||
#include "scheme.h"
|
||||
|
||||
char *getmem(); /* Lattice C's memory allocation function */
|
||||
|
||||
/************************************************************************/
|
||||
/* Determine Port */
|
||||
/* */
|
||||
/* Purpose: To determine is a register contains a valid port object */
|
||||
/* representation and to return the appropriate port */
|
||||
/* pointer in "tmp_reg". */
|
||||
/************************************************************************/
|
||||
get_port(reg, mode)
|
||||
int reg[2], mode;
|
||||
{
|
||||
int disp; /* displacement component of a pointer */
|
||||
int page; /* page number component of a pointer */
|
||||
|
||||
/* fetch page and displacement portions of port pointer */
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
disp = reg[C_DISP];
|
||||
|
||||
/* check to see if port pointer is nil-- if so, search fluid env */
|
||||
if (!page)
|
||||
{
|
||||
if (mode) intern (tmp_reg, "OUTPUT-PORT", 11);
|
||||
else intern (tmp_reg, "INPUT-PORT", 10);
|
||||
|
||||
/* search fluid environment for interned symbol */
|
||||
ASSERT(fluid_lookup(tmp_reg));
|
||||
page = CORRPAGE(tmp_page);
|
||||
disp = tmp_disp;
|
||||
} /* end: if (!page) */
|
||||
|
||||
/* At this point, the page, disp should point to a port, or the
|
||||
symbol 'console */
|
||||
if (ptype[page] != PORTTYPE*2)
|
||||
{
|
||||
if (CORRPAGE(CON_PAGE) != page || CON_DISP != disp) return(1);
|
||||
tmp_page = SPECPOR*2;
|
||||
tmp_disp = (mode ? OUT_DISP : IN_DISP);
|
||||
}
|
||||
else
|
||||
{
|
||||
tmp_page = ADJPAGE(page);
|
||||
tmp_disp = disp;
|
||||
}
|
||||
return(0);
|
||||
} /* end of function: get_port(reg, mode) */
|
||||
|
||||
/***** Code turned off 17 May 1985 (JCJ) *****
|
||||
/************************************************************************/
|
||||
/* file-exists? Predicate */
|
||||
/* */
|
||||
/* Purpose: To support the "file-exists?" predicate for the Scheme */
|
||||
/* interpreter. */
|
||||
/* */
|
||||
/* Author: John C. Jensen */
|
||||
/* Installation: Texas Instruments Incorporated, Dallas, Texas */
|
||||
/* Department: Computer Science Laboratory */
|
||||
/* Project: Computer Architecture Branch */
|
||||
/* Date Written: 17 January 1985 */
|
||||
/* Last Modification: 17 January 1985 */
|
||||
/* */
|
||||
/* Calling Sequence: file_exists(reg) */
|
||||
/* where reg - VM register containing the string */
|
||||
/* which is the filename of the */
|
||||
/* file in question. The contents */
|
||||
/* of this register is replaced */
|
||||
/* with the 't if the file exists */
|
||||
/* or 'nil if it does not. */
|
||||
/************************************************************************/
|
||||
file_exists(reg)
|
||||
int reg[2]; /* parameter register */
|
||||
{
|
||||
char *buffer; /* character buffer for filename */
|
||||
int disp; /* displacement component of a pointer */
|
||||
int handle; /* file "handle" */
|
||||
int len; /* length of the file name (bytes) */
|
||||
int page; /* page number component of a pointer */
|
||||
int retstat = 0; /* return status */
|
||||
int type; /* type code of a pointer */
|
||||
ENTER (file_ex);
|
||||
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
disp = reg[C_DISP];
|
||||
type = ptype[page];
|
||||
|
||||
switch (type)
|
||||
{
|
||||
case STRTYPE*2: len = get_word(page, disp+1) - BLK_OVHD;
|
||||
if (!(buffer = getmem(len+1))) getmem_error(rtn_name);
|
||||
get_str(buffer, page, disp);
|
||||
buffer[len] = '\0';
|
||||
if (zopen(&handle, buffer, 0, &retstat, &retstat))
|
||||
{ /* open failed-- file does not exist */
|
||||
reg[C_PAGE] = reg[C_DISP] = 0;
|
||||
}
|
||||
else
|
||||
{ /* open succeeded-- close file and return 't */
|
||||
zclose (handle);
|
||||
reg[C_PAGE] = T_PAGE*2;
|
||||
reg[C_DISP] = T_DISP;
|
||||
}
|
||||
rlsstr(buffer);
|
||||
break;
|
||||
|
||||
case SYMTYPE*2: if (CON_PAGE == reg[C_PAGE] && CON_DISP == reg[C_DISP])
|
||||
{
|
||||
reg[C_PAGE] = T_PAGE*2;
|
||||
reg[C_DISP] = T_DISP;
|
||||
break;
|
||||
}
|
||||
|
||||
default: /* invalid source operand */
|
||||
set_src_err("FILE-EXISTS?", 1, reg);
|
||||
retstat = -1;
|
||||
} /* end: case (type) */
|
||||
return(retstat);
|
||||
} /* end of function: file_exists(reg) */
|
||||
***** Code turned off 17 May 1985 (JCJ) *****/
|
||||
|
||||
|
|
@ -0,0 +1,618 @@
|
|||
/* =====> MAKE_FSL.C */
|
||||
/* TIPC Scheme Runtime Support - Conversion To Fast Load Format
|
||||
(C) Copyright 1984,1985,1987 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: 27 December 1984
|
||||
Last Modification: 17 October 1985
|
||||
|
||||
Purpose: To convert PC Scheme object programs into a fast-load format.
|
||||
|
||||
Description: Object programs are read in by the make_fsl utility and an
|
||||
equivalent fast-load representation is output. This utility
|
||||
preforms similarly to the Scheme reader, but it understands
|
||||
only enough about s-expressions to read in valid object
|
||||
programs in a standard format. Any error condition will
|
||||
abort the exectution of this utility.
|
||||
|
||||
The format of the object module which can be read by
|
||||
this utility is:
|
||||
|
||||
(execute (quote (pcs-code-block #consts #codebytes (constants) (code))))
|
||||
|
||||
where pcs-code-block is a compiler generated tag indicating
|
||||
that this is an object module.
|
||||
#consts is an integer value indicating the number of
|
||||
source contants in the compiled program.
|
||||
This is the number of entries in the
|
||||
"constants" list (see below).
|
||||
#codebytes is an integer value indicating the number
|
||||
of bytes of executable code in the compiled
|
||||
program. This is the number of entries in
|
||||
the "code" list (see below).
|
||||
(constants) is a list of program constants. Each
|
||||
constant is a Scheme s-expression in its
|
||||
ASCII source representation.
|
||||
(code) is a list of integer values representing the
|
||||
executable code of the compiled program.
|
||||
|
||||
Invocation: The MAKE_FSL utility is executed by entering the following
|
||||
command to MS-DOS:
|
||||
|
||||
MAKE_FSL PROGRAM.SO PROGRAM.FSL {/copyright}
|
||||
|
||||
where PROGRAM.SO is a valid MS-DOS file name of a file
|
||||
containing the object program (the output
|
||||
of the PC Scheme compiler),
|
||||
|
||||
PROGRAM.FSL is a valid MS-DOS file name of the file
|
||||
which is to contain the fast-load
|
||||
representation produced by this utility.
|
||||
|
||||
/copyright is an optional flag which indicates that,
|
||||
instead of the standard fast-load module
|
||||
header record, a TI copyright notice is
|
||||
to be inserted in the output file.
|
||||
|
||||
Note: The /copyright option is an undocumented feature designed to
|
||||
add some measure of protection for TI proprietary software. This
|
||||
capability is not intended to be visible to the general user
|
||||
community and is not documented in any of the messages produced
|
||||
by this utility.
|
||||
|
||||
Modification History:
|
||||
02 Feb 86 - Made two changes which corrected problems in reading
|
||||
symbols containing backslash characters. According to
|
||||
the Common Lisp standard, a backslash is an escape
|
||||
character, which causes the character following it to
|
||||
be accepted as part of the symbol.
|
||||
rb 15 Oct 86 - changed %x to %X; fasl expects uppercase and Lattice C
|
||||
now distinguishes the two printf formats
|
||||
*/
|
||||
#include "stdio.h"
|
||||
#include "ctype.h"
|
||||
|
||||
#include "schars.h" /* copy in special character definitions */
|
||||
|
||||
#define MAX_STRING_LENGTH 8192 /* maximum string length */
|
||||
|
||||
#define TRUE 1
|
||||
#define FALSE 0
|
||||
#define skip_space() ch=fgetc(in_file); while(isspace(ch))ch=fgetc(in_file);
|
||||
|
||||
static FILE *in_file, *out_file; /* input/output file pointers */
|
||||
static int count = 0; /* count of characters in current record */
|
||||
|
||||
static char *month[12] = {"Jan","Feb","Mar","Apr","May","Jun",
|
||||
"Jul","Aug","Sep","Oct","Nov","Dec"};
|
||||
|
||||
int _stack = 12288; /* Increase Lattice C's default stack size */
|
||||
|
||||
int _fmode = 0; /* default files to text mode translation */
|
||||
|
||||
char *getmem(); /* Lattice C's memory allocation routine */
|
||||
|
||||
main(argc, argv)
|
||||
int argc; /* number of arguments */
|
||||
char *argv[]; /* array of ptrs to arg strings */
|
||||
{
|
||||
int cflag = FALSE; /* copyright notice flag */
|
||||
int ch; /* current character */
|
||||
int codebytes = 0; /* number of codebytes */
|
||||
int constants = 0; /* number of constants */
|
||||
int date[3]; /* array to receive current date */
|
||||
int module = 0; /* module count */
|
||||
int n; /* number of fields read */
|
||||
int time[4]; /* array to receive current time */
|
||||
static char *invalid_module = "***Error-- Invalid Object Module***\n%s\n";
|
||||
|
||||
/* Print Welcome to Scheme */
|
||||
printf("\nFast-Load Conversion Utility for PC Scheme\n%s%s%s\n",
|
||||
" Version 3.03 7 June 88\n",
|
||||
" (C) Copyright 1987 by Texas Instruments\n",
|
||||
" All Rights Reserved.\n");
|
||||
|
||||
/* test for generation of copyright notice */
|
||||
if (argc == 4)
|
||||
{
|
||||
if (!strcmp(argv[3], "/copyright"))
|
||||
{
|
||||
cflag = TRUE;
|
||||
argc = 3;
|
||||
}
|
||||
}
|
||||
|
||||
/* test for proper number of arguments */
|
||||
if (argc != 3)
|
||||
{
|
||||
printf("***Error-- Wrong Number of Arguments to MAKE_FSL***\n");
|
||||
describe:
|
||||
printf("\nMAKE_FSL expects two file names as follows:\n\n%s%s%s%s%s",
|
||||
" MAKE_FSL PROGRAM.SO PROGRAM.FSL\n\n",
|
||||
"where PROGRAM.SO is the output of the 'compile-file' function of",
|
||||
" the PC Scheme Compiler\n",
|
||||
" PROGRAM.FSL is the name of the file which is to contain the\n",
|
||||
" output of the MAKE_FSL utility.\n");
|
||||
exit();
|
||||
}
|
||||
|
||||
/* open input file */
|
||||
_fmode = 0x8000; /* make files use binary (untranslated) output */
|
||||
if (!(in_file = fopen(argv[1], "r")))
|
||||
{
|
||||
printf("***Error-- Unable to Open Input File '%s'***\n", argv[1]);
|
||||
goto describe;
|
||||
}
|
||||
|
||||
/* open output file */
|
||||
if (!(out_file = fopen(argv[2], "w")))
|
||||
{
|
||||
printf("***Error-- Unable to Open Output File '%s'***\n", argv[2]);
|
||||
goto describe;
|
||||
}
|
||||
_fmode = 0; /* reset to text mode translation */
|
||||
|
||||
/* obtain current time and date */
|
||||
get_date(date);
|
||||
|
||||
/* Output header record(s) to output file */
|
||||
if (cflag)
|
||||
{
|
||||
/* Output TI Copyright notice */
|
||||
fprintf(out_file,
|
||||
"#!fast-load (C) Copyright %4d by Texas Instruments\r\n%s",date[2],
|
||||
"#!fast-load All Rights Reserved.\r\n");
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Output module header to output file */
|
||||
get_time(time);
|
||||
fprintf(out_file, "#!fast-load Version 3.0 %2d %s %2d %02d:%02d:%02d\r\n",
|
||||
date[1], month[date[0]-1], date[2]-1900, time[0], time[1], time[2]);
|
||||
}
|
||||
|
||||
/* read 'til end-of-file */
|
||||
skip_space();
|
||||
while (ch != EOF && ch != '\032')
|
||||
{
|
||||
/* read (skip over) object module "header" */
|
||||
n = -1;
|
||||
if (ch != '(') goto oops_header;
|
||||
ch = fgetc(in_file);
|
||||
if (ch == '%') ch = fgetc(in_file); /* "optional" % in front of execute */
|
||||
for (n = 0; n < 30; n++)
|
||||
{
|
||||
ch = tolower(ch);
|
||||
if (ch != "execute (quote (pcs-code-block "[n])
|
||||
{
|
||||
oops_header:
|
||||
printf(invalid_module, "Bad Module Header");
|
||||
printf("n = %d ch = '%c'\n", n, ch);
|
||||
exit();
|
||||
}
|
||||
ch = fgetc(in_file);
|
||||
}
|
||||
|
||||
/* read number of constants, number of code bytes */
|
||||
fscanf(in_file, "%d %d", &constants, &codebytes);
|
||||
fprintf(out_file, "h%04X %04X\r\n", constants, codebytes);
|
||||
|
||||
/* skip over '(' which begins constants list */
|
||||
skip_space();
|
||||
if (ch != '(')
|
||||
{
|
||||
if (constants || ch != 'n' || (ch = fgetc(in_file)) != 'i' ||
|
||||
(ch = fgetc(in_file)) != 'l')
|
||||
{
|
||||
printf (invalid_module, "Bad Start of Constants List");
|
||||
printf("ch = '%c'\n", ch);
|
||||
exit();
|
||||
}
|
||||
else goto good_const;
|
||||
}
|
||||
|
||||
/* read and output constants */
|
||||
for (n = 0; n < constants; n++)
|
||||
{
|
||||
count = 0;
|
||||
process_constant();
|
||||
fprintf(out_file, "\r\n");
|
||||
}
|
||||
|
||||
/* make sure constants list was exhausted */
|
||||
skip_space();
|
||||
if (ch != ')')
|
||||
{
|
||||
printf (invalid_module, "Bad End of Constants List");
|
||||
printf("ch = '%c'\n", ch);
|
||||
exit();
|
||||
}
|
||||
good_const:
|
||||
/* output start of code bytes */
|
||||
fputc('t', out_file);
|
||||
|
||||
/* read and format code bytes */
|
||||
skip_space();
|
||||
if (ch != '(')
|
||||
{
|
||||
printf(invalid_module,"Bad Start of Codebytes");
|
||||
printf("Looking For '('\n");
|
||||
exit();
|
||||
}
|
||||
|
||||
for (count = n = 0; n < codebytes; n++)
|
||||
{
|
||||
fscanf(in_file, "%d", &ch);
|
||||
fprintf(out_file, "%c", (ch & 0x00ff));
|
||||
count++;
|
||||
/* if (count++ == 34)
|
||||
{
|
||||
fprintf(out_file, "\r\n");
|
||||
count = 0;
|
||||
} */
|
||||
}
|
||||
if (count) fprintf(out_file, "\r\n"); /* complete last text record */
|
||||
|
||||
/* flush closing parenthesis from program's end */
|
||||
for (n = 0; n < 4; n++)
|
||||
{
|
||||
skip_space();
|
||||
if (ch != ')')
|
||||
{
|
||||
printf(invalid_module,"Closing Parenthesis");
|
||||
exit();
|
||||
}
|
||||
}
|
||||
|
||||
/* write trailer record for object program */
|
||||
fprintf(out_file, "z\r\n");
|
||||
printf("module %d complete\n", module++);
|
||||
|
||||
/* skip over white space at end of program */
|
||||
skip_space();
|
||||
}
|
||||
|
||||
/* close the input and output files */
|
||||
if (fclose(in_file)) printf("***Error Closing Input File***\n");
|
||||
if (fclose(out_file)) printf("***Error Closing Output File***\n");
|
||||
|
||||
} /* end of function: main(argc, argv) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Process Constant List Entry */
|
||||
/************************************************************************/
|
||||
process_constant()
|
||||
{
|
||||
int big_parts[2]; /* the two words of a 32-bit bignum value */
|
||||
char buffer[300]; /* input buffer */
|
||||
int ch; /* the current character */
|
||||
char *ch_buffer; /* character string buffer (dynamic) */
|
||||
double flonum; /* a floating point value */
|
||||
int flo_parts[4]; /* the four words of a floating point value */
|
||||
int i,j; /* our old favorite index variables */
|
||||
int n; /* character count */
|
||||
int sign; /* sign flag for integer values */
|
||||
long value; /* accumulator for integer values */
|
||||
int vect_count; /* number of entries in a vector */
|
||||
long vect_end; /* ending offset in out_file for a vector */
|
||||
long vect_start; /* starting offset in out_file for a vector */
|
||||
|
||||
long ftell(); /* returns the current position of a file */
|
||||
|
||||
/* if current constant entry is "long enough", break this record */
|
||||
if (count > 72)
|
||||
{
|
||||
fprintf(out_file, "\r\n");
|
||||
count = 0;
|
||||
}
|
||||
|
||||
/* skip over white space in front of constant */
|
||||
skip_space();
|
||||
|
||||
/* make an initial attempt to decide the constant's type */
|
||||
switch (ch)
|
||||
{
|
||||
case '"': /* the beginnings of a character string */
|
||||
if (!(ch_buffer = getmem(MAX_STRING_LENGTH)))
|
||||
{
|
||||
printf("***Error-- Memory Exhausted***\n");
|
||||
exit();
|
||||
}
|
||||
n = 0;
|
||||
do {
|
||||
ch = fgetc(in_file);
|
||||
if (ch != '\r')
|
||||
{
|
||||
if (ch == '\\')
|
||||
{
|
||||
ch_buffer[n++] = fgetc(in_file);
|
||||
}
|
||||
else
|
||||
{
|
||||
ch_buffer[n++] = ch;
|
||||
}
|
||||
}
|
||||
} while (ch != '"');
|
||||
n--; /* decrement to remove the closing '"' */
|
||||
if (n > MAX_STRING_LENGTH)
|
||||
{
|
||||
printf("***Error-- String Too Long***\n%s",
|
||||
"MAKE_FSL limits strings to %d characters\n",
|
||||
MAX_STRING_LENGTH);
|
||||
exit();
|
||||
}
|
||||
fprintf(out_file, "s%04X", n);
|
||||
for (i = 0; i < n; i++) fputc(ch_buffer[i], out_file);
|
||||
count += (n + 3);
|
||||
if (rlsmem(ch_buffer, MAX_STRING_LENGTH))
|
||||
{
|
||||
printf("***Warning-- Release Memory Error***\n");
|
||||
}
|
||||
break;
|
||||
|
||||
case '(': /* begin a list */
|
||||
ch = fgetc(in_file);
|
||||
if (ch == ')')
|
||||
{ /* empty list found-- output "nil" */
|
||||
fputc('n', out_file);
|
||||
count++;
|
||||
goto blow_this_place;
|
||||
}
|
||||
else
|
||||
{
|
||||
nuther_list:
|
||||
ungetc(ch, in_file);
|
||||
fputc('l', out_file);
|
||||
count++;
|
||||
process_constant();
|
||||
skip_space();
|
||||
if (ch == ')')
|
||||
{
|
||||
fputc('n', out_file);
|
||||
count++;
|
||||
goto blow_this_place;
|
||||
}
|
||||
else
|
||||
{
|
||||
if (ch == '.')
|
||||
{
|
||||
ch = fgetc(in_file);
|
||||
if (!isspace(ch))
|
||||
{
|
||||
/* character after '.'-- it's a symbol */
|
||||
ungetc(ch, in_file);
|
||||
ch = '.';
|
||||
goto nuther_list;
|
||||
}
|
||||
process_constant();
|
||||
skip_space();
|
||||
if (ch != ')')
|
||||
{
|
||||
printf("***Error-- Invalid List Constant (cdr)***\n");
|
||||
exit();
|
||||
}
|
||||
goto blow_this_place;
|
||||
}
|
||||
else goto nuther_list;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
case '|': /* a special slashified symbol */
|
||||
n = 0;
|
||||
do {
|
||||
ch = fgetc(in_file);
|
||||
if (ch == '\\') ch = fgetc(in_file); /*** 2/14/86 ***/
|
||||
if (ch != '\r')
|
||||
{
|
||||
if (ch == '|')
|
||||
{
|
||||
if (n > 0x00ff)
|
||||
{
|
||||
printf("***Error-- Symbol Too Long***\n%s",
|
||||
"MAKE_FSL limits symbols to 255 characters\n");
|
||||
exit();
|
||||
}
|
||||
fprintf(out_file, "x%02X", n);
|
||||
for (i = 0; i < n; i++) fputc(buffer[i], out_file);
|
||||
count += (n+3);
|
||||
goto blow_this_place;
|
||||
}
|
||||
buffer[n++] = ch;
|
||||
}
|
||||
} while (TRUE);
|
||||
|
||||
case '#': /* special constants (we hope) */
|
||||
n = 0;
|
||||
buffer[n++] = ch;
|
||||
ch = fgetc(in_file);
|
||||
switch(ch)
|
||||
{
|
||||
case '\\': /* character constant */
|
||||
buffer[n++] = ch; /* store '\' */
|
||||
ch = fgetc(in_file);
|
||||
buffer[n++] = ch; /* store 1st character */
|
||||
ch = fgetc(in_file);
|
||||
while ((!isspace(ch)) && ch != ')')
|
||||
{
|
||||
buffer[n++] = ch;
|
||||
ch = fgetc(in_file);
|
||||
}
|
||||
if (ch == ')') ungetc(ch, in_file);
|
||||
if (n == 3)
|
||||
{
|
||||
fprintf(out_file, "c%02X", buffer[2]);
|
||||
count += 3;
|
||||
}
|
||||
else
|
||||
{ /* test for a multi-character character */
|
||||
buffer[n] = '\0';
|
||||
for (j = 0; j < test_num; j++)
|
||||
{
|
||||
if (!strcmp(buffer+2, test_string[j]))
|
||||
{
|
||||
fprintf(out_file, "c%02X", test_char[j]);
|
||||
count += 3;
|
||||
break;
|
||||
}
|
||||
if (j == test_num-1)
|
||||
{
|
||||
printf("Invalid Character Constant\n");
|
||||
exit();
|
||||
}
|
||||
} /* end: for (j = 0; j < test_num; j++) */
|
||||
}
|
||||
goto blow_this_place;
|
||||
|
||||
case '(': /* vector constant */
|
||||
vect_start = ftell(out_file);
|
||||
vect_count = 0;
|
||||
fprintf(out_file, "vxxxx");
|
||||
skip_space();
|
||||
while(ch != ')')
|
||||
{
|
||||
ungetc(ch, in_file);
|
||||
process_constant();
|
||||
vect_count++;
|
||||
skip_space();
|
||||
} /* end: while(ch != ')') */
|
||||
vect_end = ftell(out_file);
|
||||
if (fseek(out_file, vect_start, 0))
|
||||
{
|
||||
printf("file seek error-- vector start\n");
|
||||
exit();
|
||||
}
|
||||
fprintf(out_file, "v%04X", vect_count);
|
||||
if (fseek(out_file, vect_end, 0))
|
||||
{
|
||||
printf("file seek error-- vector end\n");
|
||||
exit();
|
||||
}
|
||||
goto blow_this_place;
|
||||
|
||||
default: /* other special constant */
|
||||
goto right_here; /* treat as a symbol */
|
||||
}
|
||||
|
||||
default: /* must look at symbol to see what it is */
|
||||
n = 0;
|
||||
right_here:
|
||||
while (!isspace(ch))
|
||||
{
|
||||
if (ch == ')')
|
||||
{
|
||||
ungetc(ch, in_file);
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
if (n >= sizeof(buffer)) goto too_long;
|
||||
buffer[n++] = ch;
|
||||
ch = fgetc(in_file);
|
||||
}
|
||||
}
|
||||
i = 0;
|
||||
if (buffer[0] == '-' && n > 1) i++;
|
||||
for (i; i < n; i++)
|
||||
{
|
||||
if (!isdigit(buffer[i]))
|
||||
{
|
||||
if (buffer[i] == '.' && (i > 0 || isdigit(buffer[i+1])))
|
||||
{
|
||||
buffer[n++] = '\0';
|
||||
sscanf(buffer, "%lf", &flonum);
|
||||
get_parts(flo_parts, flonum);
|
||||
fprintf(out_file, "f%04X%04X%04X%04X", flo_parts[0],
|
||||
flo_parts[1], flo_parts[2], flo_parts[3]);
|
||||
count += 17;
|
||||
goto blow_this_place;
|
||||
}
|
||||
else
|
||||
{ /* this here's got to be a symbol */
|
||||
if (n > 0x00ff)
|
||||
{
|
||||
too_long:
|
||||
printf("***Error-- Symbol Too Long***\n%s",
|
||||
"MAKE_FSL limits symbols to 255 characters\n");
|
||||
exit();
|
||||
}
|
||||
/* special fixup to remove escaping \'s */
|
||||
for (i=0; i<n; i++)
|
||||
{
|
||||
if (buffer[i] == '\\')
|
||||
{
|
||||
for (j=i; j < n-1; j++) buffer[j] = buffer[j+1];
|
||||
n--;
|
||||
}
|
||||
}
|
||||
fprintf(out_file, "x%02X", n);
|
||||
for (i = 0; i < n; i++) fputc(toupper(buffer[i]),
|
||||
out_file);
|
||||
count += (n + 3);
|
||||
goto blow_this_place;
|
||||
}
|
||||
} /* end: if (!isdigit(buffer[i]))) */
|
||||
} /* end: for (i; i < n; i++) */
|
||||
/* if loop exits, we've got a fixnum */
|
||||
i = sign = 0;
|
||||
value = 0L;
|
||||
if (buffer[0] == '-')
|
||||
{
|
||||
sign = 1;
|
||||
i++;
|
||||
}
|
||||
for (i; i < n; i++)
|
||||
{
|
||||
j = (buffer[i] - '0');
|
||||
if (value > ((0x7fffffff - j)/10))
|
||||
{
|
||||
printf("***Error-- Integer Too Big***\n%s",
|
||||
"MAKE_FSL requires integers be between -2,147,483,647 and 2,147,483,647\n");
|
||||
exit();
|
||||
}
|
||||
value = (value * 10) + j;
|
||||
}
|
||||
if (sign) value = -value;
|
||||
if (value <= 16383 && value >= -16384)
|
||||
{
|
||||
i = value & 0x00007fff;
|
||||
fprintf(out_file, "i%04X", i);
|
||||
count += 5;
|
||||
goto blow_this_place;
|
||||
}
|
||||
else
|
||||
{
|
||||
if (sign) value = -value;
|
||||
get_pieces(big_parts, value);
|
||||
fprintf(out_file, "b02%02X%04X%04X", (sign ? 1 : 0),
|
||||
big_parts[0], big_parts[1]);
|
||||
count += 13;
|
||||
}
|
||||
} /* end: switch (ch) */
|
||||
|
||||
blow_this_place:
|
||||
} /* end of function: process_constant() */
|
||||
|
||||
/************************************************************************/
|
||||
/* Coerce a floating point value to "words" */
|
||||
/************************************************************************/
|
||||
get_parts(flo_parts, flonum)
|
||||
double *flo_parts, flonum;
|
||||
{
|
||||
*flo_parts = flonum;
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* Coerce a bignum value to "words" */
|
||||
/************************************************************************/
|
||||
get_pieces(big_parts, value)
|
||||
long *big_parts, value;
|
||||
{
|
||||
*big_parts = value;
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,110 @@
|
|||
#include "dos.h"
|
||||
#include "math.h"
|
||||
|
||||
#define F_NEAR 0x0001
|
||||
#define F_PAD 0x0008
|
||||
|
||||
#define RT_DOUBLE 3
|
||||
|
||||
typedef unsigned short WORD; /* 16-bit unsigned value */
|
||||
|
||||
extern WORD _psp; /* Lattice C variables */
|
||||
extern WORD _tsize;
|
||||
|
||||
/* Note xwait and xbye are the actual addresses we'll jump to when we
|
||||
call XLI from the glue routine. C calls the glue routine at the
|
||||
two entry points xli_wait and xli_bye. These 2 routines set
|
||||
up the stack for calling xwait and xbye. */
|
||||
WORD xwait[2]; /* XLI entry points */
|
||||
WORD xbye[2];
|
||||
|
||||
struct xli_file_struct {
|
||||
WORD id;
|
||||
WORD flags;
|
||||
WORD table[2]; /* offset in 0, segment in 1 */
|
||||
WORD parm_block[2];
|
||||
WORD reserved[8];
|
||||
} file_block;
|
||||
|
||||
struct xli_routine_struct {
|
||||
WORD select;
|
||||
WORD special_service;
|
||||
WORD ss_args[8];
|
||||
WORD reserved[8];
|
||||
WORD return_type;
|
||||
double return_value;
|
||||
double arg1;
|
||||
double arg2;
|
||||
} parm_block;
|
||||
|
||||
char table[] =
|
||||
/* 0 2 4 6 8 10 12 */
|
||||
"sqrt/sin/cos/tan/asin/acos/atan/atan2/exp/expt/ln/log10/log//";
|
||||
|
||||
|
||||
void main(argc,argv)
|
||||
int argc;
|
||||
char *argv[];
|
||||
{
|
||||
WORD psp;
|
||||
/*WORD memsize; */
|
||||
WORD buffer[2];
|
||||
struct SREGS segregs;
|
||||
int xli_wait();
|
||||
void xli_bye();
|
||||
|
||||
/* Note PSP@ is not necessarily directly accessible in any
|
||||
Lattice C memory model. */
|
||||
psp = *(&_psp+1); /* get seg addr of PSP */
|
||||
|
||||
/* init file block */
|
||||
file_block.id = 0x4252;
|
||||
file_block.flags = F_NEAR+F_PAD;
|
||||
file_block.table[0] = (WORD) table;
|
||||
file_block.parm_block[0] = (WORD) &parm_block;
|
||||
segread(&segregs);
|
||||
file_block.table[1] = segregs.ds;
|
||||
file_block.parm_block[1] = segregs.ds;
|
||||
|
||||
/* determine link address */
|
||||
buffer[0] = (WORD) &file_block;
|
||||
buffer[1] = segregs.ds;
|
||||
|
||||
/* determine size to keep */
|
||||
/*memsize = _tsize; */ /* done in glue routine for S Lattice */
|
||||
|
||||
/* establish the link addresses between C and PCS */
|
||||
poke((int) psp, 0x5c, (char *) buffer, 4); /* poke file block@ into PSP */
|
||||
peek((int) psp, 0x0a, (char *) xwait, 4); /* get DOS ret@ */
|
||||
xbye[0] = xwait[0];
|
||||
xbye[1] = xwait[1];
|
||||
xwait[0] += 3; /* incr by 3 for normal call */
|
||||
xbye[0] += 6; /* incr by 6 for termination */
|
||||
|
||||
while (xli_wait()) {
|
||||
switch (parm_block.select) {
|
||||
case 0: parm_block.return_value = sqrt(parm_block.arg1); break;
|
||||
case 1: parm_block.return_value = sin(parm_block.arg1); break;
|
||||
case 2: parm_block.return_value = cos(parm_block.arg1); break;
|
||||
case 3: parm_block.return_value = tan(parm_block.arg1); break;
|
||||
case 4: parm_block.return_value = asin(parm_block.arg1); break;
|
||||
case 5: parm_block.return_value = acos(parm_block.arg1); break;
|
||||
case 6: parm_block.return_value = atan(parm_block.arg1); break;
|
||||
case 7: parm_block.return_value =
|
||||
atan2(parm_block.arg1,parm_block.arg2); break;
|
||||
case 8: parm_block.return_value = exp(parm_block.arg1); break;
|
||||
case 9: parm_block.return_value =
|
||||
pow(parm_block.arg1,parm_block.arg2); break;
|
||||
case 10: parm_block.return_value = log(parm_block.arg1); break;
|
||||
case 11: parm_block.return_value = log10(parm_block.arg1); break;
|
||||
case 12: parm_block.return_value =
|
||||
log(parm_block.arg1) / log(parm_block.arg2); break;
|
||||
default: ;
|
||||
} /* end switch */
|
||||
parm_block.return_type = RT_DOUBLE;
|
||||
} /* end while */
|
||||
|
||||
xli_bye();
|
||||
|
||||
} /* end main */
|
||||
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
SC+SCHEMED+sinterp+smain+
|
||||
INTRUP+SSTRING+SMEMORY+SGCMARK+SGCSWEEP+
|
||||
SBIGMEM+SEXEC+SUPPORT+
|
||||
SHASH+SSTACK+SARITH+SUTIL+SERROR+
|
||||
sdebug+sdump+STRACE+
|
||||
sprint+cprint+cprint1+
|
||||
SERRMSG+SIO+SBIGMATH+
|
||||
sread+cread+zcio+sin_out+cio+cwindow+
|
||||
SCAR_CDR+SVARS+SAPROP+SPROP+MSDOS+
|
||||
SRESET+GET_PORT+SFASL+
|
||||
zio+SREIFY+SENV+
|
||||
sprintf+SCANNUM+STIMER+GET_PATH+
|
||||
SOBJHASH+ASM_LINK+GRAPHCMD+
|
||||
border+SLINK+ALINK+SBID+
|
||||
STRMLNRS+SRCH_STR+SQUISH+
|
||||
SRELOCAT+FREESP+SCROLL+
|
||||
SW_INT+FLO2HEX+SMMU+BLOCK+XLI
|
||||
|
||||
|
|
@ -0,0 +1,444 @@
|
|||
# PC Scheme 4.0 make file: Conventional memory PCS
|
||||
|
||||
#
|
||||
# command-line macro variables
|
||||
#
|
||||
|
||||
redo= # if nonempty, force make to do everything here
|
||||
debug= # if nonempty, generate symbol file
|
||||
|
||||
#
|
||||
# directories
|
||||
#
|
||||
|
||||
tools=\tools # read-only
|
||||
lib=\lib # read-only
|
||||
src=\build # read-only
|
||||
obj=\object # read-write
|
||||
exec=\exec # read-write
|
||||
|
||||
#
|
||||
# rules
|
||||
#
|
||||
|
||||
.asm.obj:
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
.c.obj:
|
||||
$(tools)\lc -dREGMEM -ms -ccdswum -o$@ $*
|
||||
|
||||
#
|
||||
# make-specific initialization
|
||||
#
|
||||
|
||||
# if redo on command line specified, build the entire system
|
||||
:
|
||||
if not "$(redo)"=="" del $(obj)\*.obj
|
||||
if not "$(redo)"=="" del $(exec)\pcs.*
|
||||
|
||||
#
|
||||
# application-specific initialization
|
||||
#
|
||||
|
||||
:
|
||||
cd $(src)
|
||||
path $(tools)
|
||||
|
||||
#
|
||||
# assembly language files
|
||||
#
|
||||
|
||||
$(src)\schemed.equ: $(src)\memtype.equ
|
||||
$(tools)\touch schemed.equ
|
||||
|
||||
$(src)\scheme.equ: $(src)\schemed.equ $(src)\schemed.ref $(src)\schemed.mac \
|
||||
$(src)\smmu.mac
|
||||
$(tools)\touch scheme.equ
|
||||
|
||||
$(obj)\alink.obj: $(src)\alink.asm
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\block.obj: $(src)\block.asm $(src)\scheme.equ $(src)\memtype.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\flo2hex.obj: $(src)\flo2hex.asm
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\get_path.obj: $(src)\get_path.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
#$(obj)\graphcmd.obj: $(src)\graphcmd.asm $(src)\pcmake.equ
|
||||
# $(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
# PCS 3.02 version: graphics integrated into VM
|
||||
$(obj)\graphcmd.obj: $(src)\graphics.asm $(src)\pcmake.equ
|
||||
$(tools)\masm /DREGMEM $(src)\graphics,$@ /Dcombined /Dti /Dibm;
|
||||
|
||||
$(obj)\intrup.obj: $(src)\intrup.asm $(src)\dos.mac $(src)\pcmake.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PROINTRP.ASM FOR PROTECTED MODE UPDATES ALSO ****
|
||||
|
||||
$(obj)\msdos.obj: $(src)\msdos.asm
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\saprop.obj: $(src)\saprop.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\sbid.obj: $(src)\sbid.asm
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PROBID.ASM FOR PROTECTED MODE UPDATES ALSO ****
|
||||
|
||||
$(obj)\sbigmath.obj: $(src)\sbigmath.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\sc.obj: $(src)\sc.asm $(src)\dos.mac
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\scannum.obj: $(src)\scannum.asm
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\scar_cdr.obj: $(src)\scar_cdr.asm $(src)\scheme.equ $(src)\sinterp.mac \
|
||||
$(src)\sinterp.arg
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\schemed.obj: $(src)\schemed.asm $(src)\schemed.equ $(src)\sasm.mac
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\senv.obj: $(src)\senv.asm $(src)\scheme.equ $(src)\sinterp.mac \
|
||||
$(src)\sinterp.arg $(src)\stackf.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\sexec.obj: $(src)\sexec.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\sgcmark.obj: $(src)\sgcmark.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\sgcsweep.obj: $(src)\sgcsweep.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\sinterp.obj: $(src)\sinterp.asm $(src)\schemed.equ $(src)\schemed.ref \
|
||||
$(src)\schemed.mac $(src)\pcmake.equ $(src)\stackf.equ \
|
||||
$(src)\smmu.mac $(src)\sinterp.mac $(src)\sinterp.arg
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\smmu.obj: $(src)\smmu.asm $(src)\schemed.equ $(src)\schemed.ref
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\sobjhash.obj: $(src)\sobjhash.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\squish.obj: $(src)\squish.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\srch_str.obj: $(src)\srch_str.asm $(src)\scheme.equ $(src)\pcmake.equ \
|
||||
$(src)\sinterp.arg
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\srelocat.obj: $(src)\srelocat.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\sstack.obj: $(src)\sstack.asm $(src)\scheme.equ $(src)\sinterp.mac \
|
||||
$(src)\sinterp.arg $(src)\stackf.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\sstring.obj: $(src)\sstring.asm $(src)\scheme.equ $(src)\sinterp.mac \
|
||||
$(src)\sinterp.arg
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\stimer.obj: $(src)\stimer.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
echo **** REMEMBER TO CHECK SINTERP.ASM FOR PROTECTED MODE UPDATES ALSO ****
|
||||
|
||||
$(obj)\strmlnrs.obj: $(src)\strmlnrs.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\sutil.obj: $(src)\sutil.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK FOR PROTECTED MODE UPDATES ALSO ****
|
||||
|
||||
$(obj)\svars.obj: $(src)\svars.asm $(src)\scheme.equ $(src)\sinterp.mac \
|
||||
$(src)\sinterp.arg
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\sw_int.obj: $(src)\sw_int.asm
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
$(obj)\xli.obj: $(src)\xli.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PRO2REAL.ASM FOR PROTECTED MODE UPDATES ALSO ****
|
||||
|
||||
|
||||
|
||||
#
|
||||
# C source files
|
||||
#
|
||||
|
||||
$(src)\scheme.h: $(src)\memtype.h $(src)\schmdefs.h
|
||||
$(tools)\touch scheme.h
|
||||
|
||||
$(obj)\asm_link.obj: $(src)\asm_link.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\freesp.obj: $(src)\freesp.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sarith.obj: $(src)\sarith.c $(src)\scheme.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sbigmem.obj: $(src)\sbigmem.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sdebug.obj: $(src)\sdebug.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sdump.obj: $(src)\sdump.c $(src)\scheme.h $(src)\ctype.h \
|
||||
$(src)\schars.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\serrmsg.obj: $(src)\serrmsg.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\serror.obj: $(src)\serror.c $(src)\scheme.h $(src)\ctype.h \
|
||||
$(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sfasl.obj: $(src)\sfasl.c $(src)\scheme.h $(src)\stdio.h \
|
||||
$(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\shash.obj: $(src)\shash.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\slink.obj: $(src)\slink.c $(src)\ctype.h $(src)\slink.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\smain.obj: $(src)\smain.c $(src)\version.h $(src)\scheme.h \
|
||||
$(src)\sport.h $(src)\pcmake.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\smemory.obj: $(src)\smemory.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sprintf.obj: $(src)\sprintf.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sprop.obj: $(src)\sprop.c $(src)\scheme.h $(src)\ctype.h \
|
||||
$(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sreify.obj: $(src)\sreify.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sreset.obj: $(src)\sreset.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\strace.obj: $(src)\strace.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\support.obj: $(src)\support.c $(src)\scheme.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
#
|
||||
# I/O source files - All of regular scheme's I/O files have been grouped
|
||||
# together in one place so they can be easily recognized from Protected
|
||||
# Mode Scheme's I/O files. There wasn't enough time to get all the I/O
|
||||
# code merged, so there may be duplicate code between regular scheme and
|
||||
# protected mode scheme. This means that if any code is modified in the
|
||||
# following files, you should check the corresponding protected mode
|
||||
# files also.
|
||||
#
|
||||
|
||||
# Assembly language I/O files
|
||||
|
||||
$(obj)\border.obj: $(src)\border.asm $(src)\scheme.equ $(src)\pcmake.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\cio.obj: $(src)\cio.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\cprint.obj: $(src)\cprint.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\cprint1.obj: $(src)\cprint1.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\cread.obj: $(src)\cread.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\cwindow.obj: $(src)\cwindow.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\scroll.obj: $(src)\scroll.asm $(src)\pcmake.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\sio.obj: $(src)\sio.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\zio.obj: $(src)\zio.asm $(src)\scheme.equ $(src)\pcmake.equ
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
# Lattice C I/O files
|
||||
|
||||
$(obj)\get_port.obj: $(src)\get_port.c $(src)\scheme.h $(src)\ctype.h
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\sin_out.obj: $(src)\sin_out.c $(src)\scheme.h $(src)\sport.h \
|
||||
$(src)\slist.h
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\sprint.obj: $(src)\sprint.c $(src)\scheme.h $(src)\schars.h
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\sread.obj: $(src)\sread.c $(src)\scheme.h $(src)\schars.h
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\zcio.obj: $(src)\zcio.c $(src)\scheme.h $(src)\sport.h \
|
||||
$(src)\slist.h
|
||||
$(tools)\lc1 -dREGMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
REM **** REMEMBER TO CHECK PROTECTED MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
#
|
||||
# Generate .EXE file
|
||||
#
|
||||
|
||||
$(exec)\pcs.exe: $(obj)\sc.obj \
|
||||
$(obj)\schemed.obj \
|
||||
$(obj)\sinterp.obj \
|
||||
$(obj)\smain.obj \
|
||||
$(obj)\intrup.obj \
|
||||
$(obj)\sstring.obj \
|
||||
$(obj)\smemory.obj \
|
||||
$(obj)\sgcmark.obj \
|
||||
$(obj)\sgcsweep.obj \
|
||||
$(obj)\sbigmem.obj \
|
||||
$(obj)\sexec.obj \
|
||||
$(obj)\support.obj \
|
||||
$(obj)\shash.obj \
|
||||
$(obj)\sstack.obj \
|
||||
$(obj)\sarith.obj \
|
||||
$(obj)\sutil.obj \
|
||||
$(obj)\serror.obj \
|
||||
$(obj)\sdebug.obj \
|
||||
$(obj)\sdump.obj \
|
||||
$(obj)\strace.obj \
|
||||
$(obj)\sprint.obj \
|
||||
$(obj)\cprint.obj \
|
||||
$(obj)\cprint1.obj \
|
||||
$(obj)\serrmsg.obj \
|
||||
$(obj)\sio.obj \
|
||||
$(obj)\sbigmath.obj \
|
||||
$(obj)\sread.obj \
|
||||
$(obj)\cread.obj \
|
||||
$(obj)\zcio.obj \
|
||||
$(obj)\sin_out.obj \
|
||||
$(obj)\cio.obj \
|
||||
$(obj)\cwindow.obj \
|
||||
$(obj)\scar_cdr.obj \
|
||||
$(obj)\svars.obj \
|
||||
$(obj)\saprop.obj \
|
||||
$(obj)\sprop.obj \
|
||||
$(obj)\msdos.obj \
|
||||
$(obj)\sreset.obj \
|
||||
$(obj)\get_port.obj \
|
||||
$(obj)\sfasl.obj \
|
||||
$(obj)\zio.obj \
|
||||
$(obj)\sreify.obj \
|
||||
$(obj)\senv.obj \
|
||||
$(obj)\sprintf.obj \
|
||||
$(obj)\scannum.obj \
|
||||
$(obj)\stimer.obj \
|
||||
$(obj)\get_path.obj \
|
||||
$(obj)\sobjhash.obj \
|
||||
$(obj)\asm_link.obj \
|
||||
$(obj)\graphcmd.obj \
|
||||
$(obj)\border.obj \
|
||||
$(obj)\block.obj \
|
||||
$(obj)\slink.obj \
|
||||
$(obj)\alink.obj \
|
||||
$(obj)\sbid.obj \
|
||||
$(obj)\strmlnrs.obj \
|
||||
$(obj)\srch_str.obj \
|
||||
$(obj)\squish.obj \
|
||||
$(obj)\srelocat.obj \
|
||||
$(obj)\freesp.obj \
|
||||
$(obj)\scroll.obj \
|
||||
$(obj)\sw_int.obj \
|
||||
$(obj)\flo2hex.obj \
|
||||
$(obj)\smmu.obj \
|
||||
$(obj)\xli.obj
|
||||
cd $(obj)
|
||||
$(tools)\link @$(src)\pcs.lnk,$(exec)\pcs.exe,$(exec)\pcs.map/map,$(lib)\lcm+$(lib)\lc
|
||||
cd $(src)
|
||||
|
||||
#
|
||||
# Write debug info if specified
|
||||
#
|
||||
|
||||
:
|
||||
if not "$(debug)"=="" cd $(exec)
|
||||
if not "$(debug)"=="" $(tools)\mapsym $(exec)\pcs.map
|
||||
|
||||
#
|
||||
# make-specific wrapup
|
||||
#
|
||||
|
||||
:
|
||||
echo MAKE is done.
|
||||
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
SC+SCHEMED+
|
||||
sinterp+smain+
|
||||
INTRUP+SSTRING+SMEMORY+SGCMARK+SGCSWEEP+
|
||||
SBIGMXP+
|
||||
SEXEC+SUPPORT+
|
||||
SHASH+SSTACK+SARITH+SUTIL+SERROR+SDEBUG+SDUMP+STRACE+SPRINT+CPRINT+CPRINT1+
|
||||
SERRMSG+SIO+SBIGMATH+SREAD+CREAD+ZCIO+SIN_OUT+CIO+CWINDOW+SCAR_CDR+SVARS+
|
||||
SAPROP+SPROP+MSDOS+SRESET+GET_PORT+SFASL+ZIO+SREIFY+SENV+SPRINTF+SCANNUM+STIMER+
|
||||
GET_PATH+SOBJHASH+ASM_LINK+GRAPHCMD+BORDER+SLINK+ALINK+SBID+STRMLNRS+SRCH_STR+
|
||||
squish+srelocat+
|
||||
FREESP+SCROLL+SW_INT+FLO2HEX+
|
||||
expsmmu+BLOCK+XLI
|
||||
|
||||
|
|
@ -0,0 +1,402 @@
|
|||
# PC Scheme 4.0 make file: Expanded memory PCS
|
||||
|
||||
#
|
||||
# command-line macro variables
|
||||
#
|
||||
|
||||
redo= # if nonempty, force make to do everything here
|
||||
debug= # if nonempty, generate symbol file
|
||||
|
||||
#
|
||||
# directories
|
||||
#
|
||||
|
||||
tools=\tools # read-only
|
||||
lib=\lib # read-only
|
||||
src=\build # read-only
|
||||
obj=\objectx # read-write
|
||||
exec=\exec # read-write
|
||||
|
||||
#
|
||||
# rules
|
||||
#
|
||||
|
||||
.asm.obj:
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
.c.obj:
|
||||
$(tools)\lc -dEXPMEM -ms -ccdswum -o$@ $*
|
||||
|
||||
#
|
||||
# make-specific initialization
|
||||
#
|
||||
|
||||
# this records the current status of generated files onto a log file
|
||||
:
|
||||
if not "$(redo)"=="" del $(obj)\*.obj
|
||||
if not "$(redo)"=="" del $(exec)\pcsexp.*
|
||||
|
||||
#
|
||||
# application-specific initialization
|
||||
#
|
||||
|
||||
:
|
||||
cd $(src)
|
||||
path $(tools)
|
||||
|
||||
|
||||
#
|
||||
# assembly language files
|
||||
#
|
||||
|
||||
$(src)\schemed.equ: $(src)\memtype.equ
|
||||
$(tools)\touch schemed.equ
|
||||
|
||||
$(src)\scheme.equ: $(src)\schemed.equ $(src)\schemed.ref $(src)\schemed.mac \
|
||||
$(src)\smmu.mac
|
||||
$(tools)\touch scheme.equ
|
||||
|
||||
$(obj)\intrup.obj: $(src)\intrup.asm $(src)\dos.mac $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sbigmath.obj: $(src)\sbigmath.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\msdos.obj: $(src)\msdos.asm
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\scannum.obj: $(src)\scannum.asm
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\stimer.obj: $(src)\stimer.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\get_path.obj: $(src)\get_path.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
# $(obj)\graphcmd.obj: $(src)\graphcmd.asm $(src)\pcmake.equ
|
||||
# $(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
# PCS 3.02 version: graphics integrated into VM
|
||||
$(obj)\graphcmd.obj: $(src)\graphics.asm $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXPMEM $(src)\graphics,$@ /Dcombined /Dti /Dibm;
|
||||
|
||||
$(obj)\alink.obj: $(src)\alink.asm
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sbid.obj: $(src)\sbid.asm
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\scroll.obj: $(src)\scroll.asm $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sw_int.obj: $(src)\sw_int.asm
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\flo2hex.obj: $(src)\flo2hex.asm
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sc.obj: $(src)\sc.asm $(src)\dos.mac $(src)\smmu.mac
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sinterp.obj: $(src)\sinterp.asm $(src)\schemed.equ $(src)\schemed.ref $(src)\schemed.mac \
|
||||
$(src)\pcmake.equ $(src)\stackf.equ $(src)\smmu.mac \
|
||||
$(src)\sinterp.mac $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\schemed.obj: $(src)\schemed.asm $(src)\schemed.equ $(src)\sasm.mac
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sgcsweep.obj: $(src)\sgcsweep.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sgcmark.obj: $(src)\sgcmark.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\squish.obj: $(src)\squish.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\srelocat.obj: $(src)\srelocat.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\border.obj: $(src)\border.asm $(src)\scheme.equ $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\scar_cdr.obj: $(src)\scar_cdr.asm $(src)\scheme.equ $(src)\sinterp.mac $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\senv.obj: $(src)\senv.asm $(src)\scheme.equ $(src)\sinterp.mac $(src)\sinterp.arg $(src)\stackf.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sexec.obj: $(src)\sexec.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sio.obj: $(src)\sio.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sobjhash.obj: $(src)\sobjhash.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\srch_str.obj: $(src)\srch_str.asm $(src)\scheme.equ $(src)\pcmake.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sstack.obj: $(src)\sstack.asm $(src)\scheme.equ $(src)\sinterp.mac $(src)\sinterp.arg $(src)\stackf.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\expsmmu.obj: $(src)\expsmmu.asm $(src)\schemed.equ $(src)\schemed.ref $(src)\schemed.mac
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\block.obj: $(src)\block.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sstring.obj: $(src)\sstring.asm $(src)\scheme.equ $(src)\sinterp.mac $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\strmlnrs.obj: $(src)\strmlnrs.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\sutil.obj: $(src)\sutil.asm $(src)\scheme.equ $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\svars.obj: $(src)\svars.asm $(src)\scheme.equ $(src)\sinterp.mac $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\zio.obj: $(src)\zio.asm $(src)\scheme.equ $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\cwindow.obj: $(src)\cwindow.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\cprint.obj: $(src)\cprint.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\cread.obj: $(src)\cread.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\cio.obj: $(src)\cio.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\cprint1.obj: $(src)\cprint1.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\saprop.obj: $(src)\saprop.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
$(obj)\xli.obj: $(src)\xli.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXPMEM $*,$@;
|
||||
|
||||
#
|
||||
# C source files
|
||||
#
|
||||
|
||||
$(src)\scheme.h: $(src)\memtype.h $(src)\schmdefs.h
|
||||
$(tools)\touch scheme.h
|
||||
|
||||
$(obj)\smain.obj: $(src)\smain.c $(src)\version.h $(src)\scheme.h $(src)\sport.h $(src)\pcmake.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\freesp.obj: $(src)\freesp.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\asm_link.obj: $(src)\asm_link.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\get_port.obj: $(src)\get_port.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sarith.obj: $(src)\sarith.c $(src)\scheme.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sbigmxp.obj: $(src)\sbigmxp.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\serrmsg.obj: $(src)\serrmsg.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sdebug.obj: $(src)\sdebug.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sdump.obj: $(src)\sdump.c $(src)\scheme.h $(src)\ctype.h $(src)\schars.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\serror.obj: $(src)\serror.c $(src)\scheme.h $(src)\ctype.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sfasl.obj: $(src)\sfasl.c $(src)\scheme.h $(src)\stdio.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\shash.obj: $(src)\shash.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sin_out.obj: $(src)\sin_out.c $(src)\scheme.h $(src)\sport.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\slink.obj: $(src)\slink.c $(src)\ctype.h $(src)\slink.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\smemory.obj: $(src)\smemory.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sprint.obj: $(src)\sprint.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sprintf.obj: $(src)\sprintf.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sprop.obj: $(src)\sprop.c $(src)\scheme.h $(src)\ctype.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sread.obj: $(src)\sread.c $(src)\scheme.h $(src)\schars.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sreify.obj: $(src)\sreify.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sreset.obj: $(src)\sreset.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\strace.obj: $(src)\strace.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\support.obj: $(src)\support.c $(src)\scheme.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\zcio.obj: $(src)\zcio.c $(src)\scheme.h $(src)\sport.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXPMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
#
|
||||
# Generate .EXE file
|
||||
#
|
||||
|
||||
$(exec)\pcsexp.exe: $(obj)\sc.obj \
|
||||
$(obj)\schemed.obj \
|
||||
$(obj)\sinterp.obj \
|
||||
$(obj)\smain.obj \
|
||||
$(obj)\intrup.obj \
|
||||
$(obj)\sstring.obj \
|
||||
$(obj)\smemory.obj \
|
||||
$(obj)\sgcmark.obj \
|
||||
$(obj)\sgcsweep.obj \
|
||||
$(obj)\sbigmxp.obj \
|
||||
$(obj)\sexec.obj \
|
||||
$(obj)\support.obj \
|
||||
$(obj)\shash.obj \
|
||||
$(obj)\sstack.obj \
|
||||
$(obj)\sarith.obj \
|
||||
$(obj)\sutil.obj \
|
||||
$(obj)\serror.obj \
|
||||
$(obj)\sdebug.obj \
|
||||
$(obj)\sdump.obj \
|
||||
$(obj)\strace.obj \
|
||||
$(obj)\sprint.obj \
|
||||
$(obj)\cprint.obj \
|
||||
$(obj)\cprint1.obj \
|
||||
$(obj)\serrmsg.obj \
|
||||
$(obj)\sio.obj \
|
||||
$(obj)\sbigmath.obj \
|
||||
$(obj)\sread.obj \
|
||||
$(obj)\cread.obj \
|
||||
$(obj)\zcio.obj \
|
||||
$(obj)\sin_out.obj \
|
||||
$(obj)\cio.obj \
|
||||
$(obj)\cwindow.obj \
|
||||
$(obj)\scar_cdr.obj \
|
||||
$(obj)\svars.obj \
|
||||
$(obj)\saprop.obj \
|
||||
$(obj)\sprop.obj \
|
||||
$(obj)\msdos.obj \
|
||||
$(obj)\sreset.obj \
|
||||
$(obj)\get_port.obj \
|
||||
$(obj)\sfasl.obj \
|
||||
$(obj)\zio.obj \
|
||||
$(obj)\sreify.obj \
|
||||
$(obj)\senv.obj \
|
||||
$(obj)\sprintf.obj \
|
||||
$(obj)\scannum.obj \
|
||||
$(obj)\stimer.obj \
|
||||
$(obj)\get_path.obj \
|
||||
$(obj)\sobjhash.obj \
|
||||
$(obj)\asm_link.obj \
|
||||
$(obj)\graphcmd.obj \
|
||||
$(obj)\border.obj \
|
||||
$(obj)\slink.obj \
|
||||
$(obj)\alink.obj \
|
||||
$(obj)\sbid.obj \
|
||||
$(obj)\strmlnrs.obj \
|
||||
$(obj)\srch_str.obj \
|
||||
$(obj)\squish.obj \
|
||||
$(obj)\srelocat.obj \
|
||||
$(obj)\freesp.obj \
|
||||
$(obj)\scroll.obj \
|
||||
$(obj)\sw_int.obj \
|
||||
$(obj)\flo2hex.obj \
|
||||
$(obj)\expsmmu.obj \
|
||||
$(obj)\block.obj \
|
||||
$(obj)\xli.obj
|
||||
cd $(obj)
|
||||
$(tools)\link @$(src)\pcsexp.lnk,$(exec)\pcsexp.exe,$(exec)\pcsexp.map/map,$(lib)\lcm+$(lib)\lc
|
||||
cd $(src)
|
||||
|
||||
#
|
||||
# Write debug info if specified
|
||||
#
|
||||
|
||||
:
|
||||
if not "$(debug)"=="" cd $(exec)
|
||||
if not "$(debug)"=="" $(tools)\mapsym $(exec)\pcsexp.map
|
||||
|
||||
#
|
||||
# make-specific wrapup
|
||||
#
|
||||
|
||||
:
|
||||
echo MAKE is done.
|
||||
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
extsc+SCHEMED+extinter+extmain+
|
||||
INTRUP+SSTRING+smemory+SGCMARK+
|
||||
extsweep+sbigmxt+SEXEC+SUPPORT+
|
||||
SHASH+SSTACK+SARITH+SUTIL+SERROR+SDEBUG+SDUMP+STRACE+SPRINT+
|
||||
CPRINT+CPRINT1+SERRMSG+SIO+SBIGMATH+CREAD+SREAD+ZCIO+CWINDOW+
|
||||
SIN_OUT+CIO+SCAR_CDR+SVARS+SAPROP+SPROP+MSDOS+SRESET+GET_PORT+SFASL+
|
||||
extzio+SREIFY+SENV+SPRINTF+SCANNUM+STIMER+GET_PATH+SOBJHASH+
|
||||
ASM_LINK+GRAPHCMD+BORDER+SLINK+ALINK+SBID+STRMLNRS+
|
||||
SRCH_STR+extsquis+extreloc+
|
||||
FREESP+SCROLL+SW_INT+FLO2HEX+extsmmu+BLOCK+XLI
|
||||
|
||||
|
|
@ -0,0 +1,392 @@
|
|||
# PC Scheme 4.0 make file: Extended memory PCS
|
||||
|
||||
#
|
||||
# command-line macro variables
|
||||
#
|
||||
|
||||
redo= # if nonempty, force make to do everything here
|
||||
debug= # if nonempty, generate symbol file
|
||||
|
||||
|
||||
#
|
||||
# drives and directories
|
||||
#
|
||||
|
||||
tools=\tools # read-only
|
||||
lib=\lib # read-only
|
||||
src=\build # read-only
|
||||
obj=\objectx # read-write
|
||||
exec=\exec # read-write
|
||||
|
||||
#
|
||||
# rules
|
||||
#
|
||||
|
||||
.asm.obj:
|
||||
$(tools)\masm /DREGMEM $*,$@;
|
||||
|
||||
.c.obj:
|
||||
$(tools)\lc -dREGMEM -ms -ccdswum -o$@ $*
|
||||
|
||||
#
|
||||
# make-specific initialization
|
||||
#
|
||||
|
||||
# this records the current status of generated files onto a log file
|
||||
:
|
||||
if not "$(redo)"=="" del $(obj)\*.obj
|
||||
if not "$(redo)"=="" del $(exec)\pcsext.*
|
||||
|
||||
#
|
||||
# application-specific initialization
|
||||
#
|
||||
|
||||
:
|
||||
cd $(src)
|
||||
path $(tools)
|
||||
|
||||
#
|
||||
# assembly language files
|
||||
#
|
||||
|
||||
$(obj)\intrup.obj: $(src)\intrup.asm $(src)\dos.mac $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\sbigmath.obj: $(src)\sbigmath.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\msdos.obj: $(src)\msdos.asm
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\scannum.obj: $(src)\scannum.asm
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\stimer.obj: $(src)\stimer.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\get_path.obj: $(src)\get_path.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
# $(obj)\graphcmd.obj: $(src)\graphcmd.asm $(src)\pcmake.equ
|
||||
# $(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
# PCS 3.02 version: graphics integrated into VM
|
||||
$(obj)\graphcmd.obj: $(src)\graphics.asm $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXTMEM $(src)\graphics,$@ /Dcombined /Dti /Dibm;
|
||||
|
||||
$(obj)\alink.obj: $(src)\alink.asm
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\sbid.obj: $(src)\sbid.asm
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\scroll.obj: $(src)\scroll.asm $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\sw_int.obj: $(src)\sw_int.asm
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\flo2hex.obj: $(src)\flo2hex.asm
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\extsc.obj: $(src)\sc.asm $(src)\dos.mac $(src)\smmu.mac
|
||||
$(tools)\masm /DEXTMEM $(src)\sc.asm,$(obj)\extsc.obj;
|
||||
|
||||
$(obj)\extinter.obj: $(src)\sinterp.asm $(src)\schemed.equ $(src)\schemed.ref $(src)\schemed.mac \
|
||||
$(src)\pcmake.equ $(src)\stackf.equ $(src)\smmu.mac \
|
||||
$(src)\sinterp.mac $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXTMEM $(src)\sinterp.asm,$(obj)\extinter.obj;
|
||||
|
||||
$(obj)\schemed.obj: $(src)\schemed.asm $(src)\schemed.equ $(src)\sasm.mac
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\extsweep.obj: $(src)\sgcsweep.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $(src)\sgcsweep.asm,$(obj)\extsweep.obj;
|
||||
|
||||
$(obj)\sgcmark.obj: $(src)\sgcmark.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\extsquis.obj: $(src)\squish.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $(src)\squish.asm,$(obj)\extsquis.obj;
|
||||
|
||||
$(obj)\extreloc.obj: $(src)\srelocat.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $(src)\srelocat.asm,$(obj)\extreloc.obj;
|
||||
|
||||
$(obj)\border.obj: $(src)\border.asm $(src)\scheme.equ $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\scar_cdr.obj: $(src)\scar_cdr.asm $(src)\scheme.equ $(src)\sinterp.mac $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\senv.obj: $(src)\senv.asm $(src)\scheme.equ $(src)\sinterp.mac $(src)\sinterp.arg $(src)\stackf.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\sexec.obj: $(src)\sexec.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\sio.obj: $(src)\sio.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\sobjhash.obj: $(src)\sobjhash.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\srch_str.obj: $(src)\srch_str.asm $(src)\scheme.equ $(src)\pcmake.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\sstack.obj: $(src)\sstack.asm $(src)\scheme.equ $(src)\sinterp.mac $(src)\sinterp.arg $(src)\stackf.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\extsmmu.obj: $(src)\extsmmu.asm $(src)\schemed.equ $(src)\schemed.ref $(src)\schemed.mac
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\block.obj: $(src)\block.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\sstring.obj: $(src)\sstring.asm $(src)\scheme.equ $(src)\sinterp.mac $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\strmlnrs.obj: $(src)\strmlnrs.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\sutil.obj: $(src)\sutil.asm $(src)\scheme.equ $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\svars.obj: $(src)\svars.asm $(src)\scheme.equ $(src)\sinterp.mac $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\extzio.obj: $(src)\zio.asm $(src)\scheme.equ $(src)\pcmake.equ
|
||||
$(tools)\masm /DEXTMEM $(src)\zio.asm,$(obj)\extzio.obj;
|
||||
|
||||
$(obj)\cwindow.obj: $(src)\cwindow.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\cprint.obj: $(src)\cprint.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\cread.obj: $(src)\cread.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\cio.obj: $(src)\cio.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\cprint1.obj: $(src)\cprint1.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\saprop.obj: $(src)\saprop.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
$(obj)\xli.obj: $(src)\xli.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DEXTMEM $*,$@;
|
||||
|
||||
#
|
||||
# C source files
|
||||
#
|
||||
|
||||
$(obj)\extmain.obj: $(src)\smain.c $(src)\version.h $(src)\scheme.h $(src)\sport.h $(src)\pcmake.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q smain.c
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\freesp.obj: $(src)\freesp.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\asm_link.obj: $(src)\asm_link.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\get_port.obj: $(src)\get_port.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sarith.obj: $(src)\sarith.c $(src)\scheme.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sbigmxt.obj: $(src)\sbigmxt.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\serrmsg.obj: $(src)\serrmsg.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sdebug.obj: $(src)\sdebug.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sdump.obj: $(src)\sdump.c $(src)\scheme.h $(src)\ctype.h $(src)\schars.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\serror.obj: $(src)\serror.c $(src)\scheme.h $(src)\ctype.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sfasl.obj: $(src)\sfasl.c $(src)\scheme.h $(src)\stdio.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\shash.obj: $(src)\shash.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sin_out.obj: $(src)\sin_out.c $(src)\scheme.h $(src)\sport.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\slink.obj: $(src)\slink.c $(src)\ctype.h $(src)\slink.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\smemory.obj: $(src)\smemory.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $(src)\smemory.c
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sprint.obj: $(src)\sprint.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sprintf.obj: $(src)\sprintf.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sprop.obj: $(src)\sprop.c $(src)\scheme.h $(src)\ctype.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sread.obj: $(src)\sread.c $(src)\scheme.h $(src)\schars.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sreify.obj: $(src)\sreify.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sreset.obj: $(src)\sreset.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\strace.obj: $(src)\strace.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\support.obj: $(src)\support.c $(src)\scheme.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\zcio.obj: $(src)\zcio.c $(src)\scheme.h $(src)\sport.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dEXTMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -v -o$@ $(obj)\$*.q
|
||||
|
||||
#
|
||||
# Generate .EXE file
|
||||
#
|
||||
|
||||
$(exec)\pcsext.exe: $(obj)\extsc.obj \
|
||||
$(obj)\schemed.obj \
|
||||
$(obj)\extinter.obj \
|
||||
$(obj)\extmain.obj \
|
||||
$(obj)\intrup.obj \
|
||||
$(obj)\sstring.obj \
|
||||
$(obj)\smemory.obj \
|
||||
$(obj)\sgcmark.obj \
|
||||
$(obj)\extsweep.obj \
|
||||
$(obj)\sbigmxt.obj \
|
||||
$(obj)\sexec.obj \
|
||||
$(obj)\support.obj \
|
||||
$(obj)\shash.obj \
|
||||
$(obj)\sstack.obj \
|
||||
$(obj)\sarith.obj \
|
||||
$(obj)\sutil.obj \
|
||||
$(obj)\serror.obj \
|
||||
$(obj)\sdebug.obj \
|
||||
$(obj)\sdump.obj \
|
||||
$(obj)\strace.obj \
|
||||
$(obj)\sprint.obj \
|
||||
$(obj)\cprint.obj \
|
||||
$(obj)\cprint1.obj \
|
||||
$(obj)\serrmsg.obj \
|
||||
$(obj)\sio.obj \
|
||||
$(obj)\sbigmath.obj \
|
||||
$(obj)\sread.obj \
|
||||
$(obj)\cread.obj \
|
||||
$(obj)\zcio.obj \
|
||||
$(obj)\sin_out.obj \
|
||||
$(obj)\cio.obj \
|
||||
$(obj)\cwindow.obj \
|
||||
$(obj)\scar_cdr.obj \
|
||||
$(obj)\svars.obj \
|
||||
$(obj)\saprop.obj \
|
||||
$(obj)\sprop.obj \
|
||||
$(obj)\msdos.obj \
|
||||
$(obj)\sreset.obj \
|
||||
$(obj)\get_port.obj \
|
||||
$(obj)\sfasl.obj \
|
||||
$(obj)\extzio.obj \
|
||||
$(obj)\sreify.obj \
|
||||
$(obj)\senv.obj \
|
||||
$(obj)\sprintf.obj \
|
||||
$(obj)\scannum.obj \
|
||||
$(obj)\stimer.obj \
|
||||
$(obj)\get_path.obj \
|
||||
$(obj)\sobjhash.obj \
|
||||
$(obj)\asm_link.obj \
|
||||
$(obj)\graphcmd.obj \
|
||||
$(obj)\border.obj \
|
||||
$(obj)\slink.obj \
|
||||
$(obj)\alink.obj \
|
||||
$(obj)\sbid.obj \
|
||||
$(obj)\strmlnrs.obj \
|
||||
$(obj)\srch_str.obj \
|
||||
$(obj)\extsquis.obj \
|
||||
$(obj)\extreloc.obj \
|
||||
$(obj)\freesp.obj \
|
||||
$(obj)\scroll.obj \
|
||||
$(obj)\sw_int.obj \
|
||||
$(obj)\flo2hex.obj \
|
||||
$(obj)\extsmmu.obj \
|
||||
$(obj)\block.obj \
|
||||
$(obj)\xli.obj
|
||||
cd $(obj)
|
||||
$(tools)\link @$(src)\pcsext.lnk,$(exec)\pcsext.exe,$(exec)\pcsext.map/map,$(lib)\lcm+$(lib)\lc
|
||||
cd $(src)
|
||||
|
||||
#
|
||||
# Write debug info if specified
|
||||
#
|
||||
|
||||
:
|
||||
if not "$(debug)"=="" cd $(exec)
|
||||
if not "$(debug)"=="" $(tools)\mapsym $(exec)\pcsext.map
|
||||
|
||||
#
|
||||
# make-specific wrapup
|
||||
#
|
||||
|
||||
:
|
||||
echo MAKE is done.
|
||||
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
sc+schemed+sinterp+smain+support+PROINTRP+sstring+smemory+block+
|
||||
sgcmark+sgcsweep+sbigmem+sexec+shash+sstack+sarith+sutil+
|
||||
serror+PROIO+PROREAD+PROIOSUP+PROSPRIN+PROSREAD+PROWIN+PRO2REAL+PROCIOSP+
|
||||
sprintf+sdebug+sdump+scannum+strace+serrmsg+sbigmath+scar_cdr+svars+saprop+
|
||||
sprop+msdos+sreset+sfasl+sreify+senv+get_path+sobjhash+asm_link+slink+alink+
|
||||
PROBID+strmlnrs+srch_str+squish+srelocat+freesp++flo2hex+
|
||||
PROSMMU
|
||||
|
||||
|
|
@ -0,0 +1,443 @@
|
|||
# PC Scheme 4.0 make file: Protected Memory Scheme
|
||||
|
||||
#
|
||||
# command-line macro variables
|
||||
#
|
||||
redo= # if nonempty, force make to do everything here
|
||||
debug= # if nonempty, generate symbol file
|
||||
|
||||
#
|
||||
# directories
|
||||
#
|
||||
|
||||
tools=\tools # read-only
|
||||
lib=\lib # read-only
|
||||
src=\build # read-only
|
||||
obj=\objectp # read-write
|
||||
exec=\exec # read-write
|
||||
|
||||
#
|
||||
# rules
|
||||
#
|
||||
|
||||
.asm.obj:
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
.c.obj:
|
||||
$(tools)\lc -dPROMEM -ms -ccdswum -o$@ $*
|
||||
|
||||
#
|
||||
# make-specific initialization
|
||||
#
|
||||
|
||||
# if redo on command line specified, build the entire system
|
||||
:
|
||||
if not "$(redo)"=="" del $(obj)\*.obj
|
||||
if not "$(redo)"=="" del $(exec)\pcspro.*
|
||||
|
||||
#
|
||||
# application-specific initialization
|
||||
#
|
||||
|
||||
:
|
||||
cd $(src)
|
||||
path $(tools)
|
||||
|
||||
|
||||
#
|
||||
# assembly language files
|
||||
#
|
||||
|
||||
$(src)\schemed.equ: $(src)\memtype.equ
|
||||
$(tools)\touch schemed.equ
|
||||
|
||||
$(src)\scheme.equ: $(src)\schemed.equ $(src)\schemed.ref $(src)\schemed.mac \
|
||||
$(src)\smmu.mac
|
||||
$(tools)\touch scheme.equ
|
||||
|
||||
$(obj)\alink.obj: $(src)\alink.asm
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\block.obj: $(src)\block.asm $(src)\scheme.equ $(src)\memtype.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\flo2hex.obj: $(src)\flo2hex.asm
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\get_path.obj: $(src)\get_path.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\prointrp.obj: $(src)\prointrp.asm $(src)\dos.mac $(src)\pcmake.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK INTRUP.ASM FOR REAL MODE UPDATES ALSO ****
|
||||
|
||||
$(obj)\msdos.obj: $(src)\msdos.asm
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\saprop.obj: $(src)\saprop.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\probid.obj: $(src)\probid.asm
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK SBID.ASM FOR REAL MODE UPDATES ALSO ****
|
||||
|
||||
$(obj)\sbigmath.obj: $(src)\sbigmath.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\sc.obj: $(src)\sc.asm $(src)\dos.mac
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\scannum.obj: $(src)\scannum.asm
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\scar_cdr.obj: $(src)\scar_cdr.asm $(src)\scheme.equ $(src)\sinterp.mac \
|
||||
$(src)\sinterp.arg
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\schemed.obj: $(src)\schemed.asm $(src)\schemed.equ $(src)\sasm.mac
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\senv.obj: $(src)\senv.asm $(src)\scheme.equ $(src)\sinterp.mac \
|
||||
$(src)\sinterp.arg $(src)\stackf.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\sexec.obj: $(src)\sexec.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\sgcmark.obj: $(src)\sgcmark.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\sgcsweep.obj: $(src)\sgcsweep.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\sinterp.obj: $(src)\sinterp.asm $(src)\schemed.equ $(src)\schemed.ref \
|
||||
$(src)\schemed.mac $(src)\pcmake.equ $(src)\stackf.equ \
|
||||
$(src)\smmu.mac $(src)\sinterp.mac $(src)\sinterp.arg
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\prosmmu.obj: $(src)\prosmmu.asm $(src)\schemed.equ $(src)\schemed.ref
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\sobjhash.obj: $(src)\sobjhash.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\squish.obj: $(src)\squish.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\srch_str.obj: $(src)\srch_str.asm $(src)\scheme.equ $(src)\pcmake.equ \
|
||||
$(src)\sinterp.arg
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\srelocat.obj: $(src)\srelocat.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\sstack.obj: $(src)\sstack.asm $(src)\scheme.equ $(src)\sinterp.mac \
|
||||
$(src)\sinterp.arg $(src)\stackf.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\sstring.obj: $(src)\sstring.asm $(src)\scheme.equ $(src)\sinterp.mac \
|
||||
$(src)\sinterp.arg
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
# stimer exists within sinterp.asm for protected mode
|
||||
#(obj)\stimer.obj: $(src)\stimer.asm $(src)\scheme.equ
|
||||
# $(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\strmlnrs.obj: $(src)\strmlnrs.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\sutil.obj: $(src)\sutil.asm $(src)\scheme.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK FOR REAL MODE UPDATES ALSO ****
|
||||
|
||||
$(obj)\svars.obj: $(src)\svars.asm $(src)\scheme.equ $(src)\sinterp.mac \
|
||||
$(src)\sinterp.arg
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
# sw_int now exists within PRO2REAL.ASM
|
||||
#$(obj)\sw_int.obj: $(src)\sw_int.asm
|
||||
# $(tools)\masm /DPROMEM $*,$@;
|
||||
|
||||
$(obj)\pro2real.obj: $(src)\pro2real.asm $(src)\scheme.equ $(src)\xli.equ \
|
||||
$(src)\xli_pro.mac $(src)\rpc.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK XLI.ASM FOR REAL MODE UPDATES ALSO ****
|
||||
|
||||
|
||||
|
||||
#
|
||||
# C source files
|
||||
#
|
||||
|
||||
$(src)\scheme.h: $(src)\memtype.h $(src)\schmdefs.h
|
||||
$(tools)\touch scheme.h
|
||||
|
||||
$(obj)\asm_link.obj: $(src)\asm_link.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\freesp.obj: $(src)\freesp.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sarith.obj: $(src)\sarith.c $(src)\scheme.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sbigmem.obj: $(src)\sbigmem.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sdebug.obj: $(src)\sdebug.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sdump.obj: $(src)\sdump.c $(src)\scheme.h $(src)\ctype.h \
|
||||
$(src)\schars.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\serrmsg.obj: $(src)\serrmsg.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\serror.obj: $(src)\serror.c $(src)\scheme.h $(src)\ctype.h \
|
||||
$(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sfasl.obj: $(src)\sfasl.c $(src)\scheme.h $(src)\stdio.h \
|
||||
$(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\shash.obj: $(src)\shash.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\slink.obj: $(src)\slink.c $(src)\ctype.h $(src)\slink.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\smain.obj: $(src)\smain.c $(src)\version.h $(src)\scheme.h \
|
||||
$(src)\sport.h $(src)\pcmake.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\smemory.obj: $(src)\smemory.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sprintf.obj: $(src)\sprintf.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sprop.obj: $(src)\sprop.c $(src)\scheme.h $(src)\ctype.h \
|
||||
$(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sreify.obj: $(src)\sreify.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\sreset.obj: $(src)\sreset.c $(src)\scheme.h $(src)\ctype.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\strace.obj: $(src)\strace.c $(src)\scheme.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
$(obj)\support.obj: $(src)\support.c $(src)\scheme.h $(src)\slist.h
|
||||
# $(tools)\lc -ms -ccdswum -o$@ $*
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
|
||||
#
|
||||
# I/O source files - All of protected mode scheme's I/O files have been
|
||||
# grouped together in one place so they can be easily recognized from
|
||||
# Real Mode Scheme's I/O files. There wasn't enough time to get all the I/O
|
||||
# code merged, so there may be duplicate code between regular scheme and
|
||||
# protected mode scheme. This means that if any code is modified in the
|
||||
# following files, you should check the corresponding real mode files also
|
||||
#
|
||||
|
||||
# Assembly language I/O files
|
||||
|
||||
$(obj)\proio.obj: $(src)\proio.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK REAL MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\proiosup.obj: $(src)\proiosup.asm $(src)\scheme.equ $(src)\xli.equ \
|
||||
$(src)\xli_pro.mac
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK REAL MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\proread.obj: $(src)\proread.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK REAL MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\prosprin.obj: $(src)\prosprin.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK REAL MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\prosread.obj: $(src)\prosread.asm $(src)\scheme.equ $(src)\sinterp.arg
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK REAL MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\prowin.obj: $(src)\prowin.asm $(src)\scheme.equ $(src)\xli.equ \
|
||||
$(src)\xli_pro.mac
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK REAL MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
|
||||
|
||||
# Lattice C I/O routines
|
||||
|
||||
$(obj)\prociosp.obj: $(src)\prociosp.c $(src)\scheme.h $(src)\sport.h \
|
||||
$(src)\slist.h
|
||||
$(tools)\lc1 -dPROMEM -ms -ccdswum -o$(obj)\$*.q $*
|
||||
$(tools)\lc2 -o -v$@ $(obj)\$*.q
|
||||
REM **** REMEMBER TO CHECK REAL MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
|
||||
|
||||
# Real Mode Exe Files
|
||||
|
||||
$(obj)\realschm.obj: $(src)\realschm.asm $(src)\xli.equ $(src)\xli.ref \
|
||||
$(src)\xli_pro.mac
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK REAL MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\realio.obj: $(src)\realio.asm $(src)\schemed.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK REAL MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
$(obj)\graphics.obj: $(src)\graphics.asm $(src)\pcmake.equ
|
||||
$(tools)\masm /DPROMEM $*,$@;
|
||||
REM **** REMEMBER TO CHECK REAL MODE I/O FILES FOR UPDATES ALSO ****
|
||||
|
||||
|
||||
#
|
||||
# Generate PCSPRO.EXE file
|
||||
#
|
||||
|
||||
$(exec)\pcs.exe: $(obj)\sc.obj \
|
||||
$(obj)\schemed.obj \
|
||||
$(obj)\sinterp.obj \
|
||||
$(obj)\smain.obj \
|
||||
$(obj)\sstring.obj \
|
||||
$(obj)\sgcmark.obj \
|
||||
$(obj)\sgcsweep.obj \
|
||||
$(obj)\sbigmem.obj \
|
||||
$(obj)\sexec.obj \
|
||||
$(obj)\support.obj \
|
||||
$(obj)\shash.obj \
|
||||
$(obj)\sstack.obj \
|
||||
$(obj)\sarith.obj \
|
||||
$(obj)\sutil.obj \
|
||||
$(obj)\serror.obj \
|
||||
$(obj)\sdebug.obj \
|
||||
$(obj)\sdump.obj \
|
||||
$(obj)\strace.obj \
|
||||
$(obj)\serrmsg.obj \
|
||||
$(obj)\sbigmath.obj \
|
||||
$(obj)\scar_cdr.obj \
|
||||
$(obj)\svars.obj \
|
||||
$(obj)\saprop.obj \
|
||||
$(obj)\sprop.obj \
|
||||
$(obj)\msdos.obj \
|
||||
$(obj)\sreset.obj \
|
||||
$(obj)\sfasl.obj \
|
||||
$(obj)\sreify.obj \
|
||||
$(obj)\senv.obj \
|
||||
$(obj)\sprintf.obj \
|
||||
$(obj)\scannum.obj \
|
||||
$(obj)\get_path.obj \
|
||||
$(obj)\sobjhash.obj \
|
||||
$(obj)\asm_link.obj \
|
||||
$(obj)\slink.obj \
|
||||
$(obj)\alink.obj \
|
||||
$(obj)\probid.obj \
|
||||
$(obj)\strmlnrs.obj \
|
||||
$(obj)\srch_str.obj \
|
||||
$(obj)\squish.obj \
|
||||
$(obj)\srelocat.obj \
|
||||
$(obj)\freesp.obj \
|
||||
$(obj)\flo2hex.obj \
|
||||
$(obj)\block.obj \
|
||||
$(obj)\prociosp.obj \
|
||||
$(obj)\prointrp.obj \
|
||||
$(obj)\proio.obj \
|
||||
$(obj)\proiosup.obj \
|
||||
$(obj)\proread.obj \
|
||||
$(obj)\prosmmu.obj \
|
||||
$(obj)\prosread.obj \
|
||||
$(obj)\prowin.obj \
|
||||
$(obj)\pro2real.obj \
|
||||
$(obj)\prosprin.obj
|
||||
cd $(obj)
|
||||
$(tools)\link @$(src)\pcspro.lnk,$(exec)\pcspro.exe,$(exec)\pcspro.map/map,$(lib)\lcm+$(lib)\lc;
|
||||
cd $(exec)
|
||||
if not "$(debug)"=="" $(tools)\mapsym $(exec)\pcspro.map
|
||||
$(tools)\express -msl pcspro
|
||||
$(tools)\bind -o $(exec)\pcspro.exe -i $(exec)\pcspro.exp -l $(tools)\tinyup.exe
|
||||
cd $(src)
|
||||
|
||||
|
||||
#
|
||||
# Generate REALSCHM.EXE file
|
||||
#
|
||||
|
||||
$(exec)\realschm.exe: $(obj)\realschm.obj
|
||||
cd $(obj)
|
||||
$(tools)\link $(obj)\realschm.obj,$(exec)\realschm.exe,$(exec)\realschm.map/map;
|
||||
cd $(src)
|
||||
|
||||
#
|
||||
# Generate REALIO.EXE file
|
||||
#
|
||||
|
||||
$(exec)\realio.exe: $(obj)\realio.obj
|
||||
cd $(obj)
|
||||
$(tools)\link $(obj)\realio.obj,$(exec)\realio.exe,$(exec)\realio.map/map;
|
||||
cd $(src)
|
||||
|
||||
#
|
||||
# Generate GRAPHICS.EXE file
|
||||
#
|
||||
|
||||
$(exec)\graphics.exe: $(obj)\graphics.obj
|
||||
cd $(obj)
|
||||
$(tools)\link $(obj)\graphics.obj,$(exec)\graphics.exe,$(exec)\graphics.map/map;
|
||||
cd $(src)
|
||||
|
||||
:
|
||||
cd $(src)
|
||||
|
||||
#
|
||||
# make-specific wrapup
|
||||
#
|
||||
|
||||
:
|
||||
echo MAKE is done.
|
||||
|
||||
|
|
@ -0,0 +1,552 @@
|
|||
/* =====> PROCIOSP.C */
|
||||
/* TIPC Scheme '84 Runtime Support - File Input/Output Support
|
||||
(C) Copyright 1985 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: 4 February 1985
|
||||
Last Modification:
|
||||
14 Jan 1987 - dbs Modified to allow for random i/o.
|
||||
16 Mar 1987 - tc Dos I/O errors call DOS-ERR now.
|
||||
24 Nov 1987 - tc Renamed from SIN_OUT.C to IOSUPORT.C
|
||||
Combined routines from sprint.c,sread.c
|
||||
get_port.c and zcio.c
|
||||
*/
|
||||
#include "scheme.h"
|
||||
#include "sport.h"
|
||||
#include "slist.h"
|
||||
|
||||
#define FILE_NOT_FOUND 2 /* MS-DOS error code */
|
||||
#define NON_RESTART 1 /* Operation not restartable */
|
||||
|
||||
extern char decpoint; /* Current decimal point character */
|
||||
extern unsigned GC_ING; /* Garbage collecting indicator */
|
||||
|
||||
char *getmem(); /* Lattice C's memory allocation support */
|
||||
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Get Port Object */
|
||||
/* */
|
||||
/* Purpose: To determine is a register contains a valid port object */
|
||||
/* representation and to return the appropriate port */
|
||||
/* pointer in "tmp_reg". */
|
||||
/************************************************************************/
|
||||
get_port(reg, mode)
|
||||
int reg[2], mode;
|
||||
{
|
||||
int disp; /* displacement component of a pointer */
|
||||
int page; /* page number component of a pointer */
|
||||
|
||||
/* fetch page and displacement portions of port pointer */
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
disp = reg[C_DISP];
|
||||
|
||||
/* check to see if port pointer is nil-- if so, search fluid env */
|
||||
if (!page)
|
||||
{
|
||||
if (mode) intern (tmp_reg, "OUTPUT-PORT", 11);
|
||||
else intern (tmp_reg, "INPUT-PORT", 10);
|
||||
|
||||
/* search fluid environment for interned symbol */
|
||||
ASSERT(fluid_lookup(tmp_reg));
|
||||
page = CORRPAGE(tmp_page);
|
||||
disp = tmp_disp;
|
||||
} /* end: if (!page) */
|
||||
|
||||
/* At this point, the page, disp should point to a port, or the
|
||||
symbol 'console */
|
||||
if (ptype[page] != PORTTYPE*2)
|
||||
{
|
||||
if (CORRPAGE(CON_PAGE) != page || CON_DISP != disp) return(1);
|
||||
tmp_page = SPECPOR*2;
|
||||
tmp_disp = (mode ? OUT_DISP : IN_DISP);
|
||||
}
|
||||
else
|
||||
{
|
||||
tmp_page = ADJPAGE(page);
|
||||
tmp_disp = disp;
|
||||
}
|
||||
return(0);
|
||||
} /* end of function: get_port(reg, mode) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Open a Port */
|
||||
/************************************************************************/
|
||||
spopen(file, mode)
|
||||
int file[2]; /* pathname, 'console, nil, or #<port> */
|
||||
int mode[2]; /* 'read, 'write, 'append */
|
||||
{
|
||||
/* extern int prn_handle; (tc) */
|
||||
int direction; /* 'read, 'write, 'append code */
|
||||
int disp; /* displacement component of a pointer */
|
||||
int handle; /* handle assigned to file by open */
|
||||
int hsize; /* high word of file size - dbs */
|
||||
int lsize; /* low word of file size - dbs */
|
||||
int i; /* our old favorite index variable */
|
||||
int len; /* length of file's pathname (plus 1) */
|
||||
int page; /* page number component of a pointer */
|
||||
int p_flags; /* port flags */
|
||||
int retstat = 0; /* the return status */
|
||||
int stat; /* status returned from open request */
|
||||
char *string; /* file pathname buffer pointer */
|
||||
float fsize; /* file size - dbs */
|
||||
|
||||
ENTER(spopen);
|
||||
|
||||
/* identify mode value */
|
||||
if ((direction = get_mode(mode)) == -1) goto src_err;
|
||||
|
||||
page = CORRPAGE(file[C_PAGE]);
|
||||
disp = file[C_DISP];
|
||||
|
||||
switch(ptype[page])
|
||||
{
|
||||
case STRTYPE*2: len = get_word(page, disp+1);
|
||||
if (len < 0) /* Adjust for small string */
|
||||
len = len + BLK_OVHD;
|
||||
else
|
||||
len = len - BLK_OVHD;
|
||||
|
||||
if (!(string = getmem(len+1))) getmem_error(rtn_name);
|
||||
get_str(string, page, disp);
|
||||
string[len] = '\0';
|
||||
for (i=0; i<len; i++)
|
||||
string[i] = toupper(string[i]);
|
||||
switch (direction)
|
||||
{
|
||||
case READ: if ((stat = zopen(&handle,
|
||||
string, direction,
|
||||
&hsize,&lsize)))
|
||||
{
|
||||
open_error:
|
||||
rlsstr(string);
|
||||
/* Call to dos_err will not return */
|
||||
stat += (IO_ERROR_START - 1);
|
||||
dos_err(NON_RESTART,stat,file);
|
||||
}
|
||||
break;
|
||||
case WRITE: if ((stat = zcreate(&handle, string)))
|
||||
goto open_error;
|
||||
/*
|
||||
if (((stat = strcmp(string,"PRN")) == 0) ||
|
||||
((stat = strcmp(string,"LST")) == 0))
|
||||
prn_handle = handle;
|
||||
*/
|
||||
break;
|
||||
case APPEND: if ((stat = zopen(&handle, string,
|
||||
direction,&hsize,&lsize)) == FILE_NOT_FOUND)
|
||||
{
|
||||
if((stat = zcreate(&handle, string)))
|
||||
goto open_error;
|
||||
break;
|
||||
}
|
||||
if (stat) goto open_error;
|
||||
/* do
|
||||
{
|
||||
if (zread(handle, buffer, &length))
|
||||
break;
|
||||
} while (length); */
|
||||
if (((stat = strcmp(string,"PRN")) == 0) ||
|
||||
((stat = strcmp(string,"LST")) == 0))
|
||||
break;
|
||||
mov_fptr(handle);
|
||||
fsize = (hsize * 65536) + lsize;
|
||||
}
|
||||
mov_reg(tmp_reg, file); /* save pointer to filename */
|
||||
alloc_block(file, PORTTYPE, WINDSIZE+BUFFSIZE);
|
||||
page = CORRPAGE(file[C_PAGE]);
|
||||
disp = file[C_DISP];
|
||||
zero_blk(page, disp);
|
||||
if (direction == WRITE)
|
||||
put_word(page, disp+UL_LINE, 1);
|
||||
else
|
||||
if (direction == APPEND)
|
||||
{ /* update the chunk# and buffer position */
|
||||
i = fsize / 256;
|
||||
put_word(page, disp+UL_LINE, i + 1);
|
||||
i = fsize - (i * 256);
|
||||
put_word(page, disp+BUF_POS, i);
|
||||
direction = WRITE; /* unsets read flag - dbs */
|
||||
}
|
||||
put_word(page, disp+P_FLAGS, OPEN+direction);
|
||||
put_word(page, disp+N_COLS, 80);
|
||||
put_word(page, disp+HANDLE, handle);
|
||||
put_word(page, disp+N_LINES, hsize);
|
||||
put_word(page, disp+B_ATTRIB, lsize);
|
||||
/* put pointer to pathname into port object */
|
||||
put_ptr(page, disp+STR_PTR, tmp_page, tmp_disp);
|
||||
rlsstr(string); /* release pathname buffer */
|
||||
break;
|
||||
|
||||
case SYMTYPE*2: if (file[C_PAGE] != CON_PAGE ||
|
||||
file[C_DISP] != CON_DISP) goto src_err;
|
||||
break;
|
||||
|
||||
case PORTTYPE*2: p_flags = get_word(page, disp+P_FLAGS);
|
||||
if (p_flags & OPEN) break;
|
||||
|
||||
src_err:
|
||||
default: set_src_err("OPEN-PORT", 2, file, mode);
|
||||
retstat = -1;
|
||||
} /* end: switch(ptype[page]) */
|
||||
end_of_function:
|
||||
return(retstat);
|
||||
} /* end of function: spopen(file, mode) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Close a Port */
|
||||
/************************************************************************/
|
||||
spclose(port)
|
||||
int port[2]; /* register containing port pointer */
|
||||
{
|
||||
int page; /* page number component of a pointer */
|
||||
int p_flags; /* port flags */
|
||||
int retstat = 0; /* the return status */
|
||||
int stat; /* status returned from open request */
|
||||
|
||||
static int err_code[2] = {0, SPECFIX*2}; /* close error status */
|
||||
|
||||
if (!get_port(port, 0))
|
||||
{
|
||||
page = CORRPAGE(tmp_page);
|
||||
p_flags = get_word(page, tmp_disp+P_FLAGS);
|
||||
if (p_flags & OPEN && !(p_flags & WINDOW))
|
||||
{
|
||||
/***** write EOF to file before closing *****/
|
||||
stat = 0x1A; /* ascii code of EOF character */
|
||||
retstat = 1; /* number of bytes to write */
|
||||
|
||||
if ((p_flags & WRITE) || (p_flags & READ_WRITE))
|
||||
if ((stat = zwrite(get_word(page,tmp_disp+HANDLE),&stat,&retstat)))
|
||||
{
|
||||
stat += (IO_ERROR_START - 1);
|
||||
goto io_err;
|
||||
}
|
||||
|
||||
if ((stat = zclose(get_word(page, tmp_disp+HANDLE))))
|
||||
{
|
||||
stat += (IO_ERROR_START - 1);
|
||||
io_err:
|
||||
/* We will not return from dos_err */
|
||||
dos_err(NON_RESTART,stat,port);
|
||||
}
|
||||
put_word(page, tmp_disp+P_FLAGS, p_flags & (! OPEN));
|
||||
put_word(page, tmp_disp+BUF_POS, BUFFSIZE);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
set_src_err("CLOSE-PORT", 1, port);
|
||||
retstat = -1;
|
||||
}
|
||||
return(retstat);
|
||||
} /* end of function: spclose(port) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Local Support: Determine Input/Output Mode Value */
|
||||
/************************************************************************/
|
||||
get_mode(reg, in_or_out)
|
||||
int reg[2]; /* mode register ('read, 'write, 'append) */
|
||||
int in_or_out; /* 0 = input, 1 = output */
|
||||
{
|
||||
if (ptype[CORRPAGE(reg[C_PAGE])] == SYMTYPE*2)
|
||||
{
|
||||
intern(tmp_reg, "READ", 4);
|
||||
if (tmp_disp == reg[C_DISP] && tmp_page == reg[C_PAGE]) return(0);
|
||||
intern(tmp_reg, "WRITE", 5);
|
||||
if (tmp_disp == reg[C_DISP] && tmp_page == reg[C_PAGE]) return(1);
|
||||
intern(tmp_reg, "APPEND", 6);
|
||||
if (tmp_disp == reg[C_DISP] && tmp_page == reg[C_PAGE]) return(2);
|
||||
}
|
||||
return(-1);
|
||||
} /* end of function: get_mode(reg, in_or_out) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Clear Window */
|
||||
/************************************************************************/
|
||||
clear_window(reg)
|
||||
int reg[2]; /* register containing port pointer */
|
||||
{
|
||||
int b_attrib; /* border attributes */
|
||||
int disp; /* displacement component of a pointer */
|
||||
int n_cols; /* number of columns in the window */
|
||||
int n_lines; /* number of lines in the window */
|
||||
int page; /* page number component of a pointer */
|
||||
int retstat = 0; /* the return status */
|
||||
char *string; /* buffer pointer for label's text */
|
||||
int t_attrib; /* text attributes */
|
||||
int ul_col; /* upper left corner's column number */
|
||||
int ul_line; /* upper left corner's line number */
|
||||
|
||||
char *string_asciz(); /* fetches characters of a string */
|
||||
|
||||
ENTER(clear_window);
|
||||
|
||||
get_port(reg,0);
|
||||
page = CORRPAGE(tmp_page);
|
||||
disp = tmp_disp;
|
||||
if (ptype[page] == PORTTYPE*2 &&
|
||||
get_byte(page, disp+P_FLAGS) & WINDOW)
|
||||
{
|
||||
pt_flds4(tmp_reg, &ul_line, &ul_col, &n_lines, &n_cols);
|
||||
t_attrib = get_word(page, disp+T_ATTRIB);
|
||||
b_attrib = get_word(page, disp+B_ATTRIB);
|
||||
zclear(ul_line, ul_col, n_lines, n_cols, t_attrib);
|
||||
if (b_attrib != -1)
|
||||
{
|
||||
tmp_page = get_byte(page, disp+STR_PTR);
|
||||
tmp_disp = get_word(page, disp+STR_PTR+1);
|
||||
string = string_asciz(tmp_reg);
|
||||
zborder(ul_line, ul_col, n_lines, n_cols, b_attrib, string);
|
||||
rlsstr(string);
|
||||
}
|
||||
/* put the cursor in the "home" position (upper left hand corner) */
|
||||
put_word(page, disp+CUR_LINE, 0);
|
||||
put_word(page, disp+CUR_COL, 0);
|
||||
}
|
||||
else
|
||||
{
|
||||
set_src_err("WINDOW-CLEAR", 1, reg);
|
||||
retstat = -1;
|
||||
}
|
||||
return(retstat);
|
||||
} /* end of function: clear_window(reg) */
|
||||
|
||||
/***************************************************************/
|
||||
/* PRINTFLO(f) */
|
||||
/* Given a double-length floating-point number, this */
|
||||
/* procedure formats and prints the ASCII representation of */
|
||||
/* the number. */
|
||||
/***************************************************************/
|
||||
printflo(f)
|
||||
double f;
|
||||
{
|
||||
char buf[32];
|
||||
printtxt(buf, makeflo(f,buf,0,outrange(f)));
|
||||
}
|
||||
|
||||
/***************************************************************/
|
||||
/* OUTRANGE(f) */
|
||||
/* Returns a non-zero value if the value of the given */
|
||||
/* flonum F is not "close" to 1, zero otherwise. */
|
||||
/***************************************************************/
|
||||
outrange(f)
|
||||
double f;
|
||||
{
|
||||
if (f<0) f = -f;
|
||||
return((f<1.0e-3) || (f>=1.0e7));
|
||||
}
|
||||
|
||||
/***************************************************************/
|
||||
/* MAKEFLO(flo,buf,prec,ex) */
|
||||
/* Takes a flonum FLO and converts it to a human-readable */
|
||||
/* form, storing the characters in the buffer BUF. PREC */
|
||||
/* specifies the number of decimal places to be used (as many */
|
||||
/* as necessary, up to a maximum, if PREC is 0) and EX */
|
||||
/* specifies whether to use exponential (if nonzero) or fixed- */
|
||||
/* decimal format. MAKEFLO returns the number of characters */
|
||||
/* placed in BUF, and BUF should be at least 32 bytes. */
|
||||
/***************************************************************/
|
||||
makeflo(flo,buf,prec,ex)
|
||||
double flo;
|
||||
char *buf;
|
||||
int prec,ex;
|
||||
{
|
||||
char digits[32];
|
||||
int scl = 0;
|
||||
if (flo==0.0)
|
||||
{
|
||||
*digits='0'; ex=0;
|
||||
}
|
||||
else
|
||||
{
|
||||
scale(&flo,&scl);
|
||||
flo2big(flo*1.0e15,buf);
|
||||
big2asc(buf,digits);
|
||||
}
|
||||
return(formflo(digits,buf,scl,prec,ex));
|
||||
}
|
||||
|
||||
/***************************************************************/
|
||||
/* SCALE(&flo,&x) */
|
||||
/* Given a pointer FLO to a double-length flonum and a */
|
||||
/* pointer X to an integer, SCALE puts at those two locations */
|
||||
/* a new flonum and integer such that FLO equals the new */
|
||||
/* flonum times 10 to the integer's power and the new flonum */
|
||||
/* is in the interval [ 1.0, 10.0 ). */
|
||||
/***************************************************************/
|
||||
scale(flo,x)
|
||||
double *flo;
|
||||
int *x;
|
||||
{
|
||||
double local;
|
||||
double squar = 10.0;
|
||||
double tensquar[9];
|
||||
int scale,wassmall,i;
|
||||
scale = wassmall = i = 0;
|
||||
local = ((*flo>0) ? *flo : -*flo);
|
||||
if (local == 0)
|
||||
*x = 0;
|
||||
else
|
||||
{
|
||||
if (local < 1.0)
|
||||
{
|
||||
wassmall = -1;
|
||||
local = 1.0/local;
|
||||
}
|
||||
tensquar[0] = 10.0;
|
||||
while (++i<9)
|
||||
{
|
||||
squar *= squar;
|
||||
tensquar[i] = squar;
|
||||
}
|
||||
while (--i>=0)
|
||||
{
|
||||
scale <<=1;
|
||||
if (local>=tensquar[i])
|
||||
{
|
||||
local /= tensquar[i];
|
||||
scale++;
|
||||
}
|
||||
}
|
||||
if (wassmall)
|
||||
{
|
||||
scale = -scale;
|
||||
local = 1.0/local;
|
||||
if (local!=1.0)
|
||||
{
|
||||
local *= 10;
|
||||
scale--;
|
||||
}
|
||||
}
|
||||
*x = scale;
|
||||
*flo = ((*flo < 0.0) ? -local : local);
|
||||
}
|
||||
}
|
||||
|
||||
/**************************************************************/
|
||||
/* SCANFLO(s,flo,base) */
|
||||
/* The string S, which ends in a control char, holds a */
|
||||
/* representation of a floating-point number. The value of */
|
||||
/* this number is stored in *FLO. */
|
||||
/**************************************************************/
|
||||
scanflo(s,flo,base)
|
||||
char *s;
|
||||
double *flo;
|
||||
int base;
|
||||
{
|
||||
int i=0;
|
||||
int neg=0;
|
||||
int x=0;
|
||||
double place;
|
||||
switch (*s)
|
||||
{
|
||||
case '-': neg=-1;
|
||||
case '+': i++; break;
|
||||
default: break;
|
||||
}
|
||||
while (s[i]=='#') i+=2;
|
||||
*flo = 0.0;
|
||||
while (isdig(s[i],base))
|
||||
{
|
||||
*flo = (*flo * base) + digval(s[i++]);
|
||||
}
|
||||
if (!(s[i]==decpoint)) goto EXPON;
|
||||
POINT:
|
||||
i++; place = 1.0;
|
||||
while (isdig(s[i],base))
|
||||
{
|
||||
place /= base;
|
||||
*flo += place*digval(s[i++]);
|
||||
}
|
||||
if (s[i]<' ') goto GOTFLO;
|
||||
EXPON:
|
||||
i++;
|
||||
if (s[i]=='-')
|
||||
{
|
||||
i++; place = 1.0/base;
|
||||
}
|
||||
else place=base;
|
||||
while (isdigit(s[i]))
|
||||
x = (x*10) + digval(s[i++]);
|
||||
while (x)
|
||||
{
|
||||
if (x!=(x>>1)<<1)
|
||||
*flo *= place;
|
||||
if (place<1.0e153) place*=place;
|
||||
x >>= 1;
|
||||
}
|
||||
GOTFLO:
|
||||
if (neg)
|
||||
*flo = -*flo;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************/
|
||||
/* ALLOC_INT(reg,buf) */
|
||||
/* This allocates an integer, either a fixnum or a */
|
||||
/* bignum, depending on the size of the integer, i.e., if */
|
||||
/* the absolute value < 16384, then a fixnum is allocated. */
|
||||
/* The value is read from BUF. */
|
||||
/**************************************************************/
|
||||
alloc_int(reg,buf)
|
||||
int reg[2];
|
||||
char *buf;
|
||||
{
|
||||
unsigned i,j;
|
||||
int pg;
|
||||
i = 256*buf[1] + buf[0];
|
||||
j = 256*buf[4] + buf[3];
|
||||
pg = buf[2] & 1;
|
||||
if ((i == 1) && (j <= 16383+pg)) /* If fixnum */
|
||||
alloc_fixnum(reg, (pg ? -j : j));
|
||||
else
|
||||
{
|
||||
alloc_block(reg, BIGTYPE, 2*i + 1);
|
||||
toblock(reg, 3, buf+2, 2*i +1);
|
||||
}
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* Write "GC On"Message to the who-line */
|
||||
/************************************************************************/
|
||||
gc_on()
|
||||
{
|
||||
int lcl_reg[2];
|
||||
char *text;
|
||||
char *string_asciz();
|
||||
|
||||
GC_ING = 1;
|
||||
|
||||
intern(lcl_reg, "PCS-GC-MESSAGE", 14);
|
||||
if (sym_lookup (lcl_reg, GNV_reg) &&
|
||||
(text = string_asciz(lcl_reg)))
|
||||
{
|
||||
who_write("\n");
|
||||
who_write(text);
|
||||
rlsstr(text);
|
||||
}
|
||||
else
|
||||
{
|
||||
who_write("\n * Garbage Collecting *");
|
||||
}
|
||||
} /* end of function: gc_on() */
|
||||
|
||||
/************************************************************************/
|
||||
/* Un-Write "GC On"Message to the who-line */
|
||||
/************************************************************************/
|
||||
gc_off()
|
||||
{
|
||||
|
||||
GC_ING = 0;
|
||||
|
||||
who_clear();
|
||||
} /* end of function: gc_off() */
|
||||
|
||||
|
|
@ -0,0 +1,75 @@
|
|||
********** README FILE FOR PROTECTED MODE SCHEME ************
|
||||
|
||||
|
||||
*********************
|
||||
Configuration Options
|
||||
*********************
|
||||
|
||||
|
||||
A config.286 file is created and placed in the root directory of the specified
|
||||
drive by the instpro.bat batch stream. This file contains information for the
|
||||
protected mode operating system (OS.286 - provided by AI Architects), to assist
|
||||
in switching between real and protected mode. This file must exist in the root
|
||||
directory of any drive in which you attempt to execute PCSPRO.EXE. The instal-
|
||||
lation batch stream attempts to build the config.286 file based on the type of
|
||||
machine that it is running on. It should work with all IBM machines, but may
|
||||
have some problems when running on clones. If the system does not work as
|
||||
expected, you may edit the config.286 file and attempt various combinations of
|
||||
the options. In some cases, the options may cause a machine failure and the
|
||||
machine will need to be re-booted.
|
||||
|
||||
The following configuration options may be tried:
|
||||
|
||||
SHUTDOWN=9, KEYBOARDWAIT=200 (default, most likely to work)
|
||||
SHUTDOWN=A, KEYBOARDWAIT=200
|
||||
SHUTDOWN=9, KEYBOARDWAIT=1
|
||||
SHUTDOWN=A, KEYBOARDWAIT=1 (fastest, use this when possible)
|
||||
|
||||
|
||||
KEYBOARDWAIT Specifies the amount of time required for some keyboard
|
||||
controllers so that no interrupts are lost. Default value
|
||||
is 200 (hex). Lower values will speed up certain operations.
|
||||
Some machines may require larger values to work. Valid
|
||||
settings range from 0 to FFFF (specified in hex).
|
||||
|
||||
SHUTDOWN=(9/A) Specifies the shutdown code that is used when the machine
|
||||
is switched back into real mode. Default setting is "9".
|
||||
A setting of "A" should usually perform faster when the BIOS
|
||||
supports this setting.
|
||||
|
||||
PS2=1 Specifies that the machine is a PS2 model 50,60, or 80.
|
||||
|
||||
|
||||
***********************
|
||||
TI Business Pro Options
|
||||
***********************
|
||||
|
||||
Protected mode Scheme requires version 1.03 or newer of the 8042 keyboard
|
||||
controller in your machine to work. To find out whether you have the proper
|
||||
version, we have provided a simple utility you can run to tell you the
|
||||
version number. The utility is the file VERS8042.COM on this diskette.
|
||||
If it displays a version number less than 1.03, you will need to have the
|
||||
8042 keyboard controller upgraded in order to use protected mode.
|
||||
|
||||
*********************
|
||||
Hummingboard Options
|
||||
*********************
|
||||
|
||||
PCSPRO.EXE will run under the Hummingboard under your existing hummingboard
|
||||
configuration options, however you may need to delete the config.286 file if
|
||||
we create it from the instpro.bat batch stream.
|
||||
|
||||
|
||||
*********************
|
||||
CAVEATS
|
||||
*********************
|
||||
|
||||
DOS CALL works somewhat differently in Protected Mode Scheme than in regular
|
||||
mode as follows:
|
||||
1. Since Scheme is running in protected mode, there is no reason for it
|
||||
to save off memory before executing the desired program. Therefore,
|
||||
the third argument to DOS-CALL (heap space to save) is ignored.
|
||||
|
||||
2. When given the form (DOS-CALL "executable-file" " args ..."), the
|
||||
executable can only be a .COM file. To bid executables which are .EXE
|
||||
files use (DOS-CALL "" "executable-file args ...").
|
||||
|
|
@ -0,0 +1,478 @@
|
|||
PC Scheme Version 3.03 Release Notes
|
||||
|
||||
This document describes the changes in PC Scheme since version 2.0.
|
||||
|
||||
|
||||
PC Scheme 3.0 features
|
||||
----------------------
|
||||
|
||||
Version 3.0 contains bug fixes, significant enhancements over 2.0, and
|
||||
has been upgraded to the latest Scheme Standard as defined by the "Revised
|
||||
Revised Revised (R^3) Report on the Algorithmic Language Scheme." A copy
|
||||
of that report is now included in the 3.0 manuals.
|
||||
|
||||
Also included in this document is a number of features which are not
|
||||
documented in the Language Reference Manual nor the User's Guide, but
|
||||
which may be useful for programming.
|
||||
|
||||
R^3 Report Changes
|
||||
------------------
|
||||
|
||||
1. #T and #F now replace #!TRUE and #!FALSE. #!TRUE and #!FALSE are
|
||||
still supported in 3.0, however their use is discouraged and they
|
||||
may not be supported in future versions.
|
||||
|
||||
2. Quasiquote expressions may now be nested and are defined to work
|
||||
with vectors. The keywords UNQUOTE (",") and UNQUOTE-SPLICING (",@")
|
||||
are also now recognized.
|
||||
|
||||
3. The defining form (DEFINE (<variable> <formals>) <body>) no longer
|
||||
expands into a NAMED-LAMBDA as specified in the Report. To support
|
||||
code written under earlier versions of Scheme, the global variable
|
||||
PCS-INTEGRATE-DEFINE may be set non-nil to force the expansion, or
|
||||
nil to conform to the Report. Its default value is #T.
|
||||
|
||||
4. BOOLEAN? is a new procedure which indicates if an object is either
|
||||
#T or #F (ie., (BOOLEAN? #T) => #T).
|
||||
|
||||
5. PROCEDURE? is a new procedure which indicates if an object is a
|
||||
procedure (ie., (PROCEDURE? CAR) => #T).
|
||||
|
||||
6. The expression types NAMED-LAMBDA, REC, and SEQUENCE have been removed
|
||||
from the Report but will continue to be supported as extensions.
|
||||
|
||||
7. The following procedures have been removed from the report, however
|
||||
they will continue to be supported as extensions:
|
||||
|
||||
APPEND!, STRING-NULL?, SUBSTRING-FILL!, SUBSTRING-MOVE-LEFT!,
|
||||
SUBSTRING-MOVE-RIGHT!, OBJECT-HASH, OBJECT-UNHASH, 1+, -1+.
|
||||
|
||||
8. The redundant procedure names <?, <=?, =?, >?, and >=? have been removed
|
||||
from the Report and will be supported in this release, however their use
|
||||
is discouraged and future versions may not support them.
|
||||
|
||||
9. The syntax #!NULL (for the empty list) has been removed from the report.
|
||||
Its usage is also discouraged and may not be supported in the future.
|
||||
|
||||
|
||||
|
||||
Bug Fixes
|
||||
---------
|
||||
|
||||
1. DEFINE has been corrected to bind a variable in the correct environment.
|
||||
Earlier versions of PCS could incorrectly rebind variables defined in
|
||||
parent environments, if the variable did not exist in the defining
|
||||
environment.
|
||||
|
||||
2. IMPLODE now flags an error if given a non-list object.
|
||||
|
||||
3. NUMBER->STRING has fixes to correct problems with the '(heur) format.
|
||||
|
||||
4. Shift/Break now correctly halts printing of circular lists.
|
||||
|
||||
5. INPUT-PORT? and OUTPUT-PORT? have been corrected to return '() after the
|
||||
port is closed.
|
||||
|
||||
6. Expanded Memory Scheme no longer requires the EMM page frame to be on a
|
||||
64kb boundary.
|
||||
|
||||
7. Drawing a line from x1,y1 to x2,y2 and later erasing it in the
|
||||
direction x2,y2 to x1,y1 now correctly resets all the intermediate
|
||||
pixels.
|
||||
|
||||
|
||||
|
||||
Enhancements/New Features
|
||||
-------------------------
|
||||
|
||||
1. Graphics has undergone significant changes which are documented in the
|
||||
User's Guide and Language Reference Manual. Following is a synopsis of
|
||||
the changes:
|
||||
|
||||
* The %GRAPHICS primitives now accept a seventh argument to specify
|
||||
an exclusive-or when drawing pixels or lines.
|
||||
|
||||
* A new %GRAPHICS function has been included which allows you to set
|
||||
a clipping rectangle which subsequent drawing functions use. All
|
||||
%GRAPHICS drawing routines now use the clipping rectangle.
|
||||
|
||||
* New graphics functions:
|
||||
(GET-PEN-COLOR) - returns the pen's color.
|
||||
(GET-PEN-POSITION) - returns the pen's position.
|
||||
(POINT-COLOR) - returns a point's color value.
|
||||
(SET-CLIPPING-RECTANGLE! x1 y1 x2 y2) - set clipping rectangle.
|
||||
|
||||
* Modes 14 and 16 for the EGA are now supported.
|
||||
|
||||
* CLEAR-GRAPHICS no longer automatically switches into mode 4, but
|
||||
remains in the current video mode. SET-VIDEO-MODE! will automati-
|
||||
cally do a CLEAR-GRAPHICS after changing modes.
|
||||
|
||||
2. EDWIN contains several changes to help in its performance and flexibility.
|
||||
|
||||
* The file EDWIN.INI will be loaded if it exists within the PCS
|
||||
directory. EDWIN.INI may contain code to customize the display,
|
||||
or remap the keyboard. See EDWIN.INI for examples.
|
||||
|
||||
* Edwin now loads into its own environment, EDWIN-ENVIRONMENT. This
|
||||
reduces the number of variables in the USER-GLOBAL-ENVIRONMENT and
|
||||
allows EDWIN to be removed via the new REMOVE-EDWIN command.
|
||||
|
||||
* REMOVE-EDWIN is a procedure of no arguments which may now be called
|
||||
to remove references to EDWIN so that it will disappear upon the
|
||||
next garbage collection. Remember that if EDWIN was loaded from
|
||||
SCHEME-TOP-LEVEL, the history will still contain pointers to EDWIN,
|
||||
prohibiting it from being garbage collected. In that case, you must
|
||||
perform a SCHEME-RESET prior to the garbage collect to remove all
|
||||
references to EDWIN.
|
||||
|
||||
* EDWIN will now query the user upon exiting Scheme, if its buffers
|
||||
have been modified but not written back out to the file.
|
||||
|
||||
* The time required to load files into EDWIN's buffer has been
|
||||
significantly reduced.
|
||||
|
||||
3. PC Scheme now contains an External Language Interface (XLI) to support
|
||||
the calling of subroutines written in other languages. XLI has been
|
||||
tested to work with assembly, C and Pascal. See the chapter "External
|
||||
Language Interface (XLI)" in the User's Guide for more information.
|
||||
|
||||
4. Transcendental functions have been rewritten using XLI and
|
||||
use the 8087/80287 numeric coprocessor when it is available.
|
||||
Accuracy is true double-precision and performance is significantly
|
||||
improved, even without the 8087. The complete source code of this
|
||||
XLI interface is included. Refer to the chapter "External Language
|
||||
Interface (XLI)" in the User's Guide for more information.
|
||||
|
||||
5. A semi-interpretive EVAL has been implemented. EVAL now works
|
||||
interpretively until it encounters a binding form (such as LAMBDA,
|
||||
LET, etc.), at which time the compiler will be invoked.
|
||||
|
||||
6. READ-LINE has been implemented as a primitive operation and will now echo
|
||||
to the screen when called to read from the console.
|
||||
|
||||
7. LIST-TAIL has been implemented as a primitive operation. Both LIST-REF
|
||||
and LIST-TAIL gain significant performance increases.
|
||||
|
||||
8. Random I/O is now supported via SET-FILE-POSITION! and GET-FILE-POSITION.
|
||||
See the description in the Language Reference Manual.
|
||||
|
||||
9. Binary file input and output is now supported via OPEN-BINARY-INPUT-FILE
|
||||
and OPEN-BINARY-OUTPUT-FILE procedures. See the description in the
|
||||
Language Reference Manual.
|
||||
|
||||
10. The non-essential procedure STRING->NUMBER from the R^3 Report is now
|
||||
included. See the description in the Language Reference Manual.
|
||||
|
||||
11. #\ESCAPE has been added as a system defined character.
|
||||
|
||||
12. Enhanced error handling is now available, and DOS I/O errors now trap
|
||||
to the inspector, with extended error information available. Reference
|
||||
the User's Guide under the chapter "DEBUGGING" for information on
|
||||
defining your own error handler via *USER-ERROR-HANDLER*.
|
||||
|
||||
13. New procedures EXPAND-MACRO-1, EXPAND-MACRO, and EXPAND. EXPAND-MACRO-1
|
||||
will expand the outer-level of some form once and return the expanded
|
||||
form, EXPAND-MACRO will repeatedly expand the outer-level form until it
|
||||
is no longer a macro, and EXPAND will expand the entire form (outer and
|
||||
inner level forms), returning an expansion.
|
||||
|
||||
Example: (EXPAND-MACRO '(let ((a 1) (b 2)) (foo a b)))
|
||||
|
||||
*** Note ***
|
||||
When expanding various forms with the above procedures, you may
|
||||
encounter references to primitive operations. These primitive oper-
|
||||
ations typically begin with one or more percent signs (%), are
|
||||
generally not available for direct use by the user, and may change
|
||||
in future versions of PC Scheme.
|
||||
|
||||
14. The random number generator can be reseeded using the RANDOMIZE
|
||||
function. See the description in the Language Reference Manual.
|
||||
|
||||
|
||||
|
||||
Corrections to the Manuals
|
||||
--------------------------
|
||||
|
||||
The following corrections to the User's Guide should be noted.
|
||||
|
||||
1. At the top of page 8-16, the request number to be used for the
|
||||
"swap" special service request was omitted. The bullet that reads:
|
||||
|
||||
* swap
|
||||
|
||||
should be replaced with:
|
||||
|
||||
* swap (request number = 1)
|
||||
|
||||
2. On page C-1 the symbol "remap" is equated with interrupt 7fh.
|
||||
However, the comment just below it refers to interrupt 60h.
|
||||
The correct interrupt number is 7fh. Therefore, the comment that reads:
|
||||
|
||||
; This example uses the interrupt at 60h; refer to ...
|
||||
|
||||
should be replaced with:
|
||||
|
||||
; This example uses the interrupt at 7fh; refer to ...
|
||||
|
||||
|
||||
|
||||
Undocumented/Non-Standard Features
|
||||
----------------------------------
|
||||
|
||||
The following features are undocumented features which may or may not be
|
||||
supported in future releases. They certainly are not standard Scheme
|
||||
features and prohibit portability, but may be useful in some cases.
|
||||
|
||||
|
||||
1. GRAPHICS-WINDOW is a function which may be useful in creating graphics
|
||||
windows. It is currently in an experimental stage, is not fully complete,
|
||||
and is subject to change. Still, it is useful in its current form, and
|
||||
you may try it out at your own risk.
|
||||
|
||||
GRAPHICS-WINDOW is a "marker" function indicating that the next series
|
||||
of MIT graphics functions will execute relative to a specified window
|
||||
instead of the full screen. It takes one argument, a window object
|
||||
(a port), and returns a 2-list of 4-lists. The first list is the
|
||||
clipping rectangle for the window's interior using window-centered
|
||||
coordinates, expressed as (left top right bottom), for use by the MIT
|
||||
functions, and the second list is the same rectangle expressed in
|
||||
screen coordinates for use by %GRAPHICS. It changes the graphics
|
||||
state known by the MIT functions and sets the clipping rectangle to
|
||||
correspond to the window's interior so that further use of the MIT
|
||||
functions will execute relative to the window instead of the full screen.
|
||||
Aside from setting the clipping rectangle, there are no other effects
|
||||
on %GRAPHICS.
|
||||
|
||||
After executing GRAPHICS-WINDOW on a window for the first time, a call
|
||||
to CLEAR-GRAPHICS should be issued to set the pen position and color
|
||||
and erase the graphics plane under the window (which may erase text
|
||||
too if they share the same plane). Further graphics commands are
|
||||
issued normally.
|
||||
|
||||
To move from one graphics window to another, use GRAPHICS-WINDOW with
|
||||
the next window. Note that when you move to another window, the graphics
|
||||
state (window, pen color, and pen position) of the first window is
|
||||
forgotten. You will need to save it off if you want to come back and
|
||||
start up where you left off. The functions CURRENT-GRAPHICS-WINDOW,
|
||||
GET-PEN-COLOR, and GET-PEN-POSITION, executed before the switch, will
|
||||
give you this information.
|
||||
|
||||
While executing relative to a window, CLEAR-GRAPHICS will not affect
|
||||
the entire screen. To reset CLEAR-GRAPHICS to its initial state
|
||||
where it does affect the entire screen, do (GRAPHICS-WINDOW 'SCREEN)
|
||||
followed by (CLEAR-GRAPHICS). Executing SET-VIDEO-MODE! any time will do
|
||||
this automatically. Note that (GRAPHICS-WINDOW 'SCREEN) is not the same
|
||||
as (GRAPHICS-WINDOW 'CONSOLE); although the console generally matches the
|
||||
screen, it doesn't have to--it's a window in its own right.
|
||||
|
||||
2. %LOGAND, %LOGIOR, %LOGXOR are procedures of two arguments and are used
|
||||
to perform the bitwise logical operations and, or, and xor. The
|
||||
arguments must be 15 bit integers.
|
||||
|
||||
3. UNBIND is a procedure which may be used to remove bindings from
|
||||
environments. The call to unbind is as follows:
|
||||
|
||||
(UNBIND 'VAR ENV)
|
||||
|
||||
Where : VAR is the variable you wish to remove
|
||||
ENV is any heap allocated environment, including the
|
||||
user-initial and user-global environments.
|
||||
|
||||
Unbind can be useful in providing user-assisted memory management.
|
||||
If an object which is auto-loadable is unbound via the UNBIND
|
||||
procedure, it may later be auto-loaded again. Therefore, if you
|
||||
define autoload lists, you can maintain some control over what
|
||||
code you desire in memory.
|
||||
|
||||
4. Autoload information created from the function AUTOLOAD-FROM-FILE (see
|
||||
chapter titled "ADVANCED FEATURES" in User's Guide) is stored on a
|
||||
property list under the name PCS-AUTOLOAD-INFO. Scheme defines a number
|
||||
of autoload entries of its own, and any that you add will be consed
|
||||
onto the autoload list. You can see the autoload information by
|
||||
performing (GETPROP 'PCS-AUTOLOAD-INFO).
|
||||
|
||||
The procedure AUTOLOAD-FROM-FILE also takes an optional third argument
|
||||
which indicates the environment that you want the file loaded into. For
|
||||
example
|
||||
|
||||
(autoload-from-file "DEFS.FSL" '(foo bar baz) user-initial-environment)
|
||||
|
||||
will load the file "DEFS.FSL" into the user-initial-environment whenever
|
||||
foo, bar, or baz is referenced. The optional environment argument can
|
||||
be any heap allocated environment. To add or delete entries from the
|
||||
autoload list just write your own functions to modify the list, however
|
||||
if you remove any of the compiler dependent files from the list, a
|
||||
reference to one of its functions will cause errors.
|
||||
|
||||
The undocumented procedure REMOVE-AUTOLOAD-INFO may be used to remove
|
||||
information from the autoload list. REMOVE-AUTOLOAD-INFO takes one
|
||||
argument, the filename of the autoload entry you wish to remove, and
|
||||
then removes the autoload information from the list. This function,
|
||||
along with UNBIND can be used to help the user perform memory manage-
|
||||
ment.
|
||||
|
||||
5. MAKE-HASHED-ENVIRONMENT is a procedure of no arguments which creates
|
||||
an environment in the Scheme heap in the form of a hash table for
|
||||
better accessing. The hash table contains 211 entries; any time a
|
||||
variable is defined in that environment a hash key will be determined
|
||||
via an internal hash function to find the correct entry. This is
|
||||
identical to the user global and user initial environments. A hashed
|
||||
environment's parent is the user-initial-environment.
|
||||
|
||||
A hashed environment will provide better access times than normal
|
||||
environments, given there are a lot of variables in the environment.
|
||||
However, there is certainly a space/time tradeoff to consider. The
|
||||
hashed environment contains much more overhead which will be wasted
|
||||
if you need only a handfull of variables.
|
||||
|
||||
One advantage of the hashed environment, as with all environments,
|
||||
is that if you discard all references to the environment, it will
|
||||
be garbage collected and all the space may be reclaimed. This means
|
||||
that you must keep track of all variables or references which are
|
||||
exported to other environments. Also, if you define a macro within
|
||||
an environment, the macro definition holds a reference to the
|
||||
environment and will prohibit garbage collection of the environment.
|
||||
Macro definitions may be found under the property PCS*MACRO of the
|
||||
macro name declared.
|
||||
|
||||
6. While the 3.0 implementation of transcendental functions is much
|
||||
faster and more accurate and therefore to be preferred, the 2.0
|
||||
version had the advantage of being about half the size. If space is
|
||||
more important than speed or accuracy, you can do the following:
|
||||
|
||||
1. Invoke PC Scheme as usual, except put a minus sign in front
|
||||
of the .XLI control file name; this prevents XLI from
|
||||
loading NEWTRIG.EXE. For example:
|
||||
|
||||
pcs (my.ini -my.xli) arg1 arg2
|
||||
|
||||
2. Inside PC Scheme, do:
|
||||
(eval '(load "oldpmath.fsl") user-global-environment)
|
||||
If your current directory is not the PC Scheme directory,
|
||||
you'll need to append the value of the system variable
|
||||
PCS-SYSDIR to the front of the filename. The LOAD must be
|
||||
inside the EVAL so that autoload references to pmath.fsl
|
||||
will be intercepted correctly.
|
||||
|
||||
It is not absolutely necessary to do step 1 just to use oldpmath.fsl,
|
||||
but the space savings won't be realized without it. Also, step 2
|
||||
should be done soon upon entering PC Scheme, as various system
|
||||
functions, such as some Edwin commands, require the math functions
|
||||
(whether through XLI\pmath.fsl or through oldpmath.fsl) to be loaded.
|
||||
|
||||
PC Scheme 3.02 features
|
||||
-----------------------
|
||||
|
||||
The following bugs have been fixed.
|
||||
|
||||
1. There were several obscure bugs in the extended and expanded memory
|
||||
models of PC Scheme which have been corrected. Also, extended memory
|
||||
performance has been enhanced by about 25%.
|
||||
|
||||
2. PC Scheme 3.02 recognizes an IBM PS/2 Model 80. IBM has assigned
|
||||
a new machine-type number to it, which is reflected in the value
|
||||
of PCS-MACHINE-TYPE. More importantly, FREESP in extended memory
|
||||
PC Scheme now works correctly on the Model 80.
|
||||
|
||||
3. EQUAL? on ports no longer causes a type mismatch error.
|
||||
|
||||
4. There was a bug in determining the pathname of NEWTRIG.EXE when
|
||||
PC Scheme had been installed in the root directory. This usually
|
||||
showed itself when running PC Scheme from floppy disks.
|
||||
|
||||
5. In the form (SET! (ACCESS var env) value), there was a bug in which
|
||||
environment the "value" was placed if the "var" did not already exist.
|
||||
|
||||
6. DOS-CALL no longer depends on the COMSPEC environment variable
|
||||
being listed first in the DOS environment.
|
||||
|
||||
7. Line-lengths for binary files are now automatically set to zero
|
||||
so end-of-line sequences are suppressed.
|
||||
|
||||
8. XLI checks for its version number. PC Scheme 3.02 uses the same
|
||||
version number as 3.0. The error message is "[XLI] Version mismatch".
|
||||
Also, the XLI error message "[XLI] The function requested by XCALL is not
|
||||
available" now is followed by the name of the function that failed.
|
||||
|
||||
10. PC Scheme's definition of EQV? says "=" is used to compare numeric
|
||||
arguments. However, MEMV and ASSV, which are supposed to use EQV?
|
||||
for their equality predicates, were really using EQUAL?. "=" and
|
||||
EQUAL? return different results when two numeric arguments have
|
||||
different types, so the fix may cause a change of behavior in how
|
||||
MEMV and ASSV work.
|
||||
|
||||
11. Internal "getmem" errors no longer cause an abort to DOS.
|
||||
Instead, the system performs a SCHEME-RESET. The error generally
|
||||
appears during output of extremely large data structures when
|
||||
I/O buffer space is exhausted, but the data structures themselves
|
||||
remain intact, so this should be adequate recovery in most cases.
|
||||
|
||||
12. A bug in SCOOPS was making the environments in which instance
|
||||
variables got created be dependent on the order in which the
|
||||
classes were compiled.
|
||||
|
||||
The following features are "new" to PC Scheme 3.02.
|
||||
|
||||
1. XLI can now receive error messages from external programs and drop into
|
||||
the Inspector displaying the error message.
|
||||
|
||||
The external program reports an error as follows. It formats the
|
||||
parameter block with a string as return value, where the string is
|
||||
the error message. However, instead of using a return-value type of
|
||||
2 (string), it should use a value of 10 (error-string). XLI will
|
||||
drop into the Inspector with the error message "[XLI] Error reported
|
||||
by external program" followed on the next line by the external
|
||||
program's error message (note the Inspector uses WRITE to display
|
||||
the message). The error is not restartable.
|
||||
|
||||
If an external program using this error technique is run under
|
||||
PC Scheme 3.0, XLI reports the different error "[XLI] The return value
|
||||
of XCALL is invalid" and the external program's error message never
|
||||
appears.
|
||||
|
||||
NEWTRIG.EXE has been reimplemented with this technique. Refer to
|
||||
the file XLI\TRIG_LC.C to examine the source code.
|
||||
|
||||
2. There are a couple more XLI source examples in the XLI directory.
|
||||
One is in assembly language, the other in C. One provides PC Scheme
|
||||
with sound capability, and the other demonstrates a way to run
|
||||
DOS-executable files without using DOS-CALL.
|
||||
|
||||
3. %GRAPHICS for EGA has been reimplemented to do direct screen writes.
|
||||
This gives a significant performance boost at the expense of generality,
|
||||
which may affect some EGA clones. Also, VGA modes 17 and 18 are now
|
||||
supported.
|
||||
|
||||
PC Scheme 3.03 features
|
||||
-----------------------
|
||||
|
||||
The following bugs have been fixed.
|
||||
|
||||
1. Random I/O has been fixed. If a file is opened with OPEN-EXTEND-FILE,
|
||||
one can perform both input from and output to that file.
|
||||
|
||||
2. An obscure garbage collection bug was fixed which envolved one defining
|
||||
their own top-level. If a user top-level has been defined instead of
|
||||
the Scheme-Top-level, and an out of memory encountered an error message
|
||||
occurred on the next garbage collect.
|
||||
|
||||
3. A garbage collection bug in extended memory was fixed. Compaction of
|
||||
list cells could sometimes cause problems.
|
||||
|
||||
4. A problem with DOS memory fragmentation was fixed. Upon returning from
|
||||
PC Scheme, all of memory was not being returned to DOS. This could some-
|
||||
times cause other programs to fail with "not enough memory" errors.
|
||||
|
||||
The following new features have been added:
|
||||
|
||||
1. Support has been added for VGA mode 18.
|
||||
|
||||
|
||||
2. One can now specify when garbage compaction should occur.
|
||||
|
||||
(GC-GET-COMPACT-COUNT! number) - specifies that a compaction should
|
||||
occur after every "number" of gc's.
|
||||
|
||||
(GC-GET-COMPACT-COUNT) - returns the current "number".
|
||||
|
||||
|
|
@ -0,0 +1,662 @@
|
|||
/* TIPC Scheme '84 Runtime Support - Arithmetic Support
|
||||
(C) Copyright 1984,1985 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: 9 May 1984
|
||||
Last Modification:
|
||||
11 February 1986 - Change error message text "MOD" to
|
||||
"REMAINDER"
|
||||
*/
|
||||
#include "scheme.h"
|
||||
|
||||
#include "slist.h"
|
||||
|
||||
int CXFERR_status = 0; /* floating point error status code */
|
||||
|
||||
static int *resreg = NULL; /* Result regsiter */
|
||||
|
||||
/****************************************************************/
|
||||
/* Support of unary arithmetic operations on values other */
|
||||
/* than fixnums. */
|
||||
/****************************************************************/
|
||||
arith1(op, reg)
|
||||
int op;
|
||||
int reg[2];
|
||||
{
|
||||
int disp,page;
|
||||
int siz1;
|
||||
char *big1;
|
||||
double flo;
|
||||
|
||||
double get_flo();
|
||||
char *getmem();
|
||||
|
||||
/* fetch operand page number and displacement */
|
||||
setabort();
|
||||
resreg = reg;
|
||||
disp = reg[0];
|
||||
page = CORRPAGE(reg[1]);
|
||||
switch (ptype[page]) /* dispatch on pointer type */
|
||||
{
|
||||
case (FLOTYPE*2): flo = get_flo(page, disp);
|
||||
switch (op)
|
||||
{
|
||||
case MINUS_OP: if (flo == 0.0) goto get_out;
|
||||
else flo = - flo;
|
||||
break;
|
||||
case ZERO_OP: return(flo == 0.0);
|
||||
case NEG_OP: return(flo < 0.0);
|
||||
case POS_OP: return(flo > 0.0);
|
||||
case ABS_OP: if (flo >= 0.0) goto get_out;
|
||||
else flo = -flo;
|
||||
break;
|
||||
} /* end: switch (op) */
|
||||
alloc_flonum(reg, flo);
|
||||
break;
|
||||
|
||||
case (BIGTYPE*2): siz1 = get_word(page,disp+1)+2;
|
||||
if (!(big1 = getmem(siz1)))
|
||||
abort(HEAPERR);
|
||||
copybig(page,disp,big1);
|
||||
switch(op)
|
||||
{
|
||||
case MINUS_OP: big1[2] ^= 1; break;
|
||||
case ZERO_OP: page = FALSE;
|
||||
goto ret_page;
|
||||
case POS_OP: page = !(big1[2] & 1);
|
||||
goto ret_page;
|
||||
case NEG_OP: page = big1[2] & 1;
|
||||
ret_page:
|
||||
rlsmem(big1,siz1);
|
||||
return(page);
|
||||
case ABS_OP: big1[2] &= '\376'; break;
|
||||
}
|
||||
alloc_int(reg,big1);
|
||||
rlsmem(big1,siz1);
|
||||
break;
|
||||
|
||||
default: /* Invalid operand to arithmetic function */
|
||||
not_numb(op, reg);
|
||||
return(-1);
|
||||
} /* end: switch (ptype[page]) */
|
||||
get_out:
|
||||
return(0);
|
||||
} /* end of function: arith1(op, reg) */
|
||||
|
||||
|
||||
/****************************************************************/
|
||||
/* Support of binary arithmetic operations on values other */
|
||||
/* than fixnums (+, -, *, /, mod) */
|
||||
/****************************************************************/
|
||||
arith2(op, reg1, reg2)
|
||||
int op;
|
||||
int reg1[2], reg2[2];
|
||||
{
|
||||
int disp1,disp2; /* displacements of input operands */
|
||||
int page1,page2; /* page numbers of input operands */
|
||||
int type1,type2; /* input operand types */
|
||||
int fix1, fix2; /* values of fixnum operands */
|
||||
int mag; /* magnitude test result for bignums */
|
||||
int new_type; /* type used with mixed mode operands */
|
||||
char *getmem(); /* memory-grabbing function */
|
||||
char *big1,*big2,*big3; /* bignum buffers */
|
||||
int siz1,siz2,siz3; /* sizes of bignum buffers */
|
||||
double flo1, flo2; /* values of flonum operands */
|
||||
|
||||
double get_flo();
|
||||
|
||||
setabort(); big1 = big2 = 0;
|
||||
overs: /* "re-entry" point in case bignum divide produces factional result */
|
||||
resreg = reg1;
|
||||
/* localize operand information */
|
||||
disp1 = reg1[0]; disp2 = reg2[0];
|
||||
page1 = CORRPAGE(reg1[1]); page2 = CORRPAGE(reg2[1]);
|
||||
type1 = ptype[page1]; type2 = ptype[page2];
|
||||
|
||||
/* validate and fetch 1st operand */
|
||||
switch (type1)
|
||||
{
|
||||
case (FIXTYPE*2): fix1 = get_fix(page1, disp1); break;
|
||||
case (FLOTYPE*2): flo1 = get_flo(page1, disp1); break;
|
||||
case (BIGTYPE*2): siz1 = get_word(page1, disp1+1) + 4;
|
||||
if (!(big1 = getmem(siz1)))
|
||||
abort(HEAPERR);
|
||||
copybig(page1,disp1,big1);
|
||||
break;
|
||||
default: goto non_numeric;
|
||||
} /* end: switch (type1) */
|
||||
|
||||
/* validate and fetch 2nd operand */
|
||||
switch (type2)
|
||||
{
|
||||
case (FIXTYPE*2): fix2 = get_fix(page2, disp2); break;
|
||||
case (FLOTYPE*2): flo2 = get_flo(page2, disp2); break;
|
||||
case (BIGTYPE*2): siz2 = get_word(page2, disp2+1) + 2;
|
||||
if (!(big2 = getmem(siz2)))
|
||||
{
|
||||
if (big1)
|
||||
rlsmem(big1,siz1);
|
||||
abort(HEAPERR);
|
||||
}
|
||||
copybig(page2,disp2,big2);
|
||||
break;
|
||||
default: goto non_numeric;
|
||||
} /* end: switch (type1) */
|
||||
|
||||
/* if types don't match, convert one of the operands */
|
||||
new_type = type1;
|
||||
if (type1 != type2)
|
||||
{
|
||||
switch (type1)
|
||||
{
|
||||
case (FIXTYPE*2): switch (type2)
|
||||
{
|
||||
case (FLOTYPE*2): new_type = FLOTYPE*2;
|
||||
flo1 = fix1;
|
||||
break;
|
||||
case (BIGTYPE*2): new_type = BIGTYPE*2;
|
||||
siz1 = 7;
|
||||
if (!(big1 = getmem(7)))
|
||||
{
|
||||
rlsmem(big2,siz2);
|
||||
abort(HEAPERR);
|
||||
}
|
||||
fix2big(fix1,big1);
|
||||
/* convert fixnum to bignum */
|
||||
break;
|
||||
} /* end: switch (type2) */
|
||||
break;
|
||||
|
||||
case (FLOTYPE*2): switch(type2)
|
||||
{
|
||||
case (FIXTYPE*2): flo2 = fix2;
|
||||
break;
|
||||
case (BIGTYPE*2): if (big2flo(big2,&flo2))
|
||||
{
|
||||
rlsmem(big2,siz2);
|
||||
BIGnum:
|
||||
/* No return from dos_err */
|
||||
dos_err(1,FLONUM_OVERFLOW_ERROR,reg2);
|
||||
/* reg1[0] = OVR_DISP; */
|
||||
/* reg1[1] = ADJPAGE(OVR_PAGE); */
|
||||
/* abort(OVERERR); */
|
||||
}
|
||||
rlsmem(big2,siz2);
|
||||
break;
|
||||
} /* end: switch(type2) */
|
||||
break;
|
||||
|
||||
case (BIGTYPE*2): switch(type2)
|
||||
{
|
||||
case (FIXTYPE*2): siz2 = 7;
|
||||
if (!(big2 = getmem(7)))
|
||||
{
|
||||
rlsmem(big1,siz1);
|
||||
abort(HEAPERR);
|
||||
}
|
||||
fix2big(fix2,big2);
|
||||
break;
|
||||
case (FLOTYPE*2): new_type = FLOTYPE*2;
|
||||
if (big2flo(big1,&flo1))
|
||||
{
|
||||
rlsmem(big1,siz1);
|
||||
/* No return from dos_err */
|
||||
dos_err(1,FLONUM_OVERFLOW_ERROR,reg1);
|
||||
/* goto BIGnum; */
|
||||
}
|
||||
rlsmem(big1,siz1);
|
||||
break;
|
||||
} /* end: switch(type2) */
|
||||
break;
|
||||
} /* end: switch (type1) */
|
||||
} /* end: if (type1 != type2) */
|
||||
|
||||
/* Preform the operation */
|
||||
switch (new_type)
|
||||
{
|
||||
case (FLOTYPE*2): CXFERR_status = 0;
|
||||
switch (op)
|
||||
{
|
||||
case ADD_OP: flo1 += flo2; break;
|
||||
case SUB_OP: flo1 -= flo2; break;
|
||||
case MUL_OP: flo1 *= flo2; break;
|
||||
case DIV_OP: flo1 /= flo2; break;
|
||||
case QUOT_OP:
|
||||
set_src_err("QUOTIENT", 2, reg1, reg2);
|
||||
goto error_return;
|
||||
case MOD_OP:
|
||||
set_src_err("REMAINDER", 2, reg1, reg2);
|
||||
goto error_return;
|
||||
case AND_OP:
|
||||
bad_and:
|
||||
set_src_err("LOGAND",2,reg1,reg2);
|
||||
goto error_return;
|
||||
case OR_OP:
|
||||
bad_or:
|
||||
set_src_err("LOGIOR",2,reg1,reg2);
|
||||
goto error_return;
|
||||
case XOR_OP:
|
||||
bad_xor:
|
||||
set_src_err("LOGXOR",2,reg1,reg2);
|
||||
goto error_return;
|
||||
case EQ_OP: return(flo1 == flo2);
|
||||
case NE_OP: return(flo1 != flo2);
|
||||
case LT_OP: return(flo1 < flo2);
|
||||
case GT_OP: return(flo1 > flo2);
|
||||
case LE_OP: return(flo1 <= flo2);
|
||||
case GE_OP: return(flo1 >= flo2);
|
||||
} /* end: switch (op) */
|
||||
if (CXFERR_status)
|
||||
{
|
||||
float_overflow(op, reg1, reg2);
|
||||
goto error_return;
|
||||
}
|
||||
else
|
||||
{
|
||||
if (reg1[C_PAGE] != SPECSYM*2)
|
||||
alloc_flonum(reg1, flo1);
|
||||
}
|
||||
break;
|
||||
|
||||
case (BIGTYPE*2): mag = magcomp(big1,big2) & 0x00ff;
|
||||
switch (op)
|
||||
{
|
||||
case SUB_OP: big2[2] ^= 1; /* Negate & fall thru */
|
||||
mag ^= 16;
|
||||
case ADD_OP: if (mag & 16) /* Same signs */
|
||||
if (mag & 2) /* |BIG1| greater? */
|
||||
{
|
||||
bigadd(big2,big1);
|
||||
goto alloc1;
|
||||
}
|
||||
else
|
||||
{
|
||||
bigadd(big1,big2);
|
||||
goto alloc2;
|
||||
}
|
||||
else
|
||||
{
|
||||
if (mag & 2) /* |BIG1| greater? */
|
||||
{
|
||||
bigsub(big2,big1);
|
||||
alloc1: alloc_int(reg1,big1);
|
||||
}
|
||||
else
|
||||
{
|
||||
bigsub(big1,big2);
|
||||
alloc2: alloc_int(reg1,big2);
|
||||
}
|
||||
}
|
||||
break;
|
||||
case MUL_OP: /* if reg1 is zero, we're done */
|
||||
if (type1 == FIXTYPE*2 && !fix1) break;
|
||||
/* if reg2 is zero, set result to zero */
|
||||
if (type2 == FIXTYPE*2 && !fix2)
|
||||
{
|
||||
alloc_fixnum(reg1,0);
|
||||
break;
|
||||
}
|
||||
/* must perform multiply */
|
||||
siz3 = (siz1 + siz2) - 3;
|
||||
if (!(big3=getmem(siz3)))
|
||||
{
|
||||
rls12: rlsmem(big1,siz1);
|
||||
rlsmem(big2,siz2);
|
||||
abort(HEAPERR);
|
||||
}
|
||||
bigmul(big1,big2,big3);
|
||||
alloc3: alloc_int(reg1,big3);
|
||||
rls3: rlsmem(big3,siz3);
|
||||
break;
|
||||
case DIV_OP: if (mag & 1) goto float_it;
|
||||
siz3 = siz1 - siz2 + 5;
|
||||
if (!(big3 = getmem(siz3)))
|
||||
goto rls12;
|
||||
thefix(big1);
|
||||
if (bigdiv(big1,big2,big3))
|
||||
{
|
||||
rls123: rlsmem(big1,siz1);
|
||||
rlsmem(big2,siz2);
|
||||
rlsmem(big3,siz3);
|
||||
CXFERR_status = -2;
|
||||
float_over(op, reg1, reg2);
|
||||
goto error_return;
|
||||
}
|
||||
/* test for fractional result */
|
||||
if (big1[3] || big1[4] ||
|
||||
big1[1] || big1[0] != 1)
|
||||
{
|
||||
rlsmem(big3,siz3);
|
||||
float_it:
|
||||
rlsmem(big1,siz1);
|
||||
rlsmem(big2,siz2);
|
||||
sfloat(reg1); /* make reg1 flonum */
|
||||
goto overs; /* re-try as flonum */
|
||||
}
|
||||
goto alloc3;
|
||||
case MOD_OP: if (!(mag & 1))
|
||||
{
|
||||
siz3 = siz1 - siz2 + 5;
|
||||
if (!(big3 = getmem(siz3)))
|
||||
goto rls12;
|
||||
thefix(big1);
|
||||
if (bigdiv(big1,big2,big3))
|
||||
goto rls123;
|
||||
alloc_int(reg1,big1);
|
||||
goto rls3;
|
||||
}
|
||||
break;
|
||||
case QUOT_OP: if (mag & 1)
|
||||
alloc_fixnum(reg1,0);
|
||||
else
|
||||
{
|
||||
siz3 = siz1 - siz2 + 5;
|
||||
if (!(big3 = getmem(siz3)))
|
||||
goto rls12;
|
||||
thefix(big1);
|
||||
if (bigdiv(big1,big2,big3))
|
||||
goto rls123;
|
||||
goto alloc3;
|
||||
}
|
||||
break;
|
||||
case AND_OP: goto bad_and;
|
||||
case OR_OP: goto bad_or;
|
||||
case XOR_OP: goto bad_xor;
|
||||
case EQ_OP:
|
||||
case NE_OP:
|
||||
case LT_OP:
|
||||
case GT_OP:
|
||||
case LE_OP:
|
||||
case GE_OP:
|
||||
rlsmem(big1,siz1);
|
||||
rlsmem(big2,siz2);
|
||||
switch (op)
|
||||
{
|
||||
case EQ_OP: return(!(mag & 0x000f));
|
||||
case NE_OP: return(mag & 0x000f);
|
||||
case LT_OP: return(mag & 4);
|
||||
case GT_OP: return(mag & 8);
|
||||
case LE_OP: return(!(mag & 8));
|
||||
case GE_OP: return(!(mag & 4));
|
||||
}
|
||||
} /* end: switch (op) */
|
||||
rlsmem(big1,siz1);
|
||||
rlsmem(big2,siz2);
|
||||
break;
|
||||
} /* end: switch (new_type) */
|
||||
goto end_arith2;
|
||||
non_numeric:
|
||||
not_numb(op, reg1, reg2);
|
||||
error_return:
|
||||
return(-1);
|
||||
end_arith2:
|
||||
return(0);
|
||||
} /* end of function: arith2(op, reg1, reg2) */
|
||||
|
||||
|
||||
/****************************************************************/
|
||||
/* float to integer conversion-- truncate (adjust toward zero) */
|
||||
/****************************************************************/
|
||||
truncate(reg)
|
||||
int reg[2]; /* register holding value/result */
|
||||
{
|
||||
int disp,page; /* pointer displacement, page number */
|
||||
/*%% long fix; /* temp to hold result */*/
|
||||
|
||||
disp = reg[C_DISP];
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
|
||||
switch (ptype[page])
|
||||
{
|
||||
case FLOTYPE*2: fixflo(reg,get_flo(page, disp)); /* fetch and
|
||||
re-allocate as an integer */
|
||||
/* falls through to "break" */
|
||||
case BIGTYPE*2: /* bignums and fixnums mutually exclusive */
|
||||
case FIXTYPE*2: /* already a fixnum, so no action required */
|
||||
break;
|
||||
default: not_numb(TRUNC_OP, reg); /* invalid type */
|
||||
return(-1);
|
||||
} /* end: switch (type) */
|
||||
return(0);
|
||||
} /* end of function: truncate(reg) */
|
||||
|
||||
/****************************************************************/
|
||||
/* float to integer-- floor (adjust toward -infinity) */
|
||||
/****************************************************************/
|
||||
floor(reg)
|
||||
int reg[2]; /* register holding value/result */
|
||||
{
|
||||
int disp,page; /* pointer displacement, page number */
|
||||
/*%% long fix; /* temp to hold converted result */*/
|
||||
double flo; /* temp to hold value to be converted */
|
||||
|
||||
disp = reg[C_DISP];
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
|
||||
switch (ptype[page])
|
||||
{
|
||||
case FLOTYPE*2: flo = get_flo(page, disp);
|
||||
if (flo < 0.0) flo -= 0.9999999999;
|
||||
fixflo(reg, flo); /* re-allocate as an integer */
|
||||
/* falls through to "break" */
|
||||
case BIGTYPE*2: /* bignums and fixnums mutually exclusive */
|
||||
case FIXTYPE*2: /* already a fixnum, so no action required */
|
||||
break;
|
||||
default: not_numb(FLOOR_OP, reg); /* invalid type */
|
||||
return(-1);
|
||||
} /* end: switch (type) */
|
||||
return(0);
|
||||
} /* end of function: floor(reg) */
|
||||
|
||||
/****************************************************************/
|
||||
/* float to integer-- ceiling (adjust toward +infinity) */
|
||||
/****************************************************************/
|
||||
ceiling(reg)
|
||||
int reg[2]; /* register holding value/result */
|
||||
{
|
||||
int disp,page; /* pointer displacement, page number */
|
||||
/*%% long fix; /* temp to hold converted result */*/
|
||||
double flo; /* temp to hold value to be converted */
|
||||
|
||||
disp = reg[C_DISP];
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
|
||||
switch (ptype[page])
|
||||
{
|
||||
case FLOTYPE*2: flo = get_flo(page, disp);
|
||||
if (flo > 0.0) flo += 0.9999999999;
|
||||
fixflo(reg,flo); /* re-allocate as an integer */
|
||||
/* falls through to "break" */
|
||||
case BIGTYPE*2: /* bignums and fixnums mutually exclusive */
|
||||
case FIXTYPE*2: /* already a fixnum, so no action required */
|
||||
break;
|
||||
|
||||
default: not_numb(CEIL_OP, reg); /* invalid type */
|
||||
return(-1);
|
||||
} /* end: switch (type) */
|
||||
return(0);
|
||||
} /* end of function: ceiling(reg) */
|
||||
|
||||
/****************************************************************/
|
||||
/* float to integer-- round (adjust toward nearest integer) */
|
||||
/****************************************************************/
|
||||
round(reg)
|
||||
int reg[2]; /* register holding value/result */
|
||||
{
|
||||
int disp,page; /* pointer displacement, page number */
|
||||
/*%% long fix; /* temp to hold converted result */*/
|
||||
double flo; /* floating point value */
|
||||
|
||||
disp = reg[C_DISP];
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
|
||||
switch (ptype[page])
|
||||
{
|
||||
case FLOTYPE*2: flo = get_flo(page, disp);
|
||||
flo += (flo<0 ? -0.5 : 0.5);
|
||||
fixflo(reg,flo); /* re-allocate as an integer */
|
||||
/* falls through to "break" */
|
||||
case BIGTYPE*2: /* bignums and fixnums mutually exclusive */
|
||||
case FIXTYPE*2: /* already a fixnum, so no action required */
|
||||
break;
|
||||
default: not_numb(ROUND_OP, reg); /* invalid type */
|
||||
return(-1);
|
||||
} /* end: switch (type) */
|
||||
return(0);
|
||||
} /* end of function: round(reg) */
|
||||
|
||||
/****************************************************************/
|
||||
/* Convert flonum to integer, which is stored in a register */
|
||||
/****************************************************************/
|
||||
fixflo(reg,flo)
|
||||
int reg[2];
|
||||
double flo;
|
||||
{
|
||||
int siz;
|
||||
char *getmem();
|
||||
char *bigbuf;
|
||||
setabort();
|
||||
if (flo==0.0) goto alloc_zero;
|
||||
else
|
||||
{
|
||||
if (siz=flosiz(flo))
|
||||
{
|
||||
if (!(bigbuf=getmem(siz))) abort(HEAPERR);
|
||||
flotobig(flo,bigbuf);
|
||||
alloc_int(reg,bigbuf);
|
||||
rlsmem(bigbuf,siz);
|
||||
}
|
||||
else
|
||||
{
|
||||
alloc_zero:
|
||||
alloc_fixnum(reg,0);
|
||||
}
|
||||
}
|
||||
} /* end of function: fixflo(reg,flo) */
|
||||
|
||||
/****************************************************************/
|
||||
/* Convert value to floating point */
|
||||
/****************************************************************/
|
||||
sfloat(reg)
|
||||
int reg[2]; /* register containing value/result */
|
||||
{
|
||||
int disp,page,type; /* pointer displacement, page number, type */
|
||||
int siz1; /* size of working bignum */
|
||||
char *big1; /* working bignum */
|
||||
double flo; /* temp for floating point result */
|
||||
char *getmem(); /* memory-grabbing function */
|
||||
|
||||
setabort();
|
||||
disp = reg[0];
|
||||
page = CORRPAGE(reg[1]);
|
||||
type = ptype[page];
|
||||
|
||||
switch (type)
|
||||
{
|
||||
case FIXTYPE*2: flo = get_fix(page, disp); /* fetch and convert value */
|
||||
alloc_flo(reg, flo); /* re-allocate as flonum */
|
||||
break;
|
||||
case BIGTYPE*2: siz1 = get_word(page,disp+1)+2;
|
||||
if (!(big1 = getmem(siz1)))
|
||||
abort(HEAPERR);
|
||||
copybig(page,disp,big1);
|
||||
if (big2flo(big1, &flo))
|
||||
{
|
||||
rlsmem(big1,siz1);
|
||||
/* Control does not return from dos_err */
|
||||
dos_err(1,FLONUM_OVERFLOW_ERROR, reg);
|
||||
/* reg[0] = OVR_DISP; */
|
||||
/* reg[1] = ADJPAGE(OVR_PAGE); */
|
||||
/* abort(OVERERR); */
|
||||
}
|
||||
rlsmem(big1, siz1);
|
||||
alloc_flo(reg,flo);
|
||||
break;
|
||||
case FLOTYPE*2: /* already a flonum, so no action required */
|
||||
break;
|
||||
default: not_numb(FLOAT_OP, reg);
|
||||
return(-1);
|
||||
} /* end: switch (type) */
|
||||
return(0);
|
||||
} /* end of function: sfloat(reg) */
|
||||
|
||||
|
||||
/* What to do when a fixnum result is too large to be fixnum */
|
||||
enlarge(reg,i)
|
||||
int reg[2];
|
||||
long i;
|
||||
{
|
||||
alloc_block(reg, BIGTYPE, ((abs(i)>65535) ? 5 : 3));
|
||||
putlong(reg,i);
|
||||
}
|
||||
|
||||
|
||||
/* Arithmetic support error routines */
|
||||
/* Arithmetic Operations */
|
||||
static char *operation[24]={"+","-", "*", "/", "REMAINDER",
|
||||
"LOGAND","LOGIOR","MINUS","=?", "<>?",
|
||||
"<?", ">?", "<=?", ">=?", "ABS",
|
||||
"QUOTIENT","TRUNCATE","FLOOR","CEILING","ROUND",
|
||||
"FLOAT","ZERO?","POSITIVE?","NEGATIVE?"};
|
||||
/* Note: TRUE -> binary operation; FALSE -> unary operation */
|
||||
static char binary[24]={TRUE, TRUE, TRUE, TRUE, TRUE,
|
||||
TRUE, TRUE, FALSE, TRUE, TRUE,
|
||||
TRUE, TRUE, TRUE, TRUE, FALSE,
|
||||
TRUE, FALSE, FALSE, FALSE, FALSE,
|
||||
FALSE, FALSE, FALSE, FALSE};
|
||||
not_numb(op, reg1, reg2)
|
||||
int op, reg1[2], reg2[2];
|
||||
{
|
||||
mov_reg(tmp_reg, nil_reg);
|
||||
if (binary[op]) cons(tmp_reg, reg2, tmp_reg);
|
||||
cons(reg1, reg1, tmp_reg);
|
||||
intern(tmp_reg, operation[op], strlen(operation[op]));
|
||||
cons(reg1, tmp_reg, reg1);
|
||||
set_numeric_error(1, NUMERIC_OPERAND_ERROR, reg1);
|
||||
reg1[C_DISP] = NTN_DISP;
|
||||
reg1[C_PAGE] = NTN_PAGE*2;
|
||||
}
|
||||
|
||||
float_overflow(op, reg1, reg2)
|
||||
int op, reg1[2], reg2[2];
|
||||
{
|
||||
cons(tmp_reg, reg2, nil_reg);
|
||||
cons(reg1, reg1, tmp_reg);
|
||||
intern(tmp_reg, operation[op], strlen(operation[op]));
|
||||
cons(reg1, tmp_reg, reg1);
|
||||
set_numeric_error(1,
|
||||
(CXFERR_status == -1 ? FLONUM_OVERFLOW_ERROR : ZERO_DIVIDE_ERROR), reg1);
|
||||
reg1[C_DISP] = NTN_DISP;
|
||||
reg1[C_PAGE] = NTN_PAGE*2;
|
||||
}
|
||||
|
||||
/* What to do in the event of a floating-point exception */
|
||||
CXFERR(code)
|
||||
int code;
|
||||
{
|
||||
switch (code)
|
||||
{
|
||||
case 2: /* Overflow */
|
||||
set_numeric_error(1, FLONUM_OVERFLOW_ERROR, nil_reg);
|
||||
CXFERR_status = -1;
|
||||
break;
|
||||
case 3: /* Divide by zero */
|
||||
set_numeric_error(1, ZERO_DIVIDE_ERROR, nil_reg);
|
||||
CXFERR_status = -2;
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
/* Put the next number in the present pseudo-random sequence into REG */
|
||||
/* For details on the generator KRANDOM, see the file STIMER.ASM */
|
||||
srandom(reg)
|
||||
int reg[2];
|
||||
{
|
||||
alloc_fixnum(reg,krandom());
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,141 @@
|
|||
/* =====> SBIGMEM.C */
|
||||
/* TIPC Scheme '84 Runtime Support - Memory Allocation Routines
|
||||
(C) Copyright 1984, 1985 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: 3 December 1984
|
||||
Last Modification:
|
||||
4 June 1986 (TC) - Turn off assertion processing for better
|
||||
performance.
|
||||
*/
|
||||
#include "scheme.h"
|
||||
|
||||
/* Turn off assertions in SBIGMEM.C for performance reasons */
|
||||
#define ASSERT(arg) /* do nothing */
|
||||
#define ENTER(xyz) /* do nothing */
|
||||
|
||||
extern unsigned first_page; /* paragraph address of first physical page */
|
||||
|
||||
/************************************************************************/
|
||||
/* Allocate a Large BLock in Scheme's Memory */
|
||||
/************************************************************************/
|
||||
alloc_big_block(reg, type, size)
|
||||
int reg[2]; /* register to receive pointer to allocated block */
|
||||
int type; /* type code of block to be allocated */
|
||||
unsigned size; /* size of block in bytes (including block header) */
|
||||
{
|
||||
int number_of_pages; /* number of pages required to satisy request */
|
||||
int page; /* page number where large block can be allocated */
|
||||
|
||||
#ifdef PROMEM
|
||||
if (PAGESIZE == MAX_PAGESIZE)
|
||||
number_of_pages = 1;
|
||||
else
|
||||
#endif
|
||||
number_of_pages = ((size + (PAGESIZE - 1)) / PAGESIZE);
|
||||
if ((page = find_big_block(number_of_pages)) == -1)
|
||||
{
|
||||
garbage(); /* Invoke Garbage Collector to reclaim memory */
|
||||
if ((page = find_big_block(number_of_pages)) == -1)
|
||||
{
|
||||
gcsquish(); /* Try compacting memory */
|
||||
if ((page = find_big_block(number_of_pages)) == -1)
|
||||
{
|
||||
out_of_memory(); /* attempt to execute SCHEME-RESET */
|
||||
/* Note: The above procedure returns control elsewhere */
|
||||
}
|
||||
}
|
||||
}
|
||||
zero_page(page);
|
||||
put_ptr(page, 0, type, size);
|
||||
nextcell[page] = END_LIST;
|
||||
if (size <= psize[page] - BLK_OVHD)
|
||||
{
|
||||
put_ptr(page, size, FREETYPE, psize[page] - size);
|
||||
nextcell[page] = size;
|
||||
}
|
||||
ptype[page] = type + type;
|
||||
w_attrib[page] = pageattr[type];
|
||||
pagelink[page] = pagelist[type];
|
||||
pagelist[type] = page;
|
||||
|
||||
reg[C_PAGE] = ADJPAGE(page);
|
||||
reg[C_DISP] = 0;
|
||||
} /* end of function: alloc_big_block(reg, type, size) */
|
||||
|
||||
|
||||
find_big_block(number_of_pages)
|
||||
int number_of_pages; /* number of contiguous pages required */
|
||||
{
|
||||
int free_pages[NUMPAGES+1]; /* free page table */
|
||||
int i,j; /* our old favorite index variables */
|
||||
int page; /* working page number */
|
||||
int page_found = -1; /* page number of first page in big block */
|
||||
|
||||
ENTER(find_big_block);
|
||||
|
||||
/* Initialize free_pages table */
|
||||
for (i = 0; i <= NUMPAGES; i++)
|
||||
free_pages[i] = -1;
|
||||
|
||||
/* Record the number of all free pages */
|
||||
page = freepage;
|
||||
while (page != END_LIST)
|
||||
{
|
||||
ASSERT(page >= 0 && page < NUMPAGES /* subchk? */);
|
||||
ASSERT(free_pages[page] == -1 /* infinite loop? */);
|
||||
free_pages[page] = page;
|
||||
page = pagelink[page];
|
||||
}
|
||||
|
||||
/* Search for a contiguous group of pages to satisfy request */
|
||||
for (i = 0; i < NUMPAGES - DEDPAGES - number_of_pages; i++)
|
||||
{
|
||||
if (free_pages[i] != -1)
|
||||
{
|
||||
j = 1;
|
||||
while (free_pages[i+j] != -1)
|
||||
{
|
||||
j++;
|
||||
if (j >= number_of_pages)
|
||||
{
|
||||
/* required number of pages found-- adjust page table */
|
||||
page_found = free_pages[i];
|
||||
#ifdef PROMEM
|
||||
if (PAGESIZE != MAX_PAGESIZE) /* pro version test */
|
||||
#endif
|
||||
psize[page_found] = PAGESIZE * number_of_pages;
|
||||
free_pages[i] = -1;
|
||||
|
||||
for (j = 1; j < number_of_pages; j++)
|
||||
{
|
||||
page = free_pages[i+j];
|
||||
psize[page] = 0;
|
||||
attrib[page].nomemory = 1;
|
||||
free_pages[i+j] = -1;
|
||||
}
|
||||
|
||||
/* update list of free pages */
|
||||
freepage = END_LIST;
|
||||
for (i = NUMPAGES; i > DEDPAGES; i--)
|
||||
{
|
||||
if (free_pages[i] != -1)
|
||||
{
|
||||
pagelink[(j = free_pages[i])] = freepage;
|
||||
freepage = j;
|
||||
}
|
||||
}
|
||||
return(page_found);
|
||||
}
|
||||
}
|
||||
i += j;
|
||||
}
|
||||
}
|
||||
return(-1); /* no pages found */
|
||||
} /* end of function: find_big_block(number_of_pages) */
|
||||
|
||||
|
|
@ -0,0 +1,141 @@
|
|||
/* =====> SBIGMXP.C */
|
||||
/* TIPC Scheme '84 Runtime Support - Memory Allocation Routines
|
||||
(C) Copyright 1984, 1985 by Texas Instruments Incorporated.
|
||||
All rights reserved.
|
||||
|
||||
Author: Terry Caudill
|
||||
Installation: Texas Instruments Incorporated, Austin, Texas
|
||||
Division: Data Systems Group
|
||||
Project: PC Scheme
|
||||
Comments: This code was lifted from SBIGMEM.C, which was used to
|
||||
allocate objects greater than on page in size. It was
|
||||
modified to understand expanded memory and is tied closely
|
||||
to EXPSMMU.ASM
|
||||
Date Written: 4 June 86
|
||||
|
||||
*/
|
||||
#include "scheme.h"
|
||||
|
||||
/* Turn off assertions in SBIGMXP.C for performance reasons */
|
||||
#define ASSERT(arg) /* do nothing */
|
||||
#define ENTER(xyz) /* do nothing */
|
||||
|
||||
extern unsigned first_page; /* paragraph address of first physical page */
|
||||
|
||||
/************************************************************************/
|
||||
/* Allocate a Large BLock in Scheme's Memory */
|
||||
/************************************************************************/
|
||||
alloc_big_block(reg, type, size)
|
||||
int reg[2]; /* register to receive pointer to allocated block */
|
||||
int type; /* type code of block to be allocated */
|
||||
unsigned size; /* size of block in bytes (including block header) */
|
||||
{
|
||||
int number_of_pages; /* number of pages required to satisy request */
|
||||
int page; /* page number where large block can be allocated */
|
||||
|
||||
number_of_pages = ((size + (PAGESIZE - 1)) / PAGESIZE);
|
||||
if ((page = find_big_block(number_of_pages)) == -1)
|
||||
{
|
||||
garbage(); /* Invoke Garbage Collector to reclaim memory */
|
||||
if ((page = find_big_block(number_of_pages)) == -1)
|
||||
{
|
||||
gcsquish(); /* Try compacting memory */
|
||||
if ((page = find_big_block(number_of_pages)) == -1)
|
||||
{
|
||||
out_of_memory(); /* attempt to execute SCHEME-RESET */
|
||||
/* Note: The above procedure returns control elsewhere */
|
||||
}
|
||||
}
|
||||
}
|
||||
zero_page(page);
|
||||
put_ptr(page, 0, type, size);
|
||||
nextcell[page] = END_LIST;
|
||||
if (size <= psize[page] - BLK_OVHD)
|
||||
{
|
||||
put_ptr(page, size, FREETYPE, psize[page] - size);
|
||||
nextcell[page] = size;
|
||||
}
|
||||
ptype[page] = type + type;
|
||||
w_attrib[page] = pageattr[type];
|
||||
pagelink[page] = pagelist[type];
|
||||
pagelist[type] = page;
|
||||
|
||||
reg[C_PAGE] = ADJPAGE(page);
|
||||
reg[C_DISP] = 0;
|
||||
} /* end of function: alloc_big_block(reg, type, size) */
|
||||
|
||||
|
||||
find_big_block(number_of_pages)
|
||||
int number_of_pages; /* number of contiguous pages required */
|
||||
{
|
||||
int free_pages[NUMPAGES+1]; /* free page table */
|
||||
int i,j; /* our old favorite index variables */
|
||||
int page; /* working page number */
|
||||
int page_found = -1; /* page number of first page in big block */
|
||||
int FirstEmmPage; /* First expanded memory page */
|
||||
|
||||
ENTER(find_big_block);
|
||||
|
||||
FirstEmmPage = exppage();
|
||||
|
||||
/* Initialize free_pages table */
|
||||
for (i = 0; i <= NUMPAGES; i++)
|
||||
free_pages[i] = -1;
|
||||
|
||||
/* Record the number of all free pages */
|
||||
page = freepage;
|
||||
while (page != END_LIST)
|
||||
{
|
||||
ASSERT(page >= 0 && page < NUMPAGES /* subchk? */);
|
||||
ASSERT(free_pages[page] == -1 /* infinite loop? */);
|
||||
free_pages[page] = page;
|
||||
page = pagelink[page];
|
||||
}
|
||||
|
||||
/* Search for a contiguous group of pages to satisfy request */
|
||||
for (i = 0; i < NUMPAGES - DEDPAGES - number_of_pages; i++)
|
||||
{
|
||||
if (free_pages[i] != -1)
|
||||
{
|
||||
j = 1;
|
||||
while (free_pages[i+j] != -1 &&
|
||||
(((free_pages[i] < FirstEmmPage) && (free_pages[i+j] < FirstEmmPage)) ||
|
||||
((free_pages[i] >= FirstEmmPage) && (free_pages[i+j] >= FirstEmmPage))
|
||||
)
|
||||
)
|
||||
{
|
||||
j++;
|
||||
if (j >= number_of_pages)
|
||||
{
|
||||
/* required number of pages found-- adjust page table */
|
||||
page_found = free_pages[i];
|
||||
psize[page_found] = PAGESIZE * number_of_pages;
|
||||
free_pages[i] = -1;
|
||||
|
||||
for (j = 1; j < number_of_pages; j++)
|
||||
{
|
||||
page = free_pages[i+j];
|
||||
psize[page] = 0;
|
||||
attrib[page].nomemory = 1;
|
||||
free_pages[i+j] = -1;
|
||||
}
|
||||
|
||||
/* update list of free pages */
|
||||
freepage = END_LIST;
|
||||
for (i = NUMPAGES; i > DEDPAGES; i--)
|
||||
{
|
||||
if (free_pages[i] != -1)
|
||||
{
|
||||
pagelink[(j = free_pages[i])] = freepage;
|
||||
freepage = j;
|
||||
}
|
||||
}
|
||||
return(page_found);
|
||||
}
|
||||
}
|
||||
i += j;
|
||||
}
|
||||
}
|
||||
return(-1); /* no pages found */
|
||||
} /* end of function: find_big_block(number_of_pages) */
|
||||
|
||||
|
|
@ -0,0 +1,231 @@
|
|||
/* =====> SBIGMXT.C */
|
||||
/* TIPC Scheme '84 Runtime Support - Memory Allocation Routines
|
||||
(C) Copyright 1984, 1985 by Texas Instruments Incorporated.
|
||||
All rights reserved.
|
||||
|
||||
Author: Terry Caudill
|
||||
Installation: Texas Instruments Incorporated, Austin, Texas
|
||||
Division: Data Systems Group
|
||||
Project: PC Scheme
|
||||
Comments: This code was lifted from SBIGMEM.C, which was used to
|
||||
allocate objects greater than on page in size. It was
|
||||
modified to understand extended memory and is tied closely
|
||||
to EXTSMMU.ASM
|
||||
Date Written: 4 June 86
|
||||
|
||||
*/
|
||||
#include "scheme.h"
|
||||
|
||||
/* The following are specified in EXTSMMU.ASM and must be the same here */
|
||||
#define FIXED 0x0080
|
||||
#define SWAPPED 0x0001
|
||||
|
||||
/* Turn off assertions in SBIGMXT.C for performance reasons */
|
||||
#define ASSERT(arg) /* do nothing */
|
||||
#define ENTER(xyz) /* do nothing */
|
||||
|
||||
/************************************************************************/
|
||||
/* Allocate a Large BLock in Scheme's Memory */
|
||||
/************************************************************************/
|
||||
alloc_big_block(reg, type, size)
|
||||
int reg[2]; /* register to receive pointer to allocated block */
|
||||
int type; /* type code of block to be allocated */
|
||||
unsigned size; /* size of block in bytes (including block header) */
|
||||
{
|
||||
int number_of_pages; /* number of pages required to satisy request */
|
||||
int page; /* page number where large block can be allocated */
|
||||
|
||||
number_of_pages = ((size + (PAGESIZE - 1)) / PAGESIZE);
|
||||
if ((page = find_big_block(number_of_pages)) == -1)
|
||||
{
|
||||
garbage(); /* Invoke Garbage Collector to reclaim memory */
|
||||
if ((page = find_big_block(number_of_pages)) == -1)
|
||||
{
|
||||
gcsquish(); /* Try compacting memory */
|
||||
again:
|
||||
if ((page = find_big_block(number_of_pages)) == -1)
|
||||
{
|
||||
out_of_memory(); /* attempt to execute SCHEME-RESET */
|
||||
goto again;
|
||||
}
|
||||
}
|
||||
}
|
||||
zero_page(page);
|
||||
put_ptr(page, 0, type, size);
|
||||
nextcell[page] = END_LIST;
|
||||
if (size <= psize[page] - BLK_OVHD)
|
||||
{
|
||||
put_ptr(page, size, FREETYPE, psize[page] - size);
|
||||
nextcell[page] = size;
|
||||
}
|
||||
ptype[page] = type + type;
|
||||
w_attrib[page] = pageattr[type];
|
||||
pagelink[page] = pagelist[type];
|
||||
pagelist[type] = page;
|
||||
|
||||
reg[C_PAGE] = ADJPAGE(page);
|
||||
reg[C_DISP] = 0;
|
||||
} /* end of function: alloc_big_block(reg, type, size) */
|
||||
|
||||
|
||||
find_big_block(number_of_pages)
|
||||
int number_of_pages; /* number of contiguous pages required */
|
||||
{
|
||||
int free_pages[NUMPAGES+1]; /* free page table */
|
||||
int real_pages[NUMPAGES+1]; /* real memory page table */
|
||||
int i,j,k,l; /* our old favorite index variables */
|
||||
int gap,temp; /* used for sort algorithm */
|
||||
int page; /* working page number */
|
||||
int page_found = -1; /* page number of first page in big block */
|
||||
|
||||
ENTER(find_big_block);
|
||||
|
||||
/* Initialize free_pages table */
|
||||
for (i = 0; i <= NUMPAGES; i++)
|
||||
free_pages[i] = -1;
|
||||
|
||||
/* Record the number of all free pages */
|
||||
page = freepage;
|
||||
while (page != END_LIST)
|
||||
{
|
||||
ASSERT(page >= 0 && page < NUMPAGES /* subchk? */);
|
||||
ASSERT(free_pages[page] == -1 /* infinite loop? */);
|
||||
free_pages[page] = page;
|
||||
page = pagelink[page];
|
||||
}
|
||||
|
||||
/* Search for a contiguous group of real memory pages to satisfy request */
|
||||
for (i = 0; i < NUMPAGES - DEDPAGES - number_of_pages; i++)
|
||||
{
|
||||
if ((free_pages[i] != -1) && ((pagetabl[free_pages[i]] & SWAPPED) == 0))
|
||||
{
|
||||
j = 1;
|
||||
while ((free_pages[i+j] != -1) &&
|
||||
((pagetabl[free_pages[i+j]] & SWAPPED) == 0) &&
|
||||
((pagetabl[free_pages[i+j]] - pagetabl[free_pages[i+j-1]]) == PAGESIZE/16))
|
||||
{
|
||||
j++;
|
||||
if (j >= number_of_pages)
|
||||
{
|
||||
/* required number of real memory pages found-- adjust page table */
|
||||
page_found = free_pages[i];
|
||||
update_pages(free_pages,i,number_of_pages);
|
||||
return(page_found);
|
||||
}
|
||||
}
|
||||
i += j;
|
||||
}
|
||||
}
|
||||
|
||||
/* At this point, there are no contiguous pages in real/conventional */
|
||||
/* memory. Get a list of all the swappable real memory pages and sort */
|
||||
/* them according to their paragraph address */
|
||||
|
||||
for (i=0; i <= NUMPAGES; i++)
|
||||
if ((i <= DEDPAGES) || ((pagetabl[i] & FIXED+SWAPPED) != 0))
|
||||
real_pages[i] = 1000;
|
||||
else
|
||||
real_pages[i] = i;
|
||||
|
||||
for (gap = NUMPAGES/2; gap > 0; gap /=2)
|
||||
for(i=gap; i<NUMPAGES; i++)
|
||||
for(j=i-gap;j>=0 && ((real_pages[j] == 1000) ? 65536 : pagetabl[real_pages[j]]) >
|
||||
((real_pages[j+gap] == 1000) ? 65536 : pagetabl[real_pages[j+gap]]);j-=gap)
|
||||
{
|
||||
temp = real_pages[j];
|
||||
real_pages[j] = real_pages[j+gap];
|
||||
real_pages[j+gap] = temp;
|
||||
}
|
||||
|
||||
/* Search for a contiguous group of extended memory pages to satisfy */
|
||||
/* request. Once a group of potential pages is found, search the */
|
||||
/* sorted real_pages for a contiguous group of real memory pages, ie */
|
||||
/* consecutive paragraph addresses, for pages which may be swapped to */
|
||||
/* extended memory. Swap them out, and use their prior paragraph */
|
||||
/* addresses to allocate the big block. */
|
||||
|
||||
for (i = 0; i < NUMPAGES - DEDPAGES - number_of_pages; i++)
|
||||
{
|
||||
if ((free_pages[i] != -1) && ((pagetabl[free_pages[i]] & SWAPPED) == SWAPPED))
|
||||
{
|
||||
j = 1;
|
||||
/* Lets look for consecutive extended memory pages */
|
||||
while ((free_pages[i+j] != -1) &&
|
||||
((pagetabl[free_pages[i+j]] & SWAPPED) == SWAPPED) &&
|
||||
((free_pages[i+j] - free_pages[i+j-1]) == 1))
|
||||
{
|
||||
j++;
|
||||
if (j >= number_of_pages)
|
||||
{
|
||||
page_found = free_pages[i];
|
||||
|
||||
l=0;
|
||||
/* Now lets look for contiguous real memory pages */
|
||||
while (real_pages[l] != 1000)
|
||||
{
|
||||
k=1;
|
||||
/* Note : Can't swap current code block page - CB_pag */
|
||||
if ((real_pages[l]*2) != CB_pag)
|
||||
{
|
||||
while ((real_pages[l+k] != 1000) &&
|
||||
((real_pages[l+k]*2) != CB_pag) &&
|
||||
((pagetabl[real_pages[l+k]] - pagetabl[real_pages[l+k-1]]) == PAGESIZE/16))
|
||||
{
|
||||
k++;
|
||||
if (k > number_of_pages)
|
||||
{
|
||||
/* Move each real memory page to extended memory */
|
||||
for (k=0; k<number_of_pages; k++)
|
||||
move_page(real_pages[l+k]*2,free_pages[i+k]*2);
|
||||
update_pages(free_pages,i,number_of_pages);
|
||||
return(page_found);
|
||||
}
|
||||
}
|
||||
}
|
||||
l += k;
|
||||
}
|
||||
return(-1); /* No contiguous real memory pages - exit */
|
||||
}
|
||||
}
|
||||
i += j;
|
||||
}
|
||||
}
|
||||
return(-1); /* no pages found */
|
||||
} /* end of function: find_big_block(number_of_pages) */
|
||||
|
||||
|
||||
update_pages(free_pages,index,num_pages)
|
||||
int free_pages[];
|
||||
int index,num_pages;
|
||||
{
|
||||
int i,j,page;
|
||||
|
||||
ENTER(update_pages);
|
||||
|
||||
page = free_pages[index];
|
||||
pagetabl[page] = pagetabl[page] | FIXED;
|
||||
psize[page] = PAGESIZE * num_pages;
|
||||
free_pages[index] = -1;
|
||||
|
||||
for (j = 1; j < num_pages; j++)
|
||||
{
|
||||
page = free_pages[index+j];
|
||||
pagetabl[page] = pagetabl[page] | FIXED;
|
||||
psize[page] = 0;
|
||||
attrib[page].nomemory = 1;
|
||||
free_pages[index+j] = -1;
|
||||
}
|
||||
|
||||
/* update list of free pages */
|
||||
freepage = END_LIST;
|
||||
|
||||
for (i = NUMPAGES; i > DEDPAGES; i--)
|
||||
{
|
||||
if (free_pages[i] != -1)
|
||||
{
|
||||
pagelink[(j = free_pages[i])] = freepage;
|
||||
freepage = j;
|
||||
}
|
||||
}
|
||||
} /* end of function update_pages */
|
||||
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
; =====> SCHEMED.REF
|
||||
; Copyright 1984,1985 by Texas Instruments Incorporated.
|
||||
; All Rights Reserved.
|
||||
; Last Modification: 06 January 1986
|
||||
|
||||
extrn pagetabl:word ; Page Table
|
||||
extrn attrib:word ; Page Attribute Table
|
||||
extrn nextcell:word ; Next available location table
|
||||
extrn pagelink:word ; Page link table
|
||||
extrn ptype:word ; Page type table
|
||||
extrn psize:word ; Page size table
|
||||
|
||||
extrn PAGESIZE:word ; Page size
|
||||
|
||||
; Table of pages for allocation by type
|
||||
extrn pagelist:word ; Page table
|
||||
extrn listpage:word ; [0] Page number for list cell allocation
|
||||
extrn fixpage:word ; [1] Page number for fixnum allocation
|
||||
extrn flopage:word ; [2] Page number for flonum allocation
|
||||
extrn bigpage:word ; [3] Page number for bignum allocation
|
||||
extrn sympage:word ; [4] Page number for symbol allocation
|
||||
extrn strpage:word ; [5] Page number for string allocation
|
||||
extrn vectpage:word ; [6] Page number for vector allocation
|
||||
extrn contpage:word ; [7] Page number for continuation allocation
|
||||
extrn clospage:word ; [8] Page number for closure allocation
|
||||
extrn freepage:word ; [9] Page number for free pages list
|
||||
extrn codepage:word ; [10] Page number for code page allocation
|
||||
extrn refpage:word ; [11] Page number for ref cell allocation
|
||||
extrn portpage:word ; [12] Page number for port cell allocation
|
||||
|
||||
; Table of page attributes by data object type
|
||||
extrn pageattr:word
|
||||
|
||||
; System tables
|
||||
extrn hash_pag:byte, hash_dis:word ; oblist's hash table
|
||||
extrn prop_pag:byte, prop_dis:word ; property list hash table
|
||||
extrn obj_ht:byte ; object hash table
|
||||
|
||||
; Table of bits to "or" in
|
||||
extrn bitable:word
|
||||
|
||||
extrn nextpage:word ; Next unused page number
|
||||
extrn lastpage:word ; Last unused page number
|
||||
extrn nextpara:word ; Next available paragraph number
|
||||
|
||||
; The interpreter's registers
|
||||
extrn reg0_pag:word, reg0_dis:word, reg0:dword
|
||||
extrn reg1_pag:word, reg1_dis:word, reg1:dword
|
||||
extrn FNV_pag:word, FNV_dis:word, FNV_reg:dword
|
||||
extrn GNV_pag:word, GNV_dis:word, GNV_reg:dword
|
||||
extrn CB_pag:word, CB_dis:word, CB_reg:dword
|
||||
extrn TRNS_pag:word, TRNS_dis:word, TRNS_reg:dword
|
||||
extrn tmp_page:word, tmp_disp:word, tmp_reg:dword
|
||||
extrn tm2_page:word, tm2_disp:word, tm2_reg:dword
|
||||
extrn tmp_adr:word, tm2_adr:word
|
||||
extrn PREV_pag:word, PREV_dis:word, PREV_reg:dword
|
||||
extrn CON_PAGE:word, CON_DISP:word
|
||||
extrn TOS:word, FP:word, BASE:word
|
||||
extrn FNV_save:word, STL_save:word
|
||||
extrn nil_reg:dword
|
||||
|
||||
; The Scheme runtime stack
|
||||
extrn S_stack:byte
|
||||
|
||||
; Scheme-reset state variables
|
||||
extrn FP_save:word, RST_ent:word
|
||||
|
||||
; Scheme debugger entry point offset
|
||||
extrn ERR_ent:word
|
||||
extrn VM_debug:word ; flag indicating VM debug mode
|
||||
extrn s_break:word ; flag indicating shift-break key depressed
|
||||
|
||||
; Current port
|
||||
extrn iooffs:word, ioseg:word
|
||||
|
||||
; Abort stack pointer
|
||||
extrn abadr:word
|
||||
|
||||
; Machine Type (Manufacturer) Flag
|
||||
extrn PC_MAKE:word
|
||||
|
||||
; Access to Lattice C's character attribute data structures
|
||||
extrn _ctype:byte
|
||||
_U equ 1 ; uppercase
|
||||
_L equ 2 ; lowercase
|
||||
_N equ 4 ; number
|
||||
_S equ 8 ; space
|
||||
_P equ 16 ; punctuation
|
||||
_C equ 32 ; control character
|
||||
_B equ 64 ; blank
|
||||
_X equ 128 ; hexadecimal digit
|
||||
|
||||
|
|
@ -0,0 +1,521 @@
|
|||
/* TIPC Scheme '84 -- Interactive Debug Utility
|
||||
(C) Copyright 1984,1985 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: 13 April 1984
|
||||
Modification History:
|
||||
?? 10/22/85 - ??
|
||||
rb 9/23/87 - make screen output interruptible
|
||||
*/
|
||||
|
||||
#include "ctype.h"
|
||||
#include "scheme.h"
|
||||
|
||||
#define BUFSIZE 160
|
||||
#define DEFAULT_LENGTH 64
|
||||
#define QUIT 0
|
||||
#define PROCEED 1
|
||||
#define HALT 1
|
||||
#define INTR_OUTPUT if (char_rdy()) {(void) getch(); break;}
|
||||
|
||||
extern char char_rdy();
|
||||
|
||||
/**********************************************************************/
|
||||
/* TIPC Scheme '84 Interactive Debugger */
|
||||
/* */
|
||||
/* Purpose: This utility assists the compiler developer by allowing */
|
||||
/* him or her to interactively display and modify the data */
|
||||
/* structures of the Scheme Virtual Machine as a program */
|
||||
/* executes. */
|
||||
/**********************************************************************/
|
||||
sdebug()
|
||||
{
|
||||
int after[NUMPAGES], before[NUMPAGES]; /* memory reclamation info */
|
||||
char buffer[BUFSIZE];
|
||||
int command = PROCEED;
|
||||
int disp; /* displacement into a page */
|
||||
int i,j,k;
|
||||
int idx; /* index into character string buffer */
|
||||
long ix; /* 32 bit integer temporary */
|
||||
unsigned length; /* length (in bytes) of area to dump */
|
||||
int page; /* page number */
|
||||
int *reg_page,*reg_disp; /* current register pointers */
|
||||
int sav_disp;
|
||||
int pc; /* local copy of VM's PC */
|
||||
|
||||
long hex_word();
|
||||
unsigned hex_val();
|
||||
unsigned put_word();
|
||||
ENTER(sdebug);
|
||||
|
||||
/* If we're not in VM debug mode, simply issue a SCHEME-RESET */
|
||||
if (!VM_debug) {
|
||||
reset:
|
||||
printf("\nAttempting to execute SCHEME-RESET\n%s",
|
||||
"[Returning to top level]\n");
|
||||
CB_pag = SPECCODE*2;
|
||||
CB_dis = 0;
|
||||
S_pc = RST_ent - 1;
|
||||
goto run_it;
|
||||
}
|
||||
|
||||
/* Print Welcome to the Debugging World */
|
||||
printf("\nPC Scheme Virtual Machine Debugger\n");
|
||||
|
||||
/* Read the next command from the user person */
|
||||
while (command != QUIT) {
|
||||
zcuron();
|
||||
printf("\nCOMMAND: ");
|
||||
i = 0;
|
||||
ssetadr(ADJPAGE(IN_PAGE), IN_DISP);
|
||||
while ((j = take_ch()) != '\r')
|
||||
if (j != '\n') buffer[i++] = j;
|
||||
buffer[i] = '\0';
|
||||
|
||||
/* decode instruction */
|
||||
if (i > 0) {
|
||||
switch(tolower(buffer[0])) {
|
||||
case 'a': /* display accounting information */
|
||||
accounting();
|
||||
break;
|
||||
|
||||
case 'd': /* Dump Memory: Page:Offset [length] */
|
||||
i = tolower(buffer[1]); /* save second character */
|
||||
if (i != 'f') {
|
||||
idx = 1;
|
||||
if (check_page(buffer, &idx, &page, &disp))
|
||||
break;
|
||||
if ((length = hex_val(buffer, &idx)) == 0)
|
||||
length = DEFAULT_LENGTH;
|
||||
length = min (length, psize[page] - disp);
|
||||
}
|
||||
|
||||
switch (i) {
|
||||
case 'g': /* dump global environment */
|
||||
page = CORRPAGE(GNV_pag);
|
||||
disp = GNV_dis;
|
||||
while (page) {
|
||||
INTR_OUTPUT;
|
||||
printf("\n\t*** NEW RIB ***\n\n");
|
||||
sav_disp = disp;
|
||||
disp += 6;
|
||||
for (i = 0; i < HT_SIZE; i++,disp+=3) {
|
||||
INTR_OUTPUT;
|
||||
if (j = get_byte(page, disp))
|
||||
dump_environment(j,
|
||||
get_word(page, disp+1));
|
||||
}
|
||||
disp = get_word(page,sav_disp+4);
|
||||
page = CORRPAGE(get_byte(page,sav_disp+3));
|
||||
} /* end: while (page) */
|
||||
break;
|
||||
case 'f': /* dump fluid environment */
|
||||
dump_environment(FNV_pag, FNV_dis);
|
||||
break;
|
||||
case 'h': /* hexadecimal dump */
|
||||
dump_hex(page, disp, length);
|
||||
break;
|
||||
/***** case 'p': /* dump the property list */
|
||||
dump_prop();
|
||||
break;
|
||||
*****/
|
||||
case 's': /* dump the runtime stack */
|
||||
dump_stk();
|
||||
break;
|
||||
default: /* regular ole dump of a page */
|
||||
dump_memory(page, disp, length);
|
||||
} /* end switch */
|
||||
|
||||
break;
|
||||
|
||||
case 'e': /* Execute this here program */
|
||||
run_it:
|
||||
if (run(&S_pc, 0x7fff) == HALT) {
|
||||
command = QUIT;
|
||||
}
|
||||
else {
|
||||
if (!VM_debug) goto reset;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'g': /* invoke garbage collector */
|
||||
if (ask("run garbage collector"))
|
||||
{
|
||||
sum_space(before);
|
||||
garbage();
|
||||
sum_space(after);
|
||||
for (i = DEDPAGES; i < NUMPAGES; i++)
|
||||
if (before[i] != after[i])
|
||||
printf("Page %3x -- %d bytes recovered\n", i,
|
||||
after[i] - before[i]);
|
||||
if (ask("run compaction phase"))
|
||||
{
|
||||
for (i = DEDPAGES, j = 0; i < NUMPAGES; i++)
|
||||
if (ptype[i] == FREETYPE*2) j++;
|
||||
gcsquish(); /* go for memory compaction */
|
||||
for (i = DEDPAGES, k = 0; i < NUMPAGES; i++)
|
||||
if (ptype[i] == FREETYPE*2) k++;
|
||||
printf("%d pages reclaimed\n", k-j);
|
||||
}
|
||||
}
|
||||
break;
|
||||
|
||||
case '?': /* print out commands currently defined */
|
||||
/* case 'h': */
|
||||
printf("Valid Debugger Commands:\n\n%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s",
|
||||
" A - display accounting information\n",
|
||||
" DH [page:offset [length]] - dump memory hex\n",
|
||||
" D [page:offset [length]] - dump memory formatted\n",
|
||||
" DF,DG,DS - dump fluids, globals, stack\n",
|
||||
" E - execute program (return to PC Scheme)\n",
|
||||
" G - invoke Garbage collection\n",
|
||||
/* " H - help (prints this information)\n", */
|
||||
" I reg <CR> atom - input atom to register\n",
|
||||
" IP [n] - set IP to n; if none, decrement IP by 1\n",
|
||||
/* " M - run Mark phase of garbage collector\n", */
|
||||
" O - display registers as s-expressions\n",
|
||||
" P - dump page table\n",
|
||||
" Q - quit (return to DOS)\n",
|
||||
" R,RE - display registers, do scheme-reset\n",
|
||||
/* " S - run Sweep phase of garbage collector\n", */
|
||||
" T [n] - trace n instructions\n",
|
||||
" WB [page:offset data ...] - write bytes\n",
|
||||
" WW [page:offset data ...] - write words\n",
|
||||
" X [n] - execute n instructions\n",
|
||||
" ? - help (prints this information)\n");
|
||||
break;
|
||||
|
||||
case 'i': /* input atom into register */
|
||||
if (tolower(buffer[1]) == 'p') {
|
||||
idx = 2;
|
||||
i = hex_val(buffer, &idx);
|
||||
S_pc = (i > 0 ? i : S_pc - 1);
|
||||
}
|
||||
else {
|
||||
idx = 1;
|
||||
i = int_val(buffer,&idx) % NUM_REGS;
|
||||
sread_atom(®0 + i, ADJPAGE(IN_PAGE), IN_DISP);
|
||||
} /* end else */
|
||||
break;
|
||||
|
||||
/*****
|
||||
case 'm': /* run mark phase of garbage collection */
|
||||
if (ask("run mark phase of garbage collector"))
|
||||
mark();
|
||||
break;
|
||||
*****/
|
||||
|
||||
case 'o': /* print s-expressions pointed by regs */
|
||||
reg_page = ®0_page;
|
||||
reg_disp = ®0_disp;
|
||||
for (i = 0; i < NUM_REGS; i++, reg_page+=2, reg_disp+=2)
|
||||
{
|
||||
if (*reg_disp != UN_DISP || *reg_page != UN_PAGE*2)
|
||||
sprint_reg(i, *reg_page, *reg_disp);
|
||||
}
|
||||
break;
|
||||
|
||||
case 'p': /* print page table and page control information */
|
||||
dump_page_table();
|
||||
break;
|
||||
|
||||
case 'q': /* quit */
|
||||
command = QUIT;
|
||||
break;
|
||||
|
||||
case 'r': if (tolower(buffer[1]) == 'e')
|
||||
{
|
||||
CB_pag = SPECCODE*2;
|
||||
CB_dis = 0;
|
||||
S_pc = RST_ent - 1;
|
||||
}
|
||||
else dump_regs(); /* dump registers */
|
||||
break;
|
||||
|
||||
/*****
|
||||
case 's': /* run sweep portion of garbage collector */
|
||||
if (ask("run sweep phase of garbage collector"))
|
||||
gcsweep();
|
||||
break;
|
||||
*****/
|
||||
|
||||
case 't': /* trace instruction execution */
|
||||
idx = 1;
|
||||
if ((length = hex_val(buffer, &idx)) <= 0) length = 1;
|
||||
while (length > 0) {
|
||||
if ((i = t_inst(CORRPAGE(CB_pag), &S_pc,
|
||||
/* run= */ TRUE, /* display= */ TRUE))) break;
|
||||
length--;
|
||||
} /* end while */
|
||||
pc = S_pc;
|
||||
(void) t_inst(CORRPAGE(CB_pag), &pc,
|
||||
/* run= */ FALSE, /* display= */ TRUE);
|
||||
if (i == HALT) halt_exec();
|
||||
break;
|
||||
|
||||
case 'w': /* write memory-- determine if byte or word */
|
||||
idx = 2;
|
||||
if (check_page(buffer, &idx, &page, &disp))
|
||||
break;
|
||||
switch (tolower(buffer[1]))
|
||||
{
|
||||
case 'b': /* write byte */
|
||||
while ((i = hex_byte(buffer, &idx)) >= 0)
|
||||
{
|
||||
printf("%3x:%04x Previous contents: %02x Replaced by: %02x\n",
|
||||
page, disp,
|
||||
get_byte(page, disp), i);
|
||||
put_byte(page, disp, i);
|
||||
disp++;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'w': /* write word */
|
||||
while ((ix = hex_word(buffer, &idx)) >= 0L)
|
||||
{
|
||||
printf("%3x:%04x Previous contents: %04x Replaced by: %04lx\n",
|
||||
page, disp,
|
||||
get_word(page, disp), ix);
|
||||
put_word(page, disp, ix);
|
||||
disp += 2;
|
||||
}
|
||||
break;
|
||||
|
||||
default: goto bad_command;
|
||||
} /* end: switch (buffer[1]) */
|
||||
break;
|
||||
|
||||
case 'x': /* instruction execution */
|
||||
idx = 1;
|
||||
if ((length = hex_val(buffer, &idx)) <= 0) length = 1;
|
||||
if (interp(&S_pc, length) == HALT) halt_exec();
|
||||
break;
|
||||
|
||||
default: /* unrecognized command */
|
||||
bad_command:
|
||||
printf("? unrecognized command\n");
|
||||
break;
|
||||
} /* end: switch(tolower(buffer[0])) */
|
||||
} /* end: if (i > 0) */
|
||||
} /* end: while (command != QUIT) */
|
||||
} /* end of function: sdebug() */
|
||||
|
||||
halt_exec()
|
||||
{
|
||||
printf("\n*** (exit) command executed ***\n");
|
||||
}
|
||||
|
||||
/**********************************************************************/
|
||||
/* extract a decimal value from a string */
|
||||
/**********************************************************************/
|
||||
int_val(str, idx)
|
||||
char str[];
|
||||
int *idx;
|
||||
{
|
||||
char ch;
|
||||
unsigned ret_val = 0;
|
||||
int i;
|
||||
ENTER(int_val);
|
||||
|
||||
/* skip over any leading characters in string */
|
||||
while (str[*idx] != '\0' && !isdigit(str[*idx])) (*idx)++;
|
||||
|
||||
/* continue to extract digits until end of string of delimiter */
|
||||
while ((ch = str[*idx]))
|
||||
{
|
||||
if ((i = get_int(ch)) >= 0)
|
||||
ret_val = (ret_val * 10) + i;
|
||||
else break;
|
||||
(*idx)++;
|
||||
}
|
||||
return((int) ret_val);
|
||||
} /* end of function: int_val(str, idx) */
|
||||
|
||||
/**********************************************************************/
|
||||
/* extract a hexadecimal value from a string */
|
||||
/**********************************************************************/
|
||||
unsigned hex_val(str, idx)
|
||||
char str[];
|
||||
int *idx;
|
||||
{
|
||||
char ch;
|
||||
unsigned ret_val = 0;
|
||||
int i;
|
||||
ENTER(hex_val);
|
||||
|
||||
/* skip over any leading characters in string */
|
||||
while (str[*idx] != '\0' && !isxdigit(str[*idx])) (*idx)++;
|
||||
|
||||
/* continue to extract digits until end of string of delimiter */
|
||||
while ((ch = str[*idx]))
|
||||
{
|
||||
if ((i = get_hex(ch)) >= 0)
|
||||
ret_val = (ret_val << 4) + i;
|
||||
else break;
|
||||
(*idx)++;
|
||||
}
|
||||
return(ret_val);
|
||||
} /* end of function: hex_val(str, idx) */
|
||||
|
||||
/**********************************************************************/
|
||||
/* Extract a byte value from a string */
|
||||
/**********************************************************************/
|
||||
hex_byte(str, idx)
|
||||
char str[];
|
||||
int *idx;
|
||||
{
|
||||
int first_digit, second_digit;
|
||||
ENTER(hex_byte);
|
||||
while (str[*idx] == ' ') (*idx)++; /* skip leading blanks */
|
||||
if ((first_digit = get_hex(str[*idx])) < 0) return(-1);
|
||||
(*idx)++;
|
||||
if ((second_digit = get_hex(str[*idx])) < 0) return(first_digit);
|
||||
(*idx)++;
|
||||
return(first_digit * 16 + second_digit);
|
||||
}
|
||||
|
||||
/**********************************************************************/
|
||||
/* Extract a word value from a string */
|
||||
/**********************************************************************/
|
||||
long hex_word(str, idx)
|
||||
char str[];
|
||||
int *idx;
|
||||
{
|
||||
int digit,i;
|
||||
long ret_val;
|
||||
ENTER(hex_word);
|
||||
|
||||
while (str[*idx] == ' ') (*idx)++; /* skip leading blanks */
|
||||
ret_val = -1L;
|
||||
for (i = 0; i < 4; i++)
|
||||
{
|
||||
if (str[*idx] == '\0') return(ret_val);
|
||||
if ((digit = get_hex(str[*idx])) < 0) return(ret_val);
|
||||
ret_val = (ret_val == -1L? digit : (ret_val << 4) | digit);
|
||||
(*idx)++;
|
||||
}
|
||||
return(ret_val);
|
||||
}
|
||||
|
||||
/**********************************************************************/
|
||||
/* Test for a hex digit-- if so, return its decimal value */
|
||||
/**********************************************************************/
|
||||
get_hex(ch)
|
||||
char ch; /* the character to be tested */
|
||||
{
|
||||
int i;
|
||||
static char hex_digit[16]={'0','1','2','3','4','5','6','7','8','9',
|
||||
'A','B','C','D','E','F'};
|
||||
ENTER(get_hex);
|
||||
ch = toupper(ch);
|
||||
for (i = 0; i < 16; i++) if (ch == hex_digit[i]) return(i);
|
||||
return(-1);
|
||||
} /* end of function: get_hex(ch) */
|
||||
|
||||
/**********************************************************************/
|
||||
/* Test for a decimal digit-- if so, return its value */
|
||||
/**********************************************************************/
|
||||
get_int(ch)
|
||||
char ch; /* the character to be tested */
|
||||
{
|
||||
ENTER(get_int);
|
||||
return(isdigit(ch) ? ch - '0' : -1);
|
||||
} /* end of function: get_int(ch) */
|
||||
|
||||
/**********************************************************************/
|
||||
/* Verify page number, offset values */
|
||||
/* */
|
||||
/* Purpose: This routine checks the page number, displacement, and */
|
||||
/* length parameters keyed in by the interactive debug user */
|
||||
/* to make sure they are within acceptable bounds. */
|
||||
/**********************************************************************/
|
||||
check_page(buffer, idx, page, disp)
|
||||
char buffer[];
|
||||
int *idx, *page, *disp;
|
||||
{
|
||||
/*%% int len;*/
|
||||
int ret_val = -1;
|
||||
unsigned hex_val();
|
||||
ENTER(check_page);
|
||||
|
||||
*page = hex_val(buffer, &(*idx));
|
||||
*disp = hex_val(buffer, &(*idx));
|
||||
|
||||
/* Verify that page number is valid */
|
||||
if (*page < 0 || *page >= NUMPAGES)
|
||||
{
|
||||
printf("***page numbers must be in the range 00 to %x (hex)***\n",
|
||||
NUMPAGES-1);
|
||||
}
|
||||
else
|
||||
{
|
||||
if (attrib[*page].nomemory)
|
||||
{
|
||||
printf("***page %x (hex) has not been allocated***\n", *page);
|
||||
}
|
||||
else
|
||||
{
|
||||
if (*disp < 0 || *disp >= psize[*page])
|
||||
printf("***displacements must be in the range 0000 to %04x (hex)***\n",
|
||||
psize[*page]-1);
|
||||
else ret_val = 0; /* valid page, displacement, length */
|
||||
}
|
||||
}
|
||||
return(ret_val);
|
||||
}
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/* Check with the user before doing something */
|
||||
/* */
|
||||
/* Purpose: This routine is called before performing a potentially */
|
||||
/* dangerous operation to make sure the interactive debug */
|
||||
/* user has not entered the command in error. */
|
||||
/* */
|
||||
/* Calling Sequence: answer = ask(question); */
|
||||
/* where: int answer - FALSE = question was answered "no" */
|
||||
/* TRUE = question was answered "yes" */
|
||||
/* char *question - a character string representing the */
|
||||
/* question to be asked. A '?' will be */
|
||||
/* appended to this string when it is */
|
||||
/* displayed to the user. */
|
||||
/**********************************************************************/
|
||||
ask(str)
|
||||
char *str;
|
||||
{
|
||||
int ch;
|
||||
printf("%s?\nType Y to proceed, any other character to abort\n",str);
|
||||
ch = getch();
|
||||
if (ch == 'y' || ch == 'Y') return(TRUE);
|
||||
printf("***command aborted***\n");
|
||||
return(FALSE);
|
||||
} /* end of function: ask(str) */
|
||||
|
||||
/* Print s-expressive line of register contents to standard output*/
|
||||
static char digit[10] = {'0','1','2','3','4','5','6','7','8','9'};
|
||||
sprint_reg(name,pg,ds)
|
||||
int name,pg,ds;
|
||||
{
|
||||
extern int display;
|
||||
extern int show;
|
||||
|
||||
ssetadr(ADJPAGE(OUT_PAGE),OUT_DISP);
|
||||
outchar('R');
|
||||
if (name >= 10) outchar(digit[name/10]);
|
||||
outchar(digit[name%10]);
|
||||
outchar(':');
|
||||
outchar(' ');
|
||||
|
||||
display = show = 1;
|
||||
ds = sprint(CORRPAGE(pg),ds,ADJPAGE(OUT_PAGE),OUT_DISP);
|
||||
/***********
|
||||
ds = sprint(CORRPAGE(pg),ds,OUT_PAGE,OUT_DISP,TRUE,TRUE,FALSE);
|
||||
**********/
|
||||
outchar('\n');
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,885 @@
|
|||
/* =====> SDUMP.C */
|
||||
/* TIPC Scheme '84 - Diagnostic Dump Routines
|
||||
(C) Copyright 1984,1985,1987 by Texas Instruments Incorporated.
|
||||
All rights reserved.
|
||||
|
||||
Author: John Jensen
|
||||
Installation: Texas Instruments Incorporated, Dallas, Texas
|
||||
Division: Central Research Laboratories
|
||||
Cost Center: Computer Science Laboratory
|
||||
Project: Computer Architecture Branch
|
||||
Date Written: 11 April 1984
|
||||
Modification History:
|
||||
?? 10/10/85 - ??
|
||||
rb 9/21/87 - lists, strings/symbols, and array-like data structures
|
||||
print only within user-specified bounds;
|
||||
also, hitting any key exits the printing
|
||||
*/
|
||||
#include "scheme.h"
|
||||
#include "ctype.h"
|
||||
#include "schars.h"
|
||||
#include "slist.h"
|
||||
|
||||
#define INTR_OUTPUT if (char_rdy()) {(void) getch(); goto bye;}
|
||||
|
||||
static char *page_type[NUMTYPES] = {"LIST","FIX" ,"FLO" , "BIG","SYM" ,
|
||||
"STR" ,"ARY" ,"CONT","CLOS","FREE",
|
||||
"CODE","REF" ,"PORT","CHAR","ENV"};
|
||||
/* character strings for getmem/rlsmem error message text */
|
||||
static char *mem_fmt = "%s: %smem error\n";
|
||||
static char *getmem_error = "get";
|
||||
|
||||
char *getmem();
|
||||
char char_rdy();
|
||||
|
||||
/**********************************************************************/
|
||||
/* Format a dump of the Page Table */
|
||||
/**********************************************************************/
|
||||
dump_page_table()
|
||||
{
|
||||
int i; /* the usual index variable */
|
||||
int start, end; /* starting and ending limits of FREE pages */
|
||||
int space[NUMPAGES]; /* amount of free space in each page */
|
||||
ENTER(dump_page_table);
|
||||
|
||||
/* determine the amount of free space in each page */
|
||||
sum_space(space);
|
||||
|
||||
/* Print Page Table Dump Headings */
|
||||
printf("\nDump of Scheme Memory Management Page Tables\n\n%s\n%s\n%s\n",
|
||||
"Page Page Base Next Link Free",
|
||||
" No Type Para Avail Page Size Bytes Attributes",
|
||||
"---- ---- ---- ----- ---- ---- ----- ----------");
|
||||
start = end = -1;
|
||||
for (i = 0; i < nextpage; i++)
|
||||
{
|
||||
INTR_OUTPUT;
|
||||
if (ptype[i] == FREETYPE*2) {
|
||||
if (start < 0) start = i;
|
||||
end = i;
|
||||
}
|
||||
else {
|
||||
prt_free(&start, &end);
|
||||
printf("%4x %5s %04x %4x %4x%c %4x %4x ", i,
|
||||
page_type[ptype[i]>>1], getbase(i*2), nextcell[i],
|
||||
pagelink[i], (i == pagelist[CORRPAGE(ptype[i])] ? '<' : ' '),
|
||||
psize[i], space[i]);
|
||||
/* print attributes for page */
|
||||
prt_atr(i);
|
||||
|
||||
/* Flush line to output device */
|
||||
printf("\n");
|
||||
} /* end: else */
|
||||
} /* end: for (i = 0; i < nextpage; i++) */
|
||||
prt_free(&start, &end);
|
||||
|
||||
/* Print summary of pages which are not allocated */
|
||||
if (nextpage < NUMPAGES) {
|
||||
if (nextpage == NUMPAGES-1)
|
||||
printf("Page %x is not allocated\n", nextpage);
|
||||
else
|
||||
printf("Pages %x-%x are not allocated\n", nextpage, NUMPAGES-1);
|
||||
}
|
||||
bye:
|
||||
} /* end of function: dump_page_table() */
|
||||
|
||||
/**********************************************************************/
|
||||
/* Print Page Attributes */
|
||||
/* */
|
||||
/* Purpose: This routine prints the attributes of a page on the */
|
||||
/* current print line. Attributes are separated by commas. */
|
||||
/**********************************************************************/
|
||||
prt_atr(page)
|
||||
int page;
|
||||
{
|
||||
unsigned bits;
|
||||
static char *things[16] = {"atom","list","fixnum","flonum","bignum",
|
||||
"symbol","string","array","no memory","read only",
|
||||
"continuation","closure","ref","port","code block",
|
||||
"char"};
|
||||
char *comma_needed = "";
|
||||
int i = 0;
|
||||
ENTER(prt_atr);
|
||||
|
||||
bits = w_attrib[page];
|
||||
while (bits)
|
||||
{
|
||||
if (bits & 0x8000)
|
||||
{
|
||||
printf("%s%s", comma_needed, things[i]);
|
||||
comma_needed = ",";
|
||||
}
|
||||
i++;
|
||||
bits = (bits << 1);
|
||||
} /* end: while (bits) */
|
||||
}
|
||||
|
||||
/**********************************************************************/
|
||||
/* Print Free (unused) Pages of Memory */
|
||||
/* */
|
||||
/* Purpose: Given a range of unused pages of memory, this routine */
|
||||
/* formats a message to indicate the presence of said pages.*/
|
||||
/**********************************************************************/
|
||||
prt_free(start, end)
|
||||
int *start, *end;
|
||||
{
|
||||
int i;
|
||||
ENTER(prt_free);
|
||||
if ((i = *start) >= 0)
|
||||
{
|
||||
if (i == *end)
|
||||
printf("%4x %4s %04x %4x %4x %4x %4x (unused)\n", i,
|
||||
page_type[ptype[i]>>1], getbase(i*2), nextcell[i],
|
||||
pagelink[i], psize[i], psize[i]);
|
||||
else
|
||||
printf("Pages %x-%x are allocated, but unused\n",
|
||||
i, *end);
|
||||
*start = *end = -1;
|
||||
}
|
||||
}
|
||||
|
||||
/**********************************************************************/
|
||||
/* Produce a Formatted Dump of an Area of Scheme's Address Space */
|
||||
/**********************************************************************/
|
||||
dump_memory(page, disp, length)
|
||||
int page; /* number of page to dump */
|
||||
unsigned disp; /* starting displacement */
|
||||
unsigned length; /* number of bytes to dump */
|
||||
{
|
||||
int page_type;
|
||||
static char *description[NUMTYPES] = {"List Cells","Fixnums","Flonums",
|
||||
"Bignums","Symbols","Strings",
|
||||
"Arrays","Continuation Cells",
|
||||
"Closures","Nothing (unused)",
|
||||
"Code","Ref Cells","Ports",
|
||||
"Characters", "Environments"};
|
||||
ENTER(dump_memory);
|
||||
page_type = ptype[page]>>1;
|
||||
if (page_type >= 0 && page_type < NUMTYPES && page_type != FREETYPE)
|
||||
{
|
||||
printf("Page %x (hex) contains %s\nPage attributes: ",
|
||||
page, description[page_type]);
|
||||
prt_atr(page);
|
||||
printf("\n");
|
||||
switch (page_type)
|
||||
{
|
||||
case LISTTYPE:
|
||||
dump_list(page, disp, length);
|
||||
break;
|
||||
/*** Note: Fixnums and Characters currently handled as immediates
|
||||
case CHARTYPE:
|
||||
case FIXTYPE:
|
||||
dump_fix(page, disp, length);
|
||||
break;
|
||||
***/
|
||||
case SYMTYPE:
|
||||
case STRTYPE:
|
||||
dump_str(page, disp, length);
|
||||
break;
|
||||
|
||||
case CODETYPE:
|
||||
dump_code(page, disp, length);
|
||||
break;
|
||||
|
||||
case ARYTYPE:
|
||||
case CLOSTYPE:
|
||||
case CONTTYPE:
|
||||
case ENVTYPE:
|
||||
dump_ary(page, disp, length);
|
||||
break;
|
||||
|
||||
case FLOTYPE:
|
||||
/*** dump_flo(page, disp, length);
|
||||
break; ***/
|
||||
|
||||
case PORTTYPE:
|
||||
/*** dump_port(page,disp,length);
|
||||
break; ***/
|
||||
|
||||
case BIGTYPE:
|
||||
dump_hex(page, disp, length);
|
||||
break;
|
||||
|
||||
case REFTYPE:
|
||||
default: printf("***Invalid page type: %d***\n", page_type);
|
||||
} /* end: switch (page_type) */
|
||||
} /* end: if (then clause) */
|
||||
else
|
||||
printf("***Invalid page type: %d***\n", page_type);
|
||||
} /* end of function: dump_memory(page, disp, length) */
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/* Produce a Hex Dump of a Page of Scheme's Memory */
|
||||
/**********************************************************************/
|
||||
dump_hex(page, disp, length)
|
||||
int page, disp, length;
|
||||
{
|
||||
int start, end; /* delimiters for dump area */
|
||||
ENTER(dump_hex);
|
||||
|
||||
start = disp & 0xFFF0;
|
||||
end = ((disp + length + 15) & 0xFFF0) - 1;
|
||||
|
||||
while (start <= end) {
|
||||
INTR_OUTPUT;
|
||||
if ((start & 0x000F) == 0) { /* start of new line */
|
||||
printf("\n%2x:%04x ", page, start);
|
||||
}
|
||||
printf("%02x ", get_byte(page, start));
|
||||
start++;
|
||||
}
|
||||
/* flush line to output device */
|
||||
bye: printf("\n");
|
||||
}
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/* Produce Formatted Dump of a Page Containing List Cells */
|
||||
/* */
|
||||
/* Note: the "disp" and "length" parameters currently are not used. */
|
||||
/* (they are now -- rb 9/21/87) */
|
||||
/**********************************************************************/
|
||||
dump_list(page, disp, length)
|
||||
int page;
|
||||
int disp;
|
||||
int length;
|
||||
{
|
||||
int end_disp = disp + length;
|
||||
int count = 0;
|
||||
int i,j; /* the usual index variables */
|
||||
int next;
|
||||
int number_of_cells; /* the number of list cells in current page */
|
||||
int page_length; /* length of current page in bytes */
|
||||
int start = -1;
|
||||
int end = -1;
|
||||
char *unused_cells;
|
||||
ENTER(dump_list);
|
||||
|
||||
/* if page zero, print nil */
|
||||
if (page == 0)
|
||||
{
|
||||
printf("000:0000 00 0000 00 0000 nil\n");
|
||||
} /* end: if (page == 0) then ... */
|
||||
else /* page != 0 */
|
||||
{
|
||||
number_of_cells = (page_length = psize[page])/LISTSIZE;
|
||||
if (!(unused_cells = getmem(number_of_cells)))
|
||||
{
|
||||
printf(mem_fmt, rtn_name, getmem_error); goto end_routine;
|
||||
}
|
||||
/* count up available cells */
|
||||
for (i=0; i < number_of_cells; i++) unused_cells[i] = '\0';
|
||||
next = nextcell[page];
|
||||
while (next != END_LIST) {
|
||||
j = next/LISTSIZE;
|
||||
ASSERT(j >= 0 && j < number_of_cells /* subchk? */ );
|
||||
unused_cells[j] = 'x';
|
||||
next = get_word(page, next+1);
|
||||
count++;
|
||||
ASSERT(count <= number_of_cells /* infinite loop? */);
|
||||
} /* end while */
|
||||
printf("%d (decimal) List Cells Unused\n", count);
|
||||
|
||||
/* print active List Cells */
|
||||
for (next = 0; next <= page_length - LISTSIZE; next += LISTSIZE) {
|
||||
INTR_OUTPUT;
|
||||
if (unused_cells[next/LISTSIZE]) { /* unused cell-- make a notation */
|
||||
if (start < 0) start = next;
|
||||
end = next;
|
||||
}
|
||||
else {
|
||||
if (end >= disp && start <= end_disp)
|
||||
prt_unused(&start, &end);
|
||||
if (next+LISTSIZE >= disp && next < end_disp)
|
||||
printf("%3x:%04x %02x %04x %02x %04x\n", page, next,
|
||||
CORRPAGE(get_byte(page, next)), get_word(page, next+1),
|
||||
CORRPAGE(get_byte(page, next+3)), get_word(page, next+4));
|
||||
}
|
||||
} /* end for (next=0; ... */
|
||||
if (end >= disp && start <= end_disp)
|
||||
prt_unused(&start, &end);
|
||||
|
||||
/* release memory for unused cell list */
|
||||
bye:
|
||||
if (rlsmem(unused_cells, number_of_cells))
|
||||
rlsmem_error(rtn_name);
|
||||
} /* end: else /* page != 0 */ */
|
||||
end_routine:
|
||||
} /* end of function: dump_list(page) */
|
||||
|
||||
|
||||
/***** Code for dump_ref turned off 6 July 1985 by John Jensen *****
|
||||
/**********************************************************************/
|
||||
/* Produce Formatted Dump of a Page Containing Reference Cells */
|
||||
/* */
|
||||
/* Note: the "disp" and "length" parameters currently are not used. */
|
||||
/**********************************************************************/
|
||||
dump_ref(page, disp, length)
|
||||
int page;
|
||||
int disp;
|
||||
int length;
|
||||
{
|
||||
int count = 0;
|
||||
int end = -1;
|
||||
int i,j; /* the usual index variables */
|
||||
int next;
|
||||
int number_of_cells; /* the number of cells in current page */
|
||||
int page_length; /* size of the current page in bytes */
|
||||
int start = -1;
|
||||
char *unused_cells;
|
||||
ENTER(dump_ref);
|
||||
|
||||
number_of_cells = (page_length = psize[page])/PTRSIZE;
|
||||
if (!(unused_cells = getmem(number_of_cells)))
|
||||
{
|
||||
printf(mem_fmt, rtn_name, getmem_error); goto end_routine;
|
||||
}
|
||||
/* count up available cells */
|
||||
for (i=0; i < number_of_cells; i++) unused_cells[i] = '\0';
|
||||
next = nextcell[page];
|
||||
while (next != END_LIST)
|
||||
{
|
||||
j = next/PTRSIZE;
|
||||
ASSERT(j >= 0 && j < number_of_cells /* subchk? */);
|
||||
unused_cells[j] = 'x';
|
||||
next = get_word(page, next+1);
|
||||
count++;
|
||||
ASSERT(count <= number_of_cells /* infinite loop? */);
|
||||
}
|
||||
printf("%d (decimal) Reference Cells Unused\n", count);
|
||||
|
||||
/* print active Ref Cells */
|
||||
for (next = 0; next <= page_length - PTRSIZE; next += PTRSIZE)
|
||||
{
|
||||
if (unused_cells[next/PTRSIZE])
|
||||
{ /* unused cell-- make a notation */
|
||||
if (start < 0) start = next;
|
||||
end = next;
|
||||
}
|
||||
else
|
||||
{
|
||||
prt_unused(&start, &end);
|
||||
printf("%3x:%04x %02x %04x\n", page, next,
|
||||
CORRPAGE(get_byte(page, next)), get_word(page, next+1));
|
||||
}
|
||||
} /* end: for next=0; next<=page_length-PTRSIZE; next+=PTRSIZE) */
|
||||
prt_unused(&start, &end);
|
||||
if (rlsmem (unused_cells, number_of_cells))
|
||||
{
|
||||
rlsmem_error(rtn_name);
|
||||
}
|
||||
end_routine:
|
||||
} /* end of function: dump_ref(page) */
|
||||
***** Code for dump_ref turned off 6 July 1985 by John Jensen *****/
|
||||
|
||||
/**********************************************************************/
|
||||
/* Produce a Formatted Dump of a String/Symbol Page */
|
||||
/**********************************************************************/
|
||||
dump_str(page, disp, length)
|
||||
int page, disp, length;
|
||||
{
|
||||
int end_disp = disp + length; /* display only between disp and end_disp */
|
||||
char buffer[70]; /* print line buffer */
|
||||
int ch; /* character (byte) begin formatted */
|
||||
int char_ptr; /* pointer into print line buffer */
|
||||
int count; /* count of bytes in print line buffer */
|
||||
int first_time; /* flag indicating first time through loop */
|
||||
int hex_ptr; /* pointer into print line buffer */
|
||||
int hold_addr; /* address value to print */
|
||||
int i,j; /* index variables */
|
||||
int incr; /* adjustment for header overhead */
|
||||
int next = 0; /* pointer to next block of memory in page */
|
||||
int page_length; /* length in bytes of the page we're dumping */
|
||||
int size; /* size of string/symbol in bytes */
|
||||
int type; /* type code block of memory */
|
||||
static char hex_digit[16] = {'0','1','2','3','4','5','6','7','8','9',
|
||||
'A','B','C','D','E','F'};
|
||||
ENTER(dump_str);
|
||||
|
||||
page_length = psize[page];
|
||||
while (next <= page_length - BLK_OVHD) {
|
||||
type = (i = get_byte(page, next)) & 0x003F;
|
||||
size = get_word(page, next+1);
|
||||
if (size < 0) size = BLK_OVHD + PTRSIZE; /* check for small string */
|
||||
ASSERT(size >= 3 && size <= page_length - next /* invalid size */);
|
||||
if (next+size >= disp && next <= end_disp) {
|
||||
if (type == FREETYPE) {
|
||||
printf("%3x:%04x unused block of %x (hex) bytes\n",
|
||||
page, next, size);
|
||||
}
|
||||
else /* type != FREETYPE */ {
|
||||
printf("%3x:%04x %02x %04x block type = %d size = %d (decimal) bytes\n",
|
||||
page, next, i, size, type, size);
|
||||
if (type == SYMTYPE) {
|
||||
printf(" Link: %02x %04x Hash Key: %02x\n",
|
||||
get_byte(page,next+3), get_word(page,next+4),
|
||||
get_byte(page,next+6));
|
||||
incr = 7;
|
||||
}
|
||||
else incr = 3;
|
||||
for (first_time = 1, count = 16, i = next+incr; i < next+size; i++) {
|
||||
INTR_OUTPUT;
|
||||
if (count >= 16) {
|
||||
if (!first_time) printf("%3x:%04x %s\n", page, hold_addr, buffer);
|
||||
hold_addr = i;
|
||||
for (j = 0; j < sizeof(buffer); j++) buffer[j] = ' ';
|
||||
buffer[49] = buffer[66] = '|';
|
||||
buffer[sizeof(buffer)-1] = '\0';
|
||||
hex_ptr = count = first_time = 0;
|
||||
char_ptr = 50;
|
||||
} /* end: if (then clause) */
|
||||
if ((ch = get_byte(page, i)) != '\0') buffer[char_ptr] = ch;
|
||||
buffer[hex_ptr] = hex_digit[ch >> 4];
|
||||
buffer[hex_ptr+1] = hex_digit[ch & 0x000F];
|
||||
count++;
|
||||
char_ptr++;
|
||||
hex_ptr += 3;
|
||||
} /* end for ... */
|
||||
printf("%3x:%04x %s\n", page, hold_addr, buffer);
|
||||
} /* end else */
|
||||
} /* end if */
|
||||
next += size;
|
||||
} /* end: while (next < page_length) */
|
||||
bye:
|
||||
} /* end of function: dump_str(page, disp, length) */
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/* Format a Page Containing Code Blocks */
|
||||
/**********************************************************************/
|
||||
dump_code(page, start, length)
|
||||
int page, start, length;
|
||||
{
|
||||
/*%%int ch; /* character (byte) begin formatted */*/
|
||||
/*%%int char_ptr; /* pointer into print line buffer */*/
|
||||
/*%%int count; /* count of bytes in print line buffer */*/
|
||||
int disp;
|
||||
int end; /* end of print range */
|
||||
int ent; /* entry offset of code */
|
||||
/*%%int first_time; /* flag indicating first time through loop */*/
|
||||
/*%%int hex_ptr; /* pointer into print line buffer */*/
|
||||
/*%%int hold_addr; /* address value to print */*/
|
||||
/*%%int i,j; /* index variables */*/
|
||||
int next = 0; /* pointer to next block of memory in page */
|
||||
int page_length; /* length in bytes of the page we're dumping */
|
||||
int pc;
|
||||
int size; /* size of string/symbol in bytes */
|
||||
int tag; /* page number field of a constant ptr */
|
||||
char *title; /* pointer to "constants" title */
|
||||
int type; /* type code block of memory */
|
||||
/*%%static char hex_digit[16] = {'0','1','2','3','4','5','6','7','8','9',*/
|
||||
/*%% 'A','B','C','D','E','F'};*/
|
||||
ENTER(dump_code);
|
||||
|
||||
end = start + length;
|
||||
page_length = psize[page];
|
||||
while (next <= page_length - BLK_OVHD) {
|
||||
type = get_byte(page, next) & 0x003F;
|
||||
size = get_word(page, next+1);
|
||||
ASSERT(size >= 3 && size <= page_length - next /* invalid size */);
|
||||
if (type == FREETYPE) {
|
||||
if ((next >= start && next <= end) ||
|
||||
(next+size > start && next+size <= end) ||
|
||||
(next <= start && next+size-1 >= end)) {
|
||||
printf("%3x:%04x unused block of %d (decimal) bytes\n",
|
||||
page, next, size);
|
||||
}
|
||||
}
|
||||
else /* type != FREETYPE */ {
|
||||
ent = get_word(page, next+4);
|
||||
if (next >= start && next <= end) {
|
||||
printf(
|
||||
"%3x:%04x %02x %04x block type = %d size = %d (decimal) bytes\n",
|
||||
page, next, type, size, type, size);
|
||||
printf("Code begins at %d (decimal)\n", ent);
|
||||
}
|
||||
pc = next + PTRSIZE*2;
|
||||
title = "Constants:\n";
|
||||
while (pc < next + ent) {
|
||||
INTR_OUTPUT;
|
||||
if (pc >= start && pc <= end) {
|
||||
tag = CORRPAGE(get_byte(page, pc));
|
||||
disp = get_word(page, pc+1);
|
||||
printf("%s%3x:%04x ", title, page, pc);
|
||||
annotate(tag, disp); /* describe what's being pointed at */
|
||||
title = ""; /* print heading only once */
|
||||
}
|
||||
pc += PTRSIZE;
|
||||
} /* end: while (pc < next + entry) */
|
||||
|
||||
/* format the instructions in the block */
|
||||
while (pc < next + size) {
|
||||
INTR_OUTPUT;
|
||||
t_inst(page, &pc, 0, (pc >= start && pc <= end));
|
||||
} /* end: while (pc < next + size) */
|
||||
} /* end: else */
|
||||
next += size;
|
||||
} /* end: while (next < page_length) */
|
||||
bye:
|
||||
} /* end of function: dump_code(page, start, length) */
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/* Dump the port page */
|
||||
/* */
|
||||
/* Note: DISP and LENGTH arguments are not used here. */
|
||||
/**********************************************************************/
|
||||
/*****
|
||||
dump_port(page,disp,length)
|
||||
int page,disp,length;
|
||||
{
|
||||
int c; /* Next input character */
|
||||
int csrcol; /* Port cursor column */
|
||||
int i; /* Index variable */
|
||||
int lnlen; /* Port line length */
|
||||
int next = 0; /* Pointer to next block in page */
|
||||
int page_length; /* Length in bytes of page */
|
||||
int ptype; /* Type of port */
|
||||
int size; /* Size of port in bytes */
|
||||
int type; /* Type code block of memory */
|
||||
|
||||
ENTER(dump_port);
|
||||
|
||||
page_length = psize[page];
|
||||
while (next < page_length)
|
||||
{
|
||||
type = get_byte(page,next) & 0x003F;
|
||||
size = get_word(page,next+1);
|
||||
ASSERT(size >= 46 && size <= page_length - next /* invalid size */);
|
||||
if (type == FREETYPE)
|
||||
{
|
||||
printf("%3x:%04x unused block of %d (decimal) bytes\n",
|
||||
page,next,size);
|
||||
}
|
||||
else /* type != FREETYPE */
|
||||
{
|
||||
printf(
|
||||
"%3x:%04x %02x %04x block type = %d size = %d (decimal) bytes \n",
|
||||
page, next, type, size, type, size);
|
||||
ptype = get_byte(page,next+3);
|
||||
switch (ptype)
|
||||
{
|
||||
case 0:
|
||||
printf(" Output port writing to ");
|
||||
break;
|
||||
case 1:
|
||||
printf(" Input port receiving from ");
|
||||
break;
|
||||
}
|
||||
/* Now print file name */
|
||||
i = 10;
|
||||
while ((i < 18) && ((c = get_byte(page,next+i)) != ' '))
|
||||
{
|
||||
printf("%c",toupper(c));
|
||||
i++;
|
||||
}
|
||||
i = 18;
|
||||
printf(".");
|
||||
while ((i < 21) && ((c = get_byte(page,next+i)) != ' '))
|
||||
{
|
||||
printf("%c", toupper(c));
|
||||
i++;
|
||||
}
|
||||
printf("\n");
|
||||
lnlen = get_word(page,next+4);
|
||||
csrcol = get_word(page,next+6);
|
||||
switch (ptype)
|
||||
{
|
||||
case 0:
|
||||
printf(" Line length: %d Print column: %d\n",
|
||||
lnlen, csrcol);
|
||||
break;
|
||||
case 1:
|
||||
c = get_byte(page, next+8);
|
||||
printf(" Most recent character: %02x\n",c);
|
||||
break;
|
||||
}
|
||||
} /* End of ELSE */
|
||||
next += size;
|
||||
} /* End of WHILE */
|
||||
} /* End of function: dump_port(page,disp,length) */
|
||||
*****/
|
||||
|
||||
/**********************************************************************/
|
||||
/* Format a Page Containing Arrays or Continuations */
|
||||
/**********************************************************************/
|
||||
dump_ary(page, disp, length)
|
||||
int page, disp, length;
|
||||
{
|
||||
/*%%int ent; /* entry offset of code */*/
|
||||
int start_disp = disp; /* only values in range start_disp..end_disp
|
||||
are displayed */
|
||||
int end_disp = disp + length;
|
||||
int i;
|
||||
unsigned next = 0; /* pointer to next block of memory in page */
|
||||
unsigned page_length; /* length of the current page in bytes */
|
||||
int pc;
|
||||
unsigned size; /* size of string/symbol in bytes */
|
||||
int tag; /* page number field of a constant ptr */
|
||||
int type; /* type code block of memory */
|
||||
ENTER(dump_ary);
|
||||
|
||||
page_length = psize[page];
|
||||
while (next <= page_length - BLK_OVHD) {
|
||||
type = get_byte(page, next) & 0x003F;
|
||||
size = get_word(page, next+1);
|
||||
ASSERT(size >= 3 && size <= page_length - next /* invalid size */);
|
||||
if (next+size >= start_disp && next <= end_disp) {
|
||||
if (type == FREETYPE) {
|
||||
printf("%3x:%04x unused block of %d (decimal) bytes\n",
|
||||
page, next, size);
|
||||
}
|
||||
else /* type != FREETYPE */ {
|
||||
printf(
|
||||
"%3x:%04x %02x %04x tag = %d (%s) size = %d (decimal) bytes\n",
|
||||
page, next, type, size, type, page_type[type], size);
|
||||
pc = next + PTRSIZE;
|
||||
while (pc < next + size) {
|
||||
INTR_OUTPUT;
|
||||
tag = CORRPAGE(get_byte(page, pc));
|
||||
disp = get_word(page, pc+1);
|
||||
/* see if following array entries are same as the current one */
|
||||
for (i = pc + PTRSIZE; i < next + size; i += PTRSIZE) {
|
||||
if (tag != CORRPAGE(get_byte(page, i)) ||
|
||||
disp != get_word(page, i+1)) break;
|
||||
} /* end for (i = pc + PTRSIZE; ... */
|
||||
if (i >= start_disp && pc+PTRSIZE <= end_disp) {
|
||||
if (i > pc + PTRSIZE) { /* consecutive entries with same value? */
|
||||
/* if so, print address range */
|
||||
printf("%3x:%04x-%2x:%04x ", page, pc, page, i-PTRSIZE);
|
||||
}
|
||||
else /* no consecutive entries with same value */ {
|
||||
printf("%3x:%04x ", page, pc);
|
||||
} /* end else */
|
||||
annotate(tag, disp); /* describe what's being pointed at */
|
||||
} /* end if (i >= disp ... */
|
||||
pc = i;
|
||||
} /* end while (pc < next + size) */
|
||||
} /* end else */
|
||||
} /* end if */
|
||||
next += size;
|
||||
} /* end: while (next < page_length) */
|
||||
bye:
|
||||
} /* end of function: dump_ary(page, disp, length) */
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/* Dump the runtime stack */
|
||||
/**********************************************************************/
|
||||
dump_stk()
|
||||
{
|
||||
int next;
|
||||
int ptr_disp, ptr_page;
|
||||
ENTER(dump_stk);
|
||||
|
||||
/* print the value of PREV_reg and the stack base */
|
||||
prt_reg(-4);
|
||||
printf("BASE %04x (%u decimal)\n", BASE, BASE);
|
||||
|
||||
/* print active Stack Cells */
|
||||
for (next = 0; next <= TOS; next += PTRSIZE) {
|
||||
INTR_OUTPUT;
|
||||
ptr_page = CORRPAGE(S_stack[next]);
|
||||
ptr_disp = (S_stack[next+2]<<8) + S_stack[next+1];
|
||||
printf("%s%04x ", (next==FP ? "FP->" : " "), next + BASE);
|
||||
|
||||
/* for values, show the value the stack entry points to */
|
||||
annotate(ptr_page, ptr_disp);
|
||||
|
||||
} /* end: for (next = 0; next <= TOS; next += PTRSIZE) */
|
||||
bye:
|
||||
} /* end of function: dump_stk() */
|
||||
|
||||
|
||||
prt_unused(start, end)
|
||||
int *start, *end;
|
||||
{
|
||||
ENTER(prt_unused);
|
||||
if (*start >= 0)
|
||||
{
|
||||
if (*start == *end)
|
||||
printf("Location %04x unused\n", *start);
|
||||
else
|
||||
printf("Locations %04x-%04x unused\n", *start, *end);
|
||||
*start = *end = -1;
|
||||
}
|
||||
} /* end of function: prt_unused(start, end) */
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/* Dump the VM's Registers */
|
||||
/**********************************************************************/
|
||||
dump_regs()
|
||||
{
|
||||
int i; /* the usual index variable */
|
||||
int *reg_page, *reg_disp;
|
||||
int pc = S_pc;
|
||||
long unbound; /* an "unbound" pointer */
|
||||
|
||||
long make_ptr();
|
||||
|
||||
unbound = make_ptr(UN_PAGE, UN_DISP);
|
||||
|
||||
/* Print the Contents of the general purpose registers */
|
||||
reg_page = ®0_page;
|
||||
reg_disp = ®0_disp;
|
||||
for (i = 0; i < NUM_REGS; i++, reg_page+=2, reg_disp+=2)
|
||||
if (regs[i] != unbound) prt_reg(i);
|
||||
|
||||
prt_reg(-1); /* print FNV */
|
||||
prt_reg(-3); /* print GNV */
|
||||
prt_reg(-2); /* print CB */
|
||||
if(tmp_page & 1)printf("odd tmp_page\n");
|
||||
printf("tmp_reg "); annotate(CORRPAGE(tmp_page), tmp_disp);
|
||||
(void) t_inst(CORRPAGE(CB_pag), &pc,
|
||||
/* run= */ FALSE, /* display= */ TRUE);
|
||||
} /* end of function: dump_regs() */
|
||||
|
||||
prt_reg(reg)
|
||||
int reg; /* register number to print (-2=CB, -1=FNV) */
|
||||
{
|
||||
int *disp;
|
||||
int *page;
|
||||
|
||||
page = ®0_page + reg + reg;
|
||||
disp = ®0_disp + reg + reg;
|
||||
|
||||
/* print the register name and contents */
|
||||
switch (reg) {
|
||||
case -1: printf("FNV ");
|
||||
page = &FNV_pag;
|
||||
disp = &FNV_dis;
|
||||
break;
|
||||
case -2: printf("CB ");
|
||||
page = &CB_pag;
|
||||
disp = &CB_dis;
|
||||
break;
|
||||
case -3: printf("GNV ");
|
||||
page = &GNV_pag;
|
||||
disp = &GNV_dis;
|
||||
break;
|
||||
case -4: printf("PREV ");
|
||||
page = &PREV_pag;
|
||||
disp = &PREV_dis;
|
||||
break;
|
||||
default: printf("R%d ", reg);
|
||||
}
|
||||
|
||||
/* expound on what pointer is */
|
||||
annotate(CORRPAGE(*page), *disp);
|
||||
}
|
||||
|
||||
/* Print information about what a pointer points to */
|
||||
annotate(page, disp)
|
||||
int page, disp;
|
||||
{
|
||||
int ch;
|
||||
int count;
|
||||
char dlm = '\"'; /* string/symbol delimiter */
|
||||
int i; /* index variable */
|
||||
int incr = 3; /* adjustment for string/symbol header */
|
||||
char *str; /* pointer to a character string */
|
||||
int type; /* object type code */
|
||||
double get_flo();
|
||||
|
||||
type = ptype[page]>>1;
|
||||
|
||||
printf("%2x:%04x %s", page, disp, page_type[type]);
|
||||
|
||||
/* for values, show the value the register points to */
|
||||
switch (type)
|
||||
{
|
||||
case SYMTYPE: incr = 7; /* note: control falls through STRTYPE */
|
||||
dlm = '|';
|
||||
|
||||
case STRTYPE: count = get_word(page, disp+1) - incr;
|
||||
if (count > 40) count = 40;
|
||||
disp += incr;
|
||||
printf(" %c",dlm);
|
||||
while (count > 0)
|
||||
{
|
||||
ch = get_byte(page, disp);
|
||||
printf("%c", ch); disp++; count--;
|
||||
}
|
||||
printf("%c\n",dlm);
|
||||
break;
|
||||
|
||||
case FIXTYPE: printf(" %d\n", get_fix(page, disp));
|
||||
break;
|
||||
|
||||
case FLOTYPE: printf(" %g\n", get_flo(page,disp));
|
||||
break;
|
||||
|
||||
case CHARTYPE: ch = get_char(page, disp);
|
||||
str = " ";
|
||||
*str = ch;
|
||||
for (i = 0; i < test_num; i++)
|
||||
{
|
||||
if (ch == test_char[i])
|
||||
{
|
||||
str = test_string[i];
|
||||
break;
|
||||
}
|
||||
}
|
||||
printf(" #\\%s\n", str);
|
||||
break;
|
||||
|
||||
case LISTTYPE: if (page == 0) printf(" nil");
|
||||
default: printf("\n");
|
||||
} /* end: switch (type) */
|
||||
} /* end of function: annotate(page, disp) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Dump Environment */
|
||||
/************************************************************************/
|
||||
|
||||
dump_environment(page, disp)
|
||||
int page; /* page number of current environment entry */
|
||||
int disp; /* displacement of current environment entry */
|
||||
{
|
||||
extern int display;
|
||||
extern int show;
|
||||
int search[2];
|
||||
int pair[2];
|
||||
int sym[2];
|
||||
char *symbol; /* globally bound symbol (character representation) */
|
||||
|
||||
char *symbol_name(); /* retrieves a symbol's print name */
|
||||
|
||||
search[C_PAGE] = page;
|
||||
search[C_DISP] = disp;
|
||||
while (search[C_PAGE]) {
|
||||
INTR_OUTPUT;
|
||||
|
||||
/* fetch pointer to symbol/value pair */
|
||||
mov_reg(pair, search);
|
||||
take_car(pair);
|
||||
|
||||
/* fetch pointer to symbol */
|
||||
mov_reg(sym, pair);
|
||||
take_car(sym);
|
||||
|
||||
/* retrieve symbol's print name and print said */
|
||||
symbol = symbol_name(CORRPAGE(sym[C_PAGE]), sym[C_DISP]);
|
||||
printf("%s\n", symbol);
|
||||
rlsstr(symbol);
|
||||
|
||||
/* display the value currently bound to the symbol */
|
||||
take_cdr(pair);
|
||||
annotate(CORRPAGE(pair[C_PAGE]), pair[C_DISP]);
|
||||
ssetadr(ADJPAGE(OUT_PAGE), OUT_DISP);
|
||||
display = show = 1;
|
||||
sprint(CORRPAGE(pair[C_PAGE]), pair[C_DISP], ADJPAGE(OUT_PAGE),
|
||||
OUT_DISP);
|
||||
|
||||
outchar('\015');
|
||||
outchar('\015');
|
||||
|
||||
/* follow linked list in cdr field */
|
||||
take_cdr(search);
|
||||
|
||||
} /* end: while (search[C_PAGE]) */
|
||||
bye:
|
||||
} /* end of function: dump_environment() */
|
||||
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
/* TIPC Scheme '84 Runtime Support - Error Messages
|
||||
(C) Copyright 1984,1985 by Texas Instruments Incorporated.
|
||||
All rights reserved.
|
||||
|
||||
Author: Mark E. Meyer
|
||||
Installation: Texas Instruments Incorporated, Dallas, Texas
|
||||
Division: Central Research Laboratories
|
||||
Cost Center: Computer Science Laboratory
|
||||
Project: Computer Architecture Branch
|
||||
Date Written: 3 July 1984
|
||||
Last Modification: 12 June 1985
|
||||
*/
|
||||
|
||||
#include "scheme.h"
|
||||
|
||||
|
||||
/**************************************************************/
|
||||
/* ERRMSG(code) */
|
||||
/* This simply prints whatever error message is called */
|
||||
/* for by CODE. */
|
||||
/**************************************************************/
|
||||
errmsg(code)
|
||||
int code;
|
||||
{
|
||||
switch (code)
|
||||
{
|
||||
case QUOTERR:
|
||||
printf("Bad quote form\n");
|
||||
break;
|
||||
case DOTERR:
|
||||
printf("Bad dot form\n");
|
||||
break;
|
||||
case RPARERR:
|
||||
printf(") before (\n");
|
||||
break;
|
||||
case PORTERR:
|
||||
printf("Wrong port direction\n");
|
||||
break;
|
||||
case FULLERR:
|
||||
printf("Disk full\n");
|
||||
break;
|
||||
case HEAPERR:
|
||||
printf("Heap space exhausted\n");
|
||||
printf("Press any key to return to Scheme toplevel.\n"); /*rb*/
|
||||
getch(); /*rb*/
|
||||
rbrk(); /*rb*/
|
||||
force_re(); /* we won't return */ /*rb*/
|
||||
break;
|
||||
case OVERERR:
|
||||
printf("Flonum overflow\n");
|
||||
break;
|
||||
case DIV0ERR:
|
||||
printf("Divide by zero\n");
|
||||
break;
|
||||
case EOFERR:
|
||||
/* Don't print a message for end-of-file */
|
||||
break;
|
||||
case SHARPERR:
|
||||
printf("#-macro error\n");
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,330 @@
|
|||
/* =====> SERROR.C */
|
||||
/* TIPC Scheme '84 Runtime Support - Error Processors
|
||||
(C) Copyright 1984,1985 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: 13 June 1984
|
||||
Last Modification:
|
||||
(tc) 05 June 1986 - Set or Ref of Fluid variable which is not
|
||||
defined in fluid environment is now non-
|
||||
restartable from error processor or inspector.
|
||||
(rb) 21 Jan 1988 - getmem errors return to Scheme toplevel rather
|
||||
than aborting to DOS
|
||||
(tc) 16 Feb 1988 - added PRO_ERROR routine for protected mode
|
||||
|
||||
*/
|
||||
#include "ctype.h"
|
||||
#include "scheme.h"
|
||||
|
||||
#include "slist.h"
|
||||
|
||||
static char digits[10]={'0','1','2','3','4','5','6','7','8','9'};
|
||||
static char bdigits[10]={' ','1','2','3','4','5','6','7','8','9'};
|
||||
|
||||
/************************************************************************/
|
||||
/* Wrong Number of Arguments to a Closure */
|
||||
/************************************************************************/
|
||||
#define NUM_ARGS 16 /* offset of operand count in a closure object */
|
||||
wrong_args(args_passed, closure)
|
||||
int args_passed; /* number of arguments passed */
|
||||
int closure[2]; /* pointer to called closure object */
|
||||
{
|
||||
int args_expected; /* the number of arguments expected */
|
||||
/*%%int i; /* our old friend the index variable */*/
|
||||
int page,disp; /* page/displacement parts of closure pointer */
|
||||
/*%%long *this_reg; /* pointer to a register during fixup */*/
|
||||
/*%%long unbound; /* pointer to the symbol ***unbound*** */*/
|
||||
|
||||
static char *msg=
|
||||
"Invalid argument count: Function expected xx argument(s)\nbut was called with yy as follows:";
|
||||
/* 11111111112222222222333333333344444444445555555 5556666666666777777777788888888889
|
||||
012345678901234567890123456789012345678901234567890123456 7890123456789012345678901234567890
|
||||
*/
|
||||
static int insert_offset = 77; /* offset in msg for arguments passed */
|
||||
|
||||
long make_ptr(); /* makes a Scheme pointer from page, disp */
|
||||
ENTER(wrong_args);
|
||||
|
||||
/* determine the number of arguments expected */
|
||||
page = CORRPAGE(closure[C_PAGE]);
|
||||
disp = closure[C_DISP];
|
||||
if (ptype[page] == CONTTYPE*2)
|
||||
{
|
||||
args_expected = 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
args_expected = get_fix(SPECFIX, get_word(page, disp+NUM_ARGS));
|
||||
if (args_expected < 0) args_expected = ~ args_expected;
|
||||
}
|
||||
|
||||
/* Insert arguments expected into error message text */
|
||||
msg[42] = bdigits[args_expected / 10];
|
||||
msg[43] = digits[args_expected % 10];
|
||||
|
||||
/* set Scheme variables to reflect error condition */
|
||||
arg_err(closure, args_passed, msg, insert_offset);
|
||||
|
||||
/***** Argument "fixup" code turned off 25 July 1985 (JCJ) *****
|
||||
/* if too few arguments, set undefined registers to "***unbound***" */
|
||||
if (args_expected > args_passed)
|
||||
{
|
||||
unbound = make_ptr(UN_PAGE, UN_DISP); /* create ***unbound*** pointer */
|
||||
this_reg = (®0)+args_expected; /* pointer to last undefined register */
|
||||
while (args_expected > args_passed)
|
||||
{
|
||||
*this_reg = unbound; /* set register contents to ***unbound*** */
|
||||
this_reg--;
|
||||
args_expected--;
|
||||
} /* end: while (args_expected > args_passed) */
|
||||
} /* end: if (args_expected > args_passed) */
|
||||
***** Argument "fixup" code turned off 25 July 1985 (JCJ) *****/
|
||||
|
||||
} /* end of function: wrong_args(args_passed, closure) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Local Support-- Cons up "call" expression, output message text */
|
||||
/************************************************************************/
|
||||
arg_err(ftn, args_passed, msg, offset)
|
||||
int ftn[2]; /* function object */
|
||||
int args_passed; /* the count of arguments passed */
|
||||
char *msg; /* the error message text */
|
||||
int offset; /* offset in "msg" for inserting argument count */
|
||||
{
|
||||
int i; /* index variable */
|
||||
long *this_reg; /* pointer to a register during "consing" */
|
||||
|
||||
/* insert count of arguments passed into the error message string */
|
||||
msg[offset] = bdigits[args_passed / 10];
|
||||
msg[offset+1] = digits[args_passed % 10];
|
||||
|
||||
/* cons up the function and arguments into a list */
|
||||
this_reg = (®0)+args_passed; /* pointer to last argument register */
|
||||
tmp_page = tmp_disp = 0; /* initialize end-of-list to nil */
|
||||
for (i = 0; i < args_passed; i++, this_reg--)
|
||||
cons(tmp_reg, this_reg, tmp_reg);
|
||||
cons(tmp_reg, ftn, tmp_reg); /* put procedure object at front of list */
|
||||
|
||||
/* set up the error message text and irritant */
|
||||
set_error(1, msg, tmp_reg);
|
||||
} /* end of function: arg_err(ftn, args_passed, msg, offset) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Error-- Attempted to call a non-procedural object */
|
||||
/************************************************************************/
|
||||
not_proc(non_ftn_obj, args_passed)
|
||||
int non_ftn_obj[2]; /* pointer to object in functional position */
|
||||
int args_passed; /* the number of arguments in the call */
|
||||
{
|
||||
static char *msg=
|
||||
"Attempt to call a non-procedural object with xx argument(s) as follows:";
|
||||
/* 1111111111222222222233333333334444444444555555555566666666667
|
||||
012345678901234567890123456789012345678901234567890123456 7890123456789 */
|
||||
static int insert_offset = 45; /* offset in msg for argument count */
|
||||
|
||||
arg_err(non_ftn_obj, args_passed, msg, insert_offset);
|
||||
} /* end of function: not_proc(non_ftn_obj, args_passed) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Error-- Symbol Not Fluidly Bound */
|
||||
/************************************************************************/
|
||||
not_fluidly_bound(page,disp,source)
|
||||
int page; /* symbol's page number */
|
||||
int disp; /* symbol's displacement */
|
||||
int source[2]; /* register containing the value to be bound */
|
||||
{
|
||||
/* create pointer to symbol and set up error parameters */
|
||||
tmp_page = ADJPAGE(page);
|
||||
tmp_disp = disp;
|
||||
set_numeric_error(1, SET_FLUID_ERROR, tmp_reg);
|
||||
|
||||
} /* end of function: not_fluidly_bound(page,disp,source) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Error-- Symbol Not Globally Bound */
|
||||
/************************************************************************/
|
||||
not_globally_bound(page,disp,source)
|
||||
int page; /* symbol's page number */
|
||||
int disp; /* symbol's displacement */
|
||||
int source[2]; /* register containing the value to be bound */
|
||||
{
|
||||
/* create pointer to symbol and set up error parameters */
|
||||
tmp_page = ADJPAGE(page);
|
||||
tmp_disp = disp;
|
||||
set_numeric_error(0, SET_GLOBAL_ERROR, tmp_reg);
|
||||
|
||||
} /* end of function: not_globally_bound(page,disp,source) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Error-- Symbol Not Lexically Bound */
|
||||
/************************************************************************/
|
||||
not_lexically_bound(page, disp)
|
||||
int page; /* symbol's page number */
|
||||
int disp; /* symbol's displacement */
|
||||
{
|
||||
/* create pointer to symbol and set up error parameters */
|
||||
tmp_page = ADJPAGE(page);
|
||||
tmp_disp = disp;
|
||||
set_numeric_error(0, SET_LEXICAL_ERROR, tmp_reg);
|
||||
|
||||
} /* end of function: not_lexically_bound(page, disp) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Error-- Symbol Not Bound */
|
||||
/************************************************************************/
|
||||
sym_undefined(page,disp,env,dest)
|
||||
int page; /* symbol's page number */
|
||||
int disp; /* symbol's displacement */
|
||||
int env[2]; /* the environment supposed to contain said symbol */
|
||||
int dest[2]; /* register into which the value was to be loaded */
|
||||
{
|
||||
int error_number; /* numeric error code */
|
||||
int error_restart; /* Can you resume from error? 0=yes,1=no */
|
||||
|
||||
error_restart = 0; /* Default to resumable */
|
||||
if (env == GNV_reg)
|
||||
error_number = REF_GLOBAL_ERROR;
|
||||
else
|
||||
{
|
||||
if (env == FNV_reg)
|
||||
{
|
||||
error_number = REF_FLUID_ERROR;
|
||||
error_restart = 1; /* Can't continue from fluid error */
|
||||
}
|
||||
else
|
||||
error_number = REF_LEXICAL_ERROR;
|
||||
}
|
||||
|
||||
/* create pointer to undefined symbol and set message parameters */
|
||||
tmp_page = ADJPAGE(page);
|
||||
tmp_disp = disp;
|
||||
set_numeric_error(error_restart, error_number, tmp_reg);
|
||||
|
||||
} /* end of function: sym_undefined(page,disp,env,dest) */
|
||||
|
||||
/************************************************************************/
|
||||
/* getmem error */
|
||||
/************************************************************************/
|
||||
getmem_error(routine)
|
||||
char *routine;
|
||||
{
|
||||
void rbrk();
|
||||
void force_re();
|
||||
|
||||
printf("[VM INTERNAL ERROR] %s: getmem error\n", routine);
|
||||
printf("Press any key to return to Scheme toplevel.\n"); /*rb*/
|
||||
getch();
|
||||
rbrk(); /*rb*/
|
||||
force_re(); /* we won't return */ /*rb*/
|
||||
exit();
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* rlsmem error */
|
||||
/************************************************************************/
|
||||
rlsmem_error(routine)
|
||||
char *routine;
|
||||
{
|
||||
printf("[VM INTERNAL ERROR] %s: rlsmem error", routine);
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* set error condition */
|
||||
/************************************************************************/
|
||||
set_error(code, message, irritant)
|
||||
int code; /* error condition code */
|
||||
char *message; /* text of error condition */
|
||||
int irritant[2]; /* object causing the error */
|
||||
{
|
||||
/* bind error code to the symbol |*error-code*| */
|
||||
C_push(tmp_reg);
|
||||
intern (tm2_reg, "*ERROR-CODE*", 12);
|
||||
tmp_page = SPECFIX*2;
|
||||
tmp_disp = code & 0x7fff;
|
||||
sym_bind(tm2_reg, tmp_reg, GNV_reg);
|
||||
|
||||
/* bind error message text to the symbol |*error-message*| */
|
||||
intern (tm2_reg, "*ERROR-MESSAGE*", 15);
|
||||
alloc_string(tmp_reg, message);
|
||||
sym_bind(tm2_reg, tmp_reg, GNV_reg);
|
||||
|
||||
/* bind irritant to the symbol |*irritant*| */
|
||||
C_pop(tmp_reg);
|
||||
intern (tm2_reg, "*IRRITANT*", 10);
|
||||
sym_bind(tm2_reg, irritant, GNV_reg);
|
||||
|
||||
} /* end of function: set_error(code, message, irritant) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* set numeric error condition */
|
||||
/************************************************************************/
|
||||
set_numeric_error(code, error_number, irritant)
|
||||
int code; /* error condition code */
|
||||
int error_number; /* numeric error code for a given error condition */
|
||||
int irritant[2]; /* object causing the error */
|
||||
{
|
||||
int lcl_reg[2]; /* a temporary register for fixnum values */
|
||||
|
||||
/* bind error code to the symbol |*ERROR-CODE*| */
|
||||
intern (tm2_reg, "*ERROR-CODE*", 12);
|
||||
lcl_reg[C_PAGE] = SPECFIX*2;
|
||||
lcl_reg[C_DISP] = code & 0x7fff;
|
||||
sym_bind(tm2_reg, lcl_reg, GNV_reg);
|
||||
|
||||
/* bind error message text to the symbol |*ERROR-MESSAGE*| */
|
||||
intern (tm2_reg, "*ERROR-MESSAGE*", 15);
|
||||
lcl_reg[C_DISP] = error_number;
|
||||
sym_bind(tm2_reg, lcl_reg, GNV_reg);
|
||||
|
||||
/* bind irritant to the symbol |*IRRITANT*| */
|
||||
intern (tm2_reg, "*IRRITANT*", 10);
|
||||
sym_bind(tm2_reg, irritant, GNV_reg);
|
||||
|
||||
} /* end of function: set_numeric_error(code, error_number, irritant) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Process Invalid Source Operand Condition */
|
||||
/************************************************************************/
|
||||
set_src_err(op, args, arg1, arg2, arg3, arg4)
|
||||
char *op; /* name of instruction failing */
|
||||
int args; /* number of arguments (operands) to instruction */
|
||||
int arg1[2],arg2[2],arg3[2],arg4[2]; /* register argument(s) */
|
||||
{
|
||||
int i; /* the usual index variable */
|
||||
int *reg_ptr;
|
||||
/*%%int sym[2]; /* local "register" for symbol name */*/
|
||||
mov_reg(tmp_reg, nil_reg);
|
||||
reg_ptr = (&arg1) + args - 1;
|
||||
for (i = 0; i < args; i++, reg_ptr--)
|
||||
cons(tmp_reg, *reg_ptr, tmp_reg);
|
||||
intern(tm2_reg, op, strlen(op));
|
||||
cons(tmp_reg, tm2_reg, tmp_reg);
|
||||
set_numeric_error(1, INVALID_OPERAND_ERROR, tmp_reg);
|
||||
} /* end of function: set_src_err(op, args, arg1, arg2, arg3, arg4) */
|
||||
|
||||
|
||||
#ifdef PROMEM
|
||||
/************************************************************************/
|
||||
/* Process Protected Mode Error */
|
||||
/************************************************************************/
|
||||
pro_error(rtn,fnc,errnum)
|
||||
char *rtn,*fnc;
|
||||
int errnum;
|
||||
{
|
||||
char ch;
|
||||
printf("\nFatal Error during %s , performing %s - Error # %d",
|
||||
rtn,fnc,errnum);
|
||||
printf("\nPress any key for attempt to SCHEME-RESET");
|
||||
ch = getch();
|
||||
printf("\n[Returning to top level]\n");
|
||||
force_reset();
|
||||
}
|
||||
#endif
|
||||
|
||||
|
|
@ -0,0 +1,401 @@
|
|||
/* =====> SFASL.C */
|
||||
/* TIPC Scheme '84 Runtime Support - Fast Loader
|
||||
(C) Copyright 1984,1985 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: 28 December 1984
|
||||
Last Modification: 18 October 1985
|
||||
*/
|
||||
#include "stdio.h"
|
||||
#include "scheme.h"
|
||||
#include "slist.h"
|
||||
|
||||
#define skip_space() while(isspace(sgetc()));
|
||||
|
||||
/* data structures to control file access */
|
||||
#define NUM_FILES 4 /* the maximum recursion of "%fasl" operations */
|
||||
#define BUF_LENGTH 4096 /* buffer length for fasl files */
|
||||
#define READ 0 /* file access code for "read" */
|
||||
#define CTL_Z 0x1A /* MS-DOS end-of-file character */
|
||||
static char *buffer; /* character string buffer */
|
||||
static int ch = 0; /* the current character */
|
||||
static int file_no = -1; /* the current file number */
|
||||
static char *file_buffer[NUM_FILES] = {0,0,0,0}; /* character buffers */
|
||||
static int file_handle[NUM_FILES] = {0,0,0,0}; /* handles for open files */
|
||||
static char *file_pos[NUM_FILES] = {0,0,0,0}; /* current position in buffer */
|
||||
static int file_end[NUM_FILES] = {0,0,0,0}; /* end of buffer */
|
||||
|
||||
static char *f_pos = NULL;
|
||||
static char *f_end = NULL;
|
||||
|
||||
static int zeros[3] = {0,0,0};
|
||||
|
||||
char *getmem(); /* Lattice C's memory allocation routine */
|
||||
|
||||
/************************************************************************/
|
||||
/* Read In a Fast Load Format Object Module */
|
||||
/************************************************************************/
|
||||
fasl(reg)
|
||||
int reg[2]; /* parameter register */
|
||||
{
|
||||
char lcl_buffer[256]; /* character string buffer */
|
||||
int codebytes; /* the number of codebytes in a code block */
|
||||
int constants; /* the number of constants in a code block */
|
||||
int disp; /* displacement portion of a pointer */
|
||||
int i; /* index variable */
|
||||
int len; /* length of a character string or symbol */
|
||||
int page; /* page number portion of a pointer */
|
||||
int retstat = 0; /* the return code */
|
||||
int type; /* type code for parameter pointer */
|
||||
int dummy; /* dummy variable for zopen - dbs */
|
||||
|
||||
static max_nest[2] = {NUM_FILES, SPECFIX*2}; /* maximum FSL nesting level */
|
||||
|
||||
ENTER (sfasl);
|
||||
|
||||
buffer = lcl_buffer;
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
disp = reg[C_DISP];
|
||||
type = ptype[page];
|
||||
|
||||
if (type == STRTYPE*2)
|
||||
{
|
||||
if(file_no >= NUM_FILES-1)
|
||||
{
|
||||
set_error(1, "FAST-LOAD nesting too deep. Maximum is", max_nest);
|
||||
retstat = -1;
|
||||
goto return_eof;
|
||||
}
|
||||
len = get_word(page,disp+1);
|
||||
if (len < 0)
|
||||
len = len + BLK_OVHD;
|
||||
else
|
||||
len = len - BLK_OVHD;
|
||||
get_str(buffer, page, disp);
|
||||
buffer[len] = '\0';
|
||||
file_no++;
|
||||
if ((i = zopen(&file_handle[file_no], buffer, READ, &dummy, &dummy)))
|
||||
{
|
||||
/* alloc_string(tmp_reg, buffer); */
|
||||
/* set_error(0, "Unable to open FAST-LOAD file", tmp_reg); */
|
||||
/* retstat = -1; */
|
||||
/* file_no--; */
|
||||
/* goto return_eof; */
|
||||
|
||||
/* Call to dos_err will not return */
|
||||
i += IO_ERROR_START;
|
||||
alloc_string(tmp_reg, buffer);
|
||||
dos_err(1,i,tmp_reg);
|
||||
}
|
||||
if (!(file_pos[file_no] = (file_buffer[file_no] =
|
||||
getmem(BUF_LENGTH)))) getmem_error(rtn_name);
|
||||
file_end[file_no] = 0;
|
||||
}
|
||||
|
||||
f_pos = file_pos[file_no];
|
||||
f_end = file_buffer[file_no] + (file_end[file_no]);
|
||||
|
||||
ASSERT (file_no >= 0 /* make sure file exists */);
|
||||
|
||||
/* read and validate fasl program header; get # constants and codebytes */
|
||||
skip_space();
|
||||
while (ch == '#')
|
||||
{
|
||||
for (i = 0; i < 11; i++)
|
||||
if (sgetc() != "!fast-load "[i]) goto invalid_fasl;
|
||||
while (sgetc() != '\n') /* do nothing */ ;
|
||||
skip_space();
|
||||
}
|
||||
if (ch == EOF || ch == CTL_Z) goto close_file;
|
||||
if (ch != 'h') goto invalid_fasl;
|
||||
constants = next_word();
|
||||
codebytes = next_word();
|
||||
|
||||
/* allocate and zero the code block */
|
||||
alloc_block(reg, CODETYPE, constants*PTRSIZE + PTRSIZE + codebytes);
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
disp = reg[C_DISP];
|
||||
zero_blk(page, disp);
|
||||
disp += BLK_OVHD;
|
||||
|
||||
/* insert the entry point offset */
|
||||
put_ptr(page, disp, SPECFIX*2, constants*PTRSIZE + PTRSIZE +BLK_OVHD);
|
||||
|
||||
/* process the constants list entries */
|
||||
disp = PTRSIZE + BLK_OVHD;
|
||||
while (constants--)
|
||||
{
|
||||
if (read_constant()) goto invalid_fasl;
|
||||
put_ptr(CORRPAGE(reg[C_PAGE]), reg[C_DISP]+disp, tmp_page, tmp_disp);
|
||||
disp += PTRSIZE;
|
||||
} /* end: while (constants--) */
|
||||
|
||||
/* validate the "text" portion header and read in bytecodes */
|
||||
skip_space();
|
||||
if (ch != 't') goto invalid_fasl;
|
||||
zap_chars(reg, disp, codebytes);
|
||||
|
||||
/* validate the fasl module trailer */
|
||||
skip_space();
|
||||
if (ch == 'z')
|
||||
{
|
||||
file_pos[file_no] = f_pos;
|
||||
goto end_of_function;
|
||||
}
|
||||
|
||||
invalid_fasl:
|
||||
set_error(0, "Invalid FAST-LOAD module", nil_reg);
|
||||
retstat = -1;
|
||||
|
||||
close_file:
|
||||
zclose(file_handle[file_no]);
|
||||
if (rlsmem(file_buffer[file_no], BUF_LENGTH))
|
||||
rlsmem_error(rtn_name);
|
||||
file_no--;
|
||||
return_eof:
|
||||
reg[C_PAGE] = EOF_PAGE*2;
|
||||
reg[C_DISP] = EOF_DISP;
|
||||
|
||||
end_of_function:
|
||||
return(retstat);
|
||||
} /* end of function: fasl(reg) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Read In a Constant Entry */
|
||||
/************************************************************************/
|
||||
read_constant()
|
||||
{
|
||||
int disp; /* displacement component of a pointer */
|
||||
int i; /* index variable */
|
||||
int len; /* length of a string or symbol */
|
||||
int lpage=0; /* page number for a list cell */
|
||||
int page; /* page number component of a pointer */
|
||||
|
||||
double next_flonum(); /* reads a flonum from the input file */
|
||||
|
||||
tail_recursion:
|
||||
skip_space();
|
||||
switch(ch)
|
||||
{
|
||||
case 'x': /* symbol */
|
||||
len = next_byte();
|
||||
for (i = 0; i < len; i++) buffer[i] = sgetc();
|
||||
intern(tmp_reg, buffer, len);
|
||||
break;
|
||||
|
||||
case 'i': /* short integer constant */
|
||||
tmp_page = SPECFIX*2;
|
||||
tmp_disp = next_word();
|
||||
break;
|
||||
|
||||
case 'l': /* list cell */
|
||||
if (nextcell[listpage] != END_LIST)
|
||||
{
|
||||
tmp_page = ADJPAGE(listpage);
|
||||
tmp_disp = nextcell[listpage];
|
||||
nextcell[listpage] = get_word(listpage, tmp_disp+1);
|
||||
}
|
||||
else
|
||||
alloc_list_cell(tmp_reg);
|
||||
toblock(tmp_reg, 0, zeros, LISTSIZE);
|
||||
if (lpage)
|
||||
{ /* we're building a linked list-- update previous cdr */
|
||||
C_pop(tm2_reg);
|
||||
put_ptr((lpage=CORRPAGE(tm2_page)), tm2_disp+3, tmp_page,
|
||||
tmp_disp);
|
||||
}
|
||||
else
|
||||
{ /* starting a list-- preserve list header pointer */
|
||||
C_push(tmp_reg);
|
||||
}
|
||||
C_push(tmp_reg); /* record this list cell's location */
|
||||
if (stkspc() < 64)
|
||||
{
|
||||
stk_ovfl:
|
||||
printf("\n[VM ERROR encountered!] PC stack overflow during FAST-LOAD\n%s%s",
|
||||
"Attempting to execute SCHEME-RESET\n",
|
||||
"[Returning to top level]\n");
|
||||
force_reset();
|
||||
}
|
||||
read_constant();
|
||||
/*********
|
||||
C_pop(tm2_reg); /* restore current list cell pointer */
|
||||
C_push(tm2_reg); /* save for next iteration */
|
||||
**********/
|
||||
put_ptr((lpage=CORRPAGE((int) S_stack[TOS])),
|
||||
*((int *) (S_stack+TOS+1)), tmp_page, tmp_disp);
|
||||
goto tail_recursion;
|
||||
|
||||
case 'n': /* null pointer */
|
||||
tmp_page = tmp_disp = 0;
|
||||
break;
|
||||
|
||||
case 's': /* string constant */
|
||||
len = next_word();
|
||||
alloc_block(tmp_reg, STRTYPE, len);
|
||||
zap_chars(tmp_reg, 3, len);
|
||||
break;
|
||||
|
||||
case 'c': /* character constant */
|
||||
tmp_page = SPECCHAR*2;
|
||||
tmp_disp = next_byte();
|
||||
break;
|
||||
|
||||
case 'b': /* bignum constant */
|
||||
len = next_byte();
|
||||
alloc_block(tmp_reg, BIGTYPE, len+len+1);
|
||||
page = CORRPAGE(tmp_page);
|
||||
disp = tmp_disp + BLK_OVHD;
|
||||
put_byte(page, disp++, next_byte());
|
||||
while (len--)
|
||||
{
|
||||
put_word(page, disp, next_word());
|
||||
disp += WORDINCR;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'f': /* flonum constant */
|
||||
alloc_flonum(tmp_reg, next_flonum());
|
||||
break;
|
||||
|
||||
case 'v': /* vector */
|
||||
len = next_word();
|
||||
alloc_block(tm2_reg, VECTTYPE, len+len+len);
|
||||
zero_blk(CORRPAGE(tm2_page),tm2_disp);
|
||||
if (stkspc() < 64) goto stk_ovfl;
|
||||
for (i = 0, disp = BLK_OVHD; i < len; i++, disp += PTRSIZE)
|
||||
{
|
||||
C_push(tm2_reg); /* save pointer to vector object */
|
||||
read_constant(); /* read next vector entry */
|
||||
C_pop(tm2_reg); /* restore pointer to vector object */
|
||||
put_ptr(CORRPAGE(tm2_page), tm2_disp+disp, tmp_page, tmp_disp);
|
||||
} /* end: for (i = 0, etc.) */
|
||||
mov_reg(tmp_reg, tm2_reg);
|
||||
break;
|
||||
|
||||
default: /* error-- unexpected constant tag */
|
||||
/* printf("read_constant: invalid constant tag '%c'\n", ch); */
|
||||
return(1);
|
||||
|
||||
} /* end: switch(ch) */
|
||||
|
||||
/* if we're filling in the last cdr field of a linked list, fix it up */
|
||||
if (lpage)
|
||||
{
|
||||
C_pop(tm2_reg);
|
||||
put_ptr(CORRPAGE(tm2_page), tm2_disp+3, tmp_page, tmp_disp);
|
||||
C_pop(tmp_reg); /* restore list header pointer */
|
||||
}
|
||||
return(0);
|
||||
} /* end of function: read_constant() */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Read In a Hexadecimal Byte */
|
||||
/************************************************************************/
|
||||
static int low_digit[23] = {0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,
|
||||
-1,-1,-1,-1,-1,-1,-1,
|
||||
0x0A,0x0B,0x0C,0x0D,0x0E,0x0F};
|
||||
static int high_digit[23] = {0x00,0x10,0x20,0x30,0x40,0x50,0x60,0x70,0x80,0x90,
|
||||
-1,-1,-1,-1,-1,-1,-1,
|
||||
0xA0,0xB0,0xC0,0xD0,0xE0,0xF0};
|
||||
next_byte()
|
||||
{
|
||||
int value;
|
||||
skip_space();
|
||||
return(high_digit[ch - '0'] + low_digit[sgetc() - '0']);
|
||||
} /* end of function: next_byte() */
|
||||
|
||||
/************************************************************************/
|
||||
/* Read In a Hexadecimal Word */
|
||||
/************************************************************************/
|
||||
next_word()
|
||||
{
|
||||
int value;
|
||||
value = next_byte() << 8;
|
||||
return(value | next_byte());
|
||||
} /* end of function: next_word() */
|
||||
|
||||
/************************************************************************/
|
||||
/* Read In a Floating Point Value */
|
||||
/************************************************************************/
|
||||
double next_flonum()
|
||||
{
|
||||
int flo_parts[4]; /* "words" comprising a floating point value */
|
||||
int i; /* index variable */
|
||||
|
||||
/* read in the four words comprising a floating point constant */
|
||||
for (i = 0; i < 4; i++)
|
||||
flo_parts[i] = next_word();
|
||||
|
||||
/* convert "parts" of floating point value to a true floating point number */
|
||||
return(*((double *) flo_parts));
|
||||
} /* end of function: next_flonum() */
|
||||
|
||||
/************************************************************************/
|
||||
/* Read Character From Current Input File */
|
||||
/************************************************************************/
|
||||
sgetc()
|
||||
{
|
||||
int stat; /* status returned from read */
|
||||
if (f_pos >= f_end)
|
||||
{
|
||||
file_end[file_no] = BUF_LENGTH;
|
||||
if((stat = zread(file_handle[file_no], file_buffer[file_no],
|
||||
&file_end[file_no])))
|
||||
{
|
||||
printf("[VM INTERNAL ERROR] sfasl: read error status=%d\n", stat);
|
||||
}
|
||||
if ((f_pos = file_buffer[file_no]) >= (f_end = f_pos + file_end[file_no]))
|
||||
{
|
||||
return((ch = EOF));
|
||||
}
|
||||
}
|
||||
return((ch = *f_pos++));
|
||||
} /* end of function: sgetc() */
|
||||
|
||||
/************************************************************************/
|
||||
/* Copy Block of Characters from Input Buffer to Scheme Block */
|
||||
/************************************************************************/
|
||||
zap_chars(ptr, offset, len)
|
||||
int ptr[2]; /* register holding pointer to Scheme Block */
|
||||
int offset; /* beginning offset into the Scheme Block */
|
||||
int len; /* the number of characters to transfer */
|
||||
{
|
||||
int actual; /* the number of characters transfered in one move */
|
||||
|
||||
while (len)
|
||||
{
|
||||
if (f_pos >= f_end)
|
||||
{
|
||||
sgetc();
|
||||
f_pos--;
|
||||
}
|
||||
actual = f_end - f_pos;
|
||||
if (len < actual) actual = len;
|
||||
toblock(ptr, offset, f_pos, actual);
|
||||
len -= actual;
|
||||
offset += actual;
|
||||
f_pos += actual;
|
||||
} /* end: while (len) */
|
||||
} /* end of function: zap_chars(ptr, offset, len) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Reset Fasl Data Structures */
|
||||
/************************************************************************/
|
||||
reset_fasl()
|
||||
{
|
||||
while (file_no >= 0)
|
||||
{
|
||||
zclose(file_handle[file_no]);
|
||||
if (rlsmem(file_buffer[file_no], BUF_LENGTH))
|
||||
rlsmem_error("reset_fasl");
|
||||
file_no--;
|
||||
} /* end: while (file_no >= 0) */
|
||||
} /* end of function: reset_fasl() */
|
||||
|
||||
|
|
@ -0,0 +1,110 @@
|
|||
/* =====> SHASH.C */
|
||||
/* TIPC Scheme '84 Runtime Support - Symbol Support
|
||||
(C) Copyright 1984,1985,1986 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: 5 June 1984
|
||||
Last Modification: 10 Feb 1987
|
||||
|
||||
Modification History:
|
||||
10 Feb 87 - Modified the intern routine to recognize the special
|
||||
(JCJ/TC) constants #T and #F as ``true'' and ``false,''
|
||||
respectively. Also caused #!TRUE to be interned.
|
||||
In a previous "fix", I caused #!EOF to be interned,
|
||||
and this change reverses that decision. When #!EOF is
|
||||
interned, the READ procedure aborts every time it is
|
||||
read.
|
||||
*/
|
||||
#include "ctype.h"
|
||||
#include "scheme.h"
|
||||
|
||||
intern(reg, string, length)
|
||||
int reg[2]; /* "register" to return symbol's pointer */
|
||||
char *string; /* characters comprizing symbol */
|
||||
int length; /* number of characters in the symbol */
|
||||
{
|
||||
int disp; /* displacement of the symbol's entry */
|
||||
int equal; /* equality indicator */
|
||||
int hash_value; /* value returned from hashing function */
|
||||
int i,j; /* our old favorite index variables */
|
||||
int page; /* page number of the symbol's entry */
|
||||
char *ptr; /* pointer to special constant name */
|
||||
|
||||
#define NUM_SPEC 6
|
||||
static char *special_constants[NUM_SPEC] =
|
||||
{"#T", "#F", "#!FALSE", "#!NULL", "#!TRUE", "#!UNASSIGNED"};
|
||||
static int spec_len[NUM_SPEC] =
|
||||
{2, 2, 7, 6, 6, 12};
|
||||
static int spec_page[NUM_SPEC] =
|
||||
{T_PAGE*2, NIL_PAGE*2, NIL_PAGE*2, NIL_PAGE*2, T_PAGE*2, UN_PAGE*2};
|
||||
static int spec_disp[NUM_SPEC] =
|
||||
{T_DISP, NIL_DISP, NIL_DISP, NIL_DISP, T_DISP, UN_DISP};
|
||||
|
||||
if (string[0] == '#')
|
||||
{
|
||||
for (i=0; i<NUM_SPEC; i++)
|
||||
{
|
||||
if (length == spec_len[i])
|
||||
{
|
||||
for (j=0, ptr=special_constant[i]; j<length; j++)
|
||||
if (string[j] != *ptr++) goto no_match;
|
||||
reg[C_PAGE] = spec_page[i];
|
||||
reg[C_DISP] = spec_disp[i];
|
||||
goto routine_exit;
|
||||
} /* end: if (length == spec_len[i]) */
|
||||
no_match:
|
||||
} /* end: for (i=0; i<NUM_SPEC; i++) */
|
||||
} /* end: if (string[0] == '#') */
|
||||
hash_value = hash(string, length);
|
||||
if (hash_page[hash_value] != 0)
|
||||
{
|
||||
page = CORRPAGE(hash_page[hash_value]);
|
||||
disp = hash_disp[hash_value];
|
||||
while (page != 0)
|
||||
{
|
||||
if (sym_eq(page, disp, string, length))
|
||||
{
|
||||
reg[C_PAGE] = ADJPAGE(page);
|
||||
reg[C_DISP] = disp;
|
||||
goto routine_exit;
|
||||
}
|
||||
/* Follow hash chain link pointer to next symbol */
|
||||
i = CORRPAGE(get_byte(page,disp+3));
|
||||
disp = get_word(page,disp+4);
|
||||
page = i;
|
||||
} /* end: while (page != 0) */
|
||||
/* if loop exits, symbol not found-- add to oblist */
|
||||
}
|
||||
|
||||
/* add symbol to oblist */
|
||||
alloc_sym(reg, length);
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
disp = reg[C_DISP];
|
||||
put_sym(string, page, disp, hash_page[hash_value], hash_disp[hash_value],
|
||||
hash_value);
|
||||
hash_page[hash_value] = ADJPAGE(page);
|
||||
hash_disp[hash_value] = disp;
|
||||
|
||||
routine_exit:
|
||||
} /* end of function: intern(reg, string, length) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Hashing Function */
|
||||
/************************************************************************/
|
||||
/*****
|
||||
hash(sym, len)
|
||||
char *sym; /* symbol to be "hashed" */
|
||||
int len; /* number of characters in "sym" */
|
||||
{
|
||||
unsigned acc = 0;
|
||||
int i;
|
||||
for (i = 0; i < len; i++) acc += sym[i];
|
||||
return (acc % HT_SIZE);
|
||||
} /* end of function: hash(sym, len) */
|
||||
*****/
|
||||
|
||||
|
|
@ -0,0 +1,394 @@
|
|||
/* =====> SIN_OUT.C */
|
||||
/* TIPC Scheme '84 Runtime Support - File Input/Output Support
|
||||
(C) Copyright 1985 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: 4 February 1985
|
||||
Last Modification:
|
||||
14 Jan 1987 - dbs Modified to allow for random i/o.
|
||||
16 Mar 1987 - tc Dos I/O errors call DOS-ERR now.
|
||||
*/
|
||||
#include "scheme.h"
|
||||
#include "sport.h"
|
||||
#include "slist.h"
|
||||
|
||||
#define FILE_NOT_FOUND 2 /* MS-DOS error code */
|
||||
#define NON_RESTART 1 /* Operation not restartable */
|
||||
|
||||
char *getmem(); /* Lattice C's memory allocation support */
|
||||
|
||||
/************************************************************************/
|
||||
/* Open a Port */
|
||||
/************************************************************************/
|
||||
spopen(file, mode)
|
||||
int file[2]; /* pathname, 'console, nil, or #<port> */
|
||||
int mode[2]; /* 'read, 'write, 'append */
|
||||
{
|
||||
extern int prn_handle;/* handle assigned to printer *** JHAO ***/
|
||||
/*%%char buffer[BUFFSIZE];/* read buffer for positioning at end of file */*/
|
||||
int direction; /* 'read, 'write, 'append code */
|
||||
int disp; /* displacement component of a pointer */
|
||||
int handle; /* handle assigned to file by open */
|
||||
int hsize; /* high word of file size - dbs */
|
||||
int lsize; /* low word of file size - dbs */
|
||||
int i; /* our old favorite index variable */
|
||||
int len; /* length of file's pathname (plus 1) */
|
||||
/*%%int length; /* number of characters read */*/
|
||||
int page; /* page number component of a pointer */
|
||||
int p_flags; /* port flags */
|
||||
int retstat = 0; /* the return status */
|
||||
int stat; /* status returned from open request */
|
||||
char *string; /* file pathname buffer pointer */
|
||||
float fsize; /* file size - dbs */
|
||||
|
||||
ENTER(spopen);
|
||||
|
||||
/* identify mode value */
|
||||
if ((direction = get_mode(mode)) == -1) goto src_err;
|
||||
|
||||
page = CORRPAGE(file[C_PAGE]);
|
||||
disp = file[C_DISP];
|
||||
|
||||
switch(ptype[page])
|
||||
{
|
||||
case STRTYPE*2: len = get_word(page, disp+1);
|
||||
if (len < 0) /* Adjust for small string */
|
||||
len = len + BLK_OVHD;
|
||||
else
|
||||
len = len - BLK_OVHD;
|
||||
|
||||
if (!(string = getmem(len+1))) getmem_error(rtn_name);
|
||||
get_str(string, page, disp);
|
||||
string[len] = '\0';
|
||||
for (i=0; i<len; i++)
|
||||
string[i] = toupper(string[i]);
|
||||
switch (direction)
|
||||
{
|
||||
case READ: if ((stat = zopen(&handle,
|
||||
string, direction,
|
||||
&hsize,&lsize)))
|
||||
{
|
||||
open_error:
|
||||
rlsstr(string);
|
||||
/* Call to dos_err will not return */
|
||||
stat += (IO_ERROR_START - 1);
|
||||
dos_err(NON_RESTART,stat,file);
|
||||
}
|
||||
break;
|
||||
case WRITE: if ((stat = zcreate(&handle, string)))
|
||||
goto open_error;
|
||||
if (((stat = strcmp(string,"PRN")) == 0) ||
|
||||
((stat = strcmp(string,"LST")) == 0))
|
||||
prn_handle = handle;
|
||||
break;
|
||||
case APPEND: if ((stat = zopen(&handle, string,
|
||||
direction,&hsize,&lsize)) == FILE_NOT_FOUND)
|
||||
{
|
||||
if((stat = zcreate(&handle, string)))
|
||||
goto open_error;
|
||||
break;
|
||||
}
|
||||
if (stat) goto open_error;
|
||||
/* do
|
||||
{
|
||||
if (zread(handle, buffer, &length))
|
||||
break;
|
||||
} while (length); */
|
||||
if (((stat = strcmp(string,"PRN")) == 0) ||
|
||||
((stat = strcmp(string,"LST")) == 0))
|
||||
break;
|
||||
mov_fptr(handle);
|
||||
fsize = (hsize * 65536) + lsize;
|
||||
}
|
||||
mov_reg(tmp_reg, file); /* save pointer to filename */
|
||||
alloc_block(file, PORTTYPE, WINDSIZE+BUFFSIZE);
|
||||
page = CORRPAGE(file[C_PAGE]);
|
||||
disp = file[C_DISP];
|
||||
zero_blk(page, disp);
|
||||
if (direction == WRITE)
|
||||
put_word(page, disp+UL_LINE, 1);
|
||||
else
|
||||
if (direction == APPEND)
|
||||
{ /* update the chunk# and buffer position */
|
||||
i = fsize / 256;
|
||||
put_word(page, disp+UL_LINE, i + 1);
|
||||
i = fsize - (i * 256);
|
||||
put_word(page, disp+BUF_POS, i);
|
||||
direction = WRITE; /* unsets read flag - dbs */
|
||||
}
|
||||
put_word(page, disp+P_FLAGS, OPEN+direction);
|
||||
put_word(page, disp+N_COLS, 80);
|
||||
put_word(page, disp+HANDLE, handle);
|
||||
put_word(page, disp+N_LINES, hsize);
|
||||
put_word(page, disp+B_ATTRIB, lsize);
|
||||
/* put pointer to pathname into port object */
|
||||
put_ptr(page, disp+STR_PTR, tmp_page, tmp_disp);
|
||||
rlsstr(string); /* release pathname buffer */
|
||||
break;
|
||||
|
||||
case SYMTYPE*2: if (file[C_PAGE] != CON_PAGE ||
|
||||
file[C_DISP] != CON_DISP) goto src_err;
|
||||
break;
|
||||
|
||||
case PORTTYPE*2: p_flags = get_word(page, disp+P_FLAGS);
|
||||
if (p_flags & OPEN) break;
|
||||
|
||||
src_err:
|
||||
default: set_src_err("OPEN-PORT", 2, file, mode);
|
||||
retstat = -1;
|
||||
} /* end: switch(ptype[page]) */
|
||||
end_of_function:
|
||||
return(retstat);
|
||||
} /* end of function: spopen(file, mode) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Close a Port */
|
||||
/************************************************************************/
|
||||
spclose(port)
|
||||
int port[2]; /* register containing port pointer */
|
||||
{
|
||||
int page; /* page number component of a pointer */
|
||||
int p_flags; /* port flags */
|
||||
int retstat = 0; /* the return status */
|
||||
int stat; /* status returned from open request */
|
||||
|
||||
static int err_code[2] = {0, SPECFIX*2}; /* close error status */
|
||||
|
||||
if (!get_port(port, 0))
|
||||
{
|
||||
page = CORRPAGE(tmp_page);
|
||||
p_flags = get_word(page, tmp_disp+P_FLAGS);
|
||||
if (p_flags & OPEN && !(p_flags & WINDOW))
|
||||
{
|
||||
/***** write EOF to file before closing *****/
|
||||
stat = 0x1A; /* ascii code of EOF character */
|
||||
retstat = 1; /* number of bytes to write */
|
||||
|
||||
if ((p_flags & WRITE) || (p_flags & READ_WRITE))
|
||||
if ((stat = zwrite(get_word(page,tmp_disp+HANDLE),&stat,&retstat)))
|
||||
{
|
||||
stat += (IO_ERROR_START - 1);
|
||||
goto io_err;
|
||||
}
|
||||
|
||||
if ((stat = zclose(get_word(page, tmp_disp+HANDLE))))
|
||||
{
|
||||
stat += (IO_ERROR_START - 1);
|
||||
io_err:
|
||||
/* We will not return from dos_err */
|
||||
dos_err(NON_RESTART,stat,port);
|
||||
}
|
||||
put_word(page, tmp_disp+P_FLAGS, p_flags & (! OPEN));
|
||||
put_word(page, tmp_disp+BUF_POS, BUFFSIZE);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
set_src_err("CLOSE-PORT", 1, port);
|
||||
retstat = -1;
|
||||
}
|
||||
return(retstat);
|
||||
} /* end of function: spclose(port) */
|
||||
|
||||
/***** Code for 'read' turned off 17 July 1985 (JCJ) *****
|
||||
/************************************************************************/
|
||||
/* Read an S-Expression */
|
||||
/* */
|
||||
/* Purpose: Scheme interpreter support to read an s-expression from */
|
||||
/* a port. */
|
||||
/************************************************************************/
|
||||
spread(reg)
|
||||
int reg[2];
|
||||
{
|
||||
int retstat = 0; /* the return status */
|
||||
|
||||
if (!get_port(reg, 0))
|
||||
{
|
||||
sread(reg, CORRPAGE(tmp_page), tmp_disp);
|
||||
}
|
||||
else
|
||||
{
|
||||
set_src_err("READ", 1, reg);
|
||||
retstat = -1;
|
||||
}
|
||||
return(retstat);
|
||||
} /* end of function: spread(reg) */
|
||||
***** Code for 'read' turned off 17 July 1985 (JCJ) *****/
|
||||
/********* The following codes are recoded in assembly
|
||||
/************************************************************************/
|
||||
/* Read an Atom */
|
||||
/* */
|
||||
/* Purpose: Scheme interpreter support to read an atom from a port. */
|
||||
/************************************************************************/
|
||||
srd_atom(reg)
|
||||
int reg[2];
|
||||
{
|
||||
int retstat; /* the return status */
|
||||
|
||||
if (!get_port(reg, 0))
|
||||
{
|
||||
retstat = sread_atom(reg, CORRPAGE(tmp_page), tmp_disp);
|
||||
}
|
||||
else
|
||||
{
|
||||
set_src_err("READ-ATOM", 1, reg);
|
||||
retstat = -1;
|
||||
}
|
||||
return(retstat);
|
||||
} /* end of function: srd_atom(reg) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Print an S-Expression (w/ slashification) */
|
||||
/* */
|
||||
/* Purpose: Scheme interpreter support to output an s-expression to */
|
||||
/* a port. */
|
||||
/************************************************************************/
|
||||
spprin1(value,port)
|
||||
int value[2]; /* value to be printed */
|
||||
int port[2]; /* register containing port pointer */
|
||||
{
|
||||
int retstat = 0; /* the return status */
|
||||
|
||||
if (!get_port(port, 1))
|
||||
{
|
||||
sprint(CORRPAGE(value[C_PAGE]), value[C_DISP],
|
||||
CORRPAGE(tmp_page), tmp_disp, TRUE, TRUE, FALSE);
|
||||
value[C_PAGE] = NPR_PAGE*2;
|
||||
value[C_DISP] = NPR_DISP;
|
||||
}
|
||||
else
|
||||
{
|
||||
set_src_error("WRITE", 2, value, port);
|
||||
retstat = -1;
|
||||
}
|
||||
return(retstat);
|
||||
} /* end of function: spprin1(value,port) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Print an S-Expression (w/o slashification) */
|
||||
/* */
|
||||
/* Purpose: Scheme interpreter support to output an s-expression to */
|
||||
/* a port. */
|
||||
/************************************************************************/
|
||||
spprinc(value,port)
|
||||
int value[2]; /* value to be printed */
|
||||
int port[2]; /* register containing port pointer */
|
||||
{
|
||||
int retstat = 0; /* the return status */
|
||||
|
||||
if (!get_port(port, 1))
|
||||
{
|
||||
sprint(CORRPAGE(value[C_PAGE]), value[C_DISP],
|
||||
CORRPAGE(tmp_page), tmp_disp, FALSE, TRUE, FALSE);
|
||||
value[C_PAGE] = NPR_PAGE*2;
|
||||
value[C_DISP] = NPR_DISP;
|
||||
}
|
||||
else
|
||||
{
|
||||
set_src_err("DISPLAY", 2, value, port);
|
||||
retstat = -1;
|
||||
}
|
||||
return(retstat);
|
||||
} /* end of function: spprinc(value,port) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Print an S-Expression (w/ spacing control) */
|
||||
/* */
|
||||
/* Purpose: Scheme interpreter support to output an s-expression to */
|
||||
/* a port. */
|
||||
/************************************************************************/
|
||||
spprint(value,port)
|
||||
int value[2]; /* value to be printed */
|
||||
int port[2]; /* register containing port pointer */
|
||||
{
|
||||
int retstat = 0; /* the return status */
|
||||
|
||||
if (!get_port(port, 1))
|
||||
{
|
||||
/* print a newline */
|
||||
sprint(SPECCHAR, '\n',
|
||||
CORRPAGE(tmp_page), tmp_disp, FALSE, TRUE, FALSE);
|
||||
/* print the s-expression with slashification */
|
||||
sprint(CORRPAGE(value[C_PAGE]), value[C_DISP],
|
||||
CORRPAGE(tmp_page), tmp_disp, TRUE, TRUE, FALSE);
|
||||
/* print a space */
|
||||
sprint(SPECCHAR, ' ',
|
||||
CORRPAGE(tmp_page), tmp_disp, FALSE, TRUE, FALSE);
|
||||
value[C_PAGE] = NPR_PAGE*2;
|
||||
value[C_DISP] = NPR_DISP;
|
||||
}
|
||||
else
|
||||
{
|
||||
set_src_err("PRINT", 2, value, port);
|
||||
retstat = -1;
|
||||
}
|
||||
return(retstat);
|
||||
} /* end of function: spprint(value,port) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Print a "newline" Character */
|
||||
/* */
|
||||
/* Purpose: Scheme interpreter support to output a newline character */
|
||||
/* to a port. */
|
||||
/************************************************************************/
|
||||
spnewlin(port)
|
||||
int port[2]; /* register containing port pointer */
|
||||
{
|
||||
int retstat = 0; /* the return status */
|
||||
|
||||
if (!get_port(port, 1))
|
||||
{
|
||||
/* print a newline */
|
||||
sprint(SPECCHAR, '\n',
|
||||
CORRPAGE(tmp_page), tmp_disp, FALSE, TRUE, FALSE);
|
||||
}
|
||||
else
|
||||
{
|
||||
set_src_err("NEWLINE", 1, port);
|
||||
retstat = -1;
|
||||
}
|
||||
return(retstat);
|
||||
} /* end of function: spnewlin(port) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Find Print-length of an S-Expression */
|
||||
/* */
|
||||
/* Purpose: Scheme interpreter support to determine the print length */
|
||||
/* of a Scheme object. */
|
||||
/************************************************************************/
|
||||
prt_len(value)
|
||||
int value[2]; /* value (not) to be printed */
|
||||
{
|
||||
int len; /* length of object */
|
||||
|
||||
len = sprint(CORRPAGE(value[C_PAGE]), value[C_DISP],
|
||||
OUT_PAGE, OUT_DISP, FALSE, FALSE, TRUE);
|
||||
value[C_PAGE] = SPECFIX*2;
|
||||
value[C_DISP] = len;
|
||||
} /* end of function: prt_len(value) */
|
||||
*********************************************************/
|
||||
|
||||
/************************************************************************/
|
||||
/* Local Support: Determine Input/Output Mode Value */
|
||||
/************************************************************************/
|
||||
get_mode(reg, in_or_out)
|
||||
int reg[2]; /* mode register ('read, 'write, 'append) */
|
||||
int in_or_out; /* 0 = input, 1 = output */
|
||||
{
|
||||
if (ptype[CORRPAGE(reg[C_PAGE])] == SYMTYPE*2)
|
||||
{
|
||||
intern(tmp_reg, "READ", 4);
|
||||
if (tmp_disp == reg[C_DISP] && tmp_page == reg[C_PAGE]) return(0);
|
||||
intern(tmp_reg, "WRITE", 5);
|
||||
if (tmp_disp == reg[C_DISP] && tmp_page == reg[C_PAGE]) return(1);
|
||||
intern(tmp_reg, "APPEND", 6);
|
||||
if (tmp_disp == reg[C_DISP] && tmp_page == reg[C_PAGE]) return(2);
|
||||
}
|
||||
return(-1);
|
||||
} /* end of function: get_mode(reg, in_or_out) */
|
||||
|
||||
|
|
@ -0,0 +1,322 @@
|
|||
/* =====> SLINK.C */
|
||||
/* TIPC Scheme Runtime Support - Lattice C/Assembly Language Linkage
|
||||
(C) Copyright 1985 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: 21 June 1985
|
||||
Last Modification: 18 October 1985
|
||||
*/
|
||||
#include "slink.h"
|
||||
#include "ctype.h"
|
||||
/************************************************************************/
|
||||
/* Scheme to Lattice C (or assembly langauge) Interface */
|
||||
/* */
|
||||
/* Purpose: To provide the ability for a Scheme user to link to low */
|
||||
/* level routines not written in Scheme. */
|
||||
/* */
|
||||
/* Description: This interface allows linkage to routines written in */
|
||||
/* Lattice C, or assembly langauge routines which use the */
|
||||
/* Lattice C linkage conventions. */
|
||||
/* */
|
||||
/* Limitations: This interface may be used to call routines which */
|
||||
/* accept up to six (6) arguments of the Lattice C types: */
|
||||
/* */
|
||||
/* int */
|
||||
/* long */
|
||||
/* char */
|
||||
/* char * (zero terminated string) */
|
||||
/* float */
|
||||
/* double */
|
||||
/* unsigned (16 bit integer) */
|
||||
/* */
|
||||
/* and which return a single Scheme value of one of the */
|
||||
/* following types: */
|
||||
/* */
|
||||
/* fixnum (up to 32 bits) */
|
||||
/* flonum */
|
||||
/* character */
|
||||
/* string */
|
||||
/* 't or '() */
|
||||
/* */
|
||||
/* The C and/or assembly language routines may have side */
|
||||
/* effects and save state information, but they may not */
|
||||
/* have access to, or modify, the state of the Scheme */
|
||||
/* runtime (except through the passing of parameters). */
|
||||
/* */
|
||||
/* How to Use: */
|
||||
/* */
|
||||
/* 1. Compile the routine you wish to call using the small model */
|
||||
/* (small code, small data) Lattice C compiler. */
|
||||
/* */
|
||||
/* 2. Modify this routine (SLINK.C) as follows, and compile it */
|
||||
/* with the small model Lattice C compiler. */
|
||||
/* */
|
||||
/* a. Add a declaration to indicate the type of the value to */
|
||||
/* be returned by your external routine (if no value is */
|
||||
/* declared, it will default to "int"). e.g., */
|
||||
/* */
|
||||
/* char *dir1(); */
|
||||
/* Here, the function "dir1" is declared to return */
|
||||
/* (char *), which is the C representation for a character */
|
||||
/* string. */
|
||||
/* */
|
||||
/* b. Add an entry in the "switch" statement to call your */
|
||||
/* routine. You must explicitly indicate the type of each */
|
||||
/* argument you pass, as well as the value you wish to be */
|
||||
/* returned to Scheme. e.g., */
|
||||
/* */
|
||||
/* case 0: RETURN_STRING( dir1( STRING(arg1) ) ); */
|
||||
/* */
|
||||
/* In this example, the function "dir1" is called using */
|
||||
/* the first argument, which is a character string. The */
|
||||
/* result of the "dir1" call is returned as a character */
|
||||
/* string to Scheme. */
|
||||
/* */
|
||||
/* Argument values may be obtained and converted to the */
|
||||
/* appropriate type using one of the following functions: */
|
||||
/* */
|
||||
/* INTEGER(argn) */
|
||||
/* LONG_INTEGER(argn) */
|
||||
/* CHARACTER(argn) */
|
||||
/* FLOAT(argn) */
|
||||
/* DOUBLE(argn) */
|
||||
/* STRING(argn) */
|
||||
/* UNSIGNED(argn) */
|
||||
/* */
|
||||
/* Values must be returned using one of the following */
|
||||
/* functions: */
|
||||
/* */
|
||||
/* RETURN_INTEGER(value); */
|
||||
/* RETURN_FLONUM(value); */
|
||||
/* RETURN_CHARACTER(value); */
|
||||
/* RETURN_STRING(value); */
|
||||
/* RETURN_T_OR_NIL(value); */
|
||||
/* */
|
||||
/* c. The case number in step b is the "function code" which */
|
||||
/* is used to invoke the function. The function code must */
|
||||
/* always be an integer and must be the first operand */
|
||||
/* passed to one of the "escape" Scheme functions. The */
|
||||
/* other operands follow the function code in the order */
|
||||
/* expected by the called routine. The Scheme escape */
|
||||
/* functions are named %esc1, %esc2, .., %esc7, where the */
|
||||
/* number following the "%esc" designation is the total */
|
||||
/* number of operands, INCLUDING the function code. */
|
||||
/* For example, to call the "dir1" function with one */
|
||||
/* operand, we code: */
|
||||
/* */
|
||||
/* (%esc2 0 "string") */
|
||||
/* */
|
||||
/* where the first operand (0) is the function code and */
|
||||
/* "string" is the character string to be passed as the */
|
||||
/* only argument. */
|
||||
/* */
|
||||
/* d. To provide a more meaningful calling sequence and to */
|
||||
/* check for correct parameters, a Scheme routine should */
|
||||
/* be defined for each function to be called. These */
|
||||
/* functions are normally placed in the SCHEME.INI file, */
|
||||
/* but may be installed "permanently" for a given */
|
||||
/* application by converting them to fast-load format and */
|
||||
/* appending them to the FRONT of the COMPILER.FSL file, */
|
||||
/* which is automatically loaded when PCS begins. */
|
||||
/* */
|
||||
/* A sample Scheme function for the "dir1" function is: */
|
||||
/* */
|
||||
/* (define dir1 */
|
||||
/* (lambda (filespec) */
|
||||
/* (if (string? filespec) */
|
||||
/* (%esc2 0 filespec) */
|
||||
/* (error "Invalid Parameter to 'dir1'" */
|
||||
/* filespec)))) */
|
||||
/* */
|
||||
/* Here, the Scheme function "dir1" checks its argument */
|
||||
/* to make sure that it's a string and, if it is, uses the */
|
||||
/* escape (%esc2) opcode to invoke the function. If the */
|
||||
/* argument is not a string, an error is reported through */
|
||||
/* the Scheme error procedure. */
|
||||
/* */
|
||||
/* e. The Scheme runtime must be re-linked with your Lattice */
|
||||
/* C and/or assembly language routines included. Modify */
|
||||
/* the file SCHEME.LNK file (the link edit control file) */
|
||||
/* to include your modules by adding them to the end of */
|
||||
/* the "includes" (e.g., ...+YOUROBJ). */
|
||||
/* */
|
||||
/* Comments: */
|
||||
/* */
|
||||
/* 1. The Scheme/C interface loses all typing information. All */
|
||||
/* arguments must be of the correct type or the results will */
|
||||
/* be unpredictable. Scheme functions (such as the "dir1" */
|
||||
/* example in d. (above)) should be used to force arguments */
|
||||
/* to the expected types. */
|
||||
/* */
|
||||
/* 2. There is a limited amout of procedure (code) and data */
|
||||
/* memory available to user supplied functions. Very large */
|
||||
/* functions (in terms of either code space or data space) */
|
||||
/* may cause linking to fail or Scheme to overflow its runtime */
|
||||
/* stack. */
|
||||
/************************************************************************/
|
||||
link(result, fc, arg1, arg2, arg3, arg4, arg5, arg6)
|
||||
long **result,*fc,*arg1,*arg2,*arg3,*arg4,*arg5,*arg6;
|
||||
{
|
||||
int ftncode; /* function code */
|
||||
int status; /* return code */
|
||||
int int_number; /* software int number */
|
||||
char *t_; /* local temporary */
|
||||
char* strng; /* Used by function 8 */
|
||||
|
||||
extern unsigned zapcurs; /* Denote cursor no longer in use */
|
||||
extern int compact_every; /* Indicates when to compact */
|
||||
|
||||
/**************************************************************/
|
||||
/* a. Declare each function which is to be called so that */
|
||||
/* its type is known by the Lattice C compiler. */
|
||||
/**************************************************************/
|
||||
char *dir1(); /* dir1 returns a character string */
|
||||
char *dir2(); /* dir2 returns a character string */
|
||||
long int freesp();
|
||||
long int filesize();
|
||||
char *chgdir();
|
||||
#ifndef PROMEM
|
||||
long int isw_int(); /* software interrupt - return integer */
|
||||
int tsw_int(); /* software interrupt - return t or nil */
|
||||
char *ssw_int(); /* software interrupt - return string */
|
||||
double fsw_int(); /* software interrupt - return float */
|
||||
char *flo2hex(); /* return hex representation of float */
|
||||
#endif
|
||||
int hash(); /* return hash value of symbol */
|
||||
void randomiz(); /* seed random number generator */
|
||||
#ifndef PROMEM
|
||||
unsigned xlidbg(); /* XLI debug hook */
|
||||
#endif
|
||||
|
||||
ftncode = *fc; /* make a local copy of the function code */
|
||||
|
||||
strng = "0000000000000000";
|
||||
|
||||
|
||||
/**************************************************************/
|
||||
/* b. Add a case entry in the following "switch" statement */
|
||||
/* to call your external procedure. The "case" number */
|
||||
/* is the function code which you must use to invoke your */
|
||||
/* function. */
|
||||
/**************************************************************/
|
||||
switch (ftncode)
|
||||
{
|
||||
case 0: /* function code 0: find file match */
|
||||
RETURN_STRING(dir1(STRING(arg1)));
|
||||
|
||||
case 1: /* function code 1: step through directory, matching files */
|
||||
RETURN_STRING(dir2());
|
||||
|
||||
case 2: /* function code 2: bid another MS-DOS task */
|
||||
status = bid(STRING(arg1),STRING(arg2),INTEGER(arg3),INTEGER(arg4));
|
||||
|
||||
if (status < 0) print_and_exit(
|
||||
"[VM FATAL ERROR] DOS-CALL error: unable to restore PC Scheme memory\n");
|
||||
RETURN_INTEGER(status);
|
||||
|
||||
case 3: /* function code 3: get the free space of heap */
|
||||
RETURN_INTEGER(freesp());
|
||||
|
||||
case 4: /* function code 4: scroll window up one line */
|
||||
zscroll(INTEGER(arg1),INTEGER(arg2),INTEGER(arg3),
|
||||
INTEGER(arg4),INTEGER(arg5));
|
||||
RETURN_T_OR_NIL(1);
|
||||
|
||||
case 5: /* function code 5: scroll window down one line */
|
||||
scroll_d(INTEGER(arg1),INTEGER(arg2),INTEGER(arg3),
|
||||
INTEGER(arg4),INTEGER(arg5));
|
||||
RETURN_T_OR_NIL(1);
|
||||
|
||||
case 6: /* function code 6: copy protect test - This function was */
|
||||
/* removed in version 2.0 and always returns True. */
|
||||
RETURN_T_OR_NIL(1);
|
||||
|
||||
case 7:
|
||||
#ifndef PROMEM
|
||||
/* function code 7: software interrupt */
|
||||
int_number = *arg1; /* 1st arg = interrupt number */
|
||||
status = *arg2; /* 2nd arg = return result type */
|
||||
switch (status)
|
||||
{
|
||||
case 0: /* return integer result */
|
||||
RETURN_INTEGER(isw_int(int_number,arg3,arg4,arg5,arg6));
|
||||
|
||||
case 1: /* return t or nil result */
|
||||
RETURN_T_OR_NIL(tsw_int(int_number,arg3,arg4,arg5,arg6));
|
||||
|
||||
case 2: /* return string result */
|
||||
RETURN_STRING(ssw_int(int_number,arg3,arg4,arg5,arg6));
|
||||
|
||||
case 3: /* return string result */
|
||||
RETURN_FLONUM(fsw_int(int_number,arg3,arg4,arg5,arg6));
|
||||
|
||||
default: return(-1); /* unrecognized return type */
|
||||
}
|
||||
#endif
|
||||
case 8: /* function code 8: float->hex conversion */
|
||||
RETURN_STRING(flo2hex(strng,arg1,INTEGER(arg2)));
|
||||
|
||||
case 9: /* function code 9: return hash value of symbol */
|
||||
RETURN_INTEGER(hash(STRING(arg1),strlen(arg1)));
|
||||
|
||||
case 10: /* function code 10: delete a file */
|
||||
RETURN_INTEGER(delete(STRING(arg1)));
|
||||
|
||||
case 11: /* function code 11: copy a file */
|
||||
RETURN_INTEGER(copy_fil(STRING(arg1),STRING(arg2)));
|
||||
|
||||
case 12: /* function code 12: rename files under current directory */
|
||||
RETURN_INTEGER(rename(STRING(arg1),STRING(arg2)));
|
||||
|
||||
case 13: /* function code 13: turn the cursor on */
|
||||
zapcurs = 0;
|
||||
zcuron();
|
||||
RETURN_T_OR_NIL(1);
|
||||
|
||||
case 14: /* function code 14: turn the cursor off */
|
||||
zcuron(); zcuroff();
|
||||
zapcurs = 1;
|
||||
RETURN_T_OR_NIL(1);
|
||||
|
||||
case 15: /* function code 15: get the file size */
|
||||
RETURN_INTEGER(filesize(STRING(arg1)));
|
||||
|
||||
case 16: /* function code 16: change current directory */
|
||||
RETURN_STRING(chgdir(STRING(arg1)));
|
||||
|
||||
case 17: /* function code 17: change current drive */
|
||||
chgdrv(toupper(CHARACTER(arg1)));
|
||||
RETURN_T_OR_NIL(1);
|
||||
#ifndef PROMEM
|
||||
case 18: /* function code 18: XLI debug hook */
|
||||
RETURN_INTEGER(xlidbg(INTEGER(arg1)));
|
||||
#endif
|
||||
|
||||
case 19: /* function code 19: unused */
|
||||
return(-1);
|
||||
|
||||
case 20: /* function code 20: seed random number generator */
|
||||
randomiz(INTEGER(arg1));
|
||||
RETURN_T_OR_NIL(1);
|
||||
|
||||
case 21: /* function code 21: return compaction variable */
|
||||
RETURN_INTEGER(compact_every);
|
||||
|
||||
case 22: /* function code 22: set compaction variable */
|
||||
compact_every = (INTEGER(arg1));
|
||||
RETURN_INTEGER(compact_every);
|
||||
|
||||
default: return(-1); /* unrecognized function code */
|
||||
} /* end: switch (ftncode) */
|
||||
} /* end of function: link(result,fc,arg1,arg2,arg3,arg4,arg5,arg6) */
|
||||
|
||||
/**************************************************************/
|
||||
/* Note: If you wish, your Lattice C functions may be */
|
||||
/* included in this file following this message. */
|
||||
/**************************************************************/
|
||||
|
||||
|
|
@ -0,0 +1,385 @@
|
|||
/* =====> 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();
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,511 @@
|
|||
/* =====> SMEMORY.C */
|
||||
/* TIPC Scheme '84 Runtime Support - Memory Allocation Routines
|
||||
(C) Copyright 1984,1985, 1986 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: 21 October 1985
|
||||
*/
|
||||
#include "scheme.h"
|
||||
|
||||
/* Turn off assertions in SMEMORY.C for permance reasons */
|
||||
#define ASSERT(arg) /* do nothing */
|
||||
#define ENTER(xyz) /* do nothing */
|
||||
|
||||
/**********************************************************************/
|
||||
/* Allocate a Page in Scheme's Memory */
|
||||
/**********************************************************************/
|
||||
alloc_page(type)
|
||||
int type;
|
||||
{
|
||||
int page_allocated;
|
||||
ENTER(alloc_page);
|
||||
|
||||
if (freepage == END_LIST) return(END_LIST); /* out of pages? */
|
||||
page_allocated = freepage;
|
||||
freepage = pagelink[freepage];
|
||||
|
||||
/* Define page management characteristics for this type page */
|
||||
w_attrib[page_allocated] = pageattr[type];
|
||||
pagelink[page_allocated] = pagelist[type];
|
||||
ptype[page_allocated] = type + type;
|
||||
pagelist[type] = page_allocated;
|
||||
|
||||
/* Initialize this page to all 0's */
|
||||
zero_page(page_allocated);
|
||||
|
||||
/* Initialize free storage chains for appropriate data type */
|
||||
switch (type)
|
||||
{
|
||||
case LISTTYPE:
|
||||
case FLOTYPE:
|
||||
case REFTYPE:
|
||||
swpage(page_allocated);
|
||||
break;
|
||||
|
||||
case BIGTYPE:
|
||||
case SYMTYPE:
|
||||
case STRTYPE:
|
||||
case ARYTYPE:
|
||||
case CLOSTYPE:
|
||||
case CONTTYPE:
|
||||
case CODETYPE:
|
||||
case FREETYPE:
|
||||
case PORTTYPE:
|
||||
case ENVTYPE:
|
||||
put_ptr(page_allocated, 0, FREETYPE, psize[page_allocated]);
|
||||
nextcell[page_allocated] = 0;
|
||||
break;
|
||||
|
||||
/*** Note: fixnums and characters handled as immediates
|
||||
case FIXTYPE:
|
||||
case CHARTYPE:
|
||||
***/
|
||||
default: printf("[VM INTERNAL ERROR] alloc_page: Invalid type: %d\n",
|
||||
type);
|
||||
getch();
|
||||
} /* end: switch (type) */
|
||||
|
||||
/* re-define page attributes and type (GC thinks this is a free page) */
|
||||
w_attrib[page_allocated] = pageattr[type];
|
||||
ptype[page_allocated] = type + type;
|
||||
|
||||
return(page_allocated);
|
||||
} /* end of function: alloc_page(type) */
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/* Allocate a List Cell */
|
||||
/* */
|
||||
/* Note: this routine will always return a list cell unless */
|
||||
/* memory is exhausted, in which case Scheme terminates */
|
||||
/* abnormally */
|
||||
/**********************************************************************/
|
||||
alloc_list_cell(reg)
|
||||
int reg[2];
|
||||
{
|
||||
ENTER(alloc_list_cell);
|
||||
find_list_cell(reg); /* attempt to find a free cell */
|
||||
if (reg[C_PAGE] == -1) /* did allocation succeed? */
|
||||
{
|
||||
reg[C_PAGE] = NIL_PAGE*2; /* legitimize pointer before GC */
|
||||
garbage(); /* no, invoke garbage collector */
|
||||
find_list_cell(reg); /* try again to find a free cell */
|
||||
if (reg[C_PAGE] == -1) /* did allocation succeed? */
|
||||
{
|
||||
reg[C_PAGE] = NIL_PAGE*2; /* legitimize pointer before GC */
|
||||
gcsquish(); /* no, invoke garbage collector */
|
||||
find_list_cell(reg); /* try yet again to find a free cell */
|
||||
if (reg[C_PAGE] == -1)
|
||||
{
|
||||
out_of_memory(); /* Memory Exhausted-- Attempt SCHEME-RESET */
|
||||
/* control will not return here */
|
||||
} /* end: if (reg[C_PAGE] == -1) */
|
||||
} /* end: if (reg[C_PAGE] == -1) */
|
||||
} /* end: if (reg[C_PAGE] == -1) */
|
||||
} /* end of function: alloc_list_cell(reg) */
|
||||
|
||||
|
||||
/* Find a List Cell */
|
||||
find_list_cell(reg)
|
||||
int reg[2];
|
||||
{
|
||||
int disp;
|
||||
/* int i; */
|
||||
ENTER(find_list_cell);
|
||||
|
||||
/* check available cell list */
|
||||
while ((disp = nextcell[listpage]) == END_LIST)
|
||||
{ /* No cells in this page-- try next one, or allocate new page */
|
||||
if ((listpage = pagelink[listpage]) == END_LIST)
|
||||
if ((listpage = alloc_page(LISTTYPE)) == END_LIST)
|
||||
{
|
||||
listpage = 0; /* just point to page 0 - null list */
|
||||
reg[C_PAGE] = -1; /* set failure value-- no success allocating */
|
||||
goto no_can_do;
|
||||
}
|
||||
} /* end: while ((disp = nextcell[listpage]) == END_LIST) */
|
||||
|
||||
/* allocate cell and update free cell list */
|
||||
/* i = nextcell[listpage] = get_word(listpage, disp+1); */
|
||||
/* ASSERT((i >= 0 && i < psize[listpage]) || i == END_LIST); */
|
||||
|
||||
nextcell[listpage] = get_word(listpage, disp+1);
|
||||
|
||||
/* return page number and displacement */
|
||||
reg[C_PAGE] = ADJPAGE(listpage);
|
||||
reg[C_DISP] = disp;
|
||||
no_can_do:
|
||||
} /* end of function: find_list_cell(reg) */
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/* Allocate a Flonum */
|
||||
/* Note: this routine will always return a flonum cell unless */
|
||||
/* memory is exhausted, in which case Scheme terminates */
|
||||
/* abnormally */
|
||||
/**********************************************************************/
|
||||
alloc_flonum(reg, value)
|
||||
int reg[2];
|
||||
double value;
|
||||
{
|
||||
int i; /* temporary variable */
|
||||
ENTER(alloc_flonum);
|
||||
|
||||
/* determine page for allocation-- a "special" flonum value? */
|
||||
if (value == 0.0 || value == 1.0 || value == -1.0)
|
||||
{
|
||||
reg[C_PAGE] = ADJPAGE(SPECFLO);
|
||||
i = value;
|
||||
reg[C_DISP] = FLOSIZE * (i + 1);
|
||||
}
|
||||
else
|
||||
{
|
||||
af_again:
|
||||
find_flonum(reg); /* attempt to find a free cell */
|
||||
if (reg[C_PAGE] == -1) /* did allocation succeed? */
|
||||
{
|
||||
reg[C_PAGE] = NIL_PAGE*2; /* legitimize register before GC */
|
||||
garbage(); /* no, invoke garbage collector */
|
||||
find_flonum(reg); /* try again to find a free cell */
|
||||
if (reg[C_PAGE] == -1) /* did allocation succeed? */
|
||||
{
|
||||
reg[C_PAGE] = NIL_PAGE*2; /* legitimize register before GC */
|
||||
gcsquish(); /* invoke memory compaction */
|
||||
find_flonum(reg); /* try yet again to find a free cell */
|
||||
if (reg[C_PAGE] == -1)
|
||||
{
|
||||
out_of_memory(); /* Memory Exhausted-- Attempt SCHEME-RESET */
|
||||
goto af_again;
|
||||
} /* end: if (reg[C_PAGE] == -1) */
|
||||
} /* end: if (reg[C_PAGE] == -1) */
|
||||
} /* end: if (reg[C_PAGE] == -1) */
|
||||
/* store the value into the flonum cell */
|
||||
put_flo(CORRPAGE(reg[C_PAGE]), reg[C_DISP], value);
|
||||
}
|
||||
} /* end of function: alloc_flonum(reg) */
|
||||
|
||||
|
||||
find_flonum(reg)
|
||||
int reg[2];
|
||||
{
|
||||
int disp;
|
||||
int i;
|
||||
/*%%int page;*/
|
||||
ENTER(find_flonum);
|
||||
|
||||
reg[C_PAGE] = -1; /* set status in case allocation fails */
|
||||
|
||||
if (flopage == END_LIST)
|
||||
{ /* No page of flonums allocated-- do so, if possible */
|
||||
if ((flopage = alloc_page(FLOTYPE)) == END_LIST) goto no_can_do;
|
||||
}
|
||||
|
||||
/* check available cell list */
|
||||
while ((disp = nextcell[flopage]) == END_LIST)
|
||||
{ /* No cells in this page-- try next one, or allocate new page */
|
||||
if ((flopage = pagelink[flopage]) == END_LIST)
|
||||
if ((flopage = alloc_page(FLOTYPE)) == END_LIST) goto no_can_do;
|
||||
} /* end: while ((disp = nextcell[flopage]) == END_LIST) */
|
||||
|
||||
/* allocate cell and update free cell list */
|
||||
i = nextcell[flopage] = get_word(flopage, disp+1);
|
||||
ASSERT((i >= 0 && i < psize[flopage]) || i == END_LIST);
|
||||
|
||||
/* return page number and displacement */
|
||||
put_byte(flopage, disp, FLOTYPE); /* change tag field */
|
||||
reg[C_PAGE] = ADJPAGE(flopage);
|
||||
reg[C_DISP] = disp;
|
||||
no_can_do:
|
||||
} /* end of function: find_flonum(reg, value) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Allocate String Constant */
|
||||
/************************************************************************/
|
||||
alloc_string(reg, string)
|
||||
int reg[2]; /* destination register */
|
||||
char *string; /* value of string */
|
||||
{
|
||||
alloc_block(reg, STRTYPE, strlen(string));
|
||||
put_str(string, CORRPAGE(reg[C_PAGE]), reg[C_DISP]);
|
||||
}
|
||||
|
||||
/********
|
||||
|
||||
commented out 12/31/87 by tc
|
||||
new code in block.asm
|
||||
|
||||
/************************************************************************/
|
||||
/* Allocate Variable Length Block */
|
||||
/************************************************************************/
|
||||
alloc_block(reg, type, size)
|
||||
int reg[2]; /* register to receive block pointer */
|
||||
int type; /* type code for block */
|
||||
int size; /* size (bytes) of data */
|
||||
{
|
||||
int *last_page; /* current chain entry address */
|
||||
int page; /* page number of candidate
|
||||
page for allocation */
|
||||
int str_size; /***** for small string length *****/
|
||||
|
||||
ENTER(alloc_block);
|
||||
|
||||
str_size = size; /***** save for further calculation *****/
|
||||
if (type == STRTYPE && size < PTRSIZE) /***** check for small string *****/
|
||||
size = PTRSIZE; /***** string length at least 3 *****/
|
||||
size += BLK_OVHD; /* increment request size to account for block overhead */
|
||||
|
||||
page = pagelist[type]; /* search page type chain */
|
||||
last_page = &pagelist[type]; /* remember position in chain */
|
||||
while (page != END_LIST)
|
||||
{
|
||||
find_block(reg, type, size, page);
|
||||
if (reg[C_PAGE] != -1) goto block_found;
|
||||
if (size <= SMALL_SIZE) *last_page = pagelink[page];
|
||||
last_page = &pagelink[page];
|
||||
page = pagelink[page];
|
||||
} /* end: while (page != END_LIST) */
|
||||
|
||||
/* normal block allocation failed-- test for large block */
|
||||
if (size > PAGESIZE)
|
||||
{
|
||||
/* allocate a block larger than one page */
|
||||
reg[C_PAGE] = NIL_PAGE*2; /* make register legitimate in case of GC */
|
||||
alloc_big_block(reg, type, size);
|
||||
goto block_found; /* note: allocation will succeed, or control will
|
||||
not return from the "find_big_block" call */
|
||||
}
|
||||
else
|
||||
{
|
||||
/* block not found in allocated pages-- try to allocate a new one */
|
||||
if ((page = alloc_page(type)) == END_LIST)
|
||||
{
|
||||
reg[C_PAGE] = NIL_PAGE*2; /* legitimize register before GC */
|
||||
garbage(); /* invoke garbage collector to reclaim unreferenced data */
|
||||
page = pagelist[type]; /* search page type chain once again */
|
||||
last_page = &pagelist[type]; /* remember position in chain */
|
||||
while (page != END_LIST)
|
||||
{
|
||||
find_block(reg, type, size, page);
|
||||
if (reg[C_PAGE] != -1) goto block_found;
|
||||
if (size <= SMALL_SIZE) *last_page = pagelink[page];
|
||||
last_page = &pagelink[page];
|
||||
page = pagelink[page];
|
||||
} /* end: while (page != END_LIST) */
|
||||
/* attempt a new page allocation after garbage collection */
|
||||
ab_again:
|
||||
if ((page = alloc_page(type)) == END_LIST)
|
||||
{
|
||||
reg[C_PAGE] = NIL_PAGE*2; /* legitimize register before GC */
|
||||
gcsquish(); /* invoke memory compaction */
|
||||
/* attempt a new page allocation after compaction */
|
||||
if ((page = alloc_page(type)) == END_LIST)
|
||||
{
|
||||
out_of_memory(); /* Memory Exhausted-- Attempt SCHEME-RESET */
|
||||
goto ab_again;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* allocate block in newly allocated page */
|
||||
find_block(reg, type, size, page);
|
||||
ASSERT (reg[C_PAGE] != -1 /* allocation failure */);
|
||||
|
||||
block_found:
|
||||
if (type == STRTYPE && str_size < PTRSIZE)
|
||||
/***** for small strings, put the negative value for object length *****/
|
||||
/***** string with NULL length => object length -3 *****/
|
||||
/***** string with length 1 => object length -2 *****/
|
||||
/***** string with length 2 => object length -1 *****/
|
||||
put_word(CORRPAGE(reg[C_PAGE]), reg[C_DISP]+1, str_size - PTRSIZE);
|
||||
} /* end of function: alloc_block(reg, type, size) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Try to Allocate a Variable Length Block in a Specific Page */
|
||||
/************************************************************************/
|
||||
find_block(reg, type, size, page)
|
||||
int reg[2]; /* register to receive pointer to block */
|
||||
int type; /* type code for the block */
|
||||
int size; /* size (bytes) of the entire block */
|
||||
int page; /* page in which to attempt allocation */
|
||||
{
|
||||
int disp; /* block displacement */
|
||||
int free_disp; /* displacement of a free block */
|
||||
int free_size; /* size of a block's free pool */
|
||||
int remaining; /* temporary variable */
|
||||
|
||||
ENTER(find_block);
|
||||
|
||||
reg[C_PAGE] = -1; /* initialize return register to "block not found" */
|
||||
|
||||
/* First, see if there's space in the free pool of this block */
|
||||
if ((disp = nextcell[page]) != END_LIST)
|
||||
{
|
||||
/* This page has a free pool */
|
||||
free_size = get_word(page, disp+1);
|
||||
if (size <= free_size)
|
||||
{
|
||||
/* allocate block from free pool */
|
||||
put_ptr(page, disp, type, size);
|
||||
if ((free_disp = disp + size) <= psize[page] - BLK_OVHD)
|
||||
{
|
||||
/* still free space remaining */
|
||||
put_ptr(page, free_disp, FREETYPE, free_size - size);
|
||||
nextcell[page] = free_disp; /* update free pool pointer */
|
||||
}
|
||||
else nextcell[page] = END_LIST; /* no more free space here */
|
||||
goto return_block;
|
||||
} /* end: if (size <= free_size) */
|
||||
} /* end: if ((disp = nextcell[page]) != END_LIST) */
|
||||
|
||||
/* Can't allocate from free pool-- search for a fragment */
|
||||
disp = 0;
|
||||
remaining = psize[page] - size;
|
||||
while (disp <= remaining)
|
||||
{
|
||||
free_size = get_word(page, disp+1);
|
||||
if (get_byte(page, disp) == FREETYPE)
|
||||
{
|
||||
/* free block found */
|
||||
if (size == free_size)
|
||||
{
|
||||
/* exact match-- we were lucky */
|
||||
put_byte(page, disp, type);
|
||||
goto return_block;
|
||||
}
|
||||
else if (size < free_size - BLK_OVHD)
|
||||
{
|
||||
/* split free block to allocate */
|
||||
put_ptr(page, disp, type, size);
|
||||
free_disp = disp + size;
|
||||
put_ptr(page, free_disp, FREETYPE, free_size - size);
|
||||
goto return_block;
|
||||
} /* end: if (size < free_size + BLK_OVHD) */
|
||||
} /* end: if (size == free_size) */
|
||||
if (free_size < 0) /* small string? */
|
||||
disp = disp + BLK_OVHD + PTRSIZE;
|
||||
else disp += free_size; /* advance to next block */
|
||||
} /* end: while (disp <= remaining) */
|
||||
|
||||
goto block_not_found;
|
||||
|
||||
return_block:
|
||||
reg[C_PAGE] = ADJPAGE(page);
|
||||
reg[C_DISP] = disp;
|
||||
block_not_found:
|
||||
} /* end of function: find_block(reg, type, size, page) */
|
||||
|
||||
commented out 12/31/87 by tc
|
||||
|
||||
*********************/
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/* Invoke garbage collection */
|
||||
/**********************************************************************/
|
||||
int gc_count = 0; /* global counter for gc invocations */
|
||||
int compact_every = 7; /* perform compaction every 7 gc's */
|
||||
|
||||
garbage1()
|
||||
{
|
||||
gc_on(); /* display "garbage collection" message */
|
||||
|
||||
gc_count++;
|
||||
mark();
|
||||
gc_oht(); /* clean up the object hash table */
|
||||
gcsweep();
|
||||
if (listpage == END_LIST) listpage = 0;
|
||||
gc_off(); /* un-display "garbage collection" message */
|
||||
|
||||
if (!(gc_count % compact_every)) /* see if its time to compact */
|
||||
gcsquish();
|
||||
|
||||
}
|
||||
|
||||
/* mark everything pointed to for the garbage collector */
|
||||
mark()
|
||||
{
|
||||
int i;
|
||||
int *j,*k;
|
||||
|
||||
extern int FNV_save[2],STL_save[2]; /* reset variables */
|
||||
|
||||
/* mark all objects pointed to by the Scheme VM's registers */
|
||||
j = ®0_page;
|
||||
k = ®0_disp;
|
||||
for (i = 0; i < NUM_REGS; i++,j+=2,k+=2)
|
||||
gcmark(*j, *k);
|
||||
gcmark(FNV_pag, FNV_dis);
|
||||
gcmark(GNV_pag, GNV_dis);
|
||||
gcmark(PREV_pag, PREV_dis);
|
||||
gcmark(CB_pag, CB_dis);
|
||||
gcmark(TRNS_pag, TRNS_dis);
|
||||
gcmark(tmp_page, tmp_disp);
|
||||
gcmark(tm2_page, tm2_disp);
|
||||
gcmark(FNV_save[C_PAGE], FNV_save[C_DISP]);
|
||||
gcmark(STL_save[C_PAGE], STL_save[C_DISP]);
|
||||
|
||||
/* preserve everything pointed to by active stack entries */
|
||||
for (i = 0; i <= TOS; i += PTRSIZE)
|
||||
{
|
||||
gcmark(S_stack[i], (S_stack[i+2]<<8) + S_stack[i+1]);
|
||||
}
|
||||
|
||||
/* preserve everything pointed to by the oblist */
|
||||
for (i = 0; i < HT_SIZE; i++)
|
||||
{
|
||||
if (hash_page[i]) gcmark(hash_page[i], hash_disp[i]);
|
||||
}
|
||||
|
||||
/* preserve everything pointed to by the property list */
|
||||
for (i = 0; i < HT_SIZE; i++)
|
||||
{
|
||||
if (prop_page[i]) gcmark(prop_page[i], prop_disp[i]);
|
||||
}
|
||||
} /* end of function: mark() */
|
||||
|
||||
/************************************************************************/
|
||||
/* Memory Exhausted-- Attempt to Perform SCHEME-RESET */
|
||||
/************************************************************************/
|
||||
out_of_memory()
|
||||
{
|
||||
int i;
|
||||
|
||||
if ( (nextpage < lastpage) && (nextpage < (NUMPAGES - 1)) )
|
||||
{
|
||||
freepage = nextpage;
|
||||
for (i=0; i<8 && (nextpage < (NUMPAGES - 1)); i++)
|
||||
{
|
||||
pagelink[nextpage] = nextpage+1;
|
||||
attrib[nextpage].nomemory = 1;
|
||||
nextpage += 1;
|
||||
}
|
||||
pagelink[nextpage-1] = END_LIST;
|
||||
}
|
||||
else
|
||||
{
|
||||
printf("\n[VM ERROR encountered!] Out of memory\n%s\n%s",
|
||||
"Attempting to execute SCHEME-RESET",
|
||||
"[Returning to top level]\n");
|
||||
force_reset();
|
||||
}
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* Print Message and Exit Scheme */
|
||||
/************************************************************************/
|
||||
print_and_exit(msg)
|
||||
char *msg;
|
||||
{
|
||||
printf(msg); /* print the error message */
|
||||
getch(); /* wait for any key to be pressed */
|
||||
exit(); /* bye now */
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,475 @@
|
|||
/* =====> SPRINT.C */
|
||||
/* TIPC Scheme '84 Runtime Support - S-Expression Printing
|
||||
(C) Cop[yright 1984,1985 by Texas Instruments Incorporated.
|
||||
All rights reserved.
|
||||
|
||||
Author: Mark E. Meyer
|
||||
Installation: Texas Instruments Incorporated, Dallas, Texas
|
||||
Division: Central Research Laboratories
|
||||
Cost Center: Computer Science Laboratory
|
||||
Project: Computer Architecture Branch
|
||||
Date Written: 13 June 1984
|
||||
Last Modification: 10 Feb 1987 by Terry Caudill
|
||||
|
||||
Modification History:
|
||||
|
||||
tc 2/10/87 modified PRINT-ATOM to recognize special atoms
|
||||
such as #T, #F, etc.
|
||||
|
||||
*/
|
||||
|
||||
#include "scheme.h"
|
||||
/*******
|
||||
#include "schars.h"
|
||||
*********************/
|
||||
extern char decpoint; /* The current decimal point character */
|
||||
|
||||
extern int ccount;
|
||||
extern int show;
|
||||
extern int display;
|
||||
/***********
|
||||
static int ccount = 0; /* Character count */
|
||||
static int display = TRUE; /* Whether to use | and " */
|
||||
static int show = TRUE; /* Whether to send actual characters */
|
||||
static int detail = TRUE; /* Whether to show details */
|
||||
|
||||
/***************************************************************/
|
||||
/* SPRINT(pg,ds,ppg,pds,dmode,smode,dtmode) */
|
||||
/* Given a logical (0,1,2,...) page PG and a displacement */
|
||||
/* DS, SPRINT prints the s-expression representing the object */
|
||||
/* at that location, through the port at (PPG,PDS). SPRINT is */
|
||||
/* recursive, and will go into an infinite loop if the */
|
||||
/* structure has a loop in it. Only atoms and lists are */
|
||||
/* printed as they are; other data types are printed as, for */
|
||||
/* example, <ARRAY>. SPRINT returns the number of characters */
|
||||
/* needed to print the item, not counting | around atoms and */
|
||||
/* " around strings. */
|
||||
/***************************************************************/
|
||||
sprint(pg,ds,ppg,pds,dmode,smode,dtmode)
|
||||
int pg,ds; /* Location of item to be printed */
|
||||
int ppg,pds; /* Location of output port */
|
||||
int dmode; /* If TRUE, use | and " */
|
||||
int smode; /* If FALSE, do not print characters, only ocunt them */
|
||||
int dtmode; /* If TRUE, print details of unprintables */
|
||||
{
|
||||
setabort();
|
||||
setadr(ppg,pds,0); /* Set port & make sure it's for output */
|
||||
ccount = 0;
|
||||
display = dmode;
|
||||
show = smode;
|
||||
detail = dtmode;
|
||||
subsprint(pg,ds);
|
||||
return(ccount);
|
||||
}
|
||||
|
||||
|
||||
subsprint(pg,ds)
|
||||
int pg,ds;
|
||||
{
|
||||
int ch; /* a character being printed */
|
||||
int i,j,k;
|
||||
int len; /* length of a data object */
|
||||
char *getmem();
|
||||
char *divider; /* Buffer for division by 10 */
|
||||
char *bigchars; /* ASCII representation of bignum */
|
||||
int lcl[2]; /* local "register" */
|
||||
char *str; /* temporary string pointer */
|
||||
int strange; /* number of characters in a string which must be escaped */
|
||||
double get_flo();
|
||||
char *symbol_name(); /* Retrieves print name for a symbol */
|
||||
|
||||
/* Note: the following character buffer must be long enough to hold
|
||||
the longest representation of a character. The current
|
||||
length record holder is "#\backspace" */
|
||||
static char ch_buffer[14] = "#\\xxxxxxxxxxx";
|
||||
|
||||
/* If shift-break depressed, abort I/O */
|
||||
if (s_break)
|
||||
{
|
||||
kill_output:
|
||||
printstr("\n[WARNING: Output aborted by SHIFT-BREAK]", 41);
|
||||
restart(show ? 0 : 2);
|
||||
/* Note: control does not return from "restart" */
|
||||
}
|
||||
|
||||
/* If program stack low, print no deeper */
|
||||
if (stkspc() < 64) printstr("#<DEEP!>",8);
|
||||
else
|
||||
{
|
||||
/* Otherwise, act on object type */
|
||||
switch (ptype[pg]>>1)
|
||||
{
|
||||
case (LISTTYPE):
|
||||
if (pg) /* If not NULL */
|
||||
{
|
||||
printchar('(');
|
||||
do
|
||||
{
|
||||
subsprint(CORRPAGE(get_byte((i=pg),ds)),get_word(pg,ds+1));
|
||||
pg = CORRPAGE(get_byte(pg,ds+3));
|
||||
ds = get_word(i,ds+4);
|
||||
if (pg) /* If more items in the list */
|
||||
printchar(' ');
|
||||
}
|
||||
while (pg && ((ptype[pg]) == LISTTYPE*2));
|
||||
if (pg) /* If last cdr not NIL */
|
||||
{
|
||||
printchar('.');
|
||||
printchar(' ');
|
||||
subsprint(pg,ds);
|
||||
}
|
||||
printchar(')');
|
||||
}
|
||||
else printstr("()",2);
|
||||
break;
|
||||
case (FIXTYPE):
|
||||
i = 5;
|
||||
if (!(divider = getmem(i))) abort(HEAPERR);
|
||||
fix2big( ((ds<<1)>>1), divider);
|
||||
goto PRINTINT;
|
||||
case (FLOTYPE):
|
||||
printflo(get_flo(pg,ds));
|
||||
break;
|
||||
case (ARYTYPE):
|
||||
printstr("#(",2);
|
||||
len = get_word(pg, ds+1) - 3; /* fetch length of array object */
|
||||
for (i = BLK_OVHD; i <= len; i+=PTRSIZE)
|
||||
{
|
||||
subsprint(CORRPAGE(get_byte(pg, ds+i)), get_word(pg,ds+i+1));
|
||||
if (i < len) printchar(' ');
|
||||
}
|
||||
printchar(')');
|
||||
break;
|
||||
case (CONTTYPE):
|
||||
printstr("#<CONTINUATION>",15); break;
|
||||
case (CLOSTYPE):
|
||||
printstr("#<PROCEDURE",11);
|
||||
/* fetch information operand from closure object */
|
||||
lcl[C_PAGE] = get_byte(pg,ds+3);
|
||||
lcl[C_DISP] = get_word(pg,ds+4);
|
||||
/* follow information operand list to cdr of last list cell */
|
||||
while (lcl[C_PAGE] && ptype[CORRPAGE(lcl[C_PAGE])] == LISTTYPE*2)
|
||||
{
|
||||
take_cdr(lcl);
|
||||
}
|
||||
/* if final operand is a symbol, print it */
|
||||
if (ptype[(i = CORRPAGE(lcl[C_PAGE]))] == SYMTYPE*2)
|
||||
{
|
||||
str = symbol_name(i, lcl[C_DISP]);
|
||||
printchar(' ');
|
||||
printstr(str, strlen(str));
|
||||
rlsstr(str);
|
||||
}
|
||||
printchar('>');
|
||||
break;
|
||||
case (FREETYPE):
|
||||
printstr("#<FREE>",7); break;
|
||||
case (CODETYPE):
|
||||
printstr("#<CODE>",7); break;
|
||||
case (ENVTYPE):
|
||||
printstr("#<ENVIRONMENT>",14); break;
|
||||
case (SYMTYPE):
|
||||
printatm(pg,ds,SYM_OVHD,'|');
|
||||
break;
|
||||
case (STRTYPE):
|
||||
len = get_word(pg, ds+1);
|
||||
if (len < 0) len = len + BLK_OVHD + PTRSIZE;/* check for small string */
|
||||
ccount += (len -= BLK_OVHD);
|
||||
if (show)
|
||||
{
|
||||
if (display)
|
||||
{ /* write-- need to print double quotes, escape characters */
|
||||
for (i = 0, strange = 2; i < len; i++)
|
||||
{
|
||||
ch = get_byte(pg,ds+BLK_OVHD+i);
|
||||
if (ch == '\\' || ch == '"') strange++;
|
||||
} /* end: for (i = 0, strange = 2; i < len; i++) */
|
||||
wrap(len + strange);
|
||||
givechar('"');
|
||||
for (i = 0; i < len; i++)
|
||||
{
|
||||
if (s_break) goto kill_output;
|
||||
ch = get_byte(pg,ds+BLK_OVHD+i);
|
||||
if (ch == '\\' || ch == '"') givechar('\\');
|
||||
givechar(ch);
|
||||
} /* end: for (i = 0; i < len; i++) */
|
||||
givechar('"');
|
||||
}
|
||||
else /* display-- just print the string */
|
||||
{
|
||||
wrap(len);
|
||||
for (i = 0; i < len; i++)
|
||||
{
|
||||
if (s_break) goto kill_output;
|
||||
givechar(get_byte(pg,ds+BLK_OVHD+i));
|
||||
} /* end: for (i = 0; i < len; i++) */
|
||||
} /* end: else */
|
||||
} /* end: if (show) */
|
||||
break;
|
||||
case (CHARTYPE):
|
||||
i = get_char(pg, ds);
|
||||
if (display)
|
||||
{
|
||||
ch_buffer[2] = i; /* make character into string "#\?" */
|
||||
ch_buffer[3] = '\0';
|
||||
/* Check for a "special" multi-character character constant */
|
||||
for (j = 0; j < test_num; j++)
|
||||
if (i == test_char[j])
|
||||
{
|
||||
str = test_string[j];
|
||||
k = 2;
|
||||
while ((ch_buffer[k++] = *str++));
|
||||
break;
|
||||
}
|
||||
printstr(ch_buffer, strlen(ch_buffer));
|
||||
}
|
||||
else printchar(i); /* print character without escapes */
|
||||
break;
|
||||
/* case (REFTYPE):
|
||||
printstr("#<REF>",6); break;
|
||||
*/ case (BIGTYPE):
|
||||
i = get_word(pg,ds+1) - 1;
|
||||
if (!(divider = getmem(i))) abort(HEAPERR);
|
||||
copybig(pg,ds,divider);
|
||||
PRINTINT:
|
||||
if (bigchars = getmem(j=(i*3-5)))
|
||||
{
|
||||
printstr(bigchars, big2asc(divider,bigchars));
|
||||
rlsmem(bigchars,j);
|
||||
rlsmem(divider,i);
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
rlsmem(divider,i);
|
||||
abort(HEAPERR);
|
||||
}
|
||||
case (PORTTYPE):
|
||||
printstr("#<PORT>",7); break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/***************************************************************/
|
||||
/* PRINTCHAR(c) */
|
||||
/* Prints a single character to the file, and sends a */
|
||||
/* newline if necessary. */
|
||||
/***************************************************************/
|
||||
printchar(c)
|
||||
char c;
|
||||
{
|
||||
ccount++;
|
||||
if (show)
|
||||
if (currspc() > 0)
|
||||
return(givechar(c));
|
||||
else
|
||||
{
|
||||
givechar('\n');
|
||||
if (!isspace(c)) /* After newline, print only nonspaces */
|
||||
return(givechar(c));
|
||||
else
|
||||
{
|
||||
return(0);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
return(0);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/***************************************************************/
|
||||
/* PRINTSTR(str,len) */
|
||||
/* This prints the string STR of length LEN, first */
|
||||
/* sending a newline if necessary. */
|
||||
/***************************************************************/
|
||||
printstr(str,len)
|
||||
char *str;
|
||||
int len;
|
||||
{
|
||||
int i;
|
||||
wrap(len);
|
||||
ccount += len;
|
||||
if (show) gvchars(str,len);
|
||||
}
|
||||
*************************************/
|
||||
|
||||
|
||||
/***************************************************************/
|
||||
/* PRINTATM(pg,ds,offs,c) */
|
||||
/* PRINTATM is used for printing both symbols (and */
|
||||
/* strings). The atom to be printed is located at logical page */
|
||||
/* PG and displacement DS. The argument OFFS tells how many */
|
||||
/* bytes from the top of the atom begin the characters to be */
|
||||
/* printed. The atom printname will be bracketed with the */
|
||||
/* character CH at both ends if necessary. */
|
||||
/* ( CH=='|' for symbols, '"' for strings.) */
|
||||
/***************************************************************/
|
||||
printatm(pg,ds,offs,ch)
|
||||
int pg,ds,offs;
|
||||
char ch;
|
||||
{
|
||||
/*%%int i;*/
|
||||
int j;
|
||||
char *buf;
|
||||
/*%%char c;*/
|
||||
int len; /* Length of print name */
|
||||
int strange=0; /* Number of strange characters */
|
||||
char *getmem();
|
||||
ENTER(printatm);
|
||||
|
||||
/* First stage: Copy pname into buffer, count needed escape */
|
||||
/* characters, and determine whether the pname is "strange". */
|
||||
len = get_word(pg, ds+1) - offs;
|
||||
ds += offs;
|
||||
if (!(buf = getmem(offs=2*len+1))) getmem_error(rtn_name);
|
||||
strange = (j=blk2pbuf(pg,ds,buf,len,ch,display)) & 1;
|
||||
j >>= 1;
|
||||
|
||||
/* Second stage: If necessary, check for numeric, dot, or */
|
||||
/* #-macro confusion. */
|
||||
if (!strange)
|
||||
if ((!strcmp(buf,".")) || (*buf=='#') && (pg!=SPECSYM) || (scannum(buf,10)))
|
||||
strange++;
|
||||
|
||||
/* Third stage: Send carriage-return if needed, and print */
|
||||
/* pname of atom, delimited if necessary. */
|
||||
stage_3:
|
||||
ccount += len; /* Update character count */
|
||||
if (show)
|
||||
{
|
||||
wrap(j + ((strange=(strange && display))? 2 : 0));
|
||||
if (strange) givechar(ch);
|
||||
gvchars(buf,j);
|
||||
if (strange) givechar(ch);
|
||||
}
|
||||
rlsmem(buf, offs);
|
||||
}
|
||||
|
||||
/***************************************************************/
|
||||
/* PRINTFLO(f) */
|
||||
/* Given a double-length floating-point number, this */
|
||||
/* procedure formats and prints the ASCII representation of */
|
||||
/* the number. */
|
||||
/***************************************************************/
|
||||
printflo(f)
|
||||
double f;
|
||||
{
|
||||
char buf[32];
|
||||
printstr(buf, makeflo(f,buf,0,outrange(f)));
|
||||
}
|
||||
|
||||
/***************************************************************/
|
||||
/* OUTRANGE(f) */
|
||||
/* Returns a non-zero value if the value of the given */
|
||||
/* flonum F is not "close" to 1, zero otherwise. */
|
||||
/***************************************************************/
|
||||
outrange(f)
|
||||
double f;
|
||||
{
|
||||
if (f<0) f = -f;
|
||||
return((f<1.0e-3) || (f>=1.0e7));
|
||||
}
|
||||
|
||||
/***************************************************************/
|
||||
/* MAKEFLO(flo,buf,prec,ex) */
|
||||
/* Takes a flonum FLO and converts it to a human-readable */
|
||||
/* form, storing the characters in the buffer BUF. PREC */
|
||||
/* specifies the number of decimal places to be used (as many */
|
||||
/* as necessary, up to a maximum, if PREC is 0) and EX */
|
||||
/* specifies whether to use exponential (if nonzero) or fixed- */
|
||||
/* decimal format. MAKEFLO returns the number of characters */
|
||||
/* placed in BUF, and BUF should be at least 32 bytes. */
|
||||
/***************************************************************/
|
||||
makeflo(flo,buf,prec,ex)
|
||||
double flo;
|
||||
char *buf;
|
||||
int prec,ex;
|
||||
{
|
||||
char digits[32];
|
||||
int scl = 0;
|
||||
if (flo==0.0)
|
||||
{
|
||||
*digits='0'; ex=0;
|
||||
}
|
||||
else
|
||||
{
|
||||
scale(&flo,&scl);
|
||||
flo2big(flo*1.0e15,buf);
|
||||
big2asc(buf,digits);
|
||||
}
|
||||
return(formflo(digits,buf,scl,prec,ex));
|
||||
}
|
||||
|
||||
/***************************************************************/
|
||||
/* SCALE(&flo,&x) */
|
||||
/* Given a pointer FLO to a double-length flonum and a */
|
||||
/* pointer X to an integer, SCALE puts at those two locations */
|
||||
/* a new flonum and integer such that FLO equals the new */
|
||||
/* flonum times 10 to the integer's power and the new flonum */
|
||||
/* is in the interval [ 1.0, 10.0 ). */
|
||||
/***************************************************************/
|
||||
scale(flo,x)
|
||||
double *flo;
|
||||
int *x;
|
||||
{
|
||||
double local;
|
||||
double squar = 10.0;
|
||||
double tensquar[9];
|
||||
int scale,wassmall,i;
|
||||
scale = wassmall = i = 0;
|
||||
local = ((*flo>0) ? *flo : -*flo);
|
||||
if (local == 0)
|
||||
*x = 0;
|
||||
else
|
||||
{
|
||||
if (local < 1.0)
|
||||
{
|
||||
wassmall = -1;
|
||||
local = 1.0/local;
|
||||
}
|
||||
tensquar[0] = 10.0;
|
||||
while (++i<9)
|
||||
{
|
||||
squar *= squar;
|
||||
tensquar[i] = squar;
|
||||
}
|
||||
while (--i>=0)
|
||||
{
|
||||
scale <<=1;
|
||||
if (local>=tensquar[i])
|
||||
{
|
||||
local /= tensquar[i];
|
||||
scale++;
|
||||
}
|
||||
}
|
||||
if (wassmall)
|
||||
{
|
||||
scale = -scale;
|
||||
local = 1.0/local;
|
||||
if (local!=1.0)
|
||||
{
|
||||
local *= 10;
|
||||
scale--;
|
||||
}
|
||||
}
|
||||
*x = scale;
|
||||
*flo = ((*flo < 0.0) ? -local : local);
|
||||
}
|
||||
}
|
||||
/******************
|
||||
/***************************************************************/
|
||||
/* WRAP(len) */
|
||||
/* WRAP issues a newline if there are less than LEN */
|
||||
/* spaces left on the current output line. */
|
||||
/***************************************************************/
|
||||
wrap(len)
|
||||
int len;
|
||||
{
|
||||
if (show && currspc()<len && curr_col()>1)
|
||||
givechar('\n');
|
||||
}
|
||||
*****************************/
|
||||
|
||||
|
|
@ -0,0 +1,539 @@
|
|||
/* =====> SPRINTF.C */
|
||||
/* TIPC Scheme '84 Runtime Support - C Compatible I/O Routines
|
||||
(C) Copyright 1984,1985 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: 7 December 1984
|
||||
Last Modification: 10 September 1985 by Rusty Haddock
|
||||
*/
|
||||
#include "scheme.h"
|
||||
|
||||
/************************************************************************/
|
||||
/* Main Print Driver - printf */
|
||||
/* */
|
||||
/* Acknowledgement: This routines perform formatted output functions */
|
||||
/* similar to that of the Lattice C compiler. */
|
||||
/* Some of the following descriptions are */
|
||||
/* excerpted from the Lattice 8086/8088 C Compiler */
|
||||
/* manual. */
|
||||
/* */
|
||||
/* Description: The control string (format statement) contains */
|
||||
/* ordinary characters, which are sent without */
|
||||
/* modification to the standard output port, and */
|
||||
/* format specifiers of the form: */
|
||||
/* */
|
||||
/* %-m.plX */
|
||||
/* */
|
||||
/* where (1) the optional "-" indicates the field */
|
||||
/* is to be left justified (right justified is the */
|
||||
/* default); (2) the optional "m" field is a */
|
||||
/* decimal number specifying a minimum field width;*/
|
||||
/* (3) the optional ".p" field is the character '.'*/
|
||||
/* followed by a decimal number specifying the */
|
||||
/* precision of a floating point image or the */
|
||||
/* maximum number of characters to be printed from */
|
||||
/* a string; (4) the optional "l" (letter ell) */
|
||||
/* indicates that the item to be formatted is */
|
||||
/* "long"; and (5) "X" is one of the format type */
|
||||
/* indicators from the following list: */
|
||||
/* */
|
||||
/* d -- decimal signed integer */
|
||||
/* u -- decimal unsigned integer */
|
||||
/* x -- hexadecimal integer */
|
||||
/* o -- octal integer */
|
||||
/* s -- character string */
|
||||
/* c -- single character */
|
||||
/* f -- fixed decimal floating point */
|
||||
/* e -- exponential floating point */
|
||||
/* g -- use "e" or "f", whichever is shorter */
|
||||
/* */
|
||||
/* The format type must be specified in lower case.*/
|
||||
/* Characters in the control string which are not */
|
||||
/* part of a format specified are sent to the */
|
||||
/* output port; a % may be sent by using the */
|
||||
/* sequence %%. See the Kernighan and Ritchie */
|
||||
/* text for a more detailed explanation of the */
|
||||
/* formatted output functions. */
|
||||
/************************************************************************/
|
||||
|
||||
/* working variables visible to all output routines in this module */
|
||||
static int auto_CR = TRUE; /* flag for inserting a "carriage return"
|
||||
whenever a "line feed" is encountered */
|
||||
static int field_width = 0;/* width (number of characters) of format field */
|
||||
static int leading_zeros = FALSE; /* indicates if leading zeros desired */
|
||||
static int left_justified = FALSE; /* indicates if field left justified */
|
||||
static int long_object = FALSE; /* indicates if a data item is "long" */
|
||||
static int precision = 0; /* the precision of a floating point image, or
|
||||
the maximum number of character to be printed
|
||||
from a string */
|
||||
|
||||
static char digit[16] = {'0','1','2','3','4','5','6','7','8','9',
|
||||
'A','B','C','D','E','F'};
|
||||
|
||||
char *concat_str(); /* concatenate two character strings */
|
||||
char *copy_str(); /* make copy of a character string */
|
||||
char *fmt_hex(); /* format a hexadecimal value */
|
||||
char *fmt_int(); /* format a signed integer value */
|
||||
char *fmt_long(); /* format a long signed integer value */
|
||||
char *fmt_unsigned(); /* format an unsigned integer value */
|
||||
char *getmem(); /* Lattice C's memory allocation routine */
|
||||
|
||||
printf(fmt, data)
|
||||
char *fmt; /* the "format statement" describing the I/O */
|
||||
int data; /* the first data object to be printed */
|
||||
{
|
||||
char *buffer; /* temporary output buffer for converted values */
|
||||
int *next; /* pointer to the next object to be printed */
|
||||
double *next_float; /* pointer to the next floating point object */
|
||||
long *next_long; /* pointer to the next long object to be printed */
|
||||
|
||||
ENTER(printf);
|
||||
|
||||
/* set the default port address for the I/O operation */
|
||||
ssetadr(ADJPAGE(OUT_PAGE), OUT_DISP);
|
||||
|
||||
next = &data; /* create a pointer to the next object to print */
|
||||
|
||||
/* Continue output until format is exhausted */
|
||||
while (*fmt)
|
||||
{
|
||||
if (*fmt == '%')
|
||||
{
|
||||
buffer = NULL;
|
||||
leading_zeros = FALSE;
|
||||
left_justified = FALSE;
|
||||
long_object = FALSE;
|
||||
field_width = 0;
|
||||
precision = 0;
|
||||
fmt++; /* advance pointer to next character in format */
|
||||
|
||||
/* test if field is to be left justified */
|
||||
if (*fmt == '-')
|
||||
{
|
||||
left_justified = TRUE;
|
||||
fmt++;
|
||||
}
|
||||
|
||||
/* test for request for leading zeros ('0' follows the '%') */
|
||||
if (*fmt == '0')
|
||||
{
|
||||
leading_zeros = TRUE;
|
||||
fmt++;
|
||||
}
|
||||
|
||||
/* determine the field width, if specified */
|
||||
while (isdigit(*fmt))
|
||||
{
|
||||
field_width = (field_width * 10) + *fmt - '0';
|
||||
fmt++;
|
||||
}
|
||||
|
||||
/* test for a "precision" field */
|
||||
if (*fmt == '.')
|
||||
{
|
||||
fmt++;
|
||||
while (isdigit(*fmt))
|
||||
{
|
||||
precision = (precision * 10) + *fmt - '0';
|
||||
fmt++;
|
||||
}
|
||||
} /* end: if (*fmt == '.') */
|
||||
|
||||
/* test for a "long" object */
|
||||
if (*fmt == 'l')
|
||||
{
|
||||
long_object = TRUE;
|
||||
fmt++;
|
||||
}
|
||||
|
||||
/* decode the format specifier */
|
||||
switch (*fmt)
|
||||
{
|
||||
case 'c': /* single character */
|
||||
prtf_character(*next);
|
||||
next++;
|
||||
break;
|
||||
|
||||
case 'd': /* decimal signed integer */
|
||||
if (long_object)
|
||||
{
|
||||
next_long = (long *) next;
|
||||
buffer = fmt_long(*next_long);
|
||||
next++;
|
||||
}
|
||||
else
|
||||
{
|
||||
buffer = fmt_int(*next);
|
||||
}
|
||||
next++;
|
||||
break;
|
||||
|
||||
case 'e':
|
||||
case 'f':
|
||||
case 'g': /* Floating-point numbers */
|
||||
next_float = (double *) next;
|
||||
fmt_float(*next_float,*fmt);
|
||||
next += 4;
|
||||
break;
|
||||
|
||||
/***** WATCH OUT!!! Lattice C allows nested comments!!!
|
||||
case 'o': /* octal integer */
|
||||
prtf_string("<%o not implemented>");
|
||||
next++;
|
||||
break;
|
||||
*****/
|
||||
case 's': /* character string */
|
||||
prtf_string(*next);
|
||||
next++;
|
||||
break;
|
||||
|
||||
case 'u': /* decimal unsigned integer */
|
||||
if (long_object)
|
||||
{
|
||||
prtf_string("<long objects not implemented>");
|
||||
next++;
|
||||
}
|
||||
else
|
||||
{
|
||||
buffer = fmt_unsigned(*next);
|
||||
}
|
||||
next++;
|
||||
break;
|
||||
|
||||
case 'x': /* hexadecimal integer */
|
||||
if (long_object)
|
||||
{
|
||||
prtf_string("<long objects not implemented>");
|
||||
next++;
|
||||
}
|
||||
else
|
||||
{
|
||||
buffer = fmt_hex(*next);
|
||||
}
|
||||
next++;
|
||||
break;
|
||||
|
||||
case '%': /* the percent sign itself */
|
||||
outchar('%');
|
||||
break;
|
||||
|
||||
case '\0': /* unexpected end of format specification */
|
||||
prtf_string("<unexpected end of format>\n");
|
||||
fmt--;
|
||||
break;
|
||||
|
||||
default: /* unexpected format specifier */
|
||||
outchar('%');
|
||||
outchar(*fmt);
|
||||
prtf_string("< invalid format specifier>", 0, 0, 0);
|
||||
break;
|
||||
} /* end: switch (*fmt) */
|
||||
|
||||
if (buffer)
|
||||
{
|
||||
prtf_string(buffer);
|
||||
rlsstr(buffer);
|
||||
}
|
||||
}
|
||||
else /* just a character to print (not a % formatting directive) */
|
||||
{
|
||||
outchar(*fmt);
|
||||
}
|
||||
|
||||
fmt++; /* advance pointer to next character in format */
|
||||
} /* end: while (*fmt) */
|
||||
|
||||
/* reset format control variables to permit calls to sub-entry points */
|
||||
leading_zeros = FALSE;
|
||||
left_justified = FALSE;
|
||||
long_object = FALSE;
|
||||
field_width = 0;
|
||||
precision = 0;
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* Print a single character */
|
||||
/************************************************************************/
|
||||
prtf_character(ch)
|
||||
char ch;
|
||||
{
|
||||
/*%%int i; /* our old favorite index variable */*/
|
||||
|
||||
if (field_width)
|
||||
{
|
||||
if (left_justified)
|
||||
{
|
||||
outchar(ch);
|
||||
pad_with_blanks(field_width - 1);
|
||||
}
|
||||
else /* right justified */
|
||||
{
|
||||
pad_with_blanks(field_width - 1);
|
||||
outchar(ch);
|
||||
}
|
||||
}
|
||||
else outchar(ch); /* just print the single character */
|
||||
|
||||
} /* end of function: prtf_character(ch) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Print a character string */
|
||||
/************************************************************************/
|
||||
prtf_string(string)
|
||||
char *string;
|
||||
{
|
||||
int i; /* our old favorite index variable */
|
||||
int len = 0; /* the actual length of the character string */
|
||||
|
||||
/* determine string length (search for '\0' end-of-string mark) */
|
||||
while (string[len]) len++;
|
||||
|
||||
/* if precision field specified, reduce "len" if too long */
|
||||
if (precision && precision < len) len = precision;
|
||||
|
||||
/* output string with appropriate justification */
|
||||
if (left_justified)
|
||||
{
|
||||
for (i = 0; i < len; i++) outchar(string[i]);
|
||||
pad_with_blanks(field_width - len);
|
||||
}
|
||||
else /* right justified */
|
||||
{
|
||||
pad_with_blanks(field_width - len);
|
||||
for (i = 0; i < len; i++) outchar(string[i]);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Format a floating point number */
|
||||
/************************************************************************/
|
||||
fmt_float(value,type)
|
||||
double value;
|
||||
char type;
|
||||
{
|
||||
char buf[32];
|
||||
int siz;
|
||||
siz = ((type=='g')? (outrange(value)) : (type=='e'));
|
||||
siz = makeflo(value,buf,precision,siz);
|
||||
buf[siz] = '\0';
|
||||
prtf_string(buf);
|
||||
} /* end of function: fmt_float(value,type) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Format a signed decimal integer */
|
||||
/************************************************************************/
|
||||
char *fmt_int(value)
|
||||
int value;
|
||||
{
|
||||
long lvalue;
|
||||
lvalue = value;
|
||||
return(fmt_long(lvalue));
|
||||
/*****
|
||||
char buffer[100]; /* buffer to hold characters of converted value */
|
||||
int digit_count = 0; /* count of significant digits */
|
||||
int i,j; /* index variables */
|
||||
int negative = FALSE; /* flag to indicate sign of number */
|
||||
|
||||
/* test the sign of the integer-- if negative, record that fact */
|
||||
if (value < 0)
|
||||
{
|
||||
negative = TRUE;
|
||||
value = -value;
|
||||
field_width--;
|
||||
}
|
||||
|
||||
/* convert the integer to ASCII */
|
||||
i = sizeof(buffer) - 1;
|
||||
buffer[i--] = '\0'; /* insert end of string indicator */
|
||||
do {
|
||||
buffer[i--] = digit[value % 10];
|
||||
value /= 10;
|
||||
digit_count++;
|
||||
} while (value);
|
||||
|
||||
/* if leading zeros are required, insert said */
|
||||
if (leading_zeros)
|
||||
{
|
||||
for (j = digit_count; j < field_width; j++)
|
||||
buffer[i--] = '0';
|
||||
}
|
||||
|
||||
/* if negative, insert a '-' sign */
|
||||
if (negative)
|
||||
{
|
||||
buffer[i--] = '-';
|
||||
}
|
||||
|
||||
/* return the formatted integer */
|
||||
return(copy_str(buffer+i+1));
|
||||
*****/
|
||||
} /* end of function: char *fmt_int(value) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Format a long signed decimal integer */
|
||||
/************************************************************************/
|
||||
char *fmt_long(value)
|
||||
long value;
|
||||
{
|
||||
char buffer[100]; /* buffer to hold characters of converted value */
|
||||
int digit_count = 0; /* count of significant digits */
|
||||
int i,j; /* index variables */
|
||||
int negative = FALSE; /* flag to indicate sign of number */
|
||||
|
||||
/* test the sign of the integer-- if negative, record that fact */
|
||||
if (value < 0)
|
||||
{
|
||||
negative = TRUE;
|
||||
value = -value;
|
||||
field_width--;
|
||||
}
|
||||
|
||||
/* convert the integer to ASCII */
|
||||
i = sizeof(buffer) - 1;
|
||||
buffer[i--] = '\0'; /* insert end of string indicator */
|
||||
do {
|
||||
buffer[i--] = digit[value % 10];
|
||||
value /= 10;
|
||||
digit_count++;
|
||||
} while (value);
|
||||
|
||||
/* if leading zeros are required, insert said */
|
||||
if (leading_zeros)
|
||||
{
|
||||
for (j = digit_count; j < field_width; j++)
|
||||
buffer[i--] = '0';
|
||||
}
|
||||
|
||||
/* if negative, insert a '-' sign */
|
||||
if (negative)
|
||||
{
|
||||
buffer[i--] = '-';
|
||||
}
|
||||
|
||||
/* return the formatted integer */
|
||||
return(copy_str(buffer+i+1));
|
||||
|
||||
} /* end of function: char *fmt_long(value) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Format an unsigned decimal integer */
|
||||
/************************************************************************/
|
||||
char *fmt_unsigned(value)
|
||||
unsigned value;
|
||||
{
|
||||
int i,j; /* index variables */
|
||||
char buffer[100]; /* buffer to hold characters of converted value */
|
||||
int digit_count = 0; /* count of significant digits */
|
||||
|
||||
/* convert the integer to ASCII */
|
||||
i = sizeof(buffer) - 1;
|
||||
buffer[i--] = '\0'; /* insert end of string indicator */
|
||||
do {
|
||||
buffer[i--] = digit[value % 10];
|
||||
value /= 10;
|
||||
digit_count++;
|
||||
} while (value);
|
||||
|
||||
/* if leading zeros are required, insert said */
|
||||
if (leading_zeros)
|
||||
{
|
||||
for (j = digit_count; j < field_width; j++)
|
||||
buffer[i--] = '0';
|
||||
}
|
||||
|
||||
/* return the formatted unsigned integer */
|
||||
return(copy_str(buffer+i+1));
|
||||
|
||||
} /* end of function: char *fmt_unsigned(value) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Format a hexadecimal integer */
|
||||
/************************************************************************/
|
||||
char *fmt_hex(value)
|
||||
unsigned value;
|
||||
{
|
||||
int i,j; /* index variables */
|
||||
char buffer[100]; /* buffer to hold characters of converted value */
|
||||
int digit_count = 0; /* count of significant digits */
|
||||
|
||||
/* convert the integer to ASCII */
|
||||
i = sizeof(buffer) - 1;
|
||||
buffer[i--] = '\0'; /* insert end of string indicator */
|
||||
do {
|
||||
buffer[i--] = digit[value & 0xf];
|
||||
value = value >> 4;
|
||||
digit_count++;
|
||||
} while (value);
|
||||
|
||||
/* if leading zeros are required, insert said */
|
||||
if (leading_zeros)
|
||||
{
|
||||
for (j = digit_count; j < field_width; j++)
|
||||
buffer[i--] = '0';
|
||||
}
|
||||
|
||||
/* return the hexadecimal integer value */
|
||||
return(copy_str(buffer+i+1));
|
||||
|
||||
} /* end of function: char *fmt_hex(value) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Pad with blanks */
|
||||
/************************************************************************/
|
||||
pad_with_blanks(number)
|
||||
int number; /* the number of blanks to output */
|
||||
{
|
||||
int i; /* index variable */
|
||||
|
||||
/* spew out the appropriate number of blanks */
|
||||
for (i = 0; i < number; i++) outchar(' ');
|
||||
|
||||
} /* end of function: pad_with_blanks */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Create copy of a character string */
|
||||
/************************************************************************/
|
||||
char *copy_str(string)
|
||||
char *string;
|
||||
{
|
||||
char *ret_str;
|
||||
ENTER(copy_str);
|
||||
if (!(ret_str = getmem(strlen(string)+1))) getmem_error(rtn_name);
|
||||
else
|
||||
{
|
||||
strcpy(ret_str, string);
|
||||
}
|
||||
return(ret_str);
|
||||
}
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Create concatenation of two character strings */
|
||||
/************************************************************************/
|
||||
char *concat_str(str1,str2)
|
||||
char *str1,*str2;
|
||||
{
|
||||
ENTER(concat_str);
|
||||
char *ret_str;
|
||||
if (!(ret_str = getmem(strlen(str1) + strlen(str2) + 1)))
|
||||
getmem_error(rtn_name);
|
||||
else
|
||||
{
|
||||
strcpy(ret_str, str1);
|
||||
strcat(ret_str, str2);
|
||||
}
|
||||
return(ret_str);
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,303 @@
|
|||
/* TIPC Scheme Runtime Support - Property List Support
|
||||
(C) Copyright 1985,1986 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: 27 March 1985
|
||||
Last Modification: 25 February 1986
|
||||
|
||||
Note: The property list structure has the following representation:
|
||||
|
||||
+-----------+ +-----------+ +-----------+
|
||||
| sym | o-|-->|prop | o-|-->| val | o-|--> etc.
|
||||
+-----------+ +-----------+ +-----------+
|
||||
+------------+ ^
|
||||
| | | +--> next symbol's entry
|
||||
| Property | | |
|
||||
| List Hash | +-----------+ +-----------+
|
||||
| Table |-->| | o-|-->| | o-|--> next entry in hash chain
|
||||
| | +-----------+ +-----------+
|
||||
+------------+
|
||||
*/
|
||||
#include "ctype.h"
|
||||
#include "scheme.h"
|
||||
|
||||
#include "slist.h"
|
||||
|
||||
#define FOUND 1
|
||||
#define NOT_FOUND 0
|
||||
|
||||
/************************************************************************/
|
||||
/* Get Property Value */
|
||||
/************************************************************************/
|
||||
get_prop(sym,prop)
|
||||
int sym[2];
|
||||
int prop[2];
|
||||
{
|
||||
sym_search(sym);
|
||||
if (prop_search(sym,prop) == FOUND)
|
||||
{
|
||||
take_cadr(sym);
|
||||
}
|
||||
else
|
||||
{ /* property (or symbol) not found-- return nil */
|
||||
sym[C_PAGE] = sym[C_DISP] = 0;
|
||||
}
|
||||
} /* end of function: get_prop(sym,prop) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Get Property List */
|
||||
/************************************************************************/
|
||||
prop_list(name)
|
||||
int name[2];
|
||||
{
|
||||
int retstat = 0; /* the return status */
|
||||
|
||||
if (ptype[CORRPAGE(name[C_PAGE])] == SYMTYPE*2)
|
||||
{
|
||||
sym_search(name);
|
||||
take_cdr(name);
|
||||
}
|
||||
else
|
||||
{
|
||||
set_src_err("PROPLIST", 1, name);
|
||||
retstat = -1;
|
||||
}
|
||||
return(retstat);
|
||||
} /* end of function: prop_list(name) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Put Property Value */
|
||||
/************************************************************************/
|
||||
put_prop(name, value, prop)
|
||||
int name[2];
|
||||
int value[2];
|
||||
int prop[2];
|
||||
{
|
||||
int hash_value; /* hash key for the symbol */
|
||||
ENTER(put_prop);
|
||||
|
||||
mov_reg(tmp_reg, name);
|
||||
if (ptype[CORRPAGE(name[C_PAGE])] == SYMTYPE*2)
|
||||
{
|
||||
sym_search(tmp_reg);
|
||||
if(tmp_reg[C_PAGE])
|
||||
{ /* symbol found in property list table */
|
||||
if (prop_search(tmp_reg, prop) == FOUND)
|
||||
{
|
||||
take_cdr(tmp_reg);
|
||||
put_ptr(CORRPAGE(tmp_reg[C_PAGE]), tmp_reg[C_DISP] , value[C_PAGE],
|
||||
value[C_DISP]);
|
||||
}
|
||||
else
|
||||
{ /* property not present in symbol's property list */
|
||||
mov_reg(name, tmp_reg);
|
||||
take_cdr(name);
|
||||
cons(name, value, name);
|
||||
cons(name, prop, name);
|
||||
put_ptr(CORRPAGE(tmp_reg[C_PAGE]), tmp_reg[C_DISP]+3, name[C_PAGE],
|
||||
name[C_DISP]);
|
||||
}
|
||||
}
|
||||
else
|
||||
{ /* symbol wasn't found in property list table */
|
||||
cons(tmp_reg, value, nil_reg);
|
||||
cons(tmp_reg, prop, tmp_reg);
|
||||
cons(tmp_reg, name, tmp_reg);
|
||||
hash_value = sym_hash(name);
|
||||
name[C_PAGE] = prop_page[hash_value];
|
||||
name[C_DISP] = prop_disp[hash_value];
|
||||
cons(tmp_reg, tmp_reg, name);
|
||||
prop_page[hash_value] = tmp_reg[C_PAGE];
|
||||
prop_disp[hash_value] = tmp_reg[C_DISP];
|
||||
}
|
||||
name[C_PAGE] = value[C_PAGE];
|
||||
name[C_DISP] = value[C_DISP];
|
||||
}
|
||||
else /* name operand is not a symbol */
|
||||
{
|
||||
set_src_err("PUTPROP", 3, name, value, prop);
|
||||
return(-1);
|
||||
}
|
||||
return(0);
|
||||
} /* end of function: put_prop(name, value, prop) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Remove Property */
|
||||
/************************************************************************/
|
||||
rem_prop(sym, prop)
|
||||
int sym[2];
|
||||
int prop[2];
|
||||
{
|
||||
int search[2];
|
||||
int temp[2];
|
||||
ENTER(rem_prop);
|
||||
|
||||
sym_search(sym);
|
||||
if(sym[C_PAGE])
|
||||
{
|
||||
mov_reg(search,sym);
|
||||
while (search[C_PAGE])
|
||||
{
|
||||
mov_reg(temp,search);
|
||||
take_cadr(temp);
|
||||
if (eq(temp,prop))
|
||||
{
|
||||
mov_reg(temp,search);
|
||||
take_cddr(temp);
|
||||
take_cdr(temp);
|
||||
put_ptr(CORRPAGE(search[C_PAGE]), search[C_DISP]+3, temp[C_PAGE],
|
||||
temp[C_DISP]);
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
take_cddr(search);
|
||||
}
|
||||
} /* end: while (search[C_PAGE]) */
|
||||
} /* end: if(sym[C_PAGE]) */
|
||||
} /* end of function: rem_prop(sym, prop) */
|
||||
|
||||
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Symbol List Search */
|
||||
/************************************************************************/
|
||||
|
||||
/********* Code rewritten in assembly language on 5/22/86 by JCJ ******
|
||||
|
||||
sym_search(sym)
|
||||
int sym[2];
|
||||
{
|
||||
int hash_value; /* symbol's hash value */
|
||||
int sym_save[2]; /* initial value of symbol argument */
|
||||
int temp[2]; /* temporary "register" */
|
||||
ENTER(sym_search);
|
||||
|
||||
if (ptype[CORRPAGE(sym[C_PAGE])] == SYMTYPE*2)
|
||||
{
|
||||
/* save symbol's page and displacement for testing purposes */
|
||||
mov_reg(sym_save, sym);
|
||||
|
||||
/* obtain hash chain to search */
|
||||
hash_value = sym_hash(sym);
|
||||
sym[C_PAGE] = prop_page[hash_value];
|
||||
sym[C_DISP] = prop_disp[hash_value];
|
||||
|
||||
while(sym[C_PAGE])
|
||||
{
|
||||
mov_reg(temp, sym);
|
||||
take_caar(temp);
|
||||
if (eq(temp, sym_save))
|
||||
{
|
||||
/* symbol found-- return pointer to symbol's property list */
|
||||
take_car(sym);
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
take_cdr(sym);
|
||||
}
|
||||
} /* end: while(sym[C_PAGE]) */
|
||||
}
|
||||
} /* end of function: sym_search(sym) */
|
||||
|
||||
***** Code rewritten in assembly language on 5/22/86 by JCJ ******/
|
||||
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Search For a Given Property */
|
||||
/************************************************************************/
|
||||
|
||||
/********* Code rewritten in assembly language on 5/22/86 by JCJ ******
|
||||
|
||||
prop_search(list, prop)
|
||||
int list[2],prop[2];
|
||||
{
|
||||
int search[2]; /* current search entry in list */
|
||||
int temp[2]; /* temporary "register" */
|
||||
ENTER(prop_search);
|
||||
|
||||
mov_reg(search, list);
|
||||
take_cdr(search);
|
||||
while(search[C_PAGE])
|
||||
{
|
||||
mov_reg(temp, search);
|
||||
take_car(temp);
|
||||
if (eq(temp,prop))
|
||||
{
|
||||
mov_reg(list, search);
|
||||
return(FOUND);
|
||||
}
|
||||
take_cddr(search);
|
||||
} /* end: while(search[C_PAGE]) */
|
||||
return(NOT_FOUND);
|
||||
} /* end of function: prop_search(list, prop) */
|
||||
|
||||
***** Code rewritten in assembly language on 5/22/86 by JCJ ******/
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Dump Contents of Property List */
|
||||
/************************************************************************/
|
||||
/***** Code turned off 22 OCT 85 (JCJ) *****
|
||||
dump_prop()
|
||||
{
|
||||
int ent[2]; /* current property list entry */
|
||||
int hash_value; /* current hash key value */
|
||||
int prop[2]; /* a property pointer */
|
||||
int temp[2]; /* temporary "register" */
|
||||
int sym[2]; /* pointer to a symbol whose prop list we're dumping */
|
||||
char *symbol; /* a symbol's print name */
|
||||
int val[2]; /* a value pointer */
|
||||
|
||||
char *symbol_name(); /* retrieves a symbol's print name */
|
||||
|
||||
ENTER(dump_prop);
|
||||
|
||||
for (hash_value = 0; hash_value < HT_SIZE; hash_value++)
|
||||
{
|
||||
ent[C_PAGE] = prop_page[hash_value];
|
||||
ent[C_DISP] = prop_disp[hash_value];
|
||||
while (ent[C_PAGE])
|
||||
{
|
||||
ASSERT(ptype[CORRPAGE(ent[C_PAGE])] == LISTTYPE*2);
|
||||
mov_reg(temp, ent);
|
||||
take_car(temp);
|
||||
ASSERT(ptype[CORRPAGE(temp[C_PAGE])] == LISTTYPE*2);
|
||||
mov_reg(sym,temp);
|
||||
take_car(sym);
|
||||
ASSERT(ptype[CORRPAGE(sym[C_PAGE])] == SYMTYPE*2);
|
||||
symbol = symbol_name(CORRPAGE(sym[C_PAGE]),sym[C_DISP]);
|
||||
printf("\nProperty List for |%s|\n", symbol);
|
||||
rlsstr(symbol);
|
||||
|
||||
take_cdr(temp);
|
||||
while(temp[C_PAGE])
|
||||
{
|
||||
ASSERT(ptype[CORRPAGE(temp[C_PAGE])] == LISTTYPE*2);
|
||||
mov_reg(prop,temp);
|
||||
take_car(prop);
|
||||
printf(" property: ");
|
||||
annotate(CORRPAGE(prop[C_PAGE]), prop[C_DISP]);
|
||||
take_cdr(temp);
|
||||
ASSERT(ptype[CORRPAGE(temp[C_PAGE])] == LISTTYPE*2);
|
||||
mov_reg(val,temp);
|
||||
take_car(val);
|
||||
printf(" value: ");
|
||||
annotate(CORRPAGE(val[C_PAGE]), val[C_DISP]);
|
||||
take_cdr(temp);
|
||||
} /* end: while(temp[C_PAGE]) */
|
||||
take_cdr(ent);
|
||||
} /* end: while (ent[C_PAGE]) */
|
||||
} /* end: for (hash_value = 0; hash_value < HT_SIZE; hash_value++) */
|
||||
}
|
||||
***** Code turned off 22 OCT 85 (JCJ) *****/
|
||||
|
||||
|
|
@ -0,0 +1,873 @@
|
|||
/* TIPC Scheme '84 Runtime Support - S-Expression Reading
|
||||
(C) Copyright 1984,1985 by Texas Instruments Incorporated.
|
||||
All rights reserved.
|
||||
|
||||
Author: Mark E. Meyer
|
||||
Installation: Texas Instruments Incorporated, Dallas, Texas
|
||||
Division: Central Research Laboratories
|
||||
Cost Center: Computer Science Laboratory
|
||||
Project: Computer Architecture Branch
|
||||
Date Written: 12 June 1984
|
||||
Last Modification: 18 October 1985 by John Jensen
|
||||
*/
|
||||
|
||||
#include "scheme.h"
|
||||
#include "schars.h"
|
||||
|
||||
extern char decpoint; /* Current decimal point character */
|
||||
|
||||
#define ATOM 0 /* Codes returned by FINDTASK function */
|
||||
#define NIL 1
|
||||
#define LPAREN 2
|
||||
#define RPAREN 3
|
||||
#define QUOTE 4
|
||||
#define DOT 5
|
||||
|
||||
#define DS 0 /* Register array subscripts */
|
||||
#define PG 1
|
||||
/************
|
||||
static int scan = 0;
|
||||
static char ch = ' '; /* Most recently received character */
|
||||
static int *mainreg = NULL; /* Main register */
|
||||
/** static int init_stk = 0; /* Initial Scheme top-of-stack */ **/
|
||||
static int limit; /* Current size of atom buffer */
|
||||
static char *atomb; /* Atom buffer */
|
||||
static int flag_eof; /* Whether to flag end-of-file */
|
||||
|
||||
/**************************************************************/
|
||||
/* REG2REG(sor,dest) */
|
||||
/* Copy the contents from one regsiter to another. */
|
||||
/**************************************************************/
|
||||
#define reg2reg(sor,dest) (dest)[DS] = (sor)[DS]; (dest)[PG] = (sor)[PG];
|
||||
|
||||
|
||||
/**************************************************************/
|
||||
/* SKIPSPACE() */
|
||||
/* Skip over spaces in the input stream, and get a new */
|
||||
/* line of input if necessary */
|
||||
/**************************************************************/
|
||||
#define skipspace() do {rcvchar();} while (isspace(ch));
|
||||
**************/
|
||||
|
||||
/**************************************************************/
|
||||
/* SREAD(reg,pg,ds) */
|
||||
/* Given a pointer to a register, SREAD constructs a */
|
||||
/* list structure, based on input from the port at (PG,DS), */
|
||||
/* leaving in the register a pointer to the structure. This */
|
||||
/* memory-efficient algorithm has return pointers kept */
|
||||
/* within the structure itself, both minimizing overhead and */
|
||||
/* making the structure garbage-collector-compatible. */
|
||||
/* Throughout this source, pointers in the registers use */
|
||||
/* doubled pages, CORRected to single only when necessary. */
|
||||
/* Aside from setting PORT once, a SUBSREAD routine is */
|
||||
/* used so that two additional registers known to the garabge */
|
||||
/* collector can be easily utilized. This means that READ */
|
||||
/* may only be called with one of the R-registers. */
|
||||
/**************************************************************/
|
||||
/***** Code for 'read' turned off 16 July 1985 (JCJ) *****
|
||||
sread(reg,pg,ds)
|
||||
int *reg;
|
||||
int pg,ds;
|
||||
{
|
||||
setabort();
|
||||
if (setadr(pg,ds,1)) /* Set the read port */
|
||||
abort(PORTERR);
|
||||
flag_eof = TRUE; limit = 0;
|
||||
mainreg = reg; /* Save pointer to main register */
|
||||
if (reg < ®s[3])
|
||||
subsread(reg, reg + 2, reg + 4);
|
||||
else
|
||||
{
|
||||
subsread(reg, reg - 2, reg - 4);
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
***** Code for 'read' turned off 16 July 1985 (JCJ) *****/
|
||||
|
||||
/***********
|
||||
/**************************************************************/
|
||||
/* SREAD_ATOM(reg,pg,ds) */
|
||||
/* Setup for the operation of reading a single atom from */
|
||||
/* the given port. Special characters such as ')' are parsed */
|
||||
/* as lists(!) to tell them from ordianry atoms. */
|
||||
/**************************************************************/
|
||||
sread_atom(reg,pg,ds)
|
||||
int *reg;
|
||||
int pg,ds;
|
||||
{
|
||||
setabort();
|
||||
if (setadr(pg,ds,1))
|
||||
abort(PORTERR);
|
||||
mainreg = reg; /* Save pointer to result register */
|
||||
flag_eof = TRUE; limit = /* init_stk = */ 0;
|
||||
do
|
||||
{
|
||||
skipspace(); skipcomments();
|
||||
} while (!ch); /* if ch = '\0', flush it */
|
||||
return(read_atom(reg));
|
||||
}
|
||||
***************/
|
||||
|
||||
/***** Code for 'read' turned off 16 July 1985 (JCJ) *****
|
||||
/**************************************************************/
|
||||
/* SUBSREAD(reg,pres,prev) */
|
||||
/**************************************************************/
|
||||
subsread(reg,pres,prev)
|
||||
int reg[2];
|
||||
int pres[2]; /* Pointer to the present cons cell */
|
||||
int prev[2]; /* Ptr. to cell whose car is list containing [PRES] */
|
||||
{
|
||||
int task;
|
||||
C_push(pres); /* Save old register values */
|
||||
C_push(prev);
|
||||
init_stk = TOS; /* Save initial top of stack pointer */
|
||||
prev[PG] = prev[DS] = pres[PG] = pres[DS] = 0;
|
||||
start:
|
||||
task = findtask(); /* Determine next action to take, */
|
||||
switch (task) /* depending on what's coming up */
|
||||
{
|
||||
case NIL: /* If atom coming, read it & leave */
|
||||
case ATOM:
|
||||
read_atom(reg);
|
||||
goto fastexit;
|
||||
case LPAREN: /* Grab cons cell */
|
||||
descend(reg,pres,prev);
|
||||
C_push(pres); /* Save start of list structure */
|
||||
reg[PG] = fixpage; /* Bottom of stack for dot-lparens */
|
||||
C_push(reg);
|
||||
goto fillcar; /* Read in the car */
|
||||
case QUOTE: /* Form quote structure */
|
||||
buildq(pres,reg,&task);
|
||||
C_push(reg); /* Save start */
|
||||
reg[PG] = fixpage; /* Bottom of stack */
|
||||
C_push(reg);
|
||||
while (task == QUOTE) /* Handle nested quotes */
|
||||
buildq(pres,reg,&task);
|
||||
switch (task)
|
||||
{
|
||||
case NIL: /* Read atom and leave */
|
||||
case ATOM:
|
||||
read_atom(reg);
|
||||
reg2ptr(reg,pres);
|
||||
goto exit;
|
||||
case LPAREN: /* Start reading list */
|
||||
listquote:
|
||||
grabcell(reg);
|
||||
reg2ptr(reg,pres);
|
||||
reg2reg(reg,pres);
|
||||
goto fillcar;
|
||||
default: /* Anything else is wrong! */
|
||||
abortread(QUOTERR);
|
||||
}
|
||||
case RPAREN: /* Can't start with )! */
|
||||
abortread(RPARERR);
|
||||
case DOT: /* Nor with .! */
|
||||
abortread(DOTERR);
|
||||
}
|
||||
fillcar:
|
||||
task = findtask();
|
||||
fillcar2:
|
||||
switch (task)
|
||||
{
|
||||
case NIL: /* Deposit atom in car and read in cdr */
|
||||
case ATOM:
|
||||
read_atom(reg);
|
||||
reg2ptr(reg,pres);
|
||||
goto cross;
|
||||
case LPAREN: /* Save PREV in cdr field and update PRES & PREV */
|
||||
reg2cdr(prev,pres);
|
||||
descend(reg,pres,prev);
|
||||
goto fillcar;
|
||||
case QUOTE:
|
||||
C_push(prev); /* Save PREV & PRES */
|
||||
reg2reg(pres,prev);
|
||||
do /* Build quote structure */
|
||||
buildq(pres,reg,&task);
|
||||
while (task == QUOTE);
|
||||
switch(task)
|
||||
{
|
||||
case NIL: /* If atom, read in, restore PRES & PREV, and cross */
|
||||
case ATOM:
|
||||
read_atom(reg);
|
||||
reg2ptr(reg,pres);
|
||||
reg2reg(prev,pres);
|
||||
C_pop(prev);
|
||||
goto cross;
|
||||
case LPAREN: /* If list, save old PREV in cdr of old PRES */
|
||||
C_pop(reg);
|
||||
reg2cdr(reg,prev);
|
||||
goto listquote;
|
||||
default:
|
||||
abortread(QUOTERR);
|
||||
}
|
||||
default: /* This is the case of (. */
|
||||
abortread(DOTERR);
|
||||
}
|
||||
cross:
|
||||
task = findtask();
|
||||
switch (task)
|
||||
{
|
||||
case RPAREN: /* Try to ascend to higher list */
|
||||
tryascend:
|
||||
C_pop(reg);
|
||||
while ((reg[PG] == prev[PG]) && (reg[DS] == prev[DS]))
|
||||
/* Do while there are dot-lparens to be closed */
|
||||
if (findtask() == RPAREN)
|
||||
C_pop(reg);
|
||||
else /* Some dot-lparen wasn't closed */
|
||||
{
|
||||
abortread(DOTERR);
|
||||
}
|
||||
C_push(reg); /* Restore stack */
|
||||
if (prev[PG]) /* Not done if not at top level of list */
|
||||
{
|
||||
ascend(pres,prev);
|
||||
goto cross;
|
||||
}
|
||||
else /* Else exit */
|
||||
{
|
||||
goto exit;
|
||||
}
|
||||
case DOT:
|
||||
task = findtask();
|
||||
switch (task)
|
||||
{
|
||||
case NIL: /* Fill cdr field */
|
||||
case ATOM:
|
||||
read_atom(reg);
|
||||
reg2cdr(reg,pres);
|
||||
dotatom:
|
||||
if (findtask() == RPAREN) /* Ascend only if ) follows */
|
||||
goto tryascend;
|
||||
else /* more than one thing after dot */
|
||||
{
|
||||
abortread(DOTERR);
|
||||
}
|
||||
case LPAREN: /* Push PREV onto stack */
|
||||
C_push(prev);
|
||||
buildcdr(reg,pres); /* And treat as if dot-lparen */
|
||||
goto fillcar; /* didn't happen */
|
||||
case QUOTE:
|
||||
task = -1; /* Fill cdr field first */
|
||||
do
|
||||
buildq(pres,reg,&task);
|
||||
while (task == QUOTE);
|
||||
switch (task)
|
||||
{
|
||||
case NIL: /* If atom, go fill space in quote structure */
|
||||
case ATOM:
|
||||
read_atom(reg);
|
||||
reg2ptr(reg,pres);
|
||||
goto dotatom;
|
||||
case LPAREN:
|
||||
C_push(prev); /* Save dot syntax indicator */
|
||||
goto listquote;
|
||||
default:
|
||||
abortread(QUOTERR);
|
||||
}
|
||||
default:
|
||||
abortread(DOTERR);
|
||||
}
|
||||
default: /* Otherwise, affix a cons cell to the cdr of PRES */
|
||||
buildcdr(reg,pres);
|
||||
goto fillcar2;
|
||||
}
|
||||
exit:
|
||||
TOS -= PTRSIZE; /* Discard fixnum */
|
||||
C_pop(reg); /* Get ptr to structure */
|
||||
fastexit:
|
||||
C_pop(prev); /* Restore old values */
|
||||
C_pop(pres);
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************/
|
||||
/* FINDTASK() */
|
||||
/* Scan the input stream and find out what's coming up */
|
||||
/* (atom, ", (, etc.). */
|
||||
/**************************************************************/
|
||||
findtask()
|
||||
{
|
||||
char *stpchr();
|
||||
|
||||
skipspace();
|
||||
skipcomments();
|
||||
switch (ch)
|
||||
{
|
||||
case '(':
|
||||
skipspace();
|
||||
skipcomments();
|
||||
if (ch == ')')
|
||||
{
|
||||
ch = ' '; return(NIL);
|
||||
}
|
||||
else
|
||||
{
|
||||
pushchar();
|
||||
return(LPAREN);
|
||||
}
|
||||
case ')':
|
||||
return(RPAREN);
|
||||
case '\'':
|
||||
return(QUOTE);
|
||||
case '.':
|
||||
rcvchar();
|
||||
if (isspace(ch))
|
||||
return(DOT);
|
||||
else
|
||||
{
|
||||
pushchar();
|
||||
if (stpchr( "()'|\";[]{}" , ch))
|
||||
{
|
||||
return(DOT); /* because dot is followed by non-atomic char */
|
||||
}
|
||||
else /* the dot is the first char of a symbol */
|
||||
{
|
||||
ch = '.'; /* Restore initial dot */
|
||||
return(ATOM);
|
||||
}
|
||||
}
|
||||
default:
|
||||
return(ATOM);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/***************************************************************/
|
||||
/* BUILDQ(pres,reg,task) */
|
||||
/* BUILDQ's purpose is to build a list of the form (quote */
|
||||
/* nil), and point the field pointed to by PRES to the list. */
|
||||
/* On exit, PRES points to the cdr of the (quote nil), */
|
||||
/* enabling easy handling of nested quotes; REG points to the */
|
||||
/* (quote nil) itself, and TASK is set by FINDTASK(). */
|
||||
/***************************************************************/
|
||||
buildq(pres,reg,task)
|
||||
int pres[2];
|
||||
int reg[2];
|
||||
int *task;
|
||||
{
|
||||
int temp[2]; /* Temporary register */
|
||||
C_push(pres); /* Save destination pointer field */
|
||||
grabcell(reg); /* Grab a cell and point its car to quote */
|
||||
pres[PG] = ADJPAGE(QUOTE_PAGE);
|
||||
pres[DS] = QUOTE_DISP;
|
||||
reg2ptr(pres,reg);
|
||||
grabcell(pres); /* Grab another cell, point cdr(reg) to it */
|
||||
reg2cdr(pres,reg);
|
||||
reg2reg(pres,temp); /* Save second cell address */
|
||||
C_pop(pres); /* Point destination field to the quote list */
|
||||
if (pres[PG]) /* if the field exists */
|
||||
{
|
||||
if (*task<0)
|
||||
reg2cdr(reg,pres); /* Place in PRES's cdr field */
|
||||
else
|
||||
{
|
||||
reg2ptr(reg,pres); /* Place in car field */
|
||||
}
|
||||
}
|
||||
reg2reg(temp,pres); /* Recover second cell address */
|
||||
*task = findtask();
|
||||
}
|
||||
***** Code for 'read' turned off 16 July 1985 (JCJ) *****/
|
||||
|
||||
/**************
|
||||
/***************************************************************/
|
||||
/* READ_ATOM(reg) */
|
||||
/* Read in an atom (symbol, string, number), using REG as */
|
||||
/* a scratch register, and store the pointer to the atom in */
|
||||
/* REG. Special characters such as ')' or ',' are read as */
|
||||
/* atoms themselves. Normal atoms will end in a whitespace or */
|
||||
/* a terminating macro character; strings end with the closing */
|
||||
/* '"'. Numbers in the requested base are interpreted as */
|
||||
/* such. On exit, the next character in the buffer is the one */
|
||||
/* following the last character of the atom. */
|
||||
/***************************************************************/
|
||||
read_atom(reg)
|
||||
int reg[2];
|
||||
{
|
||||
register int i = 0; /* Index within buffer */
|
||||
register char c;
|
||||
char k;
|
||||
char *bignum; /* Bignum workspace */
|
||||
char *getmem();
|
||||
char *stpchr();
|
||||
int inputch = FALSE; /* Whether the #\ macro is in effect */
|
||||
int escaped = FALSE; /* Whether an escape character has been used */
|
||||
int j,pg,ds,siz,base,neg;
|
||||
double inflo;
|
||||
|
||||
extern int CXFERR_status;
|
||||
|
||||
CXFERR_status = 0; /* set error code for normal return */
|
||||
|
||||
if (ch==' ') /* If ch is a space, form NIL */
|
||||
{
|
||||
reg[PG] = reg[DS] = 0;
|
||||
goto end_of_function;
|
||||
}
|
||||
flag_eof = FALSE;
|
||||
if (!(atomb = getmem(BUFSIZE))) /* Create buffer if possible */
|
||||
abortread(HEAPERR);
|
||||
limit = BUFSIZE; /* Initialize buffer size */
|
||||
base = 10; /* Default base */
|
||||
switch (ch) /* Read atom into buffer */
|
||||
{
|
||||
/* Special-character cases */
|
||||
case '[':
|
||||
case ']':
|
||||
case '{':
|
||||
case '}':
|
||||
case '(':
|
||||
case ')':
|
||||
case '\'':
|
||||
case '`': *atomb=ch; i++; goto speccase;
|
||||
/* String case */
|
||||
case '"': i = delimby('"',i);
|
||||
alloc_block(reg, STRTYPE, i); /* Allocate string space */
|
||||
toblock(reg, 3, atomb, i);
|
||||
goto bye_now;
|
||||
/* Comma case */
|
||||
case ',': *atomb=','; i++;
|
||||
rcvchar();
|
||||
if ((ch=='@') || (ch=='.'))
|
||||
{
|
||||
atomb[1]=ch; i++; goto speccase;
|
||||
}
|
||||
goto norcvspec;
|
||||
/* Macro case */
|
||||
case '#': flag_eof = TRUE;
|
||||
while ((ch=='#') && (!i))
|
||||
{
|
||||
rcvchar();
|
||||
if (isspace(ch)) abortread(SHARPERR);
|
||||
switch (tolower(ch))
|
||||
{
|
||||
case 'b': base=2; break;
|
||||
case 'd': base=10; break;
|
||||
case 'x':
|
||||
case 'h': base=16; break;
|
||||
case 'o': base=8; break;
|
||||
case '\\': rcvchar();
|
||||
addchar(i++,ch);
|
||||
inputch=TRUE; escaped=TRUE;
|
||||
/* Fall through to BREAK below */
|
||||
case 'i': /* Ignore (currently) meaningless macros */
|
||||
case 'e':
|
||||
case 's':
|
||||
case 'l': break;
|
||||
case '<':
|
||||
case ')': abortread(SHARPERR);
|
||||
default: *atomb = '#';
|
||||
atomb[1] = ch;
|
||||
i = 2;
|
||||
if (ch=='(') goto speccase;
|
||||
break;
|
||||
}
|
||||
rcvchar();
|
||||
}
|
||||
flag_eof = FALSE;
|
||||
/* Else a symbol */
|
||||
default: while (!isspace(ch) &&
|
||||
!stpchr( "()'`;,\"[]{}" , ch) &&
|
||||
(ch!='\032'))
|
||||
{
|
||||
switch (ch=toupper(ch))
|
||||
{
|
||||
/* Multiple-escape: read chars until next | */
|
||||
case '|': escaped = TRUE;
|
||||
i = delimby('|',i);
|
||||
break;
|
||||
/* Single-escape: get next char and put it in */
|
||||
case '\\': escaped = flag_eof = TRUE;
|
||||
rcvchar();
|
||||
flag_eof = FALSE;
|
||||
default: addchar(i++,ch);
|
||||
}
|
||||
rcvchar();
|
||||
}
|
||||
} /* End of switch (ch) */
|
||||
endatom:
|
||||
addchar(i,'\0'); /* Put null at end of token */
|
||||
/* Now check for single, unescaped dot (SPECIAL!) */
|
||||
if ((i==1) && (*atomb=='.') && !escaped) goto norcvspec;
|
||||
/* At this point a token has been accumulated. Check for number */
|
||||
j = scannum(atomb,base);
|
||||
if ((j) && !escaped) /* If a number */
|
||||
{
|
||||
if (j>0) /* integer of some size */
|
||||
{
|
||||
siz = (j + 9)/2; /* How many bytes needed for int? */
|
||||
if (!(bignum = getmem(siz)))
|
||||
{
|
||||
abortread(HEAPERR);
|
||||
}
|
||||
bignum[3] = '\0';
|
||||
bignum[4] = '\0';
|
||||
buildint(bignum,atomb,base); /* Form integer */
|
||||
alloc_int(reg,bignum);
|
||||
rlsmem(bignum,siz);
|
||||
}
|
||||
else /* scan the flonum */
|
||||
{
|
||||
scanflo(atomb,&inflo,base);
|
||||
alloc_flonum(reg,inflo);
|
||||
}
|
||||
}
|
||||
else /* allocate character or interned symbol */
|
||||
{
|
||||
if (inputch)
|
||||
{
|
||||
reg[PG] = SPECCHAR*2;
|
||||
if (i==1) reg[DS]=*atomb;
|
||||
else /* check for a multichar character constant */
|
||||
{
|
||||
*atomb = toupper(*atomb); /* convert 1st symbol to uppercase */
|
||||
for (j=0; j<test_num; j++)
|
||||
{
|
||||
if (!strcmp(atomb, test_string[j]))
|
||||
{
|
||||
reg[DS]=test_char[j]; break;
|
||||
}
|
||||
if (j == test_num-1)
|
||||
{
|
||||
alloc_string(tmp_reg, atomb);
|
||||
set_error(0,"Invalid character constant",tmp_reg);
|
||||
reg[DS] = '?';
|
||||
CXFERR_status = -1;
|
||||
}
|
||||
} /* end of for(j=0; j<test_num; j++) */
|
||||
}
|
||||
}
|
||||
else /* not a character, but a symbol */
|
||||
{
|
||||
intern(reg,atomb,i);
|
||||
}
|
||||
}
|
||||
goto release;
|
||||
|
||||
speccase: /* Process the special cases */
|
||||
intern(reg,atomb,i); /* Intern the symbol and encase in a list */
|
||||
cons(reg,reg,nil_reg);
|
||||
goto bye_now;
|
||||
|
||||
norcvspec:
|
||||
intern(reg,atomb,i); /* Intern the symbol and encase in a list */
|
||||
cons(reg,reg,nil_reg);
|
||||
|
||||
release:
|
||||
if (ch!='\032') pushchar(); /* Put post-atom char back into buffer */
|
||||
|
||||
bye_now:
|
||||
rlsmem(atomb,limit); /* Release the buffer space */
|
||||
flag_eof = TRUE;
|
||||
limit = 0;
|
||||
|
||||
end_of_function:
|
||||
return(CXFERR_status);
|
||||
}
|
||||
******************************/
|
||||
|
||||
/**************************************************************/
|
||||
/* SCANFLO(s,flo,base) */
|
||||
/* The string S, which ends in a control char, holds a */
|
||||
/* representation of a floating-point number. The value of */
|
||||
/* this number is stored in *FLO. */
|
||||
/**************************************************************/
|
||||
scanflo(s,flo,base)
|
||||
char *s;
|
||||
double *flo;
|
||||
int base;
|
||||
{
|
||||
int i=0;
|
||||
int neg=0;
|
||||
int x=0;
|
||||
double place;
|
||||
switch (*s)
|
||||
{
|
||||
case '-': neg=-1;
|
||||
case '+': i++; break;
|
||||
default: break;
|
||||
}
|
||||
while (s[i]=='#') i+=2;
|
||||
*flo = 0.0;
|
||||
while (isdig(s[i],base))
|
||||
{
|
||||
*flo = (*flo * base) + digval(s[i++]);
|
||||
}
|
||||
if (!(s[i]==decpoint)) goto EXPON;
|
||||
POINT:
|
||||
i++; place = 1.0;
|
||||
while (isdig(s[i],base))
|
||||
{
|
||||
place /= base;
|
||||
*flo += place*digval(s[i++]);
|
||||
}
|
||||
if (s[i]<' ') goto GOTFLO;
|
||||
EXPON:
|
||||
i++;
|
||||
if (s[i]=='-')
|
||||
{
|
||||
i++; place = 1.0/base;
|
||||
}
|
||||
else place=base;
|
||||
while (isdigit(s[i]))
|
||||
x = (x*10) + digval(s[i++]);
|
||||
while (x)
|
||||
{
|
||||
if (x!=(x>>1)<<1)
|
||||
*flo *= place;
|
||||
if (place<1.0e153) place*=place;
|
||||
x >>= 1;
|
||||
}
|
||||
GOTFLO:
|
||||
if (neg)
|
||||
*flo = -*flo;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************/
|
||||
/* ALLOC_INT(reg,buf) */
|
||||
/* This allocates an integer, either a fixnum or a */
|
||||
/* bignum, depending on the size of the integer, i.e., if */
|
||||
/* the absolute value < 16384, then a fixnum is allocated. */
|
||||
/* The value is read from BUF. */
|
||||
/**************************************************************/
|
||||
alloc_int(reg,buf)
|
||||
int reg[2];
|
||||
char *buf;
|
||||
{
|
||||
unsigned i,j;
|
||||
int pg;
|
||||
i = 256*buf[1] + buf[0];
|
||||
j = 256*buf[4] + buf[3];
|
||||
pg = buf[2] & 1;
|
||||
if ((i == 1) && (j <= 16383+pg)) /* If fixnum */
|
||||
alloc_fixnum(reg, (pg ? -j : j));
|
||||
else
|
||||
{
|
||||
alloc_block(reg, BIGTYPE, 2*i + 1);
|
||||
toblock(reg, 3, buf+2, 2*i +1);
|
||||
}
|
||||
}
|
||||
|
||||
/**************
|
||||
/**************************************************************/
|
||||
/* DELIMBY(c,i) */
|
||||
/* DELIMBY takes characters from the input stream and */
|
||||
/* places them in the buffer ATOMB, starting at offset I and */
|
||||
/* ending when the delimiting character C is reached. This */
|
||||
/* returns the number of characters stored in ATOMB, and CH */
|
||||
/* is left equal to C. */
|
||||
/**************************************************************/
|
||||
delimby(c,i)
|
||||
char c;
|
||||
int i;
|
||||
{
|
||||
flag_eof = TRUE; /* Signal any end-of-file error */
|
||||
rcvchar();
|
||||
while (ch != c)
|
||||
{
|
||||
if (ch != '\r')
|
||||
{
|
||||
if (ch == '\\') rcvchar();
|
||||
addchar(i++,ch);
|
||||
}
|
||||
rcvchar();
|
||||
}
|
||||
flag_eof = FALSE;
|
||||
return(i);
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************/
|
||||
/* ADDCHAR(i,c) */
|
||||
/* ADDCHAR takes the character C and places it in the */
|
||||
/* dynamic atom buffer ATOMB, at offset I. If the buffer can */
|
||||
/* not contain any more characters, additional space is */
|
||||
/* allocated, and LIMIT is adjusted accordingly. */
|
||||
/**************************************************************/
|
||||
addchar(i,c)
|
||||
int i;
|
||||
char c;
|
||||
{
|
||||
int j; /* Scratch FOR variable */
|
||||
char *atom2; /* New atom buffer, if necessary */
|
||||
char *getmem(); /* Additional memory allocator */
|
||||
if (i < limit) /* If room for character, put it in */
|
||||
atomb[i] = c;
|
||||
else /* Else create a new, larger buffer */
|
||||
{
|
||||
if (!(atom2 = getmem(limit + BUFSIZE)))
|
||||
{
|
||||
abortread(HEAPERR);
|
||||
}
|
||||
for (j = 0; j < limit; j++) atom2[j] = atomb[j];
|
||||
rlsmem(atomb,limit); /* Discard the old buffer */
|
||||
atomb = atom2;
|
||||
atomb[i] = c;
|
||||
limit += BUFSIZE;
|
||||
}
|
||||
}
|
||||
********************************/
|
||||
/***** Code for 'read' turned off 16 July 1985 (JCJ) *****
|
||||
/**************************************************************/
|
||||
/* DESCEND(reg,pres,prev) */
|
||||
/* Get a new cons cell, point the car field of [PRES] to */
|
||||
/* the cell, and update PREV and PRES. */
|
||||
/**************************************************************/
|
||||
descend(reg,pres,prev)
|
||||
int reg[2];
|
||||
int pres[2];
|
||||
int prev[2];
|
||||
{
|
||||
grabcell(reg);
|
||||
if (pres[PG]) /* Do only if PRES points to something */
|
||||
reg2ptr(reg,pres);
|
||||
reg2reg(pres,prev);
|
||||
reg2reg(reg,pres);
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************/
|
||||
/* BUILDCDR(reg,pres) */
|
||||
/* Grab a cons cell, point the cdr field of [PRES] to */
|
||||
/* it, and update PRES. */
|
||||
/**************************************************************/
|
||||
buildcdr(reg,pres)
|
||||
int reg[2];
|
||||
int pres[2];
|
||||
{
|
||||
grabcell(reg);
|
||||
pres[DS] += PTRSIZE;
|
||||
reg2ptr(reg,pres);
|
||||
reg2reg(reg,pres);
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************/
|
||||
/* ASCEND(pres,prev) */
|
||||
/* Set PRES to PREV, and pluck the new value for PREV */
|
||||
/* from the cdr field of [PREV], replacing it with NIL. */
|
||||
/**************************************************************/
|
||||
ascend(pres,prev)
|
||||
int pres[2];
|
||||
int prev[2];
|
||||
{
|
||||
int i,j; /* Scratch integers */
|
||||
reg2reg(prev,pres);
|
||||
j = pres[DS] + PTRSIZE;
|
||||
i = CORRPAGE(pres[PG]);
|
||||
/* note: put_byte/put_word return to contents of the byte/word replaced */
|
||||
prev[PG] = put_byte(i, j++, 0);
|
||||
prev[DS] = put_word(i, j, 0);
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************/
|
||||
/* GRABCELL(reg) */
|
||||
/* Grab a cons cell, point REG to it, and set it to */
|
||||
/* (nil . nil). */
|
||||
/**************************************************************/
|
||||
grabcell(reg)
|
||||
int reg[2];
|
||||
{
|
||||
int i;
|
||||
alloc_list_cell(reg);
|
||||
i = CORRPAGE(reg[PG]);
|
||||
put_word(i, reg[DS], 0);
|
||||
put_word(i, reg[DS]+2, 0);
|
||||
put_word(i, reg[DS]+4, 0);
|
||||
}
|
||||
|
||||
/**************************************************************/
|
||||
/* REG2PTR(reg,ptr) */
|
||||
/* Transfer the contents of REG to the pointer field */
|
||||
/* pointed to by PTR. */
|
||||
/**************************************************************/
|
||||
reg2ptr(reg,ptr)
|
||||
int reg[2];
|
||||
int ptr[2];
|
||||
{
|
||||
put_byte(CORRPAGE(ptr[PG]), (ptr[DS])++, reg[PG]);
|
||||
put_word(CORRPAGE(ptr[PG]), (ptr[DS])--, reg[DS]);
|
||||
}
|
||||
|
||||
/**************************************************************/
|
||||
/* REG2CDR(reg,ptr) */
|
||||
/* Transfer the contents of REG to the cdr field of the */
|
||||
/* cell pointed to by PTR. */
|
||||
/**************************************************************/
|
||||
reg2cdr(reg,ptr)
|
||||
int reg[2];
|
||||
int ptr[2];
|
||||
{
|
||||
ptr[DS] += PTRSIZE;
|
||||
reg2ptr(reg,ptr);
|
||||
ptr[DS] -= PTRSIZE;
|
||||
}
|
||||
***** Code for 'read' turned off 16 July 1985 (JCJ) *****/
|
||||
/*************
|
||||
/**************************************************************/
|
||||
/* RCVCHAR() */
|
||||
/* This fetches a character from the input stream */
|
||||
/**************************************************************/
|
||||
rcvchar()
|
||||
{
|
||||
register int i;
|
||||
i = take_ch();
|
||||
if ((i<256) && (i!=26))
|
||||
ch = i;
|
||||
else
|
||||
{
|
||||
if (flag_eof) abortread(EOFERR);
|
||||
else
|
||||
{
|
||||
ch = '\032'; /* EOF character */
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************/
|
||||
/* ABORTREAD(code) */
|
||||
/* Cancels the entire read operation via ABORT, after */
|
||||
/* resetting some vital registers. */
|
||||
/**************************************************************/
|
||||
abortread(code)
|
||||
int code;
|
||||
{
|
||||
if (code == EOFERR)
|
||||
{
|
||||
mainreg[PG] = EOF_PAGE*2; /* return "eof" indicator */
|
||||
mainreg[DS] = EOF_DISP;
|
||||
}
|
||||
else
|
||||
{
|
||||
mainreg[PG] = mainreg[DS] = 0; /* NILify main register */
|
||||
}
|
||||
if (limit) rlsmem(atomb,limit); /* Release buffer memory */
|
||||
/*****
|
||||
if (init_stk)
|
||||
{
|
||||
TOS = init_stk;
|
||||
C_pop((mainreg < ®s[3]) ? (mainreg + 4) : (mainreg - 4));
|
||||
C_pop((mainreg < ®s[3]) ? (mainreg + 2) : (mainreg - 2));
|
||||
}
|
||||
*****/
|
||||
abort(code);
|
||||
}
|
||||
|
||||
/****************************************************************/
|
||||
/* Skip over Comments */
|
||||
/****************************************************************/
|
||||
skipcomments()
|
||||
{
|
||||
while (ch == ';')
|
||||
{
|
||||
while (ch != '\r') rcvchar();
|
||||
skipspace();
|
||||
}
|
||||
} /* end of function: skipcomments() */
|
||||
****************************************************/
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,98 @@
|
|||
/* =====> SREIFY.C */
|
||||
/* TIPC Scheme '84 Runtime Support - Reification
|
||||
(C) Copyright 1985,1986 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: 5 March 1985
|
||||
Last Modification: 25 February 1986
|
||||
*/
|
||||
#include "scheme.h"
|
||||
|
||||
/************************************************************************/
|
||||
/* Reification Support */
|
||||
/************************************************************************/
|
||||
reify (direction, obj, index, val)
|
||||
int direction; /* 0=fetch; 1=store */
|
||||
int obj[2]; /* pointer to object to "reify" */
|
||||
int index[2]; /* index into said object */
|
||||
int val[2]; /* for stores, the value to store */
|
||||
{
|
||||
int disp,page; /* page and displacement components of a pointer */
|
||||
int i; /* index value */
|
||||
|
||||
ENTER(reify);
|
||||
|
||||
if (index[C_PAGE] == SPECFIX*2)
|
||||
{
|
||||
if ((i = ((get_fix(CORRPAGE(index[C_PAGE]), index[C_DISP]) + 1) * 3)) < 0)
|
||||
goto bad_opnd;
|
||||
page = CORRPAGE(obj[C_PAGE]);
|
||||
disp = obj[C_DISP];
|
||||
switch (ptype[page]>>1)
|
||||
{
|
||||
case LISTTYPE: if (i) goto bad_opnd;
|
||||
obj[C_DISP] = PTRSIZE*2;
|
||||
return_fixnum:
|
||||
obj[C_PAGE] = SPECFIX*2;
|
||||
break;
|
||||
|
||||
case REFTYPE:
|
||||
case FIXTYPE:
|
||||
case CHARTYPE: if (i) goto bad_opnd;
|
||||
obj[C_DISP] = PTRSIZE;
|
||||
goto return_fixnum;
|
||||
|
||||
case FLOTYPE: if (i) goto bad_opnd;
|
||||
obj[C_DISP] = FLOSIZE;
|
||||
goto return_fixnum;
|
||||
|
||||
case PORTTYPE:
|
||||
case SYMTYPE: if (i > 3) goto bad_opnd;
|
||||
goto reify_anyway;
|
||||
|
||||
case CODETYPE: if (i >= get_word(page, disp+4)) goto bad_opnd;
|
||||
goto reify_anyway;
|
||||
|
||||
case BIGTYPE:
|
||||
case STRTYPE: if (i) goto bad_opnd;
|
||||
|
||||
case VECTTYPE:
|
||||
case CONTTYPE:
|
||||
case CLOSTYPE:
|
||||
case ENVTYPE:
|
||||
if (i >= get_word(page, disp+1)) goto bad_opnd;
|
||||
reify_anyway:
|
||||
if (direction)
|
||||
{
|
||||
if (i)
|
||||
{
|
||||
put_ptr(page, disp+i, val[C_PAGE], val[C_DISP]);
|
||||
}
|
||||
else goto bad_opnd;
|
||||
}
|
||||
else
|
||||
{
|
||||
obj[C_PAGE] = (i ? get_byte(page, disp+i) : SPECFIX*2);
|
||||
obj[C_DISP] = get_word(page, disp+i+1);
|
||||
}
|
||||
break;
|
||||
|
||||
default: goto bad_opnd;
|
||||
|
||||
} /* end: switch (ptype[page]>>1) */
|
||||
}
|
||||
else
|
||||
{
|
||||
bad_opnd:
|
||||
if (direction) set_src_er("%REIFY!", 3, obj, index, val);
|
||||
else set_src_er("%REIFY", 2, obj, index);
|
||||
return(-1);
|
||||
}
|
||||
return(0);
|
||||
} /* end of function: reify (direction, obj, index, val) */
|
||||
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
/* =====> SRESET.C */
|
||||
/* TIPC Scheme Runtime Support - Reset
|
||||
(C) Copyright 1984, 1985, 1986 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: 18 December 1984
|
||||
Last Modification: 25 February 1986
|
||||
*/
|
||||
#include "ctype.h"
|
||||
#include "scheme.h"
|
||||
|
||||
/************************************************************************/
|
||||
/* Scheme-Reset */
|
||||
/************************************************************************/
|
||||
scheme_reset()
|
||||
{
|
||||
int car_page, car_disp;
|
||||
int i;
|
||||
int page, disp;
|
||||
|
||||
ENTER(scheme_reset);
|
||||
|
||||
/* create a pointer to the symbol "scheme-top-level" */
|
||||
intern(tmp_reg, "SCHEME-TOP-LEVEL", 16);
|
||||
|
||||
/* If first call to Scheme-reset, initialize state parameters */
|
||||
if (!FP_save)
|
||||
{
|
||||
FP_save = FP;
|
||||
page = CORRPAGE(FNV_save[C_PAGE] = FNV_pag);
|
||||
disp = FNV_save[C_DISP] = FNV_dis;
|
||||
|
||||
/* find the binding for "scheme-top-level" */
|
||||
while (page)
|
||||
{
|
||||
car_page = CORRPAGE(get_byte(page, disp));
|
||||
car_disp = get_word(page, disp+1);
|
||||
if (tmp_disp == get_word(car_page, car_disp+1) &&
|
||||
tmp_page == get_byte(car_page, car_disp))
|
||||
{
|
||||
STL_save[C_PAGE] = get_byte(car_page, car_disp+3);
|
||||
STL_save[C_DISP] = get_word(car_page, car_disp+4);
|
||||
break;
|
||||
}
|
||||
i = CORRPAGE(get_byte(page, disp+3));
|
||||
disp = get_word(page, disp+4);
|
||||
page = i;
|
||||
} /* end: while (page) */
|
||||
|
||||
if (!page) /* if "scheme-top-level" not in fluids, error */
|
||||
{
|
||||
print_and_exit(
|
||||
"[VM FATAL ERROR] No fluid binding for SCHEME-TOP-LEVEL\n");
|
||||
}
|
||||
} /* end: if (!FP_save) */
|
||||
|
||||
else
|
||||
{
|
||||
/* Reset fluid environment */
|
||||
page = CORRPAGE(FNV_pag = FNV_save[C_PAGE]);
|
||||
disp = FNV_dis = FNV_save[C_DISP];
|
||||
|
||||
/* find the binding for "scheme-top-level" */
|
||||
while (page)
|
||||
{
|
||||
car_page = CORRPAGE(get_byte(page, disp));
|
||||
car_disp = get_word(page, disp+1);
|
||||
if (tmp_disp == get_word(car_page, car_disp+1) &&
|
||||
tmp_page == get_byte(car_page, car_disp))
|
||||
{
|
||||
put_ptr(car_page, car_disp+3, STL_save[C_PAGE], STL_save[C_DISP]);
|
||||
break;
|
||||
}
|
||||
i = CORRPAGE(get_byte(page, disp+3));
|
||||
disp = get_word(page, disp+4);
|
||||
page = i;
|
||||
} /* end: while (page) */
|
||||
|
||||
ASSERT (page /* make sure scheme-top-level updated */ );
|
||||
} /* end: else */
|
||||
|
||||
} /* end of function: scheme_reset() */
|
||||
|
||||
|
|
@ -0,0 +1,493 @@
|
|||
/* =====> STRACE.C */
|
||||
/* TIPC Scheme '84 Runtime Support - Driver
|
||||
(C) Copyright 1984, 1985, 1987 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:
|
||||
11 February 1986 - Remainder Divide by Zero fix
|
||||
(see also sinterp.asm)
|
||||
dbs 21 Oct 86 - changed %graphics to seven arguments
|
||||
(see also sinterp.asm)
|
||||
rb 13 Mar 87 - added %xesc
|
||||
*/
|
||||
#include "scheme.h"
|
||||
|
||||
static char *opcodes[256] = {
|
||||
/* 000 */ "load", "ld-const", "ld-imm", "ld-nil",
|
||||
"ld-local", "ld-lex", "ld-env", "ld-global",
|
||||
/* 008 */ "ld-fluid", "ld-vec-s", "ld-vec-l", "ld-vec-r",
|
||||
"st-local", "st-lex", "st-env", "st-global",
|
||||
/* 016 */ "st-fluid", "st-vec-s", "st-vec-l", "st-vec-r",
|
||||
"set-car!", "set-cdr!", "set-ref!", "swap-ref!",
|
||||
/* 024 */ "pop", "push", "drop", "ld-global-r",
|
||||
"(unused)", "bind-fl", "unbind-fl", "define!",
|
||||
/* 032 */ "jmp-s", "jmp-l", "j-nil-s", "j-nil-l",
|
||||
"jnnil-s", "jnnil-l", "jatom-s", "jatom-l",
|
||||
/* 040 */ "jnatom-s", "jnatom-l", "jeq-s", "jeq-l",
|
||||
"jneq-s", "jneq-l", "deref", "ref",
|
||||
/* 048 */ "call", "call-tr", "call/cc", "call/cc-tr",
|
||||
"call-cl", "call-cl-tr", "call/cc-cl", "call/cc-cl-tr",
|
||||
/* 056 */ "apply-cl", "apply-cl-tr", "execute", "exit",
|
||||
"close", "drop-env", "mk-hash-env", "ld-fluid-r",
|
||||
/* 064 */ "%%car", "%%cdr", "caar", "cadr",
|
||||
"cdar", "cddr", "caaar", "caadr",
|
||||
/* 072 */ "cadar", "caddr", "cdaar", "cdadr",
|
||||
"cddar", "cdddr", "cadddr", "cons",
|
||||
/* 080 */ "add", "add-imm", "sub", "mul",
|
||||
"mul-imm", "div", "div-imm", "quotient",
|
||||
/* 088 */ "remainder", "%car", "%cdr", "random",
|
||||
"<", "<=", "=", ">",
|
||||
/* 096 */ ">=", "!=", "max", "min",
|
||||
"eq?", "eqv?", "equal?", "memq",
|
||||
/* 104 */ "memv", "member", "reverse!", "reverse",
|
||||
"assq", "assv", "assoc", "list",
|
||||
/* 112 */ "append!", "append", "delq!", "delete!",
|
||||
"get-prop", "put-prop", "proplist", "remprop",
|
||||
/* 120 */ "list2", "(unused)", "(unused)", "(unused)",
|
||||
"(unused)", "bitwise-xor", "bitwise-and", "bitwise-or",
|
||||
|
||||
/* 128 */ "atom?", "closure?", "code?", "continuation?",
|
||||
"even?", "float?", "fluid-bound?", "integer?",
|
||||
/* 136 */ "null?", "number?", "odd?", "pair?",
|
||||
"port?", "proc?", "ref?", "string?",
|
||||
/* 144 */ "symbol?", "vector?", "zero?", "negative?",
|
||||
"positive?", "abs", "float", "minus",
|
||||
/* 152 */ "floor", "ceiling", "truncate", "round",
|
||||
"char?", "env?", "(unused)", "(unused)",
|
||||
/* 160 */ "ascii->char","char->ascii", "(unused)", "(unused)",
|
||||
"(unused)", "length", "last-pair", "substr",
|
||||
/* 168 */ "alloc-vector","vector-size", "vector-fill", "mk-pack-vector",
|
||||
"substr-display","(unused)", "%start-timer", "%stop-timer",
|
||||
/* 176 */ "open-port", "close-port", "prin1", "princ",
|
||||
"print", "newline", "read", "(unused)",
|
||||
/* 184 */ "print-length","(unused)", "read-line", "read-atom",
|
||||
"read-char", "%transcript", "read-char-ready?","fasl",
|
||||
/* 192 */ "char=", "char-equal?", "char<", "char-less?",
|
||||
"char-upcase","char-downcase","string-length","string-ref",
|
||||
/* 200 */ "string-set!","make-string", "string-fill!", "str->sym",
|
||||
"str->un-sym","sym->str", "srch-next", "srch-prev",
|
||||
/* 208 */ "%make-window","%reify-port!","%reify-port", "%clear-window",
|
||||
"%save-window","%restore-window","%str-append","%graphics",
|
||||
/* 216 */ "%reify", "mk-env", "env-parent", "env-lookup",
|
||||
"define-env", "push-env", "drop-env", "ld-env",
|
||||
/* 224 */ "st-env", "set-glob-env!","%reify!", "obj-hash",
|
||||
"obj-unhash", "%reify-stack", "%reify-stack!","set-file-position!",
|
||||
/* 232 */ "%esc1", "%esc2", "%esc3", "%esc4",
|
||||
"%esc5", "%esc6", "%esc7", "%xesc",
|
||||
/* 240 */ "(unused)", "(unused)", "(unused)", "(unused)",
|
||||
"(unused)", "(unused)", "(unused)", "%gc2",
|
||||
/* 248 */ "%halt", "%gc", "ptime", "reset",
|
||||
"scheme-reset","clear-regs", "(escape)", "begin-debug"};
|
||||
|
||||
/* Format Codes: */
|
||||
#define NO_OPERANDS 0 /* no operands */
|
||||
#define REG 1 /* reg */
|
||||
#define R_R 2 /* reg,reg */
|
||||
#define R_R_R 3 /* reg,reg,reg */
|
||||
|
||||
#define SB 4 /* short offset (signed) */
|
||||
#define UB 5 /* short offset (unsigned) */
|
||||
#define SW 6 /* long offset (signed) */
|
||||
|
||||
#define UB_R 7 /* byte (unsigned),reg */
|
||||
|
||||
#define R_SB 8 /* reg,short offset (signed) */
|
||||
#define R_UB 9 /* reg,short offset (unsigned) */
|
||||
#define R_SW 10 /* reg,long offset (signed) */
|
||||
|
||||
#define R_UB_R 11 /* reg,byte (unsigned),reg */
|
||||
#define R_UW_R 12 /* reg,word (unsigned),reg */
|
||||
|
||||
#define R_UB_SB 13 /* reg,byte (unsigned),byte (signed) */
|
||||
#define R_SW_UB 14 /* reg,word (signed),byte (unsigned) */
|
||||
#define SW_SB_UB 15 /* word (signed),byte (signed),byte (unsigned) */
|
||||
|
||||
#define R_4 16 /* reg,reg,reg,reg */
|
||||
#define R_5 17 /* reg,reg,reg,reg,reg */
|
||||
#define R_6 18 /* reg,reg,reg,reg,reg,reg */
|
||||
#define R_7 19 /* reg,reg,reg,reg,reg,reg,reg */
|
||||
|
||||
#define UB_R_VR 20 /* length, reg, zero or more regs */
|
||||
|
||||
/* this array is indexed by the format codes just above */
|
||||
static int n_ops[21] = {0,1,2,3,-1,-1,-1,-1,2,-1,-1,-1,-1,-1,-1,-1,4,5,6,7,-1};
|
||||
|
||||
static char format[256] = {
|
||||
/* 000 */ R_R, R_UB, R_SB, REG,
|
||||
R_UB, R_UB_SB, R_UB, R_UB,
|
||||
/* 008 */ R_UB, R_UB, R_SW /*cheat*/, R_R,
|
||||
R_UB, R_UB_SB, R_UB, R_UB,
|
||||
/* 016 */ R_UB, R_UB_R, R_UW_R, R_R_R,
|
||||
R_R, R_R, R_R, R_R,
|
||||
/* 024 */ REG, REG, UB, R_R,
|
||||
NO_OPERANDS, UB_R, UB, R_UB,
|
||||
/* 032 */ SB, SW, R_SB, R_SW,
|
||||
R_SB, R_SW, R_SB, R_SW,
|
||||
/* 040 */ R_SB, R_SW, R_SB, R_SW,
|
||||
R_SB, R_SW, REG, REG,
|
||||
/* 048 */ SW_SB_UB, SW_SB_UB, SW_SB_UB, SW_SB_UB,
|
||||
R_UB, R_UB, REG, REG,
|
||||
/* 056 */ R_R, R_R, REG, NO_OPERANDS,
|
||||
R_SW_UB, UB, REG, R_R,
|
||||
/* 064 */ R_R, R_R, R_R, R_R,
|
||||
R_R, R_R, R_R, R_R,
|
||||
/* 072 */ R_R, R_R, R_R, R_R,
|
||||
R_R, R_R, R_R, R_R_R,
|
||||
/* 080 */ R_R, R_SB, R_R, R_R,
|
||||
R_SB, R_R, R_SB, R_R,
|
||||
/* 088 */ R_R, REG, REG, REG,
|
||||
R_R, R_R, R_R, R_R,
|
||||
/* 096 */ R_R, R_R, R_R, R_R,
|
||||
R_R, R_R, R_R, R_R,
|
||||
/* 104 */ R_R, R_R, REG, REG,
|
||||
R_R, R_R, R_R, REG,
|
||||
/* 112 */ R_R, R_R, R_R, R_R,
|
||||
R_R, R_R_R, REG, R_R,
|
||||
/* 120 */ R_R, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS,
|
||||
NO_OPERANDS, R_R, R_R, R_R,
|
||||
|
||||
/* 128 */ REG, REG, REG, REG,
|
||||
REG, REG, REG, REG,
|
||||
/* 136 */ REG, REG, REG, REG,
|
||||
REG, REG, REG, REG,
|
||||
/* 144 */ REG, REG, REG, REG,
|
||||
REG, REG, REG, REG,
|
||||
/* 152 */ REG, REG, REG, REG,
|
||||
REG, REG, NO_OPERANDS, NO_OPERANDS,
|
||||
/* 160 */ REG, REG, NO_OPERANDS, NO_OPERANDS,
|
||||
NO_OPERANDS, REG, REG, R_R_R,
|
||||
/* 168 */ REG, REG, R_R, R_R_R,
|
||||
R_5, NO_OPERANDS, REG, REG,
|
||||
/* 176 */ R_R, REG, R_R, R_R,
|
||||
R_R, REG, REG, NO_OPERANDS,
|
||||
/* 184 */ REG, NO_OPERANDS, NO_OPERANDS, REG,
|
||||
REG, REG, REG, REG,
|
||||
/* 192 */ R_R, R_R, R_R, R_R,
|
||||
REG, REG, REG, R_R,
|
||||
/* 200 */ R_R_R, R_R, R_R, REG,
|
||||
REG, REG, R_4, R_4,
|
||||
/* 208 */ REG, R_R_R, R_R, REG,
|
||||
REG, R_R, R_7, R_7,
|
||||
/* 216 */ R_R, REG, REG, R_R,
|
||||
R_R_R, UB, UB, R_UB,
|
||||
/* 224 */ R_UB, REG, R_R_R, REG,
|
||||
REG, REG, R_R, R_R_R,
|
||||
/* 232 */ REG, R_R, R_R_R, R_4,
|
||||
R_5, R_6, R_7, UB_R_VR,
|
||||
/* 240 */ NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS,
|
||||
NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS,
|
||||
/* 248 */ NO_OPERANDS, NO_OPERANDS, REG, NO_OPERANDS,
|
||||
NO_OPERANDS, NO_OPERANDS, NO_OPERANDS, NO_OPERANDS};
|
||||
|
||||
static int page,disp,display;
|
||||
|
||||
t_inst(_page, pc, run, _display)
|
||||
int _page, *pc, run, _display;
|
||||
{
|
||||
int len = 3; /* instruction length (number of bytes) */
|
||||
int op;
|
||||
int reg1,reg2,reg3;
|
||||
int nregs; /* #regs in a variable-length instruction */
|
||||
int stat = 0; /* status returned from "interp" */
|
||||
|
||||
disp = *pc;
|
||||
page = _page;
|
||||
display = _display;
|
||||
|
||||
op = get_byte(page, disp);
|
||||
if (display) printf("\t\t\t\t%3x:%04x %12s", page, *pc, opcodes[op]);
|
||||
reg1 = reg2 = reg3 = -1;
|
||||
switch(format[op])
|
||||
{
|
||||
case NO_OPERANDS: /* no operands */
|
||||
if (display) printf("\n");
|
||||
len = 1;
|
||||
break;
|
||||
|
||||
case REG: /* one register operand */
|
||||
reg1 = get_reg(1);
|
||||
fmt_regs(1);
|
||||
len = 2;
|
||||
break;
|
||||
|
||||
case R_R: /* two register operands */
|
||||
reg1 = get_reg(1);
|
||||
reg2 = get_reg(2);
|
||||
fmt_regs(2);
|
||||
break;
|
||||
|
||||
case R_R_R: /* three register operands */
|
||||
reg1 = get_reg(1);
|
||||
reg2 = get_reg(2);
|
||||
reg3 = get_reg(3);
|
||||
fmt_regs(3);
|
||||
len = 4;
|
||||
break;
|
||||
|
||||
case R_4: /* four register operands */
|
||||
reg1 = get_reg(1);
|
||||
reg2 = get_reg(2);
|
||||
reg3 = get_reg(3);
|
||||
fmt_regs(4);
|
||||
len = 5;
|
||||
break;
|
||||
|
||||
case R_5: /* five register operands */
|
||||
reg1 = get_reg(1);
|
||||
reg2 = get_reg(2);
|
||||
reg3 = get_reg(3);
|
||||
fmt_regs(5);
|
||||
len = 6;
|
||||
break;
|
||||
|
||||
case R_6: /* six register operands */
|
||||
reg1 = get_reg(1);
|
||||
reg2 = get_reg(2);
|
||||
reg3 = get_reg(3);
|
||||
fmt_regs(6);
|
||||
len = 7;
|
||||
break;
|
||||
|
||||
case R_7: /* seven register operands */
|
||||
reg1 = get_reg(1);
|
||||
reg2 = get_reg(2);
|
||||
reg3 = get_reg(3);
|
||||
fmt_regs(7);
|
||||
len = 8;
|
||||
break;
|
||||
|
||||
case SB: /* short offset (signed byte) */
|
||||
if (display) printf(" %d\n", (get_w(1) << 8) >> 8);
|
||||
len = 2;
|
||||
break;
|
||||
|
||||
case SW: /* long offset (signed word) */
|
||||
if (display) printf(" %d\n", get_w(1));
|
||||
break;
|
||||
|
||||
case UB: /* unsigned short offset (byte) */
|
||||
if (display) printf(" %d\n", get_b(1));
|
||||
len = 2;
|
||||
break;
|
||||
|
||||
case UB_R: /* unsigned short offset (byte) plus register */
|
||||
reg1 = get_reg(2);
|
||||
if (display) printf(" %d,R%d\n", get_b(1), reg1);
|
||||
break;
|
||||
|
||||
case R_SB: /* one register plus short offset (signed) */
|
||||
reg1 = get_reg(1);
|
||||
if (display) printf(" R%d,%d\n", reg1, (get_b(2) << 8) >> 8);
|
||||
break;
|
||||
|
||||
case R_UB: /* one register plus short offset (unsigned) */
|
||||
reg1 = get_reg(1);
|
||||
if (display) printf(" R%d,%d\n", reg1, get_b(2));
|
||||
break;
|
||||
|
||||
case R_SW: /* one register plus long offset (signed) */
|
||||
reg1 = get_reg(1);
|
||||
if (display) printf(" R%d,%d\n", reg1, get_w(2));
|
||||
len = 4;
|
||||
break;
|
||||
|
||||
case R_UB_R: /* register, short offset (unsigned), register */
|
||||
reg1 = get_reg(1);
|
||||
reg2 = get_reg(3);
|
||||
if (display) printf(" R%d,%d,R%d\n", reg1, get_b(2), reg2);
|
||||
len = 4;
|
||||
break;
|
||||
|
||||
case R_UW_R: /* register, long offset (unsigned), register */
|
||||
reg1 = get_reg(1);
|
||||
reg2 = get_reg(4);
|
||||
if (display) printf(" R%d,%d,R%d\n", reg1, get_w(2), reg2);
|
||||
len = 5;
|
||||
break;
|
||||
|
||||
case R_UB_SB: /* register, unsigned byte, signed byte */
|
||||
reg1 = get_reg(1);
|
||||
if (display) printf(" R%d,%d,%d\n", reg1, get_b(2),
|
||||
(get_b(3) << 8) >> 8);
|
||||
len = 4;
|
||||
break;
|
||||
|
||||
case R_SW_UB: /* register, signed word, unsigned byte */
|
||||
reg1 = get_reg(1);
|
||||
if (display) printf(" R%d,%d,%d\n", reg1, get_w(2), get_b(4));
|
||||
len = 5;
|
||||
break;
|
||||
|
||||
case SW_SB_UB: /* signed word, signed byte, unsigned byte */
|
||||
if (display) printf(" %d,%d,%d\n", get_w(1),
|
||||
(get_b(3) << 8) >> 8, get_b(4));
|
||||
len = 5;
|
||||
break;
|
||||
|
||||
case UB_R_VR: /* unsigned length byte, register, zero or more registers */
|
||||
len = get_b(1); /* length byte = #bytes in inst - 1) */
|
||||
nregs = len - 2; /* # optional registers */
|
||||
reg1 = get_reg(2);
|
||||
if (nregs >= 1) reg2 = get_reg(3);
|
||||
if (nregs >= 2) reg3 = get_reg(4);
|
||||
if (display) {
|
||||
printf(" %d,R%d\n",len,reg1);
|
||||
if (nregs > 0) {
|
||||
printf("\t\t\t\t\t\t ");
|
||||
disp += 2; /* move over opcode, length */
|
||||
fmt_regs(nregs); /* enough regs will give ugly wraparound */
|
||||
} /* end if (nregs ...) */
|
||||
} /* end if (display) */
|
||||
len = len + 1;
|
||||
break;
|
||||
|
||||
default: /* ? */
|
||||
printf("t_inst: invalid instruction format-- op=%02x\n",op);
|
||||
|
||||
} /* end: switch(format[op]) */
|
||||
|
||||
if (run) {
|
||||
if (display) {
|
||||
/* dump the registers prior to execution */
|
||||
if (reg2 == reg1) reg2 = -1;
|
||||
if (reg3 == reg1 || reg3 == reg2) reg3 = -1;
|
||||
if (reg1 >= 0) prt_reg(reg1);
|
||||
if (reg2 >= 0) prt_reg(reg2);
|
||||
if (reg3 >= 0) prt_reg(reg3);
|
||||
} /* end: if (display) */
|
||||
|
||||
/* execute the instruction */
|
||||
stat = interp(pc, 1);
|
||||
|
||||
if (display) {
|
||||
/* dump the registers after execution */
|
||||
if (reg1 >= 0) {
|
||||
printf("After execution:\n");
|
||||
prt_reg(reg1);
|
||||
if (reg2 >= 0) prt_reg(reg2);
|
||||
if (reg3 >= 0) prt_reg(reg3);
|
||||
} /* end: if (reg1 >= 0) */
|
||||
} /* end: if (display) */
|
||||
} /* end: if (run) */
|
||||
else (*pc) += len;
|
||||
return(stat);
|
||||
} /* end of function: t_inst(page,disp) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Format a Series of Register Operands */
|
||||
/************************************************************************/
|
||||
fmt_regs(n)
|
||||
int n; /* the number of register operands */
|
||||
{
|
||||
int i; /* the usual index variable */
|
||||
char *comma; /* text used to separate assembly language operands */
|
||||
if (display)
|
||||
{
|
||||
comma = " "; /* output blanks to separate instruction, first operand */
|
||||
for (i = 1; i <= n; i++)
|
||||
{
|
||||
printf("%sR%d", comma, get_reg(i)); /* print the next register */
|
||||
comma = ","; /* subsequent items separated by a comma */
|
||||
}
|
||||
printf("\n"); /* output a newline character */
|
||||
}
|
||||
} /* end of function: fmt_regs(n) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Return Register Number */
|
||||
/************************************************************************/
|
||||
get_reg(offset)
|
||||
int offset;
|
||||
{
|
||||
return(get_byte(page, disp+offset) >> 2);
|
||||
} /* end of function: get_reg(offset) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Return Word Value */
|
||||
/************************************************************************/
|
||||
get_w(offset)
|
||||
int offset;
|
||||
{
|
||||
return(get_word(page, disp+offset));
|
||||
} /* end of function: get_reg(offset) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Return Byte Value */
|
||||
/************************************************************************/
|
||||
get_b(offset)
|
||||
int offset;
|
||||
{
|
||||
return(get_byte(page, disp+offset));
|
||||
} /* end of function: get_reg(offset) */
|
||||
|
||||
/************************************************************************/
|
||||
/* "Disassemble" a Scheme Instruction for Error Message *IRRITANT* */
|
||||
/* */
|
||||
/* Note: This routine works for instructions with only registers for */
|
||||
/* operands. Immediates, offsets, etc., will cause a list to */
|
||||
/* be created with only the function name in the first position. */
|
||||
/* */
|
||||
/* The "offset" operand is the absolute displacement of the */
|
||||
/* instruction in the page containing the current code block, */
|
||||
/* not the displacement relative to the beginning of the code */
|
||||
/* block. */
|
||||
/************************************************************************/
|
||||
disassemble(function,offset)
|
||||
char *function; /* string containing function name */
|
||||
int offset; /* offset in PAGE containing current code block
|
||||
of the instruction to be disassembled */
|
||||
{
|
||||
int reg_addr[10]; /* register addresses of the instruction's operands */
|
||||
int i; /* index variable */
|
||||
int number_of_operands; /* number of operands for the instruction */
|
||||
int op; /* opcode for the instruction */
|
||||
static int fix_reg[2] = {0,SPECFIX*2}; /* special "register" for immediates */
|
||||
|
||||
/* determine characteristics of the instruction with which we're dealing */
|
||||
page = CORRPAGE(CB_pag);
|
||||
op = get_byte(page,offset++);
|
||||
tmp_page = tmp_disp = 0;
|
||||
if ((number_of_operands = n_ops[format[op]]) > 0)
|
||||
{
|
||||
/* compute the register address for each operand */
|
||||
for (i = 0; i < number_of_operands; i++)
|
||||
reg_addr[i] = get_byte(page,offset++) + (int)(®0);
|
||||
|
||||
/* if last operand is an immediate operand, phoney up a register for it */
|
||||
if (format[op] == R_SB)
|
||||
{
|
||||
reg_addr[i-1] = (int) fix_reg;
|
||||
fix_reg[C_DISP] = (get_byte(page,offset-1)<<8)>>8;
|
||||
}
|
||||
|
||||
/* cons up argument list */
|
||||
for (i = number_of_operands - 1; i >= 0; i--)
|
||||
cons(tmp_reg, reg_addr[i], tmp_reg);
|
||||
}
|
||||
|
||||
/* create a symbol for the function name and cons on front of argument list */
|
||||
intern(tm2_reg, function, strlen(function));
|
||||
cons(tmp_reg, tm2_reg, tmp_reg);
|
||||
} /* end of function: disassemble(function,offset) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Display Accounting Information */
|
||||
/************************************************************************/
|
||||
accounting()
|
||||
{
|
||||
extern int gc_count; /* garbage collector invocation count */
|
||||
extern long stk_in, stk_out; /* bytes transfered to/from the stack */
|
||||
ENTER(accounting);
|
||||
|
||||
printf("\nGarbage collector invoked %d times\n", gc_count);
|
||||
|
||||
printf("\n%9ld bytes transfered from stack to heap\n%9ld%s",
|
||||
stk_out, stk_in, " bytes transfered from heap to stack\n");
|
||||
} /* end of function: accounting() */
|
||||
|
||||
|
|
@ -0,0 +1,543 @@
|
|||
/* =====> SUPPORT.C */
|
||||
/* TIPC Scheme '84 Runtime Support - Non-Arithmetic Support
|
||||
(C) Copyright 1984,1985 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: 24 May 1984
|
||||
Last Modification: 21 October 1985
|
||||
*/
|
||||
#include "scheme.h"
|
||||
#include "slist.h"
|
||||
|
||||
char *getmem(); /* Lattice C's memory allocation routine */
|
||||
|
||||
/**********************************************************************/
|
||||
/* Substring */
|
||||
/**********************************************************************/
|
||||
ssubstr(string, start_reg, end_reg)
|
||||
int string[2]; /* register containing string pointer */
|
||||
int start_reg[2]; /* register containing starting character position */
|
||||
int end_reg[2]; /* register containing ending character position */
|
||||
{
|
||||
int end; /* ending character position */
|
||||
int start; /* starting character position */
|
||||
int str_page, str_disp;/* string's page and displacement pointers */
|
||||
int i;
|
||||
|
||||
str_page = CORRPAGE(string[C_PAGE]);
|
||||
str_disp = string[C_DISP];
|
||||
|
||||
/* validate input arguments */
|
||||
i = get_word(str_page,str_disp+1);
|
||||
if (i < 0)
|
||||
i = i + BLK_OVHD + PTRSIZE; /* adjust for small string */
|
||||
if (ptype[str_page] == STRTYPE*2 &&
|
||||
start_reg[C_PAGE] == SPECFIX*2 &&
|
||||
end_reg[C_PAGE] == SPECFIX*2 &&
|
||||
(start = get_fix(CORRPAGE(start_reg[C_PAGE]),start_reg[C_DISP])) >= 0 &&
|
||||
(end = get_fix(CORRPAGE(end_reg[C_PAGE]),end_reg[C_DISP])) >= start &&
|
||||
end <= i-BLK_OVHD)
|
||||
{ /* arguments o.k.-- allocate new string and copy substring characters */
|
||||
alloc_block(tmp_reg, STRTYPE, end-start);
|
||||
msubstr(tmp_reg, string, start, end);
|
||||
string[C_PAGE] = tmp_page;
|
||||
string[C_DISP] = tmp_disp;
|
||||
}
|
||||
else
|
||||
{ /* invalid arguments to substring */
|
||||
set_src_err("SUBSTRING", 3, string, start_reg, end_reg);
|
||||
return(-1);
|
||||
}
|
||||
return(0);
|
||||
} /* end of function: ssubstr(string, start_reg, end_reg) */
|
||||
|
||||
|
||||
/**********************************************************************/
|
||||
/* Test if two pointers are equal? */
|
||||
/**********************************************************************/
|
||||
sequal_p(reg1, reg2)
|
||||
int reg1[2], reg2[2];
|
||||
{
|
||||
int disp1,disp2; /* displacements of the two pointers */
|
||||
int i; /* index & temporary variable */
|
||||
int length; /* length of a variable length object */
|
||||
int page1,page2; /* page numbers of the two pointers */
|
||||
int result = FALSE; /* result of the comparison */
|
||||
int temp_r1[2],temp_r2[2]; /* temporary "registers" for equal_p calls */
|
||||
int type; /* type of the pointers being compared */
|
||||
|
||||
double get_flo(); /* fetch flonum from Scheme's memory */
|
||||
|
||||
/* Localize page and displacement values */
|
||||
page1 = reg1[C_PAGE];
|
||||
page2 = reg2[C_PAGE];
|
||||
disp1 = reg1[C_DISP];
|
||||
disp2 = reg2[C_DISP];
|
||||
|
||||
recurse:
|
||||
/* Quick test in case the pointers are "eq?" */
|
||||
if (disp1 == disp2 && page1 == page2) return(TRUE);
|
||||
|
||||
/* If pointer types are the same, check further */
|
||||
if ((type = ptype[(page1 = CORRPAGE(page1)) ]) ==
|
||||
ptype[(page2 = CORRPAGE(page2)) ] )
|
||||
{
|
||||
/* Check to see if shift-break key depressed */
|
||||
if (s_break) restart(3);
|
||||
/* Check to make sure we haven't recursed too deeply */
|
||||
if (stkspc() < 64)
|
||||
{
|
||||
printf("[VM ERROR encountered!] Stack overflow in EQUAL?\n%s%s",
|
||||
"Expression lists circular or too complex\n",
|
||||
"Attempting to execute SCHEME-RESET\n[Returning to top level]");
|
||||
force_reset();
|
||||
/* note: control does not return here */
|
||||
}
|
||||
/* If okay, check the objects */
|
||||
switch (type>>1)
|
||||
{
|
||||
case LISTTYPE: /* test if one pointer is nil */
|
||||
if ((!page1 && page2) || (!page2 && page1))
|
||||
return (FALSE);
|
||||
ldreg(temp_r1, page1, disp1);
|
||||
ldreg(temp_r2, page2, disp2);
|
||||
/* test "equal?-ness" of "cars" */
|
||||
if (sequal_p(temp_r1, temp_r2))
|
||||
{
|
||||
i = page1;
|
||||
page1 = get_byte(i, disp1+3);
|
||||
disp1 = get_word(i, disp1+4);
|
||||
i = page2;
|
||||
page2 = get_byte(i, disp2+3);
|
||||
disp2 = get_word(i, disp2+4);
|
||||
/* test "equal?-ness" of "cdrs" */
|
||||
goto recurse;
|
||||
}
|
||||
break;
|
||||
|
||||
case FLOTYPE: result = (get_flo(page1, disp1) ==
|
||||
get_flo(page2, disp2));
|
||||
break;
|
||||
case BIGTYPE:
|
||||
case STRTYPE: /* Compare the objects */
|
||||
result = mcmpstr(reg1, reg2);
|
||||
break;
|
||||
|
||||
case ARYTYPE: /* test each entry of the arrays for equality */
|
||||
if ((length = get_word(page1, disp1 + 1)) ==
|
||||
get_word(page2, disp2 + 1) )
|
||||
{
|
||||
for (i = PTRSIZE; i < length; i += PTRSIZE)
|
||||
{
|
||||
disp1 += PTRSIZE;
|
||||
ldreg(temp_r1, page1, disp1);
|
||||
disp2 += PTRSIZE;
|
||||
ldreg(temp_r2, page2, disp2);
|
||||
/* test "equal?-ness" of vector elements */
|
||||
if (!(result = sequal_p(temp_r1, temp_r2))) break;
|
||||
}
|
||||
}
|
||||
break;
|
||||
|
||||
case FIXTYPE:
|
||||
case CHARTYPE:
|
||||
case SYMTYPE:
|
||||
case CONTTYPE:
|
||||
case CLOSTYPE:
|
||||
case CODETYPE:
|
||||
case PORTTYPE:
|
||||
case ENVTYPE: /* For these types, assume that "eq?-ness" is o.k. */
|
||||
break;
|
||||
|
||||
case REFTYPE:
|
||||
case FREETYPE:
|
||||
default: printf("[VM INTERNAL ERROR] EQUAL?: unexpected type=%d\n",type);
|
||||
getch();
|
||||
} /* end: switch (type>>1) */
|
||||
}
|
||||
return(result);
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* String->Symbol */
|
||||
/************************************************************************/
|
||||
str_2_sym(reg)
|
||||
int reg[2];
|
||||
{
|
||||
int page, disp, len;
|
||||
char *string; /* pointer to character string */
|
||||
ENTER(str_2_sym);
|
||||
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
disp = reg[C_DISP];
|
||||
if (ptype[page] != STRTYPE*2)
|
||||
{
|
||||
set_src_err("STRING->SYMBOL", 1, reg);
|
||||
return(-1);
|
||||
}
|
||||
else
|
||||
{
|
||||
len = get_word(page, disp+1);
|
||||
if (len < 0)
|
||||
len = len + BLK_OVHD + PTRSIZE; /* adjust for small string */
|
||||
len -= BLK_OVHD;
|
||||
if (!(string = getmem(len+1))) getmem_error(rtn_name);
|
||||
get_str(string, page, disp);
|
||||
string[len] = '\0';
|
||||
intern(reg, string, len);
|
||||
rlsstr(string);
|
||||
}
|
||||
return(0);
|
||||
} /* end of function: str_2_sym(reg) */
|
||||
|
||||
/************************************************************************/
|
||||
/* String->Uninterned-symbol */
|
||||
/************************************************************************/
|
||||
str_2_usym(reg)
|
||||
int reg[2];
|
||||
{
|
||||
int page, disp, len;
|
||||
char *string; /* pointer to character string */
|
||||
ENTER(str_2_usym);
|
||||
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
disp = reg[C_DISP];
|
||||
if (ptype[page] != STRTYPE*2)
|
||||
{
|
||||
set_src_err("STRING->UNINTERNED-SYMBOL", 1, reg);
|
||||
return(-1);
|
||||
}
|
||||
else
|
||||
{
|
||||
len = get_word(page, disp+1);
|
||||
if (len < 0)
|
||||
len = len + BLK_OVHD + PTRSIZE; /* adjust for small string */
|
||||
len -= BLK_OVHD;
|
||||
if (!(string = getmem(len+1))) getmem_error(rtn_name);
|
||||
get_str(string, page, disp);
|
||||
string[len] = '\0';
|
||||
alloc_sym(reg, len);
|
||||
put_sym(string, CORRPAGE(reg[C_PAGE]), reg[C_DISP],NIL_PAGE*2,NIL_DISP,0);
|
||||
rlsstr(string);
|
||||
}
|
||||
return(0);
|
||||
} /* end of function: str_2_usym(reg) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Symbol->String */
|
||||
/************************************************************************/
|
||||
sym_2_str(reg)
|
||||
int reg[2];
|
||||
{
|
||||
int page;
|
||||
char *string; /* pointer to character string */
|
||||
|
||||
char *symbol_name(); /* retrieves symbol's print name */
|
||||
|
||||
ENTER(sym_2_str);
|
||||
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
if (ptype[page] != SYMTYPE*2)
|
||||
{
|
||||
set_src_err("SYMBOL->STRING", 1, reg);
|
||||
return(-1);
|
||||
}
|
||||
else
|
||||
{
|
||||
string = symbol_name(page, reg[C_DISP]);
|
||||
alloc_string(reg, string);
|
||||
rlsstr(string);
|
||||
}
|
||||
return(0);
|
||||
} /* end of function: sym_2_str(reg) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Retrieve Symbol Name */
|
||||
/* */
|
||||
/* Purpose: To fetch the print name of a symbol from Scheme's memory */
|
||||
/* and return it in a Lattice C string. */
|
||||
/************************************************************************/
|
||||
char *symbol_name(page,disp)
|
||||
int page,disp; /* pointer to the string data type */
|
||||
{
|
||||
char *name = NULL;
|
||||
int length; /* length of symbol + 1 (characters) */
|
||||
ENTER(symbol_name);
|
||||
|
||||
if (ptype[page] == SYMTYPE*2)
|
||||
{
|
||||
length = get_word(page, disp+1) - (BLK_OVHD + PTRSIZE);
|
||||
if (!(name = getmem(length))) getmem_error(rtn_name);
|
||||
get_sym(name, page, disp);
|
||||
name[length-1] = '\0';
|
||||
}
|
||||
return(name);
|
||||
} /* end of function: char *symbol_name(page,disp) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Retrieve String Value */
|
||||
/* */
|
||||
/* Purpose: To fetch the value of a string from Scheme's memory */
|
||||
/* and return it in a Lattice C string. */
|
||||
/************************************************************************/
|
||||
char *string_asciz(reg)
|
||||
int reg[2]; /* register containing the string pointer */
|
||||
{
|
||||
char *name = NULL; /* ASCIZ string to be returned to caller */
|
||||
int page,disp; /* page and displacement components of string pointer */
|
||||
int length; /* length of string + 1 (characters) */
|
||||
|
||||
ENTER(string_asciz);
|
||||
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
disp = reg[C_DISP];
|
||||
|
||||
if (ptype[page] == STRTYPE*2)
|
||||
{
|
||||
length = get_word(page, disp+1);
|
||||
if (length < 0)
|
||||
length = length + BLK_OVHD + PTRSIZE; /* adjust for small string */
|
||||
length = length - BLK_OVHD + 1;
|
||||
if (!(name = getmem(length))) getmem_error(rtn_name);
|
||||
get_str(name, page, disp);
|
||||
name[length-1] = '\0';
|
||||
}
|
||||
return(name);
|
||||
} /* end of function: char *string_asciz(reg) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Release String */
|
||||
/* */
|
||||
/* Purpose: To release the memory allocated to a Lattice C character */
|
||||
/* string. If the string is null, the rlsmem is skipped. */
|
||||
/************************************************************************/
|
||||
rlsstr(string)
|
||||
char *string;
|
||||
{
|
||||
if (string) /* is the string allocated? */
|
||||
{
|
||||
if (rlsmem(string, strlen(string)+1)) /* release string's memory */
|
||||
{
|
||||
rlsmem_error("rlsstr"); /* if rlsmem error, print message */
|
||||
}
|
||||
}
|
||||
} /* end of function: rlsstr(string) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Convert Scheme Integer to C Long Integer */
|
||||
/* */
|
||||
/* Purpose: To obtain the value of a Scheme integer (up to 32 bits) */
|
||||
/* for manipulation by the Lattice C support routines. */
|
||||
/* */
|
||||
/* Description: Given a Scheme pointer to an integer value, this */
|
||||
/* routine returns the long integer corresponding to */
|
||||
/* the value of the Scheme integer. */
|
||||
/* */
|
||||
/* Calling Sequence: stat = int2long(value, ptr) */
|
||||
/* where value - address of location where the long */
|
||||
/* integer result is to be stored. */
|
||||
/* ptr - a Scheme register address containing the */
|
||||
/* Scheme representation of the integer */
|
||||
/* value. */
|
||||
/* stat - return code; 0 = no errors, value returned */
|
||||
/* 1 = error, integer too large or ptr */
|
||||
/* was not an integer. */
|
||||
/************************************************************************/
|
||||
int2long(v, reg)
|
||||
long *v; /* pointer to location for long integer result */
|
||||
int reg[2]; /* Scheme "register" containing the integer object */
|
||||
{
|
||||
int page; /* Page field of register */
|
||||
|
||||
page = CORRPAGE(reg[C_PAGE]);
|
||||
switch (ptype[page])
|
||||
{
|
||||
case FIXTYPE*2: *v = get_fix(page, reg[C_DISP]);
|
||||
return(0);
|
||||
case BIGTYPE*2: return(ldlong(v, reg));
|
||||
default: return(1); /* Invalid argument type */
|
||||
} /* end: switch (ptype[page]) */
|
||||
} /* end of function: int2long(value, reg) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Convert C Long Integer to Sheme Integer */
|
||||
/* */
|
||||
/* Purpose: To convert a Lattice C long integer value to the equivalent*/
|
||||
/* Scheme representation. */
|
||||
/* */
|
||||
/* Description: Given a long integer value, this routine creates the */
|
||||
/* equivalent Scheme integer object and returns it in the */
|
||||
/* designated register. */
|
||||
/* */
|
||||
/* Calling Sequence: long2int(reg, value) */
|
||||
/* where value - the Lattice C long integer value to be */
|
||||
/* converted to Scheme representation */
|
||||
/* reg - a Scheme register address to hold the */
|
||||
/* result. */
|
||||
/************************************************************************/
|
||||
long2int(reg, value)
|
||||
int reg[2]; /* Scheme register to hold the result */
|
||||
long value; /* the Lattice C long integer value to be converted */
|
||||
{
|
||||
/* determine if value can be represented as a fixnum */
|
||||
if (value <= 16383 && value >= -16384)
|
||||
{
|
||||
reg[C_PAGE] = SPECFIX*2;
|
||||
reg[C_DISP] = value & 0x7fff;
|
||||
}
|
||||
else /* value is a bignum */
|
||||
{
|
||||
enlarge(reg,value);
|
||||
}
|
||||
} /* end of function: long2int(reg, value) */
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* Append two lists */
|
||||
/************************************************************************/
|
||||
sappend(dest,src)
|
||||
int dest[2]; /* Future result register */
|
||||
int src[2]; /* List onto which to append */
|
||||
{
|
||||
int car[2]; /* Temporary car field pointer */
|
||||
int saved = FALSE; /* Whether a list copy has been pushed */
|
||||
|
||||
C_push(src); C_push(src);
|
||||
mov_reg(tm2_reg, dest); /* save destination operand, in case of error */
|
||||
while (dest[C_PAGE] && ptype[CORRPAGE(dest[C_PAGE])]==LISTTYPE*2)
|
||||
{
|
||||
if (s_break) restart(3); /* shift-break? if so, start over */
|
||||
car[C_PAGE] = dest[C_PAGE]; car[C_DISP] = dest[C_DISP];
|
||||
take_car(car);
|
||||
cons(src, car, nil_reg);
|
||||
if (!saved)
|
||||
{
|
||||
C_push(src); saved = TRUE;
|
||||
}
|
||||
else
|
||||
{
|
||||
asetcdr(tmp_reg, src);
|
||||
}
|
||||
tmp_page = src[C_PAGE]; tmp_disp = src[C_DISP];
|
||||
take_cdr(dest);
|
||||
}
|
||||
if (dest[C_PAGE])
|
||||
{
|
||||
if (saved) C_pop(src);
|
||||
C_pop(src);
|
||||
C_pop(src); /* Restore old SRC */
|
||||
set_src_err("APPEND", 2, tm2_reg, src);
|
||||
return(-1);
|
||||
}
|
||||
C_pop(dest);
|
||||
if (saved)
|
||||
{
|
||||
C_pop(tmp_reg); /* Retrieve 2nd arg to append */
|
||||
asetcdr(src, tmp_reg);
|
||||
}
|
||||
C_pop(src); /* Restore old SRC */
|
||||
return(0);
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* Get Current Time */
|
||||
/************************************************************************/
|
||||
ptime(reg)
|
||||
int reg[2];
|
||||
{
|
||||
int i; /* the usual index variable */
|
||||
int time[4]; /* array for result of get_time() call */
|
||||
|
||||
get_time(time); /* ask MS-DOS what time it is */
|
||||
|
||||
/* cons the hours, minutes, seconds, hundredths into a list */
|
||||
tmp_page = SPECFIX*2; /* set tmp_reg's tag=fixnum */
|
||||
reg[C_PAGE] = reg[C_DISP] = 0; /* set reg to nil */
|
||||
for (i = 3; i >= 0; i--)
|
||||
{
|
||||
tmp_disp = time[i]; /* move in immediate (fixnum) */
|
||||
cons(reg, tmp_reg, reg); /* append value to front of list */
|
||||
}
|
||||
} /* end of function: ptime(reg) */
|
||||
|
||||
/************************************************************************/
|
||||
/* Start PCS Engine Timer */
|
||||
/************************************************************************/
|
||||
cset_tim(value)
|
||||
int value[2]; /* number to place in timer */
|
||||
{
|
||||
long int result; /* temporary for long arith */
|
||||
unsigned hi,lo; /* parts of 32-bit value for timer */
|
||||
int pg,ds; /* page and displacement in register */
|
||||
pg=CORRPAGE(value[C_PAGE]); ds=value[C_DISP];
|
||||
hi = 0;
|
||||
switch (ptype[pg]>>1)
|
||||
{
|
||||
case BIGTYPE: switch (get_word(pg,ds+1))
|
||||
{
|
||||
case 8: hi = get_word(pg,ds+6);
|
||||
case 6: lo = get_word(pg,ds+4);
|
||||
break;
|
||||
default: hi = lo = 65535; break;
|
||||
}
|
||||
break;
|
||||
case FIXTYPE: lo=ds; break;
|
||||
default: set_src_err("%START-TIMER", 1, value);
|
||||
}
|
||||
#ifdef PROMEM
|
||||
/* Multiply the number of ticks by 1000 to get the number of */
|
||||
/* vm instructions to execute before timing out */
|
||||
result = ((hi * 65536) + lo) * 1000;
|
||||
lo = result & 0xffff;
|
||||
hi = result / 65536l;
|
||||
#endif
|
||||
if (!settimer(hi,lo))
|
||||
{
|
||||
set_error(1, "Timer already running", nil_reg);
|
||||
return(-1);
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* Stop PCS Engine Timer and Return Value */
|
||||
/************************************************************************/
|
||||
crst_tim(value)
|
||||
int value[2];
|
||||
{
|
||||
long int rsttimer(); /* RSTTIMER returns a long int value */
|
||||
long int result; /* and puts it here */
|
||||
unsigned hi,lo; /* where it is broken into these pieces */
|
||||
int pg,ds; /* Page, displacement of new number */
|
||||
#ifdef PROMEM
|
||||
/* divide number of vm instructions remaining by 1000 to get the */
|
||||
/* number of engine ticks remaining */
|
||||
result = rsttimer() / 1000;
|
||||
#else
|
||||
result = rsttimer();
|
||||
#endif
|
||||
lo = result & 0xffff;
|
||||
hi = result / 65536l;
|
||||
if ((!hi) && (lo<16384)) alloc_fixnum(value,lo);
|
||||
else
|
||||
{
|
||||
alloc_block(value, BIGTYPE, (hi? 5 : 3));
|
||||
pg = CORRPAGE(value[C_PAGE]);
|
||||
ds = value[C_DISP]+3;
|
||||
put_byte(pg, ds++, 0); /* Positive sign */
|
||||
put_word(pg, ds++, lo);
|
||||
if (hi)
|
||||
{
|
||||
ds++; put_word(pg, ds, hi);
|
||||
}
|
||||
}
|
||||
return(0);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
subttl Structure definitions
|
||||
page
|
||||
|
||||
; Data structures in the child's space
|
||||
|
||||
; File block
|
||||
file_block struc
|
||||
fb_id dw ? ;ID
|
||||
fb_flags dw ? ;flags
|
||||
fb_lut dw ?,? ;lookup table@ (far)
|
||||
fb_pb dw ?,? ;parameter block@ (far)
|
||||
fb_reserved dw 8 dup (?) ;reserved
|
||||
file_block ends
|
||||
;
|
||||
fb_dummy equ fb_reserved ;dummy for now
|
||||
fb_sysint_addr equ fb_reserved+2 ;system code (far @ of entry routine)
|
||||
|
||||
; Parameter block
|
||||
parm_block struc
|
||||
pb_select dw ? ;lookup table entry maps to number
|
||||
pb_ss dw ? ;special services
|
||||
pb_ss_args dw 8 dup (?) ;special service arguments
|
||||
pb_reserved dw 8 dup (?) ;reserved
|
||||
pb_rvtype dw ? ;return value type
|
||||
pb_rv dw 4 dup (?) ;return value
|
||||
pb_args dw ? ;beginning of passed parameters
|
||||
parm_block ends
|
||||
|
||||
; Local structures
|
||||
|
||||
; The context we will remember for parent or child
|
||||
state struc
|
||||
st_ds dw 0
|
||||
st_es dw 0
|
||||
st_ss dw 0
|
||||
st_sp dw 0
|
||||
st_bp dw 0
|
||||
state ends
|
||||
|
||||
; The child's stack at the point it called us
|
||||
cstack struc
|
||||
cs_ret dw 0,0 ;far return address
|
||||
cs_len dw 0 ;child's length
|
||||
cs_psp dw 0 ;child's PSP
|
||||
cstack ends
|
||||
|
||||
; String search temporary structure
|
||||
search_struc struc
|
||||
srch_exe dw 0 ;# of child being tested
|
||||
srch_dptr dw 0,0 ;seg:offset of child's string
|
||||
srch_sptr dw 0,0 ;seg:offset of parent's string
|
||||
srch_slen dw 0 ;#chars in Scheme string
|
||||
search_struc ends
|
||||
|
||||
; Swap structure
|
||||
swap_struc struc
|
||||
sw_reg dw 0 ;VM register containing this argument
|
||||
sw_offset dw 0 ;argument's final location (after
|
||||
;packing, etc) in parm block
|
||||
swap_struc ends
|
||||
|
||||
; Information needed during one xesc call
|
||||
xesc_struc struc
|
||||
xs_rvptr dw 0,0 ;return value@ (far)
|
||||
xs_args dw 0,0 ;first arg@ (far)
|
||||
xs_local dw 0,0 ;work area@ (far)
|
||||
xs_dest dw 0,0 ;copy data to this dest@ (far)
|
||||
xs_pc dw 0,0 ;bytecode@ into xesc instruction (far)
|
||||
xs_select dw 0 ;name converted to this number
|
||||
xs_flags dw 0 ;flags
|
||||
xs_nargs dw 0 ;actual #args in current call
|
||||
xs_rvtype dw 0 ;return value type
|
||||
xs_rvreg dw 0 ;return value goes into this VM register
|
||||
xs_pb_segment dw 0 ;segment address of parm block
|
||||
C_fn dw ? ;used during far calls to our C routines
|
||||
C_retadr dw ?,?
|
||||
xesc_struc ends
|
||||
|
||||
|
||||
Loading…
Reference in New Issue