Mercurial > hg > xemacs-beta
comparison lisp/cl-macs.el @ 452:3d3049ae1304 r21-2-41
Import from CVS: tag r21-2-41
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 11:40:21 +0200 |
| parents | 1ccc32a20af4 |
| children | 023b83f4e54b |
comparison
equal
deleted
inserted
replaced
| 451:8ad70c5cd5d7 | 452:3d3049ae1304 |
|---|---|
| 148 | 148 |
| 149 (defvar cl-macro-environment nil) | 149 (defvar cl-macro-environment nil) |
| 150 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote) | 150 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote) |
| 151 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms) | 151 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms) |
| 152 | 152 |
| 153 ;; npak@ispras.ru | |
| 154 (defun cl-upcase-arg (arg) | |
| 155 ;; Changes all non-keyword sysmbols in `arg' to symbols | |
| 156 ;; with name in upper case. | |
| 157 ;; arg is either symbol or list of symbols or lists | |
| 158 (cond ((symbolp arg) | |
| 159 (if (memq arg lambda-list-keywords) | |
| 160 ;; Do not upcase &optional, &key etc. | |
| 161 arg | |
| 162 (intern (upcase (symbol-name arg))))) | |
| 163 ((listp arg) | |
| 164 (mapcar 'cl-upcase-arg arg)))) | |
| 165 | |
| 166 ;; npak@ispras.ru | |
| 167 (defun cl-function-arglist (function agrlist) | |
| 168 "Returns string with printed representation of arguments list. | |
| 169 Supports Common Lisp lambda lists." | |
| 170 (prin1-to-string | |
| 171 (cons function (cl-upcase-arg agrlist)))) | |
| 172 | |
| 153 (defun cl-transform-lambda (form bind-block) | 173 (defun cl-transform-lambda (form bind-block) |
| 154 (let* ((args (car form)) (body (cdr form)) | 174 (let* ((args (car form)) (body (cdr form)) |
| 155 (bind-defs nil) (bind-enquote nil) | 175 (bind-defs nil) (bind-enquote nil) |
| 156 (bind-inits nil) (bind-lets nil) (bind-forms nil) | 176 (bind-inits nil) (bind-lets nil) (bind-forms nil) |
| 157 (header nil) (simple-args nil)) | 177 (header nil) (simple-args nil) |
| 178 (doc "")) | |
| 179 ;; Add CL lambda list to documentation. npak@ispras.ru | |
| 180 (if (stringp (car body)) | |
| 181 (setq doc (cl-pop body))) | |
| 182 (cl-push (concat "\nCommon Lisp lambda list:\n" | |
| 183 " " (cl-function-arglist bind-block args) | |
| 184 "\n\n" | |
| 185 doc) | |
| 186 header) | |
| 187 | |
| 158 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) | 188 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) |
| 159 (cl-push (cl-pop body) header)) | 189 (cl-push (cl-pop body) header)) |
| 160 (setq args (if (listp args) (copy-list args) (list '&rest args))) | 190 (setq args (if (listp args) (copy-list args) (list '&rest args))) |
| 161 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) | 191 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) |
| 162 (if (setq bind-defs (cadr (memq '&cl-defs args))) | 192 (if (setq bind-defs (cadr (memq '&cl-defs args))) |