From: yamaoka <yamaoka>
Date: Wed, 24 Nov 1999 02:39:09 +0000 (+0000)
Subject: (union, copy-list): New compiler macros for emulating cl functions.
X-Git-Tag: t-gnus-6_13_3-04~2
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=12901d521adee7dcfe580fb3bf4554b5f693a08e;p=elisp%2Fgnus.git-

(union, copy-list): New compiler macros for emulating cl functions.
---

diff --git a/lisp/dgnushack.el b/lisp/dgnushack.el
index 24d24c3..5ddc31a 100644
--- a/lisp/dgnushack.el
+++ b/lisp/dgnushack.el
@@ -49,6 +49,56 @@
 (fset 'facep 'ignore)
 
 (require 'cl)
+
+;; Define cl functions as compiler macros.
+(unless (and (fboundp 'copy-list)
+	     (subrp (symbol-function 'copy-list)))
+  (define-compiler-macro copy-list (list)
+    (` (let ((list (, list)))
+	 (if (consp list)
+	     (let ((res nil))
+	       (while (consp list) (push (pop list) res))
+	       (prog1 (nreverse res) (setcdr res list)))
+	   (car list)))))
+  )
+
+(unless (and (fboundp 'union)
+	     (subrp (symbol-function 'union)))
+  (define-compiler-macro union (cl-list1 cl-list2 &rest cl-keys)
+    (let ((adjoin (symbol-function 'adjoin)))
+      (if cl-keys
+	  (` (let ((list1 (, cl-list1))
+		   (list2 (, cl-list2))
+		   (keys (, cl-keys)))
+	       (cond ((null list1) list2) ((null list2) list1)
+		     ((equal list1 list2) list1)
+		     (t
+		      (or (>= (length list1) (length list2))
+			  (setq list1 (prog1 list2 (setq list2 list1))))
+		      (while list2
+			(if (or keys (numberp (car list2)))
+			    (setq list1 (apply (, adjoin)
+					       (car list2) list1 keys))
+			  (or (memq (car list2) list1)
+			      (push (car list2) list1)))
+			(pop list2))
+		      list1))))
+	(` (let ((list1 (, cl-list1))
+		 (list2 (, cl-list2)))
+	     (cond ((null list1) list2) ((null list2) list1)
+		   ((equal list1 list2) list1)
+		   (t
+		    (or (>= (length list1) (length list2))
+			(setq list1 (prog1 list2 (setq list2 list1))))
+		    (while list2
+		      (if (numberp (car list2))
+			  (setq list1 (funcall (, adjoin) (car list2) list1))
+			(or (memq (car list2) list1)
+			    (push (car list2) list1)))
+		      (pop list2))
+		    list1)))))))
+  )
+
 (require 'bytecomp)
 
 ;; Attempt to pickup the additional load-path(s).