Import Upstream version 5d6upstream/5d6

1 files changed, 51 insertions, 17 deletions

diff --git a/record.c b/record.c
index 585c920..6811575 100644
--- a/record.c
+++ b/record.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM library with other files
  * to produce an executable, this does not by itself cause the
  * resulting executable to be covered by the GNU General Public License.
  * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * linking the SCM library code into it.
  *
  * This exception does not however invalidate any other reasons why
  * the executable file might be covered by the GNU General Public License.
  *
  * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE.  If you copy
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, as the General Public License permits, the exception does
  * not apply to the code that you add in this way.  To avoid misleading
  * anyone as to the status of such modified files, you must delete
  * this exception notice from them.
  *
- * If you write modifications of your own for GUILE, it is your choice
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -130,18 +130,19 @@ SCM rec_constr(rtd, flds)
     while (i--) REC_IND_SET(indices, i, i+1);
   }
   else {
-    ASSERT(NIMP(flds) && CONSP(flds), flds, ARG2, s_rec_constr);
-    indices = MAKE_REC_INDS(ilength(flds));
+    i = ilength(flds);
+    ASSERT(i>=0, flds, ARG2, s_rec_constr);
+    indices = MAKE_REC_INDS(i);
     for(i = 0; NIMP(flds); i++, flds = CDR(flds)) {
       fld = CAR(flds);
       ASSERT(NIMP(fld) && SYMBOLP(fld), fld, ARG2, s_rec_constr);
       flst = RTD_FIELDS(rtd);
       for (j = 0; ; j++, flst = CDR(flst)) {
+	ASSERT(NNULLP(flst), fld, ARG2, s_rec_constr);
 	if (fld==CAR(flst)) {
 	  REC_IND_SET(indices, i, j+1);
 	  break;
 	}
-	ASSERT(NNULLP(flst), fld, ARG2, s_rec_constr);
       }
     }
   }
@@ -165,7 +166,7 @@ static void rec_error(arg, pos, what, rtd, i)
   }
   else
     mesg = st_append(cons2(mesg, recname, EOL));
-  everr(UNDEFINED, EOL, arg, pos, CHARS(mesg));
+  wta(arg, pos, CHARS(mesg));
 }
 #endif
 static char s_rec_constr1[] = "record constructor: ";
@@ -259,9 +260,9 @@ SCM makrectyp(name, fields)
 {
   SCM n, argv[2];
 #ifndef RECKLESS
-  if(ilength(fields) < 0)
+  if (ilength(fields) < 0)
   errout: wta(fields, (char *)ARG2, s_makrectyp);
-  for (n=fields; NIMP(n); n = CDR(n))
+  for (n = fields; NIMP(n); n = CDR(n))
     if (!SYMBOLP(CAR(n))) goto errout;
 #endif
   argv[0] = name;
@@ -274,7 +275,7 @@ SCM rec_prinset(rtd, printer)
      SCM rtd, printer;
 {
   ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_prinset);
-  ASSERT(BOOL_F==printer || scm_arity_check(printer, 2L, (char *)0),
+  ASSERT(BOOL_F==printer || scm_arity_check(printer, 3L, (char *)0),
 	 printer, ARG2, s_rec_prinset);
   RTD_PRINTER(rtd) = printer;
   return UNSPECIFIED;
@@ -291,7 +292,7 @@ static SCM markrec(ptr)
 static sizet freerec(ptr)
      CELLPTR ptr;
 {
-  must_free(CHARS(ptr), sizeof(SCM)*NUMDIGS(ptr));
+  must_free(CHARS((SCM)ptr), sizeof(SCM)*NUMDIGS((SCM)ptr));
   return 0;
 }
 static int recprin1(exp, port, writing)
@@ -299,16 +300,30 @@ static int recprin1(exp, port, writing)
      int writing;
 {
   SCM names, printer = RTD_PRINTER(REC_RTD(exp));
+  SCM argv[3];
   sizet i;
   if NIMP(printer) {
-    SCM argv[2];
     argv[0] = exp;
     argv[1] = port;
-    return scm_cvapply(printer, 2L, argv);
+    argv[2] = writing ? BOOL_T : BOOL_F;
+    /* A writing value of 2 means we are printing an error message.
+       An error in a record printer at this time will result in a
+       fatal recursive error. */
+    if (2 != writing) {
+      if (NFALSEP(scm_cvapply(printer, 3L, argv)))
+	return 1;
+    }
+    else {
+      lputs("\n; Ignoring record-printer: ", cur_errp);
+    }
   }
   names = RTD_FIELDS(REC_RTD(exp));
   lputs("#s(", port);
   iprin1(RTD_NAME(REC_RTD(exp)), port, 0);
+  if (writing) {
+    lputc(':', port);
+    intprint(((long)REC_RTD(exp))>>1, 16, port);
+  }
   for (i = 1; i < NUMDIGS(exp); i++) {
     lputc(' ', port);
     iprin1(CAR(names), port, 0);
@@ -329,6 +344,24 @@ static int recprin1(exp, port, writing)
 */
   return 1;
 }
+
+static SCM f_rtdprin1;
+SCM rec_rtdprin1(rtd, port, writing_p)
+     SCM rtd, port, writing_p;
+{
+  lputs("#s(record-type ", port);
+  iprin1(RTD_NAME(rtd), port, 0);
+  lputc(':', port);
+  intprint(((long)rtd)>>1, 16, port);
+  lputs(" fields ", port);
+  iprin1(RTD_FIELDS(rtd), port, 0);
+  if (NIMP(RTD_PRINTER(rtd)))
+    lputs(" P)", port);
+  else
+    lputc(')', port);
+  return BOOL_T;
+}
+
 SCM recequal(rec0, rec1)
      SCM rec0, rec1;
 {
@@ -360,13 +393,14 @@ void init_record()
   SCM the_rtd, rtd_name = makfrom0str("record-type");
   SCM rtd_fields = cons2(i_name, i_fields, cons(i_printer, EOL));
   tc16_record = newsmob(&recsmob);
+  f_rtdprin1 = make_subr(" rtdprin1", tc7_subr_3, rec_rtdprin1);
   DEFER_INTS;
   the_rtd = must_malloc_cell(4L * sizeof(SCM),
 		 MAKE_NUMDIGS(4L, tc16_record), s_record);
   REC_RTD(the_rtd) = the_rtd;
   RTD_NAME(the_rtd) = rtd_name;
   RTD_FIELDS(the_rtd) = rtd_fields;
-  RTD_PRINTER(the_rtd) = BOOL_F;
+  RTD_PRINTER(the_rtd) = f_rtdprin1;
   ALLOW_INTS;
   the_rtd_rtd = the_rtd;	/* Protected by make-record-type */
   f_rec_pred1 = make_subr(" record-predicate-procedure", tc7_subr_2, rec_pred1);