* 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).