"Fossies" - the Fresh Open Source Software Archive

Member "scm/sys.c" (22 Oct 2017, 80987 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 "sys.c" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 5f2_vs_5f3.

    1 /* "sys.c" opening and closing files, storage, and GC.
    2  * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002, 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 #include <ctype.h>
   20 
   21 #include "scm.h"
   22 #include "setjump.h"
   23 
   24 #ifdef POCKETCONSOLE
   25 # include <io.h>
   26 #endif
   27 
   28 void    igc P((const char *what, SCM basecont));
   29 SCM *loc_open_file;     /* for open-file callback */
   30 SCM *loc_try_create_file;
   31 
   32 /* ttyname() etc. should be defined in <unistd.h>.  But unistd.h is
   33    missing on many systems. */
   34 
   35 #ifndef STDC_HEADERS
   36     char *ttyname P((int fd));
   37     char *tmpnam P((char *s));
   38 # ifdef sun
   39 #  ifndef __SVR4
   40         int fputs P((char *s, FILE* stream));
   41         int fputc P((char c, FILE* stream));
   42         int fflush P((FILE* stream));
   43 #  endif
   44 # else
   45     sizet fwrite ();
   46 # endif
   47     int fgetc P((FILE* stream));
   48     int fclose P((FILE* stream));
   49     int pclose P((FILE* stream));
   50     int unlink P((const char *pathname));
   51     char *mktemp P((char *template));
   52 #else
   53 # ifdef linux
   54 #  include <unistd.h>
   55 # endif
   56 # ifdef __NetBSD__
   57 #  include <unistd.h>
   58 # endif
   59 # ifdef __OpenBSD__
   60 #  include <unistd.h>
   61 # endif
   62 #endif
   63 
   64 static void gc_sweep P((int contin_bad));
   65 
   66 char    s_nogrow[] = "could not grow", s_heap[] = "heap",
   67   s_hplims[] = "hplims", s_try_create_file[] = "try-create-file";
   68 
   69 static char s_segs[] = "segments", s_numheaps[] = "number of heaps";
   70 static char s_input_portp[] = "input-port?",
   71         s_output_portp[] = "output-port?";
   72 #define s_portp (&s_input_portp[6])
   73 static char s_port_closedp[] = "port-closed?";
   74 static char s_try_open_file[] = "try-open-file";
   75 #define s_open_file (&s_try_open_file[4])
   76 char    s_close_port[] = "close-port";
   77 
   78 #ifdef __IBMC__
   79 # include <io.h>
   80 # include <direct.h>
   81 # define ttyname(x) "CON:"
   82 #else
   83 # ifndef MSDOS
   84 #  ifndef ultrix
   85 #   ifndef vms
   86 #    ifdef _DCC
   87 #     include <ioctl.h>
   88 #     define setbuf(stream, buf) setvbuf(stream, buf, _IONBF, 0)
   89 #    else
   90 #     ifdef MWC
   91 #      include <sys/io.h>
   92 #     else
   93 #      ifndef macintosh
   94 #       ifndef ARM_ULIB
   95 #        ifndef PLAN9
   96 #         include <sys/ioctl.h>
   97 #        endif
   98 #       endif
   99 #      endif
  100 #     endif
  101 #    endif
  102 #   endif
  103 #  endif
  104 # endif
  105 #endif /* __IBMC__ */
  106 SCM i_setbuf0(port)     /* should be called with DEFER_INTS active */
  107      SCM port;
  108 {
  109   VERIFY_INTS("i_setbuf0", 0L);
  110 #ifndef NOSETBUF
  111 # ifndef MSDOS
  112 #  ifdef FIONREAD
  113 #   ifndef ultrix
  114   SYSCALL(setbuf(STREAM(port), 0L););
  115 #   endif
  116 #  endif
  117 # endif
  118 #endif
  119   return UNSPECIFIED;
  120 }
  121 
  122 /* The CRDY bit is overloaded to indicate that additional processing
  123    is needed when reading or writing, such as updating line and column
  124    numbers.  Returns 0 if cmodes is non-null and modes string is not
  125    valid. */
  126 /* If nonnull, the CMODES argument receives a copy of all chars in MODES
  127    which are allowed by ANSI C. */
  128 long mode_bits(modes, cmodes)
  129      char *modes, *cmodes;
  130 {
  131   int iout = 0;
  132   long bits = OPN;
  133   for (; *modes; modes++)
  134     switch (*modes) {
  135     case 'r': bits |= RDNG; goto outc;
  136     case 'w': case 'a': bits |= WRTNG; goto outc;
  137     case '+': bits |= (RDNG | WRTNG); goto outc;
  138     case 'b': bits |= BINARY; goto outc;
  139     case '0': bits |= BUF0; break;
  140     case '?': bits |= (TRACKED | CRDY); break;
  141     case 'x': bits |= EXCLUSIVE; break;
  142     outc: if (cmodes && (iout < 3)) cmodes[iout++] = *modes; break;
  143     }
  144   if (!cmodes) return bits;
  145   cmodes[iout] = 0;
  146   switch (cmodes[0]) {
  147   default: return 0;
  148   case 'r': case 'w': case 'a': return bits;
  149   }
  150 }
  151 
  152 SCM try_open_file(filename, modes)
  153      SCM filename, modes;
  154 {
  155   register SCM port;
  156   FILE *f;
  157   char cmodes[4];
  158   long flags;
  159   ASRTER(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file);
  160   ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_open_file);
  161   flags = mode_bits(CHARS(modes), cmodes);
  162   ASRTER(flags, modes, ARG2, s_open_file);
  163   if ((EXCLUSIVE & flags) && NIMP(*loc_try_create_file)) {
  164     port = apply(*loc_try_create_file, filename, cons(modes, listofnull));
  165     if (UNSPECIFIED != port) return port;
  166   }
  167   DEFER_INTS;
  168   SCM_OPENCALL((f = fopen(CHARS(filename), cmodes)));
  169   if (!f) {
  170     ALLOW_INTS;
  171     return BOOL_F;
  172   }
  173   port = scm_port_entry(f, tc16_fport, flags);
  174   if (BUF0 & flags) i_setbuf0(port);
  175   ALLOW_INTS;
  176   SCM_PORTDATA(port) = filename;
  177   return port;
  178 }
  179 
  180                 /* Callback to Scheme */
  181 SCM open_file(filename, modes)
  182      SCM filename, modes;
  183 {
  184   return apply(*loc_open_file,
  185            filename,
  186            cons(modes, listofnull));
  187 }
  188 
  189 long tc16_clport;
  190 SCM close_port(port)
  191      SCM port;
  192 {
  193     sizet i;
  194         SCM ret = UNSPECIFIED;
  195     ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_close_port);
  196     if (CLOSEDP(port)) return UNSPECIFIED;
  197     i = PTOBNUM(port);
  198     DEFER_INTS;
  199     if (ptobs[i].fclose) {
  200           int r;
  201       SYSCALL(r = (ptobs[i].fclose)(STREAM(port)););
  202           if (EOF == r)
  203             ret = BOOL_F;
  204           else
  205             ret = MAKINUM(r);
  206     }
  207     CAR(port) &= ~OPN;
  208     SCM_PORTFLAGS(port) &= ~OPN;
  209     /* Bash the old ptobnum with the closed port ptobnum.
  210        This allows catching some errors cheaply. */
  211     SCM_SET_PTOBNUM(port, tc16_clport);
  212     ALLOW_INTS;
  213     return ret;
  214 }
  215 SCM scm_portp(x)
  216      SCM x;
  217 {
  218     if (IMP(x)) return BOOL_F;
  219     return PORTP(x) ? BOOL_T : BOOL_F;
  220 }
  221 SCM input_portp(x)
  222      SCM x;
  223 {
  224     if (IMP(x)) return BOOL_F;
  225     return INPORTP(x) ? BOOL_T : BOOL_F;
  226 }
  227 SCM output_portp(x)
  228      SCM x;
  229 {
  230     if (IMP(x)) return BOOL_F;
  231     return OUTPORTP(x) ? BOOL_T : BOOL_F;
  232 }
  233 SCM port_closedp(port)
  234      SCM port;
  235 {
  236   ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_closedp);
  237   if (CLOSEDP(port)) return BOOL_T;
  238   return BOOL_F;
  239 }
  240 SCM scm_port_type(port)
  241      SCM port;
  242 {
  243   int i;
  244   if (NIMP(port) && PORTP(port)) {
  245     i = PTOBNUM(port);
  246     if (ptobs[i].name) return CAR(sysintern(ptobs[i].name, UNDEFINED));
  247     return BOOL_T;
  248   }
  249   return BOOL_F;
  250 }
  251 
  252 #if (__TURBOC__==1)
  253 # undef L_tmpnam        /* Not supported in TURBOC V1.0 */
  254 #endif
  255 #ifdef GO32
  256 # undef L_tmpnam        /* Would put files in %TMPDIR% = %DJDIR%/tmp */
  257 #endif
  258 #ifdef MWC
  259 # undef L_tmpnam
  260 #endif
  261 
  262 #ifdef L_tmpnam
  263 SCM ltmpnam()
  264 {
  265   char name[L_tmpnam];
  266   char* ret;
  267   SYSCALL(ret = tmpnam(name););
  268   if (! ret) return BOOL_F;
  269   return makfrom0str(name);
  270 }
  271 #else
  272 /* TEMPTEMPLATE is used only if mktemp() is being used instead of
  273    tmpnam(). */
  274 
  275 # ifdef AMIGA
  276 #  define TEMPTEMPLATE "T:SchemeaaaXXXXXX";
  277 # else
  278 #  ifdef vms
  279 #   define TEMPTEMPLATE "sys$scratch:aaaXXXXXX";
  280 #  else /* vms */
  281 #   ifdef __MSDOS__
  282 #    ifdef GO32
  283 #     define TEMPTEMPLATE "\\tmp\\TMPaaaXXXXXX";
  284 #    else
  285 #     define TEMPTEMPLATE "TMPaaaXXXXXX";
  286 #    endif
  287 #   else /* __MSDOS__ */
  288 #    define TEMPTEMPLATE "/tmp/aaaXXXXXX";
  289 #   endif /* __MSDOS__ */
  290 #  endif /* vms */
  291 # endif /* AMIGA */
  292 
  293 char template[] = TEMPTEMPLATE;
  294 # define TEMPLEN (sizeof template/sizeof(char) - 1)
  295 SCM ltmpnam()
  296 {
  297   SCM name;
  298   int temppos = TEMPLEN-9;
  299   name = makfromstr(template, (sizet)TEMPLEN);
  300   DEFER_INTS;
  301 inclp:
  302   template[temppos]++;
  303   if (!isalpha(template[temppos])) {
  304     template[temppos++] = 'a';
  305     goto inclp;
  306   }
  307 # ifndef AMIGA
  308 #  ifndef __MSDOS__
  309   SYSCALL(temppos = !*mktemp(CHARS(name)););
  310   if (temppos) name = BOOL_F;
  311 #  endif
  312 # endif
  313   ALLOW_INTS;
  314   return name;
  315 }
  316 #endif /* L_tmpnam */
  317 
  318 #ifdef M_SYSV
  319 # define remove unlink
  320 #endif
  321 static char s_del_fil[] = "delete-file";
  322 SCM del_fil(str)
  323      SCM str;
  324 {
  325   int ans;
  326   ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_del_fil);
  327 #ifdef STDC_HEADERS
  328   SYSCALL(ans = remove(CHARS(str)););
  329 #else
  330   SYSCALL(ans = unlink(CHARS(str)););
  331 #endif
  332   return ans ? BOOL_F : BOOL_T;
  333 }
  334 
  335 void prinport(exp, port, type)
  336      SCM exp; SCM port; char *type;
  337 {
  338   int filn = fileno(STREAM(exp));
  339   lputs("#<", port);
  340   if (CLOSEDP(exp)) lputs("closed-", port);
  341   else {
  342     if (RDNG & CAR(exp)) lputs("input-", port);
  343     if (WRTNG & CAR(exp)) lputs("output-", port);
  344   }
  345   lputs(type, port);
  346   lputc(' ', port);
  347 #ifndef MSDOS
  348 # ifndef __EMX__
  349 #  ifndef _DCC
  350 #   ifndef AMIGA
  351 #    ifndef macintosh
  352 #     ifndef PLAN9
  353   if (OPENP(exp) && tc16_fport==TYP16(exp) && filn >= 0 && isatty(filn)) {
  354     char *ttyn = ttyname(filn);
  355     if (ttyn) lputs(ttyn, port);
  356     else goto punt;
  357   }
  358   else
  359 #     endif
  360 #    endif
  361 #   endif
  362 #  endif
  363 # endif
  364 #endif
  365   punt:
  366     {
  367       SCM s = PORTP(exp) ? SCM_PORTDATA(exp) : UNDEFINED;
  368       if (NIMP(s) && STRINGP(s))
  369     scm_iprin1(s, port, 1);
  370       else if (OPFPORTP(exp))
  371     scm_intprint((long)filn, 10, port);
  372       else
  373     scm_intprint(CDR(exp), -16, port);
  374       if (TRACKED & SCM_PORTFLAGS(exp)) {
  375     lputs(" L", port);
  376     scm_intprint(scm_port_table[SCM_PORTNUM(exp)].line, 10, port);
  377     lputs(" C", port);
  378     scm_intprint(scm_port_table[SCM_PORTNUM(exp)].col+0L, 10, port);
  379       }
  380     }
  381   lputc('>', port);
  382 }
  383 
  384 static int stputc(c, p)
  385      int c; SCM p;
  386 {
  387   sizet ind = INUM(CAR(p));
  388   if (ind >= LENGTH(CDR(p))) resizuve(CDR(p), MAKINUM(ind + (ind>>1)));
  389   CHARS(CDR(p))[ind] = c;
  390   CAR(p) = MAKINUM(ind + 1);
  391   return c;
  392 }
  393 sizet stwrite(str, siz, num, p)
  394      sizet siz, num;
  395      char *str; SCM p;
  396 {
  397   sizet ind = INUM(CAR(p));
  398   sizet len = siz * num;
  399   char *dst;
  400   if (ind + len >= LENGTH(CDR(p)))
  401     resizuve(CDR(p), MAKINUM(ind + len + ((ind + len)>>1)));
  402   dst = &(CHARS(CDR(p))[ind]);
  403   while (len--) dst[len] = str[len];
  404   CAR(p) = MAKINUM(ind + siz*num);
  405   return num;
  406 }
  407 static int stputs(s, p)
  408      char *s; SCM p;
  409 {
  410   stwrite(s, 1, strlen(s), p);
  411   return 0;
  412 }
  413 static int stgetc(p)
  414      SCM p;
  415 {
  416   sizet ind = INUM(CAR(p));
  417   if (ind >= LENGTH(CDR(p))) return EOF;
  418   CAR(p) = MAKINUM(ind + 1);
  419   return UCHARS(CDR(p))[ind];
  420 }
  421 static int stclose(p)
  422      SCM p;
  423 {
  424   SETCDR(p, nullstr);
  425   return 0;
  426 }
  427 static int stungetc(c, p)
  428      int c;
  429      SCM p;
  430 {
  431   sizet ind;
  432   p = CDR(p);
  433   ind = INUM(CAR(p));
  434   if (ind == 0) return EOF;
  435   CAR(p) = MAKINUM(--ind);
  436   ASRTER(UCHARS(CDR(p))[ind] == c, MAKICHR(c), "stungetc", "");
  437   return c;
  438 }
  439 int noop0(stream)
  440      FILE *stream;
  441 {
  442   return 0;
  443 }
  444 SCM mkstrport(pos, str, modes, caller)
  445      SCM pos;
  446      SCM str;
  447      long modes;
  448      char *caller;
  449 {
  450   SCM z;
  451   ASRTER(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller);
  452   ASRTER(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller);
  453   str = cons(pos, str);
  454   NEWCELL(z);
  455   DEFER_INTS;
  456   SETCHARS(z, str);
  457   CAR(z) = (modes | tc16_strport); /* port table entry 0 is scratch. */
  458   /*  z = scm_port_entry((FILE *)str, tc16_strport, modes); */
  459   ALLOW_INTS;
  460   return z;
  461 }
  462 static char s_cwos[] = "call-with-output-string";
  463 static char s_cwis[] = "call-with-input-string";
  464 SCM cwos(proc)
  465      SCM proc;
  466 {
  467   SCM p = mkstrport(INUM0, make_string(MAKINUM(30), UNDEFINED),
  468             OPN | WRTNG,
  469             s_cwos);
  470   apply(proc, p, listofnull);
  471   return resizuve(CDR(CDR(p)), CAR(CDR(p)));
  472 }
  473 SCM cwis(str, proc)
  474      SCM str, proc;
  475 {
  476   SCM p = mkstrport(INUM0, str, OPN | RDNG, s_cwis);
  477   return apply(proc, p, listofnull);
  478 }
  479 #ifdef vms
  480 sizet pwrite(ptr, size, nitems, port)
  481      char *ptr;
  482      sizet size, nitems;
  483      FILE* port;
  484 {
  485   sizet len = size * nitems;
  486   sizet i = 0;
  487   for (;i < len;i++) putc(ptr[i], port);
  488   return len;
  489 }
  490 # define ffwrite pwrite
  491 #else
  492 # define ffwrite fwrite
  493 #endif
  494 
  495 static ptobfuns fptob = {
  496   s_port_type,
  497   mark0,
  498   fclose,
  499   0,
  500   0,
  501   fputc,
  502 #ifdef __MWERKS__
  503   (int (*)(char *, struct _FILE *))fputs,
  504   (unsigned long (*)(char *, unsigned long, unsigned long, struct _FILE *))ffwrite,
  505 #else
  506   fputs,
  507   ffwrite,
  508 #endif
  509   fflush,
  510   fgetc,
  511   fclose};
  512 
  513 ptobfuns pipob = {
  514   0,
  515   mark0,
  516   0,                /* replaced by pclose in init_posix() */
  517   0,
  518   0,
  519   fputc,
  520 #ifdef __MWERKS__
  521   (int (*)(char *, struct _FILE *))fputs,
  522   (unsigned long (*)(char *, unsigned long, unsigned long, struct _FILE *))ffwrite,
  523 #else
  524   fputs,
  525   ffwrite,
  526 #endif
  527   fflush,
  528   fgetc};
  529 
  530 static ptobfuns stptob = {
  531   s_string,
  532   markcdr,
  533   noop0,
  534   0,
  535   0,
  536   stputc,
  537   stputs,
  538   stwrite,
  539   noop0,
  540   stgetc,
  541   stclose,
  542   stungetc};
  543 
  544                 /* Soft ports */
  545 
  546 /* fputc, fwrite, fputs, and fclose are called within a
  547    SYSCALL.  So we need to set errno to 0 before returning.  fflush
  548    may be called within a SYSCALL.  So we need to set errno to 0
  549    before returning. */
  550 
  551 static int sfputc(c, p)
  552      int c; SCM p;
  553 {
  554   SCM arg = MAKICHR(c);
  555   scm_cvapply(VELTS(p)[0], 1L, &arg);
  556   errno = 0;
  557   return c;
  558 }
  559 sizet sfwrite(str, siz, num, p)
  560      sizet siz, num;
  561      const void *str; SCM p;
  562 {
  563   SCM sstr;
  564   sstr = makfromstr(str, siz * num);
  565   scm_cvapply(VELTS(p)[1], 1L, &sstr);
  566   errno = 0;
  567   return num;
  568 }
  569 static int sfputs(s, p)
  570      const char *s; SCM p;
  571 {
  572   sfwrite(s, 1, strlen(s), p);
  573   return 0;
  574 }
  575 int sfflush(stream)
  576      SCM stream;
  577 {
  578   SCM f = VELTS(stream)[2];
  579   if (BOOL_F==f) return 0;
  580   f = apply(f, EOL, EOL);
  581   errno = 0;
  582   return BOOL_F==f ? EOF : 0;
  583 }
  584 static int sfgetc(p)
  585      SCM p;
  586 {
  587   SCM ans;
  588   ans = scm_cvapply(VELTS(p)[3], 0L, (SCM *)0);
  589   errno = 0;
  590   if (FALSEP(ans) || EOF_VAL==ans) return EOF;
  591   ASRTER(ICHRP(ans), ans, ARG1, "getc");
  592   return ICHR(ans);
  593 }
  594 static int sfclose(p)
  595      SCM p;
  596 {
  597   SCM f = VELTS(p)[4];
  598   if (BOOL_F==f) return 0;
  599   f = apply(f, EOL, EOL);
  600   errno = 0;
  601   return BOOL_F==f ? EOF : 0;
  602 }
  603 static char s_mksfpt[] = "make-soft-port";
  604 SCM mksfpt(pv, modes)
  605      SCM pv, modes;
  606 {
  607   SCM z;
  608   long flags;
  609   static long arities[] = {1, 1, 0, 0, 0};
  610 #ifndef RECKLESS
  611   int i;
  612   if (! (NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv)))
  613     badarg: wta(pv, (char *)ARG1, s_mksfpt);
  614   for (i = 0; i < 5; i++) {
  615     ASRTGO(FALSEP(VELTS(pv)[i]) ||
  616        scm_arity_check(VELTS(pv)[i], arities[i], (char *)0),
  617        badarg);
  618   }
  619 #endif
  620   ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_mksfpt);
  621   flags = mode_bits(CHARS(modes), (char *)0);
  622   ASRTER(flags, modes, ARG2, s_mksfpt);
  623   DEFER_INTS;
  624   z = scm_port_entry((FILE *)pv, tc16_sfport, flags);
  625   ALLOW_INTS;
  626   return z;
  627 }
  628 
  629 static ptobfuns sfptob = {
  630   "soft",
  631   markcdr,
  632   noop0,
  633   0,
  634   0,
  635   sfputc,
  636   sfputs,
  637   sfwrite,
  638   sfflush,
  639   sfgetc,
  640   sfclose};
  641 
  642         /* Closed ports, just return an error code and let
  643            the caller complain. */
  644 static int clputc(c, p)
  645      int c; FILE *p;
  646 {
  647   return EOF;
  648 }
  649 static sizet clwrite(str, siz, num, p)
  650      sizet siz, num;
  651      char *str; FILE *p;
  652 {
  653   return 0;
  654 }
  655 static int clputs(s, p)
  656      char *s; FILE *p;
  657 {
  658   return EOF;
  659 }
  660 static int clgetc(p)
  661      FILE *p;
  662 {
  663   return EOF;
  664 }
  665 static ptobfuns clptob = {
  666   s_port_type,
  667   mark0,
  668   noop0,
  669   0,
  670   0,
  671   clputc,
  672   clputs,
  673   clwrite,
  674   clgetc,
  675   clgetc,
  676   0};
  677 
  678 /* The following ptob is for printing system messages in an interrupt-safe
  679    way.  Writing to sys_errp while interrupts are disabled will never enable
  680    interrupts, do any actual i/o, or any allocation.  Messages will be
  681    written to cur_errp as soon as interrupts are enabled. There will only
  682    ever be one of these. */
  683 int output_deferred = 0;
  684 static int tc16_sysport;
  685 #define SYS_ERRP_SIZE 480
  686 static char errbuf[SYS_ERRP_SIZE];
  687 static sizet errbuf_end = 0;
  688 
  689 static sizet syswrite(str, siz, num, p)
  690      sizet siz, num;
  691      char *str; FILE *p;
  692 {
  693   sizet src, dst = errbuf_end;
  694   sizet n = siz*num;
  695   if (ints_disabled) {
  696     deferred_proc = process_signals;
  697     output_deferred = !0;
  698     for (src = 0; src < n; src++, dst++)
  699       errbuf[dst % SYS_ERRP_SIZE] = str[src];
  700     errbuf_end = dst;
  701   }
  702   else {
  703     /* if (NIMP(cur_errp) && OPOUTPORTP(cur_errp)) lfflush(cur_errp); */
  704     if (errbuf_end > 0) {
  705       if (errbuf_end > SYS_ERRP_SIZE) {
  706     scm_warn("output buffer", " overflowed", UNDEFINED);
  707     scm_intprint((long)errbuf_end, 10, cur_errp);
  708     lputs(" chars needed\n", cur_errp);
  709     errbuf_end = errbuf_end % SYS_ERRP_SIZE;
  710     lfwrite(&errbuf[errbuf_end], 1,
  711         SYS_ERRP_SIZE - errbuf_end, cur_errp);
  712       }
  713       lfwrite(errbuf, sizeof(char), errbuf_end, cur_errp);
  714       errbuf_end = 0;
  715     }
  716     num = lfwrite(str, siz, num, cur_errp);
  717     /* if (NIMP(cur_errp) && OPOUTPORTP(cur_errp)) lfflush(cur_errp); */
  718   }
  719   errno = 0;
  720   return num;
  721 }
  722 static int sysputs(s, p)
  723      char *s; FILE *p;
  724 {
  725   syswrite(s, 1, strlen(s), p);
  726   return 0;
  727 }
  728 static int sysputc(c, p)
  729      int c; FILE *p;
  730 {
  731   char cc = c;
  732   syswrite(&cc, 1, 1, p);
  733   return c;
  734 }
  735 static int sysflush(p)
  736      FILE *p;
  737 {
  738   syswrite("", 0, 0, p);
  739   return 0;
  740 }
  741 static ptobfuns sysptob = {
  742   0,
  743   mark0,
  744   noop0,
  745   0,
  746   0,
  747   sysputc,
  748   sysputs,
  749   syswrite,
  750   sysflush,
  751   noop0,
  752   noop0};
  753 
  754 /* A `safeport' is used for writing objects as part of an error response.
  755    Since these objects may be very large or circular, the safeport will
  756    output only a fixed number of characters before exiting via longjmp.
  757    A setjmp must be done before each use of the safeport. */
  758 
  759 static char s_msp[] = "mksafeport";
  760 int tc16_safeport;
  761 SCM mksafeport(maxlen, port)
  762      int maxlen;
  763      SCM port;
  764 {
  765   SCM z;
  766   if (UNBNDP(port)) port = cur_errp;
  767   ASRTER(NIMP(port) && OPPORTP(port), port, ARG2, s_msp);
  768   z = must_malloc_cell(sizeof(safeport)+0L,
  769                tc16_safeport | OPN | WRTNG,
  770                s_msp);
  771   ((safeport *)STREAM(z))->ccnt = maxlen;
  772   ((safeport *)STREAM(z))->port = port;
  773   return z;
  774 }
  775 int reset_safeport(sfp, maxlen, port)
  776      int maxlen;
  777      SCM sfp, port;
  778 {
  779   if (NIMP(sfp) && tc16_safeport==TYP16(sfp)) {
  780     ((safeport *)STREAM(sfp))->ccnt = maxlen;
  781     if (NIMP(port))
  782       ((safeport *)STREAM(sfp))->port = port;
  783     return !0;
  784   }
  785   return 0;
  786 }
  787 static sizet safewrite(str, siz, num, p)
  788      sizet siz, num;
  789      char *str; safeport *p;
  790 {
  791   int count = p->ccnt;
  792   sizet n = siz*num;
  793   if (n < count) {
  794     p->ccnt = count - n;
  795     lfwrite(str, siz, num, p->port);
  796   }
  797   else if (count) {
  798     num = count / siz;
  799     p->ccnt = 0;
  800     lfwrite(str, siz, num, p->port);
  801     lputs(" ...", p->port);
  802     longjmp(p->jmpbuf, !0); /* The usual C longjmp, not SCM's longjump */
  803   }
  804   return num;
  805 }
  806 static int safeputs(s, p)
  807      char *s; safeport *p;
  808 {
  809   safewrite(s, 1, strlen(s), p);
  810   return 0;
  811 }
  812 static int safeputc(c, p)
  813      int c; safeport *p;
  814 {
  815   char cc = c;
  816   safewrite(&cc, 1, 1, p);
  817   return c;
  818 }
  819 static int safeflush(p)
  820      safeport *p;
  821 {
  822   if (p && NIMP(p->port) && OPOUTPORTP(p->port)) lfflush(p->port);
  823   return 0;
  824 }
  825 static SCM marksafep(ptr)
  826      SCM ptr;
  827 {
  828   return ((safeport *)STREAM(ptr))->port;
  829 }
  830 static int freesafep(ptr)
  831      FILE *ptr;
  832 {
  833   must_free((char *)ptr, sizeof(safeport));
  834   return 0;
  835 }
  836 static ptobfuns safeptob = {
  837   0,
  838   marksafep,
  839   freesafep,
  840   0,
  841   0,
  842   safeputc,
  843   safeputs,
  844   safewrite,
  845   safeflush,
  846   noop0,
  847   noop0};
  848 
  849 static int freeprint(exp, port, writing)
  850      SCM exp; SCM port; int writing;
  851 {
  852   if (tc_broken_heart==CAR(exp)) {
  853     lputs("#<GC-FORWARD->", port);
  854     scm_iprin1(CDR(exp), port, writing);
  855   }
  856   else {
  857     if (NIMP(CDR(exp)) && tc7_smob==CAR(CDR(exp))) {
  858       lputs("#<FREE-CELL ", port);
  859     }
  860     else {
  861       lputs("#<NEW-CELL . ", port);
  862       scm_iprin1(CDR(exp), port, writing);
  863     }
  864     lputs(" @0x", port);
  865     scm_intprint((long)exp, -16, port);
  866   }
  867   lputc('>', port);
  868   return !0;
  869 }
  870 static smobfuns freecell = {
  871   mark0,
  872   free0,
  873   freeprint,
  874   0};
  875 static smobfuns flob = {
  876   mark0,
  877   /*flofree*/0,
  878   floprint,
  879 #ifdef FLOATS
  880   floequal
  881 #else
  882   0
  883 #endif
  884 };
  885 static smobfuns bigob = {
  886   mark0,
  887   /*bigfree*/0,
  888   bigprint,
  889 #ifdef BIGDIG
  890   bigequal
  891 #else
  892   0
  893 #endif
  894 };
  895 
  896 scm_gra finals_gra;
  897 static char s_final[] = "final";
  898 
  899 /* statically allocated ports for diagnostic messages */
  900 static cell tmp_errpbuf[3];
  901 static SCM tmp_errp;
  902 extern sizet num_protects;  /* sys_protects now in scl.c */
  903 void init_types()
  904 {
  905   sizet j = num_protects;
  906   while(j) sys_protects[--j] = UNDEFINED;
  907 
  908   /* We need to set up tmp_errp before any errors may be
  909      thrown, the port_table index will be zero, usable by
  910      all ports that don't care about their table entries. */
  911   tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0]));
  912   CAR(tmp_errp) = tc16_fport | OPN | WRTNG;
  913   /*  CAR(tmp_errp) = scm_port_entry(tc16_fport, OPN|WRTNG); */
  914   SETSTREAM(tmp_errp, stderr);
  915   cur_errp = def_errp = sys_safep = tmp_errp;
  916 
  917   /* subrs_gra is trimmed to actual used by scm_init_extensions() */
  918   scm_init_gra(&subrs_gra, sizeof(subr_info), 420 , 0, "subrs");
  919   scm_init_gra(&ptobs_gra, sizeof(ptobfuns), 8, 255, "ptobs");
  920   /* These newptob calls must be done in this order */
  921   /* tc16_fport = */ newptob(&fptob);
  922   /* tc16_pipe = */ newptob(&pipob);
  923   /* tc16_strport = */ newptob(&stptob);
  924   /* tc16_sfport = */ newptob(&sfptob);
  925   tc16_clport = newptob(&clptob);
  926   tc16_sysport = newptob(&sysptob);
  927   tc16_safeport = newptob(&safeptob);
  928   scm_init_gra(&smobs_gra, sizeof(smobfuns), 16, 255, "smobs");
  929   /* These newsmob calls must be done in this order */
  930   newsmob(&freecell);
  931   newsmob(&flob);
  932   newsmob(&bigob);
  933   newsmob(&bigob);
  934   scm_init_gra(&finals_gra, sizeof(void (*)()), 4, 0, s_final);
  935 }
  936 
  937 #ifdef TEST_FINAL
  938 void test_final()
  939 {
  940   fputs("test_final ok\n", stderr);
  941 }
  942 #endif
  943 void add_final(final)
  944      void (* final)();
  945 {
  946   scm_grow_gra(&finals_gra, (char *)&final);
  947 }
  948 
  949 static SCM gc_finalizers = EOL, gc_finalizers_pending = EOL;
  950 static char s_add_finalizer[] = "add-finalizer";
  951 SCM scm_add_finalizer(value, finalizer)
  952      SCM value, finalizer;
  953 {
  954   SCM z;
  955   ASRTER(NIMP(value), value, ARG1, s_add_finalizer);
  956 #ifndef RECKLESS
  957   scm_arity_check(finalizer, 0L, s_add_finalizer);
  958 #endif
  959   z = acons(value, finalizer, EOL);
  960   DEFER_INTS;
  961   CDR(z) = gc_finalizers;
  962   gc_finalizers = z;
  963   ALLOW_INTS;
  964   return UNSPECIFIED;
  965 }
  966 
  967 static char s_estk[] = "environment stack";
  968 static cell ecache_v[ECACHE_SIZE];
  969 SCM scm_egc_roots[ECACHE_SIZE/20];
  970 CELLPTR scm_ecache;
  971 VOLATILE long scm_ecache_index, scm_ecache_len, scm_egc_root_index;
  972 SCM scm_estk = UNDEFINED, *scm_estk_ptr;
  973 static SCM estk_pool = EOL;
  974 long scm_estk_size;
  975 static SCM make_stk_seg(size, contents)
  976      sizet size;
  977      SCM contents;
  978 {
  979   SCM seg = BOOL_F, *src, *dst;
  980   sizet i;
  981   VERIFY_INTS("make_stk_seg", 0L);
  982   while NIMP(estk_pool) {
  983     if (size==LENGTH(estk_pool)) {
  984       seg = estk_pool;
  985       estk_pool = SCM_ESTK_PARENT(seg);
  986       break;
  987     }
  988     estk_pool = SCM_ESTK_PARENT(estk_pool);
  989   }
  990   if (IMP(seg)) seg = must_malloc_cell((long)size*sizeof(SCM),
  991                      MAKE_LENGTH(size, tc7_vector), s_estk);
  992   dst = VELTS(seg);
  993   if (NIMP(contents)) {
  994     src = VELTS(contents);
  995     for (i = size; i--;) dst[i] = src[i];
  996   }
  997   else {
  998     for (i = size; i--;) dst[i] = UNSPECIFIED;
  999     SCM_ESTK_PARENT(seg) = BOOL_F;
 1000     SCM_ESTK_PARENT_INDEX(seg) = INUM0;
 1001     dst[SCM_ESTK_BASE - 1] = UNDEFINED;  /* underflow sentinel */
 1002   }
 1003   dst[size - 1] = UNDEFINED;    /* overflow sentinel */
 1004   return seg;
 1005 }
 1006 /* size is a number of SCM elements, or zero for a default size.
 1007    If nonzero, size must be SCM_ESTK_BASE + N * SCM_ESTK_FRLEN + 1
 1008    for some reasonable number of stackframes N  */
 1009 void scm_estk_reset(size)
 1010      sizet size;
 1011 {
 1012   VERIFY_INTS("scm_estk_reset", 0L);
 1013   if (!size) size = SCM_ESTK_BASE + 20*SCM_ESTK_FRLEN + 1;
 1014   scm_estk = make_stk_seg(size, UNDEFINED);
 1015   scm_estk_ptr = &(VELTS(scm_estk)[SCM_ESTK_BASE]);
 1016   scm_estk_size = size + 0L;
 1017 }
 1018 void scm_estk_grow()
 1019 {
 1020   /* 40 and 10 below are adjustable parameters:  the number of frames
 1021      in a stack segment, and the number of frames to overlap between
 1022      stack segments. */
 1023   sizet size = 40 * SCM_ESTK_FRLEN + SCM_ESTK_BASE + 1;
 1024   sizet overlap = 10*SCM_ESTK_FRLEN;
 1025   SCM estk = make_stk_seg(size, UNDEFINED);
 1026   SCM *newv, *oldv;
 1027   sizet i, j;
 1028   newv = VELTS(estk);
 1029   oldv = VELTS(scm_estk);
 1030   j = scm_estk_ptr - oldv + SCM_ESTK_FRLEN - overlap;
 1031   SCM_ESTK_PARENT(estk) = scm_estk;
 1032   SCM_ESTK_PARENT_WRITABLEP(estk) = BOOL_T;
 1033   SCM_ESTK_PARENT_INDEX(estk) = MAKINUM(j - SCM_ESTK_FRLEN);
 1034   for (i = SCM_ESTK_BASE; i < SCM_ESTK_BASE + overlap; i++, j++) {
 1035     newv[i] = oldv[j];
 1036     oldv[j] = BOOL_F;
 1037   }
 1038   scm_estk = estk;
 1039   scm_estk_ptr = &(newv[SCM_ESTK_BASE + overlap]);
 1040   scm_estk_size += size + 0L;
 1041   /*  growth_mon(s_estk, scm_estk_size, "locations", !0); */
 1042 }
 1043 void scm_estk_shrink()
 1044 {
 1045   SCM parent;
 1046   sizet i;
 1047   parent = SCM_ESTK_PARENT(scm_estk);
 1048   i = INUM(SCM_ESTK_PARENT_INDEX(scm_estk));
 1049   if (IMP(parent)) wta(UNDEFINED, "underflow", s_estk);
 1050   if (BOOL_F==SCM_ESTK_PARENT_WRITABLEP(scm_estk)) {
 1051     parent = make_stk_seg((sizet)LENGTH(parent), parent);
 1052     SCM_ESTK_PARENT_WRITABLEP(parent) = BOOL_F;
 1053   }
 1054   SCM_ESTK_PARENT(scm_estk) = estk_pool;
 1055   estk_pool = scm_estk;
 1056   scm_estk_size -= LENGTH(scm_estk);
 1057   scm_estk = parent;
 1058   scm_estk_ptr = &(VELTS(parent)[i]);
 1059   /*  growth_mon(s_estk, scm_estk_size, "locations", 0); */
 1060 }
 1061 
 1062 void scm_env_cons(x, y)
 1063      SCM x, y;
 1064 {
 1065    register SCM z;
 1066    register int i;
 1067    DEFER_INTS_EGC;
 1068    i = scm_ecache_index;
 1069    if (1>i) {
 1070      scm_egc();
 1071      i = scm_ecache_index;
 1072    }
 1073    z = PTR2SCM(&(scm_ecache[--i]));
 1074    CAR(z) = x;
 1075    CDR(z) = y;
 1076    scm_env_tmp = z;
 1077    scm_ecache_index = i;
 1078 }
 1079 
 1080 void scm_env_cons2(w, x, y)
 1081      SCM w, x, y;
 1082 {
 1083    SCM z1, z2;
 1084    register int i;
 1085    DEFER_INTS_EGC;
 1086    i = scm_ecache_index;
 1087    if (2>i) {
 1088      scm_egc();
 1089      i = scm_ecache_index;
 1090    }
 1091    z1 = PTR2SCM(&(scm_ecache[--i]));
 1092    CAR(z1) = x;
 1093    CDR(z1) = y;
 1094    z2 = PTR2SCM(&(scm_ecache[--i]));
 1095    CAR(z2) = w;
 1096    CDR(z2) = z1;
 1097    scm_env_tmp = z2;
 1098    scm_ecache_index = i;
 1099 }
 1100 
 1101 void scm_env_cons3(v, w, x, y)
 1102      SCM v, w, x, y;
 1103 {
 1104    SCM z1, z2;
 1105    register int i;
 1106    DEFER_INTS_EGC;
 1107    i = scm_ecache_index;
 1108    if (3>i) {
 1109      scm_egc();
 1110      i = scm_ecache_index;
 1111    }
 1112    z1 = PTR2SCM(&(scm_ecache[--i]));
 1113    CAR(z1) = x;
 1114    CDR(z1) = y;
 1115    z2 = PTR2SCM(&(scm_ecache[--i]));
 1116    CAR(z2) = w;
 1117    CDR(z2) = z1;
 1118    z1 = PTR2SCM(&(scm_ecache[--i]));
 1119    CAR(z1) = v;
 1120    CDR(z1) = z2;
 1121    scm_env_tmp = z1;
 1122    scm_ecache_index = i;
 1123 }
 1124 
 1125 void scm_env_v2lst(argc, argv)
 1126      long argc;
 1127      SCM *argv;
 1128 {
 1129    SCM z1, z2;
 1130    register int i;
 1131    DEFER_INTS_EGC;
 1132    i = scm_ecache_index;
 1133    if (argc>i) {
 1134      scm_egc();
 1135      i = scm_ecache_index;
 1136    }
 1137    z1 = z2 = scm_env_tmp;   /* set z1 just in case argc is zero */
 1138    while (argc--) {
 1139      z1 = PTR2SCM(&(scm_ecache[--i]));
 1140      CAR(z1) = argv[argc];
 1141      CDR(z1) = z2;
 1142      z2 = z1;
 1143    }
 1144    scm_env_tmp = z1;
 1145    scm_ecache_index = i;
 1146 }
 1147 
 1148 /* scm_env = acons(names, scm_env_tmp, scm_env) */
 1149 void scm_extend_env()
 1150 {
 1151    SCM z;
 1152    register int i;
 1153    DEFER_INTS_EGC;
 1154    i = scm_ecache_index;
 1155    if (1>i) {
 1156      scm_egc();
 1157      i = scm_ecache_index;
 1158    }
 1159    z = PTR2SCM(&(scm_ecache[--i]));
 1160    CAR(z) = scm_env_tmp;
 1161    CDR(z) = scm_env;
 1162    scm_env = z;
 1163    scm_ecache_index = i;
 1164 }
 1165 void old_scm_extend_env(names)
 1166      SCM names;
 1167 {
 1168    SCM z1, z2;
 1169    register int i;
 1170    DEFER_INTS_EGC;
 1171    i = scm_ecache_index;
 1172    if (2>i) {
 1173      scm_egc();
 1174      i = scm_ecache_index;
 1175    }
 1176    z1 = PTR2SCM(&(scm_ecache[--i]));
 1177    CAR(z1) = names;
 1178    CDR(z1) = scm_env_tmp;
 1179    z2 = PTR2SCM(&(scm_ecache[--i]));
 1180    CAR(z2) = z1;
 1181    CDR(z2) = scm_env;
 1182    scm_env = z2;
 1183    scm_ecache_index = i;
 1184 }
 1185 char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc";
 1186 char s_recursive[] = "recursive";
 1187 #define s_gc (s_cache_gc+6)
 1188 static iproc subr0s[] = {
 1189     {"tmpnam", ltmpnam},
 1190     {"open-ports", scm_open_ports},
 1191     {0, 0}};
 1192 
 1193 static iproc subr1s[] = {
 1194     {s_input_portp, input_portp},
 1195     {s_output_portp, output_portp},
 1196     {s_portp, scm_portp},
 1197     {s_port_closedp, port_closedp},
 1198     {s_close_port, close_port},
 1199     {"eof-object?", eof_objectp},
 1200     {"port-type", scm_port_type},
 1201     {s_cwos, cwos},
 1202     {"object-hash", obhash},
 1203     {s_obunhash, obunhash},
 1204     {s_del_fil, del_fil},
 1205     {0, 0}};
 1206 
 1207 static iproc subr2s[] = {
 1208     {s_try_open_file, try_open_file},
 1209     {s_cwis, cwis},
 1210     {s_mksfpt, mksfpt},
 1211     {s_add_finalizer, scm_add_finalizer},
 1212     {0, 0}};
 1213 
 1214 SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3));
 1215 void init_io()
 1216 {
 1217   make_subr("dynamic-wind", tc7_subr_3, dynwind);
 1218   make_subr(s_gc, tc7_subr_1o, gc);
 1219   init_iprocs(subr0s, tc7_subr_0);
 1220   init_iprocs(subr1s, tc7_subr_1);
 1221   init_iprocs(subr2s, tc7_subr_2);
 1222   loc_open_file =
 1223     &CDR(sysintern(s_open_file,
 1224            CDR(sysintern(s_try_open_file, UNDEFINED))));
 1225   loc_try_create_file = &CDR(sysintern(s_try_create_file, UNDEFINED));
 1226 #ifndef CHEAP_CONTINUATIONS
 1227   add_feature("full-continuation");
 1228 #endif
 1229 #ifdef TEST_FINAL
 1230   add_final(test_final);
 1231 #endif
 1232 }
 1233 
 1234 void grew_lim(nm)
 1235      long nm;
 1236 {
 1237   growth_mon(s_limit, nm, "bytes", !0);
 1238 }
 1239 int expmem = 0;
 1240 sizet hplim_ind = 0;
 1241 long heap_cells = 0;
 1242 CELLPTR *hplims, heap_org;
 1243 VOLATILE SCM freelist = EOL;
 1244 long mltrigger, mtrigger = INIT_MALLOC_LIMIT;
 1245 int gc_hook_pending = 0, gc_hook_active = 0;
 1246 
 1247 /* Ints should be deferred when calling igc_for_alloc. */
 1248 static char *igc_for_alloc(where, olen, size, what)
 1249      char *where;
 1250      unsigned long olen;
 1251      unsigned long size;
 1252      const char *what;
 1253 {
 1254   char *ptr;
 1255   unsigned long nm;
 1256             /* Check to see that heap is initialized */
 1257   ASRTER(heap_cells > 0, MAKINUM(size), NALLOC, what);
 1258 /* printf("igc_for_alloc(%lx, %lu, %u, %s)\n", where, olen, size, what); fflush(stdout); */
 1259   igc(what, rootcont);
 1260   nm = mallocated + size - olen;
 1261   if (nm > mltrigger) {
 1262     if (nm > mtrigger) grew_lim(nm + nm/2);
 1263     else grew_lim(mtrigger + mtrigger/2);
 1264   }
 1265   if (where) SYSCALL(ptr = (char *)realloc(where, size););
 1266   else SYSCALL(ptr = (char *)malloc(size););
 1267   ASRTER(ptr, MAKINUM(size), NALLOC, what);
 1268   if (nm > mltrigger) {
 1269     if (nm > mtrigger) mtrigger = nm + nm/2;
 1270     else mtrigger += mtrigger/2;
 1271     mltrigger = mtrigger - MIN_MALLOC_YIELD;
 1272   }
 1273   mallocated = nm;
 1274   return ptr;
 1275 }
 1276 char *must_malloc(len, what)
 1277      long len;
 1278      const char *what;
 1279 {
 1280   char *ptr;
 1281   sizet size = len;
 1282   unsigned long nm = mallocated + size;
 1283   VERIFY_INTS("must_malloc", what);
 1284 #ifdef SHORT_SIZET
 1285   ASRTER(len==size, MAKINUM(len), NALLOC, what);
 1286 #endif
 1287   if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size););
 1288   else ptr = 0;
 1289   if (!ptr) ptr = igc_for_alloc(0L, 0L, size+0L, what);
 1290   else mallocated = nm;
 1291 /* printf("must_malloc(%lu, %s) => %lx\n", len, what, ptr); fflush(stdout); */
 1292   return ptr;
 1293 }
 1294 SCM must_malloc_cell(len, c, what)
 1295      long len;
 1296      SCM c;
 1297      const char *what;
 1298 {
 1299   SCM z;
 1300   char *ptr;
 1301   sizet size = len;
 1302   unsigned long nm = mallocated + size;
 1303   VERIFY_INTS("must_malloc_cell", what);
 1304 #ifdef SHORT_SIZET
 1305   ASRTER(len==size, MAKINUM(len), NALLOC, what);
 1306 #endif
 1307   NEWCELL(z);
 1308   if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size););
 1309   else ptr = 0;
 1310   if (!ptr) ptr = igc_for_alloc(0L, 0L, size+0L, what);
 1311   else mallocated = nm;
 1312 /* printf("must_malloc_cell(%lu, %lx, %s) => %lx\n", len, c, what, ptr); fflush(stdout); */
 1313   SETCHARS(z, ptr);
 1314   CAR(z) = c;
 1315   return z;
 1316 }
 1317 char *must_realloc(where, olen, len, what)
 1318      char *where;
 1319      unsigned long olen, len;
 1320      const char *what;
 1321 {
 1322   char *ptr;
 1323   sizet size = len;
 1324   unsigned long nm = mallocated + size - olen;
 1325   VERIFY_INTS("must_realloc", what);
 1326 #ifdef SHORT_SIZET
 1327   ASRTER(len==size, MAKINUM(len), NALLOC, what);
 1328 #endif
 1329   ASRTER(!errjmp_bad, MAKINUM(len), NALLOC, what);
 1330 /* printf("must_realloc(%lx, %lu, %lu, %s)\n", where, olen, len, what); fflush(stdout);
 1331    printf("nm = %ld <= mtrigger = %ld: %d; size = %u\n", nm, mtrigger, (nm <= mtrigger), size); fflush(stdout); */
 1332   if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size););
 1333   else ptr = 0;
 1334   if (!ptr) ptr = igc_for_alloc(where, olen, size+0L, what);
 1335   else mallocated = nm;
 1336   return ptr;
 1337 }
 1338 void must_realloc_cell(z, olen, len, what)
 1339      SCM z;
 1340      unsigned long olen, len;
 1341      const char *what;
 1342 {
 1343   char *ptr, *where = CHARS(z);
 1344   sizet size = len;
 1345   unsigned long nm = mallocated + size - olen;
 1346   VERIFY_INTS("must_realloc_cell", what);
 1347 #ifdef SHORT_SIZET
 1348   ASRTER(len==size, MAKINUM(len), NALLOC, what);
 1349 #endif
 1350   ASRTER(!errjmp_bad, MAKINUM(len), NALLOC, what);
 1351 /* printf("must_realloc_cell(%lx, %lu, %lu, %s)\n", z, olen, len, what); fflush(stdout); */
 1352   if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size););
 1353   else ptr = 0;
 1354   if (!ptr) ptr = igc_for_alloc(where, olen, size+0L, what);
 1355   else mallocated = nm;
 1356   SETCHARS(z, ptr);
 1357 }
 1358 void must_free(obj, len)
 1359      char *obj;
 1360      sizet len;
 1361 {
 1362   if (obj) {
 1363 #ifdef CAREFUL_INTS
 1364     while (len--) obj[len] = '#';
 1365 #endif
 1366 /* printf("free(%lx)\n", obj); fflush(stdout); */
 1367     free(obj);
 1368     mallocated = mallocated - len;
 1369   }
 1370   else wta(INUM0, "already free", "");
 1371 }
 1372 
 1373 SCM symhash;            /* This used to be a sys_protect, but
 1374                    Radey Shouman <shouman@zianet.com>
 1375                    added GC for unused, UNDEFINED
 1376                    symbols.*/
 1377 int no_symhash_gc =
 1378 #ifdef NO_SYM_GC
 1379   !0                /* Hobbit-compiled code must not GC symhash. */
 1380 #else
 1381   0
 1382 #endif
 1383   ;
 1384 int symhash_dim = NUM_HASH_BUCKETS;
 1385 /* sym2vcell looks up the symbol in the symhash table. */
 1386 SCM sym2vcell(sym)
 1387      SCM sym;
 1388 {
 1389   SCM lsym, z;
 1390   sizet hash = strhash(UCHARS(sym), (sizet)LENGTH(sym),
 1391                (unsigned long)symhash_dim);
 1392   for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
 1393     z = CAR(lsym);
 1394     if (CAR(z)==sym) return z;
 1395   }
 1396   wta(sym, "uninterned symbol? ", "");
 1397 }
 1398 /* intern() and sysintern() return a pair;
 1399    CAR is the symbol, CDR is the value. */
 1400 SCM intern(name, len)
 1401      char *name;
 1402      sizet len;
 1403 {
 1404   SCM lsym, z;
 1405   register sizet i = len;
 1406   register unsigned char *tmp = (unsigned char *)name;
 1407   sizet hash = strhash(tmp, i, (unsigned long)symhash_dim);
 1408   /* printf("intern %s len=%d\n",name,len); fflush(stdout); */
 1409   DEFER_INTS;
 1410   for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
 1411     z = CAR(lsym);
 1412     z = CAR(z);
 1413     tmp = UCHARS(z);
 1414     if (LENGTH(z) != len) goto trynext;
 1415     for (i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext;
 1416     ALLOW_INTS;
 1417     return CAR(lsym);
 1418   trynext: ;
 1419   }
 1420   /*  lsym = makfromstr(name, len); */
 1421   lsym = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_msymbol), s_string);
 1422   i = len;
 1423   CHARS(lsym)[len] = 0;
 1424   while (i--) CHARS(lsym)[i] = name[i];
 1425   z = acons(lsym, UNDEFINED, UNDEFINED);
 1426   CDR(z) = VELTS(symhash)[hash];
 1427   VELTS(symhash)[hash] = z;
 1428   z = CAR(z);
 1429   ALLOW_INTS;
 1430   return z;
 1431 }
 1432 SCM sysintern(name, val)
 1433      const char *name;
 1434      SCM val;
 1435 {
 1436   SCM lsym, z;
 1437   sizet len = strlen(name);
 1438   register sizet i = len;
 1439   register unsigned char *tmp = (unsigned char *)name;
 1440   sizet hash = strhash(tmp, i, (unsigned long)symhash_dim);
 1441   for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
 1442     z = CAR(lsym);
 1443     z = CAR(z);
 1444     tmp = UCHARS(z);
 1445     if (LENGTH(z) != len) goto trynext;
 1446     for (i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext;
 1447     lsym = CAR(lsym);
 1448     if (!UNBNDP(val)) CDR(lsym) = val;
 1449     else if (UNBNDP(CDR(lsym)) && tc7_msymbol==TYP7(CAR(lsym)))
 1450       scm_gc_protect(lsym);
 1451     return lsym;
 1452   trynext: ;
 1453   }
 1454   NEWCELL(lsym);
 1455   SETLENGTH(lsym, len, tc7_ssymbol);
 1456   SETCHARS(lsym, name);
 1457   lsym = cons(lsym, val);
 1458   z = cons(lsym, UNDEFINED);
 1459   CDR(z) = VELTS(symhash)[hash];
 1460   VELTS(symhash)[hash] = z;
 1461   return lsym;
 1462 }
 1463 SCM cons(x, y)
 1464      SCM x, y;
 1465 {
 1466     register SCM z;
 1467     NEWCELL(z);
 1468     CAR(z) = x;
 1469     CDR(z) = y;
 1470     return z;
 1471 }
 1472 SCM cons2(w, x, y)
 1473      SCM w, x, y;
 1474 {
 1475     register SCM z;
 1476     NEWCELL(z);
 1477     CAR(z) = x;
 1478     CDR(z) = y;
 1479     x = z;
 1480     NEWCELL(z);
 1481     CAR(z) = w;
 1482     CDR(z) = x;
 1483     return z;
 1484 }
 1485 SCM acons(w, x, y)
 1486      SCM w, x, y;
 1487 {
 1488     register SCM z;
 1489     NEWCELL(z);
 1490     CAR(z) = w;
 1491     CDR(z) = x;
 1492     x = z;
 1493     NEWCELL(z);
 1494     CAR(z) = x;
 1495     CDR(z) = y;
 1496     return z;
 1497 }
 1498 
 1499 SCM makstr(len)
 1500      long len;
 1501 {
 1502     SCM s;
 1503 #ifndef SHORT_SIZET
 1504     ASRTER(!(len & ~LENGTH_MAX), MAKINUM(len), NALLOC, s_string);
 1505 #endif
 1506     DEFER_INTS;
 1507     s = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_string), s_string);
 1508     CHARS(s)[len] = 0;
 1509     ALLOW_INTS;
 1510     return s;
 1511 }
 1512 
 1513 char s_redefining[] = "redefining ";
 1514 scm_gra subrs_gra;
 1515 SCM scm_maksubr(name, type, fcn)
 1516      const char *name;
 1517      int type;
 1518      SCM (*fcn)();
 1519 {
 1520     subr_info info;
 1521     int isubr;
 1522     register SCM z;
 1523     info.name = name;
 1524     for (isubr = subrs_gra.len; 0 < isubr--;) {
 1525       if (0==strcmp(((char **)subrs_gra.elts)[isubr], name)) {
 1526         scm_warn(s_redefining, (char *)name, UNDEFINED);
 1527         goto foundit;
 1528       }
 1529     }
 1530     isubr = scm_grow_gra(&subrs_gra, (char *)&info);
 1531  foundit:
 1532     NEWCELL(z);
 1533     if (!fcn && tc7_cxr==type) {
 1534       const char *p = name;
 1535       int code = 0;
 1536       while (*++p != 'r')
 1537         switch (*p) {
 1538         default: wta(UNDEFINED, "bad cxr name", (char *)name);
 1539         case 'a': code = (code<<2) + 1; continue;
 1540         case 'd': code = (code<<2) + 2; continue;
 1541         }
 1542       type += (code << 8);
 1543     }
 1544     CAR(z) = (isubr<<16) + type;
 1545     SUBRF(z) = fcn;
 1546     return z;
 1547 }
 1548 SCM make_subr(name, type, fcn)
 1549      const char *name;
 1550      int type;
 1551      SCM (*fcn)();
 1552 {
 1553     return CDR(sysintern(name, scm_maksubr(name, type, fcn)));
 1554 }
 1555 
 1556 #ifdef CCLO
 1557 char s_comp_clo[] = "compiled-closure";
 1558 SCM makcclo(proc, len)
 1559      SCM proc;
 1560      long len;
 1561 {
 1562   SCM s;
 1563 # ifndef SHORT_SIZET
 1564   ASRTER(len < (((unsigned long)-1L)>>16), UNDEFINED, NALLOC, s_comp_clo);
 1565 # endif
 1566   DEFER_INTS;
 1567   s = must_malloc_cell(len*sizeof(SCM), MAKE_NUMDIGS(len, tc16_cclo),
 1568                s_comp_clo);
 1569   while (--len) VELTS(s)[len] = UNSPECIFIED;
 1570   CCLO_SUBR(s) = proc;
 1571   ALLOW_INTS;
 1572   return s;
 1573 }
 1574 #endif
 1575 
 1576 void stack_check()
 1577 {
 1578   STACKITEM *start = CONT(rootcont)->stkbse;
 1579   STACKITEM stack;
 1580 #ifdef STACK_GROWS_UP
 1581   if (&stack - start > STACK_LIMIT/sizeof(STACKITEM))
 1582 #else
 1583   if (start - &stack > STACK_LIMIT/sizeof(STACKITEM))
 1584 #endif /* def STACK_GROWS_UP */
 1585     {
 1586       stack_report();
 1587       wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack");
 1588     }
 1589 }
 1590 
 1591 void stack_report()
 1592 {
 1593   STACKITEM stack;
 1594   lputs(";; stack: 0x", cur_errp);
 1595   scm_intprint((long)CONT(rootcont)->stkbse, -16, cur_errp);
 1596   lputs(" - 0x", cur_errp);
 1597   scm_intprint((long)&stack, -16, cur_errp);
 1598   lputs("; ", cur_errp);
 1599   scm_intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 10, cur_errp);
 1600   lputs(" bytes\n", cur_errp);
 1601 }
 1602 
 1603 SCM dynwind(thunk1, thunk2, thunk3)
 1604      SCM thunk1, thunk2, thunk3;
 1605 {
 1606   SCM ans;
 1607   apply(thunk1, EOL, EOL);
 1608   dynwinds = acons(thunk1, thunk3, dynwinds);
 1609   ans = apply(thunk2, EOL, EOL);
 1610   dynwinds = CDR(dynwinds);
 1611   apply(thunk3, EOL, EOL);
 1612   return ans;
 1613 }
 1614 void downd(to, delta)
 1615      SCM to;
 1616      long delta;
 1617 {
 1618  tail:
 1619   if (dynwinds==to);
 1620   else if (0 > delta) {
 1621     downd(CDR(to), 1+delta);
 1622     apply(CAR(CAR(to)), EOL, EOL);
 1623     dynwinds = to;
 1624   }
 1625   else {
 1626     SCM from = CDR(CAR(dynwinds));
 1627     dynwinds = CDR(dynwinds);
 1628     apply(from, EOL, EOL);
 1629     delta--; goto tail;     /* downd(to, delta-1); */
 1630   }
 1631 }
 1632 void dowinds(to)
 1633      SCM to;
 1634 {
 1635   downd(to,  ilength(dynwinds) - ilength(to));
 1636 }
 1637 
 1638 /* Remember that setjump needs to be called after scm_make_cont */
 1639 
 1640 SCM scm_make_cont()
 1641 {
 1642   SCM cont, estk, *from;
 1643   CONTINUATION *ncont;
 1644   sizet n;
 1645   VERIFY_INTS("scm_make_cont", 0L);
 1646   NEWCELL(cont);
 1647   from = VELTS(scm_estk);
 1648   n = scm_estk_ptr - from + SCM_ESTK_FRLEN;
 1649 #ifdef CHEAP_CONTINUATIONS
 1650   estk = scm_estk;
 1651 #else
 1652   from[1] = BOOL_F;     /* Can't write to parent stack */
 1653   estk = must_malloc_cell((long)n*sizeof(SCM),
 1654               MAKE_LENGTH(n, tc7_vector), s_cont);
 1655   {
 1656     SCM *to = VELTS(estk);
 1657     while(n--) to[n] = from[n];
 1658   }
 1659 #endif
 1660   ncont = make_continuation(CONT(rootcont));
 1661   if (!ncont) wta(MAKINUM(-1), (char *)NALLOC, s_cont);
 1662   ncont->other.parent = rootcont;
 1663   SETCONT(cont, ncont);
 1664   SETLENGTH(cont, ncont->length, tc7_contin);
 1665   ncont->other.dynenv = dynwinds;
 1666   ncont->other.stkframe[0] = scm_env;
 1667   ncont->other.stkframe[1] = scm_env_tmp;
 1668   ncont->other.estk = estk;
 1669 #ifdef CHEAP_CONTINUATIONS
 1670   ncont->other.estk_ptr = scm_estk_ptr;
 1671 #else
 1672   ncont->other.estk_ptr = (SCM *)0;
 1673 #endif
 1674 #ifndef RECKLESS
 1675   ncont->other.stkframe[2] = scm_trace_env;
 1676   ncont->other.stkframe[3] = scm_trace;
 1677 #endif
 1678   return cont;
 1679 }
 1680 static char s_sstale[] = "strangely stale";
 1681 void scm_dynthrow(tocont, arg1, arg2, rest)
 1682      SCM tocont;
 1683      SCM arg1, arg2, rest;
 1684 {
 1685   CONTINUATION *cont = CONT(tocont);
 1686   if (cont->stkbse != CONT(rootcont)->stkbse)
 1687     wta(tocont, &s_sstale[10], s_cont);
 1688   dowinds(cont->other.dynenv);
 1689   {
 1690     DEFER_INTS;
 1691 #ifdef CHEAP_CONTINUATIONS
 1692     scm_estk = cont->other.estk;
 1693     scm_estk_ptr = cont->other.estk_ptr;
 1694 #else
 1695     {
 1696       SCM *to, *from =  VELTS(cont->other.estk);
 1697       sizet n = LENGTH(cont->other.estk);
 1698       if (LENGTH(scm_estk) < n) scm_estk_reset(n);
 1699       to = VELTS(scm_estk);
 1700       scm_estk_ptr = &(to[n - SCM_ESTK_FRLEN]);
 1701       while(n--) to[n] = from[n];
 1702     }
 1703 #endif
 1704     scm_env = cont->other.stkframe[0];
 1705     scm_env_tmp = cont->other.stkframe[1];
 1706 #ifndef RECKLESS
 1707     scm_trace_env = cont->other.stkframe[2];
 1708     scm_trace = cont->other.stkframe[3];
 1709 #endif
 1710     if (!UNBNDP(arg2) && IM_VALUES_TOKEN == scm_env_tmp) {
 1711       scm_env_cons(arg2, rest);
 1712       arg2 = UNDEFINED;
 1713     }
 1714     ALLOW_INTS;
 1715   }
 1716   if (!UNBNDP(arg2)) return;    /* eval will signal wrong number of args */
 1717   throw_to_continuation(cont, arg1, CONT(rootcont));
 1718   wta(tocont, s_sstale, s_cont);
 1719 }
 1720 
 1721 SCM obhash(obj)
 1722      SCM obj;
 1723 {
 1724 
 1725 #ifdef BIGDIG
 1726   long n = SRS(obj, 1);
 1727   if (!FIXABLE(n)) return long2big(n);
 1728 #endif
 1729   return (obj<<1)+2L;
 1730 }
 1731 
 1732 SCM obunhash(obj)
 1733      SCM obj;
 1734 {
 1735 #ifdef BIGDIG
 1736   if (NIMP(obj) && BIGP(obj)) {
 1737     sizet i = NUMDIGS(obj);
 1738     BIGDIG *ds = BDIGITS(obj);
 1739     if (TYP16(obj)==tc16_bigpos) {
 1740       obj = 0;
 1741       while (i--) obj = BIGUP(obj) + ds[i];
 1742     }
 1743     else {
 1744       obj = 0;
 1745       while (i--) obj = BIGUP(obj) - ds[i];
 1746     }
 1747     obj <<= 1;
 1748     goto comm;
 1749   }
 1750 #endif
 1751   ASRTER(INUMP(obj), obj, ARG1, s_obunhash);
 1752   obj = SRS(obj, 1) & ~1L;
 1753 comm:
 1754   if (IMP(obj)) return obj;
 1755   if (NCELLP(obj)) return BOOL_F;
 1756   {
 1757     /* This code is adapted from mark_locations() in "sys.c" and
 1758        scm_cell_p() in "rope.c", which means that changes to these
 1759        routines must be coordinated. */
 1760     register CELLPTR ptr = (CELLPTR)SCM2PTR(obj);
 1761     register sizet i = 0, j = hplim_ind;
 1762     do {
 1763       if (PTR_GT(hplims[i++], ptr)) break;
 1764       if (PTR_LE(hplims[--j], ptr)) break;
 1765       if ((i != j)
 1766       && PTR_LE(hplims[i++], ptr)
 1767       && PTR_GT(hplims[--j], ptr)) continue;
 1768       if (NFREEP(obj)) return obj;
 1769       break;
 1770     } while(i<j);
 1771   }
 1772   return BOOL_F;
 1773 }
 1774 
 1775 unsigned long strhash(str, len, n)
 1776      unsigned char *str;
 1777      sizet len;
 1778      unsigned long n;
 1779 {
 1780   if (len>5)
 1781     {
 1782       sizet i = 5;
 1783       unsigned long h = 264 % n;
 1784       while (i--) h = ((h<<8) + ((unsigned)(downcase[str[h % len]]))) % n;
 1785       return h;
 1786     }
 1787   else {
 1788     sizet i = len;
 1789     unsigned long h = 0;
 1790     while (i) h = ((h<<8) + ((unsigned)(downcase[str[--i]]))) % n;
 1791     return h;
 1792   }
 1793 }
 1794 
 1795 static void fixconfig(s1, s2, s)
 1796      char *s1, *s2;
 1797      int s;
 1798 {
 1799   fputs(s1, stderr);
 1800   fputs(s2, stderr);
 1801   fputs("\nin ", stderr);
 1802   fputs(s ? "setjump" : "scmfig", stderr);
 1803   fputs(".h and recompile scm\n", stderr);
 1804   quit(MAKINUM(1L));
 1805 }
 1806 
 1807 void heap_report()
 1808 {
 1809   sizet i = 0;
 1810   if (hplim_ind) lputs("; heap segments:", sys_errp);
 1811   while(i < hplim_ind) {
 1812     {
 1813       long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]);
 1814       lputs("\n; 0x", sys_errp);
 1815       scm_intprint((long)hplims[i++], -16, sys_errp);
 1816       lputs(" - 0x", sys_errp);
 1817       scm_intprint((long)hplims[i++], -16, sys_errp);
 1818       lputs("; ", sys_errp);
 1819       scm_intprint(seg_cells, 10, sys_errp);
 1820       lputs(" cells; ", sys_errp);
 1821       scm_intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp);
 1822       lputs(".kiB", sys_errp);
 1823     }}
 1824 }
 1825 sizet init_heap_seg(seg_org, size)
 1826      CELLPTR seg_org;
 1827      sizet size;
 1828 {
 1829   register CELLPTR ptr = seg_org;
 1830 #ifdef POINTERS_MUNGED
 1831   register SCM scmptr;
 1832 #else
 1833 # define scmptr ptr
 1834 #endif
 1835   CELLPTR seg_end = CELL_DN((char *)ptr + size);
 1836   sizet i = hplim_ind, ni = 0;
 1837   if (ptr==NULL) return 0;
 1838   while((ni < hplim_ind) && PTR_LE(hplims[ni], seg_org)) ni++;
 1839   while(i-- > ni) hplims[i+2] = hplims[i];
 1840   hplim_ind += 2;
 1841   hplims[ni++] = ptr;       /* same as seg_org here */
 1842   hplims[ni++] = seg_end;
 1843   ptr = CELL_UP(ptr);
 1844   ni = seg_end - ptr;
 1845 /* printf("ni = %u; hplim_ind = %u\n", ni, hplim_ind); */
 1846 /* printf("ptr = %lx\n", ptr); */
 1847   for (i = ni;i--;ptr++) {
 1848 #ifdef POINTERS_MUNGED
 1849     scmptr = PTR2SCM(ptr);
 1850 #endif
 1851     CAR(scmptr) = (SCM)tc_free_cell;
 1852     CDR(scmptr) = PTR2SCM(ptr+1);
 1853   }
 1854 /*  CDR(scmptr) = freelist; */
 1855   CDR(PTR2SCM(--ptr)) = freelist;
 1856   freelist = PTR2SCM(CELL_UP(seg_org));
 1857   heap_cells += ni;
 1858   return size;
 1859 #ifdef scmptr
 1860 # undef scmptr
 1861 #endif
 1862 }
 1863 static void alloc_some_heap()
 1864 {
 1865   CELLPTR ptr, *tmplims;
 1866   sizet len = (2+hplim_ind)*sizeof(CELLPTR);
 1867   ASRTGO(len==(2+hplim_ind)*sizeof(CELLPTR), badhplims);
 1868   if (errjmp_bad) wta(UNDEFINED, "need larger initial", s_heap);
 1869   tmplims = (CELLPTR *)must_realloc((char *)hplims,
 1870                     len-2L*sizeof(CELLPTR), (long)len,
 1871                     s_heap);
 1872   /*  SYSCALL(tmplims = (CELLPTR *)realloc((char *)hplims, len);); */
 1873   if (!tmplims)
 1874 badhplims:
 1875     wta(UNDEFINED, s_nogrow, s_hplims);
 1876   else hplims = tmplims;
 1877   /* hplim_ind gets incremented in init_heap_seg() */
 1878   if (expmem) {
 1879     len = (sizet)(EXPHEAP(heap_cells)*sizeof(cell));
 1880     if ((sizet)(EXPHEAP(heap_cells)*sizeof(cell)) != len) len = 0;
 1881   }
 1882   else len = HEAP_SEG_SIZE;
 1883   while (len >= MIN_HEAP_SEG_SIZE) {
 1884     SYSCALL(ptr = (CELLPTR) malloc(len););
 1885     if (ptr) {
 1886       init_heap_seg(ptr, len);
 1887       return;
 1888     }
 1889     len /= 2;
 1890   }
 1891   wta(UNDEFINED, s_nogrow, s_heap);
 1892 }
 1893 
 1894 /* Initialize a Growable arRAy, of initial size LEN, growing to at most
 1895    MAXLEN elements of size ELTSIZE */
 1896 void scm_init_gra(gra, eltsize, len, maxlen, what)
 1897      scm_gra *gra;
 1898      sizet eltsize, len, maxlen;
 1899      const char *what;
 1900 {
 1901   char *nelts;
 1902   /* DEFER_INTS; */
 1903   /* Can't call must_malloc, because heap may not be initialized yet. */
 1904   /*  SYSCALL(nelts = malloc(len*eltsize););
 1905       if (!nelts) wta(MAKINUM(len*eltsize), (char *)NALLOC, what);
 1906       mallocated += len*eltsize;
 1907   */
 1908   nelts = must_malloc((long)len*eltsize, what);
 1909   gra->eltsize = eltsize;
 1910   gra->len = 0;
 1911   gra->elts = nelts;
 1912   gra->alloclen = len;
 1913   gra->maxlen = maxlen;
 1914   gra->what = what;
 1915   /* ALLOW_INTS; */
 1916 }
 1917 /* Returns the index into the elt array */
 1918 int scm_grow_gra(gra, elt)
 1919      scm_gra *gra;
 1920      char *elt;
 1921 {
 1922   int i;
 1923   char *tmp;
 1924   if (gra->alloclen <= gra->len) {
 1925     sizet inc = gra->len / 5 + 1;
 1926     sizet nlen = gra->len + inc;
 1927     if (gra->maxlen && nlen > gra->maxlen)
 1928       /* growerr: */ wta(MAKINUM(nlen), (char *)NALLOC, gra->what);
 1929     /*
 1930       SYSCALL(tmp = realloc(gra->elts, nlen*gra->eltsize););
 1931       if (!tmp) goto growerr;
 1932       mallocated += (nlen - gra->alloclen)*gra->eltsize;
 1933     */
 1934     tmp = must_realloc(gra->elts, (long)gra->alloclen*gra->eltsize,
 1935                (long)nlen*gra->eltsize, gra->what);
 1936     gra->elts = tmp;
 1937     gra->alloclen = nlen;
 1938   }
 1939   tmp = &gra->elts[gra->len*gra->eltsize];
 1940   gra->len += 1;
 1941   for (i = 0; i < gra->eltsize; i++)
 1942     tmp[i] = elt[i];
 1943   return gra->len - 1;
 1944 }
 1945 void scm_trim_gra(gra)
 1946      scm_gra *gra;
 1947 {
 1948   char *tmp;
 1949   long curlen = gra->len;
 1950   if (0L==curlen) curlen = 1L;
 1951   if (curlen==(long)gra->alloclen) return;
 1952   tmp = must_realloc(gra->elts,
 1953              (long)gra->alloclen * gra->eltsize,
 1954              curlen * gra->eltsize,
 1955              gra->what);
 1956   gra->elts = tmp;
 1957   gra->alloclen = curlen;
 1958 }
 1959 void scm_free_gra(gra)
 1960      scm_gra *gra;
 1961 {
 1962   free(gra->elts);
 1963   gra->elts = 0;
 1964   mallocated -= gra->maxlen*gra->eltsize;
 1965 }
 1966 void gra_report1(gra)
 1967      scm_gra *gra;
 1968 {
 1969   scm_intprint((long)gra->len, -10, cur_errp);
 1970   lputs(" (of ", cur_errp);
 1971   scm_intprint((long)gra->alloclen, -10, cur_errp);
 1972   lputs(") ", cur_errp);
 1973   lputs(gra->what, cur_errp);
 1974   lputs("; ", cur_errp);
 1975 }
 1976 void gra_report()
 1977 {
 1978   lputs(";; gra: ", cur_errp);
 1979   gra_report1(&ptobs_gra);
 1980   gra_report1(&smobs_gra);
 1981   gra_report1(&finals_gra);
 1982   gra_report1(&subrs_gra);
 1983   lputs("\n", cur_errp);
 1984 }
 1985 
 1986 scm_gra smobs_gra;
 1987 long newsmob(smob)
 1988      smobfuns *smob;
 1989 {
 1990   return tc7_smob + 256*scm_grow_gra(&smobs_gra, (char *)smob);
 1991 }
 1992 scm_gra ptobs_gra;
 1993 long newptob(ptob)
 1994      ptobfuns *ptob;
 1995 {
 1996   return tc7_port + 256*scm_grow_gra(&ptobs_gra, (char *)ptob);
 1997 }
 1998 port_info *scm_port_table = 0;
 1999 static sizet scm_port_table_len = 0;
 2000 static char s_port_table[] = "port table";
 2001 SCM scm_port_entry(stream, ptype, flags)
 2002      FILE *stream;
 2003      long ptype, flags;
 2004 {
 2005   SCM z;
 2006   sizet nlen;
 2007   int i, j;
 2008   VERIFY_INTS("scm_port_entry", 0L);
 2009   flags = flags | (ptype & ~0xffffL);
 2010   ASRTER(flags, INUM0, ARG1, "scm_port_entry");
 2011   for (i = 1; i < scm_port_table_len; i++)
 2012     if (0L==scm_port_table[i].flags) goto ret;
 2013   if (scm_port_table_len <= SCM_PORTNUM_MAX) {
 2014     nlen = scm_port_table_len + (scm_port_table_len / 2);
 2015     if (nlen >= SCM_PORTNUM_MAX) nlen = (sizet)SCM_PORTNUM_MAX + 1;
 2016     scm_port_table = (port_info *)
 2017       must_realloc((char *)scm_port_table,
 2018            (long)scm_port_table_len * sizeof(port_info),
 2019            (long)nlen * sizeof(port_info),
 2020            s_port_table);
 2021     scm_port_table_len = nlen;
 2022     growth_mon(s_port_table, nlen + 0L, "entries", !0);
 2023     for (j = i; j < scm_port_table_len; j++) {
 2024       scm_port_table[j].flags = 0L;
 2025       scm_port_table[j].data = UNDEFINED;
 2026       scm_port_table[j].port = UNDEFINED;
 2027     }
 2028   }
 2029   else {
 2030     igc(s_port_table, rootcont);
 2031     for (i = 0; i < scm_port_table_len; i++)
 2032       if (0L==scm_port_table[i].flags) goto ret;
 2033     wta(UNDEFINED, s_nogrow, s_port_table);
 2034   }
 2035  ret:
 2036   NEWCELL(z);
 2037   SETSTREAM(z, stream);
 2038   CAR(z) = (((long)i)<<20) | (flags & 0x0f0000) | ptype;
 2039   scm_port_table[i].unread = EOF;
 2040   scm_port_table[i].flags = flags;
 2041   scm_port_table[i].line = 1L;  /* should both be one-based? */
 2042   scm_port_table[i].col = 1;
 2043   scm_port_table[i].data = UNSPECIFIED;
 2044   scm_port_table[i].port = z;
 2045   return z;
 2046 }
 2047 SCM scm_open_ports()
 2048 {
 2049   SCM p, res = EOL;
 2050   int k;
 2051   for (k = scm_port_table_len - 1; k > 0; k--) {
 2052     p = scm_port_table[k].port;
 2053     if (NIMP(p) && OPPORTP(p))
 2054       res = cons(p, res);
 2055   }
 2056   return res;
 2057 }
 2058 
 2059 SCM markcdr(ptr)
 2060      SCM ptr;
 2061 {
 2062   return CDR(ptr);
 2063 }
 2064 sizet free0(ptr)
 2065      CELLPTR ptr;
 2066 {
 2067   return 0;
 2068 }
 2069 SCM equal0(ptr1, ptr2)
 2070      SCM ptr1, ptr2;
 2071 {
 2072   return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F;
 2073 }
 2074 
 2075 static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ",
 2076   rdmsg[] = "reduce";
 2077 void init_storage(stack_start_ptr, init_heap_size)
 2078      STACKITEM *stack_start_ptr;
 2079      long init_heap_size;
 2080 {
 2081     sizet j;
 2082     /* Because not all protects may get initialized */
 2083     freelist = EOL;
 2084     expmem = 0;
 2085     estk_pool = EOL;
 2086     scm_estk = BOOL_F;
 2087     scm_port_table = 0;
 2088     scm_port_table_len = 0;
 2089     no_symhash_gc =
 2090 #ifdef NO_SYM_GC
 2091       !0           /* Hobbit-compiled code must not GC symhash. */
 2092 #else
 2093       0
 2094 #endif
 2095       ;
 2096 
 2097 #ifdef SHORT_SIZET
 2098     if (sizeof(sizet) >= sizeof(long))
 2099       fixconfig(remsg, "SHORT_SIZET", 0);
 2100 #else
 2101     if (sizeof(sizet) < sizeof(long))
 2102       fixconfig(addmsg, "SHORT_SIZET", 0);
 2103 #endif
 2104 #ifdef SHORT_INT
 2105     if (sizeof(int) >= sizeof(long))
 2106       fixconfig(remsg, "SHORT_INT", 0);
 2107 #else
 2108     if (sizeof(int) < sizeof(long))
 2109       fixconfig(addmsg, "SHORT_INT", 0);
 2110 #endif
 2111 #ifdef CDR_DOUBLES
 2112     if (sizeof(double) != sizeof(long))
 2113       fixconfig(remsg, "CDR_DOUBLES", 0);
 2114 #else
 2115 # ifdef SINGLES
 2116     if (sizeof(float) != sizeof(long)) {
 2117       if (sizeof(double) == sizeof(long))
 2118         fixconfig(addmsg, "CDR_DOUBLES", 0);
 2119       else
 2120         fixconfig(remsg, "SINGLES", 0);
 2121     }
 2122 # endif
 2123 #endif
 2124 #ifdef BIGDIG
 2125     if (2*BITSPERDIG/CHAR_BIT > sizeof(long))
 2126       fixconfig(remsg, "BIGDIG", 0);
 2127 # ifndef DIGSTOOBIG
 2128     if (DIGSPERLONG*sizeof(BIGDIG) > sizeof(long))
 2129       fixconfig(addmsg, "DIGSTOOBIG", 0);
 2130 # endif
 2131     if (NUMDIGS_MAX > (((unsigned long)-1L)>>16))
 2132       fixconfig(rdmsg, "NUMDIGS_MAX", 0);
 2133 #endif
 2134 #ifdef STACK_GROWS_UP
 2135     if (((STACKITEM *)&j - stack_start_ptr) < 0)
 2136       fixconfig(remsg, "STACK_GROWS_UP", 1);
 2137 #else
 2138     if ((stack_start_ptr - (STACKITEM *)&j) < 0)
 2139       fixconfig(addmsg, "STACK_GROWS_UP", 1);
 2140 #endif
 2141     j = HEAP_SEG_SIZE;
 2142     if (HEAP_SEG_SIZE != j)
 2143       fixconfig(rdmsg, "size of HEAP_SEG_SIZE", 0);
 2144 
 2145     mtrigger = INIT_MALLOC_LIMIT;
 2146     mltrigger = mtrigger - MIN_MALLOC_YIELD;
 2147     hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR), s_hplims);
 2148     if (0L==init_heap_size) init_heap_size = INIT_HEAP_SIZE;
 2149     j = init_heap_size;
 2150 /*      printf("j = %u; init_heap_size = %lu\n", j, init_heap_size); */
 2151     if ((init_heap_size != j) || !init_heap_seg((CELLPTR) malloc(j), j)) {
 2152       j = HEAP_SEG_SIZE;
 2153 /*        printf("j = %u; HEAP_SEG_SIZE = %lu\n", j, HEAP_SEG_SIZE); */
 2154       if (!init_heap_seg((CELLPTR) malloc(j), j))
 2155         wta(MAKINUM(j), (char *)NALLOC, s_heap);
 2156     }
 2157     else expmem = 1;
 2158     heap_org = CELL_UP(hplims[0]);
 2159         /* hplims[0] can change. do not remove heap_org */
 2160 
 2161     scm_port_table_len = 16;
 2162     scm_port_table = (port_info *)
 2163       must_malloc((long)scm_port_table_len * sizeof(port_info), s_port_table);
 2164     for (j = 0; j < scm_port_table_len; j++) {
 2165       scm_port_table[j].flags = 0L;
 2166       scm_port_table[j].data = UNDEFINED;
 2167       scm_port_table[j].port = UNDEFINED;
 2168     }
 2169 
 2170     nullstr = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_string), s_string);
 2171     CHARS(nullstr)[0] = 0;
 2172     nullvect = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_vector), s_vector);
 2173     {
 2174       long i = symhash_dim;
 2175       SCM *velts;
 2176       symhash = must_malloc_cell(i * sizeof(SCM),
 2177                      MAKE_LENGTH(i, tc7_vector),
 2178                      s_vector);
 2179       velts = VELTS(symhash);
 2180       while(--i >= 0) (velts)[i] = EOL;
 2181     }
 2182     /* Now that symhash is setup, we can sysintern() */
 2183     sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM));
 2184     sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM));
 2185 #ifdef BIGDIG
 2186     sysintern("bignum-radix", MAKINUM(BIGRAD));
 2187 #endif
 2188     def_inp = scm_port_entry(stdin, tc16_fport, OPN|RDNG);
 2189     SCM_PORTDATA(def_inp) = CAR(sysintern("stdin", UNDEFINED));
 2190     def_outp = scm_port_entry(stdout, tc16_fport, OPN|WRTNG|TRACKED);
 2191     SCM_PORTDATA(def_outp) = CAR(sysintern("stdout", UNDEFINED));
 2192     NEWCELL(def_errp);
 2193     CAR(def_errp) = (tc16_fport|OPN|WRTNG);
 2194     SETSTREAM(def_errp, stderr);
 2195     cur_inp = def_inp;
 2196     cur_outp = def_outp;
 2197     cur_errp = def_errp;
 2198     NEWCELL(sys_errp);
 2199     CAR(sys_errp) = (tc16_sysport|OPN|WRTNG);
 2200     SETSTREAM(sys_errp, 0);
 2201     sys_safep = mksafeport(0, def_errp);
 2202     dynwinds = EOL;
 2203     NEWCELL(rootcont);
 2204     SETCONT(rootcont, make_root_continuation(stack_start_ptr));
 2205     CAR(rootcont) = tc7_contin;
 2206     CONT(rootcont)->other.dynenv = EOL;
 2207     CONT(rootcont)->other.parent = BOOL_F;
 2208     listofnull = cons(EOL, EOL);
 2209     undefineds = cons(UNDEFINED, EOL);
 2210     CDR(undefineds) = undefineds;
 2211     /* flo0 is now setup in scl.c */
 2212     /* Set up environment cache */
 2213     scm_ecache_len = sizeof(ecache_v)/sizeof(cell);
 2214     scm_ecache = CELL_UP(ecache_v);
 2215     scm_ecache_len = CELL_DN(ecache_v + scm_ecache_len - 1) - scm_ecache + 1;
 2216     scm_ecache_index = scm_ecache_len;
 2217     scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
 2218     scm_estk = BOOL_F;
 2219     scm_estk_reset(0);
 2220 }
 2221 
 2222 /* The way of garbage collecting which allows use of the cstack is due to */
 2223 /* Scheme In One Defun, but in C this time.
 2224 
 2225  *            COPYRIGHT (c) 1989 BY                 *
 2226  *    PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
 2227  *             ALL RIGHTS RESERVED                  *
 2228 
 2229 Permission to use, copy, modify, distribute and sell this software
 2230 and its documentation for any purpose and without fee is hereby
 2231 granted, provided that the above copyright notice appear in all copies
 2232 and that both that copyright notice and this permission notice appear
 2233 in supporting documentation, and that the name of Paradigm Associates
 2234 Inc not be used in advertising or publicity pertaining to distribution
 2235 of the software without specific, written prior permission.
 2236 
 2237 PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
 2238 ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
 2239 PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
 2240 ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
 2241 WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
 2242 ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
 2243 SOFTWARE.
 2244 
 2245 gjc@paradigm.com
 2246 
 2247 Paradigm Associates Inc      Phone: 617-492-6079
 2248 29 Putnam Ave, Suite 6
 2249 Cambridge, MA 02138
 2250 */
 2251 char s_cells[] = "cells";
 2252 SCM gc_for_newcell()
 2253 {
 2254     SCM fl;
 2255     int oints = ints_disabled; /* Temporary expedient */
 2256     if (!oints) ints_disabled = 1;
 2257     igc(s_cells, rootcont);
 2258     if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) {
 2259       alloc_some_heap();
 2260       growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, !0);
 2261       growth_mon(s_heap, heap_cells, s_cells, !0);
 2262     }
 2263     ++cells_allocated;
 2264     fl = freelist;
 2265     freelist = CDR(fl);
 2266     ints_disabled = oints;
 2267     return fl;
 2268 }
 2269 
 2270 void gc_for_open_files()
 2271 {
 2272   igc("open files", rootcont);
 2273 }
 2274 
 2275 void scm_fill_freelist()
 2276 {
 2277   while IMP(freelist) {
 2278     igc(s_cells, rootcont);
 2279     if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) {
 2280       alloc_some_heap();
 2281       growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, !0);
 2282       growth_mon(s_heap, heap_cells, s_cells, !0);
 2283     }
 2284   }
 2285 }
 2286 
 2287 static char s_bad_type[] = "unknown type in ";
 2288 void mark_locations P((STACKITEM x[], sizet n));
 2289 static void mark_syms P((SCM v));
 2290 static void mark_sym_values P((SCM v));
 2291 static void mark_subrs P((void));
 2292 static void sweep_symhash P((SCM v));
 2293 static void mark_finalizers P((SCM *live, SCM *dead));
 2294 static void mark_port_table P((SCM port));
 2295 static void sweep_port_table P((void));
 2296 static void egc_mark P((void));
 2297 static void egc_sweep P((void));
 2298 
 2299 SCM gc(arg)
 2300      SCM arg;
 2301 {
 2302   DEFER_INTS;
 2303   if (UNBNDP(arg))
 2304     igc("call", rootcont);
 2305   else
 2306     scm_egc();
 2307   ALLOW_INTS;
 2308   return UNSPECIFIED;
 2309 }
 2310 
 2311 void scm_run_finalizers(exiting)
 2312      int exiting;
 2313 {
 2314   SCM f;
 2315   if (exiting) {        /* run all finalizers, we're going home. */
 2316     DEFER_INTS;
 2317     while NIMP(gc_finalizers) {
 2318       f = CAR(gc_finalizers);
 2319       CAR(f) = CDR(f);
 2320       CDR(f) = gc_finalizers_pending;
 2321       gc_finalizers_pending = f;
 2322       gc_finalizers = CDR(gc_finalizers);
 2323     }
 2324     ALLOW_INTS;
 2325   }
 2326   while (!0) {
 2327     DEFER_INTS;
 2328     if (NIMP(gc_finalizers_pending)) {
 2329       f = CAR(gc_finalizers_pending);
 2330       gc_finalizers_pending = CDR(gc_finalizers_pending);
 2331     }
 2332     else f = BOOL_F;
 2333     ALLOW_INTS;
 2334     if (IMP(f)) break;
 2335     apply(f, EOL, EOL);
 2336   }
 2337 }
 2338 
 2339 static SCM *loc_gc_hook = 0;
 2340 void scm_gc_hook ()
 2341 {
 2342   if (gc_hook_active) {
 2343     scm_warn("gc-hook thrashing?\n", "", UNDEFINED);
 2344     return;
 2345   }
 2346   gc_hook_active = !0;
 2347   if (! loc_gc_hook) loc_gc_hook = &CDR(sysintern("gc-hook", UNDEFINED));
 2348   if (NIMP(*loc_gc_hook)) apply(*loc_gc_hook, EOL, EOL);
 2349   scm_run_finalizers(0);
 2350   gc_hook_active = 0;
 2351 }
 2352 
 2353 void igc(what, basecont)
 2354      const char *what;
 2355      SCM basecont;
 2356 {
 2357   int j = num_protects;
 2358   long oheap_cells = heap_cells;
 2359   STACKITEM * stackbase = IMP(basecont) ? 0 : CONT(basecont)->stkbse;
 2360 #ifdef DEBUG_GMALLOC
 2361   int err = check_frag_blocks();
 2362   if (err) wta(MAKINUM(err), "malloc corrupted", what);
 2363 #endif
 2364   gc_start(what);
 2365   if (errjmp_bad) wta(UNDEFINED, s_recursive, s_gc);
 2366   errjmp_bad = s_gc;
 2367   if (no_symhash_gc)        /* Hobbit-compiled code needs this. */
 2368     gc_mark(symhash);
 2369   else {
 2370     /* By marking symhash first, we provide the best immunity from
 2371        accidental references.  In order to accidentally protect a
 2372        symbol, a pointer will have to point directly at the symbol (as
 2373        opposed to the vector or bucket lists).  */
 2374     mark_syms(symhash);
 2375     /* mark_sym_values() can be called anytime after mark_syms.  */
 2376     mark_sym_values(symhash);
 2377   }
 2378   mark_subrs();
 2379   egc_mark();
 2380   if (stackbase) {
 2381 #ifdef __ia64__
 2382     mark_regs_ia64(CONT(basecont));
 2383 #else
 2384     jump_buf save_regs_gc_mark;
 2385     FLUSH_REGISTER_WINDOWS;
 2386     /* This assumes that all registers are saved into the jump_buf */
 2387     setjump(save_regs_gc_mark);
 2388     mark_locations((STACKITEM *) save_regs_gc_mark,
 2389            (sizet) (sizeof(STACKITEM) - 1 + sizeof save_regs_gc_mark) /
 2390            sizeof(STACKITEM));
 2391     {
 2392       /* stack_len is long rather than sizet in order to guarantee that
 2393      &stack_len is long aligned */
 2394 # ifdef STACK_GROWS_UP
 2395 #  ifdef nosve
 2396       long stack_len = (STACKITEM *)(&stack_len) - stackbase;
 2397 #  else
 2398       long stack_len = stack_size(stackbase);
 2399 #  endif
 2400       mark_locations(stackbase, (sizet)stack_len);
 2401 # else
 2402 #  ifdef nosve
 2403       long stack_len = stackbase - (STACKITEM *)(&stack_len);
 2404 #  else
 2405       long stack_len = stack_size(stackbase);
 2406 #  endif
 2407       mark_locations((stackbase - stack_len), (sizet)stack_len);
 2408 # endif
 2409     }
 2410 #endif
 2411   }
 2412   while(j--)
 2413     gc_mark(sys_protects[j]);
 2414   mark_finalizers(&gc_finalizers, &gc_finalizers_pending);
 2415   if (!no_symhash_gc)       /* if not Hobbit-compiled code. */
 2416     sweep_symhash(symhash);
 2417   gc_sweep(!stackbase);
 2418   sweep_port_table();
 2419   egc_sweep();
 2420   estk_pool = EOL;
 2421   errjmp_bad = (char *)0;
 2422   gc_end();
 2423   if (oheap_cells != heap_cells) {
 2424     int grewp = heap_cells > oheap_cells;
 2425     growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, grewp);
 2426     growth_mon(s_heap, heap_cells, s_cells, grewp);
 2427   }
 2428   gc_hook_pending = !0;
 2429   deferred_proc = process_signals;
 2430 }
 2431 
 2432 static char s_not_free[] = "not freed";
 2433 void free_storage()
 2434 {
 2435   DEFER_INTS;
 2436   loc_gc_hook = (SCM *)0;
 2437   gc_start("free");
 2438   errjmp_bad = "free_storage";
 2439   cur_inp = BOOL_F; cur_outp = BOOL_F;
 2440   cur_errp = tmp_errp; sys_errp = tmp_errp;
 2441   gc_mark(def_inp);     /* don't want to close stdin */
 2442   gc_mark(def_outp);        /* don't want to close stdout */
 2443   gc_mark(def_errp);        /* don't want to close stderr */
 2444   gc_sweep(0);
 2445   rootcont = BOOL_F;
 2446   while (hplim_ind) {       /* free heap segments */
 2447     hplim_ind -= 2;
 2448     {
 2449       CELLPTR ptr = CELL_UP(hplims[hplim_ind]);
 2450       sizet seg_cells = CELL_DN(hplims[hplim_ind+1]) - ptr;
 2451       heap_cells -= seg_cells;
 2452       free((char *)hplims[hplim_ind]);
 2453       hplims[hplim_ind] = 0;
 2454       /* At this point, sys_errp is no longer valid */
 2455       /* growth_mon(s_heap, heap_cells, s_cells, 0); fflush(stderr); */
 2456     }}
 2457   if (heap_cells) wta(MAKINUM(heap_cells), s_not_free, s_heap);
 2458   if (hplim_ind) wta((SCM)MAKINUM(hplim_ind), s_not_free, s_hplims);
 2459   /* Not all cells get freed (see gc_mark() calls above). */
 2460   /* if (cells_allocated) wta(MAKINUM(cells_allocated), s_not_free, "cells"); */
 2461   /* either there is a small memory leak or I am counting wrong. */
 2462   must_free((char *)hplims, 0);
 2463   /* if (mallocated) wta(MAKINUM(mallocated), s_not_free, "malloc"); */
 2464   hplims = 0;
 2465   scm_free_gra(&finals_gra);
 2466   scm_free_gra(&smobs_gra);
 2467   scm_free_gra(&subrs_gra);
 2468   /* gc_end(); */
 2469   /* ALLOW_INTS; */ /* A really bad idea, but printing does it anyway. */
 2470   /* exit_report(); */
 2471   /* lfflush(sys_errp); */  /* This causes segfault in fc9 */
 2472   scm_free_gra(&ptobs_gra);
 2473   lmallocated = mallocated = 0;
 2474   /* Can't do gc_end() here because it uses ptobs which have been freed */
 2475   fflush(stdout);       /* in lieu of close */
 2476   fflush(stderr);       /* in lieu of close */
 2477 }
 2478 
 2479 #define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((unsigned long *)VELTS(x)) : LENGTH(x))
 2480 
 2481 /* This is used to force allocation of SCM temporaries on the stack,
 2482    it should be called with any SCM variables used for malloc headers
 2483    and entirely local to a C procedure.  */
 2484 void scm_protect_temp(ptr)
 2485      SCM *ptr;
 2486 {
 2487   return;
 2488 }
 2489 
 2490 static char s_gc_sym[] = "mark_syms", s_wrong_length[] = "wrong length";
 2491 void gc_mark(p)
 2492      SCM p;
 2493 {
 2494   register long i;
 2495   register SCM ptr = p;
 2496   CHECK_STACK;
 2497  gc_mark_loop:
 2498   if (IMP(ptr)) return;
 2499  gc_mark_nimp:
 2500   if (NCELLP(ptr)
 2501       /* #ifndef RECKLESS */
 2502       /* || PTR_GT(hplims[0], (CELLPTR)ptr) */
 2503       /* || PTR_GE((CELLPTR)ptr, hplims[hplim_ind-1]) */
 2504       /* #endif */
 2505       ) wta(ptr, "rogue pointer in ", s_heap);
 2506   switch TYP7(ptr) {
 2507   case tcs_cons_nimcar:
 2508     if (GCMARKP(ptr)) break;
 2509     SETGCMARK(ptr);
 2510     if (IMP(CDR(ptr))   /* IMP works even with a GC mark */
 2511     || (CONSP(GCCDR(ptr)) && GCMARKP(GCCDR(ptr)))
 2512     ) {
 2513       ptr = CAR(ptr);
 2514       goto gc_mark_nimp;
 2515     }
 2516     gc_mark(CAR(ptr));
 2517     ptr = GCCDR(ptr);
 2518     goto gc_mark_nimp;
 2519   case tcs_cons_imcar:
 2520   case tcs_cons_gloc:
 2521     if (GCMARKP(ptr)) break;
 2522     SETGCMARK(ptr);
 2523     ptr = GCCDR(ptr);
 2524     goto gc_mark_loop;
 2525   case tcs_closures:
 2526     if (GCMARKP(ptr)) break;
 2527     SETGCMARK(ptr);
 2528     if (IMP(GCENV(ptr))) {
 2529       ptr = CODE(ptr);
 2530       goto gc_mark_nimp;
 2531     }
 2532     gc_mark(CODE(ptr));
 2533     ptr = GCENV(ptr);
 2534     goto gc_mark_nimp;
 2535   case tc7_specfun:
 2536     if (GC8MARKP(ptr)) break;
 2537     SETGC8MARK(ptr);
 2538 #ifdef CCLO
 2539     if (tc16_cclo==GCTYP16(ptr)) {
 2540       i = CCLO_LENGTH(ptr);
 2541       if (i==0) break;
 2542       while(--i>0) if (NIMP(VELTS(ptr)[i])) gc_mark(VELTS(ptr)[i]);
 2543       ptr = VELTS(ptr)[0];
 2544     }
 2545     else
 2546 #endif
 2547       ptr = CDR(ptr);
 2548     goto gc_mark_loop;
 2549   case tc7_vector:
 2550     if (GC8MARKP(ptr)) break;
 2551     SETGC8MARK(ptr);
 2552     i = LENGTH(ptr);
 2553     if (i==0) break;
 2554     while(--i>0) if (NIMP(VELTS(ptr)[i])) gc_mark(VELTS(ptr)[i]);
 2555     ptr = VELTS(ptr)[0];
 2556     goto gc_mark_loop;
 2557   case tc7_contin:
 2558     if (GC8MARKP(ptr)) break;
 2559     SETGC8MARK(ptr);
 2560     mark_locations((STACKITEM *)VELTS(ptr),
 2561            (sizet)(LENGTH(ptr) +
 2562                (sizeof(STACKITEM) - 1 + sizeof(CONTINUATION)) /
 2563                sizeof(STACKITEM)));
 2564     break;
 2565   case tc7_string:
 2566   case tc7_msymbol:
 2567     if (GC8MARKP(ptr)) break;
 2568     ASRTER(!(CHARS(ptr)[HUGE_LENGTH(ptr)]), MAKINUM(HUGE_LENGTH(ptr)),
 2569        s_wrong_length, s_gc);
 2570   case tc7_ssymbol:
 2571   case tc7_VfixN8: case tc7_VfixZ8: case tc7_VfixZ16: case tc7_VfixN16:
 2572   case tc7_VfixZ32: case tc7_VfixN32: case tc7_VfixZ64: case tc7_VfixN64:
 2573   case tc7_VfloR32: case tc7_VfloC32: case tc7_VfloR64: case tc7_VfloC64:
 2574   case tc7_Vbool:
 2575     SETGC8MARK(ptr);
 2576   case tcs_subrs:
 2577     break;
 2578   case tc7_port:
 2579     if (GC8MARKP(ptr)) break;
 2580     SETGC8MARK(ptr);
 2581     i = PTOBNUM(ptr);
 2582     if (!(i < numptob)) goto def;
 2583     mark_port_table(ptr);
 2584     if (!ptobs[i].mark) break;
 2585     ptr = (ptobs[i].mark)(ptr);
 2586     goto gc_mark_loop;
 2587   case tc7_smob:
 2588     if (GC8MARKP(ptr)) break;
 2589     SETGC8MARK(ptr);
 2590     switch TYP16(ptr) {     /* should be faster than going through smobs */
 2591     case tc_free_cell:
 2592       /* printf("found free_cell %X ", ptr); fflush(stdout); */
 2593       ASRTER(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc);
 2594       /*      CDR(ptr) = UNDEFINED */;
 2595       break;
 2596 #ifdef BIGDIG
 2597     case tcs_bignums:
 2598       break;
 2599 #endif
 2600 #ifdef FLOATS
 2601     case tc16_flo:
 2602       break;
 2603 #endif
 2604     default:
 2605       i = SMOBNUM(ptr);
 2606       if (!(i < numsmob)) goto def;
 2607       SETGC8MARK(ptr);
 2608       if (!smobs[i].mark)  break;
 2609       ptr = (smobs[i].mark)(ptr);
 2610       goto gc_mark_loop;
 2611     }
 2612     break;
 2613   default: def: wta(ptr, s_bad_type, "gc_mark");
 2614   }
 2615 }
 2616 
 2617 /* mark_locations() marks a location pointed to by x[0:n] only if
 2618    `x[m]' is cell-aligned and points into a valid heap segment.  This
 2619    code is duplicated by obunhash() in "sys.c" and scm_cell_p() in
 2620    "rope.c", which means that changes to these routines must be
 2621    coordinated. */
 2622 
 2623 void mark_locations(x, n)
 2624      STACKITEM x[];
 2625      sizet n;
 2626 {
 2627     register long m = n;
 2628     register int i, j;
 2629     register CELLPTR ptr;
 2630     while(0 <= --m) if (CELLP(*(SCM **)&x[m])) {
 2631         ptr = (CELLPTR)SCM2PTR((SCM)(*(SCM **)&x[m]));
 2632         i = 0;
 2633         j = hplim_ind;
 2634         do {
 2635             if (PTR_GT(hplims[i++], ptr)) break;
 2636             if (PTR_LE(hplims[--j], ptr)) break;
 2637             if ((i != j)
 2638                 && PTR_LE(hplims[i++], ptr)
 2639                 && PTR_GT(hplims[--j], ptr)) continue;
 2640             /* if (NFREEP(*(SCM **)&x[m])) */ gc_mark(*(SCM *)&x[m]);
 2641             break;
 2642         } while(i<j);
 2643     }
 2644 }
 2645 
 2646 static void gc_sweep(contin_bad)
 2647      int contin_bad;
 2648 {
 2649   register CELLPTR ptr;
 2650 #ifdef POINTERS_MUNGED
 2651   register SCM scmptr;
 2652 #else
 2653 # define scmptr (SCM)ptr
 2654 #endif
 2655   register SCM nfreelist = EOL;
 2656   register long n = 0;
 2657   register sizet j, minc;
 2658   unsigned long pre_m = mallocated;
 2659   sizet i = 0;
 2660   sizet seg_cells;
 2661   while (i < hplim_ind) {
 2662     ptr = CELL_UP(hplims[i++]);
 2663     seg_cells = CELL_DN(hplims[i++]) - ptr;
 2664     for (j = seg_cells; j--; ++ptr) {
 2665 #ifdef POINTERS_MUNGED
 2666       scmptr = PTR2SCM(ptr);
 2667 #endif
 2668       switch TYP7(scmptr) {
 2669       case tcs_cons_imcar:
 2670       case tcs_cons_nimcar:
 2671       case tcs_cons_gloc:
 2672       case tcs_closures:
 2673     if (GCMARKP(scmptr)) goto cmrkcontinue;
 2674     break;
 2675       case tc7_specfun:
 2676     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2677 #ifdef CCLO
 2678     if (tc16_cclo==GCTYP16(scmptr)) {
 2679       minc = (CCLO_LENGTH(scmptr)*sizeof(SCM));
 2680       goto freechars;
 2681     }
 2682 #endif
 2683     break;
 2684       case tc7_vector:
 2685     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2686     minc = (LENGTH(scmptr)*sizeof(SCM));
 2687       freechars:
 2688     must_free(CHARS(scmptr), minc);
 2689 /*  SETCHARS(scmptr, 0);*/
 2690     break;
 2691       case tc7_Vbool:
 2692     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2693     minc = sizeof(long)*((HUGE_LENGTH(scmptr)+LONG_BIT-1)/LONG_BIT);
 2694     goto freechars;
 2695       case tc7_VfixZ32:
 2696       case tc7_VfixN32:
 2697     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2698     minc = HUGE_LENGTH(scmptr)*sizeof(long);
 2699     goto freechars;
 2700       case tc7_VfixN8:
 2701       case tc7_VfixZ8:
 2702     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2703     minc = HUGE_LENGTH(scmptr)*sizeof(char);
 2704     goto freechars;
 2705       case tc7_VfixZ16:
 2706       case tc7_VfixN16:
 2707     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2708     minc = HUGE_LENGTH(scmptr)*sizeof(short);
 2709     goto freechars;
 2710       case tc7_VfloR32:
 2711     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2712     minc = HUGE_LENGTH(scmptr)*sizeof(float);
 2713     goto freechars;
 2714       case tc7_VfloC32:
 2715     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2716     minc = HUGE_LENGTH(scmptr)*2*sizeof(float);
 2717     goto freechars;
 2718       case tc7_VfloR64:
 2719     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2720     minc = HUGE_LENGTH(scmptr)*sizeof(double);
 2721     goto freechars;
 2722       case tc7_VfloC64:
 2723     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2724     minc = HUGE_LENGTH(scmptr)*2*sizeof(double);
 2725     goto freechars;
 2726       case tc7_string:
 2727     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2728     minc = HUGE_LENGTH(scmptr)+1;
 2729     goto freechars;
 2730       case tc7_msymbol:
 2731     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2732     minc = LENGTH(scmptr)+1;
 2733     goto freechars;
 2734       case tc7_contin:
 2735     if (GC8MARKP(scmptr)) {
 2736       if (contin_bad && CONT(scmptr)->length)
 2737         scm_warn("uncollected ", "", scmptr);
 2738       goto c8mrkcontinue;
 2739     }
 2740     minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
 2741     mallocated = mallocated - minc;
 2742     free_continuation(CONT(scmptr)); break; /* goto freechars; */
 2743       case tc7_ssymbol:
 2744     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2745     /* Do not free storage because tc7_ssymbol means scmptr's
 2746            storage was not created by a call to malloc(). */
 2747     break;
 2748       case tcs_subrs:
 2749     continue;
 2750       case tc7_port:
 2751     if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2752     if (OPENP(scmptr)) {
 2753       int k = PTOBNUM(scmptr);
 2754       if (!(k < numptob)) goto sweeperr;
 2755                 /* Yes, I really do mean ptobs[k].free */
 2756                 /* rather than ptobs[k].close.  .close */
 2757                 /* is for explicit CLOSE-PORT by user */
 2758       (ptobs[k].free)(STREAM(scmptr));
 2759       gc_ports_collected++;
 2760       SETSTREAM(scmptr, 0);
 2761       CAR(scmptr) &= ~OPN;
 2762     }
 2763     break;
 2764       case tc7_smob:
 2765     switch GCTYP16(scmptr) {
 2766     case tc_free_cell:
 2767       if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2768       break;
 2769 #ifdef BIGDIG
 2770     case tcs_bignums:
 2771       if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2772       minc = (NUMDIGS(scmptr)*sizeof(BIGDIG));
 2773       goto freechars;
 2774 #endif /* def BIGDIG */
 2775 #ifdef FLOATS
 2776     case tc16_flo:
 2777       if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2778       switch ((int)(CAR(scmptr)>>16)) {
 2779       case (IMAG_PART | REAL_PART)>>16:
 2780         minc = 2*sizeof(double);
 2781         goto freechars;
 2782       case REAL_PART>>16:
 2783       case IMAG_PART>>16:
 2784         minc = sizeof(double);
 2785         goto freechars;
 2786       case 0:
 2787         break;
 2788       default:
 2789         goto sweeperr;
 2790       }
 2791       break;
 2792 #endif /* def FLOATS */
 2793     default:
 2794       if (GC8MARKP(scmptr)) goto c8mrkcontinue;
 2795       {
 2796         int k = SMOBNUM(scmptr);
 2797         if (!(k < numsmob)) goto sweeperr;
 2798         minc = (smobs[k].free)((CELLPTR)scmptr);
 2799       }
 2800     }
 2801     break;
 2802       default: sweeperr: wta(scmptr, s_bad_type, "gc_sweep");
 2803       }
 2804       ++n;
 2805       CAR(scmptr) = (SCM)tc_free_cell;
 2806       CDR(scmptr) = nfreelist;
 2807       nfreelist = scmptr;
 2808       continue;
 2809     c8mrkcontinue:
 2810       CLRGC8MARK(scmptr);
 2811       continue;
 2812     cmrkcontinue:
 2813       CLRGCMARK(scmptr);
 2814     }
 2815 #ifdef GC_FREE_SEGMENTS
 2816     if (n==seg_cells) {
 2817       heap_cells -= seg_cells;
 2818       n = 0;
 2819       free((char *)hplims[i-2]);
 2820       /*      must_free((char *)hplims[i-2],
 2821         sizeof(cell) * (hplims[i-1] - hplims[i-2])); */
 2822       hplims[i-2] = 0;
 2823       for (j = i;j < hplim_ind;j++) hplims[j-2] = hplims[j];
 2824       hplim_ind -= 2;
 2825       i -= 2;           /* need to scan segment just moved. */
 2826       nfreelist = freelist;
 2827     }
 2828     else
 2829 #endif /* ifdef GC_FREE_SEGMENTS */
 2830     freelist = nfreelist;
 2831     gc_cells_collected += n;
 2832     n = 0;
 2833   }
 2834   lcells_allocated += (heap_cells - gc_cells_collected - cells_allocated);
 2835   cells_allocated = (heap_cells - gc_cells_collected);
 2836   gc_malloc_collected = (pre_m - mallocated);
 2837   lmallocated = lmallocated - gc_malloc_collected;
 2838 }
 2839 
 2840 /* mark_syms marks those symbols of hash table V which have
 2841    non-UNDEFINED values.  */
 2842 static void mark_syms(v)
 2843      SCM v;
 2844 {
 2845   SCM x, al;
 2846   int k = LENGTH(v);
 2847   while (k--)
 2848     for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
 2849       /* If this bucket has already been marked, then something is wrong.  */
 2850       ASRTER(!GCMARKP(al), al, s_bad_type, s_gc_sym);
 2851       x = CAR(al);
 2852       SETGCMARK(al);        /* Do mark bucket list */
 2853 # ifdef CAREFUL_INTS
 2854       ASRTER(NIMP(x) && NIMP(CAR(x)) && !GCMARKP(x), x, s_bad_type, s_gc_sym);
 2855       ASRTER(!GC8MARKP(CAR(x)) && !(CHARS(CAR(x))[LENGTH(CAR(x))]),
 2856          CAR(x), s_wrong_length, s_gc_sym);
 2857       ASRTER(strhash(UCHARS(CAR(x)), (sizet)LENGTH(CAR(x)),
 2858              (unsigned long)symhash_dim)==k,
 2859          CAR(x), "bad hash", s_gc_sym);
 2860 # endif
 2861       if (UNDEFINED==CDR(x) && tc7_msymbol==TYP7(CAR(x)))
 2862     goto used;      /* Don't mark symbol.  */
 2863       SETGC8MARK(CAR(x));
 2864     used:
 2865       /* SETGCMARK(x) */;   /* Don't mark value cell.  */
 2866       /* We used to mark the value cell, but value cells get returned
 2867      by calls to intern().  This caused a rare GC leak which only
 2868      showed up in large programs. */
 2869     }
 2870   SETGC8MARK(v);        /* Mark bucket vector.  */
 2871 }
 2872 
 2873 /* mark_symhash marks the values of hash table V.  */
 2874 static void mark_sym_values(v)
 2875      SCM v;
 2876 {
 2877   SCM x, al;
 2878   int k = LENGTH(v);
 2879   /* SETGC8MARK(v); */      /* already set by mark_syms */
 2880   while (k--)
 2881     for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
 2882       x = GCCDR(CAR(al));
 2883       if (IMP(x)) continue;
 2884       gc_mark(x);
 2885     }
 2886 }
 2887 
 2888 /* Splice any unused valueless symbols out of the hash buckets. */
 2889 static void sweep_symhash(v)
 2890      SCM v;
 2891 {
 2892   SCM al, x, *lloc;
 2893   int k = LENGTH(v);
 2894   while (k--) {
 2895     lloc = &(VELTS(v)[k]);
 2896     while NIMP(al = (*lloc & ~1L)) {
 2897       x = CAR(al);
 2898       if (GC8MARKP(CAR(x))) {
 2899     lloc = &(CDR(al));
 2900     SETGCMARK(x);
 2901       }
 2902       else {
 2903     *lloc = CDR(al);
 2904     CLRGCMARK(al);      /* bucket pair to be collected by gc_sweep */
 2905     CLRGCMARK(x);       /* value cell to be collected by gc_sweep */
 2906     gc_syms_collected++;
 2907       }
 2908     }
 2909     VELTS(v)[k] &= ~1L;     /* We may have deleted the first cell */
 2910   }
 2911 }
 2912 
 2913 /* This function should be called after all other marking is done. */
 2914 static void mark_finalizers(finalizers, pending)
 2915      SCM *finalizers, *pending;
 2916 {
 2917   SCM lst, elt, v;
 2918   SCM live = EOL, undead = *finalizers;
 2919   int more_to_do = !0;
 2920   gc_mark(*pending);
 2921   while NIMP(*pending) pending = &CDR(*pending);
 2922   while (more_to_do) {
 2923     more_to_do = 0;
 2924     lst = undead;
 2925     undead = EOL;
 2926     while (NIMP(lst)) {
 2927       elt = CAR(lst);
 2928       v = CAR(elt);
 2929       switch (TYP3(v)) {
 2930       default:
 2931     if (GCMARKP(v)) goto marked;
 2932     goto unmarked;
 2933       case tc3_tc7_types:
 2934     if (GC8MARKP(v)) {
 2935     marked:
 2936       gc_mark(CDR(elt));
 2937       more_to_do = !0;
 2938       v = lst;
 2939       lst = CDR(lst);
 2940       CDR(v) = live;
 2941       live = v;
 2942     }
 2943     else {
 2944     unmarked:
 2945       v = lst;
 2946       lst = CDR(lst);
 2947       CDR(v) = undead;
 2948       undead = v;
 2949     }
 2950     break;
 2951       }
 2952     }
 2953   }
 2954   gc_mark(live);
 2955   for (lst = undead; NIMP(lst); lst = CDR(lst))
 2956     CAR(lst) = CDR(CAR(lst));
 2957   gc_mark(undead);
 2958   *finalizers = live;
 2959   *pending = undead;
 2960 }
 2961 
 2962 static void mark_subrs()
 2963 {
 2964   /* subr_info *table = subrs; */
 2965   /* int k = subrs_gra.len; */
 2966   /* while (k--) { } */
 2967 }
 2968 static void mark_port_table(port)
 2969      SCM port;
 2970 {
 2971   int i = SCM_PORTNUM(port);
 2972   ASRTER(i>=0 && i<scm_port_table_len, MAKINUM(i), "bad port", s_gc);
 2973   if (i) {
 2974     scm_port_table[i].flags |= 1;
 2975     if (NIMP(scm_port_table[i].data))
 2976       gc_mark(scm_port_table[i].data);
 2977   }
 2978 }
 2979 static void sweep_port_table()
 2980 {
 2981   int k;
 2982     /* tmp_errp gets entry 0, so we never clear its flags. */
 2983   for (k = scm_port_table_len - 1; k > 0; k--) {
 2984     if (scm_port_table[k].flags & 1)
 2985       scm_port_table[k].flags &= (~1L);
 2986     else {
 2987       scm_port_table[k].flags = 0L;
 2988       scm_port_table[k].data = UNDEFINED;
 2989       scm_port_table[k].port = UNDEFINED;
 2990     }
 2991   }
 2992 }
 2993 
 2994 /* Environment cache GC routines */
 2995 /* This is called during a non-cache gc. We only mark those stack frames
 2996    that are in use. */
 2997 static void egc_mark()
 2998 {
 2999   SCM *v;
 3000   int i;
 3001   gc_mark(scm_env);
 3002   gc_mark(scm_env_tmp);
 3003   if (IMP(scm_estk)) return;    /* Can happen when moving estk. */
 3004   if (GC8MARKP(scm_estk)) return;
 3005   v = VELTS(scm_estk);
 3006   SETGC8MARK(scm_estk);
 3007   i = scm_estk_ptr - v + SCM_ESTK_FRLEN;
 3008   while(--i >= 0)
 3009     if (NIMP(v[i]))
 3010       gc_mark(v[i]);
 3011 }
 3012 static void egc_sweep()
 3013 {
 3014   SCM z;
 3015   int i;
 3016   for (i = scm_ecache_index; i < scm_ecache_len; i++) {
 3017     z = PTR2SCM(&(scm_ecache[i]));
 3018     if (CONSP(z)) {
 3019       CLRGCMARK(z);
 3020     }
 3021     else {
 3022       CLRGC8MARK(z);
 3023     }
 3024   }
 3025   /* Under some circumstances I don't fully understand, continuations may
 3026      point to dead ecache cells. This prevents gc marked cells from causing
 3027      errors during ecache gc. */
 3028   for (i = scm_ecache_index; i--;) {
 3029     scm_ecache[i].car = UNSPECIFIED;
 3030     scm_ecache[i].cdr = UNSPECIFIED;
 3031   }
 3032 }
 3033 
 3034 #define ECACHEP(x) (PTR_LE((CELLPTR)(ecache_v), (CELLPTR)SCM2PTR(x)) && \
 3035             PTR_GT((CELLPTR)(ecache_v) + ECACHE_SIZE, (CELLPTR)SCM2PTR(x)))
 3036 static void egc_copy(px)
 3037      SCM *px;
 3038 {
 3039   SCM z, x = *px;
 3040   do {
 3041     if (tc_broken_heart==CAR(x)) {
 3042       *px = CDR(x);
 3043       return;
 3044     }
 3045     if (IMP(freelist)) wta(freelist, "empty freelist", "ecache gc");
 3046     z = freelist;
 3047     freelist = CDR(freelist);
 3048     ++cells_allocated;
 3049     CAR(z) = CAR(x);
 3050     CDR(z) = CDR(x);
 3051     CAR(x) = (SCM)tc_broken_heart;
 3052     CDR(x) = z;
 3053     *px = z;
 3054     x = CAR(z);
 3055     if (NIMP(x) && ECACHEP(x))
 3056       egc_copy(&(CAR(z)));
 3057     px = &(CDR(z));
 3058     x = *px;
 3059   } while (NIMP(x) && ECACHEP(x));
 3060 }
 3061 
 3062 static void egc_copy_locations(ve, len)
 3063      SCM *ve;
 3064      sizet len;
 3065 {
 3066   SCM x;
 3067   while (len--) {
 3068     x = ve[len];
 3069     if (NIMP(x) && ECACHEP(x)) {
 3070       if (tc_broken_heart==CAR(x))
 3071     ve[len] = CDR(x);
 3072       else
 3073     egc_copy(&(ve[len]));
 3074     }
 3075   }
 3076 }
 3077 static void egc_copy_stack(stk, len)
 3078      SCM stk;
 3079      sizet len;
 3080 {
 3081   while (!0) {
 3082     egc_copy_locations(VELTS(stk), len);
 3083     len = INUM(SCM_ESTK_PARENT_INDEX(stk)) + SCM_ESTK_FRLEN;
 3084     stk =SCM_ESTK_PARENT(stk);
 3085     if (IMP(stk)) return;
 3086     /*    len = LENGTH(stk); */
 3087   }
 3088 }
 3089 extern long tc16_env, tc16_promise;
 3090 static void egc_copy_roots()
 3091 {
 3092   SCM *roots = &(scm_egc_roots[scm_egc_root_index]);
 3093   SCM e, x;
 3094   int len = sizeof(scm_egc_roots)/sizeof(SCM) - scm_egc_root_index ;
 3095   if (!(len>=0 && len <= sizeof(scm_egc_roots)/sizeof(SCM)))
 3096     wta(MAKINUM(scm_egc_root_index), "egc-root-index", "corrupted");
 3097   while (len--) {
 3098     x = roots[len];
 3099     if (IMP(x)) continue;
 3100     switch TYP3(x) {
 3101     clo:
 3102     case tc3_closure:
 3103       e = ENV(x);
 3104       if (NIMP(e) && ECACHEP(e)) {
 3105     egc_copy(&e);
 3106     CDR(x) = (6L & CDR(x)) | e;
 3107       }
 3108       break;
 3109     case tc3_cons_imcar:
 3110     case tc3_cons_nimcar:   /* These are environment frames that have
 3111                    been destructively altered by DEFINE or
 3112                    LETREC.  This is only a problem if a
 3113                    non-cache cell was made to point into the
 3114                    cache. */
 3115       if (ECACHEP(x)) break;
 3116       e = CAR(x);
 3117       if (NIMP(e) && ECACHEP(e))
 3118     egc_copy(&(CAR(x)));
 3119       break;
 3120     default:
 3121       if (tc7_contin==TYP7(x)) {
 3122     egc_copy_locations(CONT(x)->other.stkframe, 2);
 3123 #ifndef CHEAP_CONTINUATIONS
 3124     x = CONT(x)->other.estk;
 3125     egc_copy_stack(x, LENGTH(x));
 3126 #endif
 3127     break;
 3128       }
 3129       if (tc16_env==CAR(x)) {
 3130     e = CDR(x);
 3131     if (NIMP(e) && ECACHEP(e))
 3132       egc_copy(&(CDR(x)));
 3133     break;
 3134       }
 3135       if (tc16_promise==CAR(x)) {
 3136     x = CDR(x);
 3137     goto clo;
 3138       }
 3139     }
 3140   }
 3141   scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
 3142 }
 3143 extern long scm_stk_moved, scm_clo_moved, scm_env_work;
 3144 static int egc_need_gc()
 3145 {
 3146   SCM fl = freelist;
 3147   int n;
 3148   if (heap_cells - cells_allocated <= scm_ecache_len)
 3149     return 1;
 3150  /* Interrupting a NEWCELL could leave cells_allocated inconsistent with
 3151     freelist, see handle_it() in repl.c */
 3152   for (n = 4; n; n--) {
 3153     if (IMP(fl)) return 1;
 3154     fl = CDR(fl);
 3155   }
 3156   return 0;
 3157 }
 3158 void scm_egc()
 3159 {
 3160   VERIFY_INTS("scm_egc", 0L);
 3161 /* We need to make sure there are enough cells available to migrate
 3162    the entire environment cache, gc does not work properly during ecache gc */
 3163   while (egc_need_gc()) {
 3164     igc("ecache", rootcont);
 3165     if ((gc_cells_collected < MIN_GC_YIELD) ||
 3166     (heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) {
 3167       alloc_some_heap();
 3168       growth_mon("number of heaps", (long)(hplim_ind/2), "segments", !0);
 3169       growth_mon(s_heap, heap_cells, s_cells, !0);
 3170     }
 3171   }
 3172   if (errjmp_bad)
 3173     wta(UNDEFINED, s_recursive, s_cache_gc);
 3174   {
 3175     SCM stkframe[2];
 3176     long lcells = cells_allocated;
 3177     sizet nstk = (scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN);
 3178     ASRTER(nstk<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", s_cache_gc);
 3179     scm_egc_start();
 3180     stkframe[0] = scm_env;
 3181     stkframe[1] = scm_env_tmp;
 3182     egc_copy_roots();
 3183     scm_clo_moved += cells_allocated - lcells;
 3184     lcells = cells_allocated;
 3185     egc_copy_locations(stkframe, sizeof(stkframe)/sizeof(SCM));
 3186     egc_copy_stack(scm_estk, nstk);
 3187     scm_env = stkframe[0];
 3188     scm_env_tmp = stkframe[1];
 3189     scm_stk_moved += cells_allocated - lcells;
 3190     scm_ecache_index = scm_ecache_len;
 3191     scm_env_work += scm_ecache_len;
 3192     scm_egc_end();
 3193   }
 3194   errjmp_bad = (char *)0;
 3195 }