mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-03 11:33:37 +00:00
Code Issues Releases Activity

(defstruct): Treat multi-nested :include properly.

Browse Source 
(flet): Warn when flet rebinds a macro name.
(labels): Rewrite to be fully CL-compliant.
This commit is contained in:
Richard M. Stallman 1996-04-16 04:36:21 +00:00
parent bd9c5e7949
commit 36f0f2b12a
1 changed files with 29 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
lisp/emacs-lisp/cl-macs.el
View File

@ -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)