diff options
Diffstat (limited to 'record.c')
| -rw-r--r-- | record.c | 68 |
1 files changed, 51 insertions, 17 deletions
@@ -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); |