Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 4793:8b50bee3c88c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove attempted support for 1996-era emacs without self-quoting keywords. lisp/ChangeLog addition: 2009-12-19 Aidan Kehoe <kehoea@parhasard.net> * cl-macs.el (cl-do-arglist): * cl-compat.el (keyword-of): Remove support in our generated code for emacs versions where keywords are not self-quoting. src/ChangeLog addition: 2009-12-19 Aidan Kehoe <kehoea@parhasard.net> * symbols.c (reject_constant_symbols): Indicate that accepting attempted modification of keywords is a temporary thing.
author Aidan Kehoe <kehoea@parhasard.net>
date Sat, 19 Dec 2009 18:10:20 +0000
parents e29fcfd8df5f
children 8484c6c76837
comparison
equal deleted inserted replaced
4783:e29fcfd8df5f 4793:8b50bee3c88c
438 bind-forms))) 438 bind-forms)))
439 (while (and (eq (car args) '&key) (pop args)) 439 (while (and (eq (car args) '&key) (pop args))
440 (while (and args (not (memq (car args) lambda-list-keywords))) 440 (while (and args (not (memq (car args) lambda-list-keywords)))
441 (let ((arg (pop args))) 441 (let ((arg (pop args)))
442 (or (consp arg) (setq arg (list arg))) 442 (or (consp arg) (setq arg (list arg)))
443 (let* ((karg (if (consp (car arg)) (caar arg) 443 (let* ((karg (if (consp (car arg))
444 (intern (format ":%s" (car arg))))) 444 ;; It's possible to use non-keywords here, as
445 ;; in the KEYWORD-ARGUMENT-NAME-PACKAGE Common
446 ;; Lisp issue:
447 (caar arg)
448 ;; Use read instead of intern in case we ever
449 ;; actually get packages and keywords are no
450 ;; longer in obarray:
451 (read (concat ":" (symbol-name (car arg))))))
445 (varg (if (consp (car arg)) (cadar arg) (car arg))) 452 (varg (if (consp (car arg)) (cadar arg) (car arg)))
446 (def (if (cdr arg) (cadr arg) 453 (def (if (cdr arg) (cadr arg)
447 (or (car bind-defs) (cadr (assq varg bind-defs))))) 454 (or (car bind-defs) (cadr (assq varg bind-defs)))))
448 (look (list 'memq (list 'quote karg) restarg))) 455 (look (list 'memq (quote-maybe karg) restarg)))
449 (and def bind-enquote (setq def (list 'quote def))) 456 (and def bind-enquote (setq def (list 'quote def)))
450 (if (cddr arg) 457 (if (cddr arg)
451 (let* ((temp (or (nth 2 arg) (gensym))) 458 (let* ((temp (or (nth 2 arg) (gensym)))
452 (val (list 'car (list 'cdr temp)))) 459 (val (list 'car (list 'cdr temp))))
453 (cl-do-arglist temp look) 460 (cl-do-arglist temp look)
465 (if (eq (cl-const-expr-p def) t) 472 (if (eq (cl-const-expr-p def) t)
466 (list 473 (list
467 'quote 474 'quote
468 (list nil (cl-const-expr-val def))) 475 (list nil (cl-const-expr-val def)))
469 (list 'list nil def)))))))) 476 (list 'list nil def))))))))
470 (push karg keys) 477 (push karg keys)))))
471 ;; XEmacs addition
472 (if (= (aref (symbol-name karg) 0) ?:)
473 (progn (set karg karg)
474 (push (list 'setq karg (list 'quote karg))
475 bind-inits)))))))
476 (setq keys (nreverse keys)) 478 (setq keys (nreverse keys))
477 (or (and (eq (car args) '&allow-other-keys) (pop args)) 479 (or (and (eq (car args) '&allow-other-keys) (pop args))
478 (null keys) (= safety 0) 480 (null keys) (= safety 0)
479 (let* ((var (gensym "--keys--")) 481 (let* ((var (gensym "--keys--"))
480 (allow '(:allow-other-keys)) 482 (allow '(:allow-other-keys))
485 (list (list 'memq (list 'car var) 487 (list (list 'memq (list 'car var)
486 (list 'quote (append keys allow))) 488 (list 'quote (append keys allow)))
487 (list 'setq var (list 'cdr (list 'cdr var)))) 489 (list 'setq var (list 'cdr (list 'cdr var))))
488 (list (list 'car 490 (list (list 'car
489 (list 'cdr 491 (list 'cdr
490 (list 'memq (cons 'quote allow) 492 (list 'memq (car allow)
491 restarg))) 493 restarg)))
492 (list 'setq var nil)) 494 (list 'setq var nil))
493 (list t 495 (list t
494 (list 496 (list
495 'error 497 'error