diff options
author | LaMont Jones <lamont@debian.org> | 2003-05-07 08:36:40 -0600 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:27 -0800 |
commit | e21d47d7813159bb71e0671df9b52ec0470c358d (patch) | |
tree | 3c7770ea846123c291f599044e9f234ac17616bb /record.c | |
parent | 8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693 (diff) | |
parent | deda2c0fd8689349fea2a900199a76ff7ecb319e (diff) | |
download | scm-e21d47d7813159bb71e0671df9b52ec0470c358d.tar.gz scm-e21d47d7813159bb71e0671df9b52ec0470c358d.zip |
Import Debian changes 5d6-3.2debian/5d6-3.2
scm (5d6-3.2) unstable; urgency=low
* Fix hppa compile. Closes: #144062
scm (5d6-3.1) unstable; urgency=low
* NMU with patch from James Troup, to fix FTBFS on sparc. Closes: #191171
scm (5d6-3) unstable; urgency=low
* Add build depend on xlibs-dev (Closes: #148020)
scm (5d6-2) unstable; urgency=low
* Remove libregexx-dev from build-depends.
* Change build to use ./scmlit rather than scmlit (should fix some build
problems) (looks like alpha is mostly building)
* New release (Closes: #140175)
* Built with turtlegraphics last time (Closes: #58515)
scm (5d6-1) unstable; urgency=low
* New upstream.
* Add xlib and turtlegr to requested list of features. (closes
some bug)
* Make clean actually clean most everything up.
* Remove hacks renaming build to something else and just set build as a
.PHONY target in debian/rules.
* Add the turtlegr code.
scm (5d5-1) unstable; urgency=low
* New upstream
* Has fixes for 64 bit archs. May fix alpha compile problem. Does fix
(Closes: #140175)
* Take out -O2 arg.
scm (5d4-3) unstable; urgency=low
* Don't link with regexx, but just use libc6's regular expression
functions.
* Define (terms) to output /usr/share/common-licenses/GPL (Closes:
#119321)
scm (5d4-2) unstable; urgency=low
* Add texinfo to build depends (Closes: #107011)
scm (5d4-1) unstable; urgency=low
* New upstream release.
* Move install-info --remove to prerm.
scm (5d3-5) unstable; urgency=low
* Move scm info files to section "The Algorithmic Language Scheme" to
match up with guile.
scm (5d3-4) unstable; urgency=low
* Fix build depends (Closes: #76691)
scm (5d3-3) unstable; urgency=low
* Fix path in scm dhelp file.
scm (5d3-2) unstable; urgency=low
* Actually put the header files in the package. Oops.
scm (5d3-1) unstable; urgency=low
* New upstream. (Closes: #74761)
* Make (terms) use new license location.
* Make use libregexx rather than librx.
* Fix build depends for above.
* Using new regex lib seems to fix crash (Closes: #66787)
* Consider adding scm-dev package with headers, but instead just add the
headers to the scm package. (Closes: #70787)
* Add doc-base support.
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); |