further debug improvements of the parser framework

parent 4990b176
......@@ -963,27 +963,31 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(define-syntax <%p-values%>
(syntax-rules ()
(lambda (x)
(syntax-case x ()
((_ (cut s pr cc) (((P p) ...) vars (fkn . l)) e2 ...)
(parse<> (cut s pr (lambda (ss pr2 p ... . vars)
(syntax-parameterize
((P (lambda (x)
(syntax-case x ()
((x . l)
#'(p . l))
(x #'p))))
...)
(parse<> (cut ss pr2 cc)
(<and> e2 ...)))))
(fkn P ... . l)))
#'(parse<> (cut s pr (lambda (ss pr2 p ... . vars)
(syntax-parameterize
((P (lambda (x)
(syntax-case x ()
((x . l)
#'(p . l))
(x #'p))))
...)
(parse<> (cut ss pr2 cc)
(<and> e2 ...)))))
(fkn P ... . l)))
((a . l)
(error
(format #f "wrong application of ~a in <and> like constructs" 'a)))))
(format #f "wrong application of ~a in <and> like constructs of ~a"
(syntax->datum #'a)
(syntax->datum x)))))))
(define-syntax <%q-values%>
(syntax-rules ()
(lambda (x)
(syntax-case x ()
((_ (cut s pr cc) (((P p) ...) vars a ...) e2 ...)
(parse<> (cut s pr (lambda (ss pr2 p ... . vars)
#'(parse<> (cut s pr (lambda (ss pr2 p ... . vars)
(syntax-parameterize
((P (lambda (x)
(syntax-case x ()
......@@ -996,7 +1000,8 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<and> a ...)))
((a . l)
(error
(format #f "wrong application of ~a in <and> like constructs" 'a)))))
(format #f "wrong application of ~a in <and> like constructs of ~a"
(syntax->datum #'a) (syntax->datum x)))))))
(define-syntax define-guile-log-parser-tool
......
......@@ -88,7 +88,12 @@
(define (print-last-line xl)
(let ((l ((list-ref xl 3))))
(if (and do-print (pair? l))
(format #t "endline (~a) : ~a~%" (caar l) (list->string (cdar l))))))
(format #t "endline (~a) : ~a~%"
(caar l)
(let ((r (cdar l)))
(if r
(list->string )
'<eof>))))))
(define file-next-line
(case-lambda
......@@ -188,7 +193,7 @@
X XL ((N NI) (M MI) (XX Init) ...)
s-false s-true s-mk-seq s-mk-and s-mk-or
f-read f-test f-test! pr-test f-tag f-tag! pr-tag
chtr f-id f-pk
chtr f-id f-pk s-tag s-tag! spr-tag
s-seq s-and s-and! s-and!! s-and-i s-or s-or-i
f-or f-or! f-and f-and! f-seq f? f+ f* ff? ff+ ff*
f-cons f-list f-cons* mk-token p-freeze parse f-out
......@@ -197,9 +202,10 @@
f-char f-char! pr-char f-reg f-reg! pr-reg
f-ws f-ws* pr-ws+ tok-ws* tok-ws+ parse-no-clear
s-rpl f-rpl s-tr f-tr f-1-char f-1-char! pr-1-char
f-not f-not! pr-not f-seq! f-seq!!
pp)
f-not f-not! pr-not f-seq! f-seq!! f-deb
pp do-print f-wrap)
(begin
(define f-read
(<p-lambda> (c)
(when (pair? X)
......@@ -269,43 +275,74 @@
(s-mk-or s-or <or>)
(s-mk-or s-or-i <or-i>)
(define (head-n n x)
(let lp ((i n) (x x) (r '()))
(if (= i 0)
(reverse r)
(if (pair? x)
(lp (- i 1) (cdr x) (cons (car x) r))
(reverse r)))))
(define (f-pk nm)
(<p-lambda> (c)
(<pp-dyn> `(,nm ,X ,c) `(leaving ,nm))
(<pp-dyn> `(,nm ,(head-n 10 X) ,c) `(leaving ,nm))
(<p-cc> c)))
(define (f-deb nm)
(<p-lambda> (c)
(if do-print
(<pp-dyn> `(,nm ,X ,c) `(leaving ,nm))
<cc>)
(<p-cc> c)))
(define (f-wrap s f)
(case-lambda
((x . l)
(if (symbol? x)
(s-seq (f-deb `(,x ,s)) (apply f l) (f-deb `(success ,x ,s)))
(apply f x l)))
(()
(f))))
(define (ss x)
(cond
((string? x)
(let ((ws (fluid-ref *whitespace*)))
(f-seq ws (s-tag x) ws)))
(f-seq ws (f-tag x) ws)))
((procedure? x)
x)
(else
(f-out x))))
(define f-and
(case-lambda
((f) (ss f))
((f g) (s-and (ss f) (ss g)))
((f g . l) (s-and (ss f) (ss g) (apply f-and l)))
(() s-true)))
(define (f-and! . l) (s-and! (apply f-and l)))
(f-wrap 'f-and
(case-lambda
((f) (ss f))
((f g) (s-and (ss f) (ss g)))
((f g . l) (s-and (ss f) (ss g) (apply f-and l)))
(() s-true))))
(define f-and!
(f-wrap 'f-and!
(lambda l
(s-and! (apply f-and l)))))
(define f-or
(case-lambda
((f) (ss f))
((f g) (s-or (ss f) (ss g)))
((f g . l) (s-or (ss f) (ss g) (apply f-or l)))
(() s-false)))
(define (f-or! . x) (f-and! (apply f-or x)))
(f-wrap 'f-or
(case-lambda
((f) (ss f))
((f g) (s-or (ss f) (ss g)))
((f g . l) (s-or (ss f) (ss g) (apply f-or l)))
(() s-false))))
(define f-or!
(f-wrap 'f-or!
(lambda x
(f-and! (apply f-or x)))))
(define (f-out tag)
(lambda (s p cc . x)
(cc s p (reverse (cons tag (cdr (reverse x)))))))
(apply cc s p (reverse (cons tag (cdr (reverse x)))))))
(define (f> f n) (letrec ((ret (lambda (n)
(if (= n 0)
......@@ -404,12 +441,12 @@
(if (not val)
(<let> ((n N) (m M))
(.. (cc) (f c))
(<let> ((val (mk S c cc)))
(<let> ((val2 (mk S c cc)))
(<code>
(<unwind> fr)
(hash-set! (fluid-ref *freeze-map*)
(cons* n m tok) (list X XL N M val)))
(<p-cc> val)))
(cons* n m tok) (list X XL N M XX ... val2)))
(<p-cc> val2)))
(<apply> f-true val))))))
(define (f* f) (letrec ((ret (f-or (s-seq f ret) s-true))) (s-and! ret)))
......@@ -438,7 +475,7 @@
(<run> 1 (cout)
(<values> (x xl . l)
(matcher '() (make-file-reader) NI MI Init ... _))
(<code> (print-last-line xl))
(<code> (print-last-line (if xl xl '())))
(<=> cout ,(car (reverse l)))))))
(if (string? str)
(with-input-from-string str f)
......@@ -518,58 +555,73 @@
(<p-cc> c)))
(define f-seq
(case-lambda
((f) (ss f))
((f g) (s-seq (ss f) (ss g)))
((f g . l) (s-seq (ss f) (ss g) (apply f-seq l)))
(() s-true)))
(define (f-cons f g)
(<p-lambda> (c)
(.. (c1) ((ss f) c))
(.. (c2) ((ss g) 1))
(<p-cc> (cons c1 c2))))
(f-wrap 'f-seq
(case-lambda
((f) (ss f))
((f g) (s-seq (ss f) (ss g)))
((f g . l) (s-seq (ss f) (ss g) (apply f-seq l)))
(() s-true))))
(define f-cons
(f-wrap 'f-cons
(lambda (f g)
(<p-lambda> (c)
(.. (c1) ((ss f) c))
(.. (c2) ((ss g) c1))
(<p-cc> (cons c1 c2))))))
(define f-cons*
(case-lambda
((x) (ss x))
((x y) (f-cons x y))
((x y . l)
(f-cons x (apply f-cons* y l)))))
(f-wrap 'f-cons*
(case-lambda
((x) (ss x))
((x y) (f-cons x y))
((x y . l)
(f-cons x (apply f-cons* y l))))))
(define f-list
(case-lambda
((x) (f-cons x (f-out '())))
((x y) (f-cons x (f-cons y (f-out '()))))
((x y . l)
(f-cons x (apply f-list y l)))))
(define (f* x)
(f-or! (s-seq (s-and! (ss x)) (Ds (f* x))) s-true))
(f-wrap 'f-list
(case-lambda
((x) (f-cons x (f-out '())))
((x y) (f-cons x (f-cons y (f-out '()))))
((x y . l)
(f-cons x (apply f-list y l))))))
(define f*
(f-wrap 'f*
(lambda (x)
(f-or! (s-seq (s-and! (ss x)) (Ds (f* x))) s-true))))
(define ff*
(case-lambda
((x)
(f-or! (f-cons (f-and! (ss x)) (Ds (ff* x))) (f-out '())))
((x d)
(f-or! (f-cons (f-and! (ss x)) (Ds (ff* x d))) (f-out d)))))
(define (f? x)
(f-or! (ss x) s-true))
(f-wrap 'ff*
(case-lambda
((x)
(f-or! (f-cons (f-and! (ss x)) (Ds (ff* x))) (f-out '())))
((x d)
(f-or! (f-cons (f-and! (ss x)) (Ds (ff* x d))) (f-out d))))))
(define f?
(f-wrap 'f?
(lambda (x)
(f-or! (ss x) s-true))))
(define ff?
(case-lambda
((x)
(f-or! (ss x) (f-out #f)))
((x default)
(f-or! (ss x) (f-out default)))))
(f-wrap 'ff?
(case-lambda
((x)
(f-or! (ss x) (f-out #f)))
((x default)
(f-or! (ss x) (f-out default))))))
(define (f+ x)
(s-seq (ss x) (f* x)))
(define f+
(f-wrap 'f+
(lambda (x)
(s-seq (ss x) (f* x)))))
(define (ff+ x . l)
(f-cons (ss x) (apply ff* x l)))
(define ff+
(f-wrap 'ff+
(lambda (x . l)
(f-cons (ss x) (apply ff* x l)))))
(define-syntax s-tag
(lambda (x)
......@@ -636,7 +688,7 @@
(eval-when (compile load eval)
(define names '(f-read f-test f-test! pr-test f-tag f-tag! pr-tag
chtr f-id f-pk
chtr f-id f-pk s-tag s-tag! spr-tag
s-seq s-and s-and! s-and!! s-and-i s-or s-or-i
f-or f-or! f-and f-and! f-seq f? f+ f* ff? ff+ ff*
f-cons f-list f-cons* mk-token p-freeze parse f-out
......@@ -645,8 +697,8 @@
f-char f-char! pr-char f-reg f-reg! pr-reg
f-ws f-ws* pr-ws+ tok-ws* tok-ws+ parse-no-clear
s-rpl f-rpl s-tr f-tr f-1-char f-1-char! pr-1-char
f-not f-not! pr-not f-seq! f-seq!!
pp)))
f-not f-not! pr-not f-seq! f-seq!! f-deb
pp do-print f-wrap)))
(define-syntax setup-parser
(lambda (x)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment