comparison lisp/emacs-lisp/cl-macs.el @ 15030:257fd294d7cb

(defstruct): Treat multi-nested :include properly. (flet): Warn when flet rebinds a macro name. (labels): Rewrite to be fully CL-compliant.

15029:ba44a899c055

go back to their previous definitions, or lack thereof)."
  (list* 'letf*
	 (mapcar
	  (function
	   (lambda (x)
	     (let ((func (list 'function*
			       (list 'lambda (cadr x)
				     (list* 'block (car x) (cddr x))))))
	       (if (and (cl-compiling-file)
			(boundp 'byte-compile-function-environment))

			    byte-compile-function-environment))
	       (list (list 'symbol-function (list 'quote (car x))) func))))
	  bindings)
	 body))

(defmacro labels (&rest args) (cons 'flet args))

;; The following ought to have a better definition for use with newer
;; byte compilers.
(defmacro macrolet (bindings &rest body)
  "(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns.

	 (safety (if (cl-compiling-file) cl-optimize-safety 3))
	 (include nil)
	 (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)
	 (forms nil)
	 pred-form pred-check)

	      ((eq opt ':include)
	       (setq include (car args)
		     include-descs (mapcar (function
					    (lambda (x)
					      (if (consp x) x (list x))))
					   (cdr args))
		     include-tag-symbol (intern (format "cl-struct-%s-tags"
							include))))
	      ((eq opt ':print-function)
	       (setq print-func (car args)))
	      ((eq opt ':type)
	       (setq type (car args)))
	      ((eq opt ':named)

		    (cl-pop include-descs)))
	  (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
		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))
      (if type
	  (progn
	    (or (memq type '(vector list))
		(error "Illegal :type specifier: %s" type))
	    (if named (setq tag name)))

    (cl-push (list* 'eval-when '(compile load eval)
		    (list 'put (list 'quote name) '(quote cl-struct-slots)
			  (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-print)
			  print-auto)
		    (mapcar (function (lambda (x)
					(list 'put (list 'quote (car x))
					      '(quote side-effect-free)

15030:257fd294d7cb

go back to their previous definitions, or lack thereof)."
  (list* 'letf*
	 (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))))))
	       (if (and (cl-compiling-file)
			(boundp 'byte-compile-function-environment))

			    byte-compile-function-environment))
	       (list (list 'symbol-function (list 'quote (car x))) func))))
	  bindings)
	 body))

(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.
(defmacro macrolet (bindings &rest body)
  "(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns.

	 (safety (if (cl-compiling-file) cl-optimize-safety 3))
	 (include nil)
	 (tag (intern (format "cl-struct-%s" name)))
	 (tag-symbol (intern (format "cl-struct-%s-tags" name)))
	 (include-descs nil)
	 (side-eff nil)
	 (type nil)
	 (named nil)
	 (forms nil)
	 pred-form pred-check)

	      ((eq opt ':include)
	       (setq include (car args)
		     include-descs (mapcar (function
					    (lambda (x)
					      (if (consp x) x (list x))))
					   (cdr args))))
	      ((eq opt ':print-function)
	       (setq print-func (car args)))
	      ((eq opt ':type)
	       (setq type (car args)))
	      ((eq opt ':named)

		    (cl-pop include-descs)))
	  (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
		type (car inc-type)
		named (assq 'cl-tag-slot descs))
	  (if (cadr inc-type) (setq tag name named t))
	  (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))
		(error "Illegal :type specifier: %s" type))
	    (if named (setq tag name)))

    (cl-push (list* 'eval-when '(compile load eval)
		    (list 'put (list 'quote name) '(quote cl-struct-slots)
			  (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)
					(list 'put (list 'quote (car x))
					      '(quote side-effect-free)