Created
October 20, 2009 13:28
-
-
Save lkuty/214257 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
(defun |#"-reader| (stream sub-char numarg) | |
(declare (ignore sub-char numarg)) | |
(let (chars) | |
(do ((prev (read-char stream) curr) | |
(curr (read-char stream) (read-char stream))) | |
((and (char= prev #\") (char= curr #\#))) | |
(push prev chars)) | |
(coerce (nreverse chars) 'string))) | |
(set-dispatch-macro-character #\# #\" #'|#"-reader|) | |
;#"Ceci est un message contenant un " et un /"# | |
(defun segment-reader (stream ch n) | |
(if (> n 0) | |
(let ((chars)) | |
(do ((curr (read-char stream) | |
(read-char stream))) | |
((char= ch curr)) | |
(push curr chars)) | |
(cons (coerce (nreverse chars) 'string) | |
(segment-reader stream ch (- n 1)))))) | |
(defun mkstr (&rest args) | |
(with-output-to-string (s) | |
(dolist (a args) (princ a s)))) | |
(defun symb (&rest args) | |
(values (intern (apply #'mkstr args)))) | |
(defun group (source n) | |
(if (zerop n) (error "zero length")) | |
(labels ((rec (source acc) | |
(let ((rest (nthcdr n source))) | |
(if (consp rest) | |
(nreverse | |
(cons source acc)))))) | |
(if source (rec source nil) nil))) | |
(defun flatten (x) | |
(labels ((rec (x acc) | |
(cond ((null x) acc) | |
((atom x) (cons x acc)) | |
(t (rec | |
(car x) | |
(rec (cdr x) acc)))))) | |
(rec x nil))) | |
(defun g!-symbol-p (s) | |
(and (symbolp s) | |
(> (length (symbol-name s)) 2) | |
(string= (symbol-name s) | |
"G!" | |
:start1 0 | |
:end1 2))) | |
(defmacro defmacro/g! (name args &rest body) | |
(let ((syms (remove-duplicates | |
(remove-if-not #'g!-symbol-p | |
(flatten body))))) | |
`(defmacro ,name ,args | |
(let ,(mapcar | |
(lambda (s) | |
`(,s (gensym ,(subseq | |
(symbol-name s) | |
2)))) | |
syms) | |
,@body)))) | |
(defun o!-symbol-p (s) | |
(and (symbolp s) | |
(> (length (symbol-name s)) 2) | |
(string= (symbol-name s) | |
"O!" | |
:start1 0 | |
:end1 2))) | |
(defun o!-symbol-to-g!-symbol (s) | |
(symb "G!" | |
(subseq (symbol-name s) 2))) | |
(defmacro defmacro! (name args &rest body) | |
(let* ((os (remove-if-not #'o!-symbol-p args)) | |
(gs (mapcar #'o!-symbol-to-g!-symbol os))) | |
`(defmacro/g! ,name ,args | |
`(let ,(mapcar #'list (list ,@gs) (list ,@os)) | |
,(progn ,@body))))) | |
#+cl-ppcre | |
(defmacro! match-mode-ppcre-lambda-form (o!args) | |
``(lambda (,',g!str) | |
(cl-ppcre:scan | |
,(car ,g!args) | |
,',g!str))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment