From 710a97992705d67c3ded0d4b270c5978ce29b11f Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:37 -0800 Subject: Import Upstream version 5e4 --- repl.c | 432 ++++++++++++++++++++++++++++++++++++----------------------------- 1 file changed, 242 insertions(+), 190 deletions(-) (limited to 'repl.c') 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 #endif +#ifdef linux +# include +#endif + #ifdef ARM_ULIB # include int set_erase() @@ -88,8 +92,8 @@ unsigned char uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; void init_tables() { int i; - for(i = 0;i', 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("#', 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', port); break; } @@ -373,9 +380,9 @@ taloop: break; case tc7_contin: lputs("#', port); break; case tc7_port: @@ -393,7 +400,7 @@ taloop: if (i= 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("#', 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("\ -- cgit v1.2.3