aboutsummaryrefslogtreecommitdiffstats
path: root/record.c
diff options
context:
space:
mode:
Diffstat (limited to 'record.c')
-rw-r--r--record.c197
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);
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-10 21:42:46 +0000