From f27c5f8271ff0fdd8c0ed430dc5235b16d8048bd Mon Sep 17 00:00:00 2001
From: yamaoka <yamaoka>
Date: Wed, 15 Dec 1999 08:02:42 +0000
Subject: [PATCH] (read-color, x-defined-colors, event-object,
 get-popup-menu-response, toolbar-gnus,
 get-charset-property, find-coding-system,
 coding-system-get, font-lock-set-defaults): Don't bind.
 (union, member-if, mapcon, mapc, last): Don't define as
 compiler macros under XEmacs. (member-if): New compiler
 macro for emulating cl function.

---
 lisp/dgnushack.el |  186 ++++++++++++++++++++++++++---------------------------
 1 file changed, 92 insertions(+), 94 deletions(-)

diff --git a/lisp/dgnushack.el b/lisp/dgnushack.el
index e4cf885..2b21985 100644
--- a/lisp/dgnushack.el
+++ b/lisp/dgnushack.el
@@ -50,86 +50,99 @@
 
 (require 'cl)
 
-;; cl functions.
-(define-compiler-macro mapc (&whole form fn seq &rest rest)
-  (if (and (fboundp 'mapc)
-	   (subrp (symbol-function 'mapc)))
-      form
-    (if rest
-	`(let* ((fn ,fn)
-		(seq ,seq)
-		(args (list seq ,@rest))
-		(m (apply (function min) (mapcar (function length) args)))
-		(n 0))
-	   (while (< n m)
-	     (apply fn (mapcar (function (lambda (arg) (nth n arg))) args))
-	     (setq n (1+ n)))
-	   seq)
-      `(let ((seq ,seq))
-	 (mapcar ,fn seq)
-	 seq))))
-
-(define-compiler-macro last (&whole form x &optional n)
-  (if (and (fboundp 'last)
-	   (subrp (symbol-function 'last)))
-      form
-    (if n
-	`(let* ((x ,x)
-		(n ,n)
-		(m 0)
-		(p x))
-	   (while (consp p)
-	     (incf m)
-	     (pop p))
-	   (if (<= n 0)
-	       p
-	     (if (< n m)
-		 (nthcdr (- m n) x)
-	       x)))
-      `(let ((x ,x))
-	 (while (consp (cdr x))
-	   (pop x))
-	 x))))
-
-(define-compiler-macro mapcon (&whole form fn seq &rest rest)
-  (if (and (fboundp 'mapcon)
-	   (subrp (symbol-function 'mapcon)))
-      form
-    (if rest
+;; Emulating cl functions.
+(unless (featurep 'xemacs)
+  (define-compiler-macro last (&whole form x &optional n)
+    (if (and (fboundp 'last)
+	     (subrp (symbol-function 'last)))
+	form
+      (if n
+	  `(let* ((x ,x)
+		  (n ,n)
+		  (m 0)
+		  (p x))
+	     (while (consp p)
+	       (incf m)
+	       (pop p))
+	     (if (<= n 0)
+		 p
+	       (if (< n m)
+		   (nthcdr (- m n) x)
+		 x)))
+	`(let ((x ,x))
+	   (while (consp (cdr x))
+	     (pop x))
+	   x))))
+
+  (define-compiler-macro mapc (&whole form fn seq &rest rest)
+    (if (and (fboundp 'mapc)
+	     (subrp (symbol-function 'mapc)))
+	form
+      (if rest
+	  `(let* ((fn ,fn)
+		  (seq ,seq)
+		  (args (list seq ,@rest))
+		  (m (apply (function min) (mapcar (function length) args)))
+		  (n 0))
+	     (while (< n m)
+	       (apply fn (mapcar (function (lambda (arg) (nth n arg))) args))
+	       (setq n (1+ n)))
+	     seq)
+	`(let ((seq ,seq))
+	   (mapcar ,fn seq)
+	   seq))))
+
+  (define-compiler-macro mapcon (&whole form fn seq &rest rest)
+    (if (and (fboundp 'mapcon)
+	     (subrp (symbol-function 'mapcon)))
+	form
+      (if rest
+	  `(let (res
+		 (args (list ,seq ,@rest))
+		 p)
+	     (while (not (memq nil args))
+	       (push (apply ,fn args) res)
+	       (setq p args)
+	       (while p
+		 (setcar p (cdr (pop p)))
+		 ))
+	     (apply (function nconc) (nreverse res)))
 	`(let (res
-	       (args (list ,seq ,@rest))
-	       p)
-	   (while (not (memq nil args))
-	     (push (apply ,fn args) res)
-	     (setq p args)
-	     (while p
-	       (setcar p (cdr (pop p)))
-	       ))
-	   (apply (function nconc) (nreverse res)))
-      `(let (res
-	     (arg ,seq))
-	 (while arg
-	   (push (funcall ,fn arg) res)
-	   (setq arg (cdr arg)))
-	 (apply (function nconc) (nreverse res))))))
-
-(define-compiler-macro union (&whole form list1 list2)
-  (if (and (fboundp 'union)
-	   (subrp (symbol-function 'union)))
-      form
-    `(let ((a ,list1)
-	   (b ,list2))
-       (cond ((null a) b)
-	     ((null b) a)
-	     ((equal a b) a)
-	     (t
-	      (or (>= (length a) (length b))
-		  (setq a (prog1 b (setq b a))))
-	      (while b
-		(or (memq (car b) a)
-		    (push (car b) a))
-		(pop b))
-	      a)))))
+	       (arg ,seq))
+	   (while arg
+	     (push (funcall ,fn arg) res)
+	     (setq arg (cdr arg)))
+	   (apply (function nconc) (nreverse res))))))
+
+  (define-compiler-macro member-if (&whole form pred list)
+    (if (and (fboundp 'member-if)
+	     (subrp (symbol-function 'member-if)))
+	form
+      `(let ((fn ,pred)
+	     (seq ,list))
+	 (while (and seq
+		     (not (funcall fn (car seq))))
+	   (pop seq))
+	 seq)))
+
+  (define-compiler-macro union (&whole form list1 list2)
+    (if (and (fboundp 'union)
+	     (subrp (symbol-function 'union)))
+	form
+      `(let ((a ,list1)
+	     (b ,list2))
+	 (cond ((null a) b)
+	       ((null b) a)
+	       ((equal a b) a)
+	       (t
+		(or (>= (length a) (length b))
+		    (setq a (prog1 b (setq b a))))
+		(while b
+		  (or (memq (car b) a)
+		      (push (car b) a))
+		  (pop b))
+		a)))))
+  )
 
 ;; If we are building w3 in a different directory than the source
 ;; directory, we must read *.el from source directory and write *.elc
@@ -241,16 +254,8 @@
 ;; Unknown variables and functions.
 (unless (boundp 'buffer-file-coding-system)
   (defvar buffer-file-coding-system (symbol-value 'file-coding-system)))
-(autoload 'font-lock-set-defaults "font-lock")
-(unless (fboundp 'coding-system-get)
-  (defalias 'coding-system-get 'ignore))
-(when (boundp 'MULE)
-  (defalias 'find-coding-system 'ignore))
-(unless (fboundp 'get-charset-property)
-  (defalias 'get-charset-property 'ignore))
 (unless (featurep 'xemacs)
   (defalias 'Custom-make-dependencies 'ignore)
-  (defalias 'toolbar-gnus 'ignore)
   (defalias 'update-autoloads-from-directory 'ignore))
 (autoload 'texinfo-parse-line-arg "texinfmt")
 
@@ -265,13 +270,6 @@
 (defalias 'ange-ftp-re-read-dir 'ignore)
 (defalias 'define-mail-user-agent 'ignore)
 
-(eval-and-compile
-  (unless (string-match "XEmacs" emacs-version)
-    (fset 'get-popup-menu-response 'ignore)
-    (fset 'event-object 'ignore)
-    (fset 'x-defined-colors 'ignore)
-    (fset 'read-color 'ignore)))
-
 (defun dgnushack-compile (&optional warn)
   ;;(setq byte-compile-dynamic t)
   (unless warn
-- 
1.7.10.4