(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 5a9ab08..fc2c48a 100644 (file)
--- a/lisp/cl-macs.el
+++ b/lisp/cl-macs.el
@@ -149,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 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)
-        (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)))