Mercurial > hg > xemacs-beta
changeset 4742:4cf435fcebbc
Make #'letf not error if handed a #'values form.
lisp/ChangeLog addition:
2009-11-14 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (letf):
Check whether arguments to #'values are bound, and make them
unbound after evaluating BODY; document the limitations of this
macro.
tests/ChangeLog addition:
2009-11-14 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Don't call Known-Bug-Expect-Failure now that the particular letf
bug it tickled is fixed.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 14 Nov 2009 11:43:09 +0000 |
| parents | e14f9fdd5096 |
| children | 776bbf454f3a |
| files | lisp/ChangeLog lisp/cl-macs.el tests/ChangeLog tests/automated/lisp-tests.el |
| diffstat | 4 files changed, 106 insertions(+), 29 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sat Nov 14 11:32:10 2009 +0000 +++ b/lisp/ChangeLog Sat Nov 14 11:43:09 2009 +0000 @@ -1,3 +1,10 @@ +2009-11-14 Aidan Kehoe <kehoea@parhasard.net> + + * cl-macs.el (letf): + Check whether arguments to #'values are bound, and make them + unbound after evaluating BODY; document the limitations of this + macro. + 2009-11-14 Aidan Kehoe <kehoea@parhasard.net> * faces.el (init-other-random-faces):
--- a/lisp/cl-macs.el Sat Nov 14 11:32:10 2009 +0000 +++ b/lisp/cl-macs.el Sat Nov 14 11:43:09 2009 +0000 @@ -2587,6 +2587,28 @@ (list 'let* (append (car method) (list (list temp (nth 2 method)))) (cl-setf-do-store (nth 1 method) form) nil))))) +;; This function is not in Common Lisp, and there are gaps in its structure and +;; implementation that reflect that it was never well-specified. E.g. with +;; setf, the question of whether a PLACE is bound or not and how to make it +;; unbound doesn't arise, but we need some way of specifying that for letf to +;; be sensible for gethash, symbol-value and so on; currently we just hard-code +;; symbol-value, symbol-function and values (the latter is XEmacs work that +;; I've just done) in the body of this function, and the following gives the +;; wrong behaviour for gethash: +;; +;; (setq my-hash-table #s(hash-table test equal data ()) +;; print-gensym t) +;; => t +;; (gethash "my-key" my-hash-table (gensym)) +;; => #:G68010 +;; (letf (((gethash "my-key" my-hash-table) 4000)) +;; (message "key value is %S" (gethash "my-key" my-hash-table))) +;; => "key value is 4000" +;; (gethash "my-key" my-hash-table (gensym)) +;; => nil ;; should be an uninterned symbol. +;; +;; Aidan Kehoe, Fr Nov 13 16:12:21 GMT 2009 + ;;;###autoload (defmacro letf (bindings &rest body) "(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. @@ -2608,20 +2630,56 @@ (value (cadar rev)) (method (cl-setf-do-modify place 'no-opt)) (save (gensym "--letf-save--")) - (bound (and (memq (car place) '(symbol-value symbol-function)) + (bound (and (memq (car place) + '(symbol-value symbol-function values)) (gensym "--letf-bound--"))) (temp (and (not (cl-const-expr-p value)) (cdr bindings) - (gensym "--letf-val--")))) + (gensym "--letf-val--"))) + (syms (and (eq 'values (car place)) + (gensym "--letf-syms--"))) + (cursor (and syms (gensym "--letf-cursor--"))) + (sym (and syms (gensym "--letf-sym--")))) (setq lets (nconc (car method) - (if bound - (list (list bound - (list (if (eq (car place) - 'symbol-value) - 'boundp 'fboundp) - (nth 1 (nth 2 method)))) - (list save (list 'and bound - (nth 2 method)))) - (list (list save (nth 2 method)))) + (cond + (syms + `((,syms ',(loop + for sym in (cdr place) + nconc (if (symbolp sym) (list sym)))) + (,cursor ,syms) + (,bound nil) + (,save + (prog2 + (while (consp ,cursor) + (setq ,bound + (cons (and (boundp (car ,cursor)) + (symbol-value + (car ,cursor))) + ,bound) + ,cursor (cdr ,cursor))) + ;; Just using ,bound as a temporary + ;; variable here, to initialise ,save: + (nreverse ,bound) + ;; Now, really initialise ,bound: + (setq ,cursor ,syms + ,bound nil + ,bound + (progn (while (consp ,cursor) + (setq ,bound + (cons + (boundp (car ,cursor)) + ,bound) + ,cursor (cdr ,cursor))) + (nreverse ,bound))))))) + (bound + (list (list bound + (list (if (eq (car place) + 'symbol-value) + 'boundp 'fboundp) + (nth 1 (nth 2 method)))) + (list save (list 'and bound + (nth 2 method))))) + (t + (list (list save (nth 2 method))))) (and temp (list (list temp value))) lets) body (list @@ -2632,13 +2690,25 @@ (or temp value)) body) body)) - (if bound - (list 'if bound - (cl-setf-do-store (nth 1 method) save) - (list (if (eq (car place) 'symbol-value) - 'makunbound 'fmakunbound) - (nth 1 (nth 2 method)))) - (cl-setf-do-store (nth 1 method) save)))) + (cond + (syms + `(while (consp ,syms) + (if (car ,bound) + (set (car ,syms) (car ,save)) + (makunbound (car ,syms))) + (setq ,syms (cdr ,syms) + ,bound (cdr ,bound) + ,save (cdr ,save)))) + (bound + (list 'if bound + (cl-setf-do-store (nth 1 method) save) + (list (if (eq (car place) + 'symbol-function) + 'fmakunbound + 'makunbound) + (nth 1 (nth 2 method))))) + (t + (cl-setf-do-store (nth 1 method) save))))) rev (cdr rev)))) (list* 'let* lets body))))
--- a/tests/ChangeLog Sat Nov 14 11:32:10 2009 +0000 +++ b/tests/ChangeLog Sat Nov 14 11:43:09 2009 +0000 @@ -1,3 +1,9 @@ +2009-11-14 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + Don't call Known-Bug-Expect-Failure now that the particular letf + bug it tickled is fixed. + 2009-11-11 Stephen Turnbull <stephen@xemacs.org> * sigpipe.c: Add standard permission notice, after email
--- a/tests/automated/lisp-tests.el Sat Nov 14 11:32:10 2009 +0000 +++ b/tests/automated/lisp-tests.el Sat Nov 14 11:43:09 2009 +0000 @@ -2079,17 +2079,11 @@ (Assert (eq t (and)) "Checking #'and behaves correctly with zero arguments.") - ;; This bug was here before the full multiple-value functionality - ;; was introduced (check it with (floor* pi) if you're - ;; curious). #'setf works, though, which is what most people are - ;; interested in. If you know the setf-method code better than I do, - ;; please post a patch; otherwise this is going to the back of the - ;; queue of things to do. I didn't break it :-) Aidan Kehoe, Mon Aug - ;; 31 10:45:50 GMTDT 2009. - (Known-Bug-Expect-Error - void-variable - (letf (((values three one-four-one-five-nine) (floor pi))) - (* three one-four-one-five-nine)))) + (Assert + (= (* 3.0 (- pi 3.0)) + (letf (((values three one-four-one-five-nine) (floor pi))) + (* three one-four-one-five-nine))) + "checking letf handles #'values in a basic sense")) (Assert (equalp "hi there" "Hi There") "checking equalp isn't case-sensitive")