Import Upstream version 5d2upstream/5d2

1 files changed, 114 insertions, 83 deletions

diff --git a/record.c b/record.c
index 7724889..585c920 100644
--- a/record.c
+++ b/record.c
@@ -1,18 +1,18 @@
 /* Copyright (C) 1994, 1995, 1997 Free Software Foundation, Inc.
- * 
+ *
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
  * the Free Software Foundation; either version 2, or (at your option)
  * any later version.
- * 
+ *
  * This program is distributed in the hope that it will be useful,
  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  * GNU General Public License for more details.
- * 
+ *
  * You should have received a copy of the GNU General Public License
  * along with this software; see the file COPYING.  If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ * 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.
@@ -36,50 +36,33 @@
  *
  * If you write modifications of your own for GUILE, it is your choice
  * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.  
+ * If you do not wish that, delete this exception notice.
  */
 
 /* "record.c" code for (R5RS) proposed "Record" user definable datatypes.
    Author: Radey Shouman */
 
 #include "scm.h"
-
-typedef struct {
-  SCM rtd;
-  SCM name;
-  SCM fields;
-} rtd_type;
-
-typedef union {
-  struct {
-    SCM proc;
-    SCM rtd;
-  } pred;
-  struct {
-    SCM proc;
-    SCM rtd;
-    SCM index;
-  } acc;
-  struct {
-    SCM proc;
-    SCM rtd;
-    SCM recsize;
-    SCM indices;
-  } constr;
-} rec_cclo;
-
 long tc16_record;
 
 /* Record-type-descriptor for record-type-descriptors */
 static SCM the_rtd_rtd;
 
-/* Record <= [rtd, ... elts ... ] */
+/* Record <= [rtd, elt ... ]
+   RTD <= [rtd, name, (field ...), printer]
+   Predicate <= [cclo-procedure, rtd]
+   Accessor, Modifier <= [cclo-procedure, rtd, index]
+   Constructor <= [cclo-procedure, rtd, record-size, #(index ...)] */
 #define REC_RTD(x) (VELTS(x)[0])
 #define RECP(x) (tc16_record==TYP16(x))
 #define RTDP(x) (RECP(x) && the_rtd_rtd==REC_RTD(x))
-#define RTD_NAME(x) (((rtd_type *)CDR(x))->name)
-#define RTD_FIELDS(x) (((rtd_type *)CDR(x))->fields)
-#define RCLO_RTD(x) (((rec_cclo *)CDR(x))->pred.rtd)
+#define RTD_NAME(x) (VELTS(x)[1])
+#define RTD_FIELDS(x) (VELTS(x)[2])
+#define RTD_PRINTER(x) (VELTS(x)[3])
+#define RCLO_RTD(x) (VELTS(x)[1])
+#define RCLO_INDEX(x) (VELTS(x)[2]) /* For accessors, modifiers */
+#define RCONSTR_SIZE(x) (VELTS(x)[2])
+#define RCONSTR_INDICES(x) (VELTS(x)[3])
 
 /* If we are compiling this as a dll, then we cannot assume that
    arrays will be available when the dll is loaded */
@@ -103,7 +86,6 @@ SCM recordp(obj)
 {
   return (NIMP(obj) && RECP(obj) ? BOOL_T : BOOL_F);
 }
-static char s_rec_pred1[] = " record-predicate-procedure";
 SCM rec_pred1(cclo, obj)
      SCM cclo, obj;
 {
@@ -136,58 +118,80 @@ SCM rec_constr(rtd, flds)
      SCM rtd, flds;
 {
   SCM flst, fld;
-  SCM cclo = makcclo(f_rec_constr1, (long)sizeof(rec_cclo)/sizeof(SCM));
-  rec_cclo *ptr = (rec_cclo *)CDR(cclo);
+  SCM cclo = makcclo(f_rec_constr1, 4L);
+  SCM indices;
   sizet i, j;
   ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_constr);
-  ptr->constr.rtd = rtd;
+  RCLO_RTD(cclo) = rtd;
   i = ilength(RTD_FIELDS(rtd));
-  ptr->constr.recsize = MAKINUM(i);
+  RCONSTR_SIZE(cclo) = MAKINUM(i);
   if UNBNDP(flds) {
-    ptr->constr.indices = MAKE_REC_INDS(i);
-    while (i--)
-      REC_IND_SET(ptr->constr.indices, i, i+1);
+    indices = MAKE_REC_INDS(i);
+    while (i--) REC_IND_SET(indices, i, i+1);
   }
   else {
     ASSERT(NIMP(flds) && CONSP(flds), flds, ARG2, s_rec_constr);
-    ptr->constr.indices = MAKE_REC_INDS(ilength(flds));
+    indices = MAKE_REC_INDS(ilength(flds));
     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)) {
 	if (fld==CAR(flst)) {
-	  REC_IND_SET(ptr->constr.indices, i, j+1);
+	  REC_IND_SET(indices, i, j+1);
 	  break;
 	}
 	ASSERT(NNULLP(flst), fld, ARG2, s_rec_constr);
       }
     }
   }
+  RCONSTR_INDICES(cclo) = indices;
   return cclo;
 }
-static char s_rec_constr1[] = " record-constructor-procedure";
+#ifndef RECKLESS
+static void rec_error(arg, pos, what, rtd, i)
+     SCM arg, rtd;
+     int i;
+     char *pos, *what;
+{
+  SCM recname = RTD_NAME(rtd);
+  SCM fld = RTD_FIELDS(rtd);
+  SCM mesg = makfrom0str(what);
+  if (i > 0) {
+    while (--i) fld = CDR(fld);
+    fld = CAR(fld);
+    mesg = st_append(cons2(mesg, recname,
+			   cons2(makfrom0str(" -> "), symbol2string(fld), EOL)));
+  }
+  else
+    mesg = st_append(cons2(mesg, recname, EOL));
+  everr(UNDEFINED, EOL, arg, pos, CHARS(mesg));
+}
+#endif
+static char s_rec_constr1[] = "record constructor: ";
 SCM rec_constr1(args)
      SCM args;
 {
   SCM cclo = CAR(args);
-  SCM rec, inds = (((rec_cclo *)CDR(cclo))->constr.indices);
-  sizet i = INUM(((rec_cclo *)CDR(cclo))->constr.recsize);
+  SCM rec, inds = RCONSTR_INDICES(cclo);
+  sizet i = INUM(RCONSTR_SIZE(cclo));
   args = CDR(args);
   DEFER_INTS;
-  rec = must_malloc_cell((i+1L)*sizeof(SCM), s_record);
-  SETNUMDIGS(rec, i+1L, tc16_record);
-  ALLOW_INTS;
+  rec = must_malloc_cell((i+1L)*sizeof(SCM),
+			 MAKE_NUMDIGS(i+1L, tc16_record), s_record);
   while (i--)
     VELTS(rec)[i+1] = UNSPECIFIED;
   REC_RTD(rec) = RCLO_RTD(cclo);
+  ALLOW_INTS;
   for (i = 0; i < LENGTH(inds); i++, args = CDR(args)) {
-    ASSERT(NNULLP(args), UNDEFINED, WNA, s_rec_constr1);
+#ifndef RECKLESS
+    if (NULLP(args))
+      wna: rec_error(UNDEFINED, WNA, s_rec_constr1, RCLO_RTD(cclo), -1);
+#endif
     VELTS(rec)[ REC_IND_REF(inds, i) ] = CAR(args);
   }
-  ASSERT(NULLP(args), UNDEFINED, WNA, s_rec_constr1);
+  ASRTGO(NULLP(args), wna);
   return rec;
-
 }
 
 /* Makes an accessor or modifier.
@@ -199,7 +203,7 @@ static SCM makrecclo(proc, rtd, field, what)
   SCM flst;
   SCM cclo = makcclo(proc, 3L);
   int i;
-  ASSERT(RTDP(rtd), rtd, ARG1, what);
+  ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, what);
   ASSERT(NIMP(field) && SYMBOLP(field), field, ARG2, what);
   RCLO_RTD(cclo) = rtd;
   flst = RTD_FIELDS(rtd);
@@ -208,24 +212,30 @@ static SCM makrecclo(proc, rtd, field, what)
     if (CAR(flst)==field) break;
     flst = CDR(flst);
   }
-  (((rec_cclo *)CDR(cclo))->acc.index) = MAKINUM(i);
+  RCLO_INDEX(cclo) = MAKINUM(i);
   return cclo;
 }
-static char s_rec_accessor1[] = " record-accessor-procedure";
+static char s_rec_accessor1[] = "record accessor: ";
 SCM rec_accessor1(cclo, rec)
      SCM cclo, rec;
 {
-  ASSERT(NIMP(rec) && RECP(rec), rec, ARG1, s_rec_accessor1);
-  ASSERT(RCLO_RTD(cclo)==REC_RTD(rec), rec, ARG1, s_rec_accessor1);
-  return VELTS(rec)[ INUM(((rec_cclo *)CDR(cclo))->acc.index) ];
+  register int i = INUM(RCLO_INDEX(cclo));
+#ifndef RECKLESS
+  if (IMP(rec) || !RECP(rec) || RCLO_RTD(cclo)!=REC_RTD(rec))
+    rec_error(rec, ARG1, s_rec_accessor1, RCLO_RTD(cclo), i);
+#endif
+  return VELTS(rec)[i];
 }
-static char s_rec_modifier1[] = " record-modifier-procedure";
+static char s_rec_modifier1[] = "record modifier: ";
 SCM rec_modifier1(cclo, rec, val)
      SCM cclo, rec, val;
 {
-  ASSERT(NIMP(rec) && RECP(rec), rec, ARG1, s_rec_modifier1);
-  ASSERT(RCLO_RTD(cclo)==REC_RTD(rec), rec, ARG1, s_rec_modifier1);
-  VELTS(rec)[ INUM(((rec_cclo *)CDR(cclo))->acc.index) ] = val;
+  register int i = INUM(RCLO_INDEX(cclo));
+#ifndef RECKLESS
+  if (IMP(rec) || !RECP(rec) || RCLO_RTD(cclo)!=REC_RTD(rec))
+    rec_error(rec, ARG1, s_rec_modifier1, RCLO_RTD(cclo), i);
+#endif
+  VELTS(rec)[i] = val;
   return UNSPECIFIED;
 }
 static SCM f_rec_accessor1;
@@ -242,28 +252,38 @@ SCM rec_modifier(rtd, field)
 {
  return makrecclo(f_rec_modifier1, rtd, field, s_rec_accessor);
 }
-
-static char s_makrectyp[] = "make-record-type";
 SCM *loc_makrtd;
+static char s_makrectyp[] = "make-record-type";
 SCM makrectyp(name, fields)
      SCM name, fields;
 {
-  SCM n;
+  SCM n, argv[2];
 #ifndef RECKLESS
   if(ilength(fields) < 0)
   errout: wta(fields, (char *)ARG2, s_makrectyp);
   for (n=fields; NIMP(n); n = CDR(n))
     if (!SYMBOLP(CAR(n))) goto errout;
 #endif
-  return apply(*loc_makrtd, name, cons(fields, listofnull));
+  argv[0] = name;
+  argv[1] = fields;
+  return scm_cvapply(*loc_makrtd, 2L, argv);
+}
+
+static char s_rec_prinset[] = "record-printer-set!";
+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),
+	 printer, ARG2, s_rec_prinset);
+  RTD_PRINTER(rtd) = printer;
+  return UNSPECIFIED;
 }
 
 static SCM markrec(ptr)
      SCM ptr;
 {
   sizet i;
-  if GC8MARKP(ptr) return BOOL_F;
-  SETGC8MARK(ptr);
   for (i = NUMDIGS(ptr); --i;)
     if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]);
   return REC_RTD(ptr);
@@ -272,14 +292,21 @@ static sizet freerec(ptr)
      CELLPTR ptr;
 {
   must_free(CHARS(ptr), sizeof(SCM)*NUMDIGS(ptr));
-  return sizeof(SCM)*NUMDIGS(ptr);
+  return 0;
 }
 static int recprin1(exp, port, writing)
      SCM exp, port;
      int writing;
 {
-  SCM names = RTD_FIELDS(REC_RTD(exp));
+  SCM names, printer = RTD_PRINTER(REC_RTD(exp));
   sizet i;
+  if NIMP(printer) {
+    SCM argv[2];
+    argv[0] = exp;
+    argv[1] = port;
+    return scm_cvapply(printer, 2L, argv);
+  }
+  names = RTD_FIELDS(REC_RTD(exp));
   lputs("#s(", port);
   iprin1(RTD_NAME(REC_RTD(exp)), port, 0);
   for (i = 1; i < NUMDIGS(exp); i++) {
@@ -323,23 +350,26 @@ static iproc subr2s[] = {
   {s_rec_accessor, rec_accessor},
   {s_rec_modifier, rec_modifier},
   {s_makrectyp, makrectyp},
+  {s_rec_prinset, rec_prinset},
   {0, 0}};
-static char s_name[] = "name";
-static char s_fields[] = "fields";
 void init_record()
 {
-  SCM i_name = CAR(intern(s_name, (sizeof s_name)-1));
-  SCM i_fields = CAR(intern(s_fields, (sizeof s_fields)-1));
+  SCM i_name = CAR(sysintern("name", UNDEFINED));
+  SCM i_fields = CAR(sysintern("fields", UNDEFINED));
+  SCM i_printer = CAR(sysintern("printer", UNDEFINED));
+  SCM the_rtd, rtd_name = makfrom0str("record-type");
+  SCM rtd_fields = cons2(i_name, i_fields, cons(i_printer, EOL));
   tc16_record = newsmob(&recsmob);
   DEFER_INTS;
-  the_rtd_rtd = must_malloc_cell((long)sizeof(rtd_type), s_record);
-  SETNUMDIGS(the_rtd_rtd, (long)sizeof(rtd_type)/sizeof(SCM), tc16_record);
+  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;
   ALLOW_INTS;
-  REC_RTD(the_rtd_rtd) = the_rtd_rtd;
-  RTD_NAME(the_rtd_rtd) = makfromstr(s_record, (sizeof s_record)-1);
-  RTD_FIELDS(the_rtd_rtd) = cons2(i_name, i_fields, EOL);
-  sysintern("record:rtd", the_rtd_rtd);
-  f_rec_pred1 = make_subr(s_rec_pred1, tc7_subr_2, rec_pred1);
+  the_rtd_rtd = the_rtd;	/* Protected by make-record-type */
+  f_rec_pred1 = make_subr(" record-predicate-procedure", tc7_subr_2, rec_pred1);
   f_rec_constr1 = make_subr(s_rec_constr1, tc7_lsubr, rec_constr1);
   f_rec_accessor1 = make_subr(s_rec_accessor1, tc7_subr_2, rec_accessor1);
   f_rec_modifier1 = make_subr(s_rec_modifier1, tc7_subr_3, rec_modifier1);
@@ -349,6 +379,7 @@ void init_record()
   sysintern("record-type-descriptor?", rec_pred(the_rtd_rtd));
   sysintern("record-type-name", rec_accessor(the_rtd_rtd, i_name));
   sysintern("record-type-field-names", rec_accessor(the_rtd_rtd, i_fields));
-  loc_makrtd = &CDR(sysintern("RTD:make", rec_constr(the_rtd_rtd, UNDEFINED)));
+  loc_makrtd = &CDR(sysintern("RTD:make",
+			      rec_constr(the_rtd_rtd, cons2(i_name, i_fields, EOL))));
   add_feature(s_record);
 }