;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*-
-;; Copyright (C) 1993, 2000-2014 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2000-2016 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Keywords: extensions
;;;###autoload
(defun cl-gcd (&rest args)
"Return the greatest common divisor of the arguments."
- (let ((a (abs (or (pop args) 0))))
- (while args
- (let ((b (abs (pop args))))
- (while (> b 0) (setq b (% a (setq a b))))))
- a))
+ (let ((a (or (pop args) 0)))
+ (dolist (b args)
+ (while (/= b 0)
+ (setq b (% a (setq a b)))))
+ (abs a)))
;;;###autoload
(defun cl-lcm (&rest args)
"Return the least common multiple of the arguments."
(if (memq 0 args)
0
- (let ((a (abs (or (pop args) 1))))
- (while args
- (let ((b (abs (pop args))))
- (setq a (* (/ a (cl-gcd a b)) b))))
- a)))
+ (let ((a (or (pop args) 1)))
+ (dolist (b args)
+ (setq a (* (/ a (cl-gcd a b)) b)))
+ (abs a))))
;;;###autoload
(defun cl-isqrt (x)
;; Inspired by "ran3" from Numerical Recipes. Additive congruential method.
(let ((vec (aref state 3)))
(if (integerp vec)
- (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1))
+ (let ((i 0) (j (- 1357335 (abs (% vec 1357333)))) (k 1))
(aset state 3 (setq vec (make-vector 55 nil)))
(aset vec 0 j)
(while (> (setq i (% (+ i 21) 55)) 0)
(setq cl-least-positive-normalized-float y
cl-least-negative-normalized-float (- y))
;; Divide down until value underflows to zero.
- (setq x (/ 1 z) y x)
+ (setq x (/ z) y x)
(while (condition-case _ (> (/ x 2) 0) (arith-error nil))
(setq x (/ x 2)))
(setq cl-least-positive-float x
(defun cl-subseq (seq start &optional end)
"Return the subsequence of SEQ from START to END.
If END is omitted, it defaults to the length of the sequence.
-If START or END is negative, it counts from the end."
+If START or END is negative, it counts from the end.
+Signal an error if START or END are outside of the sequence (i.e
+too large if positive or too small if negative)."
(declare (gv-setter
(lambda (new)
- `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end)
- ,new))))
- (if (stringp seq) (substring seq start end)
- (let (len)
- (and end (< 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)))
- (if end
- (let ((res nil))
- (while (>= (setq end (1- end)) start)
- (push (pop seq) res))
- (nreverse res))
- (copy-sequence seq)))
- (t
- (or end (setq end (or len (length seq))))
- (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))))))
-
-;;;###autoload
-(defun cl-concatenate (type &rest seqs)
+ (macroexp-let2 nil new new
+ `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end)
+ ,new)))))
+ (cond ((or (stringp seq) (vectorp seq)) (substring seq start end))
+ ((listp seq)
+ (let (len
+ (errtext (format "Bad bounding indices: %s, %s" start end)))
+ (and end (< end 0) (setq end (+ end (setq len (length seq)))))
+ (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
+ (unless (>= start 0)
+ (error "%s" errtext))
+ (when (> start 0)
+ (setq seq (nthcdr (1- start) seq))
+ (or seq (error "%s" errtext))
+ (setq seq (cdr seq)))
+ (if end
+ (let ((res nil))
+ (while (and (>= (setq end (1- end)) start) seq)
+ (push (pop seq) res))
+ (or (= (1+ end) start) (error "%s" errtext))
+ (nreverse res))
+ (copy-sequence seq))))
+ (t (error "Unsupported sequence: %s" seq))))
+
+;;;###autoload
+(defun cl-concatenate (type &rest sequences)
"Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
\n(fn TYPE SEQUENCE...)"
- (cond ((eq type 'vector) (apply 'vconcat seqs))
- ((eq type 'string) (apply 'concat seqs))
- ((eq type 'list) (apply 'append (append seqs '(nil))))
- (t (error "Not a sequence type name: %s" type))))
-
+ (pcase type
+ (`vector (apply #'vconcat sequences))
+ (`string (apply #'concat sequences))
+ (`list (apply #'append (append sequences '(nil))))
+ (_ (error "Not a sequence type name: %S" type))))
;;; List functions.
(prog1 (cl-prettyprint form)
(message ""))))
+;;; Integration into the online help system.
+
+(eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class.
+(require 'help-mode)
+
+;; FIXME: We could go crazy and add another entry so describe-symbol can be
+;; used with the slot names of CL structs (and/or EIEIO objects).
+(add-to-list 'describe-symbol-backends
+ `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s))))
+
+(defconst cl--typedef-regexp
+ (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct"
+ "cl-deftype" "deftype"))
+ "[ \t\r\n]+%s[ \t\r\n]+"))
+(with-eval-after-load 'find-func
+ (defvar find-function-regexp-alist)
+ (add-to-list 'find-function-regexp-alist
+ `(define-type . cl--typedef-regexp)))
+
+(define-button-type 'cl-help-type
+ :supertype 'help-function-def
+ 'help-function #'cl-describe-type
+ 'help-echo (purecopy "mouse-2, RET: describe this type"))
+
+(define-button-type 'cl-type-definition
+ :supertype 'help-function-def
+ 'help-echo (purecopy "mouse-2, RET: find type definition"))
+
+(declare-function help-fns-short-filename "help-fns" (filename))
+
+;;;###autoload
+(defun cl-find-class (type) (cl--find-class type))
+
+;;;###autoload
+(defun cl-describe-type (type)
+ "Display the documentation for type TYPE (a symbol)."
+ (interactive
+ (let ((str (completing-read "Describe type: " obarray #'cl-find-class t)))
+ (if (<= (length str) 0)
+ (user-error "Abort!")
+ (list (intern str)))))
+ (help-setup-xref (list #'cl-describe-type type)
+ (called-interactively-p 'interactive))
+ (save-excursion
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (let ((class (cl-find-class type)))
+ (if class
+ (cl--describe-class type class)
+ ;; FIXME: Describe other types (the built-in ones, or those from
+ ;; cl-deftype).
+ (user-error "Unknown type %S" type))))
+ (with-current-buffer standard-output
+ ;; Return the text we displayed.
+ (buffer-string)))))
+
+(defun cl--describe-class (type &optional class)
+ (unless class (setq class (cl--find-class type)))
+ (let ((location (find-lisp-object-file-name type 'define-type))
+ ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch.
+ (metatype (cl--class-name (symbol-value (aref class 0)))))
+ (insert (symbol-name type)
+ (substitute-command-keys " is a type (of kind `"))
+ (help-insert-xref-button (symbol-name metatype)
+ 'cl-help-type metatype)
+ (insert (substitute-command-keys "')"))
+ (when location
+ (insert (substitute-command-keys " in `"))
+ (help-insert-xref-button
+ (help-fns-short-filename location)
+ 'cl-type-definition type location 'define-type)
+ (insert (substitute-command-keys "'")))
+ (insert ".\n")
+
+ ;; Parents.
+ (let ((pl (cl--class-parents class))
+ cur)
+ (when pl
+ (insert " Inherits from ")
+ (while (setq cur (pop pl))
+ (setq cur (cl--class-name cur))
+ (insert (substitute-command-keys "`"))
+ (help-insert-xref-button (symbol-name cur)
+ 'cl-help-type cur)
+ (insert (substitute-command-keys (if pl "', " "'"))))
+ (insert ".\n")))
+
+ ;; Children, if available. ¡For EIEIO!
+ (let ((ch (condition-case nil
+ (cl-struct-slot-value metatype 'children class)
+ (cl-struct-unknown-slot nil)))
+ cur)
+ (when ch
+ (insert " Children ")
+ (while (setq cur (pop ch))
+ (insert (substitute-command-keys "`"))
+ (help-insert-xref-button (symbol-name cur)
+ 'cl-help-type cur)
+ (insert (substitute-command-keys (if ch "', " "'"))))
+ (insert ".\n")))
+
+ ;; Type's documentation.
+ (let ((doc (cl--class-docstring class)))
+ (when doc
+ (insert "\n" doc "\n\n")))
+
+ ;; Describe all the slots in this class.
+ (cl--describe-class-slots class)
+
+ ;; Describe all the methods specific to this class.
+ (let ((generics (cl-generic-all-functions type)))
+ (when generics
+ (insert (propertize "Specialized Methods:\n\n" 'face 'bold))
+ (dolist (generic generics)
+ (insert (substitute-command-keys "`"))
+ (help-insert-xref-button (symbol-name generic)
+ 'help-function generic)
+ (insert (substitute-command-keys "'"))
+ (pcase-dolist (`(,qualifiers ,args ,doc)
+ (cl--generic-method-documentation generic type))
+ (insert (format " %s%S\n" qualifiers args)
+ (or doc "")))
+ (insert "\n\n"))))))
+
+(defun cl--describe-class-slot (slot)
+ (insert
+ (concat
+ (propertize "Slot: " 'face 'bold)
+ (prin1-to-string (cl--slot-descriptor-name slot))
+ (unless (eq (cl--slot-descriptor-type slot) t)
+ (concat " type = "
+ (prin1-to-string (cl--slot-descriptor-type slot))))
+ ;; FIXME: The default init form is treated differently for structs and for
+ ;; eieio objects: for structs, the default is nil, for eieio-objects
+ ;; it's a special "unbound" value.
+ (unless nil ;; (eq (cl--slot-descriptor-initform slot) eieio-unbound)
+ (concat " default = "
+ (prin1-to-string (cl--slot-descriptor-initform slot))))
+ (when (alist-get :printer (cl--slot-descriptor-props slot))
+ (concat " printer = "
+ (prin1-to-string
+ (alist-get :printer (cl--slot-descriptor-props slot)))))
+ (when (alist-get :documentation (cl--slot-descriptor-props slot))
+ (concat "\n "
+ (substitute-command-keys
+ (alist-get :documentation (cl--slot-descriptor-props slot)))
+ "\n")))
+ "\n"))
+
+(defun cl--describe-class-slots (class)
+ "Print help description for the slots in CLASS.
+Outputs to the current buffer."
+ (let* ((slots (cl--class-slots class))
+ ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch.
+ (metatype (cl--class-name (symbol-value (aref class 0))))
+ ;; ¡For EIEIO!
+ (cslots (condition-case nil
+ (cl-struct-slot-value metatype 'class-slots class)
+ (cl-struct-unknown-slot nil))))
+ (insert (propertize "Instance Allocated Slots:\n\n"
+ 'face 'bold))
+ (mapc #'cl--describe-class-slot slots)
+ (when (> (length cslots) 0)
+ (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))
+ (mapc #'cl--describe-class-slot cslots))))
(run-hooks 'cl-extra-load-hook)