cxr.lisp

(defvar *original-readtable* *readtable*)
(defvar *cxr-readtable* (copy-readtable *original-readtable*))

(defconstant +constituents+
  (remove-if #'get-macro-character
             "!$%&0123456789<=>?[]^_{}~.+-*/@ABCDEFGHIJKLMNOPQRTSUVWXYZabcdefghijklmnopqrstuvwxyz"))

(defun cxr-reader (stream char)
  (let* ((chars (loop with cs = `(,char)
                      for c = (peek-char nil stream nil nil t)
                      while (find c +constituents+)
                      do (push (read-char stream nil nil t) cs)
                      finally (return (reverse cs))))
         (ads  (butlast (cdr chars)))
         (last (car (last chars))))
    (if (and (equalp char #\c)
             (> (length ads) 4)
             (equalp last #\r)
             (every (lambda (x) (member x '(#\a #\d) :test #'equalp)) ads))
        (expand-cxr ads)
      (let ((*readtable* *original-readtable*))
        (read-from-string (coerce chars 'string))))))

(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)))))))
    `(cl:lambda (x) ,(expand ads))))

(let ((*readtable* *cxr-readtable*))
  (loop for c across +constituents+
        do (set-macro-character c #'cxr-reader)))