Menu
▾
▴
clisp-cvs Digest, Vol 20, Issue 34
|
From: <cli...@li...> - 2007-12-16 01:07:08
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src lispbibl.d, 1.748, 1.749 error.d, 1.147, 1.148 constobj.d, 1.188, 1.189 ChangeLog, 1.5848, 1.5849 (Sam Steingold) 2. clisp/src record.d,1.119,1.120 (Sam Steingold) ---------------------------------------------------------------------- Message: 1 Date: Sat, 15 Dec 2007 23:10:18 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src lispbibl.d, 1.748, 1.749 error.d, 1.147, 1.148 constobj.d, 1.188, 1.189 ChangeLog, 1.5848, 1.5849 To: cli...@li... Message-ID: <E1J...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv19147/src Modified Files: lispbibl.d error.d constobj.d ChangeLog Log Message: (MAKE_CHECK_REPLACEMENT): new macro (check_list_replacement, check_array_replacement) (check_vector_replacement, check_posfixnum_replacement) (check_integer_replacement, check_char_replacement) (check_string_replacement, check_stream_replacement) (check_uint_replacement, check_sint_replacement) (check_ulong_replacement, check_slong_replacement) (check_ffloat_replacement, check_dfloat_replacement): use it (error_c_integer): add (error_uint8, error_sint8, error_uint16, error_sint16, error_uint32) (error_sint32, error_uint64, error_sint64): define as macros, expanding to error_c_integer() (check_c_integer_replacement): add (check_uint8_replacement, check_sint8_replacement) (check_uint16_replacement, check_sint16_replacement) (check_uint32_replacement, check_sint32_replacement) (check_uint64_replacement, check_sint64_replacement): define as macros, expanding to check_c_integer_replacement() Index: error.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/error.d,v retrieving revision 1.147 retrieving revision 1.148 diff -u -d -r1.147 -r1.148 --- error.d 14 Dec 2007 19:09:58 -0000 1.147 +++ error.d 15 Dec 2007 23:10:07 -0000 1.148 @@ -845,21 +845,29 @@ error(type_error,GETTEXT("~S: ~S is not a list")); } +/* define a global check_TYPE_replacement function + > name: type name + > expected_type: object O(...) + > test: test for the acceptability of the replacement value + > error_message: C string GETTEXT(...) */ +#define MAKE_CHECK_REPLACEMENT(typename,expected_type,test,error_message) \ + global maygc object check_##typename##_replacement (object obj) { \ + do { \ + pushSTACK(NIL); /* no PLACE */ \ + pushSTACK(obj); /* TYPE-ERROR slot DATUM */ \ + pushSTACK(expected_type); /* TYPE-ERROR slot EXPECTED-TYPE */ \ + pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); \ + check_value(type_error,error_message); \ + obj = value1; \ + } while (!test(obj)); \ + return obj; \ + } + /* check_list_replacement(obj) > obj: not a list < result: a list, a replacement can trigger GC */ -global maygc object check_list_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(S(list)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not a list")); - obj = value1; - } while (!listp(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(list,S(list),listp,GETTEXT("~S: ~S is not a list")) /* Error message, if an object isn't a proper list because it is dotted. error_proper_list_dotted(caller,obj); @@ -1031,33 +1039,15 @@ > obj: not an array < result: an array, a replacement can trigger GC */ -global maygc object check_array_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(S(array)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: argument ~S is not an array")); - obj = value1; - } while (!arrayp(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(array,S(array),arrayp, + GETTEXT("~S: argument ~S is not an array")) /* check_vector_replacement(obj) > obj: not an vector < result: an vector, a replacement can trigger GC */ -global maygc object check_vector_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(S(vector)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: argument ~S is not a vector")); - obj = value1; - } while (!vectorp(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(vector,S(vector),vectorp, + GETTEXT("~S: argument ~S is not a vector")) /* check_byte_vector_replacement(obj) > obj: not an (ARRAY (UNSIGNED-BYTE 8) (*)) @@ -1094,41 +1084,22 @@ pushSTACK(obj); /* TYPE-ERROR slot DATUM */ pushSTACK(O(type_posfixnum)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - error(type_error,GETTEXT("~S: argument ~S should be a nonnegative fixnum")); + error(type_error,GETTEXT("~S: argument ~S is not a nonnegative fixnum")); } /* check_posfixnum_replacement(obj) > obj: not a fixnum >= 0 < result: a fixnum >= 0, a replacement can trigger GC */ -global maygc object check_posfixnum_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_posfixnum)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: argument ~S should be a nonnegative fixnum")); - obj = value1; - } while (!posfixnump(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(posfixnum,O(type_posfixnum),posfixnump, + GETTEXT("~S: argument ~S is not a nonnegative fixnum")) /* check_integer_replacement(obj) > obj: not an integer < result: an integer, a replacement can trigger GC */ -global maygc object check_integer_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(S(integer)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); - pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not an integer")); - obj = value1; - } while (!integerp(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(integer,S(integer),integerp, + GETTEXT("~S: ~S is not an integer")) /* check_pos_integer_replacement(obj) > obj: not an integer >= 0 @@ -1162,34 +1133,15 @@ > obj: not a character < result: a character, a replacement can trigger GC */ -global maygc object check_char_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(S(character)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); - pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: argument ~S is not a character")); - obj = value1; - } while (!charp(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(char,S(character),charp, + GETTEXT("~S: argument ~S is not a character")) /* check_string_replacement(obj) > obj: not a string < result: a string, a replacement can trigger GC */ -global maygc object check_string_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(S(string)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: argument ~S is not a string")); - obj = value1; - } while (!stringp(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(string,S(string),stringp, + GETTEXT("~S: argument ~S is not a string")) /* error-message, if an argument is not a Simple-String: > obj: the erroneous argument */ @@ -1216,7 +1168,7 @@ pushSTACK(O(type_string_integer)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); error(type_error, - GETTEXT("~S: argument ~S is neither a string nor an integer")); + GETTEXT("~S: argument ~S is neither a string nor an integer")); } /* Error message, if a string size is too big. @@ -1227,8 +1179,7 @@ pushSTACK(obj); /* TYPE-ERROR slot DATUM */ pushSTACK(O(type_stringsize)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(obj); - error(type_error, - GETTEXT("string too long: desired length ~S exceeds the supported maximum length")); + error(type_error,GETTEXT("string too long: desired length ~S exceeds the supported maximum length")); } /* error message if an argument is not a class. @@ -1247,17 +1198,8 @@ > obj: not a stream < obj: a stream can trigger GC */ -global maygc object check_stream_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(S(stream)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: argument ~S is not a stream")); - obj = value1; - } while (!streamp(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(stream,S(stream),streamp, + GETTEXT("~S: argument ~S is not a stream")) /* Report an error when the argument is not an encoding: > obj: the (possibly) bad argument @@ -1339,7 +1281,7 @@ STACK_1 = arglist; /* ANSI CL 3.5.1.6. wants a PROGRAM-ERROR here. */ error(program_error, - GETTEXT("~S: keyword arguments in ~S should occur pairwise")); + GETTEXT("~S: keyword arguments in ~S should occur pairwise")); } /* error-message for flawed keyword @@ -1350,8 +1292,7 @@ pushSTACK(kw); /* KEYWORD-ERROR slot DATUM */ pushSTACK(S(symbol)); /* KEYWORD-ERROR slot EXPECTED-TYPE */ pushSTACK(kw); pushSTACK(S(LLkey)); pushSTACK(caller); - error(keyword_error, - GETTEXT("~S: ~S marker ~S is not a symbol")); + error(keyword_error,GETTEXT("~S: ~S marker ~S is not a symbol")); } /* error-message for flawed keyword @@ -1374,8 +1315,8 @@ STACK_4 = type; } error(keyword_error, - GETTEXT("~S: illegal keyword/value pair ~S, ~S in argument list.\n" - "The allowed keywords are ~S")); + GETTEXT("~S: illegal keyword/value pair ~S, ~S in argument list.\n" + "The allowed keywords are ~S")); } /* check_function_replacement(obj) @@ -1540,316 +1481,106 @@ } } -/* Error message, if an argument isn't of a given elementary C type. - error_<ctype>(obj); - > obj: the faulty argument */ -nonreturning_function(global, error_uint8, (object obj)) { - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_uint8)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(fixnum(8)); pushSTACK(obj); - pushSTACK(TheSubr(subr_self)->name); - error(type_error,GETTEXT("~S: argument ~S is not a nonnegative integer with at most ~S bits")); -} -nonreturning_function(global, error_sint8, (object obj)) { +/* error if an argument is not of a given elementary integer C type. + error_c_integer(obj); + > obj: the faulty argument + > tcode: type code: 0 for int8, 1 for int16, 2 for int32, 3 for int64 + > signedp: sint or uint */ +local const char* prepare_c_integer_signal (object obj, int tcode, bool signedp) +{ pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_sint8)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(fixnum(8)); pushSTACK(obj); - pushSTACK(TheSubr(subr_self)->name); - error(type_error,GETTEXT("~S: argument ~S is not an integer with at most ~S bits (including the sign bit)")); -} -nonreturning_function(global, error_uint16, (object obj)) { - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_uint16)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(fixnum(16)); pushSTACK(obj); - pushSTACK(TheSubr(subr_self)->name); - error(type_error,GETTEXT("~S: argument ~S is not a nonnegative integer with at most ~S bits")); -} -nonreturning_function(global, error_sint16, (object obj)) { - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_sint16)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(fixnum(16)); pushSTACK(obj); - pushSTACK(TheSubr(subr_self)->name); - error(type_error,GETTEXT("~S: argument ~S is not an integer with at most ~S bits (including the sign bit)")); -} -nonreturning_function(global, error_uint32, (object obj)) { - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_uint32)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(fixnum(32)); pushSTACK(obj); - pushSTACK(TheSubr(subr_self)->name); - error(type_error,GETTEXT("~S: argument ~S is not a nonnegative integer with at most ~S bits")); -} -nonreturning_function(global, error_sint32, (object obj)) { - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_sint32)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(fixnum(32)); pushSTACK(obj); - pushSTACK(TheSubr(subr_self)->name); - error(type_error,GETTEXT("~S: argument ~S is not an integer with at most ~S bits (including the sign bit)")); -} -nonreturning_function(global, error_uint64, (object obj)) { - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_uint64)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(fixnum(64)); pushSTACK(obj); + pushSTACK((signedp?&O(type_sint8):&O(type_uint8))[tcode]); /*EXPECTED-TYPE*/ + pushSTACK(fixnum(8<<tcode)); pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - error(type_error,GETTEXT("~S: argument ~S is not a nonnegative integer with at most ~S bits")); + return signedp + ? GETTEXT("~S: argument ~S is not an integer with at most ~S bits (including the sign bit)") + : GETTEXT("~S: argument ~S is not a nonnegative integer with at most ~S bits"); } -nonreturning_function(global, error_sint64, (object obj)) { - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_sint64)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(fixnum(64)); pushSTACK(obj); - pushSTACK(TheSubr(subr_self)->name); - error(type_error,GETTEXT("~S: argument ~S is not an integer with at most ~S bits (including the sign bit)")); +nonreturning_function(global, error_c_integer, + (object obj, int tcode, bool signedp)) { + error(type_error,prepare_c_integer_signal(obj,tcode,signedp)); } -/* error, if argument is not an integer in the range of the C type 'uint8'. - check_uint8_replacement(obj) - > obj: not an integer in the range of uint8 - < obj: an integer in the range of uint8 +/* get a replacement of a given elementary integer C type. + check_c_integer_replacement(obj) + > obj: not an integer in the range specified by tcode and signedp (see above) + < obj: an integer in the range specified by tcode and signedp can trigger GC */ -global maygc object check_uint8_replacement (object obj) { +global maygc object check_c_integer_replacement (object obj, int tcode, + bool signedp) { do { pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_uint8)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not an 8-bit number")); + check_value(type_error,prepare_c_integer_signal(obj,tcode,signedp)); obj = value1; } while (!uint8_p(obj)); return obj; } -/* error, if argument is not an integer in the range of the C type 'sint8'. - check_sint8_replacement(obj) - > obj: not an integer in the range of sint8 - < obj: an integer in the range of sint8 - can trigger GC */ -global maygc object check_sint8_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_sint8)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not an 8-bit number")); - obj = value1; - } while (!sint8_p(obj)); - return obj; -} - -/* error, if argument is not an integer in the range of the C type 'uint16'. - check_uint16_replacement(obj) - > obj: not an integer in the range of uint16 - < obj: an integer in the range of uint16 - can trigger GC */ -global maygc object check_uint16_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_uint16)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not a 16-bit number")); - obj = value1; - } while (!uint16_p(obj)); - return obj; -} - -/* error, if argument is not an integer in the range of the C type 'sint16'. - check_sint16_replacement(obj) - > obj: not an integer in the range of sint16 - < obj: an integer in the range of sint16 - can trigger GC */ -global maygc object check_sint16_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_sint16)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not a 16-bit number")); - obj = value1; - } while (!sint16_p(obj)); - return obj; -} - -/* error, if argument is not an integer in the range of the C type 'uint32'. - check_uint32_replacement(obj) - > obj: not an integer in the range of uint32 - < obj: an integer in the range of uint32 - can trigger GC */ -global maygc object check_uint32_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_uint32)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not a 32-bit number")); - obj = value1; - } while (!uint32_p(obj)); - return obj; -} - -/* error, if argument is not an integer in the range of the C type 'sint32'. - check_sint32_replacement(obj) - > obj: not an integer in the range of sint32 - < obj: an integer in the range of sint32 - can trigger GC */ -global maygc object check_sint32_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_sint32)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not a 32-bit number")); - obj = value1; - } while (!sint32_p(obj)); - return obj; -} - -/* error, if argument is not an integer in the range of the C type 'uint64'. - check_uint64_replacement(obj) - > obj: not an integer in the range of uint64 - < obj: an integer in the range of uint64 - can trigger GC */ -global maygc object check_uint64_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_uint64)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not a 64-bit number")); - obj = value1; - } while (!uint64_p(obj)); - return obj; -} - -/* error, if argument is not an integer in the range of the C type 'sint64'. - check_sint64_replacement(obj) - > obj: not an integer in the range of sint64 - < obj: an integer in the range of sint64 - can trigger GC */ -global maygc object check_sint64_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(O(type_sint64)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not a 64-bit number")); - obj = value1; - } while (!sint64_p(obj)); - return obj; -} - /* error, if argument is not an integer in the range of the C type 'uint'. check_uint_replacement(obj) > obj: not an integer in the range of uint < obj: an integer in the range of uint can trigger GC */ -global maygc object check_uint_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - #if (int_bitsize==16) - pushSTACK(O(type_uint16)); /* TYPE-ERROR slot EXPECTED-TYPE */ - #else /* (int_bitsize==32) */ - pushSTACK(O(type_uint32)); /* TYPE-ERROR slot EXPECTED-TYPE */ - #endif - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not an `unsigned int' number")); - obj = value1; - } while (!uint_p(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(uint, +#if (int_bitsize==16) + O(type_uint16), +#else /* (int_bitsize==32) */ + O(type_uint32), +#endif + uint_p,GETTEXT("~S: ~S is not an `unsigned int' number")) /* error, if argument is not an integer in the range of the C type 'sint'. check_sint_replacement(obj) > obj: not an integer in the range of sint < obj: an integer in the range of sint can trigger GC */ -global maygc object check_sint_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - #if (int_bitsize==16) - pushSTACK(O(type_sint16)); /* TYPE-ERROR slot EXPECTED-TYPE */ - #else /* (int_bitsize==32) */ - pushSTACK(O(type_sint32)); /* TYPE-ERROR slot EXPECTED-TYPE */ - #endif - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not an `int' number")); - obj = value1; - } while (!sint_p(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(sint, +#if (int_bitsize==16) + O(type_sint16), +#else /* (int_bitsize==32) */ + O(type_sint32), +#endif + sint_p,GETTEXT("~S: ~S is not an `int' number")) /* error, if argument is not an integer in the range of the C type 'ulong'. check_ulong_replacement(obj) > obj: not an integer in the range of ulong < obj: an integer in the range of ulong can trigger GC */ -global maygc object check_ulong_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - #if (long_bitsize==32) - pushSTACK(O(type_uint32)); /* TYPE-ERROR slot EXPECTED-TYPE */ - #else /* (long_bitsize==64) */ - pushSTACK(O(type_uint64)); /* TYPE-ERROR slot EXPECTED-TYPE */ - #endif - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not a `unsigned long' number")); - obj = value1; - } while (!ulong_p(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(ulong, +#if (long_bitsize==32) + O(type_uint32), +#else /* (long_bitsize==64) */ + O(type_uint64), +#endif + ulong_p, + GETTEXT("~S: ~S is not a `unsigned long' number")) /* error, if argument is not an integer in the range of the C type 'slong'. check_slong_replacement(obj) > obj: not an integer in the range of slong < obj: an integer in the range of slong can trigger GC */ -global maygc object check_slong_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - #if (long_bitsize==32) - pushSTACK(O(type_sint32)); /* TYPE-ERROR slot EXPECTED-TYPE */ - #else /* (long_bitsize==64) */ - pushSTACK(O(type_sint64)); /* TYPE-ERROR slot EXPECTED-TYPE */ - #endif - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not a `long' number")); - obj = value1; - } while (!slong_p(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(slong, +#if (long_bitsize==32) + O(type_sint32), +#else /* (long_bitsize==64) */ + O(type_sint64), +#endif + slong_p,GETTEXT("~S: ~S is not a `long' number")) /* error, if argument is not a Single-Float. check_ffloat_replacement(obj) > obj: not a single-float < obj: a single-float can trigger GC */ -global maygc object check_ffloat_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(S(single_float)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not a single-float")); - obj = value1; - } while (!single_float_p(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(ffloat,S(single_float),single_float_p, + GETTEXT("~S: ~S is not a single-float")) /* error, if argument is not a Double-Float. check_dfloat_replacement(obj) > obj: not a double-float < obj: a double-float can trigger GC */ -global maygc object check_dfloat_replacement (object obj) { - do { - pushSTACK(NIL); /* no PLACE */ - pushSTACK(obj); /* TYPE-ERROR slot DATUM */ - pushSTACK(S(double_float)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); - check_value(type_error,GETTEXT("~S: ~S is not a double-float")); - obj = value1; - } while (!double_float_p(obj)); - return obj; -} +MAKE_CHECK_REPLACEMENT(dfloat,S(double_float),double_float_p, + GETTEXT("~S: ~S is not a double-float")) Index: constobj.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constobj.d,v retrieving revision 1.188 retrieving revision 1.189 diff -u -d -r1.188 -r1.189 --- constobj.d 14 Dec 2007 18:59:55 -0000 1.188 +++ constobj.d 15 Dec 2007 23:10:07 -0000 1.189 @@ -358,6 +358,7 @@ LISPOBJ(error_types,"#()") /* for errors of type TYPE-ERROR: */ LISPOBJ(type_function_name,"(OR SYMBOL (CONS (EQL SETF) (CONS SYMBOL NULL)))") + /* the following 8 object order should be in sync with error.d:prepare_c_integer_signal() */ LISPOBJ(type_uint8,"(INTEGER 0 255)") /* or "(UNSIGNED-BYTE 8)" */ LISPOBJ(type_sint8,"(INTEGER -128 127)") /* or "(SIGNED-BYTE 8)" */ LISPOBJ(type_uint16,"(INTEGER 0 65535)") /* or "(UNSIGNED-BYTE 16)" */ Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.748 retrieving revision 1.749 diff -u -d -r1.748 -r1.749 --- lispbibl.d 14 Dec 2007 15:41:57 -0000 1.748 +++ lispbibl.d 15 Dec 2007 23:10:06 -0000 1.749 @@ -14743,17 +14743,19 @@ # used by EVAL, FOREIGN -# Error message, if an argument isn't of a given elementary C type. -# error_<ctype>(obj); -# > obj: the faulty argument -nonreturning_function(extern, error_uint8, (object obj)); -nonreturning_function(extern, error_sint8, (object obj)); -nonreturning_function(extern, error_uint16, (object obj)); -nonreturning_function(extern, error_sint16, (object obj)); -nonreturning_function(extern, error_uint32, (object obj)); -nonreturning_function(extern, error_sint32, (object obj)); -nonreturning_function(extern, error_uint64, (object obj)); -nonreturning_function(extern, error_sint64, (object obj)); +/* Error message, if an argument isn't of a given elementary C type. + error_<ctype>(obj); + > obj: the faulty argument */ +nonreturning_function(global, error_c_integer, + (object obj, int tcode, bool signedp)); +#define error_uint8(obj) error_c_integer(obj,0,true) +#define error_sint8(obj) error_c_integer(obj,0,true) +#define error_uint16(obj) error_c_integer(obj,1,false) +#define error_sint16(obj) error_c_integer(obj,1,true) +#define error_uint32(obj) error_c_integer(obj,2,false) +#define error_sint32(obj) error_c_integer(obj,2,true) +#define error_uint64(obj) error_c_integer(obj,3,false) +#define error_sint64(obj) error_c_integer(obj,3,true) # nonreturning_function(extern, error_uint, (object obj)); # nonreturning_function(extern, error_sint, (object obj)); #if (int_bitsize==16) @@ -14773,14 +14775,14 @@ #define error_slong error_sint64 #endif /* used by STREAM, ENCODING, modules */ -%% puts("nonreturning_function(extern, error_uint8, (object obj));"); -%% puts("nonreturning_function(extern, error_sint8, (object obj));"); -%% puts("nonreturning_function(extern, error_uint16, (object obj));"); -%% puts("nonreturning_function(extern, error_sint16, (object obj));"); -%% puts("nonreturning_function(extern, error_uint32, (object obj));"); -%% puts("nonreturning_function(extern, error_sint32, (object obj));"); -%% puts("nonreturning_function(extern, error_uint64, (object obj));"); -%% puts("nonreturning_function(extern, error_sint64, (object obj));"); +%% export_def(error_uint8(obj)); +%% export_def(error_sint8(obj)); +%% export_def(error_uint16(obj)); +%% export_def(error_sint16(obj)); +%% export_def(error_uint32(obj)); +%% export_def(error_sint32(obj)); +%% export_def(error_uint64(obj)); +%% export_def(error_sint64(obj)); %% #if (int_bitsize==16) %% emit_define("error_uint","error_uint16"); %% emit_define("error_sint","error_sint16"); @@ -14802,35 +14804,36 @@ < result: an object that can be converted to the C type, either the same as obj or a replacement can trigger GC */ -extern maygc object check_uint8_replacement (object obj); +extern maygc object check_c_integer_replacement (object obj, int tcode, bool signedp); +#define check_uint8_replacement(obj) check_c_integer_replacement(obj,0,false) #ifndef COMPILE_STANDALONE MAKE_CHECK_(uint8) #endif -extern maygc object check_sint8_replacement (object obj); +#define check_sint8_replacement(obj) check_c_integer_replacement(obj,0,true) #ifndef COMPILE_STANDALONE MAKE_CHECK_(sint8) #endif -extern maygc object check_uint16_replacement (object obj); +#define check_uint16_replacement(obj) check_c_integer_replacement(obj,1,false) #ifndef COMPILE_STANDALONE MAKE_CHECK_(uint16) #endif -extern maygc object check_sint16_replacement (object obj); +#define check_sint16_replacement(obj) check_c_integer_replacement(obj,1,true) #ifndef COMPILE_STANDALONE MAKE_CHECK_(sint16) #endif -extern maygc object check_uint32_replacement (object obj); +#define check_uint32_replacement(obj) check_c_integer_replacement(obj,2,false) #ifndef COMPILE_STANDALONE MAKE_CHECK_(uint32) #endif -extern maygc object check_sint32_replacement (object obj); +#define check_sint32_replacement(obj) check_c_integer_replacement(obj,2,true) #ifndef COMPILE_STANDALONE MAKE_CHECK_(sint32) #endif -extern maygc object check_uint64_replacement (object obj); +#define check_uint64_replacement(obj) check_c_integer_replacement(obj,3,false) #ifndef COMPILE_STANDALONE MAKE_CHECK_(uint64) #endif -extern maygc object check_sint64_replacement (object obj); +#define check_sint64_replacement(obj) check_c_integer_replacement(obj,3,true) #ifndef COMPILE_STANDALONE MAKE_CHECK_(sint64) #endif @@ -14859,35 +14862,36 @@ MAKE_CHECK_LOW(dfloat,double_float_p(obj)) #endif # is used by STREAM, FFI -%% puts("extern object check_uint8_replacement (object obj);"); +%% puts("extern object check_c_integer_replacement (object obj, int tcode, bool signedp);"); +%% export_def(check_uint8_replacement(obj)); %% puts("#ifndef COMPILE_STANDALONE"); %% export_literal(MAKE_CHECK_(uint8)); %% puts("#endif"); -%% puts("extern object check_sint8_replacement (object obj);"); +%% export_def(check_sint8_replacement(obj)); %% puts("#ifndef COMPILE_STANDALONE"); %% export_literal(MAKE_CHECK_(sint8)); %% puts("#endif"); -%% puts("extern object check_uint16_replacement (object obj);"); +%% export_def(check_uint16_replacement(obj)); %% puts("#ifndef COMPILE_STANDALONE"); %% export_literal(MAKE_CHECK_(uint16)); %% puts("#endif"); -%% puts("extern object check_sint16_replacement (object obj);"); +%% export_def(check_sint16_replacement(obj)); %% puts("#ifndef COMPILE_STANDALONE"); %% export_literal(MAKE_CHECK_(sint16)); %% puts("#endif"); -%% puts("extern object check_uint32_replacement (object obj);"); +%% export_def(check_uint32_replacement(obj)); %% puts("#ifndef COMPILE_STANDALONE"); %% export_literal(MAKE_CHECK_(uint32)); %% puts("#endif"); -%% puts("extern object check_sint32_replacement (object obj);"); +%% export_def(check_sint32_replacement(obj)); %% puts("#ifndef COMPILE_STANDALONE"); %% export_literal(MAKE_CHECK_(sint32)); %% puts("#endif"); -%% puts("extern object check_uint64_replacement (object obj);"); +%% export_def(check_uint64_replacement(obj)); %% puts("#ifndef COMPILE_STANDALONE"); %% export_literal(MAKE_CHECK_(uint64)); %% puts("#endif"); -%% puts("extern object check_sint64_replacement (object obj);"); +%% export_def(check_sint64_replacement(obj)); %% puts("#ifndef COMPILE_STANDALONE"); %% export_literal(MAKE_CHECK_(sint64)); %% puts("#endif"); Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.5848 retrieving revision 1.5849 diff -u -d -r1.5848 -r1.5849 --- ChangeLog 14 Dec 2007 15:47:18 -0000 1.5848 +++ ChangeLog 15 Dec 2007 23:10:07 -0000 1.5849 @@ -1,3 +1,30 @@ +2007-12-15 Sam Steingold <sd...@gn...> + + * error.d (MAKE_CHECK_REPLACEMENT): new macro + (check_list_replacement, check_array_replacement) + (check_vector_replacement, check_posfixnum_replacement) + (check_integer_replacement, check_char_replacement) + (check_string_replacement, check_stream_replacement) + (check_uint_replacement, check_sint_replacement) + (check_ulong_replacement, check_slong_replacement) + (check_ffloat_replacement, check_dfloat_replacement): use it + (error_uint8, error_sint8, error_uint16, error_sint16, error_uint32) + (error_sint32, error_uint64, error_sint64): remove + (error_c_integer): add + (check_uint8_replacement, check_sint8_replacement) + (check_uint16_replacement, check_sint16_replacement) + (check_uint32_replacement, check_sint32_replacement) + (check_uint64_replacement, check_sint64_replacement): remove + (check_c_integer_replacement): add + * lispbibl.d (error_uint8, error_sint8, error_uint16, error_sint16) + (error_uint32, error_sint32, error_uint64, error_sint64): define + as macros, expanding to error_c_integer() + (check_uint8_replacement, check_sint8_replacement) + (check_uint16_replacement, check_sint16_replacement) + (check_uint32_replacement, check_sint32_replacement) + (check_uint64_replacement, check_sint64_replacement): define + as macros, expanding to check_c_integer_replacement() + 2007-12-14 Sam Steingold <sd...@gn...> * avl.d, control.d, debug.d, eval.d, hashtabl.d, intprint.d, io.d: ------------------------------ Message: 2 Date: Sat, 15 Dec 2007 23:44:05 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src record.d,1.119,1.120 To: cli...@li... Message-ID: <E1J...@ma...> Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv32126/src Modified Files: record.d Log Message: convert comments from "# " to "/**/" Index: record.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/record.d,v retrieving revision 1.119 retrieving revision 1.120 diff -u -d -r1.119 -r1.120 --- record.d 5 Dec 2007 16:06:31 -0000 1.119 +++ record.d 15 Dec 2007 23:44:03 -0000 1.120 @@ -13,8 +13,8 @@ (SYS::%RECORD-STORE record index value) store value as the index'th entry in the record and return value. (SYS::%RECORD-LENGTH record) return the length of the record. -*/ -/* Error message + + Error message > STACK_1: record > STACK_0: (bad) index > limit: exclusive upper bound on the index */ @@ -37,7 +37,7 @@ nonreturning_function(local, error_record, (void)) { pushSTACK(TheSubr(subr_self)->name); /* function name */ error(error_condition, /* type_error ?? */ - GETTEXT("~S: ~S is not a record")); + GETTEXT("~S: ~S is not a record")); } /* Subroutine for record access functions @@ -286,7 +286,7 @@ pushSTACK(closure); pushSTACK(TheSubr(subr_self)->name); /* function name */ error(error_condition, /* type_error ?? */ - GETTEXT("~S: ~S is not a closure")); + GETTEXT("~S: ~S is not a closure")); } VALUES1(Closure_name(closure)); } @@ -299,7 +299,7 @@ pushSTACK(closure); pushSTACK(TheSubr(subr_self)->name); /* function name */ error(error_condition, /* type_error ?? */ - GETTEXT("~S: ~S is not a closure")); + GETTEXT("~S: ~S is not a closure")); } var object new_name = popSTACK(); if (Closure_instancep(closure)) @@ -314,7 +314,7 @@ pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); /* function name */ error(error_condition, /* type_error ?? */ - GETTEXT("~S: This is not a compiled closure: ~S")); + GETTEXT("~S: This is not a compiled closure: ~S")); } /* (SYS::CLOSURE-CODEVEC closure) returns the code-vector of a compiled @@ -511,7 +511,7 @@ if (!funcallable_instance_p(closure)) { pushSTACK(closure); pushSTACK(TheSubr(subr_self)->name); error(error_condition, /* type_error ?? */ - GETTEXT("~S: argument is not a funcallable instance: ~S")); + GETTEXT("~S: argument is not a funcallable instance: ~S")); } var object function = STACK_0; if (!(subrp(function) || closurep(function) || ffunctionp(function))) { @@ -581,7 +581,7 @@ pushSTACK(oldclos); pushSTACK(TheSubr(subr_self)->name); /* function name */ error(error_condition, - GETTEXT("~S: This is not a prototype of a generic function: ~S")); + GETTEXT("~S: This is not a prototype of a generic function: ~S")); } vector = copy_svector(vector); /* copy the vector */ TheSvector(vector)->data[0] = STACK_1; /* put in venv */ @@ -1019,9 +1019,9 @@ class must be an instance of <standard-class> or <structure-class>. */ LISPFUN(pallocate_instance,seclass_read,1,0,rest,nokey,0,NIL) { check_initialization_argument_list(argcount,S(allocate_instance)); - # No need to check the validity of the initargs, because ANSI CL says - # "The caller of allocate-instance is expected to have already checked - # the initialization arguments." + /* No need to check the validity of the initargs, because ANSI CL says + "The caller of allocate-instance is expected to have already checked + the initialization arguments." */ set_args_end_pointer(rest_args_pointer); /* clean up STACK */ return_Values do_allocate_instance(popSTACK()); } @@ -1163,7 +1163,7 @@ if (!eq(slotinfo,nullobj)) { /* found? */ if (regular_instance_p(slotinfo)) { if (!eq(TheSlotDefinition(slotinfo)->slotdef_efm_svuc,L(pslot_value_using_class))) { - # Call the effective method of CLOS:SLOT-VALUE-USING-CLASS. + /* Call the effective method of CLOS:SLOT-VALUE-USING-CLASS. */ var object efm = TheSlotDefinition(slotinfo)->slotdef_efm_svuc; pushSTACK(clas); pushSTACK(STACK_(1+1)); pushSTACK(slotinfo); funcall(efm,3); @@ -1200,13 +1200,13 @@ if (!eq(slotinfo,nullobj)) { /* found? */ if (regular_instance_p(slotinfo)) { if (!eq(TheSlotDefinition(slotinfo)->slotdef_efm_ssvuc,L(pset_slot_value_using_class))) { - # Call the effective method of (SETF CLOS:SLOT-VALUE-USING-CLASS). + /* Call the effective method of (SETF CLOS:SLOT-VALUE-USING-CLASS). */ var object efm = TheSlotDefinition(slotinfo)->slotdef_efm_ssvuc; pushSTACK(STACK_0); pushSTACK(clas); pushSTACK(STACK_(2+2)); pushSTACK(slotinfo); funcall(efm,4); - # It must return the new-value. But anyway, just for safety - # (don't trust user-defined methods): + /* It must return the new-value. But anyway, just for safety + (don't trust user-defined methods): */ value1 = STACK_0; goto done; } @@ -1235,7 +1235,7 @@ if (!eq(slotinfo,nullobj)) { /* found? */ if (regular_instance_p(slotinfo)) { if (!eq(TheSlotDefinition(slotinfo)->slotdef_efm_sbuc,L(pslot_boundp_using_class))) { - # Call the effective method of CLOS:SLOT-BOUNDP-USING-CLASS. + /* Call the effective method of CLOS:SLOT-BOUNDP-USING-CLASS. */ var object efm = TheSlotDefinition(slotinfo)->slotdef_efm_sbuc; pushSTACK(clas); pushSTACK(STACK_(1+1)); pushSTACK(slotinfo); funcall(efm,3); @@ -1265,7 +1265,7 @@ if (!eq(slotinfo,nullobj)) { /* found? */ if (regular_instance_p(slotinfo)) { if (!eq(TheSlotDefinition(slotinfo)->slotdef_efm_smuc,L(pslot_makunbound_using_class))) { - # Call the effective method of CLOS:SLOT-MAKUNBOUND-USING-CLASS. + /* Call the effective method of CLOS:SLOT-MAKUNBOUND-USING-CLASS. */ var object efm = TheSlotDefinition(slotinfo)->slotdef_efm_smuc; pushSTACK(clas); pushSTACK(STACK_(1+1)); pushSTACK(slotinfo); funcall(efm,3); @@ -1403,16 +1403,16 @@ do { pushSTACK(obj); var object cv = TheInstance(obj)->inst_class_version; - # We know that the next class is already finalized before - # TheInstance(obj)->inst_class_version is filled. + /* We know that the next class is already finalized before + TheInstance(obj)->inst_class_version is filled. */ { var object newclass = TheClassVersion(TheClassVersion(cv)->cv_next)->cv_class; if (!eq(TheClass(newclass)->initialized,fixnum(6))) NOTREACHED; } - # Compute the information needed for the update, if not already done. + /* Compute the information needed for the update, if not already done. */ if (nullp(TheClassVersion(cv)->cv_slotlists_valid_p)) { - # Invoke (CLOS::CLASS-VERSION-COMPUTE-SLOTLISTS cv): + /* Invoke (CLOS::CLASS-VERSION-COMPUTE-SLOTLISTS cv): */ pushSTACK(cv); funcall(S(class_version_compute_slotlists),1); obj = STACK_0; cv = TheInstance(obj)->inst_class_version; @@ -1420,7 +1420,7 @@ } pushSTACK(TheClassVersion(cv)->cv_added_slots); pushSTACK(TheClassVersion(cv)->cv_discarded_slots); - # Fetch the values of the local slots that are discarded. + /* Fetch the values of the local slots that are discarded. */ { var uintV max_local_slots = posfixnum_to_V(TheClass(TheClassVersion(cv)->cv_class)->instance_size); get_space_on_STACK(2*max_local_slots); @@ -1444,8 +1444,8 @@ } obj = STACK_3; cv = TheInstance(obj)->inst_class_version; - # Fetch the values of the slots that remain local or were shared and - # become local. These values are retained. + /* Fetch the values of the slots that remain local or were shared and + become local. These values are retained. */ var uintL kept_slots; { var object oldclass = TheClassVersion(cv)->cv_class; @@ -1474,10 +1474,10 @@ } kept_slots = count; } - # STACK layout: user-obj, UNWIND-PROTECT frame, - # obj, added-slots, discarded-slots, propertylist, - # {old-value, new-slotinfo}*kept_slots. - # ANSI CL 4.3.6.1. Modifying the Structure of Instances + /* STACK layout: user-obj, UNWIND-PROTECT frame, + obj, added-slots, discarded-slots, propertylist, + {old-value, new-slotinfo}*kept_slots. + ANSI CL 4.3.6.1. Modifying the Structure of Instances */ { var object newclass = TheClassVersion(TheClassVersion(cv)->cv_next)->cv_class; /* (CLOS::ALLOCATE-STD-INSTANCE newclass (class-instance-size newclass)) or @@ -1505,11 +1505,11 @@ TheSrecord(obj)->recdata[posfixnum_to_V(new_slotinfo)] = popSTACK(); }); STACK_3 = STACK_(2+4); - # STACK layout: user-obj, UNWIND-PROTECT frame, - # user-obj, added-slots, discarded-slots, propertylist. - # ANSI CL 4.3.6.2. Initializing Newly Added Local Slots + /* STACK layout: user-obj, UNWIND-PROTECT frame, + user-obj, added-slots, discarded-slots, propertylist. + ANSI CL 4.3.6.2. Initializing Newly Added Local Slots */ funcall(S(update_instance_frc),4); - # STACK layout: user-obj, UNWIND-PROTECT frame. + /* STACK layout: user-obj, UNWIND-PROTECT frame. */ obj = STACK_2; instance_un_realloc(obj); } while (!instance_valid_p(obj)); @@ -1631,7 +1631,7 @@ var object slotinfo = slot; if (regular_instance_p(slotinfo)) { if (!eq(TheSlotDefinition(slotinfo)->slotdef_efm_sbuc,L(pslot_boundp_using_class))) { - # Call (eff-SLOT-BOUNDP-USING-CLASS clas instance slot): + /* Call (eff-SLOT-BOUNDP-USING-CLASS clas instance slot): */ var object efm = TheSlotDefinition(slotinfo)->slotdef_efm_sbuc; pushSTACK(clas); pushSTACK(slots); pushSTACK(slot); pushSTACK(clas); pushSTACK(Before(rest_args_pointer STACKop 1)); pushSTACK(slot); @@ -1678,7 +1678,7 @@ var object slotinfo = slot; if (regular_instance_p(slotinfo)) { if (!eq(TheSlotDefinition(slotinfo)->slotdef_efm_ssvuc,L(pset_slot_value_using_class))) { - # Call (eff-SET-SLOT-VALUE-USING-CLASS value1 clas instance slot): + /* Call (eff-SET-SLOT-VALUE-USING-CLASS value1 clas instance slot): */ var object efm = TheSlotDefinition(slotinfo)->slotdef_efm_ssvuc; pushSTACK(clas); pushSTACK(slots); pushSTACK(value1); pushSTACK(clas); pushSTACK(Before(rest_args_pointer STACKop 1)); pushSTACK(slot); @@ -1780,7 +1780,7 @@ var object slotinfo = slot; if (regular_instance_p(slotinfo)) { if (!eq(TheSlotDefinition(slotinfo)->slotdef_efm_ssvuc,L(pset_slot_value_using_class))) { - # Call (eff-SET-SLOT-VALUE-USING-CLASS value clas instance slot): + /* Call (eff-SET-SLOT-VALUE-USING-CLASS value clas instance slot): */ var object efm = TheSlotDefinition(slotinfo)->slotdef_efm_ssvuc; pushSTACK(clas); pushSTACK(slots); pushSTACK(value); pushSTACK(clas); pushSTACK(Before(rest_args_pointer)); pushSTACK(slot); @@ -1877,7 +1877,7 @@ var object slotinfo = slot; if (regular_instance_p(slotinfo)) { if (!eq(TheSlotDefinition(slotinfo)->slotdef_efm_sbuc,L(pslot_boundp_using_class))) { - # Call (eff-SLOT-BOUNDP-USING-CLASS clas instance slot): + /* Call (eff-SLOT-BOUNDP-USING-CLASS clas instance slot): */ var object efm = TheSlotDefinition(slotinfo)->slotdef_efm_sbuc; pushSTACK(clas); pushSTACK(slots); pushSTACK(slot); pushSTACK(clas); pushSTACK(Before(rest_args_pointer)); pushSTACK(slot); @@ -1912,7 +1912,7 @@ var object slotinfo = slot; if (regular_instance_p(slotinfo)) { if (!eq(TheSlotDefinition(slotinfo)->slotdef_efm_ssvuc,L(pset_slot_value_using_class))) { - # Call (eff-SET-SLOT-VALUE-USING-CLASS value1 clas instance slot): + /* Call (eff-SET-SLOT-VALUE-USING-CLASS value1 clas instance slot): */ var object efm = TheSlotDefinition(slotinfo)->slotdef_efm_ssvuc; pushSTACK(clas); pushSTACK(slots); pushSTACK(value1); pushSTACK(clas); pushSTACK(Before(rest_args_pointer)); pushSTACK(slot); ------------------------------ ------------------------------------------------------------------------- SF.Net email is sponsored by: Check out the new SourceForge.net Marketplace. It's the best place to buy or sell services for just about anything Open Source. http://ad.doubleclick.net/clk;164216239;13503038;w?http://sf.net/marketplace ------------------------------ _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest, Vol 20, Issue 34 ***************************************** |