summaryrefslogtreecommitdiffstats
path: root/record.c
diff options
context:
space:
mode:
Diffstat (limited to 'record.c')
-rw-r--r--record.c68
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);