;;; -*-Scheme-*-
;;;
-;;; $Id: matcher.scm,v 1.9 2001/07/02 12:14:29 cph Exp $
+;;; $Id: matcher.scm,v 1.10 2001/07/02 18:20:08 cph Exp $
;;;
;;; Copyright (c) 2001 Massachusetts Institute of Technology
;;;
;;;; Pattern-matcher language
-(declare (usual-integrations))
-\f
;;; A matcher is a procedure of one argument, a parser buffer.
;;; It performs a match against the contents of the buffer, starting
;;; at the location of the buffer pointer. If the match is
;;; matched segment, and #T is returned. If the match fails, the
;;; buffer pointer is unchanged, and #F is returned.
-;;; The *MATCHER macro provides a concise way to define a broad class
-;;; of matchers using a BNF-like syntax.
+(declare (usual-integrations))
+\f
+;;;; Preprocessor
+
+(define (preprocess-matcher-expression expression
+ external-bindings
+ internal-bindings)
+ (cond ((and (pair? expression)
+ (symbol? (car expression))
+ (list? (cdr expression)))
+ (let ((preprocessor (matcher-preprocessor (car expression))))
+ (if preprocessor
+ (preprocessor expression external-bindings internal-bindings)
+ (error "Unknown matcher expression:" expression))))
+ ((symbol? expression)
+ (let ((preprocessor (matcher-preprocessor expression)))
+ (if preprocessor
+ (preprocessor expression external-bindings internal-bindings)
+ expression)))
+ (else
+ (error "Unknown matcher expression:" expression))))
+
+(define (preprocess-matcher-expressions expressions
+ external-bindings
+ internal-bindings)
+ (map (lambda (expression)
+ (preprocess-matcher-expression expression
+ external-bindings
+ internal-bindings))
+ expressions))
+
+(define (define-matcher-preprocessor name procedure)
+ (if (pair? name)
+ (for-each (lambda (name) (define-matcher-preprocessor name procedure))
+ name)
+ (hash-table/put! matcher-preprocessors name procedure))
+ name)
+
+(define (matcher-preprocessor name)
+ (hash-table/get matcher-preprocessors name #f))
+
+(define matcher-preprocessors
+ (make-eq-hash-table))
+
+(syntax-table/define system-global-syntax-table 'DEFINE-*MATCHER-MACRO
+ (lambda (bvl expression)
+ (cond ((symbol? bvl)
+ `(DEFINE-*MATCHER-EXPANDER ',bvl
+ (LAMBDA ()
+ ,expression)))
+ ((named-lambda-bvl? bvl)
+ `(DEFINE-*MATCHER-EXPANDER ',(car bvl)
+ (LAMBDA ,(cdr bvl)
+ ,expression)))
+ (else
+ (error "Malformed bound-variable list:" bvl)))))
+
+(define (define-*matcher-expander name procedure)
+ (define-matcher-preprocessor name
+ (lambda (expression external-bindings internal-bindings)
+ (preprocess-matcher-expression (if (pair? expression)
+ (apply procedure (cdr expression))
+ (procedure))
+ external-bindings
+ internal-bindings))))
+\f
+(define-*matcher-expander '+
+ (lambda (expression)
+ `(SEQ ,expression (* ,expression))))
+
+(define-*matcher-expander '?
+ (lambda (expression)
+ `(ALT ,expression (SEQ))))
+
+(define-matcher-preprocessor '(ALT SEQ)
+ (lambda (expression external-bindings internal-bindings)
+ `(,(car expression)
+ ,@(flatten-expressions (preprocess-matcher-expressions (cdr expression)
+ external-bindings
+ internal-bindings)
+ (car expression)))))
+
+(define-matcher-preprocessor '*
+ (lambda (expression external-bindings internal-bindings)
+ `(,(car expression)
+ ,(preprocess-matcher-expression (check-1-arg expression)
+ external-bindings
+ internal-bindings))))
+
+(define-matcher-preprocessor '(CHAR CHAR-CI NOT-CHAR NOT-CHAR-CI)
+ (lambda (expression external-bindings internal-bindings)
+ external-bindings
+ `(,(car expression)
+ ,(handle-complex-expression (check-1-arg expression)
+ internal-bindings))))
+
+(define-matcher-preprocessor 'STRING
+ (lambda (expression external-bindings internal-bindings)
+ external-bindings
+ (let ((string (check-1-arg expression)))
+ (if (and (string? string) (fix:= (string-length string) 1))
+ `(CHAR ,(string-ref string 0))
+ `(STRING ,(handle-complex-expression string internal-bindings))))))
+
+(define-matcher-preprocessor 'STRING-CI
+ (lambda (expression external-bindings internal-bindings)
+ external-bindings
+ (let ((string (check-1-arg expression)))
+ (if (and (string? string) (fix:= (string-length string) 1))
+ `(CHAR-CI ,(string-ref string 0))
+ `(STRING-CI
+ ,(handle-complex-expression string internal-bindings))))))
+
+(define-matcher-preprocessor 'ALPHABET
+ (lambda (expression external-bindings internal-bindings)
+ `(,(car expression)
+ ,(let ((arg (check-1-arg expression)))
+ (if (string? arg)
+ (handle-complex-expression
+ (if (string-prefix? "^" arg)
+ `(RE-COMPILE-CHAR-SET ,(string-tail arg 1) #T)
+ `(RE-COMPILE-CHAR-SET ,arg #F))
+ external-bindings)
+ (handle-complex-expression arg internal-bindings))))))
+
+(define-matcher-preprocessor 'WITH-POINTER
+ (lambda (expression external-bindings internal-bindings)
+ (check-2-args expression (lambda (expression) (symbol? (cadr expression))))
+ `(,(car expression) ,(cadr expression)
+ ,(preprocess-matcher-expression (caddr expression)
+ external-bindings
+ internal-bindings))))
+
+(define-matcher-preprocessor 'SEXP
+ (lambda (expression external-bindings internal-bindings)
+ external-bindings
+ (handle-complex-expression (check-1-arg expression) internal-bindings)))
+\f
+;;;; Compiler
(syntax-table/define system-global-syntax-table '*MATCHER
(lambda (expression)
(let ((external-bindings (list 'BINDINGS))
(internal-bindings (list 'BINDINGS)))
(let ((expression
- (canonicalize-matcher-expression expression
- external-bindings
- internal-bindings)))
+ (preprocess-matcher-expression expression
+ external-bindings
+ internal-bindings)))
(maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
(cdr external-bindings))
(with-buffer-name
(cdr internal-bindings))
(call-with-unknown-pointer
(lambda (pointer)
- (compile-matcher-expression expression pointer
- (simple-backtracking-continuation `#T)
- (simple-backtracking-continuation `#F)))))))))))
+ (compile-isolated-matcher-expression expression
+ pointer))))))))))
+
+(define (compile-isolated-matcher-expression expression pointer)
+ (compile-matcher-expression expression pointer
+ (simple-backtracking-continuation `#T)
+ (simple-backtracking-continuation `#F)))
(define (compile-matcher-expression expression pointer if-succeed if-fail)
(cond ((and (pair? expression)
(else
(error "Malformed matcher:" expression))))
-(syntax-table/define system-global-syntax-table 'DEFINE-*MATCHER-MACRO
- (lambda (bvl expression)
- (cond ((symbol? bvl)
- `(DEFINE-*MATCHER-MACRO* ',bvl
- (LAMBDA ()
- ,expression)))
- ((named-lambda-bvl? bvl)
- `(DEFINE-*MATCHER-MACRO* ',(car bvl)
- (LAMBDA ,(cdr bvl)
- ,expression)))
- (else
- (error "Malformed bound-variable list:" bvl)))))
-
-(define (define-*matcher-macro* name procedure)
- (hash-table/put! *matcher-macros name procedure)
- name)
-
-(define (*matcher-expander name)
- (hash-table/get *matcher-macros name #f))
-
-(define *matcher-macros
- (make-eq-hash-table))
-\f
-;;;; Canonicalization
-
-(define (canonicalize-matcher-expression expression
- external-bindings internal-bindings)
- (define (do-expression expression)
- (cond ((and (pair? expression)
- (symbol? (car expression))
- (list? (cdr expression)))
- (case (car expression)
- ((ALT SEQ)
- `(,(car expression)
- ,@(flatten-expressions (map do-expression (cdr expression))
- (car expression))))
- ((*)
- `(,(car expression)
- ,(do-expression (check-1-arg expression))))
- ((+)
- (do-expression
- (let ((expression (check-1-arg expression)))
- `(SEQ ,expression (* ,expression)))))
- ((?)
- (do-expression
- `(ALT ,(check-1-arg expression) (SEQ))))
- ((CHAR CHAR-CI NOT-CHAR NOT-CHAR-CI)
- `(,(car expression)
- ,(handle-complex-expression (check-1-arg expression)
- internal-bindings)))
- ((STRING)
- (let ((string (check-1-arg expression)))
- (if (and (string? string) (fix:= (string-length string) 1))
- `(CHAR ,(string-ref string 0))
- `(STRING
- ,(handle-complex-expression string
- internal-bindings)))))
- ((STRING-CI)
- (let ((string (check-1-arg expression)))
- (if (and (string? string) (fix:= (string-length string) 1))
- `(CHAR-CI ,(string-ref string 0))
- `(STRING-CI
- ,(handle-complex-expression string
- internal-bindings)))))
- ((ALPHABET)
- `(,(car expression)
- ,(let ((arg (check-1-arg expression)))
- (if (string? arg)
- (handle-complex-expression
- (if (string-prefix? "^" arg)
- `(RE-COMPILE-CHAR-SET ,(string-tail arg 1) #T)
- `(RE-COMPILE-CHAR-SET ,arg #F))
- external-bindings)
- (handle-complex-expression arg internal-bindings)))))
- ((WITH-POINTER)
- (check-2-args expression
- (lambda (expression) (symbol? (cadr expression))))
- `(,(car expression)
- ,(cadr expression)
- ,(do-expression (caddr expression))))
- ((SEXP)
- (handle-complex-expression (check-1-arg expression)
- internal-bindings))
- (else
- (let ((expander (*matcher-expander (car expression))))
- (if expander
- (do-expression (apply expander (cdr expression)))
- (error "Unknown matcher expression:" expression))))))
- ((symbol? expression)
- (let ((expander (*matcher-expander expression)))
- (if expander
- (do-expression (expander))
- expression)))
- (else
- (error "Unknown matcher expression:" expression))))
- (do-expression expression))
-\f
-;;;; Matchers
-
(define-macro (define-matcher form . compiler-body)
(let ((name (car form))
(parameters (cdr form)))
`(IF ,,test-expression
,(CALL-WITH-UNKNOWN-POINTER IF-SUCCEED)
,(IF-FAIL POINTER))))))
-
+\f
(define-atomic-matcher (char char)
`(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* ,char))
(define-matcher (with-pointer identifier expression)
`(LET ((,identifier ,(pointer-reference pointer)))
,(compile-matcher-expression expression pointer if-succeed if-fail)))
-\f
+
(define-matcher (* expression)
if-fail
(handle-pending-backtracking pointer
(lambda (pointer)
pointer
- (call-with-unknown-pointer
- (lambda (pointer)
- (let ((v (generate-uninterned-symbol)))
- `(BEGIN
- (LET ,v ()
- ,(compile-matcher-expression expression pointer
+ (let ((v (generate-uninterned-symbol)))
+ `(BEGIN
+ (LET ,v ()
+ ,(call-with-unknown-pointer
+ (lambda (pointer)
+ (compile-matcher-expression expression pointer
(simple-backtracking-continuation `(,v))
- (simple-backtracking-continuation `UNSPECIFIC)))
- ,(if-succeed pointer))))))))
+ (simple-backtracking-continuation `UNSPECIFIC)))))
+ ,(call-with-unknown-pointer if-succeed))))))
(define-matcher (seq . expressions)
(let loop ((expressions expressions) (pointer* pointer))
(if-succeed pointer*))))
(define-matcher (alt . expressions)
- (cond ((not (pair? expressions))
- (if-fail pointer))
- ((not (pair? (cdr expressions)))
- (compile-matcher-expression expression pointer if-succeed if-fail))
- (else
- (handle-pending-backtracking pointer
- (lambda (pointer)
- `(IF (OR ,@(map (let ((s (simple-backtracking-continuation '#T))
- (f (simple-backtracking-continuation '#F)))
- (lambda (expression)
- (compile-matcher-expression expression pointer
- s f)))
- expressions))
- ,(call-with-unknown-pointer if-succeed)
- ,(if-fail pointer)))))))
+ (if (pair? expressions)
+ (if (pair? (cdr expressions))
+ (handle-pending-backtracking pointer
+ (lambda (pointer)
+ `(IF (OR ,@(map (lambda (expression)
+ (compile-isolated-matcher-expression expression
+ pointer))
+ expressions))
+ ,(call-with-unknown-pointer if-succeed)
+ ,(if-fail pointer))))
+ (compile-matcher-expression (car expressions) pointer
+ if-succeed
+ if-fail))
+ (if-fail pointer)))
;;; Edwin Variables:
;;; Eval: (scheme-indent-method 'handle-pending-backtracking 1)
;;; -*-Scheme-*-
;;;
-;;; $Id: parser.scm,v 1.13 2001/07/02 12:14:32 cph Exp $
+;;; $Id: parser.scm,v 1.14 2001/07/02 18:20:17 cph Exp $
;;;
;;; Copyright (c) 2001 Massachusetts Institute of Technology
;;;
;;;; Parser language
-(declare (usual-integrations))
-\f
;;; A parser is a procedure of one argument, a parser buffer. It
;;; attempts to parse the contents of the buffer, starting at the
;;; location of the buffer pointer. If the parse is successful, the
;;; vector of results is returned. If the parse fails, the buffer
;;; pointer is unchanged, and #F is returned.
-;;; The *PARSER macro provides a concise way to define a broad class
-;;; of parsers using a BNF-like syntax.
+(declare (usual-integrations))
+\f
+;;;; Preprocessor
+
+(define (preprocess-parser-expression expression
+ external-bindings
+ internal-bindings)
+ (cond ((and (pair? expression)
+ (symbol? (car expression))
+ (list? (cdr expression)))
+ (let ((preprocessor (parser-preprocessor (car expression))))
+ (if preprocessor
+ (preprocessor expression external-bindings internal-bindings)
+ (error "Unknown parser expression:" expression))))
+ ((symbol? expression)
+ (let ((preprocessor (parser-preprocessor expression)))
+ (if preprocessor
+ (preprocessor expression external-bindings internal-bindings)
+ expression)))
+ (else
+ (error "Unknown parser expression:" expression))))
+
+(define (preprocess-parser-expressions expressions
+ external-bindings
+ internal-bindings)
+ (map (lambda (expression)
+ (preprocess-parser-expression expression
+ external-bindings
+ internal-bindings))
+ expressions))
+
+(define (define-parser-preprocessor name procedure)
+ (if (pair? name)
+ (for-each (lambda (name) (define-parser-preprocessor name procedure))
+ name)
+ (hash-table/put! parser-preprocessors name procedure))
+ name)
+
+(define (parser-preprocessor name)
+ (hash-table/get parser-preprocessors name #f))
+
+(define parser-preprocessors
+ (make-eq-hash-table))
+
+(syntax-table/define system-global-syntax-table 'DEFINE-*PARSER-MACRO
+ (lambda (bvl expression)
+ (cond ((symbol? bvl)
+ `(DEFINE-*PARSER-EXPANDER ',bvl
+ (LAMBDA ()
+ ,expression)))
+ ((named-lambda-bvl? bvl)
+ `(DEFINE-*PARSER-EXPANDER ',(car bvl)
+ (LAMBDA ,(cdr bvl)
+ ,expression)))
+ (else
+ (error "Malformed bound-variable list:" bvl)))))
+
+(define (define-*parser-expander name procedure)
+ (define-parser-preprocessor name
+ (lambda (expression external-bindings internal-bindings)
+ (preprocess-parser-expression (if (pair? expression)
+ (apply procedure (cdr expression))
+ (procedure))
+ external-bindings
+ internal-bindings))))
+\f
+(define-*parser-expander '+
+ (lambda (expression)
+ `(SEQ ,expression (* ,expression))))
+
+(define-*parser-expander '?
+ (lambda (expression)
+ `(ALT ,expression (SEQ))))
+
+(define-parser-preprocessor '(ALT SEQ)
+ (lambda (expression external-bindings internal-bindings)
+ `(,(car expression)
+ ,@(flatten-expressions (preprocess-parser-expressions (cdr expression)
+ external-bindings
+ internal-bindings)
+ (car expression)))))
+
+(define-parser-preprocessor '(* COMPLETE TOP-LEVEL)
+ (lambda (expression external-bindings internal-bindings)
+ `(,(car expression)
+ ,(preprocess-parser-expression (check-1-arg expression)
+ external-bindings
+ internal-bindings))))
+
+(define-parser-preprocessor '(MATCH NOISE)
+ (lambda (expression external-bindings internal-bindings)
+ `(,(car expression)
+ ,(preprocess-matcher-expression (check-1-arg expression)
+ external-bindings
+ internal-bindings))))
+
+(define-parser-preprocessor '(DEFAULT TRANSFORM ELEMENT-TRANSFORM ENCAPSULATE)
+ (lambda (expression external-bindings internal-bindings)
+ (check-2-args expression)
+ `(,(car expression) ,(cadr expression)
+ ,(preprocess-parser-expression (caddr expression)
+ external-bindings
+ internal-bindings))))
+
+(define-parser-preprocessor 'WITH-POINTER
+ (lambda (expression external-bindings internal-bindings)
+ (check-2-args expression (lambda (expression) (symbol? (cadr expression))))
+ `(,(car expression) ,(cadr expression)
+ ,(preprocess-parser-expression (caddr expression)
+ external-bindings
+ internal-bindings))))
+
+(define-parser-preprocessor 'SEXP
+ (lambda (expression external-bindings internal-bindings)
+ external-bindings
+ (handle-complex-expression (check-1-arg expression) internal-bindings)))
+\f
+;;;; Compiler
(syntax-table/define system-global-syntax-table '*PARSER
(lambda (expression)
(optimize-expression (generate-parser-code expression))))
(define (generate-parser-code expression)
- (with-canonical-parser-expression expression
- (lambda (expression)
- (call-with-unknown-pointer
- (lambda (pointer)
- (compile-parser-expression expression pointer
- simple-backtracking-succeed
- (simple-backtracking-continuation `#F)))))))
+ (let ((external-bindings (list 'BINDINGS))
+ (internal-bindings (list 'BINDINGS)))
+ (let ((expression
+ (preprocess-parser-expression expression
+ external-bindings
+ internal-bindings)))
+ (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+ (cdr external-bindings))
+ (with-buffer-name
+ (lambda ()
+ (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+ (cdr internal-bindings))
+ (call-with-unknown-pointer
+ (lambda (pointer)
+ (compile-parser-expression expression pointer
+ simple-backtracking-succeed
+ (simple-backtracking-continuation `#F)))))))))))
(define (compile-parser-expression expression pointer if-succeed if-fail)
(cond ((and (pair? expression)
(define simple-backtracking-succeed
(backtracking-succeed (lambda (result) result)))
-
-(syntax-table/define system-global-syntax-table 'DEFINE-*PARSER-MACRO
- (lambda (bvl expression)
- (cond ((symbol? bvl)
- `(DEFINE-*PARSER-MACRO* ',bvl
- (LAMBDA ()
- ,expression)))
- ((named-lambda-bvl? bvl)
- `(DEFINE-*PARSER-MACRO* ',(car bvl)
- (LAMBDA ,(cdr bvl)
- ,expression)))
- (else
- (error "Malformed bound-variable list:" bvl)))))
-
-(define (define-*parser-macro* name procedure)
- (hash-table/put! *parser-macros name procedure)
- name)
-
-(define (*parser-expander name)
- (hash-table/get *parser-macros name #f))
-
-(define *parser-macros
- (make-eq-hash-table))
-\f
-;;;; Canonicalization
-
-(define (with-canonical-parser-expression expression receiver)
- (let ((external-bindings (list 'BINDINGS))
- (internal-bindings (list 'BINDINGS)))
- (define (do-expression expression)
- (cond ((and (pair? expression)
- (symbol? (car expression))
- (list? (cdr expression)))
- (case (car expression)
- ((ALT SEQ)
- `(,(car expression)
- ,@(flatten-expressions (map do-expression (cdr expression))
- (car expression))))
- ((* COMPLETE TOP-LEVEL)
- `(,(car expression)
- ,(do-expression (check-1-arg expression))))
- ((+)
- (do-expression
- (let ((expression (check-1-arg expression)))
- `(SEQ ,expression (* ,expression)))))
- ((?)
- (do-expression
- `(ALT ,(check-1-arg expression) (SEQ))))
- ((MATCH NOISE)
- `(,(car expression)
- ,(canonicalize-matcher-expression (check-1-arg expression)
- external-bindings
- internal-bindings)))
- ((DEFAULT TRANSFORM ELEMENT-TRANSFORM ENCAPSULATE)
- (check-2-args expression)
- `(,(car expression) ,(cadr expression)
- ,(do-expression (caddr expression))))
- ((WITH-POINTER)
- (check-2-args expression
- (lambda (expression)
- (symbol? (cadr expression))))
- `(,(car expression)
- ,(cadr expression)
- ,(do-expression (caddr expression))))
- ((SEXP)
- (handle-complex-expression (check-1-arg expression)
- internal-bindings))
- (else
- (let ((expander (*parser-expander (car expression))))
- (if expander
- (do-expression (apply expander (cdr expression)))
- (error "Unknown parser expression:" expression))))))
- ((symbol? expression)
- (let ((expander (*parser-expander expression)))
- (if expander
- (do-expression (expander))
- expression)))
- (else
- (error "Unknown parser expression:" expression))))
- (let ((expression (do-expression expression)))
- (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
- (cdr external-bindings))
- (with-buffer-name
- (lambda ()
- (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
- (cdr internal-bindings))
- (receiver expression))))))))
\f
-;;;; Parsers
-
(define-macro (define-parser form . compiler-body)
(let ((name (car form))
(parameters (cdr form)))
(lambda (pointer) (if-succeed pointer `(VECTOR)))
if-fail))
-(define-parser (default value parser)
+(define-parser (default value expression)
if-fail
- (compile-parser-expression parser pointer if-succeed
+ (compile-parser-expression expression pointer if-succeed
(lambda (pointer)
(if-succeed pointer `(VECTOR ,value)))))
-\f
-(define-parser (transform transform parser)
- (compile-parser-expression parser pointer
+
+(define-parser (transform transform expression)
+ (compile-parser-expression expression pointer
(lambda (pointer* result)
(with-variable-binding `(,transform ,result)
(lambda (result)
,(if-fail (backtrack-to pointer pointer*))))))
if-fail))
-(define-parser (element-transform transform parser)
- (compile-parser-expression parser pointer
+(define-parser (element-transform transform expression)
+ (compile-parser-expression expression pointer
(lambda (pointer result)
(if-succeed pointer `(VECTOR-MAP ,transform ,result)))
if-fail))
-(define-parser (encapsulate transform parser)
- (compile-parser-expression parser pointer
+(define-parser (encapsulate transform expression)
+ (compile-parser-expression expression pointer
(lambda (pointer result)
(if-succeed pointer `(VECTOR (,transform ,result))))
if-fail))
-(define-parser (complete parser)
- (compile-parser-expression parser pointer
+(define-parser (complete expression)
+ (compile-parser-expression expression pointer
(lambda (pointer* result)
`(IF (PEEK-PARSER-BUFFER-CHAR ,*buffer-name*)
,(if-fail (backtrack-to pointer pointer*))
,(if-succeed pointer* result))))
if-fail))
-(define-parser (top-level parser)
- (compile-parser-expression parser pointer
+(define-parser (top-level expression)
+ (compile-parser-expression expression pointer
(lambda (pointer result)
`(BEGIN
(DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
,(if-succeed pointer result)))
if-fail))
-
+\f
(define-parser (with-pointer identifier expression)
`(LET ((,identifier ,(pointer-reference pointer)))
,(compile-parser-expression expression pointer
if-succeed if-fail)))
-\f
+
+(define-parser (* expression)
+ if-fail
+ (handle-pending-backtracking pointer
+ (lambda (pointer)
+ pointer
+ (with-variable-binding
+ (let ((loop (generate-uninterned-symbol))
+ (elements (generate-uninterned-symbol)))
+ `(LET ,loop ((,elements (VECTOR)))
+ ,(call-with-unknown-pointer
+ (lambda (pointer)
+ (compile-parser-expression expression pointer
+ (backtracking-succeed
+ (lambda (element)
+ `(,loop (VECTOR-APPEND ,elements ,element))))
+ (simple-backtracking-continuation elements))))))
+ (lambda (elements)
+ (call-with-unknown-pointer
+ (lambda (pointer)
+ (if-succeed pointer elements))))))))
+
(define-parser (seq . expressions)
(if (pair? expressions)
(if (pair? (cdr expressions))
(if-succeed pointer `(VECTOR))))
(define-parser (alt . expressions)
- (handle-pending-backtracking pointer
- (lambda (pointer)
- (with-variable-binding
- `(OR ,@(map (lambda (expression)
- (compile-parser-expression expression pointer
- simple-backtracking-succeed
- (simple-backtracking-continuation `#F)))
- expressions))
- (lambda (result)
- `(IF ,result
- ,(call-with-unknown-pointer
- (lambda (pointer)
- (if-succeed pointer result)))
- ,(if-fail pointer)))))))
-
-(define-parser (* parser)
- if-fail
- (handle-pending-backtracking pointer
- (lambda (pointer)
- pointer
- (call-with-unknown-pointer
- (lambda (pointer)
- (with-variable-binding
- (let ((loop (generate-uninterned-symbol))
- (elements (generate-uninterned-symbol)))
- `(LET ,loop ((,elements (VECTOR)))
- ,(compile-parser-expression parser pointer
- (backtracking-succeed
- (lambda (element)
- `(,loop (VECTOR-APPEND ,elements ,element))))
- (simple-backtracking-continuation elements))))
- (lambda (elements)
- (if-succeed pointer elements))))))))
+ (if (pair? expressions)
+ (if (pair? (cdr expressions))
+ (handle-pending-backtracking pointer
+ (lambda (pointer)
+ (with-variable-binding
+ `(OR ,@(map (lambda (expression)
+ (compile-parser-expression expression pointer
+ simple-backtracking-succeed
+ (simple-backtracking-continuation `#F)))
+ expressions))
+ (lambda (result)
+ `(IF ,result
+ ,(call-with-unknown-pointer
+ (lambda (pointer)
+ (if-succeed pointer result)))
+ ,(if-fail pointer))))))
+ (compile-parser-expression (car expressions) pointer
+ if-succeed
+ if-fail))
+ (if-fail pointer)))
;;; Edwin Variables:
;;; Eval: (scheme-indent-method 'handle-pending-backtracking 1)
projects / mit-scheme.git / commitdiff