(U-000278B8): Apply new conventions for glyph granularity.

[chise/xemacs-chise.git.1] / lisp / cl-macs.el

diff --git a/lisp/cl-macs.el b/lisp/cl-macs.el
index 841d5e0..fc2c48a 100644 (file)
--- 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))))))
         #'(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.
 
 
 ;;; Initialization.

@@ -106,31 +106,6 @@
   (run-hooks 'cl-hack-bytecomp-hook))
 
 
   (run-hooks 'cl-hack-bytecomp-hook))
 
 

-;;; Symbols.
-
-(defvar *gensym-counter*)
-
-;;;###autoload
-(defun gensym (&optional arg)
-  "Generate a new uninterned symbol.
-The name is made by appending a number to PREFIX, default \"G\"."
-  (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))))
-
-;;;###autoload
-(defun gentemp (&optional arg)
-  "Generate a new interned symbol with a unique name.
-The name is made by appending a number to PREFIX, default \"G\"."
-  (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)))
-
-

 ;;; Program structure.
 
 ;;;###autoload
 ;;; Program structure.
 
 ;;;###autoload

@@ -174,12 +149,64 @@ ARGLIST allows full Common Lisp conventions."
 (defvar cl-macro-environment nil)
 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
 (defvar cl-macro-environment nil)
 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)

+(defvar arglist-visited)
+
+;; npak@ispras.ru
+(defun cl-upcase-arg (arg)
+  ;; Changes all non-keyword symbols in `ARG' to symbols
+  ;; with name in upper case.
+  ;; ARG is either symbol or list of symbols or lists
+  (cond ;;((null arg) 'NIL)
+        ((symbolp arg)
+         ;; Do not upcase &optional, &key etc.
+         (if (memq arg lambda-list-keywords) arg
+           (intern (upcase (symbol-name arg)))))
+        ((listp arg)
+         (if (memq arg arglist-visited) (error 'circular-list '(arg)))
+         (cl-push arg arglist-visited)
+         (let ((arg (copy-list arg)) junk)
+           ;; Clean the list
+           (let ((p (last arg))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
+           (if (setq junk (cadr (memq '&cl-defs arg)))
+               (setq arg (delq '&cl-defs (delq junk arg))))
+           (if (memq '&cl-quote arg)
+               (setq arg (delq '&cl-quote arg)))
+           (mapcar 'cl-upcase-arg arg)))
+        (t arg)                         ; May be we are in initializer
+        ))
+
+;; npak@ispras.ru
+(defun cl-function-arglist (name arglist)
+  "Returns string with printed representation of arguments list.
+Supports Common Lisp lambda lists."
+  (if (not (or (listp arglist) (symbolp arglist))) "Not available"
+    (setq arglist-visited nil)
+    (condition-case nil
+        (prin1-to-string
+         (cons (if (eq name 'cl-none) 'lambda name)
+               (cond ((null arglist) nil)
+                     ((listp arglist) (cl-upcase-arg arglist))
+                     ((symbolp arglist)
+                      (cl-upcase-arg (list '&rest arglist)))
+                     (t (wrong-type-argument 'listp arglist)))))
+      (t "Not available"))))

 
 (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)
 
 (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 (and (stringp (car body))
+             (cdr body))
+        (setq doc (cl-pop body)))
+    (cl-push (concat doc
+                     "\nCommon Lisp lambda list:\n" 
+                     "  " (cl-function-arglist bind-block args) 
+                     "\n\n")
+             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)))
     (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)))

@@ -1438,10 +1465,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
   (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))
 
        ((eq (car-safe spec) 'inline)
         (while (setq spec (cdr spec))

@@ -1459,13 +1486,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)))
 
        ((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)))
               (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)
 
        ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
         (if (eq byte-compile-warnings t)

@@ -1794,6 +1823,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 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
 
 ;;; More complex setf-methods.
 ;;; These should take &environment arguments, but since full arglists aren't

@@ -2458,24 +2488,32 @@ The type name can then be used in `typecase', `check-type', etc."
          (t (error "Bad type spec: %s" type)))))
 
 ;;;###autoload
          (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."
   "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
 
 ;;;###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."
 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)
 
 ;;;###autoload
 (defmacro assert (form &optional show-args string &rest args)

@@ -2774,6 +2812,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)
    (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)
    (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)

@@ -2788,7 +2828,6 @@ surrounded by (block NAME ...)."
 (proclaim '(inline floatp-safe acons map concatenate notany notevery
 ;; XEmacs change
                   cl-set-elt revappend nreconc
 (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
                   ))
 
 ;;; Things that are side-effect-free.  Moved to byte-optimize.el