From 3278b75942bdbe706f7a0fba87729bb1e935b68b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 5d2 --- record.c | 197 ++++++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 114 insertions(+), 83 deletions(-) (limited to 'record.c') 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); } -- cgit v1.2.3