Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 1580:15a9361e2781

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2003-07-18 20:39:44 by james] Nickolay Pakoulin's fix to Common Lisp docstring construction.
author james
date Fri, 18 Jul 2003 20:39:45 +0000
parents 01c57eb70ae9
children 393039450288
comparison
equal deleted inserted replaced
1579:aebc80e1f056 1580:15a9361e2781
208 '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) 208 '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
209 209
210 (defvar cl-macro-environment nil) 210 (defvar cl-macro-environment nil)
211 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote) 211 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
212 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms) 212 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
213 (defvar arglist-visited)
213 214
214 ;; npak@ispras.ru 215 ;; npak@ispras.ru
215 (defun cl-upcase-arg (arg) 216 (defun cl-upcase-arg (arg)
216 ;; Changes all non-keyword sysmbols in `arg' to symbols 217 ;; Changes all non-keyword symbols in `ARG' to symbols
217 ;; with name in upper case. 218 ;; with name in upper case.
218 ;; arg is either symbol or list of symbols or lists 219 ;; ARG is either symbol or list of symbols or lists
219 (cond ((symbolp arg) 220 (cond ((symbolp arg)
220 (if (memq arg lambda-list-keywords) 221 ;; Do not upcase &optional, &key etc.
221 ;; Do not upcase &optional, &key etc. 222 (if (memq arg lambda-list-keywords) arg
222 arg 223 (intern (upcase (symbol-name arg)))))
223 (intern (upcase (symbol-name arg))))) 224 ((listp arg)
224 ((listp arg) 225 (if (memq arg arglist-visited) (error 'circular-list '(arg)))
225 (mapcar 'cl-upcase-arg arg)))) 226 (cl-push arg arglist-visited)
227 (let ((arg (copy-list arg)) junk)
228 ;; Clean the list
229 (let ((p (last arg))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
230 (if (setq junk (cadr (memq '&cl-defs arg)))
231 (setq arg (delq '&cl-defs (delq junk arg))))
232 (if (memq '&cl-quote arg)
233 (setq arg (delq '&cl-quote arg)))
234 (mapcar 'cl-upcase-arg arg)))
235 (t arg))) ; Maybe we are in initializer
226 236
227 ;; npak@ispras.ru 237 ;; npak@ispras.ru
228 (defun cl-function-arglist (function agrlist) 238 (defun cl-function-arglist (name arglist)
229 "Returns string with printed representation of arguments list. 239 "Returns string with printed representation of arguments list.
230 Supports Common Lisp lambda lists." 240 Supports Common Lisp lambda lists."
231 (prin1-to-string 241 (if (not (or (listp arglist) (symbolp arglist)))
232 (cons function (cl-upcase-arg agrlist)))) 242 "Not available"
243 (setq arglist-visited nil)
244 (condition-case nil
245 (prin1-to-string
246 (cons (if (eq name 'cl-none) 'lambda name)
247 (cond ((null arglist) nil)
248 ((listp arglist) (cl-upcase-arg arglist))
249 ((symbolp arglist)
250 (cl-upcase-arg (list '&rest arglist)))
251 (t (wrong-type-argument 'listp arglist)))))
252 (t "Not available"))))
253
233 254
234 (defun cl-transform-lambda (form bind-block) 255 (defun cl-transform-lambda (form bind-block)
235 (let* ((args (car form)) (body (cdr form)) 256 (let* ((args (car form)) (body (cdr form))
236 (bind-defs nil) (bind-enquote nil) 257 (bind-defs nil) (bind-enquote nil)
237 (bind-inits nil) (bind-lets nil) (bind-forms nil) 258 (bind-inits nil) (bind-lets nil) (bind-forms nil)
238 (header nil) (simple-args nil) 259 (header nil) (simple-args nil)
239 (doc "")) 260 (doc ""))
240 ;; Add CL lambda list to documentation. npak@ispras.ru 261 ;; Add CL lambda list to documentation. npak@ispras.ru
241 (if (stringp (car body)) 262 (if (and (stringp (car body))
263 (cdr body))
242 (setq doc (cl-pop body))) 264 (setq doc (cl-pop body)))
243 (cl-push (concat "\nCommon Lisp lambda list:\n" 265 (cl-push (concat doc
266 "\nCommon Lisp lambda list:\n"
244 " " (cl-function-arglist bind-block args) 267 " " (cl-function-arglist bind-block args)
245 "\n\n" 268 "\n\n")
246 doc)
247 header) 269 header)
248 270
249 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) 271 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
250 (cl-push (cl-pop body) header)) 272 (cl-push (cl-pop body) header))
251 (setq args (if (listp args) (copy-list args) (list '&rest args))) 273 (setq args (if (listp args) (copy-list args) (list '&rest args)))