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

[Alan Mackenzie <acm@muc.de>]

Hello, Stefan.

On Fri, Mar 13, 2015 at 04:38:05PM -0400, Stefan Monnier wrote:
> > They're not that rare.  I count 304 currently in Emacs, including
> > eudc-cdaar (twice), in 78 files.  That's a lot of files that need to
> > require cl.

> Most likely 99.9% of these files also use other CL facilities, so that
> wouldn't save them from requiring CL.  And in any case, using CL
> facilities is perfectly fine (provided you do it via cl-lib rather than
> cl.el).

I don't know how many of them require other bits of CL.  But the point
is that CL is not loaded by default, so any use of cXXXr in standard
files is awkward.  I'm thinking in particular about my new fix-re.el
here.

> > let-binding variables, then accessing them, must be quite slow
> > by comparison.

> Via dynamically scoped vars, that's indeed the case.
> But with lexical-binding not anymore.

OK, fair enough.  But unless we're talking about doing cXXXr needlessly
in a tight loop, it's hardly going to make a noticeable difference.

Here's what I now propose to commit.  In the patch:

1. All c[ad]\{3,4\}r are now declared in subr.el, generated from macros.
2. Each of these has a cl-cXXXr as an alias, declared as obsolete as
  from 25.1.
3. caar, cadr, cdar, and cddr are now declared as defuns (changed from
  defsubsts).
4. All the cXXr, including caar, etc., use the compiler macro
  `compiler-macro-cXXr' (renamed by removing "cl-" from the name).

It proved impractical also to generate caar, cadr, cdar, and cddr from
the macros, since there were circular dependencies in the
`compiler_macro' form in `zerop'.  I now accept that adding in 5 element
cXXXr's would be tasteless and uncalled for.



diff --git a/lisp/subr.el b/lisp/subr.el
index deadca6..89371f4 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -339,20 +339,38 @@ configuration."
 \f
 ;;;; List functions.
 
-(defsubst caar (x)
+(defun compiler-macro-cXXr (form x)
+  (let* ((head (car form))
+         (n (symbol-name (car form)))
+         (i (- (length n) 2)))
+    (if (not (string-match "c[ad]+r\\'" n))
+        (if (and (fboundp head) (symbolp (symbol-function head)))
+            (compiler-macro-cXXr (cons (symbol-function head) (cdr form))
+                                     x)
+          (error "Compiler macro for cXXr applied to non-cXXr form"))
+      (while (> i (match-beginning 0))
+        (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x))
+        (setq i (1- i)))
+      x)))
+
+(defun caar (x)
   "Return the car of the car of X."
+  (declare (compiler-macro compiler-macro-cXXr))
   (car (car x)))
 
-(defsubst cadr (x)
+(defun cadr (x)
   "Return the car of the cdr of X."
+  (declare (compiler-macro compiler-macro-cXXr))
   (car (cdr x)))
 
-(defsubst cdar (x)
+(defun cdar (x)
   "Return the cdr of the car of X."
+  (declare (compiler-macro compiler-macro-cXXr))
   (cdr (car x)))
 
-(defsubst cddr (x)
+(defun cddr (x)
   "Return the cdr of the cdr of X."
+  (declare (compiler-macro compiler-macro-cXXr))
   (cdr (cdr x)))
 
 (defun last (list &optional n)
@@ -478,6 +496,80 @@ argument VECP, this copies vectors as well as conses."
 	    (aset tree i (copy-tree (aref tree i) vecp)))
 	  tree)
       tree)))
+
+;; Macros to generate caaar ... cddddr.
+(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 #'char-to-string 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)
+  "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).  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)
+       (declare (compiler-macro compiler-macro-cXXr))
+       ,(gen-cXXr--code raw bits))))
+
+(defmacro gen-cXXr-all (bits)
+  "Generate defuns for all `c[ad]+r's with BITS a's and d's.
+Include `compiler-macro' declarations in the defuns."
+  `(progn
+     ,@(mapcar
+	(lambda (n)
+	  (gen-cXXr--defun n bits))
+	(number-sequence 0 (1- (lsh 1 bits))))))
+
+(defmacro gen-cXXr-all-cl-aliases (bits)
+  "Generate cl- aliases for all defuns `c[ad]+r' with BITS a's and d's.
+Also mark the aliases as obsolete."
+  `(progn
+     ,@(mapcar
+	(lambda (n)
+	  (let* ((raw (gen-cXXr--rawname n bits))
+		 (old (intern (concat "cl-c" raw "r")))
+		 (new (intern (concat "c" raw "r"))))
+	    `(progn (defalias ',old ',new)
+		    (make-obsolete ',old ',new "25.1"))))
+	(number-sequence 0 (1- (lsh 1 bits))))))
+
+(gen-cXXr-all 3)		; Generate `caaar', `caadr', ..., `cdddr'.
+(gen-cXXr-all-cl-aliases 3)
+(gen-cXXr-all 4)		 ; Generate `caaaar', `caaadr', ..., `cddddr'.
+(gen-cXXr-all-cl-aliases 4)
 \f
 ;;;; Various list-search functions.
 

[Boring patch ripping out stuff from cl-lib.el, etc., not shown.]


>         Stefan

-- 
Alan Mackenzie (Nuremberg, Germany).