1 ;;; deflexer using cl-ppcre
3 ;;; Heavily stolen from
4 ;;; http://common-lisp.net/pipermail/cl-ppcre-devel/2004-June/000041.html
5 ;;; by Edi Weitz, combined with other stuff found in the CL-PPCRE code.
7 ;;; Hacked together by Julian Squires <julian@cipht.net> / 2006.
8 ;;; XXX Needs heavy refactoring!
10 (defpackage :cl-ppcre-lex
11 (:use
:cl
:cl-ppcre
:anaphora
)
12 (:import-from
:cl-ppcre
#:nsubseq
)
15 (in-package :cl-ppcre-lex
)
17 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
18 (defmacro with-unique-names
((&rest bindings
) &body body
)
19 ;; see <http://www.cliki.net/Common%20Lisp%20Utilities>
20 `(let ,(mapcar #'(lambda (binding)
21 (check-type binding
(or cons symbol
))
23 (destructuring-bind (var x
) binding
24 (check-type var symbol
)
25 `(,var
(gensym ,(etypecase x
26 (symbol (symbol-name x
))
27 (character (string x
))
29 `(,binding
(gensym ,(symbol-name binding
)))))
33 (defun collect-bindings (var-list string reg-starts reg-ends
)
34 (loop for var in var-list
37 collect
`(,var
(awhen (aref ,reg-starts
,counter
)
39 (aref ,reg-ends
,counter
))))))
41 (defun gather-fns (list)
42 (with-unique-names (scanner string start match-start match-end
43 reg-starts reg-ends next-pos-fn
)
46 (destructuring-bind (regex (&rest var-list
) &body body
) x
47 (let ((bindings (collect-bindings var-list string reg-starts reg-ends
)))
49 (lambda (,scanner
,string
,start
,next-pos-fn
)
51 (,match-start
,match-end
,reg-starts
,reg-ends
)
52 (cl-ppcre:scan
,scanner
,string
:start
,start
)
54 `((declare (ignore ,reg-starts
,reg-ends
))))
56 (let ((it (progn ,@(if bindings
57 `((let (,@bindings
) ,@body
))
59 (when it
(funcall ,next-pos-fn
,match-end
) it
))))))))))))
61 (defmacro deflexer
(name &body body
)
62 (with-unique-names (regex-table regex sexpr-regex anchored-regex function
)
64 (loop for
(,regex .
,function
) in
(list ,@(gather-fns body
))
68 (error "Compiled scanners are not allowed here"))
70 (cl-ppcre::parse-string
,regex
))
74 (cl-ppcre:create-scanner
`(:sequence
75 :modeless-start-anchor
77 collect
(cons ,anchored-regex
,function
))))
78 (defun ,name
(string next-pos-fn
&key
((:start start
) 0))
79 (loop for
(scanner . function
) in
,regex-table
80 for value
= (funcall function scanner string start next-pos-fn
)
81 when value do
(return value
))))))