miniscm: add ports
This commit is contained in:
parent
93cfe0d94a
commit
9d08c1f59e
|
|
@ -52,6 +52,8 @@
|
|||
|
||||
(define (tail stream) (force (cdr stream)))
|
||||
|
||||
(define (eof-object? x) (eq? x #f))
|
||||
|
||||
;;;;; following part is written by a.k
|
||||
|
||||
;;;; atom?
|
||||
|
|
|
|||
|
|
@ -25,11 +25,17 @@
|
|||
*--
|
||||
*/
|
||||
|
||||
/* TODO: Add basic port operations.
|
||||
*
|
||||
* UNSLISP only needs one input port and one output port (besides stdin
|
||||
* and stdout). The easiest thing to do is to make ports integers that
|
||||
* reference a global list of FILE*.
|
||||
/* This version of MiniScheme has been modified to bootstrap UNSLISP.
|
||||
*
|
||||
* Additions:
|
||||
* * Proper support for disabling quasiquote
|
||||
* * Chars
|
||||
* * Proper support for changing init file by preprocessor define
|
||||
* * Ports
|
||||
*
|
||||
* Ports and chars only support the minimum necessary to run UNSLISP.
|
||||
* The eof-object is #f. (Defining an entire type for EOF seems like
|
||||
* a kludge. An EOF test function would be a better design.)
|
||||
*/
|
||||
|
||||
/*
|
||||
|
|
@ -112,7 +118,8 @@
|
|||
|
||||
|
||||
|
||||
#define banner "Hello, This is Mini-Scheme Interpreter Version 0.85k4-a for UNSLISP.\n"
|
||||
#define banner "UNSLISP MiniScheme 0.85k4-a fork. Must be run from the \n\
|
||||
UNSLISP repository root directory.\n"
|
||||
|
||||
|
||||
#include <stdio.h>
|
||||
|
|
@ -235,6 +242,7 @@ typedef struct cell *pointer;
|
|||
#endif
|
||||
#define T_PROMISE 512 /* 0000001000000000 */
|
||||
#define T_CHAR 1024 /* 0000010000000000 */
|
||||
#define T_PORT 2048 /* 0000100000000000 */
|
||||
#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */
|
||||
#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */
|
||||
#define MARK 32768 /* 1000000000000000 */
|
||||
|
|
@ -260,6 +268,8 @@ typedef struct cell *pointer;
|
|||
#define hasprop(p) (type(p)&T_SYMBOL)
|
||||
#define symprop(p) cdr(p)
|
||||
|
||||
#define isport(p) (type(p)&T_PORT)
|
||||
|
||||
#define issyntax(p) (type(p)&T_SYNTAX)
|
||||
#define isproc(p) (type(p)&T_PROC)
|
||||
#define syntaxname(p) strvalue(car(p))
|
||||
|
|
@ -335,6 +345,11 @@ long fcells = 0; /* # of free cells */
|
|||
FILE *infp; /* input file */
|
||||
FILE *outfp; /* output file */
|
||||
|
||||
#ifndef PORTMAX
|
||||
# define PORTMAX 8
|
||||
#endif
|
||||
FILE *ports[PORTMAX]; /* Ports */
|
||||
|
||||
#ifdef USE_SETJMP
|
||||
jmp_buf error_jmp;
|
||||
|
||||
|
|
@ -550,22 +565,27 @@ char *q;
|
|||
return (mk_number(atol(q)));
|
||||
}
|
||||
|
||||
pointer mk_char_c(c)
|
||||
char c;
|
||||
{
|
||||
register pointer x = get_cell(NIL, NIL);
|
||||
type(x) = (T_CHAR | T_ATOM);
|
||||
ivalue(x) = c;
|
||||
|
||||
return x;
|
||||
}
|
||||
|
||||
/* make char */
|
||||
pointer mk_char(name)
|
||||
char *name;
|
||||
{
|
||||
register pointer x = get_cell(NIL, NIL);
|
||||
type(x) = (T_CHAR | T_ATOM);
|
||||
|
||||
if (stricmp(name, "space") == 0) {
|
||||
ivalue(x) = ' ';
|
||||
name[0] = ' ';
|
||||
} else if (stricmp(name, "newline") == 0) {
|
||||
ivalue(x) = '\n';
|
||||
} else {
|
||||
ivalue(x) = *name;
|
||||
name[0] = '\n';
|
||||
}
|
||||
|
||||
return x;
|
||||
return mk_char_c(name[0]);
|
||||
}
|
||||
|
||||
/* make constant */
|
||||
|
|
@ -912,6 +932,9 @@ int f;
|
|||
p = strbuff;
|
||||
sprintf(p, "#\\%c", ivalue(l));
|
||||
}
|
||||
} else if (isport(l)) {
|
||||
p = strbuff;
|
||||
sprintf(p, "#<PORT %ld>", ivalue(l));
|
||||
}
|
||||
if (f < 0)
|
||||
return strlen(p);
|
||||
|
|
@ -1008,6 +1031,11 @@ register pointer a, b;
|
|||
return (ivalue(a) == ivalue(b));
|
||||
else
|
||||
return (0);
|
||||
} else if (isport(a)) {
|
||||
if (isport(b))
|
||||
return (ivalue(a) == ivalue(b));
|
||||
else
|
||||
return (0);
|
||||
} else
|
||||
return (a == b);
|
||||
}
|
||||
|
|
@ -1177,6 +1205,14 @@ register pointer a, b;
|
|||
#define OP_MACROP 103
|
||||
#define OP_CHAR 104
|
||||
|
||||
#define OP_OPENIN 105
|
||||
#define OP_CLOSEIN 106
|
||||
#define OP_READIN 107
|
||||
|
||||
#define OP_OPENOUT 108
|
||||
#define OP_CLOSEOUT 109
|
||||
#define OP_WRITEOUT 110
|
||||
|
||||
static FILE *tmpfp;
|
||||
static int tok;
|
||||
static int print_flag;
|
||||
|
|
@ -2182,7 +2218,110 @@ register short op;
|
|||
return T; /* NOTREACHED */
|
||||
}
|
||||
|
||||
#define CANNOT_OPEN_FILE -1
|
||||
#define TOO_MANY_PORTS -2
|
||||
int try_to_open(name, mode)
|
||||
const char *name;
|
||||
const char *mode;
|
||||
{
|
||||
register int x;
|
||||
|
||||
for (x = 0; x < PORTMAX; x++) {
|
||||
if (ports[x] == NULL) {
|
||||
ports[x] = fopen(name, mode);
|
||||
if (!ports[x])
|
||||
return CANNOT_OPEN_FILE;
|
||||
return x;
|
||||
}
|
||||
}
|
||||
|
||||
return TOO_MANY_PORTS;
|
||||
}
|
||||
|
||||
pointer mk_port(port)
|
||||
int port;
|
||||
{
|
||||
register pointer x = get_cell(NIL, NIL);
|
||||
type(x) = (T_PORT | T_ATOM);
|
||||
ivalue(x) = port;
|
||||
return x;
|
||||
}
|
||||
|
||||
pointer opexe_7(op)
|
||||
register short op;
|
||||
{
|
||||
pointer x;
|
||||
int port;
|
||||
|
||||
switch (op) {
|
||||
case OP_OPENIN: case OP_OPENOUT:
|
||||
if (!isstring(car(args))) {
|
||||
Error_0("open-input/output-file -- argument is not string");
|
||||
}
|
||||
port = try_to_open(strvalue(car(args)), op == OP_OPENIN ? "rb" : "wb");
|
||||
switch (port) {
|
||||
case CANNOT_OPEN_FILE:
|
||||
Error_1("open-input/output-file -- cannot open file", car(args));
|
||||
case TOO_MANY_PORTS:
|
||||
Error_0("open-input/output-file -- too many ports open");
|
||||
default:
|
||||
x = mk_port(port);
|
||||
s_return(x);
|
||||
}
|
||||
case OP_CLOSEIN: case OP_CLOSEOUT:
|
||||
if (!isport(car(args))) {
|
||||
Error_0("close-input/output-file -- argument is not port");
|
||||
}
|
||||
|
||||
port = ivalue(car(args));
|
||||
if (port < 0 || port >= PORTMAX) {
|
||||
Error_0("close-input/output-file -- corrupted port value");
|
||||
}
|
||||
|
||||
fclose(ports[port]);
|
||||
ports[port] = NULL;
|
||||
s_return(T);
|
||||
case OP_READIN:
|
||||
if (!isport(car(args))) {
|
||||
Error_0("read-char -- argument is not port");
|
||||
}
|
||||
|
||||
port = ivalue(car(args));
|
||||
if (port < 0 || port >= PORTMAX) {
|
||||
Error_0("read-char -- corrupted port value");
|
||||
}
|
||||
|
||||
port = getc(ports[port]);
|
||||
if (port == EOF) {
|
||||
x = F;
|
||||
} else {
|
||||
x = mk_char_c((char)port);
|
||||
}
|
||||
|
||||
s_return(x);
|
||||
case OP_WRITEOUT:
|
||||
if (!isport(car(args))) {
|
||||
Error_0("write-char -- 1st argument is not port");
|
||||
}
|
||||
|
||||
if (!ischar(cadr(args))) {
|
||||
Error_0("write-char -- 2nd argument is not char");
|
||||
}
|
||||
|
||||
port = ivalue(car(args));
|
||||
if (port < 0 || port >= PORTMAX) {
|
||||
Error_0("read-char -- corrupted port value");
|
||||
}
|
||||
|
||||
putc((char)ivalue(cadr(args)), ports[port]);
|
||||
s_return(T);
|
||||
default:
|
||||
sprintf(strbuff, "%d is illegal operator", operator);
|
||||
Error_0(strbuff);
|
||||
}
|
||||
|
||||
return T;
|
||||
}
|
||||
|
||||
|
||||
pointer (*dispatch_table[])() = {
|
||||
|
|
@ -2301,7 +2440,14 @@ pointer (*dispatch_table[])() = {
|
|||
* operator when macros are disabled. */
|
||||
opexe_6, /* OP_MACROP, */
|
||||
|
||||
opexe_3 /* OP_CHAR */
|
||||
opexe_3, /* OP_CHAR */
|
||||
|
||||
opexe_7, /* OP_OPENIN */
|
||||
opexe_7, /* OP_CLOSEIN */
|
||||
opexe_7, /* OP_READIN */
|
||||
opexe_7, /* OP_OPENOUT */
|
||||
opexe_7, /* OP_CLOSEOUT */
|
||||
opexe_7 /* OP_WRITEOUT */
|
||||
};
|
||||
|
||||
|
||||
|
|
@ -2450,6 +2596,14 @@ init_procs()
|
|||
#endif
|
||||
mk_proc(OP_QUIT, "quit");
|
||||
mk_proc(OP_CHAR, "char?");
|
||||
|
||||
mk_proc(OP_OPENIN, "open-input-file");
|
||||
mk_proc(OP_CLOSEIN, "close-input-port");
|
||||
mk_proc(OP_READIN, "read-char");
|
||||
|
||||
mk_proc(OP_OPENOUT, "open-output-file");
|
||||
mk_proc(OP_CLOSEOUT, "close-output-port");
|
||||
mk_proc(OP_WRITEOUT, "write-char");
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,18 @@
|
|||
(define copy
|
||||
(lambda (from to)
|
||||
(let ((from-file (open-input-file from))
|
||||
(to-file (open-output-file to)))
|
||||
(letrec
|
||||
((loop
|
||||
(lambda ()
|
||||
(let ((c (read-char from-file)))
|
||||
(if (eof-object? c)
|
||||
#f
|
||||
(begin
|
||||
(write-char to-file c)
|
||||
(loop)))))))
|
||||
(loop))
|
||||
(close-input-port from-file)
|
||||
(close-output-port to-file))))
|
||||
|
||||
(copy "miniscm/miniscm.c" "/tmp/miniscm-copy.c")
|
||||
Loading…
Reference in New Issue