;;; gnus-clfns.el --- compiler macros for emulating cl functions
-;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
;; Author: Kastsumi Yamaoka <yamaoka@jpl.org>
;; Keywords: cl, compile
(require 'pym)
(define-compiler-macro butlast (&whole form x &optional n)
- (if (and (fboundp 'butlast)
- (subrp (symbol-function 'butlast)))
+ (if (>= emacs-major-version 21)
form
(if n
`(let ((x ,x)
(setcdr (nthcdr (- m 2) x) nil)
x))))))
- (define-compiler-macro coerce (&whole form x type)
- (if (and (fboundp 'coerce)
- (subrp (symbol-function 'coerce)))
- form
- `(let ((x ,x)
- (type ,type))
- (cond ((eq type 'list) (if (listp x) x (append x nil)))
- ((eq type 'vector) (if (vectorp x) x (vconcat x)))
- ((eq type 'string) (if (stringp x) x (concat x)))
- ((eq type 'array) (if (arrayp x) x (vconcat x)))
- ((and (eq type 'character) (stringp x) (= (length x) 1))
- (aref x 0))
- ((and (eq type 'character) (symbolp x)
- (= (length (symbol-name x)) 1))
- (aref (symbol-name x) 0))
- ((eq type 'float) (float x))
- ((typep x type) x)
- (t (error "Can't coerce %s to type %s" x type))))))
+;; (define-compiler-macro coerce (&whole form x type)
+;; (if (and (fboundp 'coerce)
+;; (subrp (symbol-function 'coerce)))
+;; form
+;; `(let ((x ,x)
+;; (type ,type))
+;; (cond ((eq type 'list) (if (listp x) x (append x nil)))
+;; ((eq type 'vector) (if (vectorp x) x (vconcat x)))
+;; ((eq type 'string) (if (stringp x) x (concat x)))
+;; ((eq type 'array) (if (arrayp x) x (vconcat x)))
+;; ((and (eq type 'character) (stringp x) (= (length x) 1))
+;; (aref x 0))
+;; ((and (eq type 'character) (symbolp x)
+;; (= (length (symbol-name x)) 1))
+;; (aref (symbol-name x) 0))
+;; ((eq type 'float) (float x))
+;; ((typep x type) x)
+;; (t (error "Can't coerce %s to type %s" x type))))))
- (define-compiler-macro copy-list (&whole form list)
- (if (and (fboundp 'copy-list)
- (subrp (symbol-function 'copy-list)))
- form
- `(let ((list ,list))
- (if (consp list)
- (let ((res nil))
- (while (consp list) (push (pop list) res))
- (prog1 (nreverse res) (setcdr res list)))
- (car list)))))
+;; (define-compiler-macro copy-list (&whole form list)
+;; (if (and (fboundp 'copy-list)
+;; (subrp (symbol-function 'copy-list)))
+;; form
+;; `(let ((list ,list))
+;; (if (consp list)
+;; (let ((res nil))
+;; (while (consp list) (push (pop list) res))
+;; (prog1 (nreverse res) (setcdr res list)))
+;; (car list)))))
(define-compiler-macro last (&whole form x &optional n)
- (if (and (fboundp 'last)
- (subrp (symbol-function 'last)))
+ (if (>= emacs-major-version 20)
form
(if n
`(let* ((x ,x)
(pop x))
x))))
- (define-compiler-macro merge (&whole form type seq1 seq2 pred &rest keys)
- (if (and (fboundp 'merge)
- (subrp (symbol-function 'merge)))
+ (define-compiler-macro mapc (&whole form fn seq &rest rest)
+ (if (>= emacs-major-version 21)
form
- `(let ((type ,type)
- (seq1 ,seq1)
- (seq2 ,seq2)
- (pred ,pred))
- (or (listp seq1) (setq seq1 (append seq1 nil)))
- (or (listp seq2) (setq seq2 (append seq2 nil)))
- (let ((res nil))
- (while (and seq1 seq2)
- (if (funcall pred (car seq2) (car seq1))
- (push (pop seq2) res)
- (push (pop seq1) res)))
- (coerce (nconc (nreverse res) seq1 seq2) type)))))
+ (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 string (&whole form &rest args)
- (if (and (fboundp 'string)
- (subrp (symbol-function 'string)))
- form
- (list 'concat (cons 'list args))))
+;; (define-compiler-macro merge (&whole form type seq1 seq2 pred &rest keys)
+;; (if (and (fboundp 'merge)
+;; (subrp (symbol-function 'merge)))
+;; form
+;; `(let ((type ,type)
+;; (seq1 ,seq1)
+;; (seq2 ,seq2)
+;; (pred ,pred))
+;; (or (listp seq1) (setq seq1 (append seq1 nil)))
+;; (or (listp seq2) (setq seq2 (append seq2 nil)))
+;; (let ((res nil))
+;; (while (and seq1 seq2)
+;; (if (funcall pred (car seq2) (car seq1))
+;; (push (pop seq2) res)
+;; (push (pop seq1) res)))
+;; (coerce (nconc (nreverse res) seq1 seq2) type)))))
- (defun-maybe string (&rest args)
- "Concatenate all the argument characters and make the result a string."
- (concat args))
+;; (define-compiler-macro string (&whole form &rest args)
+;; (if (>= emacs-major-version 20)
+;; form
+;; (list 'concat (cons 'list args))))
+
+;; (defun-maybe string (&rest args)
+;; "Concatenate all the argument characters and make the result a string."
+;; (concat args))
(define-compiler-macro string-to-list (&whole form string)
(cond ((fboundp 'string-to-list)
(setq l (cons c l)))
(nreverse l)))
- (define-compiler-macro subseq (&whole form seq start &optional end)
- (if (and (fboundp 'subseq)
- (subrp (symbol-function 'subseq)))
- form
- (if end
- `(let ((seq ,seq)
- (start ,start)
- (end ,end))
- (if (stringp seq)
- (substring seq start end)
- (let (len)
- (if (< end 0)
- (setq end (+ end (setq len (length seq)))))
- (if (< start 0)
- (setq start (+ start (or len (setq len (length seq))))))
- (cond ((listp seq)
- (if (> start 0)
- (setq seq (nthcdr start seq)))
- (let ((res nil))
- (while (>= (setq end (1- end)) start)
- (push (pop seq) res))
- (nreverse res)))
- (t
- (let ((res (make-vector (max (- end start) 0) nil))
- (i 0))
- (while (< start end)
- (aset res i (aref seq start))
- (setq i (1+ i)
- start (1+ start)))
- res))))))
- `(let ((seq ,seq)
- (start ,start))
- (if (stringp seq)
- (substring seq start)
- (let (len)
- (if (< start 0)
- (setq start (+ start (or len (setq len (length seq))))))
- (cond ((listp seq)
- (if (> start 0)
- (setq seq (nthcdr start seq)))
- (copy-sequence seq))
- (t
- (let* ((end (or len (length seq)))
- (res (make-vector (max (- end start) 0) nil))
- (i 0))
- (while (< start end)
- (aset res i (aref seq start))
- (setq i (1+ i)
- start (1+ start)))
- res)))))))))
+;; (define-compiler-macro subseq (&whole form seq start &optional end)
+;; (if (and (fboundp 'subseq)
+;; (subrp (symbol-function 'subseq)))
+;; form
+;; (if end
+;; `(let ((seq ,seq)
+;; (start ,start)
+;; (end ,end))
+;; (if (stringp seq)
+;; (substring seq start end)
+;; (let (len)
+;; (if (< end 0)
+;; (setq end (+ end (setq len (length seq)))))
+;; (if (< start 0)
+;; (setq start (+ start (or len (setq len (length seq))))))
+;; (cond ((listp seq)
+;; (if (> start 0)
+;; (setq seq (nthcdr start seq)))
+;; (let ((res nil))
+;; (while (>= (setq end (1- end)) start)
+;; (push (pop seq) res))
+;; (nreverse res)))
+;; (t
+;; (let ((res (make-vector (max (- end start) 0) nil))
+;; (i 0))
+;; (while (< start end)
+;; (aset res i (aref seq start))
+;; (setq i (1+ i)
+;; start (1+ start)))
+;; res))))))
+;; `(let ((seq ,seq)
+;; (start ,start))
+;; (if (stringp seq)
+;; (substring seq start)
+;; (let (len)
+;; (if (< start 0)
+;; (setq start (+ start (or len (setq len (length seq))))))
+;; (cond ((listp seq)
+;; (if (> start 0)
+;; (setq seq (nthcdr start seq)))
+;; (copy-sequence seq))
+;; (t
+;; (let* ((end (or len (length seq)))
+;; (res (make-vector (max (- end start) 0) nil))
+;; (i 0))
+;; (while (< start end)
+;; (aset res i (aref seq start))
+;; (setq i (1+ i)
+;; start (1+ start)))
+;; res)))))))))
)
;; A tool for the developers.
projects / elisp / gnus.git- / commitdiff