--- a/r2/parsetng.scm Sun Oct 09 21:18:13 2005 +1300
+++ b/r2/parsetng.scm Wed Oct 12 11:32:15 2005 +1300
@@ -62,17 +62,83 @@
(parse-results-next results)
(- n 1)))))
+(define (parse-results->pregexp-stream results)
+ (pregexp-make-stream (lambda (r)
+ (if r
+ (cons (parse-results-token-value r)
+ (parse-results-next r))
+ (cons #f #f)))
+ results))
+
(define (packrat-regex exp)
(let ((re (if (string? exp) (pregexp exp) exp)))
(lambda (results)
- (let* ((stream (pregexp-make-stream
- (lambda (r)
- (if r
- (cons (parse-results-token-value r)
- (parse-results-next r))
- (cons #f #f)))))
+ (let* ((stream (parse-results->pregexp-stream results))
(match (pregexp-match-head re stream)))
(if match
- (let-values (((str next) (parse-results-take results (cdr match))))
+ (let-values (((str next) (parse-results-take results (cdar match))))
(make-result str next))
(make-expected-result (parse-results-position results) exp))))))
+
+(define (packrat-cache key parser)
+ (lambda (results)
+ (results->result results key
+ (lambda ()
+ (parser results)))))
+
+(define-syntax define-packrat-cached
+ (syntax-rules ()
+ ((_ (fnname results) body ...)
+ (define fnname
+ (packrat-cache 'fnname
+ (letrec ((fnname (lambda (results) body ...)))
+ fnname))))
+ ((_ fnname exp)
+ (define fnname
+ (packrat-cache 'fnname exp)))))
+
+(define parse-ThiNG
+ (packrat-parser (begin
+ (define-packrat-cached (white results)
+ (if (and-let* ((ch (parse-results-token-value results)))
+ (char-whitespace? ch))
+ (white (parse-results-next results))
+ (comment results)))
+ (define-packrat-cached (comment results)
+ (if (eq? (parse-results-token-value results) #\")
+ (skip-comment-body (parse-results-next results))
+ (make-result 'whitespace results)))
+ (define (skip-comment-body results)
+ (if (eq? (parse-results-token-value results) #\")
+ (white (parse-results-next results))
+ (skip-comment-body (parse-results-next results))))
+ (define-packrat-cached ident
+ (packrat-regex "[a-z][a-zA-Z0-9_]*"))
+ datum)
+ (datum ((s <- seq0 '#f) s))
+ (seq0 ((s <- seq1) s)
+ (() '(seq)))
+ (seq1 ((d <- dict white '#\, s <- seq1) `(seq ,d ,@(cdr s)))
+ ((d <- dict) `(seq ,d)))
+ (dict ((e <- entry white d <- dict) `(dict ,e ,@(cdr d)))
+ ((e <- entry) `(dict ,e))
+ ((v <- app) v))
+ (entry ((k <- app white '#\: v <- app) (list k v)))
+ (app ((parts <- app*) (fold (lambda (arg op) `(app ,op ,arg)) (car parts) (cdr parts))))
+ (app* ((v <- simple white vs <- app*) (cons v vs))
+ ((v <- simple) (list v)))
+ (simple ((white d1 <- simple1) d1))
+ (simple1 (('#\{ d <- datum white '#\}) `(quote ,d))
+ (('#\( d <- datum white '#\)) d)
+ (('#\[ d <- datum white '#\]) `(meta ,d))
+ ((i <- ident) (string->symbol i)))))
+
+(define read-ThiNG
+ (lambda ()
+ (parse-result->value "While parsing ThiNG"
+ (parse-ThiNG (port-results "stdin" (current-input-port))))))
+
+(define string->ThiNG
+ (lambda (s)
+ (parse-result->value "While parsing ThiNG"
+ (parse-ThiNG (string-results "<string>" s)))))