"Fossies" - the Fresh Open Source Software Archive

Member "scm/repl.c" (14 Oct 2017, 60076 Bytes) of package /linux/privat/scm-5f3.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "repl.c" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 5f2_vs_5f3.

    1 /* "repl.c" error, read-eval-print loop, read, write and load code.
    2  * Copyright (C) 1990-2006 Free Software Foundation, Inc.
    3  *
    4  * This program is free software: you can redistribute it and/or modify
    5  * it under the terms of the GNU Lesser General Public License as
    6  * published by the Free Software Foundation, either version 3 of the
    7  * License, or (at your option) any later version.
    8  *
    9  * This program is distributed in the hope that it will be useful, but
   10  * WITHOUT ANY WARRANTY; without even the implied warranty of
   11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   12  * Lesser General Public License for more details.
   13  *
   14  * You should have received a copy of the GNU Lesser General Public
   15  * License along with this program.  If not, see
   16  * <http://www.gnu.org/licenses/>.
   17  */
   18 
   19 /* Author: Aubrey Jaffer */
   20 
   21 #include "scm.h"
   22 #include "setjump.h"
   23 void    igc P((const char *what, SCM basecont));
   24 void    unexec P((char *new_name, char *a_name, unsigned data_start,
   25           unsigned bss_start, unsigned entry_address));
   26 void    scm_fill_freelist P((void));
   27 
   28 #ifdef __CYGWIN__
   29 # include <sys/types.h>
   30 #endif
   31 
   32 #ifdef __NetBSD__
   33 # include <ctype.h>
   34 # include <unistd.h>
   35 #endif
   36 
   37 #ifdef __OpenBSD__
   38 # include <ctype.h>
   39 # include <unistd.h>
   40 #endif
   41 
   42 #ifdef PLAN9
   43 # include <ctype.h>
   44 #endif
   45 
   46 #ifdef linux
   47 # include <ctype.h>
   48 #endif
   49 
   50 #ifdef ARM_ULIB
   51 # include <termio.h>
   52 int set_erase()
   53 {
   54    struct termio tin;
   55 
   56    ioctl(0, TCGETA, &tin);
   57    tin.c_cc[VERASE] = '\010';
   58 
   59    ioctl(0, TCSETA, &tin);
   60    return(0);
   61 }
   62 #endif
   63 
   64 unsigned char upcase[CHAR_CODE_LIMIT];
   65 unsigned char downcase[CHAR_CODE_LIMIT];
   66 unsigned char lowers[] = "abcdefghijklmnopqrstuvwxyz";
   67 unsigned char uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
   68 void init_tables()
   69 {
   70   int i;
   71   for (i = 0;i<CHAR_CODE_LIMIT;i++) upcase[i] = downcase[i] = i;
   72   for (i = 0;i<sizeof lowers/sizeof(char);i++) {
   73     upcase[lowers[i]] = uppers[i];
   74     downcase[uppers[i]] = lowers[i];
   75   }
   76 }
   77 
   78 #ifdef EBCDIC
   79 char *charnames[] = {
   80   "nul","soh","stx","etx", "pf", "ht", "lc","del",
   81    0   , 0   ,"smm", "vt", "ff", "cr", "so", "si",
   82   "dle","dc1","dc2","dc3","res", "nl", "bs", "il",
   83   "can", "em", "cc", 0   ,"ifs","igs","irs","ius",
   84    "ds","sos", "fs", 0   ,"byp", "lf","eob","pre",
   85    0   , 0   , "sm", 0   , 0   ,"enq","ack","bel",
   86    0   , 0   ,"syn", 0   , "pn", "rs", "uc","eot",
   87    0   , 0   , 0   , 0   ,"dc4","nak", 0   ,"sub",
   88   "space", s_newline, "tab", "backspace", "return", "page", "null"};
   89 char charnums[] =
   90 "\000\001\002\003\004\005\006\007\
   91 \010\011\012\013\014\015\016\017\
   92 \020\021\022\023\024\025\026\027\
   93 \030\031\032\033\034\035\036\037\
   94 \040\041\042\043\044\045\046\047\
   95 \050\051\052\053\054\055\056\057\
   96 \060\061\062\063\064\065\066\067\
   97 \070\071\072\073\074\075\076\077\
   98  \n\t\b\r\f\0";
   99 #endif /* def EBCDIC */
  100 #ifdef ASCII
  101 char *charnames[] = {
  102   "nul","soh","stx","etx","eot","enq","ack","bel",
  103    "bs", "ht", "nl", "vt", "np", "cr", "so", "si",
  104   "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
  105   "can", "em","sub","esc", "fs", "gs", "rs", "us",
  106   "space", s_newline, "tab", "backspace", "return", "page", "null", "del"};
  107 char charnums[] =
  108 "\000\001\002\003\004\005\006\007\
  109 \010\011\012\013\014\015\016\017\
  110 \020\021\022\023\024\025\026\027\
  111 \030\031\032\033\034\035\036\037\
  112  \n\t\b\r\f\0\177";
  113 #endif /* def ASCII */
  114 char *isymnames[] = {
  115                 /* Special Forms */
  116                 /*  NUM_ISPCSYMS ISPCSYMS here */
  117   "#@and", "#@begin", "#@case", "#@cond", "#@do", "#@if", "#@lambda",
  118   "#@let", "#@let*", "#@letrec", "#@or", "#@quote", "#@set!",
  119   "#@funcall", "#@apply", "#@farloc-car", "#@farloc-cdr", "#@delay",
  120   "#@quasiquote", "#@eval-for-apply", "#@let-syntax", "#@acro-call",
  121   "#<line>",  "#@define", "#@eval-values",
  122   "#@unquote", "#@unquote-splicing", "#@else", "#@=>", "#@values-token",
  123   "#@keyword",
  124                 /* user visible ISYMS */
  125                 /* other keywords */
  126                 /* Flags */
  127   "#f", "#t", "#<undefined>", "#<eof>", "()", "#<unspecified>"
  128   };
  129 
  130 static char s_read_char[] = "read-char", s_peek_char[] = "peek-char";
  131 char            s_write[] = "write", s_newline[] = "newline";
  132 static char s_display[] = "display", s_write_char[] = "write-char";
  133 static char s_freshline[] = "freshline";
  134 
  135 static char s_eofin[] = "end of file in ";
  136 static char s_unknown_sharp[] = "unknown # object";
  137 
  138 static SCM scm_lread1 P((SCM port, int flgs, const char *what));
  139 static SCM scm_lreadr P((SCM tok_buf, SCM port, int flgs));
  140 static SCM scm_lreadpr P((SCM tok_buf, SCM port, int flgs));
  141 static SCM scm_lreadparen P((SCM tok_buf, SCM port, int flgs, char *name));
  142 static SCM scm_lread_rec P((SCM tok_buf, SCM port));
  143 static sizet scm_read_token P((int ic, SCM tok_buf, SCM port, int flgs));
  144 static void err_head P((char *str));
  145 extern int case_sensitize_symbols; /* 0 or 8 */
  146 
  147 void scm_intprint(n, radix, port)
  148      long n;
  149      int radix;
  150      SCM port;
  151 {
  152   char num_buf[INTBUFLEN];
  153   lfwrite(num_buf, (sizet)sizeof(char), ilong2str(n, radix, num_buf), port);
  154 }
  155 
  156 void scm_ipruk(hdr, ptr, port)
  157      char *hdr;
  158      SCM ptr;
  159      SCM port;
  160 {
  161   lputs("#<unknown-", port);
  162   lputs(hdr, port);
  163   if (scm_cell_p(ptr)) {
  164     lputs(" (0x", port);
  165     scm_intprint(CAR(ptr), -16, port);
  166     lputs(" . 0x", port);
  167     scm_intprint(CDR(ptr), -16, port);
  168     lputs(") @", port);
  169   }
  170   lputs(" 0x", port);
  171   scm_intprint(ptr, -16, port);
  172   lputc('>', port);
  173 }
  174 
  175 void scm_iprlist(hdr, exp, tlr, port, writing)
  176      char *hdr, tlr;
  177      SCM exp;
  178      SCM port;
  179      int writing;
  180 {
  181   lputs(hdr, port);
  182   /* CHECK_INTS; */
  183   scm_iprin1(CAR(exp), port, writing);
  184   exp = GCCDR(exp); /* CDR(exp); */
  185   for (;NIMP(exp);exp = GCCDR(exp) /* CDR(exp)*/) {
  186     if (!scm_cell_p(~1L & exp)) break;
  187     if (NECONSP(exp)) break;
  188     lputc(' ', port);
  189     /* CHECK_INTS; */
  190     scm_iprin1(CAR(exp), port, writing);
  191   }
  192   if (NNULLP(exp)) {
  193     lputs(" . ", port);
  194     scm_iprin1(exp, port, writing);
  195   }
  196   lputc(tlr, port);
  197 }
  198 void scm_iprin1(exp, port, writing)
  199      SCM exp;
  200      SCM port;
  201      int writing;
  202 {
  203   register long i;
  204 taloop:
  205   switch (7 & PTR2INT(exp)) {
  206   case 2:
  207   case 6:
  208     scm_intprint(INUM(exp), 10, port);
  209     break;
  210   case 4:
  211     if (ICHRP(exp)) {
  212       i = ICHR(exp);
  213       if (writing) lputs("#\\", port);
  214       if (!writing) lputc((int)i, port);
  215       else if ((i <= ' ') && charnames[i]) lputs(charnames[i], port);
  216 #ifndef EBCDIC
  217       else if (i=='\177')
  218     lputs(charnames[(sizeof charnames/sizeof(char *))-1], port);
  219 #endif /* ndef EBCDIC */
  220       else if (i > '\177')
  221     scm_intprint(i, -8, port);
  222       else lputc((int)i, port);
  223     }
  224     else if (SCM_LINUMP(exp)) {
  225       lputs("#<line ", port);
  226       scm_intprint(SCM_LINUM(exp), -10, port);
  227       lputc('>', port);
  228     }
  229     else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *))))
  230       lputs(ISYMCHARS(exp), port);
  231     else if (ILOCP(exp)) {
  232       lputs("#@", port);
  233       scm_intprint((long)IFRAME(exp), -10, port);
  234       lputc(ICDRP(exp)?'-':'+', port);
  235       scm_intprint((long)IDIST(exp), -10, port);
  236     }
  237     else goto idef;
  238     break;
  239   case 1:           /* gloc */
  240     if (!scm_cell_p(exp-1)) {
  241       scm_ipruk("gloc", exp, port);
  242       break;
  243     }
  244     lputs("#@", port);
  245 #ifdef _M_ARM
  246     /* MS CLARM compiler workaround */
  247     exp = CAR(MS_CLARM_dumy = exp - 1);
  248 #else
  249     exp = CAR(exp-1);
  250 #endif
  251     goto taloop;
  252   default:
  253   idef:
  254     scm_ipruk("immediate", exp, port);
  255     break;
  256   case 0:
  257     if (!scm_cell_p(exp)) {
  258       scm_ipruk("heap", exp, port);
  259       break;
  260     }
  261     switch TYP7(exp) {
  262     case (127 & IM_LET):
  263       if (CAR(exp) != IM_LET) {
  264     lputs("(#@call ", port);
  265     exp = CDR(exp);
  266     scm_iprin1(CAR(exp), port, writing);
  267     scm_iprlist(" ", CAR(CDR(exp)), ')', port, writing);
  268     break;
  269       }
  270       /* else fall through */
  271     case (127 & IM_AND): case (127 & IM_BEGIN): case (127 & IM_CASE):
  272     case (127 & IM_COND): case (127 & IM_DO): case (127 & IM_IF):
  273     case (127 & IM_LAMBDA): case (127 & IM_LETSTAR):
  274     case (127 & IM_LETREC): case (127 & IM_OR): case (127 & IM_QUOTE):
  275     case (127 & IM_SET): case (127 & IM_FUNCALL):
  276     case tcs_cons_inum:
  277     case tcs_cons_iloc:
  278     case tcs_cons_chflag:
  279     case tcs_cons_gloc:
  280     case tcs_cons_nimcar:
  281       scm_iprlist("(", exp, ')', port, writing);
  282       break;
  283     case tcs_closures:
  284       scm_princlosure(exp, port, writing);
  285       break;
  286     case tc7_string:
  287       if (writing) {
  288     lputc('\"', port);
  289     for (i = 0;i<LENGTH(exp);++i) switch (CHARS(exp)[i]) {
  290     case '\"':
  291     case '\\':
  292       lputc('\\', port);
  293     default:
  294       lputc(CHARS(exp)[i], port);
  295     }
  296     lputc('\"', port);
  297     break;
  298       }
  299     case tcs_symbols:
  300       if (writing) {        /* slashified symbol */
  301     for (i = 0;i<LENGTH(exp);++i) switch (CHARS(exp)[i]) {
  302     case 'A': case 'B': case 'C': case 'D': case 'E':
  303     case 'F': case 'G': case 'H': case 'I': case 'J':
  304     case 'K': case 'L': case 'M': case 'N': case 'O':
  305     case 'P': case 'Q': case 'R': case 'S': case 'T':
  306     case 'U': case 'V': case 'W': case 'X': case 'Y': case 'Z':
  307       if (case_sensitize_symbols) goto skipit;
  308     case '\\': case '\"': case '\'': case '(': case ')': case '#':
  309       lputc('\\', port);
  310     skipit:
  311     default:
  312       lputc(CHARS(exp)[i], port);
  313     }
  314     break;
  315       }
  316       else
  317     lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port);
  318       break;
  319     case tc7_vector:
  320       lputs("#(", port);
  321       for (i = 0;i+1<LENGTH(exp);++i) {
  322     /* CHECK_INTS; */
  323     scm_iprin1(VELTS(exp)[i], port, writing);
  324     lputc(' ', port);
  325       }
  326       if (i<LENGTH(exp)) {
  327     /* CHECK_INTS; */
  328     scm_iprin1(VELTS(exp)[i], port, writing);
  329       }
  330       lputc(')', port);
  331       break;
  332     case tc7_VfixN8: case tc7_VfixZ8: case tc7_VfixN16: case tc7_VfixZ16:
  333     case tc7_VfixN32: case tc7_VfixZ32: case tc7_VfixN64: case tc7_VfixZ64:
  334     case tc7_VfloR32: case tc7_VfloC32: case tc7_VfloR64: case tc7_VfloC64:
  335     case tc7_Vbool: 
  336       raprin1(exp, port, writing);
  337       break;
  338     case tcs_subrs:
  339       lputs("#<primitive-procedure ", port);
  340       lputs(SNAME(exp), port);
  341       lputc('>', port);
  342       break;
  343     case tc7_specfun:
  344 #ifdef CCLO
  345       if (tc16_cclo==TYP16(exp)) {
  346     lputs("#<compiled-closure ", port);
  347     scm_iprin1(CCLO_SUBR(exp), port, writing);
  348     lputc(' ', port);
  349     scm_iprin1(VELTS(exp)[1], port, writing);
  350     lputc('>', port);
  351     break;
  352       }
  353 #endif
  354       lputs("#<primitive-procedure ", port);
  355       lputs(CHARS(CDR(exp)), port);
  356       lputc('>', port);
  357       break;
  358     case tc7_contin:
  359       lputs("#<continuation ", port);
  360       scm_intprint(LENGTH(exp), -10, port);
  361       lputs(" @ ", port);
  362       scm_intprint((long)CHARS(exp), -16, port);
  363       lputc('>', port);
  364       break;
  365     case tc7_port:
  366       i = PTOBNUM(exp);
  367       if (i<numptob) {
  368     if (ptobs[i].print && (ptobs[i].print)(exp, port, writing))
  369       ;
  370     else
  371       prinport(exp, port, ptobs[i].name ? ptobs[i].name : "unknown");
  372     break;
  373       }
  374       goto punk;
  375     case tc7_smob:
  376       i = SMOBNUM(exp);
  377       if (i<numsmob && smobs[i].print && (smobs[i].print)(exp, port, writing))
  378     break;
  379       goto punk;
  380     default: punk: scm_ipruk("type", exp, port);
  381     }
  382   }
  383 }
  384 
  385 static char s_char_readyp[]="char-ready?";
  386 
  387 #ifdef __IBMC__
  388 # define MSDOS
  389 #endif
  390 #ifdef MSDOS
  391 # include <io.h>
  392 # include <conio.h>
  393 static int input_waiting(f)
  394      FILE *f;
  395 {
  396   if (feof(f)) return 1;
  397   if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin)))) return kbhit();
  398   return -1;
  399 }
  400 #else
  401 # ifdef _DCC
  402 #  include <ioctl.h>
  403 # else
  404 #  ifndef AMIGA
  405 #   ifndef vms
  406 #    ifdef MWC
  407 #     include <sys/io.h>
  408 #    else
  409 #     ifndef macintosh
  410 #      ifndef ARM_ULIB
  411 #       ifndef PLAN9
  412 #        include <sys/ioctl.h>
  413 #       endif
  414 #      endif
  415 #     endif
  416 #    endif
  417 #   endif
  418 #  endif
  419 # endif
  420 
  421 # ifdef HAVE_SYS_TIME_H
  422 #  include <sys/time.h>
  423 # endif
  424 
  425 static int input_waiting(f)
  426      FILE *f;
  427 {
  428 # ifdef HAVE_SELECT
  429   fd_set ifds;
  430   struct timeval tv;
  431   int ret;
  432 
  433   FD_ZERO(&ifds);
  434   FD_SET(fileno(f), &ifds);
  435   tv.tv_sec = 0;
  436   tv.tv_usec = 0;
  437   SYSCALL(ret = select((fileno(f) + 1), &ifds, (fd_set *) NULL,
  438          (fd_set *) NULL, &tv););
  439   ASRTER(ret>=0, MAKINUM(ret), "select error", s_char_readyp);
  440   return FD_ISSET(fileno(f), &ifds);
  441 # else
  442 #  ifdef FIONREAD
  443   long remir;
  444   if (feof(f)) return 1;
  445   ioctl(fileno(f), FIONREAD, &remir);
  446   return remir;
  447 #  else
  448   return -1;
  449 #  endif
  450 # endif
  451 }
  452 #endif
  453 /* perhaps should undefine MSDOS from __IBMC__ here */
  454 SCM char_readyp(port)
  455      SCM port;
  456 {
  457   if (UNBNDP(port)) port = cur_inp;
  458   ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp);
  459   if (CRDYP(port) || !(BUF0 & SCM_PORTFLAGS(port))) return BOOL_T;
  460   return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F;
  461 }
  462 
  463 #ifdef GO32
  464 # include <pc.h>
  465 #endif
  466 #ifndef HAVE_SELECT
  467 # ifdef PLAN9
  468 #  define kbhit() 0
  469 # else
  470 #  include <time.h>
  471 # endif
  472 #endif
  473 #ifdef __STDC__
  474 # define timet time_t
  475 #else
  476 # define timet long
  477 #endif
  478 static char s_wfi[] = "wait-for-input";
  479 SCM wait_for_input(args)
  480      SCM args;
  481 {
  482   SCM how_long, port1, port, ports, ans = EOL;
  483   int timeout, pos = ARG2;
  484   ASRTER(!NULLP(args), INUM0, WNA, s_wfi);
  485   how_long = CAR(args);
  486   args = CDR(args);
  487   if (NULLP(args)) port1 = cur_inp;
  488   else {
  489     port1 = CAR(args);
  490     args = CDR(args);
  491   }
  492   timeout = num2long(how_long, (char *)ARG1, s_wfi);
  493   ASRTER(timeout >= 0, how_long, ARG1, s_wfi);
  494   port = port1;
  495   ports = args;
  496   while (1) {
  497 /*     ASRTER(NIMP(port) && OPINPORTP(port) && (BUF0 & SCM_PORTFLAGS(port)), */
  498 /*     port, pos, s_wfi); */
  499     if (CRDYP(port) || feof(STREAM(port))) timeout = 0;
  500     if (NULLP(ports)) break;
  501     if (ARG5 <= pos) pos = ARGn;
  502     else if (ARG1 < pos) pos = 1 + pos;
  503     port = CAR(ports);
  504     ports = CDR(ports);
  505   }
  506   {
  507 #ifdef HAVE_SELECT
  508     fd_set ifds;
  509     struct timeval tv;
  510     int ret, fd_max = 0;
  511 
  512     tv.tv_sec = timeout;
  513     tv.tv_usec = 0;
  514 
  515     FD_ZERO(&ifds);
  516     port = port1;
  517     ports = args;
  518     while (1) {
  519       int fd = fileno(STREAM(port));
  520       FD_SET(fd, &ifds);
  521       if (fd_max < fd) fd_max = fd;
  522 
  523       if (NULLP(ports)) break;
  524       port = CAR(ports);
  525       ports = CDR(ports);
  526     }
  527     SYSCALL(ret = select(fd_max + 1, &ifds, (fd_set *)0L, (fd_set *)0L, &tv););
  528     ASRTER(ret>=0, MAKINUM(ret), "select error", s_wfi);
  529 
  530     port = port1;
  531     ports = args;
  532     while (1) {
  533       if (FD_ISSET(fileno(STREAM(port)), &ifds)
  534       || CRDYP(port) || feof(STREAM(port)))
  535     ans = cons(port, ans);
  536       if (NULLP(ports)) break;
  537       port = CAR(ports);
  538       ports = CDR(ports);
  539     }
  540 #else
  541     timet start = 0;
  542     time(&start);
  543     start = start + timeout;
  544     port = port1;
  545     ports = args;
  546     do {
  547       FILE *f = STREAM(port);
  548       if (feof(f)) ans = cons(port, ans);
  549       else {
  550 # ifdef _WIN32
  551         if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin))) && kbhit())
  552           ans = cons(port, ans);
  553 # else
  554 #  ifdef FIONREAD
  555         long remir;
  556         ioctl(fileno(f), FIONREAD, &remir);
  557         if (remir) ans = cons(port, ans);
  558 #  else
  559         /* If we get here this is not going to work */
  560 #  endif
  561 # endif
  562           if (NULLP(ports)) break;
  563         port = CAR(ports);
  564         ports = CDR(ports);
  565       }
  566     } while (time((timet*)0L) < start);
  567 #endif
  568     return NULLP(ans) ? BOOL_F : ans;
  569   }
  570 }
  571 
  572 SCM eof_objectp(x)
  573      SCM x;
  574 {
  575     return (EOF_VAL==x) ? BOOL_T : BOOL_F;
  576 }
  577 
  578 static SCM *loc_broken_pipe = 0;
  579 /* returning non-zero means try again. */
  580 int scm_io_error(port, what)
  581      SCM port;
  582      const char *what;
  583 {
  584 #ifdef HAVE_PIPE
  585 # ifdef EPIPE
  586   if (EPIPE==errno) {
  587     if (scm_verbose > 2) {
  588       err_head("WARNING");
  589       lputs(";;", cur_errp);
  590       lputs(what, cur_errp);
  591       lputs(": closing pipe ", cur_errp);
  592       scm_iprin1(port, cur_errp, 1);
  593       scm_newline(cur_errp);
  594     }
  595     close_port(port);
  596     if (*loc_broken_pipe && NIMP(*loc_broken_pipe))
  597       apply(*loc_broken_pipe, port, listofnull);
  598     return 0;
  599   }
  600 # endif
  601 #endif
  602   if (SCM_INTERRUPTED(errno)) {
  603     errno = 0;
  604     return !0;
  605   }
  606   wta(port, what, "Input/Output");
  607   return 0;         /* squelch warning */
  608 }
  609 
  610 void lfflush(port)      /* internal SCM call */
  611      SCM port;
  612 {
  613   sizet i = PTOBNUM(port);
  614   while ((ptobs[i].fflush)(STREAM(port)) &&
  615      scm_io_error(port, "lfflush"))
  616     ;
  617 }
  618 static char s_force_output[] = "force-output";
  619 SCM scm_force_output(port)
  620      SCM port;
  621 {
  622   if (UNBNDP(port)) port = cur_outp;
  623   else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_force_output);
  624   lfflush(port);
  625   return UNSPECIFIED;
  626 }
  627 
  628 SCM scm_write(obj, port)
  629      SCM obj, port;
  630 {
  631     if (UNBNDP(port)) port = cur_outp;
  632     else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write);
  633     scm_iprin1(obj, port, 1);
  634     return UNSPECIFIED;
  635 }
  636 SCM scm_display(obj, port)
  637      SCM obj, port;
  638 {
  639     if (UNBNDP(port)) port = cur_outp;
  640     else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display);
  641     scm_iprin1(obj, port, 0);
  642     return UNSPECIFIED;
  643 }
  644 SCM scm_newline(port)
  645      SCM port;
  646 {
  647     if (UNBNDP(port)) port = cur_outp;
  648     else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_newline);
  649     lputc('\n', port);
  650     if (port==cur_outp) lfflush(port);
  651     return UNSPECIFIED;
  652 }
  653 SCM scm_write_char(chr, port)
  654      SCM chr, port;
  655 {
  656     if (UNBNDP(port)) port = cur_outp;
  657     else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_char);
  658     ASRTER(ICHRP(chr), chr, ARG1, s_write_char);
  659     lputc((int)ICHR(chr), port);
  660     return UNSPECIFIED;
  661 }
  662 SCM scm_freshline(port)
  663      SCM port;
  664 {
  665     if (UNBNDP(port)) port = cur_outp;
  666     else ASRTER(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_freshline);
  667     if (INUM0==scm_port_col(port)) return UNSPECIFIED;
  668     lputc('\n', port);
  669     if (port==cur_outp) lfflush(port);
  670     return UNSPECIFIED;
  671 }
  672 
  673 void lputc(c, port)
  674      int c;
  675      SCM port;
  676 {
  677   sizet i = PTOBNUM(port);
  678   while (EOF==(ptobs[i].fputc)(c, STREAM(port)) &&
  679      scm_io_error(port, "fputc"))
  680     ;
  681   if (CRDY & CAR(port)) {
  682     i = SCM_PORTNUM(port);
  683     switch (c) {
  684     case LINE_INCREMENTORS:
  685       scm_port_table[i].line++;
  686       scm_port_table[i].col = 1;
  687       break;
  688     default:
  689       scm_port_table[i].col++;
  690     }
  691   }
  692 }
  693 void lputs(s, port)
  694      const char *s;
  695      SCM port;
  696 {
  697   sizet i = PTOBNUM(port);
  698   ASRTER(s, INUM0, ARG1, "lputs");
  699   while (EOF==(ptobs[i].fputs)(s, STREAM(port)) &&
  700      scm_io_error(port, "fputs"))
  701     ;
  702   if (CRDY & CAR(port)) {
  703     sizet j;
  704     i = SCM_PORTNUM(port);
  705     for (j = 0; s[j]; j++) {
  706       switch (s[j]) {
  707       case LINE_INCREMENTORS:
  708     scm_port_table[i].line++;
  709     scm_port_table[i].col = 1;
  710     break;
  711       default:
  712     scm_port_table[i].col++;
  713       }
  714     }
  715   }
  716 }
  717 sizet lfwrite(ptr, size, nitems, port)
  718      char *ptr;
  719      sizet size;
  720      sizet nitems;
  721      SCM port;
  722 {
  723   sizet ret, i = PTOBNUM(port);
  724   do {
  725     ret = (ptobs[i].fwrite)(ptr, size, nitems, STREAM(port));
  726   } while(nitems != ret && scm_io_error(port, "fwrite"));
  727   if (CRDY & CAR(port)) {
  728     sizet j;
  729     i = SCM_PORTNUM(port);
  730     for (j = 0; j < ret*size; j++) {
  731       switch (ptr[j]) {
  732       case LINE_INCREMENTORS:
  733     scm_port_table[i].line++;
  734     scm_port_table[i].col = 1;
  735     break;
  736       default:
  737     scm_port_table[i].col++;
  738       }
  739     }
  740   }
  741   return ret;
  742 }
  743 
  744 int lgetc(port)
  745   SCM port;
  746 {
  747   FILE *f;
  748   int c;
  749   int i, j = -1;
  750   if (CRDY & CAR(port)) {
  751     j = SCM_PORTNUM(port);
  752     c = scm_port_table[j].unread;
  753     if (c != EOF) {
  754       scm_port_table[j].unread = EOF;
  755       CAR(port) &= (scm_port_table[j].flags | (~0xf0000)); /* CLRDY(port) */
  756       return c;
  757     }
  758   }
  759   f = STREAM(port);
  760   i = PTOBNUM(port);
  761 #ifdef linux
  762   c = (ptobs[i].fgetc)(f);
  763 #else
  764   SYSCALL(c = (ptobs[i].fgetc)(f););
  765 #endif
  766   if (j > -1)  {
  767     /* This means that CRDY is set, note that CRDY is overloaded */
  768     switch (c) {
  769     case LINE_INCREMENTORS:
  770       scm_port_table[j].line++;
  771       scm_port_table[j].colprev = scm_port_table[j].col;
  772       scm_port_table[j].col = 1;
  773       break;
  774     default:
  775       scm_port_table[j].col++;
  776     }
  777   }
  778   return c;
  779 }
  780 void lungetc(c, port)
  781   int c;
  782   SCM port;
  783 {
  784   int i = PTOBNUM(port);
  785 /*  ASRTER(!CRDYP(port), port, ARG2, "too many lungetc");*/
  786   if (ptobs[i].ungetc)
  787     (ptobs[i].ungetc)(c, port);
  788   else {
  789     scm_port_table[SCM_PORTNUM(port)].unread = c;
  790     CAR(port) |= CRDY;
  791   }
  792 }
  793 
  794 SCM scm_read_char(port)
  795      SCM port;
  796 {
  797   int c;
  798   if (UNBNDP(port)) port = cur_inp;
  799   ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char);
  800   c = lgetc(port);
  801   if (EOF==c) return EOF_VAL;
  802   return MAKICHR(c);
  803 }
  804 SCM scm_peek_char(port)
  805   SCM port;
  806 {
  807     int c;
  808     if (UNBNDP(port)) port = cur_inp;
  809     else ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, s_peek_char);
  810     c = lgetc(port);
  811     if (EOF==c) return EOF_VAL;
  812     lungetc(c, port);
  813     return MAKICHR(c);
  814 }
  815 
  816 char *grow_tok_buf(tok_buf)
  817      SCM tok_buf;
  818 {
  819   sizet len = LENGTH(tok_buf);
  820   len += len / 2;
  821   resizuve(tok_buf, (SCM)MAKINUM(len));
  822   return CHARS(tok_buf);
  823 }
  824 
  825 static int flush_ws(port)
  826      SCM port;
  827 {
  828   register int c;
  829   while(1) switch (c = lgetc(port)) {
  830     case ';': lp: switch (c = lgetc(port)) {
  831       default: goto lp;
  832       case EOF: return c;
  833       case LINE_INCREMENTORS: break;
  834     }
  835     case LINE_INCREMENTORS:
  836     case WHITE_SPACES: break;
  837     case EOF:
  838     default:
  839       return c;
  840   }
  841 }
  842 
  843 /* Top-level readers */
  844 static SCM p_read_for_load, p_read;
  845 static char s_read[] = "read";
  846 static char s_read_for_load[] = "read-for-load";
  847 #ifndef MEMOIZE_LOCALS
  848 static SCM p_read_numbered;
  849 static char s_read_numbered[] = "read-numbered";
  850 #endif
  851 SCM scm_read(port)
  852      SCM port;
  853 {
  854   return scm_lread1(port, case_sensitize_symbols, s_read);
  855 }
  856 
  857 SCM scm_read_for_load(port)
  858      SCM port;
  859 {
  860   return scm_lread1(port, 4 | case_sensitize_symbols, s_read_for_load);
  861 }
  862 
  863 #ifndef MEMOIZE_LOCALS
  864 SCM scm_read_numbered(port)
  865      SCM port;
  866 {
  867   return scm_lread1(port, 6 | case_sensitize_symbols, s_read_numbered);
  868 }
  869 #endif
  870 
  871 static SCM scm_lread1(port, flgs, what)
  872      SCM port;
  873      int flgs;
  874      const char *what;
  875 {
  876   int c;
  877   SCM tok_buf;
  878   if (UNBNDP(port)) port = cur_inp;
  879   ASRTER(NIMP(port) && OPINPORTP(port), port, ARG1, what);
  880   do {
  881     c = flush_ws(port);
  882     if (EOF==c) return EOF_VAL;
  883     lungetc(c, port);
  884     tok_buf = makstr(30L);
  885   } while (EOF_VAL==(tok_buf = scm_lreadr(tok_buf, port, flgs)));
  886   return tok_buf;
  887 }
  888 static SCM *loc_loadsharp = 0, *loc_readsharp = 0, *loc_charsharp = 0;
  889 static SCM scm_lreadpr(tok_buf, port, flgs)
  890      SCM tok_buf;
  891      SCM port;
  892      int flgs;
  893 {
  894   int c;
  895   sizet j;
  896   SCM p;
  897   if (2==(3 & flgs)) return scm_lread_rec(tok_buf, port);
  898  tryagain:
  899   c = flush_ws(port);
  900   switch (c) {
  901   case EOF: return EOF_VAL;
  902 #ifdef BRACKETS_AS_PARENS
  903   case '[':
  904 #endif
  905   case '(': return scm_lreadparen(tok_buf, port, flgs, s_list);
  906 #ifdef BRACKETS_AS_PARENS
  907   case ']':
  908 #endif
  909   case ')': return UNDEFINED; /* goto tryagain; */
  910   case '\'': return cons2(i_quote,
  911               scm_lreadr(tok_buf, port, flgs), EOL);
  912   case '`': return cons2(i_quasiquote,
  913              scm_lreadr(tok_buf, port, flgs), EOL);
  914   case ',':
  915     c = lgetc(port);
  916     if ('@'==c) p = i_uq_splicing;
  917     else {
  918       lungetc(c, port);
  919       p = i_unquote;
  920     }
  921     return cons2(p, scm_lreadr(tok_buf, port, flgs), EOL);
  922   case '#':
  923     c = lgetc(port);
  924     switch (c) {
  925 #ifdef BRACKETS_AS_PARENS
  926     case '[':
  927 #endif
  928     case '(':
  929       p = scm_lreadparen(tok_buf, port, flgs, s_vector);
  930       return NULLP(p) ? nullvect : vector(p);
  931     case 't': case 'T': return BOOL_T;
  932     case 'f': case 'F': return BOOL_F;
  933     case 'b': case 'B': case 'o': case 'O':
  934     case 'd': case 'D': case 'x': case 'X':
  935     case 'i': case 'I': case 'e': case 'E':
  936       lungetc(c, port);
  937       c = '#';
  938       goto num;
  939     case '*':
  940       j = scm_read_token(c, tok_buf, port, flgs);
  941       p = istr2bve(CHARS(tok_buf)+1, (long)(j-1));
  942       if (NFALSEP(p)) return p;
  943       else goto unkshrp;
  944     case '\\':
  945       c = lgetc(port);
  946       if ('\\'==c) {
  947     CHARS(tok_buf)[0] = c;
  948     j = 1;
  949       } else j = scm_read_token(c, tok_buf, port, flgs);
  950       if (j==1) return MAKICHR(c);
  951       for (c = 0;c<sizeof charnames/sizeof(char *);c++)
  952     if (charnames[c]
  953         && (0==strcasecmp(charnames[c], CHARS(tok_buf))))
  954       return MAKICHR(charnums[c]);
  955       if (loc_charsharp && NIMP(*loc_charsharp)) {
  956     resizuve(tok_buf, MAKINUM(j));
  957     p = apply(*loc_charsharp, tok_buf, listofnull);
  958     if (ICHRP(p)) return p;
  959       }
  960       wta(UNDEFINED, "unknown # object: #\\", CHARS(tok_buf));
  961     case '|':
  962       j = 1;    /* here j is the comment nesting depth */
  963     lp: c = lgetc(port);
  964     lpc:
  965       switch (c) {
  966       case EOF: wta(UNDEFINED, s_eofin, "balanced comment");
  967       case LINE_INCREMENTORS:
  968       default:
  969     goto lp;
  970       case '|':
  971     if ('#' != (c = lgetc(port))) goto lpc;
  972     if (--j) goto lp;
  973     break;
  974       case '#':
  975     if ('|' != (c = lgetc(port))) goto lpc;
  976     ++j; goto lp;
  977       }
  978       goto tryagain;
  979     default: callshrp:
  980       {
  981     SCM reader =
  982 #ifndef MEMOIZE_LOCALS
  983       (3 & flgs) ? p_read_numbered :
  984 #endif
  985       ((4 & flgs) ? p_read_for_load : p_read);
  986     SCM args = cons2(MAKICHR(c), port, cons(reader, EOL));
  987     if ((4 & flgs) && loc_loadsharp && NIMP(*loc_loadsharp)) {
  988       p = apply(*loc_loadsharp, args, EOL);
  989       if (UNSPECIFIED==p) goto tryagain;
  990       return p;
  991     } else if (loc_readsharp && NIMP(*loc_readsharp)) {
  992       p = apply(*loc_readsharp, args, EOL);
  993       if (UNSPECIFIED==p) goto tryagain;
  994       return p;
  995     }
  996       }
  997     unkshrp: wta((SCM)MAKICHR(c), s_unknown_sharp, "");
  998     }
  999   case '\"':
 1000     j = 0;
 1001     while ('\"' != (c = lgetc(port))) {
 1002       ASRTER(EOF != c, UNDEFINED, s_eofin, s_string);
 1003       if (j+1 >= LENGTH(tok_buf)) grow_tok_buf(tok_buf);
 1004       switch (c) {
 1005       case LINE_INCREMENTORS: break;
 1006       case '\\':
 1007     switch (c = lgetc(port)) {
 1008     case LINE_INCREMENTORS: continue;
 1009     case '0': c = '\0'; break;
 1010     case 'f': c = '\f'; break;
 1011     case 'n': c = '\n'; break;
 1012     case 'r': c = '\r'; break;
 1013     case 't': c = '\t'; break;
 1014     case 'a': c = '\007'; break;
 1015     case 'v': c = '\v'; break;
 1016     }
 1017       }
 1018       CHARS(tok_buf)[j] = c;
 1019       ++j;
 1020     }
 1021     if (j==0) return nullstr;
 1022     CHARS(tok_buf)[j] = 0;
 1023     return makfromstr(CHARS(tok_buf), j);
 1024   case DIGITS:
 1025   case '.': case '-': case '+':
 1026   num:
 1027     j = scm_read_token(c, tok_buf, port, flgs);
 1028     p = istring2number(CHARS(tok_buf), (long)j, 10L);
 1029     if (NFALSEP(p)) return p;
 1030     if (c=='#') {
 1031       if ((j==2) && (lgetc(port)=='(')) {
 1032     lungetc('(', port);
 1033     c = CHARS(tok_buf)[1];
 1034     goto callshrp;
 1035       }
 1036       wta(UNDEFINED, s_unknown_sharp, CHARS(tok_buf));
 1037     }
 1038     goto tok;
 1039   default:
 1040     j = scm_read_token(c, tok_buf, port, flgs);
 1041   tok:
 1042     p = intern(CHARS(tok_buf), j);
 1043     return CAR(p);
 1044   }
 1045 }
 1046 static SCM scm_lreadr(tok_buf, port, flgs)
 1047      SCM tok_buf;
 1048      SCM port;
 1049      int flgs;
 1050 {
 1051   SCM ans = scm_lreadpr(tok_buf, port, flgs);
 1052   switch (ans) {
 1053   case UNDEFINED:
 1054     scm_warn("unexpected \")\"", "", port);
 1055     return scm_lreadpr(tok_buf, port, flgs);
 1056   }
 1057   return ans;
 1058 }
 1059 static SCM scm_lread_rec(tok_buf, port)
 1060      SCM tok_buf;
 1061      SCM port;
 1062 {
 1063   SCM line, form;
 1064   int c = flush_ws(port);
 1065   switch (c) {
 1066   default:
 1067     lungetc(c, port);
 1068     line = scm_port_line(port);
 1069     form = scm_lreadpr(tok_buf, port, 5);
 1070     if (NFALSEP(line) && NIMP(form) &&
 1071     (CONSP(form) || VECTORP(form))) {
 1072       return cons(SCM_MAKE_LINUM(INUM(line)), form);
 1073     }
 1074     return form;
 1075 #ifdef BRACKETS_AS_PARENS
 1076   case ']':
 1077 #endif
 1078   case ')': return UNDEFINED;
 1079   case EOF: return EOF_VAL;
 1080   }
 1081 }
 1082 
 1083 #ifdef _UNICOS
 1084 _Pragma("noopt");       /* # pragma _CRI noopt */
 1085 #endif
 1086 static sizet scm_read_token(ic, tok_buf, port, flgs)
 1087      int ic;
 1088      SCM tok_buf;
 1089      SCM port;
 1090      int flgs;
 1091 {
 1092   register sizet j = 1;
 1093   register int c = ic;
 1094   register char *p = CHARS(tok_buf);
 1095   p[0] = '\\'==c ? lgetc(port) : 8 & flgs ? c : downcase[c];
 1096   while(1) {
 1097     if (j+1 >= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf);
 1098     switch (c = lgetc(port)) {
 1099 #ifdef BRACKETS_AS_PARENS
 1100     case '[': case ']':
 1101 #endif
 1102     case '(': case ')': case '\"': case ';':
 1103     case ',': case '`':
 1104       /* case '#': */
 1105     case WHITE_SPACES:
 1106     case LINE_INCREMENTORS:
 1107       lungetc(c, port);
 1108     case EOF:
 1109       p[j] = 0;
 1110       return j;
 1111     case '\\':  /* slashified symbol */
 1112       p[j++] = lgetc(port);
 1113       break;
 1114     default:
 1115       p[j++] = 8 & flgs ? c : downcase[c];
 1116     }
 1117   }
 1118 }
 1119 #ifdef _UNICOS
 1120 _Pragma("opt");         /* # pragma _CRI opt */
 1121 #endif
 1122 
 1123 /* flgs was originally an argument to determine whether a read was */
 1124 /* top-level or recursve.  It has been overloaded to determine also */
 1125 /* what to do in the case of a recursive read. */
 1126 /* It distinguishes four states: */
 1127 /* 0 - not adding line-numbers - never changes.  Uses READ:SHARP */
 1128 /* 4 - not adding line-numbers - never changes.  Uses LOAD:SHARP */
 1129 /* 5 - top level read when adding line-numbers.  Uses LOAD:SHARP */
 1130 /* 6 - recursive read when adding line-numbers.  Uses LOAD:SHARP */
 1131 
 1132 static SCM scm_lreadparen(tok_buf, port, flgs, name)
 1133      SCM tok_buf;
 1134      SCM port;
 1135      int flgs;
 1136      char *name;
 1137 {
 1138   SCM lst, fst,
 1139     tmp = scm_lreadpr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 2 : 0));
 1140   if (UNDEFINED==tmp) return EOL;
 1141   if (i_dot==tmp) {
 1142     fst = scm_lreadr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 1 : 0));
 1143   closeit:
 1144     tmp = scm_lreadpr(tok_buf, port, 0);
 1145     if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", name);
 1146     return fst;
 1147   }
 1148   fst = lst = cons(tmp, EOL);
 1149   while (UNDEFINED !=
 1150      (tmp = scm_lreadpr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 2 : 0)))) {
 1151     if (EOF_VAL==tmp) wta(lst, s_eofin, s_list);
 1152     if (i_dot==tmp) {
 1153       CDR(lst) = scm_lreadr(tok_buf, port, (0xC & flgs) | ((3 & flgs) ? 1 : 0));
 1154       goto closeit;
 1155     }
 1156     lst = (CDR(lst) = cons(tmp, EOL));
 1157   }
 1158   return fst;
 1159 }
 1160 
 1161 /* These procedures implement synchronization primitives.  Processors
 1162    with an atomic test-and-set instruction can use it here (and not
 1163    DEFER_INTS). */
 1164 char s_swapcar[] = "swap-car!";
 1165 SCM swapcar(pair, value)
 1166      SCM pair, value;
 1167 {
 1168   SCM ret;
 1169   ASRTER(NIMP(pair) && CONSP(pair), pair, ARG1, s_swapcar);
 1170   DEFER_INTS;
 1171   ret = CAR(pair);
 1172   CAR(pair) = value;
 1173   ALLOW_INTS;
 1174   return ret;
 1175 }
 1176 char s_tryarb[] = "try-arbiter";
 1177 char s_relarb[] = "release-arbiter";
 1178 long tc16_arbiter;
 1179 SCM tryarb(arb)
 1180      SCM arb;
 1181 {
 1182   ASRTER((TYP16(arb)==tc16_arbiter), arb, ARG1, s_tryarb);
 1183   DEFER_INTS;
 1184   if (CAR(arb) & (1L<<16))
 1185     arb = BOOL_F;
 1186   else {
 1187     CAR(arb) = tc16_arbiter | (1L<<16);
 1188     arb = BOOL_T;
 1189   }
 1190   ALLOW_INTS;
 1191   return arb;
 1192 }
 1193 SCM relarb(arb)
 1194      SCM arb;
 1195 {
 1196   ASRTER((TYP16(arb)==tc16_arbiter), arb, ARG1, s_relarb);
 1197   if (!(CAR(arb) & (1L<<16))) return BOOL_F;
 1198   CAR(arb) = tc16_arbiter;
 1199   return BOOL_T;
 1200 }
 1201 SCM makarb(name)
 1202      SCM name;
 1203 {
 1204   register SCM z;
 1205   NEWCELL(z);
 1206   CDR(z) = name;
 1207   CAR(z) = tc16_arbiter;
 1208   return z;
 1209 }
 1210 static int prinarb(exp, port, writing)
 1211      SCM exp; SCM port; int writing;
 1212 {
 1213   lputs("#<arbiter ", port);
 1214   if (CAR(exp) & (1L<<16)) lputs("locked ", port);
 1215   scm_iprin1(CDR(exp), port, writing);
 1216   lputc('>', port);
 1217   return !0;
 1218 }
 1219 
 1220 static char s_tryload[] = "try-load";
 1221 #define s_load (&s_tryload[4])
 1222 
 1223 struct errdesc {char *msg;char *s_response;short parent_err;};
 1224 struct errdesc errmsgs[] = {
 1225   {"Wrong number of args", 0, 0},
 1226   {"numerical overflow", 0, FPE_SIGNAL},
 1227   {"Argument out of range", 0, FPE_SIGNAL},
 1228   {"Could not allocate", "out-of-storage", 0},
 1229   {"Thrashing", "thrashing", 0},
 1230   {"EXIT", "end-of-program", -1},
 1231   {"hang up", "hang-up", EXIT},
 1232   {"user interrupt", "user-interrupt", 0},
 1233   {"arithmetic error", "arithmetic-error", 0},
 1234   {"bus error", 0, 0},
 1235   {"segment violation", 0, 0},
 1236   {"alarm", "alarm-interrupt", 0},
 1237   {"virtual alarm", "virtual-alarm-interrupt", 0},
 1238   {"profile interrupt", "profile-alarm-interrupt", 0},
 1239 };
 1240 
 1241 void (* deferred_proc) P((void)) = 0;
 1242 char *errjmp_bad = "init";
 1243 VOLATILE int ints_disabled = 1;
 1244 unsigned long SIG_deferred = 0;
 1245 int scm_verbose = 1;        /* Low so that monitor info won't be */
 1246                 /* printed while in init_storage. (BOOM) */
 1247 static int errjmp_recursive = 0;
 1248 static int errobj_codep;
 1249 static SCM err_exp, err_env;
 1250 static char *err_pos, *err_s_subr;
 1251 static cell tmp_errobj = {(SCM)UNDEFINED, (SCM)EOL};
 1252 static cell tmp_loadpath = {(SCM)BOOL_F, (SCM)EOL};
 1253 SCM *loc_errobj = (SCM *)&tmp_errobj;
 1254 SCM *loc_loadpath = (SCM *)&tmp_loadpath;
 1255 unsigned long  mallocated = 0, lmallocated = 0;
 1256 long cells_allocated = 0, lcells_allocated = 0,
 1257   rt = 0, gc_rt, gc_time_taken;
 1258 long gc_cells_collected, gc_malloc_collected, gc_ports_collected;
 1259 long gc_syms_collected;
 1260 long scm_env_work = 0,  scm_gcs = 0, scm_egcs = 0,
 1261   scm_stk_moved = 0, scm_clo_moved = 0, scm_egc_rt;
 1262 static void def_err_response P((void));
 1263 
 1264 int handle_it(i)
 1265      int i;
 1266 {
 1267   SCM proc;
 1268   char *name = errmsgs[i-WNA].s_response;
 1269   if (errjmp_bad || errjmp_recursive)
 1270     wta(UNDEFINED, (char *)i, ""); /* sends it to def_err_response */
 1271   /* NEWCELL does not defer interrupts; so be careful to maintain the
 1272      freelist integrity. */
 1273   if (name) {
 1274     int j;
 1275     SCM n[2];      /* GC-protect discarded cells (possibly being used
 1276               by interrupted code). */
 1277     DEFER_INTS;
 1278     /* Two cells are discarded because NEWCELL may have been
 1279        interrupted between computing the right-hand-side of
 1280           freelist = CDR(freelist)
 1281        and assigning it to freelist. */
 1282     for (j=0; j<2; j++) NEWCELL(n[j]); /* discard 2 possibly-used cells */
 1283     CDR(n[1]) = EOL;        /* lose pointer to freelist */
 1284     ALLOW_INTS;
 1285     /* discarding was necessary here because intern() may do NEWCELL */
 1286     proc = CDR(intern(name, (sizet)strlen(name)));
 1287     if (NIMP(proc)) {      /* Save environment stack, in case it moves
 1288                   when applying proc.  Do an ecache gc to
 1289                   protect contents of stack. */
 1290       SCM estk, *estk_ptr, env, env_tmp;
 1291       DEFER_INTS;
 1292 #ifndef NO_ENV_CACHE
 1293       scm_egc();
 1294 #endif
 1295       estk = scm_estk;
 1296       estk_ptr = scm_estk_ptr;
 1297       env = scm_env;
 1298       env_tmp = scm_env_tmp;
 1299       scm_estk = BOOL_F;
 1300       scm_estk_reset(0);
 1301       SCM_ESTK_PARENT(scm_estk) = estk;
 1302       SCM_ESTK_PARENT_INDEX(scm_estk) = MAKINUM(estk_ptr - VELTS(estk));
 1303       ALLOW_INTS;
 1304       apply(proc, EOL, EOL);
 1305       DEFER_INTS;
 1306       scm_estk = estk;
 1307       scm_estk_ptr = estk_ptr;
 1308       scm_env = env;
 1309       scm_env_tmp = env_tmp;
 1310       scm_fill_freelist();
 1311       ALLOW_INTS;
 1312       return i;
 1313     }
 1314   }
 1315   /* Ensure that freelist is not empty when returning from interrupt */
 1316   DEFER_INTS;
 1317   scm_fill_freelist();
 1318   ALLOW_INTS;
 1319   return errmsgs[i-WNA].parent_err;
 1320 }
 1321 
 1322 SCM exitval = MAKINUM(EXIT_FAILURE); /* INUM return value */
 1323 extern char s_unexec[];
 1324 SCM scm_top_level(initpath, toplvl_fun)
 1325      char *initpath;
 1326      SCM (*toplvl_fun)();
 1327 {
 1328   SCM ret;
 1329 #ifdef _UNICOS
 1330   int i;
 1331 #else
 1332   long i;
 1333 #endif
 1334   if (!toplvl_fun) toplvl_fun = repl;
 1335   CONT(rootcont)->stkbse = (STACKITEM *)&i;
 1336   i = setjump(CONT(rootcont)->jmpbuf);
 1337 #ifndef SHORT_INT
 1338   if (i) i = UNCOOK(i);
 1339 #endif
 1340  drloop:
 1341   switch (PTR2INT(i)) {
 1342   default:
 1343     {
 1344       char *name = errmsgs[i-WNA].s_response;
 1345       if (name) {
 1346     SCM proc = CDR(intern(name, (sizet)strlen(name)));
 1347     if (NIMP(proc)) apply(proc, EOL, EOL);
 1348       }}
 1349     i = errmsgs[i-WNA].parent_err;
 1350     if (i) goto drloop;
 1351   case 1:           /* from everr() */
 1352     def_err_response();
 1353     goto reset_toplvl;
 1354   case 0:
 1355     exitval = MAKINUM(EXIT_SUCCESS);
 1356     errjmp_bad = (char *)0;
 1357     errjmp_recursive = 0;
 1358     if (NIMP(sys_errp) && OPOUTPORTP(sys_errp)) lfflush(sys_errp);
 1359     errno = 0;
 1360     SIG_deferred = 0;
 1361     deferred_proc = 0;
 1362     ints_disabled = 0;
 1363     scm_init_INITS();
 1364     if (dumped) {
 1365       lcells_allocated = cells_allocated;
 1366       lmallocated = mallocated;
 1367       rt = INUM(my_time());
 1368       gc_time_taken = 0;
 1369     }
 1370     else if (initpath &&
 1371          (isspace(initpath[0]) || ';'==initpath[0] || '('==initpath[0]))
 1372       scm_ldstr(initpath);
 1373     else if (scm_ldfile(initpath ? initpath : "")) /* load Scheme init files */
 1374       wta(*loc_errobj, "Could not open file", s_load);
 1375     {
 1376       SCM boot_tail = scm_evstr("boot-tail");
 1377       /* initialization tail-call */
 1378       if (NIMP(boot_tail))
 1379         apply(boot_tail, (dumped ? makfrom0str(initpath) : BOOL_F), listofnull);
 1380     }
 1381   case -2:          /* abrt */
 1382   reset_toplvl:
 1383     ints_disabled = 1;
 1384     errjmp_bad = (char *)0;
 1385     errjmp_recursive = 0;
 1386     if (NIMP(sys_errp) && OPOUTPORTP(sys_errp)) lfflush(sys_errp);
 1387     SIG_deferred = 0;
 1388     deferred_proc = 0;
 1389     gc_hook_active = 0;
 1390     scm_estk_reset(0);
 1391 
 1392     /* Closing the loading file turned out to be a bad idea. */
 1393     /* But I will leave the code here in case someone wants it. */
 1394 #ifdef CLOSE_LOADING_PORTS_ON_ABORT
 1395     if (NIMP(loadports) && OPINPORTP(CAR(loadports))) {
 1396       if (scm_verbose > 1) {
 1397     lputs("; Aborting load (closing): ", cur_errp);
 1398     scm_display(*loc_loadpath, cur_errp);
 1399     scm_newline(cur_errp);
 1400       }
 1401       close_port(CAR(loadports)); /* close loading file. */
 1402     }
 1403 #endif
 1404 
 1405     *loc_loadpath = BOOL_F;
 1406     loadports = EOL;
 1407     ints_disabled = 0;
 1408     dowinds(EOL);
 1409     ret = toplvl_fun();     /* typically repl() */
 1410     if (INUMP(ret)) exitval = ret;
 1411     err_pos = (char *)EXIT;
 1412     i = EXIT;
 1413     goto drloop;        /* encountered EOF on stdin */
 1414   case -1:          /* quit */
 1415     dowinds(EOL);
 1416     if (MAKINUM(EXIT_SUCCESS) != exitval) {
 1417       lputs("; program args: ", cur_errp);
 1418       scm_write(progargs, cur_errp);
 1419       scm_newline(cur_errp);
 1420     }
 1421     return exitval;
 1422   case -3:          /* restart. */
 1423     dowinds(EOL);
 1424     return 0;
 1425 #ifdef CAN_DUMP
 1426   case -4:          /* dump */
 1427     DEFER_INTS;
 1428     scm_estk_reset(0);
 1429     scm_egc();
 1430     igc(s_unexec, BOOL_F);
 1431     ALLOW_INTS;
 1432     dumped = 1;
 1433 # ifdef linux
 1434     sbrk(getpagesize());    /* The last few words of the .data segment
 1435                    were not being mapped in for dumped
 1436                    executables. */
 1437 # endif
 1438     unexec(CHARS(*loc_errobj), execpath, 0, 0, 0);
 1439     goto reset_toplvl;
 1440 #endif
 1441   }
 1442 }
 1443 
 1444 SCM line_num()
 1445 {
 1446   if (IMP(loadports))
 1447     return INUM0;
 1448   return scm_port_line(CAR(loadports));
 1449 }
 1450 static char s_port_line[] = "port-line";
 1451 SCM scm_port_line(port)
 1452      SCM port;
 1453 {
 1454   sizet lnum;
 1455   ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_line);
 1456   if (! (TRACKED & SCM_PORTFLAGS(port))) return BOOL_F;
 1457   lnum = scm_port_table[SCM_PORTNUM(port)].line;
 1458   switch (CGETUN(port)) {
 1459   default:
 1460   case EOF:         /* no ungetted char */
 1461     break;
 1462   case LINE_INCREMENTORS:
 1463     lnum--;
 1464     break;
 1465   }
 1466   return MAKINUM(lnum);
 1467 }
 1468 static char s_port_col[] = "port-column";
 1469 SCM scm_port_col(port)
 1470      SCM port;
 1471 {
 1472   long col;
 1473   ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_col);
 1474   if (! (TRACKED & SCM_PORTFLAGS(port))) return BOOL_F;
 1475   col = scm_port_table[SCM_PORTNUM(port)].col;
 1476   switch (CGETUN(port)) {
 1477   default:
 1478     col--;
 1479     break;
 1480   case EOF:         /* no ungetted char */
 1481     break;
 1482   case LINE_INCREMENTORS:
 1483     col = scm_port_table[SCM_PORTNUM(port)].colprev;
 1484     break;
 1485   }
 1486   return MAKINUM(col);
 1487 }
 1488 
 1489 static char s_file_position[] = "file-position";
 1490 SCM scm_file_position(port, pos)
 1491      SCM port, pos;
 1492 {
 1493   ASRTER(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_position);
 1494   if (UNBNDP(pos) || FALSEP(pos)) {
 1495     long ans;
 1496     SYSCALL(ans = ftell(STREAM(port)););
 1497     if (ans < 0) return BOOL_F;
 1498     if (CRDYP(port)) ans--;
 1499     return MAKINUM(ans);
 1500   }
 1501   ASRTER((INUMP(pos) && (INUM(pos) >= 0))
 1502      || (NIMP(pos) && (TYP16(pos)==tc16_bigpos)),
 1503      port, ARG2, s_file_position);
 1504 #ifndef RECKLESS
 1505   if (TRACKED & SCM_PORTFLAGS(port)) {
 1506     if (INUM0==pos) {
 1507       int i = SCM_PORTNUM(port);
 1508       scm_port_table[i].line = 1L;
 1509       scm_port_table[i].col = 1;
 1510     }
 1511     else {
 1512       if (2 <= scm_verbose)
 1513     scm_warn("Setting file position for tracked port: ", "", port);
 1514       SCM_PORTFLAGS(port) &= (~TRACKED);
 1515     }
 1516   }
 1517 #endif
 1518   {
 1519     int ans;
 1520     CLRDY(port);        /* Clear ungetted char */
 1521     SYSCALL(ans = fseek(STREAM(port), INUM(pos), 0););
 1522 #ifdef HAVE_PIPE
 1523 # ifdef ESPIPE
 1524     if (!OPIOPORTP(port))
 1525       ASRTER(ESPIPE != errno, port, ARG1, s_file_position);
 1526 # endif
 1527 #endif
 1528     return ans ? BOOL_F : BOOL_T;
 1529   }
 1530 }
 1531 
 1532 static char s_port_filename[] = "port-filename";
 1533 SCM scm_port_filename(port)
 1534      SCM port;
 1535 {
 1536   SCM x;
 1537   ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_filename);
 1538   x = SCM_PORTDATA(port);
 1539   if (NIMP(x) && STRINGP(x))
 1540     return SCM_PORTDATA(port);
 1541   return BOOL_F;
 1542 }
 1543 
 1544 SCM prog_args()
 1545 {
 1546   return progargs;
 1547 }
 1548 
 1549 extern char s_heap[];
 1550 void growth_mon(obj, size, units, grewp)
 1551      char *obj;
 1552      long size;
 1553      char *units;
 1554      int grewp;
 1555 {
 1556   if (scm_verbose > 2)
 1557     {
 1558       lputs((grewp ? "; grew " : "; shrank "), sys_errp);
 1559       lputs(obj, sys_errp);
 1560       lputs(" to ", sys_errp);
 1561       scm_intprint(size, -10, sys_errp);
 1562       lputc(' ', sys_errp);
 1563       lputs(units, sys_errp);
 1564       if ((scm_verbose > 4) && (obj==s_heap)) heap_report();
 1565       lputs("\n; ", sys_errp);
 1566     }
 1567 }
 1568 
 1569 void gc_start(what)
 1570      const char *what;
 1571 {
 1572   if (scm_verbose > 4) {
 1573     lputs(";GC(", sys_errp);
 1574     lputs(what, sys_errp);
 1575     lputs(") ", sys_errp);
 1576   }
 1577   scm_gcs++;
 1578   gc_rt = INUM(my_time());
 1579   gc_cells_collected = 0;
 1580   gc_malloc_collected = 0;
 1581   gc_ports_collected = 0;
 1582   gc_syms_collected = 0;
 1583 }
 1584 void gc_end()
 1585 {
 1586   gc_rt = INUM(my_time()) - gc_rt;
 1587   gc_time_taken = gc_time_taken + gc_rt;
 1588   if (scm_verbose > 4) {
 1589     scm_intprint(time_in_msec(gc_rt), -10, sys_errp);
 1590     lputs(".ms cpu, ", sys_errp);
 1591     scm_intprint(gc_cells_collected, -10, sys_errp);
 1592     lputs(" cells, ", sys_errp);
 1593     scm_intprint(gc_malloc_collected, -10, sys_errp);
 1594     lputs(" malloc, ", sys_errp);
 1595     scm_intprint(gc_syms_collected, -10, sys_errp);
 1596     lputs(" syms, ", sys_errp);
 1597     scm_intprint(gc_ports_collected, -10, sys_errp);
 1598     lputs(" ports collected\n", sys_errp);
 1599   }
 1600 }
 1601 void scm_egc_start()
 1602 {
 1603   scm_egc_rt = INUM(my_time());
 1604   scm_egcs++;
 1605 }
 1606 void scm_egc_end()
 1607 {
 1608   scm_egc_rt = INUM(my_time()) - scm_egc_rt;
 1609   gc_time_taken = gc_time_taken + scm_egc_rt;
 1610 }
 1611 void repl_report()
 1612 {
 1613   if (scm_verbose > 2) {
 1614     lfflush(cur_outp);
 1615     lputs(";Evaluation took ", cur_errp);
 1616     scm_intprint(time_in_msec(INUM(my_time())-rt), -10, cur_errp);
 1617     lputs(".ms (", cur_errp);
 1618     scm_intprint(time_in_msec(gc_time_taken), -10, cur_errp);
 1619     lputs(".ms in gc) ", cur_errp);
 1620     scm_intprint(cells_allocated - lcells_allocated, -10, cur_errp);
 1621     lputs(" cells work, ", cur_errp);
 1622     scm_env_work += scm_ecache_len - scm_ecache_index;
 1623     scm_intprint(scm_env_work, -10, cur_errp);
 1624     lputs(" env, ", cur_errp);
 1625     scm_intprint(mallocated - lmallocated, -10, cur_errp);
 1626     lputs(".B other\n", cur_errp);
 1627     if (scm_verbose > 3) {
 1628       lputc(';', cur_errp);
 1629       scm_intprint(scm_gcs, -10, cur_errp);
 1630       lputs( " gc, ", cur_errp);
 1631       scm_intprint(scm_egcs, -10, cur_errp);
 1632       lputs( " ecache gc, ", cur_errp);
 1633       scm_intprint(scm_clo_moved, -10, cur_errp);
 1634       lputs(" env migrated from closures, ", cur_errp);
 1635       scm_intprint(scm_stk_moved, -10, cur_errp);
 1636       lputs(" from stack\n", cur_errp);
 1637     }
 1638     lfflush(cur_errp);
 1639   }
 1640 }
 1641 #ifndef LACK_SBRK
 1642 unsigned long scm_init_brk = 0, scm_dumped_brk = 0;
 1643 void init_sbrk()
 1644 {
 1645   if (dumped)
 1646     scm_dumped_brk = (unsigned long)sbrk(0);
 1647   else
 1648     scm_init_brk = (unsigned long)sbrk(0);
 1649 }
 1650 void scm_brk_report()
 1651 {
 1652   unsigned long scm_curbrk = (unsigned long)sbrk(0),
 1653     dif1 = ((dumped ? scm_dumped_brk : scm_curbrk) - scm_init_brk)/1024,
 1654     dif2 = (scm_curbrk - scm_dumped_brk)/1024;
 1655 
 1656   lputs("initial brk = 0x", cur_errp);
 1657   scm_intprint(scm_init_brk, -16, cur_errp);
 1658   if (dumped) {
 1659     lputs(", dumped = 0x", cur_errp);
 1660     scm_intprint(scm_dumped_brk, -16, cur_errp);
 1661   }
 1662   lputs(", current = 0x", cur_errp);
 1663   scm_intprint(scm_curbrk, -16, cur_errp);
 1664   lputs("; ", cur_errp);
 1665   scm_intprint(dif1, 10, cur_errp);
 1666   if (dumped) {
 1667     lputs(dif2 < 0 ? " - " : " + ", cur_errp);
 1668     scm_intprint(dif2 < 0 ? -dif2 : dif2, 10, cur_errp);
 1669   }
 1670   lputs(".kiB\n", cur_errp);
 1671 }
 1672 #endif
 1673 SCM lroom(opt)
 1674      SCM opt;
 1675 {
 1676   scm_intprint(cells_allocated, -10, cur_errp);
 1677   lputs(" out of ", cur_errp);
 1678   scm_intprint(heap_cells, -10, cur_errp);
 1679   lputs(" cells in use, ", cur_errp);
 1680   scm_intprint(mallocated, -10, cur_errp);
 1681   lputs(".B allocated (of ", cur_errp);
 1682   scm_intprint(mtrigger, 10, cur_errp);
 1683   lputs(")\n", cur_errp);
 1684   if (!UNBNDP(opt)) {
 1685 #ifndef LACK_SBRK
 1686     if (scm_init_brk) scm_brk_report();
 1687 #endif
 1688     scm_ecache_report();
 1689     heap_report(); lputc('\n', cur_errp);
 1690     gra_report();
 1691     stack_report();
 1692   }
 1693   return UNSPECIFIED;
 1694 }
 1695 void scm_ecache_report()
 1696 {
 1697   scm_intprint(scm_estk_size, 10 , cur_errp);
 1698   lputs(" env stack items, ", cur_errp);
 1699   scm_intprint(scm_ecache_len - scm_ecache_index, 10, cur_errp);
 1700   lputs(" out of ", cur_errp);
 1701   scm_intprint(scm_ecache_len, 10, cur_errp);
 1702   lputs(" env cells in use.\n", cur_errp);
 1703 }
 1704 void exit_report()
 1705 {
 1706   if (scm_verbose > 2) {
 1707     lputs(";Totals: ", cur_errp);
 1708     scm_intprint(time_in_msec(INUM(my_time())), -10, cur_errp);
 1709     lputs(".ms my time, ", cur_errp);
 1710     scm_intprint(time_in_msec(INUM(your_time())), -10, cur_errp);
 1711     lputs(".ms your time\n", cur_errp);
 1712   }
 1713 }
 1714 
 1715 SCM prolixity(arg)
 1716      SCM arg;
 1717 {
 1718   int old = scm_verbose;
 1719   if (!UNBNDP(arg)) {
 1720     if (FALSEP(arg)) scm_verbose = 1;
 1721     else scm_verbose = INUM(arg);
 1722   }
 1723   return MAKINUM(old);
 1724 }
 1725 
 1726 static SCM i_repl;
 1727 SCM repl()
 1728 {
 1729   SCM x;
 1730   SCM env = EOL; /* scm_env_addprop(SCM_ENV_FILENAME, i_repl, EOL); */
 1731   int c;
 1732   if (OPINPORTP(cur_inp) && OPOUTPORTP(cur_outp)) {
 1733     repl_report();
 1734     while(1) {
 1735       if (OPOUTPORTP(cur_inp)) { /* This case for curses window */
 1736     lfflush(cur_outp);
 1737     if (scm_verbose) lputs(PROMPT, cur_inp);
 1738     lfflush(cur_inp);
 1739       }
 1740       else {
 1741     if (scm_verbose) lputs(PROMPT, cur_outp);
 1742     lfflush(cur_outp);
 1743       }
 1744       lcells_allocated = cells_allocated;
 1745       scm_env_work = scm_ecache_index - scm_ecache_len;
 1746       scm_egcs = scm_clo_moved = scm_stk_moved = 0;
 1747       lmallocated = mallocated;
 1748       x = scm_read_for_load(cur_inp);
 1749       rt = INUM(my_time());
 1750       scm_gcs = 0;
 1751       gc_time_taken = 0;
 1752       if (EOF_VAL==x) return MAKINUM(EXIT_SUCCESS);
 1753       if (!CRDYP(cur_inp)) {    /* assure newline read (and transcripted) */
 1754     if (EOF==(c = lgetc(cur_inp))) break;
 1755     lungetc(c, cur_inp);
 1756       }
 1757 #ifdef __HIGHC__
 1758 # define __MSDOS__
 1759 #endif
 1760 #ifdef __MSDOS__
 1761       if ('\n' != CGETUN(cur_inp))
 1762     if (OPOUTPORTP(cur_inp)) /* This case for curses window */
 1763       {lfflush(cur_outp); scm_newline(cur_inp);}
 1764     else scm_newline(cur_outp);
 1765 #endif
 1766       if (NIMP(x)) {
 1767     x = CONSP(x) ?
 1768       scm_eval_values(x, env, (SCM)EOL) :
 1769       cons(EVAL(x, env, (SCM)EOL), EOL);
 1770       }
 1771       else
 1772     x = cons(x, EOL);
 1773       repl_report();
 1774       if (IMP(x))
 1775     {if (scm_verbose > 2) lputs(";;no values\n", cur_outp);}
 1776       else if (IMP(CDR(x))) {
 1777     scm_iprin1(CAR(x), cur_outp, 1);
 1778     lputc('\n', cur_outp);
 1779       }
 1780       else
 1781     while (NIMP(x)) {
 1782       lputc(' ', cur_outp);
 1783       scm_iprin1(CAR(x), cur_outp, 1);
 1784       lputc('\n', cur_outp);
 1785       x = CDR(x);
 1786     }
 1787     }
 1788   }
 1789   return UNSPECIFIED;
 1790 }
 1791 SCM quit(n)
 1792      SCM n;
 1793 {
 1794   if (UNBNDP(n) || BOOL_T==n) n = MAKINUM(EXIT_SUCCESS);
 1795   if (INUMP(n)) exitval = n;
 1796   else exitval = MAKINUM(EXIT_FAILURE);
 1797   if (errjmp_bad) exit(INUM(exitval));
 1798   longjump(CONT(rootcont)->jmpbuf, COOKIE(-1));
 1799 }
 1800 SCM abrt()
 1801 {
 1802   if (errjmp_bad) exit(EXIT_FAILURE);
 1803   longjump(CONT(rootcont)->jmpbuf, COOKIE(-2));
 1804 }
 1805 char s_restart[] = "restart";
 1806 SCM restart()
 1807 {
 1808   /* ASRTER(!dumped, UNDEFINED, "dumped can't", s_restart); */
 1809   longjump(CONT(rootcont)->jmpbuf, COOKIE(-3));
 1810 }
 1811 
 1812 #ifdef CAN_DUMP
 1813 char s_unexec[] = "unexec";
 1814 SCM scm_unexec(newpath)
 1815      SCM newpath;
 1816 {
 1817   ASRTER(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec);
 1818   ASRTER(execpath, UNSPECIFIED, s_no_execpath, s_unexec);
 1819   *loc_errobj = newpath;
 1820   longjump(CONT(rootcont)->jmpbuf, COOKIE(-4));
 1821 }
 1822 #endif
 1823 
 1824 #ifdef CAREFUL_INTS
 1825 ints_infot *ints_info = 0;
 1826 static void ints_viol_iprin(num)
 1827      int num;
 1828 {
 1829   char num_buf[INTBUFLEN];
 1830   sizet i = ilong2str(num+0L, 10, num_buf);
 1831   num_buf[i] = 0;
 1832   fputs(num_buf, stderr);
 1833 }
 1834 void ints_viol(info, sense)
 1835      ints_infot *info;
 1836      int sense;
 1837 {
 1838   fputs(info->fname, stderr);
 1839   fputc(':', stderr);
 1840   ints_viol_iprin(info->linum);
 1841   fputs(": ints already ", stderr);
 1842   fputs(sense ? "dis" : "en", stderr);
 1843   fputs("abled (", stderr);
 1844   ints_viol_iprin(ints_disabled);
 1845   fputs(")\n", stderr);
 1846   if (ints_info) {
 1847     fputs(ints_info->fname, stderr);
 1848     fputc(':', stderr);
 1849     ints_viol_iprin(ints_info->linum);
 1850     fputs(": last change\n", stderr);
 1851   }
 1852   ints_info = info;
 1853 }
 1854 void ints_warn(str1, str2, fname, linum)
 1855      char *str1, *str2, *fname;
 1856      int linum;
 1857 {
 1858   fputs(fname, stderr);
 1859   fputc(':', stderr);
 1860   ints_viol_iprin(linum);
 1861   fputs(": unprotected call to ", stderr);
 1862   fputs(str1, stderr);
 1863   if (str2) {
 1864     fputs(" (", stderr);
 1865     fputs(str2, stderr);
 1866     fputc(')', stderr);
 1867   }
 1868   fputc('\n', stderr);
 1869 }
 1870 #endif
 1871 
 1872 SCM tryload(filename, reader)
 1873      SCM filename, reader;
 1874 {
 1875   ASRTER(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load);
 1876   if (FALSEP(reader)) reader = UNDEFINED;
 1877 #ifndef RECKLESS
 1878   if (!UNBNDP(reader)) scm_arity_check(reader, 1L, s_load);
 1879 #endif
 1880   {
 1881     SCM oloadpath = *loc_loadpath;
 1882     SCM oloadports = loadports;
 1883     SCM form, port;
 1884     SCM env = EOL;
 1885     port = open_file(filename, makfromstr("r?", (sizet)2*sizeof(char)));
 1886     if (FALSEP(port)) return port;
 1887     *loc_loadpath = filename;
 1888     loadports = cons(port, loadports);
 1889 #ifdef SCM_ENV_FILENAME
 1890     env = scm_env_addprop(SCM_ENV_FILENAME, filename, env);
 1891 #endif
 1892     while(1) {
 1893       if (UNBNDP(reader))
 1894     form = scm_read_for_load(port);
 1895       else
 1896     form = scm_cvapply(reader, 1L, &port);
 1897       if (EOF_VAL==form) break;
 1898       SIDEVAL(form, env, EOL);
 1899     }
 1900     close_port(port);
 1901     loadports = oloadports;
 1902     *loc_loadpath = oloadpath;
 1903   }
 1904   return BOOL_T;
 1905 }
 1906 static char s_eval_string[] = "eval-string";
 1907 static char s_load_string[] = "load-string";
 1908 static SCM i_eval_string = 0;
 1909 SCM scm_eval_string(str)
 1910      SCM str;
 1911 {
 1912   SCM env = EOL;
 1913 #ifdef SCM_ENV_FILENAME
 1914   if (i_eval_string)
 1915     env = scm_env_addprop(SCM_ENV_FILENAME, i_eval_string, env);
 1916 #endif
 1917   str = mkstrport(INUM0, str, OPN | RDNG, s_eval_string);
 1918   str = scm_read(str);
 1919   return EVAL(str, env, EOL);
 1920 }
 1921 static SCM i_load_string = 0;
 1922 SCM scm_load_string(str)
 1923      SCM str;
 1924 {
 1925   SCM env = EOL;
 1926 #ifdef SCM_ENV_FILENAME
 1927   if (i_load_string)
 1928     env = scm_env_addprop(SCM_ENV_FILENAME, i_load_string, env);
 1929 #endif
 1930   ASRTER(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1,
 1931      s_load_string);
 1932   str = mkstrport(INUM0, str, OPN | RDNG, s_load_string);
 1933   while(1) {
 1934     SCM form = scm_read_for_load(str);
 1935     if (EOF_VAL==form) break;
 1936     SIDEVAL(form, env, EOL);
 1937   }
 1938   return BOOL_T;
 1939 }
 1940 
 1941 void scm_line_msg(file, linum, port)
 1942     SCM file, linum, port;
 1943 {
 1944   scm_iprin1(file, port, 1);
 1945   if (SCM_LINUMP(linum)) {
 1946     lputs(", line ", port);
 1947     scm_intprint(SCM_LINUM(linum), -10, port);
 1948   }
 1949   lputs(": ", port);
 1950 }
 1951 void scm_err_line(what, file, linum, port)
 1952      const char *what;
 1953      SCM file, linum, port;
 1954 {
 1955   lputs(what, port);
 1956   if (NIMP(file) && STRINGP(file))
 1957     scm_line_msg(file, linum, port);
 1958 #ifdef CAUTIOUS
 1959   else {
 1960     SCM env = scm_env_getprop(SCM_ENV_FILENAME, scm_trace_env);
 1961     if (NIMP(env)) {
 1962       file = CAR(env);
 1963       scm_check_linum(scm_trace, &linum);
 1964       scm_line_msg(file, linum, port);
 1965     }
 1966   }
 1967 #endif
 1968 }
 1969 
 1970 static void err_head(str)
 1971      char *str;
 1972 {
 1973   SCM lps;
 1974   int oerrno = errno;
 1975   exitval = MAKINUM(EXIT_FAILURE);
 1976   if (NIMP(cur_outp) && OPOUTPORTP(cur_outp)) lfflush(cur_outp);
 1977   lps = IMP(loadports) ? loadports : CDR(loadports);
 1978   if (NIMP(lps)) {
 1979     lputs("\n;In file loaded from ", cur_errp);
 1980     for (; NIMP(lps); lps = CDR(lps)) {
 1981       scm_iprin1(scm_port_filename(CAR(lps)), cur_errp, 0);
 1982       lputs(":", cur_errp);
 1983       scm_iprin1(scm_port_line(CAR(lps)), cur_errp, 1);
 1984       lputs(IMP(CDR(lps)) ? ":" : ",\n;       loaded from ", cur_errp);
 1985     }
 1986   }
 1987   lputs("\n;", cur_errp);
 1988   lfflush(cur_errp);
 1989   errno = oerrno;
 1990   /* if (NIMP(cur_errp) && stderr==STREAM(cur_errp)) { ... } */
 1991   if (errno>0) perror(str);
 1992   fflush(stderr);
 1993 }
 1994 void scm_warn(str1, str2, obj)
 1995      char *str1, *str2;
 1996      SCM obj;
 1997 {
 1998   err_head("WARNING");
 1999   scm_err_line("WARNING: ", UNDEFINED, UNDEFINED, cur_errp);
 2000   lputs(str1, cur_errp);
 2001   if (str2 && *str2) {
 2002     lputs(str2, cur_errp);
 2003     lputc('\n', cur_errp);
 2004   }
 2005   if (!UNBNDP(obj)) {
 2006     scm_iprin1(obj, cur_errp, 1);
 2007     lputc('\n', cur_errp);
 2008   }
 2009   lfflush(cur_errp);
 2010 }
 2011 
 2012 SCM lerrno(arg)
 2013      SCM arg;
 2014 {
 2015   int old = errno;
 2016   if (!UNBNDP(arg)) {
 2017     if (FALSEP(arg)) errno = 0;
 2018     else errno = INUM(arg);
 2019   }
 2020   return MAKINUM(old);
 2021 }
 2022 static char s_perror[] = "perror";
 2023 SCM lperror(arg)
 2024      SCM arg;
 2025 {
 2026   ASRTER(NIMP(arg) && STRINGP(arg), arg, ARG1, s_perror);
 2027   err_head(CHARS(arg));
 2028   return UNSPECIFIED;
 2029 }
 2030 static void def_err_response()
 2031 {
 2032   SCM file, env = err_env, obj = *loc_errobj;
 2033   SCM linum = UNDEFINED;
 2034   int badport = IMP(cur_errp) || !OPOUTPORTP(cur_errp);
 2035   int writing = 2; /* Value of 2 used only for printing error messages */
 2036   int codep = errobj_codep;
 2037   DEFER_INTS;
 2038   if (badport || (errjmp_recursive++)) {
 2039     if (IMP(def_errp) || !OPOUTPORTP(def_errp)) exit(EXIT_FAILURE);
 2040     lputs("RECURSIVE ERROR: ", def_errp);
 2041     if (badport || TYP16(cur_errp)==tc16_sfport) {
 2042       lputs("reverting from ", def_errp);
 2043       scm_iprin1(cur_errp, def_errp, 2);
 2044       lputs("to default error port\n", def_errp);
 2045       cur_errp = def_errp;
 2046       errjmp_recursive = 0;
 2047     }
 2048     else exit(EXIT_FAILURE);
 2049   }
 2050 #ifdef SCM_ENV_FILENAME
 2051   file = scm_env_getprop(SCM_ENV_FILENAME, env);
 2052   if (NIMP(file)) file = CAR(file);
 2053   else file = UNDEFINED;
 2054 #else
 2055   file = BOOL_F;
 2056 #endif
 2057   if (codep) obj = scm_check_linum(obj, &linum);
 2058   err_exp = scm_check_linum(err_exp, UNBNDP(linum) ? &linum : 0L);
 2059   err_head("ERROR");
 2060   scm_err_line("ERROR: ", file, linum, cur_errp);
 2061   if (err_s_subr && *err_s_subr) {
 2062     lputs(err_s_subr, cur_errp);
 2063     lputs(": ", cur_errp);
 2064   }
 2065   if (!err_pos) return;     /* Already been printed */
 2066   if (err_pos==(char *)ARG1 && UNBNDP(obj)) err_pos = (char *)WNA;
 2067 #ifdef nosve
 2068   if ((~0x1fL) & (short)err_pos) lputs(err_pos, cur_errp);
 2069   else if (WNA > (short)err_pos) {
 2070     lputs("Wrong type in arg", cur_errp);
 2071     lputc((short)err_pos <= ARGn ? ' ' : '1' + (short)err_pos - ARG1, cur_errp);
 2072   }
 2073 #else
 2074   if ((~0x1fL) & (long)err_pos) lputs(err_pos, cur_errp);
 2075   else if (WNA > (long)err_pos) {
 2076     lputs("Wrong type in arg", cur_errp);
 2077     lputc((long)err_pos <= ARGn ? ' ' : '1' + (int)err_pos - ARG1, cur_errp);
 2078   }
 2079 #endif
 2080   else lputs(errmsgs[((int)err_pos)-WNA].msg, cur_errp);
 2081   lputs(((long)err_pos==WNA)?" given ":" ", cur_errp);
 2082   err_pos = 0;
 2083   if (!UNBNDP(obj))
 2084     if (reset_safeport(sys_safep, 55, cur_errp))
 2085       if (0==setjmp(SAFEP_JMPBUF(sys_safep))) {
 2086     if (codep) scm_princode(obj, EOL, sys_safep, writing);
 2087     else scm_iprin1(obj, sys_safep, writing);
 2088       }
 2089   if (UNBNDP(err_exp)) goto getout;
 2090   if (NIMP(err_exp)) {
 2091     if (reset_safeport(sys_safep, 55, cur_errp))
 2092       if (0==setjmp(SAFEP_JMPBUF(sys_safep))) {
 2093     lputs("\n; in expression: ", cur_errp);
 2094     if (NCONSP(err_exp)) scm_princode(err_exp, env, sys_safep, writing);
 2095     else if (UNDEFINED==CDR(err_exp))
 2096       scm_iprin1(CAR(err_exp), sys_safep, writing);
 2097     else {
 2098       if (UNBNDP(env)) scm_iprlist("(... ", err_exp, ')', sys_safep, writing);
 2099       else scm_princode(err_exp, env, sys_safep, writing);
 2100     }
 2101       }
 2102   }
 2103   scm_scope_trace(env);
 2104  getout:
 2105 #ifdef CAUTIOUS
 2106   scm_stack_trace(UNDEFINED);
 2107 #endif
 2108   lputc('\n', cur_errp);
 2109   lfflush(cur_errp);
 2110   err_exp = err_env = UNDEFINED;
 2111   if (errjmp_bad) {
 2112     lputs("\nFATAL ERROR DURING CRITICAL CODE SECTION: ", cur_errp);
 2113     lputs(errjmp_bad, cur_errp);
 2114     lputc('\n', cur_errp);
 2115     lroom(BOOL_T);
 2116 #ifdef vms
 2117     exit(EXIT_FAILURE);
 2118 #else
 2119     exit(errno? (long)errno : EXIT_FAILURE);
 2120 #endif
 2121   }
 2122   errno = 0;
 2123   ALLOW_INTS;
 2124 }
 2125 void everr(exp, env, arg, pos, s_subr, codep)
 2126      SCM exp, env, arg;
 2127      const char *pos, *s_subr;
 2128      int codep;
 2129 {
 2130   err_exp = exp;
 2131   err_env = env;
 2132   *loc_errobj = arg;
 2133   err_pos = pos;
 2134   err_s_subr = s_subr;
 2135   errobj_codep = codep;
 2136   if (errjmp_bad || errjmp_recursive) def_err_response();
 2137   longjump(CONT(rootcont)->jmpbuf,
 2138        (~0x1fL) & (long)pos || (WNA > (long)pos) ?
 2139        COOKIE(1) : COOKIE((int)pos));
 2140   /* will do error processing at stack base */
 2141 }
 2142 void wta(arg, pos, s_subr)
 2143      SCM arg;
 2144      const char *pos, *s_subr;
 2145 {
 2146 #ifndef RECKLESS
 2147   everr(scm_trace, scm_trace_env, arg, pos, s_subr, 0);
 2148 #else
 2149   everr(UNDEFINED, EOL, arg, pos, s_subr, 0);
 2150 #endif
 2151 }
 2152 void scm_experr(arg, pos, s_subr)
 2153      SCM arg;
 2154      const char *pos, *s_subr;
 2155 {
 2156 #ifndef RECKLESS
 2157   everr(scm_trace, scm_trace_env, arg, pos, s_subr, !0);
 2158 #else
 2159   everr(UNDEFINED, EOL, arg, pos, s_subr, !0);
 2160 #endif
 2161 }
 2162 SCM cur_input_port()
 2163 {
 2164   return cur_inp;
 2165 }
 2166 SCM cur_output_port()
 2167 {
 2168   return cur_outp;
 2169 }
 2170 SCM cur_error_port()
 2171 {
 2172   return cur_errp;
 2173 }
 2174 char s_cur_inp[] = "set-current-input-port";
 2175 char s_cur_outp[] = "set-current-output-port";
 2176 char s_cur_errp[] = "set-current-error-port";
 2177 SCM set_inp(port)
 2178      SCM port;
 2179 {
 2180   SCM oinp;
 2181   ASRTER(NIMP(port) && INPORTP(port), port, ARG1, s_cur_inp);
 2182   DEFER_INTS;
 2183   oinp = cur_inp;
 2184   cur_inp = port;
 2185   ALLOW_INTS;
 2186   return oinp;
 2187 }
 2188 SCM set_outp(port)
 2189      SCM port;
 2190 {
 2191   SCM ooutp;
 2192   ASRTER(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_outp);
 2193   DEFER_INTS;
 2194   ooutp = cur_outp;
 2195   cur_outp = port;
 2196   ALLOW_INTS;
 2197   return ooutp;
 2198 }
 2199 SCM set_errp(port)
 2200      SCM port;
 2201 {
 2202   SCM oerrp;
 2203   ASRTER(NIMP(port) && OUTPORTP(port), port, ARG1, s_cur_errp);
 2204   DEFER_INTS;
 2205   oerrp = cur_errp;
 2206   cur_errp = port;
 2207   ALLOW_INTS;
 2208   return oerrp;
 2209 }
 2210 static char s_isatty[] = "isatty?";
 2211 SCM l_isatty(port)
 2212      SCM port;
 2213 {
 2214   int fn;
 2215   ASRTER(NIMP(port) && OPPORTP(port), port, ARG1, s_isatty);
 2216   if (tc16_fport != TYP16(port)) return BOOL_F;
 2217   fn = fileno(STREAM(port));
 2218   return (fn >= 0 && isatty(fn)) ? BOOL_T : BOOL_F;
 2219 }
 2220 
 2221 static iproc subr0s[] = {
 2222     {&s_cur_inp[4], cur_input_port},
 2223     {&s_cur_outp[4], cur_output_port},
 2224     {&s_cur_errp[4], cur_error_port},
 2225     {"program-arguments", prog_args},
 2226     {"line-number", line_num},
 2227     {"abort", abrt},
 2228     {s_restart, restart},
 2229     {0, 0}};
 2230 
 2231 static iproc subr1s[] = {
 2232     {s_cur_inp, set_inp},
 2233     {s_cur_outp, set_outp},
 2234     {s_cur_errp, set_errp},
 2235     {s_load_string, scm_load_string},
 2236     {s_eval_string, scm_eval_string},
 2237     {s_perror, lperror},
 2238     {"make-arbiter", makarb},
 2239     {s_tryarb, tryarb},
 2240     {s_relarb, relarb},
 2241     {s_isatty, l_isatty},
 2242     {s_port_line, scm_port_line},
 2243     {s_port_col, scm_port_col},
 2244     {s_port_filename, scm_port_filename},
 2245     {0, 0}};
 2246 
 2247 static iproc subr1os[] = {
 2248     {s_read_char, scm_read_char},
 2249     {s_peek_char, scm_peek_char},
 2250     {s_newline, scm_newline},
 2251     {s_freshline, scm_freshline},
 2252     {s_force_output, scm_force_output},
 2253     {s_char_readyp, char_readyp},
 2254     {"quit", quit},
 2255     {"verbose", prolixity},
 2256     {"errno", lerrno},
 2257     {"room", lroom},
 2258     {0, 0}};
 2259 
 2260 static iproc subr2os[] = {
 2261     {s_write, scm_write},
 2262     {s_display, scm_display},
 2263     {s_write_char, scm_write_char},
 2264     {s_tryload, tryload},
 2265     {s_file_position, scm_file_position},
 2266 #ifdef CAN_DUMP
 2267     {s_unexec, scm_unexec},
 2268 #endif
 2269     {0, 0}};
 2270 
 2271 static smobfuns arbsmob = {markcdr, free0, prinarb};
 2272 char s_ccl[] = "char-code-limit";
 2273 
 2274 void init_repl( iverbose )
 2275      int iverbose;
 2276 {
 2277     sysintern(s_ccl, MAKINUM(CHAR_CODE_LIMIT));
 2278     i_repl = CAR(sysintern("repl", UNDEFINED));
 2279     loc_errobj = &CDR(sysintern("errobj", UNDEFINED));
 2280     loc_loadpath = &CDR(sysintern("*load-pathname*", BOOL_F));
 2281     loc_loadsharp = &CDR(sysintern("load:sharp", UNDEFINED));
 2282     loc_readsharp = &CDR(sysintern("read:sharp", UNDEFINED));
 2283     loc_charsharp = &CDR(sysintern("char:sharp", UNDEFINED));
 2284     loc_broken_pipe = &CDR(sysintern("broken-pipe", UNDEFINED));
 2285     scm_verbose = iverbose;
 2286     init_iprocs(subr0s, tc7_subr_0);
 2287     init_iprocs(subr1os, tc7_subr_1o);
 2288     init_iprocs(subr1s, tc7_subr_1);
 2289     init_iprocs(subr2os, tc7_subr_2o);
 2290     add_feature(s_char_readyp);
 2291     make_subr(s_swapcar, tc7_subr_2, swapcar);
 2292     make_subr(s_wfi, tc7_lsubr, wait_for_input);
 2293 #ifndef MEMOIZE_LOCALS
 2294     p_read_numbered =
 2295       make_subr(s_read_numbered, tc7_subr_1, scm_read_numbered);
 2296 #endif
 2297     p_read_for_load =
 2298       make_subr(s_read_for_load, tc7_subr_1, scm_read_for_load);
 2299     p_read =
 2300       make_subr(s_read, tc7_subr_1o, scm_read);
 2301     i_eval_string = CAR(sysintern(s_eval_string, UNDEFINED));
 2302     i_load_string = CAR(sysintern(s_load_string, UNDEFINED));
 2303     scm_ldstr("\n\
 2304 (define file-set-position file-position)\n\
 2305 ");
 2306 #ifdef CAN_DUMP
 2307     add_feature("dump");
 2308     scm_ldstr("\
 2309 (define (dump file . thunk)\n\
 2310   (cond ((null? thunk) (set! *interactive* #f) (set! *argv* #f))\n\
 2311     ((not (car thunk)) (set! *argv* #f))\n\
 2312     ((boolean? (car thunk)))\n\
 2313     (else (set! boot-tail (lambda (t) ((car thunk))))))\n\
 2314   (set! restart exec-self)\n\
 2315   (require #f)\n\
 2316   (unexec file))\n\
 2317 ");
 2318 #endif
 2319 #ifdef ARM_ULIB
 2320     set_erase();
 2321 #endif
 2322     tc16_arbiter = newsmob(&arbsmob);
 2323 }
 2324 void final_repl()
 2325 {
 2326   i_eval_string = i_load_string = 0;
 2327   loc_errobj = (SCM *)&tmp_errobj;
 2328   loc_loadpath = (SCM *)&tmp_loadpath;
 2329   loadports = EOL;
 2330 }