Last active
October 25, 2023 07:20
-
-
Save shirok/dd6cf4242a5ae59b85732b405b6d961b to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment