Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 4742:4cf435fcebbc

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 ebca981a0012
children e29fcfd8df5f
comparison
equal deleted inserted replaced
4741:e14f9fdd5096 4742:4cf435fcebbc
2585 (cl-setf-do-store (nth 1 method) form)))))) 2585 (cl-setf-do-store (nth 1 method) form))))))
2586 (let ((method (cl-setf-do-modify (car places) 'unsafe))) 2586 (let ((method (cl-setf-do-modify (car places) 'unsafe)))
2587 (list 'let* (append (car method) (list (list temp (nth 2 method)))) 2587 (list 'let* (append (car method) (list (list temp (nth 2 method))))
2588 (cl-setf-do-store (nth 1 method) form) nil))))) 2588 (cl-setf-do-store (nth 1 method) form) nil)))))
2589 2589
2590 ;; This function is not in Common Lisp, and there are gaps in its structure and
2591 ;; implementation that reflect that it was never well-specified. E.g. with
2592 ;; setf, the question of whether a PLACE is bound or not and how to make it
2593 ;; unbound doesn't arise, but we need some way of specifying that for letf to
2594 ;; be sensible for gethash, symbol-value and so on; currently we just hard-code
2595 ;; symbol-value, symbol-function and values (the latter is XEmacs work that
2596 ;; I've just done) in the body of this function, and the following gives the
2597 ;; wrong behaviour for gethash:
2598 ;;
2599 ;; (setq my-hash-table #s(hash-table test equal data ())
2600 ;; print-gensym t)
2601 ;; => t
2602 ;; (gethash "my-key" my-hash-table (gensym))
2603 ;; => #:G68010
2604 ;; (letf (((gethash "my-key" my-hash-table) 4000))
2605 ;; (message "key value is %S" (gethash "my-key" my-hash-table)))
2606 ;; => "key value is 4000"
2607 ;; (gethash "my-key" my-hash-table (gensym))
2608 ;; => nil ;; should be an uninterned symbol.
2609 ;;
2610 ;; Aidan Kehoe, Fr Nov 13 16:12:21 GMT 2009
2611
2590 ;;;###autoload 2612 ;;;###autoload
2591 (defmacro letf (bindings &rest body) 2613 (defmacro letf (bindings &rest body)
2592 "(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. 2614 "(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs.
2593 This is the analogue of `let', but with generalized variables (in the 2615 This is the analogue of `let', but with generalized variables (in the
2594 sense of `setf') for the PLACEs. Each PLACE is set to the corresponding 2616 sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
2606 (list 'symbol-value (list 'quote (caar rev))) 2628 (list 'symbol-value (list 'quote (caar rev)))
2607 (caar rev))) 2629 (caar rev)))
2608 (value (cadar rev)) 2630 (value (cadar rev))
2609 (method (cl-setf-do-modify place 'no-opt)) 2631 (method (cl-setf-do-modify place 'no-opt))
2610 (save (gensym "--letf-save--")) 2632 (save (gensym "--letf-save--"))
2611 (bound (and (memq (car place) '(symbol-value symbol-function)) 2633 (bound (and (memq (car place)
2634 '(symbol-value symbol-function values))
2612 (gensym "--letf-bound--"))) 2635 (gensym "--letf-bound--")))
2613 (temp (and (not (cl-const-expr-p value)) (cdr bindings) 2636 (temp (and (not (cl-const-expr-p value)) (cdr bindings)
2614 (gensym "--letf-val--")))) 2637 (gensym "--letf-val--")))
2638 (syms (and (eq 'values (car place))
2639 (gensym "--letf-syms--")))
2640 (cursor (and syms (gensym "--letf-cursor--")))
2641 (sym (and syms (gensym "--letf-sym--"))))
2615 (setq lets (nconc (car method) 2642 (setq lets (nconc (car method)
2616 (if bound 2643 (cond
2617 (list (list bound 2644 (syms
2618 (list (if (eq (car place) 2645 `((,syms ',(loop
2619 'symbol-value) 2646 for sym in (cdr place)
2620 'boundp 'fboundp) 2647 nconc (if (symbolp sym) (list sym))))
2621 (nth 1 (nth 2 method)))) 2648 (,cursor ,syms)
2622 (list save (list 'and bound 2649 (,bound nil)
2623 (nth 2 method)))) 2650 (,save
2624 (list (list save (nth 2 method)))) 2651 (prog2
2652 (while (consp ,cursor)
2653 (setq ,bound
2654 (cons (and (boundp (car ,cursor))
2655 (symbol-value
2656 (car ,cursor)))
2657 ,bound)
2658 ,cursor (cdr ,cursor)))
2659 ;; Just using ,bound as a temporary
2660 ;; variable here, to initialise ,save:
2661 (nreverse ,bound)
2662 ;; Now, really initialise ,bound:
2663 (setq ,cursor ,syms
2664 ,bound nil
2665 ,bound
2666 (progn (while (consp ,cursor)
2667 (setq ,bound
2668 (cons
2669 (boundp (car ,cursor))
2670 ,bound)
2671 ,cursor (cdr ,cursor)))
2672 (nreverse ,bound)))))))
2673 (bound
2674 (list (list bound
2675 (list (if (eq (car place)
2676 'symbol-value)
2677 'boundp 'fboundp)
2678 (nth 1 (nth 2 method))))
2679 (list save (list 'and bound
2680 (nth 2 method)))))
2681 (t
2682 (list (list save (nth 2 method)))))
2625 (and temp (list (list temp value))) 2683 (and temp (list (list temp value)))
2626 lets) 2684 lets)
2627 body (list 2685 body (list
2628 (list 'unwind-protect 2686 (list 'unwind-protect
2629 (cons 'progn 2687 (cons 'progn
2630 (if (cdr (car rev)) 2688 (if (cdr (car rev))
2631 (cons (cl-setf-do-store (nth 1 method) 2689 (cons (cl-setf-do-store (nth 1 method)
2632 (or temp value)) 2690 (or temp value))
2633 body) 2691 body)
2634 body)) 2692 body))
2635 (if bound 2693 (cond
2636 (list 'if bound 2694 (syms
2637 (cl-setf-do-store (nth 1 method) save) 2695 `(while (consp ,syms)
2638 (list (if (eq (car place) 'symbol-value) 2696 (if (car ,bound)
2639 'makunbound 'fmakunbound) 2697 (set (car ,syms) (car ,save))
2640 (nth 1 (nth 2 method)))) 2698 (makunbound (car ,syms)))
2641 (cl-setf-do-store (nth 1 method) save)))) 2699 (setq ,syms (cdr ,syms)
2700 ,bound (cdr ,bound)
2701 ,save (cdr ,save))))
2702 (bound
2703 (list 'if bound
2704 (cl-setf-do-store (nth 1 method) save)
2705 (list (if (eq (car place)
2706 'symbol-function)
2707 'fmakunbound
2708 'makunbound)
2709 (nth 1 (nth 2 method)))))
2710 (t
2711 (cl-setf-do-store (nth 1 method) save)))))
2642 rev (cdr rev)))) 2712 rev (cdr rev))))
2643 (list* 'let* lets body)))) 2713 (list* 'let* lets body))))
2644 2714
2645 ;;;###autoload 2715 ;;;###autoload
2646 (defmacro letf* (bindings &rest body) 2716 (defmacro letf* (bindings &rest body)