commit: Make #'letf not error if handed a #'values form.
Aidan Kehoe
kehoea at parhasard.net
Sat Nov 14 06:44:11 EST 2009
changeset: 4742:4cf435fcebbc
tag: tip
user: Aidan Kehoe <kehoea at parhasard.net>
date: Sat Nov 14 11:43:09 2009 +0000
files: lisp/ChangeLog lisp/cl-macs.el tests/ChangeLog tests/automated/lisp-tests.el
description:
Make #'letf not error if handed a #'values form.
lisp/ChangeLog addition:
2009-11-14 Aidan Kehoe <kehoea at 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 at parhasard.net>
* automated/lisp-tests.el:
Don't call Known-Bug-Expect-Failure now that the particular letf
bug it tickled is fixed.
diff -r e14f9fdd5096 -r 4cf435fcebbc lisp/ChangeLog
--- 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 at 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 at parhasard.net>
* faces.el (init-other-random-faces):
diff -r e14f9fdd5096 -r 4cf435fcebbc lisp/cl-macs.el
--- 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))))
diff -r e14f9fdd5096 -r 4cf435fcebbc tests/ChangeLog
--- 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 at 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 at xemacs.org>
* sigpipe.c: Add standard permission notice, after email
diff -r e14f9fdd5096 -r 4cf435fcebbc tests/automated/lisp-tests.el
--- 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")
More information about the XEmacs-Patches
mailing list