Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5476:f2881cb841b4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merged with trunk.
author Mats Lidell <matsl@xemacs.org>
date Tue, 26 Apr 2011 23:41:47 +0200
parents 248176c74e6b 97ac18bd1fa3
children 4813ff11c6e2
comparison
equal deleted inserted replaced
5475:248176c74e6b 5476:f2881cb841b4
1787 ;;;###autoload 1787 ;;;###autoload
1788 (defmacro* symbol-macrolet (((name expansion) &rest symbol-macros) &body form) 1788 (defmacro* symbol-macrolet (((name expansion) &rest symbol-macros) &body form)
1789 "Make symbol macro definitions. 1789 "Make symbol macro definitions.
1790 Within the body FORMs, references to the variable NAME will be replaced 1790 Within the body FORMs, references to the variable NAME will be replaced
1791 by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)." 1791 by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)."
1792 (check-type name symbol)
1792 (cl-macroexpand-all (cons 'progn form) 1793 (cl-macroexpand-all (cons 'progn form)
1793 (append (list (list (symbol-name name) expansion)) 1794 (nconc (list (list (eq-hash name) expansion))
1794 (loop 1795 (loop
1795 for (name expansion) in symbol-macros 1796 for (name expansion) in symbol-macros
1796 collect (list (symbol-name name) expansion)) 1797 do (check-type name symbol)
1797 cl-macro-environment))) 1798 collect (list (eq-hash name) expansion))
1799 cl-macro-environment)))
1798 1800
1799 (defvar cl-closure-vars nil) 1801 (defvar cl-closure-vars nil)
1800 ;;;###autoload 1802 ;;;###autoload
1801 (defmacro lexical-let (bindings &rest body) 1803 (defmacro lexical-let (bindings &rest body)
1802 "Like `let', but lexically scoped. 1804 "Like `let', but lexically scoped.
1803 The main visible difference is that lambdas inside BODY will create 1805 The main visible difference is that lambdas inside BODY will create
1804 lexical closures as in Common Lisp." 1806 lexical closures as in Common Lisp."
1805 (let* ((cl-closure-vars cl-closure-vars) 1807 (let* ((cl-closure-vars cl-closure-vars)
1806 (vars (mapcar #'(lambda (x) 1808 (vars (mapcar #'(lambda (x)
1807 (or (consp x) (setq x (list x))) 1809 (or (consp x) (setq x (list x)))
1808 (push (gensym (format "--%s--" (car x))) 1810 (push (gensym (concat "--" (symbol-name (car x))
1809 cl-closure-vars) 1811 "--" ))
1812 cl-closure-vars)
1810 (set (car cl-closure-vars) [bad-lexical-ref]) 1813 (set (car cl-closure-vars) [bad-lexical-ref])
1811 (list (car x) (cadr x) (car cl-closure-vars))) 1814 (list (car x) (cadr x) (car cl-closure-vars)))
1812 bindings)) 1815 bindings))
1813 (ebody 1816 (ebody
1814 (cl-macroexpand-all 1817 (cl-macroexpand-all
1815 (cons 'progn body) 1818 (cons 'progn body)
1816 (nconc (mapcar #'(lambda (x) 1819 (nconc (mapcar #'(lambda (x)
1817 (list (symbol-name (car x)) 1820 (list (eq-hash (car x))
1818 (list 'symbol-value (caddr x)) 1821 (list 'symbol-value (caddr x))
1819 t)) 1822 t))
1820 vars) 1823 vars)
1821 (list '(defun . cl-defun-expander)) 1824 (list '(defun . cl-defun-expander))
1822 cl-macro-environment)))) 1825 cl-macro-environment))))