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))) |
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))) |
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)) |
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 |
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 |
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'. |
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. |
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. |
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)))) |
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))) |
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))) |
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, |
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) |