* bug#16520: 24.3.50; cl-defstruct with :predicate option
@ 2014-01-22 10:06 Helmut Eller
2014-01-22 13:47 ` Stefan Monnier
2014-01-23 15:02 ` Stefan Monnier
0 siblings, 2 replies; 10+ messages in thread
From: Helmut Eller @ 2014-01-22 10:06 UTC (permalink / raw)
To: 16520
Compiling this code:
(require 'cl-lib)
(cl-defstruct (foo (:predicate foop)))
(defun bar (x) (cl-check-type x foo))
with with: emacs -Q -batch -f batch-byte-compile foo.el
produces this warning:
foo.el:8:1:Warning: the function `foo-p' is not known to be defined.
and since foo-p is not defined will also lead errors at run-time when
bar is called.
Adding eval-and-compile to the structure definition avoids the problem
but it's a bug that the compiler emits a call to foo-p at all.
In GNU Emacs 24.3.50.2 (i686-pc-linux-gnu, GTK+ Version 2.24.10)
of 2014-01-20 on ix
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#16520: 24.3.50; cl-defstruct with :predicate option
2014-01-22 10:06 bug#16520: 24.3.50; cl-defstruct with :predicate option Helmut Eller
@ 2014-01-22 13:47 ` Stefan Monnier
2014-01-23 15:02 ` Stefan Monnier
1 sibling, 0 replies; 10+ messages in thread
From: Stefan Monnier @ 2014-01-22 13:47 UTC (permalink / raw)
To: Helmut Eller; +Cc: 16520
> Compiling this code:
> (require 'cl-lib)
> (cl-defstruct (foo (:predicate foop)))
> (defun bar (x) (cl-check-type x foo))
> with with: emacs -Q -batch -f batch-byte-compile foo.el
> produces this warning:
> foo.el:8:1:Warning: the function `foo-p' is not known to be defined.
Hmm... indeed, that's bad.
Stefan
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#16520: 24.3.50; cl-defstruct with :predicate option
2014-01-22 10:06 bug#16520: 24.3.50; cl-defstruct with :predicate option Helmut Eller
2014-01-22 13:47 ` Stefan Monnier
@ 2014-01-23 15:02 ` Stefan Monnier
2014-01-29 10:00 ` Helmut Eller
1 sibling, 1 reply; 10+ messages in thread
From: Stefan Monnier @ 2014-01-23 15:02 UTC (permalink / raw)
To: Helmut Eller; +Cc: 16520-done
Version: 24.4
> (cl-defstruct (foo (:predicate foop)))
> (defun bar (x) (cl-check-type x foo))
[...]
> foo.el:8:1:Warning: the function `foo-p' is not known to be defined.
Thanks, should be fixed now (more or less: it's an ugly hack).
Stefan
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#16520: 24.3.50; cl-defstruct with :predicate option
2014-01-23 15:02 ` Stefan Monnier
@ 2014-01-29 10:00 ` Helmut Eller
2014-01-29 13:59 ` Stefan Monnier
0 siblings, 1 reply; 10+ messages in thread
From: Helmut Eller @ 2014-01-29 10:00 UTC (permalink / raw)
To: 16520
On Thu, Jan 23 2014, Stefan Monnier wrote:
> Version: 24.4
>
>> (cl-defstruct (foo (:predicate foop)))
>> (defun bar (x) (cl-check-type x foo))
> [...]
>> foo.el:8:1:Warning: the function `foo-p' is not known to be defined.
>
> Thanks, should be fixed now (more or less: it's an ugly hack).
The fix doesn't work for this example:
(require 'cl-lib)
(cl-defstruct (foo (:predicate foo?)))
(defun bar (x) (cl-check-type x foo))
neither for
(cl-defstruct (foo (:predicate nil)))
Helmut
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#16520: 24.3.50; cl-defstruct with :predicate option
2014-01-29 10:00 ` Helmut Eller
@ 2014-01-29 13:59 ` Stefan Monnier
2014-01-29 17:47 ` Helmut Eller
0 siblings, 1 reply; 10+ messages in thread
From: Stefan Monnier @ 2014-01-29 13:59 UTC (permalink / raw)
To: Helmut Eller; +Cc: 16520
> The fix doesn't work for this example:
> (require 'cl-lib)
> (cl-defstruct (foo (:predicate foo?)))
> (defun bar (x) (cl-check-type x foo))
Indeed. But it should work for:
(require 'cl-lib)
(cl-defstruct (foo (:predicate foo?)))
(defun bar (x) (cl-check-type x foo?))
> neither for
> (cl-defstruct (foo (:predicate nil)))
Not sure if it should work in that case,
Stefan
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#16520: 24.3.50; cl-defstruct with :predicate option
2014-01-29 13:59 ` Stefan Monnier
@ 2014-01-29 17:47 ` Helmut Eller
2014-01-30 3:58 ` Stefan Monnier
0 siblings, 1 reply; 10+ messages in thread
From: Helmut Eller @ 2014-01-29 17:47 UTC (permalink / raw)
To: 16520
On Wed, Jan 29 2014, Stefan Monnier wrote:
>> The fix doesn't work for this example:
>
>> (require 'cl-lib)
>> (cl-defstruct (foo (:predicate foo?)))
>> (defun bar (x) (cl-check-type x foo))
>
> Indeed. But it should work for:
>
> (require 'cl-lib)
> (cl-defstruct (foo (:predicate foo?)))
> (defun bar (x) (cl-check-type x foo?))
Which is arguably a bug. If the goal is to imitate Common Lisp
semantics then the type name is foo not foo?. If I wanted to call a
predicate I would have written (check-type x (satisfies foo?)).
>> neither for
>> (cl-defstruct (foo (:predicate nil)))
>
> Not sure if it should work in that case,
It does work in Common Lisp.
Helmut
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#16520: 24.3.50; cl-defstruct with :predicate option
2014-01-29 17:47 ` Helmut Eller
@ 2014-01-30 3:58 ` Stefan Monnier
2014-01-30 12:07 ` Helmut Eller
0 siblings, 1 reply; 10+ messages in thread
From: Stefan Monnier @ 2014-01-30 3:58 UTC (permalink / raw)
To: Helmut Eller; +Cc: 16520
>>> neither for
>>> (cl-defstruct (foo (:predicate nil)))
>> Not sure if it should work in that case,
> It does work in Common Lisp.
Then.. patch welcome ;-)
Stefan
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#16520: 24.3.50; cl-defstruct with :predicate option
2014-01-30 3:58 ` Stefan Monnier
@ 2014-01-30 12:07 ` Helmut Eller
2014-01-30 14:43 ` Stefan Monnier
0 siblings, 1 reply; 10+ messages in thread
From: Helmut Eller @ 2014-01-30 12:07 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 16520
[-- Attachment #1: Type: text/plain, Size: 239 bytes --]
On Thu, Jan 30 2014, Stefan Monnier wrote:
>>>> neither for
>>>> (cl-defstruct (foo (:predicate nil)))
>>> Not sure if it should work in that case,
>> It does work in Common Lisp.
>
> Then.. patch welcome ;-)
Maybe something like this:
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: defstruct.patch --]
[-- Type: text/x-diff, Size: 3096 bytes --]
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 45448ec..d8e62c3 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2569,6 +2569,7 @@ non-nil value, that slot cannot be set via `setf'.
(push `(cl-eval-when (compile load eval)
(put ',name 'cl-struct-slots ',descs)
(put ',name 'cl-struct-type ',(list type (eq named t)))
+ (put ',name 'cl-struct-tag-symbol ',tag-symbol)
(put ',name 'cl-struct-include ',include)
(put ',name 'cl-struct-print ,print-auto)
,@(mapcar (lambda (x)
@@ -2599,6 +2600,26 @@ Of course, we really can't know that for sure, so it's just a heuristic."
(or (cdr (assq sym byte-compile-function-environment))
(cdr (assq sym byte-compile-macro-environment))))))
+(defun cl--make-struct-type-test (val type)
+ (let* ((stype (get type 'cl-struct-type))
+ (slots (get type 'cl-struct-slots))
+ (tag-symbol (get type 'cl-struct-tag-symbol))
+ (pos (cl-loop for i from 0 for s in slots
+ when (eq (car s) 'cl-tag-slot) return i)))
+ (or pos (error "Not a named struct: %s" type))
+ (cl-ecase (car stype)
+ (vector `(and (vectorp ,val)
+ (>= (length ,val) ,(length slots))
+ (memq (aref ,val ,pos) ,tag-symbol)
+ t))
+ (list (cond ((zerop pos)
+ `(and (memq (car-safe ,val) ,tag-symbol)
+ t))
+ (t
+ `(and (consp ,val)
+ (memq (nth ,pos ,val) ,tag-symbol)
+ t)))))))
+
(defun cl--make-type-test (val type)
(if (symbolp type)
(cond ((get type 'cl-deftype-handler)
@@ -2611,6 +2632,9 @@ Of course, we really can't know that for sure, so it's just a heuristic."
((eq type 'fixnum) `(integerp ,val))
;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef
((memq type '(character string-char)) `(characterp ,val))
+ ((and (get type 'cl-struct-type)
+ (assq 'cl-tag-slot (get type 'cl-struct-slots)))
+ (cl--make-struct-type-test val type))
(t
(let* ((name (symbol-name type))
(namep (intern (concat name "p"))))
diff --git a/test/automated/cl-lib.el b/test/automated/cl-lib.el
index 8b6ed6d..3689c9c 100644
--- a/test/automated/cl-lib.el
+++ b/test/automated/cl-lib.el
@@ -195,4 +195,17 @@
(should (eql (cl-mismatch "Aa" "aA") 0))
(should (eql (cl-mismatch '(a b c) '(a b d)) 2)))
+(cl-defstruct cl-lib-test-struct-1)
+(cl-defstruct (cl-lib-test-struct-2 (:predicate cl-lib-test-struct-2?)))
+(cl-defstruct (cl-lib-test-struct-3 (:predicate nil)))
+(cl-defstruct (cl-lib-test-struct-4 (:predicate nil)
+ (:include cl-lib-test-struct-3)))
+
+(ert-deftest cl-lib-test-typep ()
+ (should (cl-typep (make-cl-lib-test-struct-1) 'cl-lib-test-struct-1))
+ (should (not (cl-typep (make-cl-lib-test-struct-2) 'cl-lib-test-struct-1)))
+ (should (cl-typep (make-cl-lib-test-struct-2) 'cl-lib-test-struct-2))
+ (should (cl-typep (make-cl-lib-test-struct-3) 'cl-lib-test-struct-3))
+ (should (cl-typep (make-cl-lib-test-struct-4) 'cl-lib-test-struct-3)))
+
;;; cl-lib.el ends here
^ permalink raw reply related [flat|nested] 10+ messages in thread
* bug#16520: 24.3.50; cl-defstruct with :predicate option
2014-01-30 12:07 ` Helmut Eller
@ 2014-01-30 14:43 ` Stefan Monnier
2014-01-30 22:33 ` Helmut Eller
0 siblings, 1 reply; 10+ messages in thread
From: Stefan Monnier @ 2014-01-30 14:43 UTC (permalink / raw)
To: Helmut Eller; +Cc: 16520
> Maybe something like this:
Thanks, looks reasonable. Could you try and share the
cl--make-struct-type-test code with the part that defines foo-p to avoid
the duplication?
Stefan
^ permalink raw reply [flat|nested] 10+ messages in thread
* bug#16520: 24.3.50; cl-defstruct with :predicate option
2014-01-30 14:43 ` Stefan Monnier
@ 2014-01-30 22:33 ` Helmut Eller
0 siblings, 0 replies; 10+ messages in thread
From: Helmut Eller @ 2014-01-30 22:33 UTC (permalink / raw)
To: Stefan Monnier; +Cc: 16520
[-- Attachment #1: Type: text/plain, Size: 270 bytes --]
On Thu, Jan 30 2014, Stefan Monnier wrote:
>> Maybe something like this:
>
> Thanks, looks reasonable. Could you try and share the
> cl--make-struct-type-test code with the part that defines foo-p to avoid
> the duplication?
I tried but it doesn't look much better:
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: defstruct.patch --]
[-- Type: text/x-diff, Size: 5040 bytes --]
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 45448ec..12f8ab1 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2319,6 +2319,40 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first.
;;; Structures.
+(defun cl--make-struct-type-test (val type slots tag-symbol)
+ (let ((pos (cl-loop for i from 0 for (s) in slots
+ when (eq s 'cl-tag-slot) return i)))
+ (cl-ecase type
+ (vector
+ `(and (vectorp ,val)
+ (>= (length ,val) ,(length slots))
+ (memq (aref ,val ,pos) ,tag-symbol)
+ t))
+ (list
+ (cond ((zerop pos)
+ `(and (memq (car-safe ,val) ,tag-symbol)
+ t))
+ (t
+ `(and (consp ,val)
+ (memq (nth ,pos ,val) ,tag-symbol)
+ t)))))))
+
+(defun cl--make-struct-check-form (pred-form safety)
+ (cond ((= safety 0) nil)
+ (t (let* ((form (cond ((and (eq (car pred-form) 'and)
+ (eq (car (last pred-form)) 't))
+ (butlast pred-form))
+ (t pred-form)))
+ (form (cond ((and (eq (car form) 'and)
+ (= (length form) 2))
+ (nth 1 form))
+ (t form))))
+ (cond ((and (= safety 1)
+ (eq (car form) 'and)
+ (eq (car (nth 1 form)) 'vectorp))
+ (nth 3 form))
+ (t form))))))
+
;;;###autoload
(defmacro cl-defstruct (struct &rest descs)
"Define a struct type.
@@ -2461,21 +2495,10 @@ non-nil value, that slot cannot be set via `setf'.
(or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
(push `(defvar ,tag-symbol) forms)
(setq pred-form (and named
- (let ((pos (- (length descs)
- (length (memq (assq 'cl-tag-slot descs)
- descs)))))
- (if (eq type 'vector)
- `(and (vectorp cl-x)
- (>= (length cl-x) ,(length descs))
- (memq (aref cl-x ,pos) ,tag-symbol))
- (if (= pos 0)
- `(memq (car-safe cl-x) ,tag-symbol)
- `(and (consp cl-x)
- (memq (nth ,pos cl-x) ,tag-symbol))))))
- pred-check (and pred-form (> safety 0)
- (if (and (eq (cl-caadr pred-form) 'vectorp)
- (= safety 1))
- (cons 'and (cl-cdddr pred-form)) pred-form)))
+ (cl--make-struct-type-test 'cl-x type descs
+ tag-symbol))
+ pred-check (and pred-form
+ (cl--make-struct-check-form pred-form safety)))
(let ((pos 0) (descp descs))
(while descp
(let* ((desc (pop descp))
@@ -2530,10 +2553,7 @@ non-nil value, that slot cannot be set via `setf'.
(setq slots (nreverse slots)
defaults (nreverse defaults))
(and predicate pred-form
- (progn (push `(cl-defsubst ,predicate (cl-x)
- ,(if (eq (car pred-form) 'and)
- (append pred-form '(t))
- `(and ,pred-form t))) forms)
+ (progn (push `(cl-defsubst ,predicate (cl-x) ,pred-form) forms)
(push (cons predicate 'error-free) side-eff)))
(and copier
(progn (push `(defun ,copier (x) (copy-sequence x)) forms)
@@ -2569,6 +2589,7 @@ non-nil value, that slot cannot be set via `setf'.
(push `(cl-eval-when (compile load eval)
(put ',name 'cl-struct-slots ',descs)
(put ',name 'cl-struct-type ',(list type (eq named t)))
+ (put ',name 'cl-struct-tag-symbol ',tag-symbol)
(put ',name 'cl-struct-include ',include)
(put ',name 'cl-struct-print ,print-auto)
,@(mapcar (lambda (x)
@@ -2611,6 +2632,12 @@ Of course, we really can't know that for sure, so it's just a heuristic."
((eq type 'fixnum) `(integerp ,val))
;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef
((memq type '(character string-char)) `(characterp ,val))
+ ((and (get type 'cl-struct-type)
+ (assq 'cl-tag-slot (get type 'cl-struct-slots)))
+ (cl--make-struct-type-test val
+ (car (get type 'cl-struct-type))
+ (get type 'cl-struct-slots)
+ (get type 'cl-struct-tag-symbol)))
(t
(let* ((name (symbol-name type))
(namep (intern (concat name "p"))))
diff --git a/test/automated/cl-lib.el b/test/automated/cl-lib.el
index 8b6ed6d..3689c9c 100644
--- a/test/automated/cl-lib.el
+++ b/test/automated/cl-lib.el
@@ -195,4 +195,17 @@
(should (eql (cl-mismatch "Aa" "aA") 0))
(should (eql (cl-mismatch '(a b c) '(a b d)) 2)))
+(cl-defstruct cl-lib-test-struct-1)
+(cl-defstruct (cl-lib-test-struct-2 (:predicate cl-lib-test-struct-2?)))
+(cl-defstruct (cl-lib-test-struct-3 (:predicate nil)))
+(cl-defstruct (cl-lib-test-struct-4 (:predicate nil)
+ (:include cl-lib-test-struct-3)))
+
+(ert-deftest cl-lib-test-typep ()
+ (should (cl-typep (make-cl-lib-test-struct-1) 'cl-lib-test-struct-1))
+ (should (not (cl-typep (make-cl-lib-test-struct-2) 'cl-lib-test-struct-1)))
+ (should (cl-typep (make-cl-lib-test-struct-2) 'cl-lib-test-struct-2))
+ (should (cl-typep (make-cl-lib-test-struct-3) 'cl-lib-test-struct-3))
+ (should (cl-typep (make-cl-lib-test-struct-4) 'cl-lib-test-struct-3)))
+
;;; cl-lib.el ends here
^ permalink raw reply related [flat|nested] 10+ messages in thread
end of thread, other threads:[~2014-01-30 22:33 UTC | newest]
Thread overview: 10+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2014-01-22 10:06 bug#16520: 24.3.50; cl-defstruct with :predicate option Helmut Eller
2014-01-22 13:47 ` Stefan Monnier
2014-01-23 15:02 ` Stefan Monnier
2014-01-29 10:00 ` Helmut Eller
2014-01-29 13:59 ` Stefan Monnier
2014-01-29 17:47 ` Helmut Eller
2014-01-30 3:58 ` Stefan Monnier
2014-01-30 12:07 ` Helmut Eller
2014-01-30 14:43 ` Stefan Monnier
2014-01-30 22:33 ` Helmut Eller
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).