From 12901d521adee7dcfe580fb3bf4554b5f693a08e Mon Sep 17 00:00:00 2001 From: yamaoka Date: Wed, 24 Nov 1999 02:39:09 +0000 Subject: [PATCH] (union, copy-list): New compiler macros for emulating cl functions. --- lisp/dgnushack.el | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) 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). -- 1.7.10.4