/[emacs]/emacs/lisp/emacs-lisp/cl-extra.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/cl-extra.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.27 by lektu, Mon May 16 15:32:09 2005 UTC revision 1.28 by lektu, Sun May 22 17:48:02 2005 UTC
# Line 46  Line 46 
46    
47  (defun coerce (x type)  (defun coerce (x type)
48    "Coerce OBJECT to type TYPE.    "Coerce OBJECT to type TYPE.
49  TYPE is a Common Lisp type specifier."  TYPE is a Common Lisp type specifier.
50    \n(fn OBJECT TYPE)"
51    (cond ((eq type 'list) (if (listp x) x (append x nil)))    (cond ((eq type 'list) (if (listp x) x (append x nil)))
52          ((eq type 'vector) (if (vectorp x) x (vconcat x)))          ((eq type 'vector) (if (vectorp x) x (vconcat x)))
53          ((eq type 'string) (if (stringp x) x (concat x)))          ((eq type 'string) (if (stringp x) x (concat x)))
# Line 120  strings case-insensitively." Line 121  strings case-insensitively."
121        (nreverse cl-res))))        (nreverse cl-res))))
122    
123  (defun map (cl-type cl-func cl-seq &rest cl-rest)  (defun map (cl-type cl-func cl-seq &rest cl-rest)
124    "Map a function across one or more sequences, returning a sequence.    "Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
125  TYPE is the sequence type to return, FUNC is the function, and SEQS  TYPE is the sequence type to return.
126  are the argument sequences."  \n(fn TYPE FUNCTION SEQUENCE...)"
127    (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest)))    (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest)))
128      (and cl-type (coerce cl-res cl-type))))      (and cl-type (coerce cl-res cl-type))))
129    
130  (defun maplist (cl-func cl-list &rest cl-rest)  (defun maplist (cl-func cl-list &rest cl-rest)
131    "Map FUNC to each sublist of LIST or LISTS.    "Map FUNCTION to each sublist of LIST or LISTs.
132  Like `mapcar', except applies to lists and their cdr's rather than to  Like `mapcar', except applies to lists and their cdr's rather than to
133  the elements themselves."  the elements themselves.
134    \n(fn FUNCTION LIST...)"
135    (if cl-rest    (if cl-rest
136        (let ((cl-res nil)        (let ((cl-res nil)
137              (cl-args (cons cl-list (copy-sequence cl-rest)))              (cl-args (cons cl-list (copy-sequence cl-rest)))
# Line 146  the elements themselves." Line 148  the elements themselves."
148        (nreverse cl-res))))        (nreverse cl-res))))
149    
150  (defun cl-mapc (cl-func cl-seq &rest cl-rest)  (defun cl-mapc (cl-func cl-seq &rest cl-rest)
151    "Like `mapcar', but does not accumulate values returned by the function."    "Like `mapcar', but does not accumulate values returned by the function.
152    \n(fn FUNCTION SEQUENCE...)"
153    (if cl-rest    (if cl-rest
154        (progn (apply 'map nil cl-func cl-seq cl-rest)        (progn (apply 'map nil cl-func cl-seq cl-rest)
155               cl-seq)               cl-seq)
156      (mapc cl-func cl-seq)))      (mapc cl-func cl-seq)))
157    
158  (defun mapl (cl-func cl-list &rest cl-rest)  (defun mapl (cl-func cl-list &rest cl-rest)
159    "Like `maplist', but does not accumulate values returned by the function."    "Like `maplist', but does not accumulate values returned by the function.
160    \n(fn FUNCTION LIST...)"
161    (if cl-rest    (if cl-rest
162        (apply 'maplist cl-func cl-list cl-rest)        (apply 'maplist cl-func cl-list cl-rest)
163      (let ((cl-p cl-list))      (let ((cl-p cl-list))
# Line 161  the elements themselves." Line 165  the elements themselves."
165    cl-list)    cl-list)
166    
167  (defun mapcan (cl-func cl-seq &rest cl-rest)  (defun mapcan (cl-func cl-seq &rest cl-rest)
168    "Like `mapcar', but nconc's together the values returned by the function."    "Like `mapcar', but nconc's together the values returned by the function.
169    \n(fn FUNCTION SEQUENCE...)"
170    (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest)))    (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest)))
171    
172  (defun mapcon (cl-func cl-list &rest cl-rest)  (defun mapcon (cl-func cl-list &rest cl-rest)
173    "Like `maplist', but nconc's together the values returned by the function."    "Like `maplist', but nconc's together the values returned by the function.
174    \n(fn FUNCTION LIST...)"
175    (apply 'nconc (apply 'maplist cl-func cl-list cl-rest)))    (apply 'nconc (apply 'maplist cl-func cl-list cl-rest)))
176    
177  (defun some (cl-pred cl-seq &rest cl-rest)  (defun some (cl-pred cl-seq &rest cl-rest)
178    "Return true if PREDICATE is true of any element of SEQ or SEQs.    "Return true if PREDICATE is true of any element of SEQ or SEQs.
179  If so, return the true (non-nil) value returned by PREDICATE."  If so, return the true (non-nil) value returned by PREDICATE.
180    \n(fn PREDICATE SEQ...)"
181    (if (or cl-rest (nlistp cl-seq))    (if (or cl-rest (nlistp cl-seq))
182        (catch 'cl-some        (catch 'cl-some
183          (apply 'map nil          (apply 'map nil
# Line 183  If so, return the true (non-nil) value r Line 190  If so, return the true (non-nil) value r
190        cl-x)))        cl-x)))
191    
192  (defun every (cl-pred cl-seq &rest cl-rest)  (defun every (cl-pred cl-seq &rest cl-rest)
193    "Return true if PREDICATE is true of every element of SEQ or SEQs."    "Return true if PREDICATE is true of every element of SEQ or SEQs.
194    \n(fn PREDICATE SEQ...)"
195    (if (or cl-rest (nlistp cl-seq))    (if (or cl-rest (nlistp cl-seq))
196        (catch 'cl-every        (catch 'cl-every
197          (apply 'map nil          (apply 'map nil
# Line 195  If so, return the true (non-nil) value r Line 203  If so, return the true (non-nil) value r
203      (null cl-seq)))      (null cl-seq)))
204    
205  (defun notany (cl-pred cl-seq &rest cl-rest)  (defun notany (cl-pred cl-seq &rest cl-rest)
206    "Return true if PREDICATE is false of every element of SEQ or SEQs."    "Return true if PREDICATE is false of every element of SEQ or SEQs.
207    \n(fn PREDICATE SEQ...)"
208    (not (apply 'some cl-pred cl-seq cl-rest)))    (not (apply 'some cl-pred cl-seq cl-rest)))
209    
210  (defun notevery (cl-pred cl-seq &rest cl-rest)  (defun notevery (cl-pred cl-seq &rest cl-rest)
211    "Return true if PREDICATE is false of some element of SEQ or SEQs."    "Return true if PREDICATE is false of some element of SEQ or SEQs.
212    \n(fn PREDICATE SEQ...)"
213    (not (apply 'every cl-pred cl-seq cl-rest)))    (not (apply 'every cl-pred cl-seq cl-rest)))
214    
215  ;;; Support for `loop'.  ;;; Support for `loop'.
# Line 332  If so, return the true (non-nil) value r Line 342  If so, return the true (non-nil) value r
342            (setq a (* (/ a (gcd a b)) b))))            (setq a (* (/ a (gcd a b)) b))))
343        a)))        a)))
344    
345  (defun isqrt (a)  (defun isqrt (x)
346    "Return the integer square root of the argument."    "Return the integer square root of the argument."
347    (if (and (integerp a) (> a 0))    (if (and (integerp x) (> x 0))
348        (let ((g (cond ((<= a 100) 10) ((<= a 10000) 100)        (let ((g (cond ((<= x 100) 10) ((<= x 10000) 100)
349                       ((<= a 1000000) 1000) (t a)))                       ((<= x 1000000) 1000) (t x)))
350              g2)              g2)
351          (while (< (setq g2 (/ (+ g (/ a g)) 2)) g)          (while (< (setq g2 (/ (+ g (/ x g)) 2)) g)
352            (setq g g2))            (setq g g2))
353          g)          g)
354      (if (eq a 0) 0 (signal 'arith-error nil))))      (if (eq x 0) 0 (signal 'arith-error nil))))
355    
356  (defun floor* (x &optional y)  (defun floor* (x &optional y)
357    "Return a list of the floor of X and the fractional part of X.    "Return a list of the floor of X and the fractional part of X.
# Line 388  With two arguments, return rounding and Line 398  With two arguments, return rounding and
398    "The remainder of X divided by Y, with the same sign as X."    "The remainder of X divided by Y, with the same sign as X."
399    (nth 1 (truncate* x y)))    (nth 1 (truncate* x y)))
400    
401  (defun signum (a)  (defun signum (x)
402    "Return 1 if A is positive, -1 if negative, 0 if zero."    "Return 1 if X is positive, -1 if negative, 0 if zero."
403    (cond ((> a 0) 1) ((< a 0) -1) (t 0)))    (cond ((> x 0) 1) ((< x 0) -1) (t 0)))
404    
405    
406  ;; Random numbers.  ;; Random numbers.
# Line 514  If START or END is negative, it counts f Line 524  If START or END is negative, it counts f
524                 res))))))                 res))))))
525    
526  (defun concatenate (type &rest seqs)  (defun concatenate (type &rest seqs)
527    "Concatenate, into a sequence of type TYPE, the argument SEQUENCES."    "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
528    \n(fn TYPE SEQUENCE...)"
529    (cond ((eq type 'vector) (apply 'vconcat seqs))    (cond ((eq type 'vector) (apply 'vconcat seqs))
530          ((eq type 'string) (apply 'concat seqs))          ((eq type 'string) (apply 'concat seqs))
531          ((eq type 'list) (apply 'append (append seqs '(nil))))          ((eq type 'list) (apply 'append (append seqs '(nil))))
# Line 532  If START or END is negative, it counts f Line 543  If START or END is negative, it counts f
543    (nconc (nreverse x) y))    (nconc (nreverse x) y))
544    
545  (defun list-length (x)  (defun list-length (x)
546    "Return the length of a list.  Return nil if list is circular."    "Return the length of list X.  Return nil if list is circular."
547    (let ((n 0) (fast x) (slow x))    (let ((n 0) (fast x) (slow x))
548      (while (and (cdr fast) (not (and (eq fast slow) (> n 0))))      (while (and (cdr fast) (not (and (eq fast slow) (> n 0))))
549        (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow)))        (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow)))
# Line 550  If START or END is negative, it counts f Line 561  If START or END is negative, it counts f
561  ;;; Property lists.  ;;; Property lists.
562    
563  (defun get* (sym tag &optional def)    ; See compiler macro in cl-macs.el  (defun get* (sym tag &optional def)    ; See compiler macro in cl-macs.el
564    "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none."    "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none.
565    \n(fn SYMBOL PROPNAME &optional DEFAULT)"
566    (or (get sym tag)    (or (get sym tag)
567        (and def        (and def
568             (let ((plist (symbol-plist sym)))             (let ((plist (symbol-plist sym)))
# Line 560  If START or END is negative, it counts f Line 572  If START or END is negative, it counts f
572    
573  (defun getf (plist tag &optional def)  (defun getf (plist tag &optional def)
574    "Search PROPLIST for property PROPNAME; return its value or DEFAULT.    "Search PROPLIST for property PROPNAME; return its value or DEFAULT.
575  PROPLIST is a list of the sort returned by `symbol-plist'."  PROPLIST is a list of the sort returned by `symbol-plist'.
576    \n(fn PROPLIST PROPNAME &optional DEFAULT)"
577    (setplist '--cl-getf-symbol-- plist)    (setplist '--cl-getf-symbol-- plist)
578    (or (get '--cl-getf-symbol-- tag)    (or (get '--cl-getf-symbol-- tag)
579        ;; Originally we called get* here,        ;; Originally we called get* here,
# Line 582  PROPLIST is a list of the sort returned Line 595  PROPLIST is a list of the sort returned
595      (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))      (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
596    
597  (defun cl-remprop (sym tag)  (defun cl-remprop (sym tag)
598    "Remove from SYMBOL's plist the property PROP and its value."    "Remove from SYMBOL's plist the property PROPNAME and its value.
599    \n(fn SYMBOL PROPNAME)"
600    (let ((plist (symbol-plist sym)))    (let ((plist (symbol-plist sym)))
601      (if (and plist (eq tag (car plist)))      (if (and plist (eq tag (car plist)))
602          (progn (setplist sym (cdr (cdr plist))) t)          (progn (setplist sym (cdr (cdr plist))) t)

Legend:
Removed from v.1.27  
changed lines
  Added in v.1.28

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26