Menu
▾
▴
clisp-cvs digest, Vol 1 #415 - 8 msgs
|
From: <cli...@li...> - 2004-03-22 13:02:07
|
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/doc impbody.xml,1.213,1.214 (Bruno Haible) 2. clisp/src lispbibl.d,1.442,1.443 charstrg.d,1.100,1.101 predtype.d,1.93,1.94 constsym.d,1.223,1.224 ChangeLog,1.2766,1.2767 (Bruno Haible) 3. clisp/src predtype.d,1.94,1.95 constsym.d,1.224,1.225 compiler.lisp,1.172,1.173 defs2.lisp,1.22,1.23 disassem.lisp,1.10,1.11 edit.lisp,1.8,1.9 trace.lisp,1.21,1.22 subr.d,1.161,1.162 describe.lisp,1.39,1.40 ChangeLog,1.2767,1.2768 (Bruno Haible) 4. clisp/doc impbody.xml,1.214,1.215 (Bruno Haible) 5. clisp/src predtype.d,1.95,1.96 describe.lisp,1.40,1.41 ChangeLog,1.2768,1.2769 (Bruno Haible) 6. clisp/src format.lisp,1.24,1.25 ChangeLog,1.2769,1.2770 (Bruno Haible) 7. clisp/src/po de.po,1.9,1.10 (Bruno Haible) 8. clisp/src charstrg.d,1.101,1.102 ChangeLog,1.2770,1.2771 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/doc impbody.xml,1.213,1.214 Date: Mon, 22 Mar 2004 10:14:41 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7036/doc Modified Files: impbody.xml Log Message: TYPE-OF of a standard character now returns STANDARD-CHAR. Index: impbody.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impbody.xml,v retrieving revision 1.213 retrieving revision 1.214 diff -u -d -r1.213 -r1.214 --- impbody.xml 18 Mar 2004 13:53:32 -0000 1.213 +++ impbody.xml 22 Mar 2004 10:14:39 -0000 1.214 @@ -356,7 +356,7 @@ (#.&most-negative-fixnum;))</literal></simpara></listitem> <listitem><simpara>&rational-t;, &short-float-t;, &single-float-t;, &double-float-t;, &long-float-t;, &complex-t;</simpara></listitem> - <listitem><simpara>&character-t;, &base-char-t;</simpara></listitem> + <listitem><simpara>&character-t;, &base-char-t;, &standard-char-t;</simpara></listitem> <listitem><simpara><literal role="type">(&array-t; &eltype-r; &dimensions-r;)</literal>, <literal role="type">(&simple-array-t; &eltype-r; &dimensions-r;)</literal></simpara></listitem> --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src lispbibl.d,1.442,1.443 charstrg.d,1.100,1.101 predtype.d,1.93,1.94 constsym.d,1.223,1.224 ChangeLog,1.2766,1.2767 Date: Mon, 22 Mar 2004 10:14:45 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7036/src Modified Files: lispbibl.d charstrg.d predtype.d constsym.d ChangeLog Log Message: TYPE-OF of a standard character now returns STANDARD-CHAR. Index: charstrg.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/charstrg.d,v retrieving revision 1.100 retrieving revision 1.101 diff -u -d -r1.100 -r1.101 --- charstrg.d 21 Mar 2004 16:26:53 -0000 1.100 +++ charstrg.d 22 Mar 2004 10:14:40 -0000 1.101 @@ -1494,7 +1494,7 @@ var object arg = check_char(popSTACK()); var chart ch = char_code(arg); var cint c = as_cint(ch); - VALUES_IF((('~' >= c) && (c >= ' ')) || (c == NL)); + VALUES_IF(standard_cint_p(c)); } LISPFUNNF(graphic_char_p,1) Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.442 retrieving revision 1.443 diff -u -d -r1.442 -r1.443 --- lispbibl.d 21 Mar 2004 16:26:52 -0000 1.442 +++ lispbibl.d 22 Mar 2004 10:14:39 -0000 1.443 @@ -4096,6 +4096,9 @@ # Conversion standard char (in ASCII encoding) --> object. #define ascii_char(x) code_char(ascii(x)) +# Test for STANDARD-CHAR. +#define standard_cint_p(x) ((('~' >= (x)) && ((x) >= ' ')) || ((x) == NL)) + # Whether to use three different kinds of string representations. #if defined(UNICODE) && (defined(GNU) || (defined(UNIX) && !defined(NO_ALLOCA) && !defined(SPARC)) || defined(BORLAND) || defined(MICROSOFT)) && !defined(NO_SMALL_SSTRING) #define HAVE_SMALL_SSTRING Index: constsym.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constsym.d,v retrieving revision 1.223 retrieving revision 1.224 diff -u -d -r1.223 -r1.224 --- constsym.d 19 Mar 2004 12:36:29 -0000 1.223 +++ constsym.d 22 Mar 2004 10:14:41 -0000 1.224 @@ -1243,6 +1243,7 @@ LISPSYM(Kread_only,"READ-ONLY",keyword) /* other symbols: */ +LISPSYM(standard_char,"STANDARD-CHAR",lisp) /* type in PREDTYPE */ LISPSYM(string_char,"STRING-CHAR",ext) /* type in PREDTYPE */ LISPSYM(base_char,"BASE-CHAR",lisp) /* type in PREDTYPE */ LISPSYM(array_rank_limit,"ARRAY-RANK-LIMIT",lisp) /* constant in ARRAY */ Index: predtype.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/predtype.d,v retrieving revision 1.93 retrieving revision 1.94 diff -u -d -r1.93 -r1.94 --- predtype.d 21 Mar 2004 16:26:52 -0000 1.93 +++ predtype.d 22 Mar 2004 10:14:41 -0000 1.94 @@ -1656,13 +1656,17 @@ ? name : clas); } break; - case_char: /* Character -> BASE-CHAR or CHARACTER */ + case_char: /* Character -> STANDARD-CHAR or BASE-CHAR or CHARACTER */ #if (base_char_code_limit < char_code_limit) if (as_cint(char_code(arg)) >= base_char_code_limit) { value1 = S(character); break; } #endif - value1 = S(base_char); break; + if (standard_cint_p(as_cint(char_code(arg)))) + value1 = S(standard_char); + else + value1 = S(base_char); + break; case_subr: /* SUBR -> COMPILED-FUNCTION */ value1 = S(compiled_function); break; #ifdef TYPECODES Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.2766 retrieving revision 1.2767 diff -u -d -r1.2766 -r1.2767 --- ChangeLog 21 Mar 2004 18:46:31 -0000 1.2766 +++ ChangeLog 22 Mar 2004 10:14:41 -0000 1.2767 @@ -1,3 +1,16 @@ +2004-02-28 Bruno Haible <br...@cl...> + + Due to the rule 1 in + <http://www.lisp.org/HyperSpec/Body/fun_type-of.html>, + we must have (TYPEP X Y) ==> (SUBTYPEP (TYPE-OF X) Y) + for all "built-in types" Y as listed in table 4-2 in + <http://www.lisp.org/HyperSpec/Body/sec_4-2-3.html> + Apply this to X = #\a and Y = STANDARD-CHAR. + * lispbibl.d (standard_cint_p): New macro. + * charstrg.d (STANDARD-CHAR-P): Use it. + * predtype.d (TYPE-OF): For standard-char elements, return + STANDARD-CHAR instead of BASE-CHAR. + 2004-03-21 Sam Steingold <sd...@gn...> * makemake.in (installcheck): pass "-E utf-8 -norc" to CLISP --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src predtype.d,1.94,1.95 constsym.d,1.224,1.225 compiler.lisp,1.172,1.173 defs2.lisp,1.22,1.23 disassem.lisp,1.10,1.11 edit.lisp,1.8,1.9 trace.lisp,1.21,1.22 subr.d,1.161,1.162 describe.lisp,1.39,1.40 ChangeLog,1.2767,1.2768 Date: Mon, 22 Mar 2004 10:17:09 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7667/src Modified Files: predtype.d constsym.d compiler.lisp defs2.lisp disassem.lisp edit.lisp trace.lisp subr.d describe.lisp ChangeLog Log Message: Generic functions are no longer of type COMPILED-FUNCTION. Index: disassem.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/disassem.lisp,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- disassem.lisp 21 May 2003 16:47:58 -0000 1.10 +++ disassem.lisp 22 Mar 2004 10:17:06 -0000 1.11 @@ -54,7 +54,7 @@ (unless (sys::closurep object) (error-of-type 'error (TEXT "Cannot disassemble ~S") object)) ;; the object is a closure. - (unless (compiled-function-p object) + (unless (sys::%compiled-function-p object) (setq object (compile-lambda (sys::%record-ref object 0) ; name (sys::%record-ref object 1) ; lambdabody Index: describe.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/describe.lisp,v retrieving revision 1.39 retrieving revision 1.40 diff -u -d -r1.39 -r1.40 --- describe.lisp 21 Mar 2004 16:26:53 -0000 1.39 +++ describe.lisp 22 Mar 2004 10:17:06 -0000 1.40 @@ -467,8 +467,8 @@ (FUNCTION (format stream (TEXT "a~:[n interpret~; compil~]ed function.") - (compiled-function-p obj)) - (if (compiled-function-p obj) + (sys::%compiled-function-p obj)) + (if (sys::%compiled-function-p obj) (multiple-value-bind (req opt rest-p key-p keywords other-keys-p) (sys::signature obj) (sys::describe-signature stream req opt rest-p key-p keywords Index: edit.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/edit.lisp,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- edit.lisp 20 Jan 2004 11:32:09 -0000 1.8 +++ edit.lisp 22 Mar 2004 10:17:06 -0000 1.9 @@ -74,7 +74,7 @@ (when (eql obj end-of-file) (return)) (print (evalhook obj nil nil (cdr def))) ) ) ) ) - (when (compiled-function-p fun) (compile funname)) + (when (sys::%compiled-function-p fun) (compile funname)) ) ) funname ) Index: trace.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/trace.lisp,v retrieving revision 1.21 retrieving revision 1.22 diff -u -d -r1.21 -r1.22 --- trace.lisp 19 Dec 2003 19:15:05 -0000 1.21 +++ trace.lisp 22 Mar 2004 10:17:06 -0000 1.22 @@ -82,7 +82,8 @@ (error-of-type 'type-error :datum closure :expected-type 'closure (TEXT "~S: ~S must name a closure") 'local name)) - (if (compiled-function-p closure) closure + (if (sys::%compiled-function-p closure) + closure (fdefinition (compile name closure))))) (local-helper (spec) (do* ((spe (cdr spec) (cdr spe)) @@ -102,7 +103,8 @@ (TEXT "~S: ~S must be a closure") `(setf (local ,@spec) ,new-def))) (multiple-value-bind (clo pos) (local-helper spec) (sys::%record-store clo pos - (if (compiled-function-p new-def) new-def + (if (sys::%compiled-function-p new-def) + new-def (fdefinition (compile (closure-name (sys::%record-ref clo pos)) new-def))))))) Index: compiler.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/compiler.lisp,v retrieving revision 1.172 retrieving revision 1.173 diff -u -d -r1.172 -r1.173 --- compiler.lisp 3 Mar 2004 17:56:47 -0000 1.172 +++ compiler.lisp 22 Mar 2004 10:17:06 -0000 1.173 @@ -2395,7 +2395,7 @@ (when (and (function-name-p obj) (fboundp obj)) (setq obj (fdefinition obj))) (if (closurep obj) - (if (compiled-function-p obj) + (if (sys::%compiled-function-p obj) ;; compiled closure (multiple-value-bind (req-num opt-num rest-p key-p keywords allow-p) (signature obj) @@ -9994,7 +9994,7 @@ 'compile name) (sys::untrace2 name)) (setq trace-flag t))) - (when (compiled-function-p definition) + (when (sys::%compiled-function-p definition) (warn (TEXT "~S is already compiled.") definition) (when name @@ -10019,7 +10019,7 @@ (when (macrop definition) (setq macro-flag t) (setq definition (macro-expander definition))) - (when (compiled-function-p definition) + (when (sys::%compiled-function-p definition) (warn (TEXT "~S is already compiled.") name) (return-from compile name)))) (unless (or (and (consp definition) (eq (car definition) 'lambda)) @@ -10475,7 +10475,7 @@ (labels ((mark (cl) ; enters a Closure cl (recursive) in closures. (push cl closures) ; mark cl (dolist (c (closure-consts cl)) ; and all Sub-Closures - (when (and (sys::closurep c) (compiled-function-p c)) + (when (and (sys::closurep c) (sys::%compiled-function-p c)) (unless (member c closures) (mark c)))))) ; mark likewise (mark closure)) ; mark Main-Closure (dolist (c (nreverse closures)) ; disassemble all Closures Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.2767 retrieving revision 1.2768 diff -u -d -r1.2767 -r1.2768 --- ChangeLog 22 Mar 2004 10:14:41 -0000 1.2767 +++ ChangeLog 22 Mar 2004 10:17:06 -0000 1.2768 @@ -1,5 +1,27 @@ 2004-02-28 Bruno Haible <br...@cl...> + Exclude generic functions from the type COMPILED-FUNCTION. + So that (defgeneric foo (x) (:method ((x t)) x)) + (typep #'foo 'COMPILED-FUNCTION) ==> NIL. + Rationale: Due to the rule 1 in + <http://www.lisp.org/HyperSpec/Body/fun_type-of.html>, + we must have (TYPEP X Y) ==> (SUBTYPEP (TYPE-OF X) Y) + for all "built-in types" Y as listed in table 4-2 in + <http://www.lisp.org/HyperSpec/Body/sec_4-2-3.html> + Apply this to X = #'foo and Y = COMPILED-FUNCTION. + * predtype.d (COMPILED-FUNCTION-P): Exclude generic functions. + (SYS::%COMPILED-FUNCTION-P): New function, with the old semantics of + COMPILED-FUNCTION-P. + * compiler.lisp (function-signature, compile, disassemble-closures): + Use sys::%compiled-function-p instead of compiled-function-p. + * defs2.lisp (function-lambda-expression): Likewise. + * describe.lisp (describe-object): Likewise. + * disassem.lisp (disassemble): Likewise. + * edit.lisp (ed): Likewise. + * trace.lisp (sys::%local-set): Likewise. + +2004-02-28 Bruno Haible <br...@cl...> + Due to the rule 1 in <http://www.lisp.org/HyperSpec/Body/fun_type-of.html>, we must have (TYPEP X Y) ==> (SUBTYPEP (TYPE-OF X) Y) Index: subr.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/subr.d,v retrieving revision 1.161 retrieving revision 1.162 diff -u -d -r1.161 -r1.162 --- subr.d 25 Feb 2004 20:14:10 -0000 1.161 +++ subr.d 22 Mar 2004 10:17:06 -0000 1.162 @@ -745,6 +745,7 @@ LISPFUNNF(stringp,1) LISPFUNNF(numberp,1) LISPFUNNR(compiled_function_p,1) +LISPFUNNR(pcompiled_function_p,1) LISPFUNNF(null,1) LISPFUNNF(not,1) LISPFUNNF(closurep,1) Index: constsym.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constsym.d,v retrieving revision 1.224 retrieving revision 1.225 diff -u -d -r1.224 -r1.225 --- constsym.d 22 Mar 2004 10:14:41 -0000 1.224 +++ constsym.d 22 Mar 2004 10:17:06 -0000 1.225 @@ -667,6 +667,7 @@ LISPSYM(stringp,"STRINGP",lisp) LISPSYM(numberp,"NUMBERP",lisp) LISPSYM(compiled_function_p,"COMPILED-FUNCTION-P",lisp) +LISPSYM(pcompiled_function_p,"%COMPILED-FUNCTION-P",system) LISPSYM(null,"NULL",lisp) LISPSYM(not,"NOT",lisp) LISPSYM(closurep,"CLOSUREP",system) Index: defs2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/defs2.lisp,v retrieving revision 1.22 retrieving revision 1.23 diff -u -d -r1.22 -r1.23 --- defs2.lisp 23 Feb 2004 17:08:41 -0000 1.22 +++ defs2.lisp 22 Mar 2004 10:17:06 -0000 1.23 @@ -49,7 +49,7 @@ (values nil nil (sys::%record-ref obj 0))) ((sys::subr-info obj) (values nil nil (sys::subr-info obj))) - ((compiled-function-p obj) ; compiled closure? + ((sys::%compiled-function-p obj) ; compiled closure? (let* ((name (sys::%record-ref obj 0)) (def (get name 'sys::definition))) (values (when def (cons 'LAMBDA (cddar def))) t name))) Index: predtype.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/predtype.d,v retrieving revision 1.94 retrieving revision 1.95 diff -u -d -r1.94 -r1.95 --- predtype.d 22 Mar 2004 10:14:41 -0000 1.94 +++ predtype.d 22 Mar 2004 10:17:06 -0000 1.95 @@ -1162,6 +1162,17 @@ LISPFUNNR(compiled_function_p,1) { /* (COMPILED-FUNCTION-P object), CLTL p. 76 */ var object arg = popSTACK(); + /* check for SUBR or compiled closure (excluding generic functions) or + foreign function: */ + VALUES_IF(subrp(arg) + || (cclosurep(arg) + && (TheCodevec(TheClosure(arg)->clos_codevec)->ccv_flags & bit(4)) == 0) + || ffunctionp(arg)); +} + +LISPFUNNR(pcompiled_function_p,1) { + /* (SYS::%COMPILED-FUNCTION-P object) */ + var object arg = popSTACK(); /* check for SUBR or compiled closure or foreign function: */ VALUES_IF(subrp(arg) || cclosurep(arg) || ffunctionp(arg)); } --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/doc impbody.xml,1.214,1.215 Date: Mon, 22 Mar 2004 10:18:26 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7975/doc Modified Files: impbody.xml Log Message: Change TYPE-OF of compiled-closures and generic-functions. Index: impbody.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impbody.xml,v retrieving revision 1.214 retrieving revision 1.215 diff -u -d -r1.214 -r1.215 --- impbody.xml 22 Mar 2004 10:14:39 -0000 1.214 +++ impbody.xml 22 Mar 2004 10:18:24 -0000 1.215 @@ -372,7 +372,7 @@ <listitem><simpara><literal role="type">(&bit-vector-t; &size-r;)</literal>, <literal role="type">(&simple-bit-vector-t; &size-r;)</literal></simpara></listitem> - <listitem><simpara>&function-t;, &compiled-function-t;</simpara></listitem> + <listitem><simpara>&function-t;, &compiled-function-t;, &standard-generic-function-t;</simpara></listitem> <listitem><simpara>&stream-t;, &file-stream-t;, &synonym-stream-t;, &broadcast-stream-t;, &concatenated-stream-t;, &two-way-stream-t;, &echo-stream-t;, &string-stream-t;</simpara></listitem> --__--__-- Message: 5 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src predtype.d,1.95,1.96 describe.lisp,1.40,1.41 ChangeLog,1.2768,1.2769 Date: Mon, 22 Mar 2004 10:18:27 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7975/src Modified Files: predtype.d describe.lisp ChangeLog Log Message: Change TYPE-OF of compiled-closures and generic-functions. Index: describe.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/describe.lisp,v retrieving revision 1.40 retrieving revision 1.41 diff -u -d -r1.40 -r1.41 --- describe.lisp 22 Mar 2004 10:17:06 -0000 1.40 +++ describe.lisp 22 Mar 2004 10:18:24 -0000 1.41 @@ -448,6 +448,22 @@ (format stream (TEXT "~A string)") (case bits (8 "ISO-8859-1") (16 "UCS-2") (32 "UCS-4"))))) (format stream (TEXT ".")))) + (:method ((obj generic-function) (stream stream)) + (format stream (TEXT "a generic function.")) + (format stream (TEXT "~%Argument list: ~A") + (compiler::sig-to-list (clos::gf-signature obj))) + (let ((mc (clos::method-combination-name (clos::gf-method-combination obj)))) + (unless (eq mc 'STANDARD) + (format stream (TEXT "~%Method combination: ~S") mc))) + (let ((methods (clos::gf-methods obj))) + (if methods + (progn + (format stream (TEXT "~%Methods:")) + (dolist (meth (clos::gf-methods obj)) + (format stream "~% ~{~S ~}~S" (clos::std-method-qualifiers meth) + (mapcar #'(lambda (ps) (if (consp ps) ps (class-name ps))) + (clos::std-method-parameter-specializers meth))))) + (format stream (TEXT "~%No methods."))))) (:method ((obj function) (stream stream)) (ecase (type-of obj) #+FFI @@ -457,35 +473,35 @@ (sys::%record-ref obj 2) (sys::%record-ref obj 3) (sys::%record-ref obj 4))))) - (COMPILED-FUNCTION ; SUBR - (format stream (TEXT "a built-in system function.")) + (COMPILED-FUNCTION (multiple-value-bind (name req opt rest-p keywords other-keys) (sys::subr-info obj) - (when name - (sys::describe-signature stream req opt rest-p - keywords keywords other-keys)))) + (if (and name req) + (progn + (format stream (TEXT "a built-in system function.")) + (sys::describe-signature stream req opt rest-p + keywords keywords other-keys)) + (progn + (format stream (TEXT "a compiled function.")) + (multiple-value-bind (req opt rest-p key-p keywords other-keys-p) + (sys::signature obj) + (sys::describe-signature stream req opt rest-p key-p keywords + other-keys-p) + (let* ((name (sys::closure-name obj)) + (funform (cond ((and (symbolp name) (macro-function name)) + `(MACRO-FUNCTION ',name)) + ((fboundp name) `(FUNCTION ,name))))) + (when funform + (format stream + (TEXT "~%For more information, evaluate ~{~S~^ or ~}.") + `((DISASSEMBLE ,funform)))))))))) (FUNCTION - (format stream - (TEXT "a~:[n interpret~; compil~]ed function.") - (sys::%compiled-function-p obj)) - (if (sys::%compiled-function-p obj) - (multiple-value-bind (req opt rest-p key-p keywords other-keys-p) - (sys::signature obj) - (sys::describe-signature stream req opt rest-p key-p keywords - other-keys-p) - (let* ((name (sys::closure-name obj)) - (funform (cond ((and (symbolp name) (macro-function name)) - `(MACRO-FUNCTION ',name)) - ((fboundp name) `(FUNCTION ,name))))) - (when funform - (format stream - (TEXT "~%For more information, evaluate ~{~S~^ or ~}.") - `((DISASSEMBLE ,funform)))))) - (let ((doc (sys::%record-ref obj 2))) - (format stream (TEXT "~%argument list: ~:S") - (car (sys::%record-ref obj 1))) - (when doc - (format stream (TEXT "~%documentation: ~A") doc)))))))) + (format stream (TEXT "an interpreted function.")) + (let ((doc (sys::%record-ref obj 2))) + (format stream (TEXT "~%argument list: ~:S") + (car (sys::%record-ref obj 1))) + (when doc + (format stream (TEXT "~%documentation: ~A") doc))))))) (defun describe1 (obj stream) (let ((objstring (sys::write-to-short-string Index: predtype.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/predtype.d,v retrieving revision 1.95 retrieving revision 1.96 diff -u -d -r1.95 -r1.96 --- predtype.d 22 Mar 2004 10:17:06 -0000 1.95 +++ predtype.d 22 Mar 2004 10:18:24 -0000 1.96 @@ -1548,8 +1548,19 @@ STACK_1 = array_element_type(STACK_1); /* eltype */ value1 = listof(3); break; - case_closure: /* Closure -> FUNCTION */ - value1 = S(function); break; + case_closure: /* Closure */ + /* -> COMPILED-FUNCTION or STANDARD-GENERIC-FUNCTION or FUNCTION */ + if (simple_bit_vector_p(Atype_8Bit,TheClosure(arg)->clos_codevec)) { + # compiled Closure + if (TheCodevec(TheClosure(arg)->clos_codevec)->ccv_flags & bit(4)) + value1 = S(standard_generic_function); + else + value1 = S(compiled_function); + } else { + # interpreted Closure + value1 = S(function); + } + break; case_structure: { /* Structure -> type of the Structure */ var object type = TheStructure(arg)->structure_types; /* (name_1 ... name_i-1 name_i). type is name_1. */ Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.2768 retrieving revision 1.2769 diff -u -d -r1.2768 -r1.2769 --- ChangeLog 22 Mar 2004 10:17:06 -0000 1.2768 +++ ChangeLog 22 Mar 2004 10:18:24 -0000 1.2769 @@ -1,5 +1,19 @@ 2004-02-28 Bruno Haible <br...@cl...> + Due to the rule 1 in + <http://www.lisp.org/HyperSpec/Body/fun_type-of.html>, + we must have (TYPEP X Y) ==> (SUBTYPEP (TYPE-OF X) Y) + for all "built-in types" Y as listed in table 4-2 in + <http://www.lisp.org/HyperSpec/Body/sec_4-2-3.html> + Apply this to X = #'compile and Y = COMPILED-FUNCTION + or to X = #'print-object and Y = STANDARD-GENERIC-FUNCTION. + * predtype.d (TYPE-OF): For compiled closures, return COMPILED-FUNCTION. + For generic functions, return STANDARD-GENERIC-FUNCTION. + * describe.lisp (describe-object): Add a case for GENERIC-FUNCTION. + Update to match the changed behaviour of TYPE-OF. + +2004-02-28 Bruno Haible <br...@cl...> + Exclude generic functions from the type COMPILED-FUNCTION. So that (defgeneric foo (x) (:method ((x t)) x)) (typep #'foo 'COMPILED-FUNCTION) ==> NIL. --__--__-- Message: 6 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src format.lisp,1.24,1.25 ChangeLog,1.2769,1.2770 Date: Mon, 22 Mar 2004 10:19:53 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8371 Modified Files: format.lisp ChangeLog Log Message: Talk about "format directives", not "directives". Index: format.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/format.lisp,v retrieving revision 1.24 retrieving revision 1.25 diff -u -d -r1.24 -r1.25 --- format.lisp 9 Mar 2004 17:10:26 -0000 1.24 +++ format.lisp 22 Mar 2004 10:19:50 -0000 1.25 @@ -70,7 +70,7 @@ (defun format-parse-cs (control-string startindex csdl stop-at) (declare (fixnum startindex)) (macrolet ((errorstring () - (TEXT "The control string terminates within a directive."))) + (TEXT "The control string terminates within a format directive."))) (prog* ((index startindex) ; cs-index of the next character ch ; current character intparam ; Integer-Parameter @@ -211,7 +211,7 @@ (if directive-name (setf (csd-data newcsd) directive-name) (format-error control-string index - (TEXT "Non-existent directive")))) + (TEXT "Non-existent format directive")))) (incf index) (case ch (#\/ @@ -250,18 +250,18 @@ (( #\) #\] #\} #\> ) (unless stop-at (format-error control-string index - (TEXT "The closing directive '~A' does not have a corresponding opening one.") + (TEXT "The closing format directive '~A' does not have a corresponding opening one.") ch)) (unless (eql ch stop-at) (format-error control-string index - (TEXT "The closing directive '~A' does not match the corresponding opening one. It should read '~A'.") + (TEXT "The closing format directive '~A' does not match the corresponding opening one. It should read '~A'.") ch stop-at)) (setf (csd-clause-chain last-separator-csd) csdl) (go end)) (#\; (unless (or (eql stop-at #\]) (eql stop-at #\>)) (format-error control-string index - (TEXT "The ~~; directive is not allowed at this point."))) + (TEXT "The ~~; format directive is not allowed at this point."))) (setf (csd-clause-chain last-separator-csd) csdl) (setq last-separator-csd newcsd)) (#\Newline @@ -269,7 +269,7 @@ (if (csd-colon-p newcsd) (if (csd-atsign-p newcsd) (format-error control-string index - (TEXT "The ~~newline directive cannot take both modifiers.")) + (TEXT "The ~~newline format directive cannot take both modifiers.")) nil) ; ~:<newline> -> ignore Newline, retain Whitespace (progn (when (csd-atsign-p newcsd) @@ -286,7 +286,7 @@ string-ended (when stop-at (format-error control-string index - (TEXT "An opening directive is never closed; expecting '~A'.") + (TEXT "An opening format directive is never closed; expecting '~A'.") stop-at)) end @@ -385,7 +385,7 @@ (defun next-arg () (if (atom *FORMAT-NEXT-ARG*) (format-error *FORMAT-CS* nil - (TEXT "There are not enough arguments left for this directive.")) + (TEXT "There are not enough arguments left for this format directive.")) (pop *FORMAT-NEXT-ARG*))) ;; (format-interpret stream [endmarker]) interprets *FORMAT-CSDL* . @@ -469,7 +469,7 @@ (defun format-old-roman (arg stream) (unless (and (integerp arg) (<= 1 arg 4999)) (format-error *FORMAT-CS* nil - (TEXT "The ~~:@R directive requires an integer in the range 1 - 4999, not ~S") + (TEXT "The ~~:@R format directive requires an integer in the range 1 - 4999, not ~S") arg)) (do ((charlistr '(#\M #\D #\C #\L #\X #\V #\I) (cdr charlistr)) (valuelistr '(1000 500 100 50 10 5 1) (cdr valuelistr)) @@ -484,7 +484,7 @@ (defun format-new-roman (arg stream) (unless (and (integerp arg) (<= 1 arg 3999)) (format-error *FORMAT-CS* nil - (TEXT "The ~~@R directive requires an integer in the range 1 - 3999, not ~S") + (TEXT "The ~~@R format directive requires an integer in the range 1 - 3999, not ~S") arg)) (do ((charlistr '(#\M #\D #\C #\L #\X #\V #\I) (cdr charlistr)) (valuelistr '(1000 500 100 50 10 5 1 ) (cdr valuelistr)) @@ -541,7 +541,7 @@ ((blocks1000 (illions-list arg) ; decomposition in 1000er-Blocks (when (null illions-list) (format-error *FORMAT-CS* nil - (TEXT "The argument for the ~~R directive is too large."))) + (TEXT "The argument for the ~~R format directive is too large."))) (multiple-value-bind (thousands small) (truncate arg 1000) (when (> thousands 0) (blocks1000 (cdr illions-list) thousands)) (when (> small 0) @@ -1184,7 +1184,7 @@ (format-old-roman arg stream) (format-new-roman arg stream)) (format-error *FORMAT-CS* nil - (TEXT "The ~~R and ~~:R directives require an integer argument, not ~S") + (TEXT "The ~~R and ~~:R format directives require an integer argument, not ~S") arg)) (if colon-modifier (format-ordinal arg stream) @@ -1203,7 +1203,7 @@ (arg) (unless (characterp arg) (format-error *FORMAT-CS* nil - (TEXT "The ~~C directive requires a character argument, not ~S") + (TEXT "The ~~C format directive requires a character argument, not ~S") arg)) (if (not colon-modifier) (if (not atsign-modifier) @@ -1421,11 +1421,11 @@ (apply node stream arglistarg)))) ; wholelistarg?? (defun format-indirection-cserror (csarg) (format-error *FORMAT-CS* nil - (TEXT "The control string argument for the ~~? directive is invalid: ~S") + (TEXT "The control string argument for the ~~? format directive is invalid: ~S") csarg)) (defun format-indirection-lerror (arguments) (format-error *FORMAT-CS* nil - (TEXT "The argument list argument for the ~~? directive is invalid: ~S") + (TEXT "The argument list argument for the ~~? format directive is invalid: ~S") arguments)) ;;; ~// ANSI CL 22.3.5.4 Tilde Slash: Call Function @@ -1475,7 +1475,7 @@ (format-interpret stream 'FORMAT-CONDITIONAL-END) (unless (null (csd-clause-chain (car *FORMAT-CSDL*))) (format-error *FORMAT-CS* nil - (TEXT "The ~~; directive is not allowed at this point.")))) + (TEXT "The ~~; format directive is not allowed at this point.")))) (let ((index (or prefix (next-arg)))) (unless (integerp index) (format-error *FORMAT-CS* nil @@ -1493,7 +1493,7 @@ (defun format-conditional-error () (format-error *FORMAT-CS* nil - (TEXT "The ~~[ directive cannot take both modifiers."))) + (TEXT "The ~~[ format directive cannot take both modifiers."))) ; ~{, CLTL p.403-404, CLtL2 p. 602-604 (defun format-iteration (stream colon-modifier atsign-modifier @@ -1515,7 +1515,7 @@ (let ((arg (next-arg))) (unless (listp arg) (format-error *FORMAT-CS* nil - (TEXT "The ~~{ directive requires a list argument, not ~S") + (TEXT "The ~~{ format directive requires a list argument, not ~S") arg)) arg)))) (do* ((iteration-count 0 (1+ iteration-count))) @@ -2031,7 +2031,7 @@ (labels ((simple-arglist (n) (unless (<= (length arglist) n) (format-error *format-cs* nil - (TEXT "Too many arguments for this directive"))) + (TEXT "Too many arguments for this format directive"))) (setq arglist (append arglist (make-list (- n (length arglist)) @@ -2269,7 +2269,7 @@ (unless (null (csd-clause-chain (car *format-csdl*))) (format-error *format-cs* nil - (TEXT "The ~~; directive is not allowed at this point.")))) + (TEXT "The ~~; format directive is not allowed at this point.")))) (progn (simple-arglist 1) (push `(CASE ,(or (first arglist) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.2769 retrieving revision 1.2770 diff -u -d -r1.2769 -r1.2770 --- ChangeLog 22 Mar 2004 10:18:24 -0000 1.2769 +++ ChangeLog 22 Mar 2004 10:19:50 -0000 1.2770 @@ -1,3 +1,9 @@ +2004-02-29 Bruno Haible <br...@cl...> + + * format.lisp: In error messages, talk about "format directives", not + only "directives". + Suggested by Jörg Höhle <Joe...@t-...>. + 2004-02-28 Bruno Haible <br...@cl...> Due to the rule 1 in --__--__-- Message: 7 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src/po de.po,1.9,1.10 Date: Mon, 22 Mar 2004 12:42:11 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src/po In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7232 Modified Files: de.po Log Message: Fix a typo. Index: de.po =================================================================== RCS file: /cvsroot/clisp/clisp/src/po/de.po,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- de.po 17 Mar 2004 20:47:08 -0000 1.9 +++ de.po 22 Mar 2004 12:42:08 -0000 1.10 @@ -1567,7 +1567,7 @@ #: array.d:494 msgid "~: cannot retrieve values from an array of element type NIL" -msgstr "~S: Kann aus einem Array mit Elementtyp NIL keine Elemente holen." +msgstr "~: Kann aus einem Array mit Elementtyp NIL keine Elemente holen." #: array.d:537 msgid "~: ~ does not fit into ~, bad type" --__--__-- Message: 8 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src charstrg.d,1.101,1.102 ChangeLog,1.2770,1.2771 Date: Mon, 22 Mar 2004 12:50:32 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8905 Modified Files: charstrg.d ChangeLog Log Message: Fix nil-vector handling. Index: charstrg.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/charstrg.d,v retrieving revision 1.101 retrieving revision 1.102 diff -u -d -r1.101 -r1.102 --- charstrg.d 22 Mar 2004 10:14:40 -0000 1.101 +++ charstrg.d 22 Mar 2004 12:50:28 -0000 1.102 @@ -2390,10 +2390,6 @@ string1 = popSTACK(); /* restore string1 */ arg1->string = unpack_string_ro(string1,&len1,&arg1->offset); /* now, len1 is the length (<2^oint_data_len) of string1. */ - if (arg1->len > 0 && simple_nilarray_p(arg1->string)) - fehler_nilarray_retrieve(); - if (arg2->len > 0 && simple_nilarray_p(arg2->string)) - fehler_nilarray_retrieve(); } { /* check :START1 and :END1: */ var uintL start1; @@ -2415,6 +2411,8 @@ } /* issue the results for string1: */ arg1->index = start1; arg1->len = end1-start1; + if (arg1->len > 0 && simple_nilarray_p(arg1->string)) + fehler_nilarray_retrieve(); } { /* check :START2 and :END2: */ var uintL start2; @@ -2436,9 +2434,11 @@ } /* issue the results for string2: */ arg2->index = start2; arg2->len = end2-start2; - /* done. */ - skipSTACK(6); + if (arg2->len > 0 && simple_nilarray_p(arg2->string)) + fehler_nilarray_retrieve(); } + /* done. */ + skipSTACK(6); } /* UP: compares two strings of equal length for equality Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.2770 retrieving revision 1.2771 diff -u -d -r1.2770 -r1.2771 --- ChangeLog 22 Mar 2004 10:19:50 -0000 1.2770 +++ ChangeLog 22 Mar 2004 12:50:29 -0000 1.2771 @@ -1,3 +1,8 @@ +2004-03-22 Bruno Haible <br...@cl...> + + * charstrg.d (test_2_stringsym_limits): Move the test for nil-vector to + the right place. + 2004-02-29 Bruno Haible <br...@cl...> * format.lisp: In error messages, talk about "format directives", not --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |