42 |
(error "Tried to load `cl-extra' before `cl'!")) |
(error "Tried to load `cl-extra' before `cl'!")) |
43 |
|
|
44 |
|
|
|
;;; We define these here so that this file can compile without having |
|
|
;;; loaded the cl.el file already. |
|
|
|
|
|
(defmacro cl-push (x place) (list 'setq place (list 'cons x place))) |
|
|
(defmacro cl-pop (place) |
|
|
(list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))) |
|
|
|
|
45 |
;;; Type coercion. |
;;; Type coercion. |
46 |
|
|
47 |
(defun coerce (x type) |
(defun coerce (x type) |
104 |
(setcar cl-p1 (cdr (car cl-p1)))) |
(setcar cl-p1 (cdr (car cl-p1)))) |
105 |
(aref (car cl-p1) cl-i))) |
(aref (car cl-p1) cl-i))) |
106 |
(setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) |
(setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) |
107 |
(cl-push (apply cl-func cl-args) cl-res) |
(push (apply cl-func cl-args) cl-res) |
108 |
(setq cl-i (1+ cl-i))) |
(setq cl-i (1+ cl-i))) |
109 |
(nreverse cl-res)) |
(nreverse cl-res)) |
110 |
(let ((cl-res nil) |
(let ((cl-res nil) |
113 |
(let ((cl-n (min (length cl-x) (length cl-y))) |
(let ((cl-n (min (length cl-x) (length cl-y))) |
114 |
(cl-i -1)) |
(cl-i -1)) |
115 |
(while (< (setq cl-i (1+ cl-i)) cl-n) |
(while (< (setq cl-i (1+ cl-i)) cl-n) |
116 |
(cl-push (funcall cl-func |
(push (funcall cl-func |
117 |
(if (consp cl-x) (cl-pop cl-x) (aref cl-x cl-i)) |
(if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) |
118 |
(if (consp cl-y) (cl-pop cl-y) (aref cl-y cl-i))) |
(if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) |
119 |
cl-res))) |
cl-res))) |
120 |
(nreverse cl-res)))) |
(nreverse cl-res)))) |
121 |
|
|
135 |
(cl-args (cons cl-list (copy-sequence cl-rest))) |
(cl-args (cons cl-list (copy-sequence cl-rest))) |
136 |
cl-p) |
cl-p) |
137 |
(while (not (memq nil cl-args)) |
(while (not (memq nil cl-args)) |
138 |
(cl-push (apply cl-func cl-args) cl-res) |
(push (apply cl-func cl-args) cl-res) |
139 |
(setq cl-p cl-args) |
(setq cl-p cl-args) |
140 |
(while cl-p (setcar cl-p (cdr (cl-pop cl-p)) ))) |
(while cl-p (setcar cl-p (cdr (pop cl-p)) ))) |
141 |
(nreverse cl-res)) |
(nreverse cl-res)) |
142 |
(let ((cl-res nil)) |
(let ((cl-res nil)) |
143 |
(while cl-list |
(while cl-list |
144 |
(cl-push (funcall cl-func cl-list) cl-res) |
(push (funcall cl-func cl-list) cl-res) |
145 |
(setq cl-list (cdr cl-list))) |
(setq cl-list (cdr cl-list))) |
146 |
(nreverse cl-res)))) |
(nreverse cl-res)))) |
147 |
|
|
179 |
(if cl-res (throw 'cl-some cl-res))))) |
(if cl-res (throw 'cl-some cl-res))))) |
180 |
cl-seq cl-rest) nil) |
cl-seq cl-rest) nil) |
181 |
(let ((cl-x nil)) |
(let ((cl-x nil)) |
182 |
(while (and cl-seq (not (setq cl-x (funcall cl-pred (cl-pop cl-seq)))))) |
(while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) |
183 |
cl-x))) |
cl-x))) |
184 |
|
|
185 |
(defun every (cl-pred cl-seq &rest cl-rest) |
(defun every (cl-pred cl-seq &rest cl-rest) |
311 |
(defvar cl-progv-save) |
(defvar cl-progv-save) |
312 |
(defun cl-progv-before (syms values) |
(defun cl-progv-before (syms values) |
313 |
(while syms |
(while syms |
314 |
(cl-push (if (boundp (car syms)) |
(push (if (boundp (car syms)) |
315 |
(cons (car syms) (symbol-value (car syms))) |
(cons (car syms) (symbol-value (car syms))) |
316 |
(car syms)) cl-progv-save) |
(car syms)) cl-progv-save) |
317 |
(if values |
(if values |
318 |
(set (cl-pop syms) (cl-pop values)) |
(set (pop syms) (pop values)) |
319 |
(makunbound (cl-pop syms))))) |
(makunbound (pop syms))))) |
320 |
|
|
321 |
(defun cl-progv-after () |
(defun cl-progv-after () |
322 |
(while cl-progv-save |
(while cl-progv-save |
323 |
(if (consp (car cl-progv-save)) |
(if (consp (car cl-progv-save)) |
324 |
(set (car (car cl-progv-save)) (cdr (car cl-progv-save))) |
(set (car (car cl-progv-save)) (cdr (car cl-progv-save))) |
325 |
(makunbound (car cl-progv-save))) |
(makunbound (car cl-progv-save))) |
326 |
(cl-pop cl-progv-save))) |
(pop cl-progv-save))) |
327 |
|
|
328 |
|
|
329 |
;;; Numbers. |
;;; Numbers. |
330 |
|
|
331 |
(defun gcd (&rest args) |
(defun gcd (&rest args) |
332 |
"Return the greatest common divisor of the arguments." |
"Return the greatest common divisor of the arguments." |
333 |
(let ((a (abs (or (cl-pop args) 0)))) |
(let ((a (abs (or (pop args) 0)))) |
334 |
(while args |
(while args |
335 |
(let ((b (abs (cl-pop args)))) |
(let ((b (abs (pop args)))) |
336 |
(while (> b 0) (setq b (% a (setq a b)))))) |
(while (> b 0) (setq b (% a (setq a b)))))) |
337 |
a)) |
a)) |
338 |
|
|
340 |
"Return the least common multiple of the arguments." |
"Return the least common multiple of the arguments." |
341 |
(if (memq 0 args) |
(if (memq 0 args) |
342 |
0 |
0 |
343 |
(let ((a (abs (or (cl-pop args) 1)))) |
(let ((a (abs (or (pop args) 1)))) |
344 |
(while args |
(while args |
345 |
(let ((b (abs (cl-pop args)))) |
(let ((b (abs (pop args)))) |
346 |
(setq a (* (/ a (gcd a b)) b)))) |
(setq a (* (/ a (gcd a b)) b)))) |
347 |
a))) |
a))) |
348 |
|
|
515 |
(if end |
(if end |
516 |
(let ((res nil)) |
(let ((res nil)) |
517 |
(while (>= (setq end (1- end)) start) |
(while (>= (setq end (1- end)) start) |
518 |
(cl-push (cl-pop seq) res)) |
(push (pop seq) res)) |
519 |
(nreverse res)) |
(nreverse res)) |
520 |
(copy-sequence seq))) |
(copy-sequence seq))) |
521 |
(t |
(t |
606 |
|
|
607 |
|
|
608 |
;;; Hash tables. |
;;; Hash tables. |
609 |
|
;; This is just kept for compatibility with code byte-compiled by Emacs-20. |
610 |
|
|
611 |
(defun cl-make-hash-table (&rest cl-keys) |
;; No idea if this might still be needed. |
|
"Make an empty Common Lisp-style hash-table. |
|
|
Keywords supported: :test :size |
|
|
The Common Lisp keywords :rehash-size and :rehash-threshold are ignored." |
|
|
(let ((cl-test (or (car (cdr (memq :test cl-keys))) 'eql)) |
|
|
(cl-size (or (car (cdr (memq :size cl-keys))) 20))) |
|
|
(make-hash-table :size cl-size :test cl-size))) |
|
|
|
|
|
(defun cl-hash-table-p (x) |
|
|
"Return t if OBJECT is a hash table." |
|
|
(or (hash-table-p x) |
|
|
(eq (car-safe x) 'cl-hash-table-tag))) |
|
|
|
|
612 |
(defun cl-not-hash-table (x &optional y &rest z) |
(defun cl-not-hash-table (x &optional y &rest z) |
613 |
(signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) |
(signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) |
614 |
|
|
|
(defun cl-hash-lookup (key table) |
|
|
(or (eq (car-safe table) 'cl-hash-table-tag) (cl-not-hash-table table)) |
|
|
(let* ((array (nth 2 table)) (test (car (cdr table))) (str key) sym) |
|
|
(if (symbolp array) (setq str nil sym (symbol-value array)) |
|
|
(while (or (consp str) (and (vectorp str) (> (length str) 0))) |
|
|
(setq str (elt str 0))) |
|
|
(cond ((stringp str) (if (eq test 'equalp) (setq str (downcase str)))) |
|
|
((symbolp str) (setq str (symbol-name str))) |
|
|
((and (numberp str) (> str -8000000) (< str 8000000)) |
|
|
(or (integerp str) (setq str (truncate str))) |
|
|
(setq str (aref ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" |
|
|
"11" "12" "13" "14" "15"] (logand str 15)))) |
|
|
(t (setq str "*"))) |
|
|
(setq sym (symbol-value (intern-soft str array)))) |
|
|
(list (and sym (cond ((or (eq test 'eq) |
|
|
(and (eq test 'eql) (not (numberp key)))) |
|
|
(assq key sym)) |
|
|
((memq test '(eql equal)) (assoc key sym)) |
|
|
(t (assoc* key sym :test test)))) |
|
|
sym str))) |
|
|
|
|
|
;; These variables are just kept for compatibility with code |
|
|
;; byte-compiled by Emacs-20. |
|
615 |
(defvar cl-builtin-gethash (symbol-function 'gethash)) |
(defvar cl-builtin-gethash (symbol-function 'gethash)) |
616 |
(defvar cl-builtin-remhash (symbol-function 'remhash)) |
(defvar cl-builtin-remhash (symbol-function 'remhash)) |
617 |
(defvar cl-builtin-clrhash (symbol-function 'clrhash)) |
(defvar cl-builtin-clrhash (symbol-function 'clrhash)) |
618 |
(defvar cl-builtin-maphash (symbol-function 'maphash)) |
(defvar cl-builtin-maphash (symbol-function 'maphash)) |
619 |
|
|
620 |
(defun cl-gethash (key table &optional def) |
(defalias 'cl-gethash 'gethash) |
621 |
"Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT." |
(defalias 'cl-puthash 'puthash) |
622 |
(if (consp table) |
(defalias 'cl-remhash 'remhash) |
623 |
(let ((found (cl-hash-lookup key table))) |
(defalias 'cl-clrhash 'clrhash) |
624 |
(if (car found) (cdr (car found)) def)) |
(defalias 'cl-maphash 'maphash) |
625 |
(gethash key table def))) |
;; These three actually didn't exist in Emacs-20. |
626 |
|
(defalias 'cl-make-hash-table 'make-hash-table) |
627 |
(defun cl-puthash (key val table) |
(defalias 'cl-hash-table-p 'hash-table-p) |
628 |
(if (consp table) |
(defalias 'cl-hash-table-count 'hash-table-count) |
|
(let ((found (cl-hash-lookup key table))) |
|
|
(if (car found) (setcdr (car found) val) |
|
|
(if (nth 2 found) |
|
|
(progn |
|
|
(if (> (nth 3 table) (* (length (nth 2 table)) 3)) |
|
|
(let ((new-table (make-vector (nth 3 table) 0))) |
|
|
(mapatoms (function |
|
|
(lambda (sym) |
|
|
(set (intern (symbol-name sym) new-table) |
|
|
(symbol-value sym)))) |
|
|
(nth 2 table)) |
|
|
(setcar (cdr (cdr table)) new-table))) |
|
|
(set (intern (nth 2 found) (nth 2 table)) |
|
|
(cons (cons key val) (nth 1 found)))) |
|
|
(set (nth 2 table) (cons (cons key val) (nth 1 found)))) |
|
|
(setcar (cdr (cdr (cdr table))) (1+ (nth 3 table))))) |
|
|
(funcall 'puthash key val table)) val) |
|
|
|
|
|
(defun cl-remhash (key table) |
|
|
"Remove KEY from HASH-TABLE." |
|
|
(if (consp table) |
|
|
(let ((found (cl-hash-lookup key table))) |
|
|
(and (car found) |
|
|
(let ((del (delq (car found) (nth 1 found)))) |
|
|
(setcar (cdr (cdr (cdr table))) (1- (nth 3 table))) |
|
|
(if (nth 2 found) (set (intern (nth 2 found) (nth 2 table)) del) |
|
|
(set (nth 2 table) del)) t))) |
|
|
(prog1 (not (eq (gethash key table '--cl--) '--cl--)) |
|
|
(remhash key table)))) |
|
|
|
|
|
(defun cl-clrhash (table) |
|
|
"Clear HASH-TABLE." |
|
|
(if (consp table) |
|
|
(progn |
|
|
(or (cl-hash-table-p table) (cl-not-hash-table table)) |
|
|
(if (symbolp (nth 2 table)) (set (nth 2 table) nil) |
|
|
(setcar (cdr (cdr table)) (make-vector (length (nth 2 table)) 0))) |
|
|
(setcar (cdr (cdr (cdr table))) 0)) |
|
|
(clrhash table)) |
|
|
nil) |
|
|
|
|
|
(defun cl-maphash (cl-func cl-table) |
|
|
"Call FUNCTION on keys and values from HASH-TABLE." |
|
|
(or (cl-hash-table-p cl-table) (cl-not-hash-table cl-table)) |
|
|
(if (consp cl-table) |
|
|
(mapatoms (function (lambda (cl-x) |
|
|
(setq cl-x (symbol-value cl-x)) |
|
|
(while cl-x |
|
|
(funcall cl-func (car (car cl-x)) |
|
|
(cdr (car cl-x))) |
|
|
(setq cl-x (cdr cl-x))))) |
|
|
(if (symbolp (nth 2 cl-table)) |
|
|
(vector (nth 2 cl-table)) (nth 2 cl-table))) |
|
|
(maphash cl-func cl-table))) |
|
|
|
|
|
(defun cl-hash-table-count (table) |
|
|
"Return the number of entries in HASH-TABLE." |
|
|
(or (cl-hash-table-p table) (cl-not-hash-table table)) |
|
|
(if (consp table) |
|
|
(nth 3 table) |
|
|
(hash-table-count table))) |
|
|
|
|
629 |
|
|
630 |
;;; Some debugging aids. |
;;; Some debugging aids. |
631 |
|
|
685 |
(cl-macroexpand-all (cons 'progn (cddr form)) env) |
(cl-macroexpand-all (cons 'progn (cddr form)) env) |
686 |
(let ((letf nil) (res nil) (lets (cadr form))) |
(let ((letf nil) (res nil) (lets (cadr form))) |
687 |
(while lets |
(while lets |
688 |
(cl-push (if (consp (car lets)) |
(push (if (consp (car lets)) |
689 |
(let ((exp (cl-macroexpand-all (caar lets) env))) |
(let ((exp (cl-macroexpand-all (caar lets) env))) |
690 |
(or (symbolp exp) (setq letf t)) |
(or (symbolp exp) (setq letf t)) |
691 |
(cons exp (cl-macroexpand-body (cdar lets) env))) |
(cons exp (cl-macroexpand-body (cdar lets) env))) |
714 |
(sub (pairlis cl-closure-vars new)) (decls nil)) |
(sub (pairlis cl-closure-vars new)) (decls nil)) |
715 |
(while (or (stringp (car body)) |
(while (or (stringp (car body)) |
716 |
(eq (car-safe (car body)) 'interactive)) |
(eq (car-safe (car body)) 'interactive)) |
717 |
(cl-push (list 'quote (cl-pop body)) decls)) |
(push (list 'quote (pop body)) decls)) |
718 |
(put (car (last cl-closure-vars)) 'used t) |
(put (car (last cl-closure-vars)) 'used t) |
719 |
(append |
(append |
720 |
(list 'list '(quote lambda) '(quote (&rest --cl-rest--))) |
(list 'list '(quote lambda) '(quote (&rest --cl-rest--))) |