cxr2.lisp

(defun expand-cxr (ads)
  (labels ((expand (ads)
                   (cond
                    ((null ads) 'x)
                    ((equalp (car ads) #\a) `(cl:car ,(expand (cdr ads))))
                    (t `(cl:cdr ,(expand (cdr ads)))))))
    (let* ((nam (coerce `(#\c ,@ads #\r) 'string))
           (sym (intern (ecase (readtable-case *cxr-readtable*)
                         ((:upcase) (string-upcase nam))
                         ((:downcase) (string-downcase nam))
                         ((:invert) (map 'string
                                         (lambda (c)
                                           (cond
                                            ((upper-case-p c) (char-downcase c))
                                            ((lower-case-p c) (char-upcase c))
                                            (t c)))
                                         nam))
                         ((:preserve) nam)))))
      (unless (fboundp sym)
        (setf (fdefinition sym)
              (eval `(cl:lambda (x) ,(expand ads)))))
      sym)))