Rationalising c[ad]\{2,5\}r.

[Alan Mackenzie <acm@muc.de>]

Hello, Emacs.

Right at the moment, our functions caar, cadr, cdar, cddr, caaar, caadr,
....., cddddr are in a mess:

1. caar,  cadr, cdar, and cddr are defined in subr.el;
2. c[ad]\{3,4\}r are actually called cl-caaar, etc;
3. cl-c[ad]\{3,4\}r are defined in cl-lib.el;
4. The aliases for the names without the cl- are defined in  cl.el;
5. c[ad]\{3,4\}r each contain the form
    (declare (compiler-macro cl--compiler-macro-cXXr)
  , whereas caar, cadr, cdar, cddr don't.  At the moment, I don't know
  whether this is a bug, or whether the two cases are just handled
  differently;
6. All the defuns are written out individually, making it hard to verify
  that they are all correct, and making it very hard to extend to 5 or
  more [ad]s, and also taking up a lot of lines of code spread over
  several files.el.

I propose the following solution: all these defuns should be in subr.el,
the canonical names will be caaadr etc., and there will be compatibility
aliases for cl-caaadr etc..  All these functions and aliases will be
generated by macros, thus saving source code lines, making them more
reliable, and enabling extension to the scheme with a trivial amount of
effort.

At the moment, the number of source file lines occupied by these
functions (including blank lines) is:
subr.el:    16
cl-lib.el: 120
cl.el:      24
           ---
TOTAL      160

In my proposed change, the macros and macro invocations occupy a mere 88
lines, and even extends the scheme to 5-[ad] defuns (like cadadar).
(Yes, I do have a use for caadadr, caddadr, and cdddadr in fix-re.el.)

Here is the code I propose to put into subr.el in place of the
declarations of caar etc.:

*************************************************************************

;; Macros to generate caar ... cdddddr in subr.el.
(eval-and-compile
  (defun gen-cXXr--rawname (n bits)
    "Generate and return a string like \"adad\" corresponding to N.
BITS is the number of a's and d's.
The \"corresponding\" means each bit of N is converted to an \"a\" (for zero)
or a \"d\" (for one)."
    (let ((name (make-string bits ?a))
	  (mask (lsh 1 (1- bits)))
	  (elt 0))
      (while (< elt bits)
	(if (/= (logand n mask) 0)
	    (aset name elt ?d))
	(setq elt (1+ elt)
	      mask (lsh mask -1)))
      name))

  (defun gen-cXXr--doc-string (raw)
    "Generate a doc string for a name like \"cadadr\".
RAW is the \"inner\" part of the name, e.g. \"adad\"."
    (concat
     "Return the `c"
     (mapconcat (lambda (ad) (char-to-string ad)) raw "r' of the `c")
     "r' of X."))

  (defun gen-cXXr--code (raw bits)
    "Generate the code for a defun like \"cadadr\" in terms of `car' and `cdr'.
RAW is the \"inner\" part of the name, e.g. \"adad\", BITS is the
length of RAW."
    (let ((code 'x)
	  (elt bits))
      (while (> elt 0)
	(setq elt (1- elt))
	(setq code (list (if (eq (aref raw elt) ?a) 'car 'cdr) code)))
      code))

  (defun gen-cXXr--defun (n bits compiler-macro)
    "Generate a `defun' for a symbol like \"cadadr\".
N is a number representing the \"inner\" part of the
symbol (e.g. binary 0101 for cadadr), BITS is the length of that
part of the symbol (e.g. 4).  If COMPILER-MACRO is non-nil,
include a `compiler-macro' declaration in the defun."
    (let ((raw (gen-cXXr--rawname n bits)))
      `(defun ,(intern (concat "c" raw "r")) (x)
	 ,(gen-cXXr--doc-string raw)
	 ,@(when compiler-macro
	     '((declare (compiler-macro cl--compiler-macro-cXXr))))
	 ,(gen-cXXr--code raw bits))))

  (defun gen-cXXr--make-seq (bits)
    "Generate a list of all integers with BITS bits, in ascending order."
    (let ((x (lsh 1 bits))
	  acc)
      (while (> x 0)
	(setq x (1- x))
	(push x acc))
      acc)))

(defmacro gen-cXXr-all (bits compiler-macro)
  "Generate defuns for all `c[ad]+r's with BITS a's and d's.
If COMPILER-MACRO is non-nil, include `compiler-macro'
declarations in the defuns."
  (let ((seq (gen-cXXr--make-seq bits)))
     `(progn
	,@(mapcar
	   (lambda (n)
	     (gen-cXXr--defun n bits compiler-macro))
	   seq))))

(defmacro gen-cXXr-all-cl-aliases (bits)
  "Generate cl- aliases for all defuns `c[ad]+r' with BITS a's and d's."
  (let ((seq (gen-cXXr--make-seq bits))
	)
    `(progn
       ,@(mapcar
	  (lambda (n)
	    (let ((raw (gen-cXXr--rawname n bits)))
	      `(defalias ',(intern (concat "cl-c" raw "r"))
		 ',(intern (concat "c" raw "r")))))
	  seq))))

(gen-cXXr-all 2 nil)
(gen-cXXr-all 3 t)
(gen-cXXr-all-cl-aliases 3)
(gen-cXXr-all 4 t)
(gen-cXXr-all-cl-aliases 4)
(gen-cXXr-all 5 t)
*************************************************************************

Comments?

-- 
Alan Mackenzie (Nuremberg, Germany).