Mercurial > hg > xemacs-beta
comparison lisp/cl-macs.el @ 5509:9ac0016d8fe8
Remove `bind-inits', cl-macs.el, it's no longer used.
2011-05-18 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (bind-inits)): Removed.
* cl-macs.el (defun*):
* cl-macs.el (defmacro*):
* cl-macs.el (function*):
* cl-macs.el (macrolet):
* cl-macs.el (cl-transform-function-property):
* cl-macs.el (destructuring-bind):
Remove `bind-inits' from this file, and only ever return nil as
the first element of cl-transform-lambda's result list; bind-inits
hasn't been used since the support for non-self-quoting keywords
was removed, and its absence (and the guarantee that the first
element of the result of cl-transform-lambda is nil) make the
implementations of various other macros easier and clearer.
* cl-macs.el (cl-transform-lambda):
Give this function a docstring.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 18 May 2011 14:21:52 +0100 |
| parents | 4813ff11c6e2 |
| children | 7b5254f6e0d5 |
comparison
equal
deleted
inserted
replaced
| 5508:3fe8358ad59a | 5509:9ac0016d8fe8 |
|---|---|
| 220 | 220 |
| 221 -- &aux specifies extra bindings, exactly like a `let*' enclosing the body. | 221 -- &aux specifies extra bindings, exactly like a `let*' enclosing the body. |
| 222 The format of each binding is VAR || (VAR [INITFORM]) -- exactly like the | 222 The format of each binding is VAR || (VAR [INITFORM]) -- exactly like the |
| 223 format of `let'/`let*' bindings. | 223 format of `let'/`let*' bindings. |
| 224 " | 224 " |
| 225 (let* ((res (cl-transform-lambda (list* arglist docstring body) name)) | 225 (list* 'defun name (cdr (cl-transform-lambda (list* arglist docstring body) |
| 226 (form (list* 'defun name (cdr res)))) | 226 name)))) |
| 227 (if (car res) (list 'progn (car res) form) form))) | |
| 228 | 227 |
| 229 ;;;###autoload | 228 ;;;###autoload |
| 230 (defmacro defmacro* (name arglist &optional docstring &rest body) | 229 (defmacro defmacro* (name arglist &optional docstring &rest body) |
| 231 "Define NAME as a macro. | 230 "Define NAME as a macro. |
| 232 Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, | 231 Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, |
| 276 actual structure does not match the expected structure. On the | 275 actual structure does not match the expected structure. On the |
| 277 other hand, loop destructuring is lax -- extra arguments in a list | 276 other hand, loop destructuring is lax -- extra arguments in a list |
| 278 are ignored, not enough arguments cause the remaining parameters to | 277 are ignored, not enough arguments cause the remaining parameters to |
| 279 receive a value of nil, etc. | 278 receive a value of nil, etc. |
| 280 " | 279 " |
| 281 (let* ((res (cl-transform-lambda (list* arglist docstring body) name)) | 280 (list* 'defmacro name (cdr (cl-transform-lambda (list* arglist docstring body) |
| 282 (form (list* 'defmacro name (cdr res)))) | 281 name)))) |
| 283 (if (car res) (list 'progn (car res) form) form))) | |
| 284 | 282 |
| 285 ;;;###autoload | 283 ;;;###autoload |
| 286 (defmacro function* (symbol-or-lambda) | 284 (defmacro function* (symbol-or-lambda) |
| 287 "Introduce a function. | 285 "Introduce a function. |
| 288 Like normal `function', except that if argument is a lambda form, its | 286 Like normal `function', except that if argument is a lambda form, its |
| 289 ARGLIST allows full Common Lisp conventions." | 287 ARGLIST allows full Common Lisp conventions." |
| 290 (if (eq (car-safe symbol-or-lambda) 'lambda) | 288 `(function |
| 291 (let* ((res (cl-transform-lambda (cdr symbol-or-lambda) 'cl-none)) | 289 ,(if (eq (car-safe symbol-or-lambda) 'lambda) |
| 292 (form (list 'function (cons 'lambda (cdr res))))) | 290 (cons 'lambda (cdr (cl-transform-lambda (cdr symbol-or-lambda) |
| 293 (if (car res) (list 'progn (car res) form) form)) | 291 'cl-none))) |
| 294 (list 'function symbol-or-lambda))) | 292 symbol-or-lambda))) |
| 295 | 293 |
| 296 (defun cl-transform-function-property (func prop form) | 294 (defun cl-transform-function-property (func prop form) |
| 297 (let ((res (cl-transform-lambda form func))) | 295 `(put ',func ',prop #'(lambda ,@(cdr (cl-transform-lambda form func))))) |
| 298 (append '(progn) (cdr (cdr (car res))) | |
| 299 (list (list 'put (list 'quote func) (list 'quote prop) | |
| 300 (list 'function (cons 'lambda (cdr res)))))))) | |
| 301 | 296 |
| 302 (defconst lambda-list-keywords | 297 (defconst lambda-list-keywords |
| 303 '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) | 298 '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) |
| 304 | 299 |
| 305 (defvar cl-macro-environment nil) | 300 (defvar cl-macro-environment nil) |
| 306 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote) | 301 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote) |
| 307 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms) | 302 (defvar bind-lets) (defvar bind-forms) |
| 308 | 303 |
| 309 ;; npak@ispras.ru | 304 ;; npak@ispras.ru |
| 310 (defun cl-upcase-arg (arg) | 305 (defun cl-upcase-arg (arg) |
| 311 ;; Changes all non-keyword symbols in `ARG' to symbols | 306 ;; Changes all non-keyword symbols in `ARG' to symbols |
| 312 ;; with name in upper case. | 307 ;; with name in upper case. |
| 344 (t (wrong-type-argument 'listp arglist))))) | 339 (t (wrong-type-argument 'listp arglist))))) |
| 345 (if args (prin1-to-string args) "()")) | 340 (if args (prin1-to-string args) "()")) |
| 346 (t "Not available"))))) | 341 (t "Not available"))))) |
| 347 | 342 |
| 348 (defun cl-transform-lambda (form bind-block) | 343 (defun cl-transform-lambda (form bind-block) |
| 344 "Transform a lambda expression to support Common Lisp conventions. | |
| 345 | |
| 346 FORM is the cdr of the lambda expression. BIND-BLOCK is the implicit block | |
| 347 name that's added, typically the name of the associated function. It can be | |
| 348 the symbol `cl-none', to indicate no implicit block is needed. | |
| 349 | |
| 350 The Common Lisp conventions described are those detailed in the `defun*' and | |
| 351 `defmacro*' docstrings. This function returns a list with the first element | |
| 352 nil, to be ignored. The rest of the list represents a transformed lambda | |
| 353 expression, with any argument list parsing code necessary, and a surrounding | |
| 354 block." | |
| 349 (let* ((args (car form)) (body (cdr form)) | 355 (let* ((args (car form)) (body (cdr form)) |
| 350 (bind-defs nil) (bind-enquote nil) | 356 (bind-defs nil) (bind-enquote nil) |
| 351 (bind-inits nil) (bind-lets nil) (bind-forms nil) | 357 (bind-lets nil) (bind-forms nil) |
| 352 (header nil) (simple-args nil) | 358 (header nil) (simple-args nil) |
| 353 (complex-arglist (cl-function-arglist args)) | 359 (complex-arglist (cl-function-arglist args)) |
| 354 (doc "")) | 360 (doc "")) |
| 355 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) | 361 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) |
| 356 (push (pop body) header)) | 362 (push (pop body) header)) |
| 387 (list* nil simple-args (nconc header body)) | 393 (list* nil simple-args (nconc header body)) |
| 388 (if (memq '&optional simple-args) (push '&optional args)) | 394 (if (memq '&optional simple-args) (push '&optional args)) |
| 389 (cl-do-arglist args nil (- (length simple-args) | 395 (cl-do-arglist args nil (- (length simple-args) |
| 390 (if (memq '&optional simple-args) 1 0))) | 396 (if (memq '&optional simple-args) 1 0))) |
| 391 (setq bind-lets (nreverse bind-lets)) | 397 (setq bind-lets (nreverse bind-lets)) |
| 392 (list* (and bind-inits (list* 'eval-when '(compile load eval) | 398 ;; This code originally needed to create the keywords itself, that |
| 393 (nreverse bind-inits))) | 399 ;; wasn't done by the Lisp reader; the first element of the result |
| 394 (nconc simple-args | 400 ;; list comprised code to do this. It's not used any more. |
| 395 (list '&rest (car (pop bind-lets)))) | 401 (list* nil (nconc simple-args (list '&rest (car (pop bind-lets)))) |
| 396 ;; XEmacs change: we add usage information using Nickolay's | 402 ;; XEmacs change: we add usage information using Nickolay's |
| 397 ;; approach above | 403 ;; approach above |
| 398 (nconc header | 404 (nconc header |
| 399 (list (nconc (list 'let* bind-lets) | 405 (list (nconc (list 'let* bind-lets) |
| 400 (nreverse bind-forms) body))))))) | 406 (nreverse bind-forms) body))))))) |
| 569 return (progn BODY)) | 575 return (progn BODY)) |
| 570 | 576 |
| 571 I say \"approximately\" because the destructuring works in a somewhat | 577 I say \"approximately\" because the destructuring works in a somewhat |
| 572 different fashion, although for most reasonably simple constructs the | 578 different fashion, although for most reasonably simple constructs the |
| 573 results will be the same." | 579 results will be the same." |
| 574 (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil) | 580 (let ((bind-block 'cl-none) bind-lets bind-forms bind-defs) |
| 575 (bind-defs nil) (bind-block 'cl-none)) | |
| 576 (cl-do-arglist (or args '(&aux)) expr) | 581 (cl-do-arglist (or args '(&aux)) expr) |
| 577 (append '(progn) bind-inits | 582 (nconc (list 'let* (nreverse bind-lets)) (nreverse bind-forms) body))) |
| 578 (list (nconc (list 'let* (nreverse bind-lets)) | |
| 579 (nreverse bind-forms) body))))) | |
| 580 | |
| 581 | 583 |
| 582 ;;; The `eval-when' form. | 584 ;;; The `eval-when' form. |
| 583 | 585 |
| 584 (defvar cl-not-toplevel nil) | 586 (defvar cl-not-toplevel nil) |
| 585 | 587 |
| 1775 (nconc | 1777 (nconc |
| 1776 (loop | 1778 (loop |
| 1777 for (name . details) | 1779 for (name . details) |
| 1778 in (cons (list* name arglist docstring body) macros) | 1780 in (cons (list* name arglist docstring body) macros) |
| 1779 collect | 1781 collect |
| 1780 (list* name 'lambda | 1782 (list* name 'lambda (cdr (cl-transform-lambda details |
| 1781 (prog1 | 1783 name)))) |
| 1782 (cdr (setq details (cl-transform-lambda | |
| 1783 details name))) | |
| 1784 (eval (car details))))) | |
| 1785 cl-macro-environment))) | 1784 cl-macro-environment))) |
| 1786 | 1785 |
| 1787 ;;;###autoload | 1786 ;;;###autoload |
| 1788 (defmacro* symbol-macrolet (((name expansion) &rest symbol-macros) &body form) | 1787 (defmacro* symbol-macrolet (((name expansion) &rest symbol-macros) &body form) |
| 1789 "Make symbol macro definitions. | 1788 "Make symbol macro definitions. |