Update copyright year to 2016

[gnu-emacs] / lisp / emacs-lisp / cl-extra.el

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 38cc772e8b068f07127b1d815a2cee79e783b159..b5dfe487d07eb11e06220c28eb4bd3758865fecc 100644 (file)
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -1,6 +1,6 @@
 ;;; cl-extra.el --- Common Lisp features, part 2  -*- lexical-binding: t -*-
 
-;; Copyright (C) 1993, 2000-2015 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2000-2016 Free Software Foundation, Inc.
 
 ;; Author: Dave Gillespie <daveg@synaptics.com>
 ;; Keywords: extensions
@@ -38,7 +38,6 @@
 ;;; Code:
 
 (require 'cl-lib)
-(require 'seq)
 
 ;;; Type coercion.
 
@@ -498,7 +497,7 @@ This sets the values of: `cl-most-positive-float', `cl-most-negative-float',
        (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
@@ -518,19 +517,44 @@ This sets the values of: `cl-most-positive-float', `cl-most-negative-float',
 (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)
               (macroexp-let2 nil new new
                `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end)
                        ,new)))))
-  (seq-subseq seq start end))
-
-;;;###autoload
-(defalias 'cl-concatenate #'seq-concatenate
+  (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...)")
-
+\n(fn TYPE SEQUENCE...)"
+  (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.
 
@@ -750,16 +774,16 @@ including `cl-block' and `cl-eval-when'."
         ;; 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 ‘"))
+            (substitute-command-keys " is a type (of kind `"))
     (help-insert-xref-button (symbol-name metatype)
                              'cl-help-type metatype)
-    (insert (substitute-command-keys "’)"))
+    (insert (substitute-command-keys "')"))
     (when location
-      (insert (substitute-command-keys " in ‘"))
+      (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 (substitute-command-keys "'")))
     (insert ".\n")
 
     ;; Parents.
@@ -769,10 +793,10 @@ including `cl-block' and `cl-eval-when'."
         (insert " Inherits from ")
         (while (setq cur (pop pl))
           (setq cur (cl--class-name cur))
-          (insert (substitute-command-keys "‘"))
+          (insert (substitute-command-keys "`"))
           (help-insert-xref-button (symbol-name cur)
                                    'cl-help-type cur)
-          (insert (substitute-command-keys (if pl "’, " "’"))))
+          (insert (substitute-command-keys (if pl "', " "'"))))
         (insert ".\n")))
 
     ;; Children, if available.  ¡For EIEIO!
@@ -783,10 +807,10 @@ including `cl-block' and `cl-eval-when'."
       (when ch
         (insert " Children ")
         (while (setq cur (pop ch))
-          (insert (substitute-command-keys "‘"))
+          (insert (substitute-command-keys "`"))
           (help-insert-xref-button (symbol-name cur)
                                    'cl-help-type cur)
-          (insert (substitute-command-keys (if ch "’, " "’"))))
+          (insert (substitute-command-keys (if ch "', " "'"))))
         (insert ".\n")))
 
     ;; Type's documentation.
@@ -802,10 +826,10 @@ including `cl-block' and `cl-eval-when'."
       (when generics
         (insert (propertize "Specialized Methods:\n\n" 'face 'bold))
         (dolist (generic generics)
-          (insert (substitute-command-keys "‘"))
+          (insert (substitute-command-keys "`"))
           (help-insert-xref-button (symbol-name generic)
                                    'help-function generic)
-          (insert (substitute-command-keys "’"))
+          (insert (substitute-command-keys "'"))
           (pcase-dolist (`(,qualifiers ,args ,doc)
                          (cl--generic-method-documentation generic type))
             (insert (format " %s%S\n" qualifiers args)
@@ -831,7 +855,9 @@ including `cl-block' and `cl-eval-when'."
               (prin1-to-string
                (alist-get :printer (cl--slot-descriptor-props slot)))))
     (when (alist-get :documentation (cl--slot-descriptor-props slot))
-      (concat "\n  " (alist-get :documentation (cl--slot-descriptor-props slot))
+      (concat "\n  "
+              (substitute-command-keys
+               (alist-get :documentation (cl--slot-descriptor-props slot)))
               "\n")))
    "\n"))