From 36f0f2b12a85b0b03ce58d2d586f27039e286257 Mon Sep 17 00:00:00 2001 From: "Richard M. Stallman" Date: Tue, 16 Apr 1996 04:36:21 +0000 Subject: [PATCH] (defstruct): Treat multi-nested :include properly. (flet): Warn when flet rebinds a macro name. (labels): Rewrite to be fully CL-compliant. --- lisp/emacs-lisp/cl-macs.el | 36 +++++++++++++++++++++++++++++------- 1 file changed, 29 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 180a3f99bc8..25c897ac5f6 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1222,6 +1222,10 @@ go back to their previous definitions, or lack thereof)." (mapcar (function (lambda (x) + (if (or (and (fboundp (car x)) + (eq (car-safe (symbol-function (car x))) 'macro)) + (cdr (assq (car x) cl-macro-environment))) + (error "Use `labels', not `flet', to rebind macro names")) (let ((func (list 'function* (list 'lambda (cadr x) (list* 'block (car x) (cddr x)))))) @@ -1233,7 +1237,22 @@ go back to their previous definitions, or lack thereof)." bindings) body)) -(defmacro labels (&rest args) (cons 'flet args)) +(defmacro labels (bindings &rest body) + "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings. +This is like `flet', except the bindings are lexical instead of dynamic. +Unlike `flet', this macro is fully complaint with the Common Lisp standard." + (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) + (while bindings + (let ((var (gensym))) + (cl-push var vars) + (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets) + (cl-push var sets) + (cl-push (list (car (cl-pop bindings)) 'lambda '(&rest cl-labels-args) + (list 'list* '(quote funcall) (list 'quote var) + 'cl-labels-args)) + cl-macro-environment))) + (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body)) + cl-macro-environment))) ;; The following ought to have a better definition for use with newer ;; byte compilers. @@ -2017,7 +2036,6 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) (include-descs nil) - (include-tag-symbol nil) (side-eff nil) (type nil) (named nil) @@ -2049,9 +2067,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." include-descs (mapcar (function (lambda (x) (if (consp x) x (list x)))) - (cdr args)) - include-tag-symbol (intern (format "cl-struct-%s-tags" - include)))) + (cdr args)))) ((eq opt ':print-function) (setq print-func (car args))) ((eq opt ':type) @@ -2089,8 +2105,12 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." type (car inc-type) named (assq 'cl-tag-slot descs)) (if (cadr inc-type) (setq tag name named t)) - (cl-push (list 'pushnew (list 'quote tag) include-tag-symbol) - forms)) + (let ((incl include)) + (while incl + (cl-push (list 'pushnew (list 'quote tag) + (intern (format "cl-struct-%s-tags" incl))) + forms) + (setq incl (get incl 'cl-struct-include))))) (if type (progn (or (memq type '(vector list)) @@ -2197,6 +2217,8 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." (list 'quote descs)) (list 'put (list 'quote name) '(quote cl-struct-type) (list 'quote (list type (eq named t)))) + (list 'put (list 'quote name) '(quote cl-struct-include) + (list 'quote include)) (list 'put (list 'quote name) '(quote cl-struct-print) print-auto) (mapcar (function (lambda (x) -- 2.39.2