comparison lisp/emacs-lisp/cl-macs.el @ 26940:f1998d661bc2

Remove conditional definition of eval-when-compile. Don't specify abs, expt, gethash, hash-table-count, hash-table-p as side-effect-free here. (cl-emacs-type): Don't declare. (cl-compile-time-init): Remove Emacs 18 compiler patch. (cl-parse-loop-clause): Remove compatibility code.

26939:672e75118c0f

;; Common Lisp compatibility, beyond what is already built-in
;; in Emacs Lisp.
;;
;; This package was written by Dave Gillespie; it is a complete
;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
;;
;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
;;
;; Bug reports, comments, and suggestions are welcome!

;; This file contains the portions of the Common Lisp extensions
;; package which should be autoloaded, but need only be present

	(list 'setq place (list 'cdr (list 'cdr place)))))
(put 'cl-push 'edebug-form-spec 'edebug-sexps)
(put 'cl-pop 'edebug-form-spec 'edebug-sexps)
(put 'cl-pop2 'edebug-form-spec 'edebug-sexps)

(defvar cl-emacs-type)
(defvar cl-optimize-safety)
(defvar cl-optimize-speed)


;;; This kludge allows macros which use cl-transform-function-property

;;; Initialization.

(defvar cl-old-bc-file-form nil)

;; Patch broken Emacs 18 compiler (re top-level macros).
;; Emacs 19 compiler doesn't need this patch.
;; Also, undo broken definition of `eql' that uses same bytecode as `eq'.
(defun cl-compile-time-init ()
  (setq cl-old-bc-file-form (symbol-function 'byte-compile-file-form))
  (or (fboundp 'byte-compile-flush-pending)   ; Emacs 19 compiler?
      (defalias 'byte-compile-file-form
	(function
	 (lambda (form)
	   (setq form (macroexpand form byte-compile-macro-environment))
	   (if (eq (car-safe form) 'progn)
	       (cons 'progn (mapcar 'byte-compile-file-form (cdr form)))
	     (funcall cl-old-bc-file-form form))))))
  (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro)
  (run-hooks 'cl-hack-bytecomp-hook))


;;; Symbols.

	   (if (or (memq 'eval when) (memq ':execute when))
	       (list* 'eval-when (cons 'compile when) (cddr form))
	     form)))
	(t (eval form) form)))

(or (and (fboundp 'eval-when-compile)
	 (not (eq (car-safe (symbol-function 'eval-when-compile)) 'autoload)))
    (eval '(defmacro eval-when-compile (&rest body)
	     "Like `progn', but evaluates the body at compile time.
The result of the body appears to the compiler as a quoted constant."
	     (list 'quote (eval (cons 'progn body))))))

(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."
  (if (cl-compiling-file)
      (let* ((temp (gentemp "--cl-load-time--"))

			      (list 'function (list* 'lambda (list var other)
						     '--cl-map)) map))))

	       ((memq word '(frame frames screen screens))
		(let ((temp (gensym)))
		  (cl-push (list var (if (eq cl-emacs-type 'lucid)
					 '(selected-screen) '(selected-frame)))
			   loop-for-bindings)
		  (cl-push (list temp nil) loop-for-bindings)
		  (cl-push (list 'prog1 (list 'not (list 'eq var temp))
				 (list 'or temp (list 'setq temp var)))
			   loop-body)
		  (cl-push (list var (list (if (eq cl-emacs-type 'lucid)
					       'next-screen 'next-frame) var))
			   loop-for-steps)))

	       ((memq word '(window windows))
		(let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
		      (temp (gensym)))
		  (cl-push (list var (if scr
					 (list (if (eq cl-emacs-type 'lucid)
						   'screen-selected-window
						 'frame-selected-window) scr)
				       '(selected-window)))
			   loop-for-bindings)
		  (cl-push (list temp nil) loop-for-bindings)
		  (cl-push (list 'prog1 (list 'not (list 'eq var temp))
				 (list 'or temp (list 'setq temp var)))

(proclaim '(inline floatp-safe acons map concatenate notany notevery
		   cl-set-elt revappend nreconc gethash))

;;; Things that are side-effect-free.
(mapcar (function (lambda (x) (put x 'side-effect-free t)))
	'(oddp evenp abs expt signum last butlast ldiff pairlis gcd lcm
	  isqrt floor* ceiling* truncate* round* mod* rem* subseq
	  list-length get* getf gethash hash-table-count))

;;; Things that are side-effect-and-error-free.
(mapcar (function (lambda (x) (put x 'side-effect-free 'error-free)))
	'(eql floatp-safe list* subst acons equalp random-state-p
	  copy-tree sublis hash-table-p))


(run-hooks 'cl-macs-load-hook)

;;; cl-macs.el ends here

26940:f1998d661bc2

;; Common Lisp compatibility, beyond what is already built-in
;; in Emacs Lisp.
;;
;; This package was written by Dave Gillespie; it is a complete
;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
;;
;; Bug reports, comments, and suggestions are welcome!

;; This file contains the portions of the Common Lisp extensions
;; package which should be autoloaded, but need only be present

	(list 'setq place (list 'cdr (list 'cdr place)))))
(put 'cl-push 'edebug-form-spec 'edebug-sexps)
(put 'cl-pop 'edebug-form-spec 'edebug-sexps)
(put 'cl-pop2 'edebug-form-spec 'edebug-sexps)

(defvar cl-optimize-safety)
(defvar cl-optimize-speed)


;;; This kludge allows macros which use cl-transform-function-property

;;; Initialization.

(defvar cl-old-bc-file-form nil)

(defun cl-compile-time-init ()
  (run-hooks 'cl-hack-bytecomp-hook))


;;; Symbols.

	   (if (or (memq 'eval when) (memq ':execute when))
	       (list* 'eval-when (cons 'compile when) (cddr form))
	     form)))
	(t (eval form) form)))

(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."
  (if (cl-compiling-file)
      (let* ((temp (gentemp "--cl-load-time--"))

			      (list 'function (list* 'lambda (list var other)
						     '--cl-map)) map))))

	       ((memq word '(frame frames screen screens))
		(let ((temp (gensym)))
		  (cl-push (list var  '(selected-frame))
			   loop-for-bindings)
		  (cl-push (list temp nil) loop-for-bindings)
		  (cl-push (list 'prog1 (list 'not (list 'eq var temp))
				 (list 'or temp (list 'setq temp var)))
			   loop-body)
		  (cl-push (list var (list 'next-frame var))
			   loop-for-steps)))

	       ((memq word '(window windows))
		(let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
		      (temp (gensym)))
		  (cl-push (list var (if scr
					 (list 'frame-selected-window scr)
				       '(selected-window)))
			   loop-for-bindings)
		  (cl-push (list temp nil) loop-for-bindings)
		  (cl-push (list 'prog1 (list 'not (list 'eq var temp))
				 (list 'or temp (list 'setq temp var)))

(proclaim '(inline floatp-safe acons map concatenate notany notevery
		   cl-set-elt revappend nreconc gethash))

;;; Things that are side-effect-free.
(mapcar (function (lambda (x) (put x 'side-effect-free t)))
	'(oddp evenp signum last butlast ldiff pairlis gcd lcm
	  isqrt floor* ceiling* truncate* round* mod* rem* subseq
	  list-length get* getf))

;;; Things that are side-effect-and-error-free.
(mapcar (function (lambda (x) (put x 'side-effect-free 'error-free)))
	'(eql floatp-safe list* subst acons equalp random-state-p
	  copy-tree sublis))


(run-hooks 'cl-macs-load-hook)

;;; cl-macs.el ends here