Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 4694:2ac296807b88

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Don't needlessly intern symbols, #'function-arglist, #'cl-function-arglist 2009-09-20 Aidan Kehoe <kehoea@parhasard.net> * help.el (function-arglist): Show the double-quotes in the sample output, correctly. Bind print-gensym to nil, now we're using uninterned symbols. Don't #'mapcar + #'intern to create uppercase symbols, use #'loop and #'make-symbol instead. * cl-macs.el (cl-upcase-arg): Don't intern the upcased symbols we're using for cosmetic reasons. Trust #'true-list-p in #'cl-function-arglist to detect circularity. (cl-function-arglist): Bind print-gensym to nil, now we're printing uninterned symbols and would prefer to avoid the gensym syntax. (cl-transform-lambda): Only add the Common Lisp lambda list: argument information when that differs frmo the normal argument information.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 20 Sep 2009 21:41:22 +0100
parents 8f1ee2d15784
children fee33ab25966
comparison
equal deleted inserted replaced
4693:80cd90837ac5 4694:2ac296807b88
273 '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) 273 '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
274 274
275 (defvar cl-macro-environment nil) 275 (defvar cl-macro-environment nil)
276 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote) 276 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
277 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms) 277 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
278 (defvar arglist-visited)
279 278
280 ;; npak@ispras.ru 279 ;; npak@ispras.ru
281 (defun cl-upcase-arg (arg) 280 (defun cl-upcase-arg (arg)
282 ;; Changes all non-keyword symbols in `ARG' to symbols 281 ;; Changes all non-keyword symbols in `ARG' to symbols
283 ;; with name in upper case. 282 ;; with name in upper case.
284 ;; ARG is either symbol or list of symbols or lists 283 ;; ARG is either symbol or list of symbols or lists
285 (cond ((symbolp arg) 284 (cond ((symbolp arg)
286 ;; Do not upcase &optional, &key etc. 285 ;; Do not upcase &optional, &key etc.
287 (if (memq arg lambda-list-keywords) arg 286 (if (memq arg lambda-list-keywords)
288 (intern (upcase (symbol-name arg))))) 287 arg
288 (make-symbol (upcase (symbol-name arg)))))
289 ((listp arg) 289 ((listp arg)
290 (if (memq arg arglist-visited) (error 'circular-list '(arg)))
291 (push arg arglist-visited)
292 (let ((arg (copy-list arg)) junk) 290 (let ((arg (copy-list arg)) junk)
293 ;; Clean the list 291 ;; Clean the list
294 (let ((p (last arg))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) 292 (let ((p (last arg))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
295 (if (setq junk (cadr (memq '&cl-defs arg))) 293 (if (setq junk (cadr (memq '&cl-defs arg)))
296 (setq arg (delq '&cl-defs (delq junk arg)))) 294 (setq arg (delq '&cl-defs (delq junk arg))))
303 (defun cl-function-arglist (name arglist) 301 (defun cl-function-arglist (name arglist)
304 "Returns string with printed representation of arguments list. 302 "Returns string with printed representation of arguments list.
305 Supports Common Lisp lambda lists." 303 Supports Common Lisp lambda lists."
306 (if (not (or (listp arglist) (symbolp arglist))) 304 (if (not (or (listp arglist) (symbolp arglist)))
307 "Not available" 305 "Not available"
308 (setq arglist-visited nil) 306 (check-argument-type #'true-list-p arglist)
309 (condition-case nil 307 (let ((print-gensym nil))
310 (prin1-to-string 308 (condition-case nil
311 (cons (if (eq name 'cl-none) 'lambda name) 309 (prin1-to-string
312 (cond ((null arglist) nil) 310 (cons (if (eq name 'cl-none) 'lambda name)
313 ((listp arglist) (cl-upcase-arg arglist)) 311 (cond ((null arglist) nil)
314 ((symbolp arglist) 312 ((listp arglist) (cl-upcase-arg arglist))
315 (cl-upcase-arg (list '&rest arglist))) 313 ((symbolp arglist)
316 (t (wrong-type-argument 'listp arglist))))) 314 (cl-upcase-arg (list '&rest arglist)))
317 (t "Not available")))) 315 (t (wrong-type-argument 'listp arglist)))))
318 316 (t "Not available")))))
319 317
320 (defun cl-transform-lambda (form bind-block) 318 (defun cl-transform-lambda (form bind-block)
321 (let* ((args (car form)) (body (cdr form)) 319 (let* ((args (car form)) (body (cdr form))
322 (bind-defs nil) (bind-enquote nil) 320 (bind-defs nil) (bind-enquote nil)
323 (bind-inits nil) (bind-lets nil) (bind-forms nil) 321 (bind-inits nil) (bind-lets nil) (bind-forms nil)
324 (header nil) (simple-args nil) 322 (header nil) (simple-args nil)
323 (complex-arglist (cl-function-arglist bind-block args))
325 (doc "")) 324 (doc ""))
326 ;; Add CL lambda list to documentation. npak@ispras.ru
327 (if (and (stringp (car body))
328 (cdr body))
329 (setq doc (pop body)))
330 (push (concat doc
331 "\nCommon Lisp lambda list:\n"
332 " " (cl-function-arglist bind-block args)
333 "\n\n")
334 header)
335
336 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) 325 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
337 (push (pop body) header)) 326 (push (pop body) header))
338 (setq args (if (listp args) (copy-list args) (list '&rest args))) 327 (setq args (if (listp args) (copy-list args) (list '&rest args)))
339 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) 328 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
340 (if (setq bind-defs (cadr (memq '&cl-defs args))) 329 (if (setq bind-defs (cadr (memq '&cl-defs args)))
351 (not (and (eq (car args) '&optional) 340 (not (and (eq (car args) '&optional)
352 (or bind-defs (consp (cadr args)))))) 341 (or bind-defs (consp (cadr args))))))
353 (push (pop args) simple-args)) 342 (push (pop args) simple-args))
354 (or (eq bind-block 'cl-none) 343 (or (eq bind-block 'cl-none)
355 (setq body (list (list* 'block bind-block body)))) 344 (setq body (list (list* 'block bind-block body))))
345 (setq simple-args (nreverse simple-args)
346 header (nreverse header))
347 ;; Add CL lambda list to documentation, if the CL lambda list differs
348 ;; from the non-CL lambda list. npak@ispras.ru
349 (unless (equal complex-arglist
350 (cl-function-arglist bind-block simple-args))
351 (and (stringp (car header)) (setq doc (pop header)))
352 (push (concat doc
353 "\n\nCommon Lisp lambda list:\n"
354 " " complex-arglist "\n\n")
355 header))
356 (if (null args) 356 (if (null args)
357 (list* nil (nreverse simple-args) (nconc (nreverse header) body)) 357 (list* nil simple-args (nconc header body))
358 (if (memq '&optional simple-args) (push '&optional args)) 358 (if (memq '&optional simple-args) (push '&optional args))
359 (cl-do-arglist args nil (- (length simple-args) 359 (cl-do-arglist args nil (- (length simple-args)
360 (if (memq '&optional simple-args) 1 0))) 360 (if (memq '&optional simple-args) 1 0)))
361 (setq bind-lets (nreverse bind-lets)) 361 (setq bind-lets (nreverse bind-lets))
362 (list* (and bind-inits (list* 'eval-when '(compile load eval) 362 (list* (and bind-inits (list* 'eval-when '(compile load eval)
363 (nreverse bind-inits))) 363 (nreverse bind-inits)))
364 (nconc (nreverse simple-args) 364 (nconc simple-args
365 (list '&rest (car (pop bind-lets)))) 365 (list '&rest (car (pop bind-lets))))
366 ;; XEmacs change: we add usage information using Nickolay's 366 ;; XEmacs change: we add usage information using Nickolay's
367 ;; approach above 367 ;; approach above
368 (nconc (nreverse header) 368 (nconc header
369 (list (nconc (list 'let* bind-lets) 369 (list (nconc (list 'let* bind-lets)
370 (nreverse bind-forms) body))))))) 370 (nreverse bind-forms) body)))))))
371 371
372 (defun cl-do-arglist (args expr &optional num) ; uses bind-* 372 (defun cl-do-arglist (args expr &optional num) ; uses bind-*
373 (if (nlistp args) 373 (if (nlistp args)