From: <cli...@li...> - 2004-12-21 23:20:03
|
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/modules/wildcard wildcard.lisp,1.7,1.8 (Bruno Haible) 2. clisp/modules/regexp regexp.lisp,1.20,1.21 (Bruno Haible) 3. clisp/src ChangeLog,1.3981,1.3982 (Bruno Haible) 4. clisp/src ChangeLog,1.3982,1.3983 format.lisp,1.39,1.40 (Bruno Haible) 5. clisp/utils clispload.lsp,1.37,1.38 (Bruno Haible) 6. clisp/src predtype.d,1.126,1.127 sequence.d,1.94,1.95 subtypep.lisp,1.10,1.11 ChangeLog,1.3983,1.3984 (Bruno Haible) 7. clisp/utils clispload.lsp,1.38,1.39 (Bruno Haible) 8. clisp/src ChangeLog,1.3984,1.3985 (Sam Steingold) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/modules/wildcard wildcard.lisp,1.7,1.8 Date: Tue, 21 Dec 2004 11:47:12 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/wildcard In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8039/modules/wildcard Modified Files: wildcard.lisp Log Message: Modernize package declaration. Index: wildcard.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/wildcard/wildcard.lisp,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- wildcard.lisp 23 Feb 2004 17:08:42 -0000 1.7 +++ wildcard.lisp 21 Dec 2004 11:47:10 -0000 1.8 @@ -3,8 +3,9 @@ ;; Sam Steingold 2001-2004 (defpackage "WILDCARD" - (:use "FFI" "COMMON-LISP") - (:export "MATCH" "WILDCARD-MATCHER")) + (:case-sensitive t) (:case-inverted t) + (:use "CS-COMMON-LISP" "FFI") + (:export #:match #:wildcard-matcher)) (in-package "WILDCARD") (default-foreign-language :stdc) --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/modules/regexp regexp.lisp,1.20,1.21 Date: Tue, 21 Dec 2004 11:47:12 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/regexp In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8039/modules/regexp Modified Files: regexp.lisp Log Message: Modernize package declaration. Index: regexp.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/regexp/regexp.lisp,v retrieving revision 1.20 retrieving revision 1.21 diff -u -d -r1.20 -r1.21 --- regexp.lisp 23 Feb 2004 17:08:43 -0000 1.20 +++ regexp.lisp 21 Dec 2004 11:47:10 -0000 1.21 @@ -5,13 +5,13 @@ (defpackage "REGEXP" (:documentation "POSIX Regular Expressions - matching, compiling, executing.") - (:use "LISP") - (:export "MATCH" "MATCH-START" "MATCH-END" "MATCH-STRING" "REGEXP-QUOTE" - "REGEXP-MATCHER" - "REGEXP-COMPILE" "REGEXP-EXEC" "REGEXP-SPLIT" "WITH-LOOP-SPLIT")) + (:use "COMMON-LISP") + (:export #:match #:match-start #:match-end #:match-string #:regexp-quote + #:regexp-matcher + #:regexp-compile #:regexp-exec #:regexp-split #:with-loop-split)) (in-package "REGEXP") -(push "REGEXP" ext:*system-package-list*) +(push "REGEXP" custom:*system-package-list*) (pushnew :regexp *features*) (defstruct (match (:constructor make-match-boa (start end)) @@ -21,12 +21,12 @@ ;; The following implementation of MATCH compiles the pattern ;; once for every search. (defun match-once (pattern string &key (start 0) (end nil) - (extended nil) (ignore-case nil) - (newline nil) (nosub nil) - (notbol nil) (noteol nil)) + (extended nil) (ignore-case nil) + (newline nil) (nosub nil) + (notbol nil) (noteol nil)) (regexp-exec (regexp-compile pattern :extended extended - :ignore-case ignore-case - :newline newline :nosub nosub) + :ignore-case ignore-case + :newline newline :nosub nosub) string :start start :end end :notbol notbol :noteol noteol)) ;; The following implementation of MATCH compiles the pattern @@ -43,23 +43,23 @@ (cons pattern (make-array '(2 2 2 2)))) (defun %match (patternbox string &key (start 0) (end nil) - (extended nil) (ignore-case nil) - (newline nil) (nosub nil) - (notbol nil) (noteol nil)) + (extended nil) (ignore-case nil) + (newline nil) (nosub nil) + (notbol nil) (noteol nil)) ;; Compile the pattern, if not already done. - (let ((compiled-pattern (aref (cdr patternbox) (if extended 0 1) - (if ignore-case 0 1) (if newline 0 1) - (if nosub 0 1)))) - (unless (and compiled-pattern #+ffi(ffi:validp compiled-pattern)) + (let ((compiled-pattern + (aref (cdr patternbox) (if extended 0 1) (if ignore-case 0 1) + (if newline 0 1) (if nosub 0 1)))) + (unless (and compiled-pattern #+ffi (ffi:validp compiled-pattern)) (setq compiled-pattern (regexp-compile (car patternbox) :extended extended :ignore-case ignore-case :newline newline :nosub nosub)) (setf (aref (cdr patternbox) (if extended 0 1) (if ignore-case 0 1) - (if newline 0 1) (if nosub 0 1)) + (if newline 0 1) (if nosub 0 1)) compiled-pattern)) (regexp-exec compiled-pattern string :start start :end end - :notbol notbol :noteol noteol))) + :notbol notbol :noteol noteol))) ;; Convert a match (of type MATCH) to a substring. (defun match-string (string match) @@ -89,20 +89,20 @@ qstring)) (defun regexp-split (pattern string &key (start 0) (end nil) - (extended nil) (ignore-case nil) - (newline nil) (nosub nil) - (notbol nil) (noteol nil)) + (extended nil) (ignore-case nil) + (newline nil) (nosub nil) + (notbol nil) (noteol nil)) "Split the STRING by the regexp PATTERN. Return a list of substrings of STRINGS." (loop :with compiled = (if (stringp pattern) (regexp-compile pattern :extended extended - :ignore-case ignore-case - :newline newline :nosub nosub) + :ignore-case ignore-case + :newline newline :nosub nosub) pattern) :for match = (regexp-exec compiled string :start start :end end - :notbol notbol :noteol noteol) + :notbol notbol :noteol noteol) :collect (make-array (- (if match (match-start match) (length string)) start) :element-type 'character @@ -122,21 +122,24 @@ (let ((compiled-pattern (gensym "WLS-")) (line (gensym "WLS-")) (nb (gensym "WLS-")) (ne (gensym "WLS-")) (st (gensym "WLS-")) (be (gensym "WLS-")) (en (gensym "WLS-"))) - `(loop - :with ,compiled-pattern = - (if (stringp ,pattern) - (regexp-compile ,pattern :extended ,extended - :ignore-case ,ignore-case - :newline ,newline :nosub ,nosub) + `(LOOP + :WITH ,compiled-pattern = + (IF (STRINGP ,pattern) + (REGEXP-COMPILE ,pattern :EXTENDED ,extended + :IGNORE-CASE ,ignore-case + :NEWLINE ,newline :NOSUB ,nosub) ,pattern) - :and ,ne = ,noteol :and ,nb = ,notbol :and ,st = ,stream - :and ,be = ,start :and ,en = ,end - :and ,var - :for ,line = (read-line ,st nil nil) - :while ,line - :do (setq ,var - (regexp-split ,compiled-pattern ,line :start ,be :end ,en - :notbol ,nb :noteol ,ne)) + :AND ,ne = ,noteol + :AND ,nb = ,notbol + :AND ,st = ,stream + :AND ,be = ,start + :AND ,en = ,end + :AND ,var + :FOR ,line = (READ-LINE ,st NIL NIL) + :WHILE ,line + :DO (SETQ ,var + (REGEXP-SPLIT ,compiled-pattern ,line :START ,be :END ,en + :NOTBOL ,nb :NOTEOL ,ne)) ,@forms))) (defun regexp-matcher (pattern) --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3981,1.3982 Date: Tue, 21 Dec 2004 11:47:13 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8039/src Modified Files: ChangeLog Log Message: Modernize package declaration. Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3981 retrieving revision 1.3982 diff -u -d -r1.3981 -r1.3982 --- ChangeLog 21 Dec 2004 11:45:37 -0000 1.3981 +++ ChangeLog 21 Dec 2004 11:47:10 -0000 1.3982 @@ -1,3 +1,10 @@ +2004-12-19 Bruno Haible <br...@cl...> + + * modules/wildcard/wildcard.lisp: Define package as case-inverted. + + * modules/regexp/regexp.lisp: Modernize package declaration. Improve + indentation. + 2004-12-18 Bruno Haible <br...@cl...> * places.lisp (get-setf-method, push, pop, psetf, pushnew, remf, --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3982,1.3983 format.lisp,1.39,1.40 Date: Tue, 21 Dec 2004 13:02:58 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24484 Modified Files: ChangeLog format.lisp Log Message: Signal TYPE-ERROR instead of ERROR when appropriate. Index: format.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/format.lisp,v retrieving revision 1.39 retrieving revision 1.40 diff -u -d -r1.39 -r1.40 --- format.lisp 20 Dec 2004 14:09:13 -0000 1.39 +++ format.lisp 21 Dec 2004 13:02:55 -0000 1.40 @@ -104,7 +104,7 @@ param ; parameter of a directive may begin (incf index) (when (>= index (length control-string)) - (format-error control-string index (errorstring)) + (format-error 'error control-string index (errorstring)) (go string-ended)) (setq ch (schar control-string index)) (when (digit-char-p ch) (go num-param)) @@ -125,7 +125,7 @@ (multiple-value-setq (intparam index) (parse-integer control-string :start index :junk-allowed t)) (unless intparam - (format-error control-string index + (format-error 'error control-string index (TEXT "~A must introduce a number.") ch)) (push intparam (csd-parm-list newcsd)) @@ -134,7 +134,7 @@ quote-param ; Quote-Parameter-Treatment (incf index) (when (>= index (length control-string)) - (format-error control-string index + (format-error 'error control-string index (TEXT "The control string terminates in the middle of a parameter.")) (go string-ended)) (setq ch (schar control-string index)) @@ -144,7 +144,7 @@ (incf index) param-ok-2 ; Parameter OK (when (>= index (length control-string)) - (format-error control-string index (errorstring)) + (format-error 'error control-string index (errorstring)) (go string-ended)) (setq ch (schar control-string index)) (case ch @@ -164,7 +164,7 @@ passed-modifier ; after : or @ (incf index) (when (>= index (length control-string)) - (format-error control-string index (errorstring)) + (format-error 'error control-string index (errorstring)) (go string-ended)) (setq ch (schar control-string index)) (case ch @@ -209,14 +209,14 @@ (#\! . FORMAT-CALL)))))) (if directive-name (setf (csd-data newcsd) directive-name) - (format-error control-string index + (format-error 'error control-string index (TEXT "Non-existent format directive")))) (incf index) (case ch (#\/ (let* ((start index) (end (or (position #\/ control-string :start start) - (format-error control-string index + (format-error 'error control-string index (TEXT "Closing '/' is missing")))) (pos (position #\: control-string :start start :end end)) (name (string-upcase @@ -230,7 +230,7 @@ (string-upcase (subseq control-string start pos)))) (or (find-package packname) - (format-error control-string index + (format-error 'error control-string index (TEXT "There is no package with name ~S") packname))) *common-lisp-user-package*))) @@ -248,18 +248,18 @@ (setf (csd-data newcsd) 'FORMAT-LOGICAL-BLOCK))) (( #\) #\] #\} #\> ) (unless stop-at - (format-error control-string index + (format-error 'error control-string index (TEXT "The closing format directive '~A' does not have a corresponding opening one.") ch)) (unless (eql ch stop-at) - (format-error control-string index + (format-error 'error control-string index (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 + (format-error 'error control-string index (TEXT "The ~~; format directive is not allowed at this point."))) (setf (csd-clause-chain last-separator-csd) csdl) (setq last-separator-csd newcsd)) @@ -267,7 +267,7 @@ (setf (csd-type newcsd) 0) (if (csd-colon-p newcsd) (if (csd-atsign-p newcsd) - (format-error control-string index + (format-error 'error control-string index (TEXT "The ~~newline format directive cannot take both modifiers.")) nil) ; ~:<newline> -> ignore Newline, retain Whitespace (progn @@ -284,7 +284,7 @@ string-ended (when stop-at - (format-error control-string index + (format-error 'error control-string index (TEXT "An opening format directive is never closed; expecting '~A'.") stop-at)) @@ -300,29 +300,38 @@ (defvar *FORMAT-NEXT-ARGLIST*) ; pointer to next sublist in ~:{ iteration (defvar *FORMAT-UP-AND-OUT* nil) ; reason for up-and-out -;; (format-error control-string errorpos errorcode . arguments) -;; signals an Error, that occurred in FORMAT. The position in the -;; Control-string is marked with an arrow. -(defun format-error (control-string errorpos errorstring &rest arguments) - (when control-string - (unless errorpos (setq errorpos (csd-cs-index (car *FORMAT-CSDL*)))) - (setq errorstring - (string-concat errorstring "~%" - (TEXT "Current point in control string:"))) - (let ((pos1 0) (pos2 0)) - (declare (simple-string errorstring) (fixnum pos1 pos2)) - (loop - (setq pos2 (or (position #\Newline control-string :start pos1) - (length control-string))) - (setq errorstring (string-concat errorstring "~% ~A")) - (setq arguments - (nconc arguments (list (substring control-string pos1 pos2)))) - (when (<= pos1 errorpos pos2) - (setq errorstring (string-concat errorstring "~%~VT" "|")) - (setq arguments (nconc arguments (list (+ (- errorpos pos1) 2))))) - (when (= pos2 (length control-string)) (return)) - (setq pos1 (+ pos2 1))))) - (apply #'error-of-type 'error errorstring arguments)) +;; (format-error type {keyword value}* control-string errorpos errorcode . arguments) +;; signals an Error of the given type, that occurred in FORMAT. The position +;; in the Control-string is marked with an arrow. +(defun format-error (type &rest arguments) + (let ((type-initargs '())) + (loop + (unless (keywordp (car arguments)) (return)) + (push (pop arguments) type-initargs) + (push (pop arguments) type-initargs)) + (let* ((control-string (pop arguments)) + (errorpos (pop arguments)) + (errorstring (pop arguments))) + (when control-string + (unless errorpos (setq errorpos (csd-cs-index (car *FORMAT-CSDL*)))) + (setq errorstring + (string-concat errorstring "~%" + (TEXT "Current point in control string:"))) + (let ((pos1 0) (pos2 0)) + (declare (simple-string errorstring) (fixnum pos1 pos2)) + (loop + (setq pos2 (or (position #\Newline control-string :start pos1) + (length control-string))) + (setq errorstring (string-concat errorstring "~% ~A")) + (setq arguments + (nconc arguments (list (substring control-string pos1 pos2)))) + (when (<= pos1 errorpos pos2) + (setq errorstring (string-concat errorstring "~%~VT" "|")) + (setq arguments (nconc arguments (list (+ (- errorpos pos1) 2))))) + (when (= pos2 (length control-string)) (return)) + (setq pos1 (+ pos2 1))))) + (apply #'error-of-type + type (nreconc type-initargs (list* errorstring arguments)))))) ;;; --------------------------------------------------------------------------- @@ -383,7 +392,7 @@ ;; list *FORMAT-NEXT-ARG*. (defun next-arg () (if (atom *FORMAT-NEXT-ARG*) - (format-error *FORMAT-CS* nil + (format-error 'error *FORMAT-CS* nil (TEXT "There are not enough arguments left for this format directive.")) (pop *FORMAT-NEXT-ARG*))) @@ -466,7 +475,8 @@ ;; prints arg as old-Roman number to stream, e.g. 4 as IIII. (defun format-old-roman (arg stream) (unless (and (integerp arg) (<= 1 arg 4999)) - (format-error *FORMAT-CS* nil + (format-error 'type-error :datum arg :expected-type '(INTEGER 1 4999) + *FORMAT-CS* nil (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)) @@ -481,7 +491,8 @@ ;; prints arg as new-Roman number to stream, e.g. 4 as IV. (defun format-new-roman (arg stream) (unless (and (integerp arg) (<= 1 arg 3999)) - (format-error *FORMAT-CS* nil + (format-error 'type-error :datum arg :expected-type '(INTEGER 1 3999) + *FORMAT-CS* nil (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)) @@ -537,7 +548,8 @@ (when (minusp arg) (write-string "minus " stream) (setq arg (- arg))) (labels ((blocks1000 (illions-list arg) ; decomposition in 1000er-Blocks (when (null illions-list) - (format-error *FORMAT-CS* nil + (format-error 'type-error :datum arg :expected-type '(INTEGER 0 999999999999999999999999999999999999999999999999999999999999999999) + *FORMAT-CS* nil (TEXT "The argument for the ~~R format directive is too large."))) (multiple-value-bind (thousands small) (truncate arg 1000) (when (> thousands 0) @@ -1189,7 +1201,8 @@ (if colon-modifier (format-old-roman arg stream) (format-new-roman arg stream)) - (format-error *FORMAT-CS* nil + (format-error 'type-error :datum arg :expected-type 'INTEGER + *FORMAT-CS* nil (TEXT "The ~~R and ~~:R format directives require an integer argument, not ~S") arg)) (if colon-modifier @@ -1208,7 +1221,8 @@ (defformat-simple format-character (stream colon-modifier atsign-modifier) (arg) (unless (characterp arg) - (format-error *FORMAT-CS* nil + (format-error 'type-error :datum arg :type 'CHARACTER + *FORMAT-CS* nil (TEXT "The ~~C format directive requires a character argument, not ~S") arg)) (if (not colon-modifier) @@ -1427,11 +1441,13 @@ (let ((*FORMAT-CS* nil)) (apply node stream arglistarg)))) ; wholelistarg?? (defun format-indirection-cserror (csarg) - (format-error *FORMAT-CS* nil + (format-error 'type-error :datum csarg :expected-type '(OR STRING FUNCTION) + *FORMAT-CS* nil (TEXT "The control string argument for the ~~? format directive is invalid: ~S") csarg)) (defun format-indirection-lerror (arguments) - (format-error *FORMAT-CS* nil + (format-error 'type-error :datum arguments :expected-type 'LIST + *FORMAT-CS* nil (TEXT "The argument list argument for the ~~? format directive is invalid: ~S") arguments)) @@ -1481,11 +1497,12 @@ (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*)) (format-interpret stream 'FORMAT-CONDITIONAL-END) (unless (null (csd-clause-chain (car *FORMAT-CSDL*))) - (format-error *FORMAT-CS* nil + (format-error 'error *FORMAT-CS* nil (TEXT "The ~~; format directive is not allowed at this point.")))) (let ((index (or prefix (next-arg)))) (unless (integerp index) - (format-error *FORMAT-CS* nil + (format-error 'type-error :datum index :expected-type 'INTEGER + *FORMAT-CS* nil (TEXT "The ~~[ parameter must be an integer, not ~S") index)) (dotimes (i (if (minusp index) most-positive-fixnum index)) @@ -1499,7 +1516,7 @@ (format-skip-to-end)) ; skip to the end of ~[...~]-Directive (defun format-conditional-error () - (format-error *FORMAT-CS* nil + (format-error 'error *FORMAT-CS* nil (TEXT "The ~~[ format directive cannot take both modifiers."))) ; ~{, CLTL p.403-404, CLtL2 p. 602-604 @@ -1521,7 +1538,8 @@ (arg-list-rest (if (not atsign-modifier) (let ((arg (next-arg))) (unless (listp arg) - (format-error *FORMAT-CS* nil + (format-error 'type-error :datum arg :expected-type 'LIST + *FORMAT-CS* nil (TEXT "The ~~{ format directive requires a list argument, not ~S") arg)) arg)))) @@ -1647,7 +1665,7 @@ ;; CLtL2 p. 762-763 (defun format-logical-block (stream colon-modifier atsign-modifier) - ;; (format-error *FORMAT-CS* nil (TEXT "~~<...~~:> not implemented yet")) + ;; (format-error 'error *FORMAT-CS* nil (TEXT "~~<...~~:> not implemented yet")) (format-justification stream colon-modifier atsign-modifier)) ;; parse the CSDL and return the following values @@ -1673,7 +1691,7 @@ (setq prefix (subseq *FORMAT-CS* (csd-cs-index (car csdl)) (csd-data (car csdl)))) (pop csdl)) - (t (format-error *FORMAT-CS* (csd-cs-index (car csdl)) + (t (format-error 'error *FORMAT-CS* (csd-cs-index (car csdl)) (TEXT "Prefix for logical block must be constant"))))) (setq body-csdl (cdr csdl)) (setq temp (csd-clause-chain (car csdl))) @@ -1685,7 +1703,7 @@ (pop temp)))) (unless (and (eql (csd-type (car temp)) 2) (eq (csd-data (car temp)) 'FORMAT-JUSTIFICATION-END)) - (format-error *FORMAT-CS* (csd-cs-index (car temp)) + (format-error 'error *FORMAT-CS* (csd-cs-index (car temp)) (TEXT "Logical block suffix must be constant"))) (setq add-fill-p (csd-atsign-p (car temp))) (values prefix suffix per-line-p body-csdl add-fill-p temp))) @@ -2037,7 +2055,7 @@ (arglist (mapcar #'formatter-arg (csd-parm-list csd)))) (labels ((simple-arglist (n) (unless (<= (length arglist) n) - (format-error *format-cs* nil + (format-error 'error *format-cs* nil (TEXT "Too many arguments for this format directive"))) (setq arglist (append arglist @@ -2276,7 +2294,7 @@ (SETQ ,*args* (CDR ,*args*))) forms) (unless (null (csd-clause-chain (car *format-csdl*))) - (format-error *format-cs* nil + (format-error 'error *format-cs* nil (TEXT "The ~~; format directive is not allowed at this point.")))) (progn (simple-arglist 1) @@ -2441,7 +2459,7 @@ body-csdl add-fill last-csdl) (format-logical-block-parse *FORMAT-CSDL*) ;(when add-fill - ; (format-error *FORMAT-CS* + ; (format-error 'error *FORMAT-CS* ; (csd-cs-index (car *FORMAT-CSDL*)) ; (TEXT "Error: ~~:@> not implemented"))) (setq *FORMAT-CSDL* body-csdl) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3982 retrieving revision 1.3983 diff -u -d -r1.3982 -r1.3983 --- ChangeLog 21 Dec 2004 11:47:10 -0000 1.3982 +++ ChangeLog 21 Dec 2004 13:02:46 -0000 1.3983 @@ -1,3 +1,14 @@ +2004-12-21 Bruno Haible <br...@cl...> + + * format.lisp (format-error): Take additional arguments specifying the + error type and initargs. + (format-parse-cs, next-arg, format-old-roman, format-new-roman, + format-cardinal, format-radix, format-character, + format-indirection-cserror, format-indirection-lerror, + format-conditional, format-conditional-error, format-iteration, + format-logical-block, format-logical-block-parse, formatter-main-1): + Pass error type and initargs to format-error. + 2004-12-19 Bruno Haible <br...@cl...> * modules/wildcard/wildcard.lisp: Define package as case-inverted. --__--__-- Message: 5 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/utils clispload.lsp,1.37,1.38 Date: Tue, 21 Dec 2004 13:03:48 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/utils In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24920 Modified Files: clispload.lsp Log Message: Remove a few expected failures. Index: clispload.lsp =================================================================== RCS file: /cvsroot/clisp/clisp/utils/clispload.lsp,v retrieving revision 1.37 retrieving revision 1.38 diff -u -d -r1.37 -r1.38 --- clispload.lsp 20 Dec 2004 14:10:31 -0000 1.37 +++ clispload.lsp 21 Dec 2004 13:03:45 -0000 1.38 @@ -159,15 +159,6 @@ ;; an argument"; so only one argument is consumed (by the V, not by ~[). FORMATTER.COND.13 FORMATTER.COND.14 |FORMATTER.COND:.6| |FORMATTER.COND:.7| - ;; Paul Dietz expects that FORMAT signals an error of type TYPE-ERROR in - ;; some cases. - ;; However, ANSI CL 22.3. doesn't require this. - ;; CLISP happens to signal an error of type ERROR in this cases. - FORMAT.{.ERROR.1 FORMAT.{.ERROR.2 FORMAT.{.ERROR.3 FORMAT.{.ERROR.4 - FORMAT.{.ERROR.5 |FORMAT.:{.ERROR.1| |FORMAT.:{.ERROR.2| |FORMAT.:{.ERROR.4| - |FORMAT.:{.ERROR.5| |FORMAT.:@.ERROR.1| |FORMAT.:@.ERROR.2| - |FORMAT.:@.ERROR.3| |FORMAT.:@.ERROR.4| |FORMAT.:@.ERROR.5| - ; To be fixed: PATHNAME-MATCH-P.4 --__--__-- Message: 6 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src predtype.d,1.126,1.127 sequence.d,1.94,1.95 subtypep.lisp,1.10,1.11 ChangeLog,1.3983,1.3984 Date: Tue, 21 Dec 2004 13:58:13 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8375 Modified Files: predtype.d sequence.d subtypep.lisp ChangeLog Log Message: Treat cl-cs:string and cl:string the same way. Index: subtypep.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/subtypep.lisp,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- subtypep.lisp 22 Nov 2004 10:14:44 -0000 1.10 +++ subtypep.lisp 21 Dec 2004 13:58:08 -0000 1.11 @@ -1382,7 +1382,7 @@ (SIMPLE-BIT-VECTOR ; (canonicalize-type (list type)) => '(SIMPLE-ARRAY BIT (*))) - (STRING + ((STRING cs-cl:string) ; (canonicalize-type (list type)) => '(OR (ARRAY CHARACTER (*)) #-BASE-CHAR=CHARACTER (ARRAY BASE-CHAR (*)) @@ -1535,7 +1535,7 @@ (unless (or (eq size '*) (and (integerp size) (>= size 0))) (typespec-error 'subtypep type)) `(ARRAY BIT (,size)))) - (STRING ; (STRING &optional size) + ((STRING cs-cl:string) ; (STRING &optional size) (when (cddr type) (typespec-error 'subtypep type)) (let ((size (if (cdr type) (second type) '*))) Index: sequence.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/sequence.d,v retrieving revision 1.94 retrieving revision 1.95 diff -u -d -r1.94 -r1.95 --- sequence.d 13 Dec 2004 12:02:48 -0000 1.94 +++ sequence.d 21 Dec 2004 13:58:08 -0000 1.95 @@ -156,7 +156,8 @@ if (eq(name,S(simple_vector))) { name = S(vector); goto expanded_unconstrained; } if (eq(name,S(string))) { goto expanded_unconstrained; } - if (eq(name,S(simple_string)) || eq(name,S(base_string)) + if (eq(name,S(cs_string)) + || eq(name,S(simple_string)) || eq(name,S(base_string)) || eq(name,S(simple_base_string))) { name = S(string); goto expanded_unconstrained; } if (eq(name,S(bit_vector)) || eq(name,S(simple_bit_vector))) @@ -171,7 +172,8 @@ if (nullp(name2) || (consp(name2) && nullp(Cdr(name2)))) { if (eq(name1,S(simple_vector))) { name = S(vector); goto expanded_maybe_constrained; } - if (eq(name1,S(string)) || eq(name1,S(simple_string)) + if (eq(name1,S(string)) || eq(name1,S(cs_string)) + || eq(name1,S(simple_string)) || eq(name1,S(base_string)) || eq(name1,S(simple_base_string))) { name = S(string); goto expanded_maybe_constrained; } if (eq(name1,S(bit_vector)) || eq(name1,S(simple_bit_vector))) Index: predtype.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/predtype.d,v retrieving revision 1.126 retrieving revision 1.127 diff -u -d -r1.126 -r1.127 --- predtype.d 11 Dec 2004 14:16:12 -0000 1.126 +++ predtype.d 21 Dec 2004 13:58:07 -0000 1.127 @@ -2351,7 +2351,7 @@ || eq(result_type,S(simple_array)) /* SIMPLE-ARRAY ? */ || eq(result_type,S(vector)) /* VECTOR ? */ || eq(result_type,S(simple_vector)) /* SIMPLE-VECTOR ? */ - || eq(result_type,S(string)) /* STRING ? */ + || eq(result_type,S(string)) || eq(result_type,S(cs_string)) /* STRING ? */ || eq(result_type,S(simple_string)) /* SIMPLE-STRING ? */ || eq(result_type,S(base_string)) /* BASE-STRING ? */ || eq(result_type,S(simple_base_string)) /* SIMPLE-BASE-STRING ? */ @@ -2442,7 +2442,7 @@ || eq(type,S(simple_array)) /* SIMPLE-ARRAY ? */ || eq(type,S(vector)) /* VECTOR ? */ || eq(type,S(simple_vector)) /* SIMPLE-VECTOR ? */ - || eq(type,S(string)) /* STRING ? */ + || eq(type,S(string)) || eq(type,S(cs_string)) /* STRING ? */ || eq(type,S(simple_string)) /* SIMPLE-STRING ? */ || eq(type,S(base_string)) /* BASE-STRING ? */ || eq(type,S(simple_base_string)) /* SIMPLE-BASE-STRING ? */ Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3983 retrieving revision 1.3984 diff -u -d -r1.3983 -r1.3984 --- ChangeLog 21 Dec 2004 13:02:46 -0000 1.3983 +++ ChangeLog 21 Dec 2004 13:58:08 -0000 1.3984 @@ -1,5 +1,11 @@ 2004-12-21 Bruno Haible <br...@cl...> + * predtype.d (COERCE): Accept cs-cl:string as equivalent to cl:string. + * sequence.d (valid_type1): Likewise. + * subtypep.lisp (canonicalize-type): Likewise. + +2004-12-21 Bruno Haible <br...@cl...> + * format.lisp (format-error): Take additional arguments specifying the error type and initargs. (format-parse-cs, next-arg, format-old-roman, format-new-roman, --__--__-- Message: 7 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/utils clispload.lsp,1.38,1.39 Date: Tue, 21 Dec 2004 14:07:26 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/utils In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10557 Modified Files: clispload.lsp Log Message: Paul Dietz fixed two tests. Index: clispload.lsp =================================================================== RCS file: /cvsroot/clisp/clisp/utils/clispload.lsp,v retrieving revision 1.38 retrieving revision 1.39 diff -u -d -r1.38 -r1.39 --- clispload.lsp 21 Dec 2004 13:03:45 -0000 1.38 +++ clispload.lsp 21 Dec 2004 14:07:23 -0000 1.39 @@ -157,7 +157,7 @@ ;; Paul Dietz assumes that FORMAT ~V[ consumes two arguments. ;; However, ANSI CL 22.3.7.2. says that "the parameter is used instead of ;; an argument"; so only one argument is consumed (by the V, not by ~[). - FORMATTER.COND.13 FORMATTER.COND.14 |FORMATTER.COND:.6| |FORMATTER.COND:.7| + FORMATTER.COND.14 |FORMATTER.COND:.7| ; To be fixed: PATHNAME-MATCH-P.4 --__--__-- Message: 8 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3984,1.3985 Date: Tue, 21 Dec 2004 23:18:42 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15262/src Modified Files: ChangeLog Log Message: formatting Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3984 retrieving revision 1.3985 diff -u -d -r1.3984 -r1.3985 --- ChangeLog 21 Dec 2004 13:58:08 -0000 1.3984 +++ ChangeLog 21 Dec 2004 23:18:35 -0000 1.3985 @@ -6,13 +6,13 @@ 2004-12-21 Bruno Haible <br...@cl...> - * format.lisp (format-error): Take additional arguments specifying the - error type and initargs. - (format-parse-cs, next-arg, format-old-roman, format-new-roman, - format-cardinal, format-radix, format-character, - format-indirection-cserror, format-indirection-lerror, - format-conditional, format-conditional-error, format-iteration, - format-logical-block, format-logical-block-parse, formatter-main-1): + * format.lisp (format-error): Take additional arguments specifying + the error type and initargs. + (format-parse-cs, next-arg, format-old-roman, format-new-roman) + (format-cardinal, format-radix, format-character) + (format-indirection-cserror, format-indirection-lerror) + (format-conditional, format-conditional-error, format-iteration) + (format-logical-block, format-logical-block-parse, formatter-main-1): Pass error type and initargs to format-error. 2004-12-19 Bruno Haible <br...@cl...> --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |