X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fcl-macs.el;h=05d88da86f8aa865006dc0902e7545f61b982167;hb=c5acd0cbf1209288c4568cdb899f8b1fa56cadf1;hp=b66b4eae819b0140c82de39b9b4749be4ae316c2;hpb=2fd9701a4f902054649dde9143a3f77809afee8f;p=chise%2Fxemacs-chise.git.1

diff --git a/lisp/cl-macs.el b/lisp/cl-macs.el
index b66b4ea..05d88da 100644
--- a/lisp/cl-macs.el
+++ b/lisp/cl-macs.el
@@ -81,7 +81,7 @@
 	 #'(lambda (n p f)
 	     (list 'put (list 'quote n) (list 'quote p)
 		   (list 'function (cons 'lambda f))))))
-   (car (or features (setq features (list 'cl-kludge))))))
+   'xemacs))
 
 
 ;;; Initialization.
@@ -150,11 +150,41 @@ ARGLIST allows full Common Lisp conventions."
 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
 
+;; npak@ispras.ru
+(defun cl-upcase-arg (arg)
+  ;; Changes all non-keyword sysmbols in `arg' to symbols
+  ;; with name in upper case.
+  ;; arg is either symbol or list of symbols or lists
+  (cond ((symbolp arg)
+         (if (memq arg lambda-list-keywords)
+             ;; Do not upcase &optional, &key etc.
+             arg
+           (intern (upcase (symbol-name arg)))))
+        ((listp arg)
+         (mapcar 'cl-upcase-arg arg))))
+
+;; npak@ispras.ru
+(defun cl-function-arglist (function agrlist)
+  "Returns string with printed representation of arguments list.
+Supports Common Lisp lambda lists."
+  (prin1-to-string
+   (cons function (cl-upcase-arg agrlist))))
+
 (defun cl-transform-lambda (form bind-block)
   (let* ((args (car form)) (body (cdr form))
 	 (bind-defs nil) (bind-enquote nil)
 	 (bind-inits nil) (bind-lets nil) (bind-forms nil)
-	 (header nil) (simple-args nil))
+	 (header nil) (simple-args nil)
+         (doc ""))
+    ;; Add CL lambda list to documentation. npak@ispras.ru
+    (if (stringp (car body))
+        (setq doc (cl-pop body)))
+    (cl-push (concat "\nCommon Lisp lambda list:\n" 
+                     "  " (cl-function-arglist bind-block args) 
+                     "\n\n"
+                     doc)
+             header)
+
     (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
       (cl-push (cl-pop body) header))
     (setq args (if (listp args) (copy-list args) (list '&rest args)))
@@ -1413,10 +1443,10 @@ values.  For compatibility, (values A B C) is a synonym for (list A B C)."
   (cond ((eq (car-safe spec) 'special)
 	 (if (boundp 'byte-compile-bound-variables)
 	     (setq byte-compile-bound-variables
-		   ;; todo: this should compute correct binding bits vs. 0
-		   (append (mapcar #'(lambda (v) (cons v 0))
-				   (cdr spec))
-			   byte-compile-bound-variables))))
+		   (append
+		    (mapcar #'(lambda (v) (cons v byte-compile-global-bit))
+			    (cdr spec))
+		    byte-compile-bound-variables))))
 
 	((eq (car-safe spec) 'inline)
 	 (while (setq spec (cdr spec))
@@ -1434,13 +1464,15 @@ values.  For compatibility, (values A B C) is a synonym for (list A B C)."
 
 	((eq (car-safe spec) 'optimize)
 	 (let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
-			    '((0 nil) (1 t) (2 t) (3 t))))
+			    '((0 . nil) (1 . t) (2 . t) (3 . t))))
 	       (safety (assq (nth 1 (assq 'safety (cdr spec)))
-			     '((0 t) (1 t) (2 t) (3 nil)))))
-	   (if speed (setq cl-optimize-speed (car speed)
-			   byte-optimize (nth 1 speed)))
-	   (if safety (setq cl-optimize-safety (car safety)
-			    byte-compile-delete-errors (nth 1 safety)))))
+			     '((0 . t) (1 . t) (2 . t) (3 . nil)))))
+	   (when speed
+	     (setq cl-optimize-speed (car speed)
+		   byte-optimize (cdr speed)))
+	   (when safety
+	     (setq cl-optimize-safety (car safety)
+		   byte-compile-delete-errors (cdr safety)))))
 
 	((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
 	 (if (eq byte-compile-warnings t)
@@ -1769,6 +1801,7 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))."
 (defsetf x-get-cut-buffer x-store-cut-buffer t)   ; groan.
 (defsetf x-get-secondary-selection x-own-secondary-selection t)
 (defsetf x-get-selection x-own-selection t)
+(defsetf get-selection own-selection t)
 
 ;;; More complex setf-methods.
 ;;; These should take &environment arguments, but since full arglists aren't
@@ -2433,24 +2466,32 @@ The type name can then be used in `typecase', `check-type', etc."
 	  (t (error "Bad type spec: %s" type)))))
 
 ;;;###autoload
-(defun typep (val type)   ; See compiler macro below.
+(defun typep (object type)   ; See compiler macro below.
   "Check that OBJECT is of type TYPE.
 TYPE is a Common Lisp-style type specifier."
-  (eval (cl-make-type-test 'val type)))
+  (eval (cl-make-type-test 'object type)))
 
 ;;;###autoload
-(defmacro check-type (form type &optional string)
-  "Verify that FORM is of type TYPE; signal an error if not.
+(defmacro check-type (place type &optional string)
+  "Verify that PLACE is of type TYPE; signal a continuable error if not.
 STRING is an optional description of the desired type."
-  (and (or (not (cl-compiling-file))
-	   (< cl-optimize-speed 3) (= cl-optimize-safety 3))
-       (let* ((temp (if (cl-simple-expr-p form 3) form (gensym)))
-	      (body (list 'or (cl-make-type-test temp type)
-			  (list 'signal '(quote wrong-type-argument)
-				(list 'list (or string (list 'quote type))
-				      temp (list 'quote form))))))
-	 (if (eq temp form) (list 'progn body nil)
-	   (list 'let (list (list temp form)) body nil)))))
+  (when (or (not (cl-compiling-file))
+	    (< cl-optimize-speed 3)
+	    (= cl-optimize-safety 3))
+    (let* ((temp (if (cl-simple-expr-p place 3) place (gensym)))
+	   (test (cl-make-type-test temp type))
+	   (signal-error `(signal 'wrong-type-argument
+				  ,(list 'list (or string (list 'quote type))
+					 temp (list 'quote place))))
+	   (body
+	    (condition-case nil
+		`(while (not ,test)
+		   ,(macroexpand `(setf ,place ,signal-error)))
+	      (error
+	       `(if ,test (progn ,signal-error nil))))))
+      (if (eq temp place)
+	  body
+	`(let ((,temp ,place)) ,body)))))
 
 ;;;###autoload
 (defmacro assert (form &optional show-args string &rest args)
@@ -2749,6 +2790,8 @@ surrounded by (block NAME ...)."
    (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
    (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
    (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
+   (oddp  'eq (list 'logand x 1) 1)
+   (evenp 'eq (list 'logand x 1) 0)
    (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr)
    (caaar car caar) (caadr car cadr) (cadar car cdar)
    (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
@@ -2763,7 +2806,6 @@ surrounded by (block NAME ...)."
 (proclaim '(inline floatp-safe acons map concatenate notany notevery
 ;; XEmacs change
 		   cl-set-elt revappend nreconc
-		   plusp minusp oddp evenp
 		   ))
 
 ;;; Things that are side-effect-free.  Moved to byte-optimize.el