summaryrefslogtreecommitdiffstats
path: root/repl.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:37 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:37 -0800
commit710a97992705d67c3ded0d4b270c5978ce29b11f (patch)
treeddcb2f7a91cbb86ce582e74227768b7b898c29e1 /repl.c
parent50eb784bfcf15ee3c6b0b53d747db92673395040 (diff)
downloadscm-710a97992705d67c3ded0d4b270c5978ce29b11f.tar.gz
scm-710a97992705d67c3ded0d4b270c5978ce29b11f.zip
Import Upstream version 5e4upstream/5e4
Diffstat (limited to 'repl.c')
-rw-r--r--repl.c432
1 files changed, 242 insertions, 190 deletions
diff --git a/repl.c b/repl.c
index b6d2602..5fa98d9 100644
--- a/repl.c
+++ b/repl.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990-2002 Free Software Foundation, Inc.
+/* Copyright (C) 1990-2006 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -67,6 +67,10 @@ void scm_fill_freelist P((void));
# include <ctype.h>
#endif
+#ifdef linux
+# include <ctype.h>
+#endif
+
#ifdef ARM_ULIB
# include <termio.h>
int set_erase()
@@ -88,8 +92,8 @@ unsigned char uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
void init_tables()
{
int i;
- for(i = 0;i<CHAR_CODE_LIMIT;i++) upcase[i] = downcase[i] = i;
- for(i = 0;i<sizeof lowers/sizeof(char);i++) {
+ for (i = 0;i<CHAR_CODE_LIMIT;i++) upcase[i] = downcase[i] = i;
+ for (i = 0;i<sizeof lowers/sizeof(char);i++) {
upcase[lowers[i]] = uppers[i];
downcase[uppers[i]] = lowers[i];
}
@@ -155,15 +159,16 @@ static char s_freshline[] = "freshline";
static char s_eofin[] = "end of file in ";
static char s_unknown_sharp[] = "unknown # object";
-static SCM lread1 P((SCM port, int flgs, const char *what));
-static SCM lreadr P((SCM tok_buf, SCM port, int flgs));
-static SCM lreadpr P((SCM tok_buf, SCM port, int flgs));
-static SCM lreadparen P((SCM tok_buf, SCM port, int flgs, char *name));
-static SCM lread_rec P((SCM tok_buf, SCM port));
-static sizet read_token P((int ic, SCM tok_buf, SCM port));
+static SCM scm_lread1 P((SCM port, int flgs, const char *what));
+static SCM scm_lreadr P((SCM tok_buf, SCM port, int flgs));
+static SCM scm_lreadpr P((SCM tok_buf, SCM port, int flgs));
+static SCM scm_lreadparen P((SCM tok_buf, SCM port, int flgs, char *name));
+static SCM scm_lread_rec P((SCM tok_buf, SCM port));
+static sizet scm_read_token P((int ic, SCM tok_buf, SCM port, int flgs));
static void err_head P((char *str));
+extern int case_sensitize_symbols; /* 0 or 8 */
-void intprint(n, radix, port)
+void scm_intprint(n, radix, port)
long n;
int radix;
SCM port;
@@ -172,7 +177,7 @@ void intprint(n, radix, port)
lfwrite(num_buf, (sizet)sizeof(char), iint2str(n, radix, num_buf), port);
}
-void ipruk(hdr, ptr, port)
+void scm_ipruk(hdr, ptr, port)
char *hdr;
SCM ptr;
SCM port;
@@ -181,17 +186,17 @@ void ipruk(hdr, ptr, port)
lputs(hdr, port);
if (scm_cell_p(ptr)) {
lputs(" (0x", port);
- intprint(CAR(ptr), -16, port);
+ scm_intprint(CAR(ptr), -16, port);
lputs(" . 0x", port);
- intprint(CDR(ptr), -16, port);
+ scm_intprint(CDR(ptr), -16, port);
lputs(") @", port);
}
lputs(" 0x", port);
- intprint(ptr, -16, port);
+ scm_intprint(ptr, -16, port);
lputc('>', port);
}
-void iprlist(hdr, exp, tlr, port, writing)
+void scm_iprlist(hdr, exp, tlr, port, writing)
char *hdr, tlr;
SCM exp;
SCM port;
@@ -199,32 +204,32 @@ void iprlist(hdr, exp, tlr, port, writing)
{
lputs(hdr, port);
/* CHECK_INTS; */
- iprin1(CAR(exp), port, writing);
+ scm_iprin1(CAR(exp), port, writing);
exp = GCCDR(exp); /* CDR(exp); */
- for(;NIMP(exp);exp = GCCDR(exp) /* CDR(exp)*/) {
+ for (;NIMP(exp);exp = GCCDR(exp) /* CDR(exp)*/) {
if (!scm_cell_p(~1L & exp)) break;
if (NECONSP(exp)) break;
lputc(' ', port);
/* CHECK_INTS; */
- iprin1(CAR(exp), port, writing);
+ scm_iprin1(CAR(exp), port, writing);
}
if (NNULLP(exp)) {
lputs(" . ", port);
- iprin1(exp, port, writing);
+ scm_iprin1(exp, port, writing);
}
lputc(tlr, port);
}
-void iprin1(exp, port, writing)
+void scm_iprin1(exp, port, writing)
SCM exp;
SCM port;
int writing;
{
register long i;
taloop:
- switch (7 & (int)exp) {
+ switch (7 & PTR2INT(exp)) {
case 2:
case 6:
- intprint(INUM(exp), 10, port);
+ scm_intprint(INUM(exp), 10, port);
break;
case 4:
if (ICHRP(exp)) {
@@ -237,27 +242,27 @@ taloop:
lputs(charnames[(sizeof charnames/sizeof(char *))-1], port);
#endif /* ndef EBCDIC */
else if (i > '\177')
- intprint(i, -8, port);
+ scm_intprint(i, -8, port);
else lputc((int)i, port);
}
else if (SCM_LINUMP(exp)) {
lputs("#<line ", port);
- intprint(SCM_LINUM(exp), -10, port);
+ scm_intprint(SCM_LINUM(exp), -10, port);
lputc('>', port);
}
else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *))))
lputs(ISYMCHARS(exp), port);
else if (ILOCP(exp)) {
lputs("#@", port);
- intprint((long)IFRAME(exp), -10, port);
+ scm_intprint((long)IFRAME(exp), -10, port);
lputc(ICDRP(exp)?'-':'+', port);
- intprint((long)IDIST(exp), -10, port);
+ scm_intprint((long)IDIST(exp), -10, port);
}
else goto idef;
break;
case 1: /* gloc */
if (!scm_cell_p(exp-1)) {
- ipruk("gloc", exp, port);
+ scm_ipruk("gloc", exp, port);
break;
}
lputs("#@", port);
@@ -270,11 +275,11 @@ taloop:
goto taloop;
default:
idef:
- ipruk("immediate", exp, port);
+ scm_ipruk("immediate", exp, port);
break;
case 0:
if (!scm_cell_p(exp)) {
- ipruk("heap", exp, port);
+ scm_ipruk("heap", exp, port);
break;
}
switch TYP7(exp) {
@@ -282,8 +287,8 @@ taloop:
if (CAR(exp) != IM_LET) {
lputs("(#@call ", port);
exp = CDR(exp);
- iprin1(CAR(exp), port, writing);
- iprlist(" ", CAR(CDR(exp)), ')', port, writing);
+ scm_iprin1(CAR(exp), port, writing);
+ scm_iprlist(" ", CAR(CDR(exp)), ')', port, writing);
break;
}
/* else fall through */
@@ -297,7 +302,7 @@ taloop:
case tcs_cons_chflag:
case tcs_cons_gloc:
case tcs_cons_nimcar:
- iprlist("(", exp, ')', port, writing);
+ scm_iprlist("(", exp, ')', port, writing);
break;
case tcs_closures:
scm_princlosure(exp, port, writing);
@@ -305,7 +310,7 @@ taloop:
case tc7_string:
if (writing) {
lputc('\"', port);
- for(i = 0;i<LENGTH(exp);++i) switch (CHARS(exp)[i]) {
+ for (i = 0;i<LENGTH(exp);++i) switch (CHARS(exp)[i]) {
case '\"':
case '\\':
lputc('\\', port);
@@ -317,14 +322,16 @@ taloop:
}
case tcs_symbols:
if (writing) { /* slashified symbol */
- for(i = 0;i<LENGTH(exp);++i) switch (CHARS(exp)[i]) {
- case '\\': case '\"': case '\'': case '(': case ')': case '#':
+ for (i = 0;i<LENGTH(exp);++i) switch (CHARS(exp)[i]) {
case 'A': case 'B': case 'C': case 'D': case 'E':
case 'F': case 'G': case 'H': case 'I': case 'J':
case 'K': case 'L': case 'M': case 'N': case 'O':
case 'P': case 'Q': case 'R': case 'S': case 'T':
case 'U': case 'V': case 'W': case 'X': case 'Y': case 'Z':
+ if (case_sensitize_symbols) goto skipit;
+ case '\\': case '\"': case '\'': case '(': case ')': case '#':
lputc('\\', port);
+ skipit:
default:
lputc(CHARS(exp)[i], port);
}
@@ -335,14 +342,14 @@ taloop:
break;
case tc7_vector:
lputs("#(", port);
- for(i = 0;i+1<LENGTH(exp);++i) {
+ for (i = 0;i+1<LENGTH(exp);++i) {
/* CHECK_INTS; */
- iprin1(VELTS(exp)[i], port, writing);
+ scm_iprin1(VELTS(exp)[i], port, writing);
lputc(' ', port);
}
if (i<LENGTH(exp)) {
/* CHECK_INTS; */
- iprin1(VELTS(exp)[i], port, writing);
+ scm_iprin1(VELTS(exp)[i], port, writing);
}
lputc(')', port);
break;
@@ -360,9 +367,9 @@ taloop:
#ifdef CCLO
if (tc16_cclo==TYP16(exp)) {
lputs("#<compiled-closure ", port);
- iprin1(CCLO_SUBR(exp), port, writing);
+ scm_iprin1(CCLO_SUBR(exp), port, writing);
lputc(' ', port);
- iprin1(VELTS(exp)[1], port, writing);
+ scm_iprin1(VELTS(exp)[1], port, writing);
lputc('>', port);
break;
}
@@ -373,9 +380,9 @@ taloop:
break;
case tc7_contin:
lputs("#<continuation ", port);
- intprint(LENGTH(exp), -10, port);
+ scm_intprint(LENGTH(exp), -10, port);
lputs(" @ ", port);
- intprint((long)CHARS(exp), -16, port);
+ scm_intprint((long)CHARS(exp), -16, port);
lputc('>', port);
break;
case tc7_port:
@@ -393,7 +400,7 @@ taloop:
if (i<numsmob && smobs[i].print && (smobs[i].print)(exp, port, writing))
break;
goto punk;
- default: punk: ipruk("type", exp, port);
+ default: punk: scm_ipruk("type", exp, port);
}
}
}
@@ -605,8 +612,8 @@ int scm_io_error(port, what)
lputs(";;", cur_errp);
lputs(what, cur_errp);
lputs(": closing pipe ", cur_errp);
- iprin1(port, cur_errp, 1);
- newline(cur_errp);
+ scm_iprin1(port, cur_errp, 1);
+ scm_newline(cur_errp);
}
close_port(port);
if (*loc_broken_pipe && NIMP(*loc_broken_pipe))
@@ -623,47 +630,41 @@ int scm_io_error(port, what)
return 0; /* squelch warning */
}
-static char s_fflush[] = "fflush";
void lfflush(port) /* internal SCM call */
SCM port;
{
sizet i = PTOBNUM(port);
while ((ptobs[i].fflush)(STREAM(port)) &&
- scm_io_error(port, s_fflush))
+ scm_io_error(port, "lfflush"))
;
}
-static char s_flush[] = "force-output";
-SCM lflush(port) /* user accessible as force-output */
+static char s_force_output[] = "force-output";
+SCM scm_force_output(port)
SCM port;
{
- if (UNBNDP(port)) port = cur_outp;
- else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_flush);
- {
- sizet i = PTOBNUM(port);
- while ((ptobs[i].fflush)(STREAM(port)) &&
- scm_io_error(port, s_fflush))
- ;
- return UNSPECIFIED;
- }
+ if (UNBNDP(port)) port = cur_outp;
+ else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_force_output);
+ lfflush(port);
+ return UNSPECIFIED;
}
-SCM lwrite(obj, port)
+SCM scm_write(obj, port)
SCM obj, port;
{
if (UNBNDP(port)) port = cur_outp;
else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write);
- iprin1(obj, port, 1);
+ scm_iprin1(obj, port, 1);
return UNSPECIFIED;
}
-SCM display(obj, port)
+SCM scm_display(obj, port)
SCM obj, port;
{
if (UNBNDP(port)) port = cur_outp;
else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display);
- iprin1(obj, port, 0);
+ scm_iprin1(obj, port, 0);
return UNSPECIFIED;
}
-SCM newline(port)
+SCM scm_newline(port)
SCM port;
{
if (UNBNDP(port)) port = cur_outp;
@@ -672,7 +673,7 @@ SCM newline(port)
if (port==cur_outp) lfflush(port);
return UNSPECIFIED;
}
-SCM write_char(chr, port)
+SCM scm_write_char(chr, port)
SCM chr, port;
{
if (UNBNDP(port)) port = cur_outp;
@@ -745,7 +746,7 @@ sizet lfwrite(ptr, size, nitems, port)
sizet ret, i = PTOBNUM(port);
do {
ret = (ptobs[i].fwrite)(ptr, size, nitems, STREAM(port));
- } while(nitems != ret && scm_io_error(port, "fwrite"));
+ } while(nitems != ret && scm_io_error(port, "fwrite"));
if (CRDY & CAR(port)) {
sizet j;
i = SCM_PORTNUM(port);
@@ -823,7 +824,7 @@ SCM scm_read_char(port)
if (EOF==c) return EOF_VAL;
return MAKICHR(c);
}
-SCM peek_char(port)
+SCM scm_peek_char(port)
SCM port;
{
int c;
@@ -873,42 +874,42 @@ static char s_read_numbered[] = "read-numbered";
SCM scm_read(port)
SCM port;
{
- return lread1(port, 0, s_read);
+ return scm_lread1(port, case_sensitize_symbols, s_read);
}
SCM scm_read_for_load(port)
SCM port;
{
- return lread1(port, 4, s_read_for_load);
+ return scm_lread1(port, 4 | case_sensitize_symbols, s_read_for_load);
}
#ifndef MEMOIZE_LOCALS
SCM scm_read_numbered(port)
SCM port;
{
- return lread1(port, 6, s_read_numbered);
+ return scm_lread1(port, 6 | case_sensitize_symbols, s_read_numbered);
}
#endif
-static SCM lread1(port, flgs, what)
+static SCM scm_lread1(port, flgs, what)
SCM port;
int flgs;
const char *what;
{
- int c;
- SCM tok_buf;
- if (UNBNDP(port)) port = cur_inp;
- ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, what);
- do {
- c = flush_ws(port);
- if (EOF==c) return EOF_VAL;
- lungetc(c, port);
- tok_buf = makstr(30L);
- } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port, flgs)));
- return tok_buf;
+ int c;
+ SCM tok_buf;
+ if (UNBNDP(port)) port = cur_inp;
+ ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, what);
+ do {
+ c = flush_ws(port);
+ if (EOF==c) return EOF_VAL;
+ lungetc(c, port);
+ tok_buf = makstr(30L);
+ } while (EOF_VAL==(tok_buf = scm_lreadr(tok_buf, port, flgs)));
+ return tok_buf;
}
static SCM *loc_loadsharp = 0, *loc_readsharp = 0, *loc_charsharp = 0;
-static SCM lreadpr(tok_buf, port, flgs)
+static SCM scm_lreadpr(tok_buf, port, flgs)
SCM tok_buf;
SCM port;
int flgs;
@@ -916,7 +917,7 @@ static SCM lreadpr(tok_buf, port, flgs)
int c;
sizet j;
SCM p;
- if (2==(3&flgs)) return lread_rec(tok_buf, port);
+ if (2==(3 & flgs)) return scm_lread_rec(tok_buf, port);
tryagain:
c = flush_ws(port);
switch (c) {
@@ -924,15 +925,15 @@ static SCM lreadpr(tok_buf, port, flgs)
#ifdef BRACKETS_AS_PARENS
case '[':
#endif
- case '(': return lreadparen(tok_buf, port, flgs, s_list);
+ case '(': return scm_lreadparen(tok_buf, port, flgs, s_list);
#ifdef BRACKETS_AS_PARENS
case ']':
#endif
case ')': return UNDEFINED; /* goto tryagain; */
case '\'': return cons2(i_quote,
- lreadr(tok_buf, port, flgs), EOL);
+ scm_lreadr(tok_buf, port, flgs), EOL);
case '`': return cons2(i_quasiquote,
- lreadr(tok_buf, port, flgs), EOL);
+ scm_lreadr(tok_buf, port, flgs), EOL);
case ',':
c = lgetc(port);
if ('@'==c) p = i_uq_splicing;
@@ -940,7 +941,7 @@ static SCM lreadpr(tok_buf, port, flgs)
lungetc(c, port);
p = i_unquote;
}
- return cons2(p, lreadr(tok_buf, port, flgs), EOL);
+ return cons2(p, scm_lreadr(tok_buf, port, flgs), EOL);
case '#':
c = lgetc(port);
switch (c) {
@@ -948,7 +949,7 @@ static SCM lreadpr(tok_buf, port, flgs)
case '[':
#endif
case '(':
- p = lreadparen(tok_buf, port, flgs, s_vector);
+ p = scm_lreadparen(tok_buf, port, flgs, s_vector);
return NULLP(p) ? nullvect : vector(p);
case 't': case 'T': return BOOL_T;
case 'f': case 'F': return BOOL_F;
@@ -959,7 +960,7 @@ static SCM lreadpr(tok_buf, port, flgs)
c = '#';
goto num;
case '*':
- j = read_token(c, tok_buf, port);
+ j = scm_read_token(c, tok_buf, port, flgs);
p = istr2bve(CHARS(tok_buf)+1, (long)(j-1));
if (NFALSEP(p)) return p;
else goto unkshrp;
@@ -968,11 +969,11 @@ static SCM lreadpr(tok_buf, port, flgs)
if ('\\'==c) {
CHARS(tok_buf)[0] = c;
j = 1;
- } else j = read_token(c, tok_buf, port);
+ } else j = scm_read_token(c, tok_buf, port, flgs);
if (j==1) return MAKICHR(c);
for (c = 0;c<sizeof charnames/sizeof(char *);c++)
if (charnames[c]
- && (0==strcmp(charnames[c], CHARS(tok_buf))))
+ && (0==strcasecmp(charnames[c], CHARS(tok_buf))))
return MAKICHR(charnums[c]);
if (loc_charsharp && NIMP(*loc_charsharp)) {
resizuve(tok_buf, MAKINUM(j));
@@ -1002,11 +1003,11 @@ static SCM lreadpr(tok_buf, port, flgs)
{
SCM reader =
#ifndef MEMOIZE_LOCALS
- (3&flgs) ? p_read_numbered :
+ (3 & flgs) ? p_read_numbered :
#endif
- ((4&flgs) ? p_read_for_load : p_read);
+ ((4 & flgs) ? p_read_for_load : p_read);
SCM args = cons2(MAKICHR(c), port, cons(reader, EOL));
- if ((4&flgs) && loc_loadsharp && NIMP(*loc_loadsharp)) {
+ if ((4 & flgs) && loc_loadsharp && NIMP(*loc_loadsharp)) {
p = apply(*loc_loadsharp, args, EOL);
if (UNSPECIFIED==p) goto tryagain;
return p;
@@ -1046,7 +1047,7 @@ static SCM lreadpr(tok_buf, port, flgs)
case DIGITS:
case '.': case '-': case '+':
num:
- j = read_token(c, tok_buf, port);
+ j = scm_read_token(c, tok_buf, port, flgs);
p = istring2number(CHARS(tok_buf), (long)j, 10L);
if (NFALSEP(p)) return p;
if (c=='#') {
@@ -1059,36 +1060,36 @@ static SCM lreadpr(tok_buf, port, flgs)
}
goto tok;
default:
- j = read_token(c, tok_buf, port);
+ j = scm_read_token(c, tok_buf, port, flgs);
tok:
p = intern(CHARS(tok_buf), j);
return CAR(p);
}
}
-static SCM lreadr(tok_buf, port, flgs)
+static SCM scm_lreadr(tok_buf, port, flgs)
SCM tok_buf;
SCM port;
int flgs;
{
- SCM ans = lreadpr(tok_buf, port, flgs);
+ SCM ans = scm_lreadpr(tok_buf, port, flgs);
switch (ans) {
case UNDEFINED:
scm_warn("unexpected \")\"", "", port);
- return lreadpr(tok_buf, port, flgs);
+ return scm_lreadpr(tok_buf, port, flgs);
}
return ans;
}
-static SCM lread_rec(tok_buf, port)
+static SCM scm_lread_rec(tok_buf, port)
SCM tok_buf;
SCM port;
{
SCM line, form;
int c = flush_ws(port);
- switch(c) {
+ switch (c) {
default:
lungetc(c, port);
line = scm_port_line(port);
- form = lreadpr(tok_buf, port, 5);
+ form = scm_lreadpr(tok_buf, port, 5);
if (NFALSEP(line) && NIMP(form) &&
(CONSP(form) || VECTORP(form))) {
return cons(SCM_MAKE_LINUM(INUM(line)), form);
@@ -1105,37 +1106,38 @@ static SCM lread_rec(tok_buf, port)
#ifdef _UNICOS
_Pragma("noopt"); /* # pragma _CRI noopt */
#endif
-static sizet read_token(ic, tok_buf, port)
+static sizet scm_read_token(ic, tok_buf, port, flgs)
int ic;
SCM tok_buf;
SCM port;
+ int flgs;
{
- register sizet j = 1;
- register int c = ic;
- register char *p = CHARS(tok_buf);
- p[0] = '\\'==c ? lgetc(port) : downcase[c];
- while(1) {
- if (j+1 >= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf);
- switch (c = lgetc(port)) {
+ register sizet j = 1;
+ register int c = ic;
+ register char *p = CHARS(tok_buf);
+ p[0] = '\\'==c ? lgetc(port) : 8 & flgs ? c : downcase[c];
+ while(1) {
+ if (j+1 >= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf);
+ switch (c = lgetc(port)) {
#ifdef BRACKETS_AS_PARENS
- case '[': case ']':
+ case '[': case ']':
#endif
- case '(': case ')': case '\"': case ';':
- case ',': case '`':
- /* case '#': */
- case WHITE_SPACES:
- case LINE_INCREMENTORS:
- lungetc(c, port);
- case EOF:
- p[j] = 0;
- return j;
- case '\\': /* slashified symbol */
- p[j++] = lgetc(port);
- break;
- default:
- p[j++] = downcase[c];
- }
- }
+ case '(': case ')': case '\"': case ';':
+ case ',': case '`':
+ /* case '#': */
+ case WHITE_SPACES:
+ case LINE_INCREMENTORS:
+ lungetc(c, port);
+ case EOF:
+ p[j] = 0;
+ return j;
+ case '\\': /* slashified symbol */
+ p[j++] = lgetc(port);
+ break;
+ default:
+ p[j++] = 8 & flgs ? c : downcase[c];
+ }
+ }
}
#ifdef _UNICOS
_Pragma("opt"); /* # pragma _CRI opt */
@@ -1150,28 +1152,28 @@ _Pragma("opt"); /* # pragma _CRI opt */
/* 5 - top level read when adding line-numbers. Uses LOAD:SHARP */
/* 6 - recursive read when adding line-numbers. Uses LOAD:SHARP */
-static SCM lreadparen(tok_buf, port, flgs, name)
+static SCM scm_lreadparen(tok_buf, port, flgs, name)
SCM tok_buf;
SCM port;
int flgs;
char *name;
{
SCM lst, fst,
- tmp = lreadpr(tok_buf, port, (4&flgs) | ((3&flgs) ? 2 : 0));
+ tmp = scm_lreadpr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 2 : 0));
if (UNDEFINED==tmp) return EOL;
if (i_dot==tmp) {
- fst = lreadr(tok_buf, port, (4&flgs) | ((3&flgs) ? 1 : 0));
+ fst = scm_lreadr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 1 : 0));
closeit:
- tmp = lreadpr(tok_buf, port, 0);
+ tmp = scm_lreadpr(tok_buf, port, 0);
if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", name);
return fst;
}
fst = lst = cons(tmp, EOL);
while (UNDEFINED !=
- (tmp = lreadpr(tok_buf, port, (4&flgs) | ((3&flgs) ? 2 : 0)))) {
+ (tmp = scm_lreadpr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 2 : 0)))) {
if (EOF_VAL==tmp) wta(lst, s_eofin, s_list);
if (i_dot==tmp) {
- CDR(lst) = lreadr(tok_buf, port, (4&flgs) | ((3&flgs) ? 1 : 0));
+ CDR(lst) = scm_lreadr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 1 : 0));
goto closeit;
}
lst = (CDR(lst) = cons(tmp, EOL));
@@ -1233,7 +1235,7 @@ static int prinarb(exp, port, writing)
{
lputs("#<arbiter ", port);
if (CAR(exp) & (1L<<16)) lputs("locked ", port);
- iprin1(CDR(exp), port, writing);
+ scm_iprin1(CDR(exp), port, writing);
lputc('>', port);
return !0;
}
@@ -1359,7 +1361,7 @@ SCM scm_top_level(initpath, toplvl_fun)
if (i) i = UNCOOK(i);
#endif
drloop:
- switch ((int)i) {
+ switch (PTR2INT(i)) {
default:
{
char *name = errmsgs[i-WNA].s_response;
@@ -1376,7 +1378,7 @@ SCM scm_top_level(initpath, toplvl_fun)
exitval = MAKINUM(EXIT_SUCCESS);
errjmp_bad = (char *)0;
errjmp_recursive = 0;
- lflush(sys_errp);
+ if (NIMP(sys_errp) && OPOUTPORTP(sys_errp)) lfflush(sys_errp);
errno = 0;
SIG_deferred = 0;
deferred_proc = 0;
@@ -1404,7 +1406,7 @@ SCM scm_top_level(initpath, toplvl_fun)
ints_disabled = 1;
errjmp_bad = (char *)0;
errjmp_recursive = 0;
- lflush(sys_errp);
+ if (NIMP(sys_errp) && OPOUTPORTP(sys_errp)) lfflush(sys_errp);
SIG_deferred = 0;
deferred_proc = 0;
gc_hook_active = 0;
@@ -1416,8 +1418,8 @@ SCM scm_top_level(initpath, toplvl_fun)
if (NIMP(loadports) && OPINPORTP(CAR(loadports))) {
if (scm_verbose > 1) {
lputs("; Aborting load (closing): ", cur_errp);
- display(*loc_loadpath, cur_errp);
- newline(cur_errp);
+ scm_display(*loc_loadpath, cur_errp);
+ scm_newline(cur_errp);
}
close_port(CAR(loadports)); /* close loading file. */
}
@@ -1436,8 +1438,8 @@ SCM scm_top_level(initpath, toplvl_fun)
dowinds(EOL);
if (MAKINUM(EXIT_SUCCESS) != exitval) {
lputs("; program args: ", cur_errp);
- lwrite(progargs, cur_errp);
- newline(cur_errp);
+ scm_write(progargs, cur_errp);
+ scm_newline(cur_errp);
}
return exitval;
case -3: /* restart. */
@@ -1506,6 +1508,50 @@ SCM scm_port_col(port)
}
return MAKINUM(col);
}
+
+static char s_file_position[] = "file-position";
+SCM scm_file_position(port, pos)
+ SCM port, pos;
+{
+ ASRTER(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_position);
+ if (UNBNDP(pos) || FALSEP(pos)) {
+ long ans;
+ SYSCALL(ans = ftell(STREAM(port)););
+ if (ans < 0) return BOOL_F;
+ if (CRDYP(port)) ans--;
+ return MAKINUM(ans);
+ }
+ ASRTER((INUMP(pos) && (INUM(pos) >= 0))
+ || (NIMP(pos) && (TYP16(pos)==tc16_bigpos)),
+ port, ARG2, s_file_position);
+#ifndef RECKLESS
+ if (TRACKED & SCM_PORTFLAGS(port)) {
+ if (INUM0==pos) {
+ int i = SCM_PORTNUM(port);
+ scm_port_table[i].line = 1L;
+ scm_port_table[i].col = 1;
+ }
+ else {
+ if (2 <= verbose)
+ scm_warn("Setting file position for tracked port: ", "", port);
+ SCM_PORTFLAGS(port) &= (~TRACKED);
+ }
+ }
+#endif
+ {
+ int ans;
+ CLRDY(port); /* Clear ungetted char */
+ SYSCALL(ans = fseek(STREAM(port), INUM(pos), 0););
+#ifdef HAVE_PIPE
+# ifdef ESPIPE
+ if (!OPIOPORTP(port))
+ ASRTER(ESPIPE != errno, port, ARG1, s_file_position);
+# endif
+#endif
+ return ans ? BOOL_F : BOOL_T;
+ }
+}
+
static char s_port_filename[] = "port-filename";
SCM scm_port_filename(port)
SCM port;
@@ -1535,7 +1581,7 @@ void growth_mon(obj, size, units, grewp)
lputs((grewp ? "; grew " : "; shrank "), sys_errp);
lputs(obj, sys_errp);
lputs(" to ", sys_errp);
- intprint(size, -10, sys_errp);
+ scm_intprint(size, -10, sys_errp);
lputc(' ', sys_errp);
lputs(units, sys_errp);
if ((verbose > 4) && (obj==s_heap)) heap_report();
@@ -1563,15 +1609,15 @@ void gc_end()
gc_rt = INUM(my_time()) - gc_rt;
gc_time_taken = gc_time_taken + gc_rt;
if (verbose > 4) {
- intprint(time_in_msec(gc_rt), -10, sys_errp);
+ scm_intprint(time_in_msec(gc_rt), -10, sys_errp);
lputs(".ms cpu, ", sys_errp);
- intprint(gc_cells_collected, -10, sys_errp);
+ scm_intprint(gc_cells_collected, -10, sys_errp);
lputs(" cells, ", sys_errp);
- intprint(gc_malloc_collected, -10, sys_errp);
+ scm_intprint(gc_malloc_collected, -10, sys_errp);
lputs(" malloc, ", sys_errp);
- intprint(gc_syms_collected, -10, sys_errp);
+ scm_intprint(gc_syms_collected, -10, sys_errp);
lputs(" syms, ", sys_errp);
- intprint(gc_ports_collected, -10, sys_errp);
+ scm_intprint(gc_ports_collected, -10, sys_errp);
lputs(" ports collected\n", sys_errp);
}
}
@@ -1590,26 +1636,26 @@ void repl_report()
if (verbose > 2) {
lfflush(cur_outp);
lputs(";Evaluation took ", cur_errp);
- intprint(time_in_msec(INUM(my_time())-rt), -10, cur_errp);
+ scm_intprint(time_in_msec(INUM(my_time())-rt), -10, cur_errp);
lputs(".ms (", cur_errp);
- intprint(time_in_msec(gc_time_taken), -10, cur_errp);
+ scm_intprint(time_in_msec(gc_time_taken), -10, cur_errp);
lputs(".ms in gc) ", cur_errp);
- intprint(cells_allocated - lcells_allocated, -10, cur_errp);
+ scm_intprint(cells_allocated - lcells_allocated, -10, cur_errp);
lputs(" cells work, ", cur_errp);
scm_env_work += scm_ecache_len - scm_ecache_index;
- intprint(scm_env_work, -10, cur_errp);
+ scm_intprint(scm_env_work, -10, cur_errp);
lputs(" env, ", cur_errp);
- intprint(mallocated - lmallocated, -10, cur_errp);
+ scm_intprint(mallocated - lmallocated, -10, cur_errp);
lputs(".B other\n", cur_errp);
if (verbose > 3) {
lputc(';', cur_errp);
- intprint(scm_gcs, -10, cur_errp);
+ scm_intprint(scm_gcs, -10, cur_errp);
lputs( " gc, ", cur_errp);
- intprint(scm_egcs, -10, cur_errp);
+ scm_intprint(scm_egcs, -10, cur_errp);
lputs( " ecache gc, ", cur_errp);
- intprint(scm_clo_moved, -10, cur_errp);
+ scm_intprint(scm_clo_moved, -10, cur_errp);
lputs(" env migrated from closures, ", cur_errp);
- intprint(scm_stk_moved, -10, cur_errp);
+ scm_intprint(scm_stk_moved, -10, cur_errp);
lputs(" from stack\n", cur_errp);
}
lfflush(cur_errp);
@@ -1631,18 +1677,18 @@ void scm_brk_report()
dif2 = (scm_curbrk - scm_dumped_brk)/1024;
lputs("initial brk = 0x", cur_errp);
- intprint(scm_init_brk, -16, cur_errp);
+ scm_intprint(scm_init_brk, -16, cur_errp);
if (dumped) {
lputs(", dumped = 0x", cur_errp);
- intprint(scm_dumped_brk, -16, cur_errp);
+ scm_intprint(scm_dumped_brk, -16, cur_errp);
}
lputs(", current = 0x", cur_errp);
- intprint(scm_curbrk, -16, cur_errp);
+ scm_intprint(scm_curbrk, -16, cur_errp);
lputs("; ", cur_errp);
- intprint(dif1, 10, cur_errp);
+ scm_intprint(dif1, 10, cur_errp);
if (dumped) {
lputs(dif2 < 0 ? " - " : " + ", cur_errp);
- intprint(dif2 < 0 ? -dif2 : dif2, 10, cur_errp);
+ scm_intprint(dif2 < 0 ? -dif2 : dif2, 10, cur_errp);
}
lputs(".kiB\n", cur_errp);
}
@@ -1650,13 +1696,13 @@ void scm_brk_report()
SCM lroom(opt)
SCM opt;
{
- intprint(cells_allocated, -10, cur_errp);
+ scm_intprint(cells_allocated, -10, cur_errp);
lputs(" out of ", cur_errp);
- intprint(heap_cells, -10, cur_errp);
+ scm_intprint(heap_cells, -10, cur_errp);
lputs(" cells in use, ", cur_errp);
- intprint(mallocated, -10, cur_errp);
+ scm_intprint(mallocated, -10, cur_errp);
lputs(".B allocated (of ", cur_errp);
- intprint(mtrigger, 10, cur_errp);
+ scm_intprint(mtrigger, 10, cur_errp);
lputs(")\n", cur_errp);
if (!UNBNDP(opt)) {
#ifndef LACK_SBRK
@@ -1671,20 +1717,20 @@ SCM lroom(opt)
}
void scm_ecache_report()
{
- intprint(scm_estk_size, 10 , cur_errp);
+ scm_intprint(scm_estk_size, 10 , cur_errp);
lputs(" env stack items, ", cur_errp);
- intprint(scm_ecache_len - scm_ecache_index, 10, cur_errp);
+ scm_intprint(scm_ecache_len - scm_ecache_index, 10, cur_errp);
lputs(" out of ", cur_errp);
- intprint(scm_ecache_len, 10, cur_errp);
+ scm_intprint(scm_ecache_len, 10, cur_errp);
lputs(" env cells in use.\n", cur_errp);
}
void exit_report()
{
if (verbose > 2) {
lputs(";Totals: ", cur_errp);
- intprint(time_in_msec(INUM(my_time())), -10, cur_errp);
+ scm_intprint(time_in_msec(INUM(my_time())), -10, cur_errp);
lputs(".ms my time, ", cur_errp);
- intprint(time_in_msec(INUM(your_time())), -10, cur_errp);
+ scm_intprint(time_in_msec(INUM(your_time())), -10, cur_errp);
lputs(".ms your time\n", cur_errp);
}
}
@@ -1737,8 +1783,8 @@ SCM repl()
#ifdef __MSDOS__
if ('\n' != CGETUN(cur_inp))
if (OPOUTPORTP(cur_inp)) /* This case for curses window */
- {lfflush(cur_outp); newline(cur_inp);}
- else newline(cur_outp);
+ {lfflush(cur_outp); scm_newline(cur_inp);}
+ else scm_newline(cur_outp);
#endif
if (NIMP(x)) {
x = CONSP(x) ?
@@ -1751,13 +1797,13 @@ SCM repl()
if (IMP(x))
{if (verbose > 2) lputs(";;no values\n", cur_outp);}
else if (IMP(CDR(x))) {
- iprin1(CAR(x), cur_outp, 1);
+ scm_iprin1(CAR(x), cur_outp, 1);
lputc('\n', cur_outp);
}
else
while (NIMP(x)) {
lputc(' ', cur_outp);
- iprin1(CAR(x), cur_outp, 1);
+ scm_iprin1(CAR(x), cur_outp, 1);
lputc('\n', cur_outp);
x = CDR(x);
}
@@ -1918,10 +1964,10 @@ SCM scm_load_string(str)
void scm_line_msg(file, linum, port)
SCM file, linum, port;
{
- iprin1(file, port, 1);
+ scm_iprin1(file, port, 1);
if (SCM_LINUMP(linum)) {
lputs(", line ", port);
- intprint(SCM_LINUM(linum), -10, port);
+ scm_intprint(SCM_LINUM(linum), -10, port);
}
lputs(": ", port);
}
@@ -1955,9 +2001,9 @@ static void err_head(str)
if (NIMP(lps)) {
lputs("\n;In file loaded from ", cur_errp);
for (; NIMP(lps); lps = CDR(lps)) {
- iprin1(scm_port_filename(CAR(lps)), cur_errp, 0);
+ scm_iprin1(scm_port_filename(CAR(lps)), cur_errp, 0);
lputs(":", cur_errp);
- iprin1(scm_port_line(CAR(lps)), cur_errp, 1);
+ scm_iprin1(scm_port_line(CAR(lps)), cur_errp, 1);
lputs(IMP(CDR(lps)) ? ":" : ",\n; loaded from ", cur_errp);
}
}
@@ -1980,7 +2026,7 @@ void scm_warn(str1, str2, obj)
lputc('\n', cur_errp);
}
if (!UNBNDP(obj)) {
- iprin1(obj, cur_errp, 1);
+ scm_iprin1(obj, cur_errp, 1);
lputc('\n', cur_errp);
}
lfflush(cur_errp);
@@ -2017,7 +2063,7 @@ static void def_err_response()
lputs("RECURSIVE ERROR: ", def_errp);
if (badport || TYP16(cur_errp)==tc16_sfport) {
lputs("reverting from ", def_errp);
- iprin1(cur_errp, def_errp, 2);
+ scm_iprin1(cur_errp, def_errp, 2);
lputs("to default error port\n", def_errp);
cur_errp = def_errp;
errjmp_recursive = 0;
@@ -2061,7 +2107,7 @@ static void def_err_response()
if (reset_safeport(sys_safep, 55, cur_errp))
if (0==setjmp(SAFEP_JMPBUF(sys_safep))) {
if (codep) scm_princode(obj, EOL, sys_safep, writing);
- else iprin1(obj, sys_safep, writing);
+ else scm_iprin1(obj, sys_safep, writing);
}
if (UNBNDP(err_exp)) goto getout;
if (NIMP(err_exp)) {
@@ -2070,9 +2116,9 @@ static void def_err_response()
lputs("\n; in expression: ", cur_errp);
if (NCONSP(err_exp)) scm_princode(err_exp, env, sys_safep, writing);
else if (UNDEFINED==CDR(err_exp))
- iprin1(CAR(err_exp), sys_safep, writing);
+ scm_iprin1(CAR(err_exp), sys_safep, writing);
else {
- if (UNBNDP(env)) iprlist("(... ", err_exp, ')', sys_safep, writing);
+ if (UNBNDP(env)) scm_iprlist("(... ", err_exp, ')', sys_safep, writing);
else scm_princode(err_exp, env, sys_safep, writing);
}
}
@@ -2188,9 +2234,11 @@ static char s_isatty[] = "isatty?";
SCM l_isatty(port)
SCM port;
{
+ int fn;
ASRTER(NIMP(port) && OPPORTP(port), port, ARG1, s_isatty);
if (tc16_fport != TYP16(port)) return BOOL_F;
- return isatty(fileno(STREAM(port)))?BOOL_T:BOOL_F;
+ fn = fileno(STREAM(port));
+ return (fn >= 0 && isatty(fn)) ? BOOL_T : BOOL_F;
}
static iproc subr0s[] = {
@@ -2221,10 +2269,10 @@ static iproc subr1s[] = {
static iproc subr1os[] = {
{s_read_char, scm_read_char},
- {s_peek_char, peek_char},
- {s_newline, newline},
+ {s_peek_char, scm_peek_char},
+ {s_newline, scm_newline},
{s_freshline, scm_freshline},
- {s_flush, lflush},
+ {s_force_output, scm_force_output},
{s_char_readyp, char_readyp},
{"quit", quit},
{"verbose", prolixity},
@@ -2233,10 +2281,11 @@ static iproc subr1os[] = {
{0, 0}};
static iproc subr2os[] = {
- {s_write, lwrite},
- {s_display, display},
- {s_write_char, write_char},
+ {s_write, scm_write},
+ {s_display, scm_display},
+ {s_write_char, scm_write_char},
{s_tryload, tryload},
+ {s_file_position, scm_file_position},
#ifdef CAN_DUMP
{s_unexec, scm_unexec},
#endif
@@ -2274,6 +2323,9 @@ void init_repl( iverbose )
make_subr(s_read, tc7_subr_1o, scm_read);
i_eval_string = CAR(sysintern(s_eval_string, UNDEFINED));
i_load_string = CAR(sysintern(s_load_string, UNDEFINED));
+ scm_ldstr("\n\
+(define file-set-position file-position)\n\
+");
#ifdef CAN_DUMP
add_feature("dump");
scm_ldstr("\