CMUCL commit: intl-branch src/compiler (ctype.lisp)
Raymond Toy
rtoy at common-lisp.net
Tue Mar 9 21:08:10 CET 2010
Date: Tuesday, March 9, 2010 @ 15:08:10
Author: rtoy
Path: /project/cmucl/cvsroot/src/compiler
Tag: intl-branch
Modified: ctype.lisp
Support plurals in note-lossage/note-slime.
o Change NOTE-LOSSAGE to be a macro to wrap the format string in a
function. NOTE-LOSSAGE cals %NOTE-LOSSAGE
o Add %NOTE-LOSSAGE that is the same as the original NOTE-LOSSAGE
except the format string is now a function that returns a string.
This allows us to delay doing the domain lookup until we want to
generate the message.
o Do the same for NOTE-SLIME.
o Update strings to use NGETTEXT as needed.
------------+
ctype.lisp | 98 ++++++++++++++++++++++++++++++++++++-----------------------
1 file changed, 61 insertions(+), 37 deletions(-)
Index: src/compiler/ctype.lisp
diff -u src/compiler/ctype.lisp:1.35.52.3 src/compiler/ctype.lisp:1.35.52.4
--- src/compiler/ctype.lisp:1.35.52.3 Fri Feb 12 00:52:24 2010
+++ src/compiler/ctype.lisp Tue Mar 9 15:08:09 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/ctype.lisp,v 1.35.52.3 2010-02-12 05:52:24 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/ctype.lisp,v 1.35.52.4 2010-03-09 20:08:09 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -52,17 +52,25 @@
;;;
;;; Signal a warning if appropriate and set the *lossage-detected* flag.
;;;
-(defun note-lossage (format-string &rest format-args)
- (declare (string format-string))
+(defun %note-lossage (format-string-thunk &rest format-args)
(setq *lossage-detected* t)
(when *error-function*
- (apply *error-function* (intl:gettext format-string) format-args)))
+ (apply *error-function* (funcall format-string-thunk) format-args)))
+
+(defmacro note-lossage (format-string &rest format-args)
+ `(%note-lossage #'(lambda ()
+ ,format-string)
+ , at format-args))
;;;
-(defun note-slime (format-string &rest format-args)
- (declare (string format-string))
+(defun %note-slime (format-string-thunk &rest format-args)
(setq *slime-detected* t)
(when *warning-function*
- (apply *warning-function* (intl:gettext format-string) format-args)))
+ (apply *warning-function* (funcall format-string-thunk) format-args)))
+
+(defmacro note-slime (format-string &rest format-args)
+ `(%note-slime #'(lambda ()
+ ,format-string)
+ , at format-args))
(declaim (special *compiler-error-context*))
@@ -131,22 +139,28 @@
((not (or optional keyp rest))
(if (/= nargs min-args)
(note-lossage
- _N"Function called with ~R argument~:P, but wants exactly ~R."
+ (intl:ngettext "Function called with ~R argument, but wants exactly ~R."
+ "Function called with ~R arguments, but wants exactly ~R."
+ nargs)
nargs min-args)
(check-fixed-and-rest args required nil)))
((< nargs min-args)
(note-lossage
- _N"Function called with ~R argument~:P, but wants at least ~R."
+ (intl:ngettext "Function called with ~R argument, but wants at least ~R."
+ "Function called with ~R arguments, but wants at least ~R."
+ nargs)
nargs min-args))
((<= nargs max-args)
(check-fixed-and-rest args (append required optional) rest))
((not (or keyp rest))
(note-lossage
- _N"Function called with ~R argument~:P, but wants at most ~R."
+ (intl:ngettext "Function called with ~R argument, but wants at most ~R."
+ "Function called with ~R arguments, but wants at most ~R."
+ nargs)
nargs max-args))
((and keyp (oddp (- nargs max-args)))
(note-lossage
- _N"Function has an odd number of arguments in the keyword portion."))
+ _"Function has an odd number of arguments in the keyword portion."))
(t
(check-fixed-and-rest args (append required optional) rest)
(when keyp
@@ -164,10 +178,10 @@
(multiple-value-bind (int win)
(funcall result-test out-type return-type)
(cond ((not win)
- (note-slime _N"Can't tell whether the result is a ~S."
+ (note-slime _"Can't tell whether the result is a ~S."
(type-specifier return-type)))
((not int)
- (note-lossage _N"The result is a ~S, not a ~S."
+ (note-lossage _"The result is a ~S, not a ~S."
(type-specifier out-type)
(type-specifier return-type))))))
@@ -193,20 +207,20 @@
(multiple-value-bind (int win)
(funcall *test-function* ctype type)
(cond ((not win)
- (note-slime _N"Can't tell whether the ~:R argument is a ~S." n
+ (note-slime _"Can't tell whether the ~:R argument is a ~S." n
(type-specifier type))
nil)
((not int)
- (note-lossage _N"The ~:R argument is a ~S, not a ~S." n
+ (note-lossage _"The ~:R argument is a ~S, not a ~S." n
(type-specifier ctype)
(type-specifier type))
nil)
((eq ctype *empty-type*)
- (note-slime _N"The ~:R argument never returns a value." n)
+ (note-slime _"The ~:R argument never returns a value." n)
nil)
(t t)))))
((not (constant-continuation-p cont))
- (note-slime _N"The ~:R argument is not a constant." n)
+ (note-slime _"The ~:R argument is not a constant." n)
nil)
(t
(let ((val (continuation-value cont))
@@ -214,12 +228,12 @@
(multiple-value-bind (res win)
(ctypep val type)
(cond ((not win)
- (note-slime _N"Can't tell whether the ~:R argument is a ~
+ (note-slime _"Can't tell whether the ~:R argument is a ~
constant ~S:~% ~S"
n (type-specifier type) val)
nil)
((not res)
- (note-lossage _N"The ~:R argument is not a constant ~S:~% ~S"
+ (note-lossage _"The ~:R argument is not a constant ~S:~% ~S"
n (type-specifier type) val)
nil)
(t t)))))))
@@ -264,7 +278,7 @@
(cond
((not (check-arg-type k (specifier-type 'symbol) n)))
((not (constant-continuation-p k))
- (note-slime _N"The ~:R argument (in keyword position) is not a constant."
+ (note-slime _"The ~:R argument (in keyword position) is not a constant."
n))
(t
(let* ((name (continuation-value k))
@@ -288,12 +302,12 @@
(setq allow-other-keys (continuation-value value))
(progn
(setq allow-other-keys t)
- (note-slime _N"The value of ~S is not a constant"
+ (note-slime _"The value of ~S is not a constant"
:allow-other-keys)))
(setq allow-other-keys-seen t))))
((not info)
(unless (function-type-allowp type)
- (note-lossage _N"~S is not a known argument keyword."
+ (note-lossage _"~S is not a known argument keyword."
name)))
(t
(check-arg-type (second key) (key-info-type info)
@@ -482,18 +496,22 @@
(let ((call-min (approximate-function-type-min-args call-type)))
(when (< call-min min-args)
(note-lossage
- _N"Function previously called with ~R argument~:P, but wants at least ~R."
+ (intl:ngettext "Function previously called with ~R argument, but wants at least ~R."
+ "Function previously called with ~R arguments, but wants at least ~R."
+ call-min)
call-min min-args)))
(let ((call-max (approximate-function-type-max-args call-type)))
(cond ((<= call-max max-args))
((not (or keyp rest))
(note-lossage
- _N"Function previously called with ~R argument~:P, but wants at most ~R."
+ (intl:ngettext "Function previously called with ~R argument, but wants at most ~R."
+ "Function previously called with ~R arguments, but wants at most ~R."
+ call-max)
call-max max-args))
((and keyp (oddp (- call-max max-args)))
(note-lossage
- _N"Function previously called with an odd number of arguments in ~
+ _"Function previously called with an odd number of arguments in ~
the keyword portion.")))
(when (and keyp (> call-max max-args))
@@ -538,13 +556,13 @@
(funcall *test-function* ctype decl-type)
(cond
((not win)
- (note-slime _N"Can't tell whether previous ~? argument type ~S is a ~S."
+ (note-slime _"Can't tell whether previous ~? argument type ~S is a ~S."
context args (type-specifier ctype) (type-specifier decl-type)))
((not int)
(setq losers (type-union ctype losers))))))
(unless (eq losers *empty-type*)
- (note-lossage _N"~:(~?~) argument should be a ~S but was a ~S in a previous call."
+ (note-lossage _"~:(~?~) argument should be a ~S but was a ~S in a previous call."
context args (type-specifier decl-type) (type-specifier losers)))))
@@ -580,7 +598,7 @@
(dolist (name (names))
(unless (find name keys :key #'key-info-name)
- (note-lossage _N"Function previously called with unknown argument keyword ~S."
+ (note-lossage _"Function previously called with unknown argument keyword ~S."
name)))))))
@@ -601,7 +619,7 @@
(cond
((eq int *empty-type*)
(note-lossage
- _N"Definition's declared type for variable ~A:~% ~S~@
+ _"Definition's declared type for variable ~A:~% ~S~@
conflicts with this type from ~A:~% ~S"
(leaf-name var) (type-specifier vtype)
where (type-specifier type))
@@ -646,7 +664,9 @@
(flet ((frob (x y what)
(unless (= x y)
(note-lossage
- _N"Definition has ~R ~A arg~P, but ~A has ~R."
+ (intl:ngettext "Definition has ~R ~A arg, but ~A has ~R."
+ "Definition has ~R ~A args, but ~A has ~R."
+ x)
x what x where y))))
;; TRANSLATORS: Usage is "Definition has <n> FIXED args but <where> <m>"
;; TRANSLATORS: Translate FIXED above appropriately.
@@ -656,8 +676,10 @@
(frob (- (optional-dispatch-max-args od) min) (length opt) _"optional"))
(flet ((frob (x y what)
(unless (eq x y)
+ ;; TRANSLATORS: This format string probably needs to be
+ ;; TRANSLATORS: updated to allow better translations.
(note-lossage
- _N"Definition ~:[doesn't have~;has~] ~A, but ~
+ _"Definition ~:[doesn't have~;has~] ~A, but ~
~A ~:[doesn't~;does~]."
x what where y))))
(frob (optional-dispatch-keyp od) (function-type-keyp type)
@@ -693,7 +715,7 @@
(or def-type (specifier-type 'null)))))
(t
(note-lossage
- _N"Defining a ~S keyword not present in ~A."
+ _"Defining a ~S keyword not present in ~A."
key where)
(res *universal-type*)))))
(:required (res (pop req)))
@@ -723,7 +745,7 @@
(when info
(arg-info-keyword info)))))
(note-lossage
- _N"Definition lacks the ~S keyword present in ~A."
+ _"Definition lacks the ~S keyword present in ~A."
(key-info-name key) where))))
(try-type-intersections (vars) (res) where))))
@@ -738,7 +760,7 @@
(flet ((frob (x what)
(when x
(note-lossage
- _N"Definition has no ~A, but the ~A did."
+ _"Definition has no ~A, but the ~A did."
what where))))
(frob (function-type-optional type) _"optional args")
(frob (function-type-keyp type) _"keyword args")
@@ -748,7 +770,9 @@
(req (function-type-required type))
(nreq (length req)))
(unless (= nvars nreq)
- (note-lossage _N"Definition has ~R arg~:P, but the ~A has ~R."
+ (note-lossage (intl:ngettext "Definition has ~R arg, but the ~A has ~R."
+ "Definition has ~R args, but the ~A has ~R."
+ nvars)
nvars where nreq))
(if *lossage-detected*
(values nil nil)
@@ -795,7 +819,7 @@
(cond
((and atype (not (values-types-intersect atype type-returns)))
(note-lossage
- _N"The result type from ~A:~% ~S~@
+ _"The result type from ~A:~% ~S~@
conflicts with the definition's result type assertion:~% ~S"
where (type-specifier type-returns) (type-specifier atype))
nil)
@@ -809,7 +833,7 @@
(when (and warning-function
(not (csubtypep (leaf-type var) type)))
(funcall warning-function
- _N"Assignment to argument: ~S~% ~
+ _"Assignment to argument: ~S~% ~
prevents use of assertion from function ~
type ~A:~% ~S~%"
(leaf-name var) where (type-specifier type))))
More information about the cmucl-commit
mailing list