int nobr(void)
{
struct brkpoints *bp = brktable;
int Index, cnt;
unsigned int value1;
char *errptr;
if(cmdcount == 1)
for(cnt = 0; cnt < MAXBRK; cnt++, bp++)
bp->code = 0;
for(Index = 1; Index < cmdcount; Index++)
{
if(getexpr(cmdptrs[Index], &errptr, &value1) != 0)
{
PPrintf("Illegal value entered %s\n", cmdptrs[Index]);
continue;
}
for(cnt = 0; cnt < MAXBRK; cnt++, bp++)
{
if(bp->code && (bp->adr == value1))
{
bp->code = 0;
break;
}
}
}
return(dbrks());
}
LISP getlist () /* чтение списка ВЫР ('.' СПИС | ВЫР)... */
{
LISP p = cons (getexpr (), NIL);
switch (getlex ()) {
case '.':
setcdr (p, getexpr ());
break;
case ')':
ungetlex ();
break;
default:
ungetlex ();
setcdr (p, getlist ());
break;
case 0:
fatal ("unexpected eof");
}
return (p);
}
int stdio_enable(void)
{
char *err = NULL;
unsigned int value = 0;
unsigned instruct = 0;
if (getexpr("_printf",&err,&value) != 0) return 0;
/* If we get here, _printf was found */
if(rdwr((M_INSTR|M_RD),value,&instruct,sizeof(instruct)) == -1)
return 0;
if(instruct != 0xF000D104)
return 0;
return 1;
}
LISP getvector () /* чтение вектора ВЫР... */
{
int len = 0;
LISP vect[MAXVECT];
for (;;) {
switch (getlex ()) {
case ')':
ungetlex ();
return (vector (len, vect));
default:
if (len >= MAXVECT)
fatal ("too long vector constant");
ungetlex ();
vect[len++] = getexpr ();
continue;
case 0:
fatal ("unexpected eof");
}
}
}
int br(void)
{
struct brkpoints *bp, *target;
int Index, cnt;
unsigned int value1, value2;
char *ptr, *ptr1;
char *errptr;
for(Index = 1; Index < cmdcount; Index++)
{
if(ptr1 = strchr((ptr = cmdptrs[Index]), ':'))
*ptr1++ = '\0';
if((getexpr(ptr, &errptr, &value1) != 0)
|| (ptr1 && (getexpr(ptr1, &errptr, &value2) != 0)))
{
PPrintf("Illegal value entered %s\n", ptr);
continue;
}
for(cnt = 0, bp = brktable, target = 0; cnt < MAXBRK; cnt++, bp++)
{
if(!target && !bp->code)
target = bp;
if(bp->code && (bp->adr == value1))
{
target = bp; /* assign new break */
PPrintf("Changing break point at address %08X\n", value1);
break;
}
}
if(!target)
{
PPrintf("Break table full\n");
break;
}
target->code = BRK_EXEC;
target->adr = value1;
if(ptr1)
{
target->limit = value2;
target->code |= BRK_CNT;
}
if(cmdflags & TYPE)
{
switch(*cmdptrs[Index + 1])
{
case 'w':
target->code |= BRK_WR;
break;
case 'r':
target->code |= BRK_RD;
break;
default:
continue;
}
switch(*(cmdptrs[Index + 1] + 1))
{
case 'w':
target->code |= BRK_WR;
break;
case 'r':
target->code |= BRK_RD;
case '\0':
break;
default:
continue;
}
Index++;
}
}
return(dbrks());
}
LISP getexpr () /* чтение выражения АТОМ | ЧИСЛО | '(' СПИСОК ')' */
{
LISP p;
switch (getlex ()) {
default:
fatal ("syntax error");
case ')':
ungetlex ();
case 0:
return (NIL);
case '(':
if (getlex () == ')')
return (NIL);
ungetlex ();
p = getlist ();
if (getlex () != ')')
fatal ("right parence expected");
break;
case '\'':
p = cons (symbol ("quote"), cons (getexpr (), NIL));
break;
case '`':
p = cons (symbol ("quasiquote"), cons (getexpr (), NIL));
break;
case ',':
if (getlex () == '@')
p = cons (symbol ("unquote-splicing"), cons (getexpr (), NIL));
else {
ungetlex ();
p = cons (symbol ("unquote"), cons (getexpr (), NIL));
}
break;
case TSYMBOL:
p = symbol (lexsym);
if (trace > 2)
fprintf (stderr, "%s\n", lexsym);
break;
case TBOOL:
p = lexval ? T : NIL;
if (trace > 2)
fprintf (stderr, "#%c\n", lexval ? 't' : 'f');
break;
case TCHAR:
p = character (lexval);
if (trace > 2)
fprintf (stderr, "#\\\\%03o\n", (unsigned) lexval);
break;
case TINTEGER:
p = number (lexval);
if (trace > 2)
fprintf (stderr, "%ld\n", lexval);
break;
case TREAL:
p = real (lexrealval);
if (trace > 2)
fprintf (stderr, "%#g\n", lexrealval);
break;
case TSTRING:
p = string (lexlen, lexsym);
if (trace > 2) {
putstring (p, stderr);
fprintf (stderr, "\n");
}
break;
case TVECTOR:
p = getvector ();
if (getlex () != ')')
fatal ("right parence expected");
break;
}
return (p);
}
int main (int argc, char **argv)
{
LISP expr, val;
char *progname, *prog = 0;
progname = *argv++;
for (--argc; argc>0 && **argv=='-'; --argc, ++argv) {
char *p;
for (p=1+*argv; *p; ++p) switch (*p) {
case 'h':
fprintf (stderr, "Usage: %s [-h] [-v] [-t] [-m#] prog [arg...]\n",
progname);
return (0);
case 't':
++trace;
break;
case 'v':
++verbose;
break;
case 'm':
if (! *++p) {
if (argc <= 1)
break;
p = *++argv;
--argc;
}
memsz = atoi (p);
p += strlen (p) - 1;
break;
}
}
if (argc > 0) {
prog = *argv++;
--argc;
}
if (memsz < 1000)
memsz = (sizeof (unsigned) < 4 ? 64000 : 256000) / sizeof (cell);
if (verbose) {
fprintf (stderr, "Micro Scheme Interpreter, Release 1.0\n");
fprintf (stderr, "Memory size = %d bytes\n", memsz * sizeof (cell));
}
mem = (cell *) malloc (sizeof (cell) * memsz);
gclabel = malloc (memsz);
if (!mem || !gclabel) {
fprintf (stderr, "Out of memory\n");
return (-1);
}
if (prog && freopen (prog, "r", stdin) != stdin) {
fprintf (stderr, "Cannot open %s\n", prog);
return (-1);
}
initmem ();
T = alloc (TBOOL); /* логическая истина #t */
ZERO = number (0); /* целый ноль */
ENV = cons (cons (symbol ("version"), number (10)), NIL);
initcontext (stdfunc);
for (;;) {
gc ();
if (isatty (0))
printf ("> ");
expr = getexpr ();
if (feof (stdin))
break;
val = eval (expr, 0);
if (verbose) {
putexpr (expr, stdout);
printf (" --> ");
putexpr (val, stdout);
putchar ('\n');
}
}
return (0);
}
