xemacs-beta: lisp/cl-macs.el comparison

comparison lisp/cl-macs.el @ 5562:855b667dea13

Drop cl-macro-environment in favour of byte-compile-macro-environment. lisp/ChangeLog addition: 2011-09-04 Aidan Kehoe <kehoea@parhasard.net> * bytecomp-runtime.el: * bytecomp-runtime.el (byte-compile-macro-environment): Moved from bytecomp.el. * bytecomp.el: * bytecomp.el (byte-compile-initial-macro-environment): Add implementations for #'load-time-value, #'labels here, now cl-macs respects byte-compile-macro-environment. * bytecomp.el (byte-compile-function-environment): * bytecomp.el (byte-compile-macro-environment): Removed. * bytecomp.el (symbol-value): * bytecomp.el (byte-compile-symbol-value): Removed. * cl-extra.el (cl-macroexpand-all): * cl-macs.el: * cl-macs.el (bind-block): * cl-macs.el (cl-macro-environment): Removed. * cl-macs.el (cl-transform-lambda): * cl-macs.el (load-time-value): * cl-macs.el (block): * cl-macs.el (flet): * cl-macs.el (labels): * cl-macs.el (macrolet): * cl-macs.el (symbol-macrolet): * cl-macs.el (lexical-let): * cl-macs.el (apply): * cl-macs.el (nthcdr): * cl-macs.el (getf): * cl-macs.el (substring): * cl-macs.el (values): * cl-macs.el (get-setf-method): * cl-macs.el (cl-setf-do-modify): * cl.el: * cl.el (cl-macro-environment): Removed. * cl.el (cl-macroexpand): * obsolete.el (cl-macro-environment): Moved here. Drop cl-macro-environment, in favour of byte-compile-macro-environment; make the latter available in bytecomp-runtime.el. This makes byte-compile-macro-environment far less useless, since previously code that used cl-macs would ignore it when calling #'cl-macroexpand-all. Add byte-compiler-specific implementations for #'load-time-value, #'labels. The latter is very nice indeed; it avoids the run-time consing of the current implementation, is fully lexical and avoids the run-time shadowing of symbol function slots that flet uses. It would now be reasonable to move most core uses of flet to use labels instead. Non-core code can't rely on print-circle for mutually recursive functions, though, so it's less of an evident win.

author	Aidan Kehoe <kehoea@parhasard.net>
date	Sun, 04 Sep 2011 20:37:55 +0100
parents	9a93bc90b3bd
children	4654c01af32b

comparison

equal deleted inserted replaced

-:9a93bc90b3bd
+:855b667dea13
 `(put ',func ',prop #'(lambda ,@(cdr (cl-transform-lambda form func)))))
 (defconst lambda-list-keywords
 '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
-(defvar cl-macro-environment nil)
 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
 (defvar bind-lets) (defvar bind-forms)
 ;; npak@ispras.ru
 (defun cl-upcase-arg (arg)
 (if (setq bind-enquote (memq '&cl-quote args))
 	(setq args (delq '&cl-quote args)))
 (if (memq '&whole args) (error "&whole not currently implemented"))
 (let* ((p (memq '&environment args)) (v (cadr p)))
 (if p (setq args (nconc (delq (car p) (delq v args))
-			      (list '&aux (list v 'cl-macro-environment))))))
+`(&aux (,v byte-compile-macro-environment))))))
 (while (and args (symbolp (car args))
 		(not (memq (car args) '(nil &rest &body &key &aux)))
 		(not (and (eq (car args) '&optional)
 			  (or bind-defs (consp (cadr args))))))
 (push (pop args) simple-args))
 ;;;###autoload
 (defmacro load-time-value (form &optional read-only)
 "Like `progn', but evaluates the body at load time.
 The result of the body appears to the compiler as a quoted constant."
-(let ((gensym (gensym)))
+(list 'progn form))
-;; The body of this macro really should be (cons 'progn form), with the
-;; hairier stuff in a shadowed version in
-;; byte-compile-initial-macro-environment. That doesn't work because
-;; cl-macs.el doesn't respect byte-compile-macro-environment, which is
-;; something we should change.
-(put gensym 'cl-load-time-value-form form)
-(set gensym (eval form))
-`(symbol-value ',gensym)))
 ;;; Conditional control structures.
 ;;;###autoload
 (defmacro case (expr &rest clauses)
 	(body (cons 'progn body)))
 ;; Tell the byte-compiler this is a block, not a normal catch call, and
 ;; as such it can eliminate it if that's appropriate:
 (put (cdar cl-active-block-names) 'cl-block-name name)
 `(catch ',(cdar cl-active-block-names)
-,(cl-macroexpand-all body cl-macro-environment))))
+,(cl-macroexpand-all body byte-compile-macro-environment))))
 ;;;###autoload
 (defmacro return (&optional result)
 "Return from the block named nil.
 This is equivalent to `(return-from nil RESULT)'."
 (list* 'letf*
 	 (mapcar
 	  #'(lambda (x)
 	      (if (or (and (fboundp (car x))
 			   (eq (car-safe (symbol-function (car x))) 'macro))
-		      (cdr (assq (car x) cl-macro-environment)))
+		      (cdr (assq (car x) byte-compile-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)
 "Make temporary func bindings.
 This is like `flet', except the bindings are lexical instead of dynamic.
 Unlike `flet', this macro is fully compliant with the Common Lisp standard.
 arguments: (((FUNC ARGLIST &body BODY) &rest FUNCTIONS) &body FORM)"
-(let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
+(let ((vars nil) (sets nil)
+(byte-compile-macro-environment byte-compile-macro-environment))
 (while bindings
 (let ((var (gensym)))
 	(push var vars)
-	(push (list 'function* (cons 'lambda (cdar bindings))) sets)
+	(push `#'(lambda ,@(cdr (cl-transform-lambda (cdar bindings)
+(caar bindings)))) sets)
 	(push var sets)
 	(push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args)
 		       (list 'list* '(quote funcall) (list 'quote var)
 			     'cl-labels-args))
-		 cl-macro-environment)))
+		 byte-compile-macro-environment)))
 (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
-			cl-macro-environment)))
+			byte-compile-macro-environment)))
 ;; The following ought to have a better definition for use with newer
 ;; byte compilers.
 ;;;###autoload
 (defmacro* macrolet ((&rest macros) &body form)
 for (name . details)
 in macros
 collect
 (list* name 'lambda (cdr (cl-transform-lambda details
 name))))
-cl-macro-environment)))
+byte-compile-macro-environment)))
 ;;;###autoload
 (defmacro* symbol-macrolet ((&rest symbol-macros) &body form)
 "Make temporary symbol macro definitions.
 Elements in SYMBOL-MACROS look like (NAME EXPANSION).
 (cl-macroexpand-all (cons 'progn form)
 (nconc (loop
 			       for (name expansion) in symbol-macros
 			       do (check-type name symbol)
 			       collect (list (eq-hash name) expansion))
-			     cl-macro-environment)))
+			     byte-compile-macro-environment)))
 (defvar cl-closure-vars nil)
 ;;;###autoload
 (defmacro lexical-let (bindings &rest body)
 "Like `let', but lexically scoped.
 			      (list (eq-hash (car x))
 				    (list 'symbol-value (caddr x))
 				    t))
 			  vars)
 		  (list '(defun . cl-defun-expander))
-		  cl-macro-environment))))
+		  byte-compile-macro-environment))))
 (if (not (get (car (last cl-closure-vars)) 'used))
 	(list 'let (mapcar #'(lambda (x) (list (caddr x) (cadr x))) vars)
 	      (sublis (mapcar #'(lambda (x)
 				  (cons (caddr x) (list 'quote (caddr x))))
 			      vars)
 (defsetf get-selection own-selection t)
 ;;; More complex setf-methods.
 ;;; These should take &environment arguments, but since full arglists aren't
 ;;; available while compiling cl-macs, we fake it by referring to the global
-;;; variable cl-macro-environment directly.
+;;; variable byte-compile-macro-environment directly.
 (define-setf-method apply (func arg1 &rest rest)
 (or (and (memq (car-safe func) '(quote function function*))
 	   (symbolp (car-safe (cdr-safe func))))
 (error "First arg to apply in setf is not (function SYM): %s" func))
 (let* ((form (cons (nth 1 func) (cons arg1 rest)))
-	 (method (get-setf-method form cl-macro-environment)))
+	 (method (get-setf-method form byte-compile-macro-environment)))
 (list (car method) (nth 1 method) (nth 2 method)
 	  (cl-setf-make-apply (nth 3 method) (cadr func) (car method))
 	  (cl-setf-make-apply (nth 4 method) (cadr func) (car method)))))
 (defun cl-setf-make-apply (form func temps)
 (or (equal (last form) (last temps))
 	(error "%s is not suitable for use with setf-of-apply" func))
 (list* 'apply (list 'quote (car form)) (cdr form))))
 (define-setf-method nthcdr (n place)
-(let ((method (get-setf-method place cl-macro-environment))
+(let ((method (get-setf-method place byte-compile-macro-environment))
 	(n-temp (gensym "--nthcdr-n--"))
 	(store-temp (gensym "--nthcdr-store--")))
 (list (cons n-temp (car method))
 	  (cons n (nth 1 method))
 	  (list store-temp)
 				       store-temp)))
 		(nth 3 method) store-temp)
 	  (list 'nthcdr n-temp (nth 4 method)))))
 (define-setf-method getf (place tag &optional def)
-(let ((method (get-setf-method place cl-macro-environment))
+(let ((method (get-setf-method place byte-compile-macro-environment))
 	(tag-temp (gensym "--getf-tag--"))
 	(def-temp (gensym "--getf-def--"))
 	(store-temp (gensym "--getf-store--")))
 (list (append (car method) (list tag-temp def-temp))
 	  (append (nth 1 method) (list tag def))
 				       tag-temp store-temp)))
 		(nth 3 method) store-temp)
 	  (list 'getf (nth 4 method) tag-temp def-temp))))
 (define-setf-method substring (place from &optional to)
-(let ((method (get-setf-method place cl-macro-environment))
+(let ((method (get-setf-method place byte-compile-macro-environment))
 	(from-temp (gensym "--substring-from--"))
 	(to-temp (gensym "--substring-to--"))
 	(store-temp (gensym "--substring-store--")))
 (list (append (car method) (list from-temp to-temp))
 	  (append (nth 1 method) (list from to))
 	  (list 'substring (nth 4 method) from-temp to-temp))))
 ;; XEmacs addition
 (define-setf-method values (&rest args)
 (let ((methods (mapcar #'(lambda (x)
-			     (get-setf-method x cl-macro-environment))
+			     (get-setf-method x byte-compile-macro-environment))
 			 args))
 	(store-temp (gensym "--values-store--")))
 (list (apply 'append (mapcar 'first methods))
 	  (apply 'append (mapcar 'second methods))
 	  `((,store-temp
 	     (let* ((func (car place))
 		    (name (symbol-name func))
 		    (method (get func 'setf-method))
 		    (case-fold-search nil))
 	       (or (and method
-			(let ((cl-macro-environment env))
+			(let ((byte-compile-macro-environment env))
 			  (setq method (apply method (cdr place))))
 			(if (and (consp method) (eql (length method) 5))
 			    method
 			  (error "Setf-method for %s returns malformed method"
 				 func)))
 				       (cdr place)) env)
 	      (error "No setf-method known for %s" (car place)))
 	  (get-setf-method place env)))))
 (defun cl-setf-do-modify (place opt-expr)
-(let* ((method (get-setf-method place cl-macro-environment))
+(let* ((method (get-setf-method place byte-compile-macro-environment))
 	 (temps (car method)) (values (nth 1 method))
 	 (lets nil) (subs nil)
 	 (optimize (and (not (eq opt-expr 'no-opt))
 			(or (and (not (eq opt-expr 'unsafe))
 				 (cl-safe-expr-p opt-expr))

Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5562:855b667dea13