;;; -*-Scheme-*-
;;;
-;;; $Id: matcher.scm,v 1.7 2001/06/30 06:05:19 cph Exp $
+;;; $Id: matcher.scm,v 1.8 2001/07/02 05:08:16 cph Exp $
;;;
;;; Copyright (c) 2001 Massachusetts Institute of Technology
;;;
(lambda ()
(maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
(cdr internal-bindings))
- (compile-matcher-expression
- expression
- (no-pointers)
- (simple-backtracking-continuation `#T)
- (simple-backtracking-continuation `#F)))))))))
+ (compile-matcher-expression expression
+ (no-pointers)
+ (simple-backtracking-continuation `#T)
+ (simple-backtracking-continuation `#F)))))))))
(define (compile-matcher-expression expression pointers if-succeed if-fail)
(cond ((and (pair? expression)
(handle-pending-backtracking pointers
(lambda (pointers)
`(IF (,expression ,*buffer-name*)
- ,(if-succeed (unknown-location pointers))
+ ,(if-succeed (no-pointers))
,(if-fail pointers)))))
(else
(error "Malformed matcher:" expression))))
(HANDLE-PENDING-BACKTRACKING POINTERS
(LAMBDA (POINTERS)
`(IF ,,test-expression
- ,(IF-SUCCEED (UNKNOWN-LOCATION POINTERS))
+ ,(IF-SUCCEED (NO-POINTERS))
,(IF-FAIL POINTERS))))))
(define-atomic-matcher (char char)
(lambda (pointers)
`(LET ((,identifier ,(current-pointer pointers)))
,(compile-matcher-expression expression pointers
- if-succeed if-fail)))))
+ if-succeed if-fail)))))
\f
(define-matcher (* expression)
if-fail
(handle-pending-backtracking pointers
(lambda (pointers)
- (let ((pointers (unknown-location pointers))
+ pointers
+ (let ((pointers (no-pointers))
(v (generate-uninterned-symbol)))
`(BEGIN
(LET ,v ()
(define-matcher (seq . expressions)
(with-current-pointer pointers
- (lambda (start-pointers)
+ (lambda (start)
(let loop
((expressions expressions)
- (pointers start-pointers))
+ (pointers start))
(if (pair? expressions)
- (compile-matcher-expression (car expressions)
- pointers
- (lambda (pointers)
- (loop (cdr expressions) pointers))
- (lambda (pointers)
- (if-fail
- (new-backtrack-pointer
- start-pointers pointers))))
+ (compile-matcher-expression (car expressions) pointers
+ (lambda (pointers)
+ (loop (cdr expressions) pointers))
+ (lambda (pointers)
+ (if-fail (new-backtrack-pointer start pointers))))
(if-succeed pointers))))))
(define-matcher (alt . expressions)
- (with-current-pointer pointers
- (lambda (pointers)
- (let loop ((expressions expressions))
- (if (pair? expressions)
- (let ((predicate
- (compile-matcher-expression
- (car expressions)
- pointers
- (simple-backtracking-continuation '#T)
- (simple-backtracking-continuation '#F)))
- (consequent
- (lambda () (if-succeed (unknown-location pointers))))
- (alternative
- (lambda () (loop (cdr expressions)))))
- (cond ((eq? predicate '#T) (consequent))
- ((eq? predicate '#F) (alternative))
- (else `(IF ,predicate ,(consequent) ,(alternative)))))
- (if-fail pointers))))))
+ (cond ((not (pair? expressions))
+ (if-fail pointers))
+ ((not (pair? (cdr expressions)))
+ (compile-matcher-expression expression pointers if-succeed if-fail))
+ (else
+ (handle-pending-backtracking pointers
+ (lambda (pointers)
+ (with-current-pointer pointers
+ (lambda (pointers)
+ (let ((s (simple-backtracking-continuation '#T))
+ (f (simple-backtracking-continuation '#F))))
+ `(IF (OR ,@(map (lambda (expression)
+ (compile-matcher-expression expression
+ pointers
+ s f))
+ expressions))
+ ,(if-succeed (no-pointers))
+ ,(if-fail pointers)))))))))
;;; Edwin Variables:
;;; Eval: (scheme-indent-method 'handle-pending-backtracking 1)
;;; Eval: (scheme-indent-method 'define-matcher-optimizer 2)
;;; Eval: (scheme-indent-method 'with-buffer-name 0)
+;;; Eval: (scheme-indent-method 'compile-matcher-expression 2)
;;; End:
;;; -*-Scheme-*-
;;;
-;;; $Id: parser.scm,v 1.11 2001/06/30 06:05:09 cph Exp $
+;;; $Id: parser.scm,v 1.12 2001/07/02 05:08:19 cph Exp $
;;;
;;; Copyright (c) 2001 Massachusetts Institute of Technology
;;;
(compile-parser-expression
expression
(no-pointers)
- (lambda (pointers result)
- (handle-pending-backtracking pointers
- (lambda (pointers)
- pointers
- result)))
+ simple-backtracking-succeed
(simple-backtracking-continuation `#F)))))
(define (compile-parser-expression expression pointers if-succeed if-fail)
(with-variable-binding `(,expression ,*buffer-name*)
(lambda (result)
`(IF ,result
- ,(if-succeed (unknown-location pointers) result)
+ ,(if-succeed (no-pointers) result)
,(if-fail pointers)))))))
(else
(error "Malformed matcher:" expression))))
+(define (backtracking-succeed handler)
+ (lambda (pointers result)
+ (handle-pending-backtracking pointers
+ (lambda (pointers)
+ pointers
+ (handler result)))))
+
+(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 (match matcher)
(with-current-pointer pointers
- (lambda (start-pointers)
- (compile-matcher-expression matcher start-pointers
+ (lambda (start)
+ (compile-matcher-expression matcher start
(lambda (pointers)
(with-variable-binding
- `(VECTOR (GET-PARSER-BUFFER-TAIL
- ,*buffer-name*
- ,(current-pointer start-pointers)))
+ `(VECTOR
+ (GET-PARSER-BUFFER-TAIL ,*buffer-name*
+ ,(current-pointer start)))
(lambda (v)
(if-succeed pointers v))))
if-fail))))
\f
(define-parser (transform transform parser)
(with-current-pointer pointers
- (lambda (start-pointers)
- (compile-parser-expression parser start-pointers
+ (lambda (start)
+ (compile-parser-expression parser start
(lambda (pointers result)
(with-variable-binding `(,transform ,result)
(lambda (result)
`(IF ,result
,(if-succeed pointers result)
- ,(if-fail
- (new-backtrack-pointer start-pointers pointers))))))
+ ,(if-fail (new-backtrack-pointer start pointers))))))
if-fail))))
(define-parser (element-transform transform parser)
(define-parser (complete parser)
(with-current-pointer pointers
- (lambda (start-pointers)
- (compile-parser-expression parser start-pointers
+ (lambda (start)
+ (compile-parser-expression parser start
(lambda (pointers result)
`(IF (PEEK-PARSER-BUFFER-CHAR ,*buffer-name*)
- ,(if-fail (new-backtrack-pointer start-pointers pointers))
+ ,(if-fail (new-backtrack-pointer start pointers))
(BEGIN
(DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
,(if-succeed pointers result))))
(lambda (pointers)
`(LET ((,identifier ,(current-pointer pointers)))
,(compile-parser-expression expression pointers
- if-succeed if-fail)))))
+ if-succeed if-fail)))))
\f
(define-parser (seq . ps)
(if (pair? ps)
(if (pair? (cdr ps))
(with-current-pointer pointers
- (lambda (start-pointers)
- (let loop ((ps ps) (pointers start-pointers) (results '()))
+ (lambda (start)
+ (let loop ((ps ps) (pointers start) (results '()))
(compile-parser-expression (car ps) pointers
(lambda (pointers result)
(let ((results (cons result results)))
(if-succeed pointers
`(VECTOR-APPEND ,@(reverse results))))))
(lambda (pointers)
- (if-fail
- (new-backtrack-pointer start-pointers pointers)))))))
+ (if-fail (new-backtrack-pointer start pointers)))))))
(compile-parser-expression (car ps) pointers if-succeed if-fail))
(if-succeed pointers `(VECTOR))))
(define-parser (alt . ps)
- (with-current-pointer pointers
+ (handle-pending-backtracking pointers
(lambda (pointers)
- (with-variable-binding
- `(OR ,@(map (lambda (p)
- (compile-parser-expression p pointers
- (lambda (pointers result)
- (handle-pending-backtracking pointers
- (lambda (pointers)
- pointers
- result)))
- (simple-backtracking-continuation `#F)))
- ps))
- (lambda (result)
- `(IF ,result
- ,(if-succeed (unknown-location pointers) result)
- ,(if-fail pointers)))))))
+ (with-current-pointer pointers
+ (lambda (pointers)
+ (with-variable-binding
+ `(OR ,@(map (lambda (p)
+ (compile-parser-expression p pointers
+ simple-backtracking-succeed
+ (simple-backtracking-continuation `#F)))
+ ps))
+ (lambda (result)
+ `(IF ,result
+ ,(if-succeed (no-pointers) result)
+ ,(if-fail pointers)))))))))
(define-parser (* parser)
if-fail
(handle-pending-backtracking pointers
(lambda (pointers)
+ pointers
(with-variable-binding
(let ((loop (generate-uninterned-symbol))
(elements (generate-uninterned-symbol)))
`(LET ,loop ((,elements (VECTOR)))
,(compile-parser-expression parser (no-pointers)
- (lambda (pointers element)
- (handle-pending-backtracking pointers
- (lambda (pointers)
- pointers
- `(,loop (VECTOR-APPEND ,elements ,element)))))
- (lambda (pointers)
- (handle-pending-backtracking pointers
- (lambda (pointers)
- pointers
- elements))))))
+ (backtracking-succeed
+ (lambda (element)
+ `(,loop (VECTOR-APPEND ,elements ,element))))
+ (simple-backtracking-continuation elements))))
(lambda (elements)
- (if-succeed (unknown-location pointers) elements))))))
+ (if-succeed (no-pointers) elements))))))
;;; Edwin Variables:
;;; Eval: (scheme-indent-method 'handle-pending-backtracking 1)
;;; Eval: (scheme-indent-method 'with-buffer-name 0)
+;;; Eval: (scheme-indent-method 'compile-parser-expression 2)
;;; End:
;;; -*-Scheme-*-
;;;
-;;; $Id: shared.scm,v 1.5 2001/06/30 03:23:45 cph Exp $
+;;; $Id: shared.scm,v 1.6 2001/07/02 05:08:22 cph Exp $
;;;
;;; Copyright (c) 2001 Massachusetts Institute of Technology
;;;
;; wherever we potentially need a pointer reference. But we track
;; usage of the pointer, so that we only generate calls to
;; GET-PARSER-BUFFER-POINTER when the pointer is used.
- (if (car pointers)
+ (if (or (cdr pointers) (car pointers))
(procedure pointers)
(let ((v.u (cons (generate-uninterned-symbol) #f)))
(let ((x (procedure (cons v.u (cdr pointers)))))
x)))))
(define (current-pointer pointers)
- (if (not (car pointers))
- (error "Missing required current pointer:" pointers))
- (set-cdr! (car pointers) #t)
- (car (car pointers)))
-
-(define (unknown-location pointers)
- ;; Discard the pointer to the current position, if any. Used after
- ;; successful matching operations that modify the buffer position.
- (cons #f (cdr pointers)))
+ (let ((pointer
+ (or (cdr pointers)
+ (car pointers)
+ (error "Missing required current pointer:" pointers))))
+ (set-cdr! pointer #t)
+ (car pointer)))
(define (new-backtrack-pointer backtrack-pointers pointers)
;; Specify that we want to backtrack to the position specified in
;; delay, we can generate multiple sequential calls to change the
;; position, which is wasteful since only the last call in the
;; sequence is meaningful.
- (cons (car pointers) (car backtrack-pointers)))
+ (cons (car pointers)
+ (if (eq? (car pointers) (car backtrack-pointers))
+ #f
+ (car backtrack-pointers))))
(define (handle-pending-backtracking pointers procedure)
;; Perform a pending backtracking operation, if any.
- (if (and (cdr pointers)
- (not (eq? (car pointers) (cdr pointers))))
+ (if (cdr pointers)
(begin
(set-cdr! (cdr pointers) #t)
`(BEGIN
projects / mit-scheme.git / commitdiff