X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fcl.el;h=8150e1d83898cb32f200b44ec27df94d6fdfc897;hb=bbeb2495812aebfcba6dbe12c26fbb14f5a702c6;hp=233a476a72dad1a00796adf84444ebb01c117e7c;hpb=6883ee56ec887c2c48abe5b06b5e66aa74031910;p=chise%2Fxemacs-chise.git.1

diff --git a/lisp/cl.el b/lisp/cl.el
index 233a476..8150e1d 100644
--- a/lisp/cl.el
+++ b/lisp/cl.el
@@ -183,7 +183,7 @@ Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more
 careful about evaluating each argument only once and in the right order.
 PLACE may be a symbol, or any generalized variable allowed by `setf'."
   (if (symbolp place)
-      (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))
+      `(car (prog1 ,place (setq ,place (cdr ,place))))
     (cl-do-pop place)))
 
 (defmacro push (x place)
@@ -191,7 +191,7 @@ PLACE may be a symbol, or any generalized variable allowed by `setf'."
 Analogous to (setf PLACE (cons X PLACE)), though more careful about
 evaluating each argument only once and in the right order.  PLACE may
 be a symbol, or any generalized variable allowed by `setf'."
-  (if (symbolp place) (list 'setq place (list 'cons x place))
+  (if (symbolp place) `(setq ,place (cons ,x ,place))
     (list 'callf2 'cons x place)))
 
 (defmacro pushnew (x place &rest keys)
@@ -217,7 +217,7 @@ Keywords supported:  :test :test-not :key"
 (defun cl-set-substring (str start end val)
   (if end (if (< end 0) (incf end (length str)))
     (setq end (length str)))
-  (if (< start 0) (incf start str))
+  (if (< start 0) (incf start (length str)))
   (concat (and (> start 0) (substring str 0 start))
 	  val
 	  (and (< end (length str)) (substring str end))))
@@ -225,20 +225,9 @@ Keywords supported:  :test :test-not :key"
 
 ;;; Control structures.
 
-;; These macros are so simple and so often-used that it's better to have
-;; them all the time than to load them from cl-macs.el.
-
-;; NOTE: these macros were moved to subr.el in FSF 20.  It is of no
-;; consequence to XEmacs, because we preload this file, and they
-;; should better remain here.
-
-(defmacro when (cond &rest body)
-  "(when COND BODY...): if COND yields non-nil, do BODY, else return nil."
-  (list 'if cond (cons 'progn body)))
-
-(defmacro unless (cond &rest body)
-  "(unless COND BODY...): if COND yields nil, do BODY, else return nil."
-  (cons 'if (cons cond (cons nil body))))
+;; The macros `when' and `unless' are so useful that we want them to
+;; ALWAYS be available.  So they've been moved from cl.el to eval.c.
+;; Note: FSF Emacs moved them to subr.el in FSF 20.
 
 (defun cl-map-extents (&rest cl-args)
   ;; XEmacs: This used to check for overlays first, but that's wrong
@@ -280,7 +269,7 @@ If FORM is not a macro call, it is returned unchanged.
 Otherwise, the macro is expanded and the expansion is considered
 in place of FORM.  When a non-macro-call results, it is returned.
 
-The second optional arg ENVIRONMENT species an environment of macro
+The second optional arg ENVIRONMENT specifies an environment of macro
 definitions to shadow the loaded ones for use in file byte-compilation."
   (let ((cl-macro-environment cl-env))
     (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env))
@@ -328,37 +317,53 @@ definitions to shadow the loaded ones for use in file byte-compilation."
 
 (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100))
 
+(defun gensym (&optional arg)
+  "Generate a new uninterned symbol.
+The name is made by appending a number to a prefix.  If ARG is a string, it
+is the prefix, otherwise the prefix defaults to \"G\".  If ARG is an integer,
+the internal counter is reset to that number before creating the name.
+There is no way to specify both using this function."
+  (let ((prefix (if (stringp arg) arg "G"))
+	(num (if (integerp arg) arg
+	       (prog1 *gensym-counter*
+		 (setq *gensym-counter* (1+ *gensym-counter*))))))
+    (make-symbol (format "%s%d" prefix num))))
+
+(defun gentemp (&optional arg)
+  "Generate a new interned symbol with a unique name.
+The name is made by appending a number to ARG, default \"G\".
+If ARG is not a string, it is ignored."
+  (let ((prefix (if (stringp arg) arg "G"))
+	name)
+    (while (intern-soft (setq name (format "%s%d" prefix *gensym-counter*)))
+      (setq *gensym-counter* (1+ *gensym-counter*)))
+    (intern name)))
 
 ;;; Numbers.
 
-(defun floatp-safe (x)
-  "Return t if OBJECT is a floating point number.
-On Emacs versions that lack floating-point support, this function
-always returns nil."
-  ;;(and (numberp x) (not (integerp x)))
-  ;; XEmacs: use floatp.  XEmacs is always compiled with
-  ;; floating-point, anyway.
-  (floatp x))
+(defun floatp-safe (object)
+  "Return t if OBJECT is a floating point number."
+  (floatp object))
 
-(defun plusp (x)
+(defun plusp (number)
   "Return t if NUMBER is positive."
-  (> x 0))
+  (> number 0))
 
-(defun minusp (x)
+(defun minusp (number)
   "Return t if NUMBER is negative."
-  (< x 0))
+  (< number 0))
 
-(defun oddp (x)
+(defun oddp (integer)
   "Return t if INTEGER is odd."
-  (eq (logand x 1) 1))
+  (eq (logand integer 1) 1))
 
-(defun evenp (x)
+(defun evenp (integer)
   "Return t if INTEGER is even."
-  (eq (logand x 1) 0))
+  (eq (logand integer 1) 0))
 
-(defun cl-abs (x)
-  "Return the absolute value of ARG."
-  (if (>= x 0) x (- x)))
+(defun cl-abs (number)
+  "Return the absolute value of NUMBER."
+  (if (>= number 0) number (- number)))
 (or (fboundp 'abs) (defalias 'abs 'cl-abs))   ; This is built-in to Emacs 19
 
 (defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time)))
@@ -406,6 +411,9 @@ SEQ, this is like `mapcar'.  With several, it is like the Common Lisp
 
 ;;; List functions.
 
+;; These functions are made known to the byte-compiler by cl-macs.el
+;; and turned into efficient car and cdr bytecodes.
+
 (defalias 'first 'car)
 (defalias 'rest 'cdr)
 (defalias 'endp 'null)
@@ -558,30 +566,35 @@ SEQ, this is like `mapcar'.  With several, it is like the Common Lisp
   "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
   (cdr (cdr (cdr (cdr x)))))
 
-(defun last (x &optional n)
-  "Return the last link in the list LIST.
-With optional argument N, return Nth-to-last link (default 1)."
-  (if n
-      (let ((m 0) (p x))
-	(while (consp p) (incf m) (pop p))
-	(if (<= n 0) p
-	  (if (< n m) (nthcdr (- m n) x) x)))
-    (while (consp (cdr x)) (pop x))
-    x))
-
-(defun butlast (x &optional n)
-  "Return a copy of LIST with the last N elements removed."
-  (if (and n (<= n 0)) x
-    (nbutlast (copy-sequence x) n)))
-
-(defun nbutlast (x &optional n)
-  "Modify LIST to remove the last N elements."
-  (let ((m (length x)))
-    (or n (setq n 1))
-    (and (< n m)
-	 (progn
-	   (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
-	   x))))
+;;; `last' is implemented as a C primitive, as of 1998-11
+
+;(defun last (x &optional n)
+;  "Return the last link in the list LIST.
+;With optional argument N, return Nth-to-last link (default 1)."
+;  (if n
+;      (let ((m 0) (p x))
+;	(while (consp p) (incf m) (pop p))
+;	(if (<= n 0) p
+;	  (if (< n m) (nthcdr (- m n) x) x)))
+;    (while (consp (cdr x)) (pop x))
+;    x))
+
+;;; `butlast'  is implemented as a C primitive, as of 1998-11
+;;; `nbutlast' is implemented as a C primitive, as of 1998-11
+
+;(defun butlast (x &optional n)
+;  "Return a copy of LIST with the last N elements removed."
+;  (if (and n (<= n 0)) x
+;    (nbutlast (copy-sequence x) n)))
+
+;(defun nbutlast (x &optional n)
+;  "Modify LIST to remove the last N elements."
+;  (let ((m (length x)))
+;    (or n (setq n 1))
+;    (and (< n m)
+;	 (progn
+;	   (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
+;	   x))))
 
 (defun list* (arg &rest rest)   ; See compiler macro in cl-macs.el
   "Return a new list with specified args as elements, cons'd to last arg.
@@ -602,14 +615,16 @@ Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
       (push (pop list) res))
     (nreverse res)))
 
-(defun copy-list (list)
-  "Return a copy of a list, which may be a dotted list.
-The elements of the list are not copied, just the list structure itself."
-  (if (consp list)
-      (let ((res nil))
-	(while (consp list) (push (pop list) res))
-	(prog1 (nreverse res) (setcdr res list)))
-    (car list)))
+;;; `copy-list' is implemented as a C primitive, as of 1998-11
+
+;(defun copy-list (list)
+;  "Return a copy of a list, which may be a dotted list.
+;The elements of the list are not copied, just the list structure itself."
+;  (if (consp list)
+;      (let ((res nil))
+;	(while (consp list) (push (pop list) res))
+;	(prog1 (nreverse res) (setcdr res list)))
+;    (car list)))
 
 (defun cl-maclisp-member (item list)
   (while (and list (not (equal item (car list)))) (setq list (cdr list)))
@@ -681,45 +696,45 @@ FUNC is not added if it already appears on the list stored in HOOK."
 ;(load "cl-defs")
 
 ;;; Define data for indentation and edebug.
-(mapcar (function
-	 (lambda (entry)
-	   (mapcar (function
-		    (lambda (func)
-		      (put func 'lisp-indent-function (nth 1 entry))
-		      (put func 'lisp-indent-hook (nth 1 entry))
-		      (or (get func 'edebug-form-spec)
-			  (put func 'edebug-form-spec (nth 2 entry)))))
-		   (car entry))))
-	'(((defun* defmacro*) defun)
-	  ((function*) nil
-	   (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form)))
-	  ((eval-when) 1 (sexp &rest form))
-	  ((when unless) 1 (&rest form))
-	  ((declare) nil (&rest sexp))
-	  ((the) 1 (sexp &rest form))
-	  ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form)))
-	  ((block return-from) 1 (sexp &rest form))
-	  ((return) nil (&optional form))
-	  ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form))
-		       (form &rest form)
-		       &rest form))
-	  ((dolist dotimes) 1 ((symbolp form &rest form) &rest form))
-	  ((do-symbols) 1 ((symbolp form &optional form form) &rest form))
-	  ((do-all-symbols) 1 ((symbolp form &optional form) &rest form))
-	  ((psetq setf psetf) nil edebug-setq-form)
-	  ((progv) 2 (&rest form))
-	  ((flet labels macrolet) 1
-	   ((&rest (sexp sexp &rest form)) &rest form))
-	  ((symbol-macrolet lexical-let lexical-let*) 1
-	   ((&rest &or symbolp (symbolp form)) &rest form))
-	  ((multiple-value-bind) 2 ((&rest symbolp) &rest form))
-	  ((multiple-value-setq) 1 ((&rest symbolp) &rest form))
-	  ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form))
-	  ((letf letf*) 1 ((&rest (&rest form)) &rest form))
-	  ((callf destructuring-bind) 2 (sexp form &rest form))
-	  ((callf2) 3 (sexp form form &rest form))
-	  ((loop) defun (&rest &or symbolp form))
-	  ((ignore-errors) 0 (&rest form))))
+(mapcar
+ #'(lambda (entry)
+     (mapcar
+      #'(lambda (func)
+	  (put func 'lisp-indent-function (nth 1 entry))
+	  (put func 'lisp-indent-hook (nth 1 entry))
+	  (or (get func 'edebug-form-spec)
+	      (put func 'edebug-form-spec (nth 2 entry))))
+      (car entry)))
+ '(((defun* defmacro*) defun)
+   ((function*) nil
+    (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form)))
+   ((eval-when) 1 (sexp &rest form))
+   ((when unless) 1 (&rest form))
+   ((declare) nil (&rest sexp))
+   ((the) 1 (sexp &rest form))
+   ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form)))
+   ((block return-from) 1 (sexp &rest form))
+   ((return) nil (&optional form))
+   ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form))
+		(form &rest form)
+		&rest form))
+   ((dolist dotimes) 1 ((symbolp form &rest form) &rest form))
+   ((do-symbols) 1 ((symbolp form &optional form form) &rest form))
+   ((do-all-symbols) 1 ((symbolp form &optional form) &rest form))
+   ((psetq setf psetf) nil edebug-setq-form)
+   ((progv) 2 (&rest form))
+   ((flet labels macrolet) 1
+    ((&rest (sexp sexp &rest form)) &rest form))
+   ((symbol-macrolet lexical-let lexical-let*) 1
+    ((&rest &or symbolp (symbolp form)) &rest form))
+   ((multiple-value-bind) 2 ((&rest symbolp) &rest form))
+   ((multiple-value-setq) 1 ((&rest symbolp) &rest form))
+   ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form))
+   ((letf letf*) 1 ((&rest (&rest form)) &rest form))
+   ((callf destructuring-bind) 2 (sexp form &rest form))
+   ((callf2) 3 (sexp form form &rest form))
+   ((loop) defun (&rest &or symbolp form))
+   ((ignore-errors) 0 (&rest form))))
 
 
 ;;; This goes here so that cl-macs can find it if it loads right now.
@@ -734,6 +749,8 @@ FUNC is not added if it already appears on the list stored in HOOK."
 (defun cl-hack-byte-compiler ()
   (if (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form))
       (progn
+	(when (not (fboundp 'cl-compile-time-init))
+	  (load "cl-macs" nil t))
 	(cl-compile-time-init)   ; in cl-macs.el
 	(setq cl-hacked-flag t))))